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.
This commit is contained in:
Carl Eastlund
parent
6e40caa7e2
commit
59b1e32fe9
|
|
@ -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 '()])
|
||||
;; (1) find the minimal arity-at-least if any, find only numbers
|
||||
(if (pair? as)
|
||||
(let ([a (car as)] [as (cdr as)])
|
||||
(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))
|
||||
(let* ([reversed (reverse-sort-arity arity)]
|
||||
[normalized (normalize-reversed-arity reversed '())]
|
||||
[simplified (normalize-singleton-arity normalized)])
|
||||
simplified)
|
||||
arity))
|
||||
|
||||
;; have my own version of this to avoid a circular dependency
|
||||
(define (filter-below max l)
|
||||
(cond [(null? l) l]
|
||||
[else (let ([x (car l)])
|
||||
(if (< x max)
|
||||
(cons x (filter-below max (cdr l)))
|
||||
(filter-below max (cdr l))))])))
|
||||
(define (normalize-singleton-arity arity)
|
||||
(if (and (pair? arity) (null? (cdr arity)))
|
||||
(car arity)
|
||||
arity))
|
||||
|
||||
(define (normalize-reversed-arity arity tail)
|
||||
(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)))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -2009,16 +2039,62 @@
|
|||
(and (number? (car a))
|
||||
(< 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))]
|
||||
[l (build-list (random rand-bound)
|
||||
(λ (i) (if (zero? (random 5))
|
||||
(make-arity-at-least (random rand-bound))
|
||||
(random rand-bound))))]
|
||||
[res (normalize-arity l)])
|
||||
(unless (normalized-arity? res)
|
||||
(error 'normalize-arity-failed "input ~s; output ~s" l res)))))
|
||||
(define rand-bound (ceiling (/ i 10)))
|
||||
(define l
|
||||
(build-list (random rand-bound)
|
||||
(λ (i) (if (zero? (random 5))
|
||||
(make-arity-at-least (random rand-bound))
|
||||
(random rand-bound)))))
|
||||
(define res (normalize-arity l))
|
||||
#:final (not (normalized-arity=? l res))
|
||||
(test #t normalized-arity=? l res)))
|
||||
|
||||
(test #t procedure-arity-includes? cons 2)
|
||||
(test #f procedure-arity-includes? cons 0)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user