section {* Finite functions *}

theory Ffun
imports Map_Extra Pfun FSet_extra
begin

subsection {* Finite function type and operations *}

typedef ('a, 'b) ffun = "{f :: ('a, 'b) pfun. finite(pdom(f))}"
  morphisms pfun_of Abs_pfun
  by (rule_tac x="{}\<^sub>p" in exI, auto)

setup_lifting type_definition_ffun

lift_definition ffun_app :: "('a, 'b) ffun \<Rightarrow> 'a \<Rightarrow> 'b" ("_'(_')\<^sub>f" [999,0] 999) is "pfun_app" .

lift_definition ffun_upd :: "('a, 'b) ffun \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) ffun" is "pfun_upd" by simp

lift_definition fdom :: "('a, 'b) ffun \<Rightarrow> 'a set" is pdom .

lift_definition fran :: "('a, 'b) ffun \<Rightarrow> 'b set" is pran .

lift_definition ffun_comp :: "('b, 'c) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> ('a, 'c) ffun" (infixl "\<circ>\<^sub>f" 55) is pfun_comp by auto

lift_definition ffun_member :: "'a \<times> 'b \<Rightarrow> ('a, 'b) ffun \<Rightarrow> bool" (infix "\<in>\<^sub>f" 50) is "op \<in>\<^sub>p" .

lift_definition fdom_res :: "'a set \<Rightarrow> ('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun" (infixl "\<lhd>\<^sub>f" 85)
is "pdom_res" by simp

lift_definition fran_res :: "('a, 'b) ffun \<Rightarrow> 'b set \<Rightarrow> ('a, 'b) ffun" (infixl "\<rhd>\<^sub>f" 85)
is pran_res by simp

lift_definition ffun_graph :: "('a, 'b) ffun \<Rightarrow> ('a \<times> 'b) set" is pfun_graph .

lift_definition graph_ffun :: "('a \<times> 'b) set \<Rightarrow> ('a, 'b) ffun" is
  "\<lambda> R. if (finite (Domain R)) then graph_pfun R else pempty"
  by (simp add: finite_Domain)

definition pcard :: "('a, 'b) pfun \<Rightarrow> nat"
where "pcard f = card (pdom f)"

instantiation ffun :: (type, type) zero
begin
lift_definition zero_ffun :: "('a, 'b) ffun" is "0" by simp
instance ..
end

abbreviation fempty :: "('a, 'b) ffun" ("{}\<^sub>f")
where "fempty \<equiv> 0"

instantiation ffun :: (type, type) plus
begin
lift_definition plus_ffun :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun" is "op +" by simp
instance ..
end

instantiation ffun :: (type, type) minus
begin
lift_definition minus_ffun :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun" is "op -"
  by (metis finite_Diff finite_Domain pdom_graph_pfun pdom_pfun_graph_finite pfun_graph_inv pfun_graph_minus)
instance ..
end

instance ffun :: (type, type) monoid_add
  by (intro_classes, (transfer, simp add: add.assoc)+)

instantiation ffun :: (type, type) inf
begin
lift_definition inf_ffun :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun" is inf
  by (meson finite_Int infinite_super pdom_inter)
instance ..
end

abbreviation ffun_inter :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun" (infixl "\<inter>\<^sub>f" 80)
where "ffun_inter \<equiv> inf"

instantiation ffun :: (type, type) order
begin
  lift_definition less_eq_ffun :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> bool" is
  "\<lambda> f g. f \<subseteq>\<^sub>p g" .
  lift_definition less_ffun :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> bool" is
  "\<lambda> f g. f < g" .
instance
  by (intro_classes, (transfer, auto)+)
end

abbreviation ffun_subset :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> bool" (infix "\<subset>\<^sub>f" 50)
where "ffun_subset \<equiv> less"

abbreviation ffun_subset_eq :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> bool" (infix "\<subseteq>\<^sub>f" 50)
where "ffun_subset_eq \<equiv> less_eq"

instance ffun :: (type, type) semilattice_inf
  by (intro_classes, (transfer, auto)+)

lemma ffun_subset_eq_least [simp]:
  "{}\<^sub>f \<subseteq>\<^sub>f f"
  by (transfer, auto)

syntax
  "_FfunUpd"  :: "[('a, 'b) ffun, maplets] => ('a, 'b) ffun" ("_'(_')\<^sub>f" [900,0]900)
  "_Ffun"     :: "maplets => ('a, 'b) ffun"            ("(1{_}\<^sub>f)")

translations
  "_FfunUpd m (_Maplets xy ms)"  == "_FfunUpd (_FfunUpd m xy) ms"
  "_FfunUpd m (_maplet  x y)"    == "CONST ffun_upd m x y"
  "_Ffun ms"                     => "_FfunUpd (CONST fempty) ms"
  "_Ffun (_Maplets ms1 ms2)"     <= "_FfunUpd (_Ffun ms1) ms2"
  "_Ffun ms"                     <= "_FfunUpd (CONST fempty) ms"

subsection {* Algebraic laws *}

lemma ffun_comp_assoc: "f \<circ>\<^sub>f (g \<circ>\<^sub>f h) = (f \<circ>\<^sub>f g) \<circ>\<^sub>f h"
  by (transfer, simp add: pfun_comp_assoc)

lemma pfun_override_dist_comp:
  "(f + g) \<circ>\<^sub>f h = (f \<circ>\<^sub>f h) + (g \<circ>\<^sub>f h)"
  by (transfer, simp add: pfun_override_dist_comp)

lemma ffun_minus_unit [simp]:
  fixes f :: "('a, 'b) ffun"
  shows "f - 0 = f"
  by (transfer, simp)

lemma ffun_minus_zero [simp]:
  fixes f :: "('a, 'b) ffun"
  shows "0 - f = 0"
  by (transfer, simp)

lemma ffun_minus_self [simp]:
  fixes f :: "('a, 'b) ffun"
  shows "f - f = 0"
  by (transfer, simp)

lemma ffun_minus_plus_commute:
  "fdom(g) \<inter> fdom(h) = {} \<Longrightarrow> (f - g) + h = (f + h) - g"
  by (transfer, simp add: pfun_minus_plus_commute)

lemma ffun_plus_minus:
  "f \<subseteq>\<^sub>f g \<Longrightarrow> (g - f) + f = g"
  by (transfer, simp add: pfun_plus_minus)

lemma ffun_minus_common_subset:
  "\<lbrakk> h \<subseteq>\<^sub>f f; h \<subseteq>\<^sub>f g \<rbrakk> \<Longrightarrow> (f - h = g - h) = (f = g)"
  by (transfer, simp add: pfun_minus_common_subset)

lemma ffun_minus_plus:
  "fdom(f) \<inter> fdom(g) = {} \<Longrightarrow> (f + g) - g = f"
  by (transfer, simp add: pfun_minus_plus)

subsection {* Membership, application, and update *}

lemma ffun_ext: "\<lbrakk> \<And> x y. (x, y) \<in>\<^sub>f f \<longleftrightarrow> (x, y) \<in>\<^sub>f g \<rbrakk> \<Longrightarrow> f = g"
  by (transfer, simp add: pfun_ext)

lemma ffun_member_alt_def:
  "(x, y) \<in>\<^sub>f f \<longleftrightarrow> (x \<in> fdom f \<and> f(x)\<^sub>f = y)"
  by (transfer, simp add: pfun_member_alt_def)

lemma ffun_member_plus:
  "(x, y) \<in>\<^sub>f f + g \<longleftrightarrow> ((x \<notin> fdom(g) \<and> (x, y) \<in>\<^sub>f f) \<or> (x, y) \<in>\<^sub>f g)"
  by (transfer, simp add: pfun_member_plus)

lemma ffun_member_minus:
  "(x, y) \<in>\<^sub>f f - g \<longleftrightarrow> (x, y) \<in>\<^sub>f f \<and> (\<not> (x, y) \<in>\<^sub>f g)"
  by (transfer, simp add: pfun_member_minus)

lemma ffun_app_upd_1 [simp]: "x = y \<Longrightarrow> (f(x \<mapsto> v)\<^sub>f)(y)\<^sub>f = v"
  by (transfer, simp)

lemma ffun_app_upd_2 [simp]: "x \<noteq> y \<Longrightarrow> (f(x \<mapsto> v)\<^sub>f)(y)\<^sub>f = f(y)\<^sub>f"
  by (transfer, simp)

lemma ffun_upd_add [simp]: "f + g(x \<mapsto> v)\<^sub>f = (f + g)(x \<mapsto> v)\<^sub>f"
  by (transfer, simp)

lemma ffun_upd_twice [simp]: "f(x \<mapsto> u, x \<mapsto> v)\<^sub>f = f(x \<mapsto> v)\<^sub>f"
  by (transfer, simp)

lemma ffun_upd_comm:
  assumes "x \<noteq> y"
  shows "f(y \<mapsto> u, x \<mapsto> v)\<^sub>f = f(x \<mapsto> v, y \<mapsto> u)\<^sub>f"
  using assms by (transfer, simp add: pfun_upd_comm)

lemma ffun_upd_comm_linorder [simp]:
  fixes x y :: "'a :: linorder"
  assumes "x < y"
  shows "f(y \<mapsto> u, x \<mapsto> v)\<^sub>f = f(x \<mapsto> v, y \<mapsto> u)\<^sub>f"
  using assms by (transfer, auto)

lemma ffun_app_minus [simp]: "x \<notin> fdom g \<Longrightarrow> (f - g)(x)\<^sub>f = f(x)\<^sub>f"
  by (transfer, auto)

lemma ffun_upd_minus [simp]:
  "x \<notin> fdom g \<Longrightarrow> (f - g)(x \<mapsto> v)\<^sub>f = (f(x \<mapsto> v)\<^sub>f - g)"
  by (transfer, auto)

lemma fdom_member_minus_iff [simp]:
  "x \<notin> fdom g \<Longrightarrow> x \<in> fdom(f - g) \<longleftrightarrow> x \<in> fdom(f)"
  by (transfer, simp)

lemma fsubseteq_ffun_upd1 [intro]:
  "\<lbrakk> f \<subseteq>\<^sub>f g; x \<notin> fdom(g) \<rbrakk> \<Longrightarrow> f \<subseteq>\<^sub>f g(x \<mapsto> v)\<^sub>f"
  by (transfer, auto)

lemma fsubseteq_ffun_upd2 [intro]:
  "\<lbrakk> f \<subseteq>\<^sub>f g; x \<notin> fdom(f) \<rbrakk> \<Longrightarrow> f \<subseteq>\<^sub>f g(x \<mapsto> v)\<^sub>f"
  by (transfer, auto)

lemma psubseteq_pfun_upd3 [intro]:
  "\<lbrakk> f \<subseteq>\<^sub>f g; g(x)\<^sub>f = v \<rbrakk> \<Longrightarrow> f \<subseteq>\<^sub>f g(x \<mapsto> v)\<^sub>f"
  by (transfer, auto)

lemma fsubseteq_dom_subset:
  "f \<subseteq>\<^sub>f g \<Longrightarrow> fdom(f) \<subseteq> fdom(g)"
  by (transfer, auto simp add: psubseteq_dom_subset)

lemma fsubseteq_ran_subset:
  "f \<subseteq>\<^sub>f g \<Longrightarrow> fran(f) \<subseteq> fran(g)"
  by (transfer, simp add: psubseteq_ran_subset)

subsection {* Domain laws *}

lemma fdom_zero [simp]: "fdom 0 = {}"
  by (transfer, simp)

lemma fdom_plus [simp]: "fdom (f + g) = fdom f \<union> fdom g"
  by (transfer, auto)

lemma fdom_inter: "fdom (f \<inter>\<^sub>f g) \<subseteq> fdom f \<inter> fdom g"
  by (transfer, meson pdom_inter)

lemma fdom_comp [simp]: "fdom (g \<circ>\<^sub>f f) = fdom (f \<rhd>\<^sub>f fdom g)"
  by (transfer, auto)

lemma fdom_upd [simp]: "fdom (f(k \<mapsto> v)\<^sub>f) = insert k (fdom f)"
  by (transfer, simp)

lemma fdom_fdom_res [simp]: "fdom (A \<lhd>\<^sub>f f) = A \<inter> fdom(f)"
  by (transfer, auto)

lemma fdom_graph_ffun [simp]:
  "finite (Domain R) \<Longrightarrow> fdom (graph_ffun R) = Domain R"
  by (transfer, simp add: Domain_fst graph_map_dom)

subsection {* Range laws *}

lemma fran_zero [simp]: "fran 0 = {}"
  by (transfer, simp)

lemma fran_upd [simp]: "fran (f(k \<mapsto> v)\<^sub>f) = insert v (fran ((- {k}) \<lhd>\<^sub>f f))"
  by (transfer, auto)

lemma fran_fran_res [simp]: "fran (f \<rhd>\<^sub>f A) = fran(f) \<inter> A"
  by (transfer, auto)

lemma fran_comp [simp]: "fran (g \<circ>\<^sub>f f) = fran (fran f \<lhd>\<^sub>f g)"
  by (transfer, auto)

subsection {* Domain restriction laws *}

lemma fdom_res_zero [simp]: "A \<lhd>\<^sub>f {}\<^sub>f = {}\<^sub>f"
  by (transfer, auto)

lemma pdom_res_upd_in [simp]:
  "k \<in> A \<Longrightarrow> A \<lhd>\<^sub>f f(k \<mapsto> v)\<^sub>f = (A \<lhd>\<^sub>f f)(k \<mapsto> v)\<^sub>f"
  by (transfer, auto)

lemma pdom_res_upd_out [simp]:
  "k \<notin> A \<Longrightarrow> A \<lhd>\<^sub>f f(k \<mapsto> v)\<^sub>f = A \<lhd>\<^sub>f f"
  by (transfer, auto)

lemma fdom_res_override [simp]: "A \<lhd>\<^sub>f (f + g) = (A \<lhd>\<^sub>f f) + (A \<lhd>\<^sub>f g)"
  by (metis fdom_res.rep_eq pdom_res_override pfun_of_inject plus_ffun.rep_eq)

lemma fdom_res_minus [simp]: "A \<lhd>\<^sub>f (f - g) = (A \<lhd>\<^sub>f f) - g"
  by (transfer, auto)

lemma fdom_res_swap: "(A \<lhd>\<^sub>f f) \<rhd>\<^sub>f B = A \<lhd>\<^sub>f (f \<rhd>\<^sub>f B)"
  by (transfer, simp add: pdom_res_swap)

lemma fdom_res_twice [simp]: "A \<lhd>\<^sub>f (B \<lhd>\<^sub>f f) = (A \<inter> B) \<lhd>\<^sub>f f"
  by (transfer, auto)

lemma fdom_res_comp [simp]: "A \<lhd>\<^sub>f (g \<circ>\<^sub>f f) =  g \<circ>\<^sub>f (A \<lhd>\<^sub>f f)"
  by (transfer, simp)

subsection {* Range restriction laws *}

lemma fran_res_zero [simp]: "{}\<^sub>f \<rhd>\<^sub>f A = {}\<^sub>f"
  by (transfer, auto)

lemma fran_res_upd_1 [simp]: "v \<in> A \<Longrightarrow> f(x \<mapsto> v)\<^sub>f \<rhd>\<^sub>f A = (f \<rhd>\<^sub>f A)(x \<mapsto> v)\<^sub>f"
  by (transfer, auto)

lemma fran_res_upd_2 [simp]: "v \<notin> A \<Longrightarrow> f(x \<mapsto> v)\<^sub>f \<rhd>\<^sub>f A = ((- {x}) \<lhd>\<^sub>f f) \<rhd>\<^sub>f A"
  by (transfer, auto)

lemma fran_res_override: "(f + g) \<rhd>\<^sub>f A \<subseteq>\<^sub>f (f \<rhd>\<^sub>f A) + (g \<rhd>\<^sub>f A)"
  by (transfer, simp add: pran_res_override)

subsection {* Graph laws *}

lemma ffun_graph_inv: "graph_ffun (ffun_graph f) = f"
  by (transfer, auto simp add: pfun_graph_inv finite_Domain)

lemma ffun_graph_zero: "ffun_graph 0 = {}"
  by (transfer, simp add: pfun_graph_zero)

lemma ffun_graph_minus: "ffun_graph (f - g) = ffun_graph f - ffun_graph g"
  by (transfer, simp add: pfun_graph_minus)

lemma ffun_graph_inter: "ffun_graph (f \<inter>\<^sub>f g) = ffun_graph f \<inter> ffun_graph g"
  by (transfer, simp add: pfun_graph_inter)

text {* Hide implementation details for partial functions *}

lifting_update ffun.lifting
lifting_forget ffun.lifting

end


(*<*)
theory T7ConjuntoMaximalIngles
imports T6CFinitoIngles
begin
(*>*)
section \<open> Conjuntos consistentes maximales \<close>

text \<open>
  \label{sucP}
  En esta sección precisamos en Isabelle, cómo extender un conjunto
  consistente $S$ de fórmulas proposicionales a un conjunto consistente
  maximal de acuerdo a lo expuesto en la página 61 de \cite{Fitting}.
\<close>

subsection \<open> Conjuntos maximales \<close>

text \<open>
  \begin{definicion}\label{defmaximal}
  Sea $\mathcal{C}$ una colección de conjuntos. El conjunto $S$ es un
  elemento {\bf{maximal}} de $\mathcal{C}$ si, para cualquier
  $S' \in \mathcal{C}$ tal que $S \subseteq S'$ implica que $S = S'$.
\end{definicion}

  \noindent Su formalización es:
\<close>

definition maximal :: "'a set \<Rightarrow> 'a set set \<Rightarrow> bool" where
  "maximal S \<C> = (\<forall>S'\<in> \<C>. S \<subseteq> S' \<longrightarrow> S = S')"

text \<open>
  La construcción, a partir de $S$ de un conjunto consistente maximal
  está basada en la siguiente sucesión creciente (por inclusión) de
  conjuntos.

  \begin{definicion}\label{sucesion}
  Sean $S$ un conjunto de fórmulas, $\mathcal{C}$ una colección de
  conjuntos de fórmulas y $f$ una sucesión de fórmulas.  Definimos la
  siguiente sucesión de conjuntos, $\{S^{n}_{S,\mathcal{C},f}\}_n$.
  \[
  \begin{array}{l}
   S^{0}_{S,\mathcal{C},f} = S \\
   S^{n+1}_{S,\mathcal{C},f} =
     \left\{\begin{array}{ll}
           S^{n}_{S,\mathcal{C},f} \cup \{f_n\}, &
           \mbox{si $S^{n}_{S,\mathcal{C},f} \cup \{f_n\} \in \mathcal{C}$} \\
           S^{n}_{S,\mathcal{C},f}\; , & \mbox{en otro caso.}
     \end{array}\right.
   \end{array}
  \]
  \end{definicion}

  La formalización de la sucesión $\{S^{n}_{S,\mathcal{C},f}\}_n$ es:
\<close>

primrec sucP :: "'b formula set \<Rightarrow> 'b formula set set \<Rightarrow> (nat \<Rightarrow> 'b formula) \<Rightarrow> nat \<Rightarrow> 'b formula set"
where
  "sucP S \<C> f 0 = S"
| "sucP S \<C> f (Suc n) =
    (if sucP S \<C> f n \<union> {f n} \<in> \<C>
     then sucP S \<C> f n \<union> {f n}
     else sucP S \<C> f n)"

text \<open>
  Consideremos ahora la unión de los elementos $S^{n}_{S,\mathcal{C},f}$,
  $$S_{S,\mathcal{C},f}= \bigcup_{n} S^{n}_{S,\mathcal{C},f}.$$

  \noindent Su formalización en Isabelle es:
\<close>

definition MsucP :: "'b formula set \<Rightarrow> 'b formula set set \<Rightarrow> (nat \<Rightarrow> 'b formula) \<Rightarrow> 'b formula set"
where
"MsucP S \<C> f = (\<Union>n. sucP S \<C> f n)"

text \<open>
  En lo que sigue demostraremos que para cualquier lenguaje
  proposicional $\mathbf{L}$, si $\mathcal{C}$ es una propiedad de
  consistencia proposicional de carácter finito, $S\in \mathcal{C}$ y
  $f$ es una {\em numeración} del conjunto de fórmulas de $\mathbf{L}$
  entonces, $S_{S,\mathcal{C},f}$ es un elemento maximal de
  $\mathcal{C}$ que pertenece a $\mathcal{C}$ y extiende a $S$.

  Por definición, se tiene que el conjunto $S_{S,\mathcal{C},f}$ es una
  extensión de $S$:

  \begin{teorema}\label{MaxSubconjuntoP}
  $S \subseteq S_{S,\mathcal{C},f}.$
  \end{teorema}
\<close>

(*<*)
text \<open>
  \begin{demostracion}
  Por definición,
  $S_{S,\mathcal{C},f}= \bigcup n.\, S^{n}_{S,\mathcal{C},f}$.
  Luego por propiedades de conjuntos
  $S = S^{0}_{S,\mathcal{C},f}\subseteq S_{S,\mathcal{C},f}$.
  \end{demostracion}
\<close>
(*>*)

text \<open>
  \noindent Su formalización es:
\<close>

theorem Max_subconjuntoP: "S \<subseteq> MsucP S \<C> f"
(*<*)
proof (rule subsetI)
  fix x
  assume "x \<in> S"
  hence "x \<in> sucP S \<C> f 0" by simp
  hence  "\<exists>n. x \<in> sucP S \<C> f n" by (rule exI)
  thus "x \<in> MsucP S \<C> f" by (simp add: MsucP_def)
qed
(*>*)

text \<open>

  La demostración de que $S_{S,\mathcal{C},f}$ es un elemento de
  $\mathcal{C}$ está basada en que $\mathcal{C}$ sea de carácter finito
  y que los elementos ${S^{n}_{S,\mathcal{C},f}}$ formen una cadena
  (ascendente) de elementos de $\mathcal{C}$, es decir,
  $S^{n}_{S,\mathcal{C},f} \in \mathcal{C}$ y
  $S^{n}_{S,\mathcal{C},f}\subseteq S^{n+1}_{S,\mathcal{C},f}$, para
  todo $n$.  A continuación demostraremos de forma más general, que si
  $\mathcal{C}$ es una colección de conjuntos de carácter finito
  entonces la unión de los elementos de una cadena de conjuntos de
  $\mathcal{C}$ es también un conjunto de $\mathcal{C}$.

  \begin{definicion}\label{cadena}
  Una cadena de conjuntos es cualquier sucesión $\{S_n\}_n$ de conjuntos
  ordenada por inclusión, $S_0\subseteq S_1\subseteq S_2\subseteq\ldots$.
  \end{definicion}

  \noindent Su formalización es:
\<close>

definition es_cadena :: "(nat \<Rightarrow> 'a set) \<Rightarrow> bool" where
  "es_cadena S = (\<forall>n. S n \<subseteq> S (Suc n))"

text \<open>
  La unión $\bigcup_n S_n$ de los elementos de una cadena $\{S_n\}_n$ ,
  es llamada el límite de la cadena. La propiedad fundamental de las
  colecciones de conjuntos de carácter finito es que son cerradas bajo
  límites. Es decir, si $\mathcal{C}$ es una colección de conjuntos de
  carácter finito y $\{S_n\}_n$ es una cadena de elementos de
  $\mathcal{C}$ entonces, el límite $\bigcup_n S_n\in \mathcal{C}$.
\<close>

(*<*)
text \<open>
  Para la demostración de esta propiedad, usamos el siguiente lema.

  \begin{lema}\label{indicecadena}
  Sea $\{S_n\}_n$ una cadena y $A$ un conjunto finito. Supongamos que
  $A\subseteq \bigcup_n S_n$ entonces, $A\subseteq S_n$ para algún $n$.
  \end{lema}

  \begin{demostracion}
  La demostración es por inducción finita sobre $A$.

  {\bf{Caso base}}. Sea $A=\emptyset$, se tiene trivialmente que
  $\emptyset \subseteq S_n$ para cualquier $n$.

  {\bf{Paso de inducción}}. Hipótesis de inducción: sea $A$ un conjunto
  finito, si $A\subseteq \bigcup_n S_n$ entonces $A\subseteq S_n$ para
  algún $n$. Hay que demostrar que si
  $A\cup\{x\} \subseteq \bigcup_n S_n$, en donde $x\notin A$, entonces
  $A\cup\{x\} \subseteq S_n$ para algún $n$.

  Supongamos que $A\cup\{x\} \subseteq \bigcup_n S_n$ en donde
  $x\notin A$.  Entonces $x\in S_m$ para algún $m$ y
  $A\subseteq \bigcup_nS_n$. Por lo tanto, $x\in S_m$ para algún $m$ y,
  por hipótesis de inducción, $A \subseteq S_n$ para algún $n$. Sea $r$
  el máximo entre $m$ y $n$ entonces, como $f$ es una cadena, es fácil
  demostrar que $S_m\subseteq S_r$ y $S_n\subseteq S_r$. Luego,
  $A \subseteq S_r$ y $x\in S_r$. Así, $A \cup\{x\}\subseteq S_r$.
  \end{demostracion}

  Para la formalización del lema anterior, demostramos los siguientes
  dos resultados preliminares.
\<close>
(*>*)

(*<*)
lemma es_cadenaD:
  assumes "es_cadena S" and "x \<in> S m"
  shows "x \<in> S (m + n)"
proof -
  show ?thesis using assms by (induct n)(auto simp add: es_cadena_def)
qed

lemma es_cadenaD':
  assumes hip1: "es_cadena S" and hip2: "x \<in> S m" and hip3: "m \<le> k"
  shows "x \<in> S k"
proof -
  have "\<exists>n. k = m + n" using hip3 by arith
  then obtain n where n: "k = m + n" by (rule exE)
  moreover
  have "x \<in> S (m + n)" using hip1 hip2 by (rule es_cadenaD)
  thus ?thesis using n by simp
qed

lemma cadena_indice:
  assumes ch: "es_cadena S" and fin: "finite F"
  shows "F \<subseteq> (\<Union>n. S n) \<Longrightarrow> \<exists>n. F \<subseteq> S n" using fin
proof (induct rule: finite_induct)
  assume "{} \<subseteq> (\<Union>n. S n)"
  show "\<exists>n.{} \<subseteq> S n"  by simp
  next
    fix x F
    assume
      h1: "finite F"
      and h2: "x \<notin> F"
      and h3: "F \<subseteq> (\<Union>n. S n)\<Longrightarrow> \<exists>n. F \<subseteq> S n"
      and h4: "insert x F \<subseteq> (\<Union>n. S n)"
  show "\<exists>n. insert x F \<subseteq> S n"
  proof -
    have "\<exists>m. x \<in> S m" using h4 by simp
    then obtain m where m: "x \<in> S m" by (rule exE)
    have "F \<subseteq> (\<Union>n. S n)" using h4 by simp
    hence  "\<exists>n. F \<subseteq> S n" using h3 by simp
    then obtain n where n: "F \<subseteq> S n" by (rule exE)
    have "m \<le> (max m n)"  by (simp add: max_def)
    with ch m  have 1: "x \<in> S (max m n)" by (rule es_cadenaD')
    have 2:  "F \<subseteq> S (max m n)"
    proof (rule subsetI)
      fix y
      assume "y \<in> F"
      hence "y \<in> S n" using n by blast
      moreover
      have "n \<le> (max m n)" by simp
      ultimately
      show "y \<in> S (max m n)"  by (rule es_cadenaD'[OF ch _ _])
    qed
    have "insert x F  \<subseteq> S (max m n)" using 1 2 by simp
    thus ?thesis by (rule exI)
  qed
qed
(*>*)

text \<open>
  \begin{teorema}\label{limitecadenaP}
  Si $\mathcal{C}$ es una colección de conjuntos de carácter finito y
  $\{S_n\}_n$ es una cadena de elementos de $\mathcal{C}$ entonces, el
  límite de $\{S_n\}_n$ pertenece a $\mathcal{C}$.
  \end{teorema}
\<close>

(*<*)
text \<open>
  \begin{demostracion}

  Puesto que $\mathcal{C}$ es de carácter finito, para mostrar que
  $\bigcup_n S_n\in \mathcal{C}$, es suficiente mostrar que cada
  subconjunto finito de $\bigcup_n S_n$ pertenece a
  $\mathcal{C}$. Supongamos que $T$ es un conjunto finito y
  $T\subseteq \bigcup_n S_n$. Entonces, como $\{S_n\}_n$ es una cadena,
  por el lema \ref{indicecadena} existe $n$ tal que $T\subseteq S_n$ y
  como por hipótesis $S_n\in \mathcal{C}$ entonces se tiene que
  $T \in S_n$, ya que $\mathcal{C}$ es cerrada por subconjuntos por ser
  de carácter finito (teorema \ref{CaracterFinitoCerrada}).
  \end{demostracion}
\<close>

(*>*)
text\<open>
  \noindent Su formalización es:
\<close>

theorem cadena_union_cerrado:
  assumes hip1: "caracter_finito \<C>"
  and hip2:"es_cadena S"
  and hip3: "\<forall>n. S n \<in> \<C>"
  shows "(\<Union>n. S n) \<in> \<C>"
(*<*)
proof -
  have "\<forall>S. (S \<in> \<C>) = (\<forall>T. finite T \<longrightarrow> T \<subseteq> S \<longrightarrow> T \<in> \<C>)"
  using hip1 by (unfold caracter_finito_def)
  hence 1: "(\<Union>n. S n) \<in> \<C> = (\<forall>T. finite T \<longrightarrow> T \<subseteq> (\<Union>n. S n) \<longrightarrow> T \<in> \<C>)"
  by (rule allE)
  thus "(\<Union>n. S n) \<in> \<C>"
  proof -
    have "(\<forall>T. finite T \<longrightarrow> T \<subseteq> (\<Union>n. S n) \<longrightarrow> T \<in> \<C>)"
    proof (rule allI impI)+
      fix T
      assume h1: "finite T" and h2: "T \<subseteq> (\<Union>n. S n)"
      have "\<exists>n. T \<subseteq> S n" using hip2 h1 h2 by (rule cadena_indice)
      moreover
      have "subconj_cerrada \<C>" using hip1 by (rule caracter_finito_cerrado)
      hence "\<forall>S\<in>\<C>. \<forall>S'\<subseteq>S. S' \<in> \<C>"  by (unfold subconj_cerrada_def)
      ultimately
      show "T \<in> \<C>" using hip3 by auto
    qed
    thus "(\<Union>n. S n) \<in> \<C>" using 1 by simp
  qed
qed
(*>*)

text \<open>
  De esta forma, para demostrar que
  $\bigcup_{n} S^{n}_{S,\mathcal{C},f}\in \mathcal{C}$ como consecuencia
  del teorema anterior, basta probar que los elementos
  $S^{n}_{S,\mathcal{C},f}$ forman una cadena de elementos de $\mathcal{C}$.

  \begin{lema}\label{cadenasucP}
  Sean $S$ un conjunto de fórmulas, $\mathcal{C}$ una colección de
  conjuntos de fórmulas y $f$ una sucesión de fórmulas. Entonces, la
  sucesión $\{S^{n}_{S,\mathcal{C},f}\}_n$ es una cadena.
  \end{lema}

  \noindent Su formalización es:
\<close>

(*<*)
text \<open>
  \begin{demostracion}
  Por la definición de $S^{n}_{S,\mathcal{C},f}$, se tiene que
  $\forall n. S^{n}_{S,\mathcal{C},f} \subseteq S^{n+1}_{S,\mathcal{C},f}$.
  Por lo tanto, por definición de cadena, la sucesión
  $S^{n}_{S,\mathcal{C},f}}$ es una cadena.
  \end{demostracion}
\<close>

(*>*)

lemma es_cadena_suc: "es_cadena (sucP S \<C> f)"
by (simp add: es_cadena_def) blast

text \<open>
  Por último formalizamos el siguiente teorema que afirma que si
  $\mathcal{C}$ es una propiedad de consistencia de carácter finito y
  $S$ está en $\mathcal{C}$ entonces, $S_{S,\mathcal{C},f}$ también está
  en $\mathcal{C}$.

  \begin{teorema}\label{MaxP-in-C}
  Si $\mathcal{C}$ es una propiedad de consistencia proposicional de
  carácter finito, $S\in \mathcal{C}$ y $f$ una sucesión de fórmulas,
  entonces $S_{S,\mathcal{C},f}\in \mathcal C$.
  \end{teorema}

  \begin{demostracion}
  Por el lema \ref{cadenasucP}, $\{S^{n}_{S,\mathcal{C},f}\}_n$ es una
  cadena. Además, de la hipótesis $S\in \mathcal{C}$, por inducción se
  demuestra que $S^{n}_{S,\mathcal{C},f}\in \mathcal{C}$, para todo
  $n$. De lo anterior y como $\mathcal{C}$ es una colección de carácter
  finito, usando el lema \ref{limitecadenaP} se concluye que
  $S_{S,\mathcal{C},f} \in \mathcal{C}$.
  \end{demostracion}

  \noindent Su formalización es:
\<close>

theorem MaxP_en_C:
  assumes hip1: "caracter_finito \<C>" and hip2: "S \<in> \<C>"
  shows  "MsucP S \<C> f \<in> \<C>"
proof (unfold MsucP_def)
  have "es_cadena (sucP S \<C> f)" by (rule es_cadena_suc)
  moreover
  have "\<forall>n. sucP S \<C> f n \<in> \<C>"
  proof (rule allI)
    fix n
    show "sucP S \<C> f n \<in> \<C>" using hip2
      by (induct n)(auto simp add: sucP_def)
  qed
  ultimately
  show "(\<Union> n. sucP S \<C> f n) \<in> \<C>" by (rule cadena_union_cerrado[OF hip1])
qed

text \<open>
  Para demostrar que $S_{S,\mathcal{C},f}$ es un elemento maximal de
  $\mathcal{C}$ no es necesario que $\mathcal{C}$ sea de carácter
  finito, sólo es necesario suponer que la colección $\mathcal{C}$ sea
  cerrada por subconjuntos. Sin embargo la sucesión $f$ de fórmulas debe
  corresponder a una {\em enumeración} del conjunto de fórmulas del
  lenguaje proposicional que estemos considerando. Así, en el siguiente
  teorema demostramos que si tenemos una enumeración del conjunto de
  fórmulas de un lenguaje proposicional entonces, para cualquier
  colección de conjuntos de fórmulas $\mathcal{C}$ que sea cerrada por
  subconjuntos, se tiene que el límite $S_{S,\mathcal{C},f}$, es un
  elemento maximal de $\mathcal{C}$.

 \begin{definicion}\label{enumerar}
Un conjunto $A$ es \textbf{enumerable} si es vacío o existe una función sobreyectiva
$f\colon \mathbb{N}\to A$ del conjunto de los números naturales en el conjunto $A$.
 En este caso, se dice que $f$ es una enumeración de $A$, y se puede listar como una sucesión infinita:
$f(0),f(1),f(2), \ldots , $
en la cual aparecen todos los elementos de $A$, con posibles repeticiones, y solo elementos de $A$.
En particular, cualquier conjunto finito es enumerable.
\par\par
\end{definicion}

  \noindent Su formalización es:
\<close>

definition enumeration :: "(nat \<Rightarrow>'b) \<Rightarrow> bool" where
  "enumeration f = (\<forall>y.\<exists>n. y = (f n))"

text \<open>
  Por ejemplo, la función identidad $i\colon \mathbb{N}\to \mathbb{N}$
  es sobreyectiva. Luego es una numeración de $\mathbb{N}$.

  \begin{lema}\label{enumidentidad}
  Existe una enumeración $g$ de $\mathbb{N}$.
  \end{lema}

  \noindent Su formalización es:
\<close>

lemma enum_nat: "\<exists>g. enumeration (g:: nat \<Rightarrow> nat)"
proof -
  have "\<forall>y. \<exists> n. y = (\<lambda>n. n) n" by simp
  hence "enumeration (\<lambda>n. n)" by (unfold enumeration_def)
  thus ?thesis by auto
qed

text \<open>
  \begin{teorema}\label{suc-maximalP}
  Sean $\mathbf{L}$ un lenguaje proposicional, $S$ un conjunto de
  fórmulas de $\mathbf{L}$, $\mathcal{C}$ una colección de conjuntos de
  fórmulas de $\mathbf{L}$ cerrada por subconjuntos y $f$ una enumeración
  del conjunto de fórmulas de $\mathbf{L}$. Entonces
  $S_{S,\mathcal{C},f}$ es un elemento maximal de $\mathcal{C}$.
  \end{teorema}

  \begin{demostracion}

  Sea $S'\in \mathcal{C}$. Supongamos que
  $S_{S,\mathcal{C},f} \subseteq S'$, entonces $\forall n$
  $S^{n}_{S,\mathcal{C},f} \subseteq S'$. Demostramos por contradicción
  que $\bigcup_{n} S^{n}_{S,\mathcal{C},f} = S'$.  Supongamos que
  $\bigcup_{n} S^{n}_{S,\mathcal{C},f} \neq S'$. Entonces, existe
  $z\in S'$ tal que $z\notin \bigcup_{n} S^{n}_{S,\mathcal{C},f}$.
  Luego, existe $n$ tal que $z=f_n$, puesto que $f$ es una numeración
  del conjunto de fórmulas.  Por lo tanto, $f_n\in S'$ y como
  $S^{n}_{S,\mathcal{C},f} \subseteq S'$, tenemos que
  $S^{n}_{S,\mathcal{C},f} \cup \{f_n\}\subseteq S'$. Luego,
  $S^{n}_{S,\mathcal{C},f} \cup \{f_n\}\in \mathcal{C}$, puesto que
  $\mathcal{C}$ es cerrada por subconjuntos y $S'\in \mathcal{C}$. Así,
  por definición de la sucesión
  $S^{n}_{S,\mathcal{C},f}$, $f_n \in S^{n+1}_{S,\mathcal{C},f}$.
  Por otro lado, $f_n \notin S^{n+1}_{S,\mathcal{C},f}$, ya que
  $f_n=z$ y por hipótesis $z\notin \bigcup_{n} S^{n}_{S,\mathcal{C},f}$.
  De esta forma obtenemos una contradicción.
  \end{demostracion}

  \noindent Su formalización es:
\<close>

theorem suc_maximalP:
  assumes hip1: "enumeration f" and hip2: "subconj_cerrada \<C>"
  shows "maximal (MsucP S \<C> f) \<C>"
proof (simp add: maximal_def MsucP_def)
  show "\<forall>S'\<in>\<C>. (\<Union>x. sucP S \<C> f x) \<subseteq> S' \<longrightarrow> (\<Union>x. sucP S \<C> f x) = S'"
  proof (rule ballI impI)+
    fix S'
    assume h1: "S' \<in> \<C>" and h2: "(\<Union>x. sucP S \<C> f x) \<subseteq> S'"
    show "(\<Union>x. sucP S \<C> f x) = S'"
    proof (rule ccontr)
      assume "(\<Union>x. sucP S \<C> f x) \<noteq> S'"
      hence  "\<exists>z. z \<in> S' \<and> z \<notin> (\<Union>x. sucP S \<C> f x)" using h2 by blast
      then obtain z where z: "z \<in> S' \<and> z \<notin> (\<Union>x. sucP S \<C> f x)" by (rule exE)
      have "\<exists>n. z = f n" using hip1 h1 by (unfold enumeration_def) simp
      then obtain n where n: "z = f n" by (rule exE)
      have "sucP S \<C> f n \<union> {f n} \<subseteq> S'"
      proof -
        have "f n \<in> S'" using z n  by simp
        moreover
        have "sucP S \<C> f n \<subseteq> (\<Union>x. sucP S \<C> f x)" by auto
        ultimately
        show ?thesis using h2 by simp
      qed
      hence "sucP S \<C> f n \<union> {f n} \<in> \<C>"
        using h1 hip2 by (unfold subconj_cerrada_def) simp
      hence "f n \<in> sucP S \<C> f (Suc n)" by simp
      moreover
      have "\<forall>x. f n \<notin> sucP S \<C> f x" using z n by simp
      hence "f n \<notin> sucP S \<C> f (Suc n)" by (rule_tac x = "Suc n" in allE)
      ultimately
      show False by simp
    qed
  qed
qed

text \<open>
  \begin{corolario}\label{ExtensionConsistenteP}
  Sean $\mathbf{L}$ un lenguaje proposicional, $\mathcal{C}$ una
  colección de conjuntos de fórmulas de $\mathbf{L}$ de carácter finito,
  $S$ un elemento de $\mathcal{C}$ y $f$ una enumeración del conjunto de
  fórmulas de $\mathbf{L}$. Entonces,
  \begin{itemize}
  \item[(a)] $S\subseteq S_{S,\mathcal{C},f}$.
  \item[(b)] $S_{S,\mathcal{C},f} \in \mathcal{C}$.
  \item[(c)] $S_{S,\mathcal{C},f}$ es un elemento maximal de $\mathcal{C}$.
  \end{itemize}
  \end{corolario}

  \begin{demostracion}
  \begin{itemize}
  \item[(a)] Por el teorema \ref{MaxSubconjuntoP}.

  \item[(b)] Por el teorema \ref{MaxP-in-C}, pues $\mathcal{C}$ es de
  carácter finito y $S$ está en $\mathcal{C}$.

  \item[(c)] Dado que $\mathcal{C}$ es de carácter finito, por el teorema
  \ref{CaracterFinitoCerradaP}, se tiene que $\mathcal{C}$ es cerrada
  por subconjuntos. De esto último y puesto que $f$ es una enumeración
  del conjunto de fórmulas de $\mathbf{L}$, por el teorema
  \ref{suc-maximalP}, obtenemos $(c)$.
  \end{itemize}
  \mbox{}
  \end{demostracion}

  \noindent Su formalización es:
\<close>

corollary ExtensionConsistenteP:
  assumes hip1: "caracter_finito \<C>"
  and hip2: "S \<in> \<C>"
  and hip3:  "enumeration f"
  shows "S \<subseteq> MsucP S \<C> f"
  and "MsucP S \<C> f \<in> \<C>"
  and "maximal (MsucP S \<C> f) \<C>"
proof -
  show "S \<subseteq> MsucP S \<C> f" using Max_subconjuntoP by auto
next
  show "MsucP S \<C> f \<in> \<C>" using  MaxP_en_C[OF hip1 hip2] by simp
next
  show "maximal (MsucP S \<C> f) \<C>"
    using caracter_finito_cerrado[OF hip1] and hip3 suc_maximalP
    by auto
qed

(*<*)
end
(*>*)


(*  Title:      AVL Trees

    Author:     Tobias Nipkow and Cornelia Pusch,
                converted to Isar by Gerwin Klein
                contributions by Achim Brucker, Burkhart Wolff and Jan Smaus
    Maintainer: Gerwin Klein <gerwin.klein at nicta.com.au>

    see the file Changelog for a list of changes
*)

section \<open>AVL Trees in 2 Stages\<close>

theory AVL2
imports Main
begin

text \<open>
  This development of AVL trees leads to the same implementation
  as the monolithic one (in theorey AVL) but via an intermediate
  abstraction: AVL trees where the height is recomputed rather than
  stored in the tree. This two-stage devlopment is longer than the
  monolithic one but each individual step is simpler. It should really
  be viewed as a blueprint for the development of data structures where
  some of the fields contain redundant information (for efficiency
  reasons).
\<close>

subsection \<open>Step 1: Pure binary and AVL trees\<close>

text \<open>
  The basic formulation of AVL trees builds on pure binary trees
  and recomputes all height information whenever it is required. This
  simplifies the correctness proofs.
\<close>

datatype (set_of: 'a) tree\<^sub>0 = ET\<^sub>0 |  MKT\<^sub>0 'a "'a tree\<^sub>0" "'a tree\<^sub>0"

subsubsection \<open>Auxiliary functions\<close>

primrec height :: "'a tree\<^sub>0 \<Rightarrow> nat" where
  "height ET\<^sub>0 = 0"
  | "height (MKT\<^sub>0 n l r) = 1 + max (height l) (height r)"

primrec is_ord :: "('a::preorder) tree\<^sub>0 \<Rightarrow> bool" where
  "is_ord ET\<^sub>0 = True"
  | "is_ord (MKT\<^sub>0 n l r) =
     ((\<forall>n'\<in> set_of l. n' < n) \<and> (\<forall>n'\<in> set_of r. n < n') \<and> is_ord l \<and> is_ord r)"

primrec is_bal :: "'a tree\<^sub>0 \<Rightarrow> bool" where
  "is_bal ET\<^sub>0 = True"
  | "is_bal (MKT\<^sub>0 n l r) =
   ((height l = height r \<or> height l = 1+height r \<or> height r = 1+height l) \<and>
     is_bal l \<and> is_bal r)"

subsubsection \<open>AVL interface and simple implementation\<close>

primrec is_in\<^sub>0 :: "('a::preorder) \<Rightarrow> 'a tree\<^sub>0 \<Rightarrow> bool" where
  "is_in\<^sub>0 k ET\<^sub>0 = False"
  | "is_in\<^sub>0 k (MKT\<^sub>0 n l r) = (if k = n then True else
                         if k<n then (is_in\<^sub>0 k l)
                         else (is_in\<^sub>0 k r))"

primrec l_bal\<^sub>0 :: "'a \<Rightarrow> 'a tree\<^sub>0 \<Rightarrow> 'a tree\<^sub>0 \<Rightarrow> 'a tree\<^sub>0" where
  "l_bal\<^sub>0 n (MKT\<^sub>0 ln ll lr) r =
   (if height ll < height lr
    then case lr of ET\<^sub>0 \<Rightarrow> ET\<^sub>0 \<comment> \<open>impossible\<close>
                  | MKT\<^sub>0 lrn lrl lrr \<Rightarrow> MKT\<^sub>0 lrn (MKT\<^sub>0 ln ll lrl) (MKT\<^sub>0 n lrr r)
    else MKT\<^sub>0 ln ll (MKT\<^sub>0 n lr r))"

primrec r_bal\<^sub>0 :: "'a \<Rightarrow> 'a tree\<^sub>0 \<Rightarrow> 'a tree\<^sub>0 \<Rightarrow> 'a tree\<^sub>0" where
  "r_bal\<^sub>0 n l (MKT\<^sub>0 rn rl rr) =
   (if height rl > height rr
    then case rl of ET\<^sub>0 \<Rightarrow> ET\<^sub>0 \<comment> \<open>impossible\<close>
                  | MKT\<^sub>0 rln rll rlr \<Rightarrow> MKT\<^sub>0 rln (MKT\<^sub>0 n l rll) (MKT\<^sub>0 rn rlr rr)
    else MKT\<^sub>0 rn (MKT\<^sub>0 n l rl) rr)"

primrec insrt\<^sub>0 :: "'a::preorder \<Rightarrow> 'a tree\<^sub>0 \<Rightarrow> 'a tree\<^sub>0" where
  "insrt\<^sub>0 x ET\<^sub>0 = MKT\<^sub>0 x ET\<^sub>0 ET\<^sub>0"
  | "insrt\<^sub>0 x (MKT\<^sub>0 n l r) =
     (if x=n
      then MKT\<^sub>0 n l r
      else if x<n
           then let l' = insrt\<^sub>0 x l
                in if height l' = 2+height r
                   then l_bal\<^sub>0 n l' r
                   else MKT\<^sub>0 n l' r
           else let r' = insrt\<^sub>0 x r
                in if height r' = 2+height l
                   then r_bal\<^sub>0 n l r'
                   else MKT\<^sub>0 n l r')"

subsubsection \<open>Insertion maintains AVL balance\<close>

lemma height_l_bal:
 "height l = height r + 2
  \<Longrightarrow> height (l_bal\<^sub>0 n l r) = height r + 2 \<or>
      height (l_bal\<^sub>0 n l r)  = height r + 3"
  by (cases l) (auto split: tree\<^sub>0.split if_split_asm)

lemma height_r_bal:
 "height r = height l + 2
  \<Longrightarrow> height (r_bal\<^sub>0 n l r) = height l + 2 \<or>
      height (r_bal\<^sub>0 n l r) = height l + 3"
  by (cases r) (auto split: tree\<^sub>0.split if_split_asm)

lemma height_insrt:
 "is_bal t
  \<Longrightarrow> height (insrt\<^sub>0 x t) = height t \<or> height (insrt\<^sub>0 x t) = height t + 1"
proof (induct t)
  case ET\<^sub>0 show ?case by simp
next
  case (MKT\<^sub>0 n t1 t2) then show ?case proof (cases "x < n")
    case True show ?thesis
    proof (cases "height (insrt\<^sub>0 x t1) = height t2 + 2")
      case True with height_l_bal [of _ _ n]
      have "height (l_bal\<^sub>0 n (insrt\<^sub>0 x t1) t2) =
        height t2 + 2 \<or> height (l_bal\<^sub>0 n (insrt\<^sub>0 x t1) t2) = height t2 + 3" by simp
      with \<open>x < n\<close> MKT\<^sub>0 show ?thesis by auto
    next
      case False with \<open>x < n\<close> MKT\<^sub>0 show ?thesis by auto
    qed
  next
    case False show ?thesis
    proof (cases "height (insrt\<^sub>0 x t2) = height t1 + 2")
      case True with height_r_bal [of _ _ n]
      have "height (r_bal\<^sub>0 n t1 (insrt\<^sub>0 x t2)) = height t1 + 2 \<or>
        height (r_bal\<^sub>0 n t1 (insrt\<^sub>0 x t2)) = height t1 + 3" by simp
      with \<open>\<not> x < n\<close> MKT\<^sub>0 show ?thesis by auto
    next
      case False with \<open>\<not> x < n\<close> MKT\<^sub>0 show ?thesis by auto
    qed
  qed
qed

lemma is_bal_l_bal:
  "is_bal l \<Longrightarrow> is_bal r \<Longrightarrow> height l = height r + 2 \<Longrightarrow> is_bal (l_bal\<^sub>0 n l r)"
  by (cases l) (auto, auto split: tree\<^sub>0.split)  \<comment> \<open>separating the two auto's is just for speed\<close>

lemma is_bal_r_bal:
  "is_bal l \<Longrightarrow> is_bal r \<Longrightarrow> height r = height l + 2 \<Longrightarrow> is_bal (r_bal\<^sub>0 n l r)"
  by (cases r) (auto, auto split: tree\<^sub>0.split)  \<comment> \<open>separating the two auto's is just for speed\<close>

theorem is_bal_insrt:
  "is_bal t \<Longrightarrow> is_bal(insrt\<^sub>0 x t)"
proof (induct t)
  case ET\<^sub>0 show ?case by simp
next
  case (MKT\<^sub>0 n t1 t2) show ?case proof (cases "x < n")
    case True show ?thesis
    proof (cases "height (insrt\<^sub>0 x t1) = height t2 + 2")
      case True with \<open>x < n\<close> MKT\<^sub>0 show ?thesis
        by (simp add: is_bal_l_bal)
    next
      case False with \<open>x < n\<close> MKT\<^sub>0 show ?thesis
        using height_insrt [of t1 x] by auto
    qed
  next
    case False show ?thesis
    proof (cases "height (insrt\<^sub>0 x t2) = height t1 + 2")
      case True with \<open>\<not> x < n\<close> MKT\<^sub>0 show ?thesis
        by (simp add: is_bal_r_bal)
    next
      case False with \<open>\<not> x < n\<close> MKT\<^sub>0 show ?thesis
        using height_insrt [of t2 x] by auto
    qed
  qed
qed

subsubsection \<open>Correctness of insertion\<close>

lemma set_of_l_bal: "height l = height r + 2 \<Longrightarrow>
  set_of (l_bal\<^sub>0 x l r) = insert x (set_of l \<union> set_of r)"
  by (cases l) (auto split: tree\<^sub>0.splits)

lemma set_of_r_bal: "height r = height l + 2 \<Longrightarrow>
  set_of (r_bal\<^sub>0 x l r) = insert x (set_of l \<union> set_of r)"
  by (cases r) (auto split: tree\<^sub>0.splits)

theorem set_of_insrt:
  "set_of (insrt\<^sub>0 x t) = insert x (set_of t)"
  by (induct t) (auto simp add:set_of_l_bal set_of_r_bal Let_def)

subsubsection \<open>Correctness of lookup\<close>

theorem is_in_correct: "is_ord t \<Longrightarrow> is_in\<^sub>0 k t = (k : set_of t)"
  by (induct t) (auto simp add: less_le_not_le)

subsubsection \<open>Insertion maintains order\<close>

lemma is_ord_l_bal:
 "is_ord (MKT\<^sub>0 x l r) \<Longrightarrow> height l = Suc (Suc (height r)) \<Longrightarrow>
  is_ord (l_bal\<^sub>0 x l r)"
  by (cases l) (auto split: tree\<^sub>0.splits intro: order_less_trans)

lemma is_ord_r_bal:
 "is_ord (MKT\<^sub>0 x l r) \<Longrightarrow> height r = height l + 2 \<Longrightarrow>
  is_ord (r_bal\<^sub>0 x l r)"
  by (cases r) (auto split:tree\<^sub>0.splits intro: order_less_trans)

text \<open>If the order is linear, @{const insrt\<^sub>0} maintains the order:\<close>

theorem is_ord_insrt:
 "is_ord t \<Longrightarrow> is_ord (insrt\<^sub>0 (x::'a::linorder) t)"
  by (induct t) (simp_all add:is_ord_l_bal is_ord_r_bal set_of_insrt
    linorder_not_less order_neq_le_trans Let_def)

subsection \<open>Step 2: Binary and AVL trees with height information\<close>

datatype 'a tree = ET |  MKT 'a "'a tree" "'a tree" nat

subsubsection \<open>Auxiliary functions\<close>

primrec erase :: "'a tree \<Rightarrow> 'a tree\<^sub>0" where
  "erase ET = ET\<^sub>0"
  | "erase (MKT x l r h) = MKT\<^sub>0 x (erase l) (erase r)"

primrec hinv :: "'a tree \<Rightarrow> bool" where
  "hinv ET \<longleftrightarrow> True"
  | "hinv (MKT x l r h) \<longleftrightarrow> h = 1 + max (height (erase l)) (height (erase r))
                        \<and> hinv l \<and> hinv r"

definition avl :: "'a tree \<Rightarrow> bool" where
  "avl t \<longleftrightarrow> is_bal (erase t) \<and> hinv t"

subsubsection \<open>AVL interface and efficient implementation\<close>

primrec is_in :: "('a::preorder) \<Rightarrow> 'a tree \<Rightarrow> bool" where
  "is_in k ET \<longleftrightarrow> False"
  | "is_in k (MKT n l r h) \<longleftrightarrow> (if k = n then True else
                            if k < n then (is_in k l)
                            else (is_in k r))"

primrec ht :: "'a tree \<Rightarrow> nat" where
  "ht ET = 0"
  | "ht (MKT x l r h) = h"

definition mkt :: "'a \<Rightarrow> 'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
  "mkt x l r = MKT x l r (max (ht l) (ht r) + 1)"

primrec l_bal :: "'a \<Rightarrow> 'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
  "l_bal n (MKT ln ll lr h) r =
   (if ht ll < ht lr
    then case lr of ET \<Rightarrow> ET \<comment> \<open>impossible\<close>
                  | MKT lrn lrl lrr lrh \<Rightarrow>
                    mkt lrn (mkt ln ll lrl) (mkt n lrr r)
    else mkt ln ll (mkt n lr r))"

primrec r_bal :: "'a \<Rightarrow> 'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
 "r_bal n l (MKT rn rl rr h) =
   (if ht rl > ht rr
    then case rl of ET \<Rightarrow> ET \<comment> \<open>impossible\<close>
                  | MKT rln rll rlr h \<Rightarrow> mkt rln (mkt n l rll) (mkt rn rlr rr)
    else mkt rn (mkt n l rl) rr)"

primrec insrt :: "'a::preorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
  "insrt x ET = MKT x ET ET 1"
  | "insrt x (MKT n l r h) =
     (if x=n
      then MKT n l r h
      else if x<n
           then let l' = insrt x l; hl' = ht l'; hr = ht r
                in if hl' = 2+hr then l_bal n l' r
                   else MKT n l' r (1 + max hl' hr)
           else let r' = insrt x r; hl = ht l; hr' = ht r'
                in if hr' = 2+hl then r_bal n l r'
                   else MKT n l r' (1 + max hl hr'))"

subsubsection \<open>Correctness proof\<close>

text\<open>The auxiliary functions are implemented correctly:\<close>

lemma height_hinv: "hinv t \<Longrightarrow> ht t = height (erase t)"
  by (induct t) simp_all

lemma erase_mkt: "erase (mkt n l r) = MKT\<^sub>0 n (erase l) (erase r)"
  by (simp add: mkt_def)

lemma erase_l_bal:
 "hinv l \<Longrightarrow> hinv r \<Longrightarrow> height (erase l) = height(erase r) + 2 \<Longrightarrow>
  erase (l_bal n l r) = l_bal\<^sub>0 n (erase l) (erase r)"
  by (cases l) (simp_all add: height_hinv erase_mkt split: tree.split)

lemma erase_r_bal:
 "hinv l \<Longrightarrow> hinv r \<Longrightarrow> height(erase r) = height(erase l) + 2 \<Longrightarrow>
  erase (r_bal n l r) = r_bal\<^sub>0 n (erase l) (erase r)"
  by (cases r) (simp_all add: height_hinv erase_mkt split: tree.split)

text \<open>Function @{const insrt} maintains the invariant:\<close>

lemma hinv_mkt: "hinv l \<Longrightarrow> hinv r \<Longrightarrow> hinv (mkt x l r)"
  by (simp add: height_hinv mkt_def)

lemma hinv_l_bal:
 "hinv l \<Longrightarrow> hinv r \<Longrightarrow> height(erase l) = height(erase r) + 2 \<Longrightarrow>
  hinv (l_bal n l r)"
  by (cases l) (auto simp add: hinv_mkt split: tree.splits)

lemma hinv_r_bal:
 "hinv l \<Longrightarrow> hinv r \<Longrightarrow> height(erase r) = height(erase l) + 2 \<Longrightarrow>
  hinv (r_bal n l r)"
  by (cases r) (auto simp add: hinv_mkt split: tree.splits)

theorem hinv_insrt: "hinv t \<Longrightarrow> hinv (insrt x t)"
  by (induct t) (simp_all add: Let_def height_hinv hinv_l_bal hinv_r_bal)

text\<open>Function @{const insrt} implements @{const insrt\<^sub>0}:\<close>
lemma erase_insrt: "hinv t \<Longrightarrow> erase (insrt x t) = insrt\<^sub>0 x (erase t)"
  by (induct t) (simp_all add: Let_def hinv_insrt height_hinv erase_l_bal erase_r_bal)

text\<open>Function @{const insrt} meets its spec:\<close>

corollary "avl t \<Longrightarrow> set_of (erase (insrt x t)) = insert x (set_of (erase t))"
  by (simp add: avl_def erase_insrt set_of_insrt)

text\<open>Function @{const insrt} preserves the invariants:\<close>

corollary "avl t \<Longrightarrow> avl (insrt x t)"
  by (simp add: hinv_insrt avl_def erase_insrt is_bal_insrt)

corollary
  "avl t \<Longrightarrow> is_ord (erase t) \<Longrightarrow> is_ord (erase (insrt (x::'a::linorder) t))"
  by (simp add: avl_def erase_insrt is_ord_insrt)

text\<open>Function @{const is_in} implements @{const is_in}:\<close>

theorem is_in: "is_in x t = is_in\<^sub>0 x (erase t)"
  by (induct t) simp_all

text\<open>Function @{const is_in} meets its spec:\<close>

corollary "is_ord (erase t) \<Longrightarrow> is_in x t \<longleftrightarrow> x \<in> set_of (erase t)"
  by (simp add:is_in is_in_correct)

end


section \<open>Order and Equivalence on Lenses\<close>

theory Lens_Order
imports Lens_Algebra
begin

subsection \<open>Sub-lens Relation\<close>

text \<open>A lens $X$ is a sub-lens of $Y$ if there is a well-behaved lens $Z$ such that $X = Z \lcomp Y$,
  or in other words if $X$ can be expressed purely in terms of $Y$.\<close>

definition sublens :: "('a \<Longrightarrow> 'c) \<Rightarrow> ('b \<Longrightarrow> 'c) \<Rightarrow> bool" (infix "\<subseteq>\<^sub>L" 55) where
[lens_defs]: "sublens X Y = (\<exists> Z :: ('a, 'b) lens. vwb_lens Z \<and> X = Z ;\<^sub>L Y)"

text \<open>Various lens classes are downward closed under the sublens relation.\<close>

lemma sublens_pres_mwb:
  "\<lbrakk> mwb_lens Y; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> mwb_lens X"
  by (unfold_locales, auto simp add: sublens_def lens_comp_def)

lemma sublens_pres_wb:
  "\<lbrakk> wb_lens Y; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> wb_lens X"
  by (unfold_locales, auto simp add: sublens_def lens_comp_def)

lemma sublens_pres_vwb:
  "\<lbrakk> vwb_lens Y; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> vwb_lens X"
  by (unfold_locales, auto simp add: sublens_def lens_comp_def)

text \<open>Sublens is a preorder as the following two theorems show.\<close>

lemma sublens_refl [simp]:
  "X \<subseteq>\<^sub>L X"
  using id_vwb_lens sublens_def by fastforce

lemma sublens_trans [trans]:
  "\<lbrakk> X \<subseteq>\<^sub>L Y; Y \<subseteq>\<^sub>L Z \<rbrakk> \<Longrightarrow> X \<subseteq>\<^sub>L Z"
  apply (auto simp add: sublens_def lens_comp_assoc)
  apply (rename_tac Z\<^sub>1 Z\<^sub>2)
  apply (rule_tac x="Z\<^sub>1 ;\<^sub>L Z\<^sub>2" in exI)
  apply (simp add: lens_comp_assoc)
  using comp_vwb_lens apply blast
done

text \<open>Sublens has a least element -- @{text "0\<^sub>L"} -- and a greatest element -- @{text "1\<^sub>L"}.
  Intuitively, this shows that sublens orders how large a portion of the source type a particular
  lens views, with @{text "0\<^sub>L"} observing the least, and @{text "1\<^sub>L"} observing the most.\<close>

lemma sublens_least: "wb_lens X \<Longrightarrow> 0\<^sub>L \<subseteq>\<^sub>L X"
  using sublens_def unit_vwb_lens by fastforce

lemma sublens_greatest: "vwb_lens X \<Longrightarrow> X \<subseteq>\<^sub>L 1\<^sub>L"
  by (simp add: sublens_def)

text \<open>If $Y$ is a sublens of $X$ then any put using $X$ will necessarily erase any put using $Y$.
  Similarly, any two source types are observationally equivalent by $Y$ when performed
  following a put using $X$.\<close>

lemma sublens_obs_get:
  "\<lbrakk> mwb_lens X; Y \<subseteq>\<^sub>L X \<rbrakk> \<Longrightarrow>  get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> \<sigma> v) = get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> \<rho> v)"
  by (auto simp add: sublens_def lens_comp_def)

text \<open>Sublens preserves independence; in other words if $Y$ is independent of $Z$, then also
  any $X$ smaller than $Y$ is independent of $Z$.\<close>

lemma sublens_pres_indep:
  "\<lbrakk> X \<subseteq>\<^sub>L Y; Y \<bowtie> Z \<rbrakk> \<Longrightarrow> X \<bowtie> Z"
  apply (auto intro!:lens_indepI simp add: sublens_def lens_comp_def lens_indep_comm)
  apply (simp add: lens_indep_sym)
done

lemma sublens_pres_indep':
  "\<lbrakk> X \<subseteq>\<^sub>L Y; Z \<bowtie> Y \<rbrakk> \<Longrightarrow> Z \<bowtie> X"
  by (meson lens_indep_sym sublens_pres_indep)

lemma sublens_compat: "\<lbrakk> vwb_lens X; vwb_lens Y; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> X ##\<^sub>L Y"
  unfolding lens_compat_def lens_override_def
  by (metis (no_types, opaque_lifting) sublens_obs_get sublens_put_put vwb_lens_mwb vwb_lens_wb wb_lens.get_put)

text \<open>Well-behavedness of lens quotient has sublens as a proviso. This is because we can only
  remove $X$ from $Y$ if $X$ is smaller than $Y$. \<close>

lemma lens_quotient_mwb:
  "\<lbrakk> mwb_lens Y; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> mwb_lens (X /\<^sub>L Y)"
  by (unfold_locales, auto simp add: lens_quotient_def lens_create_def sublens_def lens_comp_def comp_def)

subsection \<open>Lens Equivalence\<close>

text \<open>Using our preorder, we can also derive an equivalence on lenses as follows. It should be
  noted that this equality, like sublens, is heterogeneously typed -- it can compare lenses whose
  view types are different, so long as the source types are the same. We show that it is reflexive,
  symmetric, and transitive. \<close>

definition lens_equiv :: "('a \<Longrightarrow> 'c) \<Rightarrow> ('b \<Longrightarrow> 'c) \<Rightarrow> bool" (infix "\<approx>\<^sub>L" 51) where
[lens_defs]: "lens_equiv X Y = (X \<subseteq>\<^sub>L Y \<and> Y \<subseteq>\<^sub>L X)"

lemma lens_equivI [intro]:
  "\<lbrakk> X \<subseteq>\<^sub>L Y; Y \<subseteq>\<^sub>L X \<rbrakk> \<Longrightarrow> X \<approx>\<^sub>L Y"
  by (simp add: lens_equiv_def)

lemma lens_equiv_refl [simp]:
  "X \<approx>\<^sub>L X"
  by (simp add: lens_equiv_def)

lemma lens_equiv_sym:
  "X \<approx>\<^sub>L Y \<Longrightarrow> Y \<approx>\<^sub>L X"
  by (simp add: lens_equiv_def)

lemma lens_equiv_trans [trans]:
  "\<lbrakk> X \<approx>\<^sub>L Y; Y \<approx>\<^sub>L Z \<rbrakk> \<Longrightarrow> X \<approx>\<^sub>L Z"
  by (auto intro: sublens_trans simp add: lens_equiv_def)

lemma lens_equiv_pres_indep:
  "\<lbrakk> X \<approx>\<^sub>L Y; Y \<bowtie> Z \<rbrakk> \<Longrightarrow> X \<bowtie> Z"
  using lens_equiv_def sublens_pres_indep by blast

lemma lens_equiv_pres_indep':
  "\<lbrakk> X \<approx>\<^sub>L Y; Z \<bowtie> Y \<rbrakk> \<Longrightarrow> Z \<bowtie> X"
  using lens_equiv_def sublens_pres_indep' by blast

lemma lens_comp_cong_1: "X \<approx>\<^sub>L Y \<Longrightarrow> X ;\<^sub>L Z \<approx>\<^sub>L Y ;\<^sub>L Z"
  unfolding lens_equiv_def
  by (metis (no_types, lifting) lens_comp_assoc sublens_def)

subsection \<open>Further Algebraic Laws\<close>

text \<open>This law explains the behaviour of lens quotient.\<close>

lemma lens_quotient_comp:
  "\<lbrakk> weak_lens Y; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> (X /\<^sub>L Y) ;\<^sub>L Y = X"
  by (auto simp add: lens_quotient_def lens_comp_def comp_def sublens_def)

text \<open>Plus distributes through quotient.\<close>

lemma lens_quotient_plus:
  "\<lbrakk> mwb_lens Z; X \<subseteq>\<^sub>L Z; Y \<subseteq>\<^sub>L Z \<rbrakk> \<Longrightarrow> (X +\<^sub>L Y) /\<^sub>L Z = (X /\<^sub>L Z) +\<^sub>L (Y /\<^sub>L Z)"
  apply (auto simp add: lens_quotient_def lens_plus_def sublens_def lens_comp_def comp_def)
  apply (rule ext)
  apply (rule ext)
  apply (simp add: prod.case_eq_if)
done

text \<open>Laws for for lens plus on the denominator. These laws allow us to extract compositions
  of @{term "fst\<^sub>L"} and @{term "snd\<^sub>L"} terms. \<close>

lemma lens_quotient_plus_den1:
  "\<lbrakk> weak_lens x; weak_lens y; x \<bowtie> y \<rbrakk> \<Longrightarrow> x /\<^sub>L (x +\<^sub>L y) = fst\<^sub>L"
  by (auto simp add: lens_defs prod.case_eq_if fun_eq_iff, metis (lifting) lens_indep_def weak_lens.put_get)

lemma lens_quotient_plus_den2: "\<lbrakk> weak_lens x; weak_lens z; x \<bowtie> z; y \<subseteq>\<^sub>L z \<rbrakk> \<Longrightarrow> y /\<^sub>L (x +\<^sub>L z) = (y /\<^sub>L z) ;\<^sub>L snd\<^sub>L "
  by (auto simp add: lens_defs prod.case_eq_if fun_eq_iff lens_indep.lens_put_irr2)

text \<open>There follows a number of laws relating sublens and summation. Firstly, sublens is preserved
  by summation. \<close>

lemma plus_pred_sublens: "\<lbrakk> mwb_lens Z; X \<subseteq>\<^sub>L Z; Y \<subseteq>\<^sub>L Z; X \<bowtie> Y \<rbrakk> \<Longrightarrow> (X +\<^sub>L Y) \<subseteq>\<^sub>L Z"
  apply (auto simp add: sublens_def)
  apply (rename_tac Z\<^sub>1 Z\<^sub>2)
  apply (rule_tac x="Z\<^sub>1 +\<^sub>L Z\<^sub>2" in exI)
  apply (auto intro!: plus_wb_lens)
   apply (simp add: lens_comp_indep_cong_left)
  apply (simp add: plus_lens_distr)
done

text \<open>Intuitively, lens plus is associative. However we cannot prove this using HOL equality due
  to monomorphic typing of this operator. But since sublens and lens equivalence are both heterogeneous
  we can now prove this in the following three lemmas.\<close>

lemma lens_plus_sub_assoc_1:
  "X +\<^sub>L Y +\<^sub>L Z \<subseteq>\<^sub>L (X +\<^sub>L Y) +\<^sub>L Z"
  apply (simp add: sublens_def)
  apply (rule_tac x="(fst\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L (snd\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L snd\<^sub>L" in exI)
  apply (auto)
   apply (rule plus_vwb_lens)
     apply (simp add: comp_vwb_lens fst_vwb_lens)
    apply (rule plus_vwb_lens)
      apply (simp add: comp_vwb_lens fst_vwb_lens snd_vwb_lens)
     apply (simp add: snd_vwb_lens)
    apply (simp add: lens_indep_left_ext)
   apply (rule lens_indep_sym)
   apply (rule plus_pres_lens_indep)
    using fst_snd_lens_indep fst_vwb_lens lens_indep_left_comp lens_indep_sym vwb_lens_mwb apply blast
   using fst_snd_lens_indep lens_indep_left_ext lens_indep_sym apply blast
  apply (auto simp add: lens_plus_def lens_comp_def fst_lens_def snd_lens_def prod.case_eq_if split_beta')[1]
done

lemma lens_plus_sub_assoc_2:
  "(X +\<^sub>L Y) +\<^sub>L Z \<subseteq>\<^sub>L X +\<^sub>L Y +\<^sub>L Z"
  apply (simp add: sublens_def)
  apply (rule_tac x="(fst\<^sub>L +\<^sub>L (fst\<^sub>L ;\<^sub>L snd\<^sub>L)) +\<^sub>L (snd\<^sub>L ;\<^sub>L snd\<^sub>L)" in exI)
  apply (auto)
   apply (rule plus_vwb_lens)
     apply (rule plus_vwb_lens)
       apply (simp add: fst_vwb_lens)
      apply (simp add: comp_vwb_lens fst_vwb_lens snd_vwb_lens)
     apply (rule lens_indep_sym)
     apply (rule lens_indep_left_ext)
     using fst_snd_lens_indep lens_indep_sym apply blast
    apply (auto intro: comp_vwb_lens simp add: snd_vwb_lens)
   apply (rule plus_pres_lens_indep)
    apply (simp add: lens_indep_left_ext lens_indep_sym)
   apply (simp add: snd_vwb_lens)
  apply (auto simp add: lens_plus_def lens_comp_def fst_lens_def snd_lens_def prod.case_eq_if split_beta')[1]
done

lemma lens_plus_assoc:
  "(X +\<^sub>L Y) +\<^sub>L Z \<approx>\<^sub>L X +\<^sub>L Y +\<^sub>L Z"
  by (simp add: lens_equivI lens_plus_sub_assoc_1 lens_plus_sub_assoc_2)

text \<open>We can similarly show that it is commutative.\<close>

lemma lens_plus_sub_comm: "X \<bowtie> Y \<Longrightarrow> X +\<^sub>L Y \<subseteq>\<^sub>L Y +\<^sub>L X"
  apply (simp add: sublens_def)
  apply (rule_tac x="snd\<^sub>L +\<^sub>L fst\<^sub>L" in exI)
  apply (auto)
   apply (simp add: fst_vwb_lens lens_indep_sym snd_vwb_lens)
  apply (simp add: lens_indep_sym lens_plus_swap)
done

lemma lens_plus_comm: "X \<bowtie> Y \<Longrightarrow> X +\<^sub>L Y \<approx>\<^sub>L Y +\<^sub>L X"
  by (simp add: lens_equivI lens_indep_sym lens_plus_sub_comm)

text \<open>Any composite lens is larger than an element of the lens, as demonstrated by the following
  four laws.\<close>

lemma lens_plus_ub [simp]: "wb_lens Y \<Longrightarrow> X \<subseteq>\<^sub>L X +\<^sub>L Y"
  by (metis fst_lens_plus fst_vwb_lens sublens_def)

lemma lens_plus_right_sublens:
  "\<lbrakk> vwb_lens Y; Y \<bowtie> Z; X \<subseteq>\<^sub>L Z \<rbrakk> \<Longrightarrow> X \<subseteq>\<^sub>L Y +\<^sub>L Z"
  apply (auto simp add: sublens_def)
  apply (rename_tac Z')
  apply (rule_tac x="Z' ;\<^sub>L snd\<^sub>L" in exI)
  apply (auto)
  using comp_vwb_lens snd_vwb_lens apply blast
  apply (metis lens_comp_assoc snd_lens_plus vwb_lens_def)
  done

lemma lens_plus_mono_left:
  "\<lbrakk> Y \<bowtie> Z; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> X +\<^sub>L Z \<subseteq>\<^sub>L Y +\<^sub>L Z"
  apply (auto simp add: sublens_def)
  apply (rename_tac Z')
  apply (rule_tac x="Z' \<times>\<^sub>L 1\<^sub>L" in exI)
  apply (subst prod_lens_comp_plus)
   apply (simp_all)
  using id_vwb_lens prod_vwb_lens apply blast
  done

lemma lens_plus_mono_right:
  "\<lbrakk> X \<bowtie> Z; Y \<subseteq>\<^sub>L Z \<rbrakk> \<Longrightarrow> X +\<^sub>L Y \<subseteq>\<^sub>L X +\<^sub>L Z"
  by (metis prod_lens_comp_plus prod_vwb_lens sublens_def sublens_refl)

text \<open>If we compose a lens $X$ with lens $Y$ then naturally the resulting lens must be smaller
  than $Y$, as $X$ views a part of $Y$. \<close>

lemma lens_comp_lb [simp]: "vwb_lens X \<Longrightarrow> X ;\<^sub>L Y \<subseteq>\<^sub>L Y"
  by (auto simp add: sublens_def)

lemma sublens_comp [simp]:
  assumes "vwb_lens b" "c \<subseteq>\<^sub>L a"
  shows "(b ;\<^sub>L c) \<subseteq>\<^sub>L a"
  by (metis assms sublens_def sublens_trans)

text \<open>We can now also show that @{text "0\<^sub>L"} is the unit of lens plus\<close>

lemma lens_unit_plus_sublens_1: "X \<subseteq>\<^sub>L 0\<^sub>L +\<^sub>L X"
  by (metis lens_comp_lb snd_lens_plus snd_vwb_lens zero_lens_indep unit_wb_lens)

lemma lens_unit_prod_sublens_2: "0\<^sub>L +\<^sub>L X \<subseteq>\<^sub>L X"
  apply (auto simp add: sublens_def)
  apply (rule_tac x="0\<^sub>L +\<^sub>L 1\<^sub>L" in exI)
  apply (auto)
  apply (auto simp add: lens_plus_def zero_lens_def lens_comp_def id_lens_def prod.case_eq_if comp_def)
  apply (rule ext)
  apply (rule ext)
  apply (auto)
done

lemma lens_plus_left_unit: "0\<^sub>L +\<^sub>L X \<approx>\<^sub>L X"
  by (simp add: lens_equivI lens_unit_plus_sublens_1 lens_unit_prod_sublens_2)

lemma lens_plus_right_unit: "X +\<^sub>L 0\<^sub>L \<approx>\<^sub>L X"
  using lens_equiv_trans lens_indep_sym lens_plus_comm lens_plus_left_unit zero_lens_indep by blast

text \<open>We can also show that both sublens and equivalence are congruences with respect to lens plus
  and lens product.\<close>

lemma lens_plus_subcong: "\<lbrakk> Y\<^sub>1 \<bowtie> Y\<^sub>2; X\<^sub>1 \<subseteq>\<^sub>L Y\<^sub>1; X\<^sub>2 \<subseteq>\<^sub>L Y\<^sub>2 \<rbrakk> \<Longrightarrow> X\<^sub>1 +\<^sub>L X\<^sub>2 \<subseteq>\<^sub>L Y\<^sub>1 +\<^sub>L Y\<^sub>2"
  by (metis prod_lens_comp_plus prod_vwb_lens sublens_def)

lemma lens_plus_eq_left: "\<lbrakk> X \<bowtie> Z; X \<approx>\<^sub>L Y \<rbrakk> \<Longrightarrow> X +\<^sub>L Z \<approx>\<^sub>L Y +\<^sub>L Z"
  by (meson lens_equiv_def lens_plus_mono_left sublens_pres_indep)

lemma lens_plus_eq_right: "\<lbrakk> X \<bowtie> Y; Y \<approx>\<^sub>L Z \<rbrakk> \<Longrightarrow> X +\<^sub>L Y \<approx>\<^sub>L X +\<^sub>L Z"
  by (meson lens_equiv_def lens_indep_sym lens_plus_mono_right sublens_pres_indep)

lemma lens_plus_cong:
  assumes "X\<^sub>1 \<bowtie> X\<^sub>2" "X\<^sub>1 \<approx>\<^sub>L Y\<^sub>1" "X\<^sub>2 \<approx>\<^sub>L Y\<^sub>2"
  shows "X\<^sub>1 +\<^sub>L X\<^sub>2 \<approx>\<^sub>L Y\<^sub>1 +\<^sub>L Y\<^sub>2"
proof -
  have "X\<^sub>1 +\<^sub>L X\<^sub>2 \<approx>\<^sub>L Y\<^sub>1 +\<^sub>L X\<^sub>2"
    by (simp add: assms(1) assms(2) lens_plus_eq_left)
  moreover have "... \<approx>\<^sub>L Y\<^sub>1 +\<^sub>L Y\<^sub>2"
    using assms(1) assms(2) assms(3) lens_equiv_def lens_plus_eq_right sublens_pres_indep by blast
  ultimately show ?thesis
    using lens_equiv_trans by blast
qed

lemma prod_lens_sublens_cong:
  "\<lbrakk> X\<^sub>1 \<subseteq>\<^sub>L X\<^sub>2; Y\<^sub>1 \<subseteq>\<^sub>L Y\<^sub>2 \<rbrakk> \<Longrightarrow> (X\<^sub>1 \<times>\<^sub>L Y\<^sub>1) \<subseteq>\<^sub>L (X\<^sub>2 \<times>\<^sub>L Y\<^sub>2)"
  apply (auto simp add: sublens_def)
  apply (rename_tac Z\<^sub>1 Z\<^sub>2)
  apply (rule_tac x="Z\<^sub>1 \<times>\<^sub>L Z\<^sub>2" in exI)
  apply (auto)
   using prod_vwb_lens apply blast
  apply (auto simp add: lens_prod_def lens_comp_def prod.case_eq_if)
  apply (rule ext, rule ext)
  apply (auto simp add: lens_prod_def lens_comp_def prod.case_eq_if)
done

lemma prod_lens_equiv_cong:
  "\<lbrakk> X\<^sub>1 \<approx>\<^sub>L X\<^sub>2; Y\<^sub>1 \<approx>\<^sub>L Y\<^sub>2 \<rbrakk> \<Longrightarrow> (X\<^sub>1 \<times>\<^sub>L Y\<^sub>1) \<approx>\<^sub>L (X\<^sub>2 \<times>\<^sub>L Y\<^sub>2)"
  by (simp add: lens_equiv_def prod_lens_sublens_cong)

text \<open>We also have the following "exchange" law that allows us to switch over a lens product and plus.\<close>

lemma lens_plus_prod_exchange:
  "(X\<^sub>1 +\<^sub>L X\<^sub>2) \<times>\<^sub>L (Y\<^sub>1 +\<^sub>L Y\<^sub>2) \<approx>\<^sub>L (X\<^sub>1 \<times>\<^sub>L Y\<^sub>1) +\<^sub>L (X\<^sub>2 \<times>\<^sub>L Y\<^sub>2)"
proof (rule lens_equivI)
  show "(X\<^sub>1 +\<^sub>L X\<^sub>2) \<times>\<^sub>L (Y\<^sub>1 +\<^sub>L Y\<^sub>2) \<subseteq>\<^sub>L (X\<^sub>1 \<times>\<^sub>L Y\<^sub>1) +\<^sub>L (X\<^sub>2 \<times>\<^sub>L Y\<^sub>2)"
    apply (simp add: sublens_def)
    apply (rule_tac x="((fst\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L (fst\<^sub>L ;\<^sub>L snd\<^sub>L)) +\<^sub>L ((snd\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L (snd\<^sub>L ;\<^sub>L snd\<^sub>L))" in exI)
    apply (auto)
     apply (auto intro!: plus_vwb_lens comp_vwb_lens fst_vwb_lens snd_vwb_lens lens_indep_right_comp)
       apply (auto intro!: lens_indepI simp add: lens_comp_def lens_plus_def fst_lens_def snd_lens_def)
    apply (auto simp add: lens_prod_def lens_plus_def lens_comp_def fst_lens_def snd_lens_def prod.case_eq_if comp_def)[1]
    apply (rule ext, rule ext, auto simp add: prod.case_eq_if)
  done
  show "(X\<^sub>1 \<times>\<^sub>L Y\<^sub>1) +\<^sub>L (X\<^sub>2 \<times>\<^sub>L Y\<^sub>2) \<subseteq>\<^sub>L (X\<^sub>1 +\<^sub>L X\<^sub>2) \<times>\<^sub>L (Y\<^sub>1 +\<^sub>L Y\<^sub>2)"
    apply (simp add: sublens_def)
    apply (rule_tac x="((fst\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L (fst\<^sub>L ;\<^sub>L snd\<^sub>L)) +\<^sub>L ((snd\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L (snd\<^sub>L ;\<^sub>L snd\<^sub>L))" in exI)
    apply (auto)
     apply (auto intro!: plus_vwb_lens comp_vwb_lens fst_vwb_lens snd_vwb_lens lens_indep_right_comp)
       apply (auto intro!: lens_indepI simp add: lens_comp_def lens_plus_def fst_lens_def snd_lens_def)
     apply (auto simp add: lens_prod_def lens_plus_def lens_comp_def fst_lens_def snd_lens_def prod.case_eq_if comp_def)[1]
    apply (rule ext, rule ext, auto simp add: lens_prod_def prod.case_eq_if)
  done
qed

lemma lens_get_put_quasi_commute:
  "\<lbrakk> vwb_lens Y; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> s v) = put\<^bsub>X /\<^sub>L Y\<^esub> (get\<^bsub>Y\<^esub> s) v"
proof -
  assume a1: "vwb_lens Y"
  assume a2: "X \<subseteq>\<^sub>L Y"
  have "\<And>l la. put\<^bsub>l ;\<^sub>L la\<^esub> = (\<lambda>b c. put\<^bsub>la\<^esub> (b::'b) (put\<^bsub>l\<^esub> (get\<^bsub>la\<^esub> b::'a) (c::'c)))"
    by (simp add: lens_comp_def)
  then have "\<And>l la b c. get\<^bsub>l\<^esub> (put\<^bsub>la ;\<^sub>L l\<^esub> (b::'b) (c::'c)) = put\<^bsub>la\<^esub> (get\<^bsub>l\<^esub> b::'a) c \<or> \<not> weak_lens l"
    by force
  then show ?thesis
    using a2 a1 by (metis lens_quotient_comp vwb_lens_wb wb_lens_def)
qed

lemma lens_put_of_quotient:
  "\<lbrakk> vwb_lens Y; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> put\<^bsub>Y\<^esub> s (put\<^bsub>X /\<^sub>L Y\<^esub> v\<^sub>2 v\<^sub>1) = put\<^bsub>X\<^esub> (put\<^bsub>Y\<^esub> s v\<^sub>2) v\<^sub>1"
proof -
  assume a1: "vwb_lens Y"
  assume a2: "X \<subseteq>\<^sub>L Y"
  have f3: "\<And>l b. put\<^bsub>l\<^esub> (b::'b) (get\<^bsub>l\<^esub> b::'a) = b \<or> \<not> vwb_lens l"
    by force
  have f4: "\<And>b c. put\<^bsub>X /\<^sub>L Y\<^esub> (get\<^bsub>Y\<^esub> b) c = get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> b c)"
    using a2 a1 by (simp add: lens_get_put_quasi_commute)
  have "\<And>b c a. put\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> b c) a = put\<^bsub>Y\<^esub> b a"
    using a2 a1 by (simp add: sublens_put_put)
  then show ?thesis
    using f4 f3 a1 by (metis mwb_lens.put_put mwb_lens_def vwb_lens_mwb weak_lens.put_get)
qed

text \<open> If two lenses are both independent and equivalent then they must be ineffectual. \<close>

lemma indep_and_equiv_implies_ief:
  assumes "wb_lens x" "x \<bowtie> y" "x \<approx>\<^sub>L y"
  shows "ief_lens x"
proof -
  have "x \<bowtie> x"
    using assms(2) assms(3) lens_equiv_pres_indep' by blast
  thus ?thesis
    using assms(1) lens_indep_quasi_irrefl vwb_lens_wb wb_lens_weak by blast
qed

lemma indep_eff_implies_not_equiv [simp]:
  fixes x :: "'a::two \<Longrightarrow> 'b"
  assumes "wb_lens x" "x \<bowtie> y"
  shows "\<not> (x \<approx>\<^sub>L y)"
  using assms indep_and_equiv_implies_ief no_ief_two_view by blast

subsection \<open>Bijective Lens Equivalences\<close>

text \<open>A bijective lens, like a bijective function, is its own inverse. Thus, if we compose its inverse
  with itself we get @{term "1\<^sub>L"}.\<close>

lemma bij_lens_inv_left:
  "bij_lens X \<Longrightarrow> inv\<^sub>L X ;\<^sub>L X = 1\<^sub>L"
  by (auto simp add: lens_inv_def lens_comp_def lens_create_def comp_def id_lens_def, rule ext, auto)

lemma bij_lens_inv_right:
  "bij_lens X \<Longrightarrow> X ;\<^sub>L inv\<^sub>L X = 1\<^sub>L"
  by (auto simp add: lens_inv_def lens_comp_def comp_def id_lens_def, rule ext, auto)

text \<open>The following important results shows that bijective lenses are precisely those that are
  equivalent to identity. In other words, a bijective lens views all of the source type.\<close>

lemma bij_lens_equiv_id:
  "bij_lens X \<longleftrightarrow> X \<approx>\<^sub>L 1\<^sub>L"
  apply (auto)
   apply (rule lens_equivI)
    apply (simp_all add: sublens_def)
   apply (rule_tac x="lens_inv X" in exI)
   apply (simp add: bij_lens_inv_left lens_inv_bij)
  apply (auto simp add: lens_equiv_def sublens_def id_lens_def lens_comp_def comp_def)
  apply (unfold_locales)
   apply (simp)
  apply (simp)
  apply (metis (no_types, lifting) vwb_lens_wb wb_lens_weak weak_lens.put_get)
done

text \<open>For this reason, by transitivity, any two bijective lenses with the same source type must be equivalent.\<close>

lemma bij_lens_equiv:
  "\<lbrakk> bij_lens X; X \<approx>\<^sub>L Y \<rbrakk> \<Longrightarrow> bij_lens Y"
  by (meson bij_lens_equiv_id lens_equiv_def sublens_trans)

lemma bij_lens_cong:
  "X \<approx>\<^sub>L Y \<Longrightarrow> bij_lens X = bij_lens Y"
  by (meson bij_lens_equiv lens_equiv_sym)

text \<open>We can also show that the identity lens @{term "1\<^sub>L"} is unique. That is to say it is the only
  lens which when compose with $Y$ will yield $Y$.\<close>

lemma lens_id_unique:
  "weak_lens Y \<Longrightarrow> Y = X ;\<^sub>L Y \<Longrightarrow> X = 1\<^sub>L"
  apply (cases Y)
  apply (cases X)
  apply (auto simp add: lens_comp_def comp_def id_lens_def fun_eq_iff)
   apply (metis select_convs(1) weak_lens.create_get)
  apply (metis select_convs(1) select_convs(2) weak_lens.put_get)
done

text \<open>Consequently, if composition of two lenses $X$ and $Y$ yields @{text "1\<^sub>L"}, then both
  of the composed lenses must be bijective.\<close>

lemma bij_lens_via_comp_id_left:
  "\<lbrakk> wb_lens X; wb_lens Y; X ;\<^sub>L Y = 1\<^sub>L \<rbrakk> \<Longrightarrow> bij_lens X"
  apply (cases Y)
  apply (cases X)
  apply (auto simp add: lens_comp_def comp_def id_lens_def fun_eq_iff)
  apply (unfold_locales)
   apply (simp_all)
   using vwb_lens_wb wb_lens_weak weak_lens.put_get apply fastforce
  apply (metis select_convs(1) select_convs(2) wb_lens_weak weak_lens.put_get)
done

lemma bij_lens_via_comp_id_right:
  "\<lbrakk> wb_lens X; wb_lens Y; X ;\<^sub>L Y = 1\<^sub>L \<rbrakk> \<Longrightarrow> bij_lens Y"
  apply (cases Y)
  apply (cases X)
  apply (auto simp add: lens_comp_def comp_def id_lens_def fun_eq_iff)
  apply (unfold_locales)
   apply (simp_all)
   using vwb_lens_wb wb_lens_weak weak_lens.put_get apply fastforce
  apply (metis select_convs(1) select_convs(2) wb_lens_weak weak_lens.put_get)
done

text \<open>Importantly, an equivalence between two lenses can be demonstrated by showing that one lens
  can be converted to the other by application of a suitable bijective lens $Z$. This $Z$ lens
  converts the view type of one to the view type of the other.\<close>

lemma lens_equiv_via_bij:
  assumes "bij_lens Z" "X = Z ;\<^sub>L Y"
  shows "X \<approx>\<^sub>L Y"
  using assms
  apply (auto simp add: lens_equiv_def sublens_def)
   using bij_lens_vwb apply blast
  apply (rule_tac x="lens_inv Z" in exI)
  apply (auto simp add: lens_comp_assoc bij_lens_inv_left)
   using bij_lens_vwb lens_inv_bij apply blast
done

text \<open>Indeed, we actually have a stronger result than this -- the equivalent lenses are precisely
  those than can be converted to one another through a suitable bijective lens. Bijective lenses
  can thus be seen as a special class of "adapter" lens.\<close>

lemma lens_equiv_iff_bij:
  assumes "weak_lens Y"
  shows "X \<approx>\<^sub>L Y \<longleftrightarrow> (\<exists> Z. bij_lens Z \<and> X = Z ;\<^sub>L Y)"
  apply (rule iffI)
   apply (auto simp add: lens_equiv_def sublens_def lens_id_unique)[1]
   apply (rename_tac Z\<^sub>1 Z\<^sub>2)
   apply (rule_tac x="Z\<^sub>1" in exI)
   apply (simp)
   apply (subgoal_tac "Z\<^sub>2 ;\<^sub>L Z\<^sub>1 = 1\<^sub>L")
    apply (meson bij_lens_via_comp_id_right vwb_lens_wb)
   apply (metis assms lens_comp_assoc lens_id_unique)
  using lens_equiv_via_bij apply blast
done

lemma pbij_plus_commute:
  "\<lbrakk> a \<bowtie> b; mwb_lens a; mwb_lens b; pbij_lens (b +\<^sub>L a) \<rbrakk> \<Longrightarrow> pbij_lens (a +\<^sub>L b)"
  apply (unfold_locales, simp_all add:lens_defs lens_indep_sym prod.case_eq_if)
  using lens_indep.lens_put_comm pbij_lens.put_det apply fastforce
  done

subsection \<open>Lens Override Laws\<close>

text \<open>The following laws are analogus to the equivalent laws for functions.\<close>

lemma lens_override_id [simp]:
  "S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on 1\<^sub>L = S\<^sub>2"
  by (simp add: lens_override_def id_lens_def)

lemma lens_override_unit [simp]:
  "S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on 0\<^sub>L = S\<^sub>1"
  by (simp add: lens_override_def zero_lens_def)

lemma lens_override_overshadow:
  assumes "mwb_lens Y"  "X \<subseteq>\<^sub>L Y"
  shows "(S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on X) \<oplus>\<^sub>L S\<^sub>3 on Y = S\<^sub>1 \<oplus>\<^sub>L S\<^sub>3 on Y"
  using assms by (simp add: lens_override_def sublens_put_put)

lemma lens_override_irr:
  assumes "X \<bowtie> Y"
  shows "S\<^sub>1 \<oplus>\<^sub>L (S\<^sub>2 \<oplus>\<^sub>L S\<^sub>3 on Y) on X = S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on X"
  using assms by (simp add: lens_override_def)

lemma lens_override_overshadow_left:
  assumes "mwb_lens X"
  shows "(S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on X) \<oplus>\<^sub>L S\<^sub>3 on X = S\<^sub>1 \<oplus>\<^sub>L S\<^sub>3 on X"
  by (simp add: assms lens_override_def)

lemma lens_override_overshadow_right:
  assumes "mwb_lens X"
  shows "S\<^sub>1 \<oplus>\<^sub>L (S\<^sub>2  \<oplus>\<^sub>L S\<^sub>3 on X) on X = S\<^sub>1 \<oplus>\<^sub>L S\<^sub>3 on X"
  by (simp add: assms lens_override_def)

lemma lens_override_plus:
  "X \<bowtie> Y \<Longrightarrow> S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on (X +\<^sub>L Y) = (S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on X) \<oplus>\<^sub>L S\<^sub>2 on Y"
  by (simp add: lens_indep_comm lens_override_def lens_plus_def)

lemma lens_override_idem [simp]:
  "vwb_lens X \<Longrightarrow> S \<oplus>\<^sub>L S on X = S"
  by (simp add: lens_override_def)

lemma lens_override_mwb_idem [simp]:
  "\<lbrakk> mwb_lens X; S \<in> \<S>\<^bsub>X\<^esub> \<rbrakk> \<Longrightarrow> S \<oplus>\<^sub>L S on X = S"
  by (simp add: lens_override_def)

lemma lens_override_put_right_in:
  "\<lbrakk> vwb_lens A; X \<subseteq>\<^sub>L A \<rbrakk> \<Longrightarrow> S\<^sub>1 \<oplus>\<^sub>L (put\<^bsub>X\<^esub> S\<^sub>2 v) on A = put\<^bsub>X\<^esub> (S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on A) v"
  by (simp add: lens_override_def lens_get_put_quasi_commute lens_put_of_quotient)

lemma lens_override_put_right_out:
  "\<lbrakk> vwb_lens A; X \<bowtie> A \<rbrakk> \<Longrightarrow> S\<^sub>1 \<oplus>\<^sub>L (put\<^bsub>X\<^esub> S\<^sub>2 v) on A = (S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on A)"
  by (simp add: lens_override_def  lens_indep.lens_put_irr2)

lemma lens_indep_overrideI:
  assumes "vwb_lens X" "vwb_lens Y" "(\<And> s\<^sub>1 s\<^sub>2 s\<^sub>3. s\<^sub>1 \<oplus>\<^sub>L s\<^sub>2 on X \<oplus>\<^sub>L s\<^sub>3 on Y = s\<^sub>1 \<oplus>\<^sub>L s\<^sub>3 on Y \<oplus>\<^sub>L s\<^sub>2 on X)"
  shows "X \<bowtie> Y"
  using assms
  apply (unfold_locales)
  apply (simp_all add: lens_override_def)
  apply (metis mwb_lens_def vwb_lens_mwb weak_lens.put_get)
  apply (metis lens_override_def lens_override_idem mwb_lens_def vwb_lens_mwb weak_lens.put_get)
  apply (metis mwb_lens_weak vwb_lens_mwb vwb_lens_wb wb_lens.get_put weak_lens.put_get)
  done

lemma lens_indep_override_def:
  assumes "vwb_lens X" "vwb_lens Y"
  shows "X \<bowtie> Y \<longleftrightarrow> (\<forall> s\<^sub>1 s\<^sub>2 s\<^sub>3. s\<^sub>1 \<oplus>\<^sub>L s\<^sub>2 on X \<oplus>\<^sub>L s\<^sub>3 on Y = s\<^sub>1 \<oplus>\<^sub>L s\<^sub>3 on Y \<oplus>\<^sub>L s\<^sub>2 on X)"
  by (metis assms(1) assms(2) lens_indep_comm lens_indep_overrideI lens_override_def)

text \<open> Alternative characterisation of very-well behaved lenses: override is idempotent. \<close>

lemma override_idem_implies_vwb:
  "\<lbrakk> mwb_lens X; \<And> s. s \<oplus>\<^sub>L s on X = s \<rbrakk> \<Longrightarrow> vwb_lens X"
  by (unfold_locales, simp_all add: lens_defs)

subsection \<open> Alternative Sublens Characterisation \<close>

text \<open> The following definition is equivalent to the above when the two lenses are very well behaved. \<close>

definition sublens' :: "('a \<Longrightarrow> 'c) \<Rightarrow> ('b \<Longrightarrow> 'c) \<Rightarrow> bool" (infix "\<subseteq>\<^sub>L''" 55) where
[lens_defs]: "sublens' X Y = (\<forall> s\<^sub>1 s\<^sub>2 s\<^sub>3. s\<^sub>1 \<oplus>\<^sub>L s\<^sub>2 on Y \<oplus>\<^sub>L s\<^sub>3 on X = s\<^sub>1 \<oplus>\<^sub>L s\<^sub>2 \<oplus>\<^sub>L s\<^sub>3 on X on Y)"

text \<open> We next prove some characteristic properties of our alternative definition of sublens. \<close>

lemma sublens'_prop1:
  assumes "vwb_lens X" "X \<subseteq>\<^sub>L' Y"
  shows "put\<^bsub>X\<^esub> (put\<^bsub>Y\<^esub> s\<^sub>1 (get\<^bsub>Y\<^esub> s\<^sub>2)) s\<^sub>3 = put\<^bsub>Y\<^esub> s\<^sub>1 (get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> s\<^sub>2 s\<^sub>3))"
  using assms
  by (simp add: sublens'_def, metis lens_override_def mwb_lens_def vwb_lens_mwb weak_lens.put_get)

lemma sublens'_prop2:
  assumes "vwb_lens X" "X \<subseteq>\<^sub>L' Y"
  shows "get\<^bsub>X\<^esub> (put\<^bsub>Y\<^esub> s\<^sub>1 (get\<^bsub>Y\<^esub> s\<^sub>2)) = get\<^bsub>X\<^esub> s\<^sub>2"
  using assms unfolding sublens'_def
  by (metis lens_override_def vwb_lens_wb wb_lens_axioms_def wb_lens_def weak_lens.put_get)

lemma sublens'_prop3:
  assumes "vwb_lens X" "vwb_lens Y" "X \<subseteq>\<^sub>L' Y"
  shows "put\<^bsub>Y\<^esub> \<sigma> (get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> (put\<^bsub>Y\<^esub> \<rho> (get\<^bsub>Y\<^esub> \<sigma>)) v)) = put\<^bsub>X\<^esub> \<sigma> v"
  by (metis assms(1) assms(2) assms(3) mwb_lens_def sublens'_prop1 vwb_lens.put_eq vwb_lens_mwb weak_lens.put_get)

text \<open> Finally we show our two definitions of sublens are equivalent, assuming very well behaved lenses. \<close>

lemma sublens'_implies_sublens:
  assumes "vwb_lens X" "vwb_lens Y" "X \<subseteq>\<^sub>L' Y"
  shows "X \<subseteq>\<^sub>L Y"
proof -
  have "vwb_lens (X /\<^sub>L Y)"
    by (unfold_locales
       ,auto simp add: assms lens_quotient_def lens_comp_def lens_create_def sublens'_prop1 sublens'_prop2)
  moreover have "X = X /\<^sub>L Y ;\<^sub>L Y"
  proof -
    have "get\<^bsub>X\<^esub> = (\<lambda>\<sigma>. get\<^bsub>X\<^esub> (create\<^bsub>Y\<^esub> \<sigma>)) \<circ> get\<^bsub>Y\<^esub>"
      by (rule ext, simp add: assms(1) assms(3) lens_create_def sublens'_prop2)
    moreover have "put\<^bsub>X\<^esub> = (\<lambda>\<sigma> v. put\<^bsub>Y\<^esub> \<sigma> (get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> (create\<^bsub>Y\<^esub> (get\<^bsub>Y\<^esub> \<sigma>)) v)))"
      by (rule ext, rule ext, simp add: assms(1) assms(2) assms(3) lens_create_def sublens'_prop3)
    ultimately show ?thesis
      by (simp add: lens_quotient_def lens_comp_def)
  qed
  ultimately show ?thesis
    using sublens_def by blast
qed

lemma sublens_implies_sublens':
  assumes "vwb_lens Y" "X \<subseteq>\<^sub>L Y"
  shows "X \<subseteq>\<^sub>L' Y"
  by (metis assms lens_override_def lens_override_put_right_in sublens'_def)

lemma sublens_iff_sublens':
  assumes "vwb_lens X" "vwb_lens Y"
  shows "X \<subseteq>\<^sub>L Y \<longleftrightarrow> X \<subseteq>\<^sub>L' Y"
  using assms sublens'_implies_sublens sublens_implies_sublens' by blast

text \<open> We can also prove the closure law for lens quotient \<close>

lemma lens_quotient_vwb: "\<lbrakk> vwb_lens x; vwb_lens y; x \<subseteq>\<^sub>L y \<rbrakk> \<Longrightarrow> vwb_lens (x /\<^sub>L y)"
  by (unfold_locales)
     (simp_all add: sublens'_def lens_quotient_def lens_quotient_mwb sublens_iff_sublens' lens_create_def sublens'_prop1 sublens'_prop2)

lemma lens_quotient_indep:
  "\<lbrakk> vwb_lens x; vwb_lens y; vwb_lens a; x \<bowtie> y; x \<subseteq>\<^sub>L a; y \<subseteq>\<^sub>L a \<rbrakk> \<Longrightarrow> (x /\<^sub>L a) \<bowtie> (y /\<^sub>L a)"
  by (unfold_locales)
     (simp_all add: lens_quotient_def sublens_iff_sublens' lens_create_def lens_indep.lens_put_comm sublens'_prop1 sublens'_prop2 lens_indep.lens_put_irr2)

lemma lens_quotient_bij: "\<lbrakk> vwb_lens x; vwb_lens y; y \<approx>\<^sub>L x \<rbrakk> \<Longrightarrow> bij_lens (x /\<^sub>L y)"
  by (metis lens_comp_quotient lens_equiv_iff_bij lens_equiv_sym vwb_lens_wb wb_lens_weak)

subsection \<open> Alternative Equivalence Characterisation \<close>

definition lens_equiv' :: "('a \<Longrightarrow> 'c) \<Rightarrow> ('b \<Longrightarrow> 'c) \<Rightarrow> bool" (infix "\<approx>\<^sub>L''" 51) where
[lens_defs]: "lens_equiv' X Y = (\<forall> s\<^sub>1 s\<^sub>2. (s\<^sub>1 \<oplus>\<^sub>L s\<^sub>2 on X = s\<^sub>1 \<oplus>\<^sub>L s\<^sub>2 on Y))"

lemma lens_equiv_iff_lens_equiv':
  assumes "vwb_lens X" "vwb_lens Y"
  shows "X \<approx>\<^sub>L Y \<longleftrightarrow> X \<approx>\<^sub>L' Y"
  apply (simp add: lens_equiv_def sublens_iff_sublens' assms)
  apply (auto simp add: lens_defs assms)
  apply (metis assms(2) mwb_lens.put_put vwb_lens_mwb vwb_lens_wb wb_lens.get_put)
  done

subsection \<open> Ineffectual Lenses as Zero Elements \<close>

lemma ief_lens_then_zero: "ief_lens x \<Longrightarrow> x \<approx>\<^sub>L 0\<^sub>L"
  by (simp add: lens_equiv_iff_lens_equiv' lens_equiv'_def)
     (simp add: ief_lens.put_inef lens_override_def)

lemma ief_lens_iff_zero: "vwb_lens x \<Longrightarrow> ief_lens x \<longleftrightarrow> x \<approx>\<^sub>L 0\<^sub>L"
  by (metis ief_lens_axioms_def ief_lens_def ief_lens_then_zero lens_equiv_def lens_override_def lens_override_unit sublens'_prop3 sublens_implies_sublens' unit_vwb_lens vwb_lens_wb wb_lens_weak)

end