131 lines
4.0 KiB
Racket
131 lines
4.0 KiB
Racket
#lang racket/base
|
|
|
|
(require
|
|
(only-in "rg.rkt"
|
|
[compile rg:compile])
|
|
(only-in "reduction-semantics.rkt"
|
|
do-test-match)
|
|
"pat-unify.rkt"
|
|
(for-syntax racket/base)
|
|
racket/match)
|
|
|
|
(provide pat->term
|
|
check-dq)
|
|
|
|
;; term generation
|
|
|
|
;; pat->term pat* env -> term
|
|
(define (pat->term lang pat full-env [term-e (make-hash)])
|
|
;(printf "\np->t: ~s\n\n ~s\n" pat full-env)
|
|
(define nt-matchers (make-hash))
|
|
(define eqs (env-eqs full-env))
|
|
(define (get-matcher nt)
|
|
(hash-ref nt-matchers nt
|
|
(λ () (let ([mtchr (do-test-match lang `(nt ,nt) '() 'pat->term #t)])
|
|
(hash-set! nt-matchers nt mtchr)
|
|
mtchr))))
|
|
(define res-term
|
|
(let recur ([p pat])
|
|
(match p
|
|
[`(name ,var ,(bound))
|
|
(define-values (rep-lvar pat) (lookup var eqs))
|
|
(call/ec (λ (fail)
|
|
(hash-ref term-e rep-lvar
|
|
(λ () (let ([t (recur pat)])
|
|
(unless t (fail #f))
|
|
(hash-set! term-e rep-lvar t)
|
|
t)))))]
|
|
[`(cstr (,nts ...) ,pat)
|
|
(match pat
|
|
[`(nt ,p-nt)
|
|
(define all-nts (cons p-nt nts))
|
|
(for/or ([nt-pat all-nts])
|
|
(define term (recur `(nt ,nt-pat)))
|
|
(and (for/and ([nt (remove nt-pat all-nts)])
|
|
((get-matcher nt) term))
|
|
term))]
|
|
[`any
|
|
(for/or ([nt-pat nts])
|
|
(define term (recur `(nt ,nt-pat)))
|
|
(and (for/and ([nt (remove nt-pat nts)])
|
|
((get-matcher nt) term))
|
|
term))]
|
|
[else
|
|
(define term (recur pat))
|
|
(and (for/and ([nt nts])
|
|
((get-matcher nt) term))
|
|
term)])]
|
|
[`(name ,var ,pat)
|
|
(error 'make-term "can't instantiate a term with an unbound variable: ~s" p)]
|
|
[`(list ,ps ...)
|
|
(call/ec (λ (fail)
|
|
(for/list ([p ps])
|
|
(let ([res (recur p)])
|
|
(unless res (fail #f))
|
|
res))))]
|
|
[else
|
|
(let-values ([(p bs) (gen-term p lang 2)])
|
|
p)])))
|
|
(and (check-dqs (remove-empty-dqs (env-dqs full-env)) term-e lang eqs)
|
|
res-term))
|
|
|
|
(define (check-dqs dqs term-e lang eqs)
|
|
(for/and ([dq dqs])
|
|
(define te (hash-copy term-e))
|
|
(define rhs (list-ref dq 0))
|
|
(define lhs (list-ref dq 1))
|
|
(check-dq rhs lhs te lang eqs)))
|
|
|
|
(define sym-index 0)
|
|
|
|
(struct not-ground ())
|
|
|
|
(define (check-dq rhs lhs term-e lang eqs)
|
|
(set! sym-index 0)
|
|
(define rhs-term (pat->term/term-e rhs term-e eqs lang))
|
|
(define lhs-term (pat->term/term-e lhs term-e eqs lang))
|
|
(not (equal? rhs-term lhs-term)))
|
|
|
|
(define (pat->term/term-e t term-e actual-e lang)
|
|
(call/ec
|
|
(λ (fail)
|
|
(let recur ([p t])
|
|
(match p
|
|
[`(name ,var ,(bound))
|
|
(if (hash-has-key? term-e (lvar var))
|
|
(recur (hash-ref term-e (lvar var)))
|
|
(let ([new-val (recur (hash-ref actual-e (lvar var)))])
|
|
(hash-set! term-e (lvar var) new-val)
|
|
new-val))]
|
|
[`(cstr (,nts ...) ,pat)
|
|
(recur pat)]
|
|
[`(list ,ps ...)
|
|
(for/list ([p ps]) (recur p))]
|
|
[`(nt ,_)
|
|
(fail (not-ground))]
|
|
[`(,stuff ...) ;; here it's a fully instanatiated list
|
|
`(,@stuff)]
|
|
[else
|
|
(let-values ([(p bs) (gen-term p lang 2)])
|
|
p)])))))
|
|
|
|
|
|
(define (gen-term pat lang size [num-atts 1] [retries 100])
|
|
(((rg:compile lang 'what) pat) size num-atts retries))
|
|
|
|
(define (lookup-pat id env)
|
|
(define-values (_ pat) (lookup id env))
|
|
pat)
|
|
|
|
(define (lookup-rep id env)
|
|
(define-values (rep _) (lookup id env))
|
|
rep)
|
|
|
|
(define (lookup id env)
|
|
(define res (hash-ref env (lvar id)))
|
|
(match res
|
|
[(lvar new-id)
|
|
(lookup new-id env)]
|
|
[else
|
|
(values (lvar id) res)]))
|