extra/backtrack/backtrack.factor

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