! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs hashtables assocs io kernel math
+USING: accessors arrays hashtables assocs io kernel math
math.vectors math.matrices math.matrices.elimination namespaces
parser prettyprint sequences words combinators math.parser
-splitting sorting shuffle symbols sets math.order ;
+splitting sorting shuffle sets math.order ;
IN: koszul
! Utilities
: inversions ( seq -- n )
0 swap [ length ] keep [
- [ nth ] 2keep swap 1+ tail-slice (inversions) +
+ [ nth ] 2keep swap 1 + tail-slice (inversions) +
] curry each ;
: duplicates? ( seq -- ? )
: ((d)) ( basis -- value ) boundaries get at ;
-: dx.y ( x y -- vec ) >r ((d)) r> wedge ;
+: dx.y ( x y -- vec ) [ ((d)) ] dip wedge ;
DEFER: (d)
: x.dy ( x y -- vec ) (d) wedge -1 alt*n ;
: (d) ( product -- value )
- dup empty?
- [ drop H{ } ] [ unclip swap [ x.dy ] 2keep dx.y alt+ ] if ;
+ [ H{ } ] [ unclip swap [ x.dy ] 2keep dx.y alt+ ] if-empty ;
: linear-op ( vec quot -- vec )
[
[
- -rot >r swap call r> alt*n (alt+)
+ -rot [ swap call ] dip alt*n (alt+)
] curry assoc-each
] with-terms ; inline
! Computing a basis
: graded ( seq -- seq )
- dup 0 [ length max ] reduce 1+ [ V{ } clone ] replicate
+ dup 0 [ length max ] reduce 1 + [ V{ } clone ] replicate
[ dup length pick nth push ] reduce ;
: nth-basis-elt ( generators n -- elt )
swap call [ at 0 or ] curry map ; inline
: op-matrix ( domain range quot -- matrix )
- rot [ >r 2dup r> (op-matrix) ] map 2nip ; inline
+ rot [ (op-matrix) ] with with map ; inline
: d-matrix ( domain range -- matrix )
[ (d) ] op-matrix ;
! Graded by degree
: (graded-ker/im-d) ( n seq -- null/rank )
#! d: C(n) ---> C(n+1)
- [ ?nth ] 2keep >r 1+ r> ?nth
+ [ ?nth ] [ [ 1 + ] dip ?nth ] 2bi
dim-im/ker-d ;
: graded-ker/im-d ( graded-basis -- seq )
[ length ] keep [ (graded-ker/im-d) ] curry map ;
: graded-betti ( generators -- seq )
- basis graded graded-ker/im-d flip first2 but-last 0 prefix v- ;
+ basis graded graded-ker/im-d unzip but-last 0 prefix v- ;
! Bi-graded for two-step complexes
: (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank )
#! d: C(u,z) ---> C(u+2,z-1)
- [ ?nth ?nth ] 3keep >r >r 2 + r> 1 - r> ?nth ?nth
+ [ ?nth ?nth ] 3keep [ [ 2 + ] dip 1 - ] dip ?nth ?nth
dim-im/ker-d ;
: bigraded-ker/im-d ( bigraded-basis -- seq )
dup length [
over first length [
- >r 2dup r> spin (bigraded-ker/im-d)
+ [ 2dup ] dip spin (bigraded-ker/im-d)
] map 2nip
] with map ;
: m'.m ( matrix -- matrix' ) dup flip swap m. ;
: empty-matrix? ( matrix -- ? )
- dup empty? [ drop t ] [ first empty? ] if ;
+ [ t ] [ first empty? ] if-empty ;
: ?m+ ( m1 m2 -- m3 )
over empty-matrix? [
] if ;
: laplacian-matrix ( basis1 basis2 basis3 -- matrix )
- dupd d-matrix m.m' >r d-matrix m'.m r> ?m+ ;
+ dupd d-matrix m.m' [ d-matrix m'.m ] dip ?m+ ;
: laplacian-betti ( basis1 basis2 basis3 -- n )
laplacian-matrix null/rank drop ;
: laplacian-kernel ( basis1 basis2 basis3 -- basis )
- >r tuck r>
+ [ tuck ] dip
laplacian-matrix dup empty-matrix? [
2drop f
] [
] if ;
: graded-triple ( seq n -- triple )
- 3 [ 1- + ] with map swap [ ?nth ] curry map ;
+ 3 [ 1 - + ] with map swap [ ?nth ] curry map ;
: graded-triples ( seq -- triples )
dup length [ graded-triple ] with map ;
: graded-laplacian ( generators quot -- seq )
- >r basis graded graded-triples [ first3 ] r> compose map ;
+ [ basis graded graded-triples [ first3 ] ] dip compose map ;
inline
: graded-laplacian-betti ( generators -- seq )
: bigraded-triples ( grid -- triples )
dup length [
over first length [
- >r 2dup r> spin bigraded-triple
+ [ 2dup ] dip spin bigraded-triple
] map 2nip
] with map ;
: bigraded-laplacian ( u-generators z-generators quot -- seq )
- >r [ basis graded ] bi@ tensor bigraded-triples r>
+ [ [ basis graded ] bi@ tensor bigraded-triples ] dip
[ [ first3 ] prepose map ] curry map ; inline
: bigraded-laplacian-betti ( u-generators z-generators -- seq )