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