McCarthy's ambivalence operator

Location: lib, 40 Lines

; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2010,2012
; Placed in the Public Domain
;
; (amb <expression> ...)  ==>  object
; (amb-collector)         ==>  procedure
; (amb-done? object)      ==>  boolean
; (amb-reset)             ==>  unspecific
;
; (load-from-library "amb.scm")
;
; Another variation of McCarthy's AMB operator.
;
; AMB takes a list of <expression>s, immediately evaluates the first one
; and returns its value. When no <expression>s are passed to AMB (or it
; runs out of <expression>s), it checks whether there is another AMB further
; up in the program structure. If there is one, it returns control to that
; instance of AMB, thereby initiating backtracking. When backtracking to an
; AMB, that AMB evaluates the next <expression> from its argument list, and
; so on.
;
; When an AMB runs out of options and there is no AMB to return control
; to, it returns a special object that can be detected with AMB-DONE?.
;
; AMB-COLLECT generates a procedure of the form
;
;       (lambda (p . v*) ...)
;
; where P is a predicate and V* is a list of values. When called, the
; procedure will apply P to V* and if the predicate is satisfied, it will
; store the values internally and initiate backtracking by calling (amb).
; When one of the values of V* satisfies AMB-DONE?, the procedure will
; return the list stored internally. At this point, the list contains
; the union of all combinations of AMB values that satisfy P.
;
; AMB-RESET clears the AMB tree. It serves as a CUT operator and an
; initializing procedure are the same time. After calling AMB-RESET
; (amb) will always fail. Any program that uses AMB should first call
; AMB-RESET.
;
; Example:   (begin (amb-reset)
;                   (let ((collect (amb-collector)))
;                     (let ((x (amb 4 1 7)))
;                       (let ((y (amb 6 8 2)))
;                         (let ((z (amb 5 3 9)))
;                           (collect > x y z))))))  ==>  ((7 6 3) (7 6 5))

(load-from-library "setters.scm")
(load-from-library "exists.scm")

(define *amb-stack* '())

(define *amb-done* (list 'amb-done))

(define (amb-reset)
  (set! *amb-stack* '()))

(define (amb-done? x)
  (eq? *amb-done* x))

(define-syntax (amb . expr*)

  (define (unfold-alternatives e*)
    (if (null? e*)
        '(begin (pop! *amb-stack*)
                (if (null? *amb-stack*)
                    *amb-done*
                    ((car *amb-stack*) *amb-done*)))
        `(let ((x (call/cc
                    (lambda (k)
                      (set-car! *amb-stack* k)
                      ,(car e*)))))
             (if (amb-done? x)
                 ,(unfold-alternatives (cdr e*))
                 x))))

  `(begin (push! #f *amb-stack*)
          ,(unfold-alternatives expr*)))

(define (amb-collector)
  (let ((values '()))
    (lambda (p . v*)
      (if (exists amb-done? v*)
          values
          (begin (if (apply p v*)
                     (push! v* values))
                 (amb))))))

contact  |  privacy