shuffle.extras: Add words to keep args and move the result above the kept args.

diff --git a/extra/modern/modern.factor b/extra/modern/modern.factor
index e29eb3b5ddf6a3d081ab4c78ef5c228c1222d722..06710659a17580159985b41156b8dbf5807ea8e9 100644 (file)
--- a/extra/modern/modern.factor
+++ b/extra/modern/modern.factor
@@ -3,8 +3,8 @@
 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 splitting strings unicode
-vocabs.loader ;
+sequences sequences.extras sets shuffle.extras splitting strings
+unicode vocabs.loader ;
 IN: modern
 
 ERROR: string-expected-got-eof n string ;
@@ -124,9 +124,9 @@ MACRO:: read-matched ( ch -- quot: ( n string tag -- n' string slice' ) )
 :: read-string ( n string tag -- n' string seq )
     n string advance-dquote-payload drop :> n'
     n' string
+    tag
     n n' 1 - string <slice>
-    n' 1 - n' string <slice>
-    tag -rot 3array ;
+    n' 1 - n' string <slice> 3array ;
 
 : take-comment ( n string slice -- n' string comment )
     2over ?nth CHAR: [ = [
@@ -285,7 +285,7 @@ ERROR: colon-word-must-be-all-uppercase-or-lowercase n string word ;
         { [ dup section-open? ] [
             [
                 matching-section-delimiter 1array lex-until
-            ] keep swap unclip-last 3array
+            ] keep-1up unclip-last 3array
         ] }
         ! <foo/>
         { [ dup html-self-close? ] [
@@ -320,7 +320,7 @@ ERROR: colon-word-must-be-all-uppercase-or-lowercase n string word ;
     } cond ;
 
 : read-acute ( n string slice -- n' string acute )
-    [ matching-section-delimiter 1array lex-until ] keep swap unclip-last 3array ;
+    [ matching-section-delimiter 1array lex-until ] keep-1up unclip-last 3array ;
 
 ! Words like append! and suffix! are allowed for now.
 : read-exclamation ( n string slice -- n' string obj )

diff --git a/extra/modern/slices/slices.factor b/extra/modern/slices/slices.factor
index 9d691974a5a6e7951ec24f4ff28e1f45f6d70651..93a3970ce9a897356989c1c38bb376ac4b49b39f 100644 (file)
--- a/extra/modern/slices/slices.factor
+++ b/extra/modern/slices/slices.factor
@@ -255,8 +255,4 @@ ERROR: subseq-expected-but-got-eof n string expected ;
     ] unless ;
 
 : rewind-slice ( n string slice -- n' string )
-    pick [
-        length swap [ - ] dip
-    ] [
-        [ nip ] dip [ [ length ] bi@ - ] keepd
-    ] if ; inline
+    2nip [ from>> ] [ seq>> ] bi ; inline
\ No newline at end of file

diff --git a/extra/shuffle/extras/extras-tests.factor b/extra/shuffle/extras/extras-tests.factor
index 5a6ff08a873995df570b4857223f847609bfe68d..244ba055458db719f1ed939d8d2b6589835490e0 100644 (file)
--- a/extra/shuffle/extras/extras-tests.factor
+++ b/extra/shuffle/extras/extras-tests.factor
@@ -29,3 +29,30 @@ IN: shuffle.extras.tests
     [ [ 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
index 7e8153e762406b9479f9945316e2ab48f547d09b..ef632e74ac2d505e93fa695a2a06df207c9a1c0d 100644 (file)
--- a/extra/shuffle/extras/extras.factor
+++ b/extra/shuffle/extras/extras.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2022 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel shuffle ;
+USING: generalizations kernel shuffle ;
 IN: shuffle.extras
 
 : 6roll ( a b c d e f -- b c d e f a ) [ roll ] 2dip rot ; inline
@@ -9,6 +9,18 @@ IN: shuffle.extras
 
 : 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 ) keep roll ; inline
+: 3keep-2up ( quot -- quot ) keep 5 nrot 5 nrot ; inline
+: 3keep-3up ( quot -- quot ) keep 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