math.matrices: Add stitch. Add Kronecker product.

diff --git a/basis/math/matrices/matrices-tests.factor b/basis/math/matrices/matrices-tests.factor
index 300352da84f5e0339f2f9963956535d411c769d1..7703d2e5243ff143b22658dc10fa2e8ccbf6c5fe 100644 (file)
--- a/basis/math/matrices/matrices-tests.factor
+++ b/basis/math/matrices/matrices-tests.factor
@@ -1,5 +1,5 @@
+USING: math.matrices math.vectors tools.test math kernel ;
 IN: math.matrices.tests
-USING: math.matrices math.vectors tools.test math ;
 
 [
     { { 0 } { 0 } { 0 } }
@@ -199,3 +199,43 @@ USING: math.matrices math.vectors tools.test math ;
 
 [ { { 4181 6765 } { 6765 10946 } } ]
 [ { { 0 1 } { 1 1 } } 20 m^n ] unit-test
+
+{
+    { { 0 5 0 10 } { 6 7 12 14 } { 0 15 0 20 } { 18 21 24 28 } }
+}
+[ { { 1 2 } { 3 4 } } { { 0 5 } { 6 7 } } kron ] unit-test
+
+{
+    {
+        { 1 1 1 1 }
+        { 1 -1 1 -1 }
+        { 1 1 -1 -1 }
+        { 1 -1 -1 1 }
+    }
+} [ { { 1 1 } { 1 -1 } } dup kron ] unit-test
+
+{
+    {
+        { 1 1 1 1 1 1 1 1 }
+        { 1 -1 1 -1 1 -1 1 -1 }
+        { 1 1 -1 -1 1 1 -1 -1 }
+        { 1 -1 -1 1 1 -1 -1 1 }
+        { 1 1 1 1 -1 -1 -1 -1 }
+        { 1 -1 1 -1 -1 1 -1 1 }
+        { 1 1 -1 -1 -1 -1 1 1 }
+        { 1 -1 -1 1 -1 1 1 -1 }
+    }
+} [ { { 1 1 } { 1 -1 } } dup dup kron kron ] unit-test
+
+{
+    {
+        { 1 1 1 1 1 1 1 1 }
+        { 1 -1 1 -1 1 -1 1 -1 }
+        { 1 1 -1 -1 1 1 -1 -1 }
+        { 1 -1 -1 1 1 -1 -1 1 }
+        { 1 1 1 1 -1 -1 -1 -1 }
+        { 1 -1 1 -1 -1 1 -1 1 }
+        { 1 1 -1 -1 -1 -1 1 1 }
+        { 1 -1 -1 1 -1 1 1 -1 }
+    }
+} [ { { 1 1 } { 1 -1 } } dup dup kron swap kron ] unit-test

diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor
index c36401b0b61bdfb05138720e665a6e1a81f9414d..a408ecb975a162c69dcda8cae7fba18d66c99d57 100644 (file)
--- a/basis/math/matrices/matrices.factor
+++ b/basis/math/matrices/matrices.factor
@@ -156,3 +156,10 @@ IN: math.matrices
 : m^n ( m n -- n ) 
     make-bits over first length identity-matrix
     [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;
+
+
+: stitch ( m -- m' )
+    [ ] [ [ append ] 2map ] map-reduce ;
+
+: kron ( m1 m2 -- m )
+    '[ [ _ n*m  ] map ] map stitch stitch ;