diff --git a/collects/racket/function.rkt b/collects/racket/function.rkt index 7f41686020..ad34a29b9a 100644 --- a/collects/racket/function.rkt +++ b/collects/racket/function.rkt @@ -2,7 +2,8 @@ (require (for-syntax racket/base syntax/name) racket/private/norm-arity) -(provide identity const thunk thunk* negate curry curryr normalize-arity) +(provide identity const thunk thunk* negate curry curryr + normalize-arity normalized-arity? arity=? arity-includes?) (define (identity x) x) @@ -80,3 +81,94 @@ (define curry (make-curry #f)) (define curryr (make-curry #t)) + +(define (normalized-arity? a) + (unless (procedure-arity? a) + (raise-argument-error 'normalized-arity? "procedure-arity?" a)) + (or (null? a) + (arity? a) + (and (list? a) + ((length a) . >= . 2) + (andmap arity? a) + (if (ormap arity-at-least? a) + (non-empty-non-singleton-sorted-list-ending-with-arity? a) + (non-singleton-non-empty-sorted-list? a))))) + +(define (arity? a) + (or (exact-nonnegative-integer? a) + (and (arity-at-least? a) + (exact-nonnegative-integer? (arity-at-least-value a))))) + +;; non-empty-non-singleton-sorted-list-ending-with-arity? : xx -> boolean +;; know that 'a' is a list of at least 2 elements +(define (non-empty-non-singleton-sorted-list-ending-with-arity? a) + (let loop ([bound (car a)] + [lst (cdr a)]) + (cond + [(null? (cdr lst)) + (and (arity-at-least? (car lst)) + (> (arity-at-least-value (car lst)) (+ 1 bound)))] + [else + (and (exact-nonnegative-integer? (car lst)) + ((car lst) . > . bound) + (loop (car lst) + (cdr lst)))]))) + +(define (non-empty-sorted-list? a) + (and (pair? a) + (sorted-list? a))) + +(define (non-singleton-non-empty-sorted-list? a) + (and (pair? a) + (pair? (cdr a)) + (sorted-list? a))) + +(define (sorted-list? a) + (or (null? a) + (sorted/bounded-list? (cdr a) (car a)))) + +(define (sorted/bounded-list? a bound) + (or (null? a) + (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-includes? 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-includes? one elem))])) + +(define (arity=? one two) + (and (arity-includes? one two) (arity-includes? two one))) diff --git a/collects/tests/racket/basic.rktl b/collects/tests/racket/basic.rktl index eb60d449c4..23eb76b6af 100644 --- a/collects/tests/racket/basic.rktl +++ b/collects/tests/racket/basic.rktl @@ -4,7 +4,7 @@ (Section 'basic) (require scheme/flonum - racket/private/norm-arity) + racket/function) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1985,100 +1985,6 @@ ;; randomized testing ;; predicate: normalize-arity produces a normalized arity ;; - - (define (normalized-arity? a) - (or (null? a) - (arity? a) - (and (list? a) - ((length a) . >= . 2) - (andmap arity? a) - (if (arity-at-least? (last a)) - (non-empty-non-singleton-sorted-list-ending-with-arity? a) - (non-singleton-non-empty-sorted-list? a))))) - - (define (arity? a) - (or (nat? a) - (and (arity-at-least? a) - (nat? (arity-at-least-value a))))) - - (define (nat? a) - (and (number? a) - (integer? a) - (a . >= . 0))) - - ;; non-empty-non-singleton-sorted-list-ending-with-arity? : xx -> boolean - ;; know that 'a' is a list of at least 2 elements - (define (non-empty-non-singleton-sorted-list-ending-with-arity? a) - (let loop ([bound (car a)] - [lst (cdr a)]) - (cond - [(null? (cdr lst)) - (and (arity-at-least? (car lst)) - (> (arity-at-least-value (car lst)) (+ 1 bound)))] - [else - (and (nat? (car lst)) - ((car lst) . > . bound) - (loop (car lst) - (cdr lst)))]))) - - (define (non-empty-sorted-list? a) - (and (pair? a) - (sorted-list? a))) - - (define (non-singleton-non-empty-sorted-list? a) - (and (pair? a) - (pair? (cdr a)) - (sorted-list? a))) - - (define (sorted-list? a) - (or (null? a) - (sorted/bounded-list? (cdr a) (car a)))) - - (define (sorted/bounded-list? a bound) - (or (null? a) - (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