generalizations: add generalizations for tuck/over from top of stack

Change the nrotates to nrotated that can dip

diff --git a/core/generalizations/generalizations-tests.factor b/core/generalizations/generalizations-tests.factor
index c59940026e197ee13fe81185847e673c061389fb..f1f3c2d790d25b0a67bbeb1419fcb1d52911133c 100644 (file)
--- a/core/generalizations/generalizations-tests.factor
+++ b/core/generalizations/generalizations-tests.factor
@@ -1,5 +1,5 @@
 USING: arrays ascii generalizations kernel math math.parser
-sequences tools.test ;
+sequences sequences.generalizations tools.test ;
 IN: generalizations.tests
 
 { 1 2 3 4 1 } [ 1 2 3 4 4 npick ] unit-test
@@ -29,11 +29,59 @@ IN: generalizations.tests
 [ [ 1 ] 5 ndip ] must-infer
 { 1 2 3 4 } [ 2 3 4 [ 1 ] 3 ndip ] unit-test
 
-[ [ 1 2 3 ] 2 3 nrotates ] must-infer
-[ [ 1 2 3 ] 2 3 -nrotates ] must-infer
-{ 1 2 3 4 } [ 1 2 3 4  4 4 nrotates ] unit-test
-{ 1 2 3 4 } [ 1 2 3 4  4 4 -nrotates ] unit-test
-{ 4 1 2 3 } [ 1 2 3 4  1 4 -nrotates ] unit-test
+[ [ 1 2 3 ] 2 3 0 nrotated ] must-infer
+[ [ 1 2 3 ] 2 3 0 -nrotated ] must-infer
+{ 1 2 3 4 } [ 1 2 3 4  4 4 0 nrotated ] unit-test
+{ 1 2 3 4 } [ 1 2 3 4  4 4 0 -nrotated ] unit-test
+{ 3 1 2 4 } [ 1 2 3 4  1 3 1 -nrotated ] unit-test
+
+
+{ 1 2 3  1 2 }
+[ 1 2 3  2 1 0 noverd ] unit-test
+
+{ 1 2 3  4 5 6 7 8  1 2 3  9 }
+[ 1 2 3  4 5 6 7 8  9  3 5 1 noverd ] unit-test
+
+{ t }
+[
+    1 2 3 4 5 6 7   8 9    3 2  ntuckd 10 narray
+    1 2 3 4 5 6 7   8 9  1 3 2 mntuckd 10 narray =
+] unit-test
+
+{ 1  4 5  2 3  4 5  6 7 }
+[ 1 2 3 4 5 6 7  2 4 2 mntuckd ] unit-test
+
+{ 1 2 3 4 2 3 4 5 6 5 6 7 }
+[ 1 2 3 4 5 6 7  5 2 1 mntuckd ] unit-test
+
+{ 4 5 6 7  0 1 2 3 4 5 6 7 8 9 } [
+    0 1 2 3   4 5 6 7   8 9
+    4 8 2 mntuckd
+] unit-test
+
+{ 1 2 3 5 4 } [ 1 2 3 4 5  2 0 -nrotd ] unit-test
+{ 1 2 4 3 5 } [ 1 2 3 4 5  2 1 -nrotd ] unit-test
+{ 1 3 2 4 5 } [ 1 2 3 4 5  2 2 -nrotd ] unit-test
+{ 2 1 3 4 5 } [ 1 2 3 4 5  2 3 -nrotd ] unit-test
+
+{ 1 2 3 5 4 } [ 1 2 3 4 5  2 0  nrotd ] unit-test
+{ 1 2 4 3 5 } [ 1 2 3 4 5  2 1  nrotd ] unit-test
+{ 1 3 2 4 5 } [ 1 2 3 4 5  2 2  nrotd ] unit-test
+{ 2 1 3 4 5 } [ 1 2 3 4 5  2 3  nrotd ] unit-test
+
+{ 1 2 5 3 4 } [ 1 2 3 4 5  3 0 -nrotd ] unit-test
+{ 1 2 5 3 4 } [ 1 2 3 4 5  -3 0 nrotd ] unit-test
+{ 1 4 2 3 5 } [ 1 2 3 4 5  3 1 -nrotd ] unit-test
+{ 1 4 2 3 5 } [ 1 2 3 4 5  -3 1 nrotd ] unit-test
+{ 3 1 2 4 5 } [ 1 2 3 4 5  3 2 -nrotd ] unit-test
+{ 3 1 2 4 5 } [ 1 2 3 4 5  -3 2 nrotd ] unit-test
+
+{ 1 2 4 5 3 } [ 1 2 3 4 5  3 0 nrotd ] unit-test
+{ 1 2 4 5 3 } [ 1 2 3 4 5  -3 0 -nrotd ] unit-test
+{ 1 3 4 2 5 } [ 1 2 3 4 5  3 1 nrotd ] unit-test
+{ 1 3 4 2 5 } [ 1 2 3 4 5  -3 1 -nrotd ] unit-test
+{ 2 3 1 4 5 } [ 1 2 3 4 5  3 2 nrotd ] unit-test
+{ 2 3 1 4 5 } [ 1 2 3 4 5  -3 2 -nrotd ] unit-test
 
 [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
 [ 1 2 3 4 5 2 '[ drop drop drop drop drop _ ] 5 nkeep ] must-infer

diff --git a/core/generalizations/generalizations.factor b/core/generalizations/generalizations.factor
index 7876facded88a23ed328061393d93e493ecf6bc1..d03bba74b1d8135c3410fad7796caf33f754b174 100644 (file)
--- a/core/generalizations/generalizations.factor
+++ b/core/generalizations/generalizations.factor
@@ -32,9 +32,6 @@ MACRO: npick ( n -- quot )
         [ 1 - [ dup ] [ '[ _ dip swap ] ] repeat ]
     } cond ;
 
-MACRO: nover ( n -- quot )
-    dup 1 + '[ _ npick ] n*quot ;
-
 : ndup ( n -- )
     [ '[ _ npick ] ] keep call-n ; inline
 
@@ -51,18 +48,57 @@ MACRO: -nrot ( n -- quot )
 : ndip ( n -- )
     [ [ dip ] curry ] swap call-n call ; inline
 
-MACRO: nrotates ( n depth -- quot )
-    '[ [ _ nrot ] ] replicate concat ;
-
-MACRO: -nrotates ( n depth -- quot )
-    '[ [ _ -nrot ] ] replicate concat ;
-
 : ndrop ( n -- )
     [ drop ] swap call-n ; inline
 
 : nnip ( n -- )
     '[ _ ndrop ] dip ; inline
 
+DEFER: -nrotd
+MACRO: nrotd ( n d -- quot )
+    over 0 < [
+        [ neg ] dip '[ _ _ -nrotd ]
+    ] [
+        [ 1 - [ ] [ '[ _ dip swap ] ] repeat ] dip '[ _ _ ndip ]
+    ] if ;
+
+MACRO: -nrotd ( n d -- quot )
+    over 0 < [
+        [ neg ] dip '[ _ _ nrotd ]
+    ] [
+        [ 1 - [ ] [ '[ swap _ dip ] ] repeat ] dip '[ _ _ ndip ]
+    ] if ;
+
+MACRO: nrotated ( nrots depth dip -- quot )
+    [ '[ [ _ nrot ] ] replicate [ ] concat-as ] dip '[ _ _ ndip ] ;
+
+MACRO: -nrotated ( -nrots depth dip -- quot )
+    [ '[ [ _ -nrot ] ] replicate [ ] concat-as ] dip '[ _ _ ndip ] ;
+
+MACRO: nrotate-heightd ( n height dip -- quot )
+    [ '[ [ _ nrot ] ] replicate concat ] dip '[ _ _ ndip ] ;
+
+MACRO: -nrotate-heightd ( n height dip -- quot )
+    [
+        '[ [ _ -nrot ] ] replicate concat
+    ] dip '[ _ _ ndip ] ;
+
+: ndupd ( n dip -- ) '[ [ _ ndup ] _ ndip ] call ; inline
+
+MACRO: ntuckd ( ntuck ndip -- quot )
+    [ 1 + ] dip '[ [ dup _ -nrot ] _ ndip ] ;
+
+MACRO: nover ( n -- quot )
+    dup 1 + '[ _ npick ] n*quot ;
+
+MACRO: noverd ( n depth dip -- quot' )
+    [ + ] [ 2drop ] [ [ + ] dip ] 3tri
+    '[ _ _ ndupd _ _ _ nrotated ] ;
+
+MACRO: mntuckd ( ndup depth ndip -- quot )
+    { [ nip ] [ 2drop ] [ drop + ] [ 2nip ] } 3cleave
+    '[ _ _ ndupd _ _ _ -nrotated ] ;
+
 : nkeep ( n -- )
     dup '[ [ _ ndup ] dip _ ndip ] call ; inline
 

diff --git a/extra/combinators/extras/extras.factor b/extra/combinators/extras/extras.factor
index ff338d2c48b97a347e446fd7950be2c1e5dbf1d3..ec0da1bfc1cac725230b802f5a7312f6c10d9657 100644 (file)
--- a/extra/combinators/extras/extras.factor
+++ b/extra/combinators/extras/extras.factor
@@ -129,17 +129,17 @@ MACRO: chain ( quots -- quot )
     [ 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
+: keep-1up ( quot -- quot ) keep 1 2 0 nrotated ; inline
+: keep-2up ( quot -- quot ) keep 2 3 0 nrotated ; inline
+: keep-3up ( quot -- quot ) keep 3 4 0 nrotated ; 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
+: 2keep-1up ( quot -- quot ) 2keep 1 3 0 nrotated ; inline
+: 2keep-2up ( quot -- quot ) 2keep 2 4 0 nrotated ; inline
+: 2keep-3up ( quot -- quot ) 2keep 3 5 0 nrotated ; 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
+: 3keep-1up ( quot -- quot ) 3keep 1 4 0 nrotated ; inline
+: 3keep-2up ( quot -- quot ) 3keep 2 5 0 nrotated ; inline
+: 3keep-3up ( quot -- quot ) 3keep 3 6 0 nrotated ; inline
 
 ! d is dummy, o is object to save notation space
 : dip-1up  ( ..a d quot: ( ..a -- ..b o d ) -- ..b d o )
@@ -155,9 +155,9 @@ MACRO: chain ( quots -- quot )
 : 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 2 5 0 nrotated ; 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
+    3dip 3 6 0 nrotated ; inline
 
 
 : 2craft-1up ( ..a quot1: ( ..a -- ..b o1 ) quot2: ( ..b -- ..c o2 ) -- ..c o1 o2 )
@@ -177,18 +177,18 @@ MACRO: chain ( quots -- quot )
 
 ! The kept values are on the bottom of the stack
 MACRO: keep-under ( quot -- quot' )
-    dup outputs 1 + '[ _ keep 1 _ -nrotates ] ;
+    dup outputs 1 + '[ _ keep 1 _ 0 -nrotated ] ;
 
 MACRO: 2keep-under ( quot -- quot' )
-    dup outputs 2 + '[ _ 2keep 2 _ -nrotates ] ;
+    dup outputs 2 + '[ _ 2keep 2 _ 0 -nrotated ] ;
 
 MACRO: 3keep-under ( quot -- quot' )
-    dup outputs 3 + '[ _ 3keep 3 _ -nrotates ] ;
+    dup outputs 3 + '[ _ 3keep 3 _ 0 -nrotated ] ;
 
 MACRO: 4keep-under ( quot -- quot' )
-    dup outputs 4 + '[ _ 4keep 4 _ -nrotates ] ;
+    dup outputs 4 + '[ _ 4keep 4 _ 0 -nrotated ] ;
 
 ! 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
+: 2temp2d ( quot: ( a b c d -- e f g h ) -- quot ) '[ 2 4 0 nrotated @ 2 4 0 -nrotated ] ; inline