(*  Title:       Prefix ordering on coinductive lists as ordering for type class order
    Author:      Andreas Lochbihler
    Maintainer:  Andreas Lochbihler
*)

section \<open>Instantiation of the order type classes for lazy lists\<close>
theory Coinductive_List_Prefix imports
  Coinductive_List
  "HOL-Library.Prefix_Order"
begin

subsection \<open>Instantiation of the order type class\<close>

instantiation llist :: (type) order begin

definition [code_unfold]: "xs \<le> ys = lprefix xs ys"

definition [code_unfold]: "xs < ys = lstrict_prefix xs ys"

instance
proof(intro_classes)
  fix xs ys zs :: "'a llist"
  show "(xs < ys) = (xs \<le> ys \<and> \<not> ys \<le> xs)"
    unfolding less_llist_def less_eq_llist_def lstrict_prefix_def
    by(auto simp: lprefix_antisym)
  show "xs \<le> xs" unfolding less_eq_llist_def by(rule lprefix_refl)
  show "\<lbrakk>xs \<le> ys; ys \<le> zs\<rbrakk> \<Longrightarrow> xs \<le> zs"
    unfolding less_eq_llist_def by(rule lprefix_trans)
  show "\<lbrakk>xs \<le> ys; ys \<le> xs\<rbrakk> \<Longrightarrow> xs = ys"
    unfolding less_eq_llist_def by(rule lprefix_antisym)
qed

end

lemma le_llist_conv_lprefix [iff]: "(\<le>) = lprefix"
by(simp add: less_eq_llist_def fun_eq_iff)

lemma less_llist_conv_lstrict_prefix [iff]: "(<) = lstrict_prefix"
by(simp add: less_llist_def fun_eq_iff)

instantiation llist :: (type) order_bot begin

definition "bot = LNil"

instance
by(intro_classes)(simp add: bot_llist_def)

end

lemma llist_of_lprefix_llist_of [simp]:
  "lprefix (llist_of xs) (llist_of ys) \<longleftrightarrow> xs \<le> ys"
proof(induct xs arbitrary: ys)
  case (Cons x xs) thus ?case
    by(cases ys)(auto simp add: LCons_lprefix_conv)
qed simp

subsection \<open>Prefix ordering as a lower semilattice\<close>

instantiation llist :: (type) semilattice_inf begin

definition [code del]:
  "inf xs ys =
   unfold_llist (\<lambda>(xs, ys). xs \<noteq> LNil \<longrightarrow> ys \<noteq> LNil \<longrightarrow> lhd xs \<noteq> lhd ys)
     (lhd \<circ> snd) (map_prod ltl ltl) (xs, ys)"

lemma llist_inf_simps [simp, code, nitpick_simp]:
  "inf LNil xs = LNil"
  "inf xs LNil = LNil"
  "inf (LCons x xs) (LCons y ys) = (if x = y then LCons x (inf xs ys) else LNil)"
unfolding inf_llist_def by simp_all

lemma llist_inf_eq_LNil [simp]:
  "lnull (inf xs ys) \<longleftrightarrow> (xs \<noteq> LNil \<longrightarrow> ys \<noteq> LNil \<longrightarrow> lhd xs \<noteq> lhd ys)"
by(simp add: inf_llist_def)

instance
proof
  fix xs ys zs :: "'a llist"
  show "inf xs ys \<le> xs" unfolding le_llist_conv_lprefix
    by(coinduction arbitrary: xs ys) auto

  show "inf xs ys \<le> ys" unfolding le_llist_conv_lprefix
    by(coinduction arbitrary: xs ys) auto

  assume "xs \<le> ys" "xs \<le> zs"
  thus "xs \<le> inf ys zs" unfolding le_llist_conv_lprefix
  proof(coinduction arbitrary: xs ys zs)
    case (lprefix xs ys zs)
    thus ?case by(cases xs)(auto 4 4 simp add: LCons_lprefix_conv)
  qed
qed

end

lemma llength_inf [simp]: "llength (inf xs ys) = llcp xs ys"
by(coinduction arbitrary: xs ys rule: enat_coinduct)(auto simp add: llcp_eq_0_iff epred_llength epred_llcp)

instantiation llist :: (type) ccpo
begin

definition "Sup A = lSup A"

instance
  by intro_classes
     (auto simp: Sup_llist_def less_eq_llist_def[abs_def] intro!: llist.lub_upper llist.lub_least)

end

end


(*  Title:      HOL/BNF_Wellorder_Relation.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Well-order relations as needed by bounded natural functors.
*)

section {* Well-Order Relations as Needed by Bounded Natural Functors *}

theory BNF_Wellorder_Relation
imports Order_Relation
begin

text{* In this section, we develop basic concepts and results pertaining
to well-order relations.  Note that we consider well-order relations
as {\em non-strict relations},
i.e., as containing the diagonals of their fields. *}

locale wo_rel =
  fixes r :: "'a rel"
  assumes WELL: "Well_order r"
begin

text{* The following context encompasses all this section. In other words,
for the whole section, we consider a fixed well-order relation @{term "r"}. *}

(* context wo_rel  *)

abbreviation under where "under \<equiv> Order_Relation.under r"
abbreviation underS where "underS \<equiv> Order_Relation.underS r"
abbreviation Under where "Under \<equiv> Order_Relation.Under r"
abbreviation UnderS where "UnderS \<equiv> Order_Relation.UnderS r"
abbreviation above where "above \<equiv> Order_Relation.above r"
abbreviation aboveS where "aboveS \<equiv> Order_Relation.aboveS r"
abbreviation Above where "Above \<equiv> Order_Relation.Above r"
abbreviation AboveS where "AboveS \<equiv> Order_Relation.AboveS r"
abbreviation ofilter where "ofilter \<equiv> Order_Relation.ofilter r"
lemmas ofilter_def = Order_Relation.ofilter_def[of r]

subsection {* Auxiliaries *}

lemma REFL: "Refl r"
using WELL order_on_defs[of _ r] by auto

lemma TRANS: "trans r"
using WELL order_on_defs[of _ r] by auto

lemma ANTISYM: "antisym r"
using WELL order_on_defs[of _ r] by auto

lemma TOTAL: "Total r"
using WELL order_on_defs[of _ r] by auto

lemma TOTALS: "\<forall>a \<in> Field r. \<forall>b \<in> Field r. (a,b) \<in> r \<or> (b,a) \<in> r"
using REFL TOTAL refl_on_def[of _ r] total_on_def[of _ r] by force

lemma LIN: "Linear_order r"
using WELL well_order_on_def[of _ r] by auto

lemma WF: "wf (r - Id)"
using WELL well_order_on_def[of _ r] by auto

lemma cases_Total:
"\<And> phi a b. \<lbrakk>{a,b} <= Field r; ((a,b) \<in> r \<Longrightarrow> phi a b); ((b,a) \<in> r \<Longrightarrow> phi a b)\<rbrakk>
             \<Longrightarrow> phi a b"
using TOTALS by auto

lemma cases_Total3:
"\<And> phi a b. \<lbrakk>{a,b} \<le> Field r; ((a,b) \<in> r - Id \<or> (b,a) \<in> r - Id \<Longrightarrow> phi a b);
              (a = b \<Longrightarrow> phi a b)\<rbrakk>  \<Longrightarrow> phi a b"
using TOTALS by auto

subsection {* Well-founded induction and recursion adapted to non-strict well-order relations *}

text{* Here we provide induction and recursion principles specific to {\em non-strict}
well-order relations.
Although minor variations of those for well-founded relations, they will be useful
for doing away with the tediousness of
having to take out the diagonal each time in order to switch to a well-founded relation. *}

lemma well_order_induct:
assumes IND: "\<And>x. \<forall>y. y \<noteq> x \<and> (y, x) \<in> r \<longrightarrow> P y \<Longrightarrow> P x"
shows "P a"
proof-
  have "\<And>x. \<forall>y. (y, x) \<in> r - Id \<longrightarrow> P y \<Longrightarrow> P x"
  using IND by blast
  thus "P a" using WF wf_induct[of "r - Id" P a] by blast
qed

definition
worec :: "(('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
where
"worec F \<equiv> wfrec (r - Id) F"

definition
adm_wo :: "(('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> bool"
where
"adm_wo H \<equiv> \<forall>f g x. (\<forall>y \<in> underS x. f y = g y) \<longrightarrow> H f x = H g x"

lemma worec_fixpoint:
assumes ADM: "adm_wo H"
shows "worec H = H (worec H)"
proof-
  let ?rS = "r - Id"
  have "adm_wf (r - Id) H"
  unfolding adm_wf_def
  using ADM adm_wo_def[of H] underS_def[of r] by auto
  hence "wfrec ?rS H = H (wfrec ?rS H)"
  using WF wfrec_fixpoint[of ?rS H] by simp
  thus ?thesis unfolding worec_def .
qed

subsection {* The notions of maximum, minimum, supremum, successor and order filter *}

text{*
We define the successor {\em of a set}, and not of an element (the latter is of course
a particular case).  Also, we define the maximum {\em of two elements}, @{text "max2"},
and the minimum {\em of a set}, @{text "minim"} -- we chose these variants since we
consider them the most useful for well-orders.  The minimum is defined in terms of the
auxiliary relational operator @{text "isMinim"}.  Then, supremum and successor are
defined in terms of minimum as expected.
The minimum is only meaningful for non-empty sets, and the successor is only
meaningful for sets for which strict upper bounds exist.
Order filters for well-orders are also known as ``initial segments". *}

definition max2 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
where "max2 a b \<equiv> if (a,b) \<in> r then b else a"

definition isMinim :: "'a set \<Rightarrow> 'a \<Rightarrow> bool"
where "isMinim A b \<equiv> b \<in> A \<and> (\<forall>a \<in> A. (b,a) \<in> r)"

definition minim :: "'a set \<Rightarrow> 'a"
where "minim A \<equiv> THE b. isMinim A b"

definition supr :: "'a set \<Rightarrow> 'a"
where "supr A \<equiv> minim (Above A)"

definition suc :: "'a set \<Rightarrow> 'a"
where "suc A \<equiv> minim (AboveS A)"

subsubsection {* Properties of max2 *}

lemma max2_greater_among:
assumes "a \<in> Field r" and "b \<in> Field r"
shows "(a, max2 a b) \<in> r \<and> (b, max2 a b) \<in> r \<and> max2 a b \<in> {a,b}"
proof-
  {assume "(a,b) \<in> r"
   hence ?thesis using max2_def assms REFL refl_on_def
   by (auto simp add: refl_on_def)
  }
  moreover
  {assume "a = b"
   hence "(a,b) \<in> r" using REFL  assms
   by (auto simp add: refl_on_def)
  }
  moreover
  {assume *: "a \<noteq> b \<and> (b,a) \<in> r"
   hence "(a,b) \<notin> r" using ANTISYM
   by (auto simp add: antisym_def)
   hence ?thesis using * max2_def assms REFL refl_on_def
   by (auto simp add: refl_on_def)
  }
  ultimately show ?thesis using assms TOTAL
  total_on_def[of "Field r" r] by blast
qed

lemma max2_greater:
assumes "a \<in> Field r" and "b \<in> Field r"
shows "(a, max2 a b) \<in> r \<and> (b, max2 a b) \<in> r"
using assms by (auto simp add: max2_greater_among)

lemma max2_among:
assumes "a \<in> Field r" and "b \<in> Field r"
shows "max2 a b \<in> {a, b}"
using assms max2_greater_among[of a b] by simp

lemma max2_equals1:
assumes "a \<in> Field r" and "b \<in> Field r"
shows "(max2 a b = a) = ((b,a) \<in> r)"
using assms ANTISYM unfolding antisym_def using TOTALS
by(auto simp add: max2_def max2_among)

lemma max2_equals2:
assumes "a \<in> Field r" and "b \<in> Field r"
shows "(max2 a b = b) = ((a,b) \<in> r)"
using assms ANTISYM unfolding antisym_def using TOTALS
unfolding max2_def by auto

subsubsection {* Existence and uniqueness for isMinim and well-definedness of minim *}

lemma isMinim_unique:
assumes MINIM: "isMinim B a" and MINIM': "isMinim B a'"
shows "a = a'"
proof-
  {have "a \<in> B"
   using MINIM isMinim_def by simp
   hence "(a',a) \<in> r"
   using MINIM' isMinim_def by simp
  }
  moreover
  {have "a' \<in> B"
   using MINIM' isMinim_def by simp
   hence "(a,a') \<in> r"
   using MINIM isMinim_def by simp
  }
  ultimately
  show ?thesis using ANTISYM antisym_def[of r] by blast
qed

lemma Well_order_isMinim_exists:
assumes SUB: "B \<le> Field r" and NE: "B \<noteq> {}"
shows "\<exists>b. isMinim B b"
proof-
  from spec[OF WF[unfolded wf_eq_minimal[of "r - Id"]], of B] NE obtain b where
  *: "b \<in> B \<and> (\<forall>b'. b' \<noteq> b \<and> (b',b) \<in> r \<longrightarrow> b' \<notin> B)" by auto
  show ?thesis
  proof(simp add: isMinim_def, rule exI[of _ b], auto)
    show "b \<in> B" using * by simp
  next
    fix b' assume As: "b' \<in> B"
    hence **: "b \<in> Field r \<and> b' \<in> Field r" using As SUB * by auto
    (*  *)
    from As  * have "b' = b \<or> (b',b) \<notin> r" by auto
    moreover
    {assume "b' = b"
     hence "(b,b') \<in> r"
     using ** REFL by (auto simp add: refl_on_def)
    }
    moreover
    {assume "b' \<noteq> b \<and> (b',b) \<notin> r"
     hence "(b,b') \<in> r"
     using ** TOTAL by (auto simp add: total_on_def)
    }
    ultimately show "(b,b') \<in> r" by blast
  qed
qed

lemma minim_isMinim:
assumes SUB: "B \<le> Field r" and NE: "B \<noteq> {}"
shows "isMinim B (minim B)"
proof-
  let ?phi = "(\<lambda> b. isMinim B b)"
  from assms Well_order_isMinim_exists
  obtain b where *: "?phi b" by blast
  moreover
  have "\<And> b'. ?phi b' \<Longrightarrow> b' = b"
  using isMinim_unique * by auto
  ultimately show ?thesis
  unfolding minim_def using theI[of ?phi b] by blast
qed

subsubsection{* Properties of minim *}

lemma minim_in:
assumes "B \<le> Field r" and "B \<noteq> {}"
shows "minim B \<in> B"
proof-
  from minim_isMinim[of B] assms
  have "isMinim B (minim B)" by simp
  thus ?thesis by (simp add: isMinim_def)
qed

lemma minim_inField:
assumes "B \<le> Field r" and "B \<noteq> {}"
shows "minim B \<in> Field r"
proof-
  have "minim B \<in> B" using assms by (simp add: minim_in)
  thus ?thesis using assms by blast
qed

lemma minim_least:
assumes  SUB: "B \<le> Field r" and IN: "b \<in> B"
shows "(minim B, b) \<in> r"
proof-
  from minim_isMinim[of B] assms
  have "isMinim B (minim B)" by auto
  thus ?thesis by (auto simp add: isMinim_def IN)
qed

lemma equals_minim:
assumes SUB: "B \<le> Field r" and IN: "a \<in> B" and
        LEAST: "\<And> b. b \<in> B \<Longrightarrow> (a,b) \<in> r"
shows "a = minim B"
proof-
  from minim_isMinim[of B] assms
  have "isMinim B (minim B)" by auto
  moreover have "isMinim B a" using IN LEAST isMinim_def by auto
  ultimately show ?thesis
  using isMinim_unique by auto
qed

subsubsection{* Properties of successor *}

lemma suc_AboveS:
assumes SUB: "B \<le> Field r" and ABOVES: "AboveS B \<noteq> {}"
shows "suc B \<in> AboveS B"
proof(unfold suc_def)
  have "AboveS B \<le> Field r"
  using AboveS_Field[of r] by auto
  thus "minim (AboveS B) \<in> AboveS B"
  using assms by (simp add: minim_in)
qed

lemma suc_greater:
assumes SUB: "B \<le> Field r" and ABOVES: "AboveS B \<noteq> {}" and
        IN: "b \<in> B"
shows "suc B \<noteq> b \<and> (b,suc B) \<in> r"
proof-
  from assms suc_AboveS
  have "suc B \<in> AboveS B" by simp
  with IN AboveS_def[of r] show ?thesis by simp
qed

lemma suc_least_AboveS:
assumes ABOVES: "a \<in> AboveS B"
shows "(suc B,a) \<in> r"
proof(unfold suc_def)
  have "AboveS B \<le> Field r"
  using AboveS_Field[of r] by auto
  thus "(minim (AboveS B),a) \<in> r"
  using assms minim_least by simp
qed

lemma suc_inField:
assumes "B \<le> Field r" and "AboveS B \<noteq> {}"
shows "suc B \<in> Field r"
proof-
  have "suc B \<in> AboveS B" using suc_AboveS assms by simp
  thus ?thesis
  using assms AboveS_Field[of r] by auto
qed

lemma equals_suc_AboveS:
assumes SUB: "B \<le> Field r" and ABV: "a \<in> AboveS B" and
        MINIM: "\<And> a'. a' \<in> AboveS B \<Longrightarrow> (a,a') \<in> r"
shows "a = suc B"
proof(unfold suc_def)
  have "AboveS B \<le> Field r"
  using AboveS_Field[of r B] by auto
  thus "a = minim (AboveS B)"
  using assms equals_minim
  by simp
qed

lemma suc_underS:
assumes IN: "a \<in> Field r"
shows "a = suc (underS a)"
proof-
  have "underS a \<le> Field r"
  using underS_Field[of r] by auto
  moreover
  have "a \<in> AboveS (underS a)"
  using in_AboveS_underS IN by fast
  moreover
  have "\<forall>a' \<in> AboveS (underS a). (a,a') \<in> r"
  proof(clarify)
    fix a'
    assume *: "a' \<in> AboveS (underS a)"
    hence **: "a' \<in> Field r"
    using AboveS_Field by fast
    {assume "(a,a') \<notin> r"
     hence "a' = a \<or> (a',a) \<in> r"
     using TOTAL IN ** by (auto simp add: total_on_def)
     moreover
     {assume "a' = a"
      hence "(a,a') \<in> r"
      using REFL IN ** by (auto simp add: refl_on_def)
     }
     moreover
     {assume "a' \<noteq> a \<and> (a',a) \<in> r"
      hence "a' \<in> underS a"
      unfolding underS_def by simp
      hence "a' \<notin> AboveS (underS a)"
      using AboveS_disjoint by fast
      with * have False by simp
     }
     ultimately have "(a,a') \<in> r" by blast
    }
    thus  "(a, a') \<in> r" by blast
  qed
  ultimately show ?thesis
  using equals_suc_AboveS by auto
qed

subsubsection {* Properties of order filters *}

lemma under_ofilter:
"ofilter (under a)"
proof(unfold ofilter_def under_def, auto simp add: Field_def)
  fix aa x
  assume "(aa,a) \<in> r" "(x,aa) \<in> r"
  thus "(x,a) \<in> r"
  using TRANS trans_def[of r] by blast
qed

lemma underS_ofilter:
"ofilter (underS a)"
proof(unfold ofilter_def underS_def under_def, auto simp add: Field_def)
  fix aa assume "(a, aa) \<in> r" "(aa, a) \<in> r" and DIFF: "aa \<noteq> a"
  thus False
  using ANTISYM antisym_def[of r] by blast
next
  fix aa x
  assume "(aa,a) \<in> r" "aa \<noteq> a" "(x,aa) \<in> r"
  thus "(x,a) \<in> r"
  using TRANS trans_def[of r] by blast
qed

lemma Field_ofilter:
"ofilter (Field r)"
by(unfold ofilter_def under_def, auto simp add: Field_def)

lemma ofilter_underS_Field:
"ofilter A = ((\<exists>a \<in> Field r. A = underS a) \<or> (A = Field r))"
proof
  assume "(\<exists>a\<in>Field r. A = underS a) \<or> A = Field r"
  thus "ofilter A"
  by (auto simp: underS_ofilter Field_ofilter)
next
  assume *: "ofilter A"
  let ?One = "(\<exists>a\<in>Field r. A = underS a)"
  let ?Two = "(A = Field r)"
  show "?One \<or> ?Two"
  proof(cases ?Two, simp)
    let ?B = "(Field r) - A"
    let ?a = "minim ?B"
    assume "A \<noteq> Field r"
    moreover have "A \<le> Field r" using * ofilter_def by simp
    ultimately have 1: "?B \<noteq> {}" by blast
    hence 2: "?a \<in> Field r" using minim_inField[of ?B] by blast
    have 3: "?a \<in> ?B" using minim_in[of ?B] 1 by blast
    hence 4: "?a \<notin> A" by blast
    have 5: "A \<le> Field r" using * ofilter_def by auto
    (*  *)
    moreover
    have "A = underS ?a"
    proof
      show "A \<le> underS ?a"
      proof(unfold underS_def, auto simp add: 4)
        fix x assume **: "x \<in> A"
        hence 11: "x \<in> Field r" using 5 by auto
        have 12: "x \<noteq> ?a" using 4 ** by auto
        have 13: "under x \<le> A" using * ofilter_def ** by auto
        {assume "(x,?a) \<notin> r"
         hence "(?a,x) \<in> r"
         using TOTAL total_on_def[of "Field r" r]
               2 4 11 12 by auto
         hence "?a \<in> under x" using under_def[of r] by auto
         hence "?a \<in> A" using ** 13 by blast
         with 4 have False by simp
        }
        thus "(x,?a) \<in> r" by blast
      qed
    next
      show "underS ?a \<le> A"
      proof(unfold underS_def, auto)
        fix x
        assume **: "x \<noteq> ?a" and ***: "(x,?a) \<in> r"
        hence 11: "x \<in> Field r" using Field_def by fastforce
         {assume "x \<notin> A"
          hence "x \<in> ?B" using 11 by auto
          hence "(?a,x) \<in> r" using 3 minim_least[of ?B x] by blast
          hence False
          using ANTISYM antisym_def[of r] ** *** by auto
         }
        thus "x \<in> A" by blast
      qed
    qed
    ultimately have ?One using 2 by blast
    thus ?thesis by simp
  qed
qed

lemma ofilter_UNION:
"(\<And> i. i \<in> I \<Longrightarrow> ofilter(A i)) \<Longrightarrow> ofilter (\<Union> i \<in> I. A i)"
unfolding ofilter_def by blast

lemma ofilter_under_UNION:
assumes "ofilter A"
shows "A = (\<Union> a \<in> A. under a)"
proof
  have "\<forall>a \<in> A. under a \<le> A"
  using assms ofilter_def by auto
  thus "(\<Union> a \<in> A. under a) \<le> A" by blast
next
  have "\<forall>a \<in> A. a \<in> under a"
  using REFL Refl_under_in[of r] assms ofilter_def[of A] by blast
  thus "A \<le> (\<Union> a \<in> A. under a)" by blast
qed

subsubsection{* Other properties *}

lemma ofilter_linord:
assumes OF1: "ofilter A" and OF2: "ofilter B"
shows "A \<le> B \<or> B \<le> A"
proof(cases "A = Field r")
  assume Case1: "A = Field r"
  hence "B \<le> A" using OF2 ofilter_def by auto
  thus ?thesis by simp
next
  assume Case2: "A \<noteq> Field r"
  with ofilter_underS_Field OF1 obtain a where
  1: "a \<in> Field r \<and> A = underS a" by auto
  show ?thesis
  proof(cases "B = Field r")
    assume Case21: "B = Field r"
    hence "A \<le> B" using OF1 ofilter_def by auto
    thus ?thesis by simp
  next
    assume Case22: "B \<noteq> Field r"
    with ofilter_underS_Field OF2 obtain b where
    2: "b \<in> Field r \<and> B = underS b" by auto
    have "a = b \<or> (a,b) \<in> r \<or> (b,a) \<in> r"
    using 1 2 TOTAL total_on_def[of _ r] by auto
    moreover
    {assume "a = b" with 1 2 have ?thesis by auto
    }
    moreover
    {assume "(a,b) \<in> r"
     with underS_incr[of r] TRANS ANTISYM 1 2
     have "A \<le> B" by auto
     hence ?thesis by auto
    }
    moreover
     {assume "(b,a) \<in> r"
     with underS_incr[of r] TRANS ANTISYM 1 2
     have "B \<le> A" by auto
     hence ?thesis by auto
    }
    ultimately show ?thesis by blast
  qed
qed

lemma ofilter_AboveS_Field:
assumes "ofilter A"
shows "A \<union> (AboveS A) = Field r"
proof
  show "A \<union> (AboveS A) \<le> Field r"
  using assms ofilter_def AboveS_Field[of r] by auto
next
  {fix x assume *: "x \<in> Field r" and **: "x \<notin> A"
   {fix y assume ***: "y \<in> A"
    with ** have 1: "y \<noteq> x" by auto
    {assume "(y,x) \<notin> r"
     moreover
     have "y \<in> Field r" using assms ofilter_def *** by auto
     ultimately have "(x,y) \<in> r"
     using 1 * TOTAL total_on_def[of _ r] by auto
     with *** assms ofilter_def under_def[of r] have "x \<in> A" by auto
     with ** have False by contradiction
    }
    hence "(y,x) \<in> r" by blast
    with 1 have "y \<noteq> x \<and> (y,x) \<in> r" by auto
   }
   with * have "x \<in> AboveS A" unfolding AboveS_def by auto
  }
  thus "Field r \<le> A \<union> (AboveS A)" by blast
qed

lemma suc_ofilter_in:
assumes OF: "ofilter A" and ABOVE_NE: "AboveS A \<noteq> {}" and
        REL: "(b,suc A) \<in> r" and DIFF: "b \<noteq> suc A"
shows "b \<in> A"
proof-
  have *: "suc A \<in> Field r \<and> b \<in> Field r"
  using WELL REL well_order_on_domain[of "Field r"] by auto
  {assume **: "b \<notin> A"
   hence "b \<in> AboveS A"
   using OF * ofilter_AboveS_Field by auto
   hence "(suc A, b) \<in> r"
   using suc_least_AboveS by auto
   hence False using REL DIFF ANTISYM *
   by (auto simp add: antisym_def)
  }
  thus ?thesis by blast
qed

end (* context wo_rel *)

end


(*  Title:       Binary Search Trees, Isar-Style
    Author:      Viktor Kuncak, MIT CSAIL, November 2003
    Maintainer:  Larry Paulson <Larry.Paulson at cl.cam.ac.uk>
    License:     LGPL
*)

header {* Mostly Isar-style Reasoning for Binary Tree Operations *}
theory BinaryTree_Map imports BinaryTree begin

text {* We prove correctness of map operations
 implemented using binary search trees from BinaryTree.

 This document is LGPL.

 Author: Viktor Kuncak, MIT CSAIL, November 2003 *}

(*============================================================*)
section {* Map implementation and an abstraction function *}
(*============================================================*)

type_synonym
  'a tarray = "(index * 'a) Tree"

definition valid_tmap :: "'a tarray => bool" where
  "valid_tmap t == sortedTree fst t"

declare valid_tmap_def [simp]

definition mapOf :: "'a tarray => index => 'a option" where
  -- {* the abstraction function from trees to maps *}
  "mapOf t i ==
   (case (tlookup fst i t) of
     None => None
   | Some ia => Some (snd ia))"

(*============================================================*)
section {* Auxiliary Properties of our Implementation *}
(*============================================================*)

lemma mapOf_lookup1: "tlookup fst i t = None ==> mapOf t i = None"
by (simp add: mapOf_def)

lemma mapOf_lookup2: "tlookup fst i t = Some (j,a) ==> mapOf t i = Some a"
by (simp add: mapOf_def)

lemma assumes h: "mapOf t i = None"
      shows mapOf_lookup3: "tlookup fst i t = None"
proof (cases "tlookup fst i t")
case None from this show ?thesis by assumption
next case (Some ia) note tsome = this
  from this have o1: "tlookup fst i t = Some (fst ia, snd ia)" by simp
  have "mapOf t i = Some (snd ia)"
  by (insert mapOf_lookup2 [of i t "fst ia" "snd ia"], simp add: o1)
  from this have "mapOf t i ~= None" by simp
  from this h show ?thesis by simp -- {* contradiction *}
qed

lemma assumes v: "valid_tmap t"
      assumes h: "mapOf t i = Some a"
      shows mapOf_lookup4: "tlookup fst i t = Some (i,a)"
proof (cases "tlookup fst i t")
case None
  from this mapOf_lookup1 have "mapOf t i = None" by auto
  from this h show ?thesis by simp -- {* contradiction *}
next case (Some ia) note tsome = this
  have tlookup_some_inst: "sortedTree fst t & (tlookup fst i t = Some ia) -->
        ia : setOf t & fst ia = i" by (simp add: tlookup_some)
  from tlookup_some_inst tsome v have "ia : setOf t" by simp
  from tsome have "mapOf t i = Some (snd ia)" by (simp add: mapOf_def)
  from this h have o1: "snd ia = a" by simp
  from tlookup_some_inst tsome v have o2: "fst ia = i" by simp
  from o1 o2 have "ia = (i,a)" by auto
  from this tsome show "tlookup fst i t = Some (i, a)" by simp
qed

subsection {* Lemmas @{text mapset_none} and @{text mapset_some} establish
              a relation between the set and map abstraction of the tree *}

lemma assumes v: "valid_tmap t"
      shows mapset_none: "(mapOf t i = None) = (ALL a. (i,a) ~: setOf t)"
proof
  -- {* ==> *}
  assume mapNone: "mapOf t i = None"
  from v mapNone mapOf_lookup3 have lnone: "tlookup fst i t = None" by auto
  show "ALL a. (i,a) ~: setOf t"
  proof
    fix a
    show "(i,a) ~: setOf t"
    proof
      assume iain: "(i,a) : setOf t"
      have tlookup_none_inst:
      "sortedTree fst t & (tlookup fst i t = None) --> (ALL x:setOf t. fst x ~= i)"
      by (insert tlookup_none [of "fst" "t" "i"], assumption)
      from v lnone tlookup_none_inst have "ALL x : setOf t. fst x ~= i" by simp
      from this iain have "fst (i,a) ~= i" by fastforce
      from this show False by simp
    qed
  qed
  -- {* <== *}
  next assume h: "ALL a. (i,a) ~: setOf t"
  show "mapOf t i = None"
  proof (cases "mapOf t i")
  case None then show ?thesis .
  next case (Some a) note mapsome = this
    from v mapsome have o1: "tlookup fst i t = Some (i,a)" by (simp add: mapOf_lookup4)
    (* moving mapOf_lookup4 to assumption does not work, although it uses
       no == !! *)
    from tlookup_some have tlookup_some_inst:
    "sortedTree fst t & tlookup fst i t = Some (i,a) -->
     (i,a) : setOf t & fst (i,a) = i"
    by (insert tlookup_some [of fst t i "(i,a)"], assumption)
    from v o1 this have "(i,a) : setOf t" by simp
    from this h show ?thesis by auto -- {* contradiction *}
  qed
qed

lemma assumes v: "valid_tmap t"
      shows mapset_some: "(mapOf t i = Some a) = ((i,a) : setOf t)"
proof
  -- {* ==> *}
  assume mapsome: "mapOf t i = Some a"
  from v mapsome have o1: "tlookup fst i t = Some (i,a)" by (simp add: mapOf_lookup4)
  from tlookup_some have tlookup_some_inst:
  "sortedTree fst t & tlookup fst i t = Some (i,a) -->
   (i,a) : setOf t & fst (i,a) = i"
  by (insert tlookup_some [of fst t i "(i,a)"], assumption)
  from v o1 this show "(i,a) : setOf t" by simp
  -- {* <== *}
  next assume iain: "(i,a) : setOf t"
  from v iain tlookup_finds have "tlookup fst (fst (i,a)) t = Some (i,a)" by fastforce
  from this have "tlookup fst i t = Some (i,a)" by simp
  from this show "mapOf t i = Some a" by (simp add: mapOf_def)
qed

(*============================================================*)
section {* Empty Map *}
(*============================================================*)

lemma mnew_spec_valid: "valid_tmap Tip"
by (simp add: mapOf_def)

lemma mtip_spec_empty: "mapOf Tip k = None"
by (simp add: mapOf_def)

(*============================================================*)
section {* Map Update Operation *}
(*============================================================*)

definition mupdate :: "index => 'a => 'a tarray => 'a tarray" where
  "mupdate i a t == binsert fst (i,a) t"

lemma assumes v: "valid_tmap t"
      shows mupdate_map: "mapOf (mupdate i a t) = (mapOf t)(i |-> a)"
proof
  fix i2
  let ?tr = "binsert fst (i,a) t"
  have upres: "mupdate i a t = ?tr" by (simp add: mupdate_def)
  from v binsert_set
  have setSpec: "setOf ?tr = setOf t - eqs fst (i,a) Un {(i,a)}" by fastforce
  from v binsert_sorted have vr: "valid_tmap ?tr" by fastforce
  show "mapOf (mupdate i a t) i2 = ((mapOf t)(i |-> a)) i2"
  proof (cases "i = i2")
  case True note i2ei = this
    from i2ei have rhs_res: "((mapOf t)(i |-> a)) i2 = Some a" by simp
    have lhs_res: "mapOf (mupdate i a t) i = Some a"
    proof -
      have will_find: "tlookup fst i ?tr = Some (i,a)"
      proof -
        from setSpec have kvin: "(i,a) : setOf ?tr" by simp
        have binsert_sorted_inst: "sortedTree fst t -->
                                 sortedTree fst ?tr"
        by (insert binsert_sorted [of "fst" "t" "(i,a)"], assumption)
        from v binsert_sorted_inst have rs: "sortedTree fst ?tr" by simp
        have tlookup_finds_inst: "sortedTree fst ?tr & (i,a) : setOf ?tr -->
                                  tlookup fst i ?tr = Some (i,a)"
        by (insert tlookup_finds [of "fst" "?tr" "(i,a)"], simp)
        from rs kvin tlookup_finds_inst show ?thesis by simp
      qed
      from upres will_find show ?thesis by (simp add: mapOf_def)
    qed
    from lhs_res rhs_res i2ei show ?thesis by simp
  next case False note i2nei = this
    from i2nei have rhs_res: "((mapOf t)(i |-> a)) i2 = mapOf t i2" by auto
    have lhs_res: "mapOf (mupdate i a t) i2 = mapOf t i2"
    proof (cases "mapOf t i2")
    case None from this have mapNone: "mapOf t i2 = None" by simp
      from v mapNone mapset_none have i2nin: "ALL a. (i2,a) ~: setOf t" by fastforce
      have noneIn: "ALL b. (i2,b) ~: setOf ?tr"
      proof
        fix b
        from v binsert_set
        have "setOf ?tr = setOf t - eqs fst (i,a) Un {(i,a)}"
        by fastforce
        from this i2nei i2nin show "(i2,b) ~: setOf ?tr" by fastforce
      qed
      have mapset_none_inst:
      "valid_tmap ?tr --> (mapOf ?tr i2 = None) = (ALL a. (i2, a) ~: setOf ?tr)"
      by (insert mapset_none [of "?tr" i2], simp)
      from vr noneIn mapset_none_inst have "mapOf ?tr i2 = None" by fastforce
      from this upres mapNone show ?thesis by simp
    next case (Some z) from this have mapSome: "mapOf t i2 = Some z" by simp
      from v mapSome mapset_some have "(i2,z) : setOf t" by fastforce
      from this setSpec i2nei have "(i2,z) : setOf ?tr" by (simp add: eqs_def)
      from this vr mapset_some have "mapOf ?tr i2 = Some z" by fastforce
      from this upres mapSome show ?thesis by simp
    qed
    from lhs_res rhs_res show ?thesis by simp
  qed
qed

lemma assumes v: "valid_tmap t"
      shows mupdate_valid: "valid_tmap (mupdate i a t)"
proof -
  let ?tr = "binsert fst (i,a) t"
  have upres: "mupdate i a t = ?tr" by (simp add: mupdate_def)
  from v binsert_sorted have vr: "valid_tmap ?tr" by fastforce
  from vr upres show ?thesis by simp
qed

(*============================================================*)
section {* Map Remove Operation *}
(*============================================================*)

definition mremove :: "index => 'a tarray => 'a tarray" where
  "mremove i t == remove fst (i, undefined) t"

lemma assumes v: "valid_tmap t"
      shows mremove_valid: "valid_tmap (mremove i t)"
proof (simp add: mremove_def)
  from v remove_sort
  show "sortedTree fst (remove fst (i, undefined) t)" by fastforce
qed

lemma assumes v: "valid_tmap t"
      shows mremove_map: "mapOf (mremove i t) i = None"
proof (simp add: mremove_def)
  let ?tr = "remove fst (i, undefined) t"
  show "mapOf ?tr i = None"
  proof -
    from v remove_spec
    have remSet: "setOf ?tr = setOf t - eqs fst (i, undefined)"
    by fastforce
    have noneIn: "ALL a. (i,a) ~: setOf ?tr"
    proof
      fix a
      from remSet show "(i,a) ~: setOf ?tr" by (simp add: eqs_def)
    qed
    from v remove_sort have vr: "valid_tmap ?tr" by fastforce
    have mapset_none_inst: "valid_tmap ?tr ==>
    (mapOf ?tr i = None) = (ALL a. (i,a) ~: setOf ?tr)"
    by (insert mapset_none [of "?tr" "i"], simp)
    from vr this have "(mapOf ?tr i = None) = (ALL a. (i,a) ~: setOf ?tr)" by fastforce
    from this noneIn show "mapOf ?tr i = None" by simp
  qed
qed

end


(*  Title:       Infinite (Non-Well-Founded) Chains
    Author:      Jasmin Blanchette <jasmin.blanchette at inria.fr>, 2016
    Maintainer:  Jasmin Blanchette <jasmin.blanchette at inria.fr>
*)

section \<open>Infinite (Non-Well-Founded) Chains\<close>

theory Infinite_Chain
imports Lambda_Free_Util
begin

text \<open>
This theory defines the concept of a minimal bad (or non-well-founded)
infinite chain, as found in the term rewriting literature to prove the
well-foundedness of syntactic term orders.
\<close>

context
  fixes p :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

definition inf_chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
  "inf_chain f \<longleftrightarrow> (\<forall>i. p (f i) (f (Suc i)))"

lemma wfP_iff_no_inf_chain: "wfP (\<lambda>x y. p y x) \<longleftrightarrow> (\<nexists>f. inf_chain f)"
  unfolding wfP_def wf_iff_no_infinite_down_chain inf_chain_def by simp

lemma inf_chain_offset: "inf_chain f \<Longrightarrow> inf_chain (\<lambda>j. f (j + i))"
  unfolding inf_chain_def by simp

definition bad :: "'a \<Rightarrow> bool" where
  "bad x \<longleftrightarrow> (\<exists>f. inf_chain f \<and> f 0 = x)"

lemma inf_chain_bad:
  assumes bad_f: "inf_chain f"
  shows "bad (f i)"
  unfolding bad_def by (rule exI[of _ "\<lambda>j. f (j + i)"]) (simp add: inf_chain_offset[OF bad_f])

context
  fixes gt :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  assumes wf: "wf {(x, y). gt y x}"
begin

primrec worst_chain :: "nat \<Rightarrow> 'a" where
  "worst_chain 0 = (SOME x. bad x \<and> (\<forall>y. bad y \<longrightarrow> \<not> gt x y))"
| "worst_chain (Suc i) = (SOME x. bad x \<and> p (worst_chain i) x \<and>
     (\<forall>y. bad y \<and> p (worst_chain i) y \<longrightarrow> \<not> gt x y))"

declare worst_chain.simps[simp del]

context
  fixes x :: 'a
  assumes x_bad: "bad x"
begin

lemma
  bad_worst_chain_0: "bad (worst_chain 0)" and
  min_worst_chain_0: "\<not> gt (worst_chain 0) x"
proof -
  obtain y where "bad y \<and> (\<forall>z. bad z \<longrightarrow> \<not> gt y z)"
    using wf_exists_minimal[OF wf, of bad, OF x_bad] by force
  hence "bad (worst_chain 0) \<and> (\<forall>z. bad z \<longrightarrow> \<not> gt (worst_chain 0) z)"
    unfolding worst_chain.simps by (rule someI)
  thus "bad (worst_chain 0)" and "\<not> gt (worst_chain 0) x"
    using x_bad by blast+
qed

lemma
  bad_worst_chain_Suc: "bad (worst_chain (Suc i))" and
  worst_chain_pred: "p (worst_chain i) (worst_chain (Suc i))" and
  min_worst_chain_Suc: "p (worst_chain i) x \<Longrightarrow> \<not> gt (worst_chain (Suc i)) x"
proof (induct i rule: less_induct)
  case (less i)

  have "bad (worst_chain i)"
  proof (cases i)
    case 0
    thus ?thesis
      using bad_worst_chain_0 by simp
  next
    case (Suc j)
    thus ?thesis
      using less(1) by blast
  qed
  then obtain fa where fa_bad: "inf_chain fa" and fa_0: "fa 0 = worst_chain i"
    unfolding bad_def by blast

  have "\<exists>s0. bad s0 \<and> p (worst_chain i) s0"
  proof (intro exI conjI)
    let ?y0 = "fa (Suc 0)"

    show "bad ?y0"
      unfolding bad_def by (auto intro: exI[of _ "\<lambda>i. fa (Suc i)"] inf_chain_offset[OF fa_bad])
    show "p (worst_chain i) ?y0"
      using fa_bad[unfolded inf_chain_def] fa_0 by metis
  qed
  then obtain y0 where y0: "bad y0 \<and> p (worst_chain i) y0"
    by blast

  obtain y1 where
    y1: "bad y1 \<and> p (worst_chain i) y1 \<and> (\<forall>z. bad z \<and> p (worst_chain i) z \<longrightarrow> \<not> gt y1 z)"
    using wf_exists_minimal[OF wf, of "\<lambda>y. bad y \<and> p (worst_chain i) y", OF y0] by force

  let ?y = "worst_chain (Suc i)"

  have conj: "bad ?y \<and> p (worst_chain i) ?y \<and> (\<forall>z. bad z \<and> p (worst_chain i) z \<longrightarrow> \<not> gt ?y z)"
    unfolding worst_chain.simps using y1 by (rule someI)

  show "bad ?y"
    by (rule conj[THEN conjunct1])
  show "p (worst_chain i) ?y"
    by (rule conj[THEN conjunct2, THEN conjunct1])
  show "p (worst_chain i) x \<Longrightarrow> \<not> gt ?y x"
    using x_bad conj[THEN conjunct2, THEN conjunct2, rule_format] by meson
qed

lemma bad_worst_chain: "bad (worst_chain i)"
  by (cases i) (auto intro: bad_worst_chain_0 bad_worst_chain_Suc)

lemma worst_chain_bad: "inf_chain worst_chain"
  unfolding inf_chain_def using worst_chain_pred by metis

end

context
  fixes x :: 'a
  assumes
    x_bad: "bad x" and
    p_trans: "\<And>z y x. p z y \<Longrightarrow> p y x \<Longrightarrow> p z x"
begin

lemma worst_chain_not_gt: "\<not> gt (worst_chain i) (worst_chain (Suc i))" for i
proof (cases i)
  case 0
  show ?thesis
    unfolding 0 by (rule min_worst_chain_0[OF inf_chain_bad[OF worst_chain_bad[OF x_bad]]])
next
  case Suc
  show ?thesis
    unfolding Suc
  by (rule min_worst_chain_Suc[OF inf_chain_bad[OF worst_chain_bad[OF x_bad]]])
    (rule p_trans[OF worst_chain_pred[OF x_bad] worst_chain_pred[OF x_bad]])
qed

end

end

end

lemma inf_chain_subset: "inf_chain p f \<Longrightarrow> p \<le> q \<Longrightarrow> inf_chain q f"
  unfolding inf_chain_def by blast

hide_fact (open) bad_worst_chain_0 bad_worst_chain_Suc

end


section \<open>Linear Combinations\<close>

theory LinearCombinations
imports Main
  "HOL-Algebra.Module"
  "HOL-Algebra.Coset"
  RingModuleFacts
  MonoidSums
  FunctionLemmas
begin

subsection \<open>Lemmas for simplification\<close>
text \<open>The following are helpful in certain simplifications (esp. congruence rules). Warning: arbitrary
use leads to looping.\<close>
lemma (in ring) coeff_in_ring:
  "\<lbrakk>a\<in>A\<rightarrow>carrier R; x\<in>A\<rbrakk> \<Longrightarrow> a x \<in>carrier R"
by (rule Pi_mem)

lemma (in ring) coeff_in_ring2:
  "\<lbrakk> x\<in>A;a\<in>A\<rightarrow>carrier R\<rbrakk> \<Longrightarrow> a x \<in>carrier R"
by (metis Pi_mem)

lemma ring_subset_carrier:
  "\<lbrakk>x \<in>A; A\<subseteq>carrier R\<rbrakk> \<Longrightarrow> x \<in>carrier R"
by auto

lemma disj_if:
  "\<lbrakk>A\<inter>B={}; x\<in> B\<rbrakk> \<Longrightarrow> (if x\<in>A then f x else g x) = g x"
by auto

lemmas (in module) sum_simp = ring_subset_carrier

subsection \<open>Linear combinations\<close>
text \<open>A linear combination is $\sum_{v\in A} a_v v$. $(a_v)_{v\in S}$ is a function
$A\to K$, where $A\subseteq K$.\<close>
definition (in module) lincomb::"['c \<Rightarrow> 'a, 'c set]\<Rightarrow> 'c"
where "lincomb a A = (\<Oplus>\<^bsub>M\<^esub>  v\<in>A. (a v \<odot>\<^bsub>M\<^esub> v))"

lemma (in module) summands_valid:
  fixes A a
  assumes h2: "A\<subseteq> carrier M" and h3: "a\<in>(A\<rightarrow>carrier R)"
  shows "\<forall> v\<in> A. (((a v) \<odot>\<^bsub>M\<^esub> v)\<in> carrier M)"
proof -
  from assms show ?thesis by auto
qed

lemma (in module) lincomb_closed [simp, intro]:
  fixes S a
  assumes h2: "S\<subseteq> carrier M" and h3: "a\<in>(S\<rightarrow>carrier R)"
  shows "lincomb a S \<in> carrier M"
proof -
  from h2 h3 show ?thesis by (unfold lincomb_def, auto intro:finsum_closed)
(*doesn't work with simp*)
qed

lemma (in comm_monoid) finprod_cong2:
  "[| A = B;
      !!i. i \<in> B ==> f i = g i; f \<in> B \<rightarrow> carrier G|] ==>
finprod G f A = finprod G g B"
by (intro finprod_cong, auto)

lemmas (in abelian_monoid) finsum_cong2 = add.finprod_cong2

lemma (in module) lincomb_cong:
  assumes h2: "A=B" and h3: "A \<subseteq> carrier M"
    and h4: "\<And>v. v\<in>A \<Longrightarrow> a v = b v" and h5: "b\<in> B\<rightarrow>carrier R"
  shows "lincomb a A = lincomb b B"
using assms
    by (simp cong: finsum_cong2 add: lincomb_def summands_valid ring_subset_carrier)

lemma (in module) lincomb_union:
  fixes a A B
  assumes h1: "finite (A\<union> B)"  and h3: "A\<union>B \<subseteq> carrier M"
    and h4: "A\<inter>B={}" and h5: "a\<in>(A\<union>B\<rightarrow>carrier R)"
  shows "lincomb a (A\<union>B) = lincomb a A \<oplus>\<^bsub>M\<^esub> lincomb a B"
using assms
  by (auto cong: finsum_cong2 simp add: lincomb_def finsum_Un_disjoint summands_valid ring_subset_carrier)

text \<open>This is useful as a simp rule sometimes, for combining linear combinations.\<close>
lemma (in module) lincomb_union2:
  fixes a b A B
  assumes h1: "finite (A\<union> B)"  and h3: "A\<union>B \<subseteq> carrier M"
    and h4: "A\<inter>B={}" and h5: "a\<in>A\<rightarrow>carrier R" and h6: "b\<in>B\<rightarrow>carrier R"
  shows "lincomb a A \<oplus>\<^bsub>M\<^esub> lincomb b B = lincomb (\<lambda>v. if (v\<in>A) then a v else b v) (A\<union>B)"
    (is "lincomb a A \<oplus>\<^bsub>M\<^esub> lincomb b B = lincomb ?c (A\<union>B)")
using assms
  by (auto cong: finsum_cong2
        simp add: lincomb_def finsum_Un_disjoint summands_valid ring_subset_carrier disj_if)

lemma (in module) lincomb_del2:
  fixes S a v
  assumes h1: "finite S" and h2: "S\<subseteq> carrier M" and h3: "a\<in>(S\<rightarrow>carrier R)" and h4:"v\<in>S"
  shows "lincomb a S = ((a v) \<odot>\<^bsub>M\<^esub> v) \<oplus>\<^bsub>M\<^esub> lincomb a (S-{v})"
proof -
  from h4 have 1: "S={v}\<union>(S-{v})" by (metis insert_Diff insert_is_Un)
  from assms show ?thesis
    apply (subst 1)
    apply (subst lincomb_union, auto)
    by (unfold lincomb_def, auto simp add: coeff_in_ring)
qed

(*alternate form of the above*)
lemma (in module) lincomb_insert:
  fixes S a v
  assumes h1: "finite S" and h2: "S\<subseteq> carrier M" and h3: "a\<in>(S\<union>{v}\<rightarrow>carrier R)" and h4:"v\<notin>S" and
h5:"v\<in> carrier M"
  shows "lincomb a (S\<union>{v}) = ((a v) \<odot>\<^bsub>M\<^esub> v) \<oplus>\<^bsub>M\<^esub> lincomb a S"
using assms
  by (auto cong: finsum_cong2
        simp add: lincomb_def finsum_Un_disjoint summands_valid ring_subset_carrier disj_if)

lemma (in module) lincomb_elim_if [simp]:
  fixes b c S
  assumes h1: "S \<subseteq> carrier M" and h2: "\<And>v. v\<in>S\<Longrightarrow> \<not>P v" and h3: "c\<in>S\<rightarrow>carrier R"
  shows "lincomb (\<lambda>w. if P w then b w else c w) S = lincomb c S"
using assms
  by (auto cong: finsum_cong2
        simp add: lincomb_def finsum_Un_disjoint summands_valid ring_subset_carrier disj_if)

lemma (in module) lincomb_smult:
  fixes A c
  assumes h2: "A\<subseteq>carrier M"  and h3: "a\<in>A\<rightarrow>carrier R" and h4: "c\<in>carrier R"
  shows "lincomb (\<lambda>w. c\<otimes>\<^bsub>R\<^esub> a w) A = c\<odot>\<^bsub>M\<^esub> (lincomb a A)"
using assms
  by (auto cong: finsum_cong2
        simp add: lincomb_def finsum_Un_disjoint finsum_smult ring_subset_carrier disj_if smult_assoc1 coeff_in_ring)

subsection \<open>Linear dependence and independence.\<close>
text \<open>A set $S$ in a module/vectorspace is linearly dependent if there is a finite set $A \subseteq S$
 and coefficients $(a_v)_{v\in A}$ such that $sum_{v\in A} a_vv=0$ and for some $v$, $a_v\neq 0$.\<close>
definition (in module) lin_dep where
  "lin_dep S = (\<exists>A a v. (finite A \<and> A\<subseteq>S \<and> (a\<in> (A\<rightarrow>carrier R)) \<and> (lincomb a A = \<zero>\<^bsub>M\<^esub>) \<and> (v\<in>A) \<and> (a v\<noteq> \<zero>\<^bsub>R\<^esub>)))"
  (*shows "\<exists>a. (a\<in> (S\<rightarrow>carrier K)) \<and> (lincomb a S = \<zero>\<^bsub>V\<^esub>) \<and> (\<exists>v\<in>S. a v\<noteq> \<zero>\<^bsub>K\<^esub>)"*)

abbreviation (in module) lin_indpt::"'c set \<Rightarrow> bool"
  where "lin_indpt S \<equiv> \<not>lin_dep S"

text \<open>In the finite case, we can take $A=S$. This may be more convenient (e.g., when adding two
linear combinations.\<close>
lemma (in module) finite_lin_dep:
  fixes S
  assumes finS:"finite S" and ld: "lin_dep S" and inC: "S\<subseteq>carrier M"
  shows "\<exists>a v. (a\<in> (S\<rightarrow>carrier R)) \<and> (lincomb a S = \<zero>\<^bsub>M\<^esub>) \<and> (v\<in>S) \<and> (a v\<noteq> \<zero>\<^bsub>R\<^esub>)"
proof -
  from ld obtain A a v where A: "(A\<subseteq>S \<and> (a\<in> (A\<rightarrow>carrier R)) \<and> (lincomb a A = \<zero>\<^bsub>M\<^esub>) \<and> (v\<in>A) \<and> (a v\<noteq> \<zero>\<^bsub>R\<^esub>))"
    by (unfold lin_dep_def, auto)
  let ?b="\<lambda>w. if w\<in>A then a w else \<zero>\<^bsub>R\<^esub>" (*extend the coefficients to be 0 outside of A*)
  from finS inC A have if_in: "(\<Oplus>\<^bsub>M\<^esub>v\<in>S. (if v \<in> A then a v else \<zero>) \<odot>\<^bsub>M\<^esub> v) = (\<Oplus>\<^bsub>M\<^esub>v\<in>S. (if v \<in> A then a v \<odot>\<^bsub>M\<^esub> v else \<zero>\<^bsub>M\<^esub>))"
    apply auto
      apply (intro finsum_cong')
    by (auto simp add: coeff_in_ring)  (*massage the sum*)
  from finS inC A have b: "lincomb ?b S = \<zero>\<^bsub>M\<^esub>"
    apply (unfold lincomb_def)
    apply (subst if_in)
    by (subst extend_sum, auto)
  from A b show ?thesis
    apply (rule_tac x="?b" in exI)
    apply (rule_tac x="v" in exI)
    by auto
qed

text \<open>Criteria of linear dependency in a easy format to apply: apply (rule lin-dep-crit)\<close>
lemma (in module) lin_dep_crit:
  fixes A S a v
  assumes fin: "finite A" and subset: "A\<subseteq>S" and h1: "(a\<in> (A\<rightarrow>carrier R))" and h2: "v\<in> A"
    and h3:"a v\<noteq> \<zero>\<^bsub>R\<^esub>" and h4: "(lincomb a A = \<zero>\<^bsub>M\<^esub>)"
  shows "lin_dep S"
proof -
  from assms show ?thesis
    by (unfold lin_dep_def, auto)
qed

text \<open>If $\sum_{v\in A} a_vv=0$ implies $a_v=0$ for all $v\in S$, then $A$ is linearly independent.\<close>
lemma (in module) finite_lin_indpt2:
  fixes A
  assumes A_fin: "finite A" and AinC: "A\<subseteq>carrier M" and
    lc0: "\<And>a. a\<in> (A\<rightarrow>carrier R) \<Longrightarrow> (lincomb a A = \<zero>\<^bsub>M\<^esub>) \<Longrightarrow> (\<forall> v\<in>A. a v= \<zero>\<^bsub>R\<^esub>)"
  shows "lin_indpt A"
proof (rule ccontr)
  assume "\<not>lin_indpt A"
  from A_fin AinC this obtain a v where av:
    "(a\<in> (A\<rightarrow>carrier R)) \<and> (lincomb a A = \<zero>\<^bsub>M\<^esub>) \<and> (v\<in>A) \<and> (a v\<noteq> \<zero>\<^bsub>R\<^esub>)"
    by (metis finite_lin_dep)
  from av lc0 show False by auto
qed

text \<open>Any set containing 0 is linearly dependent.\<close>
lemma (in module) zero_lin_dep:
  assumes 0: "\<zero>\<^bsub>M\<^esub> \<in> S" and nonzero: "carrier R \<noteq> {\<zero>\<^bsub>R\<^esub>}"
  shows "lin_dep S"
proof -
  from nonzero have zero_not_one: "\<zero>\<^bsub>R\<^esub> \<noteq> \<one>\<^bsub>R\<^esub>" by (rule nontrivial_ring)
  from 0 zero_not_one show ?thesis
    apply (unfold lin_dep_def)
    apply (rule_tac x="{\<zero>\<^bsub>M\<^esub>}" in exI)
    apply (rule_tac x="(\<lambda>v. \<one>\<^bsub>R\<^esub>)" in exI)
    apply (rule_tac x="\<zero>\<^bsub>M\<^esub>" in exI)
    by (unfold lincomb_def, auto)
qed

lemma (in module) zero_nin_lin_indpt:
  assumes h2: "S\<subseteq>carrier M" and li: "\<not>(lin_dep S)" and nonzero: "carrier R \<noteq> {\<zero>\<^bsub>R\<^esub>}"
  shows "\<zero>\<^bsub>M\<^esub> \<notin> S"
proof (rule ccontr)
  assume a1: "\<not>(\<zero>\<^bsub>M\<^esub> \<notin> S)"
  from a1 have a2: "\<zero>\<^bsub>M\<^esub> \<in> S" by auto
  from a2 nonzero have ld: "lin_dep S" by (rule zero_lin_dep)
  from li ld show False by auto
qed

text \<open>The \<open>span\<close> of $S$ is the set of linear combinations with $A \subseteq S$.\<close>
definition (in module) span::"'c set \<Rightarrow>'c set"
  where "span S = {lincomb a A | a A. finite A \<and> A\<subseteq>S \<and> a\<in> (A\<rightarrow>carrier R)}"

text \<open>The \<open>span\<close> interpreted as a module or vectorspace.\<close>
abbreviation (in module) span_vs::"'c set \<Rightarrow> ('a,'c,'d) module_scheme"
  where "span_vs S \<equiv> M \<lparr>carrier := span S\<rparr>"

text \<open>In the finite case, we can take $A=S$ without loss of generality.\<close>
lemma (in module) finite_span:
  assumes fin: "finite S" and inC: "S\<subseteq>carrier M"
  shows "span S = {lincomb a S | a. a\<in> (S\<rightarrow>carrier R)}"
proof (rule equalityI)
  {
    fix A a
    assume subset: "A \<subseteq> S" and   a: "a \<in> A \<rightarrow> carrier R"
    let ?b="(\<lambda>v. if v \<in> A then a v else \<zero>)"
    from fin inC subset a have if_in: "(\<Oplus>\<^bsub>M\<^esub>v\<in>S. ?b v \<odot>\<^bsub>M\<^esub> v) = (\<Oplus>\<^bsub>M\<^esub>v\<in>S. (if v \<in> A then a v \<odot>\<^bsub>M\<^esub> v else \<zero>\<^bsub>M\<^esub>))"
      apply (intro finsum_cong')
        by (auto simp add: coeff_in_ring)  (*massage the sum*)
    from fin inC subset a have "\<exists>b. lincomb a A = lincomb b S \<and> b \<in> S \<rightarrow> carrier R"
      apply (rule_tac x="?b" in exI)
      apply (unfold lincomb_def, auto)
      apply (subst if_in)
      by (subst extend_sum, auto)
  }
  from this show "span S \<subseteq> {lincomb a S |a. a \<in> S \<rightarrow> carrier R}"
    by (unfold span_def, auto)
next
  from fin show "{lincomb a S |a. a \<in> S \<rightarrow> carrier R} \<subseteq> span S"
    by (unfold span_def, auto)
qed

text \<open>If $v\in \text{span S}$, then we can find a linear combination. This is in an easy to apply
format (e.g. obtain a A where\ldots)\<close>
lemma (in module) in_span:
  fixes S v
  assumes  h2: "S\<subseteq>carrier V" and h3: "v\<in>span S"
  shows "\<exists>a A. (A\<subseteq>S \<and> (a\<in>A\<rightarrow>carrier R) \<and> (lincomb a A=v))"
proof -
  from h2 h3 show ?thesis
    apply (unfold span_def)
    by auto
qed

text \<open>In the finite case, we can take $A=S$.\<close>
lemma (in module) finite_in_span:
  fixes S v
  assumes fin: "finite S" and h2: "S\<subseteq>carrier M" and h3: "v\<in>span S"
  shows "\<exists>a. (a\<in>S\<rightarrow>carrier R) \<and> (lincomb a S=v)"
proof -
  from fin h2 have fin_span: "span S = {lincomb a S |a. a \<in> S \<rightarrow> carrier R}" by (rule finite_span)
  from h3 fin_span show ?thesis by auto
qed

text \<open>If a subset is linearly independent, then any linear combination that is 0 must have a
nonzero coefficient outside that set.\<close>
lemma (in module) lincomb_must_include:
  fixes A S T b v
  assumes  inC: "T\<subseteq>carrier M" and li: "lin_indpt S" and Ssub: "S\<subseteq>T" and Ssub: "A\<subseteq>T"
    and fin: "finite A"
    and b: "b\<in>A\<rightarrow>carrier R" and lc: "lincomb b A=\<zero>\<^bsub>M\<^esub>" and v_in: "v\<in>A"
    and nz_coeff: "b v\<noteq>\<zero>\<^bsub>R\<^esub>"
  shows "\<exists>w\<in>A-S. b w\<noteq>\<zero>\<^bsub>R\<^esub>"
proof (rule ccontr)
  (*we may assume B doesn't intersect A.*)
  assume 0: "\<not>(\<exists> w\<in>A-S. b w\<noteq>\<zero>\<^bsub>R\<^esub>)"
  from 0 have 1: "\<And>w. w\<in>A-S\<Longrightarrow> b w=\<zero>\<^bsub>R\<^esub>" by auto
  have Auni: "A=(S\<inter>A) \<union>(A-S)" by auto
  from fin b Ssub inC 1 have 2: "lincomb b A = lincomb b (S\<inter>A)"(* \<oplus>\<^bsub>M\<^esub> lincomb b ((-S)\<inter>A)*)
    apply (subst Auni)
    apply (subst lincomb_union, auto)
    (*apply (intro r_zero)*)
    apply (unfold lincomb_def)
    apply (subst (2) finsum_all0, auto)
    by (subst show_r_zero, auto intro!: finsum_closed)
  from 1 2 assms have ld: "lin_dep S"
    apply (intro lin_dep_crit[where ?A="S\<inter>A" and ?a="b" and ?v="v"])
    by auto
  from ld li show False by auto
qed

text \<open>A generating set is a set such that the span of $S$ is all of $M$.\<close>
abbreviation (in module) gen_set::"'c set \<Rightarrow> bool"
  where "gen_set S \<equiv> (span S = carrier M)"

subsection \<open>Submodules\<close>

lemma module_criteria:
  fixes R and M
  assumes cring: "cring R"
      and zero: "\<zero>\<^bsub>M\<^esub>\<in> carrier M"
      and add: "\<forall>v w. v\<in>carrier M \<and> w\<in>carrier M\<longrightarrow> v\<oplus>\<^bsub>M\<^esub> w\<in> carrier M"
      and neg: "\<forall>v\<in>carrier M. (\<exists>neg_v\<in>carrier M. v\<oplus>\<^bsub>M\<^esub>neg_v=\<zero>\<^bsub>M\<^esub>)"
      and smult: "\<forall>c v. c\<in> carrier R \<and> v\<in>carrier M\<longrightarrow> c\<odot>\<^bsub>M\<^esub> v \<in> carrier M"
      and comm: "\<forall>v w. v\<in>carrier M \<and> w\<in>carrier M\<longrightarrow> v\<oplus>\<^bsub>M\<^esub> w=w\<oplus>\<^bsub>M\<^esub> v"
      and assoc: "\<forall>v w x. v\<in>carrier M \<and> w\<in>carrier M \<and> x\<in>carrier M\<longrightarrow> (v\<oplus>\<^bsub>M\<^esub> w)\<oplus>\<^bsub>M\<^esub> x= v\<oplus>\<^bsub>M\<^esub> (w\<oplus>\<^bsub>M\<^esub> x)"
      and add_id: "\<forall>v\<in>carrier M. (v\<oplus>\<^bsub>M\<^esub> \<zero>\<^bsub>M\<^esub> =v)"
      and compat: "\<forall>a b v. a\<in> carrier R \<and> b\<in> carrier R \<and> v\<in>carrier M\<longrightarrow> (a\<otimes>\<^bsub>R\<^esub> b)\<odot>\<^bsub>M\<^esub> v =a\<odot>\<^bsub>M\<^esub> (b\<odot>\<^bsub>M\<^esub> v)"
      and smult_id: "\<forall>v\<in>carrier M. (\<one>\<^bsub>R\<^esub> \<odot>\<^bsub>M\<^esub> v =v)"
      and dist_f: "\<forall>a b v. a\<in> carrier R \<and> b\<in> carrier R \<and> v\<in>carrier M\<longrightarrow> (a\<oplus>\<^bsub>R\<^esub> b)\<odot>\<^bsub>M\<^esub> v =(a\<odot>\<^bsub>M\<^esub> v) \<oplus>\<^bsub>M\<^esub> (b\<odot>\<^bsub>M\<^esub> v)"
      and dist_add: "\<forall>a v w. a\<in> carrier R \<and> v\<in>carrier M \<and> w\<in>carrier M\<longrightarrow> a\<odot>\<^bsub>M\<^esub> (v\<oplus>\<^bsub>M\<^esub> w) =(a\<odot>\<^bsub>M\<^esub> v) \<oplus>\<^bsub>M\<^esub> (a\<odot>\<^bsub>M\<^esub> w)"
  shows "module R M"
proof -
  from assms have 2: "abelian_group M"
    by (intro abelian_groupI, auto)
  from assms have 3: "module_axioms R M"
    by (unfold module_axioms_def, auto)
  from 2 3 cring show ?thesis
    by (unfold module_def module_def, auto)
qed

text \<open>A submodule is $N\subseteq M$ that is closed under addition and scalar multiplication, and
contains 0 (so is not empty).\<close>
locale submodule =
  fixes R and N and M (structure)
  assumes module: "module R M"
    and subset: "N \<subseteq> carrier M"
    and m_closed [intro, simp]: "\<lbrakk>v \<in> N; w \<in> N\<rbrakk> \<Longrightarrow> v \<oplus> w \<in> N"
    and zero_closed [simp]: "\<zero> \<in> N" (*prevents N from being the empty set*)
    and smult_closed [intro, simp]: "\<lbrakk>c \<in> carrier R; v \<in> N\<rbrakk> \<Longrightarrow> c\<odot>v \<in> N"

abbreviation (in module) md::"'c set \<Rightarrow> ('a, 'c, 'd) module_scheme"
  where "md N \<equiv> M\<lparr>carrier :=N\<rparr>"

lemma (in module) carrier_vs_is_self [simp]:
  "carrier (md N) = N"
  by auto

lemma (in module) submodule_is_module:
  fixes N::"'c set"
  assumes 0: "submodule R N M"
  shows "module R (md N)"
proof  (unfold module_def, auto)
  show 1: "cring R"..
next
  from assms show 2: "abelian_group (md N)"
    apply (unfold submodule_def)
    apply (intro abelian_groupI, auto)
      apply (metis (no_types, hide_lams) M.add.m_assoc contra_subsetD)
     apply (metis (no_types, hide_lams) M.add.m_comm contra_subsetD)
    apply (rename_tac v)
    txt \<open>The inverse of $v$ under addition is $-v$\<close>
    apply (rule_tac x="\<ominus>\<^bsub>M\<^esub>v" in bexI)
     apply (metis M.l_neg contra_subsetD)
    by (metis R.add.inv_closed one_closed smult_minus_1 subset_iff)
next
  from assms show 3: "module_axioms R (md N)"
    apply (unfold module_axioms_def submodule_def, auto)
      apply (metis (no_types, hide_lams) smult_l_distr contra_subsetD)
     apply (metis (no_types, hide_lams) smult_r_distr contra_subsetD)
    by (metis (no_types, hide_lams) smult_assoc1 contra_subsetD)
qed

text \<open>$N_1+N_2=\{x+y | x\in N_1,y\in N_2\}$\<close>
definition (in module) submodule_sum:: "['c set, 'c set] \<Rightarrow> 'c set"
  where "submodule_sum N1 N2 = (\<lambda> (x,y). x \<oplus>\<^bsub>M\<^esub> y) `{(x,y). x\<in>  N1 \<and> y\<in> N2}"
(*This only depends on the carriers, actually, so it could be defined on that level if desired.*)

text \<open>A module homomorphism $M\to N$ preserves addition and scalar multiplication.\<close>
definition module_hom:: "[('a, 'c0) ring_scheme,
  ('a,'b1,'c1) module_scheme, ('a,'b2,'c2) module_scheme] \<Rightarrow>('b1\<Rightarrow>'b2) set"
  where "module_hom R M N = {f.
    ((f\<in> carrier M \<rightarrow> carrier N)
    \<and> (\<forall>m1 m2. m1\<in>carrier M\<and> m2\<in>carrier M \<longrightarrow> f (m1 \<oplus>\<^bsub>M\<^esub> m2) = (f m1) \<oplus>\<^bsub>N\<^esub> (f m2))
    \<and> (\<forall>r m. r\<in>carrier R\<and> m\<in>carrier M \<longrightarrow>f (r \<odot>\<^bsub>M\<^esub> m) = r \<odot>\<^bsub>N\<^esub> (f m)))}"

lemma module_hom_closed: "f\<in> module_hom R M N \<Longrightarrow> f\<in> carrier M \<rightarrow> carrier N"
by (unfold module_hom_def, auto)

lemma module_hom_add: "\<lbrakk>f\<in> module_hom R M N; m1\<in>carrier M; m2\<in>carrier M \<rbrakk> \<Longrightarrow> f (m1 \<oplus>\<^bsub>M\<^esub> m2) = (f m1) \<oplus>\<^bsub>N\<^esub> (f m2)"
by (unfold module_hom_def, auto)

lemma module_hom_smult: "\<lbrakk>f\<in> module_hom R M N; r\<in>carrier R; m\<in>carrier M \<rbrakk>  \<Longrightarrow> f (r \<odot>\<^bsub>M\<^esub> m) = r \<odot>\<^bsub>N\<^esub> (f m)"
by (unfold module_hom_def, auto)

locale mod_hom =
  M?: module R M + N?: module R N
    for R and M and N +
  fixes f
  assumes f_hom: "f \<in> module_hom R M N"
  notes f_add [simp] = module_hom_add [OF f_hom]
    and f_smult [simp] = module_hom_smult [OF f_hom]

text \<open>Some basic simplification rules for module homomorphisms.\<close>
context mod_hom
begin

lemma f_im [simp, intro]:
assumes "v \<in> carrier M" (*doesn't work if \<Longrightarrow>*)
shows "f v \<in> carrier N"
proof -
  have 0: "mod_hom R M N f"..
  from 0 assms show ?thesis
    apply (unfold mod_hom_def module_hom_def mod_hom_axioms_def Pi_def)
    by auto
qed

definition im:: "'e set"
  where "im = f`(carrier M)"

definition ker:: "'c set"
  where "ker = {v. v \<in> carrier M & f v = \<zero>\<^bsub>N\<^esub>}"

lemma f0_is_0[simp]: "f \<zero>\<^bsub>M\<^esub>=\<zero>\<^bsub>N\<^esub>"
proof -
  have 1: "f \<zero>\<^bsub>M\<^esub> = f (\<zero>\<^bsub>R\<^esub> \<odot>\<^bsub>M\<^esub> \<zero>\<^bsub>M\<^esub>)" by simp
  have 2: "f (\<zero>\<^bsub>R\<^esub> \<odot>\<^bsub>M\<^esub> \<zero>\<^bsub>M\<^esub>) = \<zero>\<^bsub>N\<^esub>"
    using M.M.zero_closed N.lmult_0 R.zero_closed f_im f_smult by presburger
  from 1 2 show ?thesis by auto
qed

lemma f_neg [simp]: "v \<in> carrier M\<Longrightarrow>f (\<ominus>\<^bsub>M\<^esub> v) = \<ominus>\<^bsub>N\<^esub> f v"
  by (simp flip: M.smult_minus_1 N.smult_minus_1)

lemma f_minus [simp]: "\<lbrakk>v\<in>carrier M; w\<in>carrier M\<rbrakk>\<Longrightarrow>f (v\<ominus>\<^bsub>M\<^esub>w) = f v \<ominus>\<^bsub>N\<^esub> f w"
  by (simp add: a_minus_def)

lemma ker_is_submodule: "submodule R ker M"
proof -
  have 0: "mod_hom R M N f"..
  from 0 have 1: "module R M" by (unfold mod_hom_def, auto)
  show ?thesis
    by  (rule submodule.intro, auto simp add: ker_def, rule 1) (*rmult_0*)
qed

lemma im_is_submodule: "submodule R im N"
proof -
  have 1: "im \<subseteq> carrier N" by (auto simp add: im_def image_def mod_hom_def module_hom_def f_im)
  have 2: "\<And>w1 w2.\<lbrakk>w1 \<in> im; w2 \<in> im\<rbrakk> \<Longrightarrow> w1 \<oplus>\<^bsub>N\<^esub> w2 \<in> im" (*it can't auto convert \<And> and w/ o*)
  proof -
    fix w1 w2
    assume w1: "w1 \<in> im" and w2: "w2\<in> im"
    from w1 obtain v1 where 3: "v1\<in> carrier M \<and> f v1 = w1" by (unfold im_def, auto)
    from w2 obtain v2 where 4: "v2\<in> carrier M \<and> f v2 = w2" by (unfold im_def, auto)
    from 3 4 have 5: "f (v1\<oplus>\<^bsub>M\<^esub>v2) = w1 \<oplus>\<^bsub>N\<^esub> w2" by simp
    from 3 4 have 6: "v1\<oplus>\<^bsub>M\<^esub>v2\<in> carrier M" by simp
    from 5 6 have 7: "\<exists>x\<in>carrier M. w1 \<oplus>\<^bsub>N\<^esub> w2 = f x" by metis
    from 7 show "?thesis w1 w2" by (unfold im_def image_def, auto)
  qed
  have 3: " \<zero>\<^bsub>N\<^esub> \<in> im"
  proof -
    have 8: "f \<zero>\<^bsub>M\<^esub> = \<zero>\<^bsub>N\<^esub> \<and> \<zero>\<^bsub>M\<^esub>\<in>carrier M" by auto
    from 8 have 9: "\<exists>x\<in>carrier M. \<zero>\<^bsub>N\<^esub> = f x" by metis
    from 9 show ?thesis by (unfold im_def image_def, auto)
  qed
  have 4: "\<And>c w. \<lbrakk>c \<in> carrier R; w \<in> im\<rbrakk> \<Longrightarrow> c\<odot>\<^bsub>N\<^esub> w \<in> im"
  proof -
    fix c w
    assume c: "c \<in> carrier R" and w: "w \<in> im"
    from w obtain v where 10: "v\<in> carrier M \<and> f v = w" by (unfold im_def, auto)
    from c 10 have 11: "f (c\<odot>\<^bsub>M\<^esub> v) = c\<odot>\<^bsub>N\<^esub> w\<and> (c \<odot>\<^bsub>M\<^esub> v\<in>carrier M)" by auto
    from 11 have 12: "\<exists>v1\<in>carrier M.  c\<odot>\<^bsub>N\<^esub> w=f v1" by metis
    from 12 show "?thesis c w" by (unfold im_def image_def, auto) (*sensitive to ordering*)
  qed
  from 1 2 3 4 show ?thesis by (unfold_locales, auto)
qed

lemma (in mod_hom) f_ker:
  "v\<in>ker \<Longrightarrow> f v=\<zero>\<^bsub>N\<^esub>"
by (unfold ker_def, auto)
end

text \<open>We will show that for any set $S$, the space of functions $S\to K$ forms a vector space.\<close>
definition (in ring) func_space:: "'z set\<Rightarrow>('a,('z \<Rightarrow> 'a)) module"
  where "func_space S = \<lparr>carrier = S\<rightarrow>\<^sub>Ecarrier R,
                  mult = (\<lambda> f g. restrict (\<lambda>v. \<zero>\<^bsub>R\<^esub>) S),
                  one =  restrict (\<lambda>v. \<zero>\<^bsub>R\<^esub>) S,
                  zero = restrict (\<lambda>v. \<zero>\<^bsub>R\<^esub>) S,
                  add = (\<lambda> f g. restrict (\<lambda>v. f v \<oplus>\<^bsub>R\<^esub> g v) S),
                  smult = (\<lambda> c f. restrict (\<lambda>v. c \<otimes>\<^bsub>R\<^esub> f v) S)\<rparr>"

lemma (in cring) func_space_is_module:
  fixes S
  shows "module R (func_space S)"
proof -
have 0: "cring R"..
from 0 show ?thesis
  apply (auto intro!: module_criteria simp add: func_space_def)
           apply (auto simp add: module_def)
         apply (rename_tac f)
         apply (rule_tac x="restrict (\<lambda>v'. \<ominus>\<^bsub>R\<^esub> (f v')) S" in bexI)
          apply (auto simp add:restrict_def cong: if_cong split: if_split_asm, auto)
         apply (auto simp add: a_ac PiE_mem2 r_neg) (*intro: ext*)
      apply (unfold PiE_def extensional_def Pi_def)
      by (auto simp add: m_assoc l_distr r_distr)
qed

text \<open>Note: one can define $M^n$ from this.\<close>

text \<open>A linear combination is a module homomorphism from the space of coefficients to the module,
 $(a_v)\mapsto \sum_{v\in S} a_vv$.\<close>
lemma (in module) lincomb_is_mod_hom:
  fixes S
  assumes h: "finite S" and h2: "S\<subseteq>carrier M"
  shows "mod_hom R (func_space S) M (\<lambda>a. lincomb a S)"
proof -
  have 0: "module R M"..
  {
    fix m1 m2
    assume m1: "m1 \<in> S \<rightarrow>\<^sub>E carrier R" and m2: "m2 \<in> S \<rightarrow>\<^sub>E carrier R"
    from h h2 m1 m2 have a1: "(\<Oplus>\<^bsub>M\<^esub>v\<in>S. (\<lambda>v\<in>S. m1 v \<oplus>\<^bsub>R\<^esub> m2 v) v \<odot>\<^bsub>M\<^esub> v) =
      (\<Oplus>\<^bsub>M\<^esub>v\<in>S. m1 v \<odot>\<^bsub>M\<^esub> v \<oplus>\<^bsub>M\<^esub> m2 v \<odot>\<^bsub>M\<^esub> v)"
      by (intro finsum_cong', auto simp add: smult_l_distr PiE_mem2)
    from h h2 m1 m2 have a2: "(\<Oplus>\<^bsub>M\<^esub>v\<in>S. m1 v \<odot>\<^bsub>M\<^esub> v \<oplus>\<^bsub>M\<^esub> m2 v \<odot>\<^bsub>M\<^esub> v) =
      (\<Oplus>\<^bsub>M\<^esub>v\<in>S. m1 v \<odot>\<^bsub>M\<^esub> v) \<oplus>\<^bsub>M\<^esub> (\<Oplus>\<^bsub>M\<^esub>v\<in>S. m2 v \<odot>\<^bsub>M\<^esub> v)"
      by (intro finsum_addf, auto)
    from a1 a2 have "(\<Oplus>\<^bsub>M\<^esub>v\<in>S. (\<lambda>v\<in>S. m1 v \<oplus> m2 v) v \<odot>\<^bsub>M\<^esub> v) =
       (\<Oplus>\<^bsub>M\<^esub>v\<in>S. m1 v \<odot>\<^bsub>M\<^esub> v) \<oplus>\<^bsub>M\<^esub> (\<Oplus>\<^bsub>M\<^esub>v\<in>S. m2 v \<odot>\<^bsub>M\<^esub> v)" by auto
  }
  hence 1: "\<And>m1 m2.
       m1 \<in> S \<rightarrow>\<^sub>E carrier R \<Longrightarrow>
       m2 \<in> S \<rightarrow>\<^sub>E carrier R \<Longrightarrow> (\<Oplus>\<^bsub>M\<^esub>v\<in>S. (\<lambda>v\<in>S. m1 v \<oplus> m2 v) v \<odot>\<^bsub>M\<^esub> v) =
       (\<Oplus>\<^bsub>M\<^esub>v\<in>S. m1 v \<odot>\<^bsub>M\<^esub> v) \<oplus>\<^bsub>M\<^esub> (\<Oplus>\<^bsub>M\<^esub>v\<in>S. m2 v \<odot>\<^bsub>M\<^esub> v)" by auto
  {
    fix r m
    assume r: "r \<in> carrier R" and m: "m \<in> S \<rightarrow>\<^sub>E carrier R"
    from h h2 r m have b1: "r \<odot>\<^bsub>M\<^esub> (\<Oplus>\<^bsub>M\<^esub>v\<in>S. m v \<odot>\<^bsub>M\<^esub> v) =  (\<Oplus>\<^bsub>M\<^esub>v\<in>S. r \<odot>\<^bsub>M\<^esub>(m v \<odot>\<^bsub>M\<^esub> v))"
      by (intro finsum_smult, auto)
    from h h2 r m have b2: "(\<Oplus>\<^bsub>M\<^esub>v\<in>S. (\<lambda>v\<in>S. r \<otimes> m v) v \<odot>\<^bsub>M\<^esub> v) = r \<odot>\<^bsub>M\<^esub> (\<Oplus>\<^bsub>M\<^esub>v\<in>S. m v \<odot>\<^bsub>M\<^esub> v)"
      apply (subst b1)
      apply (intro finsum_cong', auto)
      by (subst smult_assoc1, auto)
  }
  hence 2: "\<And>r m. r \<in> carrier R \<Longrightarrow>
           m \<in> S \<rightarrow>\<^sub>E carrier R \<Longrightarrow> (\<Oplus>\<^bsub>M\<^esub>v\<in>S. (\<lambda>v\<in>S. r \<otimes> m v) v \<odot>\<^bsub>M\<^esub> v) = r \<odot>\<^bsub>M\<^esub> (\<Oplus>\<^bsub>M\<^esub>v\<in>S. m v \<odot>\<^bsub>M\<^esub> v)"
            by auto
  from h h2 0 1 2 show ?thesis
    apply (unfold mod_hom_def, auto)
     apply (rule func_space_is_module)
    apply (unfold mod_hom_axioms_def module_hom_def, auto)
      apply (rule lincomb_closed, unfold func_space_def, auto)
     apply (unfold lincomb_def)
     by auto
qed

(*These are not really used.*)
lemma (in module) lincomb_sum:
  assumes A_fin: "finite A" and AinC: "A\<subseteq>carrier M" and a_fun: "a\<in>A\<rightarrow>carrier R" and
    b_fun: "b\<in>A\<rightarrow>carrier R"
  shows "lincomb (\<lambda>v. a v \<oplus>\<^bsub>R\<^esub> b v) A = lincomb a A \<oplus>\<^bsub>M\<^esub> lincomb b A"
proof -
  from A_fin AinC interpret mh: mod_hom R "func_space A" M  "(\<lambda>a. lincomb a A)" by (rule
    lincomb_is_mod_hom)
  let ?a="restrict a A"
  let ?b="restrict b A"
  from a_fun b_fun A_fin AinC
  have 1: "LinearCombinations.module.lincomb M (?a\<oplus>\<^bsub>(LinearCombinations.ring.func_space R A)\<^esub> ?b) A
    = LinearCombinations.module.lincomb M (\<lambda>x.  a x \<oplus>\<^bsub>R\<^esub> b x) A"
    by (auto simp add: func_space_def Pi_iff restrict_apply' cong: lincomb_cong)
  from a_fun b_fun A_fin AinC
  have 2: "LinearCombinations.module.lincomb M ?a A \<oplus>\<^bsub>M\<^esub>
      LinearCombinations.module.lincomb M ?b A = LinearCombinations.module.lincomb M a A \<oplus>\<^bsub>M\<^esub>
      LinearCombinations.module.lincomb M b A"
    by (simp_all add: sum_simp cong: lincomb_cong)
  from a_fun b_fun have ainC: "?a\<in>carrier (LinearCombinations.ring.func_space R A)"
    and binC: "?b\<in>carrier (LinearCombinations.ring.func_space R A)" by (unfold func_space_def, auto)
  from ainC binC have "LinearCombinations.module.lincomb M (?a\<oplus>\<^bsub>(LinearCombinations.ring.func_space R A)\<^esub> ?b) A
    = LinearCombinations.module.lincomb M ?a A \<oplus>\<^bsub>M\<^esub>
      LinearCombinations.module.lincomb M ?b A"
    by (simp cong: lincomb_cong)
  with 1 2 show ?thesis by auto
qed

text \<open>The negative of a function is just pointwise negation.\<close>
lemma (in cring) func_space_neg:
  fixes f
  assumes "f\<in> carrier (func_space S)"
  shows "\<ominus>\<^bsub>func_space S\<^esub> f = (\<lambda> v. if (v\<in>S) then \<ominus>\<^bsub>R\<^esub> f v else undefined)"
proof -
  interpret fs: module R "func_space S" by (rule func_space_is_module)
  from assms show ?thesis
    apply (intro fs.minus_equality)
      apply (unfold func_space_def PiE_def extensional_def)
      apply auto
     apply (intro restrict_ext, auto)
    by (simp add: l_neg coeff_in_ring)
qed

text \<open>Ditto for subtraction. Note the above is really a special case, when a is the 0 function.\<close>
lemma (in module) lincomb_diff:
  assumes A_fin: "finite A" and AinC: "A\<subseteq>carrier M" and a_fun: "a\<in>A\<rightarrow>carrier R" and
    b_fun: "b\<in>A\<rightarrow>carrier R"
  shows "lincomb (\<lambda>v. a v \<ominus>\<^bsub>R\<^esub> b v) A = lincomb a A \<ominus>\<^bsub>M\<^esub> lincomb b A"
proof -
  from A_fin AinC interpret mh: mod_hom R "func_space A" M  "(\<lambda>a. lincomb a A)" by (rule
    lincomb_is_mod_hom)
  let ?a="restrict a A"
  let ?b="restrict b A"
  from a_fun b_fun have ainC: "?a\<in>carrier (LinearCombinations.ring.func_space R A)"
    and binC: "?b\<in>carrier (LinearCombinations.ring.func_space R A)" by (unfold func_space_def, auto)
  from a_fun b_fun ainC binC A_fin AinC
  have 1: "LinearCombinations.module.lincomb M (?a\<ominus>\<^bsub>(func_space A)\<^esub> ?b) A
    = LinearCombinations.module.lincomb M (\<lambda>x.  a x \<ominus>\<^bsub>R\<^esub> b x) A"
    apply (subst mh.M.M.minus_eq)
    apply (intro lincomb_cong, auto)
    apply (subst func_space_neg, auto)
    apply (simp add: restrict_def func_space_def)
    by (subst R.minus_eq, auto)
  from a_fun b_fun A_fin AinC
  have 2: "LinearCombinations.module.lincomb M ?a A \<ominus>\<^bsub>M\<^esub>
      LinearCombinations.module.lincomb M ?b A = LinearCombinations.module.lincomb M a A \<ominus>\<^bsub>M\<^esub>
      LinearCombinations.module.lincomb M b A"
    by (simp cong: lincomb_cong)
  from ainC binC have "LinearCombinations.module.lincomb M (?a\<ominus>\<^bsub>(LinearCombinations.ring.func_space R A)\<^esub> ?b) A
    = LinearCombinations.module.lincomb M ?a A \<ominus>\<^bsub>M\<^esub>
      LinearCombinations.module.lincomb M ?b A"
    by (simp cong: lincomb_cong)
  with 1 2 show ?thesis by auto
qed

text \<open>The union of nested submodules is a submodule. We will use this to show that span of any
set is a submodule.\<close>
lemma (in module) nested_union_vs:
  fixes I N N'
  assumes subm: "\<And>i. i\<in>I\<Longrightarrow> submodule R (N i) M"
    and max_exists: "\<And>i j. i\<in>I\<Longrightarrow>j\<in>I\<Longrightarrow> (\<exists>k. k\<in>I \<and> N i\<subseteq>N k \<and> N j \<subseteq>N k)"
    and uni: "N'=(\<Union> i\<in>I. N i)"
    and ne: "I\<noteq>{}"
  shows "submodule R N' M"
proof -
  have 1: "module R M"..
  from subm have all_in: "\<And>i. i\<in>I \<Longrightarrow> N i \<subseteq> carrier M"
    by (unfold submodule_def, auto)
  from uni all_in have 2: "\<And>x. x \<in> N' \<Longrightarrow> x \<in> carrier M"
    by auto
  from uni have 3: "\<And>v w. v \<in> N' \<Longrightarrow> w \<in> N' \<Longrightarrow> v \<oplus>\<^bsub>M\<^esub> w \<in> N'"
  proof -
    fix v w
    assume v: "v \<in> N'" and w: "w \<in> N'"
    from uni v w obtain i j where i: "i\<in>I\<and> v\<in> N i" and j: "j\<in>I\<and> w\<in> N j" by auto
    from max_exists i j obtain k where k: "k\<in>I \<and> N i \<subseteq> N k \<and> N j \<subseteq> N k" by presburger
    from v w i j k have v2: "v\<in>N k" and w2: "w\<in> N k" by auto
    from v2 w2 k subm[of k] have vw: "v \<oplus>\<^bsub>M\<^esub> w \<in> N k" apply (unfold submodule_def) by auto
    from k vw uni show "?thesis v w"  by auto
  qed
  have 4: "\<zero>\<^bsub>M\<^esub> \<in> N'"
  proof -
    from ne obtain i where i: "i\<in>I" by auto
    from i subm have zi: "\<zero>\<^bsub>M\<^esub>\<in>N i" by (unfold submodule_def, auto)
    from i zi uni show ?thesis by auto
  qed
  from uni subm have 5: "\<And>c v. c \<in> carrier R \<Longrightarrow> v \<in> N' \<Longrightarrow> c \<odot>\<^bsub>M\<^esub> v \<in> N'"
    by (unfold submodule_def, auto)
  from 1 2 3 4 5 show ?thesis by (unfold submodule_def, auto)
qed

lemma (in module) span_is_monotone:
  fixes S T
  assumes subs: "S\<subseteq>T"
  shows "span S \<subseteq> span T"
proof -
  from subs show ?thesis
    by (unfold span_def, auto)
qed

lemma (in module) span_is_submodule:
  fixes S
  assumes  h2: "S\<subseteq>carrier M"
  shows "submodule R (span S) M"
proof (cases "S={}")
  case True
  moreover have "module R M"..
  ultimately show ?thesis apply (unfold submodule_def span_def lincomb_def, auto) done
next
  case False
  show ?thesis
  proof (rule nested_union_vs[where ?I="{F. F\<subseteq>S \<and> finite F}" and ?N="\<lambda>F. span F" and ?N'="span S"])
    show " \<And>F. F \<in> {F. F \<subseteq> S \<and> finite F} \<Longrightarrow> submodule R (span F) M"
    proof -
      fix F
      assume F: "F \<in> {F. F \<subseteq> S \<and> finite F}"
      from F have h1: "finite F" by auto
      from F h2 have inC: "F\<subseteq>carrier M" by auto
      from h1 inC interpret mh: mod_hom R "(func_space F)" M "(\<lambda>a. lincomb a F)"
        by (rule lincomb_is_mod_hom)
      from h1 inC have 1: "mh.im = span F"
        apply (unfold mh.im_def)
        apply (unfold func_space_def, simp)
        apply (subst finite_span, auto)
        apply (unfold image_def, auto)
        apply (rule_tac x="restrict a F" in bexI)
         by (auto intro!: lincomb_cong)
      from 1 show "submodule R (span F) M" by (metis mh.im_is_submodule)
    qed
  next
    show "\<And>i j. i \<in> {F. F \<subseteq> S \<and> finite F} \<Longrightarrow>
           j \<in> {F. F \<subseteq> S \<and> finite F} \<Longrightarrow>
           \<exists>k. k \<in> {F. F \<subseteq> S \<and> finite F} \<and> span i \<subseteq> span k \<and> span j \<subseteq> span k"
    proof -
      fix i j
      assume i: "i \<in> {F. F \<subseteq> S \<and> finite F}" and j: "j \<in> {F. F \<subseteq> S \<and> finite F}"
      from i j show "?thesis i j"
        apply (rule_tac x="i\<union>j" in exI)
        apply (auto del: subsetI)
         by (intro span_is_monotone, auto del: subsetI)+
    qed
  next
    show "span S=(\<Union> i\<in>{F. F \<subseteq> S \<and> finite F}. span i)"
      by (unfold span_def,auto)
  next
    have ne: "S\<noteq>{}" by fact
    from ne show "{F. F \<subseteq> S \<and> finite F} \<noteq> {}" by auto
  qed
qed

text \<open>A finite sum does not depend on the ambient module. This can be done for monoid, but
"submonoid" isn't currently defined. (It can be copied, however, for groups\ldots)
This lemma requires a somewhat annoying lemma foldD-not-depend. Then we show that linear combinations,
linear independence, span do not depend on the ambient module.\<close>
lemma (in module) finsum_not_depend:
  fixes a A N
  assumes h1: "finite A" and h2: "A\<subseteq>N" and h3: "submodule R N M" and h4: "f:A\<rightarrow>N"
  shows "(\<Oplus>\<^bsub>(md N)\<^esub> v\<in>A. f v) = (\<Oplus>\<^bsub>M\<^esub> v\<in>A. f v)"
proof -
  from h1 h2 h3 h4 show ?thesis
    apply (unfold finsum_def finprod_def)
    apply simp
    apply (intro foldD_not_depend[where ?B="A"])
         apply (unfold submodule_def LCD_def, auto)
    apply (meson M.add.m_lcomm PiE subsetCE)+
    done
qed

lemma (in module) lincomb_not_depend:
  fixes a A N
  assumes h1: "finite A" and h2: "A\<subseteq>N" and h3: "submodule R N M" and h4: "a:A\<rightarrow>carrier R"
  shows "lincomb a A = module.lincomb (md N) a A"
proof -
  from h3 interpret N: module R "(md N)" by (rule submodule_is_module)
  have 3: "N=carrier (md N)" by auto
  have 4: "(smult M ) = (smult (md N))" by auto
  from h1 h2 h3 h4 have "(\<Oplus>\<^bsub>(md N)\<^esub>v\<in>A. a v \<odot>\<^bsub>M\<^esub> v) = (\<Oplus>\<^bsub>M\<^esub>v\<in>A. a v \<odot>\<^bsub>M\<^esub> v)"
    apply (intro finsum_not_depend)
    using N.summands_valid by auto
  from this show ?thesis by (unfold lincomb_def N.lincomb_def, simp)
qed

lemma (in module) span_li_not_depend:
  fixes S N
  assumes h2: "S\<subseteq>N" and  h3: "submodule R N M"
  shows "module.span R (md N) S = module.span R M S"
    and "module.lin_dep R (md N) S = module.lin_dep R M S"
proof -
  from h3 interpret w: module R "(md N)" by (rule submodule_is_module)
  from h2 have 1:"submodule R (module.span R (md N) S) (md N)"
    by (intro w.span_is_submodule, simp)
  have 3: "\<And>a A. (finite A \<and> A\<subseteq>S \<and> a \<in> A \<rightarrow> carrier R \<Longrightarrow>
    module.lincomb M a A = module.lincomb (md N) a A)"
  proof -
    fix a A
    assume 31: "finite A \<and> A\<subseteq>S \<and> a \<in> A \<rightarrow> carrier R"
    from assms 31 show "?thesis a A"
      by (intro lincomb_not_depend, auto)
  qed
  from 3 show 4: "module.span R (md N) S = module.span R M S"
    apply (unfold span_def w.span_def)
    apply auto
    by (metis)
  have zeros: "\<zero>\<^bsub>md N\<^esub>=\<zero>\<^bsub>M\<^esub>" by auto
  from assms 3 show 5: "module.lin_dep R (md N) S = module.lin_dep R M S"
    apply (unfold lin_dep_def w.lin_dep_def)
    apply (subst zeros)
    by metis
qed

lemma (in module) span_is_subset:
  fixes S N
  assumes h2: "S\<subseteq>N" and  h3: "submodule R N M"
  shows "span S \<subseteq> N"
proof -
  from h3 interpret w: module R "(md N)" by (rule submodule_is_module)
  from h2 have 1:"submodule R (module.span R (md N) S) (md N)"
    by (intro w.span_is_submodule, simp)
  from assms have 4: "module.span R (md N) S = module.span R M S"
     by (rule span_li_not_depend)
  from 1 4 have 5: "submodule R (module.span R M S) (md N)" by auto
  from 5 show ?thesis by (unfold submodule_def, simp)
qed

lemma (in module) span_is_subset2:
  fixes S
  assumes h2: "S\<subseteq>carrier M"
  shows "span S \<subseteq> carrier M"
proof -
  have 0: "module R M"..
  from 0 have h3: "submodule R (carrier M) M" by (unfold submodule_def, auto)
  from h2 h3 show ?thesis by (rule span_is_subset)
qed

lemma (in module) in_own_span:
  fixes S
  assumes  inC:"S\<subseteq>carrier M"
  shows "S \<subseteq> span S"
proof -
  from inC show ?thesis
    apply (unfold span_def, auto)
    apply (rename_tac v)
    apply (rule_tac x="(\<lambda> w. if (w=v) then \<one>\<^bsub>R\<^esub> else \<zero>\<^bsub>R\<^esub>)" in exI)
    apply (rule_tac x="{v}" in exI)
    apply (unfold lincomb_def)
    by auto
qed

lemma (in module) subset_li_is_li:
  fixes A B
  assumes li: "lin_indpt A" and sub: "B \<subseteq> A"
  shows "lin_indpt B"
proof (rule ccontr)
  assume ld: "\<not>lin_indpt B"
  from ld sub have ldA: "lin_dep A" by (metis supset_ld_is_ld)
  from li ldA show False by auto
qed

lemma (in mod_hom) hom_sum:
  fixes A B g
  assumes h2: "A\<subseteq>carrier M" and h3: "g:A\<rightarrow>carrier M"
  shows "f (\<Oplus>\<^bsub>M\<^esub> a\<in>A. g a) = (\<Oplus>\<^bsub>N\<^esub> a\<in>A. f (g a))"
proof -
  from h2 h3 show ?thesis
  proof (induct A rule: infinite_finite_induct) (*doesn't work on outside?*)
    case (insert a A)
    then have "(\<Oplus>\<^bsub>N\<^esub>a\<in>insert a A. f (g a)) = f (g a) \<oplus>\<^bsub>N\<^esub> (\<Oplus>\<^bsub>N\<^esub>a\<in>A. f (g a))"
      by (intro finsum_insert, auto)
    with insert.prems insert.hyps show ?case
      by simp
  qed auto
qed

end


(* Author: Tobias Nipkow, Daniel Stüwe *)

section \<open>1-2 Brother Tree Implementation of Sets\<close>

theory Brother12_Set
imports
  Cmp
  Set_Specs
  "HOL-Number_Theory.Fib"
begin

subsection \<open>Data Type and Operations\<close>

datatype 'a bro =
  N0 |
  N1 "'a bro" |
  N2 "'a bro" 'a "'a bro" |
  (* auxiliary constructors: *)
  L2 'a |
  N3 "'a bro" 'a "'a bro" 'a "'a bro"

definition empty :: "'a bro" where
"empty = N0"

fun inorder :: "'a bro \<Rightarrow> 'a list" where
"inorder N0 = []" |
"inorder (N1 t) = inorder t" |
"inorder (N2 l a r) = inorder l @ a # inorder r" |
"inorder (L2 a) = [a]" |
"inorder (N3 t1 a1 t2 a2 t3) = inorder t1 @ a1 # inorder t2 @ a2 # inorder t3"

fun isin :: "'a bro \<Rightarrow> 'a::linorder \<Rightarrow> bool" where
"isin N0 x = False" |
"isin (N1 t) x = isin t x" |
"isin (N2 l a r) x =
  (case cmp x a of
     LT \<Rightarrow> isin l x |
     EQ \<Rightarrow> True |
     GT \<Rightarrow> isin r x)"

fun n1 :: "'a bro \<Rightarrow> 'a bro" where
"n1 (L2 a) = N2 N0 a N0" |
"n1 (N3 t1 a1 t2 a2 t3) = N2 (N2 t1 a1 t2) a2 (N1 t3)" |
"n1 t = N1 t"

hide_const (open) insert

locale insert
begin

fun n2 :: "'a bro \<Rightarrow> 'a \<Rightarrow> 'a bro \<Rightarrow> 'a bro" where
"n2 (L2 a1) a2 t = N3 N0 a1 N0 a2 t" |
"n2 (N3 t1 a1 t2 a2 t3) a3 (N1 t4) = N2 (N2 t1 a1 t2) a2 (N2 t3 a3 t4)" |
"n2 (N3 t1 a1 t2 a2 t3) a3 t4 = N3 (N2 t1 a1 t2) a2 (N1 t3) a3 t4" |
"n2 t1 a1 (L2 a2) = N3 t1 a1 N0 a2 N0" |
"n2 (N1 t1) a1 (N3 t2 a2 t3 a3 t4) = N2 (N2 t1 a1 t2) a2 (N2 t3 a3 t4)" |
"n2 t1 a1 (N3 t2 a2 t3 a3 t4) = N3 t1 a1 (N1 t2) a2 (N2 t3 a3 t4)" |
"n2 t1 a t2 = N2 t1 a t2"

fun ins :: "'a::linorder \<Rightarrow> 'a bro \<Rightarrow> 'a bro" where
"ins x N0 = L2 x" |
"ins x (N1 t) = n1 (ins x t)" |
"ins x (N2 l a r) =
  (case cmp x a of
     LT \<Rightarrow> n2 (ins x l) a r |
     EQ \<Rightarrow> N2 l a r |
     GT \<Rightarrow> n2 l a (ins x r))"

fun tree :: "'a bro \<Rightarrow> 'a bro" where
"tree (L2 a) = N2 N0 a N0" |
"tree (N3 t1 a1 t2 a2 t3) = N2 (N2 t1 a1 t2) a2 (N1 t3)" |
"tree t = t"

definition insert :: "'a::linorder \<Rightarrow> 'a bro \<Rightarrow> 'a bro" where
"insert x t = tree(ins x t)"

end

locale delete
begin

fun n2 :: "'a bro \<Rightarrow> 'a \<Rightarrow> 'a bro \<Rightarrow> 'a bro" where
"n2 (N1 t1) a1 (N1 t2) = N1 (N2 t1 a1 t2)" |
"n2 (N1 (N1 t1)) a1 (N2 (N1 t2) a2 (N2 t3 a3 t4)) =
  N1 (N2 (N2 t1 a1 t2) a2 (N2 t3 a3 t4))" |
"n2 (N1 (N1 t1)) a1 (N2 (N2 t2 a2 t3) a3 (N1 t4)) =
  N1 (N2 (N2 t1 a1 t2) a2 (N2 t3 a3 t4))" |
"n2 (N1 (N1 t1)) a1 (N2 (N2 t2 a2 t3) a3 (N2 t4 a4 t5)) =
  N2 (N2 (N1 t1) a1 (N2 t2 a2 t3)) a3 (N1 (N2 t4 a4 t5))" |
"n2 (N2 (N1 t1) a1 (N2 t2 a2 t3)) a3 (N1 (N1 t4)) =
  N1 (N2 (N2 t1 a1 t2) a2 (N2 t3 a3 t4))" |
"n2 (N2 (N2 t1 a1 t2) a2 (N1 t3)) a3 (N1 (N1 t4)) =
  N1 (N2 (N2 t1 a1 t2) a2 (N2 t3 a3 t4))" |
"n2 (N2 (N2 t1 a1 t2) a2 (N2 t3 a3 t4)) a5 (N1 (N1 t5)) =
  N2 (N1 (N2 t1 a1 t2)) a2 (N2 (N2 t3 a3 t4) a5 (N1 t5))" |
"n2 t1 a1 t2 = N2 t1 a1 t2"

fun split_min :: "'a bro \<Rightarrow> ('a \<times> 'a bro) option" where
"split_min N0 = None" |
"split_min (N1 t) =
  (case split_min t of
     None \<Rightarrow> None |
     Some (a, t') \<Rightarrow> Some (a, N1 t'))" |
"split_min (N2 t1 a t2) =
  (case split_min t1 of
     None \<Rightarrow> Some (a, N1 t2) |
     Some (b, t1') \<Rightarrow> Some (b, n2 t1' a t2))"

fun del :: "'a::linorder \<Rightarrow> 'a bro \<Rightarrow> 'a bro" where
"del _ N0         = N0" |
"del x (N1 t)     = N1 (del x t)" |
"del x (N2 l a r) =
  (case cmp x a of
     LT \<Rightarrow> n2 (del x l) a r |
     GT \<Rightarrow> n2 l a (del x r) |
     EQ \<Rightarrow> (case split_min r of
              None \<Rightarrow> N1 l |
              Some (b, r') \<Rightarrow> n2 l b r'))"

fun tree :: "'a bro \<Rightarrow> 'a bro" where
"tree (N1 t) = t" |
"tree t = t"

definition delete :: "'a::linorder \<Rightarrow> 'a bro \<Rightarrow> 'a bro" where
"delete a t = tree (del a t)"

end

subsection \<open>Invariants\<close>

fun B :: "nat \<Rightarrow> 'a bro set"
and U :: "nat \<Rightarrow> 'a bro set" where
"B 0 = {N0}" |
"B (Suc h) = { N2 t1 a t2 | t1 a t2.
  t1 \<in> B h \<union> U h \<and> t2 \<in> B h \<or> t1 \<in> B h \<and> t2 \<in> B h \<union> U h}" |
"U 0 = {}" |
"U (Suc h) = N1 ` B h"

abbreviation "T h \<equiv> B h \<union> U h"

fun Bp :: "nat \<Rightarrow> 'a bro set" where
"Bp 0 = B 0 \<union> L2 ` UNIV" |
"Bp (Suc 0) = B (Suc 0) \<union> {N3 N0 a N0 b N0|a b. True}" |
"Bp (Suc(Suc h)) = B (Suc(Suc h)) \<union>
  {N3 t1 a t2 b t3 | t1 a t2 b t3. t1 \<in> B (Suc h) \<and> t2 \<in> U (Suc h) \<and> t3 \<in> B (Suc h)}"

fun Um :: "nat \<Rightarrow> 'a bro set" where
"Um 0 = {}" |
"Um (Suc h) = N1 ` T h"

subsection "Functional Correctness Proofs"

subsubsection "Proofs for isin"

lemma isin_set:
  "t \<in> T h \<Longrightarrow> sorted(inorder t) \<Longrightarrow> isin t x = (x \<in> set(inorder t))"
by(induction h arbitrary: t) (fastforce simp: isin_simps split: if_splits)+

subsubsection "Proofs for insertion"

lemma inorder_n1: "inorder(n1 t) = inorder t"
by(cases t rule: n1.cases) (auto simp: sorted_lems)

context insert
begin

lemma inorder_n2: "inorder(n2 l a r) = inorder l @ a # inorder r"
by(cases "(l,a,r)" rule: n2.cases) (auto simp: sorted_lems)

lemma inorder_tree: "inorder(tree t) = inorder t"
by(cases t) auto

lemma inorder_ins: "t \<in> T h \<Longrightarrow>
  sorted(inorder t) \<Longrightarrow> inorder(ins a t) = ins_list a (inorder t)"
by(induction h arbitrary: t) (auto simp: ins_list_simps inorder_n1 inorder_n2)

lemma inorder_insert: "t \<in> T h \<Longrightarrow>
  sorted(inorder t) \<Longrightarrow> inorder(insert a t) = ins_list a (inorder t)"
by(simp add: insert_def inorder_ins inorder_tree)

end

subsubsection \<open>Proofs for deletion\<close>

context delete
begin

lemma inorder_tree: "inorder(tree t) = inorder t"
by(cases t) auto

lemma inorder_n2: "inorder(n2 l a r) = inorder l @ a # inorder r"
by(cases "(l,a,r)" rule: n2.cases) (auto)

lemma inorder_split_min:
  "t \<in> T h \<Longrightarrow> (split_min t = None \<longleftrightarrow> inorder t = []) \<and>
  (split_min t = Some(a,t') \<longrightarrow> inorder t = a # inorder t')"
by(induction h arbitrary: t a t') (auto simp: inorder_n2 split: option.splits)

lemma inorder_del:
  "t \<in> T h \<Longrightarrow> sorted(inorder t) \<Longrightarrow> inorder(del x t) = del_list x (inorder t)"
  apply (induction h arbitrary: t)
  apply (auto simp: del_list_simps inorder_n2 split: option.splits)
  apply (auto simp: del_list_simps inorder_n2
     inorder_split_min[OF UnI1] inorder_split_min[OF UnI2] split: option.splits)
  done

lemma inorder_delete:
  "t \<in> T h \<Longrightarrow> sorted(inorder t) \<Longrightarrow> inorder(delete x t) = del_list x (inorder t)"
by(simp add: delete_def inorder_del inorder_tree)

end

subsection \<open>Invariant Proofs\<close>

subsubsection \<open>Proofs for insertion\<close>

lemma n1_type: "t \<in> Bp h \<Longrightarrow> n1 t \<in> T (Suc h)"
by(cases h rule: Bp.cases) auto

context insert
begin

lemma tree_type: "t \<in> Bp h \<Longrightarrow> tree t \<in> B h \<union> B (Suc h)"
by(cases h rule: Bp.cases) auto

lemma n2_type:
  "(t1 \<in> Bp h \<and> t2 \<in> T h \<longrightarrow> n2 t1 a t2 \<in> Bp (Suc h)) \<and>
   (t1 \<in> T h \<and> t2 \<in> Bp h \<longrightarrow> n2 t1 a t2 \<in> Bp (Suc h))"
apply(cases h rule: Bp.cases)
apply (auto)[2]
apply(rule conjI impI | erule conjE exE imageE | simp | erule disjE)+
done

lemma Bp_if_B: "t \<in> B h \<Longrightarrow> t \<in> Bp h"
by (cases h rule: Bp.cases) simp_all

text\<open>An automatic proof:\<close>

lemma
  "(t \<in> B h \<longrightarrow> ins x t \<in> Bp h) \<and> (t \<in> U h \<longrightarrow> ins x t \<in> T h)"
apply(induction h arbitrary: t)
 apply (simp)
apply (fastforce simp: Bp_if_B n2_type dest: n1_type)
done

text\<open>A detailed proof:\<close>

lemma ins_type:
shows "t \<in> B h \<Longrightarrow> ins x t \<in> Bp h" and "t \<in> U h \<Longrightarrow> ins x t \<in> T h"
proof(induction h arbitrary: t)
  case 0
  { case 1 thus ?case by simp
  next
    case 2 thus ?case by simp }
next
  case (Suc h)
  { case 1
    then obtain t1 a t2 where [simp]: "t = N2 t1 a t2" and
      t1: "t1 \<in> T h" and t2: "t2 \<in> T h" and t12: "t1 \<in> B h \<or> t2 \<in> B h"
      by auto
    have ?case if "x < a"
    proof -
      have "n2 (ins x t1) a t2 \<in> Bp (Suc h)"
      proof cases
        assume "t1 \<in> B h"
        with t2 show ?thesis by (simp add: Suc.IH(1) n2_type)
      next
        assume "t1 \<notin> B h"
        hence 1: "t1 \<in> U h" and 2: "t2 \<in> B h" using t1 t12 by auto
        show ?thesis by (metis Suc.IH(2)[OF 1] Bp_if_B[OF 2] n2_type)
      qed
      with \<open>x < a\<close> show ?case by simp
    qed
    moreover
    have ?case if "a < x"
    proof -
      have "n2 t1 a (ins x t2) \<in> Bp (Suc h)"
      proof cases
        assume "t2 \<in> B h"
        with t1 show ?thesis by (simp add: Suc.IH(1) n2_type)
      next
        assume "t2 \<notin> B h"
        hence 1: "t1 \<in> B h" and 2: "t2 \<in> U h" using t2 t12 by auto
        show ?thesis by (metis Bp_if_B[OF 1] Suc.IH(2)[OF 2] n2_type)
      qed
      with \<open>a < x\<close> show ?case by simp
    qed
    moreover
    have ?case if "x = a"
    proof -
      from 1 have "t \<in> Bp (Suc h)" by(rule Bp_if_B)
      thus "?case" using \<open>x = a\<close> by simp
    qed
    ultimately show ?case by auto
  next
    case 2 thus ?case using Suc(1) n1_type by fastforce }
qed

lemma insert_type:
  "t \<in> B h \<Longrightarrow> insert x t \<in> B h \<union> B (Suc h)"
unfolding insert_def by (metis ins_type(1) tree_type)

end

subsubsection "Proofs for deletion"

lemma B_simps[simp]:
  "N1 t \<in> B h = False"
  "L2 y \<in> B h = False"
  "(N3 t1 a1 t2 a2 t3) \<in> B h = False"
  "N0 \<in> B h \<longleftrightarrow> h = 0"
by (cases h, auto)+

context delete
begin

lemma n2_type1:
  "\<lbrakk>t1 \<in> Um h; t2 \<in> B h\<rbrakk> \<Longrightarrow> n2 t1 a t2 \<in> T (Suc h)"
apply(cases h rule: Bp.cases)
apply auto[2]
apply(erule exE bexE conjE imageE | simp | erule disjE)+
done

lemma n2_type2:
  "\<lbrakk>t1 \<in> B h ; t2 \<in> Um h \<rbrakk> \<Longrightarrow> n2 t1 a t2 \<in> T (Suc h)"
apply(cases h rule: Bp.cases)
apply auto[2]
apply(erule exE bexE conjE imageE | simp | erule disjE)+
done

lemma n2_type3:
  "\<lbrakk>t1 \<in> T h ; t2 \<in> T h \<rbrakk> \<Longrightarrow> n2 t1 a t2 \<in> T (Suc h)"
apply(cases h rule: Bp.cases)
apply auto[2]
apply(erule exE bexE conjE imageE | simp | erule disjE)+
done

lemma split_minNoneN0: "\<lbrakk>t \<in> B h; split_min t = None\<rbrakk> \<Longrightarrow>  t = N0"
by (cases t) (auto split: option.splits)

lemma split_minNoneN1 : "\<lbrakk>t \<in> U h; split_min t = None\<rbrakk> \<Longrightarrow> t = N1 N0"
by (cases h) (auto simp: split_minNoneN0  split: option.splits)

lemma split_min_type:
  "t \<in> B h \<Longrightarrow> split_min t = Some (a, t') \<Longrightarrow> t' \<in> T h"
  "t \<in> U h \<Longrightarrow> split_min t = Some (a, t') \<Longrightarrow> t' \<in> Um h"
proof (induction h arbitrary: t a t')
  case (Suc h)
  { case 1
    then obtain t1 a t2 where [simp]: "t = N2 t1 a t2" and
      t12: "t1 \<in> T h" "t2 \<in> T h" "t1 \<in> B h \<or> t2 \<in> B h"
      by auto
    show ?case
    proof (cases "split_min t1")
      case None
      show ?thesis
      proof cases
        assume "t1 \<in> B h"
        with split_minNoneN0[OF this None] 1 show ?thesis by(auto)
      next
        assume "t1 \<notin> B h"
        thus ?thesis using 1 None by (auto)
      qed
    next
      case [simp]: (Some bt')
      obtain b t1' where [simp]: "bt' = (b,t1')" by fastforce
      show ?thesis
      proof cases
        assume "t1 \<in> B h"
        from Suc.IH(1)[OF this] 1 have "t1' \<in> T h" by simp
        from n2_type3[OF this t12(2)] 1 show ?thesis by auto
      next
        assume "t1 \<notin> B h"
        hence t1: "t1 \<in> U h" and t2: "t2 \<in> B h" using t12 by auto
        from Suc.IH(2)[OF t1] have "t1' \<in> Um h" by simp
        from n2_type1[OF this t2] 1 show ?thesis by auto
      qed
    qed
  }
  { case 2
    then obtain t1 where [simp]: "t = N1 t1" and t1: "t1 \<in> B h" by auto
    show ?case
    proof (cases "split_min t1")
      case None
      with split_minNoneN0[OF t1 None] 2 show ?thesis by(auto)
    next
      case [simp]: (Some bt')
      obtain b t1' where [simp]: "bt' = (b,t1')" by fastforce
      from Suc.IH(1)[OF t1] have "t1' \<in> T h" by simp
      thus ?thesis using 2 by auto
    qed
  }
qed auto

lemma del_type:
  "t \<in> B h \<Longrightarrow> del x t \<in> T h"
  "t \<in> U h \<Longrightarrow> del x t \<in> Um h"
proof (induction h arbitrary: x t)
  case (Suc h)
  { case 1
    then obtain l a r where [simp]: "t = N2 l a r" and
      lr: "l \<in> T h" "r \<in> T h" "l \<in> B h \<or> r \<in> B h" by auto
    have ?case if "x < a"
    proof cases
      assume "l \<in> B h"
      from n2_type3[OF Suc.IH(1)[OF this] lr(2)]
      show ?thesis using \<open>x<a\<close> by(simp)
    next
      assume "l \<notin> B h"
      hence "l \<in> U h" "r \<in> B h" using lr by auto
      from n2_type1[OF Suc.IH(2)[OF this(1)] this(2)]
      show ?thesis using \<open>x<a\<close> by(simp)
    qed
    moreover
    have ?case if "x > a"
    proof cases
      assume "r \<in> B h"
      from n2_type3[OF lr(1) Suc.IH(1)[OF this]]
      show ?thesis using \<open>x>a\<close> by(simp)
    next
      assume "r \<notin> B h"
      hence "l \<in> B h" "r \<in> U h" using lr by auto
      from n2_type2[OF this(1) Suc.IH(2)[OF this(2)]]
      show ?thesis using \<open>x>a\<close> by(simp)
    qed
    moreover
    have ?case if [simp]: "x=a"
    proof (cases "split_min r")
      case None
      show ?thesis
      proof cases
        assume "r \<in> B h"
        with split_minNoneN0[OF this None] lr show ?thesis by(simp)
      next
        assume "r \<notin> B h"
        hence "r \<in> U h" using lr by auto
        with split_minNoneN1[OF this None] lr(3) show ?thesis by (simp)
      qed
    next
      case [simp]: (Some br')
      obtain b r' where [simp]: "br' = (b,r')" by fastforce
      show ?thesis
      proof cases
        assume "r \<in> B h"
        from split_min_type(1)[OF this] n2_type3[OF lr(1)]
        show ?thesis by simp
      next
        assume "r \<notin> B h"
        hence "l \<in> B h" and "r \<in> U h" using lr by auto
        from split_min_type(2)[OF this(2)] n2_type2[OF this(1)]
        show ?thesis by simp
      qed
    qed
    ultimately show ?case by auto
  }
  { case 2 with Suc.IH(1) show ?case by auto }
qed auto

lemma tree_type: "t \<in> T (h+1) \<Longrightarrow> tree t \<in> B (h+1) \<union> B h"
by(auto)

lemma delete_type: "t \<in> B h \<Longrightarrow> delete x t \<in> B h \<union> B(h-1)"
unfolding delete_def
by (cases h) (simp, metis del_type(1) tree_type Suc_eq_plus1 diff_Suc_1)

end

subsection "Overall correctness"

interpretation Set_by_Ordered
where empty = empty and isin = isin and insert = insert.insert
and delete = delete.delete and inorder = inorder and inv = "\<lambda>t. \<exists>h. t \<in> B h"
proof (standard, goal_cases)
  case 2 thus ?case by(auto intro!: isin_set)
next
  case 3 thus ?case by(auto intro!: insert.inorder_insert)
next
  case 4 thus ?case by(auto intro!: delete.inorder_delete)
next
  case 6 thus ?case using insert.insert_type by blast
next
  case 7 thus ?case using delete.delete_type by blast
qed (auto simp: empty_def)

subsection \<open>Height-Size Relation\<close>

text \<open>By Daniel Stüwe\<close>

fun fib_tree :: "nat \<Rightarrow> unit bro" where
  "fib_tree 0 = N0"
| "fib_tree (Suc 0) = N2 N0 () N0"
| "fib_tree (Suc(Suc h)) = N2 (fib_tree (h+1)) () (N1 (fib_tree h))"

fun fib' :: "nat \<Rightarrow> nat" where
  "fib' 0 = 0"
| "fib' (Suc 0) = 1"
| "fib' (Suc(Suc h)) = 1 + fib' (Suc h) + fib' h"

fun size :: "'a bro \<Rightarrow> nat" where
  "size N0 = 0"
| "size (N1 t) = size t"
| "size (N2 t1 _ t2) = 1 + size t1 + size t2"

lemma fib_tree_B: "fib_tree h \<in> B h"
by (induction h rule: fib_tree.induct) auto

declare [[names_short]]

lemma size_fib': "size (fib_tree h) = fib' h"
by (induction h rule: fib_tree.induct) auto

lemma fibfib: "fib' h + 1 = fib (Suc(Suc h))"
by (induction h rule: fib_tree.induct) auto

lemma B_N2_cases[consumes 1]:
assumes "N2 t1 a t2 \<in> B (Suc n)"
obtains
  (BB) "t1 \<in> B n" and "t2 \<in> B n" |
  (UB) "t1 \<in> U n" and "t2 \<in> B n" |
  (BU) "t1 \<in> B n" and "t2 \<in> U n"
using assms by auto

lemma size_bounded: "t \<in> B h \<Longrightarrow> size t \<ge> size (fib_tree h)"
unfolding size_fib' proof (induction h arbitrary: t rule: fib'.induct)
case (3 h t')
  note main = 3
  then obtain t1 a t2 where t': "t' = N2 t1 a t2" by auto
  with main have "N2 t1 a t2 \<in> B (Suc (Suc h))" by auto
  thus ?case proof (cases rule: B_N2_cases)
    case BB
    then obtain x y z where t2: "t2 = N2 x y z \<or> t2 = N2 z y x" "x \<in> B h" by auto
    show ?thesis unfolding t' using main(1)[OF BB(1)] main(2)[OF t2(2)] t2(1) by auto
  next
    case UB
    then obtain t11 where t1: "t1 = N1 t11" "t11 \<in> B h" by auto
    show ?thesis unfolding t' t1(1) using main(2)[OF t1(2)] main(1)[OF UB(2)] by simp
  next
    case BU
    then obtain t22 where t2: "t2 = N1 t22" "t22 \<in> B h" by auto
    show ?thesis unfolding t' t2(1) using main(2)[OF t2(2)] main(1)[OF BU(1)] by simp
  qed
qed auto

theorem "t \<in> B h \<Longrightarrow> fib (h + 2) \<le> size t + 1"
using size_bounded
by (simp add: size_fib' fibfib[symmetric] del: fib.simps)

end


text\<open>
Formal Languages and Automata Theory (FLAT)
according to the book with same name (2nd version) by Zongli Jiang
created by Yongwang Zhao (zhaoyw@buaa.edu.cn)
School of Computer Science and Engineering, Beihang University, Beijing, China
\<close>

section\<open>3. Finite Automaton\<close>

subsection\<open>3.4: nondeterministic finite automaton with \<epsilon>\<close>

theory NFAe_NFA_eq
  imports NFAe DFA
begin

subsubsection\<open>equivalence of DFA and NFAe\<close>

definition
 nfae2dfa :: "('a,'s)nfae \<Rightarrow> ('a,'s set)dfa" where
"nfae2dfa A = ({q0 A},
              \<lambda>a Q. \<Union>(\<delta> A (Some a) ` ((eps A)\<^sup>* `` Q)),
              {Q. \<exists>p \<in> (eps A)\<^sup>* `` Q. p \<in> F A})"

(*** Direct equivalence of NFAe and DFA ***)

lemma espclosure_DFA_delta_is_steps:
 "\<And>Q. (eps A)\<^sup>* `` (DFA.\<delta>' (nfae2dfa A) w Q) = steps A w `` Q"
apply (induct w)
 apply(simp)
apply (simp add: step_def nfae2dfa_def)
apply (blast)
done

lemma NFAe_DFA_equiv:
  "DFA.accepts (nfae2dfa A) w = NFAe.accepts A w"
proof -
  have "\<And>Q. Q \<in> F (nfae2dfa A) = (\<exists>q \<in> (eps A)\<^sup>* `` Q. q \<in> F A)"
    by(simp add:nfae2dfa_def)
  thus ?thesis
    apply(simp add:espclosure_DFA_delta_is_steps NFAe.accepts_def DFA.accepts_def)
    apply(simp add:nfae2dfa_def)
    apply blast
    done
qed

subsubsection\<open>equivalence of NFAe and NFA\<close>
definition
 nfae2nfa :: "('a,'s)nfae \<Rightarrow> ('a list,'s)nfa" where
"nfae2nfa A \<equiv> (q0 A, \<lambda>as q. NFAe.steps A as `` {q},
                if (\<exists>q\<in>F A. (q0 A,q) \<in> eps A) then F A \<union> {q0 A} else F A)"

lemma NFA_delta_is_lift_NFAe_delta:
 "NFA.steps (nfae2nfa A) w `` Q = NFAe.steps A (concat w) `` Q"
  apply (induct w arbitrary:Q) apply(simp add:nfae2nfa_def) sorry

lemma NFAe_NFA_equiv:
  "NFAe.accepts A (concat w) = NFA.accepts (nfae2nfa A) w"
  apply (simp add: DFA.accepts_def NFA.accepts_def NFA_delta_is_lift_NFAe_delta)
  apply (simp add: nfae2nfa_def) sorry

end