Up to index of Isabelle/HOL/HOL-Nominal/Examples
theory CR_Takahashi(* $Id: CR_Takahashi.thy,v 1.6 2007/07/11 09:36:06 berghofe Exp $ *) (* Authors: Christian Urban and Mathilde Arnaud *) (* *) (* A formalisation of the Church-Rosser proof by Masako Takahashi.*) (* This formalisation follows with some very slight exceptions *) (* the version of this proof given by Randy Pollack in the paper: *) (* *) (* Polishing Up the Tait-Martin Löf Proof of the *) (* Church-Rosser Theorem (1995). *) theory CR_Takahashi imports "../Nominal" begin atom_decl name nominal_datatype lam = Var "name" | App "lam" "lam" | Lam "«name»lam" ("Lam [_]._" [100,100] 100) consts subst :: "lam => name => lam => lam" ("_[_::=_]" [100,100,100] 100) nominal_primrec "(Var x)[y::=s] = (if x=y then s else (Var x))" "(App t1 t2)[y::=s] = App (t1[y::=s]) (t2[y::=s])" "x\<sharp>(y,s) ==> (Lam [x].t)[y::=s] = Lam [x].(t[y::=s])" apply(finite_guess)+ apply(rule TrueI)+ apply(simp add: abs_fresh) apply(fresh_guess)+ done section {* Lemmas about Capture-Avoiding Substitution *} lemma subst_eqvt[eqvt]: fixes pi::"name prm" shows "pi•t1[x::=t2] = (pi•t1)[(pi•x)::=(pi•t2)]" by (nominal_induct t1 avoiding: x t2 rule: lam.induct) (auto simp add: perm_bij fresh_atm fresh_bij) lemma forget: shows "x\<sharp>t ==> t[x::=s] = t" by (nominal_induct t avoiding: x s rule: lam.induct) (auto simp add: abs_fresh fresh_atm) lemma fresh_fact: fixes z::"name" shows "z\<sharp>(t,s) ==> z\<sharp>t[y::=s]" by (nominal_induct t avoiding: z y s rule: lam.induct) (auto simp add: abs_fresh fresh_prod fresh_atm) lemma fresh_fact': fixes x::"name" shows "x\<sharp>s ==> x\<sharp>t[x::=s]" by (nominal_induct t avoiding: x s rule: lam.induct) (auto simp add: abs_fresh fresh_atm) lemma substitution_lemma: assumes a: "x≠y" "x\<sharp>u" shows "t[x::=s][y::=u] = t[y::=u][x::=s[y::=u]]" using a by (nominal_induct t avoiding: x y s u rule: lam.induct) (auto simp add: fresh_fact forget) lemma subst_rename: assumes a: "y\<sharp>t" shows "t[x::=s] = ([(y,x)]•t)[y::=s]" using a by (nominal_induct t avoiding: x y s rule: lam.induct) (auto simp add: calc_atm fresh_atm abs_fresh) section {* Beta-Reduction *} inductive "Beta" :: "lam=>lam=>bool" (" _ -->β _" [80,80] 80) where b1[intro]: "t1 -->β t2 ==> App t1 s -->β App t2 s" | b2[intro]: "s1 -->β s2 ==> App t s1 -->β App t s2" | b3[intro]: "t1 -->β t2 ==> Lam [x].t1 -->β Lam [x].t2" | b4[intro]: "App (Lam [x].t) s -->β t[x::=s]" section {* Transitive Closure of Beta *} inductive "Beta_star" :: "lam=>lam=>bool" (" _ -->β* _" [80,80] 80) where bs1[intro]: "t -->β* t" | bs2[intro]: "t -->β s ==> t -->β* s" | bs3[intro,trans]: "[|t1-->β* t2; t2 -->β* t3|] ==> t1 -->β* t3" section {* One-Reduction *} inductive One :: "lam=>lam=>bool" (" _ -->1 _" [80,80] 80) where o1[intro]: "Var x-->1 Var x" | o2[intro]: "[|t1-->1t2; s1-->1s2|] ==> App t1 s1 -->1 App t2 s2" | o3[intro]: "t1-->1t2 ==> Lam [x].t1 -->1 Lam [x].t2" | o4[intro]: "[|x\<sharp>(s1,s2); t1-->1t2; s1-->1s2|] ==> App (Lam [x].t1) s1 -->1 t2[x::=s2]" equivariance One nominal_inductive One by (simp_all add: abs_fresh fresh_fact') lemma One_refl: shows "t -->1 t" by (nominal_induct t rule: lam.induct) (auto) lemma One_subst: assumes a: "t1 -->1 t2" "s1 -->1 s2" shows "t1[x::=s1] -->1 t2[x::=s2]" using a by (nominal_induct t1 t2 avoiding: s1 s2 x rule: One.strong_induct) (auto simp add: substitution_lemma fresh_atm fresh_fact) lemma better_o4_intro: assumes a: "t1 -->1 t2" "s1 -->1 s2" shows "App (Lam [x].t1) s1 -->1 t2[x::=s2]" proof - obtain y::"name" where fs: "y\<sharp>(x,t1,s1,t2,s2)" by (rule exists_fresh, rule fin_supp, blast) have "App (Lam [x].t1) s1 = App (Lam [y].([(y,x)]•t1)) s1" using fs by (auto simp add: lam.inject alpha' fresh_prod fresh_atm) also have "… -->1 ([(y,x)]•t2)[y::=s2]" using fs a by (auto simp add: One.eqvt) also have "… = t2[x::=s2]" using fs by (simp add: subst_rename[symmetric]) finally show "App (Lam [x].t1) s1 -->1 t2[x::=s2]" by simp qed lemma One_preserves_fresh: fixes x :: "name" assumes a: "t -->1 s" shows "x\<sharp>t ==> x\<sharp>s" using a by (nominal_induct t s avoiding: x rule: One.strong_induct) (auto simp add: abs_fresh fresh_atm fresh_fact) lemma One_Var: assumes a: "Var x -->1 M" shows "M = Var x" using a by (erule_tac One.cases) (simp_all) lemma One_Lam: assumes a: "Lam [x].t -->1 s" shows "∃t'. s = Lam [x].t' ∧ t -->1 t'" using a apply(erule_tac One.cases) apply(auto simp add: lam.inject alpha) apply(rule_tac x="[(x,xa)]•t2" in exI) apply(perm_simp add: fresh_left calc_atm One.eqvt One_preserves_fresh) done lemma One_App: assumes a: "App t s -->1 r" shows "(∃t' s'. r = App t' s' ∧ t -->1 t' ∧ s -->1 s') ∨ (∃x p p' s'. r = p'[x::=s'] ∧ t = Lam [x].p ∧ p -->1 p' ∧ s -->1 s' ∧ x\<sharp>(s,s'))" using a by (erule_tac One.cases) (auto simp add: lam.inject) lemma One_Redex: assumes a: "App (Lam [x].t) s -->1 r" shows "(∃t' s'. r = App (Lam [x].t') s' ∧ t -->1 t' ∧ s -->1 s') ∨ (∃t' s'. r = t'[x::=s'] ∧ t -->1 t' ∧ s -->1 s')" using a apply(erule_tac One.cases, simp_all) apply(auto dest: One_Lam simp add: lam.inject)[1] apply(rule disjI2) apply(auto simp add: lam.inject alpha) apply(rule_tac x="[(x,xa)]•t2" in exI) apply(rule_tac x="s2" in exI) apply(simp add: subst_rename One_preserves_fresh One.eqvt) done section {* Transitive Closure of One *} inductive "One_star" :: "lam=>lam=>bool" (" _ -->1* _" [80,80] 80) where os1[intro]: "t -->1* t" | os2[intro]: "t -->1 s ==> t -->1* s" | os3[intro]: "[|t1-->1* t2; t2 -->1* t3|] ==> t1 -->1* t3" section {* Complete Development Reduction *} inductive Dev :: "lam => lam => bool" (" _ -->d _" [80,80]80) where d1[intro]: "Var x -->d Var x" | d2[intro]: "t -->d s ==> Lam [x].t -->d Lam[x].s" | d3[intro]: "[|¬(∃y t'. t1 = Lam [y].t'); t1 -->d t2; s1 -->d s2|] ==> App t1 s1 -->d App t2 s2" | d4[intro]: "[|x\<sharp>(s1,s2); t1 -->d t2; s1 -->d s2|] ==> App (Lam [x].t1) s1 -->d t2[x::=s2]" (* FIXME: needs to be in nominal_inductive *) declare perm_pi_simp[eqvt_force] equivariance Dev nominal_inductive Dev by (simp_all add: abs_fresh fresh_fact') lemma better_d4_intro: assumes a: "t1 -->d t2" "s1 -->d s2" shows "App (Lam [x].t1) s1 -->d t2[x::=s2]" proof - obtain y::"name" where fs: "y\<sharp>(x,t1,s1,t2,s2)" by (rule exists_fresh, rule fin_supp,blast) have "App (Lam [x].t1) s1 = App (Lam [y].([(y,x)]•t1)) s1" using fs by (auto simp add: lam.inject alpha' fresh_prod fresh_atm) also have "… -->d ([(y,x)]•t2)[y::=s2]" using fs a by (auto simp add: Dev.eqvt) also have "… = t2[x::=s2]" using fs by (simp add: subst_rename[symmetric]) finally show "App (Lam [x].t1) s1 -->d t2[x::=s2]" by simp qed lemma Dev_preserves_fresh: fixes x::"name" assumes a: "M-->d N" shows "x\<sharp>M ==> x\<sharp>N" using a by (induct) (auto simp add: abs_fresh fresh_fact fresh_fact') lemma Dev_Lam: assumes a: "Lam [x].M -->d N" shows "∃N'. N = Lam [x].N' ∧ M -->d N'" using a apply(erule_tac Dev.cases) apply(auto simp add: lam.inject alpha) apply(rule_tac x="[(x,xa)]•s" in exI) apply(perm_simp add: fresh_left Dev.eqvt Dev_preserves_fresh) done lemma Development_existence: shows "∃M'. M -->d M'" by (nominal_induct M rule: lam.induct) (auto dest!: Dev_Lam intro: better_d4_intro) lemma Triangle: assumes a: "t -->d t1" "t -->1 t2" shows "t2 -->1 t1" using a by (nominal_induct avoiding: t2 rule: Dev.strong_induct) (auto dest!: One_Var One_App One_Redex One_Lam intro: One_subst) (* Remark: we could here get away with a normal induction and appealing to One_preserves_fresh *) lemma Diamond_for_One: assumes a: "t -->1 t1" "t -->1 t2" shows "∃t3. t2 -->1 t3 ∧ t1 -->1 t3" proof - obtain tc where "t -->d tc" using Development_existence by blast with a have "t2 -->1 tc" and "t1 -->1 tc" by (simp_all add: Triangle) then show "∃t3. t2 -->1 t3 ∧ t1 -->1 t3" by blast qed lemma Rectangle_for_One: assumes a: "t -->1* t1" "t -->1 t2" shows "∃t3. t1 -->1 t3 ∧ t2 -->1* t3" using a Diamond_for_One by (induct arbitrary: t2) (blast)+ lemma CR_for_One_star: assumes a: "t -->1* t1" "t -->1* t2" shows "∃t3. t2 -->1* t3 ∧ t1 -->1* t3" using a Rectangle_for_One by (induct arbitrary: t2) (blast)+ section {* Establishing the Equivalence of Beta-star and One-star *} lemma Beta_Lam_cong: assumes a: "t1 -->β* t2" shows "Lam [x].t1 -->β* Lam [x].t2" using a by (induct) (blast)+ lemma Beta_App_congL: assumes a: "t1 -->β* t2" shows "App t1 s-->β* App t2 s" using a by (induct) (blast)+ lemma Beta_App_congR: assumes a: "s1 -->β* s2" shows "App t s1 -->β* App t s2" using a by (induct) (blast)+ lemma Beta_App_cong: assumes a: "t1 -->β* t2" "s1 -->β* s2" shows "App t1 s1 -->β* App t2 s2" using a by (blast intro: Beta_App_congL Beta_App_congR) lemmas Beta_congs = Beta_Lam_cong Beta_App_cong lemma One_implies_Beta_star: assumes a: "t -->1 s" shows "t -->β* s" using a by (induct) (auto intro!: Beta_congs) lemma One_star_Lam_cong: assumes a: "t1 -->1* t2" shows "Lam [x].t1 -->1* Lam [x].t2" using a by (induct) (auto) lemma One_star_App_congL: assumes a: "t1 -->1* t2" shows "App t1 s-->1* App t2 s" using a by (induct) (auto intro: One_refl) lemma One_star_App_congR: assumes a: "s1 -->1* s2" shows "App t s1 -->1* App t s2" using a by (induct) (auto intro: One_refl) lemmas One_congs = One_star_App_congL One_star_App_congR One_star_Lam_cong lemma Beta_implies_One_star: assumes a: "t1 -->β t2" shows "t1 -->1* t2" using a by (induct) (auto intro: One_refl One_congs better_o4_intro) lemma Beta_star_equals_One_star: shows "t1 -->1* t2 = t1 -->β* t2" proof assume "t1 -->1* t2" then show "t1 -->β* t2" by (induct) (auto intro: One_implies_Beta_star) next assume "t1 -->β* t2" then show "t1 -->1* t2" by (induct) (auto intro: Beta_implies_One_star) qed section {* The Church-Rosser Theorem *} theorem CR_for_Beta_star: assumes a: "t -->β* t1" "t-->β* t2" shows "∃t3. t1 -->β* t3 ∧ t2 -->β* t3" proof - from a have "t -->1* t1" and "t-->1* t2" by (simp_all only: Beta_star_equals_One_star) then have "∃t3. t1 -->1* t3 ∧ t2 -->1* t3" by (rule_tac CR_for_One_star) then show "∃t3. t1 -->β* t3 ∧ t2 -->β* t3" by (simp only: Beta_star_equals_One_star) qed end
lemma subst_eqvt:
pi • t1.0[x::=t2.0] = (pi • t1.0)[(pi • x)::=(pi • t2.0)]
lemma forget:
x \<sharp> t ==> t[x::=s] = t
lemma fresh_fact:
z \<sharp> (t, s) ==> z \<sharp> t[y::=s]
lemma fresh_fact':
x \<sharp> s ==> x \<sharp> t[x::=s]
lemma substitution_lemma:
[| x ≠ y; x \<sharp> u |] ==> t[x::=s][y::=u] = t[y::=u][x::=s[y::=u]]
lemma subst_rename:
y \<sharp> t ==> t[x::=s] = ([(y, x)] • t)[y::=s]
lemma One_refl:
t -->1 t
lemma One_subst:
[| t1.0 -->1 t2.0; s1.0 -->1 s2.0 |] ==> t1.0[x::=s1.0] -->1 t2.0[x::=s2.0]
lemma better_o4_intro:
[| t1.0 -->1 t2.0; s1.0 -->1 s2.0 |]
==> App (Lam [x].t1.0) s1.0 -->1 t2.0[x::=s2.0]
lemma One_preserves_fresh:
[| t -->1 s; x \<sharp> t |] ==> x \<sharp> s
lemma One_Var:
Var x -->1 M ==> M = Var x
lemma One_Lam:
Lam [x].t -->1 s ==> ∃t'. s = Lam [x].t' ∧ t -->1 t'
lemma One_App:
App t s -->1 r
==> (∃t' s'. r = App t' s' ∧ t -->1 t' ∧ s -->1 s') ∨
(∃x p p' s'.
r = p'[x::=s'] ∧
t = Lam [x].p ∧ p -->1 p' ∧ s -->1 s' ∧ x \<sharp> (s, s'))
lemma One_Redex:
App (Lam [x].t) s -->1 r
==> (∃t' s'. r = App (Lam [x].t') s' ∧ t -->1 t' ∧ s -->1 s') ∨
(∃t' s'. r = t'[x::=s'] ∧ t -->1 t' ∧ s -->1 s')
lemma better_d4_intro:
[| t1.0 -->d t2.0; s1.0 -->d s2.0 |]
==> App (Lam [x].t1.0) s1.0 -->d t2.0[x::=s2.0]
lemma Dev_preserves_fresh:
[| M -->d N; x \<sharp> M |] ==> x \<sharp> N
lemma Dev_Lam:
Lam [x].M -->d N ==> ∃N'. N = Lam [x].N' ∧ M -->d N'
lemma Development_existence:
∃M'. M -->d M'
lemma Triangle:
[| t -->d t1.0; t -->1 t2.0 |] ==> t2.0 -->1 t1.0
lemma Diamond_for_One:
[| t -->1 t1.0; t -->1 t2.0 |] ==> ∃t3. t2.0 -->1 t3 ∧ t1.0 -->1 t3
lemma Rectangle_for_One:
[| t -->1* t1.0; t -->1 t2.0 |] ==> ∃t3. t1.0 -->1 t3 ∧ t2.0 -->1* t3
lemma CR_for_One_star:
[| t -->1* t1.0; t -->1* t2.0 |] ==> ∃t3. t2.0 -->1* t3 ∧ t1.0 -->1* t3
lemma Beta_Lam_cong:
t1.0 -->β* t2.0 ==> Lam [x].t1.0 -->β* Lam [x].t2.0
lemma Beta_App_congL:
t1.0 -->β* t2.0 ==> App t1.0 s -->β* App t2.0 s
lemma Beta_App_congR:
s1.0 -->β* s2.0 ==> App t s1.0 -->β* App t s2.0
lemma Beta_App_cong:
[| t1.0 -->β* t2.0; s1.0 -->β* s2.0 |] ==> App t1.0 s1.0 -->β* App t2.0 s2.0
lemma Beta_congs:
t1.0 -->β* t2.0 ==> Lam [x].t1.0 -->β* Lam [x].t2.0
[| t1.0 -->β* t2.0; s1.0 -->β* s2.0 |] ==> App t1.0 s1.0 -->β* App t2.0 s2.0
lemma One_implies_Beta_star:
t -->1 s ==> t -->β* s
lemma One_star_Lam_cong:
t1.0 -->1* t2.0 ==> Lam [x].t1.0 -->1* Lam [x].t2.0
lemma One_star_App_congL:
t1.0 -->1* t2.0 ==> App t1.0 s -->1* App t2.0 s
lemma One_star_App_congR:
s1.0 -->1* s2.0 ==> App t s1.0 -->1* App t s2.0
lemma One_congs:
t1.0 -->1* t2.0 ==> App t1.0 s -->1* App t2.0 s
s1.0 -->1* s2.0 ==> App t s1.0 -->1* App t s2.0
t1.0 -->1* t2.0 ==> Lam [x].t1.0 -->1* Lam [x].t2.0
lemma Beta_implies_One_star:
t1.0 -->β t2.0 ==> t1.0 -->1* t2.0
lemma Beta_star_equals_One_star:
t1.0 -->1* t2.0 = t1.0 -->β* t2.0
theorem CR_for_Beta_star:
[| t -->β* t1.0; t -->β* t2.0 |] ==> ∃t3. t1.0 -->β* t3 ∧ t2.0 -->β* t3