New sorting comparison operators

core/math/math.factor

@@ -17,6 +17,11 @@ MATH: <= ( x y -- ? ) foldable
 MATH: >  ( x y -- ? ) foldable
 MATH: >= ( x y -- ? ) foldable
 
+: after? ( obj1 obj2 -- ? ) <=> 0 > ; inline
+: before? ( obj1 obj2 -- ? ) <=> 0 < ; inline
+: after=? ( obj1 obj2 -- ? ) <=> 0 >= ; inline
+: before=? ( obj1 obj2 -- ? ) <=> 0 <= ; inline
+
 MATH: +   ( x y -- z ) foldable
 MATH: -   ( x y -- z ) foldable
 MATH: *   ( x y -- z ) foldable

core/sorting/sorting-tests.factor

@@ -11,7 +11,7 @@ unit-test
 [ t ] [
     100 [
         drop
-        100 [ drop 20 random [ drop 1000 random ] map ] map natural-sort [ <=> 0 <= ] monotonic?
+        100 [ drop 20 random [ drop 1000 random ] map ] map natural-sort [ before=? ] monotonic?
     ] all?
 ] unit-test
 

core/sorting/sorting.factor

@@ -52,7 +52,7 @@ PRIVATE>
 
 : sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ;
 
-: sort-pair ( a b -- c d ) 2dup <=> 0 > [ swap ] when ;
+: sort-pair ( a b -- c d ) 2dup after? [ swap ] when ;
 
 : midpoint ( seq -- elt )
     [ midpoint@ ] keep nth-unsafe ; inline

core/strings/strings-tests.factor

@@ -28,8 +28,8 @@ IN: temporary
 
 [ "end" ] [ "Beginning and end" 14 tail ] unit-test
 
-[ t ] [ "abc" "abd" <=> 0 < ] unit-test
+[ t ] [ "abc" "abd" before? ] unit-test
-[ t ] [ "z" "abd" <=> 0 > ] unit-test
+[ t ] [ "z" "abd" after? ] unit-test
 
 [ 0 10 "hello" subseq ] must-fail
 

extra/alarms/alarms.factor

@@ -29,10 +29,10 @@ SYMBOL: alarm-thread
     notify-alarm-thread ;
 
 : alarm-expired? ( alarm now -- ? )
-    >r alarm-time r> <=> 0 <= ;
+    >r alarm-time r> before=? ;
 
 : reschedule-alarm ( alarm -- )
-    dup alarm-time over alarm-interval +dt
+    dup alarm-time over alarm-interval time+
     over set-alarm-time
     register-alarm ;
 

extra/opengl/capabilities/capabilities.factor

@@ -26,8 +26,8 @@ IN: opengl.capabilities
 : version-seq ( version-string -- version-seq )
     "." split [ string>number ] map ;
 
-: version<=> ( version1 version2 -- n )
+: version-before? ( version1 version2 -- ? )
-    swap version-seq swap version-seq <=> ;
+    swap version-seq swap version-seq before=? ;
 
 : (gl-version) ( -- version vendor )
     GL_VERSION glGetString " " split1 ;
@@ -36,7 +36,7 @@ IN: opengl.capabilities
 : gl-vendor-version ( -- version )
     (gl-version) nip ;
 : has-gl-version? ( version -- ? )
-    gl-version version<=> 0 <= ;
+    gl-version version-before? ;
 : (make-gl-version-error) ( required-version -- )
     "Required OpenGL version " % % " not supported (" % gl-version % " available)" % ;
 : require-gl-version ( version -- )
@@ -51,7 +51,7 @@ IN: opengl.capabilities
 : glsl-vendor-version ( -- version )
     (glsl-version) nip ;
 : has-glsl-version? ( version -- ? )
-    glsl-version version<=> 0 <= ;
+    glsl-version version-before? ;
 : require-glsl-version ( version -- )
     [ has-glsl-version? ]
     [ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ]

extra/trees/avl/avl.factor

@@ -53,14 +53,14 @@ TUPLE: avl-node balance ;
 DEFER: avl-set
 
 : avl-insert ( value key node -- node taller? )
-    2dup node-key key< left right ? [
+    2dup node-key before? left right ? [
         [ node-link avl-set ] keep swap
         >r tuck set-node-link r>
         [ dup current-side get change-balance balance-insert ] [ f ] if
     ] with-side ;
 
 : (avl-set) ( value key node -- node taller? )
-    2dup node-key key= [
+    2dup node-key = [
         -rot pick set-node-key over set-node-value f
     ] [ avl-insert ] if ;
 

extra/trees/trees.factor

@@ -61,10 +61,6 @@ SYMBOL: current-side
     #! side is -1 if k1 < k2, 0 if they are equal, or 1 if k1 > k2
     <=> sgn ;
 
-: key< ( k1 k2 -- ? ) <=> 0 < ;
-: key> ( k1 k2 -- ? ) <=> 0 > ;
-: key= ( k1 k2 -- ? ) <=> zero? ;
-
 : random-side ( -- side ) left right 2array random ;
 
 : choose-branch ( key node -- key node-left/right )
@@ -72,7 +68,7 @@ SYMBOL: current-side
 
 : node-at* ( key node -- value ? )
     [
-        2dup node-key key= [
+        2dup node-key = [
             nip node-value t
         ] [
             choose-branch node-at*
@@ -97,8 +93,8 @@ M: tree set-at ( value key tree -- )
 
 : valid-node? ( node -- ? )
     [
-        dup dup node-left [ node-key swap node-key key< ] when* >r
+        dup dup node-left [ node-key swap node-key before? ] when* >r
-        dup dup node-right [ node-key swap node-key key> ] when* r> and swap
+        dup dup node-right [ node-key swap node-key after? ] when* r> and swap
         dup node-left valid-node? swap node-right valid-node? and and
     ] [ t ] if* ;
 

extra/ui/gadgets/editors/editors.factor

@@ -256,7 +256,7 @@ M: editor gadget-text* editor-string % ;
     } at T{ one-line-elt } or ;
 
 : drag-direction? ( loc editor -- ? )
-    editor-mark* <=> 0 < ;
+    editor-mark* before? ;
 
 : drag-selection-caret ( loc editor element -- loc )
     >r [ drag-direction? ] 2keep