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

* Better versions of curry/r and negate, doc improvements, tests

Browse Source 
svn: r9043
This commit is contained in:
Eli Barzilay 2008-03-21 17:55:29 +00:00
parent c3a503a897
commit d88c6c476a
3 changed files with 153 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

90
collects/scheme/function.ss
View File

@ -6,40 +6,60 @@
(unless (procedure? f) (raise-type-error 'negate "procedure" f))
(let-values ([(arity) (procedure-arity f)]
[(required-kws accepted-kws) (procedure-keywords f)])
(define negated
(if (and (null? required-kws) (null? accepted-kws))
;; simple function
(if (equal? arity 1) ; optimize common case
(lambda (x) (not (f x)))
(lambda xs (not (apply f xs))))
;; keyworded function
(make-keyword-procedure
(lambda (kws kw-args . rest)
(not (keyword-apply f kws kw-args rest))))))
negated))
(define negated ; simple version, optimize some cases
(case arity
[(0) (lambda () (not (f)))]
[(1) (lambda (x) (not (f x)))]
[(2) (lambda (x y) (not (f x y)))]
[else (lambda xs (not (apply f xs)))]))
(if (and (null? required-kws) (null? accepted-kws))
negated
;; keyworded function
(make-keyword-procedure (lambda (kws kvs . args)
(not (keyword-apply f kws kvs args)))
negated))))
(define (curry f . args)
(unless (procedure? f) (raise-type-error 'curry "procedure" f))
(let loop ([args args])
(define curried
(if (null? args) ; always at least one step
(lambda more (loop more))
(lambda more
(let ([args (append args more)])
(if (procedure-arity-includes? f (length args))
(apply f args)
(loop args))))))
curried))
(define (make-curry right?)
;; The real code is here
(define (curry* f args kws kvs)
(unless (procedure? f)
(raise-type-error (if right? 'curryr 'curry) "procedure" f))
(let* ([arity (procedure-arity f)]
[max-arity (cond [(integer? arity) arity]
[(arity-at-least? arity) #f]
[(ormap arity-at-least? arity) #f]
[else (apply max arity)])]
[n (length args)])
(define (loop args n)
(cond
[(procedure-arity-includes? f n)
(if (null? kws) (apply f args) (keyword-apply f kws kvs args))]
[(and max-arity (n . > . max-arity))
(apply raise-arity-error f arity args)]
[else
(letrec [(curried
(case-lambda
[() curried] ; return itself on zero arguments
[more (loop (if right?
(append more args) (append args more))
(+ n (length more)))]))]
curried)]))
;; take at least one step if we can continue (there is a higher arity)
(if (equal? n max-arity)
(if (null? kws) (apply f args) (keyword-apply f kws kvs args))
(letrec ([curried
(lambda more
(let ([args (if right?
(append more args) (append args more))])
(loop args (+ n (length more)))))])
curried))))
;; curry is itself curried -- if we get args then they're the first step
(define curry
(case-lambda [(f) (define (curried . args) (curry* f args '() '()))
curried]
[(f . args) (curry* f args '() '())]))
(make-keyword-procedure (lambda (kws kvs f . args) (curry* f args kws kvs))
curry))
(define (curryr f . args)
(unless (procedure? f) (raise-type-error 'curry "procedure" f))
(let loop ([args args])
(define curried-right
(if (null? args) ; always at least one step
(lambda more (loop more))
(lambda more
(let ([args (append more args)])
(if (procedure-arity-includes? f (length args))
(apply f args)
(loop args))))))
curried-right))
(define curry (make-curry #f))
(define curryr (make-curry #t))

27
collects/scribblings/reference/procedures.scrbl
View File

@ -372,17 +372,26 @@ same arity as @scheme[proc].
@scheme[(curry proc)] returns a procedure that is a curried version of
@scheme[proc]. When the resulting procedure is applied on an
insufficient number of arguments, it returns a procedure that expects
additional arguments. However, at least one such application step is
required in any case, even if the @scheme[proc] consumes any number of
arguments.
additional arguments. At least one such application step is required
unless the current arguments are the most that @scheme[proc] can
consume (which is always the case when @scheme[proc] consumes any
number of arguments).
If additional values are provided to @scheme[curry], they are used as
the first step. (This means that @scheme[curry] itself is curried.)
If additional values are provided to the @scheme[curry] call (the
second form), they are used as the first step. (This means that
@scheme[curry] itself is curried.)
@scheme[curry] provides limited support for keyworded functions: only
the @scheme[curry] call itself can receive keyworded arguments to be
eventually handed to @scheme[proc].
@fun-examples[
(map ((curry +) 10) '(1 2 3))
(map (curry + 10) '(1 2 3))
(map (compose (curry * 2) (curry + 10)) '(1 2 3))
(map ((curry +) 10) '(1 2 3))
(map (curry + 10) '(1 2 3))
(map (compose (curry * 2) (curry + 10)) '(1 2 3))
(define foo (curry (lambda (x y z) (list x y z))))
(foo 1 2 3)
(((((foo) 1) 2)) 3)
]
}
@ -395,7 +404,7 @@ opposite direction: the first step collects the rightmost group of
arguments, and following steps add arguments to the left of these.
@fun-examples[
(map (curryr list 'foo) '(1 2 3))
(map (curryr list 'foo) '(1 2 3))
]
}

138
collects/tests/mzscheme/function.ss
View File

@ -3,8 +3,9 @@
(Section 'function)
(require mzlib/list)
(require mzlib/etc)
(require scheme/function mzlib/etc)
;; stuff from scheme/base
(test 0 (compose add1 sub1) 0)
(test 2 (compose add1 (lambda () 1)))
@ -25,63 +26,84 @@
(arity-test compose 1 -1)
(test '("a" "b" "c" "c" "d" "e" "f")
sort
'("d" "f" "e" "c" "a" "c" "b")
string<?)
;; ---------- rec (from mzlib/etc) ----------
(let ()
(define (car< x y) (< (car x) (car y)))
(define (random-list n range)
(let loop ([n n] [r '()])
(if (zero? n) r (loop (sub1 n) (cons (list (random range)) r)))))
(define (test-sort len times)
(or (zero? times)
(and (let* ([rand (random-list len (if (even? times) 1000000 10))]
[orig< (lambda (x y) (memq y (cdr (memq x rand))))]
[sorted (sort rand car<)]
[l1 (reverse (cdr (reverse sorted)))]
[l2 (cdr sorted)])
(and (= (length sorted) (length rand))
(andmap (lambda (x1 x2)
(and (not (car< x2 x1)) ; sorted?
(or (car< x1 x2) (orig< x1 x2)))) ; stable?
l1 l2)))
(test-sort len (sub1 times)))))
(test #t test-sort 1 10)
(test #t test-sort 2 20)
(test #t test-sort 3 60)
(test #t test-sort 4 200)
(test #t test-sort 5 200)
(test #t test-sort 10 200)
(test #t test-sort 100 200)
(test #t test-sort 1000 200)
;; test stability
(test '((1) (2) (3 a) (3 b) (3 c)) sort '((3 a) (1) (3 b) (2) (3 c)) car<)
;; test short lists (+ stable)
(test '() sort '() car<)
(test '((1 1)) sort '((1 1)) car<)
(test '((1 2) (1 1)) sort '((1 2) (1 1)) car<)
(test '((1) (2)) sort '((2) (1)) car<)
(for-each (lambda (l) (test '((0 3) (1 1) (1 2)) sort l car<))
'(((1 1) (1 2) (0 3))
((1 1) (0 3) (1 2))
((0 3) (1 1) (1 2))))
(for-each (lambda (l) (test '((0 2) (0 3) (1 1)) sort l car<))
'(((1 1) (0 2) (0 3))
((0 2) (1 1) (0 3))
((0 2) (0 3) (1 1)))))
(test 3 (rec f (λ (x) 3)) 3)
(test 3 (rec f (λ (x) x)) 3)
(test 2 (rec f (λ (x) (if (= x 3) (f 2) x))) 3)
(test 3 (rec (f x) 3) 3)
(test 3 (rec (f x) x) 3)
(test 2 (rec (f x) (if (= x 3) (f 2) x)) 3)
(test 2 (rec (f x . y) (car y)) 1 2 3)
(test 2 'no-duplications
(let ([x 1]) (rec ignored (begin (set! x (+ x 1)) void)) x))
(test 'f object-name (rec (f x) x))
(test 'f object-name (rec (f x . y) x))
(test 'f object-name (rec f (lambda (x) x)))
(test (list 2) (rec (f . x) (if (= (car x) 3) (f 2) x)) 3))
(test 3 (rec f (λ (x) 3)) 3)
(test 3 (rec f (λ (x) x)) 3)
(test 2 (rec f (λ (x) (if (= x 3) (f 2) x))) 3)
(test 3 (rec (f x) 3) 3)
(test 3 (rec (f x) x) 3)
(test 2 (rec (f x) (if (= x 3) (f 2) x)) 3)
(test 2 (rec (f x . y) (car y)) 1 2 3)
(test 2 'no-duplications (let ([x 1]) (rec ignored (begin (set! x (+ x 1)) void)) x))
(test 'f object-name (rec (f x) x))
(test 'f object-name (rec (f x . y) x))
(test 'f object-name (rec f (lambda (x) x)))
(test (list 2) (rec (f . x) (if (= (car x) 3) (f 2) x)) 3)
;; ---------- negate ----------
(let ()
(define *not (negate not))
(define *void (negate void))
(define *< (negate <))
(test #t *not #t)
(test #f *not #f)
(test #t *not 12)
(test #f *void)
(test #t *< 12 3)
(test #t *< 12 12)
(test #f *< 11 12)
(test #t *< 14 13 12 11)
(test #f *< 11 12 13 14))
;; ---------- curry/r ----------
(let ()
(define foo0 (lambda () 0))
(define foo1 (lambda (x) x))
(define foo3 (lambda (x y z) (list x y z)))
(define foo2< (lambda (x y . r) (list* x y r)))
(define foo35 (case-lambda [(a b c) 3] [(a b c d e) 5]))
(define foo:x (lambda (#:x [x 1] n . ns) (* x (apply + n ns))))
(define *foo0 (curry foo0))
(define *foo1 (curry foo1))
(define *foo3 (curry foo3))
(define *foo2< (curry foo2<))
(define *foo35 (curry foo35))
(define *foo:x2 (curry foo:x #:x 2))
(define ++ (curry +))
(define-syntax-rule ((f x ...) . => . e2) (test e2 f x ...))
;; see the docs for why these are expected
(((curry foo0)) . => . 0)
((*foo0) . => . 0)
((curry foo1 123) . => . 123)
((*foo1 123) . => . 123)
(((*foo1) 123) . => . 123)
((((*foo1)) 123) . => . 123)
((curry foo3 1 2 3) . => . '(1 2 3))
((*foo3 1 2 3) . => . '(1 2 3))
(((*foo3 1 2) 3) . => . '(1 2 3))
(((((((*foo3) 1)) 2)) 3) . => . '(1 2 3))
(((curry foo2< 1 2)) . => . '(1 2))
(((curry foo2< 1 2 3)) . => . '(1 2 3))
(((curry foo2< 1 2) 3) . => . '(1 2 3))
(((*foo2< 1 2)) . => . '(1 2))
(((*foo2< 1 2 3)) . => . '(1 2 3))
(((*foo2< 1 2) 3) . => . '(1 2 3))
(((curry + 1 2) 3) . => . 6)
(((++ 1 2) 3) . => . 6)
(((++) 1 2) . => . 3)
(((++)) . => . 0)
(((curry foo35 1 2) 3) . => . 3)
(((curry foo35 1 2 3)) . => . 3)
(((*foo35 1 2) 3) . => . 3)
(((*foo35 1 2 3)) . => . 3)
(((((*foo35 1 2 3 4))) 5) . => . 5)
(((((((((((*foo35)) 1)) 2)) 3 4))) 5) . => . 5)
((*foo:x2 1 2 3) . => . 12)
((map *foo:x2 '(1 2 3)) . => . '(2 4 6))
((((curryr foo3 1) 2) 3) . => . '(3 2 1))
(((curryr list 1) 2 3) . => . '(2 3 1))
)
(report-errs)