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