Merge branch 'master' of git://factorcode.org/git/factor

core/kernel/kernel-docs.factor

@@ -254,6 +254,7 @@ $nl
 "Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":"
 { $subsection <=> }
 { $subsection compare }
+{ $subsection invert-comparison }
 "Utilities for comparing objects:"
 { $subsection after? }
 { $subsection before? }

core/math/order/order-docs.factor

@@ -25,6 +25,13 @@ HELP: +eq+
 HELP: +gt+
 { $description "Returned by " { $link <=> } " when the first object is strictly greater than the second object." } ;
 
+HELP: invert-comparison
+{ $values { "symbol" "a comparison symbol, +lt+, +eq+, or +gt+" }
+          { "new-symbol" "a comparison symbol, +lt+, +eq+, or +gt+" } }
+{ $description "Invert the comparison symbol returned by " { $link <=> } ". The output for the symbol " { $snippet "+eq+" } " is itself." }
+{ $examples
+    { $example "USING: math.order prettyprint ;" "+lt+ invert-comparison ." "+gt+" } } ;
+
 HELP: compare
 { $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "symbol" "a comparison symbol, +lt+, +eq+, or +gt+" } }
 { $description "Compares the results of applying the quotation to both objects via " { $link <=> } "." }

core/math/order/order.factor

@@ -11,6 +11,9 @@ GENERIC: <=> ( obj1 obj2 -- n )
 
 : (<=>) - dup 0 < [ drop +lt+ ] [ zero? +eq+ +gt+ ? ] if ;
 
+: invert-comparison ( symbol -- new-symbol )
+    dup +lt+ eq? [ drop +gt+ ] [ +eq+ eq? +eq+ +lt+ ? ] if ;
+
 M: real <=> (<=>) ;
 M: integer <=> (<=>) ;
 

extra/calendar/calendar-tests.factor

@@ -131,16 +131,16 @@ IN: calendar.tests
 [ t ] [ 2004 1 1 23 0 0 9+1/2 hours <timestamp> >gmt
         2004 1 1 13 30 0 instant <timestamp> = ] unit-test
 
-[ 0 ] [ 2004 1 1 13 30 0 instant <timestamp>
+[ +eq+ ] [ 2004 1 1 13 30 0 instant <timestamp>
         2004 1 1 12 30 0 -1 hours <timestamp> <=> ] unit-test
 
-[ 1 ] [ 2004 1 1 13 30 0 instant <timestamp>
+[ +gt+ ] [ 2004 1 1 13 30 0 instant <timestamp>
         2004 1 1 12 30 0 instant <timestamp> <=> ] unit-test
 
-[ -1 ] [ 2004 1 1 12 30 0 instant <timestamp>
+[ +lt+ ] [ 2004 1 1 12 30 0 instant <timestamp>
         2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
 
-[ 1 ] [ 2005 1 1 12 30 0 instant <timestamp>
+[ +gt+ ] [ 2005 1 1 12 30 0 instant <timestamp>
         2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
 
 [ t ] [ now timestamp>millis millis - 1000 < ] unit-test

extra/calendar/format/format.factor

@@ -87,10 +87,10 @@ M: timestamp year. ( timestamp -- )
     [ hh ] [ mm ] bi ;
 
 : write-gmt-offset ( gmt-offset -- )
-    dup instant <=> sgn {
+    dup instant <=> {
-        {  0 [ drop "GMT" write ] }
+        { +eq+ [ drop "GMT" write ] }
-        { -1 [ "-" write before (write-gmt-offset) ] }
+        { +lt+ [ "-" write before (write-gmt-offset) ] }
-        {  1 [ "+" write (write-gmt-offset) ] }
+        { +gt+ [ "+" write (write-gmt-offset) ] }
     } case ;
 
 : timestamp>rfc822 ( timestamp -- str )
@@ -118,10 +118,10 @@ M: timestamp year. ( timestamp -- )
     [ hh ":" write ] [ mm ] bi ;
 
 : write-rfc3339-gmt-offset ( duration -- )
-    dup instant <=> sgn {
+    dup instant <=> {
-        {  0 [ drop "Z" write ] }
+        { +eq+ [ drop "Z" write ] }
-        { -1 [ "-" write before (write-rfc3339-gmt-offset) ] }
+        { +lt+ [ "-" write before (write-rfc3339-gmt-offset) ] }
-        {  1 [ "+" write (write-rfc3339-gmt-offset) ] }
+        { +gt+ [ "+" write (write-rfc3339-gmt-offset) ] }
     } case ;
     
 : (timestamp>rfc3339) ( timestamp -- )

extra/multi-methods/multi-methods.factor

@@ -73,7 +73,7 @@ SYMBOL: total
 ! Part II: Topologically sorting specializers
 : maximal-element ( seq quot -- n elt )
     dupd [
-        swapd [ call 0 < ] 2curry filter empty?
+        swapd [ call +lt+ = ] 2curry filter empty?
     ] 2curry find [ "Topological sort failed" throw ] unless* ;
     inline
 
@@ -82,16 +82,16 @@ SYMBOL: total
     [ dupd maximal-element >r over delete-nth r> ] curry
     [ ] unfold nip ; inline
 
-: classes< ( seq1 seq2 -- -1/0/1 )
+: classes< ( seq1 seq2 -- lt/eq/gt )
     [
         {
-            { [ 2dup eq? ] [ 0 ] }
+            { [ 2dup eq? ] [ +eq+ ] }
-            { [ 2dup [ class< ] 2keep swap class< and ] [ 0 ] }
+            { [ 2dup [ class< ] 2keep swap class< and ] [ +eq+ ] }
-            { [ 2dup class< ] [ -1 ] }
+            { [ 2dup class< ] [ +lt+ ] }
-            { [ 2dup swap class< ] [ 1 ] }
+            { [ 2dup swap class< ] [ +gt+ ] }
-            [ 0 ]
+            [ +eq+ ]
         } cond 2nip
-    ] 2map [ zero? not ] find nip 0 or ;
+    ] 2map [ zero? not ] find nip +eq+ or ;
 
 : sort-methods ( alist -- alist' )
     [ [ first ] bi@ classes< ] topological-sort ;

extra/multi-methods/tests/topological-sort.factor

@@ -6,14 +6,14 @@ IN: multi-methods.tests
     { 6 4 5 1 3 2 } [ <=> ] topological-sort
 ] unit-test
 
-[ -1 ] [
+[ +lt+ ] [
     { fixnum array } { number sequence } classes<
 ] unit-test
 
-[ 0 ] [
+[ +eq+ ] [
     { number sequence } { number sequence } classes<
 ] unit-test
 
-[ 1 ] [
+[ +gt+ ] [
     { object object } { number sequence } classes<
 ] unit-test

extra/trees/trees.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel generic math sequences arrays io namespaces
 prettyprint.private kernel.private assocs random combinators
-parser prettyprint.backend math.order ;
+parser prettyprint.backend math.order accessors ;
 IN: trees
 
 MIXIN: tree-mixin
@@ -25,19 +25,24 @@ TUPLE: node key value left right ;
 
 SYMBOL: current-side
 
-: left -1 ; inline
+: left ( -- symbol ) -1 ; inline
-: right 1 ; inline
+: right ( -- symbol ) 1 ; inline
 
-: go-left? ( -- ? ) current-side get left = ;
+: key-side ( k1 k2 -- n )
+    <=> {
+        { +lt+ [ -1 ] }
+        { +eq+ [ 0 ] }
+        { +gt+ [ 1 ] }
+    } case ;
 
-: inc-count ( tree -- )
+: go-left? ( -- ? ) current-side get left eq? ;
-    dup tree-count 1+ swap set-tree-count ;
 
-: dec-count ( tree -- )
+: inc-count ( tree -- ) [ 1+ ] change-count drop ;
-    dup tree-count 1- swap set-tree-count ;
+
+: dec-count ( tree -- ) [ 1- ] change-count drop ;
 
 : node-link@ ( node ? -- node )
-    go-left? xor [ node-left ] [ node-right ] if ;
+    go-left? xor [ left>> ] [ right>> ] if ;
 : set-node-link@ ( left parent ? -- ) 
     go-left? xor [ set-node-left ] [ set-node-right ] if ;
 
@@ -47,19 +52,16 @@ SYMBOL: current-side
 : set-node+link ( child node -- ) t set-node-link@ ;
 
 : with-side ( side quot -- ) [ swap current-side set call ] with-scope ; inline
-: with-other-side ( quot -- ) current-side get neg swap with-side ; inline
+: with-other-side ( quot -- )
+    current-side get neg swap with-side ; inline
 : go-left ( quot -- ) left swap with-side ; inline
 : go-right ( quot -- ) right swap with-side ; inline
 
 : change-root ( tree quot -- )
-    swap [ tree-root swap call ] keep set-tree-root ; inline
+    swap [ root>> swap call ] keep set-tree-root ; inline
 
 : leaf? ( node -- ? )
-    dup node-left swap node-right or not ;
+    [ left>> ] [ right>> ] bi or not ;
-
-: key-side ( k1 k2 -- side )
-    #! side is -1 if k1 < k2, 0 if they are equal, or 1 if k1 > k2
-    <=> sgn ;
 
 : random-side ( -- side ) left right 2array random ;
 
@@ -76,11 +78,11 @@ SYMBOL: current-side
     ] [ drop f f ] if* ;
 
 M: tree at* ( key tree -- value ? )
-    tree-root node-at* ;
+    root>> node-at* ;
 
 : node-set ( value key node -- node )
-    2dup node-key key-side dup zero? [
+    2dup key>> key-side dup 0 eq? [
-        drop nip [ set-node-value ] keep
+        drop nip swap >>value
     ] [
         [
             [ node-link [ node-set ] [ swap <node> ] if* ] keep
@@ -93,12 +95,12 @@ M: tree set-at ( value key tree -- )
 
 : valid-node? ( node -- ? )
     [
-        dup dup node-left [ node-key swap node-key before? ] when* >r
+        dup dup left>> [ node-key swap node-key before? ] when* >r
-        dup dup node-right [ node-key swap node-key after? ] when* r> and swap
+        dup dup right>> [ node-key swap node-key after? ] when* r> and swap
-        dup node-left valid-node? swap node-right valid-node? and and
+        dup left>> valid-node? swap right>> valid-node? and and
     ] [ t ] if* ;
 
-: valid-tree? ( tree -- ? ) tree-root valid-node? ;
+: valid-tree? ( tree -- ? ) root>> valid-node? ;
 
 : tree-call ( node call -- )
     >r [ node-key ] keep node-value r> call ; inline
@@ -107,20 +109,20 @@ M: tree set-at ( value key tree -- )
     {
         { [ over not ] [ 2drop f f f ] }
         { [ [
-              >r node-left r> find-node
+              >r left>> r> find-node
             ] 2keep rot ]
           [ 2drop t ] }
         { [ >r 2nip r> [ tree-call ] 2keep rot ]
           [ drop [ node-key ] keep node-value t ] }
-        [ >r node-right r> find-node ]
+        [ >r right>> r> find-node ]
     } cond ; inline
 
 M: tree-mixin assoc-find ( tree quot -- key value ? )
-    >r tree-root r> find-node ;
+    >r root>> r> find-node ;
 
 M: tree-mixin clear-assoc
-    0 over set-tree-count
+    0 >>count
-    f swap set-tree-root ;
+    f >>root drop ;
 
 : copy-node-contents ( new old -- )
     dup node-key pick set-node-key node-value swap set-node-value ;
@@ -158,22 +160,22 @@ DEFER: delete-node
 
 : delete-node ( node -- node )
     #! delete this node, returning its replacement
-    dup node-left [
+    dup left>> [
-        dup node-right [
+        dup right>> [
             delete-node-with-two-children
         ] [
-            node-left ! left but no right
+            left>> ! left but no right
         ] if
     ] [
-        dup node-right [
+        dup right>> [
-            node-right ! right but not left
+            right>> ! right but not left
         ] [
             drop f ! no children
         ] if
     ] if ;
 
 : delete-bst-node ( key node -- node )
-    2dup node-key key-side dup zero? [
+    2dup node-key key-side dup 0 eq? [
         drop nip delete-node
     ] [
         [ tuck node-link delete-bst-node over set-node-link ] with-side
@@ -197,7 +199,7 @@ M: tree-mixin assoc-like drop dup tree? [ >tree ] unless ;
 
 M: tree pprint-delims drop \ TREE{ \ } ;
 
-M: tree-mixin assoc-size tree-count ;
+M: tree-mixin assoc-size count>> ;
 M: tree-mixin clone dup assoc-clone-like ;
 M: tree-mixin >pprint-sequence >alist ;
 M: tree-mixin pprint-narrow? drop t ;