Add Partial Order design proposal

design/partial-order/A/Lexicographic.rhm

@@ -0,0 +1,30 @@
+#lang rhombus
+
+export Lexicographic
+
+import "partial-order.rkt" open
+
+class Lexicographic(elements):
+  export and
+  constructor(& elements): super(elements)
+  private implements PartialOrder
+  private override partial_compare(other :: Lexicographic, recur):
+    lexicographic_compare_list(elements, other.elements, recur)
+
+  macro
+  | 'and: $(c :: Group)': '$c'
+  | 'and: $c; $r; ...':
+      'begin:
+         let cv: $c
+         if cv .= 0
+         | and: $r; ...
+         | cv'
+
+fun
+| lexicographic_compare_list([], [], _): 0
+| lexicographic_compare_list([], [_, & _], _): -1
+| lexicographic_compare_list([_, & _], [], _): 1
+| lexicographic_compare_list([f1, & r1], [f2, & r2], recur):
+    Lexicographic.and:
+      recur(f1, f2)
+      lexicographic_compare_list(r1, r2, recur)

design/partial-order/A/partial-order.rkt

@@ -0,0 +1,131 @@
+#lang racket/base
+
+(require rhombus/private/provide)
+(provide (for-spaces (rhombus/class
+                      rhombus/namespace)
+                     PartialOrder)
+         (for-spaces (#f
+                      rhombus/repet)
+                     =~
+                     !=~
+                     <~
+                     >~
+                     <=~
+                     >=~))
+
+(require (for-syntax racket/base
+                     rhombus/private/interface-parse)
+         rhombus/private/define-operator
+         (only-in rhombus/private/arithmetic
+                  \|\| &&
+                  [+ rhombus+]
+                  [- rhombus-]
+                  [* rhombus*]
+                  [/ rhombus/])
+         rhombus/private/name-root
+         rhombus/private/realm
+         (only-in rhombus/private/class-desc define-class-desc-syntax)
+         "../common/partial-order-util.rkt")
+
+;; ---------------------------------------------------------
+
+;; PartialOrder struct type property and interface
+
+(define-values (prop:partial-order partial-order? partial-order-ref)
+  (make-struct-type-property
+   'partial-order
+   (λ (value _type-info)
+     (unless (and (procedure? value)
+                  (procedure-arity-includes? value 3))
+       (raise-argument-error* 'partial_compare
+                              rhombus-realm
+                              "a method of 2 arguments (after this)"
+                              value))
+     (list (gensym) value))))
+
+(define-values (prop:PartialOrder _PartialOrder? PartialOrder-ref)
+  (make-struct-type-property
+   'PartialOrder
+   #false
+   (list (cons prop:partial-order (lambda (v) (vector-ref v 0))))))
+
+(define-class-desc-syntax PartialOrder
+  (interface-desc #'PartialOrder
+                  #'PartialOrder
+                  #'()
+                  #'prop:PartialOrder
+                  #'PartialOrder-ref
+                  (vector-immutable (box-immutable 'partial_compare))
+                  #'#(#:abstract)
+                  (hasheq 'partial_compare 0)
+                  #hasheq()
+                  #t))
+
+;; ---------------------------------------------------------
+
+;; Public operations
+
+(define-name-root PartialOrder
+  #:fields
+  (partial_compare
+   compare
+   within))
+
+(define (partial-compare/recur a b recur)
+  (define (cmp ai bi)
+    (partial-ordering-normalize (recur ai bi)))
+  (cond
+    [(partial-order? a)
+     (ord-and/bool
+      (partial-order? b)
+      (let ([av (partial-order-ref a)])
+        (ord-and/bool
+         (eq? av (partial-order-ref b))
+         (partial-ordering-normalize ((cadr av) a b cmp)))))]
+    [(realish? a)
+     (ord-and/bool (realish? b) (partial-compare-realish a b))]
+    [else
+     (product-compare/recur a b cmp #true)]))
+
+(define (partial_compare a b)
+  (partial-compare/recur a b partial_compare))
+
+(define (compare/recur a b recur)
+  (define (cmp ai bi) (ordering-normalize (recur ai bi)))
+  (ordering-normalize (partial-compare/recur a b cmp)))
+
+(define (compare a b)
+  (compare/recur a b compare))
+
+(define (partial-compare/within a b epsilon)
+  (cond
+    [(realish? a)
+     (ord-and/bool (realish? b) (partial-compare-realish/within a b epsilon))]
+    [else
+     (define (cmp ai bi) (partial-compare/within ai bi epsilon))
+     (partial-compare/recur a b cmp)]))
+
+(define (within a b epsilon)
+  (zero? (partial-compare/within a b epsilon)))
+
+(define (=~? a b) (zero? (partial_compare a b)))
+(define (!=~? a b) (not (zero? (partial_compare a b))))
+
+(define (<~? a b) (negative? (compare a b)))
+(define (>~? a b) (positive? (compare a b)))
+(define (<=~? a b) (<= (compare a b) 0))
+(define (>=~? a b) (>= (compare a b) 0))
+
+(define-syntax-rule (define-comp~-infix name racket-name)
+  (define-infix name racket-name
+    #:weaker-than (rhombus+ rhombus- rhombus* rhombus/)
+    #:same-as (<~ <=~ =~ !=~ >=~ >~)
+    #:stronger-than (\|\| &&)
+    #:associate 'none))
+
+(define-comp~-infix <~ <~?)
+(define-comp~-infix <=~ <=~?)
+(define-comp~-infix =~ =~?)
+(define-comp~-infix !=~ !=~?)
+(define-comp~-infix >=~ >=~?)
+(define-comp~-infix >~ >~?)

design/partial-order/A/test-partial-order.rhm

@@ -0,0 +1,62 @@
+#lang rhombus
+
+import:
+  lib("racket/flonum.rkt").flvector
+  "partial-order.rkt" open
+  "Lexicographic.rhm".Lexicographic
+
+class UnredRatio(n :: Integer, d :: PositiveInteger):
+  private implements PartialOrder
+  private override partial_compare(other :: UnredRatio, recur):
+    recur(n * other.d, other.n * d)
+
+check UnredRatio(1, 2) =~ UnredRatio(2, 4) ~is #true
+check UnredRatio(1, 2) =~ UnredRatio(3, 4) ~is #false
+check UnredRatio(1, 2) <~ UnredRatio(3, 4) ~is #true
+check UnredRatio(1, 2) <~ UnredRatio(1, 4) ~is #false
+check UnredRatio(1, 2) >~ UnredRatio(1, 4) ~is #true
+check:
+  [UnredRatio(1, 2), UnredRatio(-1, 2)] <~ [UnredRatio(3, 4), UnredRatio(-1, 4)]
+  ~is #true
+check:
+  [UnredRatio(1, 2), UnredRatio(-1, 2)] >~ [UnredRatio(1, 4), UnredRatio(-3, 4)]
+  ~is #true
+
+check:
+  Lexicographic(UnredRatio(1, 2), UnredRatio(-1, 2)) <~ Lexicographic(UnredRatio(3, 4), UnredRatio(-1, 4))
+  ~is #true
+check:
+  Lexicographic(UnredRatio(1, 2), UnredRatio(-1, 2)) >~ Lexicographic(UnredRatio(1, 4), UnredRatio(-3, 4))
+  ~is #true
+
+check: Lexicographic(5, 8, 3, 13, 2) =~ Lexicographic(5, 8, 3, 13, 2) ~is #true
+check: Lexicographic(5, 8, 3, 13, 2) =~ Lexicographic(5, 8, 3, 13, 2, -1) ~is #false
+check: Lexicographic(5, 8, 3, 13, 2) !=~ Lexicographic(5, 8, 3, 13, 2, -1) ~is #true
+check: Lexicographic(5, 8, 3, 13, 2) <=~ Lexicographic(5, 8, 3, 13, 2, -1) ~is #true
+check: Lexicographic(5, 8, 3, 13, 2) <~ Lexicographic(5, 8, 3, 13, 2, -1) ~is #true
+check: Lexicographic(5, 8, 3, 13, 2) <=~ Lexicographic(5, 8, 2, 13, 2, -1) ~is #false
+check: Lexicographic(5, 8, 3, 13, 2) >=~ Lexicographic(5, 8, 2, 13, 2, -1) ~is #true
+check: Lexicographic(5, 8, 3, 13, 2) >~ Lexicographic(5, 8, 2, 13, 2, -1) ~is #true
+check: Lexicographic(5, 8, 3, 13, 2) >=~ Lexicographic(6, -1) ~is #false
+check: Lexicographic(5, 8, 3, 13, 2) <=~ Lexicographic(6, -1) ~is #true
+check: Lexicographic(5, 8, 3, 13, 2) <~ Lexicographic(6, -1) ~is #true
+check: Lexicographic(5, 8, 3, 13, 2) <=~ Lexicographic(4, 18) ~is #false
+check: Lexicographic(5, 8, 3, 13, 2) >=~ Lexicographic(4, 18) ~is #true
+check: Lexicographic(5, 8, 3, 13, 2) >~ Lexicographic(4, 18) ~is #true
+
+check: PartialOrder.within([6, 10], [6.02, 9.99], 0.05) ~is #true
+check: PartialOrder.within({#'C: 20, #'F: 68}, {#'C: 25, #'F: 77}, 10) ~is #true
+
+check: PartialOrder.within([6e+23, 10.0], [6.02e+23, 9.8], 0.05) ~is #false
+check: PartialOrder.within({#'C: 18, #'F: 64}, {#'C: 25, #'F: 77}, 10) ~is #false
+
+check: flvector(0.0) =~ flvector(-0.0) ~is #true
+check: flvector(0.0, -0.0) =~ flvector(-0.0, 0.0) ~is #true
+check: flvector(0.0, 1.0) =~ flvector(-0.0, 2.0) ~is #false
+check: flvector(0.0, 1.0) !=~ flvector(-0.0, 2.0) ~is #true
+check: flvector(0.0, 1.0) <=~ flvector(-0.0, 2.0) ~is #true
+check: flvector(0.0, 1.0) <~ flvector(-0.0, 2.0) ~is #true
+check: flvector(2.0, -0.0) <=~ flvector(1.0, 0.0) ~is #false
+check: flvector(2.0, -0.0) >=~ flvector(1.0, 0.0) ~is #true
+check: flvector(2.0, -0.0) >~ flvector(1.0, 0.0) ~is #true
+

design/partial-order/D-A/Lexicographic.rhm

@@ -0,0 +1,30 @@
+#lang rhombus
+
+export Lexicographic
+
+import "partial-order.rkt" open
+
+class Lexicographic(elements):
+  export and
+  constructor(& elements): super(elements)
+  private implements PartialOrder
+  private override partial_compare(other :: Lexicographic, recur):
+    lexicographic_compare_list(elements, other.elements, recur)
+
+  macro
+  | 'and: $(c :: Group)': '$c'
+  | 'and: $c; $r; ...':
+      'begin:
+         let cv: $c
+         if cv .= 0
+         | and: $r; ...
+         | cv'
+
+fun
+| lexicographic_compare_list([], [], _): 0
+| lexicographic_compare_list([], [_, & _], _): -1
+| lexicographic_compare_list([_, & _], [], _): 1
+| lexicographic_compare_list([f1, & r1], [f2, & r2], recur):
+    Lexicographic.and:
+      recur(f1, f2)
+      lexicographic_compare_list(r1, r2, recur)