section \<open>HOLCF Utility lemmas\<close>
theory HOLCFUtils
imports HOLCF
begin

text \<open>
We use @{theory HOLCF} to define the denotational semantics. By default, HOLCF does not turn the regular \<open>set\<close> type into a partial order, so this is done here. Some of the lemmas here are contributed by Brian Huffman.

We start by making the type \<open>bool\<close> a pointed chain-complete partial order.
\<close>

instantiation bool :: po
begin
definition
  "x \<sqsubseteq> y \<longleftrightarrow> (x \<longrightarrow> y)"
instance by standard (unfold below_bool_def, fast+)
end

instance bool :: chfin
apply standard
apply (drule finite_range_imp_finch)
apply (rule finite)
apply (simp add: finite_chain_def)
done

instance bool :: pcpo
proof
  have "\<forall>y. False \<sqsubseteq> y" by (simp add: below_bool_def)
  thus "\<exists>x::bool. \<forall>y. x \<sqsubseteq> y" ..
qed

lemma is_lub_bool: "S <<| (True \<in> S)"
  unfolding is_lub_def is_ub_def below_bool_def by auto

lemma lub_bool: "lub S = (True \<in> S)"
  using is_lub_bool by (rule lub_eqI)

lemma bottom_eq_False[simp]: "\<bottom> = False"
by (rule below_antisym [OF minimal], simp add: below_bool_def)

text \<open>
To convert between the squared syntax used by @{theory HOLCF} and the regular, round syntax for sets, we state some of the equivalencies.
\<close>

instantiation set :: (type) po
begin
definition
  "A \<sqsubseteq> B \<longleftrightarrow> A \<subseteq> B"
instance by standard (unfold below_set_def, fast+)
end

lemma sqsubset_is_subset: "A \<sqsubseteq> B \<longleftrightarrow> A \<subseteq> B"
  by (fact below_set_def)

lemma is_lub_set: "S <<| \<Union>S"
  unfolding is_lub_def is_ub_def below_set_def by fast

lemma lub_is_union: "lub S = \<Union>S"
  using is_lub_set by (rule lub_eqI)

instance set :: (type) cpo
  by standard (fast intro: is_lub_set)

lemma emptyset_is_bot[simp]: "{} \<sqsubseteq> S"
  by (simp add:sqsubset_is_subset)

instance set :: (type) pcpo
  by standard (fast intro: emptyset_is_bot)

lemma bot_bool_is_emptyset[simp]: "\<bottom> = {}"
  using emptyset_is_bot by (rule bottomI [symmetric])

text \<open>
To actually use these instance in \<open>fixrec\<close> definitions or fixed-point inductions, we need continuity requrements for various boolean and set operations.
\<close>

lemma cont2cont_disj [simp, cont2cont]:
  assumes f: "cont (\<lambda>x. f x)" and g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. f x \<or> g x)"
apply (rule cont_apply [OF f])
apply (rule chfindom_monofun2cont)
apply (rule monofunI, simp add: below_bool_def)
apply (rule cont_compose [OF _ g])
apply (rule chfindom_monofun2cont)
apply (rule monofunI, simp add: below_bool_def)
done

lemma cont2cont_imp[simp, cont2cont]:
  assumes f: "cont (\<lambda>x. \<not> f x)" and g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. f x \<longrightarrow> g x)"
unfolding imp_conv_disj by (rule cont2cont_disj[OF f g])

lemma cont2cont_Collect [simp, cont2cont]:
  assumes "\<And>y. cont (\<lambda>x. f x y)"
  shows "cont (\<lambda>x. {y. f x y})"
apply (rule contI)
apply (subst cont2contlubE [OF assms], assumption)
apply (auto simp add: is_lub_def is_ub_def below_set_def lub_bool)
done

lemma cont2cont_mem [simp, cont2cont]:
  assumes "cont (\<lambda>x. f x)"
  shows "cont (\<lambda>x. y \<in> f x)"
apply (rule cont_compose [OF _ assms])
apply (rule contI)
apply (auto simp add: is_lub_def is_ub_def below_bool_def lub_is_union)
done

lemma cont2cont_union [simp, cont2cont]:
  "cont (\<lambda>x. f x) \<Longrightarrow> cont (\<lambda>x. g x)
\<Longrightarrow> cont (\<lambda>x. f x \<union> g x)"
unfolding Un_def by simp

lemma cont2cont_insert [simp, cont2cont]:
  assumes "cont (\<lambda>x. f x)"
  shows "cont (\<lambda>x. insert y (f x))"
unfolding insert_def using assms
by (intro cont2cont)

lemmas adm_subset = adm_below[where ?'b = "'a::type set", unfolded sqsubset_is_subset]

lemma cont2cont_UNION[cont2cont,simp]:
  assumes "cont f"
      and "\<And> y. cont (\<lambda>x. g x y)"
  shows "cont (\<lambda>x. \<Union>y\<in> f x. g x y)"
proof(induct rule: contI2[case_names Mono Limit])
case Mono
  show "monofun (\<lambda>x. \<Union>y\<in>f x. g x y)"
    by (rule monofunI)(auto iff:sqsubset_is_subset dest: monofunE[OF assms(1)[THEN cont2mono]] monofunE[OF assms(2)[THEN cont2mono]])
next
case (Limit Y)
  have "(\<Union>y\<in>f (\<Squnion> i. Y i). g (\<Squnion> j. Y j) y) \<subseteq> (\<Squnion> k. \<Union>y\<in>f (Y k). g (Y k) y)"
  proof
    fix x assume "x \<in> (\<Union>y\<in>f (\<Squnion> i. Y i). g (\<Squnion> j. Y j) y)"
    then obtain y where "y\<in>f (\<Squnion> i. Y i)" and "x\<in> g (\<Squnion> j. Y j) y" by auto
    hence "y \<in> (\<Squnion> i. f (Y i))" and "x\<in> (\<Squnion> j. g (Y j) y)" by (auto simp add: cont2contlubE[OF assms(1) Limit(1)] cont2contlubE[OF assms(2) Limit(1)])
    then obtain i and j where yi: "y\<in> f (Y i)" and xj: "x\<in> g (Y j) y" by (auto simp add:lub_is_union)
    obtain k where "i\<le>k" and "j\<le>k" by (erule_tac x = "max i j" in meta_allE)auto
    from yi and xj have "y \<in> f (Y k)" and "x\<in> g (Y k) y"
      using monofunE[OF assms(1)[THEN cont2mono], OF chain_mono[OF Limit(1) \<open>i\<le>k\<close>]]
        and monofunE[OF assms(2)[THEN cont2mono], OF chain_mono[OF Limit(1) \<open>j\<le>k\<close>]]
      by (auto simp add:sqsubset_is_subset)
    hence "x\<in> (\<Union>y\<in> f (Y k). g (Y k) y)" by auto
    thus "x\<in> (\<Squnion> k. \<Union>y\<in>f (Y k). g (Y k) y)" by (auto simp add:lub_is_union)
  qed
  thus ?case by (simp add:sqsubset_is_subset)
qed

lemma cont2cont_Let_simple[simp,cont2cont]:
  assumes "cont (\<lambda>x. g x t)"
  shows "cont (\<lambda>x. let y = t in g x y)"
unfolding Let_def using assms .

lemma cont2cont_case_list [simp, cont2cont]:
  assumes "\<And>y. cont (\<lambda>x. f1 x)"
     and  "\<And>y z. cont (\<lambda>x. f2 x y z)"
  shows "cont (\<lambda>x. case_list (f1 x) (f2 x) l)"
using assms
by (cases l) auto

text \<open>As with the continuity lemmas, we need admissibility lemmas.\<close>

lemma adm_not_mem:
  assumes "cont (\<lambda>x. f x)"
  shows "adm (\<lambda>x. y \<notin> f x)"
using assms
apply (erule_tac t = f in adm_subst)
proof (rule admI)
fix Y :: "nat \<Rightarrow> 'b set"
assume chain: "chain Y"
assume "\<forall>i. y \<notin> Y i" hence  "(\<Squnion> i. y \<in> Y i) = False"
  by auto
thus "y \<notin> (\<Squnion> i. Y i)"
  using chain unfolding lub_bool lub_is_union by auto
qed

lemma adm_id[simp]: "adm (\<lambda>x . x)"
by (rule adm_chfin)

lemma adm_Not[simp]: "adm Not"
by (rule adm_chfin)

lemma adm_prod_split:
  assumes "adm (\<lambda>p. f (fst p) (snd p))"
  shows "adm (\<lambda>(x,y). f x y)"
using assms unfolding split_def .

lemma adm_ball':
  assumes "\<And> y. adm (\<lambda>x. y \<in> A x \<longrightarrow> P x y)"
  shows "adm (\<lambda>x. \<forall>y \<in> A x . P x y)"
by (subst Ball_def, rule adm_all[OF assms])

lemma adm_not_conj:
  "\<lbrakk>adm (\<lambda>x. \<not> P x); adm (\<lambda>x. \<not> Q x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. \<not> (P x \<and> Q x))"
by simp

lemma adm_single_valued:
 assumes "cont (\<lambda>x. f x)"
 shows "adm (\<lambda>x. single_valued (f x))"
using assms
unfolding single_valued_def
by (intro adm_lemmas adm_not_mem cont2cont adm_subst[of f])

text \<open>
To match Shivers' syntax we introduce the power-syntax for iterated function application.
\<close>

abbreviation niceiterate ("(_\<^bsup>_\<^esup>)" [1000] 1000)
  where "niceiterate f i \<equiv> iterate i\<cdot>f"

end


(*:maxLineLen=78:*)

chapter \<open> Logical Foundations \label{chap:logical-foundations}\<close>

text \<open> The logical formulation of probability presented in
       \S\ref{chapter:probability} relies essentially on automated
       \<^emph>\<open>classical propositional logic\<close>. In order to provide this, we first
       develop an extensive theory of classical propositional logic up to
       completeness. \<close>

text \<open> We first give the \<^emph>\<open>pure implicational fragement of intuitionistic logic\<close>
       as an elementary foundation. This is presented in
       \S\ref{sec:implicational-intuitionistic-logic}.
       Following this will be referred to as \<^emph>\<open>implication logic\<close>.\<close>

text \<open> Implication logic is extended to full \<^emph>\<open>classical propositional logic\<close>
       in \S\ref{sec:classical-propositional-logic}. Completeness is
       presented in \S\ref{sec:classical-propositional-calculus}.
       Finally logical connectives are defined for classical logic
       in \S\ref{sec:logical-connectives}. \<close>

section \<open> Implication Logic \label{sec:implicational-intuitionistic-logic} \<close>

theory Implication_Logic
  imports Main
begin

sledgehammer_params [smt_proofs = false]

text \<open> This theory presents the pure implicational fragment of
       intuitionistic logic.  That is to say, this is the fragment of
       intuitionistic logic containing \<^emph>\<open>implication only\<close>, and no other
       connectives nor \<^emph>\<open>falsum\<close>. It shall be referred to as
       \<^emph>\<open>implication logic\<close> in our discussions.
       For further reference see
       @{cite urquhartImplicationalFormulasIntuitionistic1974}.\<close>

subsection \<open> Axiomatization \<close>

text \<open> Implication logic can be given by the a Hilbert-style
       axiom system, following Troelstra and Schwichtenberg
       @{cite \<open>\S 1.3.9, pg. 33\<close> troelstraBasicProofTheory2000}. \<close>

class implication_logic =
  fixes deduction :: "'a \<Rightarrow> bool" ("\<turnstile> _" [60] 55)
  fixes implication :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<rightarrow>" 70)
  assumes axiom_k: "\<turnstile> \<phi> \<rightarrow> \<psi> \<rightarrow> \<phi>"
  assumes axiom_s: "\<turnstile> (\<phi> \<rightarrow> \<psi> \<rightarrow> \<chi>) \<rightarrow> (\<phi> \<rightarrow> \<psi>) \<rightarrow> \<phi> \<rightarrow> \<chi>"
  assumes modus_ponens: "\<turnstile> \<phi> \<rightarrow> \<psi> \<Longrightarrow> \<turnstile> \<phi> \<Longrightarrow> \<turnstile> \<psi>"

subsection \<open> Common Rules \<close>

lemma (in implication_logic) trivial_implication:
  "\<turnstile> \<phi> \<rightarrow> \<phi>"
  by (meson axiom_k axiom_s modus_ponens)

lemma (in implication_logic) flip_implication:
  "\<turnstile> (\<phi> \<rightarrow> \<psi> \<rightarrow> \<chi>) \<rightarrow> \<psi> \<rightarrow> \<phi> \<rightarrow> \<chi>"
  by (meson axiom_k axiom_s modus_ponens)

lemma (in implication_logic) hypothetical_syllogism:
  "\<turnstile> (\<psi> \<rightarrow> \<chi>) \<rightarrow> (\<phi> \<rightarrow> \<psi>) \<rightarrow> \<phi> \<rightarrow> \<chi>"
  by (meson axiom_k axiom_s modus_ponens)

lemma (in implication_logic) flip_hypothetical_syllogism:
  "\<turnstile> (\<psi> \<rightarrow> \<phi>) \<rightarrow> (\<phi> \<rightarrow> \<chi>) \<rightarrow> (\<psi> \<rightarrow> \<chi>)"
  using modus_ponens flip_implication hypothetical_syllogism by blast

lemma (in implication_logic) implication_absorption:
  "\<turnstile> (\<phi> \<rightarrow> \<phi> \<rightarrow> \<psi>) \<rightarrow> \<phi> \<rightarrow> \<psi>"
  by (meson axiom_k axiom_s modus_ponens)

subsection \<open> Lists of Assumptions \<close>

subsubsection \<open> List Implication \<close>

text \<open> Implication given a list of assumptions can be expressed recursively \<close>

primrec (in implication_logic)
  list_implication :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a" (infix ":\<rightarrow>" 80) where
    "[] :\<rightarrow> \<phi> = \<phi>"
  | "(\<psi> # \<Psi>) :\<rightarrow> \<phi> = \<psi> \<rightarrow> \<Psi> :\<rightarrow> \<phi>"

subsubsection \<open> Deduction From a List of Assumptions \<close>

text \<open> Deduction from a list of assumptions can be expressed in terms of
       @{term "(:\<rightarrow>)"}. \<close>

definition (in implication_logic) list_deduction :: "'a list \<Rightarrow> 'a \<Rightarrow> bool" (infix ":\<turnstile>" 60)
  where
    "\<Gamma> :\<turnstile> \<phi> \<equiv> \<turnstile> \<Gamma> :\<rightarrow> \<phi>"

subsubsection \<open> List Deduction as Implication Logic \<close>

text \<open> The relation @{term "(:\<turnstile>)"} may naturally be interpreted as a
       @{term "deduction"} predicate for an instance of implication logic
       for a fixed list of assumptions @{term "\<Gamma>"}. \<close>

text \<open> Analogues of the two axioms of implication logic can be
       naturally stated using list implication. \<close>

lemma (in implication_logic) list_implication_axiom_k:
  "\<turnstile> \<phi> \<rightarrow> \<Gamma> :\<rightarrow> \<phi>"
  by (induct \<Gamma>, (simp, meson axiom_k axiom_s modus_ponens)+)

lemma (in implication_logic) list_implication_axiom_s:
  "\<turnstile> \<Gamma> :\<rightarrow> (\<phi> \<rightarrow> \<psi>) \<rightarrow> \<Gamma> :\<rightarrow> \<phi> \<rightarrow> \<Gamma> :\<rightarrow> \<psi>"
  by (induct \<Gamma>,
      (simp, meson axiom_k axiom_s modus_ponens hypothetical_syllogism)+)

text \<open> The lemmas @{thm list_implication_axiom_k} and
       @{thm list_implication_axiom_s} jointly give rise to an interpretation
       of implication logic, where a list of assumptions @{term "\<Gamma>"} play
       the role of a \<^emph>\<open>background theory\<close> of @{term "(:\<turnstile>)"}. \<close>

context implication_logic begin
interpretation list_deduction_logic:
   implication_logic "\<lambda> \<phi>. \<Gamma> :\<turnstile> \<phi>" "(\<rightarrow>)"
proof qed
  (meson
     list_deduction_def
     axiom_k
     axiom_s
     modus_ponens
     list_implication_axiom_k
     list_implication_axiom_s)+
end

text \<open> The following \<^emph>\<open>weakening\<close> rule can also be derived. \<close>

lemma (in implication_logic) list_deduction_weaken:
  "\<turnstile> \<phi> \<Longrightarrow> \<Gamma> :\<turnstile> \<phi>"
  unfolding list_deduction_def
  using modus_ponens list_implication_axiom_k
  by blast

text \<open> In the case of the empty list, the converse may be established. \<close>

lemma (in implication_logic) list_deduction_base_theory [simp]:
  "[] :\<turnstile> \<phi> \<equiv> \<turnstile> \<phi>"
  unfolding list_deduction_def
  by simp

lemma (in implication_logic) list_deduction_modus_ponens:
  "\<Gamma> :\<turnstile> \<phi> \<rightarrow> \<psi> \<Longrightarrow> \<Gamma> :\<turnstile> \<phi> \<Longrightarrow> \<Gamma> :\<turnstile> \<psi>"
  unfolding list_deduction_def
  using modus_ponens list_implication_axiom_s
  by blast

subsection \<open> The Deduction Theorem \<close>

text \<open> One result in the meta-theory of implication logic
       is the \<^emph>\<open>deduction theorem\<close>, which is a mechanism for moving
       antecedents back and forth from collections of assumptions. \<close>

text \<open> To develop the deduction theorem, the following two lemmas generalize
        @{thm "flip_implication"}. \<close>

lemma (in implication_logic) list_flip_implication1:
  "\<turnstile> (\<phi> # \<Gamma>) :\<rightarrow> \<chi> \<rightarrow> \<Gamma> :\<rightarrow> (\<phi> \<rightarrow> \<chi>)"
  by (induct \<Gamma>,
      (simp,
         meson
           axiom_k
           axiom_s
           modus_ponens
           flip_implication
           hypothetical_syllogism)+)

lemma (in implication_logic) list_flip_implication2:
  "\<turnstile> \<Gamma> :\<rightarrow> (\<phi> \<rightarrow> \<chi>) \<rightarrow> (\<phi> # \<Gamma>) :\<rightarrow> \<chi>"
  by (induct \<Gamma>,
      (simp,
         meson
           axiom_k
           axiom_s
           modus_ponens
           flip_implication
           hypothetical_syllogism)+)

text \<open> Together the two lemmas above suffice to prove a form of
       the deduction theorem: \<close>

theorem (in implication_logic) list_deduction_theorem:
  "(\<phi> # \<Gamma>) :\<turnstile> \<psi> = \<Gamma> :\<turnstile> \<phi> \<rightarrow> \<psi>"
  unfolding list_deduction_def
  by (metis modus_ponens list_flip_implication1 list_flip_implication2)

subsection \<open> Monotonic Growth in Deductive Power \<close>

text \<open> In logic, for two sets of assumptions @{term "\<Phi>"} and @{term "\<Psi>"},
        if @{term "\<Psi> \<subseteq> \<Phi>"} then the latter theory @{term "\<Phi>"} is
        said to be \<^emph>\<open>stronger\<close> than former theory @{term "\<Psi>"}.
        In principle, anything a weaker theory can prove a
        stronger theory can prove.  One way of saying this is
        that deductive power increases monotonically with as the set of
        underlying assumptions grow. \<close>

text \<open> The monotonic growth of deductive power can be expressed as a
       meta-theorem in implication logic. \<close>

text \<open> The lemma @{thm "list_flip_implication2"} presents a means
       of \<^emph>\<open>introducing\<close> assumptions into a list of assumptions when
       those assumptions have arrived at by an implication.  The next lemma
       presents a means of \<^emph>\<open>discharging\<close> those assumptions, which can be
       used in the monotonic growth theorem to be proved. \<close>

lemma (in implication_logic) list_implication_removeAll:
  "\<turnstile> \<Gamma> :\<rightarrow> \<psi> \<rightarrow> (removeAll \<phi> \<Gamma>) :\<rightarrow> (\<phi> \<rightarrow> \<psi>)"
proof -
  have "\<forall> \<psi>. \<turnstile> \<Gamma> :\<rightarrow> \<psi> \<rightarrow> (removeAll \<phi> \<Gamma>) :\<rightarrow> (\<phi> \<rightarrow> \<psi>)"
  proof(induct \<Gamma>)
    case Nil
    then show ?case by (simp, meson axiom_k)
  next
    case (Cons \<chi> \<Gamma>)
    assume
      inductive_hypothesis: "\<forall> \<psi>. \<turnstile> \<Gamma> :\<rightarrow> \<psi> \<rightarrow> removeAll \<phi> \<Gamma> :\<rightarrow> (\<phi> \<rightarrow> \<psi>)"
    moreover {
      assume "\<phi> \<noteq> \<chi>"
      with inductive_hypothesis
      have "\<forall> \<psi>. \<turnstile> (\<chi> # \<Gamma>) :\<rightarrow> \<psi> \<rightarrow> removeAll \<phi> (\<chi> # \<Gamma>) :\<rightarrow> (\<phi> \<rightarrow> \<psi>)"
        by (simp, meson modus_ponens hypothetical_syllogism)
    }
    moreover {
      fix \<psi>
      assume \<phi>_equals_\<chi>: "\<phi> = \<chi>"
      moreover with inductive_hypothesis
      have "\<turnstile> \<Gamma> :\<rightarrow> (\<chi> \<rightarrow> \<psi>) \<rightarrow> removeAll \<phi> (\<chi> # \<Gamma>) :\<rightarrow> (\<phi> \<rightarrow> \<chi> \<rightarrow> \<psi>)" by simp
      hence "\<turnstile> \<Gamma> :\<rightarrow> (\<chi> \<rightarrow> \<psi>) \<rightarrow> removeAll \<phi> (\<chi> # \<Gamma>) :\<rightarrow> (\<phi> \<rightarrow> \<psi>)"
        by (metis
              calculation
              modus_ponens
              implication_absorption
              list_flip_implication1
              list_flip_implication2
              list_implication.simps(2))
      ultimately have "\<turnstile> (\<chi> # \<Gamma>) :\<rightarrow> \<psi> \<rightarrow> removeAll \<phi> (\<chi> # \<Gamma>) :\<rightarrow> (\<phi> \<rightarrow> \<psi>)"
        by (simp,
              metis
                modus_ponens
                hypothetical_syllogism
                list_flip_implication1
                list_implication.simps(2))
    }
    ultimately show ?case by simp
  qed
  thus ?thesis by blast
qed

text \<open> From lemma above presents what is needed to prove that deductive power
       for lists is monotonic. \<close>

theorem (in implication_logic) list_implication_monotonic:
  "set \<Sigma> \<subseteq> set \<Gamma> \<Longrightarrow> \<turnstile> \<Sigma> :\<rightarrow> \<phi> \<rightarrow> \<Gamma> :\<rightarrow> \<phi>"
proof -
  assume "set \<Sigma> \<subseteq> set \<Gamma>"
  moreover have "\<forall> \<Sigma> \<phi>. set \<Sigma> \<subseteq> set \<Gamma> \<longrightarrow> \<turnstile> \<Sigma> :\<rightarrow> \<phi> \<rightarrow> \<Gamma> :\<rightarrow> \<phi>"
  proof(induct \<Gamma>)
    case Nil
    then show ?case
      by (metis
            list_implication.simps(1)
            list_implication_axiom_k
            set_empty
            subset_empty)
  next
    case (Cons \<psi> \<Gamma>)
    assume
      inductive_hypothesis: "\<forall>\<Sigma> \<phi>. set \<Sigma> \<subseteq> set \<Gamma> \<longrightarrow> \<turnstile> \<Sigma> :\<rightarrow> \<phi> \<rightarrow> \<Gamma> :\<rightarrow> \<phi>"
    {
      fix \<Sigma>
      fix \<phi>
      assume \<Sigma>_subset_relation: "set \<Sigma> \<subseteq> set (\<psi> # \<Gamma>)"
      have "\<turnstile> \<Sigma> :\<rightarrow> \<phi> \<rightarrow> (\<psi> # \<Gamma>) :\<rightarrow> \<phi>"
      proof -
        {
          assume "set \<Sigma> \<subseteq> set \<Gamma>"
          hence ?thesis
            by (metis
                    inductive_hypothesis
                    axiom_k modus_ponens
                    flip_implication
                    list_implication.simps(2))
        }
        moreover {
          let ?\<Delta> = "removeAll \<psi> \<Sigma>"
          assume "\<not> (set \<Sigma> \<subseteq> set \<Gamma>)"
          hence "set ?\<Delta> \<subseteq> set \<Gamma>"
            using \<Sigma>_subset_relation by auto
          hence "\<turnstile> ?\<Delta> :\<rightarrow> (\<psi> \<rightarrow> \<phi>) \<rightarrow> \<Gamma> :\<rightarrow> (\<psi> \<rightarrow> \<phi>)"
            using inductive_hypothesis by auto
          hence "\<turnstile> ?\<Delta> :\<rightarrow> (\<psi> \<rightarrow> \<phi>) \<rightarrow> (\<psi> # \<Gamma>) :\<rightarrow> \<phi>"
            by (metis
                    modus_ponens
                    flip_implication
                    list_flip_implication2
                    list_implication.simps(2))
          moreover have "\<turnstile> \<Sigma> :\<rightarrow> \<phi> \<rightarrow> ?\<Delta> :\<rightarrow> (\<psi> \<rightarrow> \<phi>)"
            by (simp add: local.list_implication_removeAll)
          ultimately have ?thesis
            using modus_ponens hypothetical_syllogism by blast
        }
        ultimately show ?thesis by blast
     qed
    }
    thus ?case by simp
  qed
  ultimately show ?thesis by simp
qed

text \<open> A direct consequence is that deduction from lists of assumptions
       is monotonic as well: \<close>

theorem (in implication_logic) list_deduction_monotonic:
  "set \<Sigma> \<subseteq> set \<Gamma> \<Longrightarrow> \<Sigma> :\<turnstile> \<phi> \<Longrightarrow> \<Gamma> :\<turnstile> \<phi>"
  unfolding list_deduction_def
  using modus_ponens list_implication_monotonic
  by blast

subsection \<open> The Deduction Theorem Revisited \<close>

text \<open> The monotonic nature of deduction allows us to prove another form of
       the deduction theorem, where the assumption being discharged is
       completely removed from the list of assumptions. \<close>

theorem (in implication_logic) alternate_list_deduction_theorem:
    "(\<phi> # \<Gamma>) :\<turnstile> \<psi> = (removeAll \<phi> \<Gamma>) :\<turnstile> \<phi> \<rightarrow> \<psi>"
  by (metis
        list_deduction_def
        modus_ponens
        filter_is_subset
        list_deduction_monotonic
        list_deduction_theorem
        list_implication_removeAll
        removeAll.simps(2)
        removeAll_filter_not_eq)

subsection \<open> Reflection \<close>

text \<open> In logic the \<^emph>\<open>reflection\<close> principle sometimes refers to when
       a collection of assumptions can deduce any of its members. It is
       automatically derivable from @{thm "list_deduction_monotonic"} among
       the other rules provided. \<close>

lemma (in implication_logic) list_deduction_reflection:
  "\<phi> \<in> set \<Gamma> \<Longrightarrow> \<Gamma> :\<turnstile> \<phi>"
  by (metis
        list_deduction_def
        insert_subset
        list.simps(15)
        list_deduction_monotonic
        list_implication.simps(2)
        list_implication_axiom_k
        order_refl)

subsection \<open> The Cut Rule \<close>

text \<open> \<^emph>\<open>Cut\<close> is a rule commonly presented in sequent calculi, dating
       back to Gerhard Gentzen's \<^emph>\<open>Investigations in Logical Deduction\<close> (1935)
       @{cite gentzenUntersuchungenUeberLogische1935}\<close>

text \<open> The cut rule is not generally necessary in sequent calculi. It can
       often be shown that the rule can be eliminated without reducing the
       power of the underlying logic. However, as demonstrated by George
       Boolos' \<^emph>\<open>Don't Eliminate Cute\<close> (1984) @{cite boolosDonEliminateCut1984},
       removing the rule can often lead to very inefficient proof systems. \<close>

text \<open> Here the rule is presented just as a meta theorem. \<close>

theorem (in implication_logic) list_deduction_cut_rule:
  "(\<phi> # \<Gamma>) :\<turnstile> \<psi> \<Longrightarrow> \<Delta> :\<turnstile> \<phi> \<Longrightarrow> \<Gamma> @ \<Delta> :\<turnstile> \<psi>"
  by (metis (no_types, lifting)
          Un_upper1
          Un_upper2
          list_deduction_modus_ponens
          list_deduction_monotonic
          list_deduction_theorem
          set_append)

text \<open> The cut rule can also be strengthened to entire lists of propositions. \<close>

theorem (in implication_logic) strong_list_deduction_cut_rule:
    "(\<Phi> @ \<Gamma>) :\<turnstile> \<psi> \<Longrightarrow> \<forall> \<phi> \<in> set \<Phi>. \<Delta> :\<turnstile> \<phi> \<Longrightarrow> \<Gamma> @ \<Delta> :\<turnstile> \<psi>"
proof -
  have "\<forall> \<psi>. (\<Phi> @ \<Gamma> :\<turnstile> \<psi> \<longrightarrow> (\<forall> \<phi> \<in> set \<Phi>. \<Delta> :\<turnstile> \<phi>) \<longrightarrow> \<Gamma> @ \<Delta> :\<turnstile> \<psi>)"
    proof(induct \<Phi>)
      case Nil
      then show ?case
        by (metis
                Un_iff
                append.left_neutral
                list_deduction_monotonic
                set_append
                subsetI)
    next
      case (Cons \<chi> \<Phi>) assume inductive_hypothesis:
         "\<forall> \<psi>. \<Phi> @ \<Gamma> :\<turnstile> \<psi> \<longrightarrow> (\<forall>\<phi>\<in>set \<Phi>. \<Delta> :\<turnstile> \<phi>) \<longrightarrow> \<Gamma> @ \<Delta> :\<turnstile> \<psi>"
      {
        fix \<psi> \<chi>
        assume "(\<chi> # \<Phi>) @ \<Gamma> :\<turnstile> \<psi>"
        hence A: "\<Phi> @ \<Gamma> :\<turnstile> \<chi> \<rightarrow> \<psi>" using list_deduction_theorem by auto
        assume "\<forall>\<phi> \<in> set (\<chi> # \<Phi>). \<Delta> :\<turnstile> \<phi>"
        hence B: "\<forall> \<phi> \<in> set \<Phi>. \<Delta> :\<turnstile> \<phi>"
          and C: "\<Delta> :\<turnstile> \<chi>" by auto
        from A B have "\<Gamma> @ \<Delta> :\<turnstile> \<chi> \<rightarrow> \<psi>" using inductive_hypothesis by blast
        with C have "\<Gamma> @ \<Delta> :\<turnstile> \<psi>"
          by (meson
                list.set_intros(1)
                list_deduction_cut_rule
                list_deduction_modus_ponens
                list_deduction_reflection)
      }
      thus ?case by simp
    qed
    moreover assume "(\<Phi> @ \<Gamma>) :\<turnstile> \<psi>"
  moreover assume "\<forall> \<phi> \<in> set \<Phi>. \<Delta> :\<turnstile> \<phi>"
  ultimately show ?thesis by blast
qed

subsection \<open> Sets of Assumptions \<close>

text \<open> While deduction in terms of lists of assumptions is straight-forward
       to define, deduction (and the \<^emph>\<open>deduction theorem\<close>) is commonly given in
       terms of \<^emph>\<open>sets\<close> of propositions.  This formulation is suited to
       establishing strong completeness theorems and compactness theorems. \<close>

text \<open> The presentation of deduction from a set follows the presentation of
       list deduction given for @{term "(:\<turnstile>)"}. \<close>

subsection \<open> Definition of Deduction \<close>

text \<open> Just as deduction from a list @{term "(:\<turnstile>)"} can be defined in
       terms of @{term "(:\<rightarrow>)"}, deduction from a \<^emph>\<open>set\<close> of assumptions
       can be expressed in terms of @{term "(:\<turnstile>)"}. \<close>

definition (in implication_logic) set_deduction :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<tturnstile>" 60)
  where
    "\<Gamma> \<tturnstile> \<phi> \<equiv> \<exists> \<Psi>. set(\<Psi>) \<subseteq> \<Gamma> \<and> \<Psi> :\<turnstile> \<phi>"

subsubsection \<open> Interpretation as Implication Logic \<close>

text \<open> As in the case of @{term "(:\<turnstile>)"}, the relation @{term "(\<tturnstile>)"} may be
       interpreted as @{term "deduction"} predicate for a fixed set of
       assumptions @{term "\<Gamma>"}. \<close>

text \<open> The following lemma is given in order to establish this, which asserts
       that every implication logic tautology @{term "\<turnstile> \<phi>"}
       is also a tautology for @{term "\<Gamma> \<tturnstile> \<phi>"}. \<close>

lemma (in implication_logic) set_deduction_weaken:
  "\<turnstile> \<phi> \<Longrightarrow> \<Gamma> \<tturnstile> \<phi>"
  using list_deduction_base_theory set_deduction_def by fastforce

text \<open> In the case of the empty set, the converse may be established. \<close>

lemma (in implication_logic) set_deduction_base_theory:
  "{} \<tturnstile> \<phi> \<equiv> \<turnstile> \<phi>"
  using list_deduction_base_theory set_deduction_def by auto

text \<open> Next, a form of \<^emph>\<open>modus ponens\<close> is provided for @{term "(\<tturnstile>)"}. \<close>

lemma (in implication_logic) set_deduction_modus_ponens:
   "\<Gamma> \<tturnstile> \<phi> \<rightarrow> \<psi> \<Longrightarrow> \<Gamma> \<tturnstile> \<phi> \<Longrightarrow> \<Gamma> \<tturnstile> \<psi>"
proof -
  assume "\<Gamma> \<tturnstile> \<phi> \<rightarrow> \<psi>"
  then obtain \<Phi> where A: "set \<Phi> \<subseteq> \<Gamma>" and B: "\<Phi> :\<turnstile> \<phi> \<rightarrow> \<psi>"
    using set_deduction_def by blast
  assume "\<Gamma> \<tturnstile> \<phi>"
  then obtain \<Psi> where C: "set \<Psi> \<subseteq> \<Gamma>" and D: "\<Psi> :\<turnstile> \<phi>"
    using set_deduction_def by blast
  from B D have "\<Phi> @ \<Psi> :\<turnstile> \<psi>"
    using list_deduction_cut_rule list_deduction_theorem by blast
  moreover from A C have "set (\<Phi> @ \<Psi>) \<subseteq> \<Gamma>" by simp
  ultimately show ?thesis
    using set_deduction_def by blast
qed

context implication_logic begin
interpretation set_deduction_logic:
  implication_logic "\<lambda> \<phi>. \<Gamma> \<tturnstile> \<phi>" "(\<rightarrow>)"
proof
   fix \<phi> \<psi>
   show "\<Gamma> \<tturnstile> \<phi> \<rightarrow> \<psi> \<rightarrow> \<phi>"  by (metis axiom_k set_deduction_weaken)
next
    fix \<phi> \<psi> \<chi>
    show "\<Gamma> \<tturnstile> (\<phi> \<rightarrow> \<psi> \<rightarrow> \<chi>) \<rightarrow> (\<phi> \<rightarrow> \<psi>) \<rightarrow> \<phi> \<rightarrow> \<chi>"
      by (metis axiom_s set_deduction_weaken)
next
    fix \<phi> \<psi>
    show "\<Gamma> \<tturnstile> \<phi> \<rightarrow> \<psi> \<Longrightarrow> \<Gamma> \<tturnstile> \<phi> \<Longrightarrow> \<Gamma> \<tturnstile> \<psi>"
      using set_deduction_modus_ponens by metis
qed
end

subsection \<open> The Deduction Theorem \<close>

text \<open> The next result gives the deduction theorem for @{term "(\<tturnstile>)"}. \<close>

theorem (in implication_logic) set_deduction_theorem:
  "insert \<phi> \<Gamma> \<tturnstile> \<psi> = \<Gamma> \<tturnstile> \<phi> \<rightarrow> \<psi>"
proof -
  have "\<Gamma> \<tturnstile> \<phi> \<rightarrow> \<psi> \<Longrightarrow> insert \<phi> \<Gamma> \<tturnstile> \<psi>"
    by (metis
            set_deduction_def
            insert_mono
            list.simps(15)
            list_deduction_theorem)
  moreover {
    assume "insert \<phi> \<Gamma> \<tturnstile> \<psi>"
    then obtain \<Phi> where "set \<Phi> \<subseteq> insert \<phi> \<Gamma>" and "\<Phi> :\<turnstile> \<psi>"
      using set_deduction_def by auto
    hence "set (removeAll \<phi> \<Phi>) \<subseteq> \<Gamma>" by auto
    moreover from \<open>\<Phi> :\<turnstile> \<psi>\<close> have "removeAll \<phi> \<Phi> :\<turnstile> \<phi> \<rightarrow> \<psi>"
      using modus_ponens list_implication_removeAll list_deduction_def
      by blast
    ultimately have "\<Gamma> \<tturnstile> \<phi> \<rightarrow> \<psi>"
      using set_deduction_def by blast
  }
  ultimately show "insert \<phi> \<Gamma> \<tturnstile> \<psi> = \<Gamma> \<tturnstile> \<phi> \<rightarrow> \<psi>" by metis
qed

subsection \<open> Monotonic Growth in Deductive Power \<close>

text \<open> In contrast to the @{term "(:\<turnstile>)"} relation, the proof that the
       deductive power of @{term "(\<tturnstile>)"} grows monotonically with its
       assumptions may be fully automated. \<close>

theorem set_deduction_monotonic:
  "\<Sigma> \<subseteq> \<Gamma> \<Longrightarrow> \<Sigma> \<tturnstile> \<phi> \<Longrightarrow> \<Gamma> \<tturnstile> \<phi>"
  by (meson dual_order.trans set_deduction_def)

subsection \<open> The Deduction Theorem Revisited \<close>

text \<open> As a consequence of the fact that @{thm "set_deduction_monotonic"}
       is automatically provable, an alternate \<^emph>\<open>deduction theorem\<close> where the
       discharged assumption is completely removed from the set of assumptions
       is just a consequence of the more conventional
       @{thm "set_deduction_theorem"} rule and some basic set identities. \<close>

theorem (in implication_logic) alternate_set_deduction_theorem:
  "insert \<phi> \<Gamma> \<tturnstile> \<psi> = \<Gamma> - {\<phi>} \<tturnstile> \<phi> \<rightarrow> \<psi>"
  by (metis insert_Diff_single set_deduction_theorem)

subsection \<open> Reflection \<close>

text \<open> Just as in the case of @{term "(:\<turnstile>)"}, deduction from sets of
       assumptions makes true the \<^emph>\<open>reflection principle\<close> and is
       automatically provable. \<close>

theorem (in implication_logic) set_deduction_reflection:
  "\<phi> \<in> \<Gamma> \<Longrightarrow> \<Gamma> \<tturnstile> \<phi>"
  by (metis
          Set.set_insert
          list_implication.simps(1)
          list_implication_axiom_k
          set_deduction_theorem
          set_deduction_weaken)

subsection \<open> The Cut Rule \<close>

text \<open> The final principle of @{term "(\<tturnstile>)"} presented is the \<^emph>\<open>cut rule\<close>. \<close>

text \<open> First, the weak form of the rule is established. \<close>

theorem (in implication_logic) set_deduction_cut_rule:
  "insert \<phi> \<Gamma> \<tturnstile> \<psi> \<Longrightarrow> \<Delta> \<tturnstile> \<phi> \<Longrightarrow> \<Gamma> \<union> \<Delta> \<tturnstile> \<psi>"
proof -
  assume "insert \<phi> \<Gamma> \<tturnstile> \<psi>"
  hence "\<Gamma> \<tturnstile> \<phi> \<rightarrow> \<psi>" using set_deduction_theorem by auto
  hence "\<Gamma> \<union> \<Delta> \<tturnstile> \<phi> \<rightarrow> \<psi>" using set_deduction_def by auto
  moreover assume "\<Delta> \<tturnstile> \<phi>"
  hence "\<Gamma> \<union> \<Delta> \<tturnstile> \<phi>" using set_deduction_def by auto
  ultimately show ?thesis using set_deduction_modus_ponens by metis
qed

text \<open> Another lemma is shown next in order to establish the strong form
       of the cut rule. The lemma shows the existence of a \<^emph>\<open>covering list\<close> of
       assumptions \<^term>\<open>\<Psi>\<close> in the event some set of assumptions
       \<^term>\<open>\<Delta>\<close> proves everything in a finite set of assumptions
       \<^term>\<open>\<Phi>\<close>. \<close>

lemma (in implication_logic) finite_set_deduction_list_deduction:
  assumes "finite \<Phi>"
  and "\<forall> \<phi> \<in> \<Phi>. \<Delta> \<tturnstile> \<phi>"
  shows "\<exists>\<Psi>. set \<Psi> \<subseteq> \<Delta> \<and> (\<forall>\<phi> \<in> \<Phi>. \<Psi> :\<turnstile> \<phi>)"
  using assms
proof(induct \<Phi> rule: finite_induct)
  case empty thus ?case by (metis all_not_in_conv empty_subsetI set_empty)
next
  case (insert \<chi> \<Phi>)
  assume "\<forall>\<phi> \<in> \<Phi>. \<Delta> \<tturnstile> \<phi> \<Longrightarrow> \<exists>\<Psi>. set \<Psi> \<subseteq> \<Delta> \<and> (\<forall>\<phi> \<in> \<Phi>. \<Psi> :\<turnstile> \<phi>)"
     and "\<forall>\<phi> \<in> insert \<chi> \<Phi>. \<Delta> \<tturnstile> \<phi>"
  hence "\<exists>\<Psi>. set \<Psi> \<subseteq> \<Delta> \<and> (\<forall>\<phi>\<in>\<Phi>. \<Psi> :\<turnstile> \<phi>)" and "\<Delta> \<tturnstile> \<chi>" by simp+
  then obtain \<Psi>\<^sub>1 \<Psi>\<^sub>2 where
    "set (\<Psi>\<^sub>1 @ \<Psi>\<^sub>2) \<subseteq> \<Delta>"
    "\<forall>\<phi> \<in> \<Phi>. \<Psi>\<^sub>1 :\<turnstile> \<phi>"
    "\<Psi>\<^sub>2 :\<turnstile> \<chi>"
    using set_deduction_def by auto
  moreover from this have "\<forall>\<phi> \<in> (insert \<chi> \<Phi>). \<Psi>\<^sub>1 @ \<Psi>\<^sub>2 :\<turnstile> \<phi>"
    by (metis
            insert_iff
            le_sup_iff
            list_deduction_monotonic
            order_refl set_append)
  ultimately show ?case by blast
qed

text \<open> With @{thm finite_set_deduction_list_deduction} the strengthened
       form of the cut rule can be given. \<close>

theorem (in implication_logic) strong_set_deduction_cut_rule:
  assumes "\<Phi> \<union> \<Gamma> \<tturnstile> \<psi>"
  and "\<forall> \<phi> \<in> \<Phi>. \<Delta> \<tturnstile> \<phi>"
  shows "\<Gamma> \<union> \<Delta> \<tturnstile> \<psi>"
proof -
  obtain \<Sigma> where
    A: "set \<Sigma>  \<subseteq> \<Phi> \<union> \<Gamma>" and
    B: "\<Sigma> :\<turnstile> \<psi>"
    using assms(1) set_deduction_def
    by auto+
  obtain \<Phi>' \<Gamma>' where
    C: "set \<Phi>' = set \<Sigma> \<inter> \<Phi>" and
    D: "set \<Gamma>' = set \<Sigma> \<inter> \<Gamma>"
    by (metis inf_sup_aci(1) inter_set_filter)+
  then have "set (\<Phi>' @ \<Gamma>') = set \<Sigma>" using A by auto
  hence E: "\<Phi>' @ \<Gamma>' :\<turnstile> \<psi>" using B list_deduction_monotonic by blast
  hence "\<forall> \<phi> \<in> set \<Phi>'. \<Delta> \<tturnstile> \<phi>" using assms(2) C by auto
  from this obtain \<Delta>' where "set \<Delta>' \<subseteq> \<Delta>" and "\<forall> \<phi> \<in> set \<Phi>'. \<Delta>' :\<turnstile> \<phi>"
    using finite_set_deduction_list_deduction by blast
  with strong_list_deduction_cut_rule D E
  have "set (\<Gamma>' @ \<Delta>') \<subseteq> \<Gamma> \<union> \<Delta>" and "\<Gamma>' @ \<Delta>' :\<turnstile> \<psi>" by auto
  thus ?thesis using set_deduction_def by blast
qed

subsection \<open>Maximally Consistent Sets For Implication Logic \label{sec:implicational-maximally-consistent-sets}\<close>

text \<open> \<^emph>\<open>Maximally Consistent Sets\<close> are a common construction for proving
       completeness of logical calculi.  For a classic presentation, see
       Dirk van Dalen's \<^emph>\<open>Logic and Structure\<close> (2013, \S1.5, pgs. 42--45)
       @{cite vandalenLogicStructure2013}. \<close>

text \<open> Maximally consistent sets will form the foundation of all of the
       model theory we will employ in this text. In fact, apart from
       classical logic semantics, conventional model theory will not be
       used at all. \<close>

text \<open> The models we are centrally concerned are derived from maximally consistent sets.
       These include probability measures used in completeness theorems of
       probability logic found in \S\ref{sec:probability-logic-completeness},
       as well as arbitrage opportunities stipulated by the \<^emph>\<open>Dutch Book Theorem\<close>
       in \S\ref{sec:dutch-book-theorem}. \<close>

text \<open> Since implication logic does not have \<^emph>\<open>falsum\<close>, consistency is
       defined relative to a formula \<^term>\<open>\<phi>\<close>. \<close>

definition (in implication_logic)
  formula_consistent :: "'a \<Rightarrow> 'a set \<Rightarrow> bool" ("_-consistent _" [100] 100)
  where
    [simp]: "\<phi>-consistent \<Gamma> \<equiv> \<not> (\<Gamma> \<tturnstile> \<phi>)"

text \<open> Since consistency is defined relative to some \<^term>\<open>\<phi>\<close>,
       \<^emph>\<open>maximal consistency\<close> is presented as asserting that either
       \<^term>\<open>\<psi>\<close> or \<^term>\<open>\<psi> \<rightarrow> \<phi>\<close> is in the consistent set \<^term>\<open>\<Gamma>\<close>,
       for all \<^term>\<open>\<psi>\<close>.  This coincides with the traditional definition in
       classical logic when \<^term>\<open>\<phi>\<close> is \<^emph>\<open>falsum\<close>. \<close>

definition (in implication_logic)
  formula_maximally_consistent_set_def :: "'a \<Rightarrow> 'a set \<Rightarrow> bool" ("_-MCS _" [100] 100)
  where
    [simp]: "\<phi>-MCS \<Gamma> \<equiv> (\<phi>-consistent \<Gamma>) \<and> (\<forall> \<psi>. \<psi> \<in> \<Gamma> \<or> (\<psi> \<rightarrow> \<phi>) \<in> \<Gamma>)"

text \<open> Every consistent set \<^term>\<open>\<Gamma>\<close> may be extended to a maximally
       consistent set. \<close>

text \<open> However, no assumption is made regarding the cardinality of the types
       of an instance of @{class implication_logic}. \<close>

text \<open> As a result, typical proofs that assume a countable domain are not
       suitable.  Our proof leverages \<^emph>\<open>Zorn's lemma\<close>. \<close>

lemma (in implication_logic) formula_consistent_extension:
  assumes "\<phi>-consistent \<Gamma>"
  shows "(\<phi>-consistent (insert \<psi> \<Gamma>)) \<or> (\<phi>-consistent (insert (\<psi> \<rightarrow> \<phi>) \<Gamma>))"
proof -
  {
    assume "\<not> \<phi>-consistent insert \<psi> \<Gamma>"
    hence "\<Gamma> \<tturnstile> \<psi> \<rightarrow> \<phi>"
      using set_deduction_theorem
      unfolding formula_consistent_def
      by simp
    hence "\<phi>-consistent insert (\<psi> \<rightarrow> \<phi>) \<Gamma>"
     by (metis Un_absorb assms formula_consistent_def set_deduction_cut_rule)
  }
  thus ?thesis by blast
qed

theorem (in implication_logic) formula_maximally_consistent_extension:
  assumes "\<phi>-consistent \<Gamma>"
  shows "\<exists> \<Omega>. (\<phi>-MCS \<Omega>) \<and> \<Gamma> \<subseteq> \<Omega>"
proof -
  let ?\<Gamma>_extensions = "{\<Sigma>. (\<phi>-consistent \<Sigma>) \<and> \<Gamma> \<subseteq> \<Sigma>}"
  have "\<exists> \<Omega> \<in> ?\<Gamma>_extensions. \<forall>\<Sigma> \<in> ?\<Gamma>_extensions. \<Omega> \<subseteq> \<Sigma> \<longrightarrow> \<Sigma> = \<Omega>"
  proof (rule subset_Zorn)
    fix \<C> :: "'a set set"
    assume subset_chain_\<C>: "subset.chain ?\<Gamma>_extensions \<C>"
    hence \<C>:  "\<forall> \<Sigma> \<in> \<C>. \<Gamma> \<subseteq> \<Sigma>" "\<forall> \<Sigma> \<in> \<C>. \<phi>-consistent \<Sigma>"
      unfolding subset.chain_def
      by blast+
    show "\<exists> \<Omega> \<in> ?\<Gamma>_extensions. \<forall> \<Sigma> \<in> \<C>. \<Sigma> \<subseteq> \<Omega>"
    proof cases
      assume "\<C> = {}" thus ?thesis using assms by blast
    next
      let ?\<Omega> = "\<Union> \<C>"
      assume "\<C> \<noteq> {}"
      hence "\<Gamma> \<subseteq> ?\<Omega>" by (simp add: \<C>(1) less_eq_Sup)
      moreover have "\<phi>-consistent ?\<Omega>"
      proof -
        {
          assume "\<not> \<phi>-consistent ?\<Omega>"
          then obtain \<omega> where \<omega>:
            "finite \<omega>"
            "\<omega> \<subseteq> ?\<Omega>"
            "\<not> \<phi>-consistent \<omega>"
            unfolding
              formula_consistent_def
              set_deduction_def
            by auto
          from \<omega>(1) \<omega>(2) have "\<exists> \<Sigma> \<in> \<C>. \<omega> \<subseteq> \<Sigma>"
          proof (induct \<omega> rule: finite_induct)
            case empty thus ?case using \<open>\<C> \<noteq> {}\<close> by blast
          next
            case (insert \<psi> \<omega>)
            from this obtain \<Sigma>\<^sub>1 \<Sigma>\<^sub>2 where
              \<Sigma>\<^sub>1:
                  "\<omega> \<subseteq> \<Sigma>\<^sub>1"
                  "\<Sigma>\<^sub>1 \<in> \<C>"
              and \<Sigma>\<^sub>2:
                  "\<psi> \<in> \<Sigma>\<^sub>2"
                  "\<Sigma>\<^sub>2 \<in> \<C>"
              by auto
            hence "\<Sigma>\<^sub>1 \<subseteq> \<Sigma>\<^sub>2 \<or> \<Sigma>\<^sub>2 \<subseteq> \<Sigma>\<^sub>1"
              using subset_chain_\<C>
              unfolding subset.chain_def
              by blast
            hence "(insert \<psi> \<omega>) \<subseteq> \<Sigma>\<^sub>1 \<or> (insert \<psi> \<omega>) \<subseteq> \<Sigma>\<^sub>2"
              using \<Sigma>\<^sub>1 \<Sigma>\<^sub>2 by blast
            thus ?case using \<Sigma>\<^sub>1 \<Sigma>\<^sub>2 by blast
          qed
          hence "\<exists> \<Sigma> \<in> \<C>. (\<phi>-consistent \<Sigma>) \<and> \<not> (\<phi>-consistent \<Sigma>)"
            using \<C>(2) \<omega>(3)
            unfolding
              formula_consistent_def
              set_deduction_def
            by auto
          hence "False" by auto
        }
        thus ?thesis by blast
      qed
      ultimately show ?thesis by blast
    qed
  qed
  then obtain \<Omega> where \<Omega>:
    "\<Omega> \<in> ?\<Gamma>_extensions"
    "\<forall>\<Sigma> \<in> ?\<Gamma>_extensions. \<Omega> \<subseteq> \<Sigma> \<longrightarrow> \<Sigma> = \<Omega>"
    by auto+
  {
    fix \<psi>
    have "(\<phi>-consistent insert \<psi> \<Omega>) \<or> (\<phi>-consistent insert (\<psi> \<rightarrow> \<phi>) \<Omega>)"
         "\<Gamma> \<subseteq> insert \<psi> \<Omega>"
         "\<Gamma> \<subseteq> insert (\<psi> \<rightarrow> \<phi>) \<Omega>"
      using \<Omega>(1) formula_consistent_extension formula_consistent_def
      by auto
    hence "insert \<psi> \<Omega> \<in> ?\<Gamma>_extensions
             \<or> insert (\<psi> \<rightarrow> \<phi>) \<Omega> \<in> ?\<Gamma>_extensions"
      by blast
    hence "\<psi> \<in> \<Omega> \<or> (\<psi> \<rightarrow> \<phi>) \<in> \<Omega>" using \<Omega>(2) by blast
  }
  thus ?thesis
    using \<Omega>(1)
    unfolding formula_maximally_consistent_set_def_def
    by blast
qed

text \<open> Finally, maximally consistent sets contain anything that can be deduced
       from them, and model a form of \<^emph>\<open>modus ponens\<close>. \<close>

lemma (in implication_logic) formula_maximally_consistent_set_def_reflection:
  "\<phi>-MCS \<Gamma> \<Longrightarrow> \<psi> \<in> \<Gamma> = \<Gamma> \<tturnstile> \<psi>"
proof -
  assume "\<phi>-MCS \<Gamma>"
  {
    assume "\<Gamma> \<tturnstile> \<psi>"
    moreover from \<open>\<phi>-MCS \<Gamma>\<close> have "\<psi> \<in> \<Gamma> \<or> (\<psi> \<rightarrow> \<phi>) \<in> \<Gamma>" "\<not> \<Gamma> \<tturnstile> \<phi>"
      unfolding
        formula_maximally_consistent_set_def_def
        formula_consistent_def
      by auto
    ultimately have "\<psi> \<in> \<Gamma>"
      using set_deduction_reflection set_deduction_modus_ponens
      by metis
  }
  thus "\<psi> \<in> \<Gamma> = \<Gamma> \<tturnstile> \<psi>"
    using set_deduction_reflection
    by metis
qed

theorem (in implication_logic) formula_maximally_consistent_set_def_implication_elimination:
  assumes "\<phi>-MCS \<Omega>"
  shows "(\<psi> \<rightarrow> \<chi>) \<in> \<Omega> \<Longrightarrow> \<psi> \<in> \<Omega> \<Longrightarrow> \<chi> \<in> \<Omega>"
  using
    assms
    formula_maximally_consistent_set_def_reflection
    set_deduction_modus_ponens
  by blast

text \<open> This concludes our introduction to implication logic. \<close>

end


section \<open>The direct sum of modules.\<close>

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

text \<open>We define the direct sum $M_1\oplus M_2$ of 2 vector spaces as the set $M_1\times M_2$ under
componentwise addition and scalar multiplication.\<close>
definition direct_sum:: "('a,'b, 'd) module_scheme \<Rightarrow> ('a, 'c, 'e) module_scheme \<Rightarrow>('a, ('b\<times>'c)) module" (*(infixl "(\<oplus>)" 50)*)
  where  "direct_sum M1 M2 = \<lparr>carrier = carrier M1 \<times> carrier M2,
                  mult = (\<lambda> v w. (\<zero>\<^bsub>M1\<^esub>, \<zero>\<^bsub>M2\<^esub>)),
                  one =  (\<zero>\<^bsub>M1\<^esub>, \<zero>\<^bsub>M2\<^esub>),
                  zero = (\<zero>\<^bsub>M1\<^esub>, \<zero>\<^bsub>M2\<^esub>),
                  add = (\<lambda> v w. (fst v \<oplus>\<^bsub>M1\<^esub> fst w, snd v \<oplus>\<^bsub>M2\<^esub> snd w)),
                  smult = (\<lambda> c v. (c \<odot>\<^bsub>M1\<^esub> fst v, c \<odot>\<^bsub>M2\<^esub> snd v))\<rparr>"

lemma direct_sum_is_module:
  fixes R M1 M2
  assumes h1: "module R M1" and h2: "module R M2"
  shows "module R (direct_sum M1 M2)"
proof -
  from h1 have 1: "cring R" by (unfold module_def, auto)
  from h1 interpret v1: module R M1 by auto
  from h2 interpret v2: module R M2 by auto
  from h1 h2 have 2: "abelian_group (direct_sum M1 M2)"
    apply (intro abelian_groupI, auto)
         apply (unfold direct_sum_def, auto)
       by (auto simp add: v1.a_ac v2.a_ac)
  from h1 h2 assms have 3: "module_axioms R (direct_sum M1 M2)"
    apply (unfold module_axioms_def, auto)
        apply (unfold direct_sum_def, auto)
         by (auto simp add: v1.smult_l_distr v2.smult_l_distr v1.smult_r_distr v2.smult_r_distr
      v1.smult_assoc1 v2.smult_assoc1)
  from 1 2 3  show ?thesis by (unfold module_def, auto)
qed

definition inj1:: "('a,'b) module \<Rightarrow> ('a, 'c) module \<Rightarrow>('b\<Rightarrow>('b\<times>'c))"
  where "inj1 M1 M2 = (\<lambda>v. (v, \<zero>\<^bsub>M2\<^esub>))"

definition inj2:: "('a,'b) module \<Rightarrow> ('a, 'c) module \<Rightarrow>('c\<Rightarrow>('b\<times>'c))"
  where "inj2 M1 M2 = (\<lambda>v. (\<zero>\<^bsub>M1\<^esub>, v))"

lemma inj1_hom:
  fixes R M1 M2
  assumes h1: "module R M1" and h2: "module R M2"
  shows "mod_hom R M1 (direct_sum M1 M2) (inj1 M1 M2)"
proof -
  from h1 interpret v1:module R M1 by auto
  from h2 interpret v2:module R M2 by auto
  from h1 h2 show ?thesis
    apply (unfold mod_hom_def module_hom_def mod_hom_axioms_def inj1_def, auto)
       apply (rule direct_sum_is_module, auto)
      by (unfold direct_sum_def, auto)
qed

lemma inj2_hom:
  fixes R M1 M2
  assumes h1: "module R M1" and h2: "module R M2"
  shows "mod_hom R M2 (direct_sum M1 M2) (inj2 M1 M2)"
proof -
  from h1 interpret v1:module R M1 by auto
  from h2 interpret v2:module R M2 by auto
  from h1 h2 show ?thesis
    apply (unfold mod_hom_def module_hom_def mod_hom_axioms_def inj2_def, auto)
       apply (rule direct_sum_is_module, auto)
      by (unfold direct_sum_def, auto)
qed

text \<open>For submodules $M_1,M_2\subseteq M$, the map $M_1\oplus M_2\to M$ given by $(m_1,m_2)\mapsto
m_1+m_2$ is linear.\<close>
lemma (in module) sum_map_hom:
  fixes M1 M2
  assumes h1: "submodule R M1 M" and h2: "submodule R M2 M"
  shows "mod_hom R (direct_sum (md M1) (md M2)) M (\<lambda> v. (fst v) \<oplus>\<^bsub>M\<^esub> (snd v))"
proof -
  have 0: "module R M"..
  from h1 have 1: "module R (md M1)" by (rule submodule_is_module)
  from h2 have 2: "module R (md M2)" by (rule submodule_is_module)
  from h1 interpret w1: module R "(md M1)" by (rule submodule_is_module)
  from h2 interpret w2: module R "(md M2)" by (rule submodule_is_module)
  from 0 h1 h2 1 2 show ?thesis
    apply (unfold mod_hom_def mod_hom_axioms_def module_hom_def, auto)
       apply (rule direct_sum_is_module, auto)
      apply (unfold direct_sum_def, auto)
      apply (unfold submodule_def, auto)
     by (auto simp add: a_ac smult_r_distr ring_subset_carrier)
      (*key is a_ac, permutative rewrite rule*)
qed

lemma (in module) sum_is_submodule:
  fixes N1 N2
  assumes h1: "submodule R N1 M" and h2: "submodule R N2 M"
  shows "submodule R (submodule_sum N1 N2) M"
proof -
  from h1 h2 interpret l: mod_hom R "(direct_sum (md N1) (md N2))" M "(\<lambda> v. (fst v) \<oplus>\<^bsub>M\<^esub> (snd v))"
    by (rule sum_map_hom)
  have 1: "l.im =submodule_sum N1 N2"
    apply (unfold l.im_def submodule_sum_def)
    apply (unfold direct_sum_def, auto)
    by (unfold image_def, auto)
  have 2: "submodule R (l.im) M" by (rule l.im_is_submodule)
  from 1 2 show ?thesis by auto
qed

lemma (in module) in_sum:
  fixes N1 N2
  assumes h1: "submodule R N1 M" and h2: "submodule R N2 M"
  shows "N1 \<subseteq> submodule_sum N1 N2"
proof -
  from h1 h2 show ?thesis
    apply auto
    apply (unfold submodule_sum_def image_def, auto)
    apply (rename_tac v)
    apply (rule_tac x="v" in bexI)
     apply (rule_tac x="\<zero>\<^bsub>M\<^esub>" in bexI)
      by (unfold submodule_def, auto)
qed

lemma (in module) msum_comm:
  fixes N1 N2
  assumes h1: "submodule R N1 M" and h2: "submodule R N2 M"
  shows "(submodule_sum N1 N2) = (submodule_sum N2 N1)"
proof -
  (*have 0: "module R M"..*)
  from h1 h2 show ?thesis
    apply (unfold submodule_sum_def image_def, auto)
     apply (unfold submodule_def)
     apply (rename_tac v w)
     by (metis (full_types) M.add.m_comm subsetD)+
    (* Alternatively, apply (rule_tac x="w" in bexI, rule_tac x="v" in bexI,
      auto simp add: ring_subset_carrier M.a_ac)+ *)
qed

text \<open>If $M_1,M_2\subseteq M$ are submodules, then $M_1+M_2$ is the minimal subspace such that
both $M_1\subseteq M$ and $M_2\subseteq M$.\<close>
lemma (in module) sum_is_minimal:
  fixes N N1 N2
  assumes h1: "submodule R N1 M" and h2: "submodule R N2 M" and h3: "submodule R N M"
  shows "(submodule_sum N1 N2) \<subseteq> N \<longleftrightarrow> N1 \<subseteq> N \<and> N2 \<subseteq> N"
proof -
  have 1: "(submodule_sum N1 N2) \<subseteq> N \<Longrightarrow> N1 \<subseteq> N \<and> N2 \<subseteq> N"
  proof -
    assume 10: "(submodule_sum N1 N2) \<subseteq> N"
    from h1 h2 have 11: "N1\<subseteq>submodule_sum N1 N2" by (rule in_sum)
    from h2 h1 have 12: "N2\<subseteq>submodule_sum N2 N1" by (rule in_sum)
    from 12 h1 h2 have 13: "N2\<subseteq>submodule_sum N1 N2" by (metis msum_comm)
    from 10 11 13 show ?thesis by auto
  qed
  have 2: "N1 \<subseteq> N \<and> N2 \<subseteq> N \<Longrightarrow> (submodule_sum N1 N2) \<subseteq> N"
  proof -
    assume 19: "N1 \<subseteq> N \<and> N2 \<subseteq> N"
    {
    fix v
    assume 20: "v\<in>submodule_sum N1 N2"
    from 20 obtain w1 w2 where 21: "w1\<in>N1" and 22: "w2\<in>N2" and 23: "v=w1\<oplus>\<^bsub>M\<^esub> w2"
      by (unfold submodule_sum_def image_def, auto)
    from 19 21 22 23 h3 have "v \<in> N"
      apply (unfold submodule_def, auto)
      by (metis (poly_guards_query)  contra_subsetD)
(*how is an obtain goal rep'd?*)
    }
    thus ?thesis
      by (metis subset_iff)
  qed
  from 1 2 show ?thesis by metis
qed

text \<open>$\text{span} A\cup B = \text{span} A + \text{span} B$\<close>
lemma (in module) span_union_is_sum:
  fixes A B
  assumes  h2: "A\<subseteq>carrier M" and h3: "B\<subseteq>carrier M"
  shows "span (A\<union> B) = submodule_sum (span A) (span B)"
proof-
  let ?AplusB="submodule_sum (span A) (span B)"
  from  h2 have s0: "submodule R (span A) M" by (rule span_is_submodule)
  from  h3 have s1: "submodule R (span B) M" by (rule span_is_submodule)
  from s0 have s0_1: "(span A)\<subseteq>carrier M" by (unfold submodule_def, auto)
  from s1 have s1_1: "(span B)\<subseteq>carrier M" by (unfold submodule_def, auto)
  from h2 h3 have 1: "A\<union>B\<subseteq>carrier M" by auto
  from  1 have 2: "submodule R (span (A\<union>B)) M" by (rule span_is_submodule)
  from s0 s1 have 3: "submodule R ?AplusB M" by (rule sum_is_submodule)
  have c1: "span (A\<union>B) \<subseteq> ?AplusB"
(*span(A\<union>B) \<subseteq> span(A) + span(B) *)
  proof -
    from  h2 have a1: "A\<subseteq>span A" by (rule in_own_span)
    from s0 s1 have a2: "span A \<subseteq> ?AplusB" by (rule in_sum) (*M\<subseteq>M+N*)
    from a1 a2 have a3: "A\<subseteq> ?AplusB" by auto
    (*similarly*)
    from  h3 have b1: "B\<subseteq>span B" by (rule in_own_span)
    from s1 s0 have b2: "span B \<subseteq> ?AplusB" by (metis in_sum msum_comm) (*M\<subseteq>M+N*)
    from b1 b2 have b3: "B\<subseteq> ?AplusB" by auto
    from a3 b3 have 5: "A\<union>B\<subseteq> ?AplusB" by auto
      (*by default simp *)
    from 5 3 show ?thesis by (rule span_is_subset)
  qed
  have c2: "?AplusB \<subseteq> span (A\<union>B)"
  proof -
    have 11: "A\<subseteq>A\<union>B" by auto
    have 12: "B\<subseteq>A\<union>B" by auto
    from  11 have 21:"span A \<subseteq>span (A\<union>B)" by (rule span_is_monotone)
    from  12 have 22:"span B \<subseteq>span (A\<union>B)" by (rule span_is_monotone)
    from s0 s1 2 21 22 show ?thesis by (auto simp add: sum_is_minimal)
  qed
  from c1 c2 show ?thesis by auto
qed

end


(*
    File:     Set_Multiplication.thy
    Author:   Joseph Thommes, TU München
*)
section \<open>Set Multiplication\<close>

theory Set_Multiplication
  imports "HOL-Algebra.Multiplicative_Group"
begin

text \<open>This theory/section is of auxiliary nature and is mainly used to establish a connection
between the set multiplication and the multiplication of subgroups via the \<open>IDirProd\<close> (although this
particular notion is introduced later). However, as in every section of this entry, there are some
lemmas that do not have any further usage in this entry, but are of interest just by themselves.\<close>

lemma (in group) set_mult_union:
  "A <#> (B \<union> C) = (A <#> B) \<union> (A <#> C)"
  unfolding set_mult_def by auto

lemma (in group) set_mult_card_single_el_eq:
  assumes "J \<subseteq> carrier G" "x \<in> carrier G"
  shows "card (l_coset G x J) = card J" unfolding l_coset_def
proof -
  have "card ((\<otimes>) x ` J) = card J"
    using inj_on_cmult[of x] card_image[of "(\<otimes>) x" J] assms inj_on_subset[of "(\<otimes>) x" "carrier G" J]
    by blast
  moreover have "(\<Union>y\<in>J. {x \<otimes> y}) = (\<otimes>) x ` J" using image_def[of "(\<otimes>) x" J] by blast
  ultimately show "card (\<Union>h\<in>J. {x \<otimes> h}) = card J" by presburger
qed

text \<open>We find an upper bound for the cardinality of a set product.\<close>

lemma (in group) set_mult_card_le:
  assumes "finite H" "H \<subseteq> carrier G" "J \<subseteq> carrier G"
  shows "card (H <#> J) \<le> card H * card J"
  using assms
proof (induction "card H" arbitrary: H)
  case 0
  then have "H = {}" by force
  then show ?case using set_mult_def[of G H J] by simp
next
  case (Suc n)
  then obtain a where a_def: "a \<in> H" by fastforce
  then have c_n: "card (H - {a}) = n" using Suc by force
  then have "card ((H - {a}) <#> J) \<le> card (H - {a}) * card J" using Suc by blast
  moreover have "card ({a} <#> J) = card J"
    using Suc(4, 5) a_def set_mult_card_single_el_eq[of J a] l_coset_eq_set_mult[of G a J] by auto
  moreover have "H <#> J = (H - {a} <#> J) \<union> ({a} <#> J)" using set_mult_def[of G _ J] a_def by auto
  moreover have "card (H - {a}) * card J + card J = Suc n * card J" using c_n mult_Suc by presburger
  ultimately show ?case using card_Un_le[of "H - {a} <#> J" "{a} <#> J"] c_n \<open>Suc n = card H\<close> by auto
qed

lemma (in group) set_mult_finite:
  assumes "finite H" "finite J" "H \<subseteq> carrier G" "J \<subseteq> carrier G"
  shows "finite (H <#> J)"
  using assms set_mult_def[of G H J] by auto

text \<open>The next lemma allows us to later to derive that two finite subgroups $J$ and $H$ are complementary
if and only if their product has the cardinality $|J| \cdot |H|$.\<close>

lemma (in group) set_mult_card_eq_impl_empty_inter:
  assumes "finite H" "finite J" "H \<subseteq> carrier G" "J \<subseteq> carrier G" "card (H <#> J) = card H * card J"
  shows "\<And>a b. \<lbrakk>a \<in> H; b \<in> H; a \<noteq> b\<rbrakk> \<Longrightarrow> ((\<otimes>) a ` J) \<inter> ((\<otimes>) b ` J) = {}"
  using assms
proof (induction H rule: finite_induct)
  case empty
  then show ?case by fast
next
  case step: (insert x H)
  from step have x_c: "x \<in> carrier G" by simp
  from step have H_c: "H \<subseteq> carrier G" by simp
  from set_mult_card_single_el_eq[of J x] have card_x: "card ({x} <#> J) = card J"
    using \<open>J \<subseteq> carrier G\<close> x_c l_coset_eq_set_mult by metis
  moreover have ins: "(insert x H) <#> J = (H <#> J) \<union> ({x} <#> J)"
    using set_mult_def[of G _ J] by auto
  ultimately have "card (H <#> J) \<ge> card H * card J"
    using card_Un_le[of "H <#> J" "{x} <#> J"] \<open>card (insert x H <#> J) = card (insert x H) * card J\<close>
    by (simp add: step.hyps(1) step.hyps(2))
  then have card_eq:"card (H <#> J) = card H * card J"
    using set_mult_card_le[of H J] step H_c by linarith
  then have ih: "\<And>a b. \<lbrakk>a \<in> H; b \<in> H; a \<noteq> b\<rbrakk> \<Longrightarrow> ((\<otimes>) a ` J) \<inter> ((\<otimes>) b ` J) = {}"
    using step H_c by presburger

  have "card (insert x H) * card J = card H * card J + card J" using \<open>x \<notin> H\<close> using step by simp
  then have "({x} <#> J) \<inter> (H <#> J) = {}"
    using card_eq card_x ins card_Un_Int[of "H <#> J" "{x} <#> J"] step set_mult_finite by auto
  then have "\<And>a. a \<in> H \<Longrightarrow> (\<Union>y\<in>J. {a \<otimes> y}) \<inter> (\<Union>y\<in>J. {x \<otimes> y}) = {}"
    using set_mult_def[of G _ J] by blast
  then have "\<And>a b. \<lbrakk>a \<in> (insert x H); b \<in> (insert x H); a \<noteq> b\<rbrakk> \<Longrightarrow> ((\<otimes>) a ` J) \<inter> ((\<otimes>) b ` J) = {}"
    using \<open>x \<notin> H\<close> ih by blast
  then show ?case using step by presburger
qed

lemma (in group) set_mult_card_eq_impl_empty_inter':
  assumes "finite H" "finite J" "H \<subseteq> carrier G" "J \<subseteq> carrier G" "card (H <#> J) = card H * card J"
  shows "\<And>a b. \<lbrakk>a \<in> H; b \<in> H; a \<noteq> b\<rbrakk> \<Longrightarrow> (l_coset G a J) \<inter> (l_coset G b J) = {}"
  unfolding l_coset_def
  using set_mult_card_eq_impl_empty_inter image_def[of "(\<otimes>) _" J] assms by blast

lemma (in comm_group) set_mult_comm:
  assumes "H \<subseteq> carrier G" "J \<subseteq> carrier G"
  shows "(H <#> J) = (J <#> H)"
  unfolding set_mult_def
proof -
  have 1: "\<And>a b. \<lbrakk>a \<in> carrier G; b \<in> carrier G\<rbrakk> \<Longrightarrow> {a \<otimes> b} = {b \<otimes> a}" using m_comm by simp
  then have "\<And>a b.\<lbrakk>a \<in> H; b \<in> J\<rbrakk> \<Longrightarrow> {a \<otimes> b} = {b \<otimes> a}" using assms by auto
  moreover have "\<And>a b.\<lbrakk>b \<in> H; a \<in> J\<rbrakk> \<Longrightarrow> {a \<otimes> b} = {b \<otimes> a}" using assms 1 by auto
  ultimately show "(\<Union>h\<in>H. \<Union>k\<in>J. {h \<otimes> k}) = (\<Union>k\<in>J. \<Union>h\<in>H. {k \<otimes> h})"  by fast
qed

lemma (in group) set_mult_one_imp_inc:
  assumes "\<one> \<in> A" "A \<subseteq> carrier G" "B \<subseteq> carrier G"
  shows "B \<subseteq> (B <#> A)"
proof
  fix x
  assume "x \<in> B"
  thus "x \<in> (B <#> A)" using assms unfolding set_mult_def by force
qed

text \<open>In all cases, we know that the product of two sets is always contained in the subgroup
generated by them.\<close>
lemma (in group) set_mult_subset_generate:
  assumes "A \<subseteq> carrier G" "B \<subseteq> carrier G"
  shows "A <#> B \<subseteq> generate G (A \<union> B)"
proof
  fix x
  assume "x \<in> A <#> B"
  then obtain a b where ab: "a \<in> A" "b \<in> B" "x = a \<otimes> b" unfolding set_mult_def by blast
  then have "a \<in> generate G (A \<union> B)" "b \<in> generate G (A \<union> B)"
    using generate.incl[of _ "A \<union> B" G] by simp+
  thus "x \<in> generate G (A \<union> B)" using ab generate.eng by metis
qed

text \<open>In the case of subgroups, the set product is just the subgroup generated by both
of the subgroups.\<close>

lemma (in comm_group) set_mult_eq_generate_subgroup:
  assumes "subgroup H G" "subgroup J G"
  shows "generate G (H \<union> J) = H <#> J" (is "?L = ?R")
proof
  show "?L \<subseteq> ?R"
  proof
    fix x
    assume "x \<in> ?L"
    then show "x \<in> ?R"
    proof(induction rule: generate.induct)
      case one
      have "\<one> \<otimes> \<one> = \<one>" using nat_pow_one[of 2] by simp
      thus ?case
        using assms subgroup.one_closed[OF assms(1)]
              subgroup.one_closed[OF assms(2)] set_mult_def[of G H J] by fastforce
    next
      case (incl x)
      have H1: "\<one> \<in> H" using assms subgroup.one_closed by auto
      have J1: "\<one> \<in> J" using assms subgroup.one_closed by auto
      have lx: "x \<otimes> \<one> = x" using r_one[of x] incl subgroup.subset assms by blast
      have rx: "\<one> \<otimes> x = x" using l_one[of x] incl subgroup.subset assms by blast
      show ?case
      proof (cases "x \<in> H")
        case True
        then show ?thesis using set_mult_def J1 lx by fastforce
      next
        case False
        then show ?thesis using set_mult_def H1 rx incl by fastforce
      qed
    next
      case (inv h)
      then have inv_in:"(inv h) \<in> H \<union> J" (is "?iv \<in> H \<union> J")
        using assms subgroup.m_inv_closed[of _ G h] by (cases "h \<in> H"; blast)
      have H1: "\<one> \<in> H" using assms subgroup.one_closed by auto
      have J1: "\<one> \<in> J" using assms subgroup.one_closed by auto
      have lx: "?iv \<otimes> \<one> = ?iv" using r_one[of "?iv"] subgroup.subset inv_in assms by blast
      have rx: "\<one> \<otimes> ?iv = ?iv" using l_one[of "?iv"] incl subgroup.subset inv_in assms by blast
      show ?case
      proof (cases "?iv \<in> H")
        case True
        then show ?thesis using set_mult_def[of G H J] J1 lx by fastforce
      next
        case False
        then show ?thesis using set_mult_def[of G H J] H1 rx inv_in by fastforce
      qed
    next
      case (eng h g)
      from eng(3) obtain a b where aH: "a \<in> H" and bJ: "b \<in> J" and h_def: "h = a \<otimes> b"
        using set_mult_def[of G H J] by fast
      have a_carr: "a \<in> carrier G" by (metis subgroup.mem_carrier assms(1) aH)
      have b_carr: "b \<in> carrier G" by (metis subgroup.mem_carrier assms(2) bJ)
      from eng(4) obtain c d where cH: "c \<in> H" and dJ: "d \<in> J" and g_def: "g = c \<otimes> d"
        using set_mult_def[of G H J] by fast
      have c_carr: "c \<in> carrier G" by (metis subgroup.mem_carrier assms(1) cH)
      have d_carr: "d \<in> carrier G" by (metis subgroup.mem_carrier assms(2) dJ)
      then have "h \<otimes> g = (a \<otimes> c) \<otimes> (b \<otimes> d)"
        using a_carr b_carr c_carr d_carr g_def h_def m_assoc m_comm by force
      moreover have "a \<otimes> c \<in> H" using assms(1) aH cH subgroup.m_closed by fast
      moreover have "b \<otimes> d \<in> J" using assms(2) bJ dJ subgroup.m_closed by fast
      ultimately show ?case using set_mult_def by fast
    qed
  qed
next
  show "?R \<subseteq> ?L" using set_mult_subset_generate[of H J] subgroup.subset assms by blast
qed

end


theory T97
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T111
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory ex06
imports Main
begin

fun reverse where
  "reverse [] = []"
| "reverse (x # xs) = reverse xs @ [x]"

thm append.simps

fun t_append :: "'a list \<Rightarrow> 'a list \<Rightarrow> nat" where
  "t_append [] _ = 0"
| "t_append (x # xs) ys = 1 + t_append xs ys"

fun t_reverse where
  "t_reverse [] = 0"
| "t_reverse (x # xs) = t_append (reverse xs) [x] + t_reverse xs + 1"

value "replicate (4::nat) (()::unit)"

value "map (\<lambda>x. t_reverse (replicate x (()::unit))) [0::nat, 1, 2, 3, 4, 5, 6]"

lemma [simp]: "length (reverse xs) = length xs"
  by (induction xs) auto

find_theorems "((_::nat) - _) + _"

lemma "t_reverse xs = (length xs * (length xs + 1)) div 2"
  by (induction xs) auto

term sort_key

find_theorems filter insort_key

find_theorems sorted sort_key

find_theorems "?x \<in> set (filter ?P _)" "?P ?x"

lemma "filter (\<lambda>x . k x = a) (sort_key k xs) = filter (\<lambda>x . k x = a) xs"
  apply(induction xs)
   apply (auto simp: filter_insort insort_is_Cons filter_insort_triv)
  done

end