(module combinators mzscheme
(require (lib "etc.ss")
(lib "list.ss"))
(provide curry
yrruc
constant
compose/apply
map2
negate
conjoin
disjoin)
(define (curry f . args)
(lambda rest
(apply f (append args rest))))
(define (yrruc f . rest)
(lambda args
(apply f (append args rest))))
(define (constant v)
(lambda args v))
(define (compose/apply first . rest)
(foldl
(lambda (f accum)
(lambda args (apply accum (apply f args))))
first
rest))
(define (map2 f l-first . l-rest)
(let* ([ls (cons l-first l-rest)]
[lengths (map length ls)])
(unless (or (null? l-rest) (apply = lengths))
(raise (make-exn:fail:contract
(string->immutable-string
(format
"map2: all lists must be of same length, got lengths ~v"
lengths))
(current-continuation-marks))))
(recur loop ([ls ls])
(cond
[(andmap null? ls) (values null null)]
[else (let-values ([(bs cs) (loop (map cdr ls))]
[(b c) (apply f (map car ls))])
(values (cons b bs) (cons c cs)))]))))
(define (negate pred)
(lambda args (not (apply pred args))))
(define (conjoin . preds)
(lambda args (andmap (lambda (pred) (apply pred args)) preds)))
(define (disjoin . preds)
(lambda args (ormap (lambda (pred) (apply pred args)) preds)))
)