diff options
author | bnewbold <bnewbold@eta.mit.edu> | 2009-03-27 19:57:08 -0400 |
---|---|---|
committer | bnewbold <bnewbold@eta.mit.edu> | 2009-03-27 19:57:08 -0400 |
commit | bfd30bfc1096486f0781e9caea3b15161488f3f6 (patch) | |
tree | ddfec6b61bbf2d1ec4631469ae78e9e541e4a3cf /ps07_amb/ambsch.scm | |
parent | 648b3b85668e68e6b4676cbe01e530baec653d4a (diff) | |
download | 6.945-bfd30bfc1096486f0781e9caea3b15161488f3f6.tar.gz 6.945-bfd30bfc1096486f0781e9caea3b15161488f3f6.zip |
ps07 assignment
Diffstat (limited to 'ps07_amb/ambsch.scm')
-rw-r--r-- | ps07_amb/ambsch.scm | 336 |
1 files changed, 336 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 +|# |