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

Redex enum supports var-except.

Browse Source 
Also reduces code duplication in Redex enum.
This commit is contained in:
Max New 2013-05-14 13:10:21 -05:00
parent 857cdfce64
commit c0f45d7d99
3 changed files with 128 additions and 174 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

248
collects/redex/private/enum.rkt
View File

@ -274,114 +274,21 @@
(define pat/enum-with-names (define pat/enum-with-names
(case-lambda (case-lambda
[(pat nt-enums named-terms) [(pat nt-enums named-terms)
(let loop ([pat pat]) (pat/enum-with-names-with
(match-a-pattern pat
pat named-terms
[`any (λ (nt)
(sum/enum (hash-ref nt-enums nt)))]
any/enum
(listof/enum any/enum))]
[`number num/enum]
[`string string/enum]
[`natural natural/enum]
[`integer integer/enum]
[`real real/enum]
[`boolean bool/enum]
[`variable var/enum]
[`(variable-except ,s ...)
;; todo
(error/enum 'unimplemented "var-except")]
[`(variable-prefix ,s)
;; todo
(error/enum 'unimplemented "var-prefix")]
[`variable-not-otherwise-mentioned
(error/enum 'unimplemented "var-not-mentioned")] ;; error
[`hole
(const/enum 'hole)]
[`(nt ,id)
(hash-ref nt-enums id)]
[`(name ,name ,pat)
(const/enum (hash-ref named-terms name))]
[`(mismatch-name ,name ,pat)
(error/enum 'unimplemented "mismatch-name")]
[`(in-hole ,p1 ,p2) ;; untested
(map/enum
(λ (t1-t2) ;; loses bijection
(plug-hole (car t1-t2)
(cdr t1-t2)))
(λ (plugged)
(cons 'hole plugged))
(prod/enum
(loop p1)
(loop p2)))]
[`(hide-hole ,p)
(loop p)]
[`(side-condition ,p ,g ,e)
(unsupported/enum pat)]
[`(cross ,s)
(unsupported/enum pat)]
[`(list ,sub-pats ...)
;; enum-list
(map/enum
flatten-1
identity
(list/enum
(map
(λ (sub-pat)
(match sub-pat
[`(repeat ,pat #f #f)
(map/enum
cdr
(λ (ts)
(cons (length ts)
ts))
(dep/enum
nats
(λ (n)
(list/enum
(build-list n (const (loop pat)))))))]
[`(repeat ,pat ,name #f)
(error/enum 'unimplemented "named-repeat")]
[`(repeat ,pat #f ,mismatch)
(error/enum 'unimplemented "mismatch-repeat")]
[else (map/enum
(λ (x) (list x))
car
(loop sub-pat))]))
sub-pats)))]
[(? (compose not pair?))
(const/enum pat)]))]
[(pat nts named-terms rec-nt-terms) [(pat nts named-terms rec-nt-terms)
(let loop ([pat pat]) (pat/enum-with-names-with
(match-a-pattern pat
pat named-terms
[`any (λ (nt)
(sum/enum (let ([rhss (lookup nts nt)])
any/enum
(listof/enum any/enum))]
[`number num/enum]
[`string string/enum]
[`natural natural/enum]
[`integer integer/enum]
[`real real/enum]
[`boolean bool/enum]
[`variable var/enum]
[`(variable-except ,s ...)
;; todo
(error/enum 'unimplemented "var except")]
[`(variable-prefix ,s)
;; todo
(error/enum 'unimplemented "var prefix")]
[`variable-not-otherwise-mentioned
(error/enum 'unimplemented "var not otherwise mentioned")]
[`hole
(const/enum 'hole)]
[`(nt ,id)
(let ([rhss (lookup nts id)])
(apply sum/enum (apply sum/enum
(map (map
(λ (rhs) (λ (rhs)
(cond [(cdr (assoc rhs (hash-ref rec-nt-terms id))) (cond [(cdr (assoc rhs (hash-ref rec-nt-terms nt)))
(thunk/enum (thunk/enum
+inf.f +inf.f
(λ () (λ ()
@ -392,60 +299,85 @@
(rec-pat/enum (rhs-pattern rhs) (rec-pat/enum (rhs-pattern rhs)
nts nts
rec-nt-terms)])) rec-nt-terms)]))
rhss)))] rhss)))))]))
[`(name ,name ,pat)
(const/enum (hash-ref named-terms name))] (define (pat/enum-with-names-with pat named-terms f)
[`(mismatch-name ,name ,pat) (let loop ([pat pat])
(error/enum 'unimplemented "mismatch-name")] (match-a-pattern
[`(in-hole ,p1 ,p2) ;; untested pat
(map/enum [`any
(λ (t1-t2) (sum/enum
(decomposition (car t1-t2) any/enum
(cdr t1-t2))) (listof/enum any/enum))]
(λ (decomp) [`number num/enum]
(cons (decomposition-ctx decomp) [`string string/enum]
(decomposition-term decomp))) [`natural natural/enum]
(prod/enum [`integer integer/enum]
(loop p1) [`real real/enum]
(loop p2)))] [`boolean bool/enum]
[`(hide-hole ,p) [`variable var/enum]
;; todo [`(variable-except ,s ...)
(loop p)] (apply except/enum var/enum s)]
[`(side-condition ,p ,g ,e) [`(variable-prefix ,s)
(unsupported/enum pat)] ;; todo
[`(cross ,s) (error/enum 'unimplemented "var-prefix")]
(unsupported/enum pat)] [`variable-not-otherwise-mentioned
[`(list ,sub-pats ...) (error/enum 'unimplemented "var-not-mentioned")] ;; error
;; enum-list [`hole
(map/enum (const/enum 'hole)]
flatten-1 [`(nt ,id)
identity (f id)]
(list/enum [`(name ,name ,pat)
(map (const/enum (hash-ref named-terms name))]
(λ (sub-pat) [`(mismatch-name ,name ,pat)
(match sub-pat (error/enum 'unimplemented "mismatch-name")]
[`(repeat ,pat #f #f) [`(in-hole ,p1 ,p2) ;; untested
(map/enum (map/enum
cdr (λ (t1-t2) ;; loses bijection
(λ (ts) (plug-hole (car t1-t2)
(cons (length ts) (cdr t1-t2)))
ts)) (λ (plugged)
(dep/enum (cons 'hole plugged))
nats (prod/enum
(λ (n) (loop p1)
(list/enum (loop p2)))]
(build-list n (const (loop pat)))))))] [`(hide-hole ,p)
[`(repeat ,pat ,name #f) (loop p)]
(error/enum 'unimplemented "named-repeat")] [`(side-condition ,p ,g ,e)
[`(repeat ,pat #f ,mismatch) (unsupported/enum pat)]
(error/enum 'unimplemented "mismatch-repeat")] [`(cross ,s)
[else (map/enum (unsupported/enum pat)]
list [`(list ,sub-pats ...)
cdr ;; enum-list
(loop sub-pat))])) (map/enum
sub-pats)))] flatten-1
[(? (compose not pair?)) identity
(const/enum pat)]))])) (list/enum
(map
(λ (sub-pat)
(match sub-pat
[`(repeat ,pat #f #f)
(map/enum
cdr
(λ (ts)
(cons (length ts)
ts))
(dep/enum
nats
(λ (n)
(list/enum
(build-list n (const (loop pat)))))))]
[`(repeat ,pat ,name #f)
(error/enum 'unimplemented "named-repeat")]
[`(repeat ,pat #f ,mismatch)
(error/enum 'unimplemented "mismatch-repeat")]
[else (map/enum
list
car
(loop sub-pat))]))
sub-pats)))]
[(? (compose not pair?))
(const/enum pat)])))
(define (flatten-1 xs) (define (flatten-1 xs)
(append-map (append-map

47
collects/redex/private/enumerator.rkt
View File

@ -80,20 +80,28 @@
(λ (x) (encode e x)))) (λ (x) (encode e x))))
;; except/enum : enum a, a -> enum a ;; except/enum : enum a, a -> enum a
(define (except/enum e a) (define except/enum
(unless (> (size e) 0) (case-lambda
(error 'empty-enum)) [(e) e]
(let ([m (encode e a)]) [(e a . rest)
(enum (- (size e) 1) (let ([excepted
(λ (n) (begin
(if (< n m) (unless (> (size e) 0)
(decode e n) (error 'empty-enum))
(decode e (+ n 1)))) (with-handlers ([exn:fail? (λ (_)
(λ (x) (apply except/enum e rest))])
(let ([n (encode e x)]) (let ([m (encode e a)])
(cond [(< n m) n] (enum (- (size e) 1)
[(> n m) (- n 1)] (λ (n)
[else (error 'excepted)])))))) (if (< n m)
(decode e n)
(decode e (+ n 1))))
(λ (x)
(let ([n (encode e x)])
(cond [(< n m) n]
[(> n m) (- n 1)]
[else (error 'excepted)])))))))])
(apply except/enum excepted rest))]))
;; to-list : enum a -> listof a ;; to-list : enum a -> listof a
;; better be finite ;; better be finite
@ -869,4 +877,13 @@
(check-equal? (to-list (up-to 3)) (check-equal? (to-list (up-to 3))
'(0 1 2 3)) '(0 1 2 3))
(check-equal? (foldl-enum cons '() (up-to 3)) (check-equal? (foldl-enum cons '() (up-to 3))
'(3 2 1 0)))) '(3 2 1 0)))
;; except/enum test
(define not-3 (except/enum nats 3))
(test-begin
(check-equal? (decode not-3 0) 0)
(check-equal? (decode not-3 3) 4))
(define not-a (except/enum nats 'a))
(test-begin
(check-equal? (decode not-a 0) 0)))

7
collects/redex/tests/enum-test.rkt
View File

@ -24,7 +24,7 @@
(e (e e) (e (e e)
(λ (x) e) (λ (x) e)
x) x)
(x variable)) (x (variable-except λ)))
;; slow: fix dep/enum ;; slow: fix dep/enum
(try-it 250 Λc e) (try-it 250 Λc e)
@ -36,3 +36,8 @@
;; Very slow, to be fixed ;; Very slow, to be fixed
(try-it 100 Named n) (try-it 100 Named n)
(define-language not-SKI
(x (variable-except s k i)))
(try-it 21 not-SKI x)