IN: homology
USING: hashtables io kernel math namespaces prettyprint
sequences test ;

: symmetric-diff ( hash hash -- hash )
    clone swap [
        drop dup pick hash [
            over remove-hash
        ] [
            dup pick set-hash
        ] if
    ] hash-each ;

: S{ [ [ dup ] map>hash ] [ ] ; parsing

: remove-1 ( n seq -- seq )
    >r { } swap dup 1+ r> replace-slice ;

: (boundary) ( seq -- chain )
    dup length 1 <= [
        H{ }
    ] [
        dup length [ over remove-1 dup ] map>hash
    ] if nip ;

: boundary ( chain -- chain )
    hash-keys H{ } [ (boundary) symmetric-diff ] reduce ;

: bit? ( n x -- ? )
    >r 1 swap shift r> bitand 0 > ;

: (power-set) ( n simplices -- seq )
    [
        dup length [
            pick bit? [ dup set ] [ drop ] if
        ] 2each drop
    ] make-hash ;

: power-set ( simplices -- chains )
    1 over length shift [ swap (power-set) ] map-with ;

: boundaries ( chain-complex -- chain-complex )
    [
        1 swap tail-slice [ [ boundary dup ] map>hash , ] each
        S{ S{ } } ,
    ] { } make ;

: cycles ( chain-complex -- chain-complex )
    [ [ boundary hash-empty? ] subset ] map ;

: class-of ( kernel chain chains -- chains )
    [ >r 2dup r> symmetric-diff swap hash-member? ] subset 2nip ;

: quotient ( kernel chains -- quotient )
    dup [ >r 2dup r> swap class-of dup ] map>hash 2nip ;

: homology ( simplices -- homology )
    [ power-set ] map
    dup boundaries swap cycles
    [ quotient ] 2map ;

: quotient. ( quotient -- )
    hash-keys dup length [
        "  + Equivalence class #" write number>string print
        [ "      " write hash-keys . ] each terpri
    ] 2each ;

: chains. ( chain-complex -- )
    dup length [
        number>string write "-dimensional holes: " write
        hash-size log2 number>string print
    ] 2each ;

: homology. " --> " write dup . homology chains. ;

terpri
"0-dimensional holes correspond to connected components." print
"A path connected space has exactly one component (0-dimensional hole)." print
"A 1-connected space is path connected and has no holes of dimension 1." print
"A contractible space is path connected, and has no holes of dimension 1 and higher." print
terpri terpri
"==== One-point space - contractable:" print
{ { { 1 } } } homology.

terpri terpri
"==== Two-point space (0-sphere) - not path connected, so not contractible:" print
{ { { 1 } { 2 } } } homology.

terpri terpri
"==== Unit interval (1-disc) - contractible:" print
{ { { 1 } { 2 } } { { 1 2 } } } homology.

terpri terpri
"==== 1-sphere - not 1-connected, so not contractible:" print
{ { { 1 } { 2 } { 3 } } { { 1 2 } { 2 3 } { 1 3 } } } homology.

terpri terpri
"==== 1-disc - contractible:" print
{ { { 1 } { 2 } { 3 } } { { 1 2 } { 1 2 } { 1 3 } } { { 1 2 3 } } } homology.

terpri terpri
"==== 2-sphere - 1-connected but not contractible:" print
{
    { { 1 } { 2 } { 3 } { 4 } }
    { { 1 2 } { 1 3 } { 1 4 } { 2 3 } { 2 4 } { 3 4 } }
    { { 1 2 3 } { 1 2 4 } { 2 3 4 } { 1 3 4 } }
} homology.

terpri terpri
"==== 2-disc - contractible:" print
{
    { { 1 } { 2 } { 3 } { 4 } }
    { { 1 2 } { 1 3 } { 1 4 } { 2 3 } { 2 4 } { 3 4 } }
    { { 1 2 3 } { 1 2 4 } { 2 3 4 } { 1 3 4 } }
    { { 1 2 3 4 } }
} homology.