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 : preserve ( quot var -- ) [ get [ call ] dip ] keep set ; inline\r
  33 \r
  34 : amb-preserve ( quot -- ) failure preserve ; inline\r
  35 \r
  36 : unsafe-number-from-to ( to from -- to from+n )\r
  37     2dup = [ [ 1 + unsafe-number-from-to ] checkpoint ] unless ;\r
  38 \r
  39 : number-from-to ( to from -- to from+n )\r
  40     2dup < [ fail ] when unsafe-number-from-to ;\r
  41 \r
  42 : amb-integer ( seq -- int )\r
  43     length 1 - 0 number-from-to nip ;\r
  44 \r
  45 MACRO: unsafe-amb ( seq -- quot )\r
  46     dup length 1 =\r
  47     [ first 1quotation ]\r
  48     [ [ first ] [ rest ] bi\r
  49       '[ _ [ drop _ unsafe-amb ] checkpoint ] ] if ;\r
  50 \r
  51 PRIVATE> \r
  52 \r
  53 : amb-lazy ( seq -- elt )\r
  54     [ amb-integer ] [ nth ] bi ;\r
  55 \r
  56 : amb ( seq -- elt )\r
  57     [ fail f ]\r
  58     [ unsafe-amb ] if-empty ; inline\r
  59 \r
  60 MACRO: amb-execute ( seq -- quot )\r
  61     [ length 1 - ] [ <enum> [ 1quotation ] assoc-map ] bi\r
  62     '[ _ 0 unsafe-number-from-to nip _ case ] ;\r
  63 \r
  64 : if-amb ( true false -- ? )\r
  65     [\r
  66         [ { t f } amb ]\r
  67         [ '[ @ require t ] ]\r
  68         [ '[ @ f ] ]\r
  69         tri* if\r
  70     ] amb-preserve ; inline\r
  71 \r
  72 : cut-amb ( -- )\r
  73     f failure set ;\r
  74 \r
  75 : amb-all ( quot -- )\r
  76     [ { t f } amb [ call fail ] [ drop ] if ] amb-preserve ; inline\r
  77 \r
  78 : bag-of ( quot -- seq )\r
  79     V{ } clone [ '[ @ _ push ] amb-all ] keep ; inline\r