wball/perga
1
0
Fork 0
Code Issues 15 Pull requests Projects Releases Packages Wiki Activity Actions

more peano, fixed bug in checking ascriptions of definitions

Browse source
This commit is contained in:
William Ball 2024-12-05 18:56:41 -08:00
parent 84e44b0e33
commit c0e0c37689
3 changed files with 281 additions and 236 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

512
examples/peano.pg
View file

@ -151,7 +151,7 @@ def suc_or_zero : forall (n : nat), szc n :=
-- 1) Q 0 z and -- 1) Q 0 z and
-- 2) forall (x : nat) (y : A), Q x y -> Q (suc x) (fS x y), -- 2) forall (x : nat) (y : A), Q x y -> Q (suc x) (fS x y),
-- Q x y. -- Q x y.
-- In more math lingo, we take R to be the intersection of every relation -- In more mathy lingo, we take R to be the intersection of every relation
-- satisfying 1 and 2. From there we will, with much effort, prove that R is -- satisfying 1 and 2. From there we will, with much effort, prove that R is
-- actually a function satisfying the equations we want it to. -- actually a function satisfying the equations we want it to.
@ -181,10 +181,10 @@ def rec_rel_cond2 (A : *) (z : A) (fS : nat -> A -> A) : cond2 A z fS (rec_rel A
h2 n y (h Q h1 h2); h2 n y (h Q h1 h2);
def rec_rel_total (A : *) (z : A) (fS : nat -> A -> A) : total nat A (rec_rel A z fS) := def rec_rel_total (A : *) (z : A) (fS : nat -> A -> A) : total nat A (rec_rel A z fS) :=
let (R := rec_rel A z fS) let (R := rec_rel A z fS)
(P (x : nat) := exists A (R x)) (P (x : nat) := exists A (R x))
(c1 := cond1 A z fS) (c1 := cond1 A z fS)
(c2 := cond2 A z fS) (c2 := cond2 A z fS)
in in
nat_ind P nat_ind P
(exists_intro A (R zero) z (rec_rel_cond1 A z fS)) (exists_intro A (R zero) z (rec_rel_cond1 A z fS))
@ -218,8 +218,8 @@ def rec_rel_alt (A : *) (z : A) (fS : nat -> A -> A) (x : nat) (y : A) :=
-- {{{ R2 ⊆ R -- {{{ R2 ⊆ R
def R2_sub_R (A : *) (z : A) (fS : nat -> A -> A) (x : nat) (y : A) : def R2_sub_R (A : *) (z : A) (fS : nat -> A -> A) (x : nat) (y : A) :
rec_rel_alt A z fS x y -> rec_rel A z fS x y := rec_rel_alt A z fS x y -> rec_rel A z fS x y :=
let (R := rec_rel A z fS) let (R := rec_rel A z fS)
(R2 := rec_rel_alt A z fS) (R2 := rec_rel_alt A z fS)
(ac1 := alt_cond1 A z x y) (ac1 := alt_cond1 A z x y)
(ac2 := alt_cond2 A z fS x y) (ac2 := alt_cond2 A z fS x y)
in in
@ -240,14 +240,14 @@ def R2_sub_R (A : *) (z : A) (fS : nat -> A -> A) (x : nat) (y : A) :
exists_elim nat (R x y) h1 case2 exists_elim nat (R x y) h1 case2
(fun (x2 : nat) (hx2 : h1 x2) => (fun (x2 : nat) (hx2 : h1 x2) =>
let (hpred := and_elim_l (pred x x2) (exists A (h2 x2)) hx2) let (hpred := and_elim_l (pred x x2) (exists A (h2 x2)) hx2)
(hex := and_elim_r (pred x x2) (exists A (h2 x2)) hx2) (hex := and_elim_r (pred x x2) (exists A (h2 x2)) hx2)
in in
exists_elim A (R x y) (h2 x2) hex exists_elim A (R x y) (h2 x2) hex
(fun (y2 : A) (hy2 : h2 x2 y2) => (fun (y2 : A) (hy2 : h2 x2 y2) =>
let (hpreim := and_elim_l (eq A y (fS x2 y2)) (R x2 y2) hy2) let (hpreim := and_elim_l (eq A y (fS x2 y2)) (R x2 y2) hy2)
(hR := and_elim_r (eq A y (fS x2 y2)) (R x2 y2) hy2) (hR := and_elim_r (eq A y (fS x2 y2)) (R x2 y2) hy2)
(a1 := rec_rel_cond2 A z fS x2 y2 hR) (a1 := rec_rel_cond2 A z fS x2 y2 hR)
(a2 := (eq_sym A y (fS x2 y2) hpreim) (R (suc x2)) a1) (a2 := (eq_sym A y (fS x2 y2) hpreim) (R (suc x2)) a1)
in in
(eq_sym nat x (suc x2) hpred) (fun (n : nat) => R n y) a2 (eq_sym nat x (suc x2) hpred) (fun (n : nat) => R n y) a2
end) end)
@ -264,12 +264,12 @@ def R2_cond1 (A : *) (z : A) (fS : nat -> A -> A) : cond1 A z fS (rec_rel_alt A
(eq_refl A z)); (eq_refl A z));
def R2_cond2 (A : *) (z : A) (fS : nat -> A -> A) : cond2 A z fS (rec_rel_alt A z fS) := def R2_cond2 (A : *) (z : A) (fS : nat -> A -> A) : cond2 A z fS (rec_rel_alt A z fS) :=
let (R := rec_rel A z fS) let (R := rec_rel A z fS)
(R2 := rec_rel_alt A z fS) (R2 := rec_rel_alt A z fS)
in in
fun (x2 : nat) (y2 : A) (h : R2 x2 y2) => fun (x2 : nat) (y2 : A) (h : R2 x2 y2) =>
let (x := suc x2) let (x := suc x2)
(y := fS x2 y2) (y := fS x2 y2)
(cx2 := cond_x2 A z fS x y) (cx2 := cond_x2 A z fS x y)
(cy2 := cond_y2 A z fS x y x2) (cy2 := cond_y2 A z fS x y x2)
in in
@ -286,7 +286,7 @@ def R2_cond2 (A : *) (z : A) (fS : nat -> A -> A) : cond2 A z fS (rec_rel_alt A
def R_sub_R2 (A : *) (z : A) (fS : nat -> A -> A) (x : nat) (y : A) : def R_sub_R2 (A : *) (z : A) (fS : nat -> A -> A) (x : nat) (y : A) :
rec_rel A z fS x y -> rec_rel_alt A z fS x y := rec_rel A z fS x y -> rec_rel_alt A z fS x y :=
let (R := rec_rel A z fS) let (R := rec_rel A z fS)
(R2 := rec_rel_alt A z fS) (R2 := rec_rel_alt A z fS)
in in
fun (h : R x y) => fun (h : R x y) =>
@ -305,7 +305,7 @@ def fl (A B : *) (R : A -> B -> *) := forall (x : A), fl_in A B R x;
def R2_zero (A : *) (z : A) (fS : nat -> A -> A) (y : A) : def R2_zero (A : *) (z : A) (fS : nat -> A -> A) (y : A) :
rec_rel_alt A z fS zero y -> eq A y z := rec_rel_alt A z fS zero y -> eq A y z :=
let (R2 := rec_rel_alt A z fS) let (R2 := rec_rel_alt A z fS)
(ac1 := alt_cond1 A z zero y) (ac1 := alt_cond1 A z zero y)
(ac2 := alt_cond2 A z fS zero y) (ac2 := alt_cond2 A z fS zero y)
(cx2 := cond_x2 A z fS zero y) (cx2 := cond_x2 A z fS zero y)
@ -323,12 +323,12 @@ def R2_zero (A : *) (z : A) (fS : nat -> A -> A) (y : A) :
def R2_suc (A : *) (z : A) (fS : nat -> A -> A) (x2 : nat) (y : A) : def R2_suc (A : *) (z : A) (fS : nat -> A -> A) (x2 : nat) (y : A) :
rec_rel_alt A z fS (suc x2) y -> exists A (cond_y2 A z fS (suc x2) y x2) := rec_rel_alt A z fS (suc x2) y -> exists A (cond_y2 A z fS (suc x2) y x2) :=
let (R2 := rec_rel_alt A z fS) let (R2 := rec_rel_alt A z fS)
(x := suc x2) (x := suc x2)
(ac1 := alt_cond1 A z x y) (ac1 := alt_cond1 A z x y)
(ac2 := alt_cond2 A z fS x y) (ac2 := alt_cond2 A z fS x y)
(cx2 := cond_x2 A z fS x y) (cx2 := cond_x2 A z fS x y)
(cy2 := cond_y2 A z fS x y) (cy2 := cond_y2 A z fS x y)
(goal := exists A (cy2 x2)) (goal := exists A (cy2 x2))
in in
fun (h : R2 x y) => fun (h : R2 x y) =>
@ -337,8 +337,8 @@ def R2_suc (A : *) (z : A) (fS : nat -> A -> A) (x2 : nat) (y : A) :
(fun (case2 : ac2) => (fun (case2 : ac2) =>
exists_elim nat goal cx2 case2 exists_elim nat goal cx2 case2
(fun (x22 : nat) (hx22 : cx2 x22) => (fun (x22 : nat) (hx22 : cx2 x22) =>
let (hpred := and_elim_l (pred x x22) (exists A (cy2 x22)) hx22) let (hpred := and_elim_l (pred x x22) (exists A (cy2 x22)) hx22)
(hgoal := and_elim_r (pred x x22) (exists A (cy2 x22)) hx22) (hgoal := and_elim_r (pred x x22) (exists A (cy2 x22)) hx22)
(x2_x22 := suc_inj x2 x22 hpred) (x2_x22 := suc_inj x2 x22 hpred)
in in
(eq_sym nat x2 x22 x2_x22) (eq_sym nat x2 x22 x2_x22)
@ -348,8 +348,8 @@ def R2_suc (A : *) (z : A) (fS : nat -> A -> A) (x2 : nat) (y : A) :
end; end;
def R2_functional (A : *) (z : A) (fS : nat -> A -> A) : fl nat A (rec_rel_alt A z fS) := def R2_functional (A : *) (z : A) (fS : nat -> A -> A) : fl nat A (rec_rel_alt A z fS) :=
let (R := rec_rel A z fS) let (R := rec_rel A z fS)
(R2 := rec_rel_alt A z fS) (R2 := rec_rel_alt A z fS)
(f_in := fl_in nat A R2) (f_in := fl_in nat A R2)
in nat_ind f_in in nat_ind f_in
(fun (y1 y2 : A) (h1 : R2 zero y1) (h2 : R2 zero y2) => (fun (y1 y2 : A) (h1 : R2 zero y1) (h2 : R2 zero y2) =>
@ -357,22 +357,22 @@ def R2_functional (A : *) (z : A) (fS : nat -> A -> A) : fl nat A (rec_rel_alt A
(R2_zero A z fS y1 h1) (R2_zero A z fS y1 h1)
(eq_sym A y2 z (R2_zero A z fS y2 h2))) (eq_sym A y2 z (R2_zero A z fS y2 h2)))
(fun (x2 : nat) (IH : f_in x2) (y1 y2 : A) (h1 : R2 (suc x2) y1) (h2 : R2 (suc x2) y2) => (fun (x2 : nat) (IH : f_in x2) (y1 y2 : A) (h1 : R2 (suc x2) y1) (h2 : R2 (suc x2) y2) =>
let (x := suc x2) let (x := suc x2)
(cy1 := cond_y2 A z fS x y1 x2) (cy1 := cond_y2 A z fS x y1 x2)
(cy2 := cond_y2 A z fS x y2 x2) (cy2 := cond_y2 A z fS x y2 x2)
(goal := eq A y1 y2) (goal := eq A y1 y2)
in in
exists_elim A goal cy1 (R2_suc A z fS x2 y1 h1) exists_elim A goal cy1 (R2_suc A z fS x2 y1 h1)
(fun (y12 : A) (h12 : cy1 y12) => (fun (y12 : A) (h12 : cy1 y12) =>
exists_elim A goal cy2 (R2_suc A z fS x2 y2 h2) exists_elim A goal cy2 (R2_suc A z fS x2 y2 h2)
(fun (y22 : A) (h22 : cy2 y22) => (fun (y22 : A) (h22 : cy2 y22) =>
let (y1_preim := and_elim_l (eq A y1 (fS x2 y12)) (R x2 y12) h12) let (y1_preim := and_elim_l (eq A y1 (fS x2 y12)) (R x2 y12) h12)
(y2_preim := and_elim_l (eq A y2 (fS x2 y22)) (R x2 y22) h22) (y2_preim := and_elim_l (eq A y2 (fS x2 y22)) (R x2 y22) h22)
(R_x2_y12 := and_elim_r (eq A y1 (fS x2 y12)) (R x2 y12) h12) (R_x2_y12 := and_elim_r (eq A y1 (fS x2 y12)) (R x2 y12) h12)
(R_x2_y22 := and_elim_r (eq A y2 (fS x2 y22)) (R x2 y22) h22) (R_x2_y22 := and_elim_r (eq A y2 (fS x2 y22)) (R x2 y22) h22)
(R2_x2_y12 := R_sub_R2 A z fS x2 y12 R_x2_y12) (R2_x2_y12 := R_sub_R2 A z fS x2 y12 R_x2_y12)
(R2_x2_y22 := R_sub_R2 A z fS x2 y22 R_x2_y22) (R2_x2_y22 := R_sub_R2 A z fS x2 y22 R_x2_y22)
(y12_y22 := IH y12 y22 R2_x2_y12 R2_x2_y22) (y12_y22 := IH y12 y22 R2_x2_y12 R2_x2_y22)
in in
eq_trans A y1 (fS x2 y12) y2 eq_trans A y1 (fS x2 y12) y2
y1_preim y1_preim
@ -383,213 +383,259 @@ def R2_functional (A : *) (z : A) (fS : nat -> A -> A) : fl nat A (rec_rel_alt A
end) end)
end; end;
def R_functional (A : *) (z : A) (fS : nat -> A -> A) : fl nat A (rec_rel A z fS) :=
let (R := rec_rel A z fS)
(sub := R_sub_R2 A z fS)
in
fun (n : nat) (y1 y2 : A) (h1 : R n y1) (h2 : R n y2) =>
R2_functional A z fS n y1 y2 (sub n y1 h1) (sub n y2 h2)
end;
-- }}} -- }}}
-- {{{ Actually defining the function
def rec_def (A : *) (z : A) (fS : nat -> A -> A) (x : nat) : A := def rec_def (A : *) (z : A) (fS : nat -> A -> A) (x : nat) : A :=
exists_elim A A (rec_rel A z fS x) (rec_rel_total A z fS x) exists_elim A A (rec_rel A z fS x) (rec_rel_total A z fS x)
(fun (y : A) (_ : rec_rel A z fS x y) => y); (fun (y : A) (_ : rec_rel A z fS x y) => y);
-- }}} -- }}}
-- -- For any such equations, there exists a function. -- {{{ It satisfies the properties we want it to
-- rec_def (A : *) (fzero : A) (fsuc : nat -> A -> A) : nat -> A := axiom;
-- -- Kind of stupidly, we still need one more axiom. Due to how existentials are
-- -- Here's equation one. -- defined, even though rec_def n is defined to be the y such that R n y, we
-- rec_cond_zero (A : *) (fzero : A) (fsuc : nat -> A -> A) (f : nat -> A) := -- can't actually conclude that R n (rec_def n).
-- eq A (f zero) fzero;
-- -- We need to assert that, even if you "forget" that a value came from an
-- -- And equation two. -- existential, it still satisfies the property it definitionally is supposed
-- rec_cond_suc (A : *) (fzero : A) (fsuc : nat -> A -> A) (f : nat -> A) := -- to satisfy. This annoying problem would be subverted with proper Σ-types,
-- forall (n : nat) (y : A), -- provided they had η-equality.
-- eq A (f n) y -> eq A (f (suc n)) (fsuc n y); axiom definite_description (A : *) (P : A -> *) (h : exists A P) :
-- P (exists_elim A A P h (fun (x : A) (_ : P x) => x));
-- -- Said function satisfies the equations.
-- -- It satisfies equation one. -- Now we can use this axiom to prove that R n (rec_def n).
-- rec_def_sat_zero (A : *) (fzero : A) (fsuc : nat -> A -> A) : def rec_def_sat (A : *) (z : A) (fS : nat -> A -> A) (x : nat) : rec_rel A z fS x (rec_def A z fS x) :=
-- rec_cond_zero A fzero fsuc (rec_def A fzero fsuc) := axiom; definite_description A (rec_rel A z fS x) (rec_rel_total A z fS x);
--
-- -- And two. def eq1 (A : *) (z : A) (f : nat -> A) := eq A (f zero) z;
-- rec_def_sat_suc (A : *) (fzero : A) (fsuc : nat -> A -> A) :
-- rec_cond_suc A fzero fsuc (rec_def A fzero fsuc) := axiom; def eq2 (A : *) (z : A) (fS : nat -> A -> A) (f : nat -> A) := forall (n : nat), eq A (f (suc n)) (fS n (f n));
--
-- -- And, finally, this function is unique in the sense that if any other function -- f zero = z
-- -- also satisfies the equations, it takes the same values as rec_def. def rec_def_sat_zero (A : *) (z : A) (fS : nat -> A -> A) : eq1 A z (rec_def A z fS) :=
-- rec_def_unique (A : *) (fzero : A) (fsuc : nat -> A -> A) (f g : nat -> A) : let (f := rec_def A z fS) in
-- rec_cond_zero A fzero fsuc f -> R_functional A z fS zero (f zero) z
-- rec_cond_suc A fzero fsuc f -> (rec_def_sat A z fS zero)
-- rec_cond_zero A fzero fsuc g -> (rec_rel_cond1 A z fS)
-- rec_cond_suc A fzero fsuc g -> end;
-- forall (x : nat), eq A (f x) (g x) := axiom;
-- -- f n = y -> f (suc n) = fS n y
-- -- Now we can safely define addition. def rec_def_sat_suc (A : *) (z : A) (fS : nat -> A -> A) : eq2 A z fS (rec_def A z fS) :=
-- fun (n : nat) =>
-- -- First, here's the RHS of equation 2 as a function, since it will show up let (R := rec_rel A z fS)
-- -- multiple times. (f := rec_def A z fS)
-- psuc (_ r : nat) := suc r; (y := f n)
-- (Rf := rec_def_sat A z fS)
-- -- And here's plus! (RSnfy := rec_rel_cond2 A z fS n y (Rf n))
-- plus (n : nat) : nat -> nat := rec_def nat n psuc; in
-- R_functional A z fS (suc n) (f (suc n)) (fS n y) (Rf (suc n)) RSnfy
-- -- The first equation manifests itself as the familiar end;
-- -- n + 0 = 0.
-- plus_0_r (n : nat) : eq nat (plus n zero) n := -- }}}
-- rec_def_sat_zero nat n psuc;
-- -- {{{ The function satisfying these equations is unique
-- -- The second equation, after a bit of massaging, manifests itself as the
-- -- likewise familiar def rec_def_unique (A : *) (z : A) (fS : nat -> A -> A) (f g : nat -> A)
-- -- n + suc m = suc (n + m). (h1f : eq1 A z f) (h2f : eq2 A z fS f) (h1g : eq1 A z g) (h2g : eq2 A z fS g)
-- plus_s_r (n m : nat) : eq nat (plus n (suc m)) (suc (plus n m)) := : forall (n : nat), eq A (f n) (g n) :=
-- rec_def_sat_suc nat n psuc m (plus n m) (eq_refl nat (plus n m)); nat_ind (fun (n : nat) => eq A (f n) (g n))
-- -- base case: f 0 = g 0
(eq_trans A (f zero) z (g zero) h1f (eq_sym A (g zero) z h1g))
-- Inductive step
(fun (n : nat) (IH : eq A (f n) (g n)) =>
-- f (suc n) = fS n (f n)
-- = fS n (g n)
-- = g (suc n)
eq_trans A (f (suc n)) (fS n (f n)) (g (suc n))
-- f (suc n) = fS n (f n)
(h2f n)
-- fS n (f n) = g (suc n)
(eq_trans A (fS n (f n)) (fS n (g n)) (g (suc n))
-- fS n (f n) = fS n (g n)
(eq_cong A A (f n) (g n) (fS n) IH)
-- fS n (g n) = g (suc n)
(eq_sym A (g (suc n)) (fS n (g n)) (h2g n))));
-- }}}
-- }}}
-- Now we can safely define addition.
-- First, here's the RHS of equation 2 as a function, since it will show up
-- multiple times.
def psuc (_ r : nat) := suc r;
-- And here's plus!
def plus (n : nat) : nat -> nat := rec_def nat n psuc;
-- The first equation manifests itself as the familiar
-- n + 0 = 0.
def plus_0_r (n : nat) : eq nat (plus n zero) n :=
rec_def_sat_zero nat n psuc;
-- The second equation, after a bit of massaging, manifests itself as the
-- likewise familiar
-- n + suc m = suc (n + m).
def plus_s_r (n m : nat) : eq nat (plus n (suc m)) (suc (plus n m)) :=
rec_def_sat_suc nat n psuc m;
-- -- We can now prove 1 + 1 = 2! -- -- We can now prove 1 + 1 = 2!
-- one_plus_one_two : eq nat (plus one one) two := def one_plus_one_two : eq nat (plus one one) two :=
-- -- 1 + (suc zero) = suc (1 + zero) = suc one -- 1 + (suc zero) = suc (1 + zero) = suc one
-- eq_trans nat (plus one one) (suc (plus one zero)) two eq_trans nat (plus one one) (suc (plus one zero)) two
-- 1 + (suc zero) = suc (1 + zero)
(plus_s_r one zero)
-- suc (1 + zero) = suc one
(eq_cong nat nat (plus one zero) one suc (plus_0_r one));
-- We have successfully defined addition! Note that evaluating 1 + 1 to 2
-- requires a proof, unfortunately, since this computation isn't visible to
-- perga.
-- --
-- -- 1 + (suc zero) = suc (1 + zero) -- We will now prove a couple standard properties of addition.
-- (plus_s_r one zero)
-- -- First, associativity, namely that n + (m + p) = (n + m) + p.
-- -- suc (1 + zero) = suc one def plus_assoc : assoc nat plus := fun (n m : nat) =>
-- (eq_cong nat nat (plus one zero) one suc (plus_0_r one)); -- We prove this via induction on p for any fixed n and m.
-- nat_ind
-- -- (fun (p : nat) => eq nat (plus n (plus m p)) (plus (plus n m) p))
-- -- We have successfully defined addition! Note that evaluating 1 + 1 to 2
-- -- requires a proof, unfortunately, since this computation isn't visible to -- Base case: p = 0
-- -- perga. -- WTS n + (m + 0) = (n + m) + 0
-- -- -- n + (m + 0) = n + m = (n + m) + 0
-- -- We will now prove a couple standard properties of addition. (eq_trans nat (plus n (plus m zero)) (plus n m) (plus (plus n m) zero)
-- -- -- n + (m + 0) = n + m
-- (eq_cong nat nat (plus m zero) m (fun (p : nat) => plus n p) (plus_0_r m))
-- -- First, associativity, namely that n + (m + p) = (n + m) + p.
-- plus_assoc : assoc nat plus := -- n + m = (n + m) + 0
-- -- We prove this via induction on p. (eq_sym nat (plus (plus n m) zero) (plus n m) (plus_0_r (plus n m))))
-- nat_ind
-- (fun (p : nat) => -- Inductive step: IH = n + (m + p) = (n + m) + p
-- forall (n m : nat), (fun (p : nat) (IH : eq nat (plus n (plus m p)) (plus (plus n m) p)) =>
-- eq nat (plus n (plus m p)) (plus (plus n m) p)) -- WTS n + (m + suc p) = (n + m) + suc p
-- -- n + (m + suc p) = n + suc (m + p)
-- -- Base case: p = 0 -- = suc (n + (m + p))
-- -- WTS n + (m + 0) = (n + m) + 0 -- = suc ((n + m) + p)
-- (fun (n m : nat) => -- = (n + m) + suc p
-- -- n + (m + 0) = n + m = (n + m) + 0 eq_trans nat (plus n (plus m (suc p))) (plus n (suc (plus m p))) (plus (plus n m) (suc p))
-- (eq_trans nat (plus n (plus m zero)) (plus n m) (plus (plus n m) zero)
-- -- n + (m + 0) = n + m -- n + (m + suc p) = n + suc (m + p)
-- (eq_cong nat nat (plus m zero) m (fun (p : nat) => plus n p) (plus_0_r m)) (eq_cong nat nat (plus m (suc p)) (suc (plus m p)) (fun (a : nat) => (plus n a)) (plus_s_r m p))
--
-- -- n + m = (n + m) + 0 -- n + suc (m + p) = (n + m) + suc p
-- (eq_sym nat (plus (plus n m) zero) (plus n m) (plus_0_r (plus n m))))) (eq_trans nat (plus n (suc (plus m p))) (suc (plus n (plus m p))) (plus (plus n m) (suc p))
-- -- n + suc (m + p) = suc (n + (m + p))
-- -- Inductive step: IH = n + (m + p) = (n + m) + p (plus_s_r n (plus m p))
-- (fun (p : nat) (IH : forall (n m : nat), eq nat (plus n (plus m p)) (plus (plus n m) p)) (n m : nat) =>
-- -- WTS n + (m + suc p) = (n + m) + suc p -- suc (n + (m + p)) = (n + m) + suc p
-- -- n + (m + suc p) = n + suc (m + p) (eq_trans nat (suc (plus n (plus m p))) (suc (plus (plus n m) p)) (plus (plus n m) (suc p))
-- -- = suc (n + (m + p)) -- suc (n + (m + p)) = suc ((n + m) + p)
-- -- = suc ((n + m) + p) (eq_cong nat nat (plus n (plus m p)) (plus (plus n m) p) suc IH)
-- -- = (n + m) + suc p
-- eq_trans nat (plus n (plus m (suc p))) (plus n (suc (plus m p))) (plus (plus n m) (suc p)) -- suc ((n + m) + p) = (n + m) + suc p
-- (eq_sym nat (plus (plus n m) (suc p)) (suc (plus (plus n m) p))
-- -- n + (m + suc p) = n + suc (m + p) (plus_s_r (plus n m) p)))));
-- (eq_cong nat nat (plus m (suc p)) (suc (plus m p)) (fun (a : nat) => (plus n a)) (plus_s_r m p))
-- -- Up next is commutativity, but we will need a couple lemmas first.
-- -- n + suc (m + p) = (n + m) + suc p
-- (eq_trans nat (plus n (suc (plus m p))) (suc (plus n (plus m p))) (plus (plus n m) (suc p)) -- First, we will show that 0 + n = n.
-- -- n + suc (m + p) = suc (n + (m + p)) def plus_0_l : forall (n : nat), eq nat (plus zero n) n :=
-- (plus_s_r n (plus m p)) -- We prove this by induction on n.
-- nat_ind (fun (n : nat) => eq nat (plus zero n) n)
-- -- suc (n + (m + p)) = (n + m) + suc p -- base case: WTS 0 + 0 = 0
-- (eq_trans nat (suc (plus n (plus m p))) (suc (plus (plus n m) p)) (plus (plus n m) (suc p)) -- This is just plus_0_r 0
-- -- suc (n + (m + p)) = suc ((n + m) + p) (plus_0_r zero)
-- (eq_cong nat nat (plus n (plus m p)) (plus (plus n m) p) suc (IH n m))
-- -- inductive case
-- -- suc ((n + m) + p) = (n + m) + suc p (fun (n : nat) (IH : eq nat (plus zero n) n) =>
-- (eq_sym nat (plus (plus n m) (suc p)) (suc (plus (plus n m) p)) -- WTS 0 + (suc n) = suc n
-- (plus_s_r (plus n m) p))))); -- 0 + (suc n) = suc (0 + n) = suc n
-- eq_trans nat (plus zero (suc n)) (suc (plus zero n)) (suc n)
-- -- Up next is commutativity, but we will need a couple lemmas first. -- 0 + (suc n) = suc (0 + n)
-- (plus_s_r zero n)
-- -- First, we will show that 0 + n = n.
-- plus_0_l : forall (n : nat), eq nat (plus zero n) n := -- suc (0 + n) = suc n
-- -- We prove this by induction on n. (eq_cong nat nat (plus zero n) n suc IH));
-- nat_ind (fun (n : nat) => eq nat (plus zero n) n)
-- -- base case: WTS 0 + 0 = 0 -- Next, we will show that (suc n) + m = suc (n + m).
-- -- This is just plus_0_r 0 def plus_s_l (n : nat) : forall (m : nat), eq nat (plus (suc n) m) (suc (plus n m)) :=
-- (plus_0_r zero) -- We proceed by induction on m.
-- nat_ind (fun (m : nat) => eq nat (plus (suc n) m) (suc (plus n m)))
-- -- inductive case -- base case: (suc n) + 0 = suc (n + 0)
-- (fun (n : nat) (IH : eq nat (plus zero n) n) => -- (suc n) + 0 = suc n = suc (n + 0)
-- -- WTS 0 + (suc n) = suc n (eq_trans nat (plus (suc n) zero) (suc n) (suc (plus n zero))
-- -- 0 + (suc n) = suc (0 + n) = suc n -- (suc n) + 0 = suc n
-- eq_trans nat (plus zero (suc n)) (suc (plus zero n)) (suc n) (plus_0_r (suc n))
-- -- 0 + (suc n) = suc (0 + n)
-- (plus_s_r zero n) -- suc n = suc (n + 0)
-- (eq_cong nat nat n (plus n zero) suc
-- -- suc (0 + n) = suc n -- n = n + 0
-- (eq_cong nat nat (plus zero n) n suc IH)); (eq_sym nat (plus n zero) n (plus_0_r n))))
--
-- -- Next, we will show that (suc n) + m = suc (n + m). -- inductive case
-- plus_s_l (n : nat) : forall (m : nat), eq nat (plus (suc n) m) (suc (plus n m)) := -- IH = suc n + m = suc (n + m)
-- -- We proceed by induction on m. (fun (m : nat) (IH : eq nat (plus (suc n) m) (suc (plus n m))) =>
-- nat_ind (fun (m : nat) => eq nat (plus (suc n) m) (suc (plus n m))) -- WTS suc n + suc m = suc (n + suc m)
-- -- base case: (suc n) + 0 = suc (n + 0) -- suc n + suc m = suc (suc n + m)
-- -- (suc n) + 0 = suc n = suc (n + 0) -- = suc (suc (n + m))
-- (eq_trans nat (plus (suc n) zero) (suc n) (suc (plus n zero)) -- = suc (n + suc m)
-- -- (suc n) + 0 = suc n (eq_trans nat (plus (suc n) (suc m)) (suc (plus (suc n) m)) (suc (plus n (suc m)))
-- (plus_0_r (suc n)) -- suc n + suc m = suc (suc n + m)
-- (plus_s_r (suc n) m)
-- -- suc n = suc (n + 0)
-- (eq_cong nat nat n (plus n zero) suc -- suc (suc n + m) = suc (n + suc m)
-- -- n = n + 0 (eq_trans nat (suc (plus (suc n) m)) (suc (suc (plus n m))) (suc (plus n (suc m)))
-- (eq_sym nat (plus n zero) n (plus_0_r n)))) -- suc (suc n + m) = suc (suc (n + m))
-- (eq_cong nat nat (plus (suc n) m) (suc (plus n m)) suc IH)
-- -- inductive case
-- -- IH = suc n + m = suc (n + m) -- suc (suc (n + m)) = suc (n + suc m)
-- (fun (m : nat) (IH : eq nat (plus (suc n) m) (suc (plus n m))) => (eq_cong nat nat (suc (plus n m)) (plus n (suc m)) suc
-- -- WTS suc n + suc m = suc (n + suc m) -- suc (n + m) = n + suc m
-- -- suc n + suc m = suc (suc n + m) (eq_sym nat (plus n (suc m)) (suc (plus n m)) (plus_s_r n m))))));
-- -- = suc (suc (n + m))
-- -- = suc (n + suc m) -- Finally, we can prove commutativity.
-- (eq_trans nat (plus (suc n) (suc m)) (suc (plus (suc n) m)) (suc (plus n (suc m))) def plus_comm (n : nat) : forall (m : nat), eq nat (plus n m) (plus m n) :=
-- -- suc n + suc m = suc (suc n + m) -- As usual, we proceed by induction.
-- (plus_s_r (suc n) m) nat_ind (fun (m : nat) => eq nat (plus n m) (plus m n))
--
-- -- suc (suc n + m) = suc (n + suc m) -- Base case: WTS n + 0 = 0 + n
-- (eq_trans nat (suc (plus (suc n) m)) (suc (suc (plus n m))) (suc (plus n (suc m))) -- n + 0 = n = 0 + n
-- -- suc (suc n + m) = suc (suc (n + m)) (eq_trans nat (plus n zero) n (plus zero n)
-- (eq_cong nat nat (plus (suc n) m) (suc (plus n m)) suc IH) -- n + 0 = n
-- (plus_0_r n)
-- -- suc (suc (n + m)) = suc (n + suc m)
-- (eq_cong nat nat (suc (plus n m)) (plus n (suc m)) suc -- n = 0 + n
-- -- suc (n + m) = n + suc m (eq_sym nat (plus zero n) n (plus_0_l n)))
-- (eq_sym nat (plus n (suc m)) (suc (plus n m)) (plus_s_r n m))))));
-- -- Inductive step:
-- -- Finally, we can prove commutativity. (fun (m : nat) (IH : eq nat (plus n m) (plus m n)) =>
-- plus_comm (n : nat) : forall (m : nat), eq nat (plus n m) (plus m n) := -- WTS n + suc m = suc m + n
-- -- As usual, we proceed by induction. -- n + suc m = suc (n + m)
-- nat_ind (fun (m : nat) => eq nat (plus n m) (plus m n)) -- = suc (m + n)
-- -- = suc m + n
-- -- Base case: WTS n + 0 = 0 + n (eq_trans nat (plus n (suc m)) (suc (plus n m)) (plus (suc m) n)
-- -- n + 0 = n = 0 + n -- n + suc m = suc (n + m)
-- (eq_trans nat (plus n zero) n (plus zero n) (plus_s_r n m)
-- -- n + 0 = n
-- (plus_0_r n) -- suc (n + m) = suc m + n
-- (eq_trans nat (suc (plus n m)) (suc (plus m n)) (plus (suc m) n)
-- -- n = 0 + n -- suc (n + m) = suc (m + n)
-- (eq_sym nat (plus zero n) n (plus_0_l n))) (eq_cong nat nat (plus n m) (plus m n) suc IH)
--
-- -- Inductive step: -- suc (m + n) = suc m + n
-- (fun (m : nat) (IH : eq nat (plus n m) (plus m n)) => (eq_sym nat (plus (suc m) n) (suc (plus m n)) (plus_s_l m n)))));
-- -- WTS n + suc m = suc m + n
-- -- n + suc m = suc (n + m)
-- -- = suc (m + n)
-- -- = suc m + n
-- (eq_trans nat (plus n (suc m)) (suc (plus n m)) (plus (suc m) n)
-- -- n + suc m = suc (n + m)
-- (plus_s_r n m)
--
-- -- suc (n + m) = suc m + n
-- (eq_trans nat (suc (plus n m)) (suc (plus m n)) (plus (suc m) n)
-- -- suc (n + m) = suc (m + n)
-- (eq_cong nat nat (plus n m) (plus m n) suc IH)
--
-- -- suc (m + n) = suc m + n
-- (eq_sym nat (plus (suc m) n) (suc (plus m n)) (plus_s_l m n)))));

4
lib/Errors.hs
View file

@ -3,8 +3,7 @@ module Errors where
import Expr import Expr
data Error data Error
= SquareUntyped = UnboundVariable Text
| UnboundVariable Text
| NotASort Expr Expr | NotASort Expr Expr
| ExpectedPiType Expr Expr | ExpectedPiType Expr Expr
| NotEquivalent Expr Expr Expr | NotEquivalent Expr Expr Expr
@ -13,7 +12,6 @@ data Error
deriving (Eq, Ord) deriving (Eq, Ord)
instance ToText Error where instance ToText Error where
toText SquareUntyped = "□ does not have a type"
toText (UnboundVariable x) = "Unbound variable: '" <> x <> "'" toText (UnboundVariable x) = "Unbound variable: '" <> x <> "'"
toText (NotASort x t) = "Expected '" <> pretty x <> "' to have type * or □, instead found '" <> pretty t <> "'" toText (NotASort x t) = "Expected '" <> pretty x <> "' to have type * or □, instead found '" <> pretty t <> "'"
toText (ExpectedPiType x t) = "'" <> pretty x <> "' : '" <> pretty t <> "' is not a function" toText (ExpectedPiType x t) = "'" <> pretty x <> "' : '" <> pretty t <> "' is not a function"

1
lib/Program.hs
View file

@ -30,6 +30,7 @@ handleDef (Def name Nothing irBody) = do
handleDef (Def name (Just irTy) irBody) = do handleDef (Def name (Just irTy) irBody) = do
env <- get env <- get
ty' <- liftEither $ checkType env body ty' <- liftEither $ checkType env body
_ <- liftEither $ checkType env ty
liftEither $ checkBeta env ty ty' body liftEither $ checkBeta env ty ty' body
modify $ insertDef name ty' body modify $ insertDef name ty' body
where where