Add lexicographic-comparator

Author: jackfirth

base/comparator.rkt

@@ -18,6 +18,7 @@
   [comparator-of-constants (-> any/c ... comparator?)]
   [comparator-min (-> comparator? any/c any/c ... any/c)]
   [comparator-max (-> comparator? any/c any/c ... any/c)]
+  [lexicographic-comparator (-> comparator? (comparator/c (sequence/c any/c)))]
   [comparison? (-> any/c boolean?)]
   [lesser comparison?]
   [greater comparison?]
@@ -45,7 +46,9 @@
          guard
          racket/contract/combinator
          racket/list
+         racket/match
          racket/math
+         racket/sequence
          racket/set
          rebellion/base/immutable-string
          rebellion/base/symbol
@@ -152,6 +155,25 @@
    #:name enclosing-function-name))
 
 
+(define/name (lexicographic-comparator element-comparator)
+  (make-comparator
+   (λ (xs ys)
+     (define-values (more-xs? get-next-x) (sequence-generate xs))
+     (define-values (more-ys? get-next-y) (sequence-generate ys))
+     (let loop ()
+       (match (list (more-xs?) (more-ys?))
+         [(list #false #false) equivalent]
+         [(list #false #true) lesser]
+         [(list #true #false) greater]
+         [(list #true #true)
+          (define x (get-next-x))
+          (define y (get-next-y))
+          (match (compare element-comparator x y)
+            [(== equivalent) (loop)]
+            [result result])])))
+   #:name enclosing-function-name))
+
+
 (define (comparator-min comparator v . vs)
   (for/fold ([min-so-far v])
             ([v (in-list vs)]
@@ -322,6 +344,31 @@
      #rx"'\\(small medium small\\)" (λ () (comparator-of-constants 'small 'medium 'small)))
     (check-exn exn:fail:contract? (λ () (comparator-of-constants #false #false))))
 
+  (test-case (name-string lexicographic-comparator)
+    (define nums<=> (lexicographic-comparator real<=>))
+    (check-equal? (compare nums<=> (list 1) (list 1)) equivalent)
+    (check-equal? (compare nums<=> (list 2) (list 1)) greater)
+    (check-equal? (compare nums<=> (list 1) (list 2)) lesser)
+    (check-equal? (compare nums<=> (list 1 2) (list 1 2)) equivalent)
+    (check-equal? (compare nums<=> (list 1 3) (list 1 2)) greater)
+    (check-equal? (compare nums<=> (list 1 2) (list 1 3)) lesser)
+    (check-equal? (compare nums<=> (list 1) (list 1 2)) lesser)
+    (check-equal? (compare nums<=> (list 1 2) (list 1)) greater)
+    (check-equal? (compare nums<=> (list 1 2 3) (list 1 2)) greater)
+    (check-equal? (compare nums<=> (list 1 2) (list 1 2 3)) lesser)
+    (check-equal? (compare nums<=> (list 2) (list 1 2)) greater)
+    (check-equal? (compare nums<=> (list 1 2) (list 2)) lesser)
+    (check-equal? (compare nums<=> (list 0) (list 1 2)) lesser)
+    (check-equal? (compare nums<=> (list 1 2) (list 0)) greater)
+    (check-equal? (compare nums<=> (list 1 2) (list 0)) greater)
+    (check-equal? (compare nums<=> (list 1 2 3 4 5) (vector 1 2 3 4 5)) equivalent)
+    (check-equal? (compare nums<=> (vector 1 2 3 4 5) (list 1 2 3 4 5)) equivalent)
+    (check-equal? (compare nums<=> (list 1 2 3 4 5) (vector-immutable 1 2 3 4 5)) equivalent)
+    (check-equal? (compare nums<=> (vector-immutable 1 2 3 4 5) (list 1 2 3 4 5)) equivalent)
+    (check-equal? (compare nums<=> (vector 1 2 3 4 5) (vector-immutable 1 2 3 4 5)) equivalent)
+    (check-equal? (compare nums<=> (vector-immutable 1 2 3 4 5) (vector 1 2 3 4 5)) equivalent)
+    (check-equal? (compare (lexicographic-comparator char<=>) (list #\a #\b #\c) "abc") equivalent))
+
   (test-case (name-string comparator-min)
     (check-equal? (comparator-min real<=> 1 99 99) 1)
     (check-equal? (comparator-min real<=> 99 1 99) 1)

base/comparator.scrbl

@@ -32,6 +32,9 @@
                    'rebellion/type/tuple)
     #:private (list 'racket/base)))
 
+@(define lexicographic-order-url "https://en.wikipedia.org/wiki/Lexicographic_order")
+
+
 @title{Comparators}
 @defmodule[rebellion/base/comparator]
 
@@ -199,6 +202,34 @@ with equality unless otherwise stated.
               (sorting (comparator-chain gemstone-by-type<=> gemstone-by-weight<=>))
               #:into into-list))}
 
+
+@defproc[(lexicographic-comparator [element-comparator comparator?])
+         (comparator/c (sequence/c any/c))]{
+ Constructs a @tech{comparator} of
+ @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{sequences} which compares sequences in
+ @hyperlink[lexicographic-order-url]{lexicographic order} by comparing each sequence element with
+ @racket[element-comparator].
+
+ @(examples
+   #:eval (make-evaluator) #:once
+   (eval:no-prompt
+    (define real-seq<=> (lexicographic-comparator real<=>)))
+   (compare real-seq<=> (list 1 2 3) (list 3 2 1))
+   (compare real-seq<=> (list 1 2 3) (list 1))
+   (compare real-seq<=> (list 1 2 3) (list 2))
+   (compare real-seq<=> (list 1 2 3) (list 1 2 3))
+   (compare real-seq<=> (list 1 2 3) (list 1 2 3 0)))
+
+ The two sequences need not be of the same type: they will be considered equivalent if they have
+ equivalent elements in the same order. This makes this comparator @tech{inconsistent with equality}
+ when two sequences are not @racket[equal?] but contain equal elements in the same order.
+
+ @(examples
+   #:eval (make-evaluator) #:once
+   (equal? (list 1 2 3) (vector 1 2 3))
+   (compare (lexicographic-comparator real<=>) (list 1 2 3) (vector 1 2 3)))}
+
+
 @section{Predefined Comparators}
 
 @defthing[real<=> (comparator/c comparable-real?)]{
@@ -248,8 +279,8 @@ with equality unless otherwise stated.
    (eval:error (compare natural<=> 42 -10)))}
 
 @defthing[string<=> (comparator/c immutable-string?)]{
- A @tech{comparator} that lexicographically compares immutable strings. Mutable
- strings are disallowed, to prevent clients from concurrently mutating a string
+ A @tech{comparator} that @hyperlink[lexicographic-order-url]{lexicographically} compares immutable
+ strings. Mutable strings are disallowed, to prevent clients from concurrently mutating a string
  while it's being compared.
 
  @(examples
@@ -266,11 +297,11 @@ with equality unless otherwise stated.
    (compare char<=> #\a #\z))}
 
 @defthing[symbol<=> (comparator/c symbol?)]{
- A @tech{comparator} that lexicographically compares symbols. Symbols are equivalent if they contain
- the same characters. Note that this comparator is @tech{inconsistent with equality}, because symbols
- that print the same are not necessarily equal, due to the existence of unreadable and uninterned
- symbols. If only interned symbols need to be compared, use @racket[interned-symbol<=>] to ensure
- comparisons are consistent with equality.
+ A @tech{comparator} that @hyperlink[lexicographic-order-url]{lexicographically} compares symbols.
+ Symbols are equivalent if they contain the same characters. Note that this comparator is
+ @tech{inconsistent with equality}, because symbols that print the same are not necessarily equal, due
+ to the existence of unreadable and uninterned symbols. If only interned symbols need to be compared,
+ use @racket[interned-symbol<=>] to ensure comparisons are consistent with equality.
 
  @(examples
    #:eval (make-evaluator) #:once