Move more cleave stuff into core

core/combinators/combinators.factor

@@ -5,6 +5,26 @@ USING: arrays sequences sequences.private math.private
 kernel kernel.private math assocs quotations vectors
 hashtables sorting ;
 
+: cleave ( obj seq -- )
+    [ call ] with each ;
+
+: cleave>quot ( seq -- quot )
+    [ [ keep ] curry ] map concat [ drop ] append ;
+
+: 2cleave ( obj seq -- )
+    [ [ call ] 3keep drop ] each 2drop ;
+
+: 2cleave>quot ( seq -- quot )
+    [ [ 2keep ] curry ] map concat [ 2drop ] append ;
+
+: spread>quot ( seq -- quot )
+    [ length [ >r ] <repetition> concat ]
+    [ [ [ r> ] prepend ] map concat ] bi
+    compose ;
+
+: spread ( seq -- )
+    spread>quot call ;
+
 ERROR: no-cond ;
 
 : cond ( assoc -- )

core/inference/transforms/transforms-tests.factor

@@ -32,3 +32,27 @@ TUPLE: a-tuple x y z ;
     { set-a-tuple-x set-a-tuple-x } set-slots ;
 
 [ [ set-slots-test-2 ] infer ] must-fail
+
+TUPLE: color r g b ;
+
+C: <color> color
+
+: cleave-test { [ r>> ] [ g>> ] [ b>> ] } cleave ;
+
+{ 1 3 } [ cleave-test ] must-infer-as
+
+[ 1 2 3 ] [ 1 2 3 <color> cleave-test ] unit-test
+
+[ 1 2 3 ] [ 1 2 3 <color> \ cleave-test word-def call ] unit-test
+
+: 2cleave-test { [ 2array ] [ + ] [ - ] } 2cleave ;
+
+[ { 1 2 } 3 -1 ] [ 1 2 2cleave-test ] unit-test
+
+[ { 1 2 } 3 -1 ] [ 1 2 \ 2cleave-test word-def call ] unit-test
+
+: spread-test { [ sq ] [ neg ] [ recip ] } spread ;
+
+[ 16 -3 1/6 ] [ 4 3 6 spread-test ] unit-test
+
+[ 16 -3 1/6 ] [ 4 3 6 \ spread-test word-def call ] unit-test

core/inference/transforms/transforms.factor

@@ -39,6 +39,12 @@ IN: inference.transforms
     ] if
 ] 1 define-transform
 
+\ cleave [ cleave>quot ] 1 define-transform
+
+\ 2cleave [ 2cleave>quot ] 1 define-transform
+
+\ spread [ spread>quot ] 1 define-transform
+
 ! Bitfields
 GENERIC: (bitfield-quot) ( spec -- quot )
 

extra/combinators/cleave/cleave.factor

@@ -3,76 +3,6 @@ USING: kernel sequences macros ;
 
 IN: combinators.cleave
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! The cleaver family
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bi  ( x p q   -- p(x) q(x)      ) >r keep r> call          ; inline
-: tri ( x p q r -- p(x) q(x) r(x) ) >r pick >r bi r> r> call ; inline
-
-: tetra ( obj quot quot quot quot -- val val val val )
-  >r >r pick >r bi r> r> r> bi ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: 2bi ( x y p q -- p(x,y) q(x,y) ) >r 2keep r> call ; inline
-
-: 2tri ( x y z p q r -- p(x,y,z) q(x,y,z) r(x,y,z) )
-  >r >r 2keep r> 2keep r> call ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! General cleave
-
-MACRO: cleave ( seq -- )
-  dup
-    [ drop [ dup ] ] map concat
-  swap
-  dup
-    [ drop [ >r ] ]  map concat
-  swap
-    [ [ r> ] append ] map concat
-  3append
-    [ drop ]
-  append ;
-
-MACRO: 2cleave ( seq -- )
-  dup
-    [ drop [ 2dup ] ] map concat
-  swap
-  dup
-    [ drop [ >r >r ] ] map concat
-  swap
-    [ [ r> r> ] append ] map concat
-  3append
-    [ 2drop ]
-  append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! The spread family
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bi* ( x y p q -- p(x) q(y) ) >r swap slip r> call ; inline
-
-: 2bi* ( w x y z p q -- p(x) q(y) ) >r -rot 2slip r> call ; inline
-
-: tri* ( x y z p q r -- p(x) q(y) r(z) )
-  >r rot >r bi* r> r> call ; inline
-
-: tetra* ( obj obj obj obj quot quot quot quot -- val val val val )
-  >r roll >r tri* r> r> call ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! General spread
-
-MACRO: spread ( seq -- )
-  dup
-    [ drop [ >r ] ]        map concat
-  swap
-    [ [ r> ] prepend ] map concat
-  append ;
-
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! Cleave into array
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!