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