33 lines
1.0 KiB
Scheme
33 lines
1.0 KiB
Scheme
#lang scheme/base
|
|
|
|
(provide negate curry)
|
|
|
|
(define (negate f)
|
|
(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 (curry f . args)
|
|
(unless (procedure? f) (raise-type-error 'curry "procedure" f))
|
|
(let loop ([args args])
|
|
(define curry
|
|
(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))))))
|
|
curry))
|