steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

generalizations: Update 'npick' to not use >r and r>

db4
Eduardo Cavazos 2008-11-25 05:55:49 -06:00
parent 37f991420b
commit de95773574
1 changed files with 73 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

141
basis/generalizations/generalizations.factor
View File

@ -1,68 +1,73 @@
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo
! Cavazos, Slava Pestov. ! Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private namespaces math USING: kernel sequences sequences.private namespaces math
math.ranges combinators macros quotations fry arrays ; math.ranges combinators macros quotations fry arrays ;
IN: generalizations IN: generalizations
MACRO: nsequence ( n seq -- quot ) MACRO: nsequence ( n seq -- quot )
[ [
[ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi [ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
[ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce [ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce
] keep ] keep
'[ @ _ like ] ; '[ @ _ like ] ;
MACRO: narray ( n -- quot ) MACRO: narray ( n -- quot )
'[ _ { } nsequence ] ; '[ _ { } nsequence ] ;
MACRO: firstn ( n -- ) MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [ dup zero? [ drop [ drop ] ] [
[ [ '[ [ _ ] dip nth-unsafe ] ] map ] [ [ '[ [ _ ] dip nth-unsafe ] ] map ]
[ 1- '[ [ _ ] dip bounds-check 2drop ] ] [ 1- '[ [ _ ] dip bounds-check 2drop ] ]
bi prefix '[ _ cleave ] bi prefix '[ _ cleave ]
] if ; ] if ;
MACRO: npick ( n -- ) : npick-wrap ( quot n -- quot )
1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ; dup 1 >
[ swap '[ _ dip swap ] swap 1 - npick-wrap ]
MACRO: ndup ( n -- ) [ drop ]
dup '[ _ npick ] n*quot ; if ;
MACRO: nrot ( n -- ) MACRO: npick ( n -- quot ) [ dup ] swap npick-wrap ;
1- dup saver swap [ r> swap ] n*quot append ;
MACRO: ndup ( n -- )
MACRO: -nrot ( n -- ) dup '[ _ npick ] n*quot ;
1- dup [ swap >r ] n*quot swap restorer append ;
MACRO: nrot ( n -- )
MACRO: ndrop ( n -- ) 1- dup saver swap [ r> swap ] n*quot append ;
[ drop ] n*quot ;
MACRO: -nrot ( n -- )
: nnip ( n -- ) 1- dup [ swap >r ] n*quot swap restorer append ;
swap >r ndrop r> ; inline
MACRO: ndrop ( n -- )
MACRO: ntuck ( n -- ) [ drop ] n*quot ;
2 + [ dupd -nrot ] curry ;
: nnip ( n -- )
MACRO: nrev ( n -- quot ) swap >r ndrop r> ; inline
1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ;
MACRO: ntuck ( n -- )
MACRO: ndip ( quot n -- ) 2 + [ dupd -nrot ] curry ;
dup saver -rot restorer 3append ;
MACRO: nrev ( n -- quot )
MACRO: nslip ( n -- ) 1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ;
dup saver [ call ] rot restorer 3append ;
MACRO: ndip ( quot n -- )
MACRO: nkeep ( n -- ) dup saver -rot restorer 3append ;
[ ] [ 1+ ] [ ] tri
'[ [ _ ndup ] dip _ -nrot _ nslip ] ; MACRO: nslip ( n -- )
dup saver [ call ] rot restorer 3append ;
MACRO: ncurry ( n -- )
[ curry ] n*quot ; MACRO: nkeep ( n -- )
[ ] [ 1+ ] [ ] tri
MACRO: nwith ( n -- ) '[ [ _ ndup ] dip _ -nrot _ nslip ] ;
[ with ] n*quot ;
MACRO: ncurry ( n -- )
MACRO: napply ( n -- ) [ curry ] n*quot ;
2 [a,b]
[ [ 1- ] keep '[ _ ntuck _ nslip ] ] MACRO: nwith ( n -- )
map concat >quotation [ call ] append ; [ with ] n*quot ;
MACRO: napply ( n -- )
2 [a,b]
[ [ 1- ] keep '[ _ ntuck _ nslip ] ]
map concat >quotation [ call ] append ;