Working on contrib/topology/

contrib/topology/hopf.factor

@@ -25,13 +25,14 @@ IN: hopf
 
 ! Differentiate using d
 
+: ?set-hash ( value key hash/f -- hash )
+    [ [ set-hash ] keep ] [ associate ] if* ;
+
 SYMBOL: degrees
 
-H{ } clone degrees set
+: deg= degrees [ ?set-hash ] change ;
 
-: deg= degrees get set-hash ;
+: deg degrees get ?hash ;
-
-: deg degrees get hash ;
 
 : h. ( vec -- )
     hash>alist [ first2 >r concat r> 2array ] map (l.) ;
@@ -67,14 +68,17 @@ H{ } clone degrees set
 : duplicates? ( seq -- ? )
     dup prune [ length ] 2apply > ;
 
-: odd* ( n terms1 terms2 -- n terms )
+: (odd*) ( n terms -- n terms )
-    append dup duplicates? [
+    dup duplicates? [
         2drop 0 { }
     ] [
         dup permutation inversions -1^ rot *
         swap natural-sort
     ] if ;
 
+: odd* ( n terms1 terms2 -- n terms )
+    append (odd*) ;
+
 : even* ( terms1 terms2 -- terms )
     append natural-sort ;
 
@@ -96,11 +100,10 @@ H{ } clone degrees set
 
 SYMBOL: boundaries
 
-H{ } clone boundaries set
+: d= ( value basis -- )
+    boundaries [ ?set-hash ] change ;
 
-: d= ( value basis -- ) boundaries get set-hash ;
+: ((d)) ( basis -- value ) boundaries get ?hash ;
-
-: ((d)) ( basis -- value ) boundaries get hash ;
 
 : dx.y ( x y -- vec ) >r ((d)) r> h* ;
 
@@ -133,6 +136,8 @@ DEFER: (d)
         3dup nth-bit? [ nth ] [ 2drop f ] if
     ] map [ ] subset 2nip ;
 
+SYMBOL: generators
+
 : basis ( generators -- seq )
     [
         dup length 1+ [ drop V{ } clone ] map \ basis set
@@ -142,4 +147,4 @@ DEFER: (d)
         \ basis get [ [ { } 2array ] map ] map
     ] with-scope ;
 
-: H* ( generators -- seq ) basis ker/im-d (H*) ;
+: H* ( -- seq ) generators get basis ker/im-d (H*) ;

contrib/topology/laplacian.factor

@@ -0,0 +1,14 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: laplacian
+USING: arrays hopf kernel namespaces sequences topology ;
+
+! Some words for computing the Hodge star map (*), and the
+! Laplacian.
+
+: (star) ( term -- term )
+    generators get [ swap member? not ] subset-with
+    1 swap (odd*) h* ;
+
+: star ( x -- *x )
+    >h [ first (star) ] linear-op ;

contrib/topology/load.factor

@@ -4,8 +4,10 @@ PROVIDE: topology
     "linear.factor"
     "simplex.factor"
     "hopf.factor"
+    "laplacian.factor"
 } {
     "test/matrix.factor"
     "test/simplex.factor"
     "test/hopf.factor"
+    "test/laplacian.factor"
 } ;

contrib/topology/test/laplacian.factor

@@ -0,0 +1,14 @@
+IN: temporary
+USING: hopf kernel laplacian namespaces test topology ;
+
+SYMBOLS: x y z ;
+
+{ x y z } generators set
+
+1 x deg=
+1 y deg=
+1 z deg=
+
+[ t ] [ x star y z h* = ] unit-test
+[ t ] [ y star z x h* = ] unit-test
+[ t ] [ z star x y h* = ] unit-test