diff --git a/contrib/topology/hopf.factor b/contrib/topology/hopf.factor index 414757c7c4..6cb42f65b4 100644 --- a/contrib/topology/hopf.factor +++ b/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 ) - append dup duplicates? [ +: (odd*) ( n terms -- n terms ) + 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*) ; diff --git a/contrib/topology/laplacian.factor b/contrib/topology/laplacian.factor new file mode 100644 index 0000000000..1b2478613f --- /dev/null +++ b/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 ; diff --git a/contrib/topology/load.factor b/contrib/topology/load.factor index 090cd4ddd6..d7b194939d 100644 --- a/contrib/topology/load.factor +++ b/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" } ; diff --git a/contrib/topology/test/laplacian.factor b/contrib/topology/test/laplacian.factor new file mode 100644 index 0000000000..9be91086fa --- /dev/null +++ b/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