combinators.extras: add 4tri*, 4quad, 4tri@

diff --git a/extra/combinators/extras/extras-tests.factor b/extra/combinators/extras/extras-tests.factor
index 2c63ea5cc631616addd9054bbda2696fe88a52d3..5391527b47464292d239c17ea3693084fcc26f13 100644 (file)
--- a/extra/combinators/extras/extras-tests.factor
+++ b/extra/combinators/extras/extras-tests.factor
@@ -68,3 +68,31 @@ splitting tools.test splitting ;
 { 5 } [
     "hello factor!" { [ split-words ] [ first ] [ length ] } chain
 ] unit-test
+
+{
+    { 1 2 3 4 }
+    { 1 2 3 4 }
+    { 1 2 3 4 }
+    { 1 2 3 4 }
+} [
+    1 2 3 4
+    [ 4array ] [ 4array ] [ 4array ] [ 4array ] 4quad
+] unit-test
+
+{
+    { 1 2 3 4 }
+    { 5 6 7 8 }
+    { 9 10 11 12 }
+} [
+    1 2 3 4  5 6 7 8  9 10 11 12
+    [ 4array ] [ 4array ] [ 4array ] 4tri*
+] unit-test
+
+{
+    { 1 2 3 4 }
+    { 5 6 7 8 }
+    { 9 10 11 12 }
+} [
+    1 2 3 4  5 6 7 8  9 10 11 12
+    [ 4array ] 4tri@
+] unit-test
\ No newline at end of file

diff --git a/extra/combinators/extras/extras.factor b/extra/combinators/extras/extras.factor
index 6093eb95d4f62e446233b33b7a8f9070cb1e3644..2b03b1713ac9190da3c4e3c461569416df460010 100644 (file)
--- a/extra/combinators/extras/extras.factor
+++ b/extra/combinators/extras/extras.factor
@@ -34,12 +34,23 @@ MACRO: cleave-array ( quots -- quot )
 : 4bi* ( s t u v w x y z p q -- )
     [ 4dip ] dip call ; inline
 
-: 4bi@ ( s t u v w x y z quot -- )
+: 4tri* ( o p q r  s t u v  w x y z  p q r -- )
+    [ 8 ndip ] 2dip
+    [ 4dip ] dip
+    call ; inline
+
+: 4bi@ ( s t u v  w x y z  quot -- )
     dup 4bi* ; inline
 
-: 4tri ( w x y z p q r -- )
+: 4tri@ ( a b c d  e f g h  i j k l  quot -- )
+    dup dup 4tri* ; inline
+
+: 4tri ( w x y z  p q r -- )
     [ [ 4keep ] dip 4keep ] dip call ; inline
 
+: 4quad ( w x y z  p q r s -- )
+    [ [ [ 4keep ] dip 4keep ] dip 4keep ] dip call ; inline
+
 : plox ( ... x/f quot: ( ... x -- ... y ) -- ... y/f )
     dupd when ; inline