{ 1 2 3 4 } [ 3 4 1 2 2swap ] unit-test
{ 4 2 3 } [ 1 2 3 4 shuffle( a b c d -- d b c ) ] unit-test
+
+{ 2 3 4 5 1 } [ 1 2 3 4 5 5roll ] unit-test
+{ 2 3 4 5 6 1 } [ 1 2 3 4 5 6 6roll ] unit-test
+{ 2 3 4 5 6 7 1 } [ 1 2 3 4 5 6 7 7roll ] unit-test
+{ 2 3 4 5 6 7 8 1 } [ 1 2 3 4 5 6 7 8 8roll ] unit-test
: 5roll ( a b c d e -- b c d e a ) [ roll ] dip swap ; inline
+: 6roll ( a b c d e f -- b c d e f a ) [ roll ] 2dip rot ; inline
+
+: 7roll ( a b c d e f g -- b c d e f g a ) [ roll ] 3dip roll ; inline
+
+: 8roll ( a b c d e f g h -- b c d e f g h a ) [ roll ] 4dip 5roll ; inline
+
: 2reach ( w x y z -- w x y z w x ) reach reach ; inline
: nipdd ( w x y z -- x y z ) roll drop ; inline
! Copyright (C) 2013 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators.extras io.files kernel math
-sequences splitting tools.test ;
+modern.slices sequences splitting tools.test ;
+IN: combinators.extras.tests
+
{ "a b" }
[ "a" "b" [ " " glue ] once ] unit-test
} [
1 2 3 4 5 6 7 8 9 10 11 12
[ 4array ] 4tri@
-] unit-test
\ No newline at end of file
+] unit-test
+
+{ 1 2 3 } [ 1 2 [ 3 ] dip-1up ] unit-test
+{ 2 2 } [ 1 2 [ 1 + ] dip-1up ] unit-test
+{ 20 11 } [ 10 20 [ 1 + ] dip-1up ] unit-test
+
+{ 0 10 20 30 40 50 60 80 71 } [ 0 10 20 30 40 50 60 70 80 [ 1 + ] dip-1up ] unit-test
+{ 0 10 20 30 40 50 70 80 61 } [ 0 10 20 30 40 50 60 70 80 [ 1 + ] 2dip-1up ] unit-test
+{ 0 10 20 30 40 60 70 80 51 } [ 0 10 20 30 40 50 60 70 80 [ 1 + ] 3dip-1up ] unit-test
+
+
+{ 0 10 20 30 40 50 80 61 71 } [ 0 10 20 30 40 50 60 70 80 [ [ 1 + ] bi@ ] dip-2up ] unit-test
+{ 0 10 20 30 40 70 80 51 61 } [ 0 10 20 30 40 50 60 70 80 [ [ 1 + ] bi@ ] 2dip-2up ] unit-test
+{ 0 10 20 30 60 70 80 41 51 } [ 0 10 20 30 40 50 60 70 80 [ [ 1 + ] bi@ ] 3dip-2up ] unit-test
+
+{ 0 10 20 60 70 80 31 41 51 } [ 0 10 20 30 40 50 60 70 80 [ [ 1 + ] tri@ ] 3dip-3up ] unit-test
+
+{ 4 "abcd" 97 98 99 100 } [
+ 0 "abcd"
+ [ [ CHAR: a = ] accept1 ]
+ [ [ CHAR: b = ] accept1 ]
+ [ [ CHAR: c = ] accept1 ]
+ [ [ CHAR: d = ] accept1 ] 4craft-1up
+] unit-test
+
+{ 20 30 2500 } [ 20 30 [ + sq ] 2keep-1up ] unit-test
+
+{ 10 1 } [ 10 [ drop 1 ] keep-1up ] unit-test
+{ 10 20 1 } [ 10 20 [ 2drop 1 ] 2keep-1up ] unit-test
+{ 10 20 30 1 } [ 10 20 30 [ 3drop 1 ] 3keep-1up ] unit-test
+
+
+{ 10 1 } [ 10 [ drop 1 ] keep-1up ] unit-test
+{ 10 20 1 } [ 10 20 [ 2drop 1 ] 2keep-1up ] unit-test
+{ 10 20 30 1 } [ 10 20 30 [ 3drop 1 ] 3keep-1up ] unit-test
+
+{ 10 1 2 } [ 10 [ drop 1 2 ] keep-2up ] unit-test
+{ 10 20 1 2 } [ 10 20 [ 2drop 1 2 ] 2keep-2up ] unit-test
+{ 10 20 30 1 2 } [ 10 20 30 [ 3drop 1 2 ] 3keep-2up ] unit-test
+
+{ 10 1 2 3 } [ 10 [ drop 1 2 3 ] keep-3up ] unit-test
+{ 10 20 1 2 3 } [ 10 20 [ 2drop 1 2 3 ] 2keep-3up ] unit-test
+{ 10 20 30 1 2 3 } [ 10 20 30 [ 3drop 1 2 3 ] 3keep-3up ] unit-test
+
+: test-keep-under ( -- a b c d e ) 1 [ [ 5 + ] call 10 20 30 ] keep-under ;
+: test-2keep-under ( -- a b c d e f g ) 1 2 [ [ 5 + ] bi@ 10 20 30 ] 2keep-under ;
+: test-3keep-under ( -- a b c d e f g h i ) 1 2 3 [ [ 5 + ] tri@ 10 20 30 ] 3keep-under ;
+: test-4keep-under ( -- a b c d e f g h i j k l ) 1 2 3 4 [ [ 5 + ] quad@ 10 20 30 40 ] 4keep-under ;
+
+{ 1 6 10 20 30 } [ test-keep-under ] unit-test
+{ 1 2 6 7 10 20 30 } [ test-2keep-under ] unit-test
+{ 1 2 3 6 7 8 10 20 30 } [ test-3keep-under ] unit-test
+{ 1 2 3 4 6 7 8 9 10 20 30 40 } [ test-4keep-under ] unit-test
+
+{ 1 2 3 4 1 2 3 4 5 } [ 1 2 3 4 [ 5 ] 4keep-under ] unit-test
+{ 1 2 3 4 1 2 3 4 5 6 7 8 9 10 } [ 1 2 3 4 [ 5 6 7 8 9 10 ] 4keep-under ] unit-test
+
+
+{ 3 { 1 2 3 } }
+[ 0 { 1 2 3 } [ 1 + ] 1temp1d map ] unit-test
+
+{ 3 { { 1 1 } { 2 2 } { 3 3 } } }
+[ 0 { { 1 1 } { 2 2 } { 3 3 } } [ 1 + ] 1temp2d assoc-map ] unit-test
+
+{ 103 203 { { 1 1 } { 2 2 } { 3 3 } } }
+[ 100 200 { { 1 1 } { 2 2 } { 3 3 } } [ [ 1 + ] bi@ ] 2temp2d assoc-map ] unit-test
+
: 4quad ( w x y z p q r s -- )
[ [ [ 4keep ] dip 4keep ] dip 4keep ] dip call ; inline
+: quad* ( w x y z p q r s -- ) [ [ [ 3dip ] dip 2dip ] dip dip ] dip call ; inline
+
+: quad@ ( w x y z quot -- ) dup dup dup quad* ; inline
+
: plox ( ... x/f quot: ( ... x -- ... y ) -- ... y/f )
dupd when ; inline
: loop1 ( ..a quot: ( ..a -- ..a obj ? ) -- ..a obj )
[ call ] keep '[ drop _ loop1 ] when ; inline recursive
+
+: keep-1up ( quot -- quot ) keep 1 2 nrotates ; inline
+: keep-2up ( quot -- quot ) keep 2 3 nrotates ; inline
+: keep-3up ( quot -- quot ) keep 3 4 nrotates ; inline
+
+: 2keep-1up ( quot -- quot ) 2keep 1 3 nrotates ; inline
+: 2keep-2up ( quot -- quot ) 2keep 2 4 nrotates ; inline
+: 2keep-3up ( quot -- quot ) 2keep 3 5 nrotates ; inline
+
+: 3keep-1up ( quot -- quot ) 3keep 1 4 nrotates ; inline
+: 3keep-2up ( quot -- quot ) 3keep 2 5 nrotates ; inline
+: 3keep-3up ( quot -- quot ) 3keep 3 6 nrotates ; inline
+
+! d is dummy, o is object to save notation space
+: dip-1up ( ..a d quot: ( ..a -- ..b o d ) -- ..b d o )
+ dip swap ; inline
+: dip-2up ( ..a d quot: ( ..a -- ..b o1 o2 d ) -- ..b d o1 o2 )
+ dip rot rot ; inline
+
+: 2dip-1up ( ..a d1 d2 quot: ( ..a -- ..b o d1 d2 ) -- ..b d1 d2 o )
+ 2dip rot ; inline
+: 2dip-2up ( ..a d1 d2 quot: ( ..a -- ..b o1 o2 d1 d2 ) -- ..b d1 d2 o1 o2 )
+ 2dip roll roll ; inline
+
+: 3dip-1up ( ..a d1 d2 d3 quot: ( ..a -- ..b o d1 d2 d3 ) -- ..b d1 d2 d3 o )
+ 3dip roll ; inline
+: 3dip-2up ( ..a d1 d2 d3 quot: ( ..a -- ..b o1 o2 d1 d2 d3 ) -- ..b d1 d2 d3 o1 o2 )
+ 3dip 2 5 nrotates ; inline
+: 3dip-3up ( ..a d1 d2 d3 quot: ( ..a -- ..b o1 o2 o3 d1 d2 d3 ) -- ..b d1 d2 d3 o1 o2 o3 )
+ 3dip 3 6 nrotates ; inline
+
+
+: 2craft-1up ( ..a quot1: ( ..a -- ..b o1 ) quot2: ( ..b -- ..c o2 ) -- ..c o1 o2 )
+ [ call ] dip [ dip-1up ] call ; inline
+
+: 3craft-1up ( ..a quot1: ( ..a -- ..b o1 ) quot2: ( ..b -- ..c o2 ) quot3: ( ..c -- ..d o3 ) -- ..d o1 o2 o3 )
+ [ call ] 2dip [ dip-1up ] dip [ 2dip-1up ] call ; inline
+
+: 4craft-1up ( ..a quot1: ( ..a -- ..b o1 ) quot2: ( ..b -- ..c o2 ) quot3: ( ..c -- ..d o3 ) quot4: ( ..d -- ..e o4 ) -- ..e o1 o2 o3 o4 )
+ [ call ] 3dip [ dip-1up ] 2dip [ 2dip-1up ] dip [ 3dip-1up ] call ; inline
+
+: 3and ( a b c -- ? ) and and ; inline
+: 4and ( a b c d -- ? ) and and and ; inline
+
+: 3or ( a b c -- ? ) or or ; inline
+: 4or ( a b c d -- ? ) or or or ; inline
+
+! The kept values are on the bottom of the stack
+MACRO: keep-under ( quot -- quot' )
+ dup outputs 1 + '[ _ keep 1 _ -nrotates ] ;
+
+MACRO: 2keep-under ( quot -- quot' )
+ dup outputs 2 + '[ _ 2keep 2 _ -nrotates ] ;
+
+MACRO: 3keep-under ( quot -- quot' )
+ dup outputs 3 + '[ _ 3keep 3 _ -nrotates ] ;
+
+MACRO: 4keep-under ( quot -- quot' )
+ dup outputs 4 + '[ _ 4keep 4 _ -nrotates ] ;
+
+! for use with assoc-map etc
+: 1temp1d ( quot: ( a b c -- d e f ) -- quot ) '[ swap @ swap ] ; inline
+: 1temp2d ( quot: ( a b c -- d e f ) -- quot ) '[ rot @ -rot ] ; inline
+: 2temp2d ( quot: ( a b c d -- e f g h ) -- quot ) '[ 2 4 nrotates @ 2 4 -nrotates ] ; inline
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators
combinators.short-circuit kernel make math modern modern.slices
-sequences sequences.extras shuffle shuffle.extras splitting
+sequences sequences.extras shuffle combinators.extras splitting
strings unicode ;
IN: modern.html
{ CHAR: \\ CHAR: ' } slice-til-separator-inclusive {
{ f [ to>> over string-expected-got-eof ] }
{ CHAR: ' [ drop ] }
- { CHAR: \\ [ drop next-char-from drop advance-squote-payload ] }
+ { CHAR: \\ [ drop take-char drop advance-squote-payload ] }
} case
] [
string-expected-got-eof
[ "\s\r\n/>" member? ] slice-until ;
: read-value ( n string -- n' string value )
- skip-whitespace next-char-from {
+ skip-whitespace take-char {
{ CHAR: ' [ CHAR: ' read-string >string <squote> ] }
{ CHAR: " [ CHAR: " read-string >string <dquote> ] }
{ CHAR: [ [ "[" throw ] }
USING: accessors arrays assocs combinators
combinators.short-circuit continuations io.encodings.utf8
io.files kernel make math math.order modern.paths modern.slices
-sequences sequences.extras sets shuffle.extras splitting strings
+sequences sequences.extras sets combinators.extras splitting strings
unicode vocabs.loader ;
IN: modern
{ CHAR: \\ CHAR: \" } slice-til-separator-inclusive {
{ f [ to>> over string-expected-got-eof ] }
{ CHAR: \" [ drop ] }
- { CHAR: \\ [ drop next-char-from drop advance-dquote-payload ] }
+ { CHAR: \\ [ drop take-char drop advance-dquote-payload ] }
} case
] [
string-expected-got-eof
! Copyright (C) 2016 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel math sequences sequences.deep
-sequences.extras strings unicode ;
+sequences.extras combinators.extras strings unicode ;
IN: modern.slices
: >strings ( seq -- str )
over [ [ 1 - ] dip ?nth ] [ 2drop f ] if ;
! Allow eof
-: next-char-from ( n/f string -- n'/f string ch/f )
+: take-char ( n/f string -- n'/f string ch/f )
over [
2dup ?nth [ [ 1 + ] 2dip ] [ f ] if*
] [
- [ 2drop f ] [ nip ] 2bi f
+ f
] if ;
-: prev-char-from-slice-end ( slice -- ch/f )
- [ to>> 2 - ] [ seq>> ] bi ?nth ;
-
-: prev-char-from-slice ( slice -- ch/f )
- [ from>> 1 - ] [ seq>> ] bi ?nth ;
-
-: next-char-from-slice ( slice -- ch/f )
- [ to>> ] [ seq>> ] bi ?nth ;
-
-: char-before-slice ( slice -- ch/f )
- [ from>> 1 - ] [ seq>> ] bi ?nth ;
-
-: char-after-slice ( slice -- ch/f )
- [ to>> ] [ seq>> ] bi ?nth ;
-
-: find-from* ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt ? )
+: find-from* ( ... n seq quot: ( ... elt -- ... ? ) -- ... i/f elt ? )
[ find-from ] keepd
pick [ drop t ] [ length -rot nip f ] if ; inline
2dup [ >lower ] bi@ sequence= [ nip ] [ expected-sequence-error ] if ;
: expect-and-span ( n string slice expected-string -- n' string slice' )
- dup length '[ _ take-slice ] 2dip
- rot check-sequence span-slices ;
+ dup length '[ _ take-slice ] 2dip-1up check-sequence span-slices ;
: expect-and-span-insensitive ( n string slice expected-string -- n' string slice' )
- dup length '[ _ take-slice ] 2dip
- rot check-sequence-insensitive span-slices ;
+ dup length '[ _ take-slice ] 2dip-1up check-sequence-insensitive span-slices ;
:: split-slice-back ( slice n -- slice1 slice2 )
slice [ from>> ] [ to>> ] [ seq>> ] tri :> ( from to seq )
: empty-slice-end ( seq -- slice )
[ length dup ] [ ] bi <slice> ; inline
-: empty-slice-from ( n seq -- slice )
- dupd <slice> ; inline
-
:: slice-til-eol ( n string -- n' string slice/f ch/f )
n [
n string '[ "\r\n" member? ] find-from :> ( n' ch )
n string string empty-slice-end f
] if ; inline
-:: merge-slice-til-eol-slash'' ( n string -- n' string slice/f ch/f )
- n [
- n string '[ "\r\n\\" member? ] find-from :> ( n' ch )
- n' string
- n n' string ?<slice>
- ch
- ] [
- n string string empty-slice-end f
- ] if ; inline
-
-: merge-slice-til-whitespace ( n string slice -- n' string slice' )
+: merge-slice-til-whitespace ( n/f string slice -- n'/f string slice' )
pick [
[ slice-til-whitespace drop ] dip merge-slices
] when ;
-: merge-slice-til-eol ( n string slice -- n' string slice' )
- [ slice-til-eol drop ] dip merge-slices ;
-
: slice-between ( slice1 slice2 -- slice )
! ensure-same-underlying
slice-order-by-from
: slice-before ( slice -- slice' )
[ drop 0 ] [ from>> ] [ seq>> ] tri <slice> ;
-: (?nth) ( n/f string/f -- obj/f )
- over [ (?nth) ] [ 2drop f ] if ;
-
-:: merge-slice-til-eol-slash' ( n string slice -- n' string slice/f ch/f )
- n string merge-slice-til-eol-slash'' :> ( n' string' slice' ch' )
- ch' CHAR: \\ = [
- n' 1 + string' (?nth) "\r\n" member? [
- n' 2 + string' slice slice' span-slices merge-slice-til-eol-slash'
- ] [
- "omg" throw
- ] if
- ] [
- n' string' slice slice' span-slices ch'
- ] if ;
-
-! Supports \ at eol (with no space after it)
-: slice-til-eol-slash ( n string -- n' string slice/f ch/f )
- 2dup empty-slice-from merge-slice-til-eol-slash' ;
-
:: slice-til-separator-inclusive ( n string tokens -- n' string slice/f ch/f )
n string '[ tokens member? ] find-from [ dup [ 1 + ] when ] dip :> ( n' ch )
n' string
'[ from>> _ + ] [ to>> ] [ seq>> ] tri <slice> ;
: modify-to ( slice n -- slice' )
- [ [ from>> ] [ to>> ] [ seq>> ] tri ] dip
- swap [ + ] dip <slice> ;
+ [ from>> ] swap '[ to>> _ + ] [ seq>> ] tri <slice> ; inline
! { CHAR: \] [ read-closing ] }
! { CHAR: \} [ read-closing ] }
! { CHAR: \) [ read-closing ] }
-: read-closing ( n string tok -- n string tok )
+: read-closing ( n string tok -- n' string tok )
dup length 1 = [
- -1 modify-to [ 1 - ] 2dip
+ -1 modify-to
+ [ 1 - ] 2dip
] unless ;
: rewind-slice ( n string slice -- n' string )
: find-pred-loop ( ... i n seq quot: ( ... elt -- ... calc ? ) -- ... calc/f i/f elt/f )
2pick < [
[ nipd call ] 4keep
- 7 nrot 7 nrot 7 nrot
+ 3 7 nrotates
[ [ 3drop ] 2dip rot ]
[ 2drop [ 1 + ] 3dip find-pred-loop ] if
] [
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2022 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math modern.slices shuffle.extras tools.test ;
-IN: shuffle.extras.tests
-
-{ 2 3 4 5 6 1 } [ 1 2 3 4 5 6 6roll ] unit-test
-{ 2 3 4 5 6 7 1 } [ 1 2 3 4 5 6 7 7roll ] unit-test
-{ 2 3 4 5 6 7 8 1 } [ 1 2 3 4 5 6 7 8 8roll ] unit-test
-
-{ 1 2 3 } [ 1 2 [ 3 ] dip-1up ] unit-test
-{ 2 2 } [ 1 2 [ 1 + ] dip-1up ] unit-test
-{ 20 11 } [ 10 20 [ 1 + ] dip-1up ] unit-test
-
-{ 0 10 20 30 40 50 60 80 71 } [ 0 10 20 30 40 50 60 70 80 [ 1 + ] dip-1up ] unit-test
-{ 0 10 20 30 40 50 70 80 61 } [ 0 10 20 30 40 50 60 70 80 [ 1 + ] 2dip-1up ] unit-test
-{ 0 10 20 30 40 60 70 80 51 } [ 0 10 20 30 40 50 60 70 80 [ 1 + ] 3dip-1up ] unit-test
-
-
-{ 0 10 20 30 40 50 80 61 71 } [ 0 10 20 30 40 50 60 70 80 [ [ 1 + ] bi@ ] dip-2up ] unit-test
-{ 0 10 20 30 40 70 80 51 61 } [ 0 10 20 30 40 50 60 70 80 [ [ 1 + ] bi@ ] 2dip-2up ] unit-test
-{ 0 10 20 30 60 70 80 41 51 } [ 0 10 20 30 40 50 60 70 80 [ [ 1 + ] bi@ ] 3dip-2up ] unit-test
-
-{ 0 10 20 60 70 80 31 41 51 } [ 0 10 20 30 40 50 60 70 80 [ [ 1 + ] tri@ ] 3dip-3up ] unit-test
-
-{ 4 "abcd" 97 98 99 100 } [
- 0 "abcd"
- [ [ CHAR: a = ] accept1 ]
- [ [ CHAR: b = ] accept1 ]
- [ [ CHAR: c = ] accept1 ]
- [ [ CHAR: d = ] accept1 ] 4craft-1up
-] unit-test
-
-! : test-keep-under ( -- a b c d e ) 1 [ [ 5 + ] call 10 20 30 ] keep-under ;
-! : test-2keep-under ( -- a b c d e f g ) 1 2 [ [ 5 + ] bi@ 10 20 30 ] 2keep-under ;
-! : test-3keep-under ( -- a b c d e f g h i ) 1 2 3 [ [ 5 + ] tri@ 10 20 30 ] 3keep-under ;
-
-! { 1 6 10 20 30 } [ test-keep-under ] unit-test
-! { 1 2 6 7 10 20 30 } [ test-2keep-under ] unit-test
-! { 1 2 3 6 7 8 10 20 30 } [ test-3keep-under ] unit-test
-
-{ 20 30 2500 } [ 20 30 [ + sq ] 2keep-1up ] unit-test
-
-{ 10 1 } [ 10 [ drop 1 ] keep-1up ] unit-test
-{ 10 20 1 } [ 10 20 [ 2drop 1 ] 2keep-1up ] unit-test
-{ 10 20 30 1 } [ 10 20 30 [ 3drop 1 ] 3keep-1up ] unit-test
-
-
-{ 10 1 } [ 10 [ drop 1 ] keep-1up ] unit-test
-{ 10 20 1 } [ 10 20 [ 2drop 1 ] 2keep-1up ] unit-test
-{ 10 20 30 1 } [ 10 20 30 [ 3drop 1 ] 3keep-1up ] unit-test
-
-{ 10 1 2 } [ 10 [ drop 1 2 ] keep-2up ] unit-test
-{ 10 20 1 2 } [ 10 20 [ 2drop 1 2 ] 2keep-2up ] unit-test
-{ 10 20 30 1 2 } [ 10 20 30 [ 3drop 1 2 ] 3keep-2up ] unit-test
-
-{ 10 1 2 3 } [ 10 [ drop 1 2 3 ] keep-3up ] unit-test
-{ 10 20 1 2 3 } [ 10 20 [ 2drop 1 2 3 ] 2keep-3up ] unit-test
-{ 10 20 30 1 2 3 } [ 10 20 30 [ 3drop 1 2 3 ] 3keep-3up ] unit-test
+++ /dev/null
-! Copyright (C) 2022 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: generalizations kernel shuffle ;
-IN: shuffle.extras
-
-: 6roll ( a b c d e f -- b c d e f a ) [ roll ] 2dip rot ; inline
-
-: 7roll ( a b c d e f g -- b c d e f g a ) [ roll ] 3dip roll ; inline
-
-: 8roll ( a b c d e f g h -- b c d e f g h a ) [ roll ] 4dip 5roll ; inline
-
-: keep-1up ( quot -- quot ) keep swap ; inline
-: keep-2up ( quot -- quot ) keep rot rot ; inline
-: keep-3up ( quot -- quot ) keep roll roll roll ; inline
-
-: 2keep-1up ( quot -- quot ) 2keep rot ; inline
-: 2keep-2up ( quot -- quot ) 2keep roll roll ; inline
-: 2keep-3up ( quot -- quot ) 2keep 5 nrot 5 nrot 5 nrot ; inline
-
-: 3keep-1up ( quot -- quot ) 3keep roll ; inline
-: 3keep-2up ( quot -- quot ) 3keep 5 nrot 5 nrot ; inline
-: 3keep-3up ( quot -- quot ) 3keep 6 nrot 6 nrot 6 nrot ; inline
-
-! d is dummy, o is object to save notation space
-: dip-1up ( ..a d quot: ( ..a -- ..b o d ) -- ..b d o )
- dip swap ; inline
-: dip-2up ( ..a d quot: ( ..a -- ..b o1 o2 d ) -- ..b d o1 o2 )
- dip rot rot ; inline
-
-: 2dip-1up ( ..a d1 d2 quot: ( ..a -- ..b o d1 d2 ) -- ..b d1 d2 o )
- 2dip rot ; inline
-: 2dip-2up ( ..a d1 d2 quot: ( ..a -- ..b o1 o2 d1 d2 ) -- ..b d1 d2 o1 o2 )
- 2dip roll roll ; inline
-
-: 3dip-1up ( ..a d1 d2 d3 quot: ( ..a -- ..b o d1 d2 d3 ) -- ..b d1 d2 d3 o )
- 3dip roll ; inline
-: 3dip-2up ( ..a d1 d2 d3 quot: ( ..a -- ..b o1 o2 d1 d2 d3 ) -- ..b d1 d2 d3 o1 o2 )
- 3dip 5roll 5roll ; inline
-: 3dip-3up ( ..a d1 d2 d3 quot: ( ..a -- ..b o1 o2 o3 d1 d2 d3 ) -- ..b d1 d2 d3 o1 o2 o3 )
- 3dip 6roll 6roll 6roll ; inline
-
-
-: 2craft-1up ( ..a quot1: ( ..a -- ..b o1 ) quot2: ( ..b -- ..c o2 ) -- ..c o1 o2 )
- [ call ] dip [ dip-1up ] call ; inline
-
-: 3craft-1up ( ..a quot1: ( ..a -- ..b o1 ) quot2: ( ..b -- ..c o2 ) quot3: ( ..c -- ..d o3 ) -- ..d o1 o2 o3 )
- [ call ] 2dip [ dip-1up ] dip [ 2dip-1up ] call ; inline
-
-: 4craft-1up ( ..a quot1: ( ..a -- ..b o1 ) quot2: ( ..b -- ..c o2 ) quot3: ( ..c -- ..d o3 ) quot4: ( ..d -- ..e o4 ) -- ..e o1 o2 o3 o4 )
- [ call ] 3dip [ dip-1up ] 2dip [ 2dip-1up ] dip [ 3dip-1up ] call ; inline
-
-: 3and ( a b c -- ? ) and and ; inline
-: 4and ( a b c d -- ? ) and and and ; inline
-
-: 3or ( a b c -- ? ) or or ; inline
-: 4or ( a b c d -- ? ) or or or ; inline
projects / factor.git / commitdiff