More topology work

contrib/topology/homology.factor

@@ -1,32 +1,25 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: homology
-USING: kernel sequences arrays math words namespaces
+USING: arrays hashtables io kernel math matrices namespaces
-hashtables prettyprint io ;
+prettyprint sequences topology words ;
 
 ! Utilities
-: S{ [ [ dup ] map>hash ] [ ] ; parsing
-
 : (lengthen) ( seq n -- seq )
     over length - f <array> append ;
 
 : lengthen ( sim sim -- sim sim )
     2dup max-length tuck (lengthen) >r (lengthen) r> ;
 
-: unswons* 1 over tail swap first ;
-
-: swons* 1array swap append ;
-
-: rot-seq ( seq -- seq ) unswons* add ;
-
 : <point> ( -- sim ) gensym 1array ;
 
 : (C) ( point sim -- sim )
     [ [ append natural-sort ] map-with ] map-with ;
 
-: (\/) ( sim sim -- sim ) lengthen [ append natural-sort ] 2map ;
+: (\/) ( sim sim -- sim )
+    lengthen [ append natural-sort ] 2map ;
 
-: <range> ( from to -- seq ) dup <slice> ;
+: rot-seq unclip add ;
 
 ! Simplicial complexes
 SYMBOL: basepoint
@@ -41,17 +34,19 @@ SYMBOL: basepoint
 
 : +point ( sim -- sim )
     #! Adjoint an isolated point
-    unswons* <point> add swons* ;
+    unclip <point> add add* ;
 
 : C ( sim -- sim )
     #! Cone on a space
-    <point> over first over add >r swap (C) r> swons* ;
+    [
+        <point> dup 1array >r swap (C) r> add*
+    ] keep (\/) ;
 
 : S ( sim -- sim )
     #! Suspension
     [
         <point> <point> 2dup 2array >r
-        pick (C) >r swap (C) r> (\/) r> swons*
+        pick (C) >r swap (C) r> (\/) r> add*
     ] keep (\/) ;
 
 : S^0 ( -- sim )
@@ -66,93 +61,27 @@ SYMBOL: basepoint
     #! Disc
     1- S^ C ;
 
-! Mod 2 matrix algebra
+! Boundary operator
-: remove-1 ( n seq -- seq )
+: (d) ( seq -- chain )
-    >r { } swap dup 1+ r> replace-slice ;
-
-: symmetric-diff ( hash hash -- hash )
-    clone swap [
-        drop dup pick hash [
-            over remove-hash
-        ] [
-            dup pick set-hash
-        ] if
-    ] hash-each ;
-
-SYMBOL: row-basis
-SYMBOL: matrix
-SYMBOL: current-row
-
-: rows ( -- n ) matrix get length ;
-
-: exchange-rows ( m n -- )
-    2dup = [ 2drop ] [ matrix get exchange ] if ;
-
-: row ( n -- row ) matrix get nth ;
-
-: set-row ( row n -- ) matrix get set-nth ;
-
-: add-row ( src# dst# -- )
-    [ [ row ] 2apply symmetric-diff ] keep set-row ;
-
-: pivot-row ( basis-elt -- n )
-    current-row get rows <range>
-    [ row hash-member? ] find-with nip ;
-
-: kill-column ( basis-elt pivot -- )
-    dup 1+ rows <range> [
-        pick over row hash-member? [ dupd add-row ] [ drop ] if
-    ] each 2drop ;
-
-: with-matrix ( matrix basis quot -- matrix )
-    [
-        >r row-basis set matrix set r> call matrix get
-    ] with-scope ; inline
-
-: (row-reduce)
-    0 current-row set
-    row-basis get [
-        dup pivot-row dup [
-            current-row get exchange-rows
-            current-row get kill-column
-            current-row inc
-        ] [
-            2drop
-        ] if
-    ] each ;
-
-: ker/im ( -- ker im )
-    matrix get [ hash-empty? ] subset length
-    row-basis get [
-        matrix get [ hash-member? ] contains-with?
-    ] subset length ;
-
-: row-reduce ( matrix basis -- rowsp colsp matrix )
-    [ (row-reduce) ker/im ] with-matrix ;
-
-! Mod 2 homology
-: (boundary) ( seq -- chain )
     dup length 1 <= [
         H{ }
     ] [
-        dup length [ over remove-1 dup ] map>hash
+        dup length [ 2dup >r remove-nth r> -1^ ] map>hash
     ] if nip ;
 
-: boundary ( chain -- chain )
+: d ( chain -- chain )
-    H{ } swap [ drop (boundary) symmetric-diff ] hash-each ;
+    [ (d) ] linear-op ;
 
-: homology ( sim -- seq )
+: d-matrix ( n sim -- matrix )
-    dup [ [ (boundary) ] map ] map rot-seq
+    [ ?nth ] 2keep >r 1- r> ?nth [ (d) ] op-matrix ;
-    [ row-reduce drop 2array ] 2map ;
 
-: print-matrix ( matrix basis -- )
+: ker/im-d ( n sim -- ker im )
-    swap [
+    #! Dimension of kernel of C_{n-1} --> C_n, subsp. of C_{n-1}
-        swap [
+    #! Dimension of image  C_{n-1} --> C_n, subsp. of C_n
-            ( row basis-elt )
+    d-matrix null/rank ;
-            swap hash-member? 1 0 ? pprint bl
-        ] each-with terpri
-    ] each-with ;
 
-2 S^ [ [ [ (boundary) ] map ] map unswons* drop ] keep
+: (H) ( sim -- )
-[ [ row-reduce 2nip ] 2map ] keep
+    dup length [ swap ker/im-d 2array ] map-with ;
-[ print-matrix terpri ] 2each
+
+: H ( sim -- seq )
+    (H) flip first2 rot-seq v- ;

contrib/topology/hopf.factor

@@ -1,7 +1,7 @@
 ! 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 ;
+prettyprint sequences topology words ;
 IN: hopf
 
 ! Finitely generated Hopf algebras.
@@ -13,9 +13,9 @@ IN: hopf
 
 ! Define degrees using deg=
 
-! Add elements using h+
+! Add elements using l+
 
-! Multiply elements using /\
+! Multiply elements using h*
 
 ! The co-unit is co1
 
@@ -25,14 +25,6 @@ IN: hopf
 
 ! Differentiate using d
 
-: SYMBOLS:
-    string-mode on
-    [ string-mode off [ create-in define-symbol ] each ] f ;
-    parsing
-
-: canonicalize
-    [ nip zero? not ] hash-subset ;
-
 SYMBOL: degrees
 
 H{ } clone degrees set
@@ -41,6 +33,9 @@ H{ } clone degrees set
 
 : deg degrees get hash ;
 
+: h. ( vec -- )
+    hash>alist [ first2 >r concat r> 2array ] map (l.) ;
+
 : <basis-elt> ( generators -- { odd even } )
     V{ } clone V{ } clone
     rot [
@@ -56,37 +51,8 @@ H{ } clone degrees set
         { [ t ] [ 1array >h ] }
     } cond ;
 
-: (h+) ( x -- )
-    >h [ swap +@ ] hash-each ;
-
-: h+ ( x y -- x+y )
-    [ (h+) (h+) ] make-hash canonicalize ;
-
-: hsum ( seq -- vec )
-    [ [ (h+) ] each ] make-hash canonicalize ;
-
-: num-h. ( n -- str )
-    {
-        { [ dup 1 = ] [ drop " + " ] }
-        { [ dup -1 = ] [ drop " - " ] }
-        { [ t ] [ number>string " + " swap append ] }
-    } cond ;
-
 : co1 ( vec -- n ) { { } { } } swap hash [ 0 ] unless* ;
 
-: h. ( vec -- )
-    dup hash-empty? [
-        drop 0 .
-    ] [
-        [
-            [
-                num-h.
-                swap concat [ unparse ] map "/\\" join
-                append ,
-            ] hash-each
-        ] { } make concat " + " ?head drop print
-    ] if ;
-
 : permutation ( seq -- perm )
     dup natural-sort [ swap index ] map-with ;
 
@@ -98,12 +64,10 @@ H{ } clone degrees set
         swap [ nth ] 2keep >r 1+ r> tail-slice (inversions) +
     ] each-with ;
 
-: -1^ odd? -1 1 ? ;
-
 : duplicates? ( seq -- ? )
     dup prune [ length ] 2apply > ;
 
-: odd/\ ( n terms1 terms2 -- n terms )
+: odd* ( n terms1 terms2 -- n terms )
     append dup duplicates? [
         2drop 0 { }
     ] [
@@ -111,20 +75,20 @@ H{ } clone degrees set
         swap natural-sort
     ] if ;
 
-: even/\ ( terms1 terms2 -- terms )
+: even* ( terms1 terms2 -- terms )
     append natural-sort ;
 
-: (/\) ( n basis1 basis2 -- n basis )
+: (h*) ( n basis1 basis2 -- n basis )
     [
-        [ first ] 2apply odd/\
+        [ first ] 2apply odd*
-    ] 2keep [ second ] 2apply even/\ 2array ;
+    ] 2keep [ second ] 2apply even* 2array ;
 
-: /\ ( x y -- x/\y )
+: h* ( x y -- x.y )
     [ >h ] 2apply [
         [
             rot [
                 2swap [
-                    swapd * -rot (/\) +@
+                    swapd * -rot (h*) +@
                 ] 2keep
             ] hash-each 2drop
         ] hash-each-with
@@ -138,16 +102,16 @@ H{ } clone boundaries set
 
 : ((d)) ( basis -- value ) boundaries get hash ;
 
-: dx/\y ( x y -- vec ) >r ((d)) r> /\ ;
+: dx.y ( x y -- vec ) >r ((d)) r> h* ;
 
 DEFER: (d)
 
-: x/\dy ( x y -- vec ) [ (d) /\ ] keep [ deg ] map sum -1^ /\ ;
+: x.dy ( x y -- vec ) [ (d) h* ] keep [ deg ] map sum -1^ h* ;
 
 : (d) ( product -- value )
-    #! d(x/\y)=dx/\y + (-1)^deg y x/\dy
+    #! d(x.y)=dx.y + (-1)^deg y x.dy
     dup empty?
-    [ drop 0 ] [ unclip swap [ x/\dy ] 2keep dx/\y h+ ] if ;
+    [ drop 0 ] [ unclip swap [ x.dy ] 2keep dx.y l+ ] if ;
 
 : d ( x -- dx )
-    >h [ [ swap concat (d) /\ , ] hash-each ] { } make hsum ;
+    >h [ concat (d) ] linear-op ;

contrib/topology/linear.factor

@@ -0,0 +1,65 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: topology
+USING: arrays hashtables hashtables io kernel math math
+namespaces parser prettyprint sequences words ;
+
+: SYMBOLS:
+    string-mode on
+    [ string-mode off [ create-in define-symbol ] each ] f ;
+    parsing
+
+: canonicalize
+    [ nip zero? not ] hash-subset ;
+
+: (l+) ( x -- )
+    [ swap +@ ] hash-each ;
+
+: l+ ( x y -- x+y )
+    [ (l+) (l+) ] make-hash canonicalize ;
+
+: l* ( vec n -- vec )
+    dup zero? [
+        2drop H{ }
+    ] [
+        swap
+        hash>alist [ first2 rot * 2array ] map-with alist>hash
+    ] if ;
+
+: num-l. ( n -- str )
+    {
+        { [ dup 1 = ] [ drop " + " ] }
+        { [ dup -1 = ] [ drop " - " ] }
+        { [ t ] [ number>string " + " swap append ] }
+    } cond ;
+
+: (l.) ( assoc -- )
+    dup empty? [
+        drop 0 .
+    ] [
+        [
+            first2 num-l.
+            swap [ unparse ] map "." join
+            append
+        ] map concat " + " ?head drop print
+    ] if ;
+
+: l. ( vec -- ) hash>alist (l.) ;
+
+: linear-op ( vec quot -- vec )
+    [
+        swap [
+            >r swap call r> l* (l+)
+        ] hash-each-with
+    ] make-hash canonicalize ; inline
+
+: -1^ odd? -1 1 ? ;
+
+: (op-matrix) ( range quot basis-elt -- row )
+    swap call swap [ swap hash [ 0 ] unless* ] map-with ; inline
+
+: op-matrix ( domain range quot -- matrix )
+    rot [
+        ( domain quot basis-elt )
+        >r 2dup r> (op-matrix)
+    ] map 2nip ; inline

contrib/topology/load.factor

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

contrib/topology/matrix.factor

@@ -71,6 +71,6 @@ SYMBOL: matrix
 : row-reduce ( matrix -- matrix' )
     [ (row-reduce) ] with-matrix ;
 
-: rank/null ( matrix -- rank null )
+: null/rank ( matrix -- null rank )
-    row-reduce [ [ peek zero? not ] subset ] keep
+    row-reduce [ [ [ zero? ] all? ] subset ] keep
     [ length ] 2apply over - ;

contrib/topology/test/hopf.factor

@@ -0,0 +1,13 @@
+IN: temporary
+USING: topology hopf io test ;
+
+SYMBOLS: x1 x2 x3 u ;
+
+1 x1 deg=
+1 x2 deg=
+1 x3 deg=
+2 u deg=
+
+x1 x2 x3 h* h* u d=
+
+[ "2x1.x2.x3.u\n" ] [ [ u u h* d h. ] string-out ] unit-test

contrib/topology/test/matrix.factor

@@ -1,3 +1,4 @@
+IN: temporary
 USING: kernel matrices test ;
 
 {
@@ -222,12 +223,12 @@ USING: kernel matrices test ;
 ] unit-test
 
 [
-    3 1
+    1 3
 ] [
     {
         { 0 1 0 1 }
         { 1 0 0 1 }
         { 1 0 0 0 }
         { 1 1 0 1 }
-    } rank/null
+    } null/rank
 ] unit-test