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 \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 ]\r
  17     [ amb-failure ] if* ;\r
  18 \r
  19 : require ( ? -- )\r
  20     [ fail ] unless ;\r
  21 \r
  22 MACRO: checkpoint ( quot -- quot' )\r
  23     '[ failure get _\r
  24        '[ '[ failure set _ continue ] callcc0\r
  25           _ failure set @ ] callcc0 ] ;\r
  26 \r
  27 : number-from ( from -- from+n )\r
  28     [ 1 + number-from ] checkpoint ;\r
  29 \r
  30 <PRIVATE\r
  31 \r
  32 : unsafe-number-from-to ( to from -- to from+n )\r
  33     2dup = [ [ 1 + unsafe-number-from-to ] checkpoint ] unless ;\r
  34 \r
  35 : number-from-to ( to from -- to from+n )\r
  36     2dup < [ fail ] when unsafe-number-from-to ;\r
  37 \r
  38 : amb-integer ( seq -- int )\r
  39     length 1 - 0 number-from-to nip ;\r
  40 \r
  41 MACRO: unsafe-amb ( seq -- quot )\r
  42     dup length 1 =\r
  43     [ first 1quotation ]\r
  44     [ [ first ] [ rest ] bi\r
  45       '[ _ [ drop _ unsafe-amb ] checkpoint ] ] if ;\r
  46 \r
  47 PRIVATE> \r
  48 \r
  49 : amb-lazy ( seq -- elt )\r
  50     [ amb-integer ] [ nth ] bi ;\r
  51 \r
  52 : amb ( seq -- elt )\r
  53     [ fail f ]\r
  54     [ unsafe-amb ] if-empty ; inline\r
  55 \r
  56 MACRO: amb-execute ( seq -- quot )\r
  57     [ length 1 - ] [ <enum> [ 1quotation ] assoc-map ] bi\r
  58     '[ _ 0 unsafe-number-from-to nip _ case ] ;\r
  59 \r
  60 : if-amb ( true false -- )\r
  61     [\r
  62         [ { t f } amb ]\r
  63         [ '[ @ require t ] ]\r
  64         [ '[ @ f ] ]\r
  65         tri* if\r
  66     ] with-scope ; inline\r
  67 \r
  68 : cut-amb ( -- )\r
  69     f failure set ;\r