suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

faster version of the code

Browse Source 
svn: r17525
This commit is contained in:
Eli Barzilay 2010-01-07 03:38:23 +00:00
parent 41261c6047
commit 39595d2d05
1 changed files with 44 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

111
collects/scheme/private/norm-arity.ss
View File

@ -1,14 +1,12 @@
(module norm-arity '#%kernel
(#%require "for.ss" "define.ss" "small-scheme.ss" "sort.ss")
(#%provide norm:procedure-arity
(#%require "define.ss" "small-scheme.ss" "sort.ss")
(#%provide norm:procedure-arity
norm:raise-arity-error
normalize-arity) ;; for test suites
(define norm:procedure-arity
(let ([procedure-arity
(λ (p)
(normalize-arity (procedure-arity p)))])
(let ([procedure-arity (λ (p) (normalize-arity (procedure-arity p)))])
procedure-arity))
(define norm:raise-arity-error
(define norm:raise-arity-error
(let ([raise-arity-error
(λ (name arity-v . arg-vs)
(if (or (exact-nonnegative-integer? arity-v)
@ -17,12 +15,12 @@
(andmap (λ (x) (or (exact-nonnegative-integer? x)
(arity-at-least? x)))
arity-v)))
(apply raise-arity-error name (normalize-arity arity-v) arg-vs)
(apply raise-arity-error name
(normalize-arity arity-v) arg-vs)
;; here we let raise-arity-error signal an error
(apply raise-arity-error name arity-v arg-vs)))])
raise-arity-error))
;; normalize-arity : (or/c arity (listof arity))
;; -> (or/c null
;; arity
@ -36,62 +34,41 @@
;; - no duplicate entries
;; - nats are sorted
;; - at most one arity-at-least, always at the end
;; - if there is only one possibility, it is returned by itself (ie, not in a list)
(define (normalize-arity a)
(if (pair? a)
(let-values ([(min-at-least) #f])
(for ((a (in-list a)))
(when (arity-at-least? a)
(when (or (not min-at-least)
(< (arity-at-least-value a)
(arity-at-least-value min-at-least)))
(set! min-at-least a))))
(if-one-then-no-list
(cond
[min-at-least
(append (uniq
(sort
(filter (λ (x) (and (number? x)
(< x (arity-at-least-value
min-at-least))))
a)
<))
(list min-at-least))]
[else
(uniq (sort a <))])))
a))
;; have my own version of this to avoid a circular dependency
(define (filter p l)
(cond
[(null? l) l]
[else
(let ([x (car l)])
(if (p x)
(cons x (filter p (cdr l)))
(filter p (cdr l))))]))
(define (if-one-then-no-list lst)
(cond
[(and (pair? lst) (null? (cdr lst)))
(car lst)]
[else lst]))
;; uniq : sorted list of integers -> sorted, uniqe list of integers
(define (uniq lst)
(cond
[(null? lst) null]
[(null? (cdr lst)) lst]
[else
(let loop ([fst (car lst)]
[rst (cdr lst)])
(cond
[(null? rst) (list fst)]
[else
(let ([snd (car rst)])
(if (= fst snd)
(loop fst (cdr rst))
(cons fst (loop snd (cdr rst)))))]))])))
;; - if there is only one possibility, it is returned by itself (ie,
;; 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))
;; 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))))])))