added general order functions

collects/data/private/ordered-dict.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 (require racket/dict
          racket/contract/base
+         racket/string
          unstable/prop-contract)
 
 (define-values (prop:ordered-dict ordered-dict? ordered-dict-ref)
@@ -54,3 +55,187 @@
  [dict-iterate-least/>=? search-contract]
  [dict-iterate-greatest/<? search-contract]
  [dict-iterate-greatest/<=? search-contract])
+
+;; ============================================================
+
+(provide natural-cmp
+         datum-cmp)
+
+;; Comparator : any any -> (U '< '= '>)
+
+#|
+natural-cmp : Comparator
+datum-cmp : Comparator
+
+comparators for (most) built-in values
+!! May diverge on cyclical input.
+
+natural-cmp:
+  * restriction to reals equiv to <,=
+
+    real (exact and inexact, #e1 = #i1, +nan.0 not allowed!)
+  < complex
+  < Other
+
+datum-cmp:
+  * restriction to reals NOT EQUIV to <,= (separates exact, inexact)
+
+    exact real
+  < inexact real (+nan.0 > +inf.0)
+  < complex
+  < Other
+
+Other:
+
+    string
+  < bytes
+  < keyword
+  < symbol
+  < bool
+  < char
+  < null
+  < pair
+  < vector
+  < box
+  < prefab
+
+;; FIXME: What else to add? regexps (4 kinds?), syntax, ...
+
+|#
+
+(define (natural-cmp x y)
+  (gen-cmp x y #t))
+
+(define (datum-cmp x y)
+  (gen-cmp x y #f))
+
+(define (gen-cmp x y natural?)
+  (define-syntax-rule (recur x* y*)
+    (gen-cmp x* y* natural?))
+  #|
+  (cond ...
+        [(T? x) ...]
+        ;; at this point, Type(x) > T
+        [(T? y)
+         ;; Type(x) > T = Type(y), so:
+         '>])
+  Assumes arguments are legal.
+  |#
+  (cond [(real? x)
+         (if (real? y)
+             (cond [natural?
+                    (cmp* < = x y)]
+                   [else ;; exact < inexact
+                    (cond [(and (exact? x) (exact? y))
+                           (cmp* < = x y)]
+                          [(exact? x) ;; inexact y
+                           '<]
+                          [(exact? y) ;; inexact x
+                           '>]
+                          [(and (eqv? x +nan.0) (eqv? y +nan.0))
+                           '=]
+                          [(eqv? x +nan.0)
+                           '>]
+                          [(eqv? y +nan.0)
+                           '<]
+                          [else ;; inexact x, inexact y
+                           (cmp* < = x y)])])
+             '<)]
+        [(real? y) '>]
+        [(complex? x)
+         (if (complex? y)
+             (lexico (recur (real-part x) (real-part y))
+                     (recur (imag-part x) (imag-part y)))
+             '<)]
+        [(complex? y) '>]
+        [(string? x)
+         (if (string? y)
+             (cmp* string<? string=? x y)
+             '<)]
+        [(string? y) '>]
+        [(bytes? x)
+         (if (bytes? y)
+             (cmp* bytes<? bytes=? x y)
+             '<)]
+        [(bytes? y) '>]
+        [(keyword? x)
+         (if (keyword? y)
+             (cmp* keyword<? eq? x y)
+             '<)]
+        [(keyword? y) '>]
+        [(symbol? x)
+         (if (symbol? y)
+             (cmp* symbol<? eq? x y)
+             '<)]
+        [(symbol? y) '>]
+        [(boolean? x)
+         (if (boolean? y)
+             (cond [(eq? x y) '=]
+                   [y '<]
+                   [else '>])
+             '<)]
+        [(boolean? y) '>]
+        [(char? x)
+         (if (char? y)
+             (cmp* char<? char=? x y)
+             '<)]
+        [(char? y)
+         '>]
+        [(null? x)
+         (if (null? y)
+             '=
+             '<)]
+        [(null? y) '>]
+        [(pair? x)
+         (if (pair? y)
+             (lexico (recur (car x) (car y)) (recur (cdr x) (cdr y)))
+             '<)]
+        [(pair? y) '>]
+        [(vector? x)
+         (if (vector? y)
+             (vector<? x y 0 natural?)
+             '<)]
+        [(vector? y) '>]
+        [(box? x)
+         (if (box? y)
+             (recur (unbox x) (unbox y))
+             '<)]
+        [(box? y) '>]
+        [(prefab-struct-key x)
+         (if (prefab-struct-key y)
+             (lexico (recur (prefab-struct-key x) (prefab-struct-key y))
+                     (vector<? (struct->vector x) (struct->vector y) 1 natural?))
+             '<)]
+        [(prefab-struct-key y)
+         '>]
+        [else
+         (raise-type-error
+          (if natural? 'natural-cmp 'datum-cmp)
+          (string-join '("number" "string" "bytes" "keyword" "symbol" "boolean" "character"
+                         "null" "pair" "vector" "box"
+                         "or prefab struct")
+                       ", ")
+          0 x y)]))
+
+(define-syntax-rule (cmp* <? =? xe ye)
+  (let ([x xe] [y ye])
+    (if (=? x y) '= (if (<? x y) '< '>))))
+
+(define-syntax-rule (lexico c1 c2)
+  (case c1
+    ((<) '<)
+    ((=) c2)
+    ((>) '>)))
+
+(define (symbol<? x y)
+  (string<? (symbol->string x) (symbol->string y)))
+
+(define (vector<? x y i natural?)
+  (cond [(< i (vector-length x))
+         (if (< i (vector-length y))
+             (lexico (gen-cmp (vector-ref x i) (vector-ref y i) natural?)
+                     (vector<? x y (add1 i) natural?))
+             '>)]
+        [(< i (vector-length y))
+         '<]
+        [else '=]))

collects/data/splay-tree.rkt

@@ -970,15 +970,26 @@ Top-down splay
 ;; Constructors, predicates
 ;; ============================================================
 
-(define (make-splay-tree =? <?
-                         #:key-contract [key-contract any/c]
-                         #:value-contract [value-contract any/c])
+(define (*make-splay-tree cmp key-contract value-contract)
   (let ([mem (make-vector (* NODE-SIZE 4) #f)])
     (set-vnode-key! mem scratch 4)
     (cond [(and (eq? key-contract any/c) (eq? value-contract any/c))
-           (compact-splay-tree mem #f (mkcmp <? =?))]
+           (compact-splay-tree mem #f cmp)]
           [else
-           (compact-splay-tree* mem #f (mkcmp <? =?) key-contract value-contract)])))
+           (compact-splay-tree* mem #f cmp key-contract value-contract)])))
+
+(define (make-splay-tree =? <?
+                         #:key-contract [key-contract any/c]
+                         #:value-contract [value-contract any/c])
+  (*make-splay-tree (mkcmp <? =?) key-contract value-contract))
+
+(define (make-natural-splay-tree #:key-contract [key-contract any/c]
+                                 #:value-contract [value-contract any/c])
+  (*make-splay-tree natural-cmp key-contract value-contract))
+
+(define (make-datum-splay-tree #:key-contract [key-contract any/c]
+                               #:value-contract [value-contract any/c])
+  (*make-splay-tree natural-cmp key-contract value-contract))
 
 (define (make-adjustable-splay-tree #:key-contract [key-contract any/c]
                                     #:value-contract [value-contract any/c])
@@ -1060,6 +1071,12 @@ Top-down splay
   (->* ()
        (#:key-contract contract? #:value-contract contract?)
        splay-tree?)]
+ #|
+ [make-datum-splay-tree
+  (->* ()
+       (#:key-contract contract? #:value-contract contract?)
+       splay-tree?)]
+ |#
 
  [splay-tree? (-> any/c boolean?)]
  [adjustable-splay-tree? (-> any/c boolean?)]

collects/tests/data/ordered-dict.rkt

@@ -180,27 +180,31 @@
 (define (mksplay) (make-splay-tree = <))
 (define (mkadj) (make-adjustable-splay-tree))
 (define (mkcsplay) (make-splay-tree = < #:key-contract number? #:value-contract number?))
+(define (mkdsplay) (make-datum-splay-tree))
 (define (mkskip) (make-skip-list = <))
 (define (mkcskip) (make-skip-list = < #:key-contract number? #:value-contract number?))
 
 (define (performance)
   (display "Using ordered-dict interface, w/ search\n")
   (p "splay-tree" dict-test mksplay #t)
-  (p "adj-splay " dict-test mkadj #t)
+  (p "adj splay " dict-test mkadj #t)
+  (p "dat splay " dict-test mkdsplay #t)
   (p "skip-list " dict-test mkskip #t)
   (p "splay w/ c" dict-test mkcsplay #t)
   (p "skip w/ c " dict-test mkcskip #t)
   (newline)
   (display "Using custom interfaces, w/ search\n")
   (p "splay-tree" splay-test mksplay #t)
-  (p "adj-splay " splay-test mkadj #t)
+  (p "adj splay " splay-test mkadj #t)
+  (p "dat splay " splay-test mkdsplay #t)
   (p "skip-list " skip-test mkskip #t)
   (p "splay w/ c" splay-test mkcsplay #t)
   (p "skip w/ c " skip-test mkcskip #t)
   (newline)
   (display "Using custom interfaces, w/o search\n")
   (p "splay-tree" splay-test mksplay #f)
-  (p "adj-splay " splay-test mksplay #f)
+  (p "adj splay " splay-test mksplay #f)
+  (p "dat splay " splay-test mkdsplay #f)
   (p "skip-list " skip-test mkskip #f)
   (p "splay w/ c" splay-test mkcsplay #f)
   (p "skip w/ c " skip-test mkcskip #f)