307 lines
8.0 KiB
Racket
307 lines
8.0 KiB
Racket
#lang racket/base
|
|
(require racket/dict
|
|
racket/contract/base
|
|
racket/string
|
|
unstable/prop-contract)
|
|
|
|
(define ordering/c
|
|
(or/c '= '< '>))
|
|
|
|
(provide ordering/c)
|
|
|
|
(define-values (prop:ordered-dict ordered-dict? ordered-dict-ref)
|
|
(make-struct-type-property 'ordered-dict #f))
|
|
|
|
(define extreme-contract
|
|
(->i ([d ordered-dict?])
|
|
[_r (d) (or/c #f (dict-iter-contract d))]))
|
|
|
|
(define search-contract
|
|
(->i ([d ordered-dict?]
|
|
[k (d) (dict-key-contract d)])
|
|
[_r (d) (or/c #f (dict-iter-contract d))]))
|
|
|
|
(define prop:ordered-dict-contract
|
|
(let ([e extreme-contract]
|
|
[s search-contract])
|
|
(vector-immutable/c e ;; iterate-least
|
|
e ;; iterate-greatest
|
|
s ;; iterate-least/>?
|
|
s ;; iterate-least/>=?
|
|
s ;; iterate-greatest/<?
|
|
s)));; iterate-greatest/<=?
|
|
|
|
;; --------
|
|
|
|
(define-syntax-rule (appd d offset arg ...)
|
|
(let ([dv d])
|
|
((vector-ref (ordered-dict-ref dv) offset) dv arg ...)))
|
|
|
|
(define (dict-iterate-least d)
|
|
(appd d 0))
|
|
(define (dict-iterate-greatest d)
|
|
(appd d 1))
|
|
(define (dict-iterate-least/>? d k)
|
|
(appd d 2 k))
|
|
(define (dict-iterate-least/>=? d k)
|
|
(appd d 3 k))
|
|
(define (dict-iterate-greatest/<? d k)
|
|
(appd d 4 k))
|
|
(define (dict-iterate-greatest/<=? d k)
|
|
(appd d 5 k))
|
|
|
|
(provide/contract
|
|
[prop:ordered-dict
|
|
(struct-type-property/c prop:ordered-dict-contract)]
|
|
[ordered-dict? (-> any/c boolean?)]
|
|
[dict-iterate-least extreme-contract]
|
|
[dict-iterate-greatest extreme-contract]
|
|
[dict-iterate-least/>? search-contract]
|
|
[dict-iterate-least/>=? search-contract]
|
|
[dict-iterate-greatest/<? search-contract]
|
|
[dict-iterate-greatest/<=? search-contract])
|
|
|
|
;; ============================================================
|
|
|
|
(struct order (name domain-contract comparator =? <?)
|
|
#:property prop:procedure (struct-field-index comparator))
|
|
|
|
(define order*
|
|
(let ([order
|
|
(case-lambda
|
|
[(name ctc cmp)
|
|
(order name ctc cmp
|
|
(lambda (x y) (eq? (cmp x y) '=))
|
|
(lambda (x y) (eq? (cmp x y) '<)))]
|
|
[(name ctc = <)
|
|
(order name ctc
|
|
(lambda (x y)
|
|
(cond [(= x y) '=]
|
|
[(< x y) '<]
|
|
[(< y x) '>]
|
|
[else (incomparable name x y)]))
|
|
= <)]
|
|
[(name ctc = < >)
|
|
(order name ctc
|
|
(lambda (x y)
|
|
(cond [(= x y) '=]
|
|
[(< x y) '<]
|
|
[(> x y) '>]
|
|
[else (incomparable name x y)]))
|
|
= <)])])
|
|
order))
|
|
|
|
(define (incomparable name x y)
|
|
(error name "values are incomparable: ~e ~e" x y))
|
|
|
|
(provide/contract
|
|
[rename order* order
|
|
(->* (symbol? contract? procedure?) (procedure? procedure?)
|
|
order?)]
|
|
[order? (-> any/c boolean?)]
|
|
[order-comparator
|
|
(-> order? procedure?)]
|
|
[order-<?
|
|
(-> order? procedure?)]
|
|
[order-=?
|
|
(-> order? procedure?)]
|
|
[order-domain-contract
|
|
(-> order? contract?)])
|
|
|
|
;; ============================================================
|
|
|
|
(define (real/not-NaN? x) (and (real? x) (not (eqv? x +nan.0))))
|
|
|
|
(define real-order
|
|
(order* 'real-order real/not-NaN? = < >))
|
|
|
|
(provide/contract
|
|
[real-order order?])
|
|
|
|
;; ============================================================
|
|
|
|
#|
|
|
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, ...
|
|
|
|
|#
|
|
|
|
;; not exported because I'm not sure it's a good idea and I'm not sure
|
|
;; how to characterize it
|
|
(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 '=]))
|
|
|
|
(define datum-order
|
|
(order* 'datum-order any/c datum-cmp))
|
|
|
|
(provide/contract
|
|
[datum-order order?])
|