Starting contrib/topology/

contrib/topology/homology.factor

@@ -1,3 +1,5 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 IN: homology
 USING: kernel sequences arrays math words namespaces
 hashtables prettyprint io ;

contrib/topology/hopf.factor

@@ -1,9 +1,11 @@
-! Finitely generated Hopf algebras.
+! Copyright (C) 2006 Slava Pestov.
-! Making this efficient is left as an exercise for the reader.
+! See http://factorcode.org/license.txt for BSD license.
 USING: arrays errors hashtables io kernel math namespaces parser
 prettyprint sequences words ;
 IN: hopf
 
+! Finitely generated Hopf algebras.
+
 ! An element is represented as a hashtable mapping basis
 ! elements to scalars.
 

contrib/topology/load.factor

@@ -0,0 +1,3 @@
+PROVIDE: topology
+{ "matrix.factor" "homology.factor" "hopf.factor" }
+{ "test/matrix.factor" } ;

contrib/topology/matrix.factor

@@ -0,0 +1,76 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: matrices
+USING: kernel math namespaces parser prettyprint sequences test ;
+
+SYMBOL: matrix
+
+: with-matrix ( matrix quot -- )
+    [ swap matrix set call matrix get ] with-scope ; inline
+
+: nth-row ( row# -- seq ) matrix get nth ;
+
+: nth-col ( col# ignore-rows -- seq )
+    matrix get tail-slice [ nth ] map-with ;
+
+: change-row ( row# quot -- | quot: seq -- seq )
+    matrix get -rot change-nth ; inline
+
+: exchange-rows ( row# row# -- ) matrix get exchange ;
+
+: rows ( -- n ) matrix get length ;
+
+: cols ( -- n ) 0 nth-row length ;
+
+: first-col ( row# -- n )
+    #! First non-zero column
+    0 swap nth-row [ zero? not ] skip ;
+
+: clear-scale ( col# pivot-row i-row -- n )
+    >r over r> nth dup zero? [
+        3drop 0
+    ] [
+        >r nth dup zero? [
+            r> 2drop 0
+        ] [
+            r> swap / neg
+        ] if
+    ] if ;
+
+: (clear-col) ( col# pivot-row i -- )
+    [ [ clear-scale ] 2keep >r n*v r> v+ ] change-row ;
+
+: (each-row) ( row# -- slice )
+    rows dup <slice> ;
+
+: each-row ( row# quot -- )
+    >r (each-row) r> each ; inline
+
+: clear-col ( col# row# -- )
+    [ nth-row ] keep 1+
+    [ >r 2dup r> (clear-col) ] each-row
+    2drop ;
+
+: do-row ( exchange-with row# -- )
+    [ exchange-rows ] keep
+    [ first-col ] keep
+    clear-col ;
+
+: find-row ( row# quot -- i elt )
+    >r (each-row) r> find ; inline
+
+: pivot-row ( col# row# -- n )
+    [ dupd nth-row nth zero? not ] find-row 2nip ;
+
+: (row-reduce) ( -- )
+    0 cols rows min [
+        over pivot-row dup
+        [ over do-row 1+ ] [ drop ] if
+    ] each drop ;
+
+: row-reduce ( matrix -- matrix' )
+    [ (row-reduce) ] with-matrix ;
+
+: rank/null ( matrix -- rank null )
+    row-reduce [ [ peek zero? not ] subset ] keep
+    [ length ] 2apply over - ;

contrib/topology/test/matrix.factor

@@ -0,0 +1,233 @@
+USING: kernel matrices test ;
+
+{
+    { 1 0 0 }
+    { 0 0 1 }
+    { 0 1 0 }
+} [
+    [ 0 ] [ 0 first-col ] unit-test
+    [ 2 ] [ 1 first-col ] unit-test
+    [ 1 ] [ 2 first-col ] unit-test
+] with-matrix drop
+
+[
+    {
+        { 1 0 2 }
+        { 0 0 -3 }
+        { 0 1 -6 }
+    }
+] [
+    {
+        { 1 0 2 }
+        { 2 0 1 }
+        { 3 1 0 }
+    } [
+        0 0 clear-col
+    ] with-matrix
+] unit-test
+
+[ -2 ] [ 0 { 1 2 3 } { 2 7 8 } clear-scale ] unit-test
+
+[
+    {
+        { 1 0 2 }
+        { 0 0 -3 }
+        { 0 1 -6 }
+    }
+] [
+    {
+        { 1 0 2 }
+        { 2 0 1 }
+        { 3 1 0 }
+    } [
+        0 0 clear-col
+    ] with-matrix
+] unit-test
+
+[
+    {
+        { 1 0 0 3 }
+        { 0 2 0 4 }
+        { 0 0 6 8 }
+        { 0 0 0 4 }
+    }
+] [
+    {
+        { 1 0 0 3 }
+        { 0 0 6 8 }
+        { 0 2 0 4 }
+        { 0 0 0 4 }
+    } [
+        0 0 do-row
+        2 1 do-row
+    ] with-matrix
+] unit-test
+
+[
+    {
+        { 1 0 0 1 }
+        { 0 0 6 6 }
+        { 0 2 0 2 }
+        { 0 0 0 2 }
+    }
+] [
+    {
+        { 1 0 0 1 }
+        { 2 0 6 8 }
+        { 2 2 0 4 }
+        { 2 0 0 4 }
+    } [
+        0 0 do-row
+    ] with-matrix
+] unit-test
+
+{
+    { 0 1 0 1 }
+    { 1 0 0 1 }
+    { 1 0 0 0 }
+    { 1 1 0 1 }
+} [
+    [ 1 ] [ 0 0 pivot-row ] unit-test
+] with-matrix drop
+
+[
+    {
+        { 1 0 0 0 }
+        { 0 1 0 0 }
+        { 0 0 1 0 }
+        { 0 0 0 1 }
+    }
+] [
+    {
+        { 1 0 0 0 }
+        { 0 1 0 0 }
+        { 0 0 1 0 }
+        { 0 0 0 1 }
+    } row-reduce
+] unit-test
+
+[
+    {
+        { 1 0 0 0 }
+        { 0 1 0 0 }
+        { 0 0 1 0 }
+        { 0 0 0 1 }
+    }
+] [
+    {
+        { 1 0 0 0 }
+        { 1 1 0 0 }
+        { 1 0 1 0 }
+        { 1 0 0 1 }
+    } row-reduce
+] unit-test
+
+[
+    {
+        { 1 0 0 0 }
+        { 0 1 0 0 }
+        { 0 0 1 0 }
+        { 0 0 0 1 }
+    }
+] [
+    {
+        { 1 0 0 0 }
+        { 1 1 0 0 }
+        { 1 0 1 0 }
+        { 1 1 0 1 }
+    } row-reduce
+] unit-test
+
+[
+    {
+        { 1 0 0 0 }
+        { 0 1 0 0 }
+        { 0 0 1 0 }
+        { 0 0 0 1 }
+    }
+] [
+    {
+        { 1 0 0 0 }
+        { 1 1 0 0 }
+        { 1 1 0 1 }
+        { 1 0 1 0 }
+    } row-reduce
+] unit-test
+
+[
+    {
+        { 1 0 0 0 }
+        { 0 1 0 0 }
+        { 0 0 0 0 }
+        { 0 0 0 0 }
+    }
+] [
+    {
+        { 0 1 0 0 }
+        { 1 0 0 0 }
+        { 1 0 0 0 }
+        { 1 0 0 0 }
+    } [
+        [ 1 ] [ 0 0 pivot-row ] unit-test
+        1 0 do-row
+    ] with-matrix
+] unit-test
+
+[
+    {
+        { 1 0 0 0 }
+        { 0 1 0 0 }
+        { 0 0 0 0 }
+        { 0 0 0 0 }
+    }
+] [
+    {
+        { 0 1 0 0 }
+        { 1 0 0 0 }
+        { 1 0 0 0 }
+        { 1 0 0 0 }
+    } row-reduce
+] unit-test
+
+[
+    {
+        { 1 0 0 0 }
+        { 0 1 0 0 }
+        { 0 0 0 1 }
+        { 0 0 0 0 }
+    }
+] [
+    {
+        { 1 0 0 0 }
+        { 0 1 0 0 }
+        { 1 0 0 1 }
+        { 1 0 0 1 }
+    } row-reduce
+] unit-test
+
+[
+    {
+        { 1 0 0 1 }
+        { 0 1 0 1 }
+        { 0 0 0 -1 }
+        { 0 0 0 0 }
+    }
+] [
+    {
+        { 0 1 0 1 }
+        { 1 0 0 1 }
+        { 1 0 0 0 }
+        { 1 1 0 1 }
+    } row-reduce
+] unit-test
+
+[
+    3 1
+] [
+    {
+        { 0 1 0 1 }
+        { 1 0 0 1 }
+        { 1 0 0 0 }
+        { 1 1 0 1 }
+    } rank/null
+] unit-test