extra/combinators/lib/lib.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov, Chris Double,
   2 !                          Doug Coleman, Eduardo Cavazos,
   3 !                          Daniel Ehrenberg.
   4 ! See http://factorcode.org/license.txt for BSD license.
   5 USING: kernel combinators fry namespaces make quotations hashtables
   6 sequences assocs arrays stack-checker effects math math.ranges
   7 generalizations macros continuations random locals accessors ;
   8
   9 IN: combinators.lib
  10
  11 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  12 ! Currying cleave combinators
  13 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  14
  15 : bi, ( obj quot quot -- quot' quot' )
  16     [ [ curry ] curry ] bi@ bi ; inline
  17 : tri, ( obj quot quot quot -- quot' quot' quot' )
  18     [ [ curry ] curry ] tri@ tri ; inline
  19
  20 : bi*, ( obj obj quot quot -- quot' quot' )
  21     [ [ curry ] curry ] bi@ bi* ; inline
  22 : tri*, ( obj obj obj quot quot quot -- quot' quot' quot' )
  23     [ [ curry ] curry ] tri@ tri* ; inline
  24
  25 : bi@, ( obj obj quot -- quot' quot' )
  26     [ curry ] curry bi@ ; inline
  27 : tri@, ( obj obj obj quot -- quot' quot' quot' )
  28     [ curry ] curry tri@ ; inline
  29
  30 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  31 ! Generalized versions of core combinators
  32 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  33
  34 : quad ( x p q r s -- ) >r >r >r keep r> keep r> keep r> call ; inline
  35
  36 : 4slip ( quot a b c d -- a b c d ) 4 nslip ; inline
  37
  38 : 4keep ( w x y z quot -- w x y z ) 4 nkeep ; inline
  39
  40 : 2with ( param1 param2 obj quot -- obj curry )
  41     with with ; inline
  42
  43 : 3with ( param1 param2 param3 obj quot -- obj curry )
  44     with with with ; inline
  45
  46 : with* ( obj assoc quot -- assoc curry )
  47     swapd [ [ -rot ] dip call ] 2curry ; inline
  48
  49 : 2with* ( obj1 obj2 assoc quot -- assoc curry )
  50     with* with* ; inline
  51
  52 : 3with* ( obj1 obj2 obj3 assoc quot -- assoc curry )
  53     with* with* with* ; inline
  54
  55 : assoc-each-with ( obj assoc quot -- )
  56     with* assoc-each ; inline
  57
  58 : assoc-map-with ( obj assoc quot -- assoc )
  59     with* assoc-map ; inline
  60
  61 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  62 ! ifte
  63 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  64
  65 MACRO: preserving ( predicate -- quot )
  66     dup infer in>>
  67     dup 1+
  68     '[ _ _ nkeep _ nrot ] ;
  69
  70 MACRO: ifte ( quot quot quot -- )
  71     '[ _ preserving _ _ if ] ;
  72
  73 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  74 ! switch
  75 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  76
  77 MACRO: switch ( quot -- )
  78     [ [ [ preserving ] curry ] dip ] assoc-map
  79     [ cond ] curry ;
  80
  81 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  82
  83 ! Conceptual implementation:
  84
  85 ! : pcall ( seq quots -- seq ) [ call ] 2map ;
  86
  87 MACRO: parallel-call ( quots -- )
  88     [ '[ [ unclip @ ] dip [ push ] keep ] ] map concat
  89     '[ V{ } clone @ nip >array ] ;
  90
  91 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  92 ! map-call and friends
  93 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  94
  95 : (make-call-with) ( quots -- quot )
  96     [ [ keep ] curry ] map concat [ drop ] append ;
  97
  98 MACRO: map-call-with ( quots -- )
  99     [ (make-call-with) ] keep length [ narray ] curry compose ;
 100
 101 : (make-call-with2) ( quots -- quot )
 102     [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat
 103     [ 2drop ] append ;
 104
 105 MACRO: map-call-with2 ( quots -- )
 106     [
 107         [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat
 108         [ 2drop ] append
 109     ] keep length [ narray ] curry append ;
 110
 111 MACRO: map-exec-with ( words -- )
 112     [ 1quotation ] map [ map-call-with ] curry ;
 113
 114 MACRO: construct-slots ( assoc tuple-class -- tuple )
 115     [ new ] curry swap [
 116         [ dip ] curry swap 1quotation [ keep ] curry compose
 117     ] { } assoc>map concat compose ;
 118
 119 : either ( object first second -- ? )
 120     >r keep swap [ r> drop ] [ r> call ] ?if ; inline
 121
 122 : 2quot-with ( obj seq quot1 quot2 -- seq quot1 quot2 )
 123     >r pick >r with r> r> swapd with ;
 124
 125 : or? ( obj quot1 quot2 -- ? )
 126     >r keep r> rot [ 2nip ] [ call ] if* ; inline
 127
 128 : and? ( obj quot1 quot2 -- ? )
 129     >r keep r> rot [ call ] [ 2drop f ] if ; inline
 130
 131 MACRO: multikeep ( word out-indexes -- ... )
 132     [
 133         dup >r [ \ npick \ >r 3array % ] each
 134         %
 135         r> [ drop \ r> , ] each
 136     ] [ ] make ;
 137
 138 : retry ( quot n -- )
 139     [ drop ] rot compose attempt-all ; inline
 140
 141 : do-while ( pred body tail -- )
 142     >r tuck 2slip r> while ; inline
 143
 144 : generate ( generator predicate -- obj )
 145     [ dup ] swap [ dup [ nip ] unless not ] 3compose
 146     swap [ ] do-while ;
 147
 148 MACRO: predicates ( seq -- quot/f )
 149     dup [ 1quotation [ drop ] prepend ] map
 150     >r [ [ dup ] prepend ] map r> zip [ drop f ] suffix
 151     [ cond ] curry ;
 152
 153 : %chance ( quot n -- ) 100 random > swap when ; inline