diff --git a/contrib/topology/homology.factor b/contrib/topology/homology.factor index 014eaf8f09..d31dc51230 100644 --- a/contrib/topology/homology.factor +++ b/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 -hashtables prettyprint io ; +USING: arrays hashtables io kernel math matrices namespaces +prettyprint sequences topology words ; ! Utilities -: S{ [ [ dup ] map>hash ] [ ] ; parsing - : (lengthen) ( seq n -- seq ) over length - f 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 ; - : ( -- 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 ; -: ( from to -- seq ) dup ; +: rot-seq unclip add ; ! Simplicial complexes SYMBOL: basepoint @@ -41,17 +34,19 @@ SYMBOL: basepoint : +point ( sim -- sim ) #! Adjoint an isolated point - unswons* add swons* ; + unclip add add* ; : C ( sim -- sim ) #! Cone on a space - over first over add >r swap (C) r> swons* ; + [ + dup 1array >r swap (C) r> add* + ] keep (\/) ; : S ( sim -- sim ) #! Suspension [ 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 -: remove-1 ( n seq -- seq ) - >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 - [ row hash-member? ] find-with nip ; - -: kill-column ( basis-elt pivot -- ) - dup 1+ rows [ - 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 ) +! Boundary operator +: (d) ( 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 ) - H{ } swap [ drop (boundary) symmetric-diff ] hash-each ; +: d ( chain -- chain ) + [ (d) ] linear-op ; -: homology ( sim -- seq ) - dup [ [ (boundary) ] map ] map rot-seq - [ row-reduce drop 2array ] 2map ; +: d-matrix ( n sim -- matrix ) + [ ?nth ] 2keep >r 1- r> ?nth [ (d) ] op-matrix ; -: print-matrix ( matrix basis -- ) - swap [ - swap [ - ( row basis-elt ) - swap hash-member? 1 0 ? pprint bl - ] each-with terpri - ] each-with ; +: ker/im-d ( n sim -- ker im ) + #! Dimension of kernel of C_{n-1} --> C_n, subsp. of C_{n-1} + #! Dimension of image C_{n-1} --> C_n, subsp. of C_n + d-matrix null/rank ; -2 S^ [ [ [ (boundary) ] map ] map unswons* drop ] keep -[ [ row-reduce 2nip ] 2map ] keep -[ print-matrix terpri ] 2each +: (H) ( sim -- ) + dup length [ swap ker/im-d 2array ] map-with ; + +: H ( sim -- seq ) + (H) flip first2 rot-seq v- ; diff --git a/contrib/topology/hopf.factor b/contrib/topology/hopf.factor index 82438fffe7..201f777798 100644 --- a/contrib/topology/hopf.factor +++ b/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.) ; + : ( 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/\ - ] 2keep [ second ] 2apply even/\ 2array ; + [ first ] 2apply odd* + ] 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 ; diff --git a/contrib/topology/linear.factor b/contrib/topology/linear.factor new file mode 100644 index 0000000000..5d3d1ac132 --- /dev/null +++ b/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 diff --git a/contrib/topology/load.factor b/contrib/topology/load.factor index 1947d59396..d4d5e5d439 100644 --- a/contrib/topology/load.factor +++ b/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" +} ; diff --git a/contrib/topology/matrix.factor b/contrib/topology/matrix.factor index 9895f99043..ddec9a9ad2 100644 --- a/contrib/topology/matrix.factor +++ b/contrib/topology/matrix.factor @@ -71,6 +71,6 @@ SYMBOL: matrix : row-reduce ( matrix -- matrix' ) [ (row-reduce) ] with-matrix ; -: rank/null ( matrix -- rank null ) - row-reduce [ [ peek zero? not ] subset ] keep +: null/rank ( matrix -- null rank ) + row-reduce [ [ [ zero? ] all? ] subset ] keep [ length ] 2apply over - ; diff --git a/contrib/topology/test/hopf.factor b/contrib/topology/test/hopf.factor new file mode 100644 index 0000000000..ba9abaefe4 --- /dev/null +++ b/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 diff --git a/contrib/topology/test/matrix.factor b/contrib/topology/test/matrix.factor index c5fd138f44..be69de0833 100644 --- a/contrib/topology/test/matrix.factor +++ b/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