(*<*)
theory Blue_Eyes
  imports
    "HOL-Combinatorics.Transposition"
begin
(*>*)

section \<open>Introduction\<close>

text \<open>The original problem statement @{cite xkcd} explains the puzzle well:

\begin{quotation}
A group of people with assorted eye colors live on an island.
They are all perfect logicians -- if a conclusion can be logically deduced,
they will do it instantly.
No one knows the color of their eyes.
Every night at midnight, a ferry stops at the island.
Any islanders who have figured out the color of their own eyes then leave the island, and the rest stay.
Everyone can see everyone else at all times
and keeps a count of the number of people they see with each eye color (excluding themselves),
but they cannot otherwise communicate.
Everyone on the island knows all the rules in this paragraph.

On this island there are 100 blue-eyed people,
100 brown-eyed people,
and the Guru (she happens to have green eyes).
So any given blue-eyed person can see 100 people with brown eyes and 99 people with blue eyes (and one with green),
but that does not tell him his own eye color;
as far as he knows the totals could be 101 brown and 99 blue.
Or 100 brown, 99 blue, and he could have red eyes.

The Guru is allowed to speak once (let's say at noon),
on one day in all their endless years on the island.
Standing before the islanders, she says the following:

``I can see someone who has blue eyes.''

Who leaves the island, and on what night?
\end{quotation}

It might seem weird that the Guru's declaration gives anyone any new information.
For an informal discussion, see \cite[Section~1.1]{fagin1995}.\<close>

section \<open>Modeling the world \label{sec:world}\<close>

text \<open>We begin by fixing two type variables: @{typ "'color"} and @{typ "'person"}.
The puzzle doesn't specify how many eye colors are possible, but four are mentioned.
Crucially, we must assume they are distinct. We specify the existence of colors other
than blue and brown, even though we don't mention them later, because when blue and brown
are the only possible colors, the puzzle has a different solution — the brown-eyed logicians
may leave one day after the blue-eyed ones.

We refrain from specifying the exact population of the island, choosing to only assume
it is finite and denote a specific person as the Guru.

We could also model the Guru as an outside entity instead of a participant. This doesn't change
the answer and results in a slightly simpler proof, but is less faithful to the problem statement.\<close>

context
  fixes blue brown green red :: 'color
  assumes colors_distinct: "distinct [blue, brown, green, red]"

  fixes guru :: 'person
  assumes "finite (UNIV :: 'person set)"
begin

text \<open>It's slightly tricky to formalize the behavior of perfect logicians.
The representation we use is centered around the type of a @{emph \<open>world\<close>},
which describes the entire state of the environment. In our case, it's a function
@{typ "'person => 'color"} that assigns an eye color to everyone.@{footnote \<open>We would introduce
a type synonym, but at the time of writing Isabelle doesn't support including type variables fixed
by a locale in a type synonym.\<close>}

The only condition known to everyone and not dependent on the observer is Guru's declaration:\<close>

definition valid :: "('person \<Rightarrow> 'color) \<Rightarrow> bool" where
  "valid w \<longleftrightarrow> (\<exists>p. p \<noteq> guru \<and> w p = blue)"

text \<open>We then define the function @{term "possible n p w w'"}, which returns @{term True}
if on day \<open>n\<close> the potential world \<open>w'\<close> is plausible from the perspective of person \<open>p\<close>,
based on the observations they made in the actual world \<open>w\<close>.

Then, @{term "leaves n p w"} is @{term True} if \<open>p\<close> is able to unambiguously deduce
the color of their own eyes, i.e. if it is the same in all possible worlds. Note that if \<open>p\<close> actually
left many moons ago, this function still returns @{term True}.\<close>

fun leaves :: "nat \<Rightarrow> 'person \<Rightarrow> ('person \<Rightarrow> 'color) \<Rightarrow> bool"
  and possible :: "nat \<Rightarrow> 'person \<Rightarrow> ('person \<Rightarrow> 'color) \<Rightarrow> ('person \<Rightarrow> 'color) \<Rightarrow> bool"
  where
    "leaves n p w = (\<forall>w'. possible n p w w' \<longrightarrow> w' p = w p)" |
    "possible n p w w' \<longleftrightarrow> valid w \<and> valid w'
    \<and> (\<forall>p' \<noteq> p. w p' = w' p')
    \<and> (\<forall>n' < n. \<forall>p'. leaves n' p' w = leaves n' p' w')"

text \<open>Naturally, the act of someone leaving can be observed by others, thus the two definitions
are mutually recursive. As such, we need to instruct the simplifier to not unfold these definitions endlessly.\<close>
declare possible.simps[simp del] leaves.simps[simp del]

text \<open>A world is possible if
  \<^enum> The Guru's declaration holds.
  \<^enum> The eye color of everyone but the observer matches.
  \<^enum> The same people left on each of the previous days.

Moreover, we require that the actual world \<open>w\<close> is \<open>valid\<close>, so that the relation is symmetric:\<close>

lemma possible_sym: "possible n p w w' = possible n p w' w"
  by (auto simp: possible.simps)

text \<open>In fact, \<open>possible n p\<close> is an equivalence relation:\<close>

lemma possible_refl: "valid w \<Longrightarrow> possible n p w w"
  by (auto simp: possible.simps)

section \<open>Eye colors other than blue\<close>

text \<open>Since there is no way to distinguish between the colors other than blue,
only the blue-eyed people will ever leave. To formalize this notion, we define
a function that takes a world and replaces the eye color of a specified person.
The original color is specified too, so that the transformation composes nicely
with the recursive hypothetical worlds of @{const possible}.\<close>

definition try_swap :: "'person \<Rightarrow> 'color \<Rightarrow> 'color \<Rightarrow> ('person \<Rightarrow> 'color) \<Rightarrow> ('person \<Rightarrow> 'color)" where
  "try_swap p c\<^sub>1 c\<^sub>2 w x = (if c\<^sub>1 = blue \<or> c\<^sub>2 = blue \<or> x \<noteq> p then w x else transpose c\<^sub>1 c\<^sub>2 (w x))"

lemma try_swap_valid[simp]: "valid (try_swap p c\<^sub>1 c\<^sub>2 w) = valid w"
  by (cases \<open>c\<^sub>1 = blue\<close>; cases \<open>c\<^sub>2 = blue\<close>)
    (auto simp add: try_swap_def valid_def transpose_eq_iff)

lemma try_swap_eq[simp]: "try_swap p c\<^sub>1 c\<^sub>2 w x = try_swap p c\<^sub>1 c\<^sub>2 w' x \<longleftrightarrow> w x = w' x"
  by (auto simp add: try_swap_def transpose_eq_iff)

lemma try_swap_inv[simp]: "try_swap p c\<^sub>1 c\<^sub>2 (try_swap p c\<^sub>1 c\<^sub>2 w) = w"
  by (rule ext) (auto simp add: try_swap_def swap_id_eq)

lemma leaves_try_swap[simp]:
  assumes "valid w"
  shows "leaves n p (try_swap p' c\<^sub>1 c\<^sub>2 w) = leaves n p w"
  using assms
proof (induction n arbitrary: p w rule: less_induct)
  case (less n)
  have "leaves n p w" if "leaves n p (try_swap p' c\<^sub>1 c\<^sub>2 w)" for w
  proof (unfold leaves.simps; rule+)
    fix w'
    assume "possible n p w w'"
    then have "possible n p (try_swap p' c\<^sub>1 c\<^sub>2 w) (try_swap p' c\<^sub>1 c\<^sub>2 w')"
      by (fastforce simp: possible.simps less.IH)
    with `leaves n p (try_swap p' c\<^sub>1 c\<^sub>2 w)` have "try_swap p' c\<^sub>1 c\<^sub>2 w' p = try_swap p' c\<^sub>1 c\<^sub>2 w p"
      unfolding leaves.simps
      by simp
    thus "w' p = w p" by simp
  qed

  with try_swap_inv show ?case by auto
qed

text \<open>This lets us prove that only blue-eyed people will ever leave the island.\<close>

proposition only_blue_eyes_leave:
  assumes "leaves n p w" and "valid w"
  shows "w p = blue"
proof (rule ccontr)
  assume "w p \<noteq> blue"
  then obtain c where c: "w p \<noteq> c"  "c \<noteq> blue"
    using colors_distinct
    by (metis distinct_length_2_or_more)

  let ?w' = "try_swap p (w p) c w"
  have "possible n p w ?w'"
    using `valid w` apply (simp add: possible.simps)
    by (auto simp: try_swap_def)
  moreover have "?w' p \<noteq> w p"
    using c `w p \<noteq> blue` by (auto simp: try_swap_def)
  ultimately have "\<not> leaves n p w"
    by (auto simp: leaves.simps)
  with assms show False by simp
qed

section "The blue-eyed logicians"

text \<open>We will now consider the behavior of the logicians with blue eyes. First,
some simple lemmas. Reasoning about set cardinalities often requires considering infinite
sets separately. Usefully, all sets of people are finite by assumption.\<close>

lemma people_finite[simp]: "finite (S::'person set)"
proof (rule finite_subset)
  show "S \<subseteq> UNIV" by auto
  show "finite (UNIV::'person set)" by fact
qed

text \<open>Secondly, we prove a destruction rule for @{const possible}. It is strictly weaker than
the definition, but thanks to the simpler form, it's easier to guide the automation with it.\<close>
lemma possibleD_colors:
  assumes "possible n p w w'" and "p' \<noteq> p"
  shows "w' p' = w p'"
  using assms unfolding possible.simps by simp

text \<open>A central concept in the reasoning is the set of blue-eyed people someone can see.\<close>
definition blues_seen :: "('person \<Rightarrow> 'color) \<Rightarrow> 'person \<Rightarrow> 'person set" where
  "blues_seen w p = {p'. w p' = blue} - {p}"

lemma blues_seen_others:
  assumes "w p' = blue" and "p \<noteq> p'"
  shows "w p = blue \<Longrightarrow> card (blues_seen w p) = card (blues_seen w p')"
    and "w p \<noteq> blue \<Longrightarrow> card (blues_seen w p) = Suc (card (blues_seen w p'))"
proof -
  assume "w p = blue"
  then have "blues_seen w p' = blues_seen w p \<union> {p} - {p'}"
    by (auto simp add: blues_seen_def)
  moreover have "p \<notin> blues_seen w p"
    unfolding blues_seen_def by auto
  moreover have "p' \<in> blues_seen w p \<union> {p}"
    unfolding blues_seen_def using `p \<noteq> p'` `w p' = blue` by auto
  ultimately show "card (blues_seen w p) = card (blues_seen w p')"
    by simp
next
  assume "w p \<noteq> blue"
  then have "blues_seen w p' = blues_seen w p - {p'}"
    by (auto simp add: blues_seen_def)
  moreover have "p' \<in> blues_seen w p"
    unfolding blues_seen_def using `p \<noteq> p'` `w p' = blue` by auto
  ultimately show "card (blues_seen w p) = Suc (card (blues_seen w p'))"
    by (simp only: card_Suc_Diff1 people_finite)
qed

lemma possible_blues_seen:
  assumes "possible n p w w'"
  assumes "w p' = blue" and "p \<noteq> p'"
  shows "w' p = blue \<Longrightarrow> card (blues_seen w p) = card (blues_seen w' p')"
    and "w' p \<noteq> blue \<Longrightarrow> card (blues_seen w p) = Suc (card (blues_seen w' p'))"
  using possibleD_colors[OF `possible n p w w'`] and blues_seen_others assms
  by (auto simp flip: blues_seen_same)

text \<open>Finally, the crux of the solution. We proceed by strong induction.\<close>

lemma blue_leaves:
  assumes "w p = blue" and "valid w"
    and guru: "w guru \<noteq> blue"
  shows "leaves n p w \<longleftrightarrow> n \<ge> card (blues_seen w p)"
  using assms
proof (induction n arbitrary: p w rule: less_induct)
  case (less n)
  show ?case
  proof
    \<comment> \<open>First, we show that day \<open>n\<close> is sufficient to deduce that the eyes are blue.\<close>
    assume "n \<ge> card (blues_seen w p)"
    have "w' p = blue" if "possible n p w w'" for w'
    proof (cases "card (blues_seen w' p)")
      case 0
      moreover from `possible n p w w'` have "valid w'"
        by (simp add: possible.simps)
      ultimately show "w' p = blue"
        unfolding valid_def blues_seen_def by auto
    next
      case (Suc k)
      \<comment> \<open>We consider the behavior of somebody else, who also has blue eyes.\<close>
      then have "blues_seen w' p \<noteq> {}"
        by auto
      then obtain p' where "w' p' = blue" and "p \<noteq> p'"
        unfolding blues_seen_def by auto
      then have "w p' = blue"
        using possibleD_colors[OF `possible n p w w'`] by simp

      have "p \<noteq> guru"
        using `w p = blue` and `w guru \<noteq> blue` by auto
      hence "w' guru \<noteq> blue"
        using `w guru \<noteq> blue` and possibleD_colors[OF `possible n p w w'`] by simp

      have "valid w'"
        using `possible n p w w'` unfolding possible.simps by simp

      show "w' p = blue"
      proof (rule ccontr)
        assume "w' p \<noteq> blue"
        \<comment> \<open>If our eyes weren't blue, then \<open>p'\<close> would see one blue-eyed person less than us.\<close>
        with possible_blues_seen[OF `possible n p w w'` `w p' = blue` `p \<noteq> p'`]
        have *: "card (blues_seen w p) = Suc (card (blues_seen w' p'))"
          by simp
        \<comment> \<open>By induction, they would've left on day \<open>k = blues_seen w' p'\<close>.\<close>
        let ?k = "card (blues_seen w' p')"
        have "?k < n"
          using `n \<ge> card (blues_seen w p)` and * by simp
        hence "leaves ?k p' w'"
          using `valid w'` `w' p' = blue` `w' guru \<noteq> blue`
          by (intro less.IH[THEN iffD2]; auto)
        \<comment> \<open>However, we know that actually, \<open>p'\<close> didn't leave that day yet.\<close>
        moreover have "\<not> leaves ?k p' w"
        proof
          assume "leaves ?k p' w"
          then have "?k \<ge> card (blues_seen w p')"
            using `?k < n` `w p' = blue` `valid w` `w guru \<noteq> blue`
            by (intro less.IH[THEN iffD1]; auto)

          have "card (blues_seen w p) = card (blues_seen w p')"
            by (intro blues_seen_others; fact)
          with * have "?k < card (blues_seen w p')"
            by simp
          with `?k \<ge> card (blues_seen w p')` show False by simp
        qed
        moreover have "leaves ?k p' w' = leaves ?k p' w"
          using `possible n p w w'` `?k < n`
          unfolding possible.simps by simp
        ultimately show False by simp
      qed
    qed
    thus "leaves n p w"
      unfolding leaves.simps using `w p = blue` by simp
  next
    \<comment> \<open>Then, we show that it's not possible to deduce the eye color any earlier.\<close>
    {
      assume "n < card (blues_seen w p)"
      \<comment> \<open>Consider a hypothetical world where \<open>p\<close> has brown eyes instead. We will prove that this
        world is \<open>possible\<close>.\<close>
      let ?w' = "w(p := brown)"
      have "?w' guru \<noteq> blue"
        using `w guru \<noteq> blue` `w p = blue`
        by auto
      have "valid ?w'"
      proof -
        from `n < card (blues_seen w p)` have "card (blues_seen w p) \<noteq> 0" by auto
        hence "blues_seen w p \<noteq> {}"
          by auto
        then obtain p' where "p' \<in> blues_seen w p"
          by auto
        hence "p \<noteq> p'" and "w p' = blue"
          by (auto simp: blues_seen_def)
        hence "?w' p' = blue" by auto
        with `?w' guru \<noteq> blue` show "valid ?w'"
          unfolding valid_def by auto
      qed
      moreover have "leaves n' p' w = leaves n' p' ?w'" if "n' < n" for n' p'
      proof -
        have not_leavesI: "\<not>leaves n' p' w'"
          if "valid w'"  "w' guru \<noteq> blue" and P: "w' p' = blue \<Longrightarrow> n' < card (blues_seen w' p')" for w'
        proof (cases "w' p' = blue")
          case True
          then have "leaves n' p' w' \<longleftrightarrow> n' \<ge> card (blues_seen w' p')"
            using less.IH `n' < n` `valid w'` `w' guru \<noteq> blue`
            by simp
          with P[OF `w' p' = blue`] show "\<not>leaves n' p' w'" by simp
        next
          case False
          then show "\<not> leaves n' p' w'"
            using only_blue_eyes_leave `valid w'` by auto
        qed

        have "\<not>leaves n' p' w"
        proof (intro not_leavesI)
          assume "w p' = blue"
          with `w p = blue` have "card (blues_seen w p) = card (blues_seen w p')"
            apply (cases "p = p'", simp)
            by (intro blues_seen_others; auto)
          with `n' < n` and `n < card (blues_seen w p)` show "n' < card (blues_seen w p')"
            by simp
        qed fact+

        moreover have "\<not> leaves n' p' ?w'"
        proof (intro not_leavesI)
          assume "?w' p' = blue"
          with colors_distinct have "p \<noteq> p'" and "?w' p \<noteq> blue" by auto
          hence "card (blues_seen ?w' p) = Suc (card (blues_seen ?w' p'))"
            using `?w' p' = blue`
            by (intro blues_seen_others; auto)
          moreover have "blues_seen w p = blues_seen ?w' p"
            unfolding blues_seen_def by auto
          ultimately show "n' < card (blues_seen ?w' p')"
            using `n' < n` and `n < card (blues_seen w p)`
            by auto
        qed fact+

        ultimately show "leaves n' p' w = leaves n' p' ?w'" by simp
      qed
      ultimately have "possible n p w ?w'"
        using `valid w`
        by (auto simp: possible.simps)
      moreover have "?w' p \<noteq> blue"
        using colors_distinct by auto
      ultimately have "\<not> leaves n p w"
        unfolding leaves.simps
        using `w p = blue` by blast
    }
    then show "leaves n p w \<Longrightarrow> n \<ge> card (blues_seen w p)"
      by fastforce
  qed
qed

text \<open>This can be combined into a theorem that describes the behavior of the logicians based
on the objective count of blue-eyed people, and not the count by a specific person. The xkcd
puzzle is the instance where \<open>n = 99\<close>.\<close>

theorem blue_eyes:
  assumes "card {p. w p = blue} = Suc n" and "valid w" and "w guru \<noteq> blue"
  shows "leaves k p w \<longleftrightarrow> w p = blue \<and> k \<ge> n"
proof (cases "w p = blue")
  case True
  with assms have "card (blues_seen w p) = n"
    unfolding blues_seen_def by simp
  then show ?thesis
    using `w p = blue` `valid w` `w guru \<noteq> blue` blue_leaves
    by simp
next
  case False
  then show ?thesis
    using only_blue_eyes_leave `valid w` by auto
qed

end

(*<*)
end
(*>*)

section \<open>Future work\<close>

text \<open>After completing this formalization, I have been made aware of epistemic logic.
The @{emph \<open>possible worlds\<close>} model in \cref{sec:world} turns out to be quite similar
to the usual semantics of this logic. It might be interesting to solve this puzzle within
the axiom system of epistemic logic, without explicit reasoning about possible worlds.\<close>


theory FiniteHypClasses
  imports "HOL-Probability.Probability" Pi_pmf LearningTheory
begin

section "auxiliary lemmas"

lemma fixes m :: nat and  h \<delta> \<epsilon> :: real
  assumes
    nn: "h >0"  and
        epos: "\<epsilon> > 0" and m: "real m \<ge> (ln ( h / \<delta>)) / \<epsilon>"
      and dd: "\<delta> > 0" "\<delta> < 1"
  shows aux_estim: "h * exp (-\<epsilon> * m) \<le> \<delta>"
proof -
  from m epos have "ln ( h / \<delta>) \<le> real m * \<epsilon>"
    by (smt divide_cancel_right mult_imp_le_div_pos nonzero_mult_div_cancel_right)
  then have "( h / \<delta>) \<le> exp (real m * \<epsilon>)" using dd nn
    by (metis (full_types) divide_pos_pos exp_le_cancel_iff exp_ln of_nat_0_less_iff)
  then have "h \<le> \<delta> * exp (real m * \<epsilon>)" using dd
    by (smt divide_divide_eq_left exp_gt_zero less_divide_eq_1_pos linordered_field_class.sign_simps(44))
  then have A: "h / exp (real m * \<epsilon>) \<le> \<delta>"
    by (smt dd(1) divide_divide_eq_left exp_gt_zero less_divide_eq_1_pos mult.commute mult_pos_pos)
  have B: "h / exp (real m * \<epsilon>) = h * exp (-\<epsilon> * m)"
  proof -
    have "h / exp (real m * \<epsilon>) = h * (exp 0) / exp (real m * \<epsilon>)"
      by auto
    also have "\<dots> = h * exp (0 - real m * \<epsilon>)" apply(subst exp_diff) by auto
    also have "\<dots> =  h * exp (- \<epsilon> * real m)" by auto
    finally show ?thesis .
  qed
  from A B show ed: "h * exp (-\<epsilon> * m) \<le> \<delta>" by auto
qed

section "finite Hypothesis classes are PAC learnable"

(* now assume we have a finite class of Hypotheses *)
locale finiteHypothesisClass = learning_basics where X=X and Y=Y and H = H
  for X::"'a set" and Y::"'b set" and H :: "('a \<Rightarrow> 'b) set" +
  assumes fH: "finite H"
begin

text \<open>Let us now analyze the performance of the "Empirical Risk Minimization" rule
w.r.t. to the finite Hypothesis Class H.
Its learning rule ERMe chooses for a given training set S an Hypothesis h from H
which minimizes the Training Error. \<close>

lemma ERM_nonempty: "H\<noteq>{} \<Longrightarrow> ERM S n \<noteq> {}" unfolding ERM_def
  by (simp add: ex_is_arg_min_if_finite fH)

text \<open>Now we show that the ERM rule is PAC learnable,
      if we assume a finite hypotheses class H.\<close>

lemma fixes
      D :: "('a\<times>'b) pmf"
    and \<epsilon> \<delta> :: real
    and m :: nat
  assumes
        epos: "\<epsilon> > 0" and m: "real m \<ge> (ln ( real (card H) / \<delta>)) / \<epsilon>"
      and dd: "\<delta> > 0" "\<delta> < 1"
      and DX: "set_pmf D \<subseteq> (X\<times>Y)"
    and RealizabilityAssumption: "\<exists>h'\<in>H. PredErr D h' = 0"

  shows corollary_2_3_aux: "measure_pmf.prob (Samples m D) {S. PredErr D (ERMe S m) \<le> \<epsilon>}
        \<ge> 1 - \<delta>" (is "?LHS \<ge> 1 - \<delta>")
proof -

  text \<open>Fixing some Distribution @{term D} we are
    interested in upperbounding the probability to sample m-tuple of instances that
    will lead to failure of the learner.

    Formally we would like to upperbound @{term "measure_pmf.prob (Samples m D) {S. PredErr D (ERMe S m) \<le> \<epsilon>}"}.\<close>

  text \<open>Let ?S be the carrier set of m-times labelled sample pairs (x,f x) from D.\<close>
  let ?S = "set_pmf (Samples m D)"

  text \<open>Let ?Hb be the set of "bad" hypotheses, that is,\<close>
  let ?Hb = "{h\<in>H. PredErr D h > \<epsilon>}"

  have fHb: "finite ?Hb" using fH by simp
  from fH have cHb: "card ?Hb \<le> card H"
    by (simp add: card_mono)

  text \<open>In addition,\<close>
  let ?M = "{S\<in>?S. \<exists>h\<in>?Hb. TrainErr S {0..<m} h = 0}"
  text \<open>be the set of misleading samples: Namely, for every S in M, there is a "bad" hypothesis
        h in H, that looks  like a "good" hypothesis on S.\<close>

  text \<open>We can upperbound the "bad" events (in which we are interested) by ?M:\<close>
  have A: "{S\<in>?S. PredErr D (ERMe S m) > \<epsilon>} \<subseteq> ?M"
  proof
    from RealizabilityAssumption
    obtain h' where h'H: "h'\<in>H" and u: "PredErr D h' = 0" by blast

    from u have "measure_pmf.prob D {S \<in> set_pmf D. snd S \<noteq> h' (fst S)} = 0" unfolding PredErr_alt .
    with measure_pmf_zero_iff[of D "{S \<in> set_pmf D. snd S \<noteq> h' (fst S)}"]
    have correct: "\<And>x. x\<in>set_pmf D \<Longrightarrow> snd x = h' (fst x)" by blast

    fix S
    assume "S \<in> {S \<in>?S.   \<epsilon> < PredErr D (ERMe S m)}"
    then have SS: "S\<in>?S" and 2: "\<epsilon> < PredErr D (ERMe S m)" by auto

    from SS set_Pi_pmf[where A="{0..<m}"]
      have tD: "\<And>i. i\<in>{0..<m} \<Longrightarrow> S i \<in> set_pmf D"
        unfolding Samples_def by auto

      have z: "\<And>i. i\<in>{0..<m} \<Longrightarrow> (case S i of (x, y) \<Rightarrow> if h' x \<noteq> y then 1::real else 0) = 0"
        using tD correct
        by (simp add: case_prod_beta')

    have Th'0: "TrainErr S {0..<m} h' = 0"
      unfolding TrainErr_def   using z
      by fastforce

    with h'H ERM_0_in have h'ERM: "h' \<in> ERM S m" by blast
    then have "TrainErr S {0..<m} (ERMe S m) = 0" using Th'0 by(rule ERMe_minimal)
    have "ERMe S m \<in> H" unfolding ERMe_def using ERM_subset ERM_nonempty
      using nnH some_in_eq by blast

    have "\<exists>h\<in>{h \<in> H. \<epsilon> < PredErr D h}. TrainErr S {0..<m} h = 0"
      apply(rule bexI[where x="ERMe S m"])
       apply auto by fact+
    with SS show "S \<in> ?M" by auto
  qed

  text \<open>Note that we can rewrite ?M as\<close>
  have prop_2_5: "?M = (\<Union>h\<in>?Hb. {S\<in>?S. TrainErr S {0..<m} h = 0})"
    by auto

  text \<open>Next, let us bound the probability of the preceding events for each of the inner sets.\<close>
  have prop_2_9: "\<And>h. h\<in>?Hb \<Longrightarrow> measure_pmf.prob (Samples m D) ({S\<in>?S. TrainErr S {0..<m} h = 0}) \<le> exp (-\<epsilon> * m)"
  proof -
    text \<open>Fix some "bad" hypothesis h:?Hb.\<close>
    fix h
    assume "h\<in>?Hb"
    then have z: "PredErr D h > \<epsilon>" by auto

    (* magic ^^, `m>0` seems to follow from `real m \<ge> (ln ( real (card H) / \<delta>)) / \<epsilon>` *)
    from nnH fH have "card H > 0" by auto
    with m have mnn: "m>0" using epos dd
      using fH leD real_of_nat_ge_one_iff by fastforce
    from mnn have  "finite {0..<m}" "{0..<m} \<noteq>{}" by auto

    from TrainErr_correct[OF this] have Tc: "\<And>S h i. TrainErr S {0..<m} h = 0 \<Longrightarrow> i \<in> {0..<m} \<Longrightarrow> h (fst (S i)) = snd (S i)" .

    text \<open>We first estimate the probability that the "bad" hypothesis makes a "good" prediction.\<close>
    have individual_estim: "measure_pmf.prob D {x. snd x = h (fst x)} \<le> exp (-\<epsilon>)"
    proof -
      have "measure_pmf.prob D {x. snd x = h (fst x)} = 1 - PredErr D h" (is "?L = ?R")
      proof -
        have "?L = measure_pmf.prob D {S \<in> space (measure_pmf D). \<not> (S\<in>{x. snd x \<noteq> h (fst x)})}"
          by auto
        also have "\<dots> = 1 - measure_pmf.prob D {x \<in> space (measure_pmf D). x \<in> {x. snd x \<noteq> h (fst x)}}"
          apply(rule measure_pmf.prob_neg) by simp
        also have "\<dots> = ?R" unfolding PredErr_def by auto
        finally show ?thesis .
      qed
      also have "\<dots> \<le> 1 - \<epsilon>" using z by force
        (* using the inequality `1-\<epsilon> \<le> exp (-\<epsilon>)` *)
      also have "\<dots> \<le> exp (-\<epsilon>)" using epos
        by (metis add_uminus_conv_diff exp_ge_add_one_self)
      finally show"measure_pmf.prob D {x. snd x = h (fst x)} \<le> exp (-\<epsilon>)" .
    qed

    \<comment> \<open>The event @{text "L\<^sub>S(h)=0"} is equivalent to the event @{text "\<forall>i. h(x\<^sub>i) = f(x\<^sub>i)"}\<close>
    have "measure_pmf.prob (Samples m D) {S\<in>?S. TrainErr S {0..<m} h = 0}
        \<le> measure_pmf.prob (Samples m D) {S\<in>?S. (\<forall>i\<in>{0..<m}. snd (S i) = h (fst (S i)))}"
      by (auto simp add: Tc intro: measure_pmf.finite_measure_mono)
     \<comment> \<open>Since the examples in the training set are sampled i.i.d. we get that:\<close>
    also have "\<dots> \<le> measure_pmf.prob (Samples m D)  (repeated_event m {(x,y). y = h x})" (* equality should also be correct, but \<le> takes less effort *)
    proof (rule measure_pmf.finite_measure_mono, safe)
      fix S
      assume S: "S \<in> set_pmf (Samples m D)"
      then have 1: "\<And>x. x \<notin> {0..<m} \<Longrightarrow> S x = undefined"
        using set_Pi_pmf_subset[of "{0..<m}" undefined "(\<lambda>_. D)"] unfolding Samples_def
        by blast
      assume A: "\<forall>i\<in>{0..<m}. (snd (S i)) = h (fst (S i))"
      { fix i
        assume i: "i \<in> {0..<m}"
        with  set_Pi_pmf[OF _ S[unfolded Samples_def]] have Si: "S i \<in> set_pmf D" by auto
        fix x y assume "S i = (x,y)"
        with Si
        have "y = h x" unfolding Sample_def using A i by force
      } note 2=this
      show "S \<in> repeated_event m {(x, y). y = h x}" unfolding repeated_event_def PiE_dflt_def apply safe by (fact 1 2)+
    qed simp
    also have "\<dots> = (measure_pmf.prob D {(x,y). y = h x}) ^ m"
      by(rule iid)
   (* also have "\<dots> = (measure_pmf.prob D {x. f x = h x}) ^ m"
      by(simp only: reduce) *)
    \<comment> \<open>by estimating each individual sampling we obtain\<close>
    also have "\<dots> \<le>  (exp (-\<epsilon>)) ^ m"
        apply(rule power_mono)
       apply (metis (mono_tags, lifting) Collect_cong case_prod_beta individual_estim)
      by auto
    also have "\<dots> \<le> exp (-\<epsilon> * m)"
      by (metis exp_of_nat2_mult order_refl)
    finally show "measure_pmf.prob (Samples m D) ({S\<in>?S. TrainErr S {0..<m} h = 0}) \<le> exp (-\<epsilon> * m)" .
  qed

  text "now we can plug all the estimations together:"

  have "measure_pmf.prob (Samples m D) {S. PredErr D (ERMe S m) > \<epsilon>}
      = measure_pmf.prob (Samples m D) {S\<in>?S. PredErr D (ERMe S m) > \<epsilon>}"
    by (auto intro: pmf_prob_cong simp add: set_pmf_iff)
  \<comment> \<open>the overapproximation by ?M:\<close>
  also have "\<dots> \<le> measure_pmf.prob (Samples m D) ?M"
    apply(rule measure_pmf.finite_measure_mono) apply (fact A) by auto
  \<comment> \<open>the rewrite of ?M as a big Union:\<close>
  also have "\<dots> = measure_pmf.prob (Samples m D) (\<Union>h\<in>?Hb. {S\<in>?S. TrainErr S {0..<m} h = 0})"
    using prop_2_5 by auto
  \<comment> \<open>bounding the probability of a Union of events by the sum of the probability of the events:\<close>
  also have "\<dots> \<le> sum (\<lambda>h. measure_pmf.prob (Samples m D) ({S\<in>?S. TrainErr S {0..<m} h = 0})) ?Hb"
      apply(rule measure_pmf.finite_measure_subadditive_finite) using fHb by auto
  \<comment> \<open>applying the estimation:\<close>
  also have "\<dots> \<le> sum (\<lambda>h. exp (-\<epsilon> * m)) ?Hb"
    apply(rule sum_mono) using prop_2_9  by blast
  \<comment> \<open>some final rewrites:\<close>
  also have "\<dots> \<le> (card ?Hb) * exp (-\<epsilon> * m)" using fHb by auto
  also have "\<dots> \<le> (card H) * exp (-\<epsilon> * m)" using cHb by simp
  finally have k: "measure_pmf.prob (Samples m D) {S. PredErr D (ERMe S m) > \<epsilon>} \<le> (card H) * exp (-\<epsilon> * m)" .

  text \<open>solve the bound for m for \<delta>\<close>
  from nnH fH have nn: "0 < real (card H)" by fastforce
  note bound = \<open>m \<ge> (ln ( card H / \<delta>)) / \<epsilon>\<close>
  from aux_estim[OF nn epos bound dd]
    have ed: "(card H) * exp (-\<epsilon> * m) \<le> \<delta>" by auto

  text \<open>Put everything together to yield the final result:\<close>
  have "1 - \<delta> \<le> 1 - (card H) * exp (-\<epsilon> * m)" using ed by simp
  also have "\<dots> \<le> 1 - measure_pmf.prob (Samples m D) {S. PredErr D (ERMe S m) > \<epsilon>}"
    using k by linarith
  also have "\<dots> = ?LHS" (is "?R = _")
  proof -
    thm measure_pmf.prob_neg
    have "?LHS = measure_pmf.prob (Samples m D) {S \<in> space (measure_pmf (Samples m D)). \<not> (S\<in>{S. \<epsilon> < PredErr D (ERMe S m)})}"
      apply auto  by (meson not_le)
    also have "\<dots> = 1 - measure_pmf.prob (Samples m D) {x \<in> space (measure_pmf (Samples m D)). x \<in> {S. \<epsilon> < PredErr D (ERMe S m)}}"
      apply(rule measure_pmf.prob_neg) by simp
    also have "\<dots> = ?R" by auto
    finally show ?thesis by simp
  qed
  finally show "measure_pmf.prob (Samples m D) {S. PredErr D (ERMe S m) \<le> \<epsilon>} \<ge> 1 - \<delta>" by simp
qed

definition "ERMbound \<epsilon> \<delta> = nat \<lceil> (ln ( real (card H) / \<delta>)) / \<epsilon>\<rceil>"

lemma corollary_2_3: "PAC_learnable ERMe"
  unfolding PAC_learnable_def
  apply(rule exI[where x="ERMbound"])
  apply safe unfolding ERMbound_def
  using corollary_2_3_aux  by fastforce

end

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_MSortBUPermutes
  imports "../../Test_Base"
begin

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

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 lmerge :: "int list => int list => int list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if z <= x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun pairwise :: "(int list) list => (int 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 :: "(int list) list => int 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 :: "int list => int list" where
  "msortbu x = mergingbu (map (% (y :: int) => cons2 y (nil2)) x)"

fun elem :: "'a => 'a list => bool" where
  "elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "isPermutation (msortbu xs) xs"
  oops

end


theory Design_Basics imports Main Multisets_Extras "HOL-Library.Disjoint_Sets"
begin

section \<open>Design Theory Basics\<close>
text \<open>All definitions in this section reference the handbook of combinatorial designs
 \<^cite>\<open>"colbournHandbookCombinatorialDesigns2007"\<close>\<close>

subsection \<open>Initial setup\<close>

text \<open>Enable coercion of nats to ints to aid with reasoning on design properties\<close>
declare [[coercion_enabled]]
declare [[coercion "of_nat :: nat \<Rightarrow> int"]]

subsection \<open>Incidence System\<close>

text \<open>An incidence system is defined to be a wellformed set system. i.e. each block is a subset
of the base point set. Alternatively, an incidence system can be looked at as the point set
and an incidence relation which indicates if they are in the same block\<close>

locale incidence_system =
  fixes point_set :: "'a set" ("\<V>")
  fixes block_collection :: "'a set multiset" ("\<B>")
  assumes wellformed: "b \<in># \<B> \<Longrightarrow> b \<subseteq> \<V>"
begin

definition "\<I> \<equiv> { (x, b) . b \<in># \<B> \<and> x \<in> b}" (* incidence relation *)

definition incident :: "'a \<Rightarrow> 'a set \<Rightarrow> bool" where
"incident p b \<equiv> (p, b) \<in> \<I>"

text \<open>Defines common notation used to indicate number of points ($v$) and number of blocks ($b$)\<close>
abbreviation "\<v> \<equiv> card \<V>"

abbreviation "\<b> \<equiv> size \<B>"

text \<open>Basic incidence lemmas\<close>

lemma incidence_alt_def:
  assumes "p \<in> \<V>"
  assumes "b \<in># \<B>"
  shows "incident p b \<longleftrightarrow> p \<in> b"
  by (auto simp add: incident_def \<I>_def assms)

lemma wf_invalid_point: "x \<notin> \<V> \<Longrightarrow> b \<in># \<B> \<Longrightarrow> x \<notin> b"
  using wellformed by auto

lemma block_set_nempty_imp_block_ex: "\<B> \<noteq> {#} \<Longrightarrow> \<exists> bl . bl \<in># \<B>"
  by auto

text \<open>Abbreviations for all incidence systems\<close>
abbreviation multiplicity :: "'a set \<Rightarrow> nat" where
"multiplicity b \<equiv> count \<B> b"

abbreviation incomplete_block :: "'a set \<Rightarrow> bool" where
"incomplete_block bl \<equiv> card bl < card \<V> \<and> bl \<in># \<B>"

lemma incomplete_alt_size: "incomplete_block bl \<Longrightarrow> card bl < \<v>"
  by simp

lemma incomplete_alt_in: "incomplete_block bl \<Longrightarrow> bl \<in># \<B>"
  by simp

lemma incomplete_alt_imp[intro]: "card bl < \<v> \<Longrightarrow> bl \<in># \<B> \<Longrightarrow> incomplete_block bl"
  by simp

definition design_support :: "'a set set" where
"design_support \<equiv> set_mset \<B>"

end

subsection \<open>Finite Incidence Systems\<close>

text \<open>These simply require the point set to be finite.
As multisets are only defined to be finite, it is implied that the block set must be finite already\<close>

locale finite_incidence_system = incidence_system +
  assumes finite_sets: "finite \<V>"
begin

lemma finite_blocks: "b \<in># \<B> \<Longrightarrow> finite b"
  using wellformed finite_sets finite_subset by blast

lemma mset_points_distinct: "distinct_mset (mset_set \<V>)"
  using finite_sets by (simp add: distinct_mset_def)

lemma mset_points_distinct_diff_one: "distinct_mset (mset_set (\<V> - {x}))"
  by (meson count_mset_set_le_one distinct_mset_count_less_1)

lemma finite_design_support: "finite (design_support)"
  using design_support_def by auto

lemma block_size_lt_order: "bl \<in># \<B> \<Longrightarrow> card bl \<le> card \<V>"
  using wellformed by (simp add: card_mono finite_sets)

end

subsection \<open>Designs\<close>

text \<open>There are many varied definitions of a design in literature. However, the most
commonly accepted definition is a finite point set, $V$ and collection of blocks $B$, where
no block in $B$ can be empty\<close>
locale design = finite_incidence_system +
  assumes blocks_nempty: "bl \<in># \<B> \<Longrightarrow> bl \<noteq> {}"
begin

lemma wf_design: "design \<V> \<B>"  by intro_locales

lemma wf_design_iff: "bl \<in># \<B> \<Longrightarrow> design \<V> \<B> \<longleftrightarrow> (bl \<subseteq> \<V> \<and> finite \<V> \<and> bl \<noteq> {})"
  using blocks_nempty wellformed finite_sets
  by (simp add: wf_design)

text \<open>Reasoning on non empty properties and non zero parameters\<close>
lemma blocks_nempty_alt: "\<forall> bl \<in># \<B>. bl \<noteq> {}"
  using blocks_nempty by auto

lemma block_set_nempty_imp_points: "\<B> \<noteq> {#} \<Longrightarrow> \<V> \<noteq> {}"
  using wf_design wf_design_iff by auto

lemma b_non_zero_imp_v_non_zero: "\<b> > 0 \<Longrightarrow> \<v> > 0"
  using block_set_nempty_imp_points finite_sets by fastforce

lemma v_eq0_imp_b_eq_0: "\<v> = 0 \<Longrightarrow> \<b> = 0"
  using b_non_zero_imp_v_non_zero by auto

text \<open>Size lemmas\<close>
lemma block_size_lt_v: "bl \<in># \<B> \<Longrightarrow> card bl \<le> \<v>"
  by (simp add: card_mono finite_sets wellformed)

lemma block_size_gt_0: "bl \<in># \<B> \<Longrightarrow> card bl > 0"
  using finite_sets blocks_nempty finite_blocks by fastforce

lemma design_cart_product_size: "size ((mset_set \<V>) \<times># \<B>) = \<v> * \<b>"
  by (simp add: size_cartesian_product)

end

text \<open>Intro rules for design locale\<close>

lemma wf_design_implies:
  assumes "(\<And> b . b \<in># \<B> \<Longrightarrow> b \<subseteq> V)"
  assumes "\<And> b . b \<in># \<B> \<Longrightarrow> b \<noteq> {}"
  assumes "finite V"
  assumes "\<B> \<noteq> {#}"
  assumes "V \<noteq> {}"
  shows "design V \<B>"
  using assms by (unfold_locales) simp_all

lemma (in incidence_system) finite_sysI[intro]: "finite \<V> \<Longrightarrow> finite_incidence_system \<V> \<B>"
  by (unfold_locales) simp_all

lemma (in finite_incidence_system) designI[intro]: "(\<And> b. b \<in># \<B> \<Longrightarrow> b \<noteq> {}) \<Longrightarrow> \<B> \<noteq> {#}
     \<Longrightarrow> \<V> \<noteq> {} \<Longrightarrow> design \<V> \<B>"
  by (unfold_locales) simp_all

subsection \<open>Core Property Definitions\<close>

subsubsection \<open>Replication Number\<close>

text \<open>The replication number for a point is the number of blocks that point is incident with\<close>

definition point_replication_number :: "'a set multiset \<Rightarrow> 'a \<Rightarrow> nat" (infix "rep" 75) where
"B rep x \<equiv> size {#b \<in># B . x \<in> b#}"

lemma max_point_rep: "B rep x \<le> size B"
  using size_filter_mset_lesseq by (simp add: point_replication_number_def)

lemma rep_number_g0_exists:
  assumes "B rep x > 0"
  obtains b where "b \<in># B" and "x \<in> b"
proof -
  have "size {#b \<in># B . x \<in> b#} > 0" using assms point_replication_number_def
    by metis
  thus ?thesis
    by (metis filter_mset_empty_conv nonempty_has_size that)
qed

lemma rep_number_on_set_def: "finite B \<Longrightarrow> (mset_set B) rep x = card {b \<in> B . x \<in> b}"
  by (simp add: point_replication_number_def)

lemma point_rep_number_split[simp]: "(A + B) rep x = A rep x + B rep x"
  by (simp add: point_replication_number_def)

lemma point_rep_singleton_val [simp]: "x \<in> b \<Longrightarrow> {#b#} rep x = 1"
  by (simp add: point_replication_number_def)

lemma point_rep_singleton_inval [simp]: "x \<notin> b \<Longrightarrow> {#b#} rep x = 0"
  by (simp add: point_replication_number_def)

context incidence_system
begin

lemma point_rep_number_alt_def: "\<B> rep x = size {# b \<in># \<B> . x \<in> b#}"
  by (simp add: point_replication_number_def)

lemma rep_number_non_zero_system_point: " \<B> rep x > 0 \<Longrightarrow> x \<in> \<V>"
  using rep_number_g0_exists wellformed
  by (metis wf_invalid_point)

lemma point_rep_non_existance [simp]: "x \<notin> \<V> \<Longrightarrow> \<B> rep x = 0"
  using wf_invalid_point by (simp add:  point_replication_number_def filter_mset_empty_conv)

lemma point_rep_number_inv: "size {# b \<in># \<B> . x \<notin> b #} = \<b> - (\<B> rep x)"
proof -
  have "\<b> = size {# b \<in># \<B> . x \<notin> b #} + size {# b \<in># \<B> . x \<in> b #}"
    using multiset_partition by (metis add.commute size_union)
  thus ?thesis by (simp add: point_replication_number_def)
qed

lemma point_rep_num_inv_non_empty: "(\<B> rep x) < \<b> \<Longrightarrow> \<B> \<noteq> {#} \<Longrightarrow> {# b \<in># \<B> . x \<notin> b #} \<noteq> {#}"
  by (metis diff_zero point_replication_number_def size_empty size_filter_neg verit_comp_simplify1(1))

end

subsubsection \<open>Point Index\<close>

text \<open>The point index of a subset of points in a design, is the number of times those points
occur together in a block of the design\<close>
definition points_index :: "'a set multiset \<Rightarrow> 'a set \<Rightarrow> nat" (infix "index" 75) where
"B index ps \<equiv> size {#b \<in># B . ps \<subseteq> b#}"

lemma points_index_empty [simp]: "{#} index ps = 0"
  by (simp add: points_index_def)

lemma point_index_distrib: "(B1 + B2) index ps =  B1 index ps + B2 index ps"
  by (simp add: points_index_def)

lemma point_index_diff: "B1 index ps = (B1 + B2) index ps - B2 index ps"
  by (simp add: points_index_def)

lemma points_index_singleton: "{#b#} index ps = 1 \<longleftrightarrow> ps \<subseteq> b"
  by (simp add: points_index_def)

lemma points_index_singleton_zero: "\<not> (ps \<subseteq> b) \<Longrightarrow> {#b#} index ps = 0"
  by (simp add: points_index_def)

lemma points_index_sum: "(\<Sum>\<^sub># B ) index ps = (\<Sum>b \<in># B . (b index ps))"
  using points_index_empty by (induction B) (auto simp add: point_index_distrib)

lemma points_index_block_image_add_eq:
  assumes "x \<notin> ps"
  assumes "B index ps = l"
  shows "{# insert x b . b \<in># B#} index ps = l"
  using points_index_def by (metis (no_types, lifting) assms filter_mset_cong
      image_mset_filter_swap2 points_index_def size_image_mset subset_insert)

lemma points_index_on_set_def [simp]:
  assumes "finite B"
  shows "(mset_set B) index ps = card {b \<in> B. ps \<subseteq> b}"
  by (simp add: points_index_def assms)

lemma points_index_single_rep_num: "B index {x} = B rep x"
  by (simp add: points_index_def point_replication_number_def)

lemma points_index_pair_rep_num:
  assumes "\<And> b. b \<in># B \<Longrightarrow> x \<in> b"
  shows "B index {x, y} = B rep y"
  using point_replication_number_def points_index_def
  by (metis assms empty_subsetI filter_mset_cong insert_subset)

lemma points_index_0_left_imp:
  assumes "B index ps = 0"
  assumes "b \<in># B"
  shows "\<not> (ps \<subseteq> b)"
proof (rule ccontr)
  assume "\<not> \<not> ps \<subseteq> b"
  then have a: "ps \<subseteq> b" by auto
  then have "b \<in># {#bl \<in># B . ps \<subseteq> bl#}" by (simp add: assms(2))
  thus False by (metis assms(1) count_greater_eq_Suc_zero_iff count_size_set_repr not_less_eq_eq
        points_index_def size_filter_mset_lesseq)
qed

lemma points_index_0_right_imp:
  assumes "\<And> b . b \<in># B \<Longrightarrow> (\<not> ps \<subseteq> b)"
  shows "B index ps = 0"
  using assms by (simp add: filter_mset_empty_conv points_index_def)

lemma points_index_0_iff: "B index ps = 0 \<longleftrightarrow> (\<forall> b. b \<in># B \<longrightarrow> (\<not> ps \<subseteq> b))"
  using points_index_0_left_imp points_index_0_right_imp by metis

lemma points_index_gt0_impl_existance:
  assumes "B index ps > 0"
  shows "(\<exists> bl . (bl \<in># B \<and> ps \<subseteq> bl))"
proof -
  have "size {#bl \<in># B . ps \<subseteq> bl#} > 0"
    by (metis assms points_index_def)
  then obtain bl where "bl \<in># B" and "ps \<subseteq> bl"
    by (metis filter_mset_empty_conv nonempty_has_size)
  thus ?thesis by auto
qed

lemma points_index_one_unique:
  assumes "B index ps = 1"
  assumes "bl \<in># B" and "ps \<subseteq> bl" and "bl' \<in># B" and "ps \<subseteq> bl'"
  shows "bl = bl'"
proof (rule ccontr)
  assume assm: "bl \<noteq> bl'"
  then have bl1: "bl \<in># {#bl \<in># B . ps \<subseteq> bl#}" using assms by simp
  then have bl2: "bl'\<in># {#bl \<in># B . ps \<subseteq> bl#}" using assms by simp
  then have "{#bl, bl'#} \<subseteq># {#bl \<in># B . ps \<subseteq> bl#}" using assms by (metis bl1 bl2 points_index_def
        add_mset_subseteq_single_iff assm mset_subset_eq_single size_single subseteq_mset_size_eql)
  then have "size {#bl \<in># B . ps \<subseteq> bl#} \<ge> 2" using size_mset_mono by fastforce
  thus False using assms by (metis numeral_le_one_iff points_index_def semiring_norm(69))
qed

lemma points_index_one_unique_block:
  assumes "B index ps = 1"
  shows "\<exists>! bl . (bl \<in># B \<and> ps \<subseteq> bl)"
  using assms points_index_gt0_impl_existance points_index_one_unique
  by (metis zero_less_one)

lemma points_index_one_not_unique_block:
  assumes "B index ps = 1"
  assumes "ps \<subseteq> bl"
  assumes "bl \<in># B"
  assumes "bl' \<in># B - {#bl#}"
  shows "\<not> ps \<subseteq> bl'"
proof -
  have "B = (B - {#bl#}) + {#bl#}" by (simp add: assms(3))
  then have "(B - {#bl#}) index ps = B index ps - {#bl#} index ps"
    by (metis point_index_diff)
  then have "(B - {#bl#}) index ps = 0" using assms points_index_singleton
    by (metis diff_self_eq_0)
  thus ?thesis using assms(4) points_index_0_left_imp by auto
qed

lemma (in incidence_system) points_index_alt_def: "\<B> index ps = size {#b \<in># \<B> . ps \<subseteq> b#}"
  by (simp add: points_index_def)

lemma (in incidence_system) points_index_ps_nin: "\<not> (ps \<subseteq> \<V>) \<Longrightarrow> \<B> index ps = 0"
  using points_index_alt_def filter_mset_empty_conv in_mono size_empty subsetI wf_invalid_point
  by metis

lemma (in incidence_system) points_index_count_bl:
    "multiplicity bl \<ge> n \<Longrightarrow> ps \<subseteq> bl \<Longrightarrow> count {#bl \<in># \<B> . ps \<subseteq> bl#} bl \<ge> n"
  by simp

lemma (in finite_incidence_system) points_index_zero:
  assumes "card ps > card \<V>"
  shows "\<B> index ps = 0"
proof -
  have "\<And> b. b \<in># \<B> \<Longrightarrow> card ps > card b"
    using block_size_lt_order card_subset_not_gt_card finite_sets assms by fastforce
  then have "{#b \<in># \<B> . ps \<subseteq> b#} = {#}"
    by (simp add: card_subset_not_gt_card filter_mset_empty_conv finite_blocks)
  thus ?thesis using points_index_alt_def by simp
qed

lemma (in design) points_index_subset:
    "x \<subseteq># {#bl \<in># \<B> . ps \<subseteq> bl#} \<Longrightarrow> ps \<subseteq> \<V> \<Longrightarrow> (\<B> index ps) \<ge> (size x)"
  by (simp add: points_index_def size_mset_mono)

lemma (in design) points_index_count_min: "multiplicity bl \<ge> n \<Longrightarrow> ps \<subseteq> bl \<Longrightarrow> \<B> index ps \<ge> n"
  using points_index_alt_def set_count_size_min by (metis filter_mset.rep_eq)

subsubsection \<open>Intersection Number\<close>

text \<open>The intersection number of two blocks is the size of the intersection of those blocks. i.e.
the number of points which occur in both blocks\<close>
definition intersection_number :: "'a set \<Rightarrow> 'a set \<Rightarrow> nat" (infix "|\<inter>|" 70) where
"b1 |\<inter>| b2 \<equiv> card (b1 \<inter> b2)"

lemma intersection_num_non_neg: "b1 |\<inter>| b2 \<ge> 0"
  by (simp add: intersection_number_def)

lemma intersection_number_empty_iff:
  assumes "finite b1"
  shows "b1 \<inter> b2 = {} \<longleftrightarrow> b1 |\<inter>| b2 = 0"
  by (simp add: intersection_number_def assms)

lemma intersect_num_commute: "b1 |\<inter>| b2 = b2 |\<inter>| b1"
  by (simp add: inf_commute intersection_number_def)

definition n_intersect_number :: "'a set \<Rightarrow> nat\<Rightarrow> 'a set \<Rightarrow> nat" where
"n_intersect_number b1 n b2 \<equiv> card { x \<in> Pow (b1 \<inter> b2) . card x = n}"

notation n_intersect_number ("(_ |\<inter>|\<^sub>_ _)" [52, 51, 52] 50)

lemma n_intersect_num_subset_def: "b1 |\<inter>|\<^sub>n b2 = card {x . x \<subseteq> b1 \<inter> b2 \<and> card x = n}"
  using n_intersect_number_def by auto

lemma n_inter_num_one: "finite b1 \<Longrightarrow> finite b2 \<Longrightarrow> b1 |\<inter>|\<^sub>1 b2 = b1 |\<inter>| b2"
  using n_intersect_number_def intersection_number_def card_Pow_filter_one
  by (metis (full_types) finite_Int)

lemma n_inter_num_choose: "finite b1 \<Longrightarrow> finite b2 \<Longrightarrow> b1 |\<inter>|\<^sub>n b2 = (card (b1 \<inter> b2) choose n)"
  using n_subsets n_intersect_num_subset_def
  by (metis (full_types) finite_Int)

lemma set_filter_single: "x \<in> A \<Longrightarrow> {a \<in> A . a = x} = {x}"
  by auto

lemma (in design) n_inter_num_zero:
  assumes "b1 \<in># \<B>" and "b2 \<in># \<B>"
  shows "b1 |\<inter>|\<^sub>0 b2 = 1"
proof -
  have empty: "\<And>x . finite x \<Longrightarrow> card x = 0 \<Longrightarrow> x = {}"
    by simp
  have empt_in: "{} \<in> Pow (b1 \<inter> b2)" by simp
  have "finite (b1 \<inter> b2)" using finite_blocks assms by simp
  then have "\<And> x . x \<in> Pow (b1 \<inter> b2) \<Longrightarrow> finite x" by (meson PowD finite_subset)
  then have "{x \<in> Pow (b1 \<inter> b2) . card x = 0} = {x \<in> Pow (b1 \<inter> b2) . x = {}}"
    using empty by (metis card.empty)
  then have "{x \<in> Pow (b1 \<inter> b2) . card x = 0} = {{}}"
    by (simp add: empt_in set_filter_single Collect_conv_if)
  thus ?thesis by (simp add: n_intersect_number_def)
qed

lemma (in design) n_inter_num_choose_design: "b1 \<in># \<B> \<Longrightarrow> b2 \<in># \<B>
    \<Longrightarrow> b1 |\<inter>|\<^sub>n b2 = (card (b1 \<inter> b2) choose n) "
  using finite_blocks by (simp add: n_inter_num_choose)

lemma (in design) n_inter_num_choose_design_inter: "b1 \<in># \<B> \<Longrightarrow> b2 \<in># \<B>
    \<Longrightarrow> b1 |\<inter>|\<^sub>n b2 = (nat (b1 |\<inter>| b2) choose n) "
  using finite_blocks by (simp add: n_inter_num_choose intersection_number_def)

subsection \<open>Incidence System Set Property Definitions\<close>
context incidence_system
begin

text \<open>The set of replication numbers for all points of design\<close>
definition replication_numbers :: "nat set" where
"replication_numbers \<equiv> {\<B> rep x | x . x \<in> \<V>}"

lemma replication_numbers_non_empty:
  assumes "\<V> \<noteq> {}"
  shows "replication_numbers \<noteq> {}"
  by (simp add: assms replication_numbers_def)

lemma obtain_point_with_rep: "r \<in> replication_numbers \<Longrightarrow> \<exists> x. x \<in> \<V> \<and> \<B> rep x = r"
  using replication_numbers_def by auto

lemma point_rep_number_in_set: "x \<in> \<V> \<Longrightarrow> (\<B> rep x) \<in> replication_numbers"
  by (auto simp add: replication_numbers_def)

lemma (in finite_incidence_system) replication_numbers_finite: "finite replication_numbers"
  using finite_sets by (simp add: replication_numbers_def)

text \<open>The set of all block sizes in a system\<close>

definition sys_block_sizes :: "nat set" where
"sys_block_sizes \<equiv> { card bl | bl. bl \<in># \<B>}"

lemma block_sizes_non_empty_set:
  assumes "\<B> \<noteq> {#}"
  shows "sys_block_sizes \<noteq> {}"
by (simp add: sys_block_sizes_def assms)

lemma finite_block_sizes: "finite (sys_block_sizes)"
  by (simp add: sys_block_sizes_def)

lemma block_sizes_non_empty:
  assumes "\<B> \<noteq> {#}"
  shows "card (sys_block_sizes) > 0"
  using finite_block_sizes block_sizes_non_empty_set
  by (simp add: assms card_gt_0_iff)

lemma sys_block_sizes_in: "bl \<in># \<B> \<Longrightarrow> card bl \<in> sys_block_sizes"
  unfolding sys_block_sizes_def by auto

lemma sys_block_sizes_obtain_bl: "x \<in> sys_block_sizes  \<Longrightarrow> (\<exists> bl \<in># \<B>. card bl = x)"
  by (auto simp add: sys_block_sizes_def)

text \<open>The set of all possible intersection numbers in a system.\<close>

definition intersection_numbers :: "nat set" where
"intersection_numbers \<equiv> { b1 |\<inter>| b2 | b1 b2 . b1 \<in># \<B> \<and> b2 \<in># (\<B> - {#b1#})}"

lemma obtain_blocks_intersect_num: "n \<in> intersection_numbers \<Longrightarrow>
  \<exists> b1 b2. b1 \<in># \<B> \<and> b2 \<in># (\<B> - {#b1#}) \<and>  b1 |\<inter>| b2 = n"
  by (auto simp add: intersection_numbers_def)

lemma intersect_num_in_set: "b1 \<in># \<B> \<Longrightarrow> b2 \<in># (\<B> - {#b1#}) \<Longrightarrow> b1 |\<inter>| b2 \<in> intersection_numbers"
  by (auto simp add: intersection_numbers_def)

text \<open>The set of all possible point indices\<close>
definition point_indices :: "nat \<Rightarrow> nat set" where
"point_indices t \<equiv> {\<B> index ps | ps. card ps = t \<and> ps \<subseteq> \<V>}"

lemma point_indices_elem_in: "ps \<subseteq> \<V> \<Longrightarrow> card ps = t \<Longrightarrow> \<B> index ps \<in> point_indices t"
  by (auto simp add: point_indices_def)

lemma point_indices_alt_def: "point_indices t = { \<B> index ps | ps. card ps = t \<and> ps \<subseteq> \<V>}"
  by (simp add: point_indices_def)

end

subsection \<open>Basic Constructions on designs\<close>

text \<open>This section defines some of the most common universal constructions found in design theory
involving only a single design\<close>

subsubsection \<open>Design Complements\<close>

context incidence_system
begin

text \<open>The complement of a block are all the points in the design not in that block.
The complement of a design is therefore the original point sets, and set of all block complements\<close>
definition block_complement:: "'a set \<Rightarrow> 'a set" ("_\<^sup>c" [56] 55) where
"block_complement b \<equiv> \<V> - b"

definition complement_blocks :: "'a set multiset" ("(\<B>\<^sup>C)")where
"complement_blocks \<equiv> {# bl\<^sup>c . bl \<in># \<B> #}"

lemma block_complement_elem_iff:
  assumes "ps \<subseteq> \<V>"
  shows "ps \<subseteq> bl\<^sup>c \<longleftrightarrow> (\<forall> x \<in> ps. x \<notin> bl)"
  using assms block_complement_def by (auto)

lemma block_complement_inter_empty: "bl1\<^sup>c = bl2 \<Longrightarrow> bl1 \<inter> bl2 = {}"
  using block_complement_def by auto

lemma block_complement_inv:
  assumes "bl \<in># \<B>"
  assumes "bl\<^sup>c = bl2"
  shows "bl2\<^sup>c = bl"
  by (metis Diff_Diff_Int assms(1) assms(2) block_complement_def inf.absorb_iff2 wellformed)

lemma block_complement_subset_points: "ps \<subseteq> (bl\<^sup>c) \<Longrightarrow> ps \<subseteq> \<V>"
  using block_complement_def by blast

lemma obtain_comp_block_orig:
  assumes "bl1 \<in># \<B>\<^sup>C"
  obtains bl2 where "bl2 \<in># \<B>" and "bl1 = bl2\<^sup>c"
  using wellformed assms by (auto simp add: complement_blocks_def)

lemma complement_same_b [simp]: "size \<B>\<^sup>C = size \<B>"
  by (simp add: complement_blocks_def)

lemma block_comp_elem_alt_left: "x \<in> bl \<Longrightarrow> ps \<subseteq> bl\<^sup>c \<Longrightarrow> x \<notin> ps"
  by (auto simp add: block_complement_def block_complement_elem_iff)

lemma block_comp_elem_alt_right: "ps \<subseteq> \<V> \<Longrightarrow> (\<And> x . x \<in> ps \<Longrightarrow> x \<notin> bl) \<Longrightarrow> ps \<subseteq> bl\<^sup>c"
  by (auto simp add: block_complement_elem_iff)

lemma complement_index:
  assumes "ps \<subseteq> \<V>"
  shows "\<B>\<^sup>C index ps = size {# b \<in># \<B> . (\<forall> x \<in> ps . x \<notin> b) #}"
proof -
  have "\<B>\<^sup>C index ps =  size {# b \<in># {# bl\<^sup>c . bl \<in># \<B>#}. ps \<subseteq> b #}"
    by (simp add: complement_blocks_def points_index_def)
  then have "\<B>\<^sup>C index ps = size {# bl\<^sup>c | bl \<in># \<B> . ps \<subseteq> bl\<^sup>c #}"
    by (metis image_mset_filter_swap)
  thus ?thesis using assms by (simp add: block_complement_elem_iff)
qed

lemma complement_index_2:
  assumes "{x, y} \<subseteq> \<V>"
  shows "\<B>\<^sup>C index {x, y} = size {# b \<in># \<B> . x \<notin> b \<and> y \<notin> b #}"
proof -
  have a: "\<And> b. b \<in># \<B> \<Longrightarrow> \<forall> x' \<in> {x, y} . x' \<notin> b \<Longrightarrow> x \<notin> b \<and> y \<notin> b"
    by simp
  have "\<And> b. b \<in># \<B> \<Longrightarrow> x \<notin> b \<and> y \<notin> b \<Longrightarrow> \<forall> x' \<in> {x, y} . x' \<notin> b "
    by simp
  thus ?thesis using assms a complement_index
    by (smt (verit) filter_mset_cong)
qed

lemma complement_rep_number:
  assumes "x \<in> \<V>" and "\<B> rep x = r"
  shows  "\<B>\<^sup>C rep x = \<b> - r"
proof -
  have r: "size {#b \<in># \<B> . x \<in> b#} = r" using assms by (simp add: point_replication_number_def)
  then have a: "\<And> b . b \<in># \<B> \<Longrightarrow> x \<in> b \<Longrightarrow> x \<notin> b\<^sup>c"
    by (simp add: block_complement_def)
  have "\<And> b . b \<in># \<B> \<Longrightarrow> x \<notin> b \<Longrightarrow> x \<in> b\<^sup>c"
    by (simp add: assms(1) block_complement_def)
  then have alt: "(image_mset block_complement \<B>) rep x = size {#b \<in># \<B> . x \<notin> b#}"
    using a filter_mset_cong image_mset_filter_swap2 point_replication_number_def
    by (smt (verit, ccfv_SIG) size_image_mset)
  have "\<b> = size {#b \<in># \<B> . x \<in> b#} + size {#b \<in># \<B> . x \<notin> b#}"
    by (metis multiset_partition size_union)
  thus ?thesis using alt
    by (simp add: r complement_blocks_def)
qed

lemma complement_blocks_wf: "bl \<in># \<B>\<^sup>C \<Longrightarrow> bl \<subseteq> \<V>"
  by (auto simp add: complement_blocks_def block_complement_def)

lemma complement_wf [intro]: "incidence_system \<V> \<B>\<^sup>C"
  using complement_blocks_wf by (unfold_locales)

interpretation sys_complement: incidence_system "\<V>" "\<B>\<^sup>C"
  using complement_wf by simp
end

context finite_incidence_system
begin
lemma block_complement_size: "b \<subseteq> \<V> \<Longrightarrow> card (b\<^sup>c) = card \<V> - card b"
  by (simp add: block_complement_def card_Diff_subset finite_subset card_mono of_nat_diff finite_sets)

lemma block_comp_incomplete: "incomplete_block bl \<Longrightarrow> card (bl\<^sup>c) > 0"
  using block_complement_size by (simp add: wellformed)

lemma  block_comp_incomplete_nempty: "incomplete_block bl \<Longrightarrow> bl\<^sup>c \<noteq> {}"
  using wellformed block_complement_def finite_blocks
  by (auto simp add: block_complement_size block_comp_incomplete card_subset_not_gt_card)

lemma incomplete_block_proper_subset: "incomplete_block bl \<Longrightarrow> bl \<subset> \<V>"
  using wellformed by fastforce

lemma complement_finite: "finite_incidence_system \<V> \<B>\<^sup>C"
  using complement_wf finite_sets by (simp add: incidence_system.finite_sysI)

interpretation comp_fin: finite_incidence_system \<V> "\<B>\<^sup>C"
  using complement_finite by simp

end

context design
begin
lemma (in design) complement_design:
  assumes "\<And> bl . bl \<in># \<B> \<Longrightarrow> incomplete_block bl"
  shows "design \<V> (\<B>\<^sup>C)"
proof -
  interpret fin: finite_incidence_system \<V> "\<B>\<^sup>C" using complement_finite by simp
  show ?thesis using assms block_comp_incomplete_nempty wellformed
    by (unfold_locales) (auto simp add: complement_blocks_def)
qed

end
subsubsection \<open>Multiples\<close>
text \<open>An easy way to construct new set systems is to simply multiply the block collection by some
constant\<close>

context incidence_system
begin

abbreviation multiple_blocks :: "nat \<Rightarrow> 'a set multiset" where
"multiple_blocks n \<equiv> repeat_mset n \<B>"

lemma multiple_block_in_original: "b \<in># multiple_blocks n \<Longrightarrow> b \<in># \<B>"
  by (simp add: elem_in_repeat_in_original)

lemma multiple_block_in: "n > 0 \<Longrightarrow> b \<in># \<B> \<Longrightarrow>  b \<in># multiple_blocks n"
  by (simp add: elem_in_original_in_repeat)

lemma multiple_blocks_gt: "n > 0 \<Longrightarrow> size (multiple_blocks n) \<ge> size \<B>"
  by (simp)

lemma block_original_count_le: "n > 0 \<Longrightarrow> count \<B> b \<le> count (multiple_blocks n) b"
  using count_repeat_mset by simp

lemma multiple_blocks_sub: "n > 0 \<Longrightarrow> \<B> \<subseteq># (multiple_blocks n)"
  by (simp add: mset_subset_eqI block_original_count_le)

lemma multiple_1_same: "multiple_blocks 1 = \<B>"
  by simp

lemma multiple_unfold_1: "multiple_blocks (Suc n) = (multiple_blocks n) + \<B>"
  by simp

lemma multiple_point_rep_num: "(multiple_blocks n) rep x = (\<B> rep x) * n"
proof (induction n)
  case 0
  then show ?case by (simp add: point_replication_number_def)
next
  case (Suc n)
  then have "multiple_blocks (Suc n) rep x = \<B> rep x * n + (\<B> rep x)"
    using Suc.IH Suc.prems by (simp add: union_commute point_replication_number_def)
  then show ?case
    by (simp)
qed

lemma multiple_point_index: "(multiple_blocks n) index ps = (\<B> index ps) * n"
  by (induction n) (auto simp add: points_index_def)

lemma repeat_mset_block_point_rel: "\<And>b x. b \<in># multiple_blocks  n \<Longrightarrow> x \<in> b \<Longrightarrow> x \<in> \<V>"
  by (induction n) (auto, meson subset_iff wellformed)

lemma multiple_is_wellformed: "incidence_system \<V> (multiple_blocks n)"
  using repeat_mset_subset_in wellformed repeat_mset_block_point_rel by (unfold_locales) (auto)

lemma  multiple_blocks_num [simp]: "size (multiple_blocks n) = n*\<b>"
  by simp

interpretation mult_sys: incidence_system \<V> "(multiple_blocks n)"
  by (simp add: multiple_is_wellformed)

lemma multiple_block_multiplicity [simp]: "mult_sys.multiplicity n bl = (multiplicity bl) * n"
  by (simp)

lemma multiple_block_sizes_same:
  assumes "n > 0"
  shows "sys_block_sizes = mult_sys.sys_block_sizes n"
proof -
  have def: "mult_sys.sys_block_sizes n = {card bl | bl. bl \<in># (multiple_blocks n)}"
    by (simp add: mult_sys.sys_block_sizes_def)
  then have eq: "\<And> bl. bl \<in># (multiple_blocks n) \<longleftrightarrow> bl \<in># \<B>"
    using assms multiple_block_in multiple_block_in_original by blast
  thus ?thesis using def by (simp add: sys_block_sizes_def eq)
qed

end

context finite_incidence_system
begin

lemma multiple_is_finite: "finite_incidence_system \<V> (multiple_blocks n)"
  using multiple_is_wellformed finite_sets by (unfold_locales) (auto simp add: incidence_system_def)

end

context design
begin

lemma multiple_is_design: "design \<V> (multiple_blocks n)"
proof -
  interpret fis: finite_incidence_system \<V> "multiple_blocks n" using multiple_is_finite by simp
  show ?thesis using blocks_nempty
    by (unfold_locales) (auto simp add: elem_in_repeat_in_original repeat_mset_not_empty)
qed

end

subsection \<open>Simple Designs\<close>

text \<open>Simple designs are those in which the multiplicity of each block is at most one.
In other words, the block collection is a set. This can significantly ease reasoning.\<close>

locale simple_incidence_system = incidence_system +
  assumes simple [simp]: "bl \<in># \<B> \<Longrightarrow> multiplicity bl = 1"

begin

lemma simple_alt_def_all: "\<forall> bl \<in># \<B> . multiplicity bl = 1"
  using simple by auto

lemma simple_blocks_eq_sup: "mset_set (design_support) = \<B>"
  using distinct_mset_def simple design_support_def by (metis distinct_mset_set_mset_ident)

lemma simple_block_size_eq_card: "\<b> = card (design_support)"
  by (metis simple_blocks_eq_sup size_mset_set)

lemma points_index_simple_def: "\<B> index ps = card {b \<in> design_support . ps \<subseteq> b}"
  using design_support_def points_index_def card_size_filter_eq simple_blocks_eq_sup
  by (metis finite_set_mset)

lemma replication_num_simple_def: "\<B> rep x = card {b \<in> design_support . x \<in> b}"
  using design_support_def point_replication_number_def card_size_filter_eq simple_blocks_eq_sup
  by (metis finite_set_mset)

end

locale simple_design = design + simple_incidence_system

text \<open>Additional reasoning about when something is not simple\<close>
context incidence_system
begin
lemma simple_not_multiplicity: "b \<in># \<B> \<Longrightarrow> multiplicity  b > 1 \<Longrightarrow> \<not> simple_incidence_system \<V> \<B>"
  using simple_incidence_system_def simple_incidence_system_axioms_def by (metis nat_neq_iff)

lemma multiple_not_simple:
  assumes "n > 1"
  assumes "\<B> \<noteq> {#}"
  shows "\<not> simple_incidence_system \<V> (multiple_blocks n)"
proof (rule ccontr, simp)
  assume "simple_incidence_system \<V> (multiple_blocks n)"
  then have "\<And> bl. bl \<in># \<B> \<Longrightarrow> count (multiple_blocks n) bl = 1"
    using assms(1) elem_in_original_in_repeat
    by (metis not_gr_zero not_less_zero simple_incidence_system.simple)
  thus False using assms by auto
qed

end

subsection \<open>Proper Designs\<close>
text \<open>Many types of designs rely on parameter conditions that only make sense for non-empty designs.
i.e. designs with at least one block, and therefore given well-formed condition, at least one point.
To this end we define the notion of a "proper" design\<close>

locale proper_design = design +
  assumes b_non_zero: "\<b> \<noteq> 0"
begin

lemma is_proper: "proper_design \<V> \<B>" by intro_locales

lemma v_non_zero: "\<v> > 0"
  using b_non_zero v_eq0_imp_b_eq_0 by auto

lemma b_positive: "\<b> > 0" using b_non_zero
  by (simp add: nonempty_has_size)

lemma design_points_nempty: "\<V> \<noteq> {}"
  using v_non_zero by auto

lemma design_blocks_nempty: "\<B> \<noteq> {#}"
  using b_non_zero by auto

end

text \<open>Intro rules for a proper design\<close>
lemma (in design) proper_designI[intro]: "\<b> \<noteq> 0 \<Longrightarrow> proper_design \<V> \<B>"
  by (unfold_locales) simp

lemma proper_designII[intro]:
  assumes "design V B" and "B \<noteq> {#}"
  shows "proper_design V B"
proof -
  interpret des: design V B using assms by simp
  show ?thesis using assms by unfold_locales simp
qed

text \<open>Reasoning on construction closure for proper designs\<close>
context proper_design
begin

lemma multiple_proper_design:
  assumes "n > 0"
  shows "proper_design \<V> (multiple_blocks n)"
  using multiple_is_design assms design_blocks_nempty multiple_block_in
  by (metis block_set_nempty_imp_block_ex empty_iff proper_designII set_mset_empty)

lemma complement_proper_design:
  assumes "\<And> bl . bl \<in># \<B> \<Longrightarrow> incomplete_block bl"
  shows "proper_design \<V> \<B>\<^sup>C"
proof -
  interpret des: design \<V> "\<B>\<^sup>C"
    by (simp add: assms complement_design)
  show ?thesis using b_non_zero by (unfold_locales) auto
qed

end
end


(* Title:      Orders
   Author:     Insa Stucke (ist@informatik.uni-kiel.de)
*)

section {* Relation Algebra Orders *}

theory Relation_Algebra_Orders
    imports Main "$AFP/Relation_Algebra/Relation_Algebra"
begin

context relation_algebra
begin

text {* In this theory we define and prove some basic facts about order related relations. *}

definition is_refl :: "'a \<Rightarrow> bool"
  where "is_refl x \<equiv> 1' \<le> x"

definition is_trans :: "'a \<Rightarrow> bool"
  where "is_trans x \<equiv> x ; x \<le> x"

definition is_preorder :: "'a \<Rightarrow> bool"
  where "is_preorder x \<equiv> is_refl x \<and> is_trans x"

definition is_antisym :: "'a \<Rightarrow> bool"
  where "is_antisym x \<equiv> x \<cdot> x\<^sup>\<smile> \<le> 1'"

definition is_order :: "'a \<Rightarrow> bool"
  where "is_order x \<equiv> is_refl x \<and> is_antisym x \<and> is_trans x"

definition is_irrefl :: "'a \<Rightarrow> bool"
  where "is_irrefl x \<equiv> x \<le> -1'"

definition is_asym :: "'a \<Rightarrow> bool"
  where "is_asym x \<equiv> x \<cdot> x\<^sup>\<smile> \<le> 0"

definition is_lin :: "'a \<Rightarrow> bool"
  where "is_lin x \<equiv> x + x\<^sup>\<smile> = 1"

definition is_strictorder :: "'a \<Rightarrow> bool"
  where "is_strictorder x \<equiv> is_asym x \<and> is_trans x"

lemma reflone: "is_refl 1'"
by (simp add: is_refl_def)

lemma transone: "is_trans 1'"
by (simp add: is_trans_def)

lemma antisymmone: "is_antisym 1'"
by (simp add: is_antisym_def)

lemma preorderone: "is_preorder 1'"
by (simp add: is_preorder_def reflone transone)

lemma orderone: "is_order 1'"
by (simp add: antisymmone is_order_def reflone transone)

lemma reflcup: "is_refl x \<and> is_refl y \<longrightarrow> is_refl (x + y)"
by (simp add: is_refl_def le_supI2)

lemma reflcap: "is_refl x \<and> is_refl y \<longrightarrow> is_refl (x \<cdot> y)"
by (simp add: is_refl_def)

lemma reflcomp: "is_refl x \<and> is_refl y \<longrightarrow> is_refl (x ; y)"
by (metis is_refl_def mult_oner subdistl sup.boundedE sup_absorb2)

lemma transcap: "is_trans x \<and> is_trans y \<longrightarrow> is_trans (x \<cdot> y)"
by (meson is_trans_def inf_mono meet_interchange order.trans)

lemma preordercap: "is_preorder x \<and> is_preorder y \<longrightarrow> is_preorder (x \<cdot> y)"
by (simp add: is_preorder_def reflcap transcap)

lemma antisymcap: "is_antisym x \<and> is_antisym y \<longrightarrow> is_antisym (x \<cdot> y)"
by (meson is_antisym_def conv_self_conjugate_var dual_order.trans g_subdist inf.boundedI inf.cobounded1 inf.cobounded2)

lemma ordercap: "is_order x \<and> is_order y \<longrightarrow> is_order (x \<cdot> y)"
by (simp add: antisymcap is_order_def reflcap transcap)

lemma irreflcup: "is_irrefl x \<and> is_irrefl y \<longrightarrow> is_irrefl (x + y)"
by (simp add: is_irrefl_def)

lemma irreflcap: "is_irrefl x \<and> is_irrefl y \<longrightarrow> is_irrefl (x \<cdot> y)"
by (simp add: is_irrefl_def inf.coboundedI1)

lemma aux_refl_anti_lin:
  assumes "is_refl x"
  and "is_antisym x"
  and "is_lin x"
  shows "x\<^sup>\<smile> = 1' + -x"
proof (rule antisym)
  show "x\<^sup>\<smile> \<le> 1' + -x"
    using assms(2) is_antisym_def galois_2 inf_commute by auto
  show "1' + -x \<le> x\<^sup>\<smile>"
    using assms(1) assms(3) is_lin_def is_refl_def conv_iso galois_aux4 by fastforce
qed

lemma aux_card_lin_ord: "is_refl x \<and> is_antisym x \<longrightarrow> x \<cdot> x\<^sup>\<smile> = 1'"
  using is_antisym_def is_refl_def antisym conv_iso by fastforce

end

end


(* Propiedad de los conjuntos finitos de números naturales *)

(*<*)
theory ConjuntosFinitos
imports Main "HOL-Library.LaTeXsugar" "HOL-Library.OptionalSugar"
begin
(*>*)

section \<open>Propiedad de los conjuntos finitos de número naturales \<close>

subsection \<open>Demostración en lenguaje natural \<close>

text \<open>El siguiente teorema es una propiedad que verifican todos los
  conjuntos finitos de números naturales. Se ha estudiado en el
  \href{http://bit.ly/2XBW6n2}{tema 10} de la asignatura de LMF de
  tercer curso del grado en Matemáticas. Su enunciado es el siguiente:

  \begin{teorema}
    Sea S un conjunto finito de números naturales. Entonces todos los
    elementos de S son menores o iguales que la suma de los elementos de
    S; es decir,
    $$\forall m \in S \Longrightarrow m \leq \sum S$$
    donde $\sum S $ denota la suma de todos los elementos de S.
  \end{teorema}

Primero se debe notar que podemos dar una definición inductiva de
 conjunto finito, lo que conlleva un esquema de inducción asociado.

\begin{definicion}\label{defconj}
La definición inductiva de un conjunto finito es:
\begin{itemize}
\item $\emptyset$ es finito.
\item Si $A$ es un conjunto finito y $x$ un elemento entonces $A
 \cup \{x\}$ es un conjunto finito.
\end{itemize}
\end{definicion}

De esta construcción se obtiene un esquema de inducción. Para ello sea
 $\varphi$ una propiedad sobre conjuntos finitos. El esquema
de inducción viene dado por:

Si se verifica:
\begin{enumerate}
\item $\varphi(\emptyset).$
\item $\forall A$ finito  tal que $\varphi(A)$ y  $\forall x$
 entonces $\varphi(A \cup \{x\}).$
  \end{enumerate}

Entonces $\forall A$ finito se verifica $\varphi(A).$

  \begin{demostracion}
  La demostración del teorema la haremos por inducción sobre conjuntos
  finitos.

  (Base de la inducción) El caso $S = \emptyset$ es trivial.

  (Paso de la inducción) Supongamos que se verifica el teorema para un
  conjunto finito de números naturales, que se denotará por $S$ y sea
  $a$ un elemento. Vamos a demostrarlo para $S \cup \{a\}.$

  Sea $a \in \Bbb{N}$ tal que $a \notin S,$ ya que si $a \in S$ se
  tendría probado el teorema. Luego hay que probar que:
  $$\forall n \in S \cup \{a\} \Longrightarrow
    n \leq \sum (S \cup \{a\})$$

  Distingamos dos casos ahora:

  Caso 1: $n = a$.

  Si $n = a$, se tiene que:

  $$n = a \leq a + \sum S = \sum (S \cup \{a\}).$$

  Caso 2: $n \neq a.$

  Si $n \neq a,$ tenemos que $n \in S,$ luego usando la hipótesis de
  inducción:
  $$n \leq \sum S \leq \sum S + a = \sum (S \cup \{a\}).$$
  \end{demostracion}

  En la demostración del teorema hemos usado un resultado, que vamos a
  probar en Isabelle después de la especificación del teorema;
  el resultado es $\sum S + a = \sum (S \cup \{ a\})$.\<close>

subsection \<open>Especificación en Isabelle/HOL \<close>

text  \<open>Para la especificación del teorema en Isabelle, primero
consideremos la definición de conjunto finito ya definida en Isabelle.

inductive finite :: "'a set $\Rightarrow$ bool" \\
  where \\
    emptyI [simp, intro!]: "finite $\{\}$" \\
  $|$ insertI [simp, intro!]: "finite A $\Longrightarrow$ finite (insert a A)"
 \<close>

text \<open>
Esta definición de conjunto finito es una definición inductiva en
Isabelle, equivalente a la Definición \ref{defconj} en lenguaje
natural. Esta definición genera automáticamente el siguiente esquema de
 inducción en Isabelle: \<close>

text \<open>
 \begin{itemize}
  \item[] @{thm[mode=Def] finite.induct} \hfill (@{text finite.induct})
  \end{itemize}
    \<close>

text \<open> También se debe notar que  @{text "finite S "} indica que un
conjunto $S$ es finito  y definir la función @{text "sumaConj"} tal que
  @{text "sumaConj n"} es la suma de todos los elementos de S.
\<close>

definition sumaConj :: "nat set \<Rightarrow> nat" where
  "sumaConj S \<equiv> \<Sum>S"

text \<open> Donde $\sum$ ya se encuentra definido en Isabelle, pero se
renombra de la siguiente forma:

abbreviation Sum ("$\sum$") \\
  where "$\sum \equiv$  sum $(\lambda x. x)$" \<close>

text \<open>El enunciado del teorema es el siguiente : \<close>

lemma "finite S \<Longrightarrow> \<forall>x \<in> S. x \<le> sumaConj S"
  oops

text \<open>Vamos a demostrar primero el lema enunciado anteriormente \<close>

lemma aux_propiedad_conjuntos_finitos:
  assumes "finite S"
    "x \<notin> S"
  shows "x + sumaConj S = sumaConj (insert x S)"
proof -
  have "x + sumaConj S = x + \<Sum>S"
    by (simp only: sumaConj_def)
  also have "\<dots> = sum (\<lambda>x. x) (insert x S)"
    using assms
    by (rule sum.insert[THEN sym])
   also have "\<dots> = sumaConj (insert x S)"
    by (simp only: sumaConj_def )
  finally show ?thesis
    by this
qed

text \<open>En la demostración del lema anterior se ha usado
  @{term"sumConj_def"}, que hace referencia a la definición sumaConj que
  hemos hecho anteriormente.

Vamos a presentar diferentes formas de demostración:\<close>

subsection \<open>Demostración automática\<close>

text \<open>La demostración automática es:\<close>

lemma "finite S \<Longrightarrow> \<forall>x\<in>S. x \<le> sumaConj S"
  by (induct rule: finite_induct)
     (auto simp add: sumaConj_def)

subsection \<open>Demostración detallada\<close>

text \<open>La demostración declarativa es: \<close>

lemma sumaConj_acota:
  "finite S \<Longrightarrow> \<forall>x\<in>S. x \<le> sumaConj S"
proof (induct rule: finite_induct)
  show "\<forall>x \<in> {}. x \<le> sumaConj {}"
    by (simp only: ball_empty)
next
  fix x and F
  assume fF: "finite F"
    and xF: "x \<notin> F"
    and HI: "\<forall> x\<in>F. x \<le> sumaConj F"
  show "\<forall>y \<in> insert x F. y \<le> sumaConj (insert x F)"
  proof
    fix y
    assume "y \<in> insert x F"
    then have "y = x \<or> y \<in> F"
      by (simp only: insert_iff)
    then show "y \<le> sumaConj (insert x F)"
    proof
      assume "y = x"
      then have "y \<le> x + (sumaConj F)"
        by (simp only: le_add_same_cancel1)
      also have "\<dots> = sumaConj (insert x F)"
        using fF xF
        by (rule aux_propiedad_conjuntos_finitos)
      finally show ?thesis
        by this
    next
      assume "y \<in> F"
      then have "y \<le> sumaConj F"
        using HI
        by (simp only: HI)
      also have "\<dots> \<le> x + (sumaConj F)"
        by (simp only: le_add_same_cancel2)
      also have "\<dots> = sumaConj (insert x F)"
        using fF xF
        by (rule aux_propiedad_conjuntos_finitos)
      finally show ?thesis
        by this
    qed
  qed
qed

(*<*)
end
(*>*)


section "Arithmetic and Boolean Expressions"

(* Exercise 3.4. Take a copy of theory AExp and modify it as follows. Extend
type aexp with a binary constructor Times that represents multiplication.
Modify the definition of the functions aval and asimp accordingly. You can
remove asimp_const. Function asimp should eliminate 0 and 1 from multi-
plications as well as evaluate constant subterms. Update all proofs concerned. *)

theory Chapter3AExp imports Main begin

subsection "Arithmetic Expressions"

type_synonym vname = string
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

text_raw\<open>\snip{AExpaexpdef}{2}{1}{%\<close>
datatype aexp = N int | V vname | Plus aexp aexp | Times aexp aexp
text_raw\<open>}%endsnip\<close>

(* Extend aval to include Times *)

text_raw\<open>\snip{AExpavaldef}{1}{2}{%\<close>
fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s + aval a\<^sub>2 s" |
"aval (Times a1 a2) s = aval a1 s * aval a2 s"
text_raw\<open>}%endsnip\<close>

value "aval (Plus (V ''x'') (N 5)) (\<lambda>x. if x = ''x'' then 7 else 0)"

text \<open>The same state more concisely:\<close>
value "aval (Plus (V ''x'') (N 5)) ((\<lambda>x. 0) (''x'':= 7))"

text \<open>A little syntax magic to write larger states compactly:\<close>

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

text \<open>\noindent
  We can now write a series of updates to the function @{text "\<lambda>x. 0"} compactly:
\<close>
lemma "<a := 1, b := 2> = (<> (a := 1)) (b := (2::int))"
  by (rule refl)

value "aval (Plus (V ''x'') (N 5)) <''x'' := 7>"

text \<open>In  the @{term[source] "<a := b>"} syntax, variables that are not mentioned are 0 by default:
\<close>
value "aval (Plus (V ''x'') (N 5)) <''y'' := 7>"

text\<open>Note that this @{text"<\<dots>>"} syntax works for any function space
@{text"\<tau>\<^sub>1 \<Rightarrow> \<tau>\<^sub>2"} where @{text "\<tau>\<^sub>2"} has a @{text 0}.\<close>

text\<open>Now we also eliminate all occurrences 0 in additions. The standard
method: optimized versions of the constructors:\<close>

text_raw\<open>\snip{AExpplusdef}{0}{2}{%\<close>
fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i\<^sub>1) (N i\<^sub>2) = N(i\<^sub>1+i\<^sub>2)" |
"plus (N i) a = (if i=0 then a else Plus (N i) a)" |
"plus a (N i) = (if i=0 then a else Plus a (N i))" |
"plus a\<^sub>1 a\<^sub>2 = Plus a\<^sub>1 a\<^sub>2"
text_raw\<open>}%endsnip\<close>

lemma aval_plus[simp]:
  "aval (plus a1 a2) s = aval a1 s + aval a2 s"
apply(induction a1 a2 rule: plus.induct)
apply simp_all (* just for a change from auto *)
  done

(* Define times to eliminate 0s and 1s appropriately *)
fun times :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"times (N n1) (N n2) = N (n1 * n2)" |
"times (N n) a = (if n=0 then (N 0) else (if n=1 then a else (Times (N n) a)))" |
"times a (N n) = (if n=0 then (N 0) else (if n=1 then a else (Times a (N n))))" |
"times a1 a2 = Times a1 a2"

lemma aval_times[simp]: "aval (times a1 a2) s = aval a1 s * aval a2 s"
  apply(induction a1 a2 rule: times.induct)
                      apply(simp_all)
  done

text_raw\<open>\snip{AExpasimpdef}{2}{0}{%\<close>
fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a\<^sub>1 a\<^sub>2) = plus (asimp a\<^sub>1) (asimp a\<^sub>2)" |
"asimp (Times a1 a2) = times (asimp a1) (asimp a2)"
text_raw\<open>}%endsnip\<close>

value "asimp (Plus (Plus (N 0) (N 0)) (Plus (V ''x'') (N 0)))"

value "asimp (Times (Times (N 0) (N 0)) (Times (V ''x'') (N 0)))"
value "asimp (Times (Times (N 1) (N 1)) (Times (V ''x'') (N 0)))"
value "asimp (Times (Times (N 0) (N 0)) (Times (V ''x'') (N 1)))"
value "asimp (Times (Times (N 1) (N 1)) (Times (V ''x'') (N 1)))"

theorem aval_asimp[simp]:
  "aval (asimp a) s = aval a s"
apply(induction a)
apply simp_all
done

end


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

section \<open>Function Definitions and Termination Proofs\<close>

theory Fun_Def
  imports Basic_BNF_LFPs Partial_Function SAT
  keywords
    "function" "termination" :: thy_goal and
    "fun" "fun_cases" :: thy_decl
begin

subsection \<open>Definitions with default value\<close>

definition THE_default :: "'a \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a"
  where "THE_default d P = (if (\<exists>!x. P x) then (THE x. P x) else d)"

lemma THE_defaultI': "\<exists>!x. P x \<Longrightarrow> P (THE_default d P)"
  by (simp add: theI' THE_default_def)

lemma THE_default1_equality: "\<exists>!x. P x \<Longrightarrow> P a \<Longrightarrow> THE_default d P = a"
  by (simp add: the1_equality THE_default_def)

lemma THE_default_none: "\<not> (\<exists>!x. P x) \<Longrightarrow> THE_default d P = d"
  by (simp add: THE_default_def)

lemma fundef_ex1_existence:
  assumes f_def: "f \<equiv> (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
  assumes ex1: "\<exists>!y. G x y"
  shows "G x (f x)"
  apply (simp only: f_def)
  apply (rule THE_defaultI')
  apply (rule ex1)
  done

lemma fundef_ex1_uniqueness:
  assumes f_def: "f \<equiv> (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
  assumes ex1: "\<exists>!y. G x y"
  assumes elm: "G x (h x)"
  shows "h x = f x"
  apply (simp only: f_def)
  apply (rule THE_default1_equality [symmetric])
   apply (rule ex1)
  apply (rule elm)
  done

lemma fundef_ex1_iff:
  assumes f_def: "f \<equiv> (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
  assumes ex1: "\<exists>!y. G x y"
  shows "(G x y) = (f x = y)"
  apply (auto simp:ex1 f_def THE_default1_equality)
  apply (rule THE_defaultI')
  apply (rule ex1)
  done

lemma fundef_default_value:
  assumes f_def: "f \<equiv> (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
  assumes graph: "\<And>x y. G x y \<Longrightarrow> D x"
  assumes "\<not> D x"
  shows "f x = d x"
proof -
  have "\<not>(\<exists>y. G x y)"
  proof
    assume "\<exists>y. G x y"
    then have "D x" using graph ..
    with \<open>\<not> D x\<close> show False ..
  qed
  then have "\<not>(\<exists>!y. G x y)" by blast
  then show ?thesis
    unfolding f_def by (rule THE_default_none)
qed

definition in_rel_def[simp]: "in_rel R x y \<equiv> (x, y) \<in> R"

lemma wf_in_rel: "wf R \<Longrightarrow> wfP (in_rel R)"
  by (simp add: wfP_def)

ML_file "Tools/Function/function_core.ML"
ML_file "Tools/Function/mutual.ML"
ML_file "Tools/Function/pattern_split.ML"
ML_file "Tools/Function/relation.ML"
ML_file "Tools/Function/function_elims.ML"

method_setup relation = \<open>
  Args.term >> (fn t => fn ctxt => SIMPLE_METHOD' (Function_Relation.relation_infer_tac ctxt t))
\<close> "prove termination using a user-specified wellfounded relation"

ML_file "Tools/Function/function.ML"
ML_file "Tools/Function/pat_completeness.ML"

method_setup pat_completeness = \<open>
  Scan.succeed (SIMPLE_METHOD' o Pat_Completeness.pat_completeness_tac)
\<close> "prove completeness of (co)datatype patterns"

ML_file "Tools/Function/fun.ML"
ML_file "Tools/Function/induction_schema.ML"

method_setup induction_schema = \<open>
  Scan.succeed (Method.CONTEXT_TACTIC oo Induction_Schema.induction_schema_tac)
\<close> "prove an induction principle"

subsection \<open>Measure functions\<close>

inductive is_measure :: "('a \<Rightarrow> nat) \<Rightarrow> bool"
  where is_measure_trivial: "is_measure f"

named_theorems measure_function "rules that guide the heuristic generation of measure functions"
ML_file "Tools/Function/measure_functions.ML"

lemma measure_size[measure_function]: "is_measure size"
  by (rule is_measure_trivial)

lemma measure_fst[measure_function]: "is_measure f \<Longrightarrow> is_measure (\<lambda>p. f (fst p))"
  by (rule is_measure_trivial)

lemma measure_snd[measure_function]: "is_measure f \<Longrightarrow> is_measure (\<lambda>p. f (snd p))"
  by (rule is_measure_trivial)

ML_file "Tools/Function/lexicographic_order.ML"

method_setup lexicographic_order = \<open>
  Method.sections clasimp_modifiers >>
  (K (SIMPLE_METHOD o Lexicographic_Order.lexicographic_order_tac false))
\<close> "termination prover for lexicographic orderings"

subsection \<open>Congruence rules\<close>

lemma let_cong [fundef_cong]: "M = N \<Longrightarrow> (\<And>x. x = N \<Longrightarrow> f x = g x) \<Longrightarrow> Let M f = Let N g"
  unfolding Let_def by blast

lemmas [fundef_cong] =
  if_cong image_cong INF_cong SUP_cong
  bex_cong ball_cong imp_cong map_option_cong Option.bind_cong

lemma split_cong [fundef_cong]:
  "(\<And>x y. (x, y) = q \<Longrightarrow> f x y = g x y) \<Longrightarrow> p = q \<Longrightarrow> case_prod f p = case_prod g q"
  by (auto simp: split_def)

lemma comp_cong [fundef_cong]: "f (g x) = f' (g' x') \<Longrightarrow> (f \<circ> g) x = (f' \<circ> g') x'"
  by (simp only: o_apply)

subsection \<open>Simp rules for termination proofs\<close>

declare
  trans_less_add1[termination_simp]
  trans_less_add2[termination_simp]
  trans_le_add1[termination_simp]
  trans_le_add2[termination_simp]
  less_imp_le_nat[termination_simp]
  le_imp_less_Suc[termination_simp]

lemma size_prod_simp[termination_simp]: "size_prod f g p = f (fst p) + g (snd p) + Suc 0"
  by (induct p) auto

subsection \<open>Decomposition\<close>

lemma less_by_empty: "A = {} \<Longrightarrow> A \<subseteq> B"
  and union_comp_emptyL: "A O C = {} \<Longrightarrow> B O C = {} \<Longrightarrow> (A \<union> B) O C = {}"
  and union_comp_emptyR: "A O B = {} \<Longrightarrow> A O C = {} \<Longrightarrow> A O (B \<union> C) = {}"
  and wf_no_loop: "R O R = {} \<Longrightarrow> wf R"
  by (auto simp add: wf_comp_self [of R])

subsection \<open>Reduction pairs\<close>

definition "reduction_pair P \<longleftrightarrow> wf (fst P) \<and> fst P O snd P \<subseteq> fst P"

lemma reduction_pairI[intro]: "wf R \<Longrightarrow> R O S \<subseteq> R \<Longrightarrow> reduction_pair (R, S)"
  by (auto simp: reduction_pair_def)

lemma reduction_pair_lemma:
  assumes rp: "reduction_pair P"
  assumes "R \<subseteq> fst P"
  assumes "S \<subseteq> snd P"
  assumes "wf S"
  shows "wf (R \<union> S)"
proof -
  from rp \<open>S \<subseteq> snd P\<close> have "wf (fst P)" "fst P O S \<subseteq> fst P"
    unfolding reduction_pair_def by auto
  with \<open>wf S\<close> have "wf (fst P \<union> S)"
    by (auto intro: wf_union_compatible)
  moreover from \<open>R \<subseteq> fst P\<close> have "R \<union> S \<subseteq> fst P \<union> S" by auto
  ultimately show ?thesis by (rule wf_subset)
qed

definition "rp_inv_image = (\<lambda>(R,S) f. (inv_image R f, inv_image S f))"

lemma rp_inv_image_rp: "reduction_pair P \<Longrightarrow> reduction_pair (rp_inv_image P f)"
  unfolding reduction_pair_def rp_inv_image_def split_def by force

subsection \<open>Concrete orders for SCNP termination proofs\<close>

definition "pair_less = less_than <*lex*> less_than"
definition "pair_leq = pair_less^="
definition "max_strict = max_ext pair_less"
definition "max_weak = max_ext pair_leq \<union> {({}, {})}"
definition "min_strict = min_ext pair_less"
definition "min_weak = min_ext pair_leq \<union> {({}, {})}"

lemma wf_pair_less[simp]: "wf pair_less"
  by (auto simp: pair_less_def)

text \<open>Introduction rules for \<open>pair_less\<close>/\<open>pair_leq\<close>\<close>
lemma pair_leqI1: "a < b \<Longrightarrow> ((a, s), (b, t)) \<in> pair_leq"
  and pair_leqI2: "a \<le> b \<Longrightarrow> s \<le> t \<Longrightarrow> ((a, s), (b, t)) \<in> pair_leq"
  and pair_lessI1: "a < b  \<Longrightarrow> ((a, s), (b, t)) \<in> pair_less"
  and pair_lessI2: "a \<le> b \<Longrightarrow> s < t \<Longrightarrow> ((a, s), (b, t)) \<in> pair_less"
  by (auto simp: pair_leq_def pair_less_def)

text \<open>Introduction rules for max\<close>
lemma smax_emptyI: "finite Y \<Longrightarrow> Y \<noteq> {} \<Longrightarrow> ({}, Y) \<in> max_strict"
  and smax_insertI:
    "y \<in> Y \<Longrightarrow> (x, y) \<in> pair_less \<Longrightarrow> (X, Y) \<in> max_strict \<Longrightarrow> (insert x X, Y) \<in> max_strict"
  and wmax_emptyI: "finite X \<Longrightarrow> ({}, X) \<in> max_weak"
  and wmax_insertI:
    "y \<in> YS \<Longrightarrow> (x, y) \<in> pair_leq \<Longrightarrow> (XS, YS) \<in> max_weak \<Longrightarrow> (insert x XS, YS) \<in> max_weak"
  by (auto simp: max_strict_def max_weak_def elim!: max_ext.cases)

text \<open>Introduction rules for min\<close>
lemma smin_emptyI: "X \<noteq> {} \<Longrightarrow> (X, {}) \<in> min_strict"
  and smin_insertI:
    "x \<in> XS \<Longrightarrow> (x, y) \<in> pair_less \<Longrightarrow> (XS, YS) \<in> min_strict \<Longrightarrow> (XS, insert y YS) \<in> min_strict"
  and wmin_emptyI: "(X, {}) \<in> min_weak"
  and wmin_insertI:
    "x \<in> XS \<Longrightarrow> (x, y) \<in> pair_leq \<Longrightarrow> (XS, YS) \<in> min_weak \<Longrightarrow> (XS, insert y YS) \<in> min_weak"
  by (auto simp: min_strict_def min_weak_def min_ext_def)

text \<open>Reduction Pairs.\<close>

lemma max_ext_compat:
  assumes "R O S \<subseteq> R"
  shows "max_ext R O (max_ext S \<union> {({}, {})}) \<subseteq> max_ext R"
  using assms
  apply auto
  apply (elim max_ext.cases)
  apply rule
     apply auto[3]
  apply (drule_tac x=xa in meta_spec)
  apply simp
  apply (erule bexE)
  apply (drule_tac x=xb in meta_spec)
  apply auto
  done

lemma max_rpair_set: "reduction_pair (max_strict, max_weak)"
  unfolding max_strict_def max_weak_def
  apply (intro reduction_pairI max_ext_wf)
   apply simp
  apply (rule max_ext_compat)
  apply (auto simp: pair_less_def pair_leq_def)
  done

lemma min_ext_compat:
  assumes "R O S \<subseteq> R"
  shows "min_ext R O  (min_ext S \<union> {({},{})}) \<subseteq> min_ext R"
  using assms
  apply (auto simp: min_ext_def)
  apply (drule_tac x=ya in bspec, assumption)
  apply (erule bexE)
  apply (drule_tac x=xc in bspec)
   apply assumption
  apply auto
  done

lemma min_rpair_set: "reduction_pair (min_strict, min_weak)"
  unfolding min_strict_def min_weak_def
  apply (intro reduction_pairI min_ext_wf)
   apply simp
  apply (rule min_ext_compat)
  apply (auto simp: pair_less_def pair_leq_def)
  done

subsection \<open>Tool setup\<close>

ML_file "Tools/Function/termination.ML"
ML_file "Tools/Function/scnp_solve.ML"
ML_file "Tools/Function/scnp_reconstruct.ML"
ML_file "Tools/Function/fun_cases.ML"

ML_val \<comment> "setup inactive"
\<open>
  Context.theory_map (Function_Common.set_termination_prover
    (K (ScnpReconstruct.decomp_scnp_tac [ScnpSolve.MAX, ScnpSolve.MIN, ScnpSolve.MS])))
\<close>

end


theory 3
  imports Main
begin

  (* exercise 2.3 *)

  (* this exercise can't appear in the same file as 2.2, because the nat type used in count would
  then be different than the nat type used by the library-defined length *)

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
  "count v Nil = 0"
| "count v (Cons x xs) = (if v=x then Suc (count v xs) else count v xs)"

value "count (1::int) [1, 2, 1]"
value "count (2::int) [1, 2, 1]"

lemma count_leq_length: "count v xs \<le> length xs"
  apply(induction xs)
   apply(auto)
  done

    (* exercise 2.4 *)
fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "snoc [] x = [x]"
| "snoc (x # xs) e = Cons x (snoc xs e)"

value "snoc [1,2,4] 10 :: int list"

fun reverse :: "'a list \<Rightarrow> 'a list" where
  "reverse [] = []"
| "reverse (x # xs) = snoc (reverse xs) x"

value "[1,2,3] @ [4,5] :: int list"

lemma reverse_snoc_is_cons_reverse[simp]: "reverse (snoc xs a) = a # (reverse xs)"
  apply(induction xs)
   apply(auto)
  done

    (* This needs lemma: reverse (snoc (reverse xs) a) = a # xs *)
lemma reverse_reverse_is_id[simp]: "reverse (reverse xs) = xs"
  apply(induction xs)
   apply(auto)
  done

    (* exercise 2.5 *)
fun sum_upto::"nat \<Rightarrow> nat" where
  "sum_upto 0 = 0"
| "sum_upto (Suc n) = (Suc n) + sum_upto n"

value "6 div 2 :: int"
value "5 div 2 :: int"
value "1 div 2 :: int"

lemma summation_formula_01[simp]: "sum_upto n = (n * (n+1)) div 2"
  apply(induction n)
   apply(auto)
  done

end


theory ex01
  imports Main
begin

term "op+"

lemma "a + b = b + (a :: nat)"
  by auto

lemma "a + (b + c) = (a + b) + (c::nat)"
  by auto

term "Nil"
term "Cons a b"

fun count :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
  "count [] _ = 0"
| "count (x#xs) y = (if x=y then count xs y + 1 else count xs y)"

fun count' :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
  "count' [] _ = 0"
| "count' (x # xs) y = (if x = y then 1 else 0) + count' xs y"

value "count [1,2,3,4,2,2,2::int] 2"

find_theorems "length [] = _"
find_theorems "length (_ # _) =  _"

lemma "count xs a \<le> length xs"
  apply(induction xs)
   apply(simp)
  apply(simp)
  done

fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "snoc [] y = [y]"
| "snoc (x # xs) y = x # snoc xs y"

lemma "snoc xs x = xs@[x]"
  apply(induction xs) by auto

fun reverse :: "'a list \<Rightarrow> 'a list" where
  "reverse [] = []"
| "reverse (x # xs) = snoc (reverse xs) x"

lemma aux: "reverse (snoc xs x) = x # reverse xs"
  apply(induction xs) by auto

lemma rev_rev[simp]: "reverse (reverse xs) = xs"
  apply (induction xs)
   apply (auto simp:aux)
  done

lemma "reverse (reverse xs) = xs"
  apply(induction xs)
   apply(auto simp:)
  apply(subst aux)
  apply auto
  done

end