working on matrices library

library/collections/sequences-epilogue.factor

@@ -79,6 +79,9 @@ M: sequence (tree-each) [ (tree-each) ] seq-each-with ;
 : seq-map ( seq quot -- seq | quot: elt -- elt )
     swap [ swap nmap ] immutable ; inline
 
+: seq-map-with ( obj list quot -- list )
+    swap [ with rot ] seq-map 2nip ; inline
+
 : (2nmap) ( seq1 seq2 i quot -- elt3 )
     pick pick >r >r >r 2nth r> call r> r> swap set-nth ; inline
 
@@ -89,7 +92,7 @@ M: sequence (tree-each) [ (tree-each) ] seq-each-with ;
     ] repeat 3drop ; inline
 
 : seq-2map ( seq1 seq2 quot -- seq | quot: elt1 elt2 -- elt3 )
-    >r clone r> over >r 2nmap r> ; inline
+    swap [ swap 2nmap ] immutable ; inline
 
 ! Operations
 : index* ( obj i seq -- n )

library/math/matrices.factor

@@ -4,19 +4,29 @@ IN: matrices
 USING: errors generic kernel lists math namespaces prettyprint
 sequences stdio test vectors ;
 
-! Vector and matrix math use these generics.
+! The major dimension is the number of elements per row.
+TUPLE: matrix rows cols sequence ;
+
+! Vector and matrix protocol.
 GENERIC: v+
 GENERIC: v-
 GENERIC: v* ( element-wise multiplication )
 GENERIC: v. ( interior multiplication )
 
+: v*n ( vec n -- vec ) swap [ * ] seq-map-with ;
+
 ! On numbers, these operations do the obvious thing
 M: number v+ ( n n -- n ) + ;
 M: number v- ( n n -- n ) - ;
 M: number v* ( n n -- n ) * ;
-M: number v. ( n n -- n ) * ;
+
+M: number v. ( n n -- n )
+    over vector? [ v*n ] [ * ] ifte ;
 
 ! Vector operations
+DEFER: <row-vector>
+DEFER: <col-vector>
+
 M: object v+ ( v v -- v ) [ v+ ] seq-2map ;
 M: object v- ( v v -- v ) [ v- ] seq-2map ;
 M: object v* ( v v -- v ) [ v* ] seq-2map ;
@@ -24,12 +34,15 @@ M: object v* ( v v -- v ) [ v* ] seq-2map ;
 ! Later, this will fixed when seq-2each works properly
 ! M: object v. ( v v -- x ) 0 swap [ * + ] seq-2each ;
 : +/ ( seq -- n ) 0 swap [ + ] seq-each ;
-M: object v. ( v v -- x ) v* +/ ;
 
-! Matrices.
-! The major dimension is the number of elements per row.
-TUPLE: matrix rows cols sequence ;
+GENERIC: vv. ( obj v -- v )
+M: number vv. ( v n -- v ) v*n ;
+M: matrix vv. ( v m -- v )
+    swap <col-vector> v. matrix-sequence ;
+M: object vv. v* +/ ;
+M: object v. ( v v -- x ) swap vv. ;
 
+! Matrices
 M: matrix clone ( matrix -- matrix )
     clone-tuple
     dup matrix-sequence clone over set-matrix-sequence ;
@@ -45,6 +58,14 @@ M: matrix clone ( matrix -- matrix )
 : <zero-matrix> ( rows cols -- matrix )
     2dup * zero-vector <matrix> ;
 
+: <row-vector> ( vector -- matrix )
+    #! Turn a vector into a matrix of one row.
+    [ 1 swap length ] keep <matrix> ;
+
+: <col-vector> ( vector -- matrix )
+    #! Turn a vector into a matrix of one column.
+    [ length 1 ] keep <matrix> ;
+
 : 2repeat ( i j quot -- | quot: i j -- i j )
     rot [
         rot [ [ rot dup slip -rot ] repeat ] keep -rot
@@ -79,7 +100,8 @@ SYMBOL: matrix-maker
 TUPLE: row index matrix ;
 : >row< dup row-index swap row-matrix ;
 M: row length row-matrix matrix-cols ;
-M: row nth ( n row -- ) >row< matrix-get ;
+M: row nth ( n row -- ) >row< swapd matrix-get ;
+M: row thaw >vector ;
 
 ! A sequence of rows.
 TUPLE: row-seq matrix ;
@@ -91,6 +113,7 @@ TUPLE: col index matrix ;
 : >col< dup col-index swap col-matrix ;
 M: col length col-matrix matrix-rows ;
 M: col nth ( n column -- ) >col< swapd matrix-get ;
+M: col thaw >vector ;
 
 ! A sequence of columns.
 TUPLE: col-seq matrix ;
@@ -128,6 +151,7 @@ M: matrix v* ( m m -- m ) matrix+/- v* <matrix> ;
 
 M: matrix v. ( m1 m2 -- m )
     2dup *dimensions [
+        ( m1 m2 row col )
         >r >r 2dup r> rot <row> r> rot <col> v.
     ] make-matrix 2nip ;
 
@@ -136,8 +160,9 @@ M: matrix v. ( m1 m2 -- m )
 : M[ f ; parsing
 
 : ]M
-    reverse [ dup car length swap length ] keep
-    [ [ % ] each ] make-vector <matrix> swons ; parsing
+    reverse
+    [ dup length swap car length ] keep
+    concat >vector <matrix> swons ; parsing
 
 : row-list ( matrix -- list )
     #! A list of lists, where each sublist is a row of the

library/test/math/matrices.factor

@@ -0,0 +1,77 @@
+IN: temporary
+USING: matrices test ;
+
+[
+    M[ [ 0 ] [ 0 ] [ 0 ] ]M
+] [
+    3 1 <zero-matrix>
+] unit-test
+
+[
+    M[ [ 1 ] [ 2 ] [ 3 ] ]M
+] [
+    { 1 2 3 } <col-vector>
+] unit-test
+
+[
+    M[ [ 1 0 0 ]
+       [ 0 1 0 ]
+       [ 0 0 1 ] ]M
+] [
+    3 <identity-matrix>
+] unit-test
+
+[
+    M[ [ 1 0 4 ]
+       [ 0 7 0 ]
+       [ 6 0 3 ] ]M
+] [
+    M[ [ 1 0 0 ]
+       [ 0 2 0 ]
+       [ 0 0 3 ] ]M
+       
+    M[ [ 0 0 4 ]
+       [ 0 5 0 ]
+       [ 6 0 0 ] ]M
+
+    v+
+] unit-test
+
+[
+    M[ [ 1 0 4 ]
+       [ 0 7 0 ]
+       [ 6 0 3 ] ]M
+] [
+    M[ [ 1 0 0 ]
+       [ 0 2 0 ]
+       [ 0 0 3 ] ]M
+       
+    M[ [ 0 0 -4 ]
+       [ 0 -5 0 ]
+       [ -6 0 0 ] ]M
+
+    v-
+] unit-test
+
+[
+    { 10 20 30 }
+] [
+    10 { 1 2 3 } v.
+] unit-test
+
+[
+    { 10 20 30 }
+] [
+    { 1 2 3 } 10 v.
+] unit-test
+
+[
+    { 3 4 }
+] [
+    M[ [ 1 0 ]
+       [ 0 1 ] ]M
+
+    { 3 4 }
+
+    v.
+] unit-test

library/test/test.factor

@@ -70,6 +70,7 @@ SYMBOL: failures
             "stream" "math/bitops"
             "math/math-combinators" "math/rational" "math/float"
             "math/complex" "math/irrational" "math/integer"
+            "math/matrices"
             "httpd/url-encoding" "httpd/html" "httpd/httpd"
             "crashes" "sbuf" "threads" "parsing-word"
             "inference" "dataflow" "interpreter" "alien"