diff --git a/README.md b/README.md index a7ceb45..14c0e91 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# untyped NbE in racket +# Kripke-style untyped NbE in racket [![status-badge](https://woodpecker.electriclam.com/api/badges/4/status.svg)](https://woodpecker.electriclam.com/repos/4) An implementation of normalization by evaluation loosely based on [A @@ -10,3 +10,6 @@ Since the implementation is untyped, the `normalize` function only gives you β-normal forms. However, you can get a little bit of βη-equivalence by invoking Coquand's algorithm (`η-eq?`) on β-normal forms. + +A more efficient version of NbE based on de Bruijn levels (inverted de +bruijn indices) can be found in the `debruijn-levels` branch. diff --git a/nbe-test.rkt b/nbe-test.rkt index b7b4b81..0e3df78 100644 --- a/nbe-test.rkt +++ b/nbe-test.rkt @@ -1,6 +1,6 @@ -#lang typed/racket +#lang racket -(require typed/rackunit "nbe.rkt") +(require rackunit "nbe.rkt") (define-syntax tm-app (syntax-rules () @@ -11,85 +11,64 @@ (define-syntax-rule (tm-var a) `(var ,a)) (define-syntax-rule (tm-abs a) `(λ ,a)) -(: tm-id Term) (define tm-id '(λ (var 0))) -(: tm-fst Term) (define tm-fst '(λ (λ (var 1)))) -(: tm-snd Term) (define tm-snd '(λ (λ (var 0)))) -(: tm-pair Term) (define tm-pair `(λ (λ (λ ,(tm-app '(var 0) '(var 2) '(var 1)))))) -(: tm-fix Term) (define tm-fix (let ([g (tm-abs (tm-app (tm-var 1) (tm-app (tm-var 0) (tm-var 0))))]) (tm-abs (tm-app g g)))) -(: tm-zero Term) (define tm-zero tm-snd) -(: tm-suc (-> Term Term)) (define (tm-suc a) (tm-abs (tm-abs (tm-app (tm-var 1) (tm-app a (tm-var 1) (tm-var 0)))))) -(: tm-add (-> Term Term Term)) (define (tm-add a b) (tm-abs (tm-abs (tm-app b (tm-var 1) (tm-app a (tm-var 1) (tm-var 0)))))) -(: tm-ind (-> Term Term Term Term)) -(define (tm-ind a b c) - `(ind ,a ,b ,c)) - -(: tm-padd (-> Term Term Term)) -(define (tm-padd a b) - (tm-app (tm-ind a tm-id (tm-abs (tm-psuc (tm-app (tm-var 1) (tm-var 0))))) b)) - -(: tm-compose (-> Term Term Term)) (define (tm-compose a b) (tm-abs (tm-app a (tm-app b (tm-var 0))))) -(: tm-mult (-> Term Term Term)) (define (tm-mult a b) (tm-compose a b)) -(: tm-nat (-> V Term)) (define (tm-nat n) (if (positive? n) (tm-suc (tm-nat (- n 1))) tm-zero)) -(: tm-const Term) -(define tm-const tm-fst) - -(: tm-loop Term) -(define tm-loop - (let ([g (tm-abs (tm-app (tm-var 0) (tm-var 0)))]) - (tm-app g g))) - -(: tm-nat-to-pnat Term) -(define tm-nat-to-pnat - (tm-abs (tm-app (tm-var 0) (tm-abs '(succ (var 0))) 'zero))) - -(: tm-pnat (-> V Term)) (define (tm-pnat n) (if (positive? n) `(succ ,(tm-pnat (- n 1))) 'zero)) -(: tm-psuc (-> Term Term)) +(define (tm-ifz a b c) + `(if-zero ,a ,b ,c)) + (define (tm-psuc a) `(succ ,a)) +(define (tm-double m) + (tm-app tm-fix + (tm-abs (tm-abs (tm-ifz (tm-var 0) 'zero 'zero))) m )) + +(define (tm-padd m n) + (tm-app tm-fix + (tm-abs (tm-abs (tm-abs (tm-ifz (tm-var 1) (tm-var 0) (tm-psuc (tm-app (tm-var 3) (tm-var 0) (tm-var 1))))))) m n)) + (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 499) (tm-nat 777))) (normalize (tm-add (tm-nat 777) (tm-nat 499)))) -(check-equal? (normalize (tm-app tm-const (tm-nat 0) tm-loop)) (normalize (tm-nat 0))) -(check-equal? (normalize (tm-app tm-nat-to-pnat (tm-nat 10))) (tm-pnat 10)) -(check-equal? (normalize `(ind ,(tm-pnat 3) ,(tm-pnat 0) (var 1))) (tm-pnat 2)) -(check-equal? (normalize `(ind ,(tm-pnat 3) ,tm-loop (var 1))) (tm-pnat 2)) -(check-equal? (normalize (tm-padd (tm-pnat 10000) (tm-pnat 2000))) - (tm-pnat 12000)) +(check-equal? (normalize (tm-mult (tm-nat 3) (tm-nat 2))) (normalize (tm-nat 6))) +(check-equal? (normalize (tm-mult (tm-nat 11) (tm-nat 116))) (normalize (tm-nat 1276))) +(check η-eq? (normalize (tm-add (tm-nat 499) (tm-nat 777))) (normalize (tm-add (tm-nat 777) (tm-nat 499)))) +(check βη-eq? (tm-mult (tm-nat 6) (tm-nat 7)) (tm-nat 42)) +(check βη-eq? '(if-zero (succ (succ zero)) zero (succ (succ (var 0)))) (tm-pnat 3)) +(check βη-eq? (tm-padd (tm-pnat 8) (tm-pnat 11)) (tm-pnat 19)) +(check βη-eq? (tm-padd (tm-pnat 2) (tm-psuc (tm-var 0))) '(succ (succ (succ (var 0))))) diff --git a/nbe.rkt b/nbe.rkt index 57db916..f1afe9d 100644 --- a/nbe.rkt +++ b/nbe.rkt @@ -1,159 +1,138 @@ -#lang typed/racket +#lang racket ;; Grammar (Λ) ;; t := λ t | app t t | i -(define-type denv (-> V (Promise D))) -(define-type V Nonnegative-Integer) -(define-type Term (∪ 'zero - (List 'succ Term) - (List 'var V) - (List 'λ Term) - (List 'app Term Term) - (List 'ind Term Term Term))) +;; Domain +;; D := neu D_ne | fun [(var -> var) -> D → D] +;; D_ne := var i | app D_ne D -(define-type D (∪ 'zero - (List 'succ (Promise D)) - (List 'fun (-> (Promise D) D)) - (List 'neu D-ne))) +(define (tm? a) + (match a + ['zero true] + [`(succ ,a) (tm? a)] + [`(if-zero ,a ,b ,c) (and (tm? a) (tm? b) (tm? c))] + [`(λ ,a) (tm? a)] + [`(app ,a ,b) (and (tm? a) (tm? b))] + [`(var ,i) (exact-nonnegative-integer? i)] + [_ false])) -(define-type D-ne (∪ (List 'app D-ne D) - (List 'idx V) - (List 'ind D-ne D (-> (Promise D) (Promise D) D)))) +(define-syntax-rule (ap a b) + (match (force a) + [`(fun ,f) (force (f identity b))] + [`(neu ,u) `(neu (app ,u ,b))] + [_ (error "ap: type error")])) -(: ext (-> denv (Promise D) denv)) -(define (ext ρ a) - (lambda (i) +(define-syntax-rule (ifz a b c) + (match (force a) + ['zero (force b)] + [`(succ ,u) (ap c u)] + [`(neu ,u) `(neu (if-zero ,u ,b ,c))])) + +(define compose-ren compose) +(define (compose-ren-sub ξ ρ) + (compose (curry ren-dom ξ) ρ)) +(define-syntax-rule (ext ρ a) + (lambda (i) (if (zero? i) a (ρ (- i 1))))) - - -(: interp-fun (-> Term denv D)) -(define (interp-fun a ρ) - (list 'fun (λ (x) (interp a (ext ρ x))))) - -(: interp-fun2 (-> Term denv (-> (Promise D) (Promise D) D))) -(define (interp-fun2 a ρ) - (λ (x y) (interp a (ext (ext ρ x) y)))) - -(: interp-ind (-> D (Promise D) (-> (Promise D) (Promise D) D) D)) -(define (interp-ind a b c) +(define (ren-ne-dom ξ a) (match a - [`(neu ,u) `(neu (ind ,u ,(force b) ,c))] - ['zero (force b)] - [`(succ ,a) (c a (delay (interp-ind (force a) b c)))])) + [`(var ,i) `(var ,(ξ i))] + [`(app ,a ,b) `(app ,(ren-ne-dom ξ a) ,(ren-dom ξ b))] + [`(if-zero ,a ,b ,c) `(if-zero ,(ren-ne-dom ξ a) ,(ren-dom ξ b) ,(ren-dom ξ c))])) -(: ap (-> D Term denv D)) -(define (ap a b ρ) - (match a - ['zero (error "type-error: ap zero")] - [`(succ ,_) (error "type-error: ap succ")] - [`(fun ,f) (f (delay (interp b ρ)))] - [`(neu ,u) `(neu (app ,u ,(interp b ρ)))])) +(define (ren-dom ξ a) + (delay (match (force a) + ['zero 'zero] + [`(succ ,a) `(succ ,(ren-dom ξ a))] + [`(neu ,a) `(neu ,(ren-ne-dom ξ a))] + [`(fun ,f) `(fun ,(λ (ξ0 α) (f (compose-ren ξ0 ξ) α)))]))) + +(define-syntax-rule (interp-fun a ρ) + (list 'fun (λ (ξ x) (interp a (ext (compose-ren-sub ξ ρ) x))))) -(: interp (-> Term denv D)) (define (interp a ρ) - (match a + (delay (match a [`(var ,i) (force (ρ i))] ['zero 'zero] - [`(succ ,a) `(succ ,(delay (interp a ρ)))] - [`(ind ,a ,b ,c) (interp-ind - (interp a ρ) - (delay (interp b ρ)) - (interp-fun2 c ρ))] + [`(succ ,a) `(succ ,(interp a ρ))] + [`(if-zero ,a ,b ,c) (ifz (interp a ρ) (interp b ρ) (interp-fun c ρ))] [`(λ ,a) (interp-fun a ρ)] - [`(app ,a ,b) (ap (interp a ρ) b ρ)])) + [`(app ,a ,b) (ap (interp a ρ) (interp b ρ))]))) -(: reify (-> V D Term)) -(define (reify n a) - (match a +(define (reify a) + (match (force a) ['zero 'zero] - [`(succ ,a) `(succ ,(reify n (force a)))] - [`(fun ,f) (list 'λ (reify (+ n 1) (f (delay `(neu (idx ,n))))))] - [`(neu ,a) (reify-neu n a)])) + [`(succ ,a) `(succ ,(reify a))] + [`(fun ,f) (list 'λ (reify (f (curry + 1) '(neu (var 0)))))] + [`(neu ,a) (reify-neu a)])) -(: reify-neu (-> V D-ne Term)) -(define (reify-neu n a) +(define (extract-body a) (match a - [`(ind ,a ,b ,c) (list 'ind - (reify-neu n a) - (reify n b) - (reify (+ n 2) - (c (delay `(neu (idx ,n))) - (delay `(neu (idx ,(+ 1 n)))))))] - [`(app ,u ,v) (list 'app (reify-neu n u) (reify n v))] - [`(idx ,i) (list 'var (max 0 (- n (+ i 1))))])) + [`(λ ,a) a] + [_ (error "reify-neu: not reifiable")])) -(: idsub (-> V V D)) -(define (idsub s i) `(neu (idx ,(max 0 (- s (+ i 1)))))) - -(: scope (-> Term V)) -(define (scope a) +(define (reify-neu a) (match a - ['zero 0] - [`(succ ,a) (scope a)] - (`(ind ,a ,b ,c) (max (scope a) (scope b) (- (scope c) 2))) - [`(if-zero ,a ,b ,c) (max (scope a) (scope b) (scope c))] - [`(λ ,a) (max 0 (- (scope a) 1))] - [`(app ,a ,b) (max (scope a) (scope b))] - [`(var ,i) (+ i 1)])) + [`(if-zero ,a ,b ,c) (list 'if (reify-neu a) (reify b) (extract-body (reify c)))] + [`(app ,u ,v) (list 'app (reify-neu u) (reify v))] + [`(var ,i) a])) + +(define (idsub i) `(neu (var ,i))) -(: normalize (-> Term Term)) (define (normalize a) - (let ([sa (scope a)]) - (reify sa (interp a (λ (x) (delay (idsub sa x))))))) + (reify (interp a idsub))) -;; (define (subst ρ a) -;; (match a -;; [`(var ,i) (ρ i)] -;; [`(app ,a ,b) `(app ,(subst ρ a) ,(subst ρ b))] -;; [`(λ ,a) `(λ ,(subst (ext (compose (curry subst (λ (i) `(var ,(+ i 1)))) ρ) -;; '(var 0)) a))])) +(define (subst ρ a) + (match a + [`(var ,i) (ρ i)] + [`(app ,a ,b) `(app ,(subst ρ a) ,(subst ρ b))] + [`(λ ,a) `(λ ,(subst (ext (compose (curry subst (λ (i) `(var ,(+ i 1)))) ρ) + '(var 0)) a))])) -;; (define (idsub-tm i) `(var ,i)) -;; (define (subst1 b a) -;; (subst (ext idsub-tm b) a)) +(define (idsub-tm i) `(var ,i)) +(define (subst1 b a) + (subst (ext idsub-tm b) a)) -;; (define (eval-tm a) -;; (match a -;; [(list 'var _) a] -;; [(list 'λ a) `(λ ,(eval-tm a))] -;; [(list 'app a b) -;; (match (eval-tm a) -;; [(list 'λ a) (eval-tm (subst1 b a))] -;; [v `(app ,v ,(eval-tm b))])])) +(define (eval-tm a) + (match a + [(list 'var _) a] + [(list 'λ a) `(λ ,(eval-tm a))] + [(list 'app a b) + (match (eval-tm a) + [(list 'λ a) (eval-tm (subst1 b a))] + [v `(app ,v ,(eval-tm b))])])) -;; (define (eval-tm-strict a) -;; (match a -;; [(list 'var _) a] -;; [(list 'λ a) `(λ ,(eval-tm-strict a))] -;; [(list 'app a b) -;; (match (eval-tm-strict a) -;; [(list 'λ a) (eval-tm-strict (subst1 (eval-tm-strict b) a))] -;; [v `(app ,v ,(eval-tm-strict b))])])) +(define (eval-tm-strict a) + (match a + [(list 'var _) a] + [(list 'λ a) `(λ ,(eval-tm-strict a))] + [(list 'app a b) + (match (eval-tm-strict a) + [(list 'λ a) (eval-tm-strict (subst1 (eval-tm-strict b) a))] + [v `(app ,v ,(eval-tm-strict b))])])) -;; ;; Coquand's algorithm but for β-normal forms -;; (: η-eq? (-> Term Term Boolean)) -;; (define (η-eq? a b) -;; (match (list a b) -;; ['(zero zero) true] -;; [`((succ ,a) (succ ,b)) (η-eq? a b)] -;; [`((if-zero ,a ,b ,c) (if-zero ,a0 ,b0 ,c0)) -;; (and (η-eq? a a0) (η-eq? b b0) (η-eq? c c0))] -;; [`((λ ,a) (λ ,b)) (η-eq? a b)] -;; [`((λ ,a) ,u) (η-eq? a `(app ,(subst (λ (i) `(var ,(+ i 1))) u) (var 0)))] -;; [`(,u (λ ,a)) (η-eq? `(app ,(subst (λ (i) `(var ,(+ i 1))) u) (var 0)) a)] -;; [`((app ,u0 ,v0) (app ,u1 ,v1)) (and (η-eq? u0 u1) (η-eq? v0 v1))] -;; [`((var ,i) (var ,j)) (eqv? i j)] -;; [_ false])) +;; Coquand's algorithm but for β-normal forms +(define (η-eq? a b) + (match (list a b) + ['(zero zero) true] + [`((succ ,a) (succ ,b)) (η-eq? a b)] + [`((if-zero ,a ,b ,c) (if-zero ,a0 ,b0 ,c0)) + (and (η-eq? a a0) (η-eq? b b0) (η-eq? c c0))] + [`((λ ,a) (λ ,b)) (η-eq? a b)] + [`((λ ,a) ,u) (η-eq? a `(app ,(subst (λ (i) `(var ,(+ i 1))) u) (var 0)))] + [`(,u (λ ,a)) (η-eq? `(app ,(subst (λ (i) `(var ,(+ i 1))) u) (var 0)) a)] + [`((app ,u0 ,v0) (app ,u1 ,v1)) (and (η-eq? u0 u1) (η-eq? v0 v1))] + [`((var ,i) (var ,j)) (eqv? i j)] + [_ false])) -;; (define (βη-eq? a b) -;; (η-eq? (normalize a) (normalize b))) +(define (βη-eq? a b) + (η-eq? (normalize a) (normalize b))) -(: β-eq? (-> Term Term Boolean)) (define (β-eq? a b) (equal? (normalize a) (normalize b))) -(provide reify interp normalize β-eq? Term D V) +(provide eval-tm eval-tm-strict reify interp normalize tm? η-eq? βη-eq? β-eq?)