(*  Title:      Sauer_Shelah_Lemma.thy
    Author:     Ata Keskin, TU München
*)

section "Sauer-Shelah Lemma"

theory Sauer_Shelah_Lemma
  imports Shattering Card_Lemmas Binomial_Lemmas
begin

subsection \<open>Generalized Sauer-Shelah Lemma\<close>

text \<open>To prove the Sauer-Shelah Lemma, we will first prove a slightly stronger fact that every family
      @{term "F"} shatters at least as many sets as @{term "card F"}. We first fix an element @{term "x \<in> (\<Union> F)"}
      and consider the subfamily @{term F0} of sets in the family not containing it. By induction, @{term F0}
      shatters at least as many elements of @{term F} as @{term "card F0"}.
      Next, we consider the subfamily @{term F1} of sets in the family that contain @{term x}.
      Again, by induction, @{term F1} shatters as many elements of @{term F} as its cardinality.
      The number of elements of @{term F} shattered by @{term F0} and @{term F1} sum up to at least
      @{term "card F0 + card F1 = card F"}. When a set @{term "S \<in> F"} is shattered by only one of the two subfamilies, say @{term F0},
      it contributes one unit to the set @{term "shattered_by F0"} and to @{term "shattered_by F"}. However, when the set is shattered by
      both subfamilies, both @{term S} and @{term "S \<union> {x}"} are in @{term "shattered_by F"}, so @{term S} contributes two units
      to @{term "shattered_by F0 \<union> shattered_by F1"}. Therefore, the cardinality of @{term "shattered_by F"}
      is at least equal to the cardinality of @{term "shattered_by F0 \<union> shattered_by F1"}, which is at least @{term "card F"}.\<close>

lemma sauer_shelah_0:
  fixes F :: "'a set set"
  shows "finite (\<Union> F) \<Longrightarrow> card F \<le> card (shattered_by F)"
proof (induction F rule: measure_induct_rule[of "card"])
  case (less F)
  note finite_F = finite_UnionD[OF less(2)]
  note finite_shF = finite_shattered_by[OF less(2)]
  show ?case
  proof (cases "2 \<le> card F")
    case True
    from obtain_difference_element[OF True]
    obtain x :: 'a where x_in_Union_F: "x \<in> \<Union>F"
                     and x_not_in_Int_F: "x \<notin> \<Inter>F" by blast

    text \<open>Define F0 as the subfamily of F containing sets that don't contain @{term x}.\<close>
    let ?F0 = "{S \<in> F. x \<notin> S}"
    from x_in_Union_F have F0_psubset_F: "?F0 \<subset> F" by blast
    from F0_psubset_F have F0_in_F: "?F0 \<subseteq> F" by blast
    from subset_shattered_by[OF F0_in_F] have shF0_subset_shF: "shattered_by ?F0 \<subseteq> shattered_by F" .
    from F0_in_F have Un_F0_in_Un_F:"\<Union> ?F0 \<subseteq> \<Union> F" by blast

    text \<open>F0 shatters at least as many sets as @{term "card F0"} by the induction hypothesis.\<close>
    note IH_F0 = less(1)[OF psubset_card_mono[OF finite_F F0_psubset_F] rev_finite_subset[OF less(2) Un_F0_in_Un_F]]

    text \<open>Define F1 as the subfamily of F containing sets that contain @{term x}.\<close>
    let ?F1 = "{S \<in> F. x \<in> S}"
    from x_not_in_Int_F have F1_psubset_F: "?F1 \<subset> F" by blast
    from F1_psubset_F have F1_in_F: "?F1 \<subseteq> F" by blast
    from subset_shattered_by[OF F1_in_F] have shF1_subset_shF: "shattered_by ?F1 \<subseteq> shattered_by F" .
    from F1_in_F have Un_F1_in_Un_F:"\<Union> ?F1 \<subseteq> \<Union> F" by blast

    text \<open>F1 shatters at least as many sets as @{term "card F1"} by the induction hypothesis.\<close>
    note IH_F1 = less(1)[OF psubset_card_mono[OF finite_F F1_psubset_F] rev_finite_subset[OF less(2) Un_F1_in_Un_F]]

    from shF0_subset_shF shF1_subset_shF
    have shattered_subset: "(shattered_by ?F0) \<union> (shattered_by ?F1) \<subseteq> shattered_by F" by simp

    text \<open>There is a set with the same cardinality as the intersection of
        @{term "shattered_by F0"} and @{term "shattered_by F1"} which is disjoint from their union and is also contained in @{term "shattered_by F"}.\<close>
    have f_copies_the_intersection:
      "\<exists>f. inj_on f (shattered_by ?F0 \<inter> shattered_by ?F1) \<and>
       (shattered_by ?F0 \<union> shattered_by ?F1) \<inter> (f ` (shattered_by ?F0 \<inter> shattered_by ?F1)) = {} \<and>
       f ` (shattered_by ?F0 \<inter> shattered_by ?F1) \<subseteq> shattered_by F"
    proof
      have x_not_in_shattered: "\<forall>S\<in>(shattered_by ?F0) \<union> (shattered_by ?F1). x \<notin> S" unfolding shattered_by_def by blast

      text \<open>This set is precisely the image of the intersection under @{term "insert x"}.\<close>
      let ?f = "insert x"
      have 0: "inj_on ?f (shattered_by ?F0 \<inter> shattered_by ?F1)"
      proof
        fix X Y
        assume x0: "X \<in> (shattered_by ?F0 \<inter> shattered_by ?F1)" and y0: "Y \<in> (shattered_by ?F0 \<inter> shattered_by ?F1)"
               and 0: "?f X = ?f Y"
        from x_not_in_shattered x0 have "X = ?f X - {x}" by blast
        also from 0 have "... = ?f Y - {x}" by argo
        also from x_not_in_shattered y0 have "... = Y" by blast
        finally show "X = Y" .
      qed

      text \<open>The set is disjoint from the union.\<close>
      have 1: "(shattered_by ?F0 \<union> shattered_by ?F1) \<inter> ?f ` (shattered_by ?F0 \<inter> shattered_by ?F1) = {}"
      proof (rule ccontr)
        assume "(shattered_by ?F0 \<union> shattered_by ?F1) \<inter> ?f ` (shattered_by ?F0 \<inter> shattered_by ?F1) \<noteq> {}"
        then obtain S where 10: "S \<in> (shattered_by ?F0 \<union> shattered_by ?F1)"
                        and 11: "S \<in> ?f ` (shattered_by ?F0 \<inter> shattered_by ?F1)" by auto
        from 10 x_not_in_shattered have "x \<notin> S" by blast
        with 11 show "False" by blast
      qed

      text \<open>This set is also in @{term "shattered_by F"}.\<close>
      have 2: "?f ` (shattered_by ?F0 \<inter> shattered_by ?F1) \<subseteq> shattered_by F"
      proof
        fix S_x
        assume "S_x \<in> ?f ` (shattered_by ?F0 \<inter> shattered_by ?F1)"
        then obtain S where 20: "S \<in> shattered_by ?F0"
                        and 21: "S \<in> shattered_by ?F1"
                        and 22: "S_x = ?f S" by blast
        from x_not_in_shattered 20 have x_not_in_S: "x \<notin> S" by blast

        from 22 Pow_insert[of x S] have "Pow S_x = Pow S \<union> ?f ` Pow S" by fast
        also from 20 have "... = (?F0 \<inter>* S) \<union> (?f ` Pow S)" unfolding shattered_by_def by blast
        also from 21 have "... = (?F0 \<inter>* S) \<union> (?f ` (?F1 \<inter>* S))" unfolding shattered_by_def by force
        also from insert_IntF[of x S ?F1] have "... = (?F0 \<inter>* S) \<union> (?f ` ?F1 \<inter>* (?f S))" by argo
        also from 22 have "... = (?F0 \<inter>* S) \<union> (?F1 \<inter>* S_x)" by blast
        also from 22 have "... = (?F0 \<inter>* S_x) \<union> (?F1 \<inter>* S_x)" by blast
        also from subset_IntF[OF F0_in_F, of S_x] subset_IntF[OF F1_in_F, of S_x] have "... \<subseteq> (F \<inter>* S_x)" by blast
        finally have "Pow S_x \<subseteq> (F \<inter>* S_x)" .
        thus "S_x \<in> shattered_by F" unfolding shattered_by_def by blast
      qed

      from 0 1 2 show "inj_on ?f (shattered_by ?F0 \<inter> shattered_by ?F1) \<and>
        (shattered_by ?F0 \<union> shattered_by ?F1) \<inter> (?f ` (shattered_by ?F0 \<inter> shattered_by ?F1)) = {} \<and>
        ?f ` (shattered_by ?F0 \<inter> shattered_by ?F1) \<subseteq> shattered_by F" by blast
    qed

    have F0_union_F1_is_F: "?F0 \<union> ?F1 = F" by fastforce
    from finite_F have finite_F0: "finite ?F0" and finite_F1: "finite ?F1" by fastforce+
    have disjoint_F0_F1: "?F0 \<inter> ?F1 = {}" by fastforce

    text \<open>We have the following lower bound on the cardinality of @{term "shattered_by F"}:\<close>
    from F0_union_F1_is_F card_Un_disjoint[OF finite_F0 finite_F1 disjoint_F0_F1]
    have "card F = card ?F0 + card ?F1" by argo
    also from IH_F0
    have "... \<le> card (shattered_by ?F0) + card ?F1" by linarith
    also from IH_F1
    have "... \<le> card (shattered_by ?F0) + card (shattered_by ?F1)" by linarith
    also from card_Int_copy[OF finite_shF shattered_subset f_copies_the_intersection]
    have "... \<le> card (shattered_by F)" by argo
    finally show ?thesis .
  next
    text \<open>If @{term F} contains less than 2 sets, the statement follows trivially.\<close>
    case False
    hence "card F = 0 \<or> card F = 1" by force
    thus ?thesis
    proof
      assume "card F = 0"
      thus ?thesis by auto
    next
      assume asm: "card F = 1"
      hence F_not_empty: "F \<noteq> {}" by fastforce
      from shatters_empty[OF F_not_empty] have "{{}} \<subseteq> shattered_by F" unfolding shattered_by_def by fastforce
      from card_mono[OF finite_shF this] asm show ?thesis by fastforce
    qed
  qed
qed

subsection \<open>Sauer-Shelah Lemma\<close>

text \<open>The generalized version immediately implies the Sauer-Shelah Lemma,
      because only @{text "(\<Sum>i\<le>k. n choose i)"} of the subsets of an @{term n}-item universe have cardinality less than @{term "k + (1::nat)"}.
      Thus, when @{text "(\<Sum>i\<le>k. n choose i) < card F"}, there are not enough sets to be shattered,
      so one of the shattered sets must have cardinality at least @{term "k + (1::nat)"}.\<close>

corollary sauer_shelah:
  fixes F :: "'a set set"
  assumes "finite (\<Union>F)" and "(\<Sum>i\<le>k. card (\<Union>F) choose i) < card F"
  shows "\<exists>S. (F shatters S \<and> card S = k + 1)"
proof -
  let ?K = "{S. S \<subseteq> \<Union>F \<and> card S \<le> k}"
  from finite_Pow_iff[of F] assms(1) have finite_Pow_Un: "finite (Pow (\<Union>F))" by fast

  from sauer_shelah_0[OF assms(1)] assms(2) have "(\<Sum>i\<le>k. card (\<Union>F) choose i) < card (shattered_by F)" by linarith
  with choose_row_sum_set[OF assms(1), of k] have "card ?K < card (shattered_by F)" by presburger

  from finite_diff_not_empty[OF finite_subset[OF _ finite_Pow_Un] this]
  obtain S where "S \<in> shattered_by F - ?K" by blast
  then have F_shatters_S: "F shatters S" and "S \<subseteq> \<Union>F" and "\<not>(S \<subseteq> \<Union>F \<and> card S \<le> k)" unfolding shattered_by_def by blast+
  then have card_S_ge_Suc_k: "k + 1 \<le> card S" by simp
  from obtain_subset_with_card_n[OF card_S_ge_Suc_k] obtain S' where "card S' = k + 1" and "S' \<subseteq> S" by blast
  from this(1) supset_shatters[OF this(2) F_shatters_S] show ?thesis by blast
qed

subsection \<open>Sauer-Shelah Lemma for hypergraphs\<close>

text \<open>If we designate X to be the set of hyperedges and S the set of vertices, we can also formulate the Sauer-Shelah Lemma in terms of hypergraphs.
      In this form, the statement provides a sufficient condition for the existence of an hyperedge of a given cardinality which is shattered by the set of edges.\<close>

corollary sauer_shelah_2:
  fixes X :: "'a set set" and S :: "'a set"
  assumes "finite S" and "X \<subseteq> Pow S" and "(\<Sum>i\<le>k. card S choose i) < card X"
  shows "\<exists>Y. (X shatters Y \<and> card Y = k + 1)"
proof -
  from assms(2) have 0: "\<Union>X \<subseteq> S" by blast
  then have "(\<Sum>i\<le>k. card (\<Union>X) choose i) \<le> (\<Sum>i\<le>k. card S choose i)"
    by (simp add: assms(1) card_mono choose_mono sum_mono)
  then show ?thesis
    using "0" assms finite_subset sauer_shelah by fastforce
qed

subsection \<open>Alternative statement of the Sauer-Shelah Lemma\<close>

text \<open>We can also state the Sauer-Shelah Lemma in terms of the @{term VC_dim}. If the VC-dimension of @{term F} is @{term k} then @{term F}
      can consist at most of @{text "(\<Sum>i\<le>k. card (\<Union>F) choose i)"} sets which is in @{text "\<O>(card (\<Union>F)^k)"}.\<close>

corollary sauer_shelah_alt:
  assumes "finite (\<Union>F)" and "VC_dim F = k"
  shows "card F \<le> (\<Sum>i\<le>k. card (\<Union>F) choose i)"
proof (rule ccontr)
  assume "\<not> card F \<le> (\<Sum>i\<le>k. card (\<Union>F) choose i)" hence "(\<Sum>i\<le>k. card (\<Union>F) choose i) < card F" by linarith
  then obtain S where "F shatters S" and "card S = k + 1"
    by (meson assms(1) sauer_shelah)
  then have \<section>: "k + 1 \<in> {card S | S. F shatters S}"
    by simp metis
  have "finite {A. F shatters A}"
    by (metis \<open>finite (\<Union> F)\<close> finite_shattered_by shattered_by_def)
  then have "bdd_above {card A |A. F shatters A}"
    by simp
  then have "k + 1 \<le> Sup {card A |A. F shatters A}"
    by (smt (verit, best) "\<section>" cSup_upper)
  then have "k + 1 \<le> VC_dim F"
    by (simp add: VC_dim_def)
  then show False
    using assms(2) by auto
qed

end


(*<*)theory CTL imports Base begin(*>*)

subsection{*Computation Tree Logic --- CTL*}

text{*\label{sec:CTL}
\index{CTL|(}%
The semantics of PDL only needs reflexive transitive closure.
Let us be adventurous and introduce a more expressive temporal operator.
We extend the datatype
@{text formula} by a new constructor
*}
(*<*)
datatype formula = Atom "atom"
                  | Neg formula
                  | And formula formula
                  | AX formula
                  | EF formula(*>*)
                  | AF formula

text{*\noindent
which stands for ``\emph{A}lways in the \emph{F}uture'':
on all infinite paths, at some point the formula holds.
Formalizing the notion of an infinite path is easy
in HOL: it is simply a function from @{typ nat} to @{typ state}.
*}

definition Paths :: "state \<Rightarrow> (nat \<Rightarrow> state)set" where
"Paths s \<equiv> {p. s = p 0 \<and> (\<forall>i. (p i, p(i+1)) \<in> M)}"

text{*\noindent
This definition allows a succinct statement of the semantics of @{const AF}:
\footnote{Do not be misled: neither datatypes nor recursive functions can be
extended by new constructors or equations. This is just a trick of the
presentation (see \S\ref{sec:doc-prep-suppress}). In reality one has to define
a new datatype and a new function.}
*}
(*<*)
primrec valid :: "state \<Rightarrow> formula \<Rightarrow> bool" ("(_ \<Turnstile> _)" [80,80] 80) where
"s \<Turnstile> Atom a  =  (a \<in> L s)" |
"s \<Turnstile> Neg f   = (~(s \<Turnstile> f))" |
"s \<Turnstile> And f g = (s \<Turnstile> f \<and> s \<Turnstile> g)" |
"s \<Turnstile> AX f    = (\<forall>t. (s,t) \<in> M \<longrightarrow> t \<Turnstile> f)" |
"s \<Turnstile> EF f    = (\<exists>t. (s,t) \<in> M\<^sup>* \<and> t \<Turnstile> f)" |
(*>*)
"s \<Turnstile> AF f    = (\<forall>p \<in> Paths s. \<exists>i. p i \<Turnstile> f)"

text{*\noindent
Model checking @{const AF} involves a function which
is just complicated enough to warrant a separate definition:
*}

definition af :: "state set \<Rightarrow> state set \<Rightarrow> state set" where
"af A T \<equiv> A \<union> {s. \<forall>t. (s, t) \<in> M \<longrightarrow> t \<in> T}"

text{*\noindent
Now we define @{term "mc(AF f)"} as the least set @{term T} that includes
@{term"mc f"} and all states all of whose direct successors are in @{term T}:
*}
(*<*)
primrec mc :: "formula \<Rightarrow> state set" where
"mc(Atom a)  = {s. a \<in> L s}" |
"mc(Neg f)   = -mc f" |
"mc(And f g) = mc f \<inter> mc g" |
"mc(AX f)    = {s. \<forall>t. (s,t) \<in> M  \<longrightarrow> t \<in> mc f}" |
"mc(EF f)    = lfp(\<lambda>T. mc f \<union> M\<inverse> `` T)"|(*>*)
"mc(AF f)    = lfp(af(mc f))"

text{*\noindent
Because @{const af} is monotone in its second argument (and also its first, but
that is irrelevant), @{term"af A"} has a least fixed point:
*}

lemma mono_af: "mono(af A)"
apply(simp add: mono_def af_def)
apply blast
done
(*<*)
lemma mono_ef: "mono(\<lambda>T. A \<union> M\<inverse> `` T)"
apply(rule monoI)
by(blast)

lemma EF_lemma:
  "lfp(\<lambda>T. A \<union> M\<inverse> `` T) = {s. \<exists>t. (s,t) \<in> M\<^sup>* \<and> t \<in> A}"
apply(rule equalityI)
 apply(rule subsetI)
 apply(simp)
 apply(erule lfp_induct_set)
  apply(rule mono_ef)
 apply(simp)
 apply(blast intro: rtrancl_trans)
apply(rule subsetI)
apply(simp, clarify)
apply(erule converse_rtrancl_induct)
 apply(subst lfp_unfold[OF mono_ef])
 apply(blast)
apply(subst lfp_unfold[OF mono_ef])
by(blast)
(*>*)
text{*
All we need to prove now is  @{prop"mc(AF f) = {s. s \<Turnstile> AF f}"}, which states
that @{term mc} and @{text"\<Turnstile>"} agree for @{const AF}\@.
This time we prove the two inclusions separately, starting
with the easy one:
*}

theorem AF_lemma1: "lfp(af A) \<subseteq> {s. \<forall>p \<in> Paths s. \<exists>i. p i \<in> A}"

txt{*\noindent
In contrast to the analogous proof for @{const EF}, and just
for a change, we do not use fixed point induction.  Park-induction,
named after David Park, is weaker but sufficient for this proof:
\begin{center}
@{thm lfp_lowerbound[of _ "S",no_vars]} \hfill (@{thm[source]lfp_lowerbound})
\end{center}
The instance of the premise @{prop"f S \<subseteq> S"} is proved pointwise,
a decision that \isa{auto} takes for us:
*}
apply(rule lfp_lowerbound)
apply(auto simp add: af_def Paths_def)

txt{*
@{subgoals[display,indent=0,margin=70,goals_limit=1]}
In this remaining case, we set @{term t} to @{term"p(1::nat)"}.
The rest is automatic, which is surprising because it involves
finding the instantiation @{term"\<lambda>i::nat. p(i+1)"}
for @{text"\<forall>p"}.
*}

apply(erule_tac x = "p 1" in allE)
apply(auto)
done

text{*
The opposite inclusion is proved by contradiction: if some state
@{term s} is not in @{term"lfp(af A)"}, then we can construct an
infinite @{term A}-avoiding path starting from~@{term s}. The reason is
that by unfolding @{const lfp} we find that if @{term s} is not in
@{term"lfp(af A)"}, then @{term s} is not in @{term A} and there is a
direct successor of @{term s} that is again not in \mbox{@{term"lfp(af
A)"}}. Iterating this argument yields the promised infinite
@{term A}-avoiding path. Let us formalize this sketch.

The one-step argument in the sketch above
is proved by a variant of contraposition:
*}

lemma not_in_lfp_afD:
 "s \<notin> lfp(af A) \<Longrightarrow> s \<notin> A \<and> (\<exists> t. (s,t) \<in> M \<and> t \<notin> lfp(af A))"
apply(erule contrapos_np)
apply(subst lfp_unfold[OF mono_af])
apply(simp add: af_def)
done

text{*\noindent
We assume the negation of the conclusion and prove @{term"s : lfp(af A)"}.
Unfolding @{const lfp} once and
simplifying with the definition of @{const af} finishes the proof.

Now we iterate this process. The following construction of the desired
path is parameterized by a predicate @{term Q} that should hold along the path:
*}

primrec path :: "state \<Rightarrow> (state \<Rightarrow> bool) \<Rightarrow> (nat \<Rightarrow> state)" where
"path s Q 0 = s" |
"path s Q (Suc n) = (SOME t. (path s Q n,t) \<in> M \<and> Q t)"

text{*\noindent
Element @{term"n+1::nat"} on this path is some arbitrary successor
@{term t} of element @{term n} such that @{term"Q t"} holds.  Remember that @{text"SOME t. R t"}
is some arbitrary but fixed @{term t} such that @{prop"R t"} holds (see \S\ref{sec:SOME}). Of
course, such a @{term t} need not exist, but that is of no
concern to us since we will only use @{const path} when a
suitable @{term t} does exist.

Let us show that if each state @{term s} that satisfies @{term Q}
has a successor that again satisfies @{term Q}, then there exists an infinite @{term Q}-path:
*}

lemma infinity_lemma:
  "\<lbrakk> Q s; \<forall>s. Q s \<longrightarrow> (\<exists> t. (s,t) \<in> M \<and> Q t) \<rbrakk> \<Longrightarrow>
   \<exists>p\<in>Paths s. \<forall>i. Q(p i)"

txt{*\noindent
First we rephrase the conclusion slightly because we need to prove simultaneously
both the path property and the fact that @{term Q} holds:
*}

apply(subgoal_tac
  "\<exists>p. s = p 0 \<and> (\<forall>i::nat. (p i, p(i+1)) \<in> M \<and> Q(p i))")

txt{*\noindent
From this proposition the original goal follows easily:
*}

 apply(simp add: Paths_def, blast)

txt{*\noindent
The new subgoal is proved by providing the witness @{term "path s Q"} for @{term p}:
*}

apply(rule_tac x = "path s Q" in exI)
apply(clarsimp)

txt{*\noindent
After simplification and clarification, the subgoal has the following form:
@{subgoals[display,indent=0,margin=70,goals_limit=1]}
It invites a proof by induction on @{term i}:
*}

apply(induct_tac i)
 apply(simp)

txt{*\noindent
After simplification, the base case boils down to
@{subgoals[display,indent=0,margin=70,goals_limit=1]}
The conclusion looks exceedingly trivial: after all, @{term t} is chosen such that @{prop"(s,t):M"}
holds. However, we first have to show that such a @{term t} actually exists! This reasoning
is embodied in the theorem @{thm[source]someI2_ex}:
@{thm[display,eta_contract=false]someI2_ex}
When we apply this theorem as an introduction rule, @{text"?P x"} becomes
@{prop"(s, x) : M & Q x"} and @{text"?Q x"} becomes @{prop"(s,x) : M"} and we have to prove
two subgoals: @{prop"EX a. (s, a) : M & Q a"}, which follows from the assumptions, and
@{prop"(s, x) : M & Q x ==> (s,x) : M"}, which is trivial. Thus it is not surprising that
@{text fast} can prove the base case quickly:
*}

 apply(fast intro: someI2_ex)

txt{*\noindent
What is worth noting here is that we have used \methdx{fast} rather than
@{text blast}.  The reason is that @{text blast} would fail because it cannot
cope with @{thm[source]someI2_ex}: unifying its conclusion with the current
subgoal is non-trivial because of the nested schematic variables. For
efficiency reasons @{text blast} does not even attempt such unifications.
Although @{text fast} can in principle cope with complicated unification
problems, in practice the number of unifiers arising is often prohibitive and
the offending rule may need to be applied explicitly rather than
automatically. This is what happens in the step case.

The induction step is similar, but more involved, because now we face nested
occurrences of @{text SOME}. As a result, @{text fast} is no longer able to
solve the subgoal and we apply @{thm[source]someI2_ex} by hand.  We merely
show the proof commands but do not describe the details:
*}

apply(simp)
apply(rule someI2_ex)
 apply(blast)
apply(rule someI2_ex)
 apply(blast)
apply(blast)
done

text{*
Function @{const path} has fulfilled its purpose now and can be forgotten.
It was merely defined to provide the witness in the proof of the
@{thm[source]infinity_lemma}. Aficionados of minimal proofs might like to know
that we could have given the witness without having to define a new function:
the term
@{term[display]"rec_nat s (\<lambda>n t. SOME u. (t,u)\<in>M \<and> Q u)"}
is extensionally equal to @{term"path s Q"},
where @{term rec_nat} is the predefined primitive recursor on @{typ nat}.
*}
(*<*)
lemma
"\<lbrakk> Q s; \<forall> s. Q s \<longrightarrow> (\<exists> t. (s,t)\<in>M \<and> Q t) \<rbrakk> \<Longrightarrow>
 \<exists> p\<in>Paths s. \<forall> i. Q(p i)"
apply(subgoal_tac
 "\<exists> p. s = p 0 \<and> (\<forall> i. (p i,p(Suc i))\<in>M \<and> Q(p i))")
 apply(simp add: Paths_def)
 apply(blast)
apply(rule_tac x = "rec_nat s (\<lambda>n t. SOME u. (t,u)\<in>M \<and> Q u)" in exI)
apply(simp)
apply(intro strip)
apply(induct_tac i)
 apply(simp)
 apply(fast intro: someI2_ex)
apply(simp)
apply(rule someI2_ex)
 apply(blast)
apply(rule someI2_ex)
 apply(blast)
by(blast)
(*>*)

text{*
At last we can prove the opposite direction of @{thm[source]AF_lemma1}:
*}

theorem AF_lemma2: "{s. \<forall>p \<in> Paths s. \<exists>i. p i \<in> A} \<subseteq> lfp(af A)"

txt{*\noindent
The proof is again pointwise and then by contraposition:
*}

apply(rule subsetI)
apply(erule contrapos_pp)
apply simp

txt{*
@{subgoals[display,indent=0,goals_limit=1]}
Applying the @{thm[source]infinity_lemma} as a destruction rule leaves two subgoals, the second
premise of @{thm[source]infinity_lemma} and the original subgoal:
*}

apply(drule infinity_lemma)

txt{*
@{subgoals[display,indent=0,margin=65]}
Both are solved automatically:
*}

 apply(auto dest: not_in_lfp_afD)
done

text{*
If you find these proofs too complicated, we recommend that you read
\S\ref{sec:CTL-revisited}, where we show how inductive definitions lead to
simpler arguments.

The main theorem is proved as for PDL, except that we also derive the
necessary equality @{text"lfp(af A) = ..."} by combining
@{thm[source]AF_lemma1} and @{thm[source]AF_lemma2} on the spot:
*}

theorem "mc f = {s. s \<Turnstile> f}"
apply(induct_tac f)
apply(auto simp add: EF_lemma equalityI[OF AF_lemma1 AF_lemma2])
done

text{*

The language defined above is not quite CTL\@. The latter also includes an
until-operator @{term"EU f g"} with semantics ``there \emph{E}xists a path
where @{term f} is true \emph{U}ntil @{term g} becomes true''.  We need
an auxiliary function:
*}

primrec
until:: "state set \<Rightarrow> state set \<Rightarrow> state \<Rightarrow> state list \<Rightarrow> bool" where
"until A B s []    = (s \<in> B)" |
"until A B s (t#p) = (s \<in> A \<and> (s,t) \<in> M \<and> until A B t p)"
(*<*)definition
 eusem :: "state set \<Rightarrow> state set \<Rightarrow> state set" where
"eusem A B \<equiv> {s. \<exists>p. until A B s p}"(*>*)

text{*\noindent
Expressing the semantics of @{term EU} is now straightforward:
@{prop[display]"s \<Turnstile> EU f g = (\<exists>p. until {t. t \<Turnstile> f} {t. t \<Turnstile> g} s p)"}
Note that @{term EU} is not definable in terms of the other operators!

Model checking @{term EU} is again a least fixed point construction:
@{text[display]"mc(EU f g) = lfp(\<lambda>T. mc g \<union> mc f \<inter> (M\<inverse> `` T))"}

\begin{exercise}
Extend the datatype of formulae by the above until operator
and prove the equivalence between semantics and model checking, i.e.\ that
@{prop[display]"mc(EU f g) = {s. s \<Turnstile> EU f g}"}
%For readability you may want to annotate {term EU} with its customary syntax
%{text[display]"| EU formula formula    E[_ U _]"}
%which enables you to read and write {text"E[f U g]"} instead of {term"EU f g"}.
\end{exercise}
For more CTL exercises see, for example, Huth and Ryan @{cite "Huth-Ryan-book"}.
*}

(*<*)
definition eufix :: "state set \<Rightarrow> state set \<Rightarrow> state set \<Rightarrow> state set" where
"eufix A B T \<equiv> B \<union> A \<inter> (M\<inverse> `` T)"

lemma "lfp(eufix A B) \<subseteq> eusem A B"
apply(rule lfp_lowerbound)
apply(auto simp add: eusem_def eufix_def)
 apply(rule_tac x = "[]" in exI)
 apply simp
apply(rule_tac x = "xa#xb" in exI)
apply simp
done

lemma mono_eufix: "mono(eufix A B)"
apply(simp add: mono_def eufix_def)
apply blast
done

lemma "eusem A B \<subseteq> lfp(eufix A B)"
apply(clarsimp simp add: eusem_def)
apply(erule rev_mp)
apply(rule_tac x = x in spec)
apply(induct_tac p)
 apply(subst lfp_unfold[OF mono_eufix])
 apply(simp add: eufix_def)
apply(clarsimp)
apply(subst lfp_unfold[OF mono_eufix])
apply(simp add: eufix_def)
apply blast
done

(*
definition eusem :: "state set \<Rightarrow> state set \<Rightarrow> state set" where
"eusem A B \<equiv> {s. \<exists>p\<in>Paths s. \<exists>j. p j \<in> B \<and> (\<forall>i < j. p i \<in> A)}"

axiomatization where
M_total: "\<exists>t. (s,t) \<in> M"

consts apath :: "state \<Rightarrow> (nat \<Rightarrow> state)"
primrec
"apath s 0 = s"
"apath s (Suc i) = (SOME t. (apath s i,t) \<in> M)"

definition pcons :: "state \<Rightarrow> (nat \<Rightarrow> state) \<Rightarrow> (nat \<Rightarrow> state)" where
"pcons s p == \<lambda>i. case i of 0 \<Rightarrow> s | Suc j \<Rightarrow> p j"

lemma pcons_PathI: "[| (s,t) : M; p \<in> Paths t |] ==> pcons s p \<in> Paths s";
by(simp add: Paths_def pcons_def split: nat.split);

lemma "lfp(eufix A B) \<subseteq> eusem A B"
apply(rule lfp_lowerbound)
apply(clarsimp simp add: eusem_def eufix_def);
apply(erule disjE);
 apply(rule_tac x = "apath x" in bexI);
  apply(rule_tac x = 0 in exI);
  apply simp;
 apply simp;
apply(clarify);
apply(rule_tac x = "pcons xb p" in bexI);
 apply(rule_tac x = "j+1" in exI);
 apply (simp add: pcons_def split: nat.split);
apply (simp add: pcons_PathI)
done
*)
(*>*)

text{* Let us close this section with a few words about the executability of
our model checkers.  It is clear that if all sets are finite, they can be
represented as lists and the usual set operations are easily
implemented. Only @{const lfp} requires a little thought.  Fortunately, theory
@{text While_Combinator} in the Library~@{cite "HOL-Library"} provides a
theorem stating that in the case of finite sets and a monotone
function~@{term F}, the value of \mbox{@{term"lfp F"}} can be computed by
iterated application of @{term F} to~@{term"{}"} until a fixed point is
reached. It is actually possible to generate executable functional programs
from HOL definitions, but that is beyond the scope of the tutorial.%
\index{CTL|)} *}
(*<*)end(*>*)


(* ************************************************************************** *)
(* Title:      Generated_Rings.thy                                            *)
(* Author:     Martin Baillon                                                 *)
(* ************************************************************************** *)

theory Generated_Rings
  imports Subrings
begin

section\<open>Generated Rings\<close>

inductive_set
  generate_ring :: "('a, 'b) ring_scheme \<Rightarrow> 'a set \<Rightarrow> 'a set"
  for R and H where
    one:   "\<one>\<^bsub>R\<^esub> \<in> generate_ring R H"
  | incl:  "h \<in> H \<Longrightarrow> h \<in> generate_ring R H"
  | a_inv: "h \<in> generate_ring R H \<Longrightarrow> \<ominus>\<^bsub>R\<^esub> h \<in> generate_ring R H"
  | eng_add : "\<lbrakk> h1 \<in> generate_ring R H; h2 \<in> generate_ring R H \<rbrakk> \<Longrightarrow> h1 \<oplus>\<^bsub>R\<^esub> h2 \<in> generate_ring R H"
  | eng_mult: "\<lbrakk> h1 \<in> generate_ring R H; h2 \<in> generate_ring R H \<rbrakk> \<Longrightarrow> h1 \<otimes>\<^bsub>R\<^esub> h2 \<in> generate_ring R H"

subsection\<open>Basic Properties of Generated Rings - First Part\<close>

lemma (in ring) generate_ring_in_carrier:
  assumes "H \<subseteq> carrier R"
  shows "h \<in> generate_ring R H \<Longrightarrow> h \<in> carrier R"
  apply (induction rule: generate_ring.induct) using assms
  by blast+

lemma (in ring) generate_ring_incl:
  assumes "H \<subseteq> carrier R"
  shows "generate_ring R H \<subseteq> carrier R"
  using generate_ring_in_carrier[OF assms] by auto

lemma (in ring) zero_in_generate: "\<zero>\<^bsub>R\<^esub> \<in> generate_ring R H"
  using one a_inv by (metis generate_ring.eng_add one_closed r_neg)

lemma (in ring) generate_ring_is_subring:
  assumes "H \<subseteq> carrier R"
  shows "subring (generate_ring R H) R"
  by (auto intro!: subringI[of "generate_ring R H"]
         simp add: generate_ring_in_carrier[OF assms] one a_inv eng_mult eng_add)

lemma (in ring) generate_ring_is_ring:
  assumes "H \<subseteq> carrier R"
  shows "ring (R \<lparr> carrier := generate_ring R H \<rparr>)"
  using subring_iff[OF generate_ring_incl[OF assms]] generate_ring_is_subring[OF assms] by simp

lemma (in ring) generate_ring_min_subring1:
  assumes "H \<subseteq> carrier R" and "subring E R" "H \<subseteq> E"
  shows "generate_ring R H \<subseteq> E"
proof
  fix h assume h: "h \<in> generate_ring R H"
  show "h \<in> E"
    using h and assms(3)
      by (induct rule: generate_ring.induct)
         (auto simp add: subringE(3,5-7)[OF assms(2)])
qed

lemma (in ring) generate_ringI:
  assumes "H \<subseteq> carrier R"
    and "subring E R" "H \<subseteq> E"
    and "\<And>K. \<lbrakk> subring K R; H \<subseteq> K \<rbrakk> \<Longrightarrow> E \<subseteq> K"
  shows "E = generate_ring R H"
proof
  show "E \<subseteq> generate_ring R H"
    using assms generate_ring_is_subring generate_ring.incl by (metis subset_iff)
  show "generate_ring R H \<subseteq> E"
    using generate_ring_min_subring1[OF assms(1-3)] by simp
qed

lemma (in ring) generate_ringE:
  assumes "H \<subseteq> carrier R" and "E = generate_ring R H"
  shows "subring E R" and "H \<subseteq> E" and "\<And>K. \<lbrakk> subring K R; H \<subseteq> K \<rbrakk> \<Longrightarrow> E \<subseteq> K"
proof -
  show "subring E R" using assms generate_ring_is_subring by simp
  show "H \<subseteq> E" using assms(2) by (simp add: generate_ring.incl subsetI)
  show "\<And>K. subring K R  \<Longrightarrow> H \<subseteq> K \<Longrightarrow> E \<subseteq> K"
    using assms generate_ring_min_subring1 by auto
qed

lemma (in ring) generate_ring_min_subring2:
  assumes "H \<subseteq> carrier R"
  shows "generate_ring R H = \<Inter>{K. subring K R \<and> H \<subseteq> K}"
proof
  have "subring (generate_ring R H) R \<and> H \<subseteq> generate_ring R H"
    by (simp add: assms generate_ringE(2) generate_ring_is_subring)
  thus "\<Inter>{K. subring K R \<and> H \<subseteq> K} \<subseteq> generate_ring R H" by blast
next
  have "\<And>K. subring K R \<and> H \<subseteq> K \<Longrightarrow> generate_ring R H \<subseteq> K"
    by (simp add: assms generate_ring_min_subring1)
  thus "generate_ring R H \<subseteq> \<Inter>{K. subring K R \<and> H \<subseteq> K}" by blast
qed

lemma (in ring) mono_generate_ring:
  assumes "I \<subseteq> J" and "J \<subseteq> carrier R"
  shows "generate_ring R I \<subseteq> generate_ring R J"
proof-
  have "I \<subseteq> generate_ring R J "
    using assms generate_ringE(2) by blast
  thus "generate_ring R I \<subseteq> generate_ring R J"
    using generate_ring_min_subring1[of I "generate_ring R J"] assms generate_ring_is_subring[OF assms(2)]
    by blast
qed

lemma (in ring) subring_gen_incl :
  assumes "subring H R"
    and  "subring K R"
    and "I \<subseteq> H"
    and "I \<subseteq> K"
  shows "generate_ring (R\<lparr>carrier := K\<rparr>) I \<subseteq> generate_ring (R\<lparr>carrier := H\<rparr>) I"
proof
  {fix J assume J_def : "subring J R" "I \<subseteq> J"
    have "generate_ring (R \<lparr> carrier := J \<rparr>) I \<subseteq> J"
      using ring.mono_generate_ring[of "(R\<lparr>carrier := J\<rparr>)" I J ] subring_is_ring[OF J_def(1)]
          ring.generate_ring_in_carrier[of "R\<lparr>carrier := J\<rparr>"]  ring_axioms J_def(2)
      by auto}
  note incl_HK = this
  {fix x have "x \<in> generate_ring (R\<lparr>carrier := K\<rparr>) I \<Longrightarrow> x \<in> generate_ring (R\<lparr>carrier := H\<rparr>) I"
    proof (induction  rule : generate_ring.induct)
      case one
        have "\<one>\<^bsub>R\<lparr>carrier := H\<rparr>\<^esub> \<otimes> \<one>\<^bsub>R\<lparr>carrier := K\<rparr>\<^esub> = \<one>\<^bsub>R\<lparr>carrier := H\<rparr>\<^esub>" by simp
        moreover have "\<one>\<^bsub>R\<lparr>carrier := H\<rparr>\<^esub> \<otimes> \<one>\<^bsub>R\<lparr>carrier := K\<rparr>\<^esub> = \<one>\<^bsub>R\<lparr>carrier := K\<rparr>\<^esub>" by simp
        ultimately show ?case using assms generate_ring.one by metis
    next
      case (incl h) thus ?case using generate_ring.incl by force
    next
      case (a_inv h)
      note hyp = this
      have "a_inv (R\<lparr>carrier := K\<rparr>) h = a_inv R h"
        using assms group.m_inv_consistent[of "add_monoid R" K] a_comm_group incl_HK[of K] hyp
        unfolding subring_def comm_group_def a_inv_def by auto
      moreover have "a_inv (R\<lparr>carrier := H\<rparr>) h = a_inv R h"
        using assms group.m_inv_consistent[of "add_monoid R" H] a_comm_group incl_HK[of H] hyp
        unfolding subring_def comm_group_def a_inv_def by auto
      ultimately show ?case using generate_ring.a_inv a_inv.IH by fastforce
    next
      case (eng_add h1 h2)
      thus ?case using incl_HK assms generate_ring.eng_add by force
    next
      case (eng_mult h1 h2)
      thus ?case using generate_ring.eng_mult by force
    qed}
  thus "\<And>x. x \<in> generate_ring (R\<lparr>carrier := K\<rparr>) I \<Longrightarrow> x \<in> generate_ring (R\<lparr>carrier := H\<rparr>) I"
    by auto
qed

lemma (in ring) subring_gen_equality:
  assumes "subring H R" "K \<subseteq> H"
  shows "generate_ring R K = generate_ring (R \<lparr> carrier := H \<rparr>) K"
  using subring_gen_incl[OF assms(1)carrier_is_subring assms(2)] assms subringE(1)
        subring_gen_incl[OF carrier_is_subring assms(1) _ assms(2)]
  by force

end


theory Add
imports Main
begin

(*funcao recursiva de somar nat*)
primrec add::"nat \<Rightarrow> nat \<Rightarrow> nat"
where
  add01: "add x 0 = x" |
  add02: "add x (Suc y) = Suc (add x y)"

theorem th_add01as:"\<forall>x y. add (add x y) z = add x (add y z)"
apply(induction z)
apply(simp)
apply(simp)
  done

theorem addT0:"add 1 x = Suc x"
proof(induct x)
  show "add 1 0 = Suc 0"
  proof -
    have "add 1 0 = 1" by (simp only:add01)
    also have "... = Suc 0" by (simp only:algebra)
    finally show "add 1 0 = Suc 0" by simp
  qed
next
  fix x0::nat
  assume HIP:"add 1 x0 = Suc x0"
  show "add 1 (Suc x0) = Suc (Suc x0)"
  proof -
    have "add 1 (Suc x0) = Suc (add 1 x0)" by (simp only:add02)
    also have "... = Suc (Suc x0)" by (simp only:HIP)
    finally show "add 1 (Suc x0) = Suc (Suc x0)" by simp
  qed
qed

theorem addT1:"\<forall>x. add x y = x + y"
proof (induct y)
  show "\<forall>x. add x 0 = x + 0"
  proof (rule allI)
    fix x0::nat
    have "add x0 0 = x0" by (simp only:add01)
    also have "... = x0 + 0" by simp
    finally show "add x0 0 = x0 + 0" by simp
  qed
next
  fix y0::nat
  assume HIP:"\<forall>x. add x y0 = x + y0"
  show "\<forall>x. add x (Suc y0) = x + (Suc y0)"
  proof (rule allI)
    fix x0::nat
    have "add x0 (Suc y0) = Suc (add x0 y0)" by (simp only:add02)
    also have "... = Suc (x0 + y0)" by (simp only:HIP)
    also have "... = x0 + (Suc y0)" by simp
    finally show "add x0 (Suc y0) = x0 + (Suc y0)" by simp
  qed
qed

inductive ev::"nat \<Rightarrow> bool"
where
  ev0: "ev 0" |
  ev1: "ev n \<Longrightarrow> ev (Suc (Suc n))"

thm "ev.induct"

lemma "ev (Suc(Suc(Suc(Suc 0))))"
apply(rule ev1)
apply(rule ev1)
apply(rule ev0)
done

fun even::"nat \<Rightarrow> bool"
where
  "even 0 = True" |
  "even (Suc 0) = False" |
  "even (Suc(Suc n)) = even n"

theorem "ev n \<Longrightarrow> even n"
apply(induct rule: ev.induct)
apply(auto)
done

theorem "even n \<Longrightarrow> ev n"
apply(induct rule: even.induct)
apply(simp add: ev0)
apply(simp)
apply(simp add: ev1)
done

theorem "ev n \<Longrightarrow> \<exists>k. n = 2*k"
apply(induct rule: ev.induct)
apply(simp)
apply(arith)
done

(*provas isar*)

thm nat.induct
print_statement nat.induct

theorem th_add01isar:"\<forall>x y. add (add x y) z = add x (add y z)"
proof (induction z)
show "\<forall>x y. add (add x y) 0 = add x (add y 0)"
by simp
next
fix x0::nat
assume HI:"\<forall>x y. add (add x y) x0 = add x (add y x0)"
show "\<forall>x y. add (add x y) (Suc x0) = add x (add y (Suc x0))"
by (simp add:HI)
qed

theorem th_add01isar2:"\<forall>x y. add (add x y) z = add x (add y z)"
proof (induction z)
show "\<forall>x y. add (add x y) 0 = add x (add y 0)"
proof(rule allI, rule allI)
fix x0::nat and y0::nat
have "add (add x0 y0) 0 = add x0 y0"
by (simp only:add01)
also have "... = add x0 (add y0 0)"
by (simp only:add01)
finally show "add (add x0 y0) 0 = add x0 (add y0 0)"
by simp
qed
next
fix z0::nat
assume HI:"\<forall>x y. add (add x y) z0 = add x (add y z0)"
show "\<forall>x y. add (add x y)(Suc z0) = add x (add y (Suc z0))"
proof(rule allI, rule allI)
fix x0::nat and y0::nat
have "add (add x0 y0)(Suc z0) = Suc(add (add x0 y0) z0)" by (simp only:add02)
also have "... = Suc(add x0 (add y0 z0))" by (simp only:HI)
also have "... = add x0 (Suc (add y0 z0))" by (simp only:add02)
also have "... = add x0 (add y0 (Suc z0))" by (simp only:add02)
finally show "add (add x0 y0)(Suc z0) = add x0 (add y0 (Suc z0))" by simp
qed
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_nat_MSortBUCount
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun map :: "('a => 'b) => 'a list => 'b list" where
  "map f (nil2) = nil2"
| "map f (cons2 y xs) = cons2 (f y) (map f xs)"

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun lmerge :: "Nat list => Nat list => Nat list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if le z x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun pairwise :: "(Nat list) list => (Nat list) list" where
  "pairwise (nil2) = nil2"
| "pairwise (cons2 xs (nil2)) = cons2 xs (nil2)"
| "pairwise (cons2 xs (cons2 ys xss)) =
     cons2 (lmerge xs ys) (pairwise xss)"

(*fun did not finish the proof*)
function mergingbu :: "(Nat list) list => Nat list" where
  "mergingbu (nil2) = nil2"
| "mergingbu (cons2 xs (nil2)) = xs"
| "mergingbu (cons2 xs (cons2 z x2)) =
     mergingbu (pairwise (cons2 xs (cons2 z x2)))"
  by pat_completeness auto

fun msortbu :: "Nat list => Nat list" where
  "msortbu x = mergingbu (map (% (y :: Nat) => cons2 y (nil2)) x)"

fun count :: "'a => 'a list => Nat" where
  "count x (nil2) = Z"
| "count x (cons2 z ys) =
     (if (x = z) then plus (S Z) (count x ys) else count x ys)"

theorem property0 :
  "((count x (msortbu xs)) = (count x xs))"
  oops

end