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