Delete empty unit tests files, remove 1- and 1+, reorder IN: lines in a lot of places...

[factor.git] / extra / koszul / koszul.factor

diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor
index aecae1cf881d92102d29cfb6763e3896c55dc837..59efec1c02302124c896aa0956fc71e538470e8b 100755 (executable)
--- a/extra/koszul/koszul.factor
+++ b/extra/koszul/koszul.factor
@@ -1,13 +1,13 @@
 ! Copyright (C) 2006, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: 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
-: -1^ odd? -1 1 ? ;
+: -1^ ( m -- n ) odd? -1 1 ? ;
 
 : >alt ( obj -- vec )
     {
@@ -18,7 +18,7 @@ IN: koszul
         [ 1array >alt ]
     } cond ;
 
-: canonicalize
+: canonicalize ( assoc -- assoc' )
     [ nip zero? not ] assoc-filter ;
 
 SYMBOL: terms
@@ -41,7 +41,7 @@ SYMBOL: terms
         nip number>string
     ] [
         num-alt.
-        swap [ word-name ] map "." join
+        swap [ name>> ] map "." join
         append
     ] if ;
 
@@ -75,7 +75,7 @@ SYMBOL: terms
 
 : 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 -- ? )
@@ -108,20 +108,19 @@ SYMBOL: boundaries
 
 : ((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
 
@@ -142,13 +141,13 @@ DEFER: (d)
 
 ! Computing a basis
 : graded ( seq -- seq )
-    dup 0 [ length max ] reduce 1+ [ drop V{ } clone ] map
+    dup 0 [ length max ] reduce 1 + [ V{ } clone ] replicate
     [ dup length pick nth push ] reduce ;
 
 : nth-basis-elt ( generators n -- elt )
     over length [
         3dup bit? [ nth ] [ 2drop f ] if
-    ] map [ ] filter 2nip ;
+    ] map sift 2nip ;
 
 : basis ( generators -- seq )
     natural-sort dup length 2^ [ nth-basis-elt ] with map ;
@@ -166,7 +165,7 @@ DEFER: (d)
     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 ;
@@ -177,25 +176,25 @@ DEFER: (d)
 ! 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 ;
 
@@ -207,11 +206,11 @@ DEFER: (d)
     [ v- ] 2map ;
 
 ! Laplacian
-: m.m' dup flip m. ;
-: m'.m dup flip swap m. ;
+: m.m' ( matrix -- matrix' ) dup flip m. ;
+: 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? [
@@ -225,13 +224,13 @@ DEFER: (d)
     ] 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
     ] [
@@ -241,13 +240,13 @@ DEFER: (d)
     ] 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 )
@@ -257,28 +256,29 @@ DEFER: (d)
     [ laplacian-kernel ] graded-laplacian ;
 
 : graded-basis. ( seq -- )
-    dup length [
+    [
         "=== Degree " write pprint
         ": dimension " write dup length .
         [ alt. ] each
-    ] 2each ;
+    ] each-index ;
 
 : bigraded-triple ( u-deg z-deg bigraded-basis -- triple )
     #! d: C(u,z) ---> C(u+2,z-1)
-    [ >r >r 2 - r> 1 + r> ?nth ?nth ] 3keep
-    [ ?nth ?nth ] 3keep
-    >r >r 2 + r> 1 - r> ?nth ?nth
+    [ [ 2 - ] [ 1 + ] [ ] tri* ?nth ?nth ] 
+    [ ?nth ?nth ] 
+    [ [ 2 + ] [ 1 - ] [ ] tri* ?nth ?nth ]
+    3tri
     3array ;
 
 : 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 )
@@ -288,11 +288,11 @@ DEFER: (d)
     [ laplacian-kernel ] bigraded-laplacian ;
 
 : bigraded-basis. ( seq -- )
-    dup length [
+    [
         "=== U-degree " write .
-        dup length [
+        [
             "  === Z-degree " write pprint
             ": dimension " write dup length .
             [ "  " write alt. ] each
-        ] 2each
-    ] 2each ;
+        ] each-index
+    ] each-index ;