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 combinators combinators.smart fry generalizations
   4 kernel macros math quotations sequences
   5 sequences.generalizations sequences.private system ;
   6 IN: combinators.extras
   7
   8 : once ( quot -- ) call ; inline
   9 : twice ( quot -- ) dup [ call ] dip call ; inline
  10 : thrice ( quot -- ) dup dup [ call ] 2dip [ call ] dip call ; inline
  11 : forever ( quot -- ) [ t ] compose loop ; inline
  12
  13 MACRO: cond-case ( assoc -- )
  14     [
  15         dup callable? not [
  16             [ first [ dup ] prepose ]
  17             [ second [ drop ] prepose ] bi 2array
  18         ] when
  19     ] map [ cond ] curry ;
  20
  21 MACRO: cleave-array ( quots -- )
  22     [ '[ _ cleave ] ] [ length '[ _ narray ] ] bi compose ;
  23
  24 : 3bi* ( u v w x y z p q -- )
  25     [ 3dip ] dip call ; inline
  26
  27 : 3bi@ ( u v w x y z quot -- )
  28     dup 3bi* ; inline
  29
  30 : 4bi ( w x y z p q -- )
  31     [ 4keep ] dip call ; inline
  32
  33 : 4bi* ( s t u v w x y z p q -- )
  34     [ 4dip ] dip call ; inline
  35
  36 : 4bi@ ( s t u v w x y z quot -- )
  37     dup 4bi* ; inline
  38
  39 : 4tri ( w x y z p q r -- )
  40     [ [ 4keep ] dip 4keep ] dip call ; inline
  41
  42 : keepd ( ..a x y quot: ( ..a x y -- ..b ) -- ..b x )
  43     2keep drop ; inline
  44
  45 : plox ( ... x/f quot: ( ... x -- ... ) -- ... )
  46     dupd when ; inline
  47
  48 MACRO: smart-plox ( true -- )
  49     [ inputs [ 1 - [ and ] n*quot ] keep ] keep swap
  50     '[ _ _ [ _ ndrop f ] smart-if ] ;
  51
  52 : throttle ( quot millis -- quot' )
  53     1,000,000 * '[
  54         _ nano-count { 0 } 2dup first-unsafe _ + >=
  55         [ 0 swap set-nth-unsafe call ] [ 3drop ] if
  56     ] ; inline
  57
  58 : swap-when ( x y quot: ( x -- n ) quot: ( n n -- ? ) -- x' y' )
  59     '[ _ _ 2dup _ bi@ @ [ swap ] when ] call ; inline