factor/examples/homology.factor

157 lines
3.5 KiB
Factor

IN: homology
USING: kernel sequences arrays math words namespaces
hashtables prettyprint io ;
! 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 ;
: <range> ( from to -- seq ) dup <slice> ;
! Simplicial complexes
SYMBOL: basepoint
: {*} ( -- sim )
#! Initial object in category
{ { { basepoint } } } ;
: \/ ( sim sim -- sim )
#! Glue two complexes at base point
(\/) [ prune ] map ;
: +point ( sim -- sim )
#! Adjoint an isolated point
unswons* <point> add swons* ;
: C ( sim -- sim )
#! Cone on a space
<point> over first over add >r swap (C) r> swons* ;
: S ( sim -- sim )
#! Suspension
[
<point> <point> 2dup 2array >r
pick (C) >r swap (C) r> (\/) r> swons*
] keep (\/) ;
: S^0 ( -- sim )
#! Degenerate sphere -- two points
{*} +point ;
: S^ ( n -- sim )
#! Sphere
S^0 swap [ S ] times ;
: D^ ( n -- sim )
#! 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 )
dup length 1 <= [
H{ }
] [
dup length [ over remove-1 dup ] map>hash
] if nip ;
: boundary ( chain -- chain )
H{ } swap [ drop (boundary) symmetric-diff ] hash-each ;
: homology ( sim -- seq )
dup [ [ (boundary) ] map ] map rot-seq
[ row-reduce drop 2array ] 2map ;
: print-matrix ( matrix basis -- )
swap [
swap [
( row basis-elt )
swap hash-member? 1 0 ? pprint bl
] each-with terpri
] each-with ;
2 S^ [ [ [ (boundary) ] map ] map unswons* drop ] keep
[ [ row-reduce 2nip ] 2map ] keep
[ print-matrix terpri ] 2each