More topology work
slava
parent
fadf7bca30
commit
75456f99de
|
|
@ -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 <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
|
||||
: 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 <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 )
|
||||
! 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- ;
|
||||
|
|
|
|||
|
|
@ -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/\
|
||||
] 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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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"
|
||||
} ;
|
||||
|
|
|
|||
|
|
@ -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 - ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue