From bfd30bfc1096486f0781e9caea3b15161488f3f6 Mon Sep 17 00:00:00 2001 From: bnewbold Date: Fri, 27 Mar 2009 19:57:08 -0400 Subject: ps07 assignment --- ps07_amb/ambsch.scm | 336 ++++++++++++ ps07_amb/examples.scm | 189 +++++++ ps07_amb/funco.scm | 223 ++++++++ ps07_amb/load.scm | 11 + ps07_amb/ps.txt | 1355 ++++++++++++++++++++++++++++++++++++++++++++++ ps07_amb/stack-queue.scm | 52 ++ 6 files changed, 2166 insertions(+) create mode 100644 ps07_amb/ambsch.scm create mode 100644 ps07_amb/examples.scm create mode 100644 ps07_amb/funco.scm create mode 100644 ps07_amb/load.scm create mode 100644 ps07_amb/ps.txt create mode 100644 ps07_amb/stack-queue.scm 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 ... ) ==> + (amb-list (list (lambda () ) ... (lambda () ))) + +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 ) + (with-right-to-left-alternation ) + (with-random-order-alternation ) + +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 + (%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))) + + + -- cgit v1.2.3