suzanne.soy/cur
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fixed notion of values, and cached reduction

Browse Source 
* Made the primitive form of elim (elim t_0 t_1), allowing this form to be
  considered a value when t_0 and t_1 are values.
* Moved definition of values to reduction language, and fixed it. This
  fixed issues with unique decomposition, and thus fixed reduction of
  eliminators.
* Enabled caching in apply-reduction-relation* to speed up results of
  recursive calls.
This commit is contained in:
William J. Bowman 2015-09-29 17:52:33 -04:00
parent 0807128f9e
commit b95de692b9
No known key found for this signature in database
GPG Key ID: DDD48D26958F0D1A
3 changed files with 73 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

136
curnel/redex-core.rkt
View File

@ -35,14 +35,11 @@
(i ::= natural) (i ::= natural)
(U ::= (Unv i)) (U ::= (Unv i))
(x ::= variable-not-otherwise-mentioned) (x ::= variable-not-otherwise-mentioned)
(v ::= (Π (x : t) t) (λ (x : t) t) elim x U capp) (t e ::= (Π (x : t) t) (λ (x : t) t) (elim t t) x U (t t)))
(capp ::= (x v) (capp v))
(t e ::= v (t t)))
(define x? (redex-match? cicL x)) (define x? (redex-match? cicL x))
(define t? (redex-match? cicL t)) (define t? (redex-match? cicL t))
(define e? (redex-match? cicL e)) (define e? (redex-match? cicL e))
(define v? (redex-match? cicL v))
(define U? (redex-match? cicL U)) (define U? (redex-match? cicL U))
(module+ test (module+ test
@ -61,14 +58,8 @@
(check-true (U? (term (Unv 0)))) (check-true (U? (term (Unv 0))))
(check-true (U? (term Type))) (check-true (U? (term Type)))
(check-true (e? (term (λ (x_0 : (Unv 0)) x_0)))) (check-true (e? (term (λ (x_0 : (Unv 0)) x_0))))
(check-true (v? (term (λ (x_0 : (Unv 0)) x_0))))
(check-true (t? (term (λ (x_0 : (Unv 0)) x_0)))) (check-true (t? (term (λ (x_0 : (Unv 0)) x_0))))
(check-true (t? (term (λ (x_0 : (Unv 0)) x_0)))) (check-true (t? (term (λ (x_0 : (Unv 0)) x_0)))))
(check-true
(v? (term (refl Nat))))
(check-true
(v? (term ((refl Nat) z))))
)
;; 'A' ;; 'A'
;; Types of Universes ;; Types of Universes
@ -104,10 +95,10 @@
#:contract (α-equivalent t t) #:contract (α-equivalent t t)
[----------------- "α-x" [----------------- "α-x"
(α-equivalent x x)] (α-equivalent x x)]
[----------------- "α-U" [----------------- "α-U"
(α-equivalent U U)] (α-equivalent U U)]
[(α-equivalent t_1 (subst t_3 x_1 x_0)) [(α-equivalent t_1 (subst t_3 x_1 x_0))
(α-equivalent t_0 t_2) (α-equivalent t_0 t_2)
@ -125,8 +116,8 @@
(check-holds (α-equivalent (λ (x : A) x) (λ (y : A) y)))) (check-holds (α-equivalent (λ (x : A) x) (λ (y : A) y))))
(define-metafunction cicL (define-metafunction cicL
fresh-x : any ... -> x fresh-x : any ... -> x
[(fresh-x any ...) ,(variable-not-in (term (any ...)) (term x))]) [(fresh-x any ...) ,(variable-not-in (term (any ...)) (term x))])
;; NB: Substitution is hard ;; NB: Substitution is hard
;; NB: Copy and pasted from Redex examples ;; NB: Copy and pasted from Redex examples
@ -156,7 +147,7 @@
(term (x_0 t_0 x t t_1)) (term (x_0 t_0 x t t_1))
(term x_0)))] (term x_0)))]
[(subst (e_0 e_1) x t) ((subst e_0 x t) (subst e_1 x t))] [(subst (e_0 e_1) x t) ((subst e_0 x t) (subst e_1 x t))]
[(subst elim x t) elim]) [(subst (elim e_0 e_1) x t) (elim (subst e_0 x t) (subst e_1 x t))])
(module+ test (module+ test
(check-true (t? (term (Π (a : A) (Π (b : B) ((and A) B)))))) (check-true (t? (term (Π (a : A) (Π (b : B) ((and A) B))))))
(check-holds (check-holds
@ -175,23 +166,32 @@
;; TODO: I think a lot of things can be simplified if I rethink how ;; TODO: I think a lot of things can be simplified if I rethink how
;; TODO: model contexts, telescopes, and such. ;; TODO: model contexts, telescopes, and such.
(define-extended-language cic-redL cicL (define-extended-language cic-redL cicL
;; NB: (in-hole Θv (elim x U)) is only a value when it's a partially applied elim.
;; TODO: Perhaps (elim x U) should step to an eta-expanded version of elim
(v ::= x U (Π (x : t) t) (λ (x : t) t) (elim x U) (in-hole Θv x) (in-hole Θv (elim x U)))
;; call-by-value, plus reduce under Π (helps with typing checking) ;; call-by-value, plus reduce under Π (helps with typing checking)
(E ::= hole (v E) (E e) (E ::= hole (E e) (v E)
(Π (x : (in-hole Θ x)) E)
(Π (x : v) E) (Π (x : v) E)
(Π (x : E) e)) (Π (x : E) e))
;; TODO: Σ should probably be moved to cicL, since elim is there.
;; Σ (signature). (inductive-name : type ((constructor : type) ...)) ;; Σ (signature). (inductive-name : type ((constructor : type) ...))
(Σ ::= ∅ (Σ (x : t ((x : t) ...)))) (Σ ::= ∅ (Σ (x : t ((x : t) ...))))
(Ξ Φ ::= hole (Π (x : t) Ξ)) ;;(Telescope) (Ξ Φ ::= hole (Π (x : t) Ξ)) ;;(Telescope)
;; NB: Does an apply context correspond to a substitution (γ)? ;; NB: Does an apply context correspond to a substitution (γ)?
(Θ ::= hole (Θ e))) ;;(Apply context) (Θ ::= hole (Θ e)) ;;(Apply context)
(Θv ::= hole (Θv v)))
(define Σ? (redex-match? cic-redL Σ)) (define Σ? (redex-match? cic-redL Σ))
(define Ξ? (redex-match? cic-redL Ξ)) (define Ξ? (redex-match? cic-redL Ξ))
(define Φ? (redex-match? cic-redL Φ)) (define Φ? (redex-match? cic-redL Φ))
(define Θ? (redex-match? cic-redL Θ)) (define Θ? (redex-match? cic-redL Θ))
(define Θv? (redex-match? cic-redL Θv))
(define E? (redex-match? cic-redL E)) (define E? (redex-match? cic-redL E))
(define v? (redex-match? cic-redL v))
(module+ test (module+ test
(check-true (v? (term (λ (x_0 : (Unv 0)) x_0))))
(check-true (v? (term (refl Nat))))
(check-true (v? (term ((refl Nat) z))))
;; TODO: Rename these signatures, and use them in all future tests. ;; TODO: Rename these signatures, and use them in all future tests.
(define Σ (term ((∅ (nat : (Unv 0) ((zero : nat) (s : (Π (x : nat) nat))))) (define Σ (term ((∅ (nat : (Unv 0) ((zero : nat) (s : (Π (x : nat) nat)))))
(bool : (Unv 0) ((true : bool) (false : bool)))))) (bool : (Unv 0) ((true : bool) (false : bool))))))
@ -231,7 +231,6 @@
((append-Σ Σ_2 Σ_1) (x : t ((x_c : t_c) ...)))]) ((append-Σ Σ_2 Σ_1) (x : t ((x_c : t_c) ...)))])
;; TODO: Test ;; TODO: Test
;; TODO: Isn't this just plug?
;; TODO: Maybe this should be called "apply-to-telescope" ;; TODO: Maybe this should be called "apply-to-telescope"
(define-metafunction cic-redL (define-metafunction cic-redL
apply-telescope : t Ξ -> t apply-telescope : t Ξ -> t
@ -274,7 +273,7 @@
(in-hole Θ_i (hole (in-hole Θ_r x_ci))) (in-hole Θ_i (hole (in-hole Θ_r x_ci)))
(x_c0 ... x_ci x_c1 ...)) (x_c0 ... x_ci x_c1 ...))
((elim-recur x_D U e_P Θ Θ_m Θ_i (x_c0 ... x_ci x_c1 ...)) ((elim-recur x_D U e_P Θ Θ_m Θ_i (x_c0 ... x_ci x_c1 ...))
(in-hole (Θ (in-hole Θ_r x_ci)) (((elim x_D) U) e_P)))] (in-hole (Θ (in-hole Θ_r x_ci)) ((elim x_D U) e_P)))]
[(elim-recur x_D U e_P Θ Θ_i Θ_nr (x ...)) hole]) [(elim-recur x_D U e_P Θ Θ_i Θ_nr (x ...)) hole])
(module+ test (module+ test
(check-true (check-true
@ -285,7 +284,7 @@
((hole (s zero)) (λ (x : nat) (λ (ih-x : nat) (s (s x))))) ((hole (s zero)) (λ (x : nat) (λ (ih-x : nat) (s (s x)))))
(hole zero) (hole zero)
(zero s))) (zero s)))
(term (hole ((((((elim nat) Type) (λ (x : nat) nat)) (term (hole (((((elim nat Type) (λ (x : nat) nat))
(s zero)) (s zero))
(λ (x : nat) (λ (ih-x : nat) (s (s x))))) (λ (x : nat) (λ (ih-x : nat) (s (s x)))))
zero)))) zero))))
@ -295,7 +294,7 @@
((hole (s zero)) (λ (x : nat) (λ (ih-x : nat) (s (s x))))) ((hole (s zero)) (λ (x : nat) (λ (ih-x : nat) (s (s x)))))
(hole (s zero)) (hole (s zero))
(zero s))) (zero s)))
(term (hole ((((((elim nat) Type) (λ (x : nat) nat)) (term (hole (((((elim nat Type) (λ (x : nat) nat))
(s zero)) (s zero))
(λ (x : nat) (λ (ih-x : nat) (s (s x))))) (λ (x : nat) (λ (ih-x : nat) (s (s x)))))
(s zero)))))) (s zero))))))
@ -327,16 +326,16 @@
(--> (Σ (in-hole E ((any (x : t_0) t_1) t_2))) (--> (Σ (in-hole E ((any (x : t_0) t_1) t_2)))
(Σ (in-hole E (subst t_1 x t_2))) (Σ (in-hole E (subst t_1 x t_2)))
-->β) -->β)
(--> (Σ (in-hole E (in-hole Θ (((elim x_D) U) e_P)))) (--> (Σ (in-hole E (in-hole Θv ((elim x_D U) v_P))))
(Σ (in-hole E (in-hole Θ_r (in-hole Θ_i e_mi)))) (Σ (in-hole E (in-hole Θ_r (in-hole Θv_i v_mi))))
#| #|
| The elim form must appear applied like so: | The elim form must appear applied like so:
| (elim x_D U e_P m_0 ... m_i m_j ... m_n p ... (c_i a ...)) | (elim x_D U v_P m_0 ... m_i m_j ... m_n p ... (c_i a ...))
| |
| Where: | Where:
| x_D is the inductive being eliminated | x_D is the inductive being eliminated
| U is the universe of the result of the motive | U is the universe of the result of the motive
| e_P is the motive | v_P is the motive
| m_{0..n} are the methods | m_{0..n} are the methods
| p ... are the parameters of x_D | p ... are the parameters of x_D
| c_i is a constructor of x_d | c_i is a constructor of x_d
@ -344,11 +343,11 @@
| Unfortunately, Θ contexts turn all this inside out: | Unfortunately, Θ contexts turn all this inside out:
| TODO: Write better abstractions for this notation | TODO: Write better abstractions for this notation
|# |#
(where (in-hole (Θ_p (in-hole Θ_i x_ci)) Θ_m) (where (in-hole (Θv_p (in-hole Θv_i x_ci)) Θv_m)
Θ) Θv)
;; Check that Θ_p actually matches the parameters of x_D, to ensure it doesn't capture other ;; Check that Θ_p actually matches the parameters of x_D, to ensure it doesn't capture other
;; arguments. ;; arguments.
(judgment-holds (telescope-match Θ_p (parameters-of Σ x_D))) (judgment-holds (telescope-match Θv_p (parameters-of Σ x_D)))
;; Ensure x_ci is actually a constructor for x_D ;; Ensure x_ci is actually a constructor for x_D
(where ((x_c* : t_c*) ...) (where ((x_c* : t_c*) ...)
(constructors-for Σ x_D)) (constructors-for Σ x_D))
@ -356,11 +355,11 @@
(x_c* ...)) (x_c* ...))
;; There should be a number of methods equal to the number of constructors; to ensure E ;; There should be a number of methods equal to the number of constructors; to ensure E
;; doesn't capture methods and Θ_m doesn't capture other arguments ;; doesn't capture methods and Θ_m doesn't capture other arguments
(judgment-holds (length-match Θ_m (x_c* ...))) (judgment-holds (length-match Θv_m (x_c* ...)))
;; Find the method for constructor x_ci, relying on the order of the arguments. ;; Find the method for constructor x_ci, relying on the order of the arguments.
(where e_mi (method-lookup Σ x_D x_ci Θ_m)) (where v_mi (method-lookup Σ x_D x_ci Θv_m))
;; Generate the inductive recursion ;; Generate the inductive recursion
(where Θ_r (elim-recur x_D U e_P (in-hole Θ_p Θ_m) Θ_m Θ_i (x_c* ...))) (where Θ_r (elim-recur x_D U v_P (in-hole Θv_p Θv_m) Θv_m Θv_i (x_c* ...)))
-->elim))) -->elim)))
(define-metafunction cic-redL (define-metafunction cic-redL
@ -373,7 +372,8 @@
reduce : Σ e -> e reduce : Σ e -> e
[(reduce Σ e) [(reduce Σ e)
e_r e_r
(where (_ e_r) ,(let ([r (apply-reduction-relation* cic--> (term (Σ e)))]) (where (_ e_r) ,(let ([r (apply-reduction-relation* cic--> (term (Σ e))
#:cache-all? #t)])
(unless (null? (cdr r)) (unless (null? (cdr r))
(error "Church-rosser broken" r)) (error "Church-rosser broken" r))
(car r)))]) (car r)))])
@ -386,19 +386,19 @@
(term (Π (x : t) (Unv 0)))) (term (Π (x : t) (Unv 0))))
(check-equal? (term (reduce ∅ (Π (x : t) ((Π (x_0 : t) (x_0 x)) x)))) (check-equal? (term (reduce ∅ (Π (x : t) ((Π (x_0 : t) (x_0 x)) x))))
(term (Π (x : t) (x x)))) (term (Π (x : t) (x x))))
(check-equal? (term (reduce ,Σ ((((((elim nat) Type) (λ (x : nat) nat)) (check-equal? (term (reduce ,Σ (((((elim nat Type) (λ (x : nat) nat))
(s zero)) (s zero))
(λ (x : nat) (λ (ih-x : nat) (λ (x : nat) (λ (ih-x : nat)
(s (s x))))) (s (s x)))))
zero))) zero)))
(term (s zero))) (term (s zero)))
(check-equal? (term (reduce ,Σ ((((((elim nat) Type) (λ (x : nat) nat)) (check-equal? (term (reduce ,Σ (((((elim nat Type) (λ (x : nat) nat))
(s zero)) (s zero))
(λ (x : nat) (λ (ih-x : nat) (λ (x : nat) (λ (ih-x : nat)
(s (s x))))) (s (s x)))))
(s zero)))) (s zero))))
(term (s (s zero)))) (term (s (s zero))))
(check-equal? (term (reduce ,Σ ((((((elim nat) Type) (λ (x : nat) nat)) (check-equal? (term (reduce ,Σ (((((elim nat Type) (λ (x : nat) nat))
(s zero)) (s zero))
(λ (x : nat) (λ (ih-x : nat) (s (s x))))) (λ (x : nat) (λ (ih-x : nat) (s (s x)))))
(s (s (s zero)))))) (s (s (s zero))))))
@ -406,21 +406,21 @@
(check-equal? (check-equal?
(term (reduce ,Σ (term (reduce ,Σ
((((((elim nat) Type) (λ (x : nat) nat)) (((((elim nat Type) (λ (x : nat) nat))
(s (s zero))) (s (s zero)))
(λ (x : nat) (λ (ih-x : nat) (s ih-x)))) (λ (x : nat) (λ (ih-x : nat) (s ih-x))))
(s (s zero))))) (s (s zero)))))
(term (s (s (s (s zero)))))) (term (s (s (s (s zero))))))
(check-equal? (check-equal?
(term (step ,Σ (term (step ,Σ
((((((elim nat) Type) (λ (x : nat) nat)) (((((elim nat Type) (λ (x : nat) nat))
(s (s zero))) (s (s zero)))
(λ (x : nat) (λ (ih-x : nat) (s ih-x)))) (λ (x : nat) (λ (ih-x : nat) (s ih-x))))
(s (s zero))))) (s (s zero)))))
(term (term
(((λ (x : nat) (λ (ih-x : nat) (s ih-x))) (((λ (x : nat) (λ (ih-x : nat) (s ih-x)))
(s zero)) (s zero))
((((((elim nat) Type) (λ (x : nat) nat)) (((((elim nat Type) (λ (x : nat) nat))
(s (s zero))) (s (s zero)))
(λ (x : nat) (λ (ih-x : nat) (s ih-x)))) (λ (x : nat) (λ (ih-x : nat) (s ih-x))))
(s zero))))) (s zero)))))
@ -428,7 +428,7 @@
(term (step ,Σ (step ,Σ (term (step ,Σ (step ,Σ
(((λ (x : nat) (λ (ih-x : nat) (s ih-x))) (((λ (x : nat) (λ (ih-x : nat) (s ih-x)))
(s zero)) (s zero))
((((((elim nat) Type) (λ (x : nat) nat)) (((((elim nat Type) (λ (x : nat) nat))
(s (s zero))) (s (s zero)))
(λ (x : nat) (λ (ih-x : nat) (s ih-x)))) (λ (x : nat) (λ (ih-x : nat) (s ih-x))))
(s zero)))))) (s zero))))))
@ -437,7 +437,7 @@
((λ (ih-x1 : nat) (s ih-x1)) ((λ (ih-x1 : nat) (s ih-x1))
(((λ (x : nat) (λ (ih-x : nat) (s ih-x))) (((λ (x : nat) (λ (ih-x : nat) (s ih-x)))
zero) zero)
((((((elim nat) Type) (λ (x : nat) nat)) (((((elim nat Type) (λ (x : nat) nat))
(s (s zero))) (s (s zero)))
(λ (x : nat) (λ (ih-x : nat) (s ih-x)))) (λ (x : nat) (λ (ih-x : nat) (s ih-x))))
zero)))))) zero))))))
@ -804,8 +804,8 @@
;; The types of the methods for this inductive. ;; The types of the methods for this inductive.
(where Ξ_m (methods-for x_D x_P (constructors-for Σ x_D))) (where Ξ_m (methods-for x_D x_P (constructors-for Σ x_D)))
----------------- "DTR-Elim_D" ----------------- "DTR-Elim_D"
(type-infer Σ Γ ((elim x_D) U) (type-infer Σ Γ (elim x_D U)
;; The type of ((elim x_D) U) is something like: ;; The type of (elim x_D U) is something like:
;; (∀ (P : (∀ a -> ... -> (D a ...) -> U)) ;; (∀ (P : (∀ a -> ... -> (D a ...) -> U))
;; (method_ci ...) -> ... -> ;; (method_ci ...) -> ... ->
;; (a -> ... -> (D a ...) -> ;; (a -> ... -> (D a ...) ->
@ -858,8 +858,8 @@
;; TODO: Clean up/Reorganize these tests ;; TODO: Clean up/Reorganize these tests
(check-true (check-true
(redex-match? cic-typingL (redex-match? cic-typingL
(in-hole Θ_m ((((elim x_D) U) e_D) e_P)) (in-hole Θ_m (((elim x_D U) e_D) e_P))
(term (((((elim truth) Type) T) (Π (x : truth) (Unv 1))) (Unv 0))))) (term ((((elim truth Type) T) (Π (x : truth) (Unv 1))) (Unv 0)))))
(define Σtruth (term (∅ (truth : (Unv 0) ((T : truth)))))) (define Σtruth (term (∅ (truth : (Unv 0) ((T : truth))))))
(check-holds (type-infer ,Σtruth ∅ truth (in-hole Ξ U))) (check-holds (type-infer ,Σtruth ∅ truth (in-hole Ξ U)))
(check-holds (type-infer ,Σtruth ∅ T (in-hole Θ_ai truth))) (check-holds (type-infer ,Σtruth ∅ T (in-hole Θ_ai truth)))
@ -872,15 +872,15 @@
(methods-for truth (methods-for truth
(λ (x : truth) (Unv 1)) (λ (x : truth) (Unv 1))
((T : truth))))) ((T : truth)))))
(check-holds (type-infer ,Σtruth ∅ ((elim truth) Type) t)) (check-holds (type-infer ,Σtruth ∅ (elim truth Type) t))
(check-holds (type-check (∅ (truth : (Unv 0) ((T : truth)))) (check-holds (type-check (∅ (truth : (Unv 0) ((T : truth))))
∅ ∅
(((((elim truth) (Unv 2)) (λ (x : truth) (Unv 1))) (Unv 0)) ((((elim truth (Unv 2)) (λ (x : truth) (Unv 1))) (Unv 0))
T) T)
(Unv 1))) (Unv 1)))
(check-not-holds (type-check (∅ (truth : (Unv 0) ((T : truth)))) (check-not-holds (type-check (∅ (truth : (Unv 0) ((T : truth))))
∅ ∅
(((((elim truth) (Unv 1)) Type) Type) T) ((((elim truth (Unv 1)) Type) Type) T)
(Unv 1))) (Unv 1)))
(check-holds (check-holds
(type-infer ∅ ∅ (Π (x2 : (Unv 0)) (Unv 0)) U)) (type-infer ∅ ∅ (Π (x2 : (Unv 0)) (Unv 0)) U))
@ -898,7 +898,7 @@
(check-holds (type-check ,Σ syn ...))) (check-holds (type-check ,Σ syn ...)))
(nat-test ∅ (Π (x : nat) nat) (Unv 0)) (nat-test ∅ (Π (x : nat) nat) (Unv 0))
(nat-test ∅ (λ (x : nat) x) (Π (x : nat) nat)) (nat-test ∅ (λ (x : nat) x) (Π (x : nat) nat))
(nat-test ∅ ((((((elim nat) Type) (λ (x : nat) nat)) zero) (nat-test ∅ (((((elim nat Type) (λ (x : nat) nat)) zero)
(λ (x : nat) (λ (ih-x : nat) x))) zero) (λ (x : nat) (λ (ih-x : nat) x))) zero)
nat) nat)
(nat-test ∅ nat (Unv 0)) (nat-test ∅ nat (Unv 0))
@ -907,38 +907,38 @@
(nat-test ∅ (s zero) nat) (nat-test ∅ (s zero) nat)
;; TODO: Meta-function auto-currying and such ;; TODO: Meta-function auto-currying and such
(check-holds (check-holds
(type-infer ,Σ ∅ (((((elim nat) (Unv 0)) (λ (x : nat) nat)) (type-infer ,Σ ∅ ((((elim nat (Unv 0)) (λ (x : nat) nat))
zero) zero)
(λ (x : nat) (λ (ih-x : nat) x))) (λ (x : nat) (λ (ih-x : nat) x)))
t)) t))
(nat-test ∅ ((((((elim nat) (Unv 0)) (λ (x : nat) nat)) (nat-test ∅ (((((elim nat (Unv 0)) (λ (x : nat) nat))
zero) zero)
(λ (x : nat) (λ (ih-x : nat) x))) (λ (x : nat) (λ (ih-x : nat) x)))
zero) zero)
nat) nat)
(nat-test ∅ ((((((elim nat) (Unv 0)) (λ (x : nat) nat)) (nat-test ∅ (((((elim nat (Unv 0)) (λ (x : nat) nat))
(s zero)) (s zero))
(λ (x : nat) (λ (ih-x : nat) (s (s x))))) (λ (x : nat) (λ (ih-x : nat) (s (s x)))))
zero) zero)
nat) nat)
(nat-test ∅ ((((((elim nat) Type) (λ (x : nat) nat)) (nat-test ∅ (((((elim nat Type) (λ (x : nat) nat))
(s zero)) (s zero))
(λ (x : nat) (λ (ih-x : nat) (s (s x))))) zero) (λ (x : nat) (λ (ih-x : nat) (s (s x))))) zero)
nat) nat)
(nat-test (∅ n : nat) (nat-test (∅ n : nat)
((((((elim nat) (Unv 0)) (λ (x : nat) nat)) zero) (λ (x : nat) (λ (ih-x : nat) x))) n) (((((elim nat (Unv 0)) (λ (x : nat) nat)) zero) (λ (x : nat) (λ (ih-x : nat) x))) n)
nat) nat)
(check-holds (check-holds
(type-check (,Σ (bool : (Unv 0) ((btrue : bool) (bfalse : bool)))) (type-check (,Σ (bool : (Unv 0) ((btrue : bool) (bfalse : bool))))
(∅ n2 : nat) (∅ n2 : nat)
((((((elim nat) (Unv 0)) (λ (x : nat) bool)) (((((elim nat (Unv 0)) (λ (x : nat) bool))
btrue) btrue)
(λ (x : nat) (λ (ih-x : bool) bfalse))) (λ (x : nat) (λ (ih-x : bool) bfalse)))
n2) n2)
bool)) bool))
(check-not-holds (check-not-holds
(type-check ,Σ ∅ (type-check ,Σ ∅
(((((elim nat) (Unv 0)) nat) (s zero)) zero) ((((elim nat (Unv 0)) nat) (s zero)) zero)
nat)) nat))
(define lam (term (λ (nat : (Unv 0)) nat))) (define lam (term (λ (nat : (Unv 0)) nat)))
(check-equal? (check-equal?
@ -997,7 +997,7 @@
(in-hole Ξ (Π (x : (in-hole Θ_Ξ and)) U_P)))) (in-hole Ξ (Π (x : (in-hole Θ_Ξ and)) U_P))))
(check-holds (check-holds
(type-check (,Σ4 (true : (Unv 0) ((tt : true)))) ∅ (type-check (,Σ4 (true : (Unv 0) ((tt : true)))) ∅
(((((((elim and) (Unv 0)) ((((((elim and (Unv 0))
(λ (A : Type) (λ (B : Type) (λ (x : ((and A) B)) (λ (A : Type) (λ (B : Type) (λ (x : ((and A) B))
true)))) true))))
(λ (A : (Unv 0)) (λ (A : (Unv 0))
@ -1034,7 +1034,7 @@
(check-holds (check-holds
(type-check ,Σ4 (type-check ,Σ4
(((∅ P : (Unv 0)) Q : (Unv 0)) ab : ((and P) Q)) (((∅ P : (Unv 0)) Q : (Unv 0)) ab : ((and P) Q))
(((((((elim and) (Unv 0)) ((((((elim and (Unv 0))
(λ (A : Type) (λ (B : Type) (λ (x : ((and A) B)) (λ (A : Type) (λ (B : Type) (λ (x : ((and A) B))
((and B) A))))) ((and B) A)))))
(λ (A : (Unv 0)) (λ (A : (Unv 0))
@ -1054,7 +1054,7 @@
t)) t))
(check-holds (check-holds
(type-check (,Σ4 (true : (Unv 0) ((tt : true)))) ∅ (type-check (,Σ4 (true : (Unv 0) ((tt : true)))) ∅
(((((((elim and) (Unv 0)) ((((((elim and (Unv 0))
(λ (A : Type) (λ (B : Type) (λ (x : ((and A) B)) (λ (A : Type) (λ (B : Type) (λ (x : ((and A) B))
((and B) A))))) ((and B) A)))))
(λ (A : (Unv 0)) (λ (A : (Unv 0))
@ -1086,17 +1086,17 @@
(in-hole Ξ (Π (x : (in-hole Θ false)) U)))) (in-hole Ξ (Π (x : (in-hole Θ false)) U))))
(check-true (check-true
(redex-match? cic-typingL (redex-match? cic-typingL
((in-hole Θ_m (((elim x_D) U) e_P)) e_D) ((in-hole Θ_m ((elim x_D U) e_P)) e_D)
(term ((((elim false) (Unv 1)) (λ (y : false) (Π (x : Type) x))) (term (((elim false (Unv 1)) (λ (y : false) (Π (x : Type) x)))
x)))) x))))
(check-holds (check-holds
(type-check ,sigma (,gamma x : false) (type-check ,sigma (,gamma x : false)
((((elim false) (Unv 0)) (λ (y : false) (Π (x : Type) x))) x) (((elim false (Unv 0)) (λ (y : false) (Π (x : Type) x))) x)
(Π (x : (Unv 0)) x))) (Π (x : (Unv 0)) x)))
;; nat-equal? tests ;; nat-equal? tests
(define zero? (define zero?
(term (((((elim nat) Type) (λ (x : nat) bool)) (term ((((elim nat Type) (λ (x : nat) bool))
true) true)
(λ (x : nat) (λ (x_ih : bool) false))))) (λ (x : nat) (λ (x_ih : bool) false)))))
(check-holds (check-holds
@ -1108,7 +1108,7 @@
(term (reduce ,Σ (,zero? (s zero)))) (term (reduce ,Σ (,zero? (s zero))))
(term false)) (term false))
(define ih-equal? (define ih-equal?
(term (((((elim nat) Type) (λ (x : nat) bool)) (term ((((elim nat Type) (λ (x : nat) bool))
false) false)
(λ (x : nat) (λ (y : bool) (x_ih x)))))) (λ (x : nat) (λ (y : bool) (x_ih x))))))
(check-holds (check-holds
@ -1122,7 +1122,7 @@
(check-holds (check-holds
(type-infer ,Σ ∅ (λ (x : nat) (Π (x : nat) bool)) (Π (x : nat) (Unv 0)))) (type-infer ,Σ ∅ (λ (x : nat) (Π (x : nat) bool)) (Π (x : nat) (Unv 0))))
(define nat-equal? (define nat-equal?
(term (((((elim nat) Type) (λ (x : nat) (Π (x : nat) bool))) (term ((((elim nat Type) (λ (x : nat) (Π (x : nat) bool)))
,zero?) ,zero?)
(λ (x : nat) (λ (x_ih : (Π (x : nat) bool)) (λ (x : nat) (λ (x_ih : (Π (x : nat) bool))
,ih-equal?))))) ,ih-equal?)))))
@ -1143,7 +1143,7 @@
(check-true (Σ? Σ=)) (check-true (Σ? Σ=))
(define refl-elim (define refl-elim
(term ((((((((elim ==) (Unv 0)) (λ (A1 : (Unv 0)) (λ (x1 : A1) (λ (y1 : A1) (λ (p2 : (((== (term (((((((elim == (Unv 0)) (λ (A1 : (Unv 0)) (λ (x1 : A1) (λ (y1 : A1) (λ (p2 : (((==
A1) A1)
x1) x1)
y1)) y1))
@ -1154,7 +1154,7 @@
(check-true (check-true
(redex-match? (redex-match?
cic-redL cic-redL
(Σ (in-hole E (in-hole Θ (((elim x_D) U) e_P)))) (Σ (in-hole E (in-hole Θ ((elim x_D U) e_P))))
(term (,Σ= ,refl-elim)))) (term (,Σ= ,refl-elim))))
(check-true (check-true
(redex-match? (redex-match?

2
curnel/redex-lang.rkt
View File

@ -173,7 +173,7 @@
[(elim t1 t2) [(elim t1 t2)
(let* ([t1 (cur->datum #'t1)] (let* ([t1 (cur->datum #'t1)]
[t2 (cur->datum #'t2)]) [t2 (cur->datum #'t2)])
(term ((elim ,t1) ,t2)))] (term (elim ,t1 ,t2)))]
[(#%app e1 e2) [(#%app e1 e2)
(term (,(cur->datum #'e1) ,(cur->datum #'e2)))])))) (term (,(cur->datum #'e1) ,(cur->datum #'e2)))]))))
(unless (and inner-expand? (type-infer/term reified-term)) (unless (and inner-expand? (type-infer/term reified-term))

10
stdlib/nat.rkt
View File

@ -47,22 +47,20 @@
(check-equal? (nat-equal? z (s z)) false) (check-equal? (nat-equal? z (s z)) false)
(check-equal? (nat-equal? (s z) (s z)) true)) (check-equal? (nat-equal? (s z) (s z)) true))
#| TODO: Disabled until #20 fixed
(define (even? (n : Nat)) (define (even? (n : Nat))
(elim Nat Type (lambda (x : Nat) Bool) (elim Nat Type (lambda (x : Nat) Bool)
false true
(lambda* (n : Nat) (odd? : Bool) (lambda* (n : Nat) (odd? : Bool)
(not odd?)) (not odd?))
n)) n))
(define (odd? (n : Nat)) (define (odd? (n : Nat))
(and (not (even? n)) (not (even? n)))
(not (nat-equal? n z))))
(module+ test (module+ test
(check-equal? (check-equal?
(even? z) (even? z)
false) true)
(check-equal? (check-equal?
(even? (s z)) (even? (s z))
false) false)
@ -81,4 +79,4 @@
(check-equal? (check-equal?
(odd? (s (s (s z)))) (odd? (s (s (s z))))
true)) true))
|#