extra/combinators/lib/lib.factor

   1 ! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman,
   2 !                    Eduardo Cavazos, Daniel Ehrenberg.
   3 ! See http://factorcode.org/license.txt for BSD license.
   4 USING: kernel combinators namespaces quotations hashtables
   5 sequences assocs arrays inference effects math math.ranges
   6 arrays.lib shuffle macros bake combinators.cleave
   7 continuations ;
   8
   9 IN: combinators.lib
  10
  11 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  12
  13 : generate ( generator predicate -- obj )
  14     #! Call 'generator' until the result satisfies 'predicate'.
  15     [ slip over slip ] 2keep
  16     roll [ 2drop ] [ rot drop generate ] if ; inline
  17
  18 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  19 ! Generalized versions of core combinators
  20 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  21
  22 MACRO: ndip ( quot n -- ) dup saver -rot restorer 3append ;
  23
  24 MACRO: nslip ( n -- ) dup saver [ call ] rot restorer 3append ;
  25
  26 : 4slip ( quot a b c d -- a b c d ) 4 nslip ; inline
  27
  28 MACRO: nkeep ( n -- )
  29   [ ] [ 1+ ] [ ] tri
  30   [ [ , ndup ] dip , -nrot , nslip ]
  31   bake ;
  32
  33 : 4keep ( w x y z quot -- w x y z ) 4 nkeep ; inline
  34
  35 MACRO: ncurry ( n -- ) [ curry ] n*quot ;
  36
  37 MACRO: nwith ( quot n -- )
  38   tuck 1+ dup
  39   [ , -nrot [ , nrot , call ] , ncurry ]
  40   bake ;
  41
  42 MACRO: napply ( n -- )
  43   2 [a,b]
  44   [ [ ] [ 1- ] bi
  45     [ , ntuck , nslip ]
  46     bake ]
  47   map concat >quotation [ call ] append ;
  48
  49 : 3apply ( obj obj obj quot -- ) 3 napply ; inline
  50
  51 : dipd ( x y quot -- y ) 2 ndip ; inline
  52
  53 : 2with ( param1 param2 obj quot -- obj curry )
  54     with with ; inline
  55
  56 : 3with ( param1 param2 param3 obj quot -- obj curry )
  57     with with with ; inline
  58
  59 : with* ( obj assoc quot -- assoc curry )
  60     swapd [ [ -rot ] dip call ] 2curry ; inline
  61
  62 : 2with* ( obj1 obj2 assoc quot -- assoc curry )
  63     with* with* ; inline
  64
  65 : 3with* ( obj1 obj2 obj3 assoc quot -- assoc curry )
  66     with* with* with* ; inline
  67
  68 : assoc-each-with ( obj assoc quot -- )
  69     with* assoc-each ; inline
  70
  71 : assoc-map-with ( obj assoc quot -- assoc )
  72     with* assoc-map ; inline
  73
  74 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  75 ! short circuiting words
  76 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  77
  78 : short-circuit ( quots quot default -- quot )
  79   1quotation -rot { } map>assoc <reversed> alist>quot ;
  80
  81 MACRO: && ( quots -- ? )
  82     [ [ not ] append [ f ] ] t short-circuit ;
  83
  84 MACRO: <-&& ( quots -- )
  85     [ [ dup ] swap append [ not ] append [ f ] ] t short-circuit
  86     [ nip ] append ;
  87
  88 MACRO: <--&& ( quots -- )
  89     [ [ 2dup ] swap append [ not ] append [ f ] ] t short-circuit
  90     [ 2nip ] append ;
  91
  92 MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
  93
  94 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  95 ! ifte
  96 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  97
  98 MACRO: ifte ( quot quot quot -- )
  99     pick infer effect-in
 100     dup 1+ swap
 101     [ >r >r , nkeep , nrot r> r> if ]
 102     bake ;
 103
 104 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 105 ! switch
 106 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 107
 108 : preserving ( predicate -- quot )
 109     dup infer effect-in
 110     dup 1+ spin
 111     [ , , nkeep , nrot ]
 112     bake ;
 113
 114 MACRO: switch ( quot -- )
 115     [ [ preserving ] [ ] bi* ] assoc-map
 116     [ , cond ]
 117     bake ;
 118
 119 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 120
 121 ! Conceptual implementation:
 122
 123 ! : pcall ( seq quots -- seq ) [ call ] 2map ;
 124
 125 MACRO: parallel-call ( quots -- )
 126     [ [ unclip % r> dup >r push ] bake ] map concat
 127     [ V{ } clone >r % drop r> >array ] bake ;
 128
 129 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 130 ! map-call and friends
 131 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 132
 133 : (make-call-with) ( quots -- quot )
 134     [ [ keep ] curry ] map concat [ drop ] append ;
 135
 136 MACRO: call-with ( quots -- )
 137     (make-call-with) ;
 138
 139 MACRO: map-call-with ( quots -- )
 140     [ (make-call-with) ] keep length [ narray ] curry compose ;
 141
 142 : (make-call-with2) ( quots -- quot )
 143     [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
 144     [ 2drop ] append ;
 145
 146 MACRO: call-with2 ( quots -- )
 147     (make-call-with2) ;
 148
 149 MACRO: map-call-with2 ( quots -- )
 150     [ (make-call-with2) ] keep length [ narray ] curry append ;
 151
 152 MACRO: map-exec-with ( words -- )
 153     [ 1quotation ] map [ map-call-with ] curry ;
 154
 155 MACRO: construct-slots ( assoc tuple-class -- tuple )
 156     [ construct-empty ] curry swap [
 157         [ dip ] curry swap 1quotation [ keep ] curry compose
 158     ] { } assoc>map concat compose ;
 159
 160 : either ( object first second -- ? )
 161     >r keep swap [ r> drop ] [ r> call ] ?if ; inline
 162
 163 : 2quot-with ( obj seq quot1 quot2 -- seq quot1 quot2 )
 164     >r pick >r with r> r> swapd with ;
 165
 166 : or? ( obj quot1 quot2 -- ? )
 167     >r keep r> rot [ 2nip ] [ call ] if* ; inline
 168
 169 : and? ( obj quot1 quot2 -- ? )
 170     >r keep r> rot [ call ] [ 2drop f ] if ; inline
 171
 172 : retry ( quot n -- )
 173     [ drop ] rot compose attempt-all ; inline