1#lang racket/base
2
3(require racket/private/norm-arity)
4
5(provide normalize-arity normalized-arity? arity=? arity-includes?)
6
7(define (normalized-arity? a)
8  (or (null? a)
9      (arity? a)
10      (and (list? a)
11           ((length a) . >= . 2)
12           (andmap arity? a)
13           (if (ormap arity-at-least? a)
14               (non-empty-non-singleton-sorted-list-ending-with-arity? a)
15               (non-singleton-non-empty-sorted-list? a)))))
16
17(define (arity? a)
18  (or (exact-nonnegative-integer? a)
19      (and (arity-at-least? a)
20           (exact-nonnegative-integer? (arity-at-least-value a)))))
21
22;; non-empty-non-singleton-sorted-list-ending-with-arity? : xx -> boolean
23;; know that 'a' is a list of at least 2 elements
24(define (non-empty-non-singleton-sorted-list-ending-with-arity? a)
25  (let loop ([bound (car a)]
26             [lst (cdr a)])
27    (cond
28      [(null? (cdr lst))
29       (and (arity-at-least? (car lst))
30            (> (arity-at-least-value (car lst)) (+ 1 bound)))]
31      [else
32       (and (exact-nonnegative-integer? (car lst))
33            ((car lst) . > . bound)
34            (loop (car lst)
35                  (cdr lst)))])))
36
37(define (non-empty-sorted-list? a)
38  (and (pair? a)
39       (sorted-list? a)))
40
41(define (non-singleton-non-empty-sorted-list? a)
42  (and (pair? a)
43       (pair? (cdr a))
44       (sorted-list? a)))
45
46(define (sorted-list? a)
47  (or (null? a)
48      (sorted/bounded-list? (cdr a) (car a))))
49
50(define (sorted/bounded-list? a bound)
51  (or (null? a)
52      (and (number? (car a))
53           (< bound (car a))
54           (sorted/bounded-list? (cdr a) (car a)))))
55
56(define (arity-supports-number? arity n)
57  (cond
58    [(exact-nonnegative-integer? arity) (= arity n)]
59    [(arity-at-least? arity) (<= (arity-at-least-value arity) n)]
60    [(list? arity)
61     (for/or {[elem (in-list arity)]}
62       (arity-supports-number? elem n))]))
63
64(define (arity-supports-at-least? arity n)
65  (cond
66    [(exact-nonnegative-integer? arity) #f]
67    [(arity-at-least? arity) (<= (arity-at-least-value arity) n)]
68    [(list? arity)
69     (define min-at-least
70       (for/fold {[min-at-least #f]} {[elem (in-list arity)]}
71         (cond
72           [(exact-nonnegative-integer? elem) min-at-least]
73           [(arity-at-least? elem)
74            (cond
75              [(not min-at-least) (arity-at-least-value elem)]
76              [else (min min-at-least (arity-at-least-value elem))])])))
77     (cond
78       [(not min-at-least) #f]
79       [else
80        (for/and {[i (in-range n min-at-least)]}
81          (arity-supports-number? arity i))])]))
82
83(define (unchecked-arity-includes? one two)
84  (cond
85    [(exact-nonnegative-integer? two)
86     (arity-supports-number? one two)]
87    [(arity-at-least? two)
88     (arity-supports-at-least? one (arity-at-least-value two))]
89    [(list? two)
90     (for/and {[elem (in-list two)]}
91       (unchecked-arity-includes? one elem))]))
92
93(define (arity-includes? one two)
94  (unless (procedure-arity? one)
95    (raise-argument-error 'arity-includes? "procedure-arity?" 0 one two))
96  (unless (procedure-arity? two)
97    (raise-argument-error 'arity-includes? "procedure-arity?" 1 one two))
98  (unchecked-arity-includes? one two))
99
100(define (arity=? one two)
101  (unless (procedure-arity? one)
102    (raise-argument-error 'arity=? "procedure-arity?" 0 one two))
103  (unless (procedure-arity? two)
104    (raise-argument-error 'arity=? "procedure-arity?" 1 one two))
105  (and
106    (unchecked-arity-includes? one two)
107    (unchecked-arity-includes? two one)))
108