From b59dac0a32952e215ddee6c4ee27d85519120d61 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 13 Jun 2022 23:04:19 -0500 Subject: [PATCH] combinators.extras: Add some weird combinators that might be useful. --- basis/shuffle/shuffle-tests.factor | 5 ++ basis/shuffle/shuffle.factor | 6 ++ extra/combinators/extras/extras-tests.factor | 72 ++++++++++++++++++- extra/combinators/extras/extras.factor | 68 ++++++++++++++++++ extra/modern/html/html.factor | 6 +- extra/modern/modern.factor | 4 +- extra/modern/slices/slices.factor | 74 +++----------------- extra/sequences/extras/extras.factor | 2 +- extra/shuffle/extras/authors.txt | 1 - extra/shuffle/extras/extras-tests.factor | 58 --------------- extra/shuffle/extras/extras.factor | 56 --------------- 11 files changed, 166 insertions(+), 186 deletions(-) delete mode 100644 extra/shuffle/extras/authors.txt delete mode 100644 extra/shuffle/extras/extras-tests.factor delete mode 100644 extra/shuffle/extras/extras.factor diff --git a/basis/shuffle/shuffle-tests.factor b/basis/shuffle/shuffle-tests.factor index b9eee02ce0..d950ccd766 100644 --- a/basis/shuffle/shuffle-tests.factor +++ b/basis/shuffle/shuffle-tests.factor @@ -3,3 +3,8 @@ USING: shuffle tools.test ; { 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 diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor index 3c7cc64f38..393dffc2f6 100644 --- a/basis/shuffle/shuffle.factor +++ b/basis/shuffle/shuffle.factor @@ -19,6 +19,12 @@ SYNTAX: shuffle( : 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 diff --git a/extra/combinators/extras/extras-tests.factor b/extra/combinators/extras/extras-tests.factor index 9294b8f784..54f0574493 100644 --- a/extra/combinators/extras/extras-tests.factor +++ b/extra/combinators/extras/extras-tests.factor @@ -1,7 +1,9 @@ ! 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 @@ -95,4 +97,70 @@ sequences splitting tools.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 + diff --git a/extra/combinators/extras/extras.factor b/extra/combinators/extras/extras.factor index 2b03b1713a..ff338d2c48 100644 --- a/extra/combinators/extras/extras.factor +++ b/extra/combinators/extras/extras.factor @@ -51,6 +51,10 @@ MACRO: cleave-array ( quots -- quot ) : 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 @@ -124,3 +128,67 @@ MACRO: chain ( quots -- quot ) : 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 diff --git a/extra/modern/html/html.factor b/extra/modern/html/html.factor index 0ec7b034a4..d5d33ed20b 100644 --- a/extra/modern/html/html.factor +++ b/extra/modern/html/html.factor @@ -2,7 +2,7 @@ ! 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 @@ -70,7 +70,7 @@ C: dquote { 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 @@ -87,7 +87,7 @@ C: dquote [ "\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 ] } { CHAR: " [ CHAR: " read-string >string ] } { CHAR: [ [ "[" throw ] } diff --git a/extra/modern/modern.factor b/extra/modern/modern.factor index 06710659a1..64752f2446 100644 --- a/extra/modern/modern.factor +++ b/extra/modern/modern.factor @@ -3,7 +3,7 @@ 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 @@ -115,7 +115,7 @@ MACRO:: read-matched ( ch -- quot: ( n string tag -- n' string slice' ) ) { 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 diff --git a/extra/modern/slices/slices.factor b/extra/modern/slices/slices.factor index 93a3970ce9..a7d0c0a937 100644 --- a/extra/modern/slices/slices.factor +++ b/extra/modern/slices/slices.factor @@ -1,7 +1,7 @@ ! 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 ) @@ -43,29 +43,14 @@ ERROR: unexpected-end n string ; 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 @@ -93,12 +78,10 @@ ERROR: expected-sequence-error expected actual ; 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 ) @@ -141,9 +124,6 @@ ERROR: expected-sequence-error expected actual ; : empty-slice-end ( seq -- slice ) [ length dup ] [ ] bi ; inline -: empty-slice-from ( n seq -- slice ) - dupd ; inline - :: slice-til-eol ( n string -- n' string slice/f ch/f ) n [ n string '[ "\r\n" member? ] find-from :> ( n' ch ) @@ -154,24 +134,11 @@ ERROR: expected-sequence-error expected actual ; 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 ? - 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 @@ -181,25 +148,6 @@ ERROR: expected-sequence-error expected actual ; : slice-before ( slice -- slice' ) [ drop 0 ] [ from>> ] [ seq>> ] tri ; -: (?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 @@ -243,15 +191,15 @@ ERROR: subseq-expected-but-got-eof n string expected ; '[ from>> _ + ] [ to>> ] [ seq>> ] tri ; : modify-to ( slice n -- slice' ) - [ [ from>> ] [ to>> ] [ seq>> ] tri ] dip - swap [ + ] dip ; + [ from>> ] swap '[ to>> _ + ] [ seq>> ] tri ; 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 ) diff --git a/extra/sequences/extras/extras.factor b/extra/sequences/extras/extras.factor index ae0de0ae73..b9443bca8d 100644 --- a/extra/sequences/extras/extras.factor +++ b/extra/sequences/extras/extras.factor @@ -704,7 +704,7 @@ PRIVATE> : 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 ] [ diff --git a/extra/shuffle/extras/authors.txt b/extra/shuffle/extras/authors.txt deleted file mode 100644 index 7c1b2f2279..0000000000 --- a/extra/shuffle/extras/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/shuffle/extras/extras-tests.factor b/extra/shuffle/extras/extras-tests.factor deleted file mode 100644 index b94d7fae8c..0000000000 --- a/extra/shuffle/extras/extras-tests.factor +++ /dev/null @@ -1,58 +0,0 @@ -! 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 diff --git a/extra/shuffle/extras/extras.factor b/extra/shuffle/extras/extras.factor deleted file mode 100644 index 4dd56d58bc..0000000000 --- a/extra/shuffle/extras/extras.factor +++ /dev/null @@ -1,56 +0,0 @@ -! 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 -- 2.34.1