Cohomology of Lie algebras (all generators in degree 1)

contrib/topology/homology.factor

@@ -19,8 +19,6 @@ prettyprint sequences topology words ;
 : (\/) ( sim sim -- sim )
     lengthen [ append natural-sort ] 2map ;
 
-: rot-seq unclip add ;
-
 ! Simplicial complexes
 SYMBOL: basepoint
 
@@ -75,13 +73,9 @@ SYMBOL: basepoint
 : d-matrix ( n sim -- matrix )
     [ ?nth ] 2keep >r 1- r> ?nth [ (d) ] op-matrix ;
 
-: ker/im-d ( n sim -- ker im )
+: ker/im-d ( sim -- seq )
     #! 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 ;
+    dup length [ swap d-matrix null/rank 2array ] map-with ;
 
-: (H) ( sim -- )
+: H ( sim -- seq ) ker/im-d (H) ;
-    dup length [ swap ker/im-d 2array ] map-with ;
-
-: H ( sim -- seq )
-    (H) flip first2 rot-seq v- ;

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
+USING: arrays errors hashtables io kernel math matrices
-prettyprint sequences topology words ;
+namespaces parser prettyprint sequences topology words ;
 IN: hopf
 
 ! Finitely generated Hopf algebras.
@@ -111,7 +111,35 @@ DEFER: (d)
 : (d) ( product -- value )
     #! d(x.y)=dx.y + (-1)^deg y x.dy
     dup empty?
-    [ drop 0 ] [ unclip swap [ x.dy ] 2keep dx.y l+ ] if ;
+    [ drop H{ } ] [ unclip swap [ x.dy ] 2keep dx.y l+ ] if ;
 
 : d ( x -- dx )
     >h [ concat (d) ] linear-op ;
+
+: d-matrix ( n sim -- matrix )
+    [ ?nth ] 2keep >r 1+ r> ?nth [ concat (d) ] op-matrix ;
+
+: ker/im-d ( sim -- seq )
+    #! 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
+    dup length [ swap d-matrix null/rank 2array ] map-with ;
+
+: nth-bit? ( m bit# -- ? )
+    1 swap shift bitand 0 > ;
+
+: nth-basis-elt ( generators n -- elt )
+    over length [
+        ( generators n bit# -- )
+        3dup nth-bit? [ nth ] [ 2drop f ] if
+    ] map [ ] subset 2nip ;
+
+: basis ( generators -- seq )
+    [
+        dup length 1+ [ drop V{ } clone ] map \ basis set
+        1 over length shift [
+            nth-basis-elt dup length \ basis get nth push
+        ] each-with
+        \ basis get [ [ { } 2array ] map ] map
+    ] with-scope ;
+
+: H* ( generators -- seq ) basis ker/im-d (H*) ;

contrib/topology/linear.factor

@@ -63,3 +63,13 @@ namespaces parser prettyprint sequences words ;
         ( domain quot basis-elt )
         >r 2dup r> (op-matrix)
     ] map 2nip ; inline
+
+: rot-seq 1 swap cut swap append ;
+
+: (H) ( sim -- ) flip first2 rot-seq v- ;
+
+: -rot-seq 1 swap cut* swap append ;
+
+: (H*) ( sim -- ) flip first2 -rot-seq v- ;
+
+: -rot-seq 1 swap cut* swap append ;

contrib/topology/matrix.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: matrices
-USING: kernel math namespaces parser prettyprint sequences test ;
+USING: kernel math namespaces parser sequences ;
 
 SYMBOL: matrix
 

contrib/topology/test/hopf.factor

@@ -11,3 +11,17 @@ SYMBOLS: x1 x2 x3 u ;
 x1 x2 x3 h* h* u d=
 
 [ "2x1.x2.x3.u\n" ] [ [ u u h* d h. ] string-out ] unit-test
+
+x1 x2 h* x3 d=
+[ { 1 2 2 1 } ] [ { x1 x2 x3 } H* ] unit-test
+
+SYMBOLS: x y z ;
+
+1 x deg=
+1 y deg=
+1 z deg=
+x y h* z d=
+y z h* x d=
+z x h* y d=
+
+[ { 1 0 0 1 } ] [ { x y z } H* ] unit-test