;;;; Extension of Scheme for amb
;;;   amb is the ambiguous operator of McCarthy.

#|
(list (amb 1 2 3) (amb 'a 'b))

;;; has 6 possible values

(1 a), (1 b), (2 a), (2 b), (3 a), (3 b)
|#

(define-syntax amb
  (sc-macro-transformer
   (lambda (form uenv)
     `(ambl
       ,@(map (lambda (arg)
                `(lambda ()
                   ,(close-syntax arg uenv)))
              (cdr form))))))

(define (ambl . alternatives)
  (search-wrapper
   (lambda (succeed fail)
     (if (pair? alternatives)
         (let lp ((alts alternatives))
           (succeed (car alts)
                    (lambda ()
                      (if (pair? (cdr alts))
                          (lp (cdr alts))
                          (fail)))))
         (fail)))))

;;; amb-set! is an assignment operator
;;;  that gets undone on backtracking.

(define-syntax amb-set!
  (sc-macro-transformer
   (lambda (form uenv)
     (compile-amb-set (cadr form) (caddr form)
                      uenv))))

(define (compile-amb-set var val-expr uenv)
  (let ((var (close-syntax var uenv))
        (val (close-syntax val-expr uenv)))
    `(let ((old-value ,var))
       (effect-wrapper
        (lambda ()
          (set! ,var ,val))
        (lambda ()
          (set! ,var old-value))))))


;;; A general wrapper for undoable effects

(define (effect-wrapper doer undoer)
  (search-wrapper
   (lambda (succeed fail)
     (doer)
     (succeed (lambda () unspecific)
              (lambda ()
                (undoer)
                (fail))))))

;;; The search wrapper converts success/fail to 
;;; a search discipline.

(define (search-wrapper proc)
  ;; proc = (lambda (succeed fail) ...)
  (call-with-current-continuation
   (lambda (k)
     (proc (lambda (get-val fail)
             (add-to-search-schedule
              (lambda ()
                (within-continuation k
                  fail)))
             (within-continuation k
               get-val))
           (lambda ()
             (within-continuation k
               (search-next)))))))

(define (search-next)
  (if (pair? *search-schedule*)
      (let ((fail (car *search-schedule*)))
        (set! *search-schedule*
              (cdr *search-schedule*))
        (fail))
      (*top-level* unspecific)))

(define (with-depth-first-schedule thunk)
  (fluid-let ((add-to-search-schedule
	       add-to-depth-first-search-schedule))
    (thunk)))


(define (with-breadth-first-schedule thunk)
  (fluid-let ((add-to-search-schedule
	       add-to-breadth-first-search-schedule))
    (thunk)))

(define (add-to-depth-first-search-schedule fail)
  (set! *search-schedule*
        (cons fail *search-schedule*)))
             
(define (add-to-breadth-first-search-schedule fail)
  (set! *search-schedule*
        (append *search-schedule*
                (list fail))))

(define *search-schedule* '())

;;; Default is depth first.
(define add-to-search-schedule
  add-to-depth-first-search-schedule)

(define (init-amb)
  (set! *search-schedule* '())
  'done)


(define *top-level*
  (lambda (ignore)
    (display ";No more alternatives\n")
    (abort->top-level unspecific)))

#|
;;; Elementary backtrack test.


(with-depth-first-schedule
    (lambda ()
      (init-amb)
      (pp (list (amb 1 2 3) (amb 'a 'b)))
      (amb)))
(1 a)
(2 a)
(3 a)
(1 b)
(2 b)
(3 b)
;No more alternatives

(with-breadth-first-schedule
    (lambda ()
      (init-amb)
      (pp (list (amb 1 2 3) (amb 'a 'b)))
      (amb)))
(1 a)
(1 b)
(2 a)
(2 b)
(3 a)
(3 b)
;No more alternatives


;;; Testing undoable assignment. 
  
(begin (init-amb)
       (let ((x (amb 1 2 3)) (y 0))
         (pp `(before ,x ,y))
         (amb-set! y x)
         (pp `(after ,x ,y))
         (amb)))
(before 1 0)
(after 1 1)
(before 2 0)
(after 2 2)
(before 3 0)
(after 3 3)
;Unspecified return value
|#

#|
;;; In breadth-first we get useful results here.  
;;; None from depth-first.

(define (a-pythagorean-triple-from low)
  (let ((i (an-integer-from low)))
    (let ((j (an-integer-from i)))
      (let ((k (an-integer-from j)))
        (require (= (+ (* i i) (* j j)) (* k k)))
        (list i j k)))))

(define (require p)
  (if (not p) (amb)))

(define (an-integer-from low)
  (amb low (an-integer-from (+ low 1))))

(with-breadth-first-schedule
    (lambda ()
      (init-amb)
      (pp (a-pythagorean-triple-from 1))
      (amb)))
(3 4 5)
(6 8 10)
(5 12 13)
(9 12 15)
(8 15 17)
(12 16 20)
(15 20 25)
(7 24 25)
(10 24 26)
(20 21 29)
(18 24 30)
(16 30 34)
(21 28 35)
(12 35 37)
;Quit!
|#

;;; A useful device:

(define (amb-collect-values result-thunk #!optional limit)
  (call-with-current-continuation
   (lambda (k)
     (let ((values '()) (count 0))
       (fluid-let ((*top-level* (lambda (ignore) (k values)))
		   (*search-schedule* '()))
	 (let ((value (result-thunk)))
	   (set! values (cons value values))
	   (set! count (+ count 1))
	   (if (and (not (default-object? limit))
		    (>= count limit))
	       (k values))
	   (amb)))))))

#|
;;; For example, for controlling search:

(define (a-pythagorean-triple-between low high)
  (let ((i (an-integer-between low high)))
    (let ((j (an-integer-between i high)))
      (let ((k (an-integer-between j high)))
        (require (= (+ (* i i) (* j j)) (* k k)))
        (list i j k)))))

(define (an-integer-between low high)
  (require (<= low high))
  (amb low
       (an-integer-between (+ low 1) high)))

(begin (init-amb)
       (let ((mid (amb-collect-values
		   (lambda ()
		     (a-pythagorean-triple-between 1 20))
		   ;; I want only 3, and 
		   ;; I don't want to backtrack into this.
		   3)))			
	 (pp mid)
	 (pp (list (a-pythagorean-triple-between 1 10)
		   mid	 
		   (a-pythagorean-triple-between 10 30)))	 
	 (amb)))
((6 8 10) (5 12 13) (3 4 5))
((3 4 5) ((6 8 10) (5 12 13) (3 4 5)) (10 24 26))
((6 8 10) ((6 8 10) (5 12 13) (3 4 5)) (10 24 26))
((3 4 5) ((6 8 10) (5 12 13) (3 4 5)) (12 16 20))
((6 8 10) ((6 8 10) (5 12 13) (3 4 5)) (12 16 20))
((3 4 5) ((6 8 10) (5 12 13) (3 4 5)) (15 20 25))
((6 8 10) ((6 8 10) (5 12 13) (3 4 5)) (15 20 25))
((3 4 5) ((6 8 10) (5 12 13) (3 4 5)) (18 24 30))
((6 8 10) ((6 8 10) (5 12 13) (3 4 5)) (18 24 30))
((3 4 5) ((6 8 10) (5 12 13) (3 4 5)) (20 21 29))
((6 8 10) ((6 8 10) (5 12 13) (3 4 5)) (20 21 29))
;Unspecified return value
|#