extra/combinators/extras/extras.factor

   1 ! Copyright (C) 2013 Doug Coleman, John Benediktsson.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs combinators combinators.smart
   4 generalizations graphs.private kernel math math.order namespaces
   5 quotations sequences sequences.generalizations sequences.private
   6 sets shuffle stack-checker.transforms system words ;
   7 IN: combinators.extras
   8
   9 : callk ( ..a quot: ( ..a -- ..b ) -- ..b quot )
  10     dup [ call ] dip ; inline
  11
  12 : once ( quot -- ) call ; inline
  13 : twice ( quot -- ) callk call ; inline
  14 : thrice ( quot -- ) callk callk call ; inline
  15 : forever ( quot -- ) [ t ] compose loop ; inline
  16
  17 MACRO: cond-case ( assoc -- quot )
  18     [
  19         dup callable? not [
  20             [ first [ dup ] prepose ]
  21             [ second [ drop ] prepose ] bi 2array
  22         ] when
  23     ] map [ cond ] curry ;
  24
  25 MACRO: cleave-array ( quots -- quot )
  26     [ '[ _ cleave ] ] [ length '[ _ narray ] ] bi compose ;
  27
  28 : 3bi* ( u v w x y z p q -- )
  29     [ 3dip ] dip call ; inline
  30
  31 : 3bi@ ( u v w x y z quot -- )
  32     dup 3bi* ; inline
  33
  34 : 4bi ( w x y z p q -- )
  35     [ 4keep ] dip call ; inline
  36
  37 : 4bi* ( s t u v w x y z p q -- )
  38     [ 4dip ] dip call ; inline
  39
  40 : 4tri* ( o p q r  s t u v  w x y z  p q r -- )
  41     [ 8 ndip ] 2dip
  42     [ 4dip ] dip
  43     call ; inline
  44
  45 : 4bi@ ( s t u v  w x y z  quot -- )
  46     dup 4bi* ; inline
  47
  48 : 4tri@ ( a b c d  e f g h  i j k l  quot -- )
  49     dup dup 4tri* ; inline
  50
  51 : 4tri ( w x y z  p q r -- )
  52     [ [ 4keep ] dip 4keep ] dip call ; inline
  53
  54 : 4quad ( w x y z  p q r s -- )
  55     [ [ [ 4keep ] dip 4keep ] dip 4keep ] dip call ; inline
  56
  57 : quad* ( w x y z p q r s -- ) [ [ [ 3dip ] dip 2dip ] dip dip ] dip call ; inline
  58
  59 : quad@ ( w x y z quot -- ) dup dup dup quad* ; inline
  60
  61 MACRO: smart-plox ( true -- quot )
  62     [ inputs [ 1 - [ and ] n*quot ] keep ] keep swap
  63     '[ _ _ [ _ ndrop f ] smart-if ] ;
  64
  65 : throttle ( quot millis -- quot' )
  66     1,000,000 * '[
  67         _ nano-count { 0 } 2dup first-unsafe _ + >=
  68         [ 0 swap set-nth-unsafe call ] [ 3drop ] if
  69     ] ; inline
  70
  71 : swap-when ( x y quot: ( x -- n ) quot: ( n n -- ? ) -- x' y' )
  72     '[ _ _ 2dup _ bi@ @ [ swap ] when ] call ; inline
  73
  74
  75 ! ?1arg-result-falsify
  76
  77 : 1falsify ( obj/f -- obj/f ) ; inline
  78 : 2falsify ( obj1 obj2 -- obj1/f obj2/f ) 2dup and [ 2drop f f ] unless ; inline
  79 : 3falsify ( obj1 obj2 obj3 -- obj1/f obj2/f obj3/f ) 3dup and and [ 3drop f f f ] unless ; inline
  80
  81 MACRO: n-and ( n -- quot )
  82     1 [-] [ and ] n*quot ;
  83
  84 MACRO: n*obj ( n obj -- quot )
  85     1quotation n*quot ;
  86
  87 MACRO:: n-falsify ( n -- quot )
  88     [ n ndup n n-and [ n ndrop n f n*obj ] unless ] ;
  89
  90 ! plox
  91 : ?1res ( ..a obj/f quot -- ..b )
  92     dupd when ; inline
  93
  94 ! when both args are true, call quot. otherwise dont
  95 : ?2res ( ..a obj1 obj2 quot: ( obj1 obj2 -- ? ) -- ..b )
  96     [ 2dup and ] dip [ 2drop f ] if ; inline
  97
  98 ! try the quot, keep the original arg if quot is true
  99 : ?1arg ( obj quot: ( obj -- ? ) -- obj/f )
 100     [ ?1res ] keepd '[ _ ] [ f ] if ; inline
 101
 102 : ?2arg ( obj1 obj2 quot: ( obj1 obj2 -- ? ) -- obj1/f obj2/f )
 103     [ ?2res ] 2keepd '[ _ _ ] [ f f ] if ; inline
 104
 105 <<
 106 : alist>quot* ( default assoc -- quot )
 107     [ rot \ if* 3array [ ] append-as ] assoc-each ;
 108
 109 : cond*>quot ( assoc -- quot )
 110     [ dup pair? [ [ drop ] prepend [ t ] swap 2array ] unless ] map
 111     reverse! [ no-cond ] swap alist>quot* ;
 112
 113 DEFER: cond*
 114 \ cond* [ cond*>quot ] 1 define-transform
 115 \ cond* t "no-compile" set-word-prop
 116 >>
 117 : cond* ( assoc -- )
 118     [ dup callable? [ drop t ] [ first call ] if ] map-find
 119     [ dup callable? [ nip call ] [ second call ] if ]
 120     [ no-cond ] if* ;
 121
 122 MACRO: chain ( quots -- quot )
 123     <reversed> [ ] [ swap '[ [ @ @ ] [ f ] if* ] ] reduce ;
 124
 125 : with-output-variable ( value variable quot -- value )
 126     over [ get ] curry compose with-variable ; inline
 127
 128 : loop1 ( ..a quot: ( ..a -- ..a obj ? ) -- ..a obj )
 129     [ call ] keep '[ drop _ loop1 ] when ; inline recursive
 130
 131
 132 : keep-1up ( quot -- quot ) keep 1 2 0 nrotated ; inline
 133 : keep-2up ( quot -- quot ) keep 2 3 0 nrotated ; inline
 134 : keep-3up ( quot -- quot ) keep 3 4 0 nrotated ; inline
 135
 136 : 2keep-1up ( quot -- quot ) 2keep 1 3 0 nrotated ; inline
 137 : 2keep-2up ( quot -- quot ) 2keep 2 4 0 nrotated ; inline
 138 : 2keep-3up ( quot -- quot ) 2keep 3 5 0 nrotated ; inline
 139
 140 : 3keep-1up ( quot -- quot ) 3keep 1 4 0 nrotated ; inline
 141 : 3keep-2up ( quot -- quot ) 3keep 2 5 0 nrotated ; inline
 142 : 3keep-3up ( quot -- quot ) 3keep 3 6 0 nrotated ; inline
 143
 144 ! d is dummy, o is object to save notation space
 145 : dip-1up  ( ..a d quot: ( ..a -- ..b o d ) -- ..b d o )
 146     dip swap ; inline
 147 : dip-2up  ( ..a d quot: ( ..a -- ..b o1 o2 d ) -- ..b d o1 o2 )
 148     dip rot rot ; inline
 149
 150 : 2dip-1up ( ..a d1 d2 quot: ( ..a -- ..b o d1 d2 ) -- ..b d1 d2 o )
 151     2dip rot ; inline
 152 : 2dip-2up ( ..a d1 d2 quot: ( ..a -- ..b o1 o2 d1 d2 ) -- ..b d1 d2 o1 o2 )
 153     2dip roll roll ; inline
 154
 155 : 3dip-1up ( ..a d1 d2 d3 quot: ( ..a -- ..b o d1 d2 d3 ) -- ..b d1 d2 d3 o )
 156     3dip roll ; inline
 157 : 3dip-2up ( ..a d1 d2 d3 quot: ( ..a -- ..b o1 o2 d1 d2 d3 ) -- ..b d1 d2 d3 o1 o2 )
 158     3dip 2 5 0 nrotated ; inline
 159 : 3dip-3up ( ..a d1 d2 d3 quot: ( ..a -- ..b o1 o2 o3 d1 d2 d3 ) -- ..b d1 d2 d3 o1 o2 o3 )
 160     3dip 3 6 0 nrotated ; inline
 161
 162
 163 : 2craft-1up ( ..a quot1: ( ..a -- ..b o1 ) quot2: ( ..b -- ..c o2 ) -- ..c o1 o2 )
 164     [ call ] dip [ dip-1up ] call ; inline
 165
 166 : 3craft-1up ( ..a quot1: ( ..a -- ..b o1 ) quot2: ( ..b -- ..c o2 ) quot3: ( ..c -- ..d o3 ) -- ..d o1 o2 o3 )
 167     [ call ] 2dip [ dip-1up ] dip [ 2dip-1up ] call ; inline
 168
 169 : 4craft-1up ( ..a quot1: ( ..a -- ..b o1 ) quot2: ( ..b -- ..c o2 ) quot3: ( ..c -- ..d o3 ) quot4: ( ..d -- ..e o4 ) -- ..e o1 o2 o3 o4 )
 170     [ call ] 3dip [ dip-1up ] 2dip [ 2dip-1up ] dip [ 3dip-1up ] call ; inline
 171
 172 : 3and ( a b c -- ? ) and and ; inline
 173 : 4and ( a b c d -- ? ) and and and ; inline
 174
 175 : 3or ( a b c -- ? ) or or ; inline
 176 : 4or ( a b c d -- ? ) or or or ; inline
 177
 178 ! The kept values are on the bottom of the stack
 179 MACRO: keep-under ( quot -- quot' )
 180     dup outputs 1 + '[ _ keep 1 _ 0 -nrotated ] ;
 181
 182 MACRO: 2keep-under ( quot -- quot' )
 183     dup outputs 2 + '[ _ 2keep 2 _ 0 -nrotated ] ;
 184
 185 MACRO: 3keep-under ( quot -- quot' )
 186     dup outputs 3 + '[ _ 3keep 3 _ 0 -nrotated ] ;
 187
 188 MACRO: 4keep-under ( quot -- quot' )
 189     dup outputs 4 + '[ _ 4keep 4 _ 0 -nrotated ] ;
 190
 191 ! for use with assoc-map etc
 192 : 1temp1d ( quot: ( a b c -- d e f ) -- quot ) '[ swap @ swap ] ; inline
 193 : 1temp2d ( quot: ( a b c -- d e f ) -- quot ) '[ rot @ -rot ] ; inline
 194 : 2temp2d ( quot: ( a b c d -- e f g h ) -- quot ) '[ 2 4 0 nrotated @ 2 4 0 -nrotated ] ; inline
 195
 196  : (closure-limit) ( vertex set quot: ( vertex -- edges ) i n -- )
 197     2dup < [
 198         [ 1 + ] dip
 199         2reach ?adjoin [
 200             [ [ dip ] keep ] 2dip [ (closure-limit) ] 2curry 2curry each
 201         ] [ 5drop ] if
 202     ] [
 203         5drop
 204     ] if ; inline recursive
 205
 206 : closure-limit-as ( vertex quot: ( vertex -- edges ) n exemplar -- set )
 207     [ 0 ] 2dip
 208     new-empty-set-like [ -roll (closure-limit) ] keep ; inline
 209
 210 : closure-limit ( vertex quot: ( vertex -- edges ) n -- set )
 211     HS{ } closure-limit-as ; inline
 212
 213 : 1check ( obj quot -- obj ? ) over [ call ] dip swap ; inline
 214 : 2check ( obj1 obj2 quot -- obj ? ) 2over [ call ] 2dip rot ; inline
 215
 216 : 1check-when ( ..a obj cond: ( ..a obj -- obj/f ) true: ( ..a obj cond -- ..b ) -- ..b )
 217     [ 1check ] dip when ; inline
 218 : 2check-when ( ..a obj1 obj2 cond: ( ..a obj1 obj2 -- obj/f ) true: ( ..a obj1 obj2 cond -- ..b ) -- ..b )
 219     [ 2check ] dip when ; inline