diff --git a/examples/homology.factor b/contrib/topology/homology.factor similarity index 97% rename from examples/homology.factor rename to contrib/topology/homology.factor index a4c495e302..014eaf8f09 100644 --- a/examples/homology.factor +++ b/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 ; diff --git a/examples/hopf.factor b/contrib/topology/hopf.factor similarity index 97% rename from examples/hopf.factor rename to contrib/topology/hopf.factor index ea18b2d518..82438fffe7 100644 --- a/examples/hopf.factor +++ b/contrib/topology/hopf.factor @@ -1,9 +1,11 @@ -! Finitely generated Hopf algebras. -! Making this efficient is left as an exercise for the reader. +! Copyright (C) 2006 Slava Pestov. +! 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. diff --git a/contrib/topology/load.factor b/contrib/topology/load.factor new file mode 100644 index 0000000000..1947d59396 --- /dev/null +++ b/contrib/topology/load.factor @@ -0,0 +1,3 @@ +PROVIDE: topology +{ "matrix.factor" "homology.factor" "hopf.factor" } +{ "test/matrix.factor" } ; diff --git a/contrib/topology/matrix.factor b/contrib/topology/matrix.factor new file mode 100644 index 0000000000..9895f99043 --- /dev/null +++ b/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 ; + +: 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 - ; diff --git a/contrib/topology/test/matrix.factor b/contrib/topology/test/matrix.factor new file mode 100644 index 0000000000..c5fd138f44 --- /dev/null +++ b/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