diff --git a/nbe-test.rkt b/nbe-test.rkt index 49ff739..51eb93c 100644 --- a/nbe-test.rkt +++ b/nbe-test.rkt @@ -1,11 +1,43 @@ #lang racket (require rackunit "nbe.rkt") + +(define-syntax tm-app + (syntax-rules () + [(tm-app a) a] + [(tm-app a b c ...) + (tm-app `(app ,a ,b) c ...)])) + +(define-syntax-rule (tm-var a) `(var ,a)) +(define-syntax-rule (tm-abs a) `(λ ,a)) + (define tm-id '(λ (var 0))) + (define tm-fst '(λ (λ (var 1)))) + (define tm-snd '(λ (λ (var 0)))) -(define tm-pair '(λ (λ (λ (app (app (var 0) (var 2)) (var 1)))))) + +(define tm-pair `(λ (λ (λ ,(tm-app '(var 0) '(var 2) '(var 1)))))) + +(define tm-y + (let ([g (tm-abs (tm-app (tm-var 1) (tm-app (tm-var 0) (tm-var 0))))]) + (tm-abs (tm-app g g)))) + +(define tm-zero tm-snd) + +(define (tm-suc a) (tm-abs (tm-abs (tm-app (tm-var 1) (tm-app a (tm-var 1) (tm-var 0)))))) + +(define (tm-add a b) + (tm-abs (tm-abs + (tm-app b (tm-var 1) (tm-app a (tm-var 1) (tm-var 0)))))) + +(define (tm-nat n) + (if (positive? n) + (tm-suc (tm-nat (- n 1))) + tm-zero)) (check-equal? (normalize `(app ,tm-id ,tm-id)) tm-id) (check-equal? (normalize `(app (app (app ,tm-pair ,tm-id) ,tm-fst) ,tm-snd)) tm-fst) (check-equal? (normalize `(app (app (app ,tm-pair ,tm-id) ,tm-fst) ,tm-fst)) tm-id) +(check-equal? (normalize (tm-app tm-snd (tm-app tm-pair tm-id tm-fst) tm-fst)) tm-fst) +(check-equal? (normalize (tm-add (tm-nat 100) (tm-nat 40))) (normalize (tm-add (tm-nat 40) (tm-nat 100)))) diff --git a/nbe.rkt b/nbe.rkt index 7a8da91..841cef8 100644 --- a/nbe.rkt +++ b/nbe.rkt @@ -43,7 +43,7 @@ (define (reify-neu a) (match a - [`(app ,u ,v) (list 'app (reify-neu u) (reify a))] + [`(app ,u ,v) (list 'app (reify-neu u) (reify v))] [`(var ,i) a])) (define (idsub i) `(neu (var ,i))) @@ -51,4 +51,11 @@ (define (normalize a) (reify (interp a idsub))) -(provide normalize) +(define (tm? a) + (match a + [`(λ ,a) (tm? a)] + [`(app ,a ,b) (and (tm? a) (tm? b))] + [`(var ,i) (exact-nonnegative-integer? i)] + [_ false])) + +(provide reify interp normalize tm?)