(* Title:      Kleene Algebra
   Author:     Alasdair Armstrong, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

header {* Action Algebras *}

theory Action_Algebra
imports Kleene_Algebra
begin

text {* Action algebras have been defined and discussed in Vaughan
Pratt's paper on \emph{Action Logic and Pure
Induction}~\cite{pratt90action}. They are expansions of Kleene
algebras by operations of left and right residuation. They are
interesting, first because most models of Kleene algebras, e.g.
relations, traces, paths and languages, possess the residuated
structure, and second because, in this setting, the Kleene star can be
equationally defined.

Action algebras can be based on residuated
semilattices~\cite{galatosjipsenkowalskiono07residuated}, which are
interesting in their own right. Many important properties of action
algebras already arise at this level.

Here we only prove some basic properties of residuated semilattices
and action algebras. A more extensive treatment is left for future
work. There is also an obvious duality between proofs for left and
right residuation which we do not formalise at this stage. *}

class residuated_join_semilattice = join_semilattice + semigroup_mult + residual_l_op + residual_r_op +
  assumes residual_l_galois: "x \<le> z \<leftarrow> y \<longleftrightarrow> x \<cdot> y \<le> z"
  and residual_r_galois: "x \<cdot> y \<le> z \<longleftrightarrow> y \<le> x \<rightarrow> z"
begin

text {* We first prove unit and counit laws for residuals, which are
also known as cancellation laws. *}

lemma galois_unitl: "x \<le> x \<cdot> y \<leftarrow> y"
  by (metis eq_refl residual_l_galois)

lemma galois_counitl: "(y \<leftarrow> x) \<cdot> x \<le> y"
  by (metis eq_refl residual_l_galois)

lemma galois_unitr: "y \<le> x \<rightarrow> x \<cdot> y"
  by (metis eq_refl residual_r_galois)

lemma galois_counitr: "x \<cdot> (x \<rightarrow> y) \<le> y"
  by (metis eq_refl residual_r_galois)

text {* Next we show that distributivity laws hold (in fact, even
distributivity laws for all existing suprema). *}

lemma distl: "x \<cdot> (y + z) = x \<cdot> y + x \<cdot> z"
proof -
  {
    fix w
    have "x \<cdot> (y + z) \<le> w \<longleftrightarrow> y + z \<le> x \<rightarrow> w"
      by (metis residual_r_galois)
    also have "... \<longleftrightarrow> y \<le> x \<rightarrow> w \<and> z \<le> x \<rightarrow> w"
      by (fact add_lub)
    also have "... \<longleftrightarrow> x \<cdot> y \<le> w \<and> x \<cdot> z \<le> w"
      by (metis residual_r_galois)
    ultimately have"x \<cdot> (y + z) \<le> w \<longleftrightarrow> x \<cdot> y + x \<cdot> z \<le> w"
      by (metis add_lub)
  }
  thus ?thesis
    by (metis eq_iff)
qed

lemma distr: "(x + y) \<cdot> z = x \<cdot> z + y \<cdot> z"
proof -
  {
    fix w
    have "(x + y) \<cdot> z \<le> w \<longleftrightarrow> x + y \<le> w \<leftarrow> z"
      by (metis residual_l_galois)
    also have "... \<longleftrightarrow> x \<le> w \<leftarrow> z \<and> y \<le> w \<leftarrow> z"
      by (fact add_lub)
    also have "... \<longleftrightarrow> x \<cdot> z \<le> w \<and> y \<cdot> z \<le> w"
      by (metis residual_l_galois)
    ultimately have"(x + y) \<cdot> z \<le> w \<longleftrightarrow> x \<cdot> z + y \<cdot> z \<le> w"
      by (metis add_lub)
  }
  thus ?thesis
    by (metis eq_iff)
qed

text {* As usual, distributivity implies isotonicity. *}

lemma mult_isol: "x \<le> y \<longrightarrow> z \<cdot> x \<le> z \<cdot> y"
  by (metis distl less_eq_def)

lemma mult_isor: "x \<le> y \<longrightarrow> x \<cdot> z \<le> y \<cdot> z"
  by (metis distr less_eq_def)

text {* Similarly, the residuals as upper adjoints preserve all
existing meets, but we do not assume that any meets exist in
residuated semilattices. However we can show subdistributivity with
respect to residuation. *}

lemma residual_l_subdist_var: "x \<leftarrow> z \<le> (x + y) \<leftarrow> z"
proof -
  {
    fix w
    have "w \<le> x \<leftarrow> z \<longleftrightarrow> w \<cdot> z \<le> x"
      by (metis residual_l_galois)
    also have "... \<longrightarrow> w \<cdot> z \<le> x + y"
      by (metis add_ub1 order_trans)
    ultimately have "w \<le> x \<leftarrow> z \<longrightarrow> w \<le> (x + y) \<leftarrow> z"
      by (metis residual_l_galois)
  }
  thus ?thesis
    by (metis eq_refl)
qed

lemma residual_l_subdist: "(x \<leftarrow> z) + (y \<leftarrow> z) \<le> (x + y) \<leftarrow> z"
  by (metis add_comm add_lub residual_l_subdist_var)

lemma residual_r_subdist_var: "(x \<rightarrow> y) \<le> x \<rightarrow> (y + z)"
  by (metis add_ub1 galois_counitr order_trans residual_r_galois)

lemma residual_r_subdist: "(x \<rightarrow> y) + (x \<rightarrow> z) \<le> x \<rightarrow> (y + z)"
  by (metis add_comm add_lub residual_r_subdist_var)

text {* As usual, subdistributivity implies isotonicity. *}

lemma residual_l_isol: "x \<le> y \<longrightarrow> x \<leftarrow> z \<le> y \<leftarrow> z"
  by (metis less_eq_def residual_l_subdist_var)

lemma residual_r_isor: "x \<le> y \<longrightarrow> z \<rightarrow> x \<le> z \<rightarrow> y"
  by (metis less_eq_def residual_r_subdist_var)

text {* Next, we prove superdistributivity laws for residuation. *}

lemma residual_l_superdist_var: "x \<leftarrow> (y + z) \<le> x \<leftarrow> y"
proof -
  {
    fix w
    have "w \<le> x \<leftarrow> (y + z) \<longleftrightarrow> w \<cdot> (y + z) \<le> x"
      by (metis residual_l_galois)
     also have "... \<longleftrightarrow> w \<cdot> y \<le> x \<and> w \<cdot> z \<le> x"
       by (metis add_lub distl)
     also have "... \<longleftrightarrow> w \<le> x \<leftarrow> y \<and> w \<le> x \<leftarrow> z"
       by (metis residual_l_galois)
    finally have "w \<le> x \<leftarrow> (y + z) \<longrightarrow> w \<le> x \<leftarrow> y"
      by simp
  }
  thus ?thesis
    by (metis eq_refl)
qed

lemma residual_r_superdist_var: "(x + y) \<rightarrow> z \<le> x \<rightarrow> z"
  by (metis add_lub galois_counitr residual_l_galois residual_r_galois)

text {* The previous proof shows, in fact, that @{text "x \<leftarrow> (y + z)"}
is the infimum of @{text "x \<leftarrow> y"} and @{text "x \<leftarrow> z"}; but we have no
operation to express this fact in action algebra. A dual property
holds for right residuation. *}

text {* As usual, superdistributivity implies antitonicity. *}

lemma residual_l_antitoner: "x \<le> y \<longrightarrow> z \<leftarrow> y \<le> z \<leftarrow> x"
  by (metis less_eq_def residual_l_superdist_var)

lemma residual_r_antitonel: "x \<le> y \<longrightarrow> y \<rightarrow> z \<le> x \<rightarrow> z"
  by (metis less_eq_def residual_r_superdist_var)

text {* Finally we prove transitivity laws for residuals. *}

lemma residual_l_trans: "(x \<leftarrow> y) \<cdot> (y \<leftarrow> z) \<le> x \<leftarrow> z"
proof -
  have "(x \<leftarrow> y) \<cdot> y \<le> x"
    by (metis galois_counitl)
  hence "(x \<leftarrow> y) \<cdot> (y \<leftarrow> z) \<cdot> z \<le> x"
    by (metis galois_counitl mult.assoc residual_l_antitoner residual_l_galois)
  thus ?thesis
    by (metis residual_l_galois)
qed

lemma residual_r_trans: "(x \<rightarrow> y) \<cdot> (y \<rightarrow> z) \<le> x \<rightarrow> z"
proof -
  have "y \<cdot> (y \<rightarrow> z)  \<le> z"
    by (metis galois_counitr)
  hence "x \<cdot> (x \<rightarrow> y) \<cdot> (y \<rightarrow> z)  \<le> z"
    by (metis galois_counitr mult.assoc residual_r_antitonel residual_r_galois)
  thus ?thesis
    by (metis mult.assoc residual_r_galois)
qed

end (* residuated_join_semilattice *)

text {* We now present an equivalent equational axiomatisation of
residuated join semilattices, which is essentially derived from an
equational axiomatisation of Galois connections in algebras with
sufficient structure. This equivalence is the basis for establishing
the equivalence of the equational axiomatisation of action algebra and
that based on Galois connections.  *}

class equational_residuated_join_semilattice = join_semilattice + semigroup_mult + residual_l_op + residual_r_op +
  assumes mult_subdist: "z \<cdot> x \<le> z \<cdot> (x + y)"
  and mult_subdistr: "x \<cdot> z \<le> (x+y) \<cdot> z"
  and right_addition: "x \<rightarrow> y \<le> x \<rightarrow> (y + z)"
  and right_galois_counit: "x \<cdot> (x \<rightarrow> y) \<le> y"
  and right_galois_unit: "y \<le> x \<rightarrow> x \<cdot> y"
  and left_addition: "y \<leftarrow> x \<le> (y + z) \<leftarrow> x"
  and left_galois_counit: "(y \<leftarrow> x) \<cdot> x \<le> y"
  and left_galois_unit: "y \<le> y \<cdot> x \<leftarrow> x"
begin

lemma residual_l_galois': "x \<cdot> y \<le> z \<longleftrightarrow> x \<le> z \<leftarrow> y"
proof
  assume "x \<cdot> y \<le> z"
  hence "(x \<cdot> y) \<leftarrow> y \<le> z \<leftarrow> y"
    by (metis less_eq_def left_addition)
  thus "x \<le> z \<leftarrow> y"
    by (metis order_trans left_galois_unit)
next
  assume "x \<le> z \<leftarrow> y"
  hence "x \<cdot> y \<le> (z \<leftarrow> y) \<cdot> y"
    by (metis less_eq_def mult_subdistr)
  thus "x \<cdot> y \<le> z"
    by (metis order_trans left_galois_counit)
qed

lemma residual_r_galois': "x \<cdot> y \<le> z \<longleftrightarrow> y \<le> x \<rightarrow> z"
proof
  assume "x \<cdot> y \<le> z"
  hence "x \<rightarrow> (x \<cdot> y) \<le> x \<rightarrow> z"
    by (metis less_eq_def right_addition)
  thus "y \<le> x \<rightarrow> z"
    by (metis order_trans right_galois_unit)
next
  assume "y \<le> x \<rightarrow> z"
  hence "x \<cdot> y \<le> x \<cdot> (x \<rightarrow> z)"
    by (metis less_eq_def mult_subdist)
  thus "x \<cdot> y \<le> z"
    by (metis order_trans right_galois_counit)
qed

subclass residuated_join_semilattice
  by (unfold_locales, metis residual_l_galois', metis residual_r_galois')

end (* equational_residuated_join_semilattice *)

text {*
Conversely, every residuated join semilattice satisfies the axioms of
equational residuated join semilattices.

Because the subclass relation must be acyclic in Isabelle, we can
only establish this for the corresponding locales.
*}

sublocale residuated_join_semilattice \<subseteq> equational_residuated_join_semilattice
  by (unfold_locales, metis add_ub1 mult_isol, metis add_ub1 mult_isor, metis residual_r_subdist_var, metis galois_counitr, metis galois_unitr, metis residual_l_subdist_var, metis galois_counitl, metis galois_unitl)

text {* We can now define an action algebra as a residuated join
semilattice that is also a dioid. Following Pratt, we also add a star
operation that is axiomatised as a reflexive transitive closure
operation.
*}

class action_algebra = residuated_join_semilattice + dioid_one_zero + star_op +
  assumes star_rtc1: "1 + x\<^sup>\<star> \<cdot> x\<^sup>\<star> + x \<le> x\<^sup>\<star>"
  and star_rtc2: "1 + y \<cdot> y + x \<le> y \<longrightarrow> x\<^sup>\<star> \<le> y"
begin

text {* We first prove a reflexivity property for residuals. *}

lemma residual_r_refl: "1 \<le> x \<rightarrow> x"
proof -
  have "x \<le> x"
    by auto
  thus ?thesis
    by (metis mult_oner residual_r_galois)
qed

lemma residual_l_refl: "1 \<le> x \<leftarrow> x"
proof -
  have "x \<le> x"
    by auto
  thus ?thesis
    by (metis mult_onel residual_l_galois)
qed

text {* We now derive pure induction laws for residuals. *}

lemma residual_l_pure_induction: "(x \<leftarrow> x)\<^sup>\<star> \<le> x \<leftarrow> x"
proof -
  have "1 + (x \<leftarrow> x) \<cdot> (x \<leftarrow> x) + (x \<leftarrow> x) \<le> (x \<leftarrow> x)"
    by (metis add_lub eq_iff residual_l_refl residual_l_trans)
  thus ?thesis
    by (metis star_rtc2)
qed

lemma residual_r_pure_induction: "(x \<rightarrow> x)\<^sup>\<star> \<le> x \<rightarrow> x"
  by (metis add_lub eq_iff residual_r_refl residual_r_trans star_rtc2)

text {* Next we show that every action algebra is a Kleene
algebra. First, we derive the star unfold law and the star induction
laws in action algebra. Then we prove a subclass statement. *}

lemma star_unfoldl: "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
proof -
  have "x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (metis add_lub mult_isor order_trans star_rtc1)
  thus ?thesis
    by (metis add_lub star_rtc1)
qed

lemma star_mon: "x \<le> y \<longrightarrow> x\<^sup>\<star> \<le> y\<^sup>\<star>"
proof
  assume "x \<le> y"
  hence "x \<le> y\<^sup>\<star>"
    by (metis add_lub order_trans star_rtc1)
  hence "1 + x + y\<^sup>\<star> \<cdot> y\<^sup>\<star> \<le> y\<^sup>\<star>"
    by (metis add_lub star_rtc1)
  thus "x\<^sup>\<star> \<le> y\<^sup>\<star>"
    by (metis add.assoc add.commute star_rtc2)
qed

lemma star_subdist': "x\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
  by (metis add_ub1 star_mon)

lemma star_inductl: "z + x \<cdot> y \<le> y \<longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
proof
  assume "z + x \<cdot> y \<le> y"
  also have "z \<le> y"
    by (metis add_lub calculation)
  moreover have "x \<cdot> y \<le> y"
    by (metis add_lub calculation)
  hence "x \<le> y \<leftarrow> y"
    by (metis residual_l_galois)
  hence "x\<^sup>\<star> \<le> (y \<leftarrow> y)\<^sup>\<star>"
    by (metis star_mon)
  hence "x\<^sup>\<star> \<le> y \<leftarrow> y"
    by (metis order_trans residual_l_pure_induction)
  hence "x\<^sup>\<star> \<cdot> y \<le> y"
    by (metis residual_l_galois)
  thus "x\<^sup>\<star> \<cdot> z \<le> y"
    by (metis calculation mult_isol order_trans)
qed

lemma star_inductr: "z + y \<cdot> x \<le> y \<longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"
proof
  assume "z + y \<cdot> x \<le> y"
  also have "z \<le> y"
    by (metis add_lub calculation)
  moreover have "y \<cdot> x \<le> y"
    by (metis add_lub calculation)
  hence "x \<le> y \<rightarrow> y"
    by (metis residual_r_galois)
  hence "x\<^sup>\<star> \<le> (y \<rightarrow> y)\<^sup>\<star>"
    by (metis star_mon)
  hence "x\<^sup>\<star> \<le> y \<rightarrow> y"
    by (metis order_trans residual_r_pure_induction)
  hence "y \<cdot> x\<^sup>\<star> \<le> y"
    by (metis residual_r_galois)
  thus "z \<cdot> x\<^sup>\<star> \<le> y"
    by (metis calculation mult_isor order_trans)
qed

subclass kleene_algebra
  by (unfold_locales, auto simp add: star_unfoldl star_inductl star_inductr)

end (* action_algebra *)

subsection {* Equational Action Algebras *}

text {* The induction axioms of Kleene algebras are universal Horn
formulas. This is unavoidable, because due to a well known result of
Redko, there is no finite equational axiomatisation for the equational
theory of regular expressions.

Action algebras, in contrast, admit a finite equational
axiomatization, as Pratt has shown. We now formalise this
result. Consequently, the equational action algebra axioms, which
imply those based on Galois connections, which in turn imply those of
Kleene algebras, are complete with respect to the equational theory of
regular expressions. However, this completeness result does not
account for residuation. *}

class equational_action_algebra = equational_residuated_join_semilattice + dioid_one_zero + star_op +
  assumes star_ax: "1 + x\<^sup>\<star> \<cdot> x\<^sup>\<star> + x \<le> x\<^sup>\<star>"
  and star_subdist: "x\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
  and right_pure_induction: "(x \<rightarrow> x)\<^sup>\<star> \<le> x \<rightarrow> x"
begin

text {* We now show that the equational axioms of action algebra
satisfy those based on the Galois connections. Since we can use our
correspondence between the two variants of residuated semilattice, it
remains to derive the second reflexive transitive closure axiom for
the star, essentially copying Pratt's proof step by step. We then
prove a subclass statement. *}

lemma star_rtc_2: "1 + y \<cdot> y + x \<le> y \<longrightarrow> x\<^sup>\<star> \<le> y"
proof
  assume "1 + y \<cdot> y + x \<le> y"
  also have "1 \<le> y"
    by (metis add_lub calculation)
  moreover have "x \<le> y"
    by (metis add_lub calculation)
  moreover have "y \<cdot> y \<le> y"
    by (metis add_lub calculation)
  hence "y \<le> y \<rightarrow> y"
    by (metis residual_r_galois)
  moreover have "x \<le> y \<rightarrow> y"
    by (metis calculation order_trans)
  hence "x\<^sup>\<star> \<le> (y \<rightarrow> y)\<^sup>\<star>"
    by (metis less_eq_def star_subdist)
  hence "x\<^sup>\<star> \<le> y \<rightarrow> y"
    by (metis order_trans right_pure_induction)
  hence "y \<cdot> x\<^sup>\<star> \<le> y"
    by (metis residual_r_galois)
  ultimately show "x\<^sup>\<star> \<le> y"
    by (metis mult_isor mult_onel order_trans)
qed

subclass action_algebra
  by (unfold_locales, metis star_ax, metis star_rtc_2)

end (* equational_action_algebra *)

text {*
Conversely, every action algebra satisfies the equational axioms of
equational action algebras.

Because the subclass relation must be acyclic in Isabelle, we can only
establish this for the corresponding locales. Again this proof is
based on the residuated semilattice result.
*}

sublocale action_algebra \<subseteq> equational_action_algebra
  by (unfold_locales, metis star_rtc1, metis star_subdist, metis residual_r_pure_induction)

subsection {* Another Variant *}

text {* Finally we show that Pratt and Kozen's star axioms generate
precisely the same theory. *}

class action_algebra_var = equational_residuated_join_semilattice + dioid_one_zero + star_op +
  assumes star_unfold': "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  and star_inductl': "z + x \<cdot> y \<le> y \<longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
  and star_inductr': "z + y \<cdot> x \<le> y \<longrightarrow> z \<cdot> x\<^sup>\<star>  \<le> y"
begin

subclass kleene_algebra
  by (unfold_locales, metis star_unfold', metis star_inductl', metis star_inductr')

subclass action_algebra
  by (unfold_locales, metis add.commute less_eq_def order_refl star_ext star_plus_one star_trans_eq, metis add.assoc add.commute star_rtc_least)

end

sublocale action_algebra \<subseteq> action_algebra_var
  by (unfold_locales, metis star_unfoldl, metis star_inductl, metis star_inductr)

end


(*  Title:      HOL/Examples/Induction_Schema.thy
    Author:     Alexander Krauss, TU Muenchen
*)

section \<open>Examples of automatically derived induction rules\<close>

theory Induction_Schema
imports Main
begin

subsection \<open>Some simple induction principles on nat\<close>

lemma nat_standard_induct: (* cf. Nat.thy *)
  "\<lbrakk>P 0; \<And>n. P n \<Longrightarrow> P (Suc n)\<rbrakk> \<Longrightarrow> P x"
by induction_schema (pat_completeness, lexicographic_order)

lemma nat_induct2:
  "\<lbrakk> P 0; P (Suc 0); \<And>k. P k ==> P (Suc k) ==> P (Suc (Suc k)) \<rbrakk>
  \<Longrightarrow> P n"
by induction_schema (pat_completeness, lexicographic_order)

lemma minus_one_induct:
  "\<lbrakk>\<And>n::nat. (n \<noteq> 0 \<Longrightarrow> P (n - 1)) \<Longrightarrow> P n\<rbrakk> \<Longrightarrow> P x"
by induction_schema (pat_completeness, lexicographic_order)

theorem diff_induct: (* cf. Nat.thy *)
  "(!!x. P x 0) ==> (!!y. P 0 (Suc y)) ==>
    (!!x y. P x y ==> P (Suc x) (Suc y)) ==> P m n"
by induction_schema (pat_completeness, lexicographic_order)

lemma list_induct2': (* cf. List.thy *)
  "\<lbrakk> P [] [];
  \<And>x xs. P (x#xs) [];
  \<And>y ys. P [] (y#ys);
   \<And>x xs y ys. P xs ys  \<Longrightarrow> P (x#xs) (y#ys) \<rbrakk>
 \<Longrightarrow> P xs ys"
by induction_schema (pat_completeness, lexicographic_order)

theorem even_odd_induct:
  assumes "R 0"
  assumes "Q 0"
  assumes "\<And>n. Q n \<Longrightarrow> R (Suc n)"
  assumes "\<And>n. R n \<Longrightarrow> Q (Suc n)"
  shows "R n" "Q n"
  using assms
by induction_schema (pat_completeness+, lexicographic_order)

end


(*<*)
theory tmpl07
  imports Main "HOL-Data_Structures.Sorting"
begin
(*>*)

text {* \ExerciseSheet{7}{25.~5.~2018} *}

text {* \Exercise{Interval Lists}

 Sets of natural numbers can be implemented as lists of intervals, where
an interval is simply a pair of numbers.  For example the set @{term "{2, 3, 5,
7, 8, 9::nat}"} can be represented by the list @{term "[(2, 3), (5, 5),
(7::nat, 9::nat)]"}.  A typical application is the list of free blocks of
dynamically allocated memory. *}

text {* We introduce the type *}

type_synonym intervals = "(nat*nat) list"

text {* Next, define an \emph{invariant}
that characterizes valid interval lists:
For efficiency reasons intervals should be sorted in ascending order, the lower
bound of each interval should be less than or equal to the upper bound, and the
intervals should be chosen as large as possible, i.e.\ no two adjacent
intervals should overlap or even touch each other.  It turns out to be
convenient to define @{term inv} in terms of a more general function
such that the additional argument is a lower bound for the intervals in
the list:*}

fun inv' :: "nat \<Rightarrow> intervals \<Rightarrow> bool" where
  "inv' _ _ \<longleftrightarrow> undefined"

definition inv where "inv = inv' 0"

text {* To relate intervals back to sets define an \emph{abstraction function}*}

fun set_of :: "intervals => nat set"
where
  "set_of _ = undefined"

text \<open>Define a function to add a single element to the interval list,
  and show its correctness\<close>

fun add :: "nat \<Rightarrow> intervals \<Rightarrow> intervals"
  where
  "add _ _ = undefined"

lemma add_correct:
  assumes "inv is"
  shows "inv (add x is)" "set_of (add x is) = insert x (set_of is)"
  oops

text \<open>Hints:
  \<^item> Sketch the different cases (position of element relative to the first interval of the list)
    on paper first
  \<^item> In one case, you will also need information about the second interval of the list.
    Do this case split via an auxiliary function! Otherwise, you may end up with a recursion equation of the form
      \<open>f (x#xs) = \<dots> case xs of x'#xs' \<Rightarrow> \<dots> f (x'#xs') \<dots>\<close>
    combined with \<open>split: list.splits\<close> this will make the simplifier loop!

\<close>

text \<open>\Exercise{Optimized Mergesort}

  Import @{theory "Sorting"} for this exercise.
  The @{const msort} function recomputes the length of the list in each iteration.
  Implement an optimized version that has an additional parameter keeping track
  of the length, and show that it is equal to the original @{const msort}.
\<close>

(* Optimized mergesort *)

fun msort2 :: "nat \<Rightarrow> 'a::linorder list \<Rightarrow> 'a list"
  where "msort2 _ _ = undefined"

lemma "n = length xs \<Longrightarrow> msort2 n xs = msort xs"
  oops

text \<open>Hint:
  Use @{thm [source] msort.simps} only when instantiated to a particular \<open>xs\<close>
  (@{thm [source] msort.simps[of xs]}),
  otherwise the simplifier will loop!
\<close>

text \<open> \NumHomework{Deletion from Interval Lists}{June 1}

  Implement and prove correct a delete function.

  Hints:
    \<^item> The correctness lemma is analogous to the one for add.
    \<^item> A monotonicity property on \<open>inv'\<close> may be useful, i.e.,
      @{prop \<open>inv' m is \<Longrightarrow> inv' m' is\<close>} if @{prop \<open>m'\<le>m\<close>}
    \<^item> A bounding lemma, relating \<open>m\<close> and the elements of @{term \<open>set_of is\<close>}
      if @{prop \<open>inv' m is\<close>}, may be useful.
\<close>

fun del :: "nat \<Rightarrow> intervals \<Rightarrow> intervals"
where
  "del _ _ = undefined"

lemma del_correct: "Come up with a meaningful spec yourself" oops

text \<open> \NumHomework{Addition of Interval to Interval List}{June 1}
  For 3 \<^bold>\<open>bonus points\<close>, implement and prove correct a function
  to add a whole interval to an interval list. The runtime must
  not depend on the size of the interval, e.g., iterating over the
  interval and adding the elements separately is not allowed!
\<close>

fun addi :: "nat \<Rightarrow> nat \<Rightarrow> intervals \<Rightarrow> intervals"
where
  "addi i j is = undefined"

lemma addi_correct:
  assumes "inv is" "i\<le>j"
  shows "inv (addi i j is)" "set_of (addi i j is) = {i..j} \<union> (set_of is)"
  sorry

(*<*)
end
(*>*)


(*  Title:      HOL/ex/Induction_Schema.thy
    Author:     Alexander Krauss, TU Muenchen
*)

section \<open>Examples of automatically derived induction rules\<close>

theory Induction_Schema
imports Main
begin

subsection \<open>Some simple induction principles on nat\<close>

lemma nat_standard_induct: (* cf. Nat.thy *)
  "\<lbrakk>P 0; \<And>n. P n \<Longrightarrow> P (Suc n)\<rbrakk> \<Longrightarrow> P x"
by induction_schema (pat_completeness, lexicographic_order)

lemma nat_induct2:
  "\<lbrakk> P 0; P (Suc 0); \<And>k. P k ==> P (Suc k) ==> P (Suc (Suc k)) \<rbrakk>
  \<Longrightarrow> P n"
by induction_schema (pat_completeness, lexicographic_order)

lemma minus_one_induct:
  "\<lbrakk>\<And>n::nat. (n \<noteq> 0 \<Longrightarrow> P (n - 1)) \<Longrightarrow> P n\<rbrakk> \<Longrightarrow> P x"
by induction_schema (pat_completeness, lexicographic_order)

theorem diff_induct: (* cf. Nat.thy *)
  "(!!x. P x 0) ==> (!!y. P 0 (Suc y)) ==>
    (!!x y. P x y ==> P (Suc x) (Suc y)) ==> P m n"
by induction_schema (pat_completeness, lexicographic_order)

lemma list_induct2': (* cf. List.thy *)
  "\<lbrakk> P [] [];
  \<And>x xs. P (x#xs) [];
  \<And>y ys. P [] (y#ys);
   \<And>x xs y ys. P xs ys  \<Longrightarrow> P (x#xs) (y#ys) \<rbrakk>
 \<Longrightarrow> P xs ys"
by induction_schema (pat_completeness, lexicographic_order)

theorem even_odd_induct:
  assumes "R 0"
  assumes "Q 0"
  assumes "\<And>n. Q n \<Longrightarrow> R (Suc n)"
  assumes "\<And>n. R n \<Longrightarrow> Q (Suc n)"
  shows "R n" "Q n"
  using assms
by induction_schema (pat_completeness+, lexicographic_order)

end


(*  Title:       Infinite Sequences
    Author:      Christian Sternagel <c-sterna@jaist.ac.jp>
                 René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)

(*
Copyright 2012 Christian Sternagel, René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)
section \<open>Infinite Sequences\<close>
theory Seq
imports
  Main
  "HOL-Library.Infinite_Set"
begin

text \<open>Infinite sequences are represented by functions of type @{typ "nat \<Rightarrow> 'a"}.\<close>
type_synonym 'a seq = "nat \<Rightarrow> 'a"

subsection \<open>Operations on Infinite Sequences\<close>

text \<open>An infinite sequence is \emph{linked} by a binary predicate @{term P} if every two
consecutive elements satisfy it. Such a sequence is called a \emph{@{term P}-chain}.\<close>
abbreviation (input) chainp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow>'a seq \<Rightarrow> bool" where
  "chainp P S \<equiv> \<forall>i. P (S i) (S (Suc i))"

text \<open>Special version for relations.\<close>
abbreviation (input) chain :: "'a rel \<Rightarrow> 'a seq \<Rightarrow> bool" where
  "chain r S \<equiv> chainp (\<lambda>x y. (x, y) \<in> r) S"

text \<open>Extending a chain at the front.\<close>
lemma cons_chainp:
  assumes "P x (S 0)" and "chainp P S"
  shows "chainp P (case_nat x S)" (is "chainp P ?S")
proof
  fix i show "P (?S i) (?S (Suc i))" using assms by (cases i) simp_all
qed

text \<open>Special version for relations.\<close>
lemma cons_chain:
  assumes "(x, S 0) \<in> r" and "chain r S" shows "chain r (case_nat x S)"
  using cons_chainp[of "\<lambda>x y. (x, y) \<in> r", OF assms] .

text \<open>A chain admits arbitrary transitive steps.\<close>
lemma chainp_imp_relpowp:
  assumes "chainp P S" shows "(P^^j) (S i) (S (i + j))"
proof (induct "i + j" arbitrary: j)
  case (Suc n) thus ?case using assms by (cases j) auto
qed simp

lemma chain_imp_relpow:
  assumes "chain r S" shows "(S i, S (i + j)) \<in> r^^j"
proof (induct "i + j" arbitrary: j)
  case (Suc n) thus ?case using assms by (cases j) auto
qed simp

lemma chainp_imp_tranclp:
  assumes "chainp P S" and "i < j" shows "P^++ (S i) (S j)"
proof -
  from less_imp_Suc_add[OF assms(2)] obtain n where "j = i + Suc n" by auto
  with chainp_imp_relpowp[of P S "Suc n" i, OF assms(1)]
    show ?thesis
      unfolding trancl_power[of "(S i, S j)", to_pred]
      by force
qed

lemma chain_imp_trancl:
  assumes "chain r S" and "i < j" shows "(S i, S j) \<in> r^+"
proof -
  from less_imp_Suc_add[OF assms(2)] obtain n where "j = i + Suc n" by auto
  with chain_imp_relpow[OF assms(1), of i "Suc n"]
    show ?thesis unfolding trancl_power by force
qed

text \<open>A chain admits arbitrary reflexive and transitive steps.\<close>
lemma chainp_imp_rtranclp:
  assumes "chainp P S" and "i \<le> j" shows "P^** (S i) (S j)"
proof -
  from assms(2) obtain n where "j = i + n" by (induct "j - i" arbitrary: j) force+
  with chainp_imp_relpowp[of P S, OF assms(1), of n i] show ?thesis
    by (simp add: relpow_imp_rtrancl[of "(S i, S (i + n))", to_pred])
qed

lemma chain_imp_rtrancl:
  assumes "chain r S" and "i \<le> j" shows "(S i, S j) \<in> r^*"
proof -
  from assms(2) obtain n where "j = i + n" by (induct "j - i" arbitrary: j) force+
  with chain_imp_relpow[OF assms(1), of i n] show ?thesis by (simp add: relpow_imp_rtrancl)
qed

text \<open>If for every @{term i} there is a later index @{term "f i"} such that the
corresponding elements satisfy the predicate @{term P}, then there is a @{term P}-chain.\<close>
lemma stepfun_imp_chainp':
  assumes "\<forall>i\<ge>n::nat. f i \<ge> i \<and> P (S i) (S (f i))"
  shows "chainp P (\<lambda>i. S ((f ^^ i) n))" (is "chainp P ?T")
proof
  fix i
  from assms have "(f ^^ i) n \<ge> n" by (induct i) auto
  with assms[THEN spec[of _ "(f ^^ i) n"]]
    show "P (?T i) (?T (Suc i))" by simp
qed

lemma stepfun_imp_chainp:
  assumes "\<forall>i\<ge>n::nat. f i > i \<and> P (S i) (S (f i))"
  shows "chainp P (\<lambda>i. S ((f ^^ i) n))" (is "chainp P ?T")
  using stepfun_imp_chainp'[of n f P S] and assms by force

lemma subchain:
  assumes "\<forall>i::nat>n. \<exists>j>i. P (f i) (f j)"
  shows "\<exists>\<phi>. (\<forall>i j. i < j \<longrightarrow> \<phi> i < \<phi> j) \<and> (\<forall>i. P (f (\<phi> i)) (f (\<phi> (Suc i))))"
proof -
  from assms have "\<forall>i\<in>{i. i > n}. \<exists>j>i. P (f i) (f j)" by simp
  from bchoice [OF this] obtain g
    where *: "\<forall>i>n. g i > i"
    and **: "\<forall>i>n. P (f i) (f (g i))" by auto
  define \<phi> where [simp]: "\<phi> i = (g ^^ i) (Suc n)" for i
  from * have ***: "\<And>i. \<phi> i > n" by (induct_tac i) auto
  then have "\<And>i. \<phi> i < \<phi> (Suc i)" using * by (induct_tac i) auto
  then have "\<And>i j. i < j \<Longrightarrow> \<phi> i < \<phi> j" by (rule lift_Suc_mono_less)
  moreover have "\<And>i. P (f (\<phi> i)) (f (\<phi> (Suc i)))" using ** and *** by simp
  ultimately show ?thesis by blast
qed

text \<open>If for every @{term i} there is a later index @{term j} such that the
corresponding elements satisfy the predicate @{term P}, then there is a @{term P}-chain.\<close>
lemma steps_imp_chainp':
  assumes "\<forall>i\<ge>n::nat. \<exists>j\<ge>i. P (S i) (S j)" shows "\<exists>T. chainp P T"
proof -
  from assms have "\<forall>i\<in>{i. i \<ge> n}. \<exists>j\<ge>i. P (S i) (S j)" by auto
  from bchoice [OF this] (*choice could be replaced by an application of Least_Enum.infinitely_many2*)
    obtain f where "\<forall>i\<ge>n. f i \<ge> i \<and> P (S i) (S (f i))" by auto
  from stepfun_imp_chainp'[of n f P S, OF this] show ?thesis by fast
qed

lemma steps_imp_chainp:
  assumes "\<forall>i\<ge>n::nat. \<exists>j>i. P (S i) (S j)" shows "\<exists>T. chainp P T"
  using steps_imp_chainp' [of n P S] and assms by force

subsection \<open>Predicates on Natural Numbers\<close>

text \<open>If some property holds for infinitely many natural numbers, obtain
an index function that points to these numbers in increasing order.\<close>

locale infinitely_many =
  fixes p :: "nat \<Rightarrow> bool"
  assumes infinite: "INFM j. p j"
begin

lemma inf: "\<exists>j\<ge>i. p j" using infinite[unfolded INFM_nat_le] by auto

fun index :: "nat seq" where
  "index 0 = (LEAST n. p n)"
| "index (Suc n) = (LEAST k. p k \<and> k > index n)"

lemma index_p: "p (index n)"
proof (induct n)
  case 0
  from inf obtain j where "p j" by auto
  with LeastI[of p j] show ?case by auto
next
  case (Suc n)
  from inf obtain k where "k \<ge> Suc (index n) \<and> p k" by auto
  with LeastI[of "\<lambda> k. p k \<and> k > index n" k] show ?case by auto
qed

lemma index_ordered: "index n < index (Suc n)"
proof -
  from inf obtain k where "k \<ge> Suc (index n) \<and> p k" by auto
  with LeastI[of "\<lambda> k. p k \<and> k > index n" k] show ?thesis by auto
qed

lemma index_not_p_between:
  assumes i1: "index n < i"
    and i2: "i < index (Suc n)"
  shows "\<not> p i"
proof -
  from not_less_Least[OF i2[simplified]] i1 show ?thesis by auto
qed

lemma index_ordered_le:
  assumes "i \<le> j" shows "index i \<le> index j"
proof -
  from assms have "j = i + (j - i)" by auto
  then obtain k where j: "j = i + k" by auto
  have "index i \<le> index (i + k)"
  proof (induct k)
    case (Suc k)
    with index_ordered[of "i + k"]
    show ?case by auto
  qed simp
  thus ?thesis unfolding j .
qed

lemma index_surj:
  assumes "k \<ge> index l"
  shows "\<exists>i j. k = index i + j \<and> index i + j < index (Suc i)"
proof -
  from assms have "k = index l + (k - index l)" by auto
  then obtain u where k: "k = index l + u" by auto
  show ?thesis unfolding k
  proof (induct u)
    case 0
    show ?case
      by (intro exI conjI, rule refl, insert index_ordered[of l], simp)
  next
    case (Suc u)
    then obtain i j
      where lu: "index l + u = index i + j" and lt: "index i + j < index (Suc i)" by auto
    hence "index l + u < index (Suc i)" by auto
    show ?case
    proof (cases "index l + (Suc u) = index (Suc i)")
      case False
      show ?thesis
        by (rule exI[of _ i], rule exI[of _ "Suc j"], insert lu lt False, auto)
    next
      case True
      show ?thesis
        by (rule exI[of _ "Suc i"], rule exI[of _ 0], insert True index_ordered[of "Suc i"], auto)
    qed
  qed
qed

lemma index_ordered_less:
  assumes "i < j" shows "index i < index j"
proof -
  from assms have "Suc i \<le> j" by auto
  from index_ordered_le[OF this]
  have "index (Suc i) \<le> index j" .
  with index_ordered[of i] show ?thesis by auto
qed

lemma index_not_p_start: assumes i: "i < index 0" shows "\<not> p i"
proof -
  from i[simplified index.simps] have "i < Least p" .
  from not_less_Least[OF this] show ?thesis .
qed

end

subsection \<open>Assembling Infinite Words from Finite Words\<close>

text \<open>Concatenate infinitely many non-empty words to an infinite word.\<close>

fun inf_concat_simple :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> (nat \<times> nat)" where
  "inf_concat_simple f 0 = (0, 0)"
| "inf_concat_simple f (Suc n) = (
    let (i, j) = inf_concat_simple f n in
    if Suc j < f i then (i, Suc j)
    else (Suc i, 0))"

lemma inf_concat_simple_add:
  assumes ck: "inf_concat_simple f k = (i, j)"
    and jl: "j + l < f i"
  shows "inf_concat_simple f (k + l) = (i,j + l)"
using jl
proof (induct l)
  case 0
  thus ?case using ck by simp
next
  case (Suc l)
  hence c: "inf_concat_simple f (k + l) = (i, j+ l)" by auto
  show ?case
    by (simp add: c, insert Suc(2), auto)
qed

lemma inf_concat_simple_surj_zero: "\<exists> k. inf_concat_simple f k = (i,0)"
proof (induct i)
  case 0
  show ?case
    by (rule exI[of _ 0], simp)
next
  case (Suc i)
  then obtain k where ck: "inf_concat_simple f k = (i,0)" by auto
  show ?case
  proof (cases "f i")
    case 0
    show ?thesis
      by (rule exI[of _ "Suc k"], simp add: ck 0)
  next
    case (Suc n)
    hence "0 + n < f i" by auto
    from inf_concat_simple_add[OF ck, OF this] Suc
    show ?thesis
      by (intro exI[of _ "k + Suc n"], auto)
  qed
qed

lemma inf_concat_simple_mono:
  assumes "k \<le> k'" shows "fst (inf_concat_simple f k) \<le> fst (inf_concat_simple f k')"
proof -
  from assms have "k' = k + (k' - k)" by auto
  then obtain l where k': "k' = k + l" by auto
  show ?thesis  unfolding k'
  proof (induct l)
    case (Suc l)
    obtain i j where ckl: "inf_concat_simple f (k+l) = (i,j)" by (cases "inf_concat_simple f (k+l)", auto)
    with Suc have "fst (inf_concat_simple f k) \<le> i" by auto
    also have "... \<le> fst (inf_concat_simple f (k + Suc l))"
      by (simp add: ckl)
    finally show ?case .
  qed simp
qed

(* inf_concat assembles infinitely many (possibly empty) words to an infinite word *)
fun inf_concat :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat \<times> nat" where
  "inf_concat n 0 = (LEAST j. n j > 0, 0)"
| "inf_concat n (Suc k) = (let (i, j) = inf_concat n k in (if Suc j < n i then (i, Suc j) else (LEAST i'. i' > i \<and> n i' > 0, 0)))"

lemma inf_concat_bounds:
  assumes inf: "INFM i. n i > 0"
    and res: "inf_concat n k = (i,j)"
  shows "j < n i"
proof (cases k)
  case 0
  with res have i: "i = (LEAST i. n i > 0)" and j: "j = 0" by auto
  from inf[unfolded INFM_nat_le] obtain i' where i': "0 < n i'" by auto
  have "0 < n (LEAST i. n i > 0)"
    by (rule LeastI, rule i')
  with i j show ?thesis by auto
next
  case (Suc k')
  obtain i' j' where res': "inf_concat n k' = (i',j')" by force
  note res = res[unfolded Suc inf_concat.simps res' Let_def split]
  show ?thesis
  proof (cases "Suc j' < n i'")
    case True
    with res show ?thesis by auto
  next
    case False
    with res have i: "i = (LEAST f. i' < f \<and> 0 < n f)" and j: "j = 0" by auto
    from inf[unfolded INFM_nat] obtain f where f: "i' < f \<and> 0 < n f" by auto
    have "0 < n (LEAST f. i' < f \<and> 0 < n f)"
      using LeastI[of "\<lambda> f. i' < f \<and> 0 < n f", OF f]
      by auto
    with i j show ?thesis by auto
  qed
qed

lemma inf_concat_add:
  assumes res: "inf_concat n k = (i,j)"
    and j: "j + m < n i"
  shows "inf_concat n (k + m) = (i,j+m)"
  using j
proof (induct m)
  case 0 show ?case using res by auto
next
  case (Suc m)
  hence "inf_concat n (k + m) = (i, j+m)" by auto
  with Suc(2)
  show ?case by auto
qed

lemma inf_concat_step:
  assumes res: "inf_concat n k = (i,j)"
    and j: "Suc (j + m) = n i"
  shows "inf_concat n (k + Suc m) = (LEAST i'. i' > i \<and> 0 < n i', 0)"
proof -
  from j have "j + m < n i" by auto
  note res = inf_concat_add[OF res, OF this]
  show ?thesis by (simp add: res j)
qed

lemma inf_concat_surj_zero:
  assumes "0 < n i"
  shows "\<exists>k. inf_concat n k = (i, 0)"
proof -
  {
    fix l
    have "\<forall> j. j < l \<and> 0 < n j \<longrightarrow> (\<exists> k. inf_concat n k = (j,0))"
    proof (induct l)
      case 0
      thus ?case by auto
    next
      case (Suc l)
      show ?case
      proof (intro allI impI, elim conjE)
        fix j
        assume j: "j < Suc l" and nj: "0 < n j"
        show "\<exists> k. inf_concat n k = (j, 0)"
        proof (cases "j < l")
          case True
          from Suc[THEN spec[of _ j]] True nj show ?thesis by auto
        next
          case False
          with j have j: "j = l" by auto
          show ?thesis
          proof (cases "\<exists> j'. j' < l \<and> 0 < n j'")
            case False
            have l: "(LEAST i. 0 < n i) = l"
            proof (rule Least_equality, rule nj[unfolded j])
              fix l'
              assume "0 < n l'"
              with False have "\<not> l' < l" by auto
              thus "l \<le> l'" by auto
            qed
            show ?thesis
              by (rule exI[of _ 0], simp add: l j)
          next
            case True
            then obtain lll where lll: "lll < l" and nlll: "0 < n lll" by auto
            then obtain ll where l: "l = Suc ll" by (cases l, auto)
            from lll l have lll: "lll = ll - (ll - lll)" by auto
            let ?l' = "LEAST d. 0 < n (ll - d)"
            have nl': "0 < n (ll - ?l')"
            proof (rule LeastI)
              show "0 < n (ll - (ll - lll))" using lll nlll by auto
            qed
            with Suc[THEN spec[of _ "ll - ?l'"]] obtain k where k:
              "inf_concat n k = (ll - ?l',0)" unfolding l by auto
            from nl' obtain off where off: "Suc (0 + off) = n (ll - ?l')" by (cases "n (ll - ?l')", auto)
            from inf_concat_step[OF k, OF off]
            have id: "inf_concat n (k + Suc off) = (LEAST i'. ll - ?l' < i' \<and> 0 < n i',0)" (is "_ = (?l,0)") .
            have ll: "?l = l" unfolding l
            proof (rule Least_equality)
              show "ll - ?l' < Suc ll \<and> 0 < n (Suc ll)" using nj[unfolded j l] by simp
            next
              fix l'
              assume ass: "ll - ?l' < l' \<and> 0 < n l'"
              show "Suc ll \<le> l'"
              proof (rule ccontr)
                assume not: "\<not> ?thesis"
                hence "l' \<le> ll" by auto
                hence "ll = l' + (ll - l')" by auto
                then obtain k where ll: "ll = l' + k" by auto
                from ass have "l' + k - ?l' < l'" unfolding ll by auto
                hence kl': "k < ?l'" by auto
                have "0 < n (ll - k)" using ass unfolding ll by simp
                from Least_le[of "\<lambda> k. 0 < n (ll - k)", OF this] kl'
                show False by auto
              qed
            qed
            show ?thesis unfolding j
              by (rule exI[of _ "k + Suc off"], unfold id ll, simp)
          qed
        qed
      qed
    qed
  }
  with assms show ?thesis by auto
qed

lemma inf_concat_surj:
  assumes j: "j < n i"
  shows "\<exists>k. inf_concat n k = (i, j)"
proof -
  from j have "0 < n i" by auto
  from inf_concat_surj_zero[of n, OF this]
  obtain k where "inf_concat n k = (i,0)" by auto
  from inf_concat_add[OF this, of j] j
  show ?thesis by auto
qed

lemma inf_concat_mono:
  assumes inf: "INFM i. n i > 0"
    and resk: "inf_concat n k = (i, j)"
    and reskp: "inf_concat n k' = (i', j')"
    and lt: "i < i'"
  shows "k < k'"
proof -
  note bounds = inf_concat_bounds[OF inf]
  {
    assume "k' \<le> k"
    hence "k = k' + (k - k')" by auto
    then obtain l where k: "k = k' + l" by auto
    have "i' \<le> fst (inf_concat n (k' + l))"
    proof (induct l)
      case 0
      with reskp show ?case by auto
    next
      case (Suc l)
      obtain i'' j'' where l: "inf_concat n (k' + l) = (i'',j'')" by force
      with Suc have one: "i' \<le> i''" by auto
      from bounds[OF l] have j'': "j'' < n i''" by auto
      show ?case
      proof (cases "Suc j'' < n i''")
        case True
        show ?thesis by (simp add: l True one)
      next
        case False
        let ?i = "LEAST i'. i'' < i' \<and> 0 < n i'"
        from inf[unfolded INFM_nat] obtain k where "i'' < k \<and> 0 < n k" by auto
        from LeastI[of "\<lambda> k. i'' < k \<and> 0 < n k", OF this]
        have "i'' < ?i" by auto
        with one show ?thesis by (simp add: l False)
      qed
    qed
    with resk k lt have False by auto
  }
  thus ?thesis by arith
qed

lemma inf_concat_Suc:
  assumes inf: "INFM i. n i > 0"
    and f: "\<And> i. f i (n i) = f (Suc i) 0"
    and resk: "inf_concat n k = (i, j)"
    and ressk: "inf_concat n (Suc k) = (i', j')"
  shows "f i' j' = f i (Suc j)"
proof -
  note bounds = inf_concat_bounds[OF inf]
  from bounds[OF resk] have j: "j < n i" .
  show ?thesis
  proof (cases "Suc j < n i")
    case True
    with ressk resk
    show ?thesis by simp
  next
    case False
    let ?p = "\<lambda> i'. i < i' \<and> 0 < n i'"
    let ?i' = "LEAST i'. ?p i'"
    from False j have id: "Suc (j + 0) = n i" by auto
    from inf_concat_step[OF resk, OF id] ressk
    have i': "i' = ?i'" and j': "j' = 0" by auto
    from id have j: "Suc j = n i" by simp
    from inf[unfolded INFM_nat] obtain k where "?p k" by auto
    from LeastI[of ?p, OF this] have "?p ?i'" .
    hence "?i' = Suc i + (?i' - Suc i)" by simp
    then obtain d where ii': "?i' = Suc i + d" by auto
    from not_less_Least[of _ ?p, unfolded ii'] have d': "\<And> d'. d' < d \<Longrightarrow> n (Suc i + d') = 0" by auto
    have "f (Suc i) 0 = f ?i' 0" unfolding ii' using d'
    proof (induct d)
      case 0
      show ?case by simp
    next
      case (Suc d)
      hence "f (Suc i) 0 = f (Suc i + d) 0" by auto
      also have "... = f (Suc (Suc i + d)) 0"
        unfolding f[symmetric]
        using Suc(2)[of d] by simp
      finally show ?case by simp
    qed
    thus ?thesis unfolding i' j' j f by simp
  qed
qed

end


(*
  File: Group.thy
  Author: Bohua Zhan

  Basics of group theory.
*)

theory Group
  imports AlgStructure Morphism
begin

section \<open>Monoids\<close>

definition is_monoid :: "i \<Rightarrow> o" where [rewrite]:
  "is_monoid(G) \<longleftrightarrow> is_mult_id(G) \<and> is_times_assoc(G)"

lemma is_monoidD [forward]:
  "is_monoid(G) \<Longrightarrow> is_mult_id(G)"
  "is_monoid(G) \<Longrightarrow> is_times_assoc(G)" by auto2+
setup {* del_prfstep_thm_eqforward @{thm is_monoid_def} *}

lemma is_monoid_group_prop [forward]:
  "is_group_raw(H) \<Longrightarrow> is_monoid(G) \<Longrightarrow> eq_str_group(G,H) \<Longrightarrow> is_monoid(H)" by auto2

ML_file "alg_monoid.ML"

section \<open>Units and multiplicative inverse\<close>

definition units :: "i \<Rightarrow> i" where [rewrite]:
  "units(G) = {x \<in>. G. (\<exists>y\<in>.G. y *\<^sub>G x = \<one>\<^sub>G \<and> x *\<^sub>G y = \<one>\<^sub>G)}"

lemma is_unitD1 [forward]: "x \<in> units(G) \<Longrightarrow> x \<in>. G" by auto2
lemma is_unitD2 [backward]: "x \<in> units(G) \<Longrightarrow> \<exists>y\<in>.G. y *\<^sub>G x = \<one>\<^sub>G \<and> x *\<^sub>G y = \<one>\<^sub>G" by auto2
lemma is_unitI [backward1, backward2]:
  "x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> y *\<^sub>G x = \<one>\<^sub>G \<Longrightarrow> x *\<^sub>G y = \<one>\<^sub>G \<Longrightarrow> x \<in> units(G)" by auto2
lemma unit_exists_invl [backward]: "x \<in> units(G) \<Longrightarrow> \<exists>y\<in>.G. y *\<^sub>G x = \<one>\<^sub>G" by auto2
lemma unit_exists_invr [backward]: "x \<in> units(G) \<Longrightarrow> \<exists>y\<in>.G. x *\<^sub>G y = \<one>\<^sub>G" by auto2
lemma one_is_unit [resolve]: "is_monoid(G) \<Longrightarrow> \<one>\<^sub>G \<in> units(G)" by auto2
lemma units_group_fun [rewrite]:
  "is_group_raw(G) \<Longrightarrow> is_group_raw(H) \<Longrightarrow> eq_str_group(G,H) \<Longrightarrow> units(G) = units(H)" by auto2
setup {* del_prfstep_thm @{thm units_def} *}

definition inv :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "inv(G,x) = (THE y. y \<in>. G \<and> y *\<^sub>G x = \<one>\<^sub>G \<and> x *\<^sub>G y = \<one>\<^sub>G)"
setup {* register_wellform_data ("inv(G,x)", ["x \<in> units(G)"]) *}

lemma inv_unique [forward]:
  "is_monoid(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> y' \<in>. G \<Longrightarrow>
   y *\<^sub>G x = \<one>\<^sub>G \<Longrightarrow> x *\<^sub>G y' = \<one>\<^sub>G \<Longrightarrow> y = y'"
@proof @have "y *\<^sub>G x *\<^sub>G y' = y *\<^sub>G (x *\<^sub>G y')" @qed

lemma inv_equality [backward1, backward2]:
  "is_monoid(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> y *\<^sub>G x = \<one>\<^sub>G \<Longrightarrow> x *\<^sub>G y = \<one>\<^sub>G \<Longrightarrow> inv(G,x) = y"
  "is_monoid(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> y *\<^sub>G x = \<one>\<^sub>G \<Longrightarrow> x *\<^sub>G y = \<one>\<^sub>G \<Longrightarrow> y = inv(G,x)" by auto2+

lemma inv_is_unit [typing]:
  "is_monoid(G) \<Longrightarrow> x \<in> units(G) \<Longrightarrow> inv(G,x) \<in> units(G)" by auto2

lemma invD [forward]:
  "is_monoid(G) \<Longrightarrow> inv(G,\<one>\<^sub>G) = \<one>\<^sub>G"
  "is_monoid(G) \<Longrightarrow> x \<in> units(G) \<Longrightarrow> inv(G,x) *\<^sub>G x = \<one>\<^sub>G"
  "is_monoid(G) \<Longrightarrow> x \<in> units(G) \<Longrightarrow> x *\<^sub>G inv(G,x) = \<one>\<^sub>G" by auto2+
setup {* del_prfstep_thm @{thm inv_def} *}

lemma inv_group_fun [rewrite]:
  "is_group_raw(H) \<Longrightarrow> is_monoid(G) \<Longrightarrow> x \<in> units(G) \<Longrightarrow> eq_str_group(G,H) \<Longrightarrow>
   inv(G,x) = inv(H,x)" by auto2

lemma unit_l_cancel [forward]:
  "is_monoid(G) \<Longrightarrow> y \<in>. G \<Longrightarrow> z \<in>. G \<Longrightarrow> x *\<^sub>G y = x *\<^sub>G z \<Longrightarrow> x \<in> units(G) \<Longrightarrow> y = z"
@proof
  @have "inv(G,x) *\<^sub>G x *\<^sub>G y = inv(G,x) *\<^sub>G (x *\<^sub>G y)"
  @have "inv(G,x) *\<^sub>G x *\<^sub>G z = inv(G,x) *\<^sub>G (x *\<^sub>G z)"
@qed

lemma unit_r_cancel [forward]:
  "is_monoid(G) \<Longrightarrow> y \<in>. G \<Longrightarrow> z \<in>. G \<Longrightarrow> y *\<^sub>G x = z *\<^sub>G x \<Longrightarrow> x \<in> units(G) \<Longrightarrow> y = z"
@proof
  @have "y *\<^sub>G (x *\<^sub>G inv(G,x)) = y *\<^sub>G x *\<^sub>G inv(G,x)"
  @have "z *\<^sub>G (x *\<^sub>G inv(G,x)) = z *\<^sub>G x *\<^sub>G inv(G,x)"
@qed

lemma unit_inv_inv [rewrite]:
  "is_monoid(G) \<Longrightarrow> x \<in> units(G) \<Longrightarrow> inv(G, inv(G,x)) = x"
@proof @have "inv(G,x) *\<^sub>G x = \<one>\<^sub>G" @qed

lemma unit_inv_comm:
  "is_monoid(G) \<Longrightarrow> y \<in>. G \<Longrightarrow> x \<in> units(G) \<Longrightarrow> x *\<^sub>G y = \<one>\<^sub>G \<Longrightarrow> y *\<^sub>G x = \<one>\<^sub>G" by auto2
setup {* fold del_prfstep_thm @{thms invD} *}
setup {* fold add_rewrite_rule @{thms invD} *}

section \<open>Definition of groups\<close>

definition is_group :: "i \<Rightarrow> o" where [rewrite]:
  "is_group(G) \<longleftrightarrow> is_monoid(G) \<and> carrier(G) = units(G)"

lemma is_groupD [forward]:
  "is_group(G) \<Longrightarrow> is_monoid(G)"
  "is_group(G) \<Longrightarrow> carrier(G) = units(G)" by auto2+

lemma is_groupI [backward1]:
  "is_monoid(G) \<Longrightarrow> unary_fun(carrier(G),f) \<Longrightarrow> \<forall>x\<in>.G. f(x) *\<^sub>G x = \<one>\<^sub>G \<Longrightarrow> is_group(G)" by auto2
setup {* del_prfstep_thm @{thm is_group_def} *}

lemma inv_equality_group1 [backward]:
  "is_group(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> y *\<^sub>G x = \<one>\<^sub>G \<Longrightarrow> inv(G,x) = y"
@proof @have "inv(G,x) *\<^sub>G x = \<one>\<^sub>G" @qed

lemma inv_equality_group2 [backward]:
  "is_group(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> y *\<^sub>G x = \<one>\<^sub>G \<Longrightarrow> y = inv(G,x)"
@proof @have "inv(G,x) *\<^sub>G x = \<one>\<^sub>G" @qed

lemma inv_distrib_group:
  "is_group(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow>
   inv(G, x *\<^sub>G y) = inv(G,y) *\<^sub>G inv(G,x) \<and>
   x \<in> units(G) \<and> y \<in> units(G) \<and> inv(G,y) \<in>. G \<and> inv(G,x) \<in>. G"
@proof @have "inv(G,y) *\<^sub>G inv(G,x) *\<^sub>G (x *\<^sub>G y) = inv(G,y) *\<^sub>G (inv(G,x) *\<^sub>G x) *\<^sub>G y" @qed

ML_file "alg_group.ML"

lemma inv_distrib_test:
  "is_group(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> z \<in>. G \<Longrightarrow>
   inv(G, x *\<^sub>G y *\<^sub>G z) = inv(G,z) *\<^sub>G inv(G,y) *\<^sub>G inv(G,x)" by auto2

lemma move_inv_r [rewrite]:
  "is_group(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> z \<in>. G \<Longrightarrow> x *\<^sub>G inv(G,y) = z \<Longrightarrow> z *\<^sub>G y = x"
@proof @have "z *\<^sub>G y *\<^sub>G inv(G,y) = z" @qed

lemma move_inv_l [rewrite]:
  "is_group(G) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow> z \<in>. G \<Longrightarrow> inv(G,x) *\<^sub>G y = z \<Longrightarrow> x *\<^sub>G z = y"
@proof @have "z = inv(G,x) *\<^sub>G (x *\<^sub>G z)" @qed

section \<open>Subgroups\<close>

definition subset_mult_closed :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "subset_mult_closed(G,H) \<longleftrightarrow> (\<forall>x\<in>H. \<forall>y\<in>H. x *\<^sub>G y \<in> H)"

lemma subset_mult_closedD [typing]:
  "subset_mult_closed(G,H) \<Longrightarrow> x \<in> H \<Longrightarrow> y \<in> H \<Longrightarrow> x *\<^sub>G y \<in> H" by auto2
setup {* del_prfstep_thm_eqforward @{thm subset_mult_closed_def} *}

definition subset_inv_closed :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "subset_inv_closed(G,H) \<longleftrightarrow> (\<forall>x\<in>H. inv(G,x) \<in> H)"

lemma subset_inv_closedD [typing]:
  "subset_inv_closed(G,H) \<Longrightarrow> x \<in> H \<Longrightarrow> inv(G,x) \<in> H" by auto2
setup {* del_prfstep_thm_eqforward @{thm subset_inv_closed_def} *}

definition is_subgroup_set :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "is_subgroup_set(G,H) \<longleftrightarrow>
    (is_group(G) \<and> H \<subseteq> carrier(G) \<and> \<one>\<^sub>G \<in> H \<and> subset_mult_closed(G,H) \<and> subset_inv_closed(G,H))"

definition subgroup :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "subgroup(G,H) = Group(H, \<one>\<^sub>G, \<lambda>x y. x *\<^sub>G y)"
setup {* register_wellform_data ("subgroup(G,H)", ["is_subgroup_set(G,H)"]) *}

lemma subgroup_is_group_raw:
  "is_subgroup_set(G,H) \<Longrightarrow> group_form(subgroup(G,H))" by auto2
setup {* add_forward_prfstep_cond @{thm subgroup_is_group_raw} [with_term "subgroup(?G,?H)"] *}

lemma subgroup_sel1:
  "carrier(subgroup(G,H)) = H"
  "one(subgroup(G,H)) = \<one>\<^sub>G" by auto2+
setup {* fold (fn th => add_forward_prfstep_cond th [with_term "subgroup(?G,?H)"]) @{thms subgroup_sel1} *}

lemma subgroup_sel2 [rewrite]:
  "\<H> = subgroup(G,H) \<Longrightarrow> x \<in>. \<H> \<Longrightarrow> y \<in>. \<H> \<Longrightarrow> is_subgroup_set(G,H) \<Longrightarrow> x *\<^sub>\<H> y = x *\<^sub>G y" by auto2+
setup {* del_prfstep_thm @{thm subgroup_def} *}

lemma subgroup_is_group:
  "is_subgroup_set(G,H) \<Longrightarrow> \<H> = subgroup(G,H) \<Longrightarrow> is_group(\<H>)"
@proof
  @have "is_monoid(\<H>)" @with
    @have "is_times_assoc(\<H>)" @with
      @have "\<forall>x\<in>H. \<forall>y\<in>H. \<forall>z\<in>H. (x *\<^sub>\<H> y) *\<^sub>\<H> z = x *\<^sub>\<H> (y *\<^sub>\<H> z)" @with
        @have "(x *\<^sub>G y) *\<^sub>G z = x *\<^sub>G (y *\<^sub>G z)" @end @end @end
  @have "\<forall>x\<in>H. inv(G,x) *\<^sub>\<H> x = \<one>\<^sub>\<H>"
@qed
setup {* add_forward_prfstep_cond @{thm subgroup_is_group} [with_term "subgroup(?G,?H)"] *}

lemma subgroup_inv [rewrite]:
  "is_subgroup_set(G,H) \<Longrightarrow> \<H> = subgroup(G,H) \<Longrightarrow> x \<in> units(\<H>) \<Longrightarrow>
   inv(\<H>,x) = inv(G,x)" by auto2

lemma subgroup_non_empty [resolve]: "\<not>is_subgroup_set(G,\<emptyset>)"
@proof @contradiction @have "\<one>\<^sub>G \<in> \<emptyset>" @qed

section \<open>Direct products\<close>

definition group_prod :: "i \<Rightarrow> i \<Rightarrow> i"  (infixr "\<times>\<^sub>G" 80) where [rewrite]:
  "G \<times>\<^sub>G H = Group(carrier(G)\<times>carrier(H), \<langle>\<one>\<^sub>G,\<one>\<^sub>H\<rangle>, \<lambda>x y. \<langle>fst(x) *\<^sub>G fst(y), snd(x) *\<^sub>H snd(y)\<rangle>)"

lemma group_prod_is_group_raw [forward]:
  "is_group_raw(G) \<Longrightarrow> is_group_raw(H) \<Longrightarrow> group_form(G \<times>\<^sub>G H)" by auto2

lemma group_prod_sel1:
  "carrier(G \<times>\<^sub>G H) = carrier(G) \<times> carrier(H)"
  "one(G \<times>\<^sub>G H) = \<langle>\<one>\<^sub>G,\<one>\<^sub>H\<rangle>" by auto2+
setup {* fold (fn th => add_forward_prfstep_cond th [with_term "?G \<times>\<^sub>G ?H"]) @{thms group_prod_sel1} *}

lemma group_prod_sel2 [rewrite]:
  "K = G \<times>\<^sub>G H \<Longrightarrow> is_group_raw(G) \<Longrightarrow> is_group_raw(H) \<Longrightarrow> x \<in>. K \<Longrightarrow> y \<in>. K \<Longrightarrow>
   x *\<^sub>K y = \<langle>fst(x) *\<^sub>G fst(y), snd(x) *\<^sub>H snd(y)\<rangle>" by auto2
setup {* del_prfstep_thm @{thm group_prod_def} *}

lemma group_prod_is_monoid [forward]:
  "is_monoid(G) \<Longrightarrow> is_monoid(H) \<Longrightarrow> is_monoid(G \<times>\<^sub>G H)"
@proof
  @let "K = G \<times>\<^sub>G H"
  @have "is_times_assoc(K)" @with
    @have "\<forall>x\<in>.K. \<forall>y\<in>.K. \<forall>z\<in>.K. (x *\<^sub>K y) *\<^sub>K z = x *\<^sub>K (y *\<^sub>K z)" @with
      @have "(fst(x) *\<^sub>G fst(y)) *\<^sub>G fst(z) = fst(x) *\<^sub>G (fst(y) *\<^sub>G fst(z))"
      @have "(snd(x) *\<^sub>H snd(y)) *\<^sub>H snd(z) = snd(x) *\<^sub>H (snd(y) *\<^sub>H snd(z))"
    @end
  @end
@qed

lemma group_prod_is_group [forward]:
  "is_group(G) \<Longrightarrow> is_group(H) \<Longrightarrow> is_group(G \<times>\<^sub>G H)"
@proof
  @let "K = G \<times>\<^sub>G H"
  @have "\<forall>x\<in>.K. \<langle>inv(G,fst(x)), inv(H,snd(x))\<rangle> *\<^sub>K x = \<one>\<^sub>K"
@qed

lemma group_prod_inv [rewrite]:
  "is_group(G) \<Longrightarrow> is_group(H) \<Longrightarrow> K = G \<times>\<^sub>G H \<Longrightarrow> \<langle>x,y\<rangle> \<in> units(K) \<Longrightarrow>
   inv(K, \<langle>x,y\<rangle>) = \<langle>inv(G,x), inv(H,y)\<rangle>" by auto2

section \<open>Homomorphisms and Isomorphisms\<close>

definition is_group_hom :: "i \<Rightarrow> o" where [rewrite]:
  "is_group_hom(f) \<longleftrightarrow> (let S = source_str(f) in let T = target_str(f) in
    is_morphism(f) \<and> is_group(S) \<and> is_group(T) \<and> (\<forall>x\<in>.S. \<forall>y\<in>.S. f`(x *\<^sub>S y) = f`x *\<^sub>T f`y))"

lemma is_group_homD1 [forward]:
  "is_group_hom(f) \<Longrightarrow> is_morphism(f) \<and> is_group(source_str(f)) \<and> is_group(target_str(f))" by auto2

lemma is_group_homD2 [rewrite]:
  "is_group_hom(f) \<Longrightarrow> G = source_str(f) \<Longrightarrow> H = target_str(f) \<Longrightarrow> x \<in>. G \<Longrightarrow> y \<in>. G \<Longrightarrow>
   f ` (x *\<^sub>G y) = f`x *\<^sub>H f`y" by auto2
setup {* del_prfstep_thm_eqforward @{thm is_group_hom_def} *}

definition group_hom_space :: "i \<Rightarrow> i \<Rightarrow> i" (infix "\<rightharpoonup>\<^sub>G" 60) where [rewrite]:
  "G \<rightharpoonup>\<^sub>G H = {f \<in> G \<rightharpoonup> H. is_group_hom(f)}"

lemma group_hom_spaceD [forward]:
  "f \<in> G \<rightharpoonup>\<^sub>G H \<Longrightarrow> f \<in> G \<rightharpoonup> H \<and> is_group_hom(f)" by auto2

lemma group_hom_spaceI [typing, backward]:
  "mor_form(f) \<Longrightarrow> is_group_hom(f) \<Longrightarrow> f \<in> source_str(f) \<rightharpoonup>\<^sub>G target_str(f)" by auto2
setup {* del_prfstep_thm @{thm group_hom_space_def} *}

lemma group_hom_compose:
  "is_group_hom(f) \<Longrightarrow> is_group_hom(g) \<Longrightarrow> target_str(f) = source_str(g) \<Longrightarrow>
   is_group_hom(g \<circ>\<^sub>m f)" by auto2
setup {* add_forward_prfstep_cond @{thm group_hom_compose} [with_term "?g \<circ>\<^sub>m ?f"] *}

lemma group_hom_one [rewrite]:
  "is_group_hom(f) \<Longrightarrow> G = source_str(f) \<Longrightarrow> H = target_str(f) \<Longrightarrow> f ` \<one>\<^sub>G = \<one>\<^sub>H"
@proof @have "f ` (\<one>\<^sub>G *\<^sub>G \<one>\<^sub>G) *\<^sub>H \<one>\<^sub>H = f ` \<one>\<^sub>G *\<^sub>H f ` \<one>\<^sub>G" @qed

lemma group_hom_inv [rewrite]:
  "is_group_hom(f) \<Longrightarrow> G = source_str(f) \<Longrightarrow> H = target_str(f) \<Longrightarrow>
   x \<in> units(G) \<Longrightarrow> f`(inv(G,x)) = inv(H,f`x)"
@proof @have "f ` (inv(G,x) *\<^sub>G x) = \<one>\<^sub>H" @qed

definition is_group_iso :: "i \<Rightarrow> o" where [rewrite]:
  "is_group_iso(f) \<longleftrightarrow> (is_group_hom(f) \<and> bijective(f))"

definition group_iso_space :: "i \<Rightarrow> i \<Rightarrow> i"  (infix "\<cong>\<^sub>G" 60) where [rewrite]:
  "group_iso_space(G,H) = {f \<in> mor_space(G,H). is_group_iso(f)}"

lemma group_iso_spaceD [forward]:
  "f \<in> G \<cong>\<^sub>G H \<Longrightarrow> f \<in> G \<rightharpoonup> H \<and> is_group_iso(f)" by auto2

lemma group_iso_spaceI [backward]:
  "mor_form(f) \<Longrightarrow> is_group_iso(f) \<Longrightarrow> f \<in> source_str(f) \<cong>\<^sub>G target_str(f)" by auto2
setup {* del_prfstep_thm @{thm group_iso_space_def} *}

lemma iso_refl [typing]: "is_group(G) \<Longrightarrow> id_mor(G) \<in> G \<cong>\<^sub>G G" by auto2

lemma iso_trans [typing]:
  "is_group_iso(f) \<Longrightarrow> is_group_iso(g) \<Longrightarrow> target_str(f) = source_str(g) \<Longrightarrow>
   g \<circ>\<^sub>m f \<in> source_str(f) \<cong>\<^sub>G target_str(g)"
@proof
  @have (@rule) "\<forall>y\<in>target(f). \<exists>x\<in>source(f). f`x = y"
  @have (@rule) "\<forall>y\<in>target(g). \<exists>x\<in>source(g). g`x = y"
@qed

lemma iso_sym [typing]:
  "is_group_iso(f) \<Longrightarrow> inverse_mor(f) \<in> target_str(f) \<cong>\<^sub>G source_str(f)"
@proof
  @let "g = inverse_mor(f)"
  @have (@rule) "\<forall>y\<in>target(f). \<exists>x\<in>source(f). f`x = y"
  @have (@rule) "\<forall>y\<in>target(g). \<exists>x\<in>source(g). g`x = y"
@qed

section \<open>Image of a homomorphism\<close>

lemma image_is_subgroup:
  "is_group_hom(f) \<Longrightarrow> H = target_str(f) \<Longrightarrow> is_subgroup_set(H, image(f))"
@proof
  @let "G = source_str(f)"
  @have "f ` \<one>\<^sub>G = \<one>\<^sub>H"
  @have "subset_mult_closed(H, image(f))" @with
    @have "\<forall>x\<in>image(f). \<forall>y\<in>image(f). x *\<^sub>H y \<in> image(f)" @with
      @obtain "x'\<in>source(f)" where "f`x' = x"
      @obtain "y'\<in>source(f)" where "f`y' = y"
      @have "f`(x' *\<^sub>G y') = x *\<^sub>H y"
    @end
  @end
  @have "subset_inv_closed(H, image(f))" @with
    @have "\<forall>x\<in>image(f). inv(H,x) \<in> image(f)" @with
      @obtain "x'\<in>source(f)" where "f`x' = x"
      @have "f`(inv(G,x')) = inv(H,x)"
    @end
  @end
@qed
setup {* add_forward_prfstep_cond @{thm image_is_subgroup} [with_term "image(?f)"] *}

definition image_subgroup :: "i \<Rightarrow> i" where image_subgroup_def [rewrite_bidir]:
  "image_subgroup(f) = subgroup(target_str(f), image(f))"

definition group_mor_restrict_image :: "i \<Rightarrow> i" where [rewrite]:
  "group_mor_restrict_image(f) = Mor(source_str(f), image_subgroup(f), \<lambda>x. f`x)"

lemma group_mor_restrict_image_is_mor [typing]:
  "is_group_hom(f) \<Longrightarrow> group_mor_restrict_image(f) \<in> source_str(f) \<rightharpoonup>\<^sub>G image_subgroup(f)" by auto2

lemma group_mor_restrict_image_eval [rewrite]:
  "is_group_hom(f) \<Longrightarrow> f' = group_mor_restrict_image(f) \<Longrightarrow> x \<in> source(f') \<Longrightarrow> f'`x = f`x" by auto2
setup {* del_prfstep_thm @{thm group_mor_restrict_image_def} *}

lemma group_mor_factorize [rewrite_back]:
  "mor_form(f) \<Longrightarrow> is_group_hom(f) \<Longrightarrow>
   f = inj_mor(image_subgroup(f), target_str(f)) \<circ>\<^sub>m group_mor_restrict_image(f)" by auto2

lemma group_mor_inj_restrict_image_bij [typing]:
  "is_group_hom(f) \<Longrightarrow> injective(f) \<Longrightarrow>
   group_mor_restrict_image(f) \<in> source_str(f) \<cong>\<^sub>G image_subgroup(f)" by auto2

end


theory MList
imports Main Utils
begin

fun valid_map :: "('a::linorder \<times> 'b) list \<Rightarrow> bool" where
  "valid_map x = (let y = map fst x in
                  (List.distinct y \<and> List.sorted y))"

definition empty :: "('a::linorder \<times> 'b) list" where
  "empty = Nil"

lemma valid_empty : "valid_map empty"
  by (simp add:MList.empty_def)

fun insert :: "'a::linorder \<Rightarrow> 'b \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b) list" where
  "insert a b Nil = Cons (a, b) Nil" |
  "insert a b (Cons (x, y) z) =
    (if a < x
     then (Cons (a, b) (Cons (x, y) z))
     else (if a > x
           then (Cons (x, y) (insert a b z))
           else (Cons (x, b) z)))"

lemma insert_length : "length (insert a b c) \<le> (length c + 1)"
  apply (induction c)
  by auto

lemma insert_in_middle : "x < a \<Longrightarrow> valid_map ((a, b) # z)
                            \<Longrightarrow> valid_map ((x, y) # (a, c) # z)"
  by auto

lemma remove_from_middle : "valid_map ((x, y) # (a, b) # z) \<Longrightarrow> x < a"
  by auto

lemma sublist_valid : "valid_map ((x, y) # c) \<Longrightarrow>
                       valid_map c"
  by simp

lemma insert_valid_aux :
  "x < a \<Longrightarrow>
   valid_map ((x, y) # c) \<Longrightarrow>
   valid_map (MList.insert a b c) \<Longrightarrow>
   valid_map ((x, y) # MList.insert a b c)"
  apply (induction c arbitrary: a b x y)
  apply auto[1]
  by (metis (no_types, opaque_lifting) insert.simps(2)
            insert_in_middle prod.collapse remove_from_middle)

lemma insert_valid_aux2 :
  "(\<And>a b. valid_map c \<Longrightarrow> valid_map (MList.insert a b c)) \<Longrightarrow>
    valid_map ((x, y) # c) \<Longrightarrow>
    x < a \<Longrightarrow>
    valid_map ((x, y) # MList.insert a b c)"
  by (smt (verit, best) insert.elims insert_in_middle remove_from_middle sublist_valid)

lemma insert_valid_aux3 :
  "(\<And>a b. valid_map c \<Longrightarrow> valid_map (MList.insert a b c)) \<Longrightarrow>
   valid_map ((x, y) # c) \<Longrightarrow> valid_map (MList.insert a b ((x, y) # c))"
  apply (simp only:insert.simps)
  apply (cases "a < x")
  apply auto[1]
  apply (cases "x < a")
  apply (smt insert_valid_aux2)
  by auto

theorem insert_valid : "valid_map c \<Longrightarrow> valid_map (MList.insert a b c)"
  apply (induction c arbitrary:a b)
  apply simp
  by (metis insert_valid_aux3 old.prod.exhaust)

lemma insert_replaces_value :
  "valid_map m \<Longrightarrow> MList.insert k v1 (MList.insert k v2 m) = MList.insert k v1 m"
proof (induction m)
  case Nil
  then show ?case
    by simp
next
  case (Cons head rest)
  then obtain hK hV where "head = (hK, hV)"
    by fastforce
  then show ?case
    using Cons.IH Cons.prems by force
qed

lemma insert_swap :
  "\<lbrakk> valid_map m
   ; k1 \<noteq> k2
   \<rbrakk> \<Longrightarrow> MList.insert k1 v1 (MList.insert k2 v2 m) = MList.insert k2 v2 (MList.insert k1 v1 m)"
proof (induction m)
  case Nil
  then show ?case
    by (simp add: not_less_iff_gr_or_eq)
next
  case (Cons head rest)
  then obtain hK hV where pHead: "head = (hK, hV)"
    using prod.exhaust_sel by blast
  then show ?case
  proof (cases rule: linorder_cases[of k2 hK])
    case less
    then show ?thesis
      using Cons.prems(2) pHead by fastforce
  next
    case equal
    then show ?thesis
      using Cons.prems(2) pHead by auto
  next
    case greater
    then show ?thesis
      using Cons.IH Cons.prems(1) Cons.prems(2) pHead by auto
  qed
qed

fun delete :: "'a::linorder \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b) list" where
  "delete a Nil = Nil" |
  "delete a (Cons (x, y) z) =
    (if a = x
     then z
     else (if a > x
           then (Cons (x, y) (delete a z))
           else (Cons (x, y) z)))"

lemma delete_length : "length (delete a b) \<le> length b"
  apply (induction b)
  by auto

lemma delete_valid_aux :
  "valid_map (a # c) \<Longrightarrow> valid_map (a # delete b c)"
  apply (induction c arbitrary: a b)
  apply simp
  by fastforce

lemma delete_valid_aux2 :
  "(\<And>a. valid_map c \<Longrightarrow> valid_map (delete a c)) \<Longrightarrow>
   valid_map (b # c) \<Longrightarrow> valid_map (delete a (b # c))"
  apply (cases "b")
  apply (simp only:delete.simps)
  by (smt delete_valid_aux sublist_valid)

theorem delete_valid : "valid_map c \<Longrightarrow> valid_map (MList.delete a c)"
  apply (induction c arbitrary: a)
  apply auto[1]
  using delete_valid_aux2 by blast

lemma delete_step :
  "valid_map ((k, v) # t) \<Longrightarrow>
   \<not> k2 = k \<Longrightarrow>
   MList.delete k2 ((k, v) # t) = ((k, v)#(MList.delete k2 t))"
  apply (induction t)
  by auto

fun lookup :: "'a::linorder \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> 'b option" where
  "lookup a Nil = None" |
  "lookup a (Cons (x, y) z) =
    (if a = x
     then Some y
     else (if a > x
           then lookup a z
           else None))"

lemma lookup_empty : "MList.lookup y MList.empty = None"
  by (simp add: MList.empty_def)

lemma insert_existing_length : "MList.lookup k l = Some a \<Longrightarrow>
                                length (MList.insert k v l) = length l"
  apply (induction l)
  apply simp
  using not_less_iff_gr_or_eq by fastforce

lemma delete_lookup_None_aux :
  "valid_map ((c, d) # b) \<Longrightarrow> lookup c b = None"
  by (metis lookup.elims order.asym remove_from_middle)

lemma delete_lookup_None_aux2 :
  "(valid_map b \<Longrightarrow> lookup a (delete a b) = None) \<Longrightarrow>
   valid_map ((c, d) # b) \<Longrightarrow> lookup a (delete a ((c, d) # b)) = None"
  apply (cases "a > c")
  apply auto[1]
  apply (cases "a = c")
  apply (simp only:delete.simps lookup.simps)
  apply (simp add: delete_lookup_None_aux)
  by auto

theorem delete_lookup_None : "valid_map b \<Longrightarrow>
                              MList.lookup a (MList.delete a b) = None"
  apply (induction b)
  apply simp
  using delete_lookup_None_aux2 by fastforce

theorem insert_lookup_Some : "MList.lookup a (MList.insert a b c) = Some b"
  apply (induction c)
  apply simp
  by force

theorem insert_lookup_different : "a \<noteq> b \<Longrightarrow> MList.lookup a (MList.insert b c d) = MList.lookup a d"
  apply (induction d)
  apply simp
  by force

lemma different_delete_lookup_aux :
  "(valid_map c \<Longrightarrow> a \<noteq> b \<Longrightarrow> lookup a (delete b c) = lookup a c) \<Longrightarrow>
   valid_map ((x, y) # c) \<Longrightarrow>
   a \<noteq> b \<Longrightarrow> lookup a (delete b ((x, y) # c)) = lookup a ((x, y) # c)"
  by (metis delete.simps(2) delete_lookup_None_aux delete_valid insert_in_middle lookup.simps(2) not_less_iff_gr_or_eq)

theorem different_delete_lookup :
  "valid_map c \<Longrightarrow> a \<noteq> b \<Longrightarrow>
   MList.lookup a (MList.delete b c) = MList.lookup a c"
  apply (induction c)
  apply simp
  by (metis different_delete_lookup_aux old.prod.exhaust)

fun unionWith :: "('b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a \<times> 'b) list \<Rightarrow>
                  ('a \<times> 'b) list \<Rightarrow> (('a::linorder) \<times> 'b) list" where
"unionWith f (Cons (x, y) t) (Cons (x2, y2) t2) =
  (if x < x2
   then Cons (x, y) (unionWith f t (Cons (x2, y2) t2))
   else (if x > x2
         then Cons (x2, y2) (unionWith f (Cons (x, y) t) t2)
         else Cons (x, f y y2) (unionWith f t t2)))" |
"unionWith f Nil l = l" |
"unionWith f l Nil = l"

lemma unionWithMonotonic1 :
  "x < x2 \<Longrightarrow> fst ( hd ( unionWith f ((x, y) # t) ((x2, y2) # t2) ) ) = x"
  by simp

lemma insert_before :
  "valid_map c \<Longrightarrow> x < fst ( hd ( c ) ) \<Longrightarrow> valid_map ((x, y) # c)"
  by (metis insert.simps(1) insert_in_middle insert_valid list.exhaust list.sel(1) prod.collapse)

lemma insert_before_union :
  "x < x2 \<Longrightarrow>
   valid_map ((x, y) # t) \<Longrightarrow>
   valid_map ((x2, y2) # t2) \<Longrightarrow>
   x < fst ( hd ( unionWith f t ((x2, y2) # t2) ) )"
  apply (induction t)
  apply auto[1]
  by auto

lemma insert_before_union2 :
  "x2 < x \<Longrightarrow>
   valid_map ((x, y) # t) \<Longrightarrow>
   valid_map ((x2, y2) # t2) \<Longrightarrow>
   x2 < fst ( hd ( unionWith f ((x, y) # t) t2 ) )"
  apply (induction t2)
  apply auto[1]
  by force

lemma insert_before_union3 :
  "valid_map ((x, y) # t) \<Longrightarrow>
   valid_map ((x, y2) # t2) \<Longrightarrow>
   (t \<noteq> [] \<or> t2 \<noteq> []) \<Longrightarrow>
   x < fst ( hd ( unionWith f t t2 ) )"
  apply (induction t)
  apply (metis list.collapse prod.collapse remove_from_middle unionWith.simps(2))
  apply (induction t2)
  apply auto[1]
  by auto

lemma unionWithValidLT_aux :
  "x < x2 \<Longrightarrow>
    (valid_map (unionWith f t ((x2, y2) # t2))) \<Longrightarrow>
    valid_map ((x, y) # t) \<Longrightarrow>
    valid_map ((x2, y2) # t2) \<Longrightarrow>
    valid_map ((x, y) # unionWith f t ((x2, y2) # t2))"
  by (meson insert_before insert_before_union)

lemma unionWithValidLT :
  "x < x2 \<Longrightarrow>
   (valid_map t \<Longrightarrow>
    valid_map ((x2, y2) # t2) \<Longrightarrow>
    valid_map (unionWith f t ((x2, y2) # t2))) \<Longrightarrow>
   valid_map ((x, y) # t) \<Longrightarrow>
   valid_map ((x2, y2) # t2) \<Longrightarrow>
   valid_map (unionWith f ((x, y) # t) ((x2, y2) # t2))"
  apply (simp only:unionWith.simps sublist_valid)
  by (meson unionWithValidLT_aux)

lemma unionWithValidGT_aux :
  "x2 < x \<Longrightarrow>
   (valid_map (unionWith f ((x, y) # t) t2)) \<Longrightarrow>
   valid_map ((x, y) # t) \<Longrightarrow>
   valid_map ((x2, y2) # t2) \<Longrightarrow>
   valid_map ((x2, y2) # unionWith f ((x, y) # t) t2)"
  by (meson insert_before insert_before_union2)

lemma unionWithValidGT :
  "x2 < x \<Longrightarrow>
   (valid_map ((x, y) # t) \<Longrightarrow>
    valid_map t2 \<Longrightarrow> valid_map (unionWith f ((x, y) # t) t2)) \<Longrightarrow>
   valid_map ((x, y) # t) \<Longrightarrow>
   valid_map ((x2, y2) # t2) \<Longrightarrow>
   valid_map (unionWith f ((x, y) # t) ((x2, y2) # t2))"
  apply (simp only:unionWith.simps sublist_valid)
  by (smt order.asym unionWithValidGT_aux)

lemma unionWithValidEQ_aux :
  "(valid_map (unionWith f t t2)) \<Longrightarrow>
   valid_map ((x, y) # t) \<Longrightarrow>
   valid_map ((x, y2) # t2) \<Longrightarrow>
   valid_map ((x, f y y2) # unionWith f t t2)"
  by (metis insert.simps(1) insert_before insert_before_union3 insert_valid unionWith.simps(2))

lemma unionWithValidEQ :
  "(valid_map t \<Longrightarrow> valid_map t2 \<Longrightarrow> valid_map (unionWith f t t2)) \<Longrightarrow>
   valid_map ((x, y) # t) \<Longrightarrow>
   valid_map ((x, y2) # t2) \<Longrightarrow>
   valid_map (unionWith f ((x, y) # t) ((x, y2) # t2))"
  apply (simp only:unionWith.simps sublist_valid)
  by (smt order.asym unionWithValidEQ_aux)

theorem unionWithValid : "valid_map a \<Longrightarrow> valid_map b \<Longrightarrow>
                          valid_map (unionWith f a b)"
  apply (induction f a b rule:unionWith.induct)
  apply (metis less_linear unionWithValidEQ unionWithValidGT unionWithValidLT)
  by auto

theorem unionWithSym : "valid_map a \<Longrightarrow> valid_map b \<Longrightarrow>
                        unionWith f a b = unionWith (flip f) b a"
  apply (induction f a b rule:unionWith.induct)
  apply auto[1]
  apply (metis list.exhaust unionWith.simps(2) unionWith.simps(3))
  by simp

fun findWithDefault :: "'b \<Rightarrow> 'a \<Rightarrow> (('a::linorder) \<times> 'b) list \<Rightarrow> 'b" where
"findWithDefault d k l = (case lookup k l of
                            None \<Rightarrow> d
                          | Some x \<Rightarrow> x)"

lemma findWithDefault_step :
  "valid_map ((k, v) # tail) \<Longrightarrow>
   k2 \<noteq> k \<Longrightarrow>
   findWithDefault d k2 ((k, v) # tail) = findWithDefault d k2 tail"
  apply simp
  apply (induction tail)
  by auto

fun member :: "'a \<Rightarrow> ((('a::linorder) \<times> 'b) list) \<Rightarrow> bool" where
"member k d = (lookup k d \<noteq> None)"

lemma deleteNotMember: "\<lbrakk> \<not> member k m \<rbrakk> \<Longrightarrow> delete k m = m"
proof (induction m)
  case Nil
  then show ?case
    by simp
next
  case (Cons headKeyVal rest)
  obtain hK hV where "headKeyVal = (hK, hV)"
    by fastforce
  with Cons show ?case
    using option.distinct(1) by force
qed

lemma equalMList: "\<lbrakk> valid_map m; valid_map n \<rbrakk> \<Longrightarrow> \<forall>x. lookup x m = lookup x n \<Longrightarrow> m = n"
proof (induction m arbitrary: n)
  case Nil
  then show ?case
    by (metis list.exhaust lookup.simps(1) lookup.simps(2) old.prod.exhaust option.distinct(1))
next
  case (Cons mHead mRest)
  then show ?case
  proof (induction n )
    case Nil
    then show ?case
      by (metis lookup.simps(1) lookup.simps(2) old.prod.exhaust option.distinct(1))
  next
    case (Cons nHead nRest)
    then show ?case
      (* TODO: this takes a little long, simplify *)
      by (metis delete.simps(2) delete_lookup_None_aux different_delete_lookup lookup.simps(2) not_None_eq option.inject order.asym prod.collapse sublist_valid)
  qed
qed

lemma insertDeleted : "\<lbrakk> valid_map m; lookup k m = Some v \<rbrakk> \<Longrightarrow> insert k v (delete k m) = m"
proof (induction m)
  case Nil
  then show ?case
    by simp
next
  case (Cons headKeyVal rest)
  obtain hK hV where headKeyVal: "headKeyVal = (hK, hV)"
    by fastforce
  then have 0: "lookup hK rest = None"
    by (metis Cons.prems(1) delete_lookup_None_aux)
  show ?case
  proof (cases rule: linorder_cases[of hK k])
    case less
    with Cons headKeyVal show ?thesis
      by (metis delete_step insert.simps(2) lookup.simps(2) order.asym sublist_valid)
  next
    case equal
    with equal Cons headKeyVal 0  show ?thesis
      by (smt (verit, best) delete_valid different_delete_lookup equalMList insert_lookup_Some insert_lookup_different insert_valid)
  next
    case greater
    then show ?thesis
      by (metis Cons.prems(2) headKeyVal lookup.simps(2) not_less_iff_gr_or_eq option.discI)
  qed
qed

lemma cons_eq_insert_rest :
"valid_map ((k,v) # rest) \<Longrightarrow>
(k,v) # rest = MList.insert k v rest"
  by (metis delete.simps(2) MList.lookup.simps(2) insertDeleted)

section "As Maps"

lemma insertAsMap : "valid_map mlist \<Longrightarrow> map_of(insert k v mlist) = (map_of mlist) (k\<mapsto>v)"
proof (induction mlist)
  case Nil
  then show ?case
    by auto
next
  case (Cons head rest)
  obtain hK hV where "head = (hK, hV)"
    by fastforce
  then show ?case
    using Cons.IH Cons.prems prod.sel(2) by fastforce
qed

lemma deleteAsMap : "valid_map mlist \<Longrightarrow> map_of (delete k mlist) = (map_of mlist)(k := None)"
proof (induction mlist)
  case Nil
  then show ?case
    by simp
next
  case (Cons head rest)
  obtain hK hV where pHead: "head = (hK, hV)"
    by fastforce
  then show ?case
  by (smt (z3) Cons.IH Cons.prems MList.member.simps delete.simps(2) deleteNotMember delete_lookup_None_aux delete_step fst_conv fun_upd_twist fun_upd_upd map_of.simps(2) sublist_valid)
qed

lemma lookupAsMap : "valid_map mlist \<Longrightarrow> lookup k mlist = (map_of mlist) k"
proof (induction mlist)
  case Nil
  then show ?case
    by simp
next
  case (Cons head rest)
  obtain hK hV where "head = (hK, hV)"
    by fastforce
  then show ?case
    by (smt (verit, ccfv_threshold) Cons.IH Cons.prems deleteNotMember delete_lookup_None delete_step list.inject lookup.simps(2) map_of_Cons_code(2) member.elims(1) sublist_valid)
qed

lemma MList_induct[consumes 1, case_names empty update]:
  assumes "valid_map m"
  assumes "P []"
  assumes "\<And>k v m. valid_map m \<Longrightarrow> \<not> member k m \<Longrightarrow> P m \<Longrightarrow> P (insert k v m)"
  shows "P m"
  using assms(1)
proof(induction m)
  case Nil
  then show ?case by (simp add: assms(2))
next
  case (Cons head rest)
  then obtain hK hV where "head = (hK, hV)"
    by fastforce
  moreover have "valid_map rest"
    using Cons.prems by auto
  moreover have "\<not> member hK rest"
    by (metis Cons.prems MList.member.simps calculation(1) delete_lookup_None_aux)
  moreover have "P rest"
    using Cons.IH calculation(2) by blast
  ultimately  show ?case using assms(3)
    by (metis Cons.prems delete.simps(2) insertDeleted lookup.simps(2))
qed

lemma insertOverDeleted :
  assumes "valid_map m"
  shows "insert k v m = insert k v (delete k m)"
using assms proof (induction m rule: MList_induct)
  case empty
  then show ?case
    by simp
next
  case (update uK uV m)
  then show ?case
    by (smt (verit) delete_valid different_delete_lookup equalMList insert_lookup_Some insert_lookup_different insert_valid)
qed

subsection "keys"

fun keys :: "('k \<times> 'v) list \<Rightarrow> 'k set" where
  "keys m = set (map fst m)"

lemma keys_member_r: "valid_map m \<Longrightarrow> member k m \<longleftrightarrow> k \<in> keys m"
proof (induction m)
  case Nil
  then show ?case
    by simp
next
  case (Cons head rest)
  moreover obtain hK hV where "head = (hK, hV)"
    by fastforce
  moreover have "valid_map rest"
    using calculation by (metis local.Cons.prems sublist_valid)
  moreover have "hK < k \<Longrightarrow> member k rest \<Longrightarrow> k \<in> keys rest"
    using calculation local.Cons.IH by blast
  moreover have "hK < k \<Longrightarrow> k \<in> keys rest \<Longrightarrow> member k rest"
    using calculation local.Cons.IH by blast
  ultimately show ?case
    by (metis keys.elims list.set_map member.simps local.Cons.prems lookupAsMap map_of_eq_None_iff)
qed

section "MList with folds"

text "The following lemma is similar to the second case of the foldr definition, which states

\<^term>\<open>foldr f (x # xs) = f x \<circ> foldr f xs\<close>

Instead of working with Cons this lemma is expressed around MList.insert"

lemma foldr_insert:
  assumes "valid_map m"
  (* We require not having the key in the rest of the list, because otherwise the
     insert would overwrite the value and the lemma would not hold *)
  assumes "\<not> MList.member k m"
  (* We require the function to be commutative over composition because the insert function
    can add the element in any order *)
  assumes "\<forall>a b. f a \<circ> f b = f b \<circ> f a"
  shows "foldr f (MList.insert k v m) = f (k, v) \<circ> foldr f m"
  using assms(1) assms(2) proof (induction m)
  case Nil
  then show ?case by simp
next
  case (Cons head rest)
  then obtain hK hV where pHead: "head = (hK, hV)"
    by force
  then have "hK \<noteq> k"
    using local.Cons.prems(2) by force
  then show ?case
    by (smt (verit, best) Cons.IH Cons.prems(1) Cons.prems(2) MList.member.simps assms(3) foldr_Cons fun.map_comp insert.simps(2) lookup.simps(2) not_less_iff_gr_or_eq pHead sublist_valid)
qed

text "Similary, \<^term>\<open>foldl_insert\<close> is defined to relate to the foldl second case definition
      \<^term>\<open>foldl f a (x # xs) = foldl f (f a x) xs\<close>"
lemma foldl_insert:
  assumes "valid_map m"
  assumes "\<not> MList.member k m"
  assumes "\<forall> a b z'. f (f z' a) b = f (f z' b) a"
  shows "foldl f z (MList.insert k v m) = foldl f (f z (k, v)) m"

using assms(1) assms(2) proof (induction m  arbitrary: z  )
  case Nil
  then show ?case
    by simp
next
  case (Cons head rest)
  moreover obtain hK hV where "head = (hK, hV)"
    by (meson Product_Type.prod.exhaust_sel)
  moreover have "hK \<noteq> k"
    using calculation  by force
  ultimately show ?case
    using assms(3) by auto
qed

section "MList with filter"

lemma filterOnInsertNotP :
  assumes "valid_map m"
      and "\<forall> v. \<not> P (k, v)"
  shows "filter P (insert k v m) = filter P m"
using assms proof (induction m)
  case Nil
  then show ?case by simp
next
  case (Cons head rest)
  then obtain hK hV where "head = (hK, hV)"
    by (meson surj_pair)
  then show ?case
    using local.Cons.IH local.Cons.prems(1) local.Cons.prems(2) by auto
qed

lemma filterOnInsertP :
  assumes "valid_map m"
      and "\<forall> v. P (k, v)"
    shows "filter P (insert k v m) = insert k v (filter P m)"
using assms proof (induction m)
  case Nil
  then show ?case by simp
next
  case (Cons head rest)
  then obtain hK hV where pHead: "head = (hK, hV)"
    by (meson surj_pair)
  then show ?case
  proof (cases rule: linorder_cases [of k hK])
    case less
    have "(k, v) # filter P rest = insert k v (filter P rest)"
      by (smt (verit) filter.simps(2) insert.elims assms(2) less local.Cons.IH local.Cons.prems(1) order_less_trans pHead remove_from_middle sublist_valid)
    then show ?thesis
      by (simp add: assms(2) less pHead)
  next
    case equal
    with Cons pHead show ?thesis by simp
  next
    case greater
    with Cons pHead show ?thesis by auto
   qed
 qed

lemma lookupAsFilter :
  assumes "valid_map m" and "lookup k m = Some v"
  shows "filter (\<lambda>(eK, _). eK = k) m = [(k, v)]"
        (is "?f m = _")
  using assms proof (induction m rule: MList_induct)
  case empty
  then show ?case
    by simp
next
  case (update uK uV m)
  then show ?case
  proof (cases "uK = k")
    assume "uK = k"
    moreover have "uV = v"
      by (metis calculation Option.option.sel insert_lookup_Some local.update.prems)
    moreover have "lookup k m = None"
      using calculation local.update.hyps(2) by auto
    moreover have "?f m = []"
      by (smt (verit, del_insts) calculation(3) case_prodE filter_False lookupAsMap map_of_eq_Some_iff option.simps(3) update.hyps(1) valid_map.elims(2))
    moreover have "?f (insert uK uV m) = [(uK, uV)]"
      using calculation filterOnInsertP local.update.hyps(1) by fastforce
    ultimately show ?thesis
      by force
  next
    assume "uK \<noteq> k"
    moreover have "?f (insert uK uV m) = ?f m"
      using calculation filterOnInsertNotP local.update.hyps(1) by fastforce
    ultimately show ?thesis
      by (metis insert_lookup_different local.update.IH local.update.prems)
  qed
qed

end