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: assocs combinators continuations fry kernel macros math\r
   5 namespaces quotations sequences summary ;\r
   6 \r
   7 IN: backtrack\r
   8 \r
   9 SYMBOL: failure\r
  10 \r
  11 ERROR: amb-failure ;\r
  12 \r
  13 M: amb-failure summary drop "Backtracking failure" ;\r
  14 \r
  15 : fail ( -- )\r
  16     failure get [ continue ] [ amb-failure ] if* ;\r
  17 \r
  18 : must-be-true ( ? -- )\r
  19     [ fail ] unless ;\r
  20 \r
  21 MACRO: checkpoint ( quot -- quot' )\r
  22     '[\r
  23         failure get _ '[\r
  24             '[ failure set _ continue ] callcc0\r
  25             _ failure set @\r
  26         ] callcc0\r
  27     ] ;\r
  28 \r
  29 : number-from ( from -- from+n )\r
  30     [ 1 + number-from ] checkpoint ;\r
  31 \r
  32 <PRIVATE\r
  33 \r
  34 : preserve ( quot var -- ) [ get [ call ] dip ] keep set ; inline\r
  35 \r
  36 : amb-preserve ( quot -- ) failure preserve ; inline\r
  37 \r
  38 : unsafe-number-from-to ( to from -- to from+n )\r
  39     2dup = [ [ 1 + unsafe-number-from-to ] checkpoint ] unless ;\r
  40 \r
  41 : number-from-to ( to from -- to from+n )\r
  42     2dup < [ fail ] when unsafe-number-from-to ;\r
  43 \r
  44 : amb-integer ( seq -- int )\r
  45     length 1 - 0 number-from-to nip ;\r
  46 \r
  47 MACRO: unsafe-amb ( seq -- quot )\r
  48     dup length 1 = [\r
  49         first 1quotation\r
  50     ] [\r
  51         unclip swap '[ _ [ drop _ unsafe-amb ] checkpoint ]\r
  52     ] if ;\r
  53 \r
  54 PRIVATE> \r
  55 \r
  56 : amb-lazy ( seq -- elt )\r
  57     [ amb-integer ] [ nth ] bi ;\r
  58 \r
  59 : amb ( seq -- elt )\r
  60     [ fail f ] [ unsafe-amb ] if-empty ; inline\r
  61 \r
  62 MACRO: amb-execute ( seq -- quot )\r
  63     [ length 1 - ] [ <enum> [ 1quotation ] assoc-map ] bi\r
  64     '[ _ 0 unsafe-number-from-to nip _ case ] ;\r
  65 \r
  66 : if-amb ( true false -- ? )\r
  67     [\r
  68         [ { t f } amb ]\r
  69         [ '[ @ must-be-true t ] ]\r
  70         [ '[ @ f ] ]\r
  71         tri* if\r
  72     ] amb-preserve ; inline\r
  73 \r
  74 : cut-amb ( -- )\r
  75     f failure set ;\r
  76 \r
  77 : amb-all ( quot -- )\r
  78     [ { t f } amb [ call fail ] [ drop ] if ] amb-preserve ; inline\r
  79 \r
  80 : bag-of ( quot -- seq )\r
  81     V{ } clone [ '[ @ _ push ] amb-all ] keep ; inline\r