Improved backtracking

diff --git a/extra/backtrack/backtrack.factor b/extra/backtrack/backtrack.factor
index 7ab11abd6dc508ab6348556b3ca1e6201a10c208..22c9afb322c310dc990bfd122e5f2c2bfc717a79 100755 (executable)
--- a/extra/backtrack/backtrack.factor
+++ b/extra/backtrack/backtrack.factor
@@ -1,20 +1,63 @@
 ! Copyright (C) 2008 William Schlieper\r
 ! See http://factorcode.org/license.txt for BSD license.\r
 \r
-USING: kernel continuations sequences namespaces fry ;\r
+USING: kernel continuations combinators sequences quotations arrays namespaces\r
+       fry summary assocs math math.order macros ;\r
 \r
 IN: backtrack\r
 \r
 SYMBOL: failure\r
+V{ } failure set-global\r
 \r
-: amb ( seq -- elt )\r
-    failure get\r
-    '[ , _ '[ , '[ failure set , , continue-with ] callcc0 ] each\r
-       , continue ] callcc1 ;\r
+ERROR: amb-failure ;\r
+\r
+M: amb-failure summary drop "Backtracking failure" ;\r
 \r
 : fail ( -- )\r
-    f amb drop ;\r
+    failure get dup empty? [ amb-failure ]\r
+    [ pop continue ] if ;\r
 \r
 : require ( ? -- )\r
     [ fail ] unless ;\r
 \r
+MACRO: checkpoint ( quot -- quot' )\r
+    '[ [ '[ failure get push , continue ] callcc0 @ ] callcc0 ] ;\r
+\r
+: number-from ( from -- from+n )\r
+    [ 1 + number-from ] checkpoint ;\r
+\r
+<PRIVATE\r
+\r
+: number-from-to ( to from -- to from+n )\r
+    2dup <=>\r
+    { { +lt+ [ fail ] }\r
+      { +eq+ [ ] }\r
+      { +gt+ [ [ 1 + number-from-to ] checkpoint ] } } case ;\r
+\r
+: amb-integer ( seq -- int )\r
+    length 1 - 0 number-from-to nip ;\r
+\r
+PRIVATE> \r
+\r
+: amb-lazy ( seq -- elt )\r
+    [ amb-integer ] [ nth ] bi ;\r
+\r
+MACRO: amb ( seq -- quot )\r
+    dup length\r
+    { { 0 [ drop [ fail f ] ] }\r
+      { 1 [ first 1quotation ] }\r
+      [ drop [ first ] [ rest ] bi\r
+        '[ , [ drop , amb ] checkpoint ] ] } case ;\r
+\r
+MACRO: amb-execute ( seq -- quot )\r
+    [ length ] [ <enum> [ 1quotation ] assoc-map ] bi\r
+    '[ , amb , case ] ;\r
+\r
+: if-amb ( true false -- )\r
+    [\r
+        [ { t f } amb ]\r
+        [ '[ @ require t ] ]\r
+        [ '[ @ f ] ]\r
+        tri* if\r
+    ] with-scope ; inline\r
+\r