132 lines
4.1 KiB
Racket
132 lines
4.1 KiB
Racket
#lang racket/base
|
|
(require racket/match
|
|
(for-syntax racket/base racket/list))
|
|
(provide conjoin
|
|
disjoin)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Higher-Order Boolean Operations
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; ryanc: adjusted limit of inner cases from 8 to 2
|
|
;; All uses so far seem to be predicates, so more cases seem
|
|
;; unnecessary. Also, all uses so far are first-order, so
|
|
;; outer case-lambda* might be better replaced with macro.
|
|
|
|
(define conjoin
|
|
(case-lambda*
|
|
[(f ... 8)
|
|
(make-intermediate-procedure
|
|
'conjoined
|
|
[(x (... ...) 2) (and (f x (... ...)) ...)]
|
|
[xs (and (apply f xs) ...)]
|
|
#:keyword
|
|
[(keys vals . args)
|
|
(and (keyword-apply f keys vals args) ...)])]
|
|
[fs
|
|
(make-intermediate-procedure
|
|
'conjoined
|
|
[(x ... 2) (andmap (lambda (f) (f x ...)) fs)]
|
|
[xs (andmap (lambda (f) (apply f xs)) fs)]
|
|
#:keyword
|
|
[(keys vals . args)
|
|
(andmap (lambda (f) (keyword-apply f keys vals args)) fs)])]))
|
|
|
|
(define disjoin
|
|
(case-lambda*
|
|
[(f ... 8)
|
|
(make-intermediate-procedure
|
|
'disjoined
|
|
[(x (... ...) 2) (or (f x (... ...)) ...)]
|
|
[xs (or (apply f xs) ...)]
|
|
#:keyword
|
|
[(keys vals . args)
|
|
(or (keyword-apply f keys vals args) ...)])]
|
|
[fs
|
|
(make-intermediate-procedure
|
|
'disjoined
|
|
[(x ... 2) (ormap (lambda (f) (f x ...)) fs)]
|
|
[xs (ormap (lambda (f) (apply f xs)) fs)]
|
|
#:keyword
|
|
[(keys vals . args)
|
|
(ormap (lambda (f) (keyword-apply f keys vals args)) fs)])]))
|
|
|
|
(define-syntax (make-intermediate-procedure stx)
|
|
(syntax-case stx [quote]
|
|
[(_ (quote name) positional-clause ... #:keyword keyword-clause)
|
|
(syntax/loc stx
|
|
(make-keyword-procedure
|
|
(let* ([name (case-lambda keyword-clause)]) name)
|
|
(let* ([name (case-lambda* positional-clause ...)]) name)))]))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Automatic case-lambda repetition
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-for-syntax (split-syntax-at orig stx id)
|
|
(let loop ([found #f]
|
|
[seen null]
|
|
[stx stx])
|
|
(syntax-case stx []
|
|
[(head . tail)
|
|
(and (identifier? #'head)
|
|
(free-identifier=? #'head id))
|
|
(if found
|
|
(raise-syntax-error
|
|
#f
|
|
(format "duplicate occurrence of ~a" (syntax-e id))
|
|
orig
|
|
#'head)
|
|
(loop (list (reverse seen) #'head #'tail)
|
|
(cons #'head seen)
|
|
#'tail))]
|
|
[(head . tail) (loop found (cons #'head seen) #'tail)]
|
|
[_ found])))
|
|
|
|
(define-for-syntax (expand-ellipsis-clause stx pattern expr)
|
|
(cond
|
|
[(split-syntax-at stx pattern #'(... ...))
|
|
=>
|
|
(lambda (found)
|
|
(syntax-case found [...]
|
|
[([pre ... repeat] (... ...) [count post ... . tail])
|
|
(and (identifier? #'repeat)
|
|
(exact-nonnegative-integer? (syntax-e #'count)))
|
|
(build-list
|
|
(add1 (syntax-e #'count))
|
|
(lambda (i)
|
|
(with-syntax ([(var ...)
|
|
(generate-temporaries
|
|
(build-list i (lambda (j) #'repeat)))]
|
|
[body expr])
|
|
(list
|
|
(syntax/loc pattern (pre ... var ... post ... . tail))
|
|
(syntax/loc expr
|
|
(let-syntax ([the-body
|
|
(lambda _
|
|
(with-syntax ([(repeat (... ...)) #'(var ...)])
|
|
#'body))])
|
|
the-body))))))]
|
|
[(pre mid post)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected ellipsis between identifier and natural number literal"
|
|
stx
|
|
#'mid)]))]
|
|
[else (list (list pattern expr))]))
|
|
|
|
(define-syntax (case-lambda* stx)
|
|
(syntax-case stx []
|
|
[(_ [pattern body] ...)
|
|
(with-syntax ([([pattern body] ...)
|
|
(append-map
|
|
(lambda (p e) (expand-ellipsis-clause stx p e))
|
|
(syntax->list #'(pattern ...))
|
|
(syntax->list #'(body ...)))])
|
|
(syntax/loc stx
|
|
(case-lambda [pattern body] ...)))]))
|