ps07 assignment

6 files changed, 2166 insertions, 0 deletions

diff --git a/ps07_amb/ambsch.scm b/ps07_amb/ambsch.scm
new file mode 100644
index 0000000..7e4bfe8
--- /dev/null
+++ b/ps07_amb/ambsch.scm
@@ -0,0 +1,336 @@
+;;;; Extension of Scheme for amb
+;;;   amb is the ambiguous operator of McCarthy.
+
+;;; (load "stack-queue.scm")
+
+(define-syntax amb
+  (sc-macro-transformer
+   (lambda (form uenv)
+     `(amb-list
+       (list ,@(map (lambda (arg)
+		      `(lambda ()
+			 ,(close-syntax arg uenv)))
+		    (cdr form)))))))
+
+(define *number-of-calls-to-fail* 0)	;for metering.
+
+(define (amb-list alternatives)
+  (if (null? alternatives)
+      (set! *number-of-calls-to-fail*
+	    (+ *number-of-calls-to-fail* 1)))
+  (call-with-current-continuation
+   (lambda (k)
+     (add-to-search-schedule
+      (map (lambda (alternative)
+             (lambda ()
+               (within-continuation k alternative)))
+           alternatives))
+     (yield))))
+
+
+;;; 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)
+  (force-next
+   (lambda () (undoer) (yield)))
+  (doer))
+
+;;; Alternative search strategy wrappers
+
+(define (with-depth-first-schedule thunk)
+  (call-with-current-continuation
+   (lambda (k)
+     (fluid-let ((add-to-search-schedule
+		  add-to-depth-first-search-schedule)
+		 (*search-schedule* (empty-search-schedule))
+		 (*top-level* k))
+       (thunk)))))
+
+(define (with-breadth-first-schedule thunk)
+  (call-with-current-continuation
+   (lambda (k)
+     (fluid-let ((add-to-search-schedule
+		  add-to-breadth-first-search-schedule)
+		 (*search-schedule* (empty-search-schedule))
+		 (*top-level* k))
+       (thunk)))))
+
+
+;;; Representation of the search schedule
+
+(define *search-schedule*)
+
+(define (empty-search-schedule)
+  (make-stack&queue))
+
+(define (yield)
+  (if (stack&queue-empty? *search-schedule*)
+      (*top-level* #f)
+      ((pop! *search-schedule*))))
+
+(define (force-next thunk)
+  (push! *search-schedule* thunk))
+
+;;; Alternative search strategies
+
+(define (add-to-depth-first-search-schedule alternatives)
+  (for-each (lambda (alternative)
+	      (push! *search-schedule* alternative))
+	    (reverse alternatives)))
+
+(define (add-to-breadth-first-search-schedule alternatives)
+  (for-each (lambda (alternative)
+	      (add-to-end! *search-schedule* alternative))
+	    alternatives))
+
+;;; For incremental interactive experiments from REPL.
+
+(define (init-amb)
+  (set! *search-schedule* (empty-search-schedule))
+  (set! *number-of-calls-to-fail* 0)
+  'done)
+
+(define add-to-search-schedule ;; Default is depth 1st
+  add-to-depth-first-search-schedule)
+
+(define *top-level*
+  (lambda (ignore)
+    (display ";No more alternatives\n")
+    (abort->top-level unspecific)))
+
+;;; AX 1 - Elementary backtrack test.
+
+(define elementary-backtrack-test
+  (lambda ()
+    (let ((x (amb 1 2 3)))
+      (pp (list x))
+      (let ((y (amb 'a 'b)))
+        (pp (list x y))
+        (let ((z (amb #t #f)))
+          (pp (list x y z)))))
+    (amb)))
+#|
+;; AX 1.d - Elementary backtrack test.  [Depth First]
+
+(with-depth-first-schedule elementary-backtrack-test)
+(1)
+(1 a)
+(1 a #t)
+(1 a #f)
+(1 b)
+(1 b #t)
+(1 b #f)
+(2)
+(2 a)
+(2 a #t)
+(2 a #f)
+(2 b)
+(2 b #t)
+(2 b #f)
+(3)
+(3 a)
+(3 a #t)
+(3 a #f)
+(3 b)
+(3 b #t)
+(3 b #f)
+;Value: #f
+
+;; AX 1.b - Elementary backtrack test.  [Breadth First]
+
+(with-breadth-first-schedule elementary-backtrack-test)
+(1)
+(2)
+(3)
+(1 a)
+(1 b)
+(2 a)
+(2 b)
+(3 a)
+(3 b)
+(1 a #t)
+(1 a #f)
+(1 b #t)
+(1 b #f)
+(2 a #t)
+(2 a #f)
+(2 b #t)
+(2 b #f)
+(3 a #t)
+(3 a #f)
+(3 b #t)
+(3 b #f)
+;Value: #f
+|#
+
+;;; AX 2 - Testing undoable assignment.
+
+(define testing-undoable-assignment
+  (lambda ()
+    (let ((x (amb 1 2 3)) (y 0) (z 0))
+      (pp `(before ,x ,y ,z))
+      (amb-set! y x)
+      (pp `(after ,x ,y ,z))
+      (amb-set! z (amb 3.14 2.718))
+      (pp `(zset ,x ,y ,z))
+      (amb-set! x (+ y z))
+      (pp `(xset ,x ,y ,z))
+      (amb))))
+#|
+;;; AX 2.d - Testing undoable assignment.  [Depth First]
+
+(with-depth-first-schedule testing-undoable-assignment)
+(before 1 0 0)
+(after 1 1 0)
+(zset 1 1 3.14)
+(xset 4.140000000000001 1 3.14)
+(zset 1 1 2.718)
+(xset 3.718 1 2.718)
+(before 2 0 0)
+(after 2 2 0)
+(zset 2 2 3.14)
+(xset 5.140000000000001 2 3.14)
+(zset 2 2 2.718)
+(xset 4.718 2 2.718)
+(before 3 0 0)
+(after 3 3 0)
+(zset 3 3 3.14)
+(xset 6.140000000000001 3 3.14)
+(zset 3 3 2.718)
+(xset 5.718 3 2.718)
+;Value: #f
+|#
+
+;;; AX 3 - Pythagorean triples
+
+;; In breadth-first we get useful results here.
+;; None from depth-first.
+
+;; AX 3.f - A Pythagorean triple from...
+
+(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 ()
+      (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)
+(7 24 25)
+(15 20 25)
+(10 24 26)
+(20 21 29)
+(18 24 30)
+(16 30 34)
+(21 28 35)
+(12 35 37)
+(15 36 39)
+(24 32 40)
+(9 40 41)
+(27 36 45)
+(14 48 50)
+(30 40 50)
+(24 45 51)
+(20 48 52)
+(28 45 53)
+(33 44 55)
+(40 42 58)
+(36 48 60)
+(11 60 61)
+(16 63 65)
+(25 60 65)
+(33 56 65)
+;Quit!
+|#
+
+;; AX 3.b - A Pythagorean triple between...
+
+;; 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)))
+
+;; 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* (empty-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)))))))
+#|
+(with-depth-first-schedule
+    (lambda ()
+      (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 (list (a-pythagorean-triple-between 1 10)
+                  mid
+                  (a-pythagorean-triple-between 10 30)))
+        (amb))))
+((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))
+;Value: #f
+|#
diff --git a/ps07_amb/examples.scm b/ps07_amb/examples.scm
new file mode 100644
index 0000000..e1162d6
--- /dev/null
+++ b/ps07_amb/examples.scm
@@ -0,0 +1,189 @@
+#|
+|| SICP Section 4.3.2
+|| Logic Puzzles
+||
+|| Baker, Cooper, Fletcher, Miller, and Smith live on
+|| different floors of a building that has only five
+|| floors.  Baker does not live on the top floor.
+|| Cooper does not live on the bottom floor.  Fletcher
+|| does not live on either the top or the bottom
+|| floor.  Miller lives on a higher floor than does
+|| Cooper.  Smith does not live on a floor adjacent to
+|| Fletcher's.  Fletcher does not live on a floor
+|| adjacent to Cooper's.  Where does everyone live?
+||
+||	(From Dinesman, 1968)
+|#
+
+(define (multiple-dwelling)
+  (let ((baker (amb 1 2 3 4 5))
+        (cooper (amb 1 2 3 4 5))
+        (fletcher (amb 1 2 3 4 5))
+        (miller (amb 1 2 3 4 5))
+        (smith (amb 1 2 3 4 5)))
+    (require
+     (distinct?
+      (list baker cooper fletcher miller smith)))
+    (require (not (= baker 5)))
+    (require (not (= cooper 1)))
+    (require (not (= fletcher 5)))
+    (require (not (= fletcher 1)))
+    (require (> miller cooper))
+    (require
+     (not (= (abs (- smith fletcher)) 1)))
+    (require
+     (not (= (abs (- fletcher cooper)) 1)))
+    (list (list 'baker baker)
+          (list 'cooper cooper)
+          (list 'fletcher fletcher)
+          (list 'miller miller)
+          (list 'smith smith))))
+
+(define (distinct? items)
+  (cond ((null? items) #t)
+        ((null? (cdr items)) #t)
+        ((member (car items) (cdr items)) #f)
+        (else (distinct? (cdr items)))))
+
+#|
+(init-amb)
+;Value: done
+
+(with-depth-first-schedule multiple-dwelling)
+;Value: ((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
+
+(amb)
+;No more alternatives
+|#
+
+;;; From SICP Section 4.3.2
+;;; Parsing natural language
+
+(define (parse input)
+  (amb-set! *unparsed* input)
+  (let ((sent (parse-sentence)))
+    (require (null? *unparsed*))
+    sent))
+
+(define *unparsed* '())
+
+(define (parse-sentence)
+  (let* ((np (parse-noun-phrase))
+	 (verb (parse-verb-phrase)))
+    (list 'sentence np verb)))
+
+(define (parse-noun-phrase)
+  (define (maybe-extend noun-phrase)
+    (amb noun-phrase
+         (maybe-extend
+	  (list 'noun-phrase
+		noun-phrase
+		(parse-prepositional-phrase)))))
+  (maybe-extend (parse-s-noun-phrase)))
+
+(define (parse-verb-phrase)
+  (define (maybe-extend verb-phrase)
+    (amb verb-phrase
+         (maybe-extend
+	  (list 'verb-phrase
+		verb-phrase
+		(parse-prepositional-phrase)))))
+  (maybe-extend (parse-word verbs)))
+
+(define (parse-s-noun-phrase)
+  (let* ((article (parse-word articles))
+	 (noun (parse-word nouns)))
+    (list 's-noun-phrase article noun)))
+
+(define (parse-prepositional-phrase)
+  (let* ((preposition
+	  (parse-word prepositions))
+	 (np (parse-noun-phrase)))
+    (list 'prep-phrase preposition np)))
+
+(define (parse-word word-list)
+  (require (not (null? *unparsed*)))
+  (require (memq (car *unparsed*)
+		 (cdr word-list)))
+  (let ((found-word (car *unparsed*)))
+    (amb-set! *unparsed* (cdr *unparsed*))
+    (list (car word-list) found-word)))
+
+(define nouns
+  '(noun student professor cat class))
+
+(define verbs
+  '(verb studies lectures eats sleeps))
+
+(define articles
+  '(article the a))
+
+(define prepositions
+  '(prep for to in by with))
+
+#|
+(init-amb)
+;Value: done
+
+(pp
+ (parse
+  '(the student with the cat sleeps in the class)))
+
+(sentence
+ (noun-phrase
+  (s-noun-phrase (article the) (noun student))
+  (prep-phrase (prep with)
+	       (s-noun-phrase (article the)
+			      (noun cat))))
+ (verb-phrase
+  (verb sleeps)
+  (prep-phrase (prep in)
+	       (s-noun-phrase (article the)
+			      (noun class)))))
+;Unspecified return value
+
+(amb)
+;No more alternatives
+|#
+
+#|
+(init-amb)
+;Value: done
+
+(pp
+ (parse
+  '(the professor lectures
+	to the student with the cat)))
+
+(sentence
+ (s-noun-phrase (article the) (noun professor))
+ (verb-phrase
+  (verb-phrase
+   (verb lectures)
+   (prep-phrase (prep to)
+		(s-noun-phrase (article the)
+			       (noun student))))
+  (prep-phrase (prep with)
+	       (s-noun-phrase (article the)
+			      (noun cat)))))
+;Unspecified return value
+
+(amb)
+
+(sentence
+ (s-noun-phrase (article the) (noun professor))
+ (verb-phrase
+  (verb lectures)
+  (prep-phrase
+   (prep to)
+   (noun-phrase
+    (s-noun-phrase (article the)
+		   (noun student))
+    (prep-phrase (prep with)
+		 (s-noun-phrase (article the)
+				(noun cat)))))))
+;Unspecified return value
+
+(amb)
+;No more alternatives
+|#
diff --git a/ps07_amb/funco.scm b/ps07_amb/funco.scm
new file mode 100644
index 0000000..73fb947
--- /dev/null
+++ b/ps07_amb/funco.scm
@@ -0,0 +1,223 @@
+;;;; Fun with Continuations
+
+#| Adapted from MIT/GNU Scheme Reference Manual [Section 12.4]:
+
+(call-with-current-continuation
+ (lambda (exit)
+   (for-each (lambda (x)
+	       (if (negative? x)
+		   (exit x)))
+	     '(54 0 37 -3 245 -19))	; **
+   #t))
+;Value: -3
+
+|#
+
+;;; Continuations as Non-Local Exits
+
+(define (funco:first-negative list-of-numbers)
+  (call-with-current-continuation
+   (lambda (k_exit)
+     (or (call-with-current-continuation
+	  (lambda (k_shortcut)
+	    (for-each (lambda (n)
+			(cond ((not (number? n))
+			       (pp `(not-a-number: ,n))
+			       (k_exit #f))
+			      ((negative? n)
+			       (k_shortcut n))
+			      (else
+			       ':keep-looking)))
+		      list-of-numbers)
+	    #f ;; Fall-through sentinel:  no negatives found.
+	    ))
+	 ':no-negatives-found))))
+
+#|
+(funco:first-negative '(54 0 37 -3 245 -19))
+;Value: -3
+
+(funco:first-negative '(54 0 37  3 245  19))
+;Value: :no-negatives-found
+
+(funco:first-negative '(54 0 37 no 245 boo))
+(not-a-number: no)
+;Value: #f
+|#
+
+;;; Continuations for Proceeding (Suspend/Resume Backtracking)
+
+(define (funco:first-negative-n-proceed list-of-numbers) ;;; **
+  (call-with-current-continuation
+   (lambda (k_exit)
+     (or (call-with-current-continuation
+	  (lambda (k_shortcut)
+	    (for-each (lambda (n)
+			(pp				 ;;; **
+			 (call-with-current-continuation ;;; **
+			  (lambda (k_proceed)		 ;;; **
+			    (cond ((not (number? n))
+				   (pp `(not-a-number: ,n))
+				   (k_exit
+				    (cons n k_proceed))) ;;; **
+				  ((negative? n)
+				   (k_shortcut
+				    (cons n k_proceed))) ;;; **
+				  (else
+				   ':keep-looking)))
+			  )))				 ;;; **
+		      list-of-numbers)
+	    #f ;; Fall-through sentinel:  no negatives found.
+	    ))
+	 ':no-negatives-found))))
+
+(define (funco:first-negative-n-proceed-more?      smore) (pair? smore))
+(define (funco:first-negative-n-proceed-more/found smore) (car   smore))
+(define (funco:first-negative-n-proceed-more/k     smore) (cdr   smore))
+(define (funco:first-negative-n-proceed-more/next  smore)
+       ((funco:first-negative-n-proceed-more/k     smore)
+	(funco:first-negative-n-proceed-more/found smore)))
+
+#|
+;;;           ------------
+(define funco:first-of-two
+  (funco:first-negative-n-proceed '(54 0 37 -3 245 -19)))
+:keep-looking
+:keep-looking
+:keep-looking
+;Value: funco:first-of-two
+
+(funco:first-negative-n-proceed-more?		funco:first-of-two)
+;Value: #t
+
+(funco:first-negative-n-proceed-more/found	funco:first-of-two)
+;Value: -3
+
+(funco:first-negative-n-proceed-more/next	funco:first-of-two)
+-3
+:keep-looking
+;Value: funco:first-of-two
+
+(funco:first-negative-n-proceed-more?		funco:first-of-two)
+;Value: #t
+
+(funco:first-negative-n-proceed-more/found	funco:first-of-two)
+;Value: -19
+
+(funco:first-negative-n-proceed-more/next	funco:first-of-two)
+-19
+;Value: funco:first-of-two
+
+(funco:first-negative-n-proceed-more?		funco:first-of-two)
+;Value: #f
+
+funco:first-of-two
+;Value: :no-negatives-found
+|#
+
+#|
+;;;           ----
+(define funco:nada
+  (funco:first-negative-n-proceed '(54 0 37  3 245  19)))
+:keep-looking
+:keep-looking
+:keep-looking
+:keep-looking
+:keep-looking
+:keep-looking
+;Value: funco:nada
+
+(funco:first-negative-n-proceed-more? funco:nada)
+;Value: #f
+
+funco:nada
+;Value: :no-negatives-found
+|#
+
+#|
+;;;           ----
+(define funco:nans
+  (funco:first-negative-n-proceed '(54 0 37 no 245 boo)))
+:keep-looking
+:keep-looking
+:keep-looking
+(not-a-number: no)
+;Value: funco:nans
+
+(funco:first-negative-n-proceed-more?		funco:nans)
+;Value: #t
+
+(funco:first-negative-n-proceed-more/found	funco:nans)
+;Value: no
+
+(funco:first-negative-n-proceed-more/next	funco:nans)
+no
+:keep-looking
+(not-a-number: boo)
+;Value: funco:nans
+
+(funco:first-negative-n-proceed-more?		funco:nans)
+;Value: #t
+
+(funco:first-negative-n-proceed-more/next	funco:nans)
+boo
+;Value: funco:nans
+
+(funco:first-negative-n-proceed-more?		funco:nans)
+;Value: #f
+
+funco:nans
+;Value: :no-negatives-found
+|#
+
+;;; Continuations for Backtracking (Re-entrant 1st-Class Continuations)
+
+(define *k_re-funco*)
+(define       funco)
+
+#|
+(begin
+  (set! funco (+ 2 (call-with-current-continuation
+		    (lambda (k_re-funco)
+		      (set! *k_re-funco* k_re-funco)
+		      3))))
+  ':ok)
+;Value: :ok
+
+funco
+;Value: 5
+
+(*k_re-funco* 4)
+;Value: :ok
+
+funco
+;Value: 6
+
+(*k_re-funco* 5)
+;Value: :ok
+
+funco
+;Value: 7
+|#
+
+;;; Dynamic Contexts and Within-Continuation
+
+(define (funco:test-k-thunk k-thunk)
+  (let ((*foo* 2))			;----------------------.
+    (define (foo-thunk) *foo*)		; *foo* is 2 out here. :
+    (call-with-current-continuation	;                      :
+     (lambda (k)			;                      :
+       (fluid-let ((*foo* 3))	;---------------------.        :
+	 (k-thunk k foo-thunk)	; *foo* is 3 in here. :        :
+	 )			;---------------------'        :
+       ))				; *foo* is 2 out here. :
+    ))					;----------------------'
+#|
+(funco:test-k-thunk (lambda (k thunk)
+		      (k (thunk))))
+;Value: 3
+
+(funco:test-k-thunk (lambda (k thunk)
+		      (within-continuation k thunk)))
+;Value: 2
+|#
diff --git a/ps07_amb/load.scm b/ps07_amb/load.scm
new file mode 100644
index 0000000..5a0c783
--- /dev/null
+++ b/ps07_amb/load.scm
@@ -0,0 +1,11 @@
+;; Fun with Continuations
+(load "funco")
+
+;; AMB Scheme extensions
+(load "stack-queue")
+(load "ambsch")
+
+;; AMB Examples from SICP
+(load "examples")
+
+':have-fun!
diff --git a/ps07_amb/ps.txt b/ps07_amb/ps.txt
new file mode 100644
index 0000000..d70b8e1
--- /dev/null
+++ b/ps07_amb/ps.txt
@@ -0,0 +1,1355 @@
+
+                MASSACHVSETTS INSTITVTE OF TECHNOLOGY
+      Department of Electrical Engineering and Computer Science
+
+                          6.945 Spring 2009
+                            Problem Set 7
+
+  Issued: Wed. 18 Mar. 2009                    Due: Wed. 1 Apr. 2009
+
+
+Readings:
+  SICP second edition
+     Section 4.3:
+        Variations on a Scheme--Nondeterministic Programming
+
+  Online MIT/GNU Scheme Documentation,
+     Section  2.3: Dynamic Binding - fluid-let
+     Section 12.4: Continuations   - call-with-current-continuation &
+                                                within-continuation
+
+  There is an entire bibliography of stuff about this on:
+     http://library.readscheme.org/page6.html
+
+Code:  load.scm, funco.scm, ambsch.scm, stack-queue, examples.scm (attached)
+
+
+                          Generate and Test
+
+We normally think of generate and test, and its extreme use in search,
+as an AI technique.  However, it can be viewed as a way of making
+systems that are modular and independently evolvable, as in the
+exploratory behavior of biological systems.  Consider a very simple
+example:  suppose we have to solve a quadratic equation.  There are two
+roots to a quadratic.  We could return both, and assume that the user
+of the solution knows how to deal with that, or we could return one
+and hope for the best.  (The canonical sqrt routine returns the
+positive square root, even though there are two square roots!)  The
+disadvantage of returning both solutions is that the receiver of that
+result must know to try the computation with both and either reject
+one, for good reason, or return both results of the computation, which
+may itself have made some choices.  The disadvantage of returning only
+one solution is that it may not be the right one for the receiver's
+purpose.
+
+A better way to handle this is to build a backtracking mechanism into
+the infrastructure.  The square-root procedure should return one of
+the roots, with the option to change its mind and return the other one
+if the first choice is determined to be inappropriate by the receiver.
+It is, and should be, the receiver's responsibility to determine if
+the ingredients to its computation are appropriate and acceptable.
+This may itself require a complex computation, involving choices whose
+consequences may not be apparent without further computation, so the
+process is recursive.  Of course, this gets us into potentially deadly
+exponential searches through all possible assignments to all the
+choices that have been made in the program.  As usual, modular
+flexibility can be dangerous.
+
+                    Linguistically Implicit Search
+
+We have talked about the extent to which a search strategy can be
+separated from the other parts of a program, so that one can
+interchange search strategies without greatly modifying the program.
+In this problem set we take the further step of pushing search and
+search control into the infrastructure that is supported by the
+language, without explicitly building search into our program at all.
+
+This idea has considerable history.  In 1961 John McCarthy had the
+idea of a nondeterministic operator AMB, which could be useful for
+representing nondeterministic automata.  In 1967 Bob Floyd had the
+idea of building backtracking search into a computer language as part
+of the linguistic glue.  In 1969 Carl Hewitt proposed a language,
+PLANNER, that embodied these ideas.  In the early 1970s Colmerauer,
+Kowalski, Roussel, and Warren developed Prolog, a language based on a
+limited form of first-order predicate calculus, which made
+backtracking search implicit.
+
+In this problem set we will learn how to implement and how to use
+linguistic nondeterminism.  Before proceeding we recommend that you
+carefully reread section 4.3, up to but not including 4.3.3 of SICP
+(pages 412--426).  This material introduces AMB and shows how it can
+be used to formalize some classes of search problems.  Section 4.3.3
+describes how to compile a language that includes AMB into a
+combinator structure.  We touched on this in Problem Set 4.  In this
+problem set we will see a different way to implement AMB, worked out
+in the file "ambsch.scm", which allows ordinary Scheme programs to
+freely intermix with code that includes nondeterministic search.
+
+But before we try to understand the implementation, it is useful to
+review what can be done with AMB.  If you load "ambsch.scm" into MIT
+Scheme you can run examples such as the ones in the comments at the
+end of the "ambsch.scm" file, and you can solve the following puzzle.
+
+-------------
+Problem 7.1: Warmup (From SICP Exercise 4.43, p.420)
+
+Formalize and solve the following puzzle with AMB:
+
+     Mary Ann Moore's father has a yacht and so has each of his
+     four friends:  Colonel Downing, Mr. Hall, Sir Barnacle Hood,
+     and Dr. Parker.  Each of the five also has one daughter and
+     each has named his yacht after a daughter of one of the
+     others.  Sir Barnacle's yacht is the Gabrielle, Mr. Moore
+     owns the Lorna; Mr. Hall the Rosalind.  The Melissa, owned
+     by Colonel Downing, is named after Sir Barnacle's daughter.
+     Gabrielle's father owns the yacht that is named after Dr.
+     Parker's daughter.  Who is Lorna's father?
+
+You must use AMB to specify the alternatives that are possible for
+each choice.  Also determine how many solutions there are if we are
+not told that Mary Ann's last name is Moore.
+-------------
+
+                    Fun with Current Continuation
+
+Before we can understand how the ambsch mechanism works we have to get
+deeper into continuations.  Continuations are one of the most powerful
+(and the most dangerous) tools of a programmer.  Scheme provides the
+ability for a programmer to get the continuation of an expression.
+But most other languages do not support the use of first-class
+continuations.  (Some other languages that do have first-class
+continuations include SML, Ruby, and Smalltalk.)
+
+Whenever a Scheme expression is evaluated, a continuation exists that
+wants the result of the expression.  The continuation represents an
+entire (default) future for the computation.  If the expression is
+evaluated at top level, for example, the continuation will take the
+result, print it on the screen, prompt for the next input, evaluate
+it, and so on forever.  Most of the time the continuation includes
+actions specified by user code, as in a continuation that will take
+the result, multiply it by the value stored in a local variable, add
+seven, and give the answer to the top-level continuation to be
+printed.  Normally these ubiquitous continuations are hidden behind the
+scenes and programmers don't think much about them.  On the rare
+occasions that you may need to deal explicitly with continuations,
+call-with-current-continuation lets you do so by creating a procedure
+that acts just like the current continuation.
+
+See the on-line MIT/GNU Scheme Reference Manual, Section 12.4, for a
+detailed description of CALL-WITH-CURRENT-CONTINUATION.
+
+Explicit continuations may be powerful and sometimes useful, but they
+are rarely necessary.  One common usage case is for non-local exits.
+Another is for resuming a suspended computation for backtracking.  Yet
+another is coroutining (which we will explore in a later problem set).
+
+
+                   Continuations as Non-Local Exits
+
+Consider the following simple example of a non-local exit continuation
+(adapted from the MIT/GNU Scheme Reference Manual [Section 12.4]):
+
+     (call-with-current-continuation
+      (lambda (exit)
+        (for-each (lambda (x)
+                    (if (negative? x)
+                        (exit x)))
+                  '(54 0 37 -3 245 -19))     ; **
+        #t))
+     ;Value: -3
+
+Because Scheme's for-each procedure walks the list in left-to-right
+order, the first negative element encountered is -3, which is
+immediately returned.  Had the list contained no negative numbers, the
+result would have been #t (since the body of the lambda form is a
+sequence of two expressions, the for-each expression followed by #t).
+
+In a larger context, this might appear within some other form, like
+the following definition (explained below) in file "funco.scm":
+
+     (define (funco:first-negative list-of-numbers)
+       (call-with-current-continuation
+        (lambda (k_exit)
+          (or (call-with-current-continuation
+               (lambda (k_shortcut)
+                 (for-each (lambda (n)
+                             (cond ((not (number? n))
+                                    (pp `(not-a-number: ,n))
+                                    (k_exit #f))
+                                   ((negative? n)
+                                    (k_shortcut n))
+                                   (else
+                                    ':keep-looking)))
+                           list-of-numbers)
+                 #f ;; Fall-through sentinel:  no negatives found.
+                 ))
+              ':no-negatives-found))))
+
+     #|
+     (funco:first-negative '(54 0 37 -3 245 -19))
+     ;Value: -3
+
+     (funco:first-negative '(54 0 37  3 245  19))
+     ;Value: :no-negatives-found
+
+     (funco:first-negative '(54 0 37 no 245 boo))
+     (not-a-number: no)
+     ;Value: #f
+     |#
+
+This demonstrates nested continuations, where the outermost k_exit
+continuation exits the entire call to funco:first-negative while the
+inner k_shortcut continuation exits only to the enclosing disjunction
+(or), then continues from there.
+
+In short, if a continuation captured by call-with-current-continuation
+is ever invoked (with value V), then the computation will continue by
+returning V as the value of the call to call-with-current-continuation
+and resuming execution normally from there.  [This is a bit tricky so
+look at the code above and re-read this last sentence a couple times
+until it makes sense... and please suggest alternative wording that
+might be less quixotically obtuse.]
+
+-------------
+Problem 7.2:
+
+A. Define a simple procedure, snark-hunt, that takes a tree of symbols
+   as argument and recursively descends it looking for the symbol
+   'snark at any leaf.  It should immediately halt and return #t if
+   one is found; #f otherwise.  Use call-with-current-continuation.
+
+   If it helps, feel free to assume that all input trees will be valid
+   non-null lists of tree-or-symbol elements, or whatever other data
+   representation you find convenient.
+
+   E.g.,
+
+    (snark-hunt '(((a b c) d (e f)) g (((snark . "oops") h) (i . j))))
+    ;Value: #t
+
+   Note that the dotted pairs in the above violate (intentionally) the
+   assumption that the input is comprised solely of proper lists of
+   tree-or-symbol elements, so overruns may well result in errors.
+
+B. How might you verify that it exits immediately rather than silently
+   returning through multiple return levels?  Define a new procedure,
+   snark-hunt/instrumented, to demonstrate this.  [Hint:  setting an
+   exit status flag then signaling an error on wayward return paths
+   might work if placed carefully, but simply tracing via pp may be
+   easier.  Whatever quick and dirty hack that works will do.  The
+   goal here is to build your intuition about continuations, not to
+   ship product-quality code.  Briefly explain your strategy.]
+-------------
+
+                    Continuations for Backtracking
+
+The preceding was somewhat simplistic since the continuations captured
+were used only for non-local exits.  Specifically, they were not used
+for backtracking.  Moreover, they were never re-entered once invoked.
+
+Now consider the following slightly more interesting scenario:
+
+     (define *k_re-funco*)
+     (define       funco)
+
+     #|
+     (begin
+       (set! funco (+ 2 (call-with-current-continuation
+                         (lambda (k_re-funco)
+                           (set! *k_re-funco* k_re-funco)
+                           3))))
+       ':ok)
+     ;Value: :ok
+
+     funco
+     ;Value: 5
+
+     (*k_re-funco* 4)
+     ;Value: :ok
+
+     funco
+     ;Value: 6
+
+     (*k_re-funco* 5)
+     ;Value: :ok
+
+     funco
+     ;Value: 7
+     |#
+
+Note carefully how re-entering this captured continuation returns
+control to the point before the add and, therefore, before assigning
+variable funco and returning the symbol ':ok.  This is why invoking it
+always returns the symbol ':ok, not the value passed to the exported
+continuation being re-entered (obviously) and not the new value to
+which that variable is re-assigned nor its old value nor unspecific.
+
+This and the other examples in file "funco.scm" (attached) demonstrate
+how to re-enter a captured continuation to proceed from intermediate
+return points.  This mechanism is used for backtracking in "ambsch.scm".
+
+                  Continuations and Dynamic Contexts
+
+We've already seen a few instances of dynamic binding via FLUID-LET in
+lecture.  Although assignment violates referential transparency, fluid
+binding can be handy for locally overriding a free variable's value.
+
+For example, consider the following code fragment:
+
+     (define *trace?* #f)
+
+     (define (foo x)
+       (set! *trace?* #t)
+       (let ((result (bar x))) ;; bar may pp status when *trace?* set
+         (set! *trace?* #f)
+         result))
+
+This works as expected only so long as bar does not capture and export
+a continuation that can be used to re-enter bar's body.  Moreover, if
+bar exits by invoking a continuation that bypasses the normal return
+mechanism that LET-binds result, the *trace?* flag may not be reset on
+the way out.  Worse, this presumes *trace?* is always #f on entry.
+
+To handle side-effects like this in the face of (possibly hidden)
+first-class continuations, a new dynamic binding form named FLUID-LET
+is provided that assigns (rather than LET-binds) variables on entry
+and reassigns them to their previous values upon exit, whether exiting
+via the normal return mechanism or through some captured continuation.
+
+Thus, FLUID-LET allows parameterization of subsystems with a condition
+that is in effect over a controlled time interval (an extent) rather
+than over a lexically apparent textual region of code (a scope).
+
+The FLUID-LET special form is documented in the on-line MIT/GNU Scheme
+Reference Manual, Section 2.3 Dynamic Binding (q.v.).
+
+In this case, for example, the expected behavior can be achieved by
+rewriting the above code fragment as:
+
+     (define (foo x)
+       (fluid-let ((*trace?* #t))
+         (bar x)))
+
+This mechanism is used in a few places in "ambsch.scm" to allow
+arbitrary nesting of depth-first verse breadth-first scheduling.
+It is also used by the mildly hackish amb-collect-values device.
+
+               Dynamic Contexts and Within-Continuation
+
+The story gets really interesting when we define a thunk (a procedure
+of no arguments) at some control point in order to delay evaluation of
+its body, but we wish to invoke it in the dynamic context of its
+definition's control point, not the dynamic context in flight at its
+eventual point of call.
+
+For example, consider the following slightly contrived code fragment:
+
+     (define (funco:test-k-thunk k-thunk)
+       (let ((*foo* 2))                      ;----------------------.
+         (define (foo-thunk) *foo*)          ; *foo* is 2 out here. :
+         (call-with-current-continuation     ;                      :
+          (lambda (k)                        ;                      :
+            (fluid-let ((*foo* 3))   ;---------------------.        :
+              (k-thunk k foo-thunk)  ; *foo* is 3 in here. :        :
+              )                      ;---------------------'        :
+            ))                               ; *foo* is 2 out here. :
+         ))                                  ;----------------------'
+
+     #|
+     (funco:test-k-thunk (lambda (k thunk)
+                           (k (thunk))))
+     ;Value: 3
+
+     (funco:test-k-thunk (lambda (k thunk)
+                           (within-continuation k thunk)))
+     ;Value: 2
+     |#
+
+The WITHIN-CONTINUATION procedure is documented in the MIT/GNU Scheme
+Reference Manual [Section 12.4]).  In short, it unrolls the dynamic
+context to that of the continuation, k, before invoking the thunk, the
+result of which is then passed to the continuation, k.
+
+In "ambsch.scm", WITHIN-CONTINUATION is used to ensure that sibling
+AMB arguments are called in the dynamic context in which they were
+introduced, not the dynamic context in which they are eventually
+invoked.  This not only ensures that each AMB alternative backtracks
+to appropriate nested search strategies, it also avoids unnecessary
+accumulation of control state during the invocation of alternatives.
+
+                      From Continuations to AMB
+
+Now that we have had experience with explicit expression continuations
+we can begin to understand the code in "ambsch.scm".  The heart of the
+backtracker is amb-list, which takes a sequence of sibling thunks,
+each representing an alternative value for the amb expression.  The
+thunks were produced by the amb macro, which syntactically transforms
+amb expressions into amb-list expressions, as follows:
+
+     (amb <e1> ... <en>) ==>
+       (amb-list (list (lambda () <e1>) ... (lambda () <en>)))
+
+The search schedule maintains an agenda of thunks that proceed the
+computation when it is necessary for an amb expression to return with
+a new alternative value.  For a particular amb expression these thunks
+are constructed so as to return from that amb expression, using the
+continuation, k, captured at the entrance to its enclosing amb-list.
+The within-continuation expression, which is almost equivalent to the
+call (k (alternative)), prevents the capture of pieces of the control
+stack that are unnecessary for continuing the computation correctly.
+
+Ambl first adds the returners for its alternative values to the search
+schedule and then yields control to the first pending returner.
+
+     (define (amb-list alternatives)
+       (if (null? alternatives)
+	   (set! *number-of-calls-to-fail*
+		 (+ *number-of-calls-to-fail* 1)))
+       (call-with-current-continuation
+	(lambda (k)
+	  (add-to-search-schedule
+	   (map (lambda (alternative)
+		  (lambda ()
+		    (within-continuation k alternative)))
+		alternatives))
+	  (yield))))
+
+
+     (define (yield)
+       (if (stack&queue-empty? *search-schedule*)
+	   (*top-level* #f)
+	   ((pop! *search-schedule*))))
+
+
+Note that procedure add-to-search-schedule is fluid bound either to
+add-to-depth-first-search-schedule (the default behavior) or else to
+add-to-breadth-first-search-schedule.  See "ambsch.scm" for details.
+
+                          Breadth -v- Depth
+
+Consider the following experiment:
+
+     (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)))
+             (set! count (+ count 1))                   ; **
+             (require (= (+ (* i i) (* j j)) (* k k)))
+             (list i j k)))))
+
+     (define count 0)
+     #|
+     (begin
+       (init-amb)
+       (set! count 0)
+       (with-breadth-first-schedule
+         (lambda () (pp (a-pythagorean-triple-between 10 20)))))
+     (12 16 20)
+
+     count
+     ;Value: 246
+
+     *number-of-calls-to-fail*
+     ;Value: 282
+
+
+     (begin
+       (init-amb)
+       (set! count 0)
+       (with-depth-first-schedule
+         (lambda () (pp (a-pythagorean-triple-between 10 20)))))
+     (12 16 20)
+
+     count
+     ;Value: 156
+
+     *number-of-calls-to-fail*
+     ;Value: 182
+     |#
+
+-------------
+Problem 7.3:
+
+Explain the different counts between depth-first and breadth-first
+(in rough terms, not the exact counts).
+
+Also, where are the extra calls to fail coming from?
+
+Considering that the breadth-first search does more work, why is the
+a-pythagorean-triple-from search [AX 3.f in "ambsch.scm"] not usable
+under the depth-first search strategy?
+-------------
+
+                  Less Deterministic Non-Determinism
+
+Eva Lu Ator chides that a criticism one might make of our AMB
+implementation is that it's not as non-deterministic as one might
+sometimes like.  Specifically, given a list of alternatives in an AMB
+form, we always choose the leftmost alternative first then the second
+leftmost and so on in left-to-right order.
+
+She suggests that one might wish to override this choice, say, with
+right-to-left alternation or even in random order.  Specifically,
+she'd like something like:
+
+     (with-left-to-right-alternation <thunk>)
+     (with-right-to-left-alternation <thunk>)
+     (with-random-order-alternation  <thunk>)
+
+She's quick to point out that this choice is independent of the choice
+of depth-first or breadth-first (or whatever else) search order one
+might choose.
+
+-------------
+Problem 7.5:
+
+A. Under what circumstances might you want an unordered (random) AMB?
+   Craft a specific short example to use as a test case below.
+
+B. Implement these three alternatives and give an example use of each.
+   For simplicity and uniformity, model your code after that for
+   with-depth-first-schedule, add-to-depth-first-search-schedule, etc.
+   [Hint:  Feel free to use the native MIT Scheme RANDOM procedure.]
+-------------
+
+                         Neurological Origami
+
+Consider the following brain twister:
+
+     (define moby-brain-twister-test
+       (lambda ()
+         (let ((x) (y) (z))
+           (set! x (amb 1 2 3))
+           (pp (list x))
+           (set! y (amb 'a 'b))
+           (pp (list x y))
+           (set! z (amb #t #f))
+           (pp (list x y z))
+           (amb))))
+     #|
+     (with-breadth-first-schedule moby-brain-twister-test)
+     (1)
+     (2)
+     (3)
+     (3 a)
+     (3 b)
+     (3 a)
+     (3 b)
+     (3 a)
+     (3 b)
+     (3 b #t)
+     (3 b #f)
+     (3 b #t)
+     (3 b #f)
+     (3 b #t)
+     (3 b #f)
+     (3 b #t)
+     (3 b #f)
+     (3 b #t)
+     (3 b #f)
+     (3 b #t)
+     (3 b #f)
+     ;Value: #f
+     |#
+
+Contrast this trace with the breadth-first elementary backtrack test
+AMB example from "ambsch.scm" [viz., AX 1.b].
+
+-------------
+Problem 7.6:
+
+Why does this weird thing happen?
+
+The explanation is very simple, but this took us many hours to
+understand.
+
+[Hint:  Look at (with-depth-first-schedule moby-brain-twister-test).]
+-------------
+
+                      A Potential Project Topic
+
+-------------
+Problem 7.7:  (optional!)
+
+In the ``Continuations and Dynamic Contexts'' discussion section
+above, it was claimed that the breadth-first and depth-first search
+strategies can be arbitrarily nested within AMB forms.
+
+Does the nesting of depth-first and breadth-first scheduling work
+correctly as currently implemented in "ambsch.scm"?  Specifically,
+design an experiment that exposes the bug (if there is one) or that
+demonstrates anecdotally that it does work correctly (if it does).
+Explain your rationale.
+
+This involves crafting a couple experiments that distinguish between
+depth-first and breadth-first search strategies then composing them in
+interesting ways to demonstrate local control over nested searches.
+
+Identifying a natural class of problems for which this flexibility is
+useful--- not just hacked together to prove a point--- might be a fine
+topic for an independent project.  Don't spend too much time on it yet.
+-------------
+
+;;;; File:  funco.scm
+
+;;;; Fun with Continuations
+
+#| Adapted from MIT/GNU Scheme Reference Manual [Section 12.4]:
+
+(call-with-current-continuation
+ (lambda (exit)
+   (for-each (lambda (x)
+               (if (negative? x)
+                   (exit x)))
+             '(54 0 37 -3 245 -19))     ; **
+   #t))
+;Value: -3
+
+|#
+
+;;; Continuations as Non-Local Exits
+
+(define (funco:first-negative list-of-numbers)
+  (call-with-current-continuation
+   (lambda (k_exit)
+     (or (call-with-current-continuation
+          (lambda (k_shortcut)
+            (for-each (lambda (n)
+                        (cond ((not (number? n))
+                               (pp `(not-a-number: ,n))
+                               (k_exit #f))
+                              ((negative? n)
+                               (k_shortcut n))
+                              (else
+                               ':keep-looking)))
+                      list-of-numbers)
+            #f ;; Fall-through sentinel:  no negatives found.
+            ))
+         ':no-negatives-found))))
+
+#|
+(funco:first-negative '(54 0 37 -3 245 -19))
+;Value: -3
+
+(funco:first-negative '(54 0 37  3 245  19))
+;Value: :no-negatives-found
+
+(funco:first-negative '(54 0 37 no 245 boo))
+(not-a-number: no)
+;Value: #f
+|#
+
+;;; Continuations for Proceeding (Suspend/Resume Backtracking)
+
+(define (funco:first-negative-n-proceed list-of-numbers) ;;; **
+  (call-with-current-continuation
+   (lambda (k_exit)
+     (or (call-with-current-continuation
+          (lambda (k_shortcut)
+            (for-each (lambda (n)
+                        (pp                              ;;; **
+                         (call-with-current-continuation ;;; **
+                          (lambda (k_proceed)            ;;; **
+                            (cond ((not (number? n))
+                                   (pp `(not-a-number: ,n))
+                                   (k_exit
+                                    (cons n k_proceed))) ;;; **
+                                  ((negative? n)
+                                   (k_shortcut
+                                    (cons n k_proceed))) ;;; **
+                                  (else
+                                   ':keep-looking)))
+                          )))                            ;;; **
+                      list-of-numbers)
+            #f ;; Fall-through sentinel:  no negatives found.
+            ))
+         ':no-negatives-found))))
+
+(define (funco:first-negative-n-proceed-more?      smore) (pair? smore))
+(define (funco:first-negative-n-proceed-more/found smore) (car   smore))
+(define (funco:first-negative-n-proceed-more/k     smore) (cdr   smore))
+(define (funco:first-negative-n-proceed-more/next  smore)
+       ((funco:first-negative-n-proceed-more/k     smore)
+        (funco:first-negative-n-proceed-more/found smore)))
+
+#|
+;;;           ------------
+(define funco:first-of-two
+  (funco:first-negative-n-proceed '(54 0 37 -3 245 -19)))
+:keep-looking
+:keep-looking
+:keep-looking
+;Value: funco:first-of-two
+
+(funco:first-negative-n-proceed-more?           funco:first-of-two)
+;Value: #t
+
+(funco:first-negative-n-proceed-more/found      funco:first-of-two)
+;Value: -3
+
+(funco:first-negative-n-proceed-more/next       funco:first-of-two)
+-3
+:keep-looking
+;Value: funco:first-of-two
+
+(funco:first-negative-n-proceed-more?           funco:first-of-two)
+;Value: #t
+
+(funco:first-negative-n-proceed-more/found      funco:first-of-two)
+;Value: -19
+
+(funco:first-negative-n-proceed-more/next       funco:first-of-two)
+-19
+;Value: funco:first-of-two
+
+(funco:first-negative-n-proceed-more?           funco:first-of-two)
+;Value: #f
+
+funco:first-of-two
+;Value: :no-negatives-found
+|#
+
+#|
+;;;           ----
+(define funco:nada
+  (funco:first-negative-n-proceed '(54 0 37  3 245  19)))
+:keep-looking
+:keep-looking
+:keep-looking
+:keep-looking
+:keep-looking
+:keep-looking
+;Value: funco:nada
+
+(funco:first-negative-n-proceed-more? funco:nada)
+;Value: #f
+
+funco:nada
+;Value: :no-negatives-found
+|#
+
+#|
+;;;           ----
+(define funco:nans
+  (funco:first-negative-n-proceed '(54 0 37 no 245 boo)))
+:keep-looking
+:keep-looking
+:keep-looking
+(not-a-number: no)
+;Value: funco:nans
+
+(funco:first-negative-n-proceed-more?           funco:nans)
+;Value: #t
+
+(funco:first-negative-n-proceed-more/found      funco:nans)
+;Value: no
+
+(funco:first-negative-n-proceed-more/next       funco:nans)
+no
+:keep-looking
+(not-a-number: boo)
+;Value: funco:nans
+
+(funco:first-negative-n-proceed-more?           funco:nans)
+;Value: #t
+
+(funco:first-negative-n-proceed-more/next       funco:nans)
+boo
+;Value: funco:nans
+
+(funco:first-negative-n-proceed-more?           funco:nans)
+;Value: #f
+
+funco:nans
+;Value: :no-negatives-found
+|#
+
+;;; Continuations for Backtracking (Re-entrant 1st-Class Continuations)
+
+(define *k_re-funco*)
+(define       funco)
+
+#|
+(begin
+  (set! funco (+ 2 (call-with-current-continuation
+                    (lambda (k_re-funco)
+                      (set! *k_re-funco* k_re-funco)
+                      3))))
+  ':ok)
+;Value: :ok
+
+funco
+;Value: 5
+
+(*k_re-funco* 4)
+;Value: :ok
+
+funco
+;Value: 6
+
+(*k_re-funco* 5)
+;Value: :ok
+
+funco
+;Value: 7
+|#
+
+;;; Dynamic Contexts and Within-Continuation
+
+(define (funco:test-k-thunk k-thunk)
+  (let ((*foo* 2))                      ;----------------------.
+    (define (foo-thunk) *foo*)          ; *foo* is 2 out here. :
+    (call-with-current-continuation     ;                      :
+     (lambda (k)                        ;                      :
+       (fluid-let ((*foo* 3))   ;---------------------.        :
+         (k-thunk k foo-thunk)  ; *foo* is 3 in here. :        :
+         )                      ;---------------------'        :
+       ))                               ; *foo* is 2 out here. :
+    ))                                  ;----------------------'
+#|
+(funco:test-k-thunk (lambda (k thunk)
+                      (k (thunk))))
+;Value: 3
+
+(funco:test-k-thunk (lambda (k thunk)
+                      (within-continuation k thunk)))
+;Value: 2
+|#
+
+;;;; File:  ambsch.scm
+;;;; Extension of Scheme for amb
+;;;   amb is the ambiguous operator of McCarthy.
+
+;;; (load "stack-queue.scm")
+
+(define-syntax amb
+  (sc-macro-transformer
+   (lambda (form uenv)
+     `(amb-list
+       (list ,@(map (lambda (arg)
+		      `(lambda ()
+			 ,(close-syntax arg uenv)))
+		    (cdr form)))))))
+
+(define *number-of-calls-to-fail* 0)	;for metering.
+
+(define (amb-list alternatives)
+  (if (null? alternatives)
+      (set! *number-of-calls-to-fail*
+	    (+ *number-of-calls-to-fail* 1)))
+  (call-with-current-continuation
+   (lambda (k)
+     (add-to-search-schedule
+      (map (lambda (alternative)
+             (lambda ()
+               (within-continuation k alternative)))
+           alternatives))
+     (yield))))
+
+
+;;; 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)
+  (force-next
+   (lambda () (undoer) (yield)))
+  (doer))
+
+;;; Alternative search strategy wrappers
+
+(define (with-depth-first-schedule thunk)
+  (call-with-current-continuation
+   (lambda (k)
+     (fluid-let ((add-to-search-schedule
+		  add-to-depth-first-search-schedule)
+		 (*search-schedule* (empty-search-schedule))
+		 (*top-level* k))
+       (thunk)))))
+
+(define (with-breadth-first-schedule thunk)
+  (call-with-current-continuation
+   (lambda (k)
+     (fluid-let ((add-to-search-schedule
+		  add-to-breadth-first-search-schedule)
+		 (*search-schedule* (empty-search-schedule))
+		 (*top-level* k))
+       (thunk)))))
+
+
+;;; Representation of the search schedule
+
+(define *search-schedule*)
+
+(define (empty-search-schedule)
+  (make-stack&queue))
+
+(define (yield)
+  (if (stack&queue-empty? *search-schedule*)
+      (*top-level* #f)
+      ((pop! *search-schedule*))))
+
+(define (force-next thunk)
+  (push! *search-schedule* thunk))
+
+;;; Alternative search strategies
+
+(define (add-to-depth-first-search-schedule alternatives)
+  (for-each (lambda (alternative)
+	      (push! *search-schedule* alternative))
+	    (reverse alternatives)))
+
+(define (add-to-breadth-first-search-schedule alternatives)
+  (for-each (lambda (alternative)
+	      (add-to-end! *search-schedule* alternative))
+	    alternatives))
+
+;;; For incremental interactive experiments from REPL.
+
+(define (init-amb)
+  (set! *search-schedule* (empty-search-schedule))
+  (set! *number-of-calls-to-fail* 0)
+  'done)
+
+(define add-to-search-schedule ;; Default is depth 1st
+  add-to-depth-first-search-schedule)
+
+(define *top-level*
+  (lambda (ignore)
+    (display ";No more alternatives\n")
+    (abort->top-level unspecific)))
+
+;;; AX 1 - Elementary backtrack test.
+
+(define elementary-backtrack-test
+  (lambda ()
+    (let ((x (amb 1 2 3)))
+      (pp (list x))
+      (let ((y (amb 'a 'b)))
+        (pp (list x y))
+        (let ((z (amb #t #f)))
+          (pp (list x y z)))))
+    (amb)))
+#|
+;; AX 1.d - Elementary backtrack test.  [Depth First]
+
+(with-depth-first-schedule elementary-backtrack-test)
+(1)
+(1 a)
+(1 a #t)
+(1 a #f)
+(1 b)
+(1 b #t)
+(1 b #f)
+(2)
+(2 a)
+(2 a #t)
+(2 a #f)
+(2 b)
+(2 b #t)
+(2 b #f)
+(3)
+(3 a)
+(3 a #t)
+(3 a #f)
+(3 b)
+(3 b #t)
+(3 b #f)
+;Value: #f
+
+;; AX 1.b - Elementary backtrack test.  [Breadth First]
+
+(with-breadth-first-schedule elementary-backtrack-test)
+(1)
+(2)
+(3)
+(1 a)
+(1 b)
+(2 a)
+(2 b)
+(3 a)
+(3 b)
+(1 a #t)
+(1 a #f)
+(1 b #t)
+(1 b #f)
+(2 a #t)
+(2 a #f)
+(2 b #t)
+(2 b #f)
+(3 a #t)
+(3 a #f)
+(3 b #t)
+(3 b #f)
+;Value: #f
+|#
+
+;;; AX 2 - Testing undoable assignment.
+
+(define testing-undoable-assignment
+  (lambda ()
+    (let ((x (amb 1 2 3)) (y 0) (z 0))
+      (pp `(before ,x ,y ,z))
+      (amb-set! y x)
+      (pp `(after ,x ,y ,z))
+      (amb-set! z (amb 3.14 2.718))
+      (pp `(zset ,x ,y ,z))
+      (amb-set! x (+ y z))
+      (pp `(xset ,x ,y ,z))
+      (amb))))
+#|
+;;; AX 2.d - Testing undoable assignment.  [Depth First]
+
+(with-depth-first-schedule testing-undoable-assignment)
+(before 1 0 0)
+(after 1 1 0)
+(zset 1 1 3.14)
+(xset 4.140000000000001 1 3.14)
+(zset 1 1 2.718)
+(xset 3.718 1 2.718)
+(before 2 0 0)
+(after 2 2 0)
+(zset 2 2 3.14)
+(xset 5.140000000000001 2 3.14)
+(zset 2 2 2.718)
+(xset 4.718 2 2.718)
+(before 3 0 0)
+(after 3 3 0)
+(zset 3 3 3.14)
+(xset 6.140000000000001 3 3.14)
+(zset 3 3 2.718)
+(xset 5.718 3 2.718)
+;Value: #f
+|#
+
+;;; AX 3 - Pythagorean triples
+
+;; In breadth-first we get useful results here.
+;; None from depth-first.
+
+;; AX 3.f - A Pythagorean triple from...
+
+(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 ()
+      (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)
+(7 24 25)
+(15 20 25)
+(10 24 26)
+(20 21 29)
+(18 24 30)
+(16 30 34)
+(21 28 35)
+(12 35 37)
+(15 36 39)
+(24 32 40)
+(9 40 41)
+(27 36 45)
+(14 48 50)
+(30 40 50)
+(24 45 51)
+(20 48 52)
+(28 45 53)
+(33 44 55)
+(40 42 58)
+(36 48 60)
+(11 60 61)
+(16 63 65)
+;Quit!
+|#
+
+;; AX 3.b - A Pythagorean triple between...
+
+;; 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)))
+
+;; 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* (empty-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)))))))
+#|
+(with-depth-first-schedule
+    (lambda ()
+      (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 (list (a-pythagorean-triple-between 1 10)
+                  mid
+                  (a-pythagorean-triple-between 10 30)))
+        (amb))))
+((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))
+;Value: #f
+|#
+
+;;;; File:  examples.scm
+
+;;; SICP Section 4.3.2 : Logic Puzzles
+;;;
+;;; Baker, Cooper, Fletcher, Miller, and Smith live on
+;;; different floors of a building that has only five
+;;; floors.  Baker does not live on the top floor.
+;;; Cooper does not live on the bottom floor.  Fletcher
+;;; does not live on either the top or the bottom
+;;; floor.  Miller lives on a higher floor than does
+;;; Cooper.  Smith does not live on a floor adjacent to
+;;; Fletcher's.  Fletcher does not live on a floor
+;;; adjacent to Cooper's.  Where does everyone live?
+;;;      (From Dinesman, 1968)
+
+
+(define (multiple-dwelling)
+  (let ((baker (amb 1 2 3 4 5))
+        (cooper (amb 1 2 3 4 5))
+        (fletcher (amb 1 2 3 4 5))
+        (miller (amb 1 2 3 4 5))
+        (smith (amb 1 2 3 4 5)))
+    (require
+     (distinct?
+      (list baker cooper fletcher miller smith)))
+    (require (not (= baker 5)))
+    (require (not (= cooper 1)))
+    (require (not (= fletcher 5)))
+    (require (not (= fletcher 1)))
+    (require (> miller cooper))
+    (require
+     (not (= (abs (- smith fletcher)) 1)))
+    (require
+     (not (= (abs (- fletcher cooper)) 1)))
+    (list (list 'baker baker)
+          (list 'cooper cooper)
+          (list 'fletcher fletcher)
+          (list 'miller miller)
+          (list 'smith smith))))
+
+(define (distinct? items)
+  (cond ((null? items) #t)
+        ((null? (cdr items)) #t)
+        ((member (car items) (cdr items)) #f)
+        (else (distinct? (cdr items)))))
+
+#|
+(init-amb)
+;Value: done
+
+(with-depth-first-schedule multiple-dwelling)
+;Value: ((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
+
+(amb)
+;No more alternatives
+|#
+
+;;; From SICP Section 4.3.2
+;;; Parsing natural language
+
+(define (parse input)
+  (amb-set! *unparsed* input)
+  (let ((sent (parse-sentence)))
+    (require (null? *unparsed*))
+    sent))
+
+(define *unparsed* '())
+
+(define (parse-sentence)
+  (let* ((np (parse-noun-phrase))
+         (verb (parse-verb-phrase)))
+    (list 'sentence np verb)))
+
+(define (parse-noun-phrase)
+  (define (maybe-extend noun-phrase)
+    (amb noun-phrase
+         (maybe-extend
+          (list 'noun-phrase
+                noun-phrase
+                (parse-prepositional-phrase)))))
+  (maybe-extend (parse-s-noun-phrase)))
+
+(define (parse-verb-phrase)
+  (define (maybe-extend verb-phrase)
+    (amb verb-phrase
+         (maybe-extend
+          (list 'verb-phrase
+                verb-phrase
+                (parse-prepositional-phrase)))))
+  (maybe-extend (parse-word verbs)))
+
+(define (parse-s-noun-phrase)
+  (let* ((article (parse-word articles))
+         (noun (parse-word nouns)))
+    (list 's-noun-phrase article noun)))
+
+(define (parse-prepositional-phrase)
+  (let* ((preposition
+          (parse-word prepositions))
+         (np (parse-noun-phrase)))
+    (list 'prep-phrase preposition np)))
+
+(define (parse-word word-list)
+  (require (not (null? *unparsed*)))
+  (require (memq (car *unparsed*)
+                 (cdr word-list)))
+  (let ((found-word (car *unparsed*)))
+    (amb-set! *unparsed* (cdr *unparsed*))
+    (list (car word-list) found-word)))
+
+(define nouns
+  '(noun student professor cat class))
+
+(define verbs
+  '(verb studies lectures eats sleeps))
+
+(define articles
+  '(article the a))
+
+(define prepositions
+  '(prep for to in by with))
+
+#|
+(init-amb)
+;Value: done
+
+(pp
+ (parse
+  '(the student with the cat sleeps in the class)))
+
+(sentence
+ (noun-phrase
+  (s-noun-phrase (article the) (noun student))
+  (prep-phrase (prep with)
+               (s-noun-phrase (article the)
+                              (noun cat))))
+ (verb-phrase
+  (verb sleeps)
+  (prep-phrase (prep in)
+               (s-noun-phrase (article the)
+                              (noun class)))))
+;Unspecified return value
+
+(amb)
+;No more alternatives
+|#
+
+#|
+(init-amb)
+;Value: done
+
+(pp
+ (parse
+  '(the professor lectures
+        to the student with the cat)))
+
+(sentence
+ (s-noun-phrase (article the) (noun professor))
+ (verb-phrase
+  (verb-phrase
+   (verb lectures)
+   (prep-phrase (prep to)
+                (s-noun-phrase (article the)
+                               (noun student))))
+  (prep-phrase (prep with)
+               (s-noun-phrase (article the)
+                              (noun cat)))))
+;Unspecified return value
+
+(amb)
+
+(sentence
+ (s-noun-phrase (article the) (noun professor))
+ (verb-phrase
+  (verb lectures)
+  (prep-phrase
+   (prep to)
+   (noun-phrase
+    (s-noun-phrase (article the)
+                   (noun student))
+    (prep-phrase (prep with)
+                 (s-noun-phrase (article the)
+                                (noun cat)))))))
+;Unspecified return value
+
+(amb)
+;No more alternatives
+|#
+
+;;;; File:  load.scm
+
+;; Fun with Continuations
+(load "funco")
+
+;; AMB Scheme extensions
+(load "ambsch")
+
+;; AMB Examples from SICP
+(load "examples")
+
+':have-fun!
diff --git a/ps07_amb/stack-queue.scm b/ps07_amb/stack-queue.scm
new file mode 100644
index 0000000..71f7c0e
--- /dev/null
+++ b/ps07_amb/stack-queue.scm
@@ -0,0 +1,52 @@
+;;;; Simple stack&queue Abstraction
+
+(declare (usual-integrations))
+
+(define-record-type <stack&queue>
+    (%make-stack&queue front back)
+    stack&queue?
+  (front stack&queue-front set-stack&queue-front!)
+  (back stack&queue-back set-stack&queue-back!))
+  
+
+(define (make-stack&queue)
+  (%make-stack&queue '() '()))
+
+(define (stack&queue-empty? stq)
+  (not (pair? (stack&queue-front stq))))
+
+(define (stack&queued? stq item)
+  (memq item (stack&queue-front stq)))
+
+(define (push! stq object)
+  (if (pair? (stack&queue-front stq))
+      (set-stack&queue-front! stq
+        (cons object (stack&queue-front stq)))
+      (begin
+	(set-stack&queue-front! stq
+	  (cons object (stack&queue-front stq)))
+	(set-stack&queue-back! stq
+	  (stack&queue-front stq))))
+  unspecific)
+
+(define (add-to-end! stq object)
+  (let ((new (cons object '())))
+    (if (pair? (stack&queue-back stq))
+	(set-cdr! (stack&queue-back stq) new)
+	(set-stack&queue-front! stq new))
+    (set-stack&queue-back! stq new)
+    unspecific))
+
+(define (pop! stq)
+  (let ((next (stack&queue-front stq)))
+    (if (not (pair? next))
+	(error "Empty stack&queue -- POP"))
+    (if (pair? (cdr next))
+	(set-stack&queue-front! stq (cdr next))
+	(begin
+	  (set-stack&queue-front! stq '())
+	  (set-stack&queue-back! stq '())))
+    (car next)))
+
+
+