Data commit

Task/Amb/Scheme/amb-1.ss

@@ -0,0 +1,34 @@
+(define fail
+  (lambda ()
+    (error "Amb tree exhausted")))
+
+(define-syntax amb
+  (syntax-rules ()
+    ((AMB) (FAIL))                      ; Two shortcuts.
+    ((AMB expression) expression)
+
+    ((AMB expression ...)
+     (LET ((FAIL-SAVE FAIL))
+       ((CALL-WITH-CURRENT-CONTINUATION ; Capture a continuation to
+          (LAMBDA (K-SUCCESS)           ;   which we return possibles.
+            (CALL-WITH-CURRENT-CONTINUATION
+              (LAMBDA (K-FAILURE)       ; K-FAILURE will try the next
+                (SET! FAIL K-FAILURE)   ;   possible expression.
+                (K-SUCCESS              ; Note that the expression is
+                 (LAMBDA ()             ;   evaluated in tail position
+                   expression))))       ;   with respect to AMB.
+            ...
+            (SET! FAIL FAIL-SAVE)      ; Finally, if this is reached,
+            FAIL-SAVE)))))))            ;   we restore the saved FAIL.
+
+
+(let ((w-1 (amb "the" "that" "a"))
+      (w-2 (amb "frog" "elephant" "thing"))
+      (w-3 (amb "walked" "treaded" "grows"))
+      (w-4 (amb "slowly" "quickly")))
+  (define (joins? left right)
+    (equal? (string-ref left (- (string-length left) 1)) (string-ref right 0)))
+  (if (joins? w-1 w-2) '() (amb))
+  (if (joins? w-2 w-3) '() (amb))
+  (if (joins? w-3 w-4) '() (amb))
+  (list w-1 w-2 w-3 w-4))

Task/Amb/Scheme/amb-2.ss

@@ -0,0 +1,34 @@
+(define %fail-stack '())
+
+(define (%fail!)
+  (if (null? %fail-stack)
+      (error 'amb "Backtracking stack exhausted!")
+      (let ((backtrack (car %fail-stack)))
+        (set! %fail-stack (cdr %fail-stack))
+        (backtrack backtrack))))
+
+(define (amb choices)
+  (let ((cc (call-with-current-continuation values)))
+    (if (null? choices)
+        (%fail!)
+        (let ((choice (car choices)))
+          (set! %fail-stack (cons cc %fail-stack))
+          (set! choices (cdr choices))
+          choice))))
+
+(define (assert! condition)
+  (unless condition (%fail!)))
+
+;;; The list can contain as many lists as desired.
+(define words (list '("the" "that" "a")
+                    '("frog" "elephant" "thing")
+                    '("walked" "treaded" "grows")
+                    '("slowly" "quickly")))
+(define (joins? a b)
+  (char=? (string-ref a (sub1 (string-length a))) (string-ref b 0)))
+(let ((sentence (map amb words)))
+  (fold (lambda (x y)
+          (assert! (joins? x y))
+          y)
+        (car sentence) (cdr sentence))
+  sentence)