2013-03-24 12:55:44 -04:00
|
|
|
! Copyright (C) 2013 Doug Coleman, John Benediktsson.
|
2013-03-07 17:11:01 -05:00
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2013-05-14 16:44:14 -04:00
|
|
|
USING: arrays combinators combinators.smart fry generalizations
|
|
|
|
kernel macros math quotations sequences
|
2013-09-24 18:07:47 -04:00
|
|
|
sequences.generalizations sequences.private system ;
|
2013-03-07 17:11:01 -05:00
|
|
|
IN: combinators.extras
|
|
|
|
|
|
|
|
: once ( quot -- ) call ; inline
|
|
|
|
: twice ( quot -- ) dup [ call ] dip call ; inline
|
|
|
|
: thrice ( quot -- ) dup dup [ call ] 2dip [ call ] dip call ; inline
|
2013-09-17 22:57:10 -04:00
|
|
|
: forever ( quot -- ) [ t ] compose loop ; inline
|
2013-03-24 12:55:44 -04:00
|
|
|
|
2015-07-19 01:16:11 -04:00
|
|
|
MACRO: cond-case ( assoc -- quot )
|
2013-03-24 12:55:44 -04:00
|
|
|
[
|
|
|
|
dup callable? not [
|
|
|
|
[ first [ dup ] prepose ]
|
|
|
|
[ second [ drop ] prepose ] bi 2array
|
|
|
|
] when
|
|
|
|
] map [ cond ] curry ;
|
2013-03-24 22:34:39 -04:00
|
|
|
|
2015-07-19 01:16:11 -04:00
|
|
|
MACRO: cleave-array ( quots -- quot )
|
2013-03-24 22:34:39 -04:00
|
|
|
[ '[ _ cleave ] ] [ length '[ _ narray ] ] bi compose ;
|
2013-05-01 21:34:27 -04:00
|
|
|
|
|
|
|
: 3bi* ( u v w x y z p q -- )
|
|
|
|
[ 3dip ] dip call ; inline
|
|
|
|
|
|
|
|
: 3bi@ ( u v w x y z quot -- )
|
|
|
|
dup 3bi* ; inline
|
2013-05-14 12:40:40 -04:00
|
|
|
|
2013-09-23 19:51:31 -04:00
|
|
|
: 4bi ( w x y z p q -- )
|
|
|
|
[ 4keep ] dip call ; inline
|
|
|
|
|
2013-10-01 17:02:56 -04:00
|
|
|
: 4bi* ( s t u v w x y z p q -- )
|
|
|
|
[ 4dip ] dip call ; inline
|
|
|
|
|
|
|
|
: 4bi@ ( s t u v w x y z quot -- )
|
|
|
|
dup 4bi* ; inline
|
|
|
|
|
2013-09-23 19:51:31 -04:00
|
|
|
: 4tri ( w x y z p q r -- )
|
|
|
|
[ [ 4keep ] dip 4keep ] dip call ; inline
|
|
|
|
|
2013-05-14 12:40:40 -04:00
|
|
|
: keepd ( ..a x y quot: ( ..a x y -- ..b ) -- ..b x )
|
|
|
|
2keep drop ; inline
|
2013-05-14 16:44:14 -04:00
|
|
|
|
|
|
|
: plox ( ... x/f quot: ( ... x -- ... ) -- ... )
|
|
|
|
dupd when ; inline
|
|
|
|
|
2015-07-19 01:16:11 -04:00
|
|
|
MACRO: smart-plox ( true -- quot )
|
2013-05-14 16:44:14 -04:00
|
|
|
[ inputs [ 1 - [ and ] n*quot ] keep ] keep swap
|
|
|
|
'[ _ _ [ _ ndrop f ] smart-if ] ;
|
2013-09-24 18:07:47 -04:00
|
|
|
|
|
|
|
: throttle ( quot millis -- quot' )
|
|
|
|
1,000,000 * '[
|
|
|
|
_ nano-count { 0 } 2dup first-unsafe _ + >=
|
|
|
|
[ 0 swap set-nth-unsafe call ] [ 3drop ] if
|
|
|
|
] ; inline
|
2014-12-03 15:03:04 -05:00
|
|
|
|
|
|
|
: swap-when ( x y quot: ( x -- n ) quot: ( n n -- ? ) -- x' y' )
|
|
|
|
'[ _ _ 2dup _ bi@ @ [ swap ] when ] call ; inline
|