Changed normalize-arity to coalesce arity-at-least with adjacent numbers.

For instance, (normalize-arity (list 1 (arity-at-least 2))) now produces
(arity-at-least 1).  The implementation and the tests for normalize-arity both
reflect this change.  The randomized tests now also check that the output
represents the same arity as the input.

collects/racket/private/norm-arity.rkt

@@ -38,37 +38,53 @@
   ;;     not in a list)
   (define (normalize-arity arity)
     (if (pair? arity)
-      (let loop ([min-at-least #f] [min-num 0] [as arity] [numbers '()])
+        (let* ([reversed (reverse-sort-arity arity)]
-        ;; (1) find the minimal arity-at-least if any, find only numbers
+               [normalized (normalize-reversed-arity reversed '())]
-        (if (pair? as)
+               [simplified (normalize-singleton-arity normalized)])
-          (let ([a (car as)] [as (cdr as)])
+          simplified)
-            (if (arity-at-least? a)
-              (if (and min-at-least (<= min-num (arity-at-least-value a)))
-                (loop min-at-least min-num as numbers)
-                (loop a (arity-at-least-value a) as numbers))
-              (loop min-at-least min-num as (cons a numbers))))
-          ;; (2) remove redundant numbers and sort
-          (let loop ([numbers (sort (if min-at-least
-                                      (filter-below min-num numbers)
-                                      numbers)
-                                    >)] ; reversed in the loop below
-                     [result (if min-at-least (list min-at-least) '())])
-            ;; (3) throw out duplicates (while reversing the list)
-            (cond [(pair? numbers)
-                   (loop (cdr numbers)
-                         (if (and (pair? result)
-                                  (eq? (car numbers) (car result)))
-                           result
-                           (cons (car numbers) result)))]
-                  ;; result is never null (otherwise the input would be null)
-                  [(null? (cdr result)) (car result)]
-                  [else result]))))
         arity))
 
-  ;; have my own version of this to avoid a circular dependency
+  (define (normalize-singleton-arity arity)
-  (define (filter-below max l)
+    (if (and (pair? arity) (null? (cdr arity)))
-    (cond [(null? l) l]
+        (car arity)
-          [else (let ([x (car l)])
+        arity))
-                  (if (< x max)
+
-                    (cons x (filter-below max (cdr l)))
+  (define (normalize-reversed-arity arity tail)
-                    (filter-below max (cdr l))))])))
+    (if (pair? arity)
+        (normalize-reversed-arity (cdr arity) (arity-insert (car arity) tail))
+        tail))
+
+  (define (arity-insert elem arity)
+    (if (pair? arity)
+        (let ([next (car arity)])
+          (if (arity-at-least? next)
+              (let ([next-value (arity-at-least-value next)])
+                (if (arity-at-least? elem)
+                    ;; arity-at-least + arity-at-least
+                    (let ([elem-value (arity-at-least-value elem)])
+                      (if (< elem-value next-value)
+                          (cons elem (cdr arity))
+                          arity))
+                    ;; number + arity-at-least
+                    (if (< elem (- next-value 1))
+                        (cons elem arity)
+                        (if (= elem (- next-value 1))
+                            (cons (arity-at-least elem) (cdr arity))
+                            arity))))
+              ;; number + number
+              (if (< elem next)
+                  (cons elem arity)
+                  arity)))
+        (cons elem arity)))
+
+  (define (reverse-sort-arity arity)
+    (sort arity arity>?))
+
+  (define (arity>? a b)
+    (if (arity-at-least? a)
+        (if (arity-at-least? b)
+            (> (arity-at-least-value a) (arity-at-least-value b))
+            #t)
+        (if (arity-at-least? b)
+            #f
+            (> a b)))))

collects/tests/racket/basic.rktl

@@ -1922,33 +1922,63 @@
 (test (make-arity-at-least 0) procedure-arity (lambda x x))
 (arity-test procedure-arity 1 1)
 
+;; Tests for normalize-arity without arity-at-least
 (test '() normalize-arity '())
 (test 1 normalize-arity 1)
 (test 1 normalize-arity '(1))
 (test '(1 2) normalize-arity '(1 2))
 (test '(1 2) normalize-arity '(2 1))
-(test (make-arity-at-least 2) normalize-arity (list (make-arity-at-least 2) 3))
-(test (list 1 (make-arity-at-least 2))
-      normalize-arity (list (make-arity-at-least 2) 1))
-(test (list 1 (make-arity-at-least 2)) 
-      normalize-arity (list (make-arity-at-least 2) 1 3))
-(test (list 0 1 (make-arity-at-least 2))
-      normalize-arity (list (make-arity-at-least 2) 1 0 3))
-(test (list 0 1 (make-arity-at-least 2))
-      normalize-arity (list (make-arity-at-least 2)
-                            (make-arity-at-least 4) 1 0 3))
-(test (list 0 1 (make-arity-at-least 2))
-      normalize-arity (list (make-arity-at-least 4)
-                            (make-arity-at-least 2) 1 0 3))
 (test (list 1 2) normalize-arity (list 1 1 2 2))
 (test 1 normalize-arity (list 1 1 1))
-(test (list 1 (make-arity-at-least 2))
+
+;; Tests for normalize-arity where everything collapses into arity-at-least
+(test (make-arity-at-least 2) normalize-arity (list (make-arity-at-least 2) 3))
+(test (make-arity-at-least 1)
+      normalize-arity (list (make-arity-at-least 2) 1))
+(test (make-arity-at-least 1)
+      normalize-arity (list (make-arity-at-least 2) 1 3))
+(test (make-arity-at-least 0)
+      normalize-arity (list (make-arity-at-least 2) 1 0 3))
+(test (make-arity-at-least 0)
+      normalize-arity (list (make-arity-at-least 2)
+                            (make-arity-at-least 4) 1 0 3))
+(test (make-arity-at-least 0)
+      normalize-arity (list (make-arity-at-least 4)
+                            (make-arity-at-least 2) 1 0 3))
+(test (make-arity-at-least 1)
       normalize-arity (list (make-arity-at-least 2) 1 1))
-(test (list 1 (make-arity-at-least 2))
+(test (make-arity-at-least 1)
       normalize-arity 
       (list (make-arity-at-least 2)
             (make-arity-at-least 2) 1 1))
 
+;; Tests for normalize-arity that result in a list with arity-at-least.
+(test (list 1 (make-arity-at-least 3))
+      normalize-arity (list (make-arity-at-least 3) 1))
+(test (list 1 (make-arity-at-least 3))
+      normalize-arity (list (make-arity-at-least 3) 1 4))
+(test (list 0 1 (make-arity-at-least 3))
+      normalize-arity (list (make-arity-at-least 3) 1 0 4))
+(test (list 0 1 (make-arity-at-least 3))
+      normalize-arity (list (make-arity-at-least 3)
+                            (make-arity-at-least 5) 1 0 4))
+(test (list 0 1 (make-arity-at-least 3))
+      normalize-arity (list (make-arity-at-least 5)
+                            (make-arity-at-least 3) 1 0 4))
+(test (list 1 (make-arity-at-least 3))
+      normalize-arity (list (make-arity-at-least 3) 1 1))
+(test (list 1 (make-arity-at-least 3))
+      normalize-arity 
+      (list (make-arity-at-least 3)
+            (make-arity-at-least 3) 1 1))
+(test (list 0 1 (make-arity-at-least 3))
+      normalize-arity (list 0 1 3 (make-arity-at-least 4)))
+(test (list 0 1 (make-arity-at-least 3))
+      normalize-arity (list (make-arity-at-least 4) 3 1 0))
+(test (list 0 1 (make-arity-at-least 3))
+      normalize-arity (list 0 1 3 (make-arity-at-least 4)
+                                5 (make-arity-at-least 6)))
+
 (let ()
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;
@@ -1984,7 +2014,7 @@
       (cond
         [(null? (cdr lst))
          (and (arity-at-least? (car lst))
-              (> (arity-at-least-value (car lst)) bound))]
+              (> (arity-at-least-value (car lst)) (+ 1 bound)))]
         [else
          (and (nat? (car lst))
               ((car lst) . > . bound)
@@ -2010,15 +2040,61 @@
              (< bound (car a))
              (sorted/bounded-list? (cdr a) (car a)))))
 
+  (define (arity-supports-number? arity n)
+    (cond
+      [(exact-nonnegative-integer? arity) (= arity n)]
+      [(arity-at-least? arity) (<= (arity-at-least-value arity) n)]
+      [(list? arity)
+       (for/or {[elem (in-list arity)]}
+         (arity-supports-number? elem n))]))
+
+  (define (arity-supports-at-least? arity n)
+    (cond
+      [(exact-nonnegative-integer? arity) #f]
+      [(arity-at-least? arity) (<= (arity-at-least-value arity) n)]
+      [(list? arity)
+       (define min-at-least
+         (for/fold {[min-at-least #f]} {[elem (in-list arity)]}
+           (cond
+             [(exact-nonnegative-integer? elem) min-at-least]
+             [(arity-at-least? elem)
+              (cond
+                [(not min-at-least) (arity-at-least-value elem)]
+                [else (min min-at-least (arity-at-least-value elem))])])))
+       (cond
+         [(not min-at-least) #f]
+         [else
+          (for/and {[i (in-range n min-at-least)]}
+            (arity-supports-number? arity i))])]))
+
+  (define (arity-supports? one two)
+    (cond
+      [(exact-nonnegative-integer? two)
+       (arity-supports-number? one two)]
+      [(arity-at-least? two)
+       (arity-supports-at-least? one (arity-at-least-value two))]
+      [(list? two)
+       (for/and {[elem (in-list two)]}
+         (arity-supports? one elem))]))
+
+  (define (arity=? one two)
+    (and (arity-supports? one two) (arity-supports? two one)))
+
+  (define (normalized-arity=? original normalized)
+    (and
+      (normalized-arity? normalized)
+      (arity=? original normalized)))
+  
   (for ((i (in-range 1 2000)))
-    (let* ([rand-bound (ceiling (/ i 10))]
+    (define rand-bound (ceiling (/ i 10)))
-           [l (build-list (random rand-bound)
+    (define l
+      (build-list (random rand-bound)
         (λ (i) (if (zero? (random 5))
                    (make-arity-at-least (random rand-bound))
-                                     (random rand-bound))))]
+                   (random rand-bound)))))
-           [res (normalize-arity l)])
+    (define res (normalize-arity l))
-      (unless (normalized-arity? res)
+    #:final (not (normalized-arity=? l res))
-        (error 'normalize-arity-failed "input ~s; output ~s" l res)))))
+    (test #t normalized-arity=? l res)))
 
 (test #t procedure-arity-includes? cons 2)
 (test #f procedure-arity-includes? cons 0)