remove extra tut-subst.rkt and tmp.rkt files
This commit is contained in:
parent
1052852fd4
commit
484636d92e
|
@ -1,96 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
#|
|
|
||||||
|
|
||||||
The substitution function in this file has been designed
|
|
||||||
to work with any expression language so long as the only
|
|
||||||
binding form is λ and the shape of λ terms is:
|
|
||||||
|
|
||||||
(λ (x t) ... e)
|
|
||||||
|
|
||||||
|#
|
|
||||||
|
|
||||||
(require racket/set racket/match
|
|
||||||
redex/reduction-semantics
|
|
||||||
rackunit)
|
|
||||||
(provide subst/proc fvs)
|
|
||||||
|
|
||||||
(define (subst/proc x? vars replacements body)
|
|
||||||
(define replacements-ht
|
|
||||||
(for/fold ([m (hash)])
|
|
||||||
([v (in-list vars)]
|
|
||||||
[rep (in-list replacements)])
|
|
||||||
(hash-set m v rep)))
|
|
||||||
(define replacements-free-vars (for/list ([x (in-set (fvs x? replacements))]) x))
|
|
||||||
(define replacements-fresh-vars (variables-not-in (cons vars body)
|
|
||||||
replacements-free-vars))
|
|
||||||
(define init-fv-map
|
|
||||||
(for/fold ([m (hash)])
|
|
||||||
([fresh (in-list replacements-fresh-vars)]
|
|
||||||
[free (in-list replacements-free-vars)])
|
|
||||||
(hash-set m free fresh)))
|
|
||||||
(let loop ([body body]
|
|
||||||
[fvs-inactive init-fv-map]
|
|
||||||
[fvs-active (hash)]
|
|
||||||
[replacements replacements-ht])
|
|
||||||
(match body
|
|
||||||
[`(λ (,xs ,ts) ... ,body)
|
|
||||||
(define-values (new-xs new-inactive new-active new-replacements)
|
|
||||||
(adjust-active-inactive xs fvs-inactive fvs-active replacements))
|
|
||||||
`(λ ,@(map (λ (x t) `(,x ,t)) new-xs ts)
|
|
||||||
,(loop body new-inactive new-active new-replacements))]
|
|
||||||
[(? x? x)
|
|
||||||
(cond
|
|
||||||
[(hash-ref fvs-active x #f) => values]
|
|
||||||
[(hash-ref replacements x #f) => values]
|
|
||||||
[else x])]
|
|
||||||
[(? list?)
|
|
||||||
(map (λ (x) (loop x fvs-inactive fvs-active replacements))
|
|
||||||
body)]
|
|
||||||
[_ body])))
|
|
||||||
|
|
||||||
(define (adjust-active-inactive xs fvs-inactive fvs-active replacements)
|
|
||||||
(let loop ([xs xs]
|
|
||||||
[new-xs '()]
|
|
||||||
[fvs-inactive fvs-inactive]
|
|
||||||
[fvs-active fvs-active]
|
|
||||||
[replacements replacements])
|
|
||||||
(cond
|
|
||||||
[(null? xs)
|
|
||||||
(values (reverse new-xs)
|
|
||||||
fvs-inactive
|
|
||||||
fvs-active
|
|
||||||
replacements)]
|
|
||||||
[else
|
|
||||||
(define x (car xs))
|
|
||||||
(define inactive-var? (hash-has-key? fvs-inactive x))
|
|
||||||
(define active-var? (hash-has-key? fvs-active x))
|
|
||||||
(define new-x
|
|
||||||
(cond
|
|
||||||
[inactive-var? (hash-ref fvs-inactive x)]
|
|
||||||
[active-var? (hash-ref fvs-active x)]
|
|
||||||
[else x]))
|
|
||||||
(loop (cdr xs)
|
|
||||||
(cons new-x new-xs)
|
|
||||||
(if inactive-var?
|
|
||||||
(hash-remove fvs-inactive x)
|
|
||||||
fvs-inactive)
|
|
||||||
(if inactive-var?
|
|
||||||
(hash-set fvs-active x (hash-ref fvs-inactive x))
|
|
||||||
fvs-active)
|
|
||||||
(if (hash-has-key? replacements x)
|
|
||||||
(hash-remove replacements x)
|
|
||||||
replacements))])))
|
|
||||||
|
|
||||||
(define (fvs x? body)
|
|
||||||
(let loop ([body body])
|
|
||||||
(match body
|
|
||||||
[`(λ (,xs ,ts) ... ,body)
|
|
||||||
(set-subtract (loop body) (apply set xs))]
|
|
||||||
[(? x?)
|
|
||||||
(set body)]
|
|
||||||
[(? list?)
|
|
||||||
(for/fold ([fvs (set)])
|
|
||||||
([e (in-list body)])
|
|
||||||
(set-union fvs (loop e)))]
|
|
||||||
[_ (set)])))
|
|
|
@ -1,22 +0,0 @@
|
||||||
#lang racket
|
|
||||||
|
|
||||||
(require redex/reduction-semantics
|
|
||||||
redex/private/gen-trace
|
|
||||||
redex/private/search)
|
|
||||||
|
|
||||||
(define-language L
|
|
||||||
(v a
|
|
||||||
b
|
|
||||||
c))
|
|
||||||
|
|
||||||
(define-metafunction L
|
|
||||||
[(is-a? a)
|
|
||||||
T]
|
|
||||||
[(is-a? v)
|
|
||||||
F])
|
|
||||||
|
|
||||||
(enable-gen-trace!)
|
|
||||||
(test-equal (generate-term L #:satisfying
|
|
||||||
(is-a? b) any
|
|
||||||
+inf.0)
|
|
||||||
'((is-a? b) = F))
|
|
Loading…
Reference in New Issue
Block a user