Improved backtracking

extra/backtrack/backtrack.factor

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