yiyunliu/nbe-kripke-racket
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Make the algorithm lazier
All checks were successful
ci/woodpecker/push/woodpecker Pipeline was successful
Details

Browse source
This commit is contained in:
Yiyun Liu 2025-04-30 01:35:39 -04:00
parent 5f9b001531
commit 3631f31346
2 changed files with 14 additions and 11 deletions
Download patch file Download diff file Expand all files Collapse all files

2
nbe-test.rkt
View file

@ -70,3 +70,5 @@
(check η-eq? (normalize (tm-add (tm-nat 499) (tm-nat 777))) (normalize (tm-add (tm-nat 777) (tm-nat 499)))) (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? (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? '(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)))))

23
nbe.rkt
View file

@ -17,19 +17,20 @@
[_ false])) [_ false]))
(define-syntax-rule (ap a b) (define-syntax-rule (ap a b)
(match a (match (force a)
[`(fun ,f) (f identity b)] [`(fun ,f) (force (f identity b))]
[`(neu ,u) `(neu (app ,u ,b))] [`(neu ,u) `(neu (app ,u ,b))]
[_ (error "ap: type error")])) [_ (error "ap: type error")]))
(define-syntax-rule (ifz a b c) (define-syntax-rule (ifz a b c)
(match a (match (force a)
['zero b] ['zero (force b)]
[`(succ ,u) (ap c u)] [`(succ ,u) (ap c u)]
[`(neu ,u) `(neu (if-zero ,u ,b ,c))])) [`(neu ,u) `(neu (if-zero ,u ,b ,c))]))
(define compose-ren compose) (define compose-ren compose)
(define (compose-ren-sub ξ ρ) (compose (curry ren-dom ξ) ρ)) (define (compose-ren-sub ξ ρ)
(compose (curry ren-dom ξ) ρ))
(define-syntax-rule (ext ρ a) (define-syntax-rule (ext ρ a)
(lambda (i) (lambda (i)
(if (zero? i) (if (zero? i)
@ -43,26 +44,26 @@
[`(if-zero ,a ,b ,c) `(if-zero ,(ren-ne-dom ξ a) ,(ren-dom ξ b) ,(ren-dom ξ c))])) [`(if-zero ,a ,b ,c) `(if-zero ,(ren-ne-dom ξ a) ,(ren-dom ξ b) ,(ren-dom ξ c))]))
(define (ren-dom ξ a) (define (ren-dom ξ a)
(match a (delay (match (force a)
['zero 'zero] ['zero 'zero]
[`(succ ,a) `(succ ,(ren-dom ξ a))] [`(succ ,a) `(succ ,(ren-dom ξ a))]
[`(neu ,a) `(neu ,(ren-ne-dom ξ a))] [`(neu ,a) `(neu ,(ren-ne-dom ξ a))]
[`(fun ,f) `(fun ,(λ (ξ0 α) (f (compose-ren ξ0 ξ) α)))])) [`(fun ,f) `(fun ,(λ (ξ0 α) (f (compose-ren ξ0 ξ) α)))])))
(define-syntax-rule (interp-fun a ρ) (define-syntax-rule (interp-fun a ρ)
(list 'fun (λ (ξ x) (interp a (ext (compose-ren-sub ξ ρ) x))))) (list 'fun (λ (ξ x) (interp a (ext (compose-ren-sub ξ ρ) x)))))
(define (interp a ρ) (define (interp a ρ)
(match a (delay (match a
[`(var ,i) (ρ i)] [`(var ,i) (force (ρ i))]
['zero 'zero] ['zero 'zero]
[`(succ ,a) `(succ ,(interp a ρ))] [`(succ ,a) `(succ ,(interp a ρ))]
[`(if-zero ,a ,b ,c) (ifz (interp a ρ) (interp b ρ) (interp-fun c ρ))] [`(if-zero ,a ,b ,c) (ifz (interp a ρ) (interp b ρ) (interp-fun c ρ))]
[`(λ ,a) (interp-fun a ρ)] [`(λ ,a) (interp-fun a ρ)]
[`(app ,a ,b) (ap (interp a ρ) (interp b ρ))])) [`(app ,a ,b) (ap (interp a ρ) (interp b ρ))])))
(define (reify a) (define (reify a)
(match a (match (force a)
['zero 'zero] ['zero 'zero]
[`(succ ,a) `(succ ,(reify a))] [`(succ ,a) `(succ ,(reify a))]
[`(fun ,f) (list 'λ (reify (f (curry + 1) '(neu (var 0)))))] [`(fun ,f) (list 'λ (reify (f (curry + 1) '(neu (var 0)))))]