extra/backtrack/backtrack.factor

   1 ! Copyright (C) 2008 William Schlieper\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 \r
   4 USING: kernel continuations combinators sequences quotations arrays namespaces\r
   5        fry summary assocs math math.order macros ;\r
   6 \r
   7 IN: backtrack\r
   8 \r
   9 SYMBOL: failure\r
  10 V{ } failure set-global\r
  11 \r
  12 ERROR: amb-failure ;\r
  13 \r
  14 M: amb-failure summary drop "Backtracking failure" ;\r
  15 \r
  16 : fail ( -- )\r
  17     failure get dup empty? [ amb-failure ]\r
  18     [ pop continue ] if ;\r
  19 \r
  20 : require ( ? -- )\r
  21     [ fail ] unless ;\r
  22 \r
  23 MACRO: checkpoint ( quot -- quot' )\r
  24     '[ [ '[ failure get push , continue ] callcc0 @ ] callcc0 ] ;\r
  25 \r
  26 : number-from ( from -- from+n )\r
  27     [ 1 + number-from ] checkpoint ;\r
  28 \r
  29 <PRIVATE\r
  30 \r
  31 : number-from-to ( to from -- to from+n )\r
  32     2dup <=>\r
  33     { { +lt+ [ fail ] }\r
  34       { +eq+ [ ] }\r
  35       { +gt+ [ [ 1 + number-from-to ] checkpoint ] } } case ;\r
  36 \r
  37 : amb-integer ( seq -- int )\r
  38     length 1 - 0 number-from-to nip ;\r
  39 \r
  40 PRIVATE> \r
  41 \r
  42 : amb-lazy ( seq -- elt )\r
  43     [ amb-integer ] [ nth ] bi ;\r
  44 \r
  45 MACRO: amb ( seq -- quot )\r
  46     dup length\r
  47     { { 0 [ drop [ fail f ] ] }\r
  48       { 1 [ first 1quotation ] }\r
  49       [ drop [ first ] [ rest ] bi\r
  50         '[ , [ drop , amb ] checkpoint ] ] } case ;\r
  51 \r
  52 MACRO: amb-execute ( seq -- quot )\r
  53     [ length ] [ <enum> [ 1quotation ] assoc-map ] bi\r
  54     '[ , amb , case ] ;\r
  55 \r
  56 : if-amb ( true false -- )\r
  57     [\r
  58         [ { t f } amb ]\r
  59         [ '[ @ require t ] ]\r
  60         [ '[ @ f ] ]\r
  61         tri* if\r
  62     ] with-scope ; inline\r
  63 \r