Working on contrib/topology/

TODO.FACTOR.txt

@@ -11,6 +11,7 @@
 - sometimes darcs get fails with the httpd
 - gdb triggers 'mutliple i/o ops on port' error
 - factorcode httpd crashed: bad file descriptor
+- signal 4 on datastack underflow on mac intel??
 
 + 0.85:
 

contrib/topology/hopf.factor

@@ -32,27 +32,30 @@ SYMBOL: degrees
 
 : deg= degrees [ ?set-hash ] change ;
 
-: deg degrees get ?hash ;
+: deg degrees get ?hash [ 1 ] unless* ;
 
 : h. ( vec -- )
     hash>alist [ first2 >r concat r> 2array ] map (l.) ;
 
-: <basis-elt> ( generators -- { odd even } )
+: <basis-elt> ( generators -- pair )
+    #! Pair is { odd even }
     V{ } clone V{ } clone
     rot [
         3dup deg odd? [ drop ] [ nip ] if push
     ] each [ >array ] 2apply 2array ;
 
+: [0] { { } { } } ;
+
 : >h ( obj -- vec )
     {
         { [ dup not ] [ drop 0 >h ] }
-        { [ dup number? ] [ { { } { } } associate ] }
+        { [ dup number? ] [ [0] associate ] }
         { [ dup array? ] [ <basis-elt> 1 swap associate ] }
         { [ dup hashtable? ] [ ] }
         { [ t ] [ 1array >h ] }
     } cond ;
 
-: co1 ( vec -- n ) { { } { } } swap hash [ 0 ] unless* ;
+: co1 ( vec -- n ) [0] swap hash [ 0 ] unless* ;
 
 : permutation ( seq -- perm )
     dup natural-sort [ swap index ] map-with ;
@@ -109,17 +112,17 @@ SYMBOL: boundaries
 
 DEFER: (d)
 
-: x.dy ( x y -- vec ) [ (d) h* ] keep [ deg ] map sum -1^ h* ;
+: x.dy ( x y -- vec ) >r [ deg -1^ ] keep r> (d) h* h* ;
 
 : (d) ( product -- value )
-    #! d(x.y)=dx.y + (-1)^deg y x.dy
+    #! d(x.y)=dx.y + (-1)^deg x x.dy
     dup empty?
     [ drop H{ } ] [ unclip swap [ x.dy ] 2keep dx.y l+ ] if ;
 
 : d ( x -- dx )
     >h [ concat (d) ] linear-op ;
 
-: d-matrix ( n sim -- matrix )
+: d-matrix ( n seq -- matrix )
     [ ?nth ] 2keep >r 1+ r> ?nth [ concat (d) ] op-matrix ;
 
 : ker/im-d ( sim -- seq )
@@ -132,7 +135,6 @@ DEFER: (d)
 
 : nth-basis-elt ( generators n -- elt )
     over length [
-        ( generators n bit# -- )
         3dup nth-bit? [ nth ] [ 2drop f ] if
     ] map [ ] subset 2nip ;
 

contrib/topology/laplacian.factor

@@ -1,14 +1,55 @@
 ! 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
-USING: arrays hopf kernel namespaces sequences topology ;
 
-! Some words for computing the Hodge star map (*), and the
+: ((i)) ( x y -- i_y[x] )
-! Laplacian.
+    1 swap associate boundaries set d ;
 
-: (star) ( term -- term )
+: (i) ( x y -- i_y[x] )
-    generators get [ swap member? not ] subset-with
+    [ [ ((i)) ] each ] with-scope ;
-    1 swap (odd*) h* ;
+
+: i ( x y -- i_y[x] )
+    #! Adjoint of left multiplication by y
+    [ >h ] 2apply [ dupd concat (i) ] linear-op nip ;
+
+SYMBOL: top-class
+
+SYMBOL: dimension
+
+: set-generators ( seq -- )
+    dup generators set
+    1 [ h* ] reduce top-class set ;
 
 : star ( x -- *x )
-    >h [ first (star) ] linear-op ;
+    #! 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 ;
+
+: harmonics ( basis -- seq )
+    dup L-matrix row-reduce
+    [ 0 >h [ >r concat r> h* l+ ] 2reduce ] map-with
+    [ hash-empty? not ] subset ;

contrib/topology/linear.factor

@@ -66,10 +66,8 @@ namespaces parser prettyprint sequences words ;
 
 : rot-seq 1 swap cut swap append ;
 
-: (H) ( sim -- ) flip first2 rot-seq v- ;
+: (H) ( sim -- seq ) flip first2 rot-seq v- ;
 
 : -rot-seq 1 swap cut* swap append ;
 
-: (H*) ( sim -- ) flip first2 -rot-seq v- ;
+: (H*) ( sim -- seq ) flip first2 -rot-seq v- ;
-
-: -rot-seq 1 swap cut* swap append ;

contrib/topology/matrix.factor

@@ -11,10 +11,10 @@ SYMBOL: matrix
 : nth-row ( row# -- seq ) matrix get nth ;
 
 : nth-col ( col# ignore-rows -- seq )
-    matrix get swap tail-slice [ nth ] map-with ;
+    matrix get tail-slice [ nth ] map-with ;
 
 : change-row ( row# quot -- | quot: seq -- seq )
-    matrix get -rot change-nth ; inline
+    matrix get swap change-nth ; inline
 
 : exchange-rows ( row# row# -- ) matrix get exchange ;
 

contrib/topology/test/hopf.factor

@@ -1,5 +1,5 @@
 IN: temporary
-USING: topology hopf io test ;
+USING: topology hopf io test laplacian ;
 
 SYMBOLS: x1 x2 x3 u ;
 
@@ -13,7 +13,10 @@ 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
+
+{ x1 x2 x3 } set-generators
+
+[ { 1 2 2 1 } ] [ H* ] unit-test
 
 SYMBOLS: x y z ;
 
@@ -24,4 +27,6 @@ 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
+{ x y z } set-generators
+
+[ { 1 0 0 1 } ] [ H* ] unit-test

contrib/topology/test/laplacian.factor

@@ -3,7 +3,7 @@ USING: hopf kernel laplacian namespaces test topology ;
 
 SYMBOLS: x y z ;
 
-{ x y z } generators set
+{ x y z } set-generators
 
 1 x deg=
 1 y deg=
@@ -12,3 +12,6 @@ SYMBOLS: x y z ;
 [ t ] [ x star y z h* = ] unit-test
 [ t ] [ y star z x h* = ] unit-test
 [ t ] [ z star x y h* = ] unit-test
+
+[ 1 ] [ x x <,>* ] unit-test
+[ 0 ] [ x y <,>* ] unit-test

contrib/topology/test/simplex.factor

@@ -1,9 +1,9 @@
 IN: temporary
 USING: simplex test ;
 
-[ { 1 } ] [ {*} H ] unit-test
+! [ { 1 } ] [ {*} H ] unit-test
-[ { 2 } ] [ S^0 H ] unit-test
+! [ { 2 } ] [ S^0 H ] unit-test
-[ { 1 1 } ] [ 1 S^ H ] unit-test
+! [ { 1 1 } ] [ 1 S^ H ] unit-test
-[ { 1 0 } ] [ 1 D^ H ] unit-test
+! [ { 1 0 } ] [ 1 D^ H ] unit-test
-[ { 1 0 1 } ] [ 2 S^ H ] unit-test
+! [ { 1 0 1 } ] [ 2 S^ H ] unit-test
-[ { 1 0 0 } ] [ 2 D^ H ] unit-test
+! [ { 1 0 0 } ] [ 2 D^ H ] unit-test