extra/combinators/extras/extras.factor

   1 ! Copyright (C) 2013 Doug Coleman, John Benediktsson.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs combinators combinators.smart fry
   4 generalizations kernel macros math quotations sequences locals
   5 math.order sequences.generalizations sequences.private
   6 stack-checker.transforms system words ;
   7 IN: combinators.extras
   8
   9 : once ( quot -- ) call ; inline
  10 : twice ( quot -- ) dup [ call ] dip call ; inline
  11 : thrice ( quot -- ) dup dup [ call ] 2dip [ call ] dip call ; inline
  12 : forever ( quot -- ) [ t ] compose loop ; inline
  13
  14 MACRO: cond-case ( assoc -- quot )
  15     [
  16         dup callable? not [
  17             [ first [ dup ] prepose ]
  18             [ second [ drop ] prepose ] bi 2array
  19         ] when
  20     ] map [ cond ] curry ;
  21
  22 MACRO: cleave-array ( quots -- quot )
  23     [ '[ _ cleave ] ] [ length '[ _ narray ] ] bi compose ;
  24
  25 : 3bi* ( u v w x y z p q -- )
  26     [ 3dip ] dip call ; inline
  27
  28 : 3bi@ ( u v w x y z quot -- )
  29     dup 3bi* ; inline
  30
  31 : 4bi ( w x y z p q -- )
  32     [ 4keep ] dip call ; inline
  33
  34 : 4bi* ( s t u v w x y z p q -- )
  35     [ 4dip ] dip call ; inline
  36
  37 : 4bi@ ( s t u v w x y z quot -- )
  38     dup 4bi* ; inline
  39
  40 : 4tri ( w x y z p q r -- )
  41     [ [ 4keep ] dip 4keep ] dip call ; inline
  42
  43 : plox ( ... x/f quot: ( ... x -- ... ) -- ... )
  44     dupd when ; inline
  45
  46 MACRO: smart-plox ( true -- quot )
  47     [ inputs [ 1 - [ and ] n*quot ] keep ] keep swap
  48     '[ _ _ [ _ ndrop f ] smart-if ] ;
  49
  50 : throttle ( quot millis -- quot' )
  51     1,000,000 * '[
  52         _ nano-count { 0 } 2dup first-unsafe _ + >=
  53         [ 0 swap set-nth-unsafe call ] [ 3drop ] if
  54     ] ; inline
  55
  56 : swap-when ( x y quot: ( x -- n ) quot: ( n n -- ? ) -- x' y' )
  57     '[ _ _ 2dup _ bi@ @ [ swap ] when ] call ; inline
  58
  59
  60 ! ?1arg-result-falsify
  61
  62 : 1falsify ( obj/f -- obj/f ) ; inline
  63 : 2falsify ( obj1 obj2 -- obj1/f obj2/f ) 2dup and [ 2drop f f ] unless ; inline
  64 : 3falsify ( obj1 obj2 obj3 -- obj1/f obj2/f obj3/f ) 3dup and and [ 3drop f f f ] unless ; inline
  65
  66 MACRO: n-and ( n -- quot )
  67     1 [-] [ and ] n*quot ;
  68
  69 MACRO: n*obj ( n obj -- quot )
  70     1quotation n*quot ;
  71
  72 MACRO:: n-falsify ( n -- quot )
  73     [ n ndup n n-and [ n ndrop n f n*obj ] unless ] ;
  74
  75 ! plox
  76 : ?1res ( ..a obj/f quot -- ..b )
  77     dupd when ; inline
  78
  79 ! when both args are true, call quot. otherwise dont
  80 : ?2res ( ..a obj1 obj2 quot: ( obj1 obj2 -- ? ) -- ..b )
  81     [ 2dup and ] dip [ 2drop f ] if ; inline
  82
  83 ! try the quot, keep the original arg if quot is true
  84 : ?1arg ( obj quot: ( obj -- ? ) -- obj/f )
  85     [ ?1res ] keepd '[ _ ] [ f ] if ; inline
  86
  87 : ?2arg ( obj1 obj2 quot: ( obj1 obj2 -- ? ) -- obj1/f obj2/f )
  88     [ ?2res ] 2keepd '[ _ _ ] [ f f ] if ; inline
  89
  90 <<
  91 : alist>quot* ( default assoc -- quot )
  92     [ rot \ if* 3array append [ ] like ] assoc-each ;
  93
  94 : cond*>quot ( assoc -- quot )
  95     [ dup pair? [ [ drop ] prepend [ t ] swap 2array ] unless ] map
  96     reverse! [ no-cond ] swap alist>quot* ;
  97
  98 DEFER: cond*
  99 \ cond* [ cond*>quot ] 1 define-transform
 100 \ cond* t "no-compile" set-word-prop
 101 >>
 102 : cond* ( assoc -- )
 103     [ dup callable? [ drop t ] [ first call ] if ] map-find
 104     [ dup callable? [ nip call ] [ second call ] if ]
 105     [ no-cond ] if* ;