diff --git a/nbe-test.rkt b/nbe-test.rkt new file mode 100644 index 0000000..49ff739 --- /dev/null +++ b/nbe-test.rkt @@ -0,0 +1,11 @@ +#lang racket + +(require rackunit "nbe.rkt") +(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)))))) + +(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) diff --git a/nbe.rkt b/nbe.rkt index 01b6442..7a8da91 100644 --- a/nbe.rkt +++ b/nbe.rkt @@ -1,39 +1,54 @@ #lang racket -(require racket/treelist) - ;; Grammar (Λ) ;; t := λ t | app t t | i ;; Domain -;; D ≃ Λ + [D → D] +;; D ≃ neu D_ne | fun [D → D] ;; D_ne = var i | app D_ne D ;; Define as we go + (define (ap a b) (match a - [`(fun ,f) (f b)])) + [`(fun ,f) (f identity b)] + [`(neu ,u) `(neu (app ,u ,b))])) + +(define compose-ren compose) +(define (compose-ren-sub ξ ρ) (compose (curry ren-dom ξ) ρ)) +(define (ext ρ a) + (lambda (i) + (if (zero? i) + a + (ρ (- i 1))))) (define (ren-ne-dom ξ a) (match a - [`(var ,i) `(var ,(treelist-ref ξ i))] + [`(var ,i) `(var ,(ξ i))] [`(app ,a ,b) `(app ,(ren-ne-dom ξ a) ,(ren-dom ξ b))])) (define (ren-dom ξ a) (match a - [`(neu ,a) `(neu ,(ren-ne-dom a))] - [`(fun ,f) `(fun ,(λ (ξ0 α) (f (compose ξ0 ξ) α)))])) + [`(neu ,a) `(neu ,(ren-ne-dom ξ a))] + [`(fun ,f) `(fun ,(λ (ξ0 α) (f (compose-ren ξ0 ξ) α)))])) (define (interp a ρ) (match a - [`(var ,i) (treelist-ref ρ i)] - [`(λ ,a) (list 'fun (λ (ξ x) (interp a (treelist-cons (compose ren-dom ρ) x))))] + [`(var ,i) (ρ i)] + [`(λ ,a) (list 'fun (λ (ξ x) (interp a (ext (compose-ren-sub ξ ρ) x))))] [`(app ,a ,b) (ap (interp a ρ) (interp b ρ))])) - - -(define (reflect a) - (list 'neu a)) - - (define (reify a) (match a - [`(fun ,f) (reify (f (reflect '(var 0))))])) + [`(fun ,f) (list 'λ (reify (f (curry + 1) '(neu (var 0)))))] + [`(neu ,a) (reify-neu a)])) + +(define (reify-neu a) + (match a + [`(app ,u ,v) (list 'app (reify-neu u) (reify a))] + [`(var ,i) a])) + +(define (idsub i) `(neu (var ,i))) + +(define (normalize a) + (reify (interp a idsub))) + +(provide normalize)