53 lines
1.1 KiB
Factor
53 lines
1.1 KiB
Factor
! Copyright (C) 2006 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: arrays hashtables hopf kernel math matrices namespaces
|
|
sequences topology ;
|
|
IN: laplacian
|
|
|
|
: ((i)) ( x y -- i_y[x] )
|
|
1 swap associate boundaries set d ;
|
|
|
|
: (i) ( x y -- i_y[x] )
|
|
[ <reversed> [ ((i)) ] each ] with-scope ;
|
|
|
|
: i ( x y -- i_y[x] )
|
|
#! Adjoint of left multiplication by y
|
|
[ >h ] 2apply [ dupd concat (i) ] linear-op nip ;
|
|
|
|
SYMBOL: top-class
|
|
|
|
: set-generators ( seq -- )
|
|
natural-sort
|
|
dup generators set
|
|
1 [ h* ] reduce top-class set ;
|
|
|
|
: star ( x -- *x )
|
|
#! Hodge star involution
|
|
top-class get swap i ;
|
|
|
|
: <,>* ( a b -- n )
|
|
#! Hodge inner product
|
|
star h* star co1 ;
|
|
|
|
: (d*) ( x -- d*[x] )
|
|
[ length 1+ generators get length * 1+ -1^ ] keep
|
|
star d star h* ;
|
|
|
|
: d* ( x -- d*[x] )
|
|
#! Adjoint of the differential
|
|
>h [ concat (d*) ] linear-op ;
|
|
|
|
: [,] ( x y -- z )
|
|
#! Lie bracket
|
|
h* d* ;
|
|
|
|
: L ( z -- Lz )
|
|
#! Laplacian.
|
|
[ d d* ] keep d* d l+ ;
|
|
|
|
: L-matrix ( basis -- matrix )
|
|
dup [ concat L ] op-matrix ;
|
|
|
|
: cohomology ( -- seq )
|
|
generators get basis [ L-matrix null/rank drop ] map ;
|