fixed things up so that everything is at least compiling now
svn: r10980
This commit is contained in:
Robby Findler
parent
ba4b0b6301
commit
86c7c808d4
|
|
@ -1,6 +1,5 @@
|
||||||
(module arithmetic mzscheme
|
#lang scheme
|
||||||
(require (planet robby/redex:5/reduction-semantics)
|
(require redex)
|
||||||
(planet robby/redex:5/gui))
|
|
||||||
|
|
||||||
(define-language lang
|
(define-language lang
|
||||||
(e (binop e e)
|
(e (binop e e)
|
||||||
|
|
@ -39,4 +38,4 @@
|
||||||
[(--> (in-hole e-ctxt_1 a) (in-hole e-ctxt_1 b))
|
[(--> (in-hole e-ctxt_1 a) (in-hole e-ctxt_1 b))
|
||||||
(c--> a b)]))
|
(c--> a b)]))
|
||||||
|
|
||||||
(traces reductions (term (- (* (sqrt 36) (/ 1 2)) (+ 1 2)))))
|
(traces reductions (term (- (* (sqrt 36) (/ 1 2)) (+ 1 2))))
|
||||||
|
|
@ -9,15 +9,13 @@ reflects the (broken) spec).
|
||||||
|
|
||||||
|#
|
|#
|
||||||
|
|
||||||
(module beginner mzscheme
|
#lang scheme
|
||||||
(require (planet robby/redex:5/reduction-semantics)
|
(require redex)
|
||||||
(planet robby/redex:5/subst)
|
|
||||||
(lib "match.ss"))
|
|
||||||
|
|
||||||
(provide run-tests
|
(provide run-tests
|
||||||
run-big-test)
|
run-big-test)
|
||||||
|
|
||||||
#|
|
#|
|
||||||
|
|
||||||
`lang' below is actually more generous than beginner, but the
|
`lang' below is actually more generous than beginner, but the
|
||||||
reductions assume that the programs are all syntactically
|
reductions assume that the programs are all syntactically
|
||||||
|
|
@ -34,7 +32,7 @@ reflects the (broken) spec).
|
||||||
|
|
||||||
|#
|
|#
|
||||||
|
|
||||||
(define-language lang
|
(define-language lang
|
||||||
(p (d/e ...))
|
(p (d/e ...))
|
||||||
(d/e (define (x x x ...) e)
|
(d/e (define (x x x ...) e)
|
||||||
(define x (lambda (x x ...) e))
|
(define x (lambda (x x ...) e))
|
||||||
|
|
@ -105,27 +103,19 @@ reflects the (broken) spec).
|
||||||
quote))
|
quote))
|
||||||
(not (prim-op? (term x))))))
|
(not (prim-op? (term x))))))
|
||||||
|
|
||||||
(define beg-e-subst
|
(define-metafunction beg-e-subst lang
|
||||||
(subst
|
[(x v x) v]
|
||||||
[(? number?)
|
[(x v (any_1 ...)) ((beg-e-subst (x v any_1)) ...)]
|
||||||
(constant)]
|
[(x v any) any])
|
||||||
[(? symbol?)
|
|
||||||
(variable)]
|
|
||||||
;; slight cheat here -- but since cond, if, and, or, etc
|
|
||||||
;; aren't allowed to be variables (syntactically), we're okay.
|
|
||||||
[`(,@(e ...))
|
|
||||||
(all-vars '())
|
|
||||||
(build (lambda (vars . e) e))
|
|
||||||
(subterms '() e)]))
|
|
||||||
|
|
||||||
(define (maker? v)
|
(define (maker? v)
|
||||||
(and (symbol? v)
|
(and (symbol? v)
|
||||||
(regexp-match #rx"^make-" (symbol->string v))))
|
(regexp-match #rx"^make-" (symbol->string v))))
|
||||||
|
|
||||||
(define p? (redex-match lang p))
|
(define p? (redex-match lang p))
|
||||||
(define prim-op? (redex-match lang prim-op))
|
(define prim-op? (redex-match lang prim-op))
|
||||||
|
|
||||||
(define reductions
|
(define reductions
|
||||||
(reduction-relation
|
(reduction-relation
|
||||||
lang
|
lang
|
||||||
((and true ... false e ...) . ==> . false)
|
((and true ... false e ...) . ==> . false)
|
||||||
|
|
@ -405,19 +395,19 @@ reflects the (broken) spec).
|
||||||
(term x_selector))))
|
(term x_selector))))
|
||||||
d/e_after ...))
|
d/e_after ...))
|
||||||
|
|
||||||
where
|
with
|
||||||
[(==> a b) (--> (in-hole p-ctxt_1 a) (in-hole p-ctxt_1 b))]
|
[(--> (in-hole p-ctxt_1 a) (in-hole p-ctxt_1 b)) (==> a b)]
|
||||||
[(e==> a b) (--> (in-hole p-ctxt a) b)]))
|
[(--> (in-hole p-ctxt a) b) (e==> a b)]))
|
||||||
|
|
||||||
(define (defined? f befores)
|
(define (defined? f befores)
|
||||||
(ormap
|
(ormap
|
||||||
(lambda (before)
|
(lambda (before)
|
||||||
(match before
|
(match before
|
||||||
[`(define (,a-name ,@(x ...)) ,b)
|
[`(define (,a-name ,x ...) ,b)
|
||||||
(eq? f a-name)]
|
(eq? f a-name)]
|
||||||
[`(define ,a-name (lambda ,@(x ...)))
|
[`(define ,a-name (lambda ,x ...))
|
||||||
(eq? f a-name)]
|
(eq? f a-name)]
|
||||||
[`(define-struct ,struct-name (,@(fields ...)))
|
[`(define-struct ,struct-name (,fields ...))
|
||||||
(or (ormap (lambda (field)
|
(or (ormap (lambda (field)
|
||||||
(eq? f (string->symbol (format "~a-~a" struct-name field))))
|
(eq? f (string->symbol (format "~a-~a" struct-name field))))
|
||||||
fields)
|
fields)
|
||||||
|
|
@ -426,7 +416,7 @@ reflects the (broken) spec).
|
||||||
[else #t]))
|
[else #t]))
|
||||||
befores))
|
befores))
|
||||||
|
|
||||||
(define (multi-subst orig-vars orig-args body)
|
(define (multi-subst orig-vars orig-args body)
|
||||||
(let loop ([args orig-args]
|
(let loop ([args orig-args]
|
||||||
[vars orig-vars]
|
[vars orig-vars]
|
||||||
[body body])
|
[body body])
|
||||||
|
|
@ -440,14 +430,17 @@ reflects the (broken) spec).
|
||||||
orig-args)]
|
orig-args)]
|
||||||
[else (loop (cdr args)
|
[else (loop (cdr args)
|
||||||
(cdr vars)
|
(cdr vars)
|
||||||
(beg-e-subst (car vars) (car args) body))])))
|
(term-let ((x (car vars))
|
||||||
|
(v (car args))
|
||||||
|
(body body))
|
||||||
|
(term (beg-e-subst (x v body)))))])))
|
||||||
|
|
||||||
(define (selector-name-match? struct fields selector)
|
(define (selector-name-match? struct fields selector)
|
||||||
(ormap (lambda (field) (string=? (format "~a-~a" struct field)
|
(ormap (lambda (field) (string=? (format "~a-~a" struct field)
|
||||||
(symbol->string selector)))
|
(symbol->string selector)))
|
||||||
fields))
|
fields))
|
||||||
|
|
||||||
(define (struct-index struct init-fields selector)
|
(define (struct-index struct init-fields selector)
|
||||||
(let loop ([i 0]
|
(let loop ([i 0]
|
||||||
[fields init-fields])
|
[fields init-fields])
|
||||||
(cond
|
(cond
|
||||||
|
|
@ -459,7 +452,7 @@ reflects the (broken) spec).
|
||||||
(loop (+ i 1)
|
(loop (+ i 1)
|
||||||
(cdr fields))))])))
|
(cdr fields))))])))
|
||||||
|
|
||||||
(define (maker-name-match? name maker)
|
(define (maker-name-match? name maker)
|
||||||
(let* ([names (symbol->string name)]
|
(let* ([names (symbol->string name)]
|
||||||
[makers (symbol->string maker)]
|
[makers (symbol->string maker)]
|
||||||
[namel (string-length names)]
|
[namel (string-length names)]
|
||||||
|
|
@ -468,13 +461,13 @@ reflects the (broken) spec).
|
||||||
(string=? (substring makers (- makerl namel) makerl)
|
(string=? (substring makers (- makerl namel) makerl)
|
||||||
names))))
|
names))))
|
||||||
|
|
||||||
(define (predicate-name-match? name predicate)
|
(define (predicate-name-match? name predicate)
|
||||||
(eq? (string->symbol (format "~a?" name)) predicate))
|
(eq? (string->symbol (format "~a?" name)) predicate))
|
||||||
|
|
||||||
(define failed-tests 0)
|
(define failed-tests 0)
|
||||||
(define total-tests 0)
|
(define total-tests 0)
|
||||||
|
|
||||||
(define (test in out)
|
(define (test in out)
|
||||||
(set! total-tests (+ total-tests 1))
|
(set! total-tests (+ total-tests 1))
|
||||||
(let/ec k
|
(let/ec k
|
||||||
(let* ([failed
|
(let* ([failed
|
||||||
|
|
@ -487,7 +480,7 @@ reflects the (broken) spec).
|
||||||
(fprintf (current-error-port) "FAILED: ~s\ngot: ~s\nexpected: ~s\n" in got out)
|
(fprintf (current-error-port) "FAILED: ~s\ngot: ~s\nexpected: ~s\n" in got out)
|
||||||
(set! failed-tests (+ failed-tests 1))))))
|
(set! failed-tests (+ failed-tests 1))))))
|
||||||
|
|
||||||
(define (test-all step . steps)
|
(define (test-all step . steps)
|
||||||
(set! total-tests (+ total-tests 1))
|
(set! total-tests (+ total-tests 1))
|
||||||
(let loop ([this step]
|
(let loop ([this step]
|
||||||
[rest steps])
|
[rest steps])
|
||||||
|
|
@ -524,8 +517,8 @@ reflects the (broken) spec).
|
||||||
this
|
this
|
||||||
nexts)])]))))
|
nexts)])]))))
|
||||||
|
|
||||||
(define show-dots (make-parameter #f))
|
(define show-dots (make-parameter #f))
|
||||||
(define (normalize orig-term failed)
|
(define (normalize orig-term failed)
|
||||||
(let loop ([term orig-term]
|
(let loop ([term orig-term]
|
||||||
[n 1000])
|
[n 1000])
|
||||||
(unless (p? term)
|
(unless (p? term)
|
||||||
|
|
@ -553,14 +546,14 @@ reflects the (broken) spec).
|
||||||
(newline))
|
(newline))
|
||||||
(failed (format "found more than one reduction\n ~s\n ->\n~s" term nexts))]))))
|
(failed (format "found more than one reduction\n ~s\n ->\n~s" term nexts))]))))
|
||||||
|
|
||||||
(define (show-test-results)
|
(define (show-test-results)
|
||||||
(cond
|
(cond
|
||||||
[(= failed-tests 0)
|
[(= failed-tests 0)
|
||||||
(fprintf (current-error-port) "passed all ~a tests\n" total-tests)]
|
(fprintf (current-error-port) "passed all ~a tests\n" total-tests)]
|
||||||
[else
|
[else
|
||||||
(fprintf (current-error-port) "failed ~a out of ~a tests\n" failed-tests total-tests)]))
|
(fprintf (current-error-port) "failed ~a out of ~a tests\n" failed-tests total-tests)]))
|
||||||
|
|
||||||
(define-syntax (tests stx)
|
(define-syntax (tests stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ args ...)
|
[(_ args ...)
|
||||||
(syntax
|
(syntax
|
||||||
|
|
@ -570,7 +563,7 @@ reflects the (broken) spec).
|
||||||
args ...
|
args ...
|
||||||
(show-test-results)))]))
|
(show-test-results)))]))
|
||||||
|
|
||||||
(define (run-tests)
|
(define (run-tests)
|
||||||
(tests
|
(tests
|
||||||
(test
|
(test
|
||||||
'((define-struct s ())
|
'((define-struct s ())
|
||||||
|
|
@ -873,7 +866,7 @@ reflects the (broken) spec).
|
||||||
`((define a 3) (a 9))
|
`((define a 3) (a 9))
|
||||||
"procedure application: expected procedure, given: 3")))
|
"procedure application: expected procedure, given: 3")))
|
||||||
|
|
||||||
(define (run-big-test)
|
(define (run-big-test)
|
||||||
(parameterize ([show-dots #t])
|
(parameterize ([show-dots #t])
|
||||||
(tests
|
(tests
|
||||||
(test
|
(test
|
||||||
|
|
@ -924,8 +917,7 @@ reflects the (broken) spec).
|
||||||
true
|
true
|
||||||
false)))))
|
false)))))
|
||||||
|
|
||||||
;; timing test
|
;; timing test
|
||||||
;#;
|
;#;
|
||||||
(time (run-tests)
|
(time (run-tests)
|
||||||
(run-big-test)))
|
(run-big-test))
|
||||||
|
|
||||||
|
|
@ -1,10 +1,9 @@
|
||||||
(module church mzscheme
|
#lang scheme
|
||||||
(require (planet robby/redex:5/reduction-semantics)
|
(require redex)
|
||||||
(planet robby/redex:5/gui))
|
|
||||||
|
|
||||||
(reduction-steps-cutoff 100)
|
(reduction-steps-cutoff 100)
|
||||||
|
|
||||||
(define-language lang
|
(define-language lang
|
||||||
(e (lambda (x) e)
|
(e (lambda (x) e)
|
||||||
(let (x e) e)
|
(let (x e) e)
|
||||||
(app e e)
|
(app e e)
|
||||||
|
|
@ -21,7 +20,7 @@
|
||||||
x)
|
x)
|
||||||
(x variable))
|
(x variable))
|
||||||
|
|
||||||
(define reductions
|
(define reductions
|
||||||
(reduction-relation
|
(reduction-relation
|
||||||
lang
|
lang
|
||||||
(--> (in-hole e-ctxt_1 (app (lambda (x_1) e_body) e_arg))
|
(--> (in-hole e-ctxt_1 (app (lambda (x_1) e_body) e_arg))
|
||||||
|
|
@ -29,7 +28,7 @@
|
||||||
(--> (in-hole e-ctxt_1 (let (x_1 v_1) e_1))
|
(--> (in-hole e-ctxt_1 (let (x_1 v_1) e_1))
|
||||||
(in-hole e-ctxt_1 (subst (x_1 v_1 e_1))))))
|
(in-hole e-ctxt_1 (subst (x_1 v_1 e_1))))))
|
||||||
|
|
||||||
(define-metafunction subst
|
(define-metafunction subst
|
||||||
lang
|
lang
|
||||||
[(x_1 e_1 (lambda (x_1) e_2)) (lambda (x_1) e_2)]
|
[(x_1 e_1 (lambda (x_1) e_2)) (lambda (x_1) e_2)]
|
||||||
[(x_1 e_1 (lambda (x_2) e_2))
|
[(x_1 e_1 (lambda (x_2) e_2))
|
||||||
|
|
@ -47,11 +46,11 @@
|
||||||
(subst (x_1 e_1 e_3)))]
|
(subst (x_1 e_1 e_3)))]
|
||||||
[(x_1 e_1 number_1) number_1])
|
[(x_1 e_1 number_1) number_1])
|
||||||
|
|
||||||
(traces lang reductions
|
(traces lang reductions
|
||||||
'(let (plus (lambda (m)
|
'(let (plus (lambda (m)
|
||||||
(lambda (n)
|
(lambda (n)
|
||||||
(lambda (s)
|
(lambda (s)
|
||||||
(lambda (z)
|
(lambda (z)
|
||||||
(app (app m s) (app (app n s) z)))))))
|
(app (app m s) (app (app n s) z)))))))
|
||||||
(let (two (lambda (s) (lambda (z) (app s (app s z)))))
|
(let (two (lambda (s) (lambda (z) (app s (app s z)))))
|
||||||
(app (app plus two) two)))))
|
(app (app plus two) two))))
|
||||||
|
|
@ -1,15 +1,15 @@
|
||||||
|
#lang scheme
|
||||||
|
|
||||||
;"one point basis"
|
;"one point basis"
|
||||||
;"formal aspects of computing"
|
;"formal aspects of computing"
|
||||||
|
|
||||||
(module combinators mzscheme
|
(require redex)
|
||||||
(require (planet robby/redex:5/reduction-semantics)
|
|
||||||
(planet robby/redex:5/gui))
|
|
||||||
|
|
||||||
(initial-font-size 12)
|
(initial-font-size 12)
|
||||||
(reduction-steps-cutoff 100)
|
(reduction-steps-cutoff 100)
|
||||||
(initial-char-width 80)
|
(initial-char-width 80)
|
||||||
|
|
||||||
(define-language lang
|
(define-language lang
|
||||||
(e (e e)
|
(e (e e)
|
||||||
comb
|
comb
|
||||||
abs1
|
abs1
|
||||||
|
|
@ -25,7 +25,7 @@
|
||||||
c*
|
c*
|
||||||
w))
|
w))
|
||||||
|
|
||||||
(define ij-relation
|
(define ij-relation
|
||||||
(reduction-relation
|
(reduction-relation
|
||||||
lang
|
lang
|
||||||
(--> (in-hole e-ctxt_1 (i e_1))
|
(--> (in-hole e-ctxt_1 (i e_1))
|
||||||
|
|
@ -33,7 +33,7 @@
|
||||||
(--> (in-hole e-ctxt_1 ((((j e_a) e_b) e_c) e_d))
|
(--> (in-hole e-ctxt_1 ((((j e_a) e_b) e_c) e_d))
|
||||||
(in-hole e-ctxt_1 ((e_a e_b) ((e_a e_d) e_c))))))
|
(in-hole e-ctxt_1 ((e_a e_b) ((e_a e_d) e_c))))))
|
||||||
|
|
||||||
(define relation
|
(define relation
|
||||||
(union-reduction-relations
|
(union-reduction-relations
|
||||||
ij-relation
|
ij-relation
|
||||||
(reduction-relation
|
(reduction-relation
|
||||||
|
|
@ -48,24 +48,25 @@
|
||||||
(in-hole e-ctxt_1 ((e_a e_b) e_b))))))
|
(in-hole e-ctxt_1 ((e_a e_b) e_b))))))
|
||||||
|
|
||||||
|
|
||||||
(define c* `((j i) i))
|
(define c* `((j i) i))
|
||||||
(define (make-c c*) `(((j ,c*) (j ,c*)) (j ,c*)))
|
(define (make-c c*) `(((j ,c*) (j ,c*)) (j ,c*)))
|
||||||
(define (make-b c) `((,c ((j i) ,c)) (j i)))
|
(define (make-b c) `((,c ((j i) ,c)) (j i)))
|
||||||
(define (make-w b c c*) `(,c ((,c ((,b ,c) ((,c ((,b j) ,c*)) ,c*))) ,c*)))
|
(define (make-w b c c*) `(,c ((,c ((,b ,c) ((,c ((,b j) ,c*)) ,c*))) ,c*)))
|
||||||
(define (make-s b c w) `((,b ((,b (,b ,w)) ,c)) (,b ,b)))
|
(define (make-s b c w) `((,b ((,b (,b ,w)) ,c)) (,b ,b)))
|
||||||
|
|
||||||
(traces/multiple lang
|
(traces lang
|
||||||
relation
|
relation
|
||||||
(list
|
(list
|
||||||
`((,c* abs1) abs2)
|
`((,c* abs1) abs2)
|
||||||
`(((,(make-c 'c*) abs1) abs2) abs3)
|
`(((,(make-c 'c*) abs1) abs2) abs3)
|
||||||
`(((,(make-b 'c) abs1) abs2) abs3)
|
`(((,(make-b 'c) abs1) abs2) abs3)
|
||||||
`((,(make-w 'b 'c 'c*) abs1) abs2)
|
`((,(make-w 'b 'c 'c*) abs1) abs2)
|
||||||
`(((,(make-s 'b 'c 'w) abs1) abs2) abs3)))
|
`(((,(make-s 'b 'c 'w) abs1) abs2) abs3))
|
||||||
|
#:multiple #t)
|
||||||
|
|
||||||
(require (lib "pretty.ss"))
|
(require (lib "pretty.ss"))
|
||||||
#;
|
#;
|
||||||
(let loop ([t (make-s (make-b (make-c c*))
|
(let loop ([t (make-s (make-b (make-c c*))
|
||||||
(make-c c*)
|
(make-c c*)
|
||||||
(make-w (make-b (make-c c*))
|
(make-w (make-b (make-c c*))
|
||||||
(make-c c*)
|
(make-c c*)
|
||||||
|
|
@ -81,10 +82,10 @@
|
||||||
(pretty-print t))
|
(pretty-print t))
|
||||||
(loop (car next) (+ i 1)))))
|
(loop (car next) (+ i 1)))))
|
||||||
|
|
||||||
#;
|
#;
|
||||||
(traces lang ij-relation
|
(traces lang ij-relation
|
||||||
(make-s (make-b (make-c c*))
|
(make-s (make-b (make-c c*))
|
||||||
(make-c c*)
|
(make-c c*)
|
||||||
(make-w (make-b (make-c c*))
|
(make-w (make-b (make-c c*))
|
||||||
(make-c c*)
|
(make-c c*)
|
||||||
c*))))
|
c*)))
|
||||||
|
|
@ -1,18 +1,17 @@
|
||||||
(module compatible-closure mzscheme
|
#lang scheme
|
||||||
(require (planet robby/redex:5/reduction-semantics)
|
(require redex)
|
||||||
(planet robby/redex:5/gui))
|
|
||||||
|
|
||||||
(define-language grammar
|
(define-language grammar
|
||||||
(B t
|
(B t
|
||||||
f
|
f
|
||||||
(B * B)))
|
(B * B)))
|
||||||
|
|
||||||
(define r
|
(define r
|
||||||
(reduction-relation
|
(reduction-relation
|
||||||
grammar
|
grammar
|
||||||
(--> (f * B_1) B_1 false) ; [a]
|
(--> (f * B_1) B_1 false) ; [a]
|
||||||
(--> (t * B_1) t true))) ; [b]
|
(--> (t * B_1) t true))) ; [b]
|
||||||
|
|
||||||
(define ->r (compatible-closure r grammar B))
|
(define ->r (compatible-closure r grammar B))
|
||||||
|
|
||||||
(traces grammar ->r '((f * f) * (t * f))))
|
(traces grammar ->r '((f * f) * (t * f)))
|
||||||
|
|
|
||||||
|
|
@ -1,67 +0,0 @@
|
||||||
(module eta mzscheme
|
|
||||||
(require (planet robby/redex:5/reduction-semantics)
|
|
||||||
(planet robby/redex:5/gui)
|
|
||||||
(planet robby/redex:5/subst))
|
|
||||||
|
|
||||||
(reduction-steps-cutoff 100)
|
|
||||||
|
|
||||||
(define-language lang
|
|
||||||
(e (e e)
|
|
||||||
x
|
|
||||||
(+ e e)
|
|
||||||
v)
|
|
||||||
(c (v c)
|
|
||||||
(c e)
|
|
||||||
(+ v c)
|
|
||||||
(+ c e)
|
|
||||||
hole)
|
|
||||||
(v (lambda (x) e)
|
|
||||||
number)
|
|
||||||
(x (variable-except lambda +)))
|
|
||||||
|
|
||||||
(define reductions
|
|
||||||
(reduction-relation
|
|
||||||
lang
|
|
||||||
(c=> ((lambda (variable_x) e_body) v_arg)
|
|
||||||
,(lc-subst (term variable_x) (term v_arg) (term e_body)))
|
|
||||||
(c=> (+ number_1 number_2)
|
|
||||||
,(+ (term number_1) (term number_2)))
|
|
||||||
(c=> (side-condition (lambda (variable_x) (e_fun variable_x))
|
|
||||||
(equal? (term e_fun) (lc-subst (term variable_x) 1234 (term e_fun))))
|
|
||||||
e_fun)
|
|
||||||
|
|
||||||
(--> (in-hole c (number_n v_arg))
|
|
||||||
,(format "procedure application: expected procedure, given: ~a; arguments were: ~a"
|
|
||||||
(term number_n)
|
|
||||||
(term v_arg)))
|
|
||||||
(--> (in-hole c (+ (name non-num (lambda (variable) e)) (name arg2 v)))
|
|
||||||
,(format "+: expects type <number> as 1st argument, given: ~s; other arguments were: ~s"
|
|
||||||
(term non-num) (term arg2)))
|
|
||||||
(--> (in-hole c (+ (name arg1 v) (name non-num (lambda (variable) e))))
|
|
||||||
,(format "+: expects type <number> as 2nd argument, given: ~s; other arguments were: ~s"
|
|
||||||
(term arg1) (term non-num)))
|
|
||||||
|
|
||||||
where
|
|
||||||
|
|
||||||
[(c=> x y) (--> (in-hole c_1 x) (in-hole c_1 y))]))
|
|
||||||
|
|
||||||
(define lc-subst
|
|
||||||
(subst
|
|
||||||
[(? symbol?) (variable)]
|
|
||||||
[(? number?) (constant)]
|
|
||||||
[`(lambda (,x) ,b)
|
|
||||||
(all-vars (list x))
|
|
||||||
(build (lambda (vars body) `(lambda (,(car vars)) ,body)))
|
|
||||||
(subterm (list x) b)]
|
|
||||||
[`(+ ,n2 ,n1)
|
|
||||||
(all-vars '())
|
|
||||||
(build (lambda (vars n1 n2) `(+ ,n1 ,n1)))
|
|
||||||
(subterm '() n1)
|
|
||||||
(subterm '() n2)]
|
|
||||||
[`(,f ,x)
|
|
||||||
(all-vars '())
|
|
||||||
(build (lambda (vars f x) `(,f ,x)))
|
|
||||||
(subterm '() f)
|
|
||||||
(subterm '() x)]))
|
|
||||||
|
|
||||||
(traces lang reductions '(+ (lambda (x) ((+ 1 2) x)) 1)))
|
|
||||||
|
|
@ -1,254 +0,0 @@
|
||||||
(module iswim mzscheme
|
|
||||||
(require (planet robby/redex:5/reduction-semantics)
|
|
||||||
(planet robby/redex:5/subst)
|
|
||||||
(lib "contract.ss"))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; Expression grammar:
|
|
||||||
|
|
||||||
(define-language iswim-grammar
|
|
||||||
(M (M M)
|
|
||||||
(o1 M)
|
|
||||||
(o2 M M)
|
|
||||||
V
|
|
||||||
("letcc" X M)
|
|
||||||
("cc" M M))
|
|
||||||
(V X
|
|
||||||
("lam" variable M)
|
|
||||||
b
|
|
||||||
("[" M "]"))
|
|
||||||
(X variable)
|
|
||||||
(b number)
|
|
||||||
(o1 "add1" "sub1" "iszero")
|
|
||||||
(o2 "+" "-" "*" "^")
|
|
||||||
(on o1 o2)
|
|
||||||
|
|
||||||
;; Evaluation contexts:
|
|
||||||
(E hole
|
|
||||||
(E M)
|
|
||||||
(V E)
|
|
||||||
(o1 E)
|
|
||||||
(o2 E M)
|
|
||||||
(o2 V E)
|
|
||||||
("cc" E M)
|
|
||||||
("cc" V E))
|
|
||||||
|
|
||||||
;; Continuations (CK machine):
|
|
||||||
(k "mt"
|
|
||||||
("fun" V k)
|
|
||||||
("arg" M k)
|
|
||||||
("narg" (V ... on) (M ...) k))
|
|
||||||
|
|
||||||
;; Environments and closures (CEK):
|
|
||||||
(env ((X = vcl) ...))
|
|
||||||
(cl (M : env))
|
|
||||||
(vcl (V- : env))
|
|
||||||
|
|
||||||
;; Values that are not variables:
|
|
||||||
(V- ("lam" variable M)
|
|
||||||
b)
|
|
||||||
|
|
||||||
;; Continuations with closures (CEK):
|
|
||||||
(k- "mt"
|
|
||||||
("fun" vcl k-)
|
|
||||||
("arg" cl k-)
|
|
||||||
("narg" (vcl ... on) (cl ...) k-)))
|
|
||||||
|
|
||||||
(define M? (redex-match iswim-grammar M))
|
|
||||||
(define V? (redex-match iswim-grammar V))
|
|
||||||
(define o1? (redex-match iswim-grammar o1))
|
|
||||||
(define o2? (redex-match iswim-grammar o2))
|
|
||||||
(define on? (redex-match iswim-grammar on))
|
|
||||||
(define k? (redex-match iswim-grammar k))
|
|
||||||
|
|
||||||
(define env? (redex-match iswim-grammar env))
|
|
||||||
(define cl? (redex-match iswim-grammar cl))
|
|
||||||
(define vcl? (redex-match iswim-grammar vcl))
|
|
||||||
(define k-? (redex-match iswim-grammar k-))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; Substitution:
|
|
||||||
|
|
||||||
;; The subst form makes implemention of capture-avoiding
|
|
||||||
;; easier. We just have to describe how variables bind
|
|
||||||
;; in our language's forms.
|
|
||||||
|
|
||||||
(define iswim-subst/backwards
|
|
||||||
(subst
|
|
||||||
[(? symbol?) (variable)]
|
|
||||||
[(? number?) (constant)]
|
|
||||||
[`("lam" ,X ,M)
|
|
||||||
(all-vars (list X))
|
|
||||||
(build (lambda (X-list M) `("lam" ,(car X-list) ,M)))
|
|
||||||
(subterm (list X) M)]
|
|
||||||
[`(,(and o (or "add1" "sub1" "iszero")) ,M1)
|
|
||||||
(all-vars '())
|
|
||||||
(build (lambda (vars M1) `(,o ,M1)))
|
|
||||||
(subterm '() M1)]
|
|
||||||
[`(,(and o (or "+" "-" "*" "^")) ,M1 ,M2)
|
|
||||||
(all-vars '())
|
|
||||||
(build (lambda (vars M1 M2) `(,o ,M1 ,M2)))
|
|
||||||
(subterm '() M1)
|
|
||||||
(subterm '() M2)]
|
|
||||||
[`(,M1 ,M2)
|
|
||||||
(all-vars '())
|
|
||||||
(build (lambda (empty-list M1 M2) `(,M1 ,M2)))
|
|
||||||
(subterm '() M1)
|
|
||||||
(subterm '() M2)]
|
|
||||||
[`("letcc" ,X ,M)
|
|
||||||
(all-vars (list X))
|
|
||||||
(build (lambda (X-list M) `("letcc" ,(car X-list) ,M)))
|
|
||||||
(subterm (list X) M)]
|
|
||||||
[`("cc" ,M1 ,M2)
|
|
||||||
(all-vars '())
|
|
||||||
(build (lambda (vars M1 M2) `("cc" ,M1 ,M2)))
|
|
||||||
(subterm '() M1)
|
|
||||||
(subterm '() M2)]
|
|
||||||
[`("[" ,E "]")
|
|
||||||
(all-vars '())
|
|
||||||
(build (lambda (vars) `("[" ,E "]")))]))
|
|
||||||
|
|
||||||
|
|
||||||
;; the argument order for the subst-generated function
|
|
||||||
;; doesn't match the order in the notes:
|
|
||||||
(define (iswim-subst M Xr Mr)
|
|
||||||
(iswim-subst/backwards Xr Mr M))
|
|
||||||
|
|
||||||
(define empty-env '())
|
|
||||||
|
|
||||||
;; Environment lookup
|
|
||||||
(define (env-lookup env X)
|
|
||||||
(let ([m (assq X env)])
|
|
||||||
(and m (caddr m))))
|
|
||||||
|
|
||||||
;; Environment extension
|
|
||||||
(define (env-extend env X vcl)
|
|
||||||
(cons (list X '= vcl) env))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; Reductions:
|
|
||||||
|
|
||||||
;; beta_v reduction
|
|
||||||
(define beta_v
|
|
||||||
(reduction-relation
|
|
||||||
iswim-grammar
|
|
||||||
(--> (("lam" X_1 M_1) V_1)
|
|
||||||
,(iswim-subst (term M_1) (term X_1) (term V_1)))))
|
|
||||||
|
|
||||||
(define delta
|
|
||||||
(reduction-relation
|
|
||||||
iswim-grammar
|
|
||||||
(--> ("add1" b_1) ,(add1 (term b_1)))
|
|
||||||
(--> ("sub1" b_1) ,(sub1 (term b_1)))
|
|
||||||
(--> ("iszero" b_1)
|
|
||||||
,(if (zero? (term b_1))
|
|
||||||
(term ("lam" x ("lam" y x)))
|
|
||||||
(term ("lam" x ("lam" y y)))))
|
|
||||||
(--> ("+" b_1 b_2) ,(+ (term b_1) (term b_2)))
|
|
||||||
(--> ("-" b_1 b_2) ,(- (term b_1) (term b_2)))
|
|
||||||
(--> ("*" b_1 b_2) ,(* (term b_1) (term b_2)))
|
|
||||||
(--> ("^" b_1 b_2) ,(expt (term b_1) (term b_2)))))
|
|
||||||
|
|
||||||
;; ->v
|
|
||||||
(define ->v (compatible-closure (union-reduction-relations beta_v delta)
|
|
||||||
iswim-grammar
|
|
||||||
M))
|
|
||||||
|
|
||||||
;; :->v
|
|
||||||
(define :->v (context-closure (union-reduction-relations beta_v delta)
|
|
||||||
iswim-grammar
|
|
||||||
E))
|
|
||||||
|
|
||||||
;; :->v+letcc
|
|
||||||
(define :->v+letcc
|
|
||||||
(union-reduction-relations
|
|
||||||
:->v
|
|
||||||
(reduction-relation
|
|
||||||
iswim-grammar
|
|
||||||
|
|
||||||
;; letcc rule:
|
|
||||||
(--> (in-hole E_1 ("letcc" X_1 M_1))
|
|
||||||
(in-hole E_1 ,(iswim-subst (term M_1)
|
|
||||||
(term X_1)
|
|
||||||
`("[" (in-hole E_1 ||) "]"))))
|
|
||||||
|
|
||||||
;; cc rule:
|
|
||||||
(--> (in-hole E ("cc" ("[" (in-hole E_2 ||) "]") V_1))
|
|
||||||
(in-hole E_2 V_1)))))
|
|
||||||
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; Helpers:
|
|
||||||
|
|
||||||
(define (delta*n on Vs)
|
|
||||||
(let ([l (apply-reduction-relation delta `(,on ,@Vs))])
|
|
||||||
(if (null? l)
|
|
||||||
#f
|
|
||||||
(car l))))
|
|
||||||
|
|
||||||
(define (delta*1 o1 V)
|
|
||||||
(delta*n o1 (list V)))
|
|
||||||
|
|
||||||
(define (delta*2 o2 V1 V2)
|
|
||||||
(delta*n o2 (list V1 V2)))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; Abbreviations:
|
|
||||||
|
|
||||||
(define (if0 test then else)
|
|
||||||
(let ([X (variable-not-in `(,then ,else) 'X)])
|
|
||||||
`(((("iszero" ,test) ("lam" ,X ,then)) ("lam" ,X ,else)) 77)))
|
|
||||||
|
|
||||||
(define true '("lam" x ("lam" y x)))
|
|
||||||
(define false '("lam" x ("lam" y y)))
|
|
||||||
(define boolean-not `("lam" x ((x ,false) ,true)))
|
|
||||||
|
|
||||||
(define mkpair '("lam" x ("lam" y ("lam" s ((s x) y)))))
|
|
||||||
(define fst '("lam" p (p ("lam" x ("lam" y x)))))
|
|
||||||
(define snd '("lam" p (p ("lam" x ("lam" y y)))))
|
|
||||||
|
|
||||||
(define Y_v '("lam" f ("lam" x
|
|
||||||
((("lam" g (f ("lam" x ((g g) x))))
|
|
||||||
("lam" g (f ("lam" x ((g g) x)))))
|
|
||||||
x))))
|
|
||||||
|
|
||||||
(define mksum `("lam" s
|
|
||||||
("lam" x
|
|
||||||
,(if0 'x 0 '("+" x (s ("sub1" x)))))))
|
|
||||||
(define sum `(,Y_v ,mksum))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; Exports:
|
|
||||||
|
|
||||||
(provide iswim-grammar)
|
|
||||||
|
|
||||||
(provide/contract (M? (any/c . -> . any/c))
|
|
||||||
(V? (any/c . -> . any/c))
|
|
||||||
(o1? (any/c . -> . any/c))
|
|
||||||
(o2? (any/c . -> . any/c))
|
|
||||||
(on? (any/c . -> . any/c))
|
|
||||||
(k? (any/c . -> . any/c))
|
|
||||||
(env? (any/c . -> . any/c))
|
|
||||||
(cl? (any/c . -> . any/c))
|
|
||||||
(vcl? (any/c . -> . any/c))
|
|
||||||
(iswim-subst (M? symbol? M? . -> . M?))
|
|
||||||
(env-lookup (env? symbol? . -> . (union false/c vcl?)))
|
|
||||||
(env-extend (env? symbol? vcl? . -> . env?))
|
|
||||||
(empty-env env?)
|
|
||||||
(beta_v reduction-relation?)
|
|
||||||
(delta reduction-relation?)
|
|
||||||
(delta*1 (o1? V? . -> . (union false/c V?)))
|
|
||||||
(delta*2 (o2? V? V? . -> . (union false/c V?)))
|
|
||||||
(delta*n (on? (listof V?) . -> . (union false/c V?)))
|
|
||||||
(->v reduction-relation?)
|
|
||||||
(:->v reduction-relation?)
|
|
||||||
(:->v+letcc reduction-relation?)
|
|
||||||
(if0 (M? M? M? . -> . M?))
|
|
||||||
(true M?)
|
|
||||||
(false M?)
|
|
||||||
(boolean-not M?)
|
|
||||||
(mkpair M?)
|
|
||||||
(fst M?)
|
|
||||||
(snd M?)
|
|
||||||
(Y_v M?)
|
|
||||||
(sum M?)))
|
|
||||||
|
|
@ -1,12 +1,16 @@
|
||||||
(module letrec mzscheme
|
#lang scheme
|
||||||
(require (planet robby/redex:5/reduction-semantics)
|
|
||||||
(planet robby/redex:5/gui)
|
|
||||||
(planet robby/redex:5/subst)
|
|
||||||
(lib "list.ss"))
|
|
||||||
|
|
||||||
(reduction-steps-cutoff 20)
|
#|
|
||||||
|
|
||||||
(define-language lang
|
BUG: letrec & let are not handled properly by substitution
|
||||||
|
|
||||||
|
|#
|
||||||
|
|
||||||
|
(require redex "subst.ss")
|
||||||
|
|
||||||
|
(reduction-steps-cutoff 20)
|
||||||
|
|
||||||
|
(define-language lang
|
||||||
(p ((store (x v) ...) e))
|
(p ((store (x v) ...) e))
|
||||||
(e (set! x e)
|
(e (set! x e)
|
||||||
(let ((x e)) e)
|
(let ((x e)) e)
|
||||||
|
|
@ -26,42 +30,15 @@
|
||||||
(begin ec e e ...)
|
(begin ec e e ...)
|
||||||
hole))
|
hole))
|
||||||
|
|
||||||
(define substitute
|
;; collect : term -> term
|
||||||
(subst
|
;; performs a garbage collection on the term `p'
|
||||||
[(? symbol?) (variable)]
|
(define (collect p)
|
||||||
[(? number?) (constant)]
|
(define (substitute var exp body)
|
||||||
[`(lambda (,x) ,b)
|
(term-let ((var var)
|
||||||
(all-vars (list x))
|
(exp exp)
|
||||||
(build (lambda (vars body) `(lambda (,(car vars)) ,body)))
|
(body body))
|
||||||
(subterm (list x) b)]
|
(term (subst (var exp body)))))
|
||||||
[`(set! ,x ,e)
|
|
||||||
(all-vars '())
|
|
||||||
(build (lambda (vars name body) `(set! ,name ,body)))
|
|
||||||
(subterm '() x)
|
|
||||||
(subterm '() e)]
|
|
||||||
[`(let ((,x ,e1)) ,e2)
|
|
||||||
(all-vars (list x))
|
|
||||||
(build (lambda (vars letval body) `(let ((,(car vars) ,letval)) ,body)))
|
|
||||||
(subterm '() e1)
|
|
||||||
(subterm (list x) e2)]
|
|
||||||
[`(letrec ((,x ,e1)) ,e2)
|
|
||||||
(all-vars (list x))
|
|
||||||
(build (lambda (vars letval body) `(letrec ((,(car vars) ,letval)) ,body)))
|
|
||||||
(subterm (list x) e1)
|
|
||||||
(subterm (list x) e2)]
|
|
||||||
[`(begin ,@(es ...))
|
|
||||||
(all-vars (list))
|
|
||||||
(build (lambda (vars . rest) `(begin ,@rest)))
|
|
||||||
(subterms '() es)]
|
|
||||||
[`(,f ,x)
|
|
||||||
(all-vars '())
|
|
||||||
(build (lambda (vars f x) `(,f ,x)))
|
|
||||||
(subterm '() f)
|
|
||||||
(subterm '() x)]))
|
|
||||||
|
|
||||||
;; collect : term -> term
|
|
||||||
;; performs a garbage collection on the term `p'
|
|
||||||
(define (collect p)
|
|
||||||
(define (find-unused vars p)
|
(define (find-unused vars p)
|
||||||
(filter (λ (var) (unused? var p))
|
(filter (λ (var) (unused? var p))
|
||||||
vars))
|
vars))
|
||||||
|
|
@ -89,7 +66,7 @@
|
||||||
[else
|
[else
|
||||||
(collect (remove-unused unused p))])))
|
(collect (remove-unused unused p))])))
|
||||||
|
|
||||||
(define reductions
|
(define reductions
|
||||||
(reduction-relation
|
(reduction-relation
|
||||||
lang
|
lang
|
||||||
(==> (in-hole pc_1 (begin v e_1 e_2 ...))
|
(==> (in-hole pc_1 (begin v e_1 e_2 ...))
|
||||||
|
|
@ -122,8 +99,7 @@
|
||||||
set!)
|
set!)
|
||||||
|
|
||||||
(==> (in-hole pc_1 ((lambda (x_1) e_1) v_1))
|
(==> (in-hole pc_1 ((lambda (x_1) e_1) v_1))
|
||||||
(in-hole pc_1
|
(in-hole pc_1 (subst (x_1 v_1 e_1)))
|
||||||
,(substitute (term x_1) (term v_1) (term e_1)))
|
|
||||||
βv)
|
βv)
|
||||||
|
|
||||||
(==> ((store (name the-store any) ...)
|
(==> ((store (name the-store any) ...)
|
||||||
|
|
@ -131,25 +107,24 @@
|
||||||
,(let ((new-x (variable-not-in (term (the-store ...)) (term x_1))))
|
,(let ((new-x (variable-not-in (term (the-store ...)) (term x_1))))
|
||||||
(term
|
(term
|
||||||
((store the-store ... (,new-x v_1))
|
((store the-store ... (,new-x v_1))
|
||||||
(in-hole ec_1
|
(in-hole ec_1 (subst (x_1 ,new-x e_1))))))
|
||||||
,(substitute (term x_1) new-x (term e_1))))))
|
|
||||||
let)
|
let)
|
||||||
|
|
||||||
(==> (in-hole pc_1 (letrec ((x_1 e_1)) e_2))
|
(==> (in-hole pc_1 (letrec ((x_1 e_1)) e_2))
|
||||||
(in-hole pc_1 (let ((x_1 0)) (begin (set! x_1 e_1) e_2)))
|
(in-hole pc_1 (let ((x_1 0)) (begin (set! x_1 e_1) e_2)))
|
||||||
letrec)
|
letrec)
|
||||||
|
|
||||||
where
|
with
|
||||||
[(==> a b) (--> a ,(collect (term b)))]))
|
[(--> a ,(collect (term b))) (==> a b)]))
|
||||||
|
|
||||||
(define (run e) (traces lang reductions `((store) ,e)))
|
(define (run e) (traces lang reductions `((store) ,e)))
|
||||||
|
|
||||||
(run '(letrec ((f (lambda (x)
|
(run '(letrec ((f (lambda (x)
|
||||||
(letrec ((y (f 1)))
|
(letrec ((y (f 1)))
|
||||||
2))))
|
2))))
|
||||||
(f 3)))
|
(f 3)))
|
||||||
|
|
||||||
(run '(letrec ((f (lambda (x)
|
(run '(letrec ((f (lambda (x)
|
||||||
(letrec ((y 1))
|
(letrec ((y 1))
|
||||||
(f 1)))))
|
(f 1)))))
|
||||||
(f 3))))
|
(f 3)))
|
||||||
|
|
|
||||||
|
|
@ -1,11 +1,9 @@
|
||||||
(module omega mzscheme
|
#lang scheme
|
||||||
(require (planet robby/redex:5/reduction-semantics)
|
(require redex "subst.ss")
|
||||||
(planet robby/redex:5/subst)
|
|
||||||
(planet robby/redex:5/gui))
|
|
||||||
|
|
||||||
(reduction-steps-cutoff 10)
|
(reduction-steps-cutoff 10)
|
||||||
|
|
||||||
(define-language lang
|
(define-language lang
|
||||||
(e (e e)
|
(e (e e)
|
||||||
(abort e)
|
(abort e)
|
||||||
x
|
x
|
||||||
|
|
@ -19,7 +17,7 @@
|
||||||
|
|
||||||
(x (variable-except lambda call/cc abort)))
|
(x (variable-except lambda call/cc abort)))
|
||||||
|
|
||||||
(define reductions
|
(define reductions
|
||||||
(reduction-relation
|
(reduction-relation
|
||||||
lang
|
lang
|
||||||
(--> (in-hole c_1 (call/cc v_arg))
|
(--> (in-hole c_1 (call/cc v_arg))
|
||||||
|
|
@ -30,31 +28,9 @@
|
||||||
e_1
|
e_1
|
||||||
abort)
|
abort)
|
||||||
(--> (in-hole c_1 ((lambda (variable_x) e_body) v_arg))
|
(--> (in-hole c_1 ((lambda (variable_x) e_body) v_arg))
|
||||||
(in-hole c_1 ,(lc-subst (term variable_x) (term v_arg) (term e_body)))
|
(in-hole c_1 (subst (variable_x v_arg e_body)))
|
||||||
βv)))
|
βv)))
|
||||||
|
|
||||||
(define lc-subst
|
(traces lang reductions '((lambda (x) (x x)) (lambda (x) (x x))))
|
||||||
(plt-subst
|
(traces lang reductions '((call/cc call/cc) (call/cc call/cc)))
|
||||||
['abort (constant)]
|
(traces lang reductions '((lambda (x) ((call/cc call/cc) x)) (call/cc call/cc)))
|
||||||
['call/cc (constant)]
|
|
||||||
[(? symbol?) (variable)]
|
|
||||||
[(? number?) (constant)]
|
|
||||||
[`(lambda (,x) ,b)
|
|
||||||
(all-vars (list x))
|
|
||||||
(build (lambda (vars body) `(lambda (,(car vars)) ,body)))
|
|
||||||
(subterm (list x) b)]
|
|
||||||
[`(call/cc ,v)
|
|
||||||
(all-vars '())
|
|
||||||
(build (lambda (vars arg) `(call/cc ,arg)))
|
|
||||||
(subterm '() v)]
|
|
||||||
[`(,f ,x)
|
|
||||||
(all-vars '())
|
|
||||||
(build (lambda (vars f x) `(,f ,x)))
|
|
||||||
(subterm '() f)
|
|
||||||
(subterm '() x)]))
|
|
||||||
|
|
||||||
|
|
||||||
(traces lang reductions '((lambda (x) (x x)) (lambda (x) (x x))))
|
|
||||||
(traces lang reductions '((call/cc call/cc) (call/cc call/cc)))
|
|
||||||
(traces lang reductions '((lambda (x) ((call/cc call/cc) x)) (call/cc call/cc)))
|
|
||||||
)
|
|
||||||
|
|
|
||||||
|
|
@ -1,16 +1,15 @@
|
||||||
|
#lang scheme
|
||||||
|
(require redex)
|
||||||
|
|
||||||
#|
|
#|
|
||||||
|
|
||||||
semaphores make things much more predictable...
|
semaphores make things much more predictable...
|
||||||
|
|
||||||
|#
|
|#
|
||||||
|
|
||||||
(module semaphores mzscheme
|
(reduction-steps-cutoff 100)
|
||||||
(require (planet robby/redex:5/reduction-semantics)
|
|
||||||
(planet robby/redex:5/gui))
|
|
||||||
|
|
||||||
(reduction-steps-cutoff 100)
|
(define-language lang
|
||||||
|
|
||||||
(define-language lang
|
|
||||||
(p ((store (variable v) ...)
|
(p ((store (variable v) ...)
|
||||||
(semas (variable sema-count) ...)
|
(semas (variable sema-count) ...)
|
||||||
(threads e ...)))
|
(threads e ...)))
|
||||||
|
|
@ -47,7 +46,7 @@ semaphores make things much more predictable...
|
||||||
number
|
number
|
||||||
(void)))
|
(void)))
|
||||||
|
|
||||||
(define reductions
|
(define reductions
|
||||||
(reduction-relation
|
(reduction-relation
|
||||||
lang
|
lang
|
||||||
(--> (in-hole (name c p-ctxt) (begin v e_1 e_2 e_rest ...))
|
(--> (in-hole (name c p-ctxt) (begin v e_1 e_2 e_rest ...))
|
||||||
|
|
@ -150,14 +149,14 @@ semaphores make things much more predictable...
|
||||||
(in-hole c (void))
|
(in-hole c (void))
|
||||||
e_after ...)))))
|
e_after ...)))))
|
||||||
|
|
||||||
(stepper lang
|
(stepper lang
|
||||||
reductions
|
reductions
|
||||||
`((store (y (list)))
|
`((store (y (list)))
|
||||||
(semas)
|
(semas)
|
||||||
(threads (set! y (cons 1 y))
|
(threads (set! y (cons 1 y))
|
||||||
(set! y (cons 2 y)))))
|
(set! y (cons 2 y)))))
|
||||||
|
|
||||||
(stepper lang
|
(stepper lang
|
||||||
reductions
|
reductions
|
||||||
`((store (y (list)))
|
`((store (y (list)))
|
||||||
(semas (x 1))
|
(semas (x 1))
|
||||||
|
|
@ -166,4 +165,4 @@ semaphores make things much more predictable...
|
||||||
(semaphore-post (semaphore x)))
|
(semaphore-post (semaphore x)))
|
||||||
(begin (semaphore-wait (semaphore x))
|
(begin (semaphore-wait (semaphore x))
|
||||||
(set! y (cons 2 y))
|
(set! y (cons 2 y))
|
||||||
(semaphore-post (semaphore x)))))))
|
(semaphore-post (semaphore x))))))
|
||||||
|
|
@ -1,12 +1,9 @@
|
||||||
(module subject-reduction mzscheme
|
#lang scheme
|
||||||
(require (planet robby/redex:5/reduction-semantics)
|
(require redex)
|
||||||
(planet robby/redex:5/gui)
|
|
||||||
(planet robby/redex:5/subst)
|
|
||||||
(lib "plt-match.ss"))
|
|
||||||
|
|
||||||
(reduction-steps-cutoff 10)
|
(reduction-steps-cutoff 10)
|
||||||
|
|
||||||
(define-language lang
|
(define-language lang
|
||||||
(e (e e)
|
(e (e e)
|
||||||
(abort e)
|
(abort e)
|
||||||
x
|
x
|
||||||
|
|
@ -21,7 +18,7 @@
|
||||||
(t num
|
(t num
|
||||||
(t -> t)))
|
(t -> t)))
|
||||||
|
|
||||||
(define reductions
|
(define reductions
|
||||||
(reduction-relation
|
(reduction-relation
|
||||||
lang
|
lang
|
||||||
(--> (in-hole c_1 (call/cc v_arg))
|
(--> (in-hole c_1 (call/cc v_arg))
|
||||||
|
|
@ -35,28 +32,10 @@
|
||||||
|
|
||||||
;; this rules calls subst with the wrong arguments, which is caught by the example below.
|
;; this rules calls subst with the wrong arguments, which is caught by the example below.
|
||||||
(--> (in-hole c_1 ((lambda (x_format t_1) e_body) v_actual))
|
(--> (in-hole c_1 ((lambda (x_format t_1) e_body) v_actual))
|
||||||
(in-hole c_1 ,(lc-subst (term x_format) (term e_body) (term v_actual)))
|
(in-hole c_1 (subst x_format v_actual e_body))
|
||||||
βv)))
|
βv)))
|
||||||
|
|
||||||
(define lc-subst
|
(define (type-check term)
|
||||||
(plt-subst
|
|
||||||
[(? symbol?) (variable)]
|
|
||||||
[(? number?) (constant)]
|
|
||||||
[`(lambda (,x ,t) ,b)
|
|
||||||
(all-vars (list x))
|
|
||||||
(build (lambda (vars body) `(lambda (,(car vars) ,t) ,body)))
|
|
||||||
(subterm (list x) b)]
|
|
||||||
[`(call/cc ,v)
|
|
||||||
(all-vars '())
|
|
||||||
(build (lambda (vars arg) `(call/cc ,arg)))
|
|
||||||
(subterm '() v)]
|
|
||||||
[`(,f ,x)
|
|
||||||
(all-vars '())
|
|
||||||
(build (lambda (vars f x) `(,f ,x)))
|
|
||||||
(subterm '() f)
|
|
||||||
(subterm '() x)]))
|
|
||||||
|
|
||||||
(define (type-check term)
|
|
||||||
(let/ec k
|
(let/ec k
|
||||||
(let loop ([term term]
|
(let loop ([term term]
|
||||||
[env '()])
|
[env '()])
|
||||||
|
|
@ -80,13 +59,13 @@
|
||||||
(k #f))]
|
(k #f))]
|
||||||
[else (k #f)]))]))))
|
[else (k #f)]))]))))
|
||||||
|
|
||||||
(define (pred term1)
|
(define (pred term1)
|
||||||
(let ([t1 (type-check term1)])
|
(let ([t1 (type-check term1)])
|
||||||
(lambda (term2)
|
(lambda (term2)
|
||||||
(and t1
|
(and t1
|
||||||
(equal? (type-check term2) t1)))))
|
(equal? (type-check term2) t1)))))
|
||||||
|
|
||||||
(define (show term)
|
(define (show term)
|
||||||
(traces/pred lang reductions (list term) (pred term)))
|
(traces reductions term #:pred (pred term)))
|
||||||
|
|
||||||
(show '((lambda (x (num -> num)) 1) ((lambda (x (num -> num)) x) (lambda (x num) x)))))
|
(show '((lambda (x (num -> num)) 1) ((lambda (x (num -> num)) x) (lambda (x num) x))))
|
||||||
74
collects/redex/examples/subst.ss
Normal file
74
collects/redex/examples/subst.ss
Normal file
|
|
@ -0,0 +1,74 @@
|
||||||
|
#lang scheme
|
||||||
|
(require redex)
|
||||||
|
(provide subst subst-n)
|
||||||
|
|
||||||
|
(define-language subst-lang
|
||||||
|
(x variable))
|
||||||
|
|
||||||
|
(define-metafunction subst-n
|
||||||
|
subst-lang
|
||||||
|
[((x_1 any_1) (x_2 any_2) ... any_3)
|
||||||
|
(subst (x_1 any_1 (subst-n ((x_2 any_2) ... any_3))))]
|
||||||
|
[(any_3) any_3])
|
||||||
|
|
||||||
|
(define-metafunction subst
|
||||||
|
subst-lang
|
||||||
|
;; 1. x_1 bound, so don't continue in λ body
|
||||||
|
[(x_1 any_1 (λ (x_2 ... x_1 x_3 ...) any_2))
|
||||||
|
(λ (x_2 ... x_1 x_3 ...) any_2)
|
||||||
|
(side-condition (not (member (term x_1) (term (x_2 ...)))))]
|
||||||
|
;; 2. general purpose capture avoiding case
|
||||||
|
[(x_1 any_1 (λ (x_2 ...) any_2))
|
||||||
|
,(term-let ([(x_new ...)
|
||||||
|
(variables-not-in (term (x_1 any_1 any_2))
|
||||||
|
(term (x_2 ...)))])
|
||||||
|
(term
|
||||||
|
(λ (x_new ...)
|
||||||
|
(subst (x_1 any_1 (subst-vars ((x_2 x_new) ... any_2)))))))]
|
||||||
|
;; 3. replace x_1 with e_1
|
||||||
|
[(x_1 any_1 x_1) any_1]
|
||||||
|
;; 4. x_1 and x_2 are different, so don't replace
|
||||||
|
[(x_1 any_1 x_2) x_2]
|
||||||
|
;; the last two cases cover all other expression forms
|
||||||
|
[(x_1 any_1 (any_2 ...))
|
||||||
|
((subst (x_1 any_1 any_2)) ...)]
|
||||||
|
[(x_1 any_1 any_2) any_2])
|
||||||
|
|
||||||
|
(define-metafunction subst-vars
|
||||||
|
subst-lang
|
||||||
|
[((x_1 any_1) x_1) any_1]
|
||||||
|
[((x_1 any_1) (any_2 ...)) ((subst-vars ((x_1 any_1) any_2)) ...)]
|
||||||
|
[((x_1 any_1) any_2) any_2]
|
||||||
|
[((x_1 any_1) (x_2 any_2) ... any_3)
|
||||||
|
(subst-vars ((x_1 any_1) (subst-vars ((x_2 any_2) ... any_3))))]
|
||||||
|
[(any) any])
|
||||||
|
|
||||||
|
(begin
|
||||||
|
(test-equal (term (subst (x y x))) (term y))
|
||||||
|
(test-equal (term (subst (x y z))) (term z))
|
||||||
|
(test-equal (term (subst (x y (x (y z))))) (term (y (y z))))
|
||||||
|
(test-equal (term (subst (x y ((λ (x) x) ((λ (y1) y1) (λ (x) z))))))
|
||||||
|
(term ((λ (x) x) ((λ (y2) y2) (λ (x) z)))))
|
||||||
|
(test-equal (term (subst (x y (if0 (+ 1 x) x x))))
|
||||||
|
(term (if0 (+ 1 y) y y)))
|
||||||
|
(test-equal (term (subst (x (λ (z) y) (λ (y) x))))
|
||||||
|
(term (λ (y1) (λ (z) y))))
|
||||||
|
(test-equal (term (subst (x 1 (λ (y) x))))
|
||||||
|
(term (λ (y) 1)))
|
||||||
|
(test-equal (term (subst (x y (λ (y) x))))
|
||||||
|
(term (λ (y1) y)))
|
||||||
|
(test-equal (term (subst (x (λ (y) y) (λ (z) (z2 z)))))
|
||||||
|
(term (λ (z1) (z2 z1))))
|
||||||
|
(test-equal (term (subst (x (λ (z) z) (λ (z) (z1 z)))))
|
||||||
|
(term (λ (z2) (z1 z2))))
|
||||||
|
(test-equal (term (subst (x z (λ (z) (z1 z)))))
|
||||||
|
(term (λ (z2) (z1 z2))))
|
||||||
|
(test-equal (term (subst (x3 5 (λ (x2) x2))))
|
||||||
|
(term (λ (x1) x1)))
|
||||||
|
(test-equal (term (subst (z * (λ (z x) 1))))
|
||||||
|
(term (λ (z x) 1)))
|
||||||
|
(test-equal (term (subst (q (λ (x) z) (λ (z x) q))))
|
||||||
|
(term (λ (z1 x1) (λ (x) z))))
|
||||||
|
(test-equal (term (subst (x 1 (λ (x x) x))))
|
||||||
|
(term (λ (x x) x)))
|
||||||
|
(test-results))
|
||||||
|
|
@ -1,12 +1,9 @@
|
||||||
(module threads mzscheme
|
#lang scheme
|
||||||
(require (planet robby/redex:5/reduction-semantics)
|
(require redex)
|
||||||
(planet robby/redex:5/subst)
|
|
||||||
(planet robby/redex:5/gui)
|
|
||||||
(lib "plt-match.ss"))
|
|
||||||
|
|
||||||
(reduction-steps-cutoff 100)
|
(reduction-steps-cutoff 100)
|
||||||
|
|
||||||
(define-language threads
|
(define-language threads
|
||||||
(p ((store (x v) ...) (threads e ...)))
|
(p ((store (x v) ...) (threads e ...)))
|
||||||
(e (set! x e)
|
(e (set! x e)
|
||||||
(let ((x e)) e)
|
(let ((x e)) e)
|
||||||
|
|
@ -21,7 +18,7 @@
|
||||||
(tc (threads e ... ec e ...))
|
(tc (threads e ... ec e ...))
|
||||||
(ec (ec e) (v ec) (set! variable ec) (let ((x ec)) e) (+ ec e) (+ v ec) hole))
|
(ec (ec e) (v ec) (set! variable ec) (let ((x ec)) e) (+ ec e) (+ v ec) hole))
|
||||||
|
|
||||||
(define reductions
|
(define reductions
|
||||||
(reduction-relation
|
(reduction-relation
|
||||||
threads
|
threads
|
||||||
(--> (in-hole pc_1 (+ number_1 number_2))
|
(--> (in-hole pc_1 (+ number_1 number_2))
|
||||||
|
|
@ -58,47 +55,20 @@
|
||||||
(in-hole tc_1 ,(substitute (term x_1) (term new-x) (term e_1))))))
|
(in-hole tc_1 ,(substitute (term x_1) (term new-x) (term e_1))))))
|
||||||
let)))
|
let)))
|
||||||
|
|
||||||
(define substitute
|
(define (substitute . x) (error 'substitute "~s" x))
|
||||||
(plt-subst
|
|
||||||
[(? symbol?) (variable)]
|
|
||||||
[(? number?) (constant)]
|
|
||||||
[`(lambda (,x) ,b)
|
|
||||||
(all-vars (list x))
|
|
||||||
(build (lambda (vars body) `(lambda (,(car vars)) ,body)))
|
|
||||||
(subterm (list x) b)]
|
|
||||||
[`(set! ,x ,e)
|
|
||||||
(all-vars '())
|
|
||||||
(build (lambda (vars name body) `(set! ,name ,body)))
|
|
||||||
(subterm '() x)
|
|
||||||
(subterm '() e)]
|
|
||||||
[`(let ((,x ,e1)) ,e2)
|
|
||||||
(all-vars (list x))
|
|
||||||
(build (lambda (vars letval body) `(let ((,(car vars) ,letval)) ,body)))
|
|
||||||
(subterm '() e1)
|
|
||||||
(subterm (list x) e2)]
|
|
||||||
[`(+ ,e1 ,e2)
|
|
||||||
(all-vars '())
|
|
||||||
(build (lambda (vars e1 e2) `(+ ,e1 ,e2)))
|
|
||||||
(subterm '() e1)
|
|
||||||
(subterm '() e2)]
|
|
||||||
[`(,f ,x)
|
|
||||||
(all-vars '())
|
|
||||||
(build (lambda (vars f x) `(,f ,x)))
|
|
||||||
(subterm '() f)
|
|
||||||
(subterm '() x)]))
|
|
||||||
|
|
||||||
(define (run es) (traces threads reductions `((store) (threads ,@es))))
|
(define (run es) (traces threads reductions `((store) (threads ,@es))))
|
||||||
(provide run)
|
(provide run)
|
||||||
|
|
||||||
(define (count x)
|
(define (count x)
|
||||||
(match x
|
(match x
|
||||||
[`(set! ,x ,e) (+ 1 (count e))]
|
[`(set! ,x ,e) (+ 1 (count e))]
|
||||||
[(? symbol?) 1]
|
[(? symbol?) 1]
|
||||||
[(? number?) 0]
|
[(? number?) 0]
|
||||||
[`(+ ,e1 ,e2) (+ 1 (count e1) (count e2))]))
|
[`(+ ,e1 ,e2) (+ 1 (count e1) (count e2))]))
|
||||||
|
|
||||||
;; use a pretty-printer that just summaizes the terms, showing the depth of each thread.
|
;; use a pretty-printer that just summaizes the terms, showing the depth of each thread.
|
||||||
(traces threads reductions
|
(traces reductions
|
||||||
'((store (x 1))
|
'((store (x 1))
|
||||||
(threads
|
(threads
|
||||||
(set! x (+ x -1))
|
(set! x (+ x -1))
|
||||||
|
|
@ -109,9 +79,8 @@
|
||||||
[`((store (x ,x)) (threads ,t1 ,t2))
|
[`((store (x ,x)) (threads ,t1 ,t2))
|
||||||
(format "~a ~a ~a" x (count t1) (count t2))])))
|
(format "~a ~a ~a" x (count t1) (count t2))])))
|
||||||
|
|
||||||
(parameterize ([initial-char-width 16])
|
(parameterize ([initial-char-width 16])
|
||||||
(stepper threads reductions '((store) (threads
|
(stepper threads reductions '((store) (threads
|
||||||
(+ 1 1)
|
(+ 1 1)
|
||||||
(+ 1 1)
|
(+ 1 1)
|
||||||
(+ 1 1)))))
|
(+ 1 1)))))
|
||||||
)
|
|
||||||
|
|
|
||||||
|
|
@ -1,11 +1,10 @@
|
||||||
(module types mzscheme
|
#lang scheme
|
||||||
(require (planet robby/redex:5/reduction-semantics)
|
(require redex
|
||||||
(planet robby/redex:5/subst)
|
"subst.ss")
|
||||||
(planet robby/redex:5/gui))
|
|
||||||
|
|
||||||
(reduction-steps-cutoff 10)
|
(reduction-steps-cutoff 10)
|
||||||
|
|
||||||
(define-language lang
|
(define-language lang
|
||||||
(e (e e)
|
(e (e e)
|
||||||
x
|
x
|
||||||
number
|
number
|
||||||
|
|
@ -28,15 +27,13 @@
|
||||||
(x (variable-except lambda -> if =))
|
(x (variable-except lambda -> if =))
|
||||||
(t num bool (-> t t)))
|
(t num bool (-> t t)))
|
||||||
|
|
||||||
(define reductions
|
(define reductions
|
||||||
(reduction-relation
|
(reduction-relation
|
||||||
lang
|
lang
|
||||||
(r--> number num)
|
(r--> number num)
|
||||||
|
|
||||||
(r--> (lambda (x_1 t_1) e_body)
|
(r--> (lambda (x_1 t_1) e_body)
|
||||||
(-> t_1 ,(lc-subst (term x_1)
|
(-> t_1 (subst (x_1 t_1 e_body))))
|
||||||
(term t_1)
|
|
||||||
(term e_body))))
|
|
||||||
|
|
||||||
(r--> ((-> t_1 t_2) t_1) t_2)
|
(r--> ((-> t_1 t_2) t_1) t_2)
|
||||||
|
|
||||||
|
|
@ -61,27 +58,12 @@
|
||||||
(not (equal? (term t_2) 'num))))
|
(not (equal? (term t_2) 'num))))
|
||||||
,(format "=: not comparing numbers ~s and ~s" (term t_1) (term t_2)))
|
,(format "=: not comparing numbers ~s and ~s" (term t_1) (term t_2)))
|
||||||
|
|
||||||
where
|
with
|
||||||
|
|
||||||
[(r--> a b) (--> (in-hole c_1 a) (in-hole c_1 b))]
|
[(--> (in-hole c_1 a) (in-hole c_1 b)) (r--> a b)]
|
||||||
[(e--> a b) (--> (in-hole c a) b)]))
|
[(--> (in-hole c a) b) (e--> a b)]))
|
||||||
|
|
||||||
(define lc-subst
|
(traces reductions
|
||||||
(subst
|
|
||||||
[(? symbol?) (variable)]
|
|
||||||
[(? number?) (constant)]
|
|
||||||
[`(lambda (,x ,t) ,b)
|
|
||||||
(all-vars (list x))
|
|
||||||
(build (lambda (vars body) `(lambda (,(car vars) ,t) ,body)))
|
|
||||||
(subterm (list x) b)]
|
|
||||||
[`(,f ,@(xs ...))
|
|
||||||
(all-vars '())
|
|
||||||
(build (lambda (vars f . xs) `(,f ,@xs)))
|
|
||||||
(subterm '() f)
|
|
||||||
(subterms '() xs)]))
|
|
||||||
|
|
||||||
(traces lang reductions
|
|
||||||
'((lambda (x num) (lambda (y num) (if (= x y) 0 x))) 1))
|
'((lambda (x num) (lambda (y num) (if (= x y) 0 x))) 1))
|
||||||
(traces lang reductions
|
(traces reductions
|
||||||
'((lambda (x num) (lambda (y num) (if (= x y) 0 (lambda (x num) x)))) 1))
|
'((lambda (x num) (lambda (y num) (if (= x y) 0 (lambda (x num) x)))) 1))
|
||||||
)
|
|
||||||
|
|
|
||||||
|
|
@ -8,15 +8,14 @@ In the other window, you expect to see the currently unreducted terms in green a
|
||||||
|
|
||||||
|#
|
|#
|
||||||
|
|
||||||
(module color-test mzscheme
|
#lang scheme/gui
|
||||||
(require "../reduction-semantics.ss"
|
|
||||||
"../gui.ss"
|
|
||||||
(lib "mred.ss" "mred")
|
|
||||||
(lib "class.ss"))
|
|
||||||
|
|
||||||
(reduction-steps-cutoff 1)
|
(require "../reduction-semantics.ss"
|
||||||
|
"../gui.ss")
|
||||||
|
|
||||||
(let ()
|
(reduction-steps-cutoff 1)
|
||||||
|
|
||||||
|
(let ()
|
||||||
|
|
||||||
(define (get-range term-node)
|
(define (get-range term-node)
|
||||||
(let loop ([node term-node])
|
(let loop ([node term-node])
|
||||||
|
|
@ -40,16 +39,16 @@ In the other window, you expect to see the currently unreducted terms in green a
|
||||||
|
|
||||||
(define-language empty-language)
|
(define-language empty-language)
|
||||||
|
|
||||||
(traces/pred empty-language
|
(traces
|
||||||
(reduction-relation
|
(reduction-relation
|
||||||
empty-language
|
empty-language
|
||||||
(--> (number_1 word)
|
(--> (number_1 word)
|
||||||
(,(+ (term number_1) 1) word)
|
(,(+ (term number_1) 1) word)
|
||||||
inc))
|
inc))
|
||||||
(list '(1 word))
|
'(1 word)
|
||||||
color-range-pred))
|
#:pred color-range-pred))
|
||||||
|
|
||||||
(let ()
|
(let ()
|
||||||
(define-language empty-language)
|
(define-language empty-language)
|
||||||
|
|
||||||
(define (last-color-pred sexp term-node)
|
(define (last-color-pred sexp term-node)
|
||||||
|
|
@ -58,8 +57,7 @@ In the other window, you expect to see the currently unreducted terms in green a
|
||||||
"green"
|
"green"
|
||||||
"white")))
|
"white")))
|
||||||
|
|
||||||
(traces/pred empty-language
|
(traces (reduction-relation
|
||||||
(reduction-relation
|
|
||||||
empty-language
|
empty-language
|
||||||
(--> (number_1 word)
|
(--> (number_1 word)
|
||||||
(,(+ (term number_1) 1) word)
|
(,(+ (term number_1) 1) word)
|
||||||
|
|
@ -67,5 +65,5 @@ In the other window, you expect to see the currently unreducted terms in green a
|
||||||
(--> (number_1 word)
|
(--> (number_1 word)
|
||||||
(,(* (term number_1) 2) word)
|
(,(* (term number_1) 2) word)
|
||||||
dup))
|
dup))
|
||||||
(list '(1 word))
|
'(1 word)
|
||||||
last-color-pred)))
|
#:pred last-color-pred))
|
||||||
|
|
@ -1,60 +0,0 @@
|
||||||
(module schemeunit-test mzscheme
|
|
||||||
(require "../schemeunit.ss"
|
|
||||||
(all-except "../reduction-semantics.ss" check)
|
|
||||||
(planet "text-ui.ss" ("schematics" "schemeunit.plt" 2))
|
|
||||||
(planet "test.ss" ("schematics" "schemeunit.plt" 2)))
|
|
||||||
|
|
||||||
(define-language lang
|
|
||||||
(e number (+ e e) (choose e e))
|
|
||||||
(ec hole (+ e ec) (+ ec e))
|
|
||||||
(v number true false))
|
|
||||||
|
|
||||||
(define reductions
|
|
||||||
(reduction-relation
|
|
||||||
lang
|
|
||||||
(--> (in-hole ec_1 (+ number_1 number_2))
|
|
||||||
(in-hole ec_1 ,(+ (term number_1) (term number_2))))
|
|
||||||
(--> (in-hole ec_1 (choose e_1 e_2))
|
|
||||||
(in-hole ec_1 e_1))
|
|
||||||
(--> (in-hole ec_1 (choose e_1 e_2))
|
|
||||||
(in-hole ec_1 e_2))))
|
|
||||||
|
|
||||||
(define tests-passed 0)
|
|
||||||
|
|
||||||
(define (try-it check in out key/vals)
|
|
||||||
(let ([sp (open-output-string)])
|
|
||||||
(parameterize ([current-output-port sp])
|
|
||||||
(test/text-ui (test-case "X" (check reductions in out))))
|
|
||||||
(let ([s (get-output-string sp)])
|
|
||||||
(for-each
|
|
||||||
(λ (key/val)
|
|
||||||
(let* ([key (car key/val)]
|
|
||||||
[val (cadr key/val)]
|
|
||||||
[m (regexp-match (format "\n~a: ([^\n]*)\n" key) s)])
|
|
||||||
(unless m
|
|
||||||
(error 'try-it "didn't find key ~s in ~s" key s))
|
|
||||||
(unless (if (regexp? val)
|
|
||||||
(regexp-match val (cadr m))
|
|
||||||
(equal? val (cadr m)))
|
|
||||||
(error 'try-in "didn't match key ~s, expected ~s got ~s" key val (cadr m)))))
|
|
||||||
key/vals)))
|
|
||||||
(set! tests-passed (+ tests-passed 1)))
|
|
||||||
|
|
||||||
(try-it check-reduces
|
|
||||||
'(choose 1 2)
|
|
||||||
1
|
|
||||||
'((multiple-results "(2 1)")))
|
|
||||||
|
|
||||||
(try-it check-reduces
|
|
||||||
'(+ 1 2)
|
|
||||||
1
|
|
||||||
'((expected "1")
|
|
||||||
(actual "3")))
|
|
||||||
|
|
||||||
(try-it check-reduces/multiple
|
|
||||||
'(+ (choose 3 4) 1)
|
|
||||||
'(4 6)
|
|
||||||
'((expecteds "(4 6)")
|
|
||||||
(actuals #rx"[(][45] [54][)]")))
|
|
||||||
|
|
||||||
(printf "schemeunit-tests: all ~a tests passed.\n" tests-passed))
|
|
||||||
|
|
@ -1,125 +0,0 @@
|
||||||
(module subst-test mzscheme
|
|
||||||
(require "../subst.ss"
|
|
||||||
(lib "match.ss"))
|
|
||||||
|
|
||||||
(define (lc-subst1 var val exp) (subst/proc var val exp lc-separate))
|
|
||||||
(define (lc-free-vars exp) (free-vars/memoize (make-hash-table) exp lc-separate))
|
|
||||||
(define (lc-rename old-name new-name exp) (alpha-rename old-name new-name exp lc-separate))
|
|
||||||
|
|
||||||
(define lc-subst2
|
|
||||||
(subst
|
|
||||||
[`(lambda ,vars ,body)
|
|
||||||
(all-vars vars)
|
|
||||||
(build (lambda (vars body) `(lambda ,vars ,body)))
|
|
||||||
(subterm vars body)]
|
|
||||||
[`(let (,l-var ,exp) ,body)
|
|
||||||
(all-vars (list l-var))
|
|
||||||
(build (lambda (l-vars exp body) `(let (,@l-vars ,exp) ,body)))
|
|
||||||
(subterm '() exp)
|
|
||||||
(subterm (list l-var) body)]
|
|
||||||
[(? symbol?) (variable)]
|
|
||||||
[(? number?) (constant)]
|
|
||||||
[`(,fun ,@(args ...))
|
|
||||||
(all-vars '())
|
|
||||||
(build (lambda (vars fun . args) `(,fun ,@args)))
|
|
||||||
(subterm '() fun)
|
|
||||||
(subterms '() args)]))
|
|
||||||
|
|
||||||
(define (lc-separate exp constant variable combine sub-piece)
|
|
||||||
(match exp
|
|
||||||
[`(lambda ,vars ,body)
|
|
||||||
(combine (lambda (vars body) `(lambda ,vars ,body))
|
|
||||||
vars
|
|
||||||
(sub-piece vars body))]
|
|
||||||
[`(let (,l-var ,exp) ,body)
|
|
||||||
(combine (lambda (l-vars exp body) `(let (,(car l-vars) ,exp) ,body))
|
|
||||||
(list l-var)
|
|
||||||
(sub-piece '() exp)
|
|
||||||
(sub-piece (list l-var) body))]
|
|
||||||
[(? symbol?) (variable (lambda (x) x) exp)]
|
|
||||||
[(? number?) (constant exp)]
|
|
||||||
[`(,fun ,@(args ...))
|
|
||||||
(apply
|
|
||||||
combine
|
|
||||||
(lambda (variables fun . args) `(,fun ,@args))
|
|
||||||
'()
|
|
||||||
(append
|
|
||||||
(list (sub-piece '() fun))
|
|
||||||
(map (lambda (x) (sub-piece '() x)) args)))]))
|
|
||||||
|
|
||||||
(define test-cases 0)
|
|
||||||
(define failed-tests? #f)
|
|
||||||
|
|
||||||
(define-syntax (test stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(_ test-exp expected)
|
|
||||||
(syntax (test test-exp expected equal?))]
|
|
||||||
[(_ test-exp expected same?)
|
|
||||||
(syntax
|
|
||||||
(let ([actual test-exp]
|
|
||||||
[expected-v expected])
|
|
||||||
;(printf "testing: ~s\n" (syntax-object->datum #'test-exp))
|
|
||||||
(set! test-cases (+ test-cases 1))
|
|
||||||
(unless (same? actual expected-v)
|
|
||||||
(set! failed-tests? #t)
|
|
||||||
(printf " test: ~s\n expected: ~s\n got: ~s\n"
|
|
||||||
(syntax-object->datum #'test-exp)
|
|
||||||
expected-v
|
|
||||||
actual))))]))
|
|
||||||
|
|
||||||
(define (set-equal? xs ys)
|
|
||||||
(and (andmap (lambda (x) (memq x ys)) xs)
|
|
||||||
(andmap (lambda (y) (memq y xs)) ys)))
|
|
||||||
|
|
||||||
(define (lc-tests)
|
|
||||||
(tests lc-free-vars lc-subst1 lc-rename)
|
|
||||||
(tests #f lc-subst2 #f))
|
|
||||||
|
|
||||||
(define (tests free-vars subst rename)
|
|
||||||
(when free-vars
|
|
||||||
(test (free-vars 'x) '(x) set-equal?)
|
|
||||||
(test (free-vars '(lambda (x) x)) '() set-equal?)
|
|
||||||
(test (free-vars '(lambda (x) y)) '(y) set-equal?)
|
|
||||||
(test (free-vars '(let (x 1) x)) '() set-equal?)
|
|
||||||
(test (free-vars '(let (x 1) y)) '(y) set-equal?)
|
|
||||||
(test (free-vars '(let (x x) y)) '(y x) set-equal?)
|
|
||||||
(test (free-vars '(let (x 1) (y y))) '(y) set-equal?)
|
|
||||||
(test (free-vars '(lambda (y) (y y))) '() set-equal?))
|
|
||||||
|
|
||||||
(when rename
|
|
||||||
(test (rename 'x 'y 'x) 'x)
|
|
||||||
(test (rename 'x 'y '(lambda (x) x)) '(lambda (y) y)))
|
|
||||||
|
|
||||||
(test (subst 'x 1 'x) 1)
|
|
||||||
(test (subst 'x 1 'y) 'y)
|
|
||||||
(test (subst 'x 1 '(lambda (x) x)) '(lambda (x) x))
|
|
||||||
(test (subst 'x 1 '(lambda (y) x)) '(lambda (y) 1))
|
|
||||||
(test (subst 'x 'y '(lambda (y) x)) '(lambda (y@) y))
|
|
||||||
(test (subst 'x 'y '(lambda (y) (x y))) '(lambda (y@) (y y@)))
|
|
||||||
(test (subst 'x 'y '(let (x 1) 1)) '(let (x 1) 1))
|
|
||||||
(test (subst 'x 'y '(let (x 1) x)) '(let (x 1) x))
|
|
||||||
(test (subst 'x 'y '(let (x 1) y)) '(let (x 1) y))
|
|
||||||
(test (subst 'x 'y '(let (y 1) (x y))) '(let (y@ 1) (y y@)))
|
|
||||||
(test (subst 'q '(lambda (x) y) '(lambda (y) y)) '(lambda (y) y))
|
|
||||||
(test (subst 'q '(lambda (x) y) '(let ([y q]) y)) '(let ([y (lambda (x) y)]) y))
|
|
||||||
(test (subst 'p '1 '(let (t 2) ((p t) t)))
|
|
||||||
'(let (t 2) ((1 t) t)))
|
|
||||||
(test (subst 'p '(lambda (s) s)
|
|
||||||
'(let (t (lambda (s) s)) ((p t) t)))
|
|
||||||
'(let (t (lambda (s) s)) (((lambda (s) s) t) t)))
|
|
||||||
(test (subst 'p
|
|
||||||
'(lambda (s) (s s))
|
|
||||||
'(let (t (lambda (s) s))
|
|
||||||
p))
|
|
||||||
'(let (t (lambda (s) s))
|
|
||||||
(lambda (s) (s s))))
|
|
||||||
|
|
||||||
(test (subst 's
|
|
||||||
'(lambda (z) (s z))
|
|
||||||
'(lambda (s) (lambda (z) (s z))))
|
|
||||||
'(lambda (s) (lambda (z) (s z))))
|
|
||||||
|
|
||||||
(test (subst 's
|
|
||||||
'(lambda (s) (lambda (z) (s z)))
|
|
||||||
'(lambda (z) (s z)))
|
|
||||||
'(lambda (z) ((lambda (s) (lambda (z) (s z))) z)))))
|
|
||||||
Loading…
Reference in New Issue
Block a user