(*                                                    *)
(* Formalisation of the chapter on Logical Relations  *)
(* and a Case Study in Equivalence Checking           *)
(* by Karl Crary from the book on Advanced Topics in  *)
(* Types and Programming Languages, MIT Press 2005    *)

(* The formalisation was done by Julien Narboux and   *)
(* Christian Urban.                                   *)

theory Crary
  imports "../Nominal"
begin

atom_decl name

nominal_datatype ty =
    TBase
  | TUnit
  | Arrow "ty" "ty" ("_\<rightarrow>_" [100,100] 100)

nominal_datatype trm =
    Unit
  | Var "name" ("Var _" [100] 100)
  | Lam "\<guillemotleft>name\<guillemotright>trm" ("Lam [_]._" [100,100] 100)
  | App "trm" "trm" ("App _ _" [110,110] 100)
  | Const "nat"

type_synonym Ctxt  = "(name\<times>ty) list"
type_synonym Subst = "(name\<times>trm) list"

lemma perm_ty[simp]:
  fixes T::"ty"
  and   pi::"name prm"
  shows "pi\<bullet>T = T"
  by (induct T rule: ty.induct) (simp_all)

lemma fresh_ty[simp]:
  fixes x::"name"
  and   T::"ty"
  shows "x\<sharp>T"
  by (simp add: fresh_def supp_def)

lemma ty_cases:
  fixes T::ty
  shows "(\<exists> T\<^sub>1 T\<^sub>2. T=T\<^sub>1\<rightarrow>T\<^sub>2) \<or> T=TUnit \<or> T=TBase"
by (induct T rule:ty.induct) (auto)

instantiation ty :: size
begin

nominal_primrec size_ty
where
  "size (TBase) = 1"
| "size (TUnit) = 1"
| "size (T\<^sub>1\<rightarrow>T\<^sub>2) = size T\<^sub>1 + size T\<^sub>2"
by (rule TrueI)+

instance ..

end

lemma ty_size_greater_zero[simp]:
  fixes T::"ty"
  shows "size T > 0"
by (nominal_induct rule: ty.strong_induct) (simp_all)

section {* Substitutions *}

fun
  lookup :: "Subst \<Rightarrow> name \<Rightarrow> trm"
where
  "lookup [] x        = Var x"
| "lookup ((y,T)#\<theta>) x = (if x=y then T else lookup \<theta> x)"

lemma lookup_eqvt[eqvt]:
  fixes pi::"name prm"
  shows "pi\<bullet>(lookup \<theta> x) = lookup (pi\<bullet>\<theta>) (pi\<bullet>x)"
by (induct \<theta>) (auto simp add: perm_bij)

lemma lookup_fresh:
  fixes z::"name"
  assumes a: "z\<sharp>\<theta>" "z\<sharp>x"
  shows "z\<sharp> lookup \<theta> x"
using a
by (induct rule: lookup.induct)
   (auto simp add: fresh_list_cons)

lemma lookup_fresh':
  assumes a: "z\<sharp>\<theta>"
  shows "lookup \<theta> z = Var z"
using a
by (induct rule: lookup.induct)
   (auto simp add: fresh_list_cons fresh_prod fresh_atm)

nominal_primrec
  psubst :: "Subst \<Rightarrow> trm \<Rightarrow> trm"  ("_<_>" [100,100] 130)
where
  "\<theta><(Var x)> = (lookup \<theta> x)"
| "\<theta><(App t\<^sub>1 t\<^sub>2)> = App \<theta><t\<^sub>1> \<theta><t\<^sub>2>"
| "x\<sharp>\<theta> \<Longrightarrow> \<theta><(Lam [x].t)> = Lam [x].(\<theta><t>)"
| "\<theta><(Const n)> = Const n"
| "\<theta><(Unit)> = Unit"
apply(finite_guess)+
apply(rule TrueI)+
apply(simp add: abs_fresh)+
apply(fresh_guess)+
done

abbreviation
 subst :: "trm \<Rightarrow> name \<Rightarrow> trm \<Rightarrow> trm" ("_[_::=_]" [100,100,100] 100)
where
  "t[x::=t']  \<equiv> ([(x,t')])<t>"

lemma subst[simp]:
  shows "(Var x)[y::=t'] = (if x=y then t' else (Var x))"
  and   "(App t\<^sub>1 t\<^sub>2)[y::=t'] = App (t\<^sub>1[y::=t']) (t\<^sub>2[y::=t'])"
  and   "x\<sharp>(y,t') \<Longrightarrow> (Lam [x].t)[y::=t'] = Lam [x].(t[y::=t'])"
  and   "Const n[y::=t'] = Const n"
  and   "Unit [y::=t'] = Unit"
  by (simp_all add: fresh_list_cons fresh_list_nil)

lemma subst_eqvt[eqvt]:
  fixes pi::"name prm"
  shows "pi\<bullet>(t[x::=t']) = (pi\<bullet>t)[(pi\<bullet>x)::=(pi\<bullet>t')]"
  by (nominal_induct t avoiding: x t' rule: trm.strong_induct)
     (perm_simp add: fresh_bij)+

lemma subst_rename:
  fixes c::"name"
  assumes a: "c\<sharp>t\<^sub>1"
  shows "t\<^sub>1[a::=t\<^sub>2] = ([(c,a)]\<bullet>t\<^sub>1)[c::=t\<^sub>2]"
using a
apply(nominal_induct t\<^sub>1 avoiding: a c t\<^sub>2 rule: trm.strong_induct)
apply(simp add: trm.inject calc_atm fresh_atm abs_fresh perm_nat_def)+
done

lemma fresh_psubst:
  fixes z::"name"
  assumes a: "z\<sharp>t" "z\<sharp>\<theta>"
  shows "z\<sharp>(\<theta><t>)"
using a
by (nominal_induct t avoiding: z \<theta> t rule: trm.strong_induct)
   (auto simp add: abs_fresh lookup_fresh)

lemma fresh_subst'':
  fixes z::"name"
  assumes "z\<sharp>t\<^sub>2"
  shows "z\<sharp>t\<^sub>1[z::=t\<^sub>2]"
using assms
by (nominal_induct t\<^sub>1 avoiding: t\<^sub>2 z rule: trm.strong_induct)
   (auto simp add: abs_fresh fresh_nat fresh_atm)

lemma fresh_subst':
  fixes z::"name"
  assumes "z\<sharp>[y].t\<^sub>1" "z\<sharp>t\<^sub>2"
  shows "z\<sharp>t\<^sub>1[y::=t\<^sub>2]"
using assms
by (nominal_induct t\<^sub>1 avoiding: y t\<^sub>2 z rule: trm.strong_induct)
   (auto simp add: abs_fresh fresh_nat fresh_atm)

lemma fresh_subst:
  fixes z::"name"
  assumes a: "z\<sharp>t\<^sub>1" "z\<sharp>t\<^sub>2"
  shows "z\<sharp>t\<^sub>1[y::=t\<^sub>2]"
using a
by (auto simp add: fresh_subst' abs_fresh)

lemma fresh_psubst_simp:
  assumes "x\<sharp>t"
  shows "((x,u)#\<theta>)<t> = \<theta><t>"
using assms
proof (nominal_induct t avoiding: x u \<theta> rule: trm.strong_induct)
  case (Lam y t x u)
  have fs: "y\<sharp>\<theta>" "y\<sharp>x" "y\<sharp>u" by fact+
  moreover have "x\<sharp> Lam [y].t" by fact
  ultimately have "x\<sharp>t" by (simp add: abs_fresh fresh_atm)
  moreover have ih:"\<And>n T. n\<sharp>t \<Longrightarrow> ((n,T)#\<theta>)<t> = \<theta><t>" by fact
  ultimately have "((x,u)#\<theta>)<t> = \<theta><t>" by auto
  moreover have "((x,u)#\<theta>)<Lam [y].t> = Lam [y].(((x,u)#\<theta>)<t>)" using fs
    by (simp add: fresh_list_cons fresh_prod)
  moreover have " \<theta><Lam [y].t> = Lam [y]. (\<theta><t>)" using fs by simp
  ultimately show "((x,u)#\<theta>)<Lam [y].t> = \<theta><Lam [y].t>" by auto
qed (auto simp add: fresh_atm abs_fresh)

lemma forget:
  fixes x::"name"
  assumes a: "x\<sharp>t"
  shows "t[x::=t'] = t"
  using a
by (nominal_induct t avoiding: x t' rule: trm.strong_induct)
   (auto simp add: fresh_atm abs_fresh)

lemma subst_fun_eq:
  fixes u::trm
  assumes h:"[x].t\<^sub>1 = [y].t\<^sub>2"
  shows "t\<^sub>1[x::=u] = t\<^sub>2[y::=u]"
proof -
  {
    assume "x=y" and "t\<^sub>1=t\<^sub>2"
    then have ?thesis using h by simp
  }
  moreover
  {
    assume h1:"x \<noteq> y" and h2:"t\<^sub>1=[(x,y)] \<bullet> t\<^sub>2" and h3:"x \<sharp> t\<^sub>2"
    then have "([(x,y)] \<bullet> t\<^sub>2)[x::=u] = t\<^sub>2[y::=u]" by (simp add: subst_rename)
    then have ?thesis using h2 by simp
  }
  ultimately show ?thesis using alpha h by blast
qed

lemma psubst_empty[simp]:
  shows "[]<t> = t"
by (nominal_induct t rule: trm.strong_induct)
   (auto simp add: fresh_list_nil)

lemma psubst_subst_psubst:
  assumes h:"c\<sharp>\<theta>"
  shows "\<theta><t>[c::=s] = ((c,s)#\<theta>)<t>"
  using h
by (nominal_induct t avoiding: \<theta> c s rule: trm.strong_induct)
   (auto simp add: fresh_list_cons fresh_atm forget lookup_fresh lookup_fresh' fresh_psubst)

lemma subst_fresh_simp:
  assumes a: "x\<sharp>\<theta>"
  shows "\<theta><Var x> = Var x"
using a
by (induct \<theta> arbitrary: x) (auto simp add:fresh_list_cons fresh_prod fresh_atm)

lemma psubst_subst_propagate:
  assumes "x\<sharp>\<theta>"
  shows "\<theta><t[x::=u]> = \<theta><t>[x::=\<theta><u>]"
using assms
proof (nominal_induct t avoiding: x u \<theta> rule: trm.strong_induct)
  case (Var n x u \<theta>)
  { assume "x=n"
    moreover have "x\<sharp>\<theta>" by fact
    ultimately have "\<theta><Var n[x::=u]> = \<theta><Var n>[x::=\<theta><u>]" using subst_fresh_simp by auto
  }
  moreover
  { assume h:"x\<noteq>n"
    then have "x\<sharp>Var n" by (auto simp add: fresh_atm)
    moreover have "x\<sharp>\<theta>" by fact
    ultimately have "x\<sharp>\<theta><Var n>" using fresh_psubst by blast
    then have " \<theta><Var n>[x::=\<theta><u>] =  \<theta><Var n>" using forget by auto
    then have "\<theta><Var n[x::=u]> = \<theta><Var n>[x::=\<theta><u>]" using h by auto
  }
  ultimately show ?case by auto
next
  case (Lam n t x u \<theta>)
  have fs:"n\<sharp>x" "n\<sharp>u" "n\<sharp>\<theta>" "x\<sharp>\<theta>" by fact+
  have ih:"\<And> y s \<theta>. y\<sharp>\<theta> \<Longrightarrow> ((\<theta><(t[y::=s])>) = ((\<theta><t>)[y::=(\<theta><s>)]))" by fact
  have "\<theta> <(Lam [n].t)[x::=u]> = \<theta><Lam [n]. (t [x::=u])>" using fs by auto
  then have "\<theta> <(Lam [n].t)[x::=u]> = Lam [n]. \<theta><t [x::=u]>" using fs by auto
  moreover have "\<theta><t[x::=u]> = \<theta><t>[x::=\<theta><u>]" using ih fs by blast
  ultimately have "\<theta> <(Lam [n].t)[x::=u]> = Lam [n].(\<theta><t>[x::=\<theta><u>])" by auto
  moreover have "Lam [n].(\<theta><t>[x::=\<theta><u>]) = (Lam [n].\<theta><t>)[x::=\<theta><u>]" using fs fresh_psubst by auto
  ultimately have "\<theta><(Lam [n].t)[x::=u]> = (Lam [n].\<theta><t>)[x::=\<theta><u>]" using fs by auto
  then show "\<theta><(Lam [n].t)[x::=u]> = \<theta><Lam [n].t>[x::=\<theta><u>]" using fs by auto
qed (auto)

section {* Typing *}

inductive
  valid :: "Ctxt \<Rightarrow> bool"
where
  v_nil[intro]:  "valid []"
| v_cons[intro]: "\<lbrakk>valid \<Gamma>;a\<sharp>\<Gamma>\<rbrakk> \<Longrightarrow> valid ((a,T)#\<Gamma>)"

equivariance valid

inductive_cases
  valid_cons_elim_auto[elim]:"valid ((x,T)#\<Gamma>)"

abbreviation
  "sub_context" :: "Ctxt \<Rightarrow> Ctxt \<Rightarrow> bool" (" _ \<subseteq> _ " [55,55] 55)
where
  "\<Gamma>\<^sub>1 \<subseteq> \<Gamma>\<^sub>2 \<equiv> \<forall>a T. (a,T)\<in>set \<Gamma>\<^sub>1 \<longrightarrow> (a,T)\<in>set \<Gamma>\<^sub>2"

lemma valid_monotonicity[elim]:
 fixes \<Gamma> \<Gamma>' :: Ctxt
 assumes a: "\<Gamma> \<subseteq> \<Gamma>'"
 and     b: "x\<sharp>\<Gamma>'"
 shows "(x,T\<^sub>1)#\<Gamma> \<subseteq> (x,T\<^sub>1)#\<Gamma>'"
using a b by auto

lemma fresh_context:
  fixes  \<Gamma> :: "Ctxt"
  and    a :: "name"
  assumes "a\<sharp>\<Gamma>"
  shows "\<not>(\<exists>\<tau>::ty. (a,\<tau>)\<in>set \<Gamma>)"
using assms
by (induct \<Gamma>)
   (auto simp add: fresh_prod fresh_list_cons fresh_atm)

lemma type_unicity_in_context:
  assumes a: "valid \<Gamma>"
  and     b: "(x,T\<^sub>1) \<in> set \<Gamma>"
  and     c: "(x,T\<^sub>2) \<in> set \<Gamma>"
  shows "T\<^sub>1=T\<^sub>2"
using a b c
by (induct \<Gamma>)
   (auto dest!: fresh_context)

inductive
  typing :: "Ctxt\<Rightarrow>trm\<Rightarrow>ty\<Rightarrow>bool" (" _ \<turnstile> _ : _ " [60,60,60] 60)
where
  T_Var[intro]:   "\<lbrakk>valid \<Gamma>; (x,T)\<in>set \<Gamma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Var x : T"
| T_App[intro]:   "\<lbrakk>\<Gamma> \<turnstile> e\<^sub>1 : T\<^sub>1\<rightarrow>T\<^sub>2; \<Gamma> \<turnstile> e\<^sub>2 : T\<^sub>1\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> App e\<^sub>1 e\<^sub>2 : T\<^sub>2"
| T_Lam[intro]:   "\<lbrakk>x\<sharp>\<Gamma>; (x,T\<^sub>1)#\<Gamma> \<turnstile> t : T\<^sub>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Lam [x].t : T\<^sub>1\<rightarrow>T\<^sub>2"
| T_Const[intro]: "valid \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> Const n : TBase"
| T_Unit[intro]:  "valid \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> Unit : TUnit"

equivariance typing

nominal_inductive typing
  by (simp_all add: abs_fresh)

lemma typing_implies_valid:
  assumes a: "\<Gamma> \<turnstile> t : T"
  shows "valid \<Gamma>"
  using a by (induct) (auto)

declare trm.inject [simp add]
declare ty.inject  [simp add]

inductive_cases typing_inv_auto[elim]:
  "\<Gamma> \<turnstile> Lam [x].t : T"
  "\<Gamma> \<turnstile> Var x : T"
  "\<Gamma> \<turnstile> App x y : T"
  "\<Gamma> \<turnstile> Const n : T"
  "\<Gamma> \<turnstile> Unit : TUnit"
  "\<Gamma> \<turnstile> s : TUnit"

declare trm.inject [simp del]
declare ty.inject [simp del]

section {* Definitional Equivalence *}

inductive
  def_equiv :: "Ctxt\<Rightarrow>trm\<Rightarrow>trm\<Rightarrow>ty\<Rightarrow>bool" ("_ \<turnstile> _ \<equiv> _ : _" [60,60] 60)
where
  Q_Refl[intro]:  "\<Gamma> \<turnstile> t : T \<Longrightarrow> \<Gamma> \<turnstile> t \<equiv> t : T"
| Q_Symm[intro]:  "\<Gamma> \<turnstile> t \<equiv> s : T \<Longrightarrow> \<Gamma> \<turnstile> s \<equiv> t : T"
| Q_Trans[intro]: "\<lbrakk>\<Gamma> \<turnstile> s \<equiv> t : T; \<Gamma> \<turnstile> t \<equiv> u : T\<rbrakk> \<Longrightarrow>  \<Gamma> \<turnstile> s \<equiv> u : T"
| Q_Abs[intro]:   "\<lbrakk>x\<sharp>\<Gamma>; (x,T\<^sub>1)#\<Gamma> \<turnstile> s\<^sub>2 \<equiv> t\<^sub>2 : T\<^sub>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Lam [x]. s\<^sub>2 \<equiv>  Lam [x]. t\<^sub>2 : T\<^sub>1 \<rightarrow> T\<^sub>2"
| Q_App[intro]:   "\<lbrakk>\<Gamma> \<turnstile> s\<^sub>1 \<equiv> t\<^sub>1 : T\<^sub>1 \<rightarrow> T\<^sub>2 ; \<Gamma> \<turnstile> s\<^sub>2 \<equiv> t\<^sub>2 : T\<^sub>1\<rbrakk> \<Longrightarrow>  \<Gamma> \<turnstile> App s\<^sub>1 s\<^sub>2 \<equiv> App t\<^sub>1 t\<^sub>2 : T\<^sub>2"
| Q_Beta[intro]:  "\<lbrakk>x\<sharp>(\<Gamma>,s\<^sub>2,t\<^sub>2); (x,T\<^sub>1)#\<Gamma> \<turnstile> s\<^sub>1 \<equiv> t\<^sub>1 : T\<^sub>2 ; \<Gamma> \<turnstile> s\<^sub>2 \<equiv> t\<^sub>2 : T\<^sub>1\<rbrakk>
                   \<Longrightarrow>  \<Gamma> \<turnstile> App (Lam [x]. s\<^sub>1) s\<^sub>2 \<equiv> t\<^sub>1[x::=t\<^sub>2] : T\<^sub>2"
| Q_Ext[intro]:   "\<lbrakk>x\<sharp>(\<Gamma>,s,t); (x,T\<^sub>1)#\<Gamma> \<turnstile> App s (Var x) \<equiv> App t (Var x) : T\<^sub>2\<rbrakk>
                   \<Longrightarrow> \<Gamma> \<turnstile> s \<equiv> t : T\<^sub>1 \<rightarrow> T\<^sub>2"
| Q_Unit[intro]:  "\<lbrakk>\<Gamma> \<turnstile> s : TUnit; \<Gamma> \<turnstile> t: TUnit\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s \<equiv> t : TUnit"

equivariance def_equiv

nominal_inductive def_equiv
  by (simp_all add: abs_fresh fresh_subst'')

lemma def_equiv_implies_valid:
  assumes a: "\<Gamma> \<turnstile> t \<equiv> s : T"
  shows "valid \<Gamma>"
using a by (induct) (auto elim: typing_implies_valid)

section {* Weak Head Reduction *}

inductive
  whr_def :: "trm\<Rightarrow>trm\<Rightarrow>bool" ("_ \<leadsto> _" [80,80] 80)
where
  QAR_Beta[intro]: "App (Lam [x]. t\<^sub>1) t\<^sub>2 \<leadsto> t\<^sub>1[x::=t\<^sub>2]"
| QAR_App[intro]:  "t\<^sub>1 \<leadsto> t\<^sub>1' \<Longrightarrow> App t\<^sub>1 t\<^sub>2 \<leadsto> App t\<^sub>1' t\<^sub>2"

declare trm.inject  [simp add]
declare ty.inject  [simp add]

inductive_cases whr_inv_auto[elim]:
  "t \<leadsto> t'"
  "Lam [x].t \<leadsto> t'"
  "App (Lam [x].t12) t2 \<leadsto> t"
  "Var x \<leadsto> t"
  "Const n \<leadsto> t"
  "App p q \<leadsto> t"
  "t \<leadsto> Const n"
  "t \<leadsto> Var x"
  "t \<leadsto> App p q"

declare trm.inject  [simp del]
declare ty.inject  [simp del]

equivariance whr_def

section {* Weak Head Normalisation *}

abbreviation
 nf :: "trm \<Rightarrow> bool" ("_ \<leadsto>|" [100] 100)
where
  "t\<leadsto>|  \<equiv> \<not>(\<exists> u. t \<leadsto> u)"

inductive
  whn_def :: "trm\<Rightarrow>trm\<Rightarrow>bool" ("_ \<Down> _" [80,80] 80)
where
  QAN_Reduce[intro]: "\<lbrakk>s \<leadsto> t; t \<Down> u\<rbrakk> \<Longrightarrow> s \<Down> u"
| QAN_Normal[intro]: "t\<leadsto>|  \<Longrightarrow> t \<Down> t"

declare trm.inject[simp]

inductive_cases whn_inv_auto[elim]: "t \<Down> t'"

declare trm.inject[simp del]

equivariance whn_def

lemma red_unicity :
  assumes a: "x \<leadsto> a"
  and     b: "x \<leadsto> b"
  shows "a=b"
  using a b
apply (induct arbitrary: b)
apply (erule whr_inv_auto(3))
apply (clarify)
apply (rule subst_fun_eq)
apply (simp)
apply (force)
apply (erule whr_inv_auto(6))
apply (blast)+
done

lemma nf_unicity :
  assumes "x \<Down> a" and "x \<Down> b"
  shows "a=b"
  using assms
proof (induct arbitrary: b)
  case (QAN_Reduce x t a b)
  have h:"x \<leadsto> t" "t \<Down> a" by fact+
  have ih:"\<And>b. t \<Down> b \<Longrightarrow> a = b" by fact
  have "x \<Down> b" by fact
  then obtain t' where "x \<leadsto> t'" and hl:"t' \<Down> b" using h by auto
  then have "t=t'" using h red_unicity by auto
  then show "a=b" using ih hl by auto
qed (auto)

section {* Algorithmic Term Equivalence and Algorithmic Path Equivalence *}

inductive
  alg_equiv :: "Ctxt\<Rightarrow>trm\<Rightarrow>trm\<Rightarrow>ty\<Rightarrow>bool" ("_ \<turnstile> _ \<Leftrightarrow> _ : _" [60,60,60,60] 60)
and
  alg_path_equiv :: "Ctxt\<Rightarrow>trm\<Rightarrow>trm\<Rightarrow>ty\<Rightarrow>bool" ("_ \<turnstile> _ \<leftrightarrow> _ : _" [60,60,60,60] 60)
where
  QAT_Base[intro]:  "\<lbrakk>s \<Down> p; t \<Down> q; \<Gamma> \<turnstile> p \<leftrightarrow> q : TBase\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s \<Leftrightarrow> t : TBase"
| QAT_Arrow[intro]: "\<lbrakk>x\<sharp>(\<Gamma>,s,t); (x,T\<^sub>1)#\<Gamma> \<turnstile> App s (Var x) \<Leftrightarrow> App t (Var x) : T\<^sub>2\<rbrakk>
                     \<Longrightarrow> \<Gamma> \<turnstile> s \<Leftrightarrow> t : T\<^sub>1 \<rightarrow> T\<^sub>2"
| QAT_One[intro]:   "valid \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> s \<Leftrightarrow> t : TUnit"
| QAP_Var[intro]:   "\<lbrakk>valid \<Gamma>;(x,T) \<in> set \<Gamma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Var x \<leftrightarrow> Var x : T"
| QAP_App[intro]:   "\<lbrakk>\<Gamma> \<turnstile> p \<leftrightarrow> q : T\<^sub>1 \<rightarrow> T\<^sub>2; \<Gamma> \<turnstile> s \<Leftrightarrow> t : T\<^sub>1\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> App p s \<leftrightarrow> App q t : T\<^sub>2"
| QAP_Const[intro]: "valid \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> Const n \<leftrightarrow> Const n : TBase"

equivariance alg_equiv

nominal_inductive alg_equiv
  avoids QAT_Arrow: x
  by simp_all

declare trm.inject [simp add]
declare ty.inject  [simp add]

inductive_cases alg_equiv_inv_auto[elim]:
  "\<Gamma> \<turnstile> s\<Leftrightarrow>t : TBase"
  "\<Gamma> \<turnstile> s\<Leftrightarrow>t : T\<^sub>1 \<rightarrow> T\<^sub>2"
  "\<Gamma> \<turnstile> s\<leftrightarrow>t : TBase"
  "\<Gamma> \<turnstile> s\<leftrightarrow>t : TUnit"
  "\<Gamma> \<turnstile> s\<leftrightarrow>t : T\<^sub>1 \<rightarrow> T\<^sub>2"

  "\<Gamma> \<turnstile> Var x \<leftrightarrow> t : T"
  "\<Gamma> \<turnstile> Var x \<leftrightarrow> t : T'"
  "\<Gamma> \<turnstile> s \<leftrightarrow> Var x : T"
  "\<Gamma> \<turnstile> s \<leftrightarrow> Var x : T'"
  "\<Gamma> \<turnstile> Const n \<leftrightarrow> t : T"
  "\<Gamma> \<turnstile> s \<leftrightarrow> Const n : T"
  "\<Gamma> \<turnstile> App p s \<leftrightarrow> t : T"
  "\<Gamma> \<turnstile> s \<leftrightarrow> App q t : T"
  "\<Gamma> \<turnstile> Lam[x].s \<leftrightarrow> t : T"
  "\<Gamma> \<turnstile> t \<leftrightarrow> Lam[x].s : T"

declare trm.inject [simp del]
declare ty.inject [simp del]

lemma Q_Arrow_strong_inversion:
  assumes fs: "x\<sharp>\<Gamma>" "x\<sharp>t" "x\<sharp>u"
  and h: "\<Gamma> \<turnstile> t \<Leftrightarrow> u : T\<^sub>1\<rightarrow>T\<^sub>2"
  shows "(x,T\<^sub>1)#\<Gamma> \<turnstile> App t (Var x) \<Leftrightarrow> App u (Var x) : T\<^sub>2"
proof -
  obtain y where fs2: "y\<sharp>(\<Gamma>,t,u)" and "(y,T\<^sub>1)#\<Gamma> \<turnstile> App t (Var y) \<Leftrightarrow> App u (Var y) : T\<^sub>2"
    using h by auto
  then have "([(x,y)]\<bullet>((y,T\<^sub>1)#\<Gamma>)) \<turnstile> [(x,y)]\<bullet> App t (Var y) \<Leftrightarrow> [(x,y)]\<bullet> App u (Var y) : T\<^sub>2"
    using  alg_equiv.eqvt[simplified] by blast
  then show ?thesis using fs fs2 by (perm_simp)
qed

(*
Warning this lemma is false:

lemma algorithmic_type_unicity:
  shows "\<lbrakk> \<Gamma> \<turnstile> s \<Leftrightarrow> t : T ; \<Gamma> \<turnstile> s \<Leftrightarrow> u : T' \<rbrakk> \<Longrightarrow> T = T'"
  and "\<lbrakk> \<Gamma> \<turnstile> s \<leftrightarrow> t : T ; \<Gamma> \<turnstile> s \<leftrightarrow> u : T' \<rbrakk> \<Longrightarrow> T = T'"

Here is the counter example :
\<Gamma> \<turnstile> Const n \<Leftrightarrow> Const n : Tbase and \<Gamma> \<turnstile> Const n \<Leftrightarrow> Const n : TUnit
*)

lemma algorithmic_path_type_unicity:
  shows "\<Gamma> \<turnstile> s \<leftrightarrow> t : T \<Longrightarrow> \<Gamma> \<turnstile> s \<leftrightarrow> u : T' \<Longrightarrow> T = T'"
proof (induct arbitrary:  u T'
       rule: alg_equiv_alg_path_equiv.inducts(2) [of _ _ _ _ _  "%a b c d . True"    ])
  case (QAP_Var \<Gamma> x T u T')
  have "\<Gamma> \<turnstile> Var x \<leftrightarrow> u : T'" by fact
  then have "u=Var x" and "(x,T') \<in> set \<Gamma>" by auto
  moreover have "valid \<Gamma>" "(x,T) \<in> set \<Gamma>" by fact+
  ultimately show "T=T'" using type_unicity_in_context by auto
next
  case (QAP_App \<Gamma> p q T\<^sub>1 T\<^sub>2 s t u T\<^sub>2')
  have ih:"\<And>u T. \<Gamma> \<turnstile> p \<leftrightarrow> u : T \<Longrightarrow> T\<^sub>1\<rightarrow>T\<^sub>2 = T" by fact
  have "\<Gamma> \<turnstile> App p s \<leftrightarrow> u : T\<^sub>2'" by fact
  then obtain r t T\<^sub>1' where "u = App r t"  "\<Gamma> \<turnstile> p \<leftrightarrow> r : T\<^sub>1' \<rightarrow> T\<^sub>2'" by auto
  with ih have "T\<^sub>1\<rightarrow>T\<^sub>2 = T\<^sub>1' \<rightarrow> T\<^sub>2'" by auto
  then show "T\<^sub>2=T\<^sub>2'" using ty.inject by auto
qed (auto)

lemma alg_path_equiv_implies_valid:
  shows  "\<Gamma> \<turnstile> s \<Leftrightarrow> t : T \<Longrightarrow> valid \<Gamma>"
  and    "\<Gamma> \<turnstile> s \<leftrightarrow> t : T \<Longrightarrow> valid \<Gamma>"
by (induct rule : alg_equiv_alg_path_equiv.inducts) auto

lemma algorithmic_symmetry:
  shows "\<Gamma> \<turnstile> s \<Leftrightarrow> t : T \<Longrightarrow> \<Gamma> \<turnstile> t \<Leftrightarrow> s : T"
  and   "\<Gamma> \<turnstile> s \<leftrightarrow> t : T \<Longrightarrow> \<Gamma> \<turnstile> t \<leftrightarrow> s : T"
by (induct rule: alg_equiv_alg_path_equiv.inducts)
   (auto simp add: fresh_prod)

lemma algorithmic_transitivity:
  shows "\<Gamma> \<turnstile> s \<Leftrightarrow> t : T \<Longrightarrow> \<Gamma> \<turnstile> t \<Leftrightarrow> u : T \<Longrightarrow> \<Gamma> \<turnstile> s \<Leftrightarrow> u : T"
  and   "\<Gamma> \<turnstile> s \<leftrightarrow> t : T \<Longrightarrow> \<Gamma> \<turnstile> t \<leftrightarrow> u : T \<Longrightarrow> \<Gamma> \<turnstile> s \<leftrightarrow> u : T"
proof (nominal_induct \<Gamma> s t T and \<Gamma> s t T avoiding: u rule: alg_equiv_alg_path_equiv.strong_inducts)
  case (QAT_Base s p t q \<Gamma> u)
  have "\<Gamma> \<turnstile> t \<Leftrightarrow> u : TBase" by fact
  then obtain r' q' where b1: "t \<Down> q'" and b2: "u \<Down> r'" and b3: "\<Gamma> \<turnstile> q' \<leftrightarrow> r' : TBase" by auto
  have ih: "\<Gamma> \<turnstile> q \<leftrightarrow> r' : TBase \<Longrightarrow> \<Gamma> \<turnstile> p \<leftrightarrow> r' : TBase" by fact
  have "t \<Down> q" by fact
  with b1 have eq: "q=q'" by (simp add: nf_unicity)
  with ih b3 have "\<Gamma> \<turnstile> p \<leftrightarrow> r' : TBase" by simp
  moreover
  have "s \<Down> p" by fact
  ultimately show "\<Gamma> \<turnstile> s \<Leftrightarrow> u : TBase" using b2 by auto
next
  case (QAT_Arrow  x \<Gamma> s t T\<^sub>1 T\<^sub>2 u)
  have ih:"(x,T\<^sub>1)#\<Gamma> \<turnstile> App t (Var x) \<Leftrightarrow> App u (Var x) : T\<^sub>2
                                   \<Longrightarrow> (x,T\<^sub>1)#\<Gamma> \<turnstile> App s (Var x) \<Leftrightarrow> App u (Var x) : T\<^sub>2" by fact
  have fs: "x\<sharp>\<Gamma>" "x\<sharp>s" "x\<sharp>t" "x\<sharp>u" by fact+
  have "\<Gamma> \<turnstile> t \<Leftrightarrow> u : T\<^sub>1\<rightarrow>T\<^sub>2" by fact
  then have "(x,T\<^sub>1)#\<Gamma> \<turnstile> App t (Var x) \<Leftrightarrow> App u (Var x) : T\<^sub>2" using fs
    by (simp add: Q_Arrow_strong_inversion)
  with ih have "(x,T\<^sub>1)#\<Gamma> \<turnstile> App s (Var x) \<Leftrightarrow> App u (Var x) : T\<^sub>2" by simp
  then show "\<Gamma> \<turnstile> s \<Leftrightarrow> u : T\<^sub>1\<rightarrow>T\<^sub>2" using fs by (auto simp add: fresh_prod)
next
  case (QAP_App \<Gamma> p q T\<^sub>1 T\<^sub>2 s t u)
  have "\<Gamma> \<turnstile> App q t \<leftrightarrow> u : T\<^sub>2" by fact
  then obtain r T\<^sub>1' v where ha: "\<Gamma> \<turnstile> q \<leftrightarrow> r : T\<^sub>1'\<rightarrow>T\<^sub>2" and hb: "\<Gamma> \<turnstile> t \<Leftrightarrow> v : T\<^sub>1'" and eq: "u = App r v"
    by auto
  have ih1: "\<Gamma> \<turnstile> q \<leftrightarrow> r : T\<^sub>1\<rightarrow>T\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> p \<leftrightarrow> r : T\<^sub>1\<rightarrow>T\<^sub>2" by fact
  have ih2:"\<Gamma> \<turnstile> t \<Leftrightarrow> v : T\<^sub>1 \<Longrightarrow> \<Gamma> \<turnstile> s \<Leftrightarrow> v : T\<^sub>1" by fact
  have "\<Gamma> \<turnstile> p \<leftrightarrow> q : T\<^sub>1\<rightarrow>T\<^sub>2" by fact
  then have "\<Gamma> \<turnstile> q \<leftrightarrow> p : T\<^sub>1\<rightarrow>T\<^sub>2" by (simp add: algorithmic_symmetry)
  with ha have "T\<^sub>1'\<rightarrow>T\<^sub>2 = T\<^sub>1\<rightarrow>T\<^sub>2" using algorithmic_path_type_unicity by simp
  then have "T\<^sub>1' = T\<^sub>1" by (simp add: ty.inject)
  then have "\<Gamma> \<turnstile> s \<Leftrightarrow> v : T\<^sub>1" "\<Gamma> \<turnstile> p \<leftrightarrow> r : T\<^sub>1\<rightarrow>T\<^sub>2" using ih1 ih2 ha hb by auto
  then show "\<Gamma> \<turnstile> App p s \<leftrightarrow> u : T\<^sub>2" using eq by auto
qed (auto)

lemma algorithmic_weak_head_closure:
  shows "\<Gamma> \<turnstile> s \<Leftrightarrow> t : T \<Longrightarrow> s' \<leadsto> s \<Longrightarrow> t' \<leadsto> t \<Longrightarrow> \<Gamma> \<turnstile> s' \<Leftrightarrow> t' : T"
apply (nominal_induct \<Gamma> s t T avoiding: s' t'
    rule: alg_equiv_alg_path_equiv.strong_inducts(1) [of _ _ _ _ "%a b c d e. True"])
apply(auto intro!: QAT_Arrow)
done

lemma algorithmic_monotonicity:
  shows "\<Gamma> \<turnstile> s \<Leftrightarrow> t : T \<Longrightarrow> \<Gamma> \<subseteq> \<Gamma>' \<Longrightarrow> valid \<Gamma>' \<Longrightarrow> \<Gamma>' \<turnstile> s \<Leftrightarrow> t : T"
  and   "\<Gamma> \<turnstile> s \<leftrightarrow> t : T \<Longrightarrow> \<Gamma> \<subseteq> \<Gamma>' \<Longrightarrow> valid \<Gamma>' \<Longrightarrow> \<Gamma>' \<turnstile> s \<leftrightarrow> t : T"
proof (nominal_induct \<Gamma> s t T and \<Gamma> s t T avoiding: \<Gamma>' rule: alg_equiv_alg_path_equiv.strong_inducts)
 case (QAT_Arrow x \<Gamma> s t T\<^sub>1 T\<^sub>2 \<Gamma>')
  have fs:"x\<sharp>\<Gamma>" "x\<sharp>s" "x\<sharp>t" "x\<sharp>\<Gamma>'" by fact+
  have h2:"\<Gamma> \<subseteq> \<Gamma>'" by fact
  have ih:"\<And>\<Gamma>'. \<lbrakk>(x,T\<^sub>1)#\<Gamma> \<subseteq> \<Gamma>'; valid \<Gamma>'\<rbrakk>  \<Longrightarrow> \<Gamma>' \<turnstile> App s (Var x) \<Leftrightarrow> App t (Var x) : T\<^sub>2" by fact
  have "valid \<Gamma>'" by fact
  then have "valid ((x,T\<^sub>1)#\<Gamma>')" using fs by auto
  moreover
  have sub: "(x,T\<^sub>1)#\<Gamma> \<subseteq> (x,T\<^sub>1)#\<Gamma>'" using h2 by auto
  ultimately have "(x,T\<^sub>1)#\<Gamma>' \<turnstile> App s (Var x) \<Leftrightarrow> App t (Var x) : T\<^sub>2" using ih by simp
  then show "\<Gamma>' \<turnstile> s \<Leftrightarrow> t : T\<^sub>1\<rightarrow>T\<^sub>2" using fs by (auto simp add: fresh_prod)
qed (auto)

lemma path_equiv_implies_nf:
  assumes "\<Gamma> \<turnstile> s \<leftrightarrow> t : T"
  shows "s \<leadsto>|" and "t \<leadsto>|"
using assms
by (induct rule: alg_equiv_alg_path_equiv.inducts(2)) (simp, auto)

section {* Logical Equivalence *}

function log_equiv :: "(Ctxt \<Rightarrow> trm \<Rightarrow> trm \<Rightarrow> ty \<Rightarrow> bool)" ("_ \<turnstile> _ is _ : _" [60,60,60,60] 60)
where
   "\<Gamma> \<turnstile> s is t : TUnit = True"
 | "\<Gamma> \<turnstile> s is t : TBase = \<Gamma> \<turnstile> s \<Leftrightarrow> t : TBase"
 | "\<Gamma> \<turnstile> s is t : (T\<^sub>1 \<rightarrow> T\<^sub>2) =
    (\<forall>\<Gamma>' s' t'. \<Gamma>\<subseteq>\<Gamma>' \<longrightarrow> valid \<Gamma>' \<longrightarrow> \<Gamma>' \<turnstile> s' is t' : T\<^sub>1 \<longrightarrow>  (\<Gamma>' \<turnstile> (App s s') is (App t t') : T\<^sub>2))"
apply (auto simp add: ty.inject)
apply (subgoal_tac "(\<exists>T\<^sub>1 T\<^sub>2. b=T\<^sub>1 \<rightarrow> T\<^sub>2) \<or> b=TUnit \<or> b=TBase" )
apply (force)
apply (rule ty_cases)
done

termination by lexicographic_order

lemma logical_monotonicity:
 fixes \<Gamma> \<Gamma>' :: Ctxt
 assumes a1: "\<Gamma> \<turnstile> s is t : T"
 and     a2: "\<Gamma> \<subseteq> \<Gamma>'"
 and     a3: "valid \<Gamma>'"
 shows "\<Gamma>' \<turnstile> s is t : T"
using a1 a2 a3
proof (induct arbitrary: \<Gamma>' rule: log_equiv.induct)
  case (2 \<Gamma> s t \<Gamma>')
  then show "\<Gamma>' \<turnstile> s is t : TBase" using algorithmic_monotonicity by auto
next
  case (3 \<Gamma> s t T\<^sub>1 T\<^sub>2 \<Gamma>')
  have "\<Gamma> \<turnstile> s is t : T\<^sub>1\<rightarrow>T\<^sub>2"
  and  "\<Gamma> \<subseteq> \<Gamma>'"
  and  "valid \<Gamma>'" by fact+
  then show "\<Gamma>' \<turnstile> s is t : T\<^sub>1\<rightarrow>T\<^sub>2" by simp
qed (auto)

corollary corollary_main:
  assumes a: "\<Gamma> \<turnstile> s \<leftrightarrow> t : T"
  shows "\<Gamma> \<turnstile> s \<Leftrightarrow> t : T"
using a main_lemma alg_path_equiv_implies_valid by blast

lemma logical_symmetry:
  assumes a: "\<Gamma> \<turnstile> s is t : T"
  shows "\<Gamma> \<turnstile> t is s : T"
using a
by (nominal_induct arbitrary: \<Gamma> s t rule: ty.strong_induct)
   (auto simp add: algorithmic_symmetry)

lemma logical_transitivity:
  assumes "\<Gamma> \<turnstile> s is t : T" "\<Gamma> \<turnstile> t is u : T"
  shows "\<Gamma> \<turnstile> s is u : T"
using assms
proof (nominal_induct arbitrary: \<Gamma> s t u  rule:ty.strong_induct)
  case TBase
  then show "\<Gamma> \<turnstile> s is u : TBase" by (auto elim:  algorithmic_transitivity)
next
  case (Arrow T\<^sub>1 T\<^sub>2 \<Gamma> s t u)
  have h1:"\<Gamma> \<turnstile> s is t : T\<^sub>1 \<rightarrow> T\<^sub>2" by fact
  have h2:"\<Gamma> \<turnstile> t is u : T\<^sub>1 \<rightarrow> T\<^sub>2" by fact
  have ih1:"\<And>\<Gamma> s t u. \<lbrakk>\<Gamma> \<turnstile> s is t : T\<^sub>1; \<Gamma> \<turnstile> t is u : T\<^sub>1\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s is u : T\<^sub>1" by fact
  have ih2:"\<And>\<Gamma> s t u. \<lbrakk>\<Gamma> \<turnstile> s is t : T\<^sub>2; \<Gamma> \<turnstile> t is u : T\<^sub>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s is u : T\<^sub>2" by fact
  {
    fix \<Gamma>' s' u'
    assume hsub:"\<Gamma> \<subseteq> \<Gamma>'" and hl:"\<Gamma>' \<turnstile> s' is u' : T\<^sub>1" and hk: "valid \<Gamma>'"
    then have "\<Gamma>' \<turnstile> u' is s' : T\<^sub>1" using logical_symmetry by blast
    then have "\<Gamma>' \<turnstile> u' is u' : T\<^sub>1" using ih1 hl by blast
    then have "\<Gamma>' \<turnstile> App t u' is App u u' : T\<^sub>2" using h2 hsub hk by auto
    moreover have "\<Gamma>' \<turnstile>  App s s' is App t u' : T\<^sub>2" using h1 hsub hl hk by auto
    ultimately have "\<Gamma>' \<turnstile>  App s s' is App u u' : T\<^sub>2" using ih2 by blast
  }
  then show "\<Gamma> \<turnstile> s is u : T\<^sub>1 \<rightarrow> T\<^sub>2" by auto
qed (auto)

lemma logical_weak_head_closure:
  assumes a: "\<Gamma> \<turnstile> s is t : T"
  and     b: "s' \<leadsto> s"
  and     c: "t' \<leadsto> t"
  shows "\<Gamma> \<turnstile> s' is t' : T"
using a b c algorithmic_weak_head_closure
by (nominal_induct arbitrary: \<Gamma> s t s' t' rule: ty.strong_induct)
   (auto, blast)

lemma logical_weak_head_closure':
  assumes "\<Gamma> \<turnstile> s is t : T" and "s' \<leadsto> s"
  shows "\<Gamma> \<turnstile> s' is t : T"
using assms
proof (nominal_induct arbitrary: \<Gamma> s t s' rule: ty.strong_induct)
  case (TBase  \<Gamma> s t s')
  then show ?case by force
next
  case (TUnit \<Gamma> s t s')
  then show ?case by auto
next
  case (Arrow T\<^sub>1 T\<^sub>2 \<Gamma> s t s')
  have h1:"s' \<leadsto> s" by fact
  have ih:"\<And>\<Gamma> s t s'. \<lbrakk>\<Gamma> \<turnstile> s is t : T\<^sub>2; s' \<leadsto> s\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s' is t : T\<^sub>2" by fact
  have h2:"\<Gamma> \<turnstile> s is t : T\<^sub>1\<rightarrow>T\<^sub>2" by fact
  then
  have hb:"\<forall>\<Gamma>' s' t'. \<Gamma>\<subseteq>\<Gamma>' \<longrightarrow> valid \<Gamma>' \<longrightarrow> \<Gamma>' \<turnstile> s' is t' : T\<^sub>1 \<longrightarrow> (\<Gamma>' \<turnstile> (App s s') is (App t t') : T\<^sub>2)"
    by auto
  {
    fix \<Gamma>' s\<^sub>2 t\<^sub>2
    assume "\<Gamma> \<subseteq> \<Gamma>'" and "\<Gamma>' \<turnstile> s\<^sub>2 is t\<^sub>2 : T\<^sub>1" and "valid \<Gamma>'"
    then have "\<Gamma>' \<turnstile> (App s s\<^sub>2) is (App t t\<^sub>2) : T\<^sub>2" using hb by auto
    moreover have "(App s' s\<^sub>2)  \<leadsto> (App s s\<^sub>2)" using h1 by auto
    ultimately have "\<Gamma>' \<turnstile> App s' s\<^sub>2 is App t t\<^sub>2 : T\<^sub>2" using ih by auto
  }
  then show "\<Gamma> \<turnstile> s' is t : T\<^sub>1\<rightarrow>T\<^sub>2" by auto
qed

abbreviation
 log_equiv_for_psubsts :: "Ctxt \<Rightarrow> Subst \<Rightarrow> Subst \<Rightarrow> Ctxt \<Rightarrow> bool"  ("_ \<turnstile> _ is _ over _" [60,60] 60)
where
  "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma> \<equiv> \<forall>x T. (x,T) \<in> set \<Gamma> \<longrightarrow> \<Gamma>' \<turnstile> \<theta><Var x> is  \<theta>'<Var x> : T"

lemma logical_pseudo_reflexivity:
  assumes "\<Gamma>' \<turnstile> t is s over \<Gamma>"
  shows "\<Gamma>' \<turnstile> s is s over \<Gamma>"
proof -
  from assms have "\<Gamma>' \<turnstile> s is t over \<Gamma>" using logical_symmetry by blast
  with assms show "\<Gamma>' \<turnstile> s is s over \<Gamma>" using logical_transitivity by blast
qed

lemma logical_subst_monotonicity :
  fixes \<Gamma> \<Gamma>' \<Gamma>'' :: Ctxt
  assumes a: "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>"
  and     b: "\<Gamma>' \<subseteq> \<Gamma>''"
  and     c: "valid \<Gamma>''"
  shows "\<Gamma>'' \<turnstile> \<theta> is \<theta>' over \<Gamma>"
using a b c logical_monotonicity by blast

lemma equiv_subst_ext :
  assumes h1: "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>"
  and     h2: "\<Gamma>' \<turnstile> s is t : T"
  and     fs: "x\<sharp>\<Gamma>"
  shows "\<Gamma>' \<turnstile> (x,s)#\<theta> is (x,t)#\<theta>' over (x,T)#\<Gamma>"
using assms
proof -
  {
    fix y U
    assume "(y,U) \<in> set ((x,T)#\<Gamma>)"
    moreover
    {
      assume "(y,U) \<in> set [(x,T)]"
      with h2 have "\<Gamma>' \<turnstile> ((x,s)#\<theta>)<Var y> is ((x,t)#\<theta>')<Var y> : U" by auto
    }
    moreover
    {
      assume hl:"(y,U) \<in> set \<Gamma>"
      then have "\<not> y\<sharp>\<Gamma>" by (induct \<Gamma>) (auto simp add: fresh_list_cons fresh_atm fresh_prod)
      then have hf:"x\<sharp> Var y" using fs by (auto simp add: fresh_atm)
      then have "((x,s)#\<theta>)<Var y> = \<theta><Var y>" "((x,t)#\<theta>')<Var y> = \<theta>'<Var y>"
        using fresh_psubst_simp by blast+
      moreover have  "\<Gamma>' \<turnstile> \<theta><Var y> is \<theta>'<Var y> : U" using h1 hl by auto
      ultimately have "\<Gamma>' \<turnstile> ((x,s)#\<theta>)<Var y> is ((x,t)#\<theta>')<Var y> : U" by auto
    }
    ultimately have "\<Gamma>' \<turnstile> ((x,s)#\<theta>)<Var y> is ((x,t)#\<theta>')<Var y> : U" by auto
  }
  then show "\<Gamma>' \<turnstile> (x,s)#\<theta> is (x,t)#\<theta>' over (x,T)#\<Gamma>" by auto
qed

theorem fundamental_theorem_1:
  assumes a1: "\<Gamma> \<turnstile> t : T"
  and     a2: "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>"
  and     a3: "valid \<Gamma>'"
  shows "\<Gamma>' \<turnstile> \<theta><t> is \<theta>'<t> : T"
using a1 a2 a3
proof (nominal_induct \<Gamma> t T avoiding: \<theta> \<theta>' arbitrary: \<Gamma>' rule: typing.strong_induct)
  case (T_Lam x \<Gamma> T\<^sub>1 t\<^sub>2 T\<^sub>2 \<theta> \<theta>' \<Gamma>')
  have vc: "x\<sharp>\<theta>" "x\<sharp>\<theta>'" "x\<sharp>\<Gamma>" by fact+
  have asm1: "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>" by fact
  have ih:"\<And>\<theta> \<theta>' \<Gamma>'. \<lbrakk>\<Gamma>' \<turnstile> \<theta> is \<theta>' over (x,T\<^sub>1)#\<Gamma>; valid \<Gamma>'\<rbrakk> \<Longrightarrow> \<Gamma>' \<turnstile> \<theta><t\<^sub>2> is \<theta>'<t\<^sub>2> : T\<^sub>2" by fact
  show "\<Gamma>' \<turnstile> \<theta><Lam [x].t\<^sub>2> is \<theta>'<Lam [x].t\<^sub>2> : T\<^sub>1\<rightarrow>T\<^sub>2" using vc
  proof (simp, intro strip)
    fix \<Gamma>'' s' t'
    assume sub: "\<Gamma>' \<subseteq> \<Gamma>''"
    and    asm2: "\<Gamma>''\<turnstile> s' is t' : T\<^sub>1"
    and    val: "valid \<Gamma>''"
    from asm1 val sub have "\<Gamma>'' \<turnstile> \<theta> is \<theta>' over \<Gamma>" using logical_subst_monotonicity by blast
    with asm2 vc have "\<Gamma>'' \<turnstile> (x,s')#\<theta> is (x,t')#\<theta>' over (x,T\<^sub>1)#\<Gamma>" using equiv_subst_ext by blast
    with ih val have "\<Gamma>'' \<turnstile> ((x,s')#\<theta>)<t\<^sub>2> is ((x,t')#\<theta>')<t\<^sub>2> : T\<^sub>2" by auto
    with vc have "\<Gamma>''\<turnstile>\<theta><t\<^sub>2>[x::=s'] is \<theta>'<t\<^sub>2>[x::=t'] : T\<^sub>2" by (simp add: psubst_subst_psubst)
    moreover
    have "App (Lam [x].\<theta><t\<^sub>2>) s' \<leadsto> \<theta><t\<^sub>2>[x::=s']" by auto
    moreover
    have "App (Lam [x].\<theta>'<t\<^sub>2>) t' \<leadsto> \<theta>'<t\<^sub>2>[x::=t']" by auto
    ultimately show "\<Gamma>''\<turnstile> App (Lam [x].\<theta><t\<^sub>2>) s' is App (Lam [x].\<theta>'<t\<^sub>2>) t' : T\<^sub>2"
      using logical_weak_head_closure by auto
  qed
qed (auto)

theorem fundamental_theorem_2:
  assumes h1: "\<Gamma> \<turnstile> s \<equiv> t : T"
  and     h2: "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>"
  and     h3: "valid \<Gamma>'"
  shows "\<Gamma>' \<turnstile> \<theta><s> is \<theta>'<t> : T"
using h1 h2 h3
proof (nominal_induct \<Gamma> s t T avoiding: \<Gamma>' \<theta> \<theta>' rule: def_equiv.strong_induct)
  case (Q_Refl \<Gamma> t T \<Gamma>' \<theta> \<theta>')
  have "\<Gamma> \<turnstile> t : T"
  and  "valid \<Gamma>'" by fact+
  moreover
  have "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>" by fact
  ultimately show "\<Gamma>' \<turnstile> \<theta><t> is \<theta>'<t> : T" using fundamental_theorem_1 by blast
next
  case (Q_Symm \<Gamma> t s T \<Gamma>' \<theta> \<theta>')
  have "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>"
  and "valid \<Gamma>'" by fact+
  moreover
  have ih: "\<And> \<Gamma>' \<theta> \<theta>'. \<lbrakk>\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>; valid \<Gamma>'\<rbrakk> \<Longrightarrow> \<Gamma>' \<turnstile> \<theta><t> is \<theta>'<s> : T" by fact
  ultimately show "\<Gamma>' \<turnstile> \<theta><s> is \<theta>'<t> : T" using logical_symmetry by blast
next
  case (Q_Trans \<Gamma> s t T u \<Gamma>' \<theta> \<theta>')
  have ih1: "\<And> \<Gamma>' \<theta> \<theta>'. \<lbrakk>\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>; valid \<Gamma>'\<rbrakk> \<Longrightarrow> \<Gamma>' \<turnstile> \<theta><s> is \<theta>'<t> : T" by fact
  have ih2: "\<And> \<Gamma>' \<theta> \<theta>'. \<lbrakk>\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>; valid \<Gamma>'\<rbrakk> \<Longrightarrow> \<Gamma>' \<turnstile> \<theta><t> is \<theta>'<u> : T" by fact
  have h: "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>"
  and  v: "valid \<Gamma>'" by fact+
  then have "\<Gamma>' \<turnstile> \<theta>' is \<theta>' over \<Gamma>" using logical_pseudo_reflexivity by auto
  then have "\<Gamma>' \<turnstile> \<theta>'<t> is \<theta>'<u> : T" using ih2 v by auto
  moreover have "\<Gamma>' \<turnstile> \<theta><s> is \<theta>'<t> : T" using ih1 h v by auto
  ultimately show "\<Gamma>' \<turnstile> \<theta><s> is \<theta>'<u> : T" using logical_transitivity by blast
next
  case (Q_Abs x \<Gamma> T\<^sub>1 s\<^sub>2 t\<^sub>2 T\<^sub>2 \<Gamma>' \<theta> \<theta>')
  have fs:"x\<sharp>\<Gamma>" by fact
  have fs2: "x\<sharp>\<theta>" "x\<sharp>\<theta>'" by fact+
  have h2: "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>"
  and  h3: "valid \<Gamma>'" by fact+
  have ih:"\<And>\<Gamma>' \<theta> \<theta>'. \<lbrakk>\<Gamma>' \<turnstile> \<theta> is \<theta>' over (x,T\<^sub>1)#\<Gamma>; valid \<Gamma>'\<rbrakk> \<Longrightarrow> \<Gamma>' \<turnstile> \<theta><s\<^sub>2> is \<theta>'<t\<^sub>2> : T\<^sub>2" by fact
  {
    fix \<Gamma>'' s' t'
    assume "\<Gamma>' \<subseteq> \<Gamma>''" and hl:"\<Gamma>''\<turnstile> s' is t' : T\<^sub>1" and hk: "valid \<Gamma>''"
    then have "\<Gamma>'' \<turnstile> \<theta> is \<theta>' over \<Gamma>" using h2 logical_subst_monotonicity by blast
    then have "\<Gamma>'' \<turnstile> (x,s')#\<theta> is (x,t')#\<theta>' over (x,T\<^sub>1)#\<Gamma>" using equiv_subst_ext hl fs by blast
    then have "\<Gamma>'' \<turnstile> ((x,s')#\<theta>)<s\<^sub>2> is ((x,t')#\<theta>')<t\<^sub>2> : T\<^sub>2" using ih hk by blast
    then have "\<Gamma>''\<turnstile> \<theta><s\<^sub>2>[x::=s'] is \<theta>'<t\<^sub>2>[x::=t'] : T\<^sub>2" using fs2 psubst_subst_psubst by auto
    moreover have "App (Lam [x]. \<theta><s\<^sub>2>) s' \<leadsto>  \<theta><s\<^sub>2>[x::=s']"
              and "App (Lam [x].\<theta>'<t\<^sub>2>) t' \<leadsto> \<theta>'<t\<^sub>2>[x::=t']" by auto
    ultimately have "\<Gamma>'' \<turnstile> App (Lam [x]. \<theta><s\<^sub>2>) s' is App (Lam [x].\<theta>'<t\<^sub>2>) t' : T\<^sub>2"
      using logical_weak_head_closure by auto
  }
  moreover have "valid \<Gamma>'" by fact
  ultimately have "\<Gamma>' \<turnstile> Lam [x].\<theta><s\<^sub>2> is Lam [x].\<theta>'<t\<^sub>2> : T\<^sub>1\<rightarrow>T\<^sub>2" by auto
  then show "\<Gamma>' \<turnstile> \<theta><Lam [x].s\<^sub>2> is \<theta>'<Lam [x].t\<^sub>2> : T\<^sub>1\<rightarrow>T\<^sub>2" using fs2 by auto
next
  case (Q_App \<Gamma> s\<^sub>1 t\<^sub>1 T\<^sub>1 T\<^sub>2 s\<^sub>2 t\<^sub>2 \<Gamma>' \<theta> \<theta>')
  then show "\<Gamma>' \<turnstile> \<theta><App s\<^sub>1 s\<^sub>2> is \<theta>'<App t\<^sub>1 t\<^sub>2> : T\<^sub>2" by auto
next
  case (Q_Beta x \<Gamma> s\<^sub>2 t\<^sub>2 T\<^sub>1 s12 t12 T\<^sub>2 \<Gamma>' \<theta> \<theta>')
  have h: "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>"
  and  h': "valid \<Gamma>'" by fact+
  have fs: "x\<sharp>\<Gamma>" by fact
  have fs2: " x\<sharp>\<theta>" "x\<sharp>\<theta>'" by fact+
  have ih1: "\<And>\<Gamma>' \<theta> \<theta>'. \<lbrakk>\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>; valid \<Gamma>'\<rbrakk> \<Longrightarrow> \<Gamma>' \<turnstile> \<theta><s\<^sub>2> is \<theta>'<t\<^sub>2> : T\<^sub>1" by fact
  have ih2: "\<And>\<Gamma>' \<theta> \<theta>'. \<lbrakk>\<Gamma>' \<turnstile> \<theta> is \<theta>' over (x,T\<^sub>1)#\<Gamma>; valid \<Gamma>'\<rbrakk> \<Longrightarrow> \<Gamma>' \<turnstile> \<theta><s12> is \<theta>'<t12> : T\<^sub>2" by fact
  have "\<Gamma>' \<turnstile> \<theta><s\<^sub>2> is \<theta>'<t\<^sub>2> : T\<^sub>1" using ih1 h' h by auto
  then have "\<Gamma>' \<turnstile> (x,\<theta><s\<^sub>2>)#\<theta> is (x,\<theta>'<t\<^sub>2>)#\<theta>' over (x,T\<^sub>1)#\<Gamma>" using equiv_subst_ext h fs by blast
  then have "\<Gamma>' \<turnstile> ((x,\<theta><s\<^sub>2>)#\<theta>)<s12> is ((x,\<theta>'<t\<^sub>2>)#\<theta>')<t12> : T\<^sub>2" using ih2 h' by auto
  then have "\<Gamma>' \<turnstile> \<theta><s12>[x::=\<theta><s\<^sub>2>] is \<theta>'<t12>[x::=\<theta>'<t\<^sub>2>] : T\<^sub>2" using fs2 psubst_subst_psubst by auto
  then have "\<Gamma>' \<turnstile> \<theta><s12>[x::=\<theta><s\<^sub>2>] is \<theta>'<t12[x::=t\<^sub>2]> : T\<^sub>2" using fs2 psubst_subst_propagate by auto
  moreover have "App (Lam [x].\<theta><s12>) (\<theta><s\<^sub>2>) \<leadsto> \<theta><s12>[x::=\<theta><s\<^sub>2>]" by auto
  ultimately have "\<Gamma>' \<turnstile> App (Lam [x].\<theta><s12>) (\<theta><s\<^sub>2>) is \<theta>'<t12[x::=t\<^sub>2]> : T\<^sub>2"
    using logical_weak_head_closure' by auto
  then show "\<Gamma>' \<turnstile> \<theta><App (Lam [x].s12) s\<^sub>2> is \<theta>'<t12[x::=t\<^sub>2]> : T\<^sub>2" using fs2 by simp
next
  case (Q_Ext x \<Gamma> s t T\<^sub>1 T\<^sub>2 \<Gamma>' \<theta> \<theta>')
  have h2: "\<Gamma>' \<turnstile> \<theta> is \<theta>' over \<Gamma>"
  and  h2': "valid \<Gamma>'" by fact+
  have fs:"x\<sharp>\<Gamma>" "x\<sharp>s" "x\<sharp>t" by fact+
  have ih:"\<And>\<Gamma>' \<theta> \<theta>'. \<lbrakk>\<Gamma>' \<turnstile> \<theta> is \<theta>' over (x,T\<^sub>1)#\<Gamma>; valid \<Gamma>'\<rbrakk>
                          \<Longrightarrow> \<Gamma>' \<turnstile> \<theta><App s (Var x)> is \<theta>'<App t (Var x)> : T\<^sub>2" by fact
   {
    fix \<Gamma>'' s' t'
    assume hsub: "\<Gamma>' \<subseteq> \<Gamma>''" and hl: "\<Gamma>''\<turnstile> s' is t' : T\<^sub>1" and hk: "valid \<Gamma>''"
    then have "\<Gamma>'' \<turnstile> \<theta> is \<theta>' over \<Gamma>" using h2 logical_subst_monotonicity by blast
    then have "\<Gamma>'' \<turnstile> (x,s')#\<theta> is (x,t')#\<theta>' over (x,T\<^sub>1)#\<Gamma>" using equiv_subst_ext hl fs by blast
    then have "\<Gamma>'' \<turnstile> ((x,s')#\<theta>)<App s (Var x)>  is ((x,t')#\<theta>')<App t (Var x)> : T\<^sub>2" using ih hk by blast
    then
    have "\<Gamma>'' \<turnstile> App (((x,s')#\<theta>)<s>) (((x,s')#\<theta>)<(Var x)>) is App (((x,t')#\<theta>')<t>) (((x,t')#\<theta>')<(Var x)>) : T\<^sub>2"
      by auto
    then have "\<Gamma>'' \<turnstile> App ((x,s')#\<theta>)<s> s'  is App ((x,t')#\<theta>')<t> t' : T\<^sub>2" by auto
    then have "\<Gamma>'' \<turnstile> App (\<theta><s>) s' is App (\<theta>'<t>) t' : T\<^sub>2" using fs fresh_psubst_simp by auto
  }
  moreover have "valid \<Gamma>'" by fact
  ultimately show "\<Gamma>' \<turnstile> \<theta><s> is \<theta>'<t> : T\<^sub>1\<rightarrow>T\<^sub>2" by auto
next
  case (Q_Unit \<Gamma> s t \<Gamma>' \<theta> \<theta>')
  then show "\<Gamma>' \<turnstile> \<theta><s> is \<theta>'<t> : TUnit" by auto
qed

theorem completeness:
  assumes asm: "\<Gamma> \<turnstile> s \<equiv> t : T"
  shows   "\<Gamma> \<turnstile> s \<Leftrightarrow> t : T"
proof -
  have val: "valid \<Gamma>" using def_equiv_implies_valid asm by simp
  moreover
  {
    fix x T
    assume "(x,T) \<in> set \<Gamma>" "valid \<Gamma>"
    then have "\<Gamma> \<turnstile> Var x is Var x : T" using main_lemma(2) by blast
  }
  ultimately have "\<Gamma> \<turnstile> [] is [] over \<Gamma>" by auto
  then have "\<Gamma> \<turnstile> []<s> is []<t> : T" using fundamental_theorem_2 val asm by blast
  then have "\<Gamma> \<turnstile> s is t : T" by simp
  then show  "\<Gamma> \<turnstile> s \<Leftrightarrow> t : T" using main_lemma(1) val by simp
qed

text {* We leave soundness as an exercise - just like Crary in the ATS book :-) \\
 @{prop[mode=IfThen] "\<lbrakk>\<Gamma> \<turnstile> s \<Leftrightarrow> t : T; \<Gamma> \<turnstile> t : T; \<Gamma> \<turnstile> s : T\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s \<equiv> t : T"} \\
 @{prop "\<lbrakk>\<Gamma> \<turnstile> s \<leftrightarrow> t : T; \<Gamma> \<turnstile> t : T; \<Gamma> \<turnstile> s : T\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s \<equiv> t : T"}
*}

end


(*   Title: HOL/ex/Erdős_Szekeres.thy
     Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com>
*)

section \<open>The Erdös-Szekeres Theorem\<close>

theory Erdoes_Szekeres
imports MainRLT
begin

lemma exists_set_with_max_card:
  assumes "finite S" "S \<noteq> {}"
  shows "\<exists>s \<in> S. card s = Max (card ` S)"
  by (metis (mono_tags, lifting) Max_in assms finite_imageI imageE image_is_empty)

subsection \<open>Definition of Monotonicity over a Carrier Set\<close>

definition
  "gen_mono_on f R S = (\<forall>i\<in>S. \<forall>j\<in>S. i \<le> j \<longrightarrow> R (f i) (f j))"

lemma gen_mono_on_empty [simp]: "gen_mono_on f R {}"
  unfolding gen_mono_on_def by auto

lemma gen_mono_on_singleton [simp]: "reflp R \<Longrightarrow> gen_mono_on f R {x}"
  unfolding gen_mono_on_def reflp_def by auto

lemma gen_mono_on_subset: "T \<subseteq> S \<Longrightarrow> gen_mono_on f R S \<Longrightarrow> gen_mono_on f R T"
  unfolding gen_mono_on_def by (simp add: subset_iff)

lemma not_gen_mono_on_subset: "T \<subseteq> S \<Longrightarrow> \<not> gen_mono_on f R T \<Longrightarrow> \<not> gen_mono_on f R S"
  unfolding gen_mono_on_def by blast

subsection \<open>The Erdoes-Szekeres Theorem following Seidenberg's (1959) argument\<close>

lemma Erdoes_Szekeres:
  fixes f :: "_ \<Rightarrow> 'a::linorder"
  shows "(\<exists>S. S \<subseteq> {0..m * n} \<and> card S = m + 1 \<and> gen_mono_on f (\<le>) S) \<or>
         (\<exists>S. S \<subseteq> {0..m * n} \<and> card S = n + 1 \<and> gen_mono_on f (\<ge>) S)"
proof (rule ccontr)
  let ?max_subseq = "\<lambda>R k. Max (card ` {S. S \<subseteq> {0..k} \<and> gen_mono_on f R S \<and> k \<in> S})"
  define phi where "phi k = (?max_subseq (\<le>) k, ?max_subseq (\<ge>) k)" for k

  have one_member: "\<And>R k. reflp R \<Longrightarrow> {k} \<in> {S. S \<subseteq> {0..k} \<and> gen_mono_on f R S \<and> k \<in> S}" by auto

  {
    fix R
    assume reflp: "reflp (R :: 'a::linorder \<Rightarrow> _)"
    from one_member[OF this] have non_empty: "\<And>k. {S. S \<subseteq> {0..k} \<and> gen_mono_on f R S \<and> k \<in> S} \<noteq> {}" by force
    from one_member[OF reflp] have "\<And>k. card {k} \<in> card ` {S. S \<subseteq> {0..k} \<and> gen_mono_on f R S \<and> k \<in> S}" by blast
    from this have lower_bound: "\<And>k. k \<le> m * n \<Longrightarrow> ?max_subseq R k \<ge> 1"
      by (auto intro!: Max_ge)

    fix b
    assume not_mono_at: "\<forall>S. S \<subseteq> {0..m * n} \<and> card S = b + 1 \<longrightarrow> \<not> gen_mono_on f R S"

    {
      fix S
      assume "S \<subseteq> {0..m * n}" "card S \<ge> b + 1"
      moreover from \<open>card S \<ge> b + 1\<close> obtain T where "T \<subseteq> S \<and> card T = Suc b"
        using obtain_subset_with_card_n by (metis Suc_eq_plus1)
      ultimately have "\<not> gen_mono_on f R S" using not_mono_at by (auto dest: not_gen_mono_on_subset)
    }
    from this have "\<forall>S. S \<subseteq> {0..m * n} \<and> gen_mono_on f R S \<longrightarrow> card S \<le> b"
      by (metis Suc_eq_plus1 Suc_leI not_le)
    from this have "\<And>k. k \<le> m * n \<Longrightarrow> \<forall>S. S \<subseteq> {0..k} \<and> gen_mono_on f R S \<longrightarrow> card S \<le> b"
      using order_trans by force
    from this non_empty have upper_bound: "\<And>k. k \<le> m * n \<Longrightarrow> ?max_subseq R k \<le> b"
      by (auto intro: Max.boundedI)

    from upper_bound lower_bound have "\<And>k. k \<le> m * n \<Longrightarrow> 1 \<le> ?max_subseq R k \<and> ?max_subseq R k \<le> b"
      by auto
  } note bounds = this

  assume contraposition: "\<not> ?thesis"
  from contraposition bounds[of "(\<le>)" "m"] bounds[of "(\<ge>)" "n"]
    have "\<And>k. k \<le> m * n \<Longrightarrow> 1 \<le> ?max_subseq (\<le>) k \<and> ?max_subseq (\<le>) k \<le> m"
    and  "\<And>k. k \<le> m * n \<Longrightarrow> 1 \<le> ?max_subseq (\<ge>) k \<and> ?max_subseq (\<ge>) k \<le> n"
    using reflp_def by simp+
  from this have "\<forall>i \<in> {0..m * n}. phi i \<in> {1..m} \<times> {1..n}"
    unfolding phi_def by auto
  from this have subseteq: "phi ` {0..m * n} \<subseteq> {1..m} \<times> {1..n}" by blast
  have card_product: "card ({1..m} \<times> {1..n}) = m * n" by (simp add: card_cartesian_product)
  have "finite ({1..m} \<times> {1..n})" by blast
  from subseteq card_product this have card_le: "card (phi ` {0..m * n}) \<le> m * n" by (metis card_mono)

  {
    fix i j
    assume "i < (j :: nat)"
    {
      fix R
      assume R: "reflp (R :: 'a::linorder \<Rightarrow> _)" "transp R" "R (f i) (f j)"
      from one_member[OF \<open>reflp R\<close>, of "i"] have
        "\<exists>S \<in> {S. S \<subseteq> {0..i} \<and> gen_mono_on f R S \<and> i \<in> S}. card S = ?max_subseq R i"
        by (intro exists_set_with_max_card) auto
      from this obtain S where S: "S \<subseteq> {0..i} \<and> gen_mono_on f R S \<and> i \<in> S" "card S = ?max_subseq R i" by auto
      from S \<open>i < j\<close> finite_subset have "j \<notin> S" "finite S" "insert j S \<subseteq> {0..j}" by auto
      from S(1) R \<open>i < j\<close> this have "gen_mono_on f R (insert j S)"
        unfolding gen_mono_on_def reflp_def transp_def
        by (metis atLeastAtMost_iff insert_iff le_antisym subsetCE)
      from this have d: "insert j S \<in> {S. S \<subseteq> {0..j} \<and> gen_mono_on f R S \<and> j \<in> S}"
        using \<open>insert j S \<subseteq> {0..j}\<close> by blast
      from this \<open>j \<notin> S\<close> S(1) have "card (insert j S) \<in>
        card ` {S. S \<subseteq> {0..j} \<and> gen_mono_on f R S \<and> j \<in> S} \<and> card S < card (insert j S)"
        by (auto intro!: imageI) (auto simp add: \<open>finite S\<close>)
      from this S(2) have "?max_subseq R i < ?max_subseq R j" by (auto intro!: Max_gr_iff [THEN iffD2])
    } note max_subseq_increase = this
    have "?max_subseq (\<le>) i < ?max_subseq (\<le>) j \<or> ?max_subseq (\<ge>) i < ?max_subseq (\<ge>) j"
    proof (cases "f j \<ge> f i")
      case True
      from this max_subseq_increase[of "(\<le>)", simplified] show ?thesis by simp
    next
      case False
      from this max_subseq_increase[of "(\<ge>)", simplified] show ?thesis by simp
    qed
    from this have "phi i \<noteq> phi j" using phi_def by auto
  }
  from this have "inj phi" unfolding inj_on_def by (metis less_linear)
  from this have card_eq: "card (phi ` {0..m * n}) = m * n + 1" by (simp add: card_image inj_on_def)
  from card_le card_eq show False by simp
qed

end


(*
  File: EquivRel.thy
  Author: Bohua Zhan

  Basics of equivalence relations and quotient sets, including the three
  isomorphism theorems on sets.
*)

theory EquivRel
  imports Coverings
begin

section \<open>Equivalence structures\<close>

definition "equiv_graph_name = succ(succ(\<emptyset>))"
definition "equiv_graph(S) = graph_eval(S, equiv_graph_name)"
setup {* add_field_data (@{term equiv_graph_name}, @{term equiv_graph}) *}

definition rawequiv :: "i \<Rightarrow> o" where [rewrite]:
  "rawequiv(R) \<longleftrightarrow>
    is_func_graph(R,{carrier_name,equiv_graph_name}) \<and> equiv_graph(R) \<in> Pow(carrier(R)\<times>carrier(R))"

lemma rawequiv_graph_is_graph [forward]:
  "rawequiv(R) \<Longrightarrow> is_graph(equiv_graph(R))" by auto2

(* Space of all rawequiv on S *)
definition rawequiv_space :: "i \<Rightarrow> i" where [rewrite]:
  "rawequiv_space(S) = {Struct({\<langle>carrier_name,S\<rangle>, \<langle>equiv_graph_name,G\<rangle>}). G\<in>Pow(S\<times>S)}"

lemma rawequiv_spaceD [forward]:
  "R \<in> rawequiv_space(S) \<Longrightarrow> rawequiv(R) \<and> carrier(R) = S" by auto2

lemma rawequiv_spaceI [resolve]:
  "rawequiv(R) \<Longrightarrow> R \<in> rawequiv_space(carrier(R))" by auto2

(* Constructor for equivalence *)
definition Equiv :: "i \<Rightarrow> (i \<Rightarrow> i \<Rightarrow> o) \<Rightarrow> i" where [rewrite]:
  "Equiv(S,R) = Struct({\<langle>carrier_name,S\<rangle>, \<langle>equiv_graph_name, rel_graph(S,R)\<rangle>})"

lemma Equiv_is_rawequiv [typing]: "Equiv(S,R) \<in> rawequiv_space(S)" by auto2

(* Evaluation of equiv *)
definition eq_sim :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o" ("(_/ \<sim>\<^sub>_ _)" [51,51,51] 50) where [rewrite_bidir]:
  "x \<sim>\<^sub>R y \<longleftrightarrow> \<langle>x,y\<rangle> \<in> equiv_graph(R)"
setup {* register_wellform_data ("x \<sim>\<^sub>R y", ["x \<in>. R", "y \<in>. R"]) *}

lemma Equiv_eval [rewrite]:
  "R = Equiv(S,f) \<Longrightarrow> x \<sim>\<^sub>R y \<longleftrightarrow> (x \<in> S \<and> y \<in> S \<and> f(x,y))" by auto2

lemma rawequivD [forward]:
  "rawequiv(R) \<Longrightarrow> x \<sim>\<^sub>R y \<Longrightarrow> x \<in>. R \<and> y \<in>. R" by auto2

(* Equality on equivalences *)
lemma equiv_eq [backward]:
  "rawequiv(R) \<Longrightarrow> rawequiv(S) \<Longrightarrow> carrier(R) = carrier(S) \<Longrightarrow>
   \<forall>x y. x \<sim>\<^sub>R y \<longleftrightarrow> x \<sim>\<^sub>S y \<Longrightarrow> R = S" by auto2

setup {* fold del_prfstep_thm [
  @{thm rawequiv_def}, @{thm rawequiv_space_def}, @{thm Equiv_def}, @{thm eq_sim_def}] *}

section \<open>Equivalence relation\<close>  (* Bourbaki II.6.1 *)

(* Self-contained condition for equiv. *)
definition equiv :: "i \<Rightarrow> o" where [rewrite]:
  "equiv(R) \<longleftrightarrow>
    rawequiv(R) \<and>
    (\<forall>x\<in>.R. x \<sim>\<^sub>R x) \<and>
    (\<forall>x y. x \<sim>\<^sub>R y \<longrightarrow> y \<sim>\<^sub>R x) \<and>
    (\<forall>x y z. x \<sim>\<^sub>R y \<longrightarrow> y \<sim>\<^sub>R z \<longrightarrow> x \<sim>\<^sub>R z)"

lemma equivD:
  "equiv(R) \<Longrightarrow> rawequiv(R)"
  "equiv(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> x \<sim>\<^sub>R x"
  "equiv(R) \<Longrightarrow> x \<sim>\<^sub>R y \<longleftrightarrow> y \<sim>\<^sub>R x"
  "equiv(R) \<Longrightarrow> x \<sim>\<^sub>R y \<Longrightarrow> y \<sim>\<^sub>R z \<Longrightarrow> x \<sim>\<^sub>R z" by auto2+
setup {* add_forward_prfstep @{thm equivD(1)} *}
setup {* add_backward_prfstep @{thm equivD(2)} *}
setup {* add_rewrite_rule @{thm equivD(3)} *}
setup {* add_forward_prfstep_cond @{thm equivD(4)} [with_cond "?x \<noteq> ?z"] *}
setup {* del_prfstep_thm_eqforward @{thm equiv_def} *}

definition equiv_space :: "i \<Rightarrow> i" where [rewrite]:
  "equiv_space(S) = {R\<in>rawequiv_space(S). equiv(R)}"

lemma equiv_spaceD [forward]:
  "R \<in> equiv_space(S) \<Longrightarrow> equiv(R) \<and> carrier(R) = S" by auto2

lemma equiv_spaceI [backward]:
  "equiv(R) \<Longrightarrow> R \<in> equiv_space(carrier(R))" by auto2
setup {* del_prfstep_thm @{thm equiv_space_def} *}

section \<open>Quotient construction\<close>  (* Bourbaki II.6.2 *)

(* Equivalence relation induced by a function *)
definition fun_equiv :: "i \<Rightarrow> i" where [rewrite]:
  "fun_equiv(f) = Equiv(source(f), \<lambda>x y. f`x = f`y)"

lemma fun_equiv_is_equiv [typing]:
  "fun_equiv(f) \<in> equiv_space(source(f))" by auto2

lemma fun_equiv_eval [rewrite]:
  "R = fun_equiv(f) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> x \<sim>\<^sub>R y \<longleftrightarrow> f`x = f`y" by auto2
setup {* del_prfstep_thm @{thm fun_equiv_def} *}

(* Definition of quotient set as set of equivalence classes. *)
definition equiv_class :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "equiv_class(R,x) = {y\<in>.R. x \<sim>\<^sub>R y}"
setup {* register_wellform_data ("equiv_class(R,x)", ["x \<in>. R"]) *}

lemma equiv_class_iff [rewrite]:
  "equiv(R) \<Longrightarrow> y \<in> equiv_class(R,x) \<longleftrightarrow> (y \<in>. R \<and> x \<sim>\<^sub>R y)" by auto2
setup {* del_prfstep_thm @{thm equiv_class_def} *}

lemma equiv_class_mem [typing2]: "equiv(R) \<Longrightarrow> x \<sim>\<^sub>R y \<Longrightarrow> y \<in> equiv_class(R,x)" by auto2

lemma equiv_class_eq [rewrite]:
  "equiv(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> equiv_class(R,x) = equiv_class(R,y) \<longleftrightarrow> x \<sim>\<^sub>R y"
@proof @have "x \<sim>\<^sub>R x" @qed

(* Usually E = carrier(R) *)
definition quotient_set :: "[i, i] \<Rightarrow> i"  (infixl "'/'/" 90) where [rewrite]:
  "E // R = {equiv_class(R,x). x\<in>E}"

lemma quotient_setI [typing, backward]:
  "y \<in>. R \<Longrightarrow> equiv_class(R,y) \<in> carrier(R)//R" by auto2

lemma quotient_set_union [rewrite]:
  "equiv(R) \<Longrightarrow> \<Union>(carrier(R)//R) = carrier(R)" by auto2

(* Choose a representative for x, under the equivalence relation R. *)
definition rep :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "rep(R,x) = Choice(x)"
setup {* register_wellform_data ("rep(R,x)", ["x \<in> carrier(R)//R"]) *}

lemma rep_in_set [typing]: "equiv(R) \<Longrightarrow> x \<in> carrier(R)//R \<Longrightarrow> rep(R,x) \<in>. R" by auto2

lemma equiv_class_of_rep: "equiv(R) \<Longrightarrow> x \<in> carrier(R)//R \<Longrightarrow> equiv_class(R,rep(R,x)) = x" by auto2
setup {* add_forward_prfstep_cond @{thm equiv_class_of_rep} [with_term "rep(?R,?x)"] *}

lemma rep_in_equiv_class: "equiv(R) \<Longrightarrow> y \<in>. R \<Longrightarrow> rep(R,equiv_class(R,y)) \<sim>\<^sub>R y" by auto2
setup {* add_forward_prfstep_cond @{thm rep_in_equiv_class} [with_term "rep(?R,equiv_class(?R,?y))"] *}

setup {* fold del_prfstep_thm [@{thm rep_def}, @{thm quotient_set_def}] *}

(* Definition of canonical surjection *)
definition qsurj :: "i \<Rightarrow> i" where [rewrite]:
  "qsurj(R) = Fun(carrier(R), carrier(R)//R, \<lambda>x. equiv_class(R,x))"

lemma qsurj_is_fun [typing]: "qsurj(R) \<in> carrier(R) \<rightarrow> carrier(R)//R" by auto2

lemma qsurj_is_surj [forward]: "equiv(R) \<Longrightarrow> surjective(qsurj(R))"
@proof @have (@rule) "\<forall>x\<in>carrier(R)//R. qsurj(R)`rep(R,x) = x" @qed

lemma qsurj_eval [rewrite]:
  "x \<in> source(qsurj(R)) \<Longrightarrow> qsurj(R)`x = equiv_class(R,x)" by auto2
setup {* del_prfstep_thm @{thm qsurj_def} *}

lemma qsurj_eq_iff1:
  "equiv(R) \<Longrightarrow> x \<sim>\<^sub>R y \<Longrightarrow> qsurj(R)`x = qsurj(R)`y" by auto2
setup {* add_rewrite_rule_cond @{thm qsurj_eq_iff1} [with_cond "?x \<noteq> ?y"] *}

lemma qsurj_eq_iff2:
  "equiv(R) \<Longrightarrow> x \<in> source(qsurj(R)) \<Longrightarrow> y \<in> source(qsurj(R)) \<Longrightarrow>
   qsurj(R)`x = qsurj(R)`y \<Longrightarrow> x \<sim>\<^sub>R y" by auto2
setup {* add_forward_prfstep_cond @{thm qsurj_eq_iff2} [with_cond "?x \<noteq> ?y", with_filt (order_filter "x" "y")] *}

(* We show that every equivalence relation is induced by some function. *)
lemma qsurj_equiv: "equiv(R) \<Longrightarrow> R = fun_equiv(qsurj(R))" by auto2

(* Examples *)
definition eq_equiv :: "i \<Rightarrow> i" where [rewrite]:
  "eq_equiv(E) = Equiv(E, \<lambda>x y. x = y)"

lemma eq_equiv_is_equiv [typing]: "eq_equiv(E) \<in> equiv_space(E)" by auto2

lemma qsurj_triv_bij: "qsurj(eq_equiv(E)) \<in> E \<cong> E//eq_equiv(E)" by auto2

definition eq_fst_rel :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "eq_fst_rel(E,F) = Equiv(E\<times>F, \<lambda>u v. fst(u) = fst(v))"

lemma eq_fst_rel_is_equiv [typing]: "eq_fst_rel(E,F) \<in> equiv_space(E\<times>F)" by auto2

lemma eq_fst_rel_eval [rewrite]:
  "R = eq_fst_rel(E,F) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> x \<sim>\<^sub>R y \<longleftrightarrow> fst(x) = fst(y)" by auto2
setup {* del_prfstep_thm @{thm eq_fst_rel_def} *}

(* Elements of quotient form a partition. Conversely, every partition is a quotient set. *)
lemma equiv_class_disjoint [backward]:
  "equiv(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> \<not>x \<sim>\<^sub>R y \<Longrightarrow>
   equiv_class(R,x) \<inter> equiv_class(R,y) = \<emptyset>" by auto2

lemma equiv_classes_is_partition:
  "equiv(R) \<Longrightarrow> is_partition_sets(carrier(R),carrier(R)//R)"
@proof @have (@rule) "\<forall>x\<in>carrier(R)//R. x = equiv_class(R,rep(R,x))" @qed

lemma partition_mem_unique [backward]:
  "mutually_disjoint_sets(X) \<Longrightarrow> a \<in> \<Union>X \<Longrightarrow> \<exists>!x. x \<in> X \<and> a \<in> x" by auto2

definition partition_mem :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "partition_mem(X,u) = (THE x. x \<in> X \<and> u \<in> x)"

definition partition_equiv :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "partition_equiv(X,u,v) \<longleftrightarrow> (u \<in> \<Union>X \<and> v \<in> \<Union>X \<and> (partition_mem(X,u) = partition_mem(X,u)))"

section \<open>Predicate compatible with an equivalence relation\<close>  (* Bourbaki II.6.3 *)

definition compat_pred :: "[i \<Rightarrow> o, i] \<Rightarrow> o" where [rewrite]:
  "compat_pred(P,R) \<longleftrightarrow> (\<forall>x y. P(x) \<longrightarrow> x \<sim>\<^sub>R y \<longrightarrow> P(y))"

lemma compat_relD [forward]:
  "compat_pred(P,R) \<Longrightarrow> x \<sim>\<^sub>R y \<Longrightarrow> P(x) \<longrightarrow> P(y)" by auto2
setup {* del_prfstep_thm_eqforward @{thm compat_pred_def} *}

(* Example *)
lemma compat_pred_eq_equiv: "compat_pred(P, eq_equiv(E))" by auto2

(* Given a equivalence relation R on E, can induce a predicate on E//R *)
definition induced_pred :: "[i \<Rightarrow> o, i, i] \<Rightarrow> o" where [rewrite]:
  "induced_pred(P,R,t) \<longleftrightarrow> (t \<in> carrier(R)//R \<and> (\<exists>x\<in>t. P(x)))"

lemma induced_pred_iff:
  "equiv(R) \<Longrightarrow> x \<in> source(qsurj(R)) \<Longrightarrow> compat_pred(P,R) \<Longrightarrow>
   induced_pred(P,R,qsurj(R)`x) \<longleftrightarrow> P(x)" by auto2

section \<open>Saturated subsets\<close>  (* Bourbaki II.6.4 *)

definition saturated_subset :: "[i, i] \<Rightarrow> o" where [rewrite]:
  "saturated_subset(R,A) \<longleftrightarrow> (A \<subseteq> carrier(R) \<and> compat_pred(\<lambda>x. x\<in>A, R))"

lemma saturated_subset_iff:
  "equiv(R) \<Longrightarrow> saturated_subset(R,A) \<longleftrightarrow> (A \<subseteq> carrier(R) \<and> (\<forall>x\<in>A. equiv_class(R,x) \<subseteq> A))" by auto2

lemma saturated_subset_iff2:
  "equiv(R) \<Longrightarrow> saturated_subset(R,A) \<longleftrightarrow> (A \<subseteq> carrier(R) \<and> A = (\<Union>x\<in>A. equiv_class(R,x)))" by auto2

lemma equiv_class_alt:
  "equiv(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> equiv_class(R,x) = qsurj(R) -`` {qsurj(R) ` x}" by auto2

lemma saturated_subset_alt [resolve]:
  "equiv(R) \<Longrightarrow> saturated_subset(R,A) \<longleftrightarrow> A = qsurj(R) -`` (qsurj(R) `` A)" by auto2

(* Put above lemma into a form that is good for rewriting. *)
lemma saturated_subset_alt' [rewrite]:
  "equiv(R) \<Longrightarrow> saturated_subset(R,A) \<Longrightarrow> qsurj(R) -`` (qsurj(R) `` A) = A" by auto2

lemma saturated_subset_alt2:
  "equiv(R) \<Longrightarrow> saturated_subset(R,A) \<longleftrightarrow> (\<exists>B. B \<subseteq> carrier(R)//R \<and> A = qsurj(R) -`` B)"
@proof @have "saturated_subset(R,A) \<longleftrightarrow> A = qsurj(R) -`` (qsurj(R) `` A)" @qed

lemma saturated_subset_union [backward]:
  "equiv(R) \<Longrightarrow> \<forall>a\<in>I. saturated_subset(R,X(a)) \<Longrightarrow> saturated_subset(R,\<Union>a\<in>I. X(a))" by auto2

lemma saturated_subset_inter [backward]:
  "equiv(R) \<Longrightarrow> I \<noteq> \<emptyset> \<Longrightarrow> \<forall>a\<in>I. saturated_subset(R,X(a)) \<Longrightarrow> saturated_subset(R,\<Inter>a\<in>I. X(a))" by auto2

lemma saturated_subset_comp [backward]:
  "equiv(R) \<Longrightarrow> saturated_subset(R,A) \<Longrightarrow> saturated_subset(R,carrier(R) \<midarrow> A)" by auto2

definition saturation_subset :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "saturation_subset(R,A) = (qsurj(R) -`` (qsurj(R) `` A))"

lemma saturation_subset_prop1:
  "equiv(R) \<Longrightarrow> A \<subseteq> carrier(R) \<Longrightarrow> A \<subseteq> saturation_subset(R,A)" by auto2

lemma saturation_subset_prop2:
  "equiv(R) \<Longrightarrow> saturated_subset(R,A') \<Longrightarrow> A \<subseteq> A' \<Longrightarrow> saturation_subset(R,A) \<subseteq> A'" by auto2

(* Alternative definition *)
lemma saturation_subset_alt [resolve]:
  "equiv(R) \<Longrightarrow> saturation_subset(R,A) = (\<Union>x\<in>A. equiv_class(R,x))" by auto2

lemma saturation_subset_union:
  "equiv(R) \<Longrightarrow> saturation_subset(R,\<Union>a\<in>I. X(a)) = (\<Union>a\<in>I. saturation_subset(R,X(a)))" by auto2

section \<open>Mappings compatible with an equivalence relation\<close>  (* Bourbaki II.6.5 *)

definition compat_fun :: "[i, i] \<Rightarrow> o" where [rewrite]:
  "compat_fun(f,R) \<longleftrightarrow> (source(f) = carrier(R) \<and> (\<forall>x y. x \<sim>\<^sub>R y \<longrightarrow> f`x = f`y))"

lemma compat_funD [forward]:
  "compat_fun(f,R) \<Longrightarrow> source(f) = carrier(R)"
  "compat_fun(f,R) \<Longrightarrow> x \<sim>\<^sub>R y \<Longrightarrow> f`x = f`y" by auto2+
setup {* del_prfstep_thm_eqforward @{thm compat_fun_def} *}

(* Alternative definition *)
lemma compat_fun_alt:
  "is_function(f) \<Longrightarrow> equiv(R) \<Longrightarrow>
   compat_fun(f,R) \<longleftrightarrow> (source(f) = carrier(R) \<and> (\<forall>x\<in>source(f). \<forall>y\<in>equiv_class(R,x). f`x = f`y))" by auto2

(* Compatible functions pass to the quotient. *)
lemma exists_induced_fun [backward]:
  "equiv(R) \<Longrightarrow> f \<in> E \<rightarrow> F \<Longrightarrow> compat_fun(f,R) \<Longrightarrow> \<exists>!h. h\<in>(E//R)\<rightarrow>F \<and> f = h \<circ> qsurj(R)"
@proof @have "\<forall>x\<in>E. \<forall>y\<in>E. qsurj(R)`x = qsurj(R)`y \<longrightarrow> f`x = f`y" @qed

definition induced_fun :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "induced_fun(f,R) = (THE h. h \<in> (source(f)//R)\<rightarrow>target(f) \<and> f = h \<circ> qsurj(R))"
setup {* register_wellform_data ("induced_fun(f,R)", ["compat_fun(f,R)"]) *}
setup {* add_prfstep_check_req ("induced_fun(f,R)", "compat_fun(f,R)") *}

lemma induced_fun_prop:
  "func_form(f) \<Longrightarrow> equiv(R) \<Longrightarrow> compat_fun(f,R) \<Longrightarrow>
   induced_fun(f,R) \<in> (source(f)//R)\<rightarrow>target(f) \<and> f = induced_fun(f,R) \<circ> qsurj(R)" by auto2
setup {* add_forward_prfstep_cond @{thm induced_fun_prop} [with_term "induced_fun(?f,?R)"] *}

lemma induced_fun_eval [rewrite]:
  "func_form(f) \<Longrightarrow> equiv(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> compat_fun(f,R) \<Longrightarrow>
   induced_fun(f,R) ` equiv_class(R,x) = f ` x" by auto2
setup {* del_prfstep_thm @{thm induced_fun_def} *}

(* Conversely, any function that passes to the quotient must be compatible. *)
lemma induced_fun_means_compat:
  "equiv(R) \<Longrightarrow> h \<in> (carrier(R)//R)\<rightarrow>F \<Longrightarrow> compat_fun(h \<circ> qsurj(R), R)" by auto2

(* f is compatible with its own induced equivalence relation. *)
lemma fun_equiv_compat: "compat_fun(f,fun_equiv(f))" by auto2
setup {* add_forward_prfstep_cond @{thm fun_equiv_compat} [with_term "fun_equiv(?f)"] *}

(* Canonical decomposition. *)
lemma injective_induced_fun:
  "func_form(f) \<Longrightarrow> g = induced_fun(f,fun_equiv(f)) \<Longrightarrow> injective(g)"
@proof
  @have "\<forall>x\<in>source(g). \<forall>y\<in>source(g). g`x = g`y \<longrightarrow> x = y" @with
    @let "x = rep(fun_equiv(f),x)" "y' = rep(fun_equiv(f),y)"
  @end
@qed
setup {* add_forward_prfstep_cond @{thm injective_induced_fun} [with_term "induced_fun(?f,fun_equiv(?f))"] *}

(* Putting everything together, statement of canonical decomposition. *)
lemma canonical_decomposition:
  "f \<in> E \<rightarrow> F \<Longrightarrow> R = fun_equiv(f) \<Longrightarrow> f' = induced_fun(f,R) \<Longrightarrow>
   f = (inj_fun(f'``(E//R),F) \<circ> func_restrict_image(f')) \<circ> qsurj(R)" by auto2

lemma first_isomorphism_theorem [typing]:
  "func_form(f) \<Longrightarrow> A = source(f) \<Longrightarrow> R = fun_equiv(f) \<Longrightarrow>
   func_restrict_image(induced_fun(f,R)) \<in> A//R \<cong> f``A"
@proof
  @let "i = induced_fun(f,R)"
  @let "g = func_restrict_image(induced_fun(f,R))"
  @have "\<forall>z\<in>i``source(i). z \<in> f``A" @with
    @obtain "y\<in>source(g)" where "g`y = z"
    @obtain "x\<in>source(qsurj(R))" where "qsurj(R)`x = y"
  @end
@qed

lemma first_isomorphism_theorem_surj [typing]:
  "func_form(f) \<Longrightarrow> surjective(f) \<Longrightarrow> A = source(f) \<Longrightarrow> R = fun_equiv(f) \<Longrightarrow>
   induced_fun(f,R) \<in> A//R \<cong> target(f)" by auto2

definition compat_fun_double :: "[i, i, i] \<Rightarrow> o" where [rewrite]:
  "compat_fun_double(f,R,S) \<longleftrightarrow> (source(f) = carrier(R) \<and> target(f) = carrier(S) \<and>
    (\<forall>x y. x \<sim>\<^sub>R y \<longrightarrow> f`x \<sim>\<^sub>S f`y))"

definition induced_fun_double :: "[i, i, i] \<Rightarrow> i" where [rewrite]:
  "induced_fun_double(f,R,S) = induced_fun(qsurj(S) \<circ> f, R)"

lemma induced_fun_double_prop:
  "is_function(f) \<Longrightarrow> equiv(R) \<Longrightarrow> equiv(S) \<Longrightarrow> compat_fun_double(f,R,S) \<Longrightarrow>
   induced_fun_double(f,R,S) \<in> source(f)//R \<rightarrow> target(f)//S \<and>
   qsurj(S) \<circ> f = induced_fun_double(f,R,S) \<circ> qsurj(R)" by auto2

section \<open>Inverse image of an equivalence relation\<close>  (* Bourbaki II.6.6 *)

definition vImage_equiv :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "vImage_equiv(f,S) = fun_equiv(qsurj(S) \<circ> f)"
setup {* register_wellform_data ("vImage_equiv(f,S)", ["target(f) = carrier(S)"]) *}

lemma vImage_equiv_is_equiv:
  "is_function(f) \<Longrightarrow> equiv(S) \<Longrightarrow> target(f) = carrier(S) \<Longrightarrow>
   equiv(vImage_equiv(f,S)) \<and> carrier(vImage_equiv(f,S)) = source(f)" by auto2
setup {* add_forward_prfstep_cond @{thm vImage_equiv_is_equiv} [with_term "vImage_equiv(?f,?S)"] *}

lemma vImage_equiv_iff [rewrite]:
  "is_function(f) \<Longrightarrow> equiv(S) \<Longrightarrow> target(f) = carrier(S) \<Longrightarrow>
   R = vImage_equiv(f,S) \<Longrightarrow> x \<in> source(f) \<Longrightarrow> y \<in> source(f) \<Longrightarrow> x \<sim>\<^sub>R y \<longleftrightarrow> f`x \<sim>\<^sub>S f`y" by auto2

lemma vImage_equiv_classes:
  "is_function(f) \<Longrightarrow> equiv(S) \<Longrightarrow> target(f) = carrier(S) \<Longrightarrow>
   x \<in> source(f) \<Longrightarrow> equiv_class(vImage_equiv(f,S),x) = f -`` equiv_class(S,f`x)" by auto2

(* Given subset A of E, pullback an equivalence relation R on E to an equivalence
   relation on A. *)
definition subset_equiv :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "subset_equiv(R,A) = vImage_equiv(inj_fun(A,carrier(R)),R)"

lemma inj_compat_double:
  "equiv(R) \<Longrightarrow> E = carrier(R) \<Longrightarrow> A \<subseteq> E \<Longrightarrow>
   compat_fun_double(inj_fun(A,E),subset_equiv(R,A),R)" by auto2

lemma second_isomorphism_theorem:
  "E = carrier(R) \<Longrightarrow> A \<subseteq> E \<Longrightarrow> R_A = subset_equiv(R,A) \<Longrightarrow>
   func_restrict_image(induced_fun_double(inj_fun(A,E),R_A,R)) \<in> A//R_A \<cong> qsurj(R) `` A"
@proof
  @let "f = induced_fun_double(inj_fun(A,E),R_A,R)"
  @have "\<forall>x. x \<in> image(f) \<longleftrightarrow> x \<in> qsurj(R) `` A" @with
    @case "x \<in> qsurj(R) `` A" @with
      @obtain "y \<in> A" where "qsurj(R)`y = x"
      @have "f`equiv_class(R_A,y) = x"
    @end
    @case "x \<in> image(f)" @with
      @obtain "y \<in> source(f)" where "f`y = x"
      @let "y' = rep(R_A,y)"
    @end
  @end
@qed

section \<open>Quotients of equivalence relations\<close>  (* Bourbaki II.6.7 *)

(* Finer condition can be defined on all relations *)
definition finer_rel :: "[i, i] \<Rightarrow> o" where [rewrite]:
  "finer_rel(R,S) \<longleftrightarrow> (carrier(R) = carrier(S) \<and> (\<forall>x y. x \<sim>\<^sub>R y \<longrightarrow> x \<sim>\<^sub>S y))"

(* Exercises *)
lemma finer_equiv1:
  "equiv(R) \<Longrightarrow> equiv(S) \<Longrightarrow> finer_rel(R,S) \<longleftrightarrow>
   (carrier(R) = carrier(S) \<and> (\<forall>x\<in>.R. equiv_class(R,x) \<subseteq> equiv_class(S,x)))" by auto2

lemma finer_equiv2:
  "equiv(R) \<Longrightarrow> equiv(S) \<Longrightarrow> finer_rel(R,S) \<longleftrightarrow>
   (carrier(R) = carrier(S) \<and> (\<forall>x\<in>.R. saturated_subset(R,equiv_class(S,x))))" by auto2

lemma finer_equiv_top:
  "equiv(R) \<Longrightarrow> finer_rel(eq_equiv(carrier(R)), R)" by auto2

lemma finer_equiv_bottom:
  "equiv(R) \<Longrightarrow> finer_rel(R, Equiv(carrier(R), \<lambda>x y. True))" by auto2

(* Now the serious business of this section *)

(* Assume R and S are equivalence relations on the same set, and S is finer than R. *)
definition quotient_rel :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "quotient_rel(R,S) = fun_equiv(induced_fun(qsurj(R),S))"

lemma compat_finer_equiv:
  "equiv(R) \<Longrightarrow> equiv(S) \<Longrightarrow> finer_rel(S,R) \<Longrightarrow>
   compat_fun(qsurj(R),S) \<and> induced_fun(qsurj(R),S) \<in> carrier(R)//S \<rightarrow> carrier(R)//R \<and>
   surjective(induced_fun(qsurj(R),S))" by auto2
setup {* add_forward_prfstep_cond @{thm compat_finer_equiv} [with_term "induced_fun(qsurj(?R),?S)"] *}

lemma finer_induced_fun_eval [rewrite]:
  "equiv(R) \<Longrightarrow> equiv(S) \<Longrightarrow> x \<in>. S \<Longrightarrow> finer_rel(S,R) \<Longrightarrow>
   induced_fun(qsurj(R),S) ` equiv_class(S,x) = equiv_class(R,x)" by auto2

lemma quotient_rel_iff [rewrite_back]:
  "equiv(R) \<Longrightarrow> equiv(S) \<Longrightarrow> x\<in>source(qsurj(S)) \<Longrightarrow> y\<in>source(qsurj(S)) \<Longrightarrow> finer_rel(S,R) \<Longrightarrow>
   Q = quotient_rel(R,S) \<Longrightarrow> x \<sim>\<^sub>R y \<longleftrightarrow> qsurj(S)`x \<sim>\<^sub>Q qsurj(S)`y" by auto2

definition third_isomorphism :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "third_isomorphism(R,S) = induced_fun(induced_fun(qsurj(R),S),quotient_rel(R,S))"

lemma third_isomorphism_theorem:
  "equiv(R) \<Longrightarrow> equiv(S) \<Longrightarrow> finer_rel(S,R) \<Longrightarrow>
   third_isomorphism(R,S) \<in> (carrier(R)//S)//(quotient_rel(R,S)) \<cong> carrier(R)//R" by auto2

(* Given an equivalence relation S on E, and an equivalence relation T on E//S,
   the pullback of T on the surjection E \<rightarrow> E//S is an equivalence relation on E coarser than S. *)
lemma vImage_finer [resolve]:
  "equiv(S) \<Longrightarrow> equiv(T) \<Longrightarrow> target(qsurj(S)) = carrier(T) \<Longrightarrow>
   finer_rel(S,vImage_equiv(qsurj(S),T))" by auto2

(* Any equivalence relation T on E//S is the quotient between a coarser equivalence relation R and S. *)
lemma equiv_is_quotient_rel:
  "equiv(S) \<Longrightarrow> equiv(T) \<Longrightarrow> carrier(T) = carrier(S)//S \<Longrightarrow> T = quotient_rel(vImage_equiv(qsurj(S),T),S)"
@proof
  @have "finer_rel(S,vImage_equiv(qsurj(S),T))"
  @have (@rule) "\<forall>y\<in>target(qsurj(S)). \<exists>x\<in>source(qsurj(S)). qsurj(S)`x = y"
@qed

section \<open>Product of two equivalence relations\<close>  (* Bourbaki II.6.8 *)

definition prod_equiv :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "prod_equiv(R,S) = Equiv(carrier(R)\<times>carrier(S), \<lambda>p q. fst(p) \<sim>\<^sub>R fst(q) \<and> snd(p) \<sim>\<^sub>S snd(q))"

lemma prod_equivD [typing]:
  "equiv(R) \<Longrightarrow> equiv(S) \<Longrightarrow> prod_equiv(R,S) \<in> equiv_space(carrier(R)\<times>carrier(S))" by auto2

lemma prod_equiv_eval [rewrite]:
  "T = prod_equiv(R,S) \<Longrightarrow> x \<in>. T \<Longrightarrow> y \<in>. T \<Longrightarrow> x \<sim>\<^sub>T y \<longleftrightarrow> (fst(x) \<sim>\<^sub>R fst(y) \<and> snd(x) \<sim>\<^sub>S snd(y))" by auto2
setup {* del_prfstep_thm @{thm prod_equiv_def} *}

lemma prod_fun_equiv [rewrite]:
  "equiv(R) \<Longrightarrow> equiv(S) \<Longrightarrow> fun_equiv(qsurj(R) \<times>\<^sub>f qsurj(S)) = prod_equiv(R,S)" by auto2

definition prod_quotient_isomorphism :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "prod_quotient_isomorphism(R,S) = induced_fun(qsurj(R) \<times>\<^sub>f qsurj(S), prod_equiv(R,S))"

lemma prod_quotient_isomorphism:
  "equiv(R) \<Longrightarrow> equiv(S) \<Longrightarrow> A = carrier(R) \<Longrightarrow> B = carrier(S) \<Longrightarrow>
   prod_quotient_isomorphism(R,S) \<in> (A\<times>B)//prod_equiv(R,S) \<cong> (A//R) \<times> (B//S)"
@proof
  @have "surjective(qsurj(R) \<times>\<^sub>f qsurj(S))"
  @have "fun_equiv(qsurj(R) \<times>\<^sub>f qsurj(S)) = prod_equiv(R,S)"
@qed

section \<open>Compatible binary operators\<close>

(* A (meta) binary operator is compatible with a (object) equivalence relation. *)
definition compat_meta_bin :: "[i, i \<Rightarrow> i \<Rightarrow> i] \<Rightarrow> o" where [rewrite]:
  "compat_meta_bin(R,f) \<longleftrightarrow> (\<forall>x1 x2 y1 y2. x1 \<sim>\<^sub>R x2 \<longrightarrow> y1 \<sim>\<^sub>R y2 \<longrightarrow> f(x1,y1) \<sim>\<^sub>R f(x2,y2))"

(* Compatibility can be shown one argument at a time. *)
definition compat_meta_bin1 :: "[i, i \<Rightarrow> i \<Rightarrow> i] \<Rightarrow> o" where [rewrite]:
  "compat_meta_bin1(R,f) \<longleftrightarrow> (\<forall>y\<in>.R. \<forall>x1 x2. x1 \<sim>\<^sub>R x2 \<longrightarrow> f(x1,y) \<sim>\<^sub>R f(x2,y))"

lemma compat_meta_bin1D [backward2]:
  "compat_meta_bin1(R,f) \<Longrightarrow> y \<in>. R \<Longrightarrow> x1 \<sim>\<^sub>R x2 \<Longrightarrow> f(x1,y) \<sim>\<^sub>R f(x2,y)" by auto2
setup {* del_prfstep_thm_eqforward @{thm compat_meta_bin1_def} *}

definition compat_meta_bin2 :: "[i, i \<Rightarrow> i \<Rightarrow> i] \<Rightarrow> o" where [rewrite]:
  "compat_meta_bin2(R,f) \<longleftrightarrow> (\<forall>x\<in>.R. \<forall>y1 y2. y1 \<sim>\<^sub>R y2 \<longrightarrow> f(x,y1) \<sim>\<^sub>R f(x,y2))"

lemma compat_meta_bin2D [backward2]:
  "compat_meta_bin2(R,f) \<Longrightarrow> x \<in>. R \<Longrightarrow> y1 \<sim>\<^sub>R y2 \<Longrightarrow> f(x,y1) \<sim>\<^sub>R f(x,y2)" by auto2
setup {* del_prfstep_thm_eqforward @{thm compat_meta_bin2_def} *}

lemma compat_meta_binI [backward]:
  "equiv(R) \<Longrightarrow> compat_meta_bin1(R,f) \<Longrightarrow> compat_meta_bin2(R,f) \<Longrightarrow> compat_meta_bin(R,f)"
@proof
  @have "\<forall>x1 x2 y1 y2. x1 \<sim>\<^sub>R x2 \<longrightarrow> y1 \<sim>\<^sub>R y2 \<longrightarrow> f(x1,y1) \<sim>\<^sub>R f(x2,y2)" @with
    @have "f(x1,y1) \<sim>\<^sub>R f(x2,y1)" @have "f(x2,y1) \<sim>\<^sub>R f(x2,y2)" @end
@qed

lemma compat_meta_binD [backward2]:
  "compat_meta_bin(R,f) \<Longrightarrow> x1 \<sim>\<^sub>R x2 \<Longrightarrow> y1 \<sim>\<^sub>R y2 \<Longrightarrow> f(x1,y1) \<sim>\<^sub>R f(x2,y2)" by auto2
setup {* del_prfstep_thm @{thm compat_meta_bin_def} *}

(* If the (meta) binary operator f is compatible with R, then f induces a binary
   operator on the quotient of R. *)
lemma induced_meta_bin [rewrite]:
  "equiv(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> compat_meta_bin(R,f) \<Longrightarrow>
   equiv_class(R,f(rep(R,equiv_class(R,x)),rep(R,equiv_class(R,y)))) = equiv_class(R,f(x,y))"
@proof @have "f(rep(R, equiv_class(R, x)), rep(R, equiv_class(R, y))) \<sim>\<^sub>R f(x,y)" @qed

end


(*  Title:      HOL/Archimedean_Field.thy
    Author:     Brian Huffman
*)

section {* Archimedean Fields, Floor and Ceiling Functions *}

theory Archimedean_Field
imports Main
begin

subsection {* Class of Archimedean fields *}

text {* Archimedean fields have no infinite elements. *}

class archimedean_field = linordered_field +
  assumes ex_le_of_int: "\<exists>z. x \<le> of_int z"

lemma ex_less_of_int:
  fixes x :: "'a::archimedean_field" shows "\<exists>z. x < of_int z"
proof -
  from ex_le_of_int obtain z where "x \<le> of_int z" ..
  then have "x < of_int (z + 1)" by simp
  then show ?thesis ..
qed

lemma ex_of_int_less:
  fixes x :: "'a::archimedean_field" shows "\<exists>z. of_int z < x"
proof -
  from ex_less_of_int obtain z where "- x < of_int z" ..
  then have "of_int (- z) < x" by simp
  then show ?thesis ..
qed

lemma ex_less_of_nat:
  fixes x :: "'a::archimedean_field" shows "\<exists>n. x < of_nat n"
proof -
  obtain z where "x < of_int z" using ex_less_of_int ..
  also have "\<dots> \<le> of_int (int (nat z))" by simp
  also have "\<dots> = of_nat (nat z)" by (simp only: of_int_of_nat_eq)
  finally show ?thesis ..
qed

lemma ex_le_of_nat:
  fixes x :: "'a::archimedean_field" shows "\<exists>n. x \<le> of_nat n"
proof -
  obtain n where "x < of_nat n" using ex_less_of_nat ..
  then have "x \<le> of_nat n" by simp
  then show ?thesis ..
qed

text {* Archimedean fields have no infinitesimal elements. *}

lemma ex_inverse_of_nat_Suc_less:
  fixes x :: "'a::archimedean_field"
  assumes "0 < x" shows "\<exists>n. inverse (of_nat (Suc n)) < x"
proof -
  from `0 < x` have "0 < inverse x"
    by (rule positive_imp_inverse_positive)
  obtain n where "inverse x < of_nat n"
    using ex_less_of_nat ..
  then obtain m where "inverse x < of_nat (Suc m)"
    using `0 < inverse x` by (cases n) (simp_all del: of_nat_Suc)
  then have "inverse (of_nat (Suc m)) < inverse (inverse x)"
    using `0 < inverse x` by (rule less_imp_inverse_less)
  then have "inverse (of_nat (Suc m)) < x"
    using `0 < x` by (simp add: nonzero_inverse_inverse_eq)
  then show ?thesis ..
qed

lemma ex_inverse_of_nat_less:
  fixes x :: "'a::archimedean_field"
  assumes "0 < x" shows "\<exists>n>0. inverse (of_nat n) < x"
  using ex_inverse_of_nat_Suc_less [OF `0 < x`] by auto

lemma ex_less_of_nat_mult:
  fixes x :: "'a::archimedean_field"
  assumes "0 < x" shows "\<exists>n. y < of_nat n * x"
proof -
  obtain n where "y / x < of_nat n" using ex_less_of_nat ..
  with `0 < x` have "y < of_nat n * x" by (simp add: pos_divide_less_eq)
  then show ?thesis ..
qed

subsection {* Existence and uniqueness of floor function *}

lemma exists_least_lemma:
  assumes "\<not> P 0" and "\<exists>n. P n"
  shows "\<exists>n. \<not> P n \<and> P (Suc n)"
proof -
  from `\<exists>n. P n` have "P (Least P)" by (rule LeastI_ex)
  with `\<not> P 0` obtain n where "Least P = Suc n"
    by (cases "Least P") auto
  then have "n < Least P" by simp
  then have "\<not> P n" by (rule not_less_Least)
  then have "\<not> P n \<and> P (Suc n)"
    using `P (Least P)` `Least P = Suc n` by simp
  then show ?thesis ..
qed

lemma floor_exists:
  fixes x :: "'a::archimedean_field"
  shows "\<exists>z. of_int z \<le> x \<and> x < of_int (z + 1)"
proof (cases)
  assume "0 \<le> x"
  then have "\<not> x < of_nat 0" by simp
  then have "\<exists>n. \<not> x < of_nat n \<and> x < of_nat (Suc n)"
    using ex_less_of_nat by (rule exists_least_lemma)
  then obtain n where "\<not> x < of_nat n \<and> x < of_nat (Suc n)" ..
  then have "of_int (int n) \<le> x \<and> x < of_int (int n + 1)" by simp
  then show ?thesis ..
next
  assume "\<not> 0 \<le> x"
  then have "\<not> - x \<le> of_nat 0" by simp
  then have "\<exists>n. \<not> - x \<le> of_nat n \<and> - x \<le> of_nat (Suc n)"
    using ex_le_of_nat by (rule exists_least_lemma)
  then obtain n where "\<not> - x \<le> of_nat n \<and> - x \<le> of_nat (Suc n)" ..
  then have "of_int (- int n - 1) \<le> x \<and> x < of_int (- int n - 1 + 1)" by simp
  then show ?thesis ..
qed

lemma floor_exists1:
  fixes x :: "'a::archimedean_field"
  shows "\<exists>!z. of_int z \<le> x \<and> x < of_int (z + 1)"
proof (rule ex_ex1I)
  show "\<exists>z. of_int z \<le> x \<and> x < of_int (z + 1)"
    by (rule floor_exists)
next
  fix y z assume
    "of_int y \<le> x \<and> x < of_int (y + 1)"
    "of_int z \<le> x \<and> x < of_int (z + 1)"
  with le_less_trans [of "of_int y" "x" "of_int (z + 1)"]
       le_less_trans [of "of_int z" "x" "of_int (y + 1)"]
  show "y = z" by (simp del: of_int_add)
qed

subsection {* Floor function *}

class floor_ceiling = archimedean_field +
  fixes floor :: "'a \<Rightarrow> int"
  assumes floor_correct: "of_int (floor x) \<le> x \<and> x < of_int (floor x + 1)"

notation (xsymbols)
  floor  ("\<lfloor>_\<rfloor>")

notation (HTML output)
  floor  ("\<lfloor>_\<rfloor>")

lemma floor_unique: "\<lbrakk>of_int z \<le> x; x < of_int z + 1\<rbrakk> \<Longrightarrow> floor x = z"
  using floor_correct [of x] floor_exists1 [of x] by auto

lemma of_int_floor_le: "of_int (floor x) \<le> x"
  using floor_correct ..

lemma le_floor_iff: "z \<le> floor x \<longleftrightarrow> of_int z \<le> x"
proof
  assume "z \<le> floor x"
  then have "(of_int z :: 'a) \<le> of_int (floor x)" by simp
  also have "of_int (floor x) \<le> x" by (rule of_int_floor_le)
  finally show "of_int z \<le> x" .
next
  assume "of_int z \<le> x"
  also have "x < of_int (floor x + 1)" using floor_correct ..
  finally show "z \<le> floor x" by (simp del: of_int_add)
qed

lemma floor_less_iff: "floor x < z \<longleftrightarrow> x < of_int z"
  by (simp add: not_le [symmetric] le_floor_iff)

lemma less_floor_iff: "z < floor x \<longleftrightarrow> of_int z + 1 \<le> x"
  using le_floor_iff [of "z + 1" x] by auto

lemma floor_le_iff: "floor x \<le> z \<longleftrightarrow> x < of_int z + 1"
  by (simp add: not_less [symmetric] less_floor_iff)

lemma floor_split[arith_split]: "P (floor t) \<longleftrightarrow> (\<forall>i. of_int i \<le> t \<and> t < of_int i + 1 \<longrightarrow> P i)"
  by (metis floor_correct floor_unique less_floor_iff not_le order_refl)

lemma floor_mono: assumes "x \<le> y" shows "floor x \<le> floor y"
proof -
  have "of_int (floor x) \<le> x" by (rule of_int_floor_le)
  also note `x \<le> y`
  finally show ?thesis by (simp add: le_floor_iff)
qed

lemma floor_less_cancel: "floor x < floor y \<Longrightarrow> x < y"
  by (auto simp add: not_le [symmetric] floor_mono)

lemma floor_of_int [simp]: "floor (of_int z) = z"
  by (rule floor_unique) simp_all

lemma floor_of_nat [simp]: "floor (of_nat n) = int n"
  using floor_of_int [of "of_nat n"] by simp

lemma le_floor_add: "floor x + floor y \<le> floor (x + y)"
  by (simp only: le_floor_iff of_int_add add_mono of_int_floor_le)

text {* Floor with numerals *}

lemma floor_zero [simp]: "floor 0 = 0"
  using floor_of_int [of 0] by simp

lemma floor_one [simp]: "floor 1 = 1"
  using floor_of_int [of 1] by simp

lemma floor_numeral [simp]: "floor (numeral v) = numeral v"
  using floor_of_int [of "numeral v"] by simp

lemma floor_neg_numeral [simp]: "floor (- numeral v) = - numeral v"
  using floor_of_int [of "- numeral v"] by simp

lemma zero_le_floor [simp]: "0 \<le> floor x \<longleftrightarrow> 0 \<le> x"
  by (simp add: le_floor_iff)

lemma one_le_floor [simp]: "1 \<le> floor x \<longleftrightarrow> 1 \<le> x"
  by (simp add: le_floor_iff)

lemma numeral_le_floor [simp]:
  "numeral v \<le> floor x \<longleftrightarrow> numeral v \<le> x"
  by (simp add: le_floor_iff)

lemma neg_numeral_le_floor [simp]:
  "- numeral v \<le> floor x \<longleftrightarrow> - numeral v \<le> x"
  by (simp add: le_floor_iff)

lemma zero_less_floor [simp]: "0 < floor x \<longleftrightarrow> 1 \<le> x"
  by (simp add: less_floor_iff)

lemma one_less_floor [simp]: "1 < floor x \<longleftrightarrow> 2 \<le> x"
  by (simp add: less_floor_iff)

lemma numeral_less_floor [simp]:
  "numeral v < floor x \<longleftrightarrow> numeral v + 1 \<le> x"
  by (simp add: less_floor_iff)

lemma neg_numeral_less_floor [simp]:
  "- numeral v < floor x \<longleftrightarrow> - numeral v + 1 \<le> x"
  by (simp add: less_floor_iff)

lemma floor_le_zero [simp]: "floor x \<le> 0 \<longleftrightarrow> x < 1"
  by (simp add: floor_le_iff)

lemma floor_le_one [simp]: "floor x \<le> 1 \<longleftrightarrow> x < 2"
  by (simp add: floor_le_iff)

lemma floor_le_numeral [simp]:
  "floor x \<le> numeral v \<longleftrightarrow> x < numeral v + 1"
  by (simp add: floor_le_iff)

lemma floor_le_neg_numeral [simp]:
  "floor x \<le> - numeral v \<longleftrightarrow> x < - numeral v + 1"
  by (simp add: floor_le_iff)

lemma floor_less_zero [simp]: "floor x < 0 \<longleftrightarrow> x < 0"
  by (simp add: floor_less_iff)

lemma floor_less_one [simp]: "floor x < 1 \<longleftrightarrow> x < 1"
  by (simp add: floor_less_iff)

lemma floor_less_numeral [simp]:
  "floor x < numeral v \<longleftrightarrow> x < numeral v"
  by (simp add: floor_less_iff)

lemma floor_less_neg_numeral [simp]:
  "floor x < - numeral v \<longleftrightarrow> x < - numeral v"
  by (simp add: floor_less_iff)

text {* Addition and subtraction of integers *}

lemma floor_add_of_int [simp]: "floor (x + of_int z) = floor x + z"
  using floor_correct [of x] by (simp add: floor_unique)

lemma floor_add_numeral [simp]:
    "floor (x + numeral v) = floor x + numeral v"
  using floor_add_of_int [of x "numeral v"] by simp

lemma floor_add_one [simp]: "floor (x + 1) = floor x + 1"
  using floor_add_of_int [of x 1] by simp

lemma floor_diff_of_int [simp]: "floor (x - of_int z) = floor x - z"
  using floor_add_of_int [of x "- z"] by (simp add: algebra_simps)

lemma floor_diff_numeral [simp]:
  "floor (x - numeral v) = floor x - numeral v"
  using floor_diff_of_int [of x "numeral v"] by simp

lemma floor_diff_one [simp]: "floor (x - 1) = floor x - 1"
  using floor_diff_of_int [of x 1] by simp

lemma le_mult_floor:
  assumes "0 \<le> a" and "0 \<le> b"
  shows "floor a * floor b \<le> floor (a * b)"
proof -
  have "of_int (floor a) \<le> a"
    and "of_int (floor b) \<le> b" by (auto intro: of_int_floor_le)
  hence "of_int (floor a * floor b) \<le> a * b"
    using assms by (auto intro!: mult_mono)
  also have "a * b < of_int (floor (a * b) + 1)"
    using floor_correct[of "a * b"] by auto
  finally show ?thesis unfolding of_int_less_iff by simp
qed

subsection {* Ceiling function *}

definition
  ceiling :: "'a::floor_ceiling \<Rightarrow> int" where
  "ceiling x = - floor (- x)"

notation (xsymbols)
  ceiling  ("\<lceil>_\<rceil>")

notation (HTML output)
  ceiling  ("\<lceil>_\<rceil>")

lemma ceiling_correct: "of_int (ceiling x) - 1 < x \<and> x \<le> of_int (ceiling x)"
  unfolding ceiling_def using floor_correct [of "- x"] by simp

lemma ceiling_unique: "\<lbrakk>of_int z - 1 < x; x \<le> of_int z\<rbrakk> \<Longrightarrow> ceiling x = z"
  unfolding ceiling_def using floor_unique [of "- z" "- x"] by simp

lemma le_of_int_ceiling: "x \<le> of_int (ceiling x)"
  using ceiling_correct ..

lemma ceiling_le_iff: "ceiling x \<le> z \<longleftrightarrow> x \<le> of_int z"
  unfolding ceiling_def using le_floor_iff [of "- z" "- x"] by auto

lemma less_ceiling_iff: "z < ceiling x \<longleftrightarrow> of_int z < x"
  by (simp add: not_le [symmetric] ceiling_le_iff)

lemma ceiling_less_iff: "ceiling x < z \<longleftrightarrow> x \<le> of_int z - 1"
  using ceiling_le_iff [of x "z - 1"] by simp

lemma le_ceiling_iff: "z \<le> ceiling x \<longleftrightarrow> of_int z - 1 < x"
  by (simp add: not_less [symmetric] ceiling_less_iff)

lemma ceiling_mono: "x \<ge> y \<Longrightarrow> ceiling x \<ge> ceiling y"
  unfolding ceiling_def by (simp add: floor_mono)

lemma ceiling_less_cancel: "ceiling x < ceiling y \<Longrightarrow> x < y"
  by (auto simp add: not_le [symmetric] ceiling_mono)

lemma ceiling_of_int [simp]: "ceiling (of_int z) = z"
  by (rule ceiling_unique) simp_all

lemma ceiling_of_nat [simp]: "ceiling (of_nat n) = int n"
  using ceiling_of_int [of "of_nat n"] by simp

lemma ceiling_add_le: "ceiling (x + y) \<le> ceiling x + ceiling y"
  by (simp only: ceiling_le_iff of_int_add add_mono le_of_int_ceiling)

text {* Ceiling with numerals *}

lemma ceiling_zero [simp]: "ceiling 0 = 0"
  using ceiling_of_int [of 0] by simp

lemma ceiling_one [simp]: "ceiling 1 = 1"
  using ceiling_of_int [of 1] by simp

lemma ceiling_numeral [simp]: "ceiling (numeral v) = numeral v"
  using ceiling_of_int [of "numeral v"] by simp

lemma ceiling_neg_numeral [simp]: "ceiling (- numeral v) = - numeral v"
  using ceiling_of_int [of "- numeral v"] by simp

lemma ceiling_le_zero [simp]: "ceiling x \<le> 0 \<longleftrightarrow> x \<le> 0"
  by (simp add: ceiling_le_iff)

lemma ceiling_le_one [simp]: "ceiling x \<le> 1 \<longleftrightarrow> x \<le> 1"
  by (simp add: ceiling_le_iff)

lemma ceiling_le_numeral [simp]:
  "ceiling x \<le> numeral v \<longleftrightarrow> x \<le> numeral v"
  by (simp add: ceiling_le_iff)

lemma ceiling_le_neg_numeral [simp]:
  "ceiling x \<le> - numeral v \<longleftrightarrow> x \<le> - numeral v"
  by (simp add: ceiling_le_iff)

lemma ceiling_less_zero [simp]: "ceiling x < 0 \<longleftrightarrow> x \<le> -1"
  by (simp add: ceiling_less_iff)

lemma ceiling_less_one [simp]: "ceiling x < 1 \<longleftrightarrow> x \<le> 0"
  by (simp add: ceiling_less_iff)

lemma ceiling_less_numeral [simp]:
  "ceiling x < numeral v \<longleftrightarrow> x \<le> numeral v - 1"
  by (simp add: ceiling_less_iff)

lemma ceiling_less_neg_numeral [simp]:
  "ceiling x < - numeral v \<longleftrightarrow> x \<le> - numeral v - 1"
  by (simp add: ceiling_less_iff)

lemma zero_le_ceiling [simp]: "0 \<le> ceiling x \<longleftrightarrow> -1 < x"
  by (simp add: le_ceiling_iff)

lemma one_le_ceiling [simp]: "1 \<le> ceiling x \<longleftrightarrow> 0 < x"
  by (simp add: le_ceiling_iff)

lemma numeral_le_ceiling [simp]:
  "numeral v \<le> ceiling x \<longleftrightarrow> numeral v - 1 < x"
  by (simp add: le_ceiling_iff)

lemma neg_numeral_le_ceiling [simp]:
  "- numeral v \<le> ceiling x \<longleftrightarrow> - numeral v - 1 < x"
  by (simp add: le_ceiling_iff)

lemma zero_less_ceiling [simp]: "0 < ceiling x \<longleftrightarrow> 0 < x"
  by (simp add: less_ceiling_iff)

lemma one_less_ceiling [simp]: "1 < ceiling x \<longleftrightarrow> 1 < x"
  by (simp add: less_ceiling_iff)

lemma numeral_less_ceiling [simp]:
  "numeral v < ceiling x \<longleftrightarrow> numeral v < x"
  by (simp add: less_ceiling_iff)

lemma neg_numeral_less_ceiling [simp]:
  "- numeral v < ceiling x \<longleftrightarrow> - numeral v < x"
  by (simp add: less_ceiling_iff)

text {* Addition and subtraction of integers *}

lemma ceiling_add_of_int [simp]: "ceiling (x + of_int z) = ceiling x + z"
  using ceiling_correct [of x] by (simp add: ceiling_unique)

lemma ceiling_add_numeral [simp]:
    "ceiling (x + numeral v) = ceiling x + numeral v"
  using ceiling_add_of_int [of x "numeral v"] by simp

lemma ceiling_add_one [simp]: "ceiling (x + 1) = ceiling x + 1"
  using ceiling_add_of_int [of x 1] by simp

lemma ceiling_diff_of_int [simp]: "ceiling (x - of_int z) = ceiling x - z"
  using ceiling_add_of_int [of x "- z"] by (simp add: algebra_simps)

lemma ceiling_diff_numeral [simp]:
  "ceiling (x - numeral v) = ceiling x - numeral v"
  using ceiling_diff_of_int [of x "numeral v"] by simp

lemma ceiling_diff_one [simp]: "ceiling (x - 1) = ceiling x - 1"
  using ceiling_diff_of_int [of x 1] by simp

lemma ceiling_split[arith_split]: "P (ceiling t) \<longleftrightarrow> (\<forall>i. of_int i - 1 < t \<and> t \<le> of_int i \<longrightarrow> P i)"
  by (auto simp add: ceiling_unique ceiling_correct)

lemma ceiling_diff_floor_le_1: "ceiling x - floor x \<le> 1"
proof -
  have "of_int \<lceil>x\<rceil> - 1 < x"
    using ceiling_correct[of x] by simp
  also have "x < of_int \<lfloor>x\<rfloor> + 1"
    using floor_correct[of x] by simp_all
  finally have "of_int (\<lceil>x\<rceil> - \<lfloor>x\<rfloor>) < (of_int 2::'a)"
    by simp
  then show ?thesis
    unfolding of_int_less_iff by simp
qed

subsection {* Negation *}

lemma floor_minus: "floor (- x) = - ceiling x"
  unfolding ceiling_def by simp

lemma ceiling_minus: "ceiling (- x) = - floor x"
  unfolding ceiling_def by simp

end