diff --git a/README.md b/README.md index 14c0e91..a7ceb45 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# Kripke-style untyped NbE in racket +# 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,6 +10,3 @@ 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 0e3df78..b7b4b81 100644 --- a/nbe-test.rkt +++ b/nbe-test.rkt @@ -1,6 +1,6 @@ -#lang racket +#lang typed/racket -(require rackunit "nbe.rkt") +(require typed/rackunit "nbe.rkt") (define-syntax tm-app (syntax-rules () @@ -11,64 +11,85 @@ (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)) -(define (tm-ifz a b c) - `(if-zero ,a ,b ,c)) - +(: tm-psuc (-> Term Term)) (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-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))))) +(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)) diff --git a/nbe.rkt b/nbe.rkt index f1afe9d..57db916 100644 --- a/nbe.rkt +++ b/nbe.rkt @@ -1,138 +1,159 @@ -#lang racket +#lang typed/racket ;; Grammar (Λ) ;; t := λ t | app t t | i -;; Domain -;; D := neu D_ne | fun [(var -> var) -> D → D] -;; D_ne := var i | app D_ne D +(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))) -(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 (∪ 'zero + (List 'succ (Promise D)) + (List 'fun (-> (Promise D) D)) + (List 'neu D-ne))) -(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")])) +(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 (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) +(: ext (-> denv (Promise D) denv)) +(define (ext ρ a) + (lambda (i) (if (zero? i) a (ρ (- i 1))))) -(define (ren-ne-dom ξ a) + + +(: 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) (match a - [`(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))])) + [`(neu ,u) `(neu (ind ,u ,(force b) ,c))] + ['zero (force b)] + [`(succ ,a) (c a (delay (interp-ind (force a) b c)))])) -(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))))) +(: 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 ρ)))])) +(: interp (-> Term denv D)) (define (interp a ρ) - (delay (match a + (match a [`(var ,i) (force (ρ i))] ['zero 'zero] - [`(succ ,a) `(succ ,(interp a ρ))] - [`(if-zero ,a ,b ,c) (ifz (interp a ρ) (interp b ρ) (interp-fun c ρ))] + [`(succ ,a) `(succ ,(delay (interp a ρ)))] + [`(ind ,a ,b ,c) (interp-ind + (interp a ρ) + (delay (interp b ρ)) + (interp-fun2 c ρ))] [`(λ ,a) (interp-fun a ρ)] - [`(app ,a ,b) (ap (interp a ρ) (interp b ρ))]))) + [`(app ,a ,b) (ap (interp a ρ) b ρ)])) -(define (reify a) - (match (force a) +(: reify (-> V D Term)) +(define (reify n a) + (match a ['zero 'zero] - [`(succ ,a) `(succ ,(reify a))] - [`(fun ,f) (list 'λ (reify (f (curry + 1) '(neu (var 0)))))] - [`(neu ,a) (reify-neu a)])) + [`(succ ,a) `(succ ,(reify n (force a)))] + [`(fun ,f) (list 'λ (reify (+ n 1) (f (delay `(neu (idx ,n))))))] + [`(neu ,a) (reify-neu n a)])) -(define (extract-body a) +(: reify-neu (-> V D-ne Term)) +(define (reify-neu n a) (match a - [`(λ ,a) a] - [_ (error "reify-neu: not reifiable")])) + [`(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))))])) -(define (reify-neu a) +(: idsub (-> V V D)) +(define (idsub s i) `(neu (idx ,(max 0 (- s (+ i 1)))))) + +(: scope (-> Term V)) +(define (scope a) (match a - [`(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))) + ['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)])) +(: normalize (-> Term Term)) (define (normalize a) - (reify (interp a idsub))) + (let ([sa (scope a)]) + (reify sa (interp a (λ (x) (delay (idsub sa x))))))) -(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 -(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 +;; (: η-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])) -(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 eval-tm eval-tm-strict reify interp normalize tm? η-eq? βη-eq? β-eq?) +(provide reify interp normalize β-eq? Term D V)