(*
  File:    Buffons_Needle.thy
  Author:  Manuel Eberl <manuel@pruvisto.org>

  A formal solution of Buffon's needle problem.
*)
section \<open>Buffon's Needle Problem\<close>
theory Buffons_Needle
  imports "HOL-Probability.Probability"
begin

subsection \<open>Auxiliary material\<close>

lemma sin_le_zero': "sin x \<le> 0" if "x \<ge> -pi" "x \<le> 0" for x
  by (metis minus_le_iff neg_0_le_iff_le sin_ge_zero sin_minus that(1) that(2))

subsection \<open>Problem definition\<close>

text \<open>
  Consider a needle of length $l$ whose centre has the $x$-coordinate $x$. The following then
  defines the set of all $x$-coordinates that the needle covers
  (i.e. the projection of the needle onto the $x$-axis.)
\<close>
definition needle :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real set" where
  "needle l x \<phi> = closed_segment (x - l / 2 * sin \<phi>) (x + l / 2 * sin \<phi>)"

text_raw \<open>
\begin{figure}
\begin{center}
\begin{tikzpicture}
\coordinate (lefttick) at (-3,0);
\coordinate (righttick) at (3,0);

\draw (lefttick) -- (righttick);
\draw [thick] (lefttick) ++ (0,0.4) -- ++(0,3);
\draw [thick] (righttick) ++ (0,0.4) -- ++(0,3);

\coordinate (needle) at (1,2);

\newcommand{\needleangle}{55}
\newcommand{\needlelength}{{1}}
\newcommand{\needlethickness}{0.6pt}

\draw ($(lefttick)+(0,4pt)$) -- ($(lefttick)-(0,4pt)$);
\draw ($(righttick)+(0,4pt)$) -- ($(righttick)-(0,4pt)$);
\draw (0,4pt) -- (0,-4pt);

\draw [densely dashed, thin] let \p1 = (needle) in (\x1, 0) -- (needle);
\draw [densely dashed, thin] let \p1 = (needle) in (needle) -- (3, \y1);
\draw (needle) ++ (15pt,0) arc(0:\needleangle:15pt);
\path (needle) -- ++(15pt,0) node [above, midway, yshift=-1.9pt, xshift=1.8pt] {$\scriptstyle\varphi$};

\node [below, xshift=-3.5pt] at ($(lefttick)-(0,4pt)$) {$-\nicefrac{d}{2}$};
\node [below] at ($(righttick)-(0,4pt)$) {$\nicefrac{d}{2}$};
\node [below,yshift=-1pt] at (0,-4pt) {$0$};
\node [below,yshift=-2pt] at (needle |- 0,-4pt) {$x$};

\draw[<->] (needle) ++({\needleangle+90}:5pt) ++(\needleangle:{-\needlelength}) -- ++(\needleangle:2) node [midway, above, rotate=\needleangle] {$\scriptstyle l$};

\draw [line width=0.7pt,fill=white] (needle) ++({\needleangle+90}:\needlethickness) -- ++(\needleangle:\needlelength) arc({\needleangle+90}:{\needleangle-90}:\needlethickness)
  -- ++(\needleangle:-\needlelength) -- ++(\needleangle:-\needlelength) arc({\needleangle+270}:{\needleangle+90}:\needlethickness) -- ++(\needleangle:\needlelength);

\end{tikzpicture}
\end{center}
\caption{A sketch of the situation in Buffon's needle experiment. There is a needle of length $l$
with its centre at a certain $x$ coordinate, angled at an angle $\varphi$ off the horizontal axis.
The two vertical lines are a distance of $d$ apart, each being $\nicefrac{d}{2}$ away from the
origin.}
\label{fig:buffon}
\end{figure}

\definecolor{myred}{HTML}{cc2428}
\begin{figure}[h]
\begin{center}
\begin{tikzpicture}
  \begin{axis}[
          xmin=0, xmax=7, ymin=0, ymax=1,
          width=\textwidth, height=0.6\textwidth,
          xlabel={$l/d$}, ylabel={$\mathcal P$}, tick style={thin,black},
          ylabel style = {rotate=270,anchor=west},
  ]
  \addplot [color=myred, line width=1pt, mark=none,domain=0:1,samples=200] ({x}, {2/pi*x});
  \addplot [color=myred, line width=1pt, mark=none,domain=1:7,samples=200] ({x}, {2/pi*(x-sqrt(x*x-1)+acos(1/x)/180*pi)});
  \end{axis}
\end{tikzpicture}
\caption{The probability $\mathcal P$ of the needle hitting one of the lines, as a function of the quotient $l/d$ (where $l$ is the length of the needle and $d$ the horizontal distance between the lines).}
\label{fig:buffonplot}
\end{center}
\end{figure}
\<close>

text \<open>
  Buffon's Needle problem is then this: Assuming the needle's $x$ position is chosen uniformly
  at random in a strip of width $d$ centred at the origin, what is the probability that the
  needle crosses at least one of the left/right boundaries of that strip (located at
  $x = \pm\frac{1}{2}d$)?

  We will show that, if we let $x := \nicefrac{l}{d}$, the probability of this is
  \[
  \mathcal P_{l,d} =
    \begin{cases}
      \nicefrac{2}{\pi} \cdot x & \text{if}\ l \leq d\\
      \nicefrac{2}{\pi}\cdot(x - \sqrt{x^2 - 1} + \arccos (\nicefrac{1}{x})) & \text{if}\ l \geq d
    \end{cases}
  \]
  A plot of this function can be found in Figure~\ref{fig:buffonplot}.
\<close>

locale Buffon =
  fixes d l :: real
  assumes d: "d > 0" and l: "l > 0"
begin

definition Buffon :: "(real \<times> real) measure" where
  "Buffon = uniform_measure lborel ({-d/2..d/2} \<times> {-pi..pi})"

lemma space_Buffon [simp]: "space Buffon = UNIV"
  by (simp add: Buffon_def)

definition Buffon_set :: "(real \<times> real) set" where
  "Buffon_set = {(x,\<phi>) \<in> {-d/2..d/2} \<times> {-pi..pi}. needle l x \<phi> \<inter> {-d/2, d/2} \<noteq> {}}"

subsection \<open>Derivation of the solution\<close>

text \<open>
  The following form is a bit easier to handle.
\<close>
lemma Buffon_set_altdef1:
  "Buffon_set =
     {(x,\<phi>) \<in> {-d/2..d/2} \<times> {-pi..pi}.
         let a = x - l / 2 * sin \<phi>; b = x + l / 2 * sin \<phi>
         in  min a b + d/2 \<le> 0 \<and> max a b + d/2 \<ge> 0 \<or> min a b - d/2 \<le> 0 \<and> max a b - d/2 \<ge> 0}"
proof -
  have "(\<lambda>(x,\<phi>). needle l x \<phi> \<inter> {-d/2, d/2} \<noteq> {}) =
      (\<lambda>(x,\<phi>). let a = x - l / 2 * sin \<phi>; b = x + l / 2 * sin \<phi>
               in  -d/2 \<ge> min a b \<and> -d/2 \<le> max a b \<or> min a b \<le> d/2 \<and> max a b \<ge> d/2)"
    by (auto simp: needle_def Let_def closed_segment_eq_real_ivl min_def max_def)
  also have "\<dots> =
    (\<lambda>(x,\<phi>). let a = x - l / 2 * sin \<phi>; b = x + l / 2 * sin \<phi>
             in  min a b + d/2 \<le> 0 \<and> max a b + d/2 \<ge> 0 \<or> min a b - d/2 \<le> 0 \<and> max a b - d/2 \<ge> 0)"
    by (auto simp add: algebra_simps Let_def)
  finally show ?thesis unfolding Buffon_set_def case_prod_unfold
    by (intro Collect_cong conj_cong refl) meson
qed

lemma Buffon_set_altdef2:
  "Buffon_set = {(x,\<phi>) \<in> {-d/2..d/2} \<times> {-pi..pi}. abs x \<ge> d / 2 - abs (sin \<phi>) * l / 2}"
  unfolding Buffon_set_altdef1
proof (intro Collect_cong prod.case_cong refl conj_cong)
  fix x \<phi>
  assume *: "(x, \<phi>) \<in> {-d/2..d/2} \<times> {-pi..pi}"
  let ?P = "\<lambda>x \<phi>. let a = x - l / 2 * sin \<phi>; b = x + l / 2 * sin \<phi>
               in  min a b + d/2 \<le> 0 \<and> max a b + d/2 \<ge> 0 \<or> min a b - d/2 \<le> 0 \<and> max a b - d/2 \<ge> 0"

  show "?P x \<phi> \<longleftrightarrow> (d / 2 - \<bar>sin \<phi>\<bar> * l / 2 \<le> \<bar>x\<bar>)"
  proof (cases "\<phi> \<ge> 0")
    case True
    have "x - l / 2 * sin \<phi> \<le> x + l / 2 * sin \<phi>" using l True *
      by (auto simp: sin_ge_zero)
    moreover from True and * have "sin \<phi> \<ge> 0" by (auto simp: sin_ge_zero)
    ultimately show ?thesis using * True
      by (force simp: field_simps Let_def min_def max_def case_prod_unfold abs_if)
  next
    case False
    with * have "x - l / 2 * sin \<phi> \<ge> x + l / 2 * sin \<phi>" using l
      by (auto simp: sin_le_zero' mult_nonneg_nonpos)
    moreover from False and * have "sin \<phi> \<le> 0" by (auto simp: sin_le_zero')
    ultimately show ?thesis using * False l d
      by (force simp: field_simps Let_def min_def max_def case_prod_unfold abs_if)
  qed
qed

text \<open>
  By using the symmetry inherent in the problem, we can reduce the problem to the following
  set, which corresponds to one quadrant of the original set:
\<close>
definition Buffon_set' :: "(real \<times> real) set" where
  "Buffon_set' = {(x,\<phi>) \<in> {0..d/2} \<times> {0..pi}. x \<ge> d / 2 - sin \<phi> * l / 2}"

lemma closed_buffon_set [simp, intro, measurable]: "closed Buffon_set"
  proof -
  have "Buffon_set = ({-d/2..d/2} \<times> {-pi..pi}) \<inter>
          (\<lambda>z. abs (fst z) + abs (sin (snd z)) * l / 2 - d / 2) -` {0..}"
    (is "_ = ?A") unfolding Buffon_set_altdef2 by auto
  also have "closed \<dots>"
    by (intro closed_Int closed_vimage closed_Times) (auto intro!: continuous_intros)
  finally show ?thesis by simp
qed

lemma closed_buffon_set' [simp, intro, measurable]: "closed Buffon_set'"
proof -
  have "Buffon_set' = ({0..d/2} \<times> {0..pi}) \<inter>
          (\<lambda>z. fst z + sin (snd z) * l / 2 - d / 2) -` {0..}"
    (is "_ = ?A") unfolding Buffon_set'_def by auto
  also have "closed \<dots>"
    by (intro closed_Int closed_vimage closed_Times) (auto intro!: continuous_intros)
  finally show ?thesis by simp
qed

lemma measurable_buffon_set [measurable]: "Buffon_set \<in> sets borel"
  by measurable

lemma measurable_buffon_set' [measurable]: "Buffon_set' \<in> sets borel"
  by measurable

sublocale prob_space Buffon
  unfolding Buffon_def
proof -
  have "emeasure lborel ({- d / 2..d / 2} \<times> {- pi..pi}) = ennreal (2 * d * pi)"
    unfolding lborel_prod [symmetric] using d
    by (subst lborel.emeasure_pair_measure_Times)
       (auto simp: ennreal_mult mult_ac simp flip: ennreal_numeral)
  also have "\<dots> \<noteq> 0 \<and> \<dots> \<noteq> \<infinity>"
    using d by auto
  finally show "prob_space (uniform_measure lborel ({- d / 2..d / 2} \<times> {- pi..pi}))"
    by (intro prob_space_uniform_measure) auto
qed

lemma buffon_prob_aux:
  "emeasure Buffon {(x,\<phi>). needle l x \<phi> \<inter> {-d/2, d/2} \<noteq> {}} =
     emeasure lborel Buffon_set / ennreal (2 * d * pi)"
proof -
  have [measurable]: "A \<times> B \<in> sets borel" if "A \<in> sets borel" "B \<in> sets borel"
    for A B :: "real set" using that unfolding borel_prod [symmetric] by simp
  have "{(x, \<phi>). needle l x \<phi> \<inter> {- d / 2, d / 2} \<noteq> {}} \<in> sets borel"
    by (intro pred_Collect_borel)
       (simp add: borel_prod [symmetric] needle_def closed_segment_eq_real_ivl case_prod_unfold)
  hence "emeasure Buffon {(x,\<phi>). needle l x \<phi> \<inter> {-d/2, d/2} \<noteq> {}} =
           emeasure lborel (({-d/2..d/2} \<times> {- pi..pi}) \<inter> {(x,\<phi>). needle l x \<phi> \<inter> {-d/2, d/2} \<noteq> {}}) /
           emeasure lborel ({-(d/2)..d/2} \<times> {-pi..pi})"
    unfolding Buffon_def Buffon_set_def by (subst emeasure_uniform_measure) simp_all
  also have "({-d/2..d/2} \<times> {- pi..pi}) \<inter> {(x, \<phi>). needle l x \<phi> \<inter> {-d/2, d/2} \<noteq> {}} = Buffon_set"
    unfolding Buffon_set_def by auto
  also have "emeasure lborel ({-(d/2)..d/2} \<times> {-pi..pi}) = ennreal (2 * d * pi)"
    using d by (simp flip: lborel_prod ennreal_mult add: lborel.emeasure_pair_measure_Times)
  finally show ?thesis .
qed

lemma emeasure_buffon_set_conv_buffon_set':
  "emeasure lborel Buffon_set = 4 * emeasure lborel Buffon_set'"
proof -
  have distr_lborel [simp]: "distr M lborel f = distr M borel f" for M and f :: "real \<Rightarrow> real"
    by (rule distr_cong) simp_all

  define A where "A = Buffon_set'"
  define B C D where "B = (\<lambda>x. (-fst x, snd x)) -` A" and "C = (\<lambda>x. (fst x, -snd x)) -` A" and
      "D = (\<lambda>x. (-fst x, -snd x)) -` A"
  have meas [measurable]:
     "(\<lambda>x::real \<times> real. (-fst x, snd x)) \<in> borel_measurable borel"
     "(\<lambda>x::real \<times> real. (fst x, -snd x)) \<in> borel_measurable borel"
     "(\<lambda>x::real \<times> real. (-fst x, -snd x)) \<in> borel_measurable borel"
    unfolding borel_prod [symmetric] by measurable
  have meas' [measurable]: "A \<in> sets borel" "B \<in> sets borel" "C \<in> sets borel" "D \<in> sets borel"
    unfolding A_def B_def C_def D_def by (rule measurable_buffon_set' measurable_sets_borel meas)+

  have *: "Buffon_set = A \<union> B \<union> C \<union> D"
  proof (intro equalityI subsetI, goal_cases)
    case (1 z)
    show ?case
    proof (cases "fst z \<ge> 0"; cases "snd z \<ge> 0")
      assume "fst z \<ge> 0" "snd z \<ge> 0"
      with 1 have "z \<in> A"
        by (auto split: prod.splits simp: Buffon_set_altdef2 Buffon_set'_def sin_ge_zero A_def B_def)
      thus ?thesis by blast
    next
      assume "\<not>(fst z \<ge> 0)" "snd z \<ge> 0"
      with 1 have "z \<in> B"
        by (auto split: prod.splits simp: Buffon_set_altdef2 Buffon_set'_def sin_ge_zero A_def B_def)
      thus ?thesis by blast
    next
      assume "fst z \<ge> 0" "\<not>(snd z \<ge> 0)"
      with 1 have "z \<in> C"
        by (auto split: prod.splits simp: Buffon_set_altdef2 Buffon_set'_def sin_le_zero' A_def B_def C_def)
      thus ?thesis by blast
    next
      assume "\<not>(fst z \<ge> 0)" "\<not>(snd z \<ge> 0)"
      with 1 have "z \<in> D"
        by (auto split: prod.splits simp: Buffon_set_altdef2 Buffon_set'_def sin_le_zero' A_def B_def D_def)
      thus ?thesis by blast
    qed
  next
    case (2 z)
    thus ?case using d l
      by (auto simp: Buffon_set_altdef2 Buffon_set'_def sin_ge_zero sin_le_zero'  A_def B_def C_def D_def)
  qed

  have "A \<inter> B = {0} \<times> ({0..pi} \<inter> {\<phi>. sin \<phi> * l - d \<ge> 0})"
    using d l by (auto simp: Buffon_set'_def  A_def B_def C_def D_def)
  moreover have "emeasure lborel \<dots> = 0"
    unfolding lborel_prod [symmetric] by (subst lborel.emeasure_pair_measure_Times) simp_all
  ultimately have AB: "(A \<inter> B) \<in> null_sets lborel"
    unfolding lborel_prod [symmetric] by (simp add: null_sets_def)

  have "C \<inter> D = {0} \<times> ({-pi..0} \<inter> {\<phi>. -sin \<phi> * l - d \<ge> 0})"
    using d l by (auto simp: Buffon_set'_def  A_def B_def C_def D_def)
  moreover have "emeasure lborel \<dots> = 0"
    unfolding lborel_prod [symmetric] by (subst lborel.emeasure_pair_measure_Times) simp_all
  ultimately have CD: "(C \<inter> D) \<in> null_sets lborel"
    unfolding lborel_prod [symmetric] by (simp add: null_sets_def)

  have "A \<inter> D = {}" "B \<inter> C = {}" using d l
    by (auto simp: Buffon_set'_def A_def D_def B_def C_def)
  moreover have "A \<inter> C = {(d/2, 0)}" "B \<inter> D = {(-d/2, 0)}"
    using d l by (auto simp: case_prod_unfold Buffon_set'_def A_def B_def C_def D_def)
  ultimately have AD: "A \<inter> D \<in> null_sets lborel" and BC: "B \<inter> C \<in> null_sets lborel" and
    AC: "A \<inter> C \<in> null_sets lborel" and BD: "B \<inter> D \<in> null_sets lborel" by auto

  note *
  also have "emeasure lborel (A \<union> B \<union> C \<union> D) = emeasure lborel (A \<union> B \<union> C) + emeasure lborel D"
    using AB AC AD BC BD CD by (intro emeasure_Un') (auto simp: Int_Un_distrib2)
  also have "emeasure lborel (A \<union> B \<union> C) = emeasure lborel (A \<union> B) + emeasure lborel C"
    using AB AC BC using AB AC AD BC BD CD by (intro emeasure_Un') (auto simp: Int_Un_distrib2)
  also have "emeasure lborel (A \<union> B) = emeasure lborel A + emeasure lborel B"
    using AB using AB AC AD BC BD CD by (intro emeasure_Un') (auto simp: Int_Un_distrib2)
  also have "emeasure lborel B = emeasure (distr lborel lborel (\<lambda>(x,y). (-x, y))) A"
    (is "_ = emeasure ?M _") unfolding B_def
    by (subst emeasure_distr) (simp_all add: case_prod_unfold)
  also have "?M = lborel" unfolding lborel_prod [symmetric]
    by (subst pair_measure_distr [symmetric]) (simp_all add: sigma_finite_lborel lborel_distr_uminus)
  also have "emeasure lborel C = emeasure (distr lborel lborel (\<lambda>(x,y). (x, -y))) A"
    (is "_ = emeasure ?M _") unfolding C_def
    by (subst emeasure_distr) (simp_all add: case_prod_unfold)
  also have "?M = lborel" unfolding lborel_prod [symmetric]
    by (subst pair_measure_distr [symmetric]) (simp_all add: sigma_finite_lborel lborel_distr_uminus)
  also have "emeasure lborel D = emeasure (distr lborel lborel (\<lambda>(x,y). (-x, -y))) A"
    (is "_ = emeasure ?M _") unfolding D_def
    by (subst emeasure_distr) (simp_all add: case_prod_unfold)
  also have "?M = lborel" unfolding lborel_prod [symmetric]
    by (subst pair_measure_distr [symmetric]) (simp_all add: sigma_finite_lborel lborel_distr_uminus)
  finally have "emeasure lborel Buffon_set =
                  of_nat (Suc (Suc (Suc (Suc 0)))) * emeasure lborel A"
    unfolding of_nat_Suc ring_distribs by simp
  also have "of_nat (Suc (Suc (Suc (Suc 0)))) = (4 :: ennreal)" by simp
  finally show ?thesis unfolding A_def .
qed

text \<open>
  It only remains now to compute the measure of @{const Buffon_set'}. We first reduce this
  problem to a relatively simple integral:
\<close>
lemma emeasure_buffon_set':
  "emeasure lborel Buffon_set' =
     ennreal (integral {0..pi} (\<lambda>x. min (d / 2) (sin x * l / 2)))"
  (is "emeasure lborel ?A = _")
proof -
  have "emeasure lborel ?A = nn_integral lborel (\<lambda>x. indicator ?A x)"
    by (intro nn_integral_indicator [symmetric]) simp_all
  also have "(lborel :: (real \<times> real) measure) = lborel \<Otimes>\<^sub>M lborel"
    by (simp only: lborel_prod)
  also have "nn_integral \<dots> (indicator ?A) = (\<integral>\<^sup>+\<phi>. \<integral>\<^sup>+x. indicator ?A (x, \<phi>) \<partial>lborel \<partial>lborel)"
    by (subst lborel_pair.nn_integral_snd [symmetric]) (simp_all add: lborel_prod borel_prod)
  also have "\<dots> = (\<integral>\<^sup>+\<phi>. \<integral>\<^sup>+x. indicator {0..pi} \<phi> * indicator {max 0 (d/2 - sin \<phi> * l / 2) .. d/2} x \<partial>lborel \<partial>lborel)"
    using d l by (intro nn_integral_cong) (auto simp: indicator_def field_simps Buffon_set'_def)
  also have "\<dots> = \<integral>\<^sup>+ \<phi>. indicator {0..pi} \<phi> * emeasure lborel {max 0 (d / 2 - sin \<phi> * l / 2)..d / 2} \<partial>lborel"
    by (subst nn_integral_cmult) simp_all
  also have "\<dots> = \<integral>\<^sup>+ \<phi>. ennreal (indicator {0..pi} \<phi> * min (d / 2) (sin \<phi> * l / 2)) \<partial>lborel"
    (is "_ = ?I") using d l by (intro nn_integral_cong) (auto simp: indicator_def sin_ge_zero max_def min_def)
  also have "integrable lborel (\<lambda>\<phi>. (d / 2) * indicator {0..pi} \<phi>)" by simp
  hence int: "integrable lborel (\<lambda>\<phi>. indicator {0..pi} \<phi> * min (d / 2) (sin \<phi> * l / 2))"
    by (rule Bochner_Integration.integrable_bound)
       (insert l d, auto intro!: AE_I2 simp: indicator_def min_def sin_ge_zero)
  hence "?I = set_lebesgue_integral lborel {0..pi} (\<lambda>\<phi>. min (d / 2) (sin \<phi> * l / 2))"
    by (subst nn_integral_eq_integral, assumption)
       (insert d l, auto intro!: AE_I2 simp: sin_ge_zero min_def indicator_def set_lebesgue_integral_def)
  also have "\<dots> = ennreal (integral {0..pi} (\<lambda>x. min (d / 2) (sin x * l / 2)))"
    (is "_ = ennreal ?I") using int by (subst set_borel_integral_eq_integral) (simp_all add: set_integrable_def)
  finally show ?thesis by (simp add: lborel_prod)
qed

text \<open>
  We now have to distinguish two cases: The first and easier one is that where the length
  of the needle, $l$, is less than or equal to the strip width, $d$:
\<close>
context
  assumes l_le_d: "l \<le> d"
begin

lemma emeasure_buffon_set'_short: "emeasure lborel Buffon_set' = ennreal l"
proof -
  have "emeasure lborel Buffon_set' =
          ennreal (integral {0..pi} (\<lambda>x. min (d / 2) (sin x * l / 2)))" (is "_ = ennreal ?I")
    by (rule emeasure_buffon_set')
  also have *: "sin \<phi> * l \<le> d" if "\<phi> \<ge> 0" "\<phi> \<le> pi" for \<phi>
    using mult_mono[OF l_le_d sin_le_one _ sin_ge_zero] that d by (simp add: algebra_simps)
  have "?I = integral {0..pi} (\<lambda>x. (l / 2) * sin x)"
    using l d l_le_d
    by (intro integral_cong) (auto dest: * simp: min_def sin_ge_zero)
  also have "\<dots> = l / 2 * integral {0..pi} sin" by simp
  also have "(sin has_integral (-cos pi - (- cos 0))) {0..pi}"
    by (intro fundamental_theorem_of_calculus)
       (auto intro!: derivative_eq_intros simp: has_real_derivative_iff_has_vector_derivative [symmetric])
  hence "integral {0..pi} sin = -cos pi - (-cos 0)"
    by (simp add: has_integral_iff)
  finally show ?thesis by (simp add: lborel_prod)
qed

lemma emeasure_buffon_set_short: "emeasure lborel Buffon_set = 4 * ennreal l"
  by (simp add: emeasure_buffon_set_conv_buffon_set' emeasure_buffon_set'_short l_le_d)

lemma prob_short_aux:
  "Buffon {(x, \<phi>). needle l x \<phi> \<inter> {- d / 2, d / 2} \<noteq> {}} = ennreal (2 * l / (d * pi))"
  unfolding buffon_prob_aux emeasure_buffon_set_short using d l
  by (simp flip: ennreal_mult ennreal_numeral add: divide_ennreal)

lemma prob_short: "\<P>((x,\<phi>) in Buffon. needle l x \<phi> \<inter> {-d/2, d/2} \<noteq> {}) = 2 * l / (d * pi)"
  using prob_short_aux unfolding emeasure_eq_measure
  using l d by (subst (asm) ennreal_inj) auto

end

text \<open>
  The other case where the needle is at least as long as the strip width is more complicated:
\<close>
context
  assumes l_ge_d: "l \<ge> d"
begin

lemma emeasure_buffon_set'_long:
  shows "l * (1 - sqrt (1 - (d / l)\<^sup>2)) + arccos (d / l) * d \<ge> 0"
  and   "emeasure lborel Buffon_set' =
           ennreal (l * (1 - sqrt (1 - (d / l)\<^sup>2)) + arccos (d / l) * d)"
proof -
  define \<phi>' where "\<phi>' = arcsin (d / l)"
  have \<phi>'_nonneg: "\<phi>' \<ge> 0" unfolding \<phi>'_def using d l l_ge_d arcsin_le_mono[of 0 "d/l"]
    by (simp add: \<phi>'_def)
  have \<phi>'_le: "\<phi>' \<le> pi / 2" unfolding \<phi>'_def using arcsin_bounded[of "d/l"] d l l_ge_d
    by (simp add: field_simps)
  have ge_phi': "sin \<phi> \<ge> d / l" if "\<phi> \<ge> \<phi>'" "\<phi> \<le> pi / 2" for \<phi>
    using arcsin_le_iff[of "d / l" "\<phi>"] d l_ge_d that \<phi>'_nonneg by (auto simp: \<phi>'_def field_simps)
  have le_phi': "sin \<phi> \<le> d / l" if "\<phi> \<le> \<phi>'" "\<phi> \<ge> 0" for \<phi>
    using le_arcsin_iff[of "d / l" "\<phi>"] d l_ge_d that \<phi>'_le by (auto simp: \<phi>'_def field_simps)
  have "cos \<phi>' = sqrt (1 - (d / l)^2)"
    unfolding \<phi>'_def by (rule cos_arcsin) (insert d l l_ge_d, auto simp: field_simps)

  have "l * (1 - cos \<phi>') + arccos (d / l) * d \<ge> 0"
    using l d l_ge_d
    by (intro add_nonneg_nonneg mult_nonneg_nonneg arccos_lbound) (auto simp: field_simps)
  thus "l * (1 - sqrt (1 - (d / l)\<^sup>2)) + arccos (d / l) * d \<ge> 0"
    by (simp add: \<open>cos \<phi>' = sqrt (1 - (d / l)^2)\<close>)

  let ?f = "(\<lambda>x. min (d / 2) (sin x * l / 2))"
  have "emeasure lborel Buffon_set' = ennreal (integral {0..pi} ?f)" (is "_ = ennreal ?I")
    by (rule emeasure_buffon_set')
  also have "?I = integral {0..pi/2} ?f + integral {pi/2..pi} ?f"
    by (rule Henstock_Kurzweil_Integration.integral_combine [symmetric]) (auto intro!: integrable_continuous_real continuous_intros)
  also have "integral {pi/2..pi} ?f = integral {-pi/2..0} (?f \<circ> (\<lambda>\<phi>. \<phi> + pi))"
    by (subst integral_shift) (auto intro!: continuous_intros)
  also have "\<dots> = integral {-(pi/2)..-0} (\<lambda>x. min (d / 2) (sin (-x) * l / 2))" by (simp add: o_def)
  also have "\<dots> = integral {0..pi/2} ?f" (is "_ = ?I") by (subst Henstock_Kurzweil_Integration.integral_reflect_real) simp_all
  also have "\<dots> + \<dots> = 2 * \<dots>" by simp
  also have "?I = integral {0..\<phi>'} ?f + integral {\<phi>'..pi/2} ?f"
    using l d l_ge_d \<phi>'_nonneg \<phi>'_le
    by (intro Henstock_Kurzweil_Integration.integral_combine [symmetric]) (auto intro!: integrable_continuous_real continuous_intros)
  also have "integral {0..\<phi>'} ?f = integral {0..\<phi>'} (\<lambda>x. l / 2 * sin x)"
    using l by (intro integral_cong) (auto simp: min_def field_simps dest: le_phi')
  also have "((\<lambda>x. l / 2 * sin x) has_integral (- (l / 2 * cos \<phi>') - (- (l / 2 * cos 0)))) {0..\<phi>'}"
    using \<phi>'_nonneg
    by (intro fundamental_theorem_of_calculus)
       (auto simp: has_real_derivative_iff_has_vector_derivative [symmetric] intro!: derivative_eq_intros)
  hence "integral {0..\<phi>'} (\<lambda>x. l / 2 * sin x) = (1 - cos \<phi>') * l / 2"
    by (simp add: has_integral_iff algebra_simps)
  also have "integral {\<phi>'..pi/2} ?f = integral {\<phi>'..pi/2} (\<lambda>_. d / 2)"
    using l by (intro integral_cong) (auto simp: min_def field_simps dest: ge_phi')
  also have "\<dots> = arccos (d / l) * d / 2" using \<phi>'_le d l l_ge_d
    by (subst arccos_arcsin_eq) (auto simp: field_simps \<phi>'_def)
  also note \<open>cos \<phi>' = sqrt (1 - (d / l)^2)\<close>
  also have "2 * ((1 - sqrt (1 - (d / l)\<^sup>2)) * l / 2 + arccos (d / l) * d / 2) =
               l * (1 - sqrt (1 - (d / l)\<^sup>2)) + arccos (d / l) * d"
    using d l by (simp add: field_simps)
  finally show "emeasure lborel Buffon_set' =
                  ennreal (l * (1 - sqrt (1 - (d / l)\<^sup>2)) + arccos (d / l) * d)" .
qed

lemma emeasure_set_long: "emeasure lborel Buffon_set =
        4 * ennreal (l * (1 - sqrt (1 - (d / l)\<^sup>2)) + arccos (d / l) * d)"
  by (simp add: emeasure_buffon_set_conv_buffon_set' emeasure_buffon_set'_long l_ge_d)

lemma prob_long_aux:
  shows "2 / pi * ((l / d) - sqrt ((l / d)\<^sup>2 - 1) + arccos (d / l)) \<ge> 0"
  and   "Buffon {(x, \<phi>). needle l x \<phi> \<inter> {- d / 2, d / 2} \<noteq> {}} =
           ennreal (2 / pi * ((l / d) - sqrt ((l / d)\<^sup>2 - 1) + arccos (d / l)))"
  using emeasure_buffon_set'_long(1)
proof -
  have *: "l * sqrt ((l\<^sup>2 - d\<^sup>2) / l\<^sup>2) + 0 \<le> l + d * arccos (d / l)"
    using d l_ge_d by (intro add_mono mult_nonneg_nonneg arccos_lbound) (auto simp: field_simps)

  have "l / d \<ge> sqrt ((l / d)\<^sup>2 - 1)"
    using l d l_ge_d by (intro real_le_lsqrt) (auto simp: field_simps)
  thus "2 / pi * ((l / d) - sqrt ((l / d)\<^sup>2 - 1) + arccos (d / l)) \<ge> 0"
    using d l l_ge_d
    by (intro mult_nonneg_nonneg add_nonneg_nonneg arccos_lbound) (auto simp: field_simps)

  have "emeasure Buffon {(x,\<phi>). needle l x \<phi> \<inter> {-d/2, d/2} \<noteq> {}} =
          ennreal (4 * (l - l * sqrt (1 - (d / l)\<^sup>2) + arccos (d / l) * d)) / ennreal (2 * d * pi)"
    using d l l_ge_d * unfolding buffon_prob_aux emeasure_set_long ennreal_numeral [symmetric]
    by (subst ennreal_mult [symmetric])
       (auto intro!: add_nonneg_nonneg mult_nonneg_nonneg simp: field_simps)
  also have "\<dots> = ennreal ((4 * (l - l * sqrt (1 - (d / l)\<^sup>2) + arccos (d / l) * d)) / (2 * d * pi))"
    using d l * by (subst divide_ennreal) (auto simp: field_simps)
  also have "(4 * (l - l * sqrt (1 - (d / l)\<^sup>2) + arccos (d / l) * d)) / (2 * d * pi) =
               2 / pi * (l / d - l / d * sqrt ((d / l)^2 * ((l / d)^2 - 1)) + arccos (d / l))"
    using d l by (simp add: field_simps)
  also have "l / d * sqrt ((d / l)^2 * ((l / d)^2 - 1)) = sqrt ((l / d) ^ 2 - 1)"
    using d l l_ge_d unfolding real_sqrt_mult real_sqrt_abs by simp
  finally show "emeasure Buffon {(x,\<phi>). needle l x \<phi> \<inter> {-d/2, d/2} \<noteq> {}} =
                  ennreal (2 / pi * ((l / d) - sqrt ((l / d)\<^sup>2 - 1) + arccos (d / l)))" .
qed

lemma prob_long:
  "\<P>((x,\<phi>) in Buffon. needle l x \<phi> \<inter> {-d/2, d/2} \<noteq> {}) =
     2 / pi * ((l / d) - sqrt ((l / d)\<^sup>2 - 1) + arccos (d / l))"
  using prob_long_aux unfolding emeasure_eq_measure
  by (subst (asm) ennreal_inj) simp_all

end

theorem prob_eq:
  defines "x \<equiv> l / d"
  shows   "\<P>((x,\<phi>) in Buffon. needle l x \<phi> \<inter> {-d/2, d/2} \<noteq> {}) =
             (if l \<le> d then
                2 / pi * x
              else
                2 / pi * (x - sqrt (x\<^sup>2 - 1) + arccos (1 / x)))"
  using prob_short prob_long unfolding x_def by auto

end

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   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.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_43
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

fun x :: "bool => bool => bool" where
  "x True y2 = True"
| "x False y2 = y2"

fun elem :: "Nat => Nat list => bool" where
  "elem z (nil2) = False"
| "elem z (cons2 z2 xs) = x (y z z2) (elem z xs)"

fun union :: "Nat list => Nat list => Nat list" where
  "union (nil2) y2 = y2"
| "union (cons2 z2 xs) y2 =
     (if elem z2 y2 then union xs y2 else cons2 z2 (union xs y2))"

theorem property0 :
  "((elem z y2) ==> (elem z (union z2 y2)))"
  oops

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

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

fun risers :: "int list => (int list) list" where
  "risers (nil2) = nil2"
| "risers (cons2 y (nil2)) = cons2 (cons2 y (nil2)) (nil2)"
| "risers (cons2 y (cons2 y2 xs)) =
     (if y <= y2 then
        (case risers (cons2 y2 xs) of
           nil2 => nil2
           | cons2 ys yss => cons2 (cons2 y ys) yss)
        else
        cons2 (cons2 y (nil2)) (risers (cons2 y2 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 mergingbu2 :: "(int list) list => int list" where
  "mergingbu2 (nil2) = nil2"
| "mergingbu2 (cons2 xs (nil2)) = xs"
| "mergingbu2 (cons2 xs (cons2 z x2)) =
     mergingbu2 (pairwise (cons2 xs (cons2 z x2)))"
  by pat_completeness auto

fun msortbu2 :: "int list => int list" where
  "msortbu2 x = mergingbu2 (risers 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 (msortbu2 xs) xs"
  oops

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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_nat_BSortSorts
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

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

fun ordered :: "Nat list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 z (nil2)) = True"
| "ordered (cons2 z (cons2 y2 xs)) =
     ((le z y2) & (ordered (cons2 y2 xs)))"

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun pairs :: "Nat list => Nat list => Nat list" where
  "pairs (nil2) z = z"
| "pairs (cons2 z2 x2) (nil2) = cons2 z2 x2"
| "pairs (cons2 z2 x2) (cons2 x3 x4) =
     x (sort2 z2 x3) (pairs x2 x4)"

fun stitch :: "Nat list => Nat list => Nat list" where
  "stitch (nil2) z = z"
| "stitch (cons2 z2 xs) z = cons2 z2 (pairs xs z)"

function evens :: "'a list => 'a list"
  and odds :: "'a list => 'a list" where
  "evens (nil2) = nil2"
| "evens (cons2 z xs) = cons2 z (odds xs)"
| "odds (nil2) = nil2"
| "odds (cons2 z xs) = evens xs"
  by pat_completeness auto

(*fun did not finish the proof*)
function bmerge :: "Nat list => Nat list => Nat list" where
  "bmerge (nil2) z = nil2"
| "bmerge (cons2 z2 x2) (nil2) = cons2 z2 x2"
| "bmerge (cons2 z2 x2) (cons2 x3 x4) =
     (let fail :: Nat list =
       stitch
         (bmerge (evens (cons2 z2 x2)) (evens (cons2 x3 x4)))
         (bmerge (odds (cons2 z2 x2)) (odds (cons2 x3 x4)))
     in (case x2 of
           nil2 =>
             (case x4 of
                nil2 => sort2 z2 x3
                | cons2 x5 x6 => fail)
           | cons2 x7 x8 => fail))"
  by pat_completeness auto

(*fun did not finish the proof*)
function bsort :: "Nat list => Nat list" where
  "bsort (nil2) = nil2"
| "bsort (cons2 z (nil2)) = cons2 z (nil2)"
| "bsort (cons2 z (cons2 x2 x3)) =
     bmerge
       (bsort (evens (cons2 z (cons2 x2 x3))))
       (bsort (odds (cons2 z (cons2 x2 x3))))"
  by pat_completeness auto

theorem property0 :
  "ordered (bsort xs)"
  oops

end


theory Concrete_Semantics_2_2
  imports Main
begin

fun add:: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add 0 n = n" |
"add (Suc m) n = Suc(add m n)"

lemma add_02: "add m 0 = m"
  apply(induction m) (*
1: add 0 0 = 0 (* saying “for an arbitrary but fixed m” *)
2: \<And>m. add m 0 = m \<Longrightarrow>  add (Suc m) 0 = Suc m (* separates assumptions from the conclusion. *)
.*)
   apply auto
  done

thm add_02
end


theory Number_Theory_Aux imports
  "HOL-Number_Theory.Cong"
  "HOL-Number_Theory.Residues"
begin

abbreviation inverse where "inverse x q \<equiv> (fst (bezw x q))"

lemma inverse: assumes "gcd x q = 1"
  shows "[x * inverse x q = 1] (mod q)"
proof-
  have 2: "fst (bezw x q) * x + snd (bezw x q) * int q = 1"
    using bezw_aux assms int_minus
    by (metis Num.of_nat_simps(2))
  hence 3: "(fst (bezw x q) * x + snd (bezw x q) * int q) mod q = 1 mod q"
    by (metis assms bezw_aux of_nat_mod)
  hence 4: "(fst (bezw x q) * x) mod q = 1 mod q"
    by simp
  hence 5:  "[(fst (bezw x q)) * x  = 1] (mod q)"
    using 2 3 cong_def by force
  then show ?thesis by(simp add: mult.commute)
qed

lemma prod_not_prime:
  assumes "prime (x::nat)"
    and "prime y"
    and "x > 2"
    and "y > 2"
  shows "\<not> prime ((x-1)*(y-1))"
  by (metis assms One_nat_def Suc_diff_1 nat_neq_iff numeral_2_eq_2 prime_gt_0_nat prime_product)

lemma ex_inverse:
  assumes coprime: "coprime (e :: nat) ((P-1)*(Q-1))"
    and "prime P"
    and "prime Q"
    and "P \<noteq> Q"
  shows "\<exists> d. [e*d = 1] (mod (P-1)) \<and> d \<noteq> 0"
proof-
  have "coprime e (P-1)"
    using assms(1) by simp
  then obtain d where d: "[e*d = 1] (mod (P-1))"
    using cong_solve_coprime_nat by auto
  then show ?thesis by (metis cong_0_1_nat cong_1 mult_0_right zero_neq_one)
qed

lemma ex_k1_k2:
  assumes coprime: "coprime (e :: nat) ((P-1)*(Q-1))"
    and " [e*d = 1] (mod (P-1))"
  shows "\<exists> k1 k2. e*d + k1*(P-1) = 1 + k2*(P-1)"
  by (metis assms(2) cong_iff_lin_nat)
lemma "a > b \<Longrightarrow>int a - int b = int (a - b)"
  by simp

lemma ex_k_mod:
  assumes coprime: "coprime (e :: nat) ((P-1)*(Q-1))"
    and "P \<noteq> Q"
    and "prime P"
    and "prime Q"
    and "d \<noteq> 0"
    and " [e*d = 1] (mod (P-1))"
  shows "\<exists> k. e*d = 1 + k*(P-1)"
proof-
  have "e > 0"
    using assms(1) assms(2) prime_gt_0_nat by fastforce
  then have "e*d \<ge> 1" using assms by simp
  then obtain k where k: "e*d = 1 + k*(P-1)"
    using assms(6) cong_to_1'_nat by auto
  then show ?thesis
    by simp
qed

lemma fermat_little_theorem:
  assumes "prime (P :: nat)"
  shows "[x^P = x] (mod P)"
proof(cases "P dvd x")
  case True
  hence "x mod P = 0" by simp
  moreover have "x ^ P mod P = 0"
    by (simp add: True assms prime_dvd_power_nat_iff prime_gt_0_nat)
  ultimately show ?thesis
    by (simp add: cong_def)
next
  case False
  hence "[x ^ (P - 1) = 1] (mod P)" using fermat_theorem assms by blast
  then show ?thesis
    by (metis Suc_diff_1 assms cong_scalar_left nat_mult_1_right not_gr_zero not_prime_0 power_Suc)
qed

lemma prime_field:
  assumes "prime (q::nat)"
    and "a < q"
    and "a \<noteq> 0"
  shows "coprime a q"
  by (meson assms coprime_commute dvd_imp_le linorder_not_le neq0_conv prime_imp_coprime)

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   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.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_75
imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun x :: "Nat => Nat => bool" where
"x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y2) = x x2 y2"

fun count :: "Nat => Nat list => Nat" where
"count y (nil2) = Z"
| "count y (cons2 z2 ys) =
     (if x y z2 then S (count y ys) else count y ys)"

fun t2 :: "Nat => Nat => Nat" where
"t2 (Z) z = z"
| "t2 (S z2) z = S (t2 z2 z)"

theorem property0 :
  "((t2 (count n xs) (count n (cons2 m (nil2)))) =
      (count n (cons2 m xs)))"
  oops

end


theory UteDefs
imports "../HOModel"
begin

section \<open>Verification of the \ute{} Consensus Algorithm\<close>

text \<open>
  Algorithm \ute{} is presented in~\cite{biely:tolerating}. It is an
  uncoordinated algorithm that tolerates value (a.k.a.\ Byzantine) faults,
  and can be understood as a variant of \emph{UniformVoting}. The parameters
  $T$, $E$, and $\alpha$ appear as thresholds of the algorithm and in the
  communication predicates. Their values can be chosen within certain bounds
  in order to adapt the algorithm to the characteristics of different systems.

  We formalize in Isabelle the correctness proof of the algorithm that
  appears in~\cite{biely:tolerating}, using the framework of theory
  \<open>HOModel\<close>.
\<close>

subsection \<open>Model of the Algorithm\<close>

text \<open>
  We begin by introducing an anonymous type of processes of finite
  cardinality that will instantiate the type variable \<open>'proc\<close>
  of the generic HO model.
\<close>

typedecl Proc \<comment> \<open>the set of processes\<close>
axiomatization where Proc_finite: "OFCLASS(Proc, finite_class)"
instance Proc :: finite by (rule Proc_finite)

abbreviation
  "N \<equiv> card (UNIV::Proc set)"   \<comment> \<open>number of processes\<close>

text \<open>
  The algorithm proceeds in \emph{phases} of $2$ rounds each (we call
  \emph{steps} the individual rounds that constitute a phase).
  The following utility functions compute the phase and step of a round,
  given the round number.
\<close>

abbreviation
 "nSteps \<equiv> 2"
definition phase where "phase (r::nat) \<equiv> r div nSteps"
definition step where "step (r::nat) \<equiv> r mod nSteps"

lemma phase_zero [simp]: "phase 0 = 0"
by (simp add: phase_def)

lemma step_zero [simp]: "step 0 = 0"
by (simp add: step_def)

lemma phase_step: "(phase r * nSteps) + step r = r"
  by (auto simp add: phase_def step_def)

text \<open>The following record models the local state of a process.\<close>

record 'val pstate =
  x :: 'val                \<comment> \<open>current value held by process\<close>
  vote :: "'val option"    \<comment> \<open>value the process voted for, if any\<close>
  decide :: "'val option"  \<comment> \<open>value the process has decided on, if any\<close>

text \<open>Possible messages sent during the execution of the algorithm.\<close>

datatype 'val msg =
   Val "'val"
 | Vote "'val option"

text \<open>
  The \<open>x\<close> field of the initial state is unconstrained, all other
  fields are initialized appropriately.
\<close>

definition Ute_initState where
  "Ute_initState p st \<equiv>
   (vote st = None) \<and> (decide st = None)"

text \<open>
  The following locale introduces the parameters used for the \ute{}
  algorithm and their constraints~\cite{biely:tolerating}.
\<close>

locale ute_parameters =
  fixes \<alpha>::nat and T::nat and E::nat
  assumes majE: "2*E \<ge> N + 2*\<alpha>"
      and majT: "2*T \<ge> N + 2*\<alpha>"
      and EltN: "E < N"
      and TltN: "T < N"
begin

text \<open>Simple consequences of the above parameter constraints.\<close>

lemma alpha_lt_N: "\<alpha> < N"
using EltN majE by auto

lemma alpha_lt_T: "\<alpha> < T"
using majT alpha_lt_N by auto

lemma alpha_lt_E: "\<alpha> < E"
using majE alpha_lt_N by auto

text \<open>
  We separately define the transition predicates and the send functions
  for each step and later combine them to define the overall next-state relation.
\<close>

text \<open>
  In step 0, each process sends its current \<open>x\<close>.
  If it receives the value $v$ more than $T$ times, it votes for $v$,
  otherwise it doesn't vote.
\<close>

definition
  send0 :: "nat \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> 'val msg"
where
  "send0 r p q st \<equiv> Val (x st)"

definition
  next0 :: "nat \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> (Proc \<Rightarrow> 'val msg option)
                \<Rightarrow> 'val pstate \<Rightarrow> bool"
where
  "next0 r p st msgs st' \<equiv>
     (\<exists>v. card {q. msgs q = Some (Val v)} > T \<and> st' = st \<lparr> vote := Some v \<rparr>)
   \<or> \<not>(\<exists>v. card {q. msgs q = Some (Val v)} > T) \<and> st' = st \<lparr> vote := None \<rparr>"

text \<open>
  In step 1, each process sends its current \<open>vote\<close>.

  If it receives more than \<open>\<alpha>\<close> votes for a given value \<open>v\<close>,
  it sets its \<open>x\<close> field to \<open>v\<close>, else it sets \<open>x\<close> to a
  default value.

  If the process receives more than \<open>E\<close> votes for \<open>v\<close>, it decides
  \<open>v\<close>, otherwise it leaves its decision unchanged.
\<close>

definition
  send1 :: "nat \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> 'val msg"
where
  "send1 r p q st \<equiv> Vote (vote st)"

definition
  next1 :: "nat \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> (Proc \<Rightarrow> 'val msg option)
                \<Rightarrow> 'val pstate \<Rightarrow> bool"
where
  "next1 r p st msgs st' \<equiv>
    ( (\<exists>v. card {q. msgs q = Some (Vote (Some v))} > \<alpha> \<and> x st' = v)
     \<or> \<not>(\<exists>v. card {q. msgs q = Some (Vote (Some v))} > \<alpha>)
         \<and> x st' = undefined  )
  \<and> ( (\<exists>v. card {q. msgs q = Some (Vote (Some v))} > E \<and> decide st' = Some v)
     \<or> \<not>(\<exists>v. card {q. msgs q = Some (Vote (Some v))} > E)
         \<and> decide st' = decide st )
  \<and> vote st' = None"

text \<open>
  The overall send function and next-state relation are simply obtained as
  the composition of the individual relations defined above.
\<close>

definition
  Ute_sendMsg :: "nat \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> 'val msg"
where
  "Ute_sendMsg (r::nat) \<equiv> if step r = 0 then send0 r else send1 r"

definition
  Ute_nextState :: "nat \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> (Proc \<Rightarrow> 'val msg option)
                        \<Rightarrow> 'val pstate \<Rightarrow> bool"
where
  "Ute_nextState r \<equiv> if step r = 0 then next0 r else next1 r"

subsection \<open>Communication Predicate for \ute{}\<close>

text \<open>
  Following~\cite{biely:tolerating}, we now define the communication predicate
  for the \ute{} algorithm to be correct.

  The round-by-round predicate stipulates the following conditions:
  \begin{itemize}
  \item no process may receive more than \<open>\<alpha>\<close> corrupted messages, and
  \item every process should receive more than \<open>max(T, N + 2*\<alpha> - E - 1)\<close>
    correct messages.
  \end{itemize}
  \cite{biely:tolerating} also requires that every process should receive more
  than \<open>\<alpha>\<close> correct messages, but this is implied, since \<open>T > \<alpha>\<close>
  (cf. lemma \<open>alpha_lt_T\<close>).
\<close>

definition Ute_commPerRd where
  "Ute_commPerRd HOrs SHOrs \<equiv>
   \<forall>p. card (HOrs p - SHOrs p) \<le> \<alpha>
     \<and> card (SHOrs p \<inter> HOrs p) > N + 2*\<alpha> - E - 1
     \<and> card (SHOrs p \<inter> HOrs p) > T"

text \<open>
  The global communication predicate requires there exists some phase
  \<open>\<Phi>\<close> such that:
  \begin{itemize}
  \item all HO and SHO sets of all processes are equal in the second step
    of phase \<open>\<Phi>\<close>, i.e.\ all processes receive messages from the
    same set of processes, and none of these messages is corrupted,
  \item every process receives more than \<open>T\<close> correct messages in
    the first step of phase \<open>\<Phi>+1\<close>, and
  \item every process receives more than \<open>E\<close> correct messages in the
    second step of phase \<open>\<Phi>+1\<close>.
  \end{itemize}
  The predicate in the article~\cite{biely:tolerating} requires infinitely
  many such phases, but one is clearly enough.
\<close>

definition Ute_commGlobal where
  "Ute_commGlobal HOs SHOs \<equiv>
    \<exists>\<Phi>. (let r = Suc (nSteps*\<Phi>)
         in  (\<exists>\<pi>. \<forall>p. \<pi> = HOs r p \<and> \<pi> = SHOs r p)
           \<and> (\<forall>p. card (SHOs (Suc r) p \<inter> HOs (Suc r) p) > T)
           \<and> (\<forall>p. card (SHOs (Suc (Suc r)) p \<inter> HOs (Suc (Suc r)) p) > E))"

subsection \<open>The \ute{} Heard-Of Machine\<close>

text \<open>
  We now define the coordinated HO machine for the \ute{} algorithm
  by assembling the algorithm definition and its communication-predicate.
\<close>

definition Ute_SHOMachine where
  "Ute_SHOMachine = \<lparr>
     CinitState =  (\<lambda> p st crd. Ute_initState p st),
     sendMsg =  Ute_sendMsg,
     CnextState = (\<lambda> r p st msgs crd st'. Ute_nextState r p st msgs st'),
     SHOcommPerRd = Ute_commPerRd,
     SHOcommGlobal = Ute_commGlobal
   \<rparr>"

abbreviation
  "Ute_M \<equiv> (Ute_SHOMachine::(Proc, 'val pstate, 'val msg) SHOMachine)"

end   \<comment> \<open>locale @{text "ute_parameters"}\<close>

end   (* theory UteDefs *)


theory ExF013
  imports Main
begin

lemma "\<And>aa. ((\<forall>x. (P x \<longrightarrow> Q x)) \<and> P aa  \<longrightarrow> Q aa)"
proof -
  {
    fix aa
    assume a:"(\<forall>x. (P x \<longrightarrow> Q x)) \<and> P aa"
    hence b:"P aa" by (rule conjE)
    from a have "\<forall>x. (P x \<longrightarrow> Q x)" by (rule conjE)
    hence "P aa \<longrightarrow> Q aa" by (rule allE)
    from this and b have "Q aa" by (rule mp)
  }
  thus "\<And>aa. ((\<forall>x. (P x \<longrightarrow> Q x)) \<and> P aa  \<longrightarrow> Q aa)"  by (rule impI)
qed


theory Blast imports Main begin

lemma "((\<exists>x. \<forall>y. p(x)=p(y)) = ((\<exists>x. q(x))=(\<forall>y. p(y))))   =
       ((\<exists>x. \<forall>y. q(x)=q(y)) = ((\<exists>x. p(x))=(\<forall>y. q(y))))"
by blast

text{*\noindent Until now, we have proved everything using only induction and
simplification.  Substantial proofs require more elaborate types of
inference.*}

lemma "(\<forall>x. honest(x) \<and> industrious(x) \<longrightarrow> healthy(x)) \<and>
       \<not> (\<exists>x. grocer(x) \<and> healthy(x)) \<and>
       (\<forall>x. industrious(x) \<and> grocer(x) \<longrightarrow> honest(x)) \<and>
       (\<forall>x. cyclist(x) \<longrightarrow> industrious(x)) \<and>
       (\<forall>x. \<not>healthy(x) \<and> cyclist(x) \<longrightarrow> \<not>honest(x))
       \<longrightarrow> (\<forall>x. grocer(x) \<longrightarrow> \<not>cyclist(x))"
by blast

lemma "(\<Union>i\<in>I. A(i)) \<inter> (\<Union>j\<in>J. B(j)) =
        (\<Union>i\<in>I. \<Union>j\<in>J. A(i) \<inter> B(j))"
by blast

text {*
@{thm[display] mult_is_0}
 \rulename{mult_is_0}}

@{thm[display] finite_Un}
 \rulename{finite_Un}}
*}

(*ideas for uses of intro, etc.: ex/Primes/is_gcd_unique?*)
end


(*  Title:      ZF/List.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section\<open>Lists in Zermelo-Fraenkel Set Theory\<close>

theory List imports Datatype ArithSimp begin

consts
  list       :: "i\<Rightarrow>i"

datatype
  "list(A)" = Nil | Cons ("a \<in> A", "l \<in> list(A)")

syntax
 "_Nil" :: i  (\<open>[]\<close>)
 "_List" :: "is \<Rightarrow> i"  (\<open>[(_)]\<close>)

translations
  "[x, xs]"     == "CONST Cons(x, [xs])"
  "[x]"         == "CONST Cons(x, [])"
  "[]"          == "CONST Nil"

consts
  length :: "i\<Rightarrow>i"
  hd     :: "i\<Rightarrow>i"
  tl     :: "i\<Rightarrow>i"

primrec
  "length([]) = 0"
  "length(Cons(a,l)) = succ(length(l))"

primrec
  "hd([]) = 0"
  "hd(Cons(a,l)) = a"

primrec
  "tl([]) = []"
  "tl(Cons(a,l)) = l"

consts
  map         :: "[i\<Rightarrow>i, i] \<Rightarrow> i"
  set_of_list :: "i\<Rightarrow>i"
  app         :: "[i,i]\<Rightarrow>i"                        (infixr \<open>@\<close> 60)

(*map is a binding operator -- it applies to meta-level functions, not
object-level functions.  This simplifies the final form of term_rec_conv,
although complicating its derivation.*)
primrec
  "map(f,[]) = []"
  "map(f,Cons(a,l)) = Cons(f(a), map(f,l))"

primrec
  "set_of_list([]) = 0"
  "set_of_list(Cons(a,l)) = cons(a, set_of_list(l))"

primrec
  app_Nil:  "[] @ ys = ys"
  app_Cons: "(Cons(a,l)) @ ys = Cons(a, l @ ys)"

consts
  rev :: "i\<Rightarrow>i"
  flat       :: "i\<Rightarrow>i"
  list_add   :: "i\<Rightarrow>i"

primrec
  "rev([]) = []"
  "rev(Cons(a,l)) = rev(l) @ [a]"

primrec
  "flat([]) = []"
  "flat(Cons(l,ls)) = l @ flat(ls)"

primrec
  "list_add([]) = 0"
  "list_add(Cons(a,l)) = a #+ list_add(l)"

consts
  drop       :: "[i,i]\<Rightarrow>i"

primrec
  drop_0:    "drop(0,l) = l"
  drop_succ: "drop(succ(i), l) = tl (drop(i,l))"

(*** Thanks to Sidi Ehmety for the following ***)

definition
(* Function `take' returns the first n elements of a list *)
  take     :: "[i,i]\<Rightarrow>i"  where
  "take(n, as) \<equiv> list_rec(\<lambda>n\<in>nat. [],
                \<lambda>a l r. \<lambda>n\<in>nat. nat_case([], \<lambda>m. Cons(a, r`m), n), as)`n"

definition
  nth :: "[i, i]\<Rightarrow>i"  where
  \<comment> \<open>returns the (n+1)th element of a list, or 0 if the
   list is too short.\<close>
  "nth(n, as) \<equiv> list_rec(\<lambda>n\<in>nat. 0,
                          \<lambda>a l r. \<lambda>n\<in>nat. nat_case(a, \<lambda>m. r`m, n), as) ` n"

definition
  list_update :: "[i, i, i]\<Rightarrow>i"  where
  "list_update(xs, i, v) \<equiv> list_rec(\<lambda>n\<in>nat. Nil,
      \<lambda>u us vs. \<lambda>n\<in>nat. nat_case(Cons(v, us), \<lambda>m. Cons(u, vs`m), n), xs)`i"

consts
  filter :: "[i\<Rightarrow>o, i] \<Rightarrow> i"
  upt :: "[i, i] \<Rightarrow>i"

primrec
  "filter(P, Nil) = Nil"
  "filter(P, Cons(x, xs)) =
     (if P(x) then Cons(x, filter(P, xs)) else filter(P, xs))"

primrec
  "upt(i, 0) = Nil"
  "upt(i, succ(j)) = (if i \<le> j then upt(i, j)@[j] else Nil)"

definition
  min :: "[i,i] \<Rightarrow>i"  where
    "min(x, y) \<equiv> (if x \<le> y then x else y)"

definition
  max :: "[i, i] \<Rightarrow>i"  where
    "max(x, y) \<equiv> (if x \<le> y then y else x)"

(*** Aspects of the datatype definition ***)

declare list.intros [simp,TC]

(*An elimination rule, for type-checking*)
inductive_cases ConsE: "Cons(a,l) \<in> list(A)"

lemma Cons_type_iff [simp]: "Cons(a,l) \<in> list(A) \<longleftrightarrow> a \<in> A \<and> l \<in> list(A)"
by (blast elim: ConsE)

(*Proving freeness results*)
lemma Cons_iff: "Cons(a,l)=Cons(a',l') \<longleftrightarrow> a=a' \<and> l=l'"
by auto

lemma Nil_Cons_iff: "\<not> Nil=Cons(a,l)"
by auto

lemma list_unfold: "list(A) = {0} + (A * list(A))"
by (blast intro!: list.intros [unfolded list.con_defs]
          elim: list.cases [unfolded list.con_defs])

(**  Lemmas to justify using "list" in other recursive type definitions **)

lemma list_mono: "A<=B \<Longrightarrow> list(A) \<subseteq> list(B)"
  unfolding list.defs
apply (rule lfp_mono)
apply (simp_all add: list.bnd_mono)
apply (assumption | rule univ_mono basic_monos)+
done

(*There is a similar proof by list induction.*)
lemma list_univ: "list(univ(A)) \<subseteq> univ(A)"
  unfolding list.defs list.con_defs
apply (rule lfp_lowerbound)
apply (rule_tac [2] A_subset_univ [THEN univ_mono])
apply (blast intro!: zero_in_univ Inl_in_univ Inr_in_univ Pair_in_univ)
done

(*These two theorems justify datatypes involving list(nat), list(A), ...*)
lemmas list_subset_univ = subset_trans [OF list_mono list_univ]

lemma list_into_univ: "\<lbrakk>l \<in> list(A);  A \<subseteq> univ(B)\<rbrakk> \<Longrightarrow> l \<in> univ(B)"
by (blast intro: list_subset_univ [THEN subsetD])

lemma list_case_type:
    "\<lbrakk>l \<in> list(A);
        c \<in> C(Nil);
        \<And>x y. \<lbrakk>x \<in> A;  y \<in> list(A)\<rbrakk> \<Longrightarrow> h(x,y): C(Cons(x,y))
\<rbrakk> \<Longrightarrow> list_case(c,h,l) \<in> C(l)"
by (erule list.induct, auto)

lemma list_0_triv: "list(0) = {Nil}"
apply (rule equalityI, auto)
apply (induct_tac x, auto)
done

(*** List functions ***)

lemma tl_type: "l \<in> list(A) \<Longrightarrow> tl(l) \<in> list(A)"
apply (induct_tac "l")
apply (simp_all (no_asm_simp) add: list.intros)
done

(** drop **)

lemma drop_Nil [simp]: "i \<in> nat \<Longrightarrow> drop(i, Nil) = Nil"
apply (induct_tac "i")
apply (simp_all (no_asm_simp))
done

lemma drop_succ_Cons [simp]: "i \<in> nat \<Longrightarrow> drop(succ(i), Cons(a,l)) = drop(i,l)"
apply (rule sym)
apply (induct_tac "i")
apply (simp (no_asm))
apply (simp (no_asm_simp))
done

lemma drop_type [simp,TC]: "\<lbrakk>i \<in> nat; l \<in> list(A)\<rbrakk> \<Longrightarrow> drop(i,l) \<in> list(A)"
apply (induct_tac "i")
apply (simp_all (no_asm_simp) add: tl_type)
done

declare drop_succ [simp del]

(** Type checking -- proved by induction, as usual **)

lemma list_rec_type [TC]:
    "\<lbrakk>l \<in> list(A);
        c \<in> C(Nil);
        \<And>x y r. \<lbrakk>x \<in> A;  y \<in> list(A);  r \<in> C(y)\<rbrakk> \<Longrightarrow> h(x,y,r): C(Cons(x,y))
\<rbrakk> \<Longrightarrow> list_rec(c,h,l) \<in> C(l)"
by (induct_tac "l", auto)

(** map **)

lemma map_type [TC]:
    "\<lbrakk>l \<in> list(A);  \<And>x. x \<in> A \<Longrightarrow> h(x): B\<rbrakk> \<Longrightarrow> map(h,l) \<in> list(B)"
apply (simp add: map_list_def)
apply (typecheck add: list.intros list_rec_type, blast)
done

lemma map_type2 [TC]: "l \<in> list(A) \<Longrightarrow> map(h,l) \<in> list({h(u). u \<in> A})"
apply (erule map_type)
apply (erule RepFunI)
done

(** length **)

lemma length_type [TC]: "l \<in> list(A) \<Longrightarrow> length(l) \<in> nat"
by (simp add: length_list_def)

lemma lt_length_in_nat:
   "\<lbrakk>x < length(xs); xs \<in> list(A)\<rbrakk> \<Longrightarrow> x \<in> nat"
by (frule lt_nat_in_nat, typecheck)

(** app **)

lemma app_type [TC]: "\<lbrakk>xs: list(A);  ys: list(A)\<rbrakk> \<Longrightarrow> xs@ys \<in> list(A)"
by (simp add: app_list_def)

(** rev **)

lemma rev_type [TC]: "xs: list(A) \<Longrightarrow> rev(xs) \<in> list(A)"
by (simp add: rev_list_def)

(** flat **)

lemma flat_type [TC]: "ls: list(list(A)) \<Longrightarrow> flat(ls) \<in> list(A)"
by (simp add: flat_list_def)

(** set_of_list **)

lemma set_of_list_type [TC]: "l \<in> list(A) \<Longrightarrow> set_of_list(l) \<in> Pow(A)"
  unfolding set_of_list_list_def
apply (erule list_rec_type, auto)
done

lemma set_of_list_append:
     "xs: list(A) \<Longrightarrow> set_of_list (xs@ys) = set_of_list(xs) \<union> set_of_list(ys)"
apply (erule list.induct)
apply (simp_all (no_asm_simp) add: Un_cons)
done

(** list_add **)

lemma list_add_type [TC]: "xs: list(nat) \<Longrightarrow> list_add(xs) \<in> nat"
by (simp add: list_add_list_def)

(*** theorems about map ***)

lemma map_ident [simp]: "l \<in> list(A) \<Longrightarrow> map(\<lambda>u. u, l) = l"
apply (induct_tac "l")
apply (simp_all (no_asm_simp))
done

lemma map_compose: "l \<in> list(A) \<Longrightarrow> map(h, map(j,l)) = map(\<lambda>u. h(j(u)), l)"
apply (induct_tac "l")
apply (simp_all (no_asm_simp))
done

lemma map_app_distrib: "xs: list(A) \<Longrightarrow> map(h, xs@ys) = map(h,xs) @ map(h,ys)"
apply (induct_tac "xs")
apply (simp_all (no_asm_simp))
done

lemma map_flat: "ls: list(list(A)) \<Longrightarrow> map(h, flat(ls)) = flat(map(map(h),ls))"
apply (induct_tac "ls")
apply (simp_all (no_asm_simp) add: map_app_distrib)
done

lemma list_rec_map:
     "l \<in> list(A) \<Longrightarrow>
      list_rec(c, d, map(h,l)) =
      list_rec(c, \<lambda>x xs r. d(h(x), map(h,xs), r), l)"
apply (induct_tac "l")
apply (simp_all (no_asm_simp))
done

(** theorems about list(Collect(A,P)) -- used in Induct/Term.thy **)

(* @{term"c \<in> list(Collect(B,P)) \<Longrightarrow> c \<in> list"} *)
lemmas list_CollectD = Collect_subset [THEN list_mono, THEN subsetD]

lemma map_list_Collect: "l \<in> list({x \<in> A. h(x)=j(x)}) \<Longrightarrow> map(h,l) = map(j,l)"
apply (induct_tac "l")
apply (simp_all (no_asm_simp))
done

(*** theorems about length ***)

lemma length_map [simp]: "xs: list(A) \<Longrightarrow> length(map(h,xs)) = length(xs)"
by (induct_tac "xs", simp_all)

lemma length_app [simp]:
     "\<lbrakk>xs: list(A); ys: list(A)\<rbrakk>
      \<Longrightarrow> length(xs@ys) = length(xs) #+ length(ys)"
by (induct_tac "xs", simp_all)

lemma length_rev [simp]: "xs: list(A) \<Longrightarrow> length(rev(xs)) = length(xs)"
apply (induct_tac "xs")
apply (simp_all (no_asm_simp) add: length_app)
done

lemma length_flat:
     "ls: list(list(A)) \<Longrightarrow> length(flat(ls)) = list_add(map(length,ls))"
apply (induct_tac "ls")
apply (simp_all (no_asm_simp) add: length_app)
done

(** Length and drop **)

(*Lemma for the inductive step of drop_length*)
lemma drop_length_Cons [rule_format]:
     "xs: list(A) \<Longrightarrow>
           \<forall>x.  \<exists>z zs. drop(length(xs), Cons(x,xs)) = Cons(z,zs)"
by (erule list.induct, simp_all)

lemma drop_length [rule_format]:
     "l \<in> list(A) \<Longrightarrow> \<forall>i \<in> length(l). (\<exists>z zs. drop(i,l) = Cons(z,zs))"
apply (erule list.induct, simp_all, safe)
apply (erule drop_length_Cons)
apply (rule natE)
apply (erule Ord_trans [OF asm_rl length_type Ord_nat], assumption, simp_all)
apply (blast intro: succ_in_naturalD length_type)
done

(*** theorems about app ***)

lemma app_right_Nil [simp]: "xs: list(A) \<Longrightarrow> xs@Nil=xs"
by (erule list.induct, simp_all)

lemma app_assoc: "xs: list(A) \<Longrightarrow> (xs@ys)@zs = xs@(ys@zs)"
by (induct_tac "xs", simp_all)

lemma flat_app_distrib: "ls: list(list(A)) \<Longrightarrow> flat(ls@ms) = flat(ls)@flat(ms)"
apply (induct_tac "ls")
apply (simp_all (no_asm_simp) add: app_assoc)
done

(*** theorems about rev ***)

lemma rev_map_distrib: "l \<in> list(A) \<Longrightarrow> rev(map(h,l)) = map(h,rev(l))"
apply (induct_tac "l")
apply (simp_all (no_asm_simp) add: map_app_distrib)
done

(*Simplifier needs the premises as assumptions because rewriting will not
  instantiate the variable ?A in the rules' typing conditions; note that
  rev_type does not instantiate ?A.  Only the premises do.
*)
lemma rev_app_distrib:
     "\<lbrakk>xs: list(A);  ys: list(A)\<rbrakk> \<Longrightarrow> rev(xs@ys) = rev(ys)@rev(xs)"
apply (erule list.induct)
apply (simp_all add: app_assoc)
done

lemma rev_rev_ident [simp]: "l \<in> list(A) \<Longrightarrow> rev(rev(l))=l"
apply (induct_tac "l")
apply (simp_all (no_asm_simp) add: rev_app_distrib)
done

lemma rev_flat: "ls: list(list(A)) \<Longrightarrow> rev(flat(ls)) = flat(map(rev,rev(ls)))"
apply (induct_tac "ls")
apply (simp_all add: map_app_distrib flat_app_distrib rev_app_distrib)
done

(*** theorems about list_add ***)

lemma list_add_app:
     "\<lbrakk>xs: list(nat);  ys: list(nat)\<rbrakk>
      \<Longrightarrow> list_add(xs@ys) = list_add(ys) #+ list_add(xs)"
apply (induct_tac "xs", simp_all)
done

lemma list_add_rev: "l \<in> list(nat) \<Longrightarrow> list_add(rev(l)) = list_add(l)"
apply (induct_tac "l")
apply (simp_all (no_asm_simp) add: list_add_app)
done

lemma list_add_flat:
     "ls: list(list(nat)) \<Longrightarrow> list_add(flat(ls)) = list_add(map(list_add,ls))"
apply (induct_tac "ls")
apply (simp_all (no_asm_simp) add: list_add_app)
done

(** New induction rules **)

lemma list_append_induct [case_names Nil snoc, consumes 1]:
    "\<lbrakk>l \<in> list(A);
        P(Nil);
        \<And>x y. \<lbrakk>x \<in> A;  y \<in> list(A);  P(y)\<rbrakk> \<Longrightarrow> P(y @ [x])
\<rbrakk> \<Longrightarrow> P(l)"
apply (subgoal_tac "P(rev(rev(l)))", simp)
apply (erule rev_type [THEN list.induct], simp_all)
done

lemma list_complete_induct_lemma [rule_format]:
 assumes ih:
    "\<And>l. \<lbrakk>l \<in> list(A);
             \<forall>l' \<in> list(A). length(l') < length(l) \<longrightarrow> P(l')\<rbrakk>
          \<Longrightarrow> P(l)"
  shows "n \<in> nat \<Longrightarrow> \<forall>l \<in> list(A). length(l) < n \<longrightarrow> P(l)"
apply (induct_tac n, simp)
apply (blast intro: ih elim!: leE)
done

theorem list_complete_induct:
      "\<lbrakk>l \<in> list(A);
          \<And>l. \<lbrakk>l \<in> list(A);
                  \<forall>l' \<in> list(A). length(l') < length(l) \<longrightarrow> P(l')\<rbrakk>
               \<Longrightarrow> P(l)
\<rbrakk> \<Longrightarrow> P(l)"
apply (rule list_complete_induct_lemma [of A])
   prefer 4 apply (rule le_refl, simp)
  apply blast
 apply simp
apply assumption
done

(*** Thanks to Sidi Ehmety for these results about min, take, etc. ***)

(** min FIXME: replace by Int! **)
(* Min theorems are also true for i, j ordinals *)
lemma min_sym: "\<lbrakk>i \<in> nat; j \<in> nat\<rbrakk> \<Longrightarrow> min(i,j)=min(j,i)"
  unfolding min_def
apply (auto dest!: not_lt_imp_le dest: lt_not_sym intro: le_anti_sym)
done

lemma min_type [simp,TC]: "\<lbrakk>i \<in> nat; j \<in> nat\<rbrakk> \<Longrightarrow> min(i,j):nat"
by (unfold min_def, auto)

lemma min_0 [simp]: "i \<in> nat \<Longrightarrow> min(0,i) = 0"
  unfolding min_def
apply (auto dest: not_lt_imp_le)
done

lemma min_02 [simp]: "i \<in> nat \<Longrightarrow> min(i, 0) = 0"
  unfolding min_def
apply (auto dest: not_lt_imp_le)
done

lemma lt_min_iff: "\<lbrakk>i \<in> nat; j \<in> nat; k \<in> nat\<rbrakk> \<Longrightarrow> i<min(j,k) \<longleftrightarrow> i<j \<and> i<k"
  unfolding min_def
apply (auto dest!: not_lt_imp_le intro: lt_trans2 lt_trans)
done

lemma min_succ_succ [simp]:
     "\<lbrakk>i \<in> nat; j \<in> nat\<rbrakk> \<Longrightarrow>  min(succ(i), succ(j))= succ(min(i, j))"
apply (unfold min_def, auto)
done

(*** more theorems about lists ***)

(** filter **)

lemma filter_append [simp]:
     "xs:list(A) \<Longrightarrow> filter(P, xs@ys) = filter(P, xs) @ filter(P, ys)"
by (induct_tac "xs", auto)

lemma filter_type [simp,TC]: "xs:list(A) \<Longrightarrow> filter(P, xs):list(A)"
by (induct_tac "xs", auto)

lemma length_filter: "xs:list(A) \<Longrightarrow> length(filter(P, xs)) \<le> length(xs)"
apply (induct_tac "xs", auto)
apply (rule_tac j = "length (l) " in le_trans)
apply (auto simp add: le_iff)
done

lemma filter_is_subset: "xs:list(A) \<Longrightarrow> set_of_list(filter(P,xs)) \<subseteq> set_of_list(xs)"
by (induct_tac "xs", auto)

lemma filter_False [simp]: "xs:list(A) \<Longrightarrow> filter(\<lambda>p. False, xs) = Nil"
by (induct_tac "xs", auto)

lemma filter_True [simp]: "xs:list(A) \<Longrightarrow> filter(\<lambda>p. True, xs) = xs"
by (induct_tac "xs", auto)

(** length **)

lemma length_is_0_iff [simp]: "xs:list(A) \<Longrightarrow> length(xs)=0 \<longleftrightarrow> xs=Nil"
by (erule list.induct, auto)

lemma length_is_0_iff2 [simp]: "xs:list(A) \<Longrightarrow> 0 = length(xs) \<longleftrightarrow> xs=Nil"
by (erule list.induct, auto)

lemma length_tl [simp]: "xs:list(A) \<Longrightarrow> length(tl(xs)) = length(xs) #- 1"
by (erule list.induct, auto)

lemma length_greater_0_iff: "xs:list(A) \<Longrightarrow> 0<length(xs) \<longleftrightarrow> xs \<noteq> Nil"
by (erule list.induct, auto)

lemma length_succ_iff: "xs:list(A) \<Longrightarrow> length(xs)=succ(n) \<longleftrightarrow> (\<exists>y ys. xs=Cons(y, ys) \<and> length(ys)=n)"
by (erule list.induct, auto)

(** more theorems about append **)

lemma append_is_Nil_iff [simp]:
     "xs:list(A) \<Longrightarrow> (xs@ys = Nil) \<longleftrightarrow> (xs=Nil \<and> ys = Nil)"
by (erule list.induct, auto)

lemma append_is_Nil_iff2 [simp]:
     "xs:list(A) \<Longrightarrow> (Nil = xs@ys) \<longleftrightarrow> (xs=Nil \<and> ys = Nil)"
by (erule list.induct, auto)

lemma append_left_is_self_iff [simp]:
     "xs:list(A) \<Longrightarrow> (xs@ys = xs) \<longleftrightarrow> (ys = Nil)"
by (erule list.induct, auto)

lemma append_left_is_self_iff2 [simp]:
     "xs:list(A) \<Longrightarrow> (xs = xs@ys) \<longleftrightarrow> (ys = Nil)"
by (erule list.induct, auto)

(*TOO SLOW as a default simprule!*)
lemma append_left_is_Nil_iff [rule_format]:
     "\<lbrakk>xs:list(A); ys:list(A); zs:list(A)\<rbrakk> \<Longrightarrow>
   length(ys)=length(zs) \<longrightarrow> (xs@ys=zs \<longleftrightarrow> (xs=Nil \<and> ys=zs))"
apply (erule list.induct)
apply (auto simp add: length_app)
done

(*TOO SLOW as a default simprule!*)
lemma append_left_is_Nil_iff2 [rule_format]:
     "\<lbrakk>xs:list(A); ys:list(A); zs:list(A)\<rbrakk> \<Longrightarrow>
   length(ys)=length(zs) \<longrightarrow> (zs=ys@xs \<longleftrightarrow> (xs=Nil \<and> ys=zs))"
apply (erule list.induct)
apply (auto simp add: length_app)
done

lemma append_eq_append_iff [rule_format]:
     "xs:list(A) \<Longrightarrow> \<forall>ys \<in> list(A).
      length(xs)=length(ys) \<longrightarrow> (xs@us = ys@vs) \<longleftrightarrow> (xs=ys \<and> us=vs)"
apply (erule list.induct)
apply (simp (no_asm_simp))
apply clarify
apply (erule_tac a = ys in list.cases, auto)
done
declare append_eq_append_iff [simp]

lemma append_eq_append [rule_format]:
  "xs:list(A) \<Longrightarrow>
   \<forall>ys \<in> list(A). \<forall>us \<in> list(A). \<forall>vs \<in> list(A).
   length(us) = length(vs) \<longrightarrow> (xs@us = ys@vs) \<longrightarrow> (xs=ys \<and> us=vs)"
apply (induct_tac "xs")
apply (force simp add: length_app, clarify)
apply (erule_tac a = ys in list.cases, simp)
apply (subgoal_tac "Cons (a, l) @ us =vs")
 apply (drule rev_iffD1 [OF _ append_left_is_Nil_iff], simp_all, blast)
done

lemma append_eq_append_iff2 [simp]:
 "\<lbrakk>xs:list(A); ys:list(A); us:list(A); vs:list(A); length(us)=length(vs)\<rbrakk>
  \<Longrightarrow>  xs@us = ys@vs \<longleftrightarrow> (xs=ys \<and> us=vs)"
apply (rule iffI)
apply (rule append_eq_append, auto)
done

lemma append_self_iff [simp]:
     "\<lbrakk>xs:list(A); ys:list(A); zs:list(A)\<rbrakk> \<Longrightarrow> xs@ys=xs@zs \<longleftrightarrow> ys=zs"
by simp

lemma append_self_iff2 [simp]:
     "\<lbrakk>xs:list(A); ys:list(A); zs:list(A)\<rbrakk> \<Longrightarrow> ys@xs=zs@xs \<longleftrightarrow> ys=zs"
by simp

(* Can also be proved from append_eq_append_iff2,
but the proof requires two more hypotheses: x \<in> A and y \<in> A *)
lemma append1_eq_iff [rule_format]:
     "xs:list(A) \<Longrightarrow> \<forall>ys \<in> list(A). xs@[x] = ys@[y] \<longleftrightarrow> (xs = ys \<and> x=y)"
apply (erule list.induct)
 apply clarify
 apply (erule list.cases)
 apply simp_all
txt\<open>Inductive step\<close>
apply clarify
apply (erule_tac a=ys in list.cases, simp_all)
done
declare append1_eq_iff [simp]

lemma append_right_is_self_iff [simp]:
     "\<lbrakk>xs:list(A); ys:list(A)\<rbrakk> \<Longrightarrow> (xs@ys = ys) \<longleftrightarrow> (xs=Nil)"
by (simp (no_asm_simp) add: append_left_is_Nil_iff)

lemma append_right_is_self_iff2 [simp]:
     "\<lbrakk>xs:list(A); ys:list(A)\<rbrakk> \<Longrightarrow> (ys = xs@ys) \<longleftrightarrow> (xs=Nil)"
apply (rule iffI)
apply (drule sym, auto)
done

lemma hd_append [rule_format]:
     "xs:list(A) \<Longrightarrow> xs \<noteq> Nil \<longrightarrow> hd(xs @ ys) = hd(xs)"
by (induct_tac "xs", auto)
declare hd_append [simp]

lemma tl_append [rule_format]:
     "xs:list(A) \<Longrightarrow> xs\<noteq>Nil \<longrightarrow> tl(xs @ ys) = tl(xs)@ys"
by (induct_tac "xs", auto)
declare tl_append [simp]

(** rev **)
lemma rev_is_Nil_iff [simp]: "xs:list(A) \<Longrightarrow> (rev(xs) = Nil \<longleftrightarrow> xs = Nil)"
by (erule list.induct, auto)

lemma Nil_is_rev_iff [simp]: "xs:list(A) \<Longrightarrow> (Nil = rev(xs) \<longleftrightarrow> xs = Nil)"
by (erule list.induct, auto)

lemma rev_is_rev_iff [rule_format]:
     "xs:list(A) \<Longrightarrow> \<forall>ys \<in> list(A). rev(xs)=rev(ys) \<longleftrightarrow> xs=ys"
apply (erule list.induct, force, clarify)
apply (erule_tac a = ys in list.cases, auto)
done
declare rev_is_rev_iff [simp]

lemma rev_list_elim [rule_format]:
     "xs:list(A) \<Longrightarrow>
      (xs=Nil \<longrightarrow> P) \<longrightarrow> (\<forall>ys \<in> list(A). \<forall>y \<in> A. xs =ys@[y] \<longrightarrow>P)\<longrightarrow>P"
by (erule list_append_induct, auto)

(** more theorems about drop **)

lemma length_drop [rule_format]:
     "n \<in> nat \<Longrightarrow> \<forall>xs \<in> list(A). length(drop(n, xs)) = length(xs) #- n"
apply (erule nat_induct)
apply (auto elim: list.cases)
done
declare length_drop [simp]

lemma drop_all [rule_format]:
     "n \<in> nat \<Longrightarrow> \<forall>xs \<in> list(A). length(xs) \<le> n \<longrightarrow> drop(n, xs)=Nil"
apply (erule nat_induct)
apply (auto elim: list.cases)
done
declare drop_all [simp]

lemma drop_append [rule_format]:
     "n \<in> nat \<Longrightarrow>
      \<forall>xs \<in> list(A). drop(n, xs@ys) = drop(n,xs) @ drop(n #- length(xs), ys)"
apply (induct_tac "n")
apply (auto elim: list.cases)
done

lemma drop_drop:
    "m \<in> nat \<Longrightarrow> \<forall>xs \<in> list(A). \<forall>n \<in> nat. drop(n, drop(m, xs))=drop(n #+ m, xs)"
apply (induct_tac "m")
apply (auto elim: list.cases)
done

(** take **)

lemma take_0 [simp]: "xs:list(A) \<Longrightarrow> take(0, xs) =  Nil"
  unfolding take_def
apply (erule list.induct, auto)
done

lemma take_succ_Cons [simp]:
    "n \<in> nat \<Longrightarrow> take(succ(n), Cons(a, xs)) = Cons(a, take(n, xs))"
by (simp add: take_def)

(* Needed for proving take_all *)
lemma take_Nil [simp]: "n \<in> nat \<Longrightarrow> take(n, Nil) = Nil"
by (unfold take_def, auto)

lemma take_all [rule_format]:
     "n \<in> nat \<Longrightarrow> \<forall>xs \<in> list(A). length(xs) \<le> n  \<longrightarrow> take(n, xs) = xs"
apply (erule nat_induct)
apply (auto elim: list.cases)
done
declare take_all [simp]

lemma take_type [rule_format]:
     "xs:list(A) \<Longrightarrow> \<forall>n \<in> nat. take(n, xs):list(A)"
apply (erule list.induct, simp, clarify)
apply (erule natE, auto)
done
declare take_type [simp,TC]

lemma take_append [rule_format]:
 "xs:list(A) \<Longrightarrow>
  \<forall>ys \<in> list(A). \<forall>n \<in> nat. take(n, xs @ ys) =
                            take(n, xs) @ take(n #- length(xs), ys)"
apply (erule list.induct, simp, clarify)
apply (erule natE, auto)
done
declare take_append [simp]

lemma take_take [rule_format]:
   "m \<in> nat \<Longrightarrow>
    \<forall>xs \<in> list(A). \<forall>n \<in> nat. take(n, take(m,xs))= take(min(n, m), xs)"
apply (induct_tac "m", auto)
apply (erule_tac a = xs in list.cases)
apply (auto simp add: take_Nil)
apply (erule_tac n=n in natE)
apply (auto intro: take_0 take_type)
done

(** nth **)

lemma nth_0 [simp]: "nth(0, Cons(a, l)) = a"
by (simp add: nth_def)

lemma nth_Cons [simp]: "n \<in> nat \<Longrightarrow> nth(succ(n), Cons(a,l)) = nth(n,l)"
by (simp add: nth_def)

lemma nth_empty [simp]: "nth(n, Nil) = 0"
by (simp add: nth_def)

lemma nth_type [rule_format]:
     "xs:list(A) \<Longrightarrow> \<forall>n. n < length(xs) \<longrightarrow> nth(n,xs) \<in> A"
apply (erule list.induct, simp, clarify)
apply (subgoal_tac "n \<in> nat")
 apply (erule natE, auto dest!: le_in_nat)
done
declare nth_type [simp,TC]

lemma nth_eq_0 [rule_format]:
     "xs:list(A) \<Longrightarrow> \<forall>n \<in> nat. length(xs) \<le> n \<longrightarrow> nth(n,xs) = 0"
apply (erule list.induct, simp, clarify)
apply (erule natE, auto)
done

lemma nth_append [rule_format]:
  "xs:list(A) \<Longrightarrow>
   \<forall>n \<in> nat. nth(n, xs @ ys) = (if n < length(xs) then nth(n,xs)
                                else nth(n #- length(xs), ys))"
apply (induct_tac "xs", simp, clarify)
apply (erule natE, auto)
done

lemma set_of_list_conv_nth:
    "xs:list(A)
     \<Longrightarrow> set_of_list(xs) = {x \<in> A. \<exists>i\<in>nat. i<length(xs) \<and> x = nth(i,xs)}"
apply (induct_tac "xs", simp_all)
apply (rule equalityI, auto)
apply (rule_tac x = 0 in bexI, auto)
apply (erule natE, auto)
done

(* Other theorems about lists *)

lemma nth_take_lemma [rule_format]:
 "k \<in> nat \<Longrightarrow>
  \<forall>xs \<in> list(A). (\<forall>ys \<in> list(A). k \<le> length(xs) \<longrightarrow> k \<le> length(ys) \<longrightarrow>
      (\<forall>i \<in> nat. i<k \<longrightarrow> nth(i,xs) = nth(i,ys))\<longrightarrow> take(k,xs) = take(k,ys))"
apply (induct_tac "k")
apply (simp_all (no_asm_simp) add: lt_succ_eq_0_disj all_conj_distrib)
apply clarify
(*Both lists are non-empty*)
apply (erule_tac a=xs in list.cases, simp)
apply (erule_tac a=ys in list.cases, clarify)
apply (simp (no_asm_use) )
apply clarify
apply (simp (no_asm_simp))
apply (rule conjI, force)
apply (rename_tac y ys z zs)
apply (drule_tac x = zs and x1 = ys in bspec [THEN bspec], auto)
done

lemma nth_equalityI [rule_format]:
     "\<lbrakk>xs:list(A); ys:list(A); length(xs) = length(ys);
         \<forall>i \<in> nat. i < length(xs) \<longrightarrow> nth(i,xs) = nth(i,ys)\<rbrakk>
      \<Longrightarrow> xs = ys"
apply (subgoal_tac "length (xs) \<le> length (ys) ")
apply (cut_tac k="length(xs)" and xs=xs and ys=ys in nth_take_lemma)
apply (simp_all add: take_all)
done

(*The famous take-lemma*)

lemma take_equalityI [rule_format]:
    "\<lbrakk>xs:list(A); ys:list(A); (\<forall>i \<in> nat. take(i, xs) = take(i,ys))\<rbrakk>
     \<Longrightarrow> xs = ys"
apply (case_tac "length (xs) \<le> length (ys) ")
apply (drule_tac x = "length (ys) " in bspec)
apply (drule_tac [3] not_lt_imp_le)
apply (subgoal_tac [5] "length (ys) \<le> length (xs) ")
apply (rule_tac [6] j = "succ (length (ys))" in le_trans)
apply (rule_tac [6] leI)
apply (drule_tac [5] x = "length (xs) " in bspec)
apply (simp_all add: take_all)
done

lemma nth_drop [rule_format]:
  "n \<in> nat \<Longrightarrow> \<forall>i \<in> nat. \<forall>xs \<in> list(A). nth(i, drop(n, xs)) = nth(n #+ i, xs)"
apply (induct_tac "n", simp_all, clarify)
apply (erule list.cases, auto)
done

lemma take_succ [rule_format]:
  "xs\<in>list(A)
   \<Longrightarrow> \<forall>i. i < length(xs) \<longrightarrow> take(succ(i), xs) = take(i,xs) @ [nth(i, xs)]"
apply (induct_tac "xs", auto)
apply (subgoal_tac "i\<in>nat")
apply (erule natE)
apply (auto simp add: le_in_nat)
done

lemma take_add [rule_format]:
     "\<lbrakk>xs\<in>list(A); j\<in>nat\<rbrakk>
      \<Longrightarrow> \<forall>i\<in>nat. take(i #+ j, xs) = take(i,xs) @ take(j, drop(i,xs))"
apply (induct_tac "xs", simp_all, clarify)
apply (erule_tac n = i in natE, simp_all)
done

lemma length_take:
     "l\<in>list(A) \<Longrightarrow> \<forall>n\<in>nat. length(take(n,l)) = min(n, length(l))"
apply (induct_tac "l", safe, simp_all)
apply (erule natE, simp_all)
done

subsection\<open>The function zip\<close>

text\<open>Crafty definition to eliminate a type argument\<close>

consts
  zip_aux        :: "[i,i]\<Rightarrow>i"

primrec (*explicit lambda is required because both arguments of "un" vary*)
  "zip_aux(B,[]) =
     (\<lambda>ys \<in> list(B). list_case([], \<lambda>y l. [], ys))"

  "zip_aux(B,Cons(x,l)) =
     (\<lambda>ys \<in> list(B).
        list_case(Nil, \<lambda>y zs. Cons(\<langle>x,y\<rangle>, zip_aux(B,l)`zs), ys))"

definition
  zip :: "[i, i]\<Rightarrow>i"  where
   "zip(xs, ys) \<equiv> zip_aux(set_of_list(ys),xs)`ys"

(* zip equations *)

lemma list_on_set_of_list: "xs \<in> list(A) \<Longrightarrow> xs \<in> list(set_of_list(xs))"
apply (induct_tac xs, simp_all)
apply (blast intro: list_mono [THEN subsetD])
done

lemma zip_Nil [simp]: "ys:list(A) \<Longrightarrow> zip(Nil, ys)=Nil"
apply (simp add: zip_def list_on_set_of_list [of _ A])
apply (erule list.cases, simp_all)
done

lemma zip_Nil2 [simp]: "xs:list(A) \<Longrightarrow> zip(xs, Nil)=Nil"
apply (simp add: zip_def list_on_set_of_list [of _ A])
apply (erule list.cases, simp_all)
done

lemma zip_aux_unique [rule_format]:
     "\<lbrakk>B<=C;  xs \<in> list(A)\<rbrakk>
      \<Longrightarrow> \<forall>ys \<in> list(B). zip_aux(C,xs) ` ys = zip_aux(B,xs) ` ys"
apply (induct_tac xs)
 apply simp_all
 apply (blast intro: list_mono [THEN subsetD], clarify)
apply (erule_tac a=ys in list.cases, auto)
apply (blast intro: list_mono [THEN subsetD])
done

lemma zip_Cons_Cons [simp]:
     "\<lbrakk>xs:list(A); ys:list(B); x \<in> A; y \<in> B\<rbrakk> \<Longrightarrow>
      zip(Cons(x,xs), Cons(y, ys)) = Cons(\<langle>x,y\<rangle>, zip(xs, ys))"
apply (simp add: zip_def, auto)
apply (rule zip_aux_unique, auto)
apply (simp add: list_on_set_of_list [of _ B])
apply (blast intro: list_on_set_of_list list_mono [THEN subsetD])
done

lemma zip_type [rule_format]:
     "xs:list(A) \<Longrightarrow> \<forall>ys \<in> list(B). zip(xs, ys):list(A*B)"
apply (induct_tac "xs")
apply (simp (no_asm))
apply clarify
apply (erule_tac a = ys in list.cases, auto)
done
declare zip_type [simp,TC]

(* zip length *)
lemma length_zip [rule_format]:
     "xs:list(A) \<Longrightarrow> \<forall>ys \<in> list(B). length(zip(xs,ys)) =
                                     min(length(xs), length(ys))"
  unfolding min_def
apply (induct_tac "xs", simp_all, clarify)
apply (erule_tac a = ys in list.cases, auto)
done
declare length_zip [simp]

lemma zip_append1 [rule_format]:
 "\<lbrakk>ys:list(A); zs:list(B)\<rbrakk> \<Longrightarrow>
  \<forall>xs \<in> list(A). zip(xs @ ys, zs) =
                 zip(xs, take(length(xs), zs)) @ zip(ys, drop(length(xs),zs))"
apply (induct_tac "zs", force, clarify)
apply (erule_tac a = xs in list.cases, simp_all)
done

lemma zip_append2 [rule_format]:
 "\<lbrakk>xs:list(A); zs:list(B)\<rbrakk> \<Longrightarrow> \<forall>ys \<in> list(B). zip(xs, ys@zs) =
       zip(take(length(ys), xs), ys) @ zip(drop(length(ys), xs), zs)"
apply (induct_tac "xs", force, clarify)
apply (erule_tac a = ys in list.cases, auto)
done

lemma zip_append [simp]:
 "\<lbrakk>length(xs) = length(us); length(ys) = length(vs);
     xs:list(A); us:list(B); ys:list(A); vs:list(B)\<rbrakk>
  \<Longrightarrow> zip(xs@ys,us@vs) = zip(xs, us) @ zip(ys, vs)"
by (simp (no_asm_simp) add: zip_append1 drop_append diff_self_eq_0)

lemma zip_rev [rule_format]:
 "ys:list(B) \<Longrightarrow> \<forall>xs \<in> list(A).
    length(xs) = length(ys) \<longrightarrow> zip(rev(xs), rev(ys)) = rev(zip(xs, ys))"
apply (induct_tac "ys", force, clarify)
apply (erule_tac a = xs in list.cases)
apply (auto simp add: length_rev)
done
declare zip_rev [simp]

lemma nth_zip [rule_format]:
   "ys:list(B) \<Longrightarrow> \<forall>i \<in> nat. \<forall>xs \<in> list(A).
                    i < length(xs) \<longrightarrow> i < length(ys) \<longrightarrow>
                    nth(i,zip(xs, ys)) = <nth(i,xs),nth(i, ys)>"
apply (induct_tac "ys", force, clarify)
apply (erule_tac a = xs in list.cases, simp)
apply (auto elim: natE)
done
declare nth_zip [simp]

lemma set_of_list_zip [rule_format]:
     "\<lbrakk>xs:list(A); ys:list(B); i \<in> nat\<rbrakk>
      \<Longrightarrow> set_of_list(zip(xs, ys)) =
          {\<langle>x, y\<rangle>:A*B. \<exists>i\<in>nat. i < min(length(xs), length(ys))
          \<and> x = nth(i, xs) \<and> y = nth(i, ys)}"
by (force intro!: Collect_cong simp add: lt_min_iff set_of_list_conv_nth)

(** list_update **)

lemma list_update_Nil [simp]: "i \<in> nat \<Longrightarrow>list_update(Nil, i, v) = Nil"
by (unfold list_update_def, auto)

lemma list_update_Cons_0 [simp]: "list_update(Cons(x, xs), 0, v)= Cons(v, xs)"
by (unfold list_update_def, auto)

lemma list_update_Cons_succ [simp]:
  "n \<in> nat \<Longrightarrow>
    list_update(Cons(x, xs), succ(n), v)= Cons(x, list_update(xs, n, v))"
apply (unfold list_update_def, auto)
done

lemma list_update_type [rule_format]:
     "\<lbrakk>xs:list(A); v \<in> A\<rbrakk> \<Longrightarrow> \<forall>n \<in> nat. list_update(xs, n, v):list(A)"
apply (induct_tac "xs")
apply (simp (no_asm))
apply clarify
apply (erule natE, auto)
done
declare list_update_type [simp,TC]

lemma length_list_update [rule_format]:
     "xs:list(A) \<Longrightarrow> \<forall>i \<in> nat. length(list_update(xs, i, v))=length(xs)"
apply (induct_tac "xs")
apply (simp (no_asm))
apply clarify
apply (erule natE, auto)
done
declare length_list_update [simp]

lemma nth_list_update [rule_format]:
     "\<lbrakk>xs:list(A)\<rbrakk> \<Longrightarrow> \<forall>i \<in> nat. \<forall>j \<in> nat. i < length(xs)  \<longrightarrow>
         nth(j, list_update(xs, i, x)) = (if i=j then x else nth(j, xs))"
apply (induct_tac "xs")
 apply simp_all
apply clarify
apply (rename_tac i j)
apply (erule_tac n=i in natE)
apply (erule_tac [2] n=j in natE)
apply (erule_tac n=j in natE, simp_all, force)
done

lemma nth_list_update_eq [simp]:
     "\<lbrakk>i < length(xs); xs:list(A)\<rbrakk> \<Longrightarrow> nth(i, list_update(xs, i,x)) = x"
by (simp (no_asm_simp) add: lt_length_in_nat nth_list_update)

lemma nth_list_update_neq [rule_format]:
  "xs:list(A) \<Longrightarrow>
     \<forall>i \<in> nat. \<forall>j \<in> nat. i \<noteq> j \<longrightarrow> nth(j, list_update(xs,i,x)) = nth(j,xs)"
apply (induct_tac "xs")
 apply (simp (no_asm))
apply clarify
apply (erule natE)
apply (erule_tac [2] natE, simp_all)
apply (erule natE, simp_all)
done
declare nth_list_update_neq [simp]

lemma list_update_overwrite [rule_format]:
     "xs:list(A) \<Longrightarrow> \<forall>i \<in> nat. i < length(xs)
   \<longrightarrow> list_update(list_update(xs, i, x), i, y) = list_update(xs, i,y)"
apply (induct_tac "xs")
 apply (simp (no_asm))
apply clarify
apply (erule natE, auto)
done
declare list_update_overwrite [simp]

lemma list_update_same_conv [rule_format]:
     "xs:list(A) \<Longrightarrow>
      \<forall>i \<in> nat. i < length(xs) \<longrightarrow>
                 (list_update(xs, i, x) = xs) \<longleftrightarrow> (nth(i, xs) = x)"
apply (induct_tac "xs")
 apply (simp (no_asm))
apply clarify
apply (erule natE, auto)
done

lemma update_zip [rule_format]:
     "ys:list(B) \<Longrightarrow>
      \<forall>i \<in> nat. \<forall>xy \<in> A*B. \<forall>xs \<in> list(A).
        length(xs) = length(ys) \<longrightarrow>
        list_update(zip(xs, ys), i, xy) = zip(list_update(xs, i, fst(xy)),
                                              list_update(ys, i, snd(xy)))"
apply (induct_tac "ys")
 apply auto
apply (erule_tac a = xs in list.cases)
apply (auto elim: natE)
done

lemma set_update_subset_cons [rule_format]:
  "xs:list(A) \<Longrightarrow>
   \<forall>i \<in> nat. set_of_list(list_update(xs, i, x)) \<subseteq> cons(x, set_of_list(xs))"
apply (induct_tac "xs")
 apply simp
apply (rule ballI)
apply (erule natE, simp_all, auto)
done

lemma set_of_list_update_subsetI:
     "\<lbrakk>set_of_list(xs) \<subseteq> A; xs:list(A); x \<in> A; i \<in> nat\<rbrakk>
   \<Longrightarrow> set_of_list(list_update(xs, i,x)) \<subseteq> A"
apply (rule subset_trans)
apply (rule set_update_subset_cons, auto)
done

(** upt **)

lemma upt_rec:
     "j \<in> nat \<Longrightarrow> upt(i,j) = (if i<j then Cons(i, upt(succ(i), j)) else Nil)"
apply (induct_tac "j", auto)
apply (drule not_lt_imp_le)
apply (auto simp: lt_Ord intro: le_anti_sym)
done

lemma upt_conv_Nil [simp]: "\<lbrakk>j \<le> i; j \<in> nat\<rbrakk> \<Longrightarrow> upt(i,j) = Nil"
apply (subst upt_rec, auto)
apply (auto simp add: le_iff)
apply (drule lt_asym [THEN notE], auto)
done

(*Only needed if upt_Suc is deleted from the simpset*)
lemma upt_succ_append:
     "\<lbrakk>i \<le> j; j \<in> nat\<rbrakk> \<Longrightarrow> upt(i,succ(j)) = upt(i, j)@[j]"
by simp

lemma upt_conv_Cons:
     "\<lbrakk>i<j; j \<in> nat\<rbrakk>  \<Longrightarrow> upt(i,j) = Cons(i,upt(succ(i),j))"
apply (rule trans)
apply (rule upt_rec, auto)
done

lemma upt_type [simp,TC]: "j \<in> nat \<Longrightarrow> upt(i,j):list(nat)"
by (induct_tac "j", auto)

(*LOOPS as a simprule, since j<=j*)
lemma upt_add_eq_append:
     "\<lbrakk>i \<le> j; j \<in> nat; k \<in> nat\<rbrakk> \<Longrightarrow> upt(i, j #+k) = upt(i,j)@upt(j,j#+k)"
apply (induct_tac "k")
apply (auto simp add: app_assoc app_type)
apply (rule_tac j = j in le_trans, auto)
done

lemma length_upt [simp]: "\<lbrakk>i \<in> nat; j \<in> nat\<rbrakk> \<Longrightarrow>length(upt(i,j)) = j #- i"
apply (induct_tac "j")
apply (rule_tac [2] sym)
apply (auto dest!: not_lt_imp_le simp add: diff_succ diff_is_0_iff)
done

lemma nth_upt [simp]:
     "\<lbrakk>i \<in> nat; j \<in> nat; k \<in> nat; i #+ k < j\<rbrakk> \<Longrightarrow> nth(k, upt(i,j)) = i #+ k"
apply (rotate_tac -1, erule rev_mp)
apply (induct_tac "j", simp)
apply (auto dest!: not_lt_imp_le
            simp add: nth_append le_iff less_diff_conv add_commute)
done

lemma take_upt [rule_format]:
     "\<lbrakk>m \<in> nat; n \<in> nat\<rbrakk> \<Longrightarrow>
         \<forall>i \<in> nat. i #+ m \<le> n \<longrightarrow> take(m, upt(i,n)) = upt(i,i#+m)"
apply (induct_tac "m")
apply (simp (no_asm_simp) add: take_0)
apply clarify
apply (subst upt_rec, simp)
apply (rule sym)
apply (subst upt_rec, simp)
apply (simp_all del: upt.simps)
apply (rule_tac j = "succ (i #+ x) " in lt_trans2)
apply auto
done
declare take_upt [simp]

lemma map_succ_upt:
     "\<lbrakk>m \<in> nat; n \<in> nat\<rbrakk> \<Longrightarrow> map(succ, upt(m,n))= upt(succ(m), succ(n))"
apply (induct_tac "n")
apply (auto simp add: map_app_distrib)
done

lemma nth_map [rule_format]:
     "xs:list(A) \<Longrightarrow>
      \<forall>n \<in> nat. n < length(xs) \<longrightarrow> nth(n, map(f, xs)) = f(nth(n, xs))"
apply (induct_tac "xs", simp)
apply (rule ballI)
apply (induct_tac "n", auto)
done
declare nth_map [simp]

lemma nth_map_upt [rule_format]:
     "\<lbrakk>m \<in> nat; n \<in> nat\<rbrakk> \<Longrightarrow>
      \<forall>i \<in> nat. i < n #- m \<longrightarrow> nth(i, map(f, upt(m,n))) = f(m #+ i)"
apply (rule_tac n = m and m = n in diff_induct, typecheck, simp, simp)
apply (subst map_succ_upt [symmetric], simp_all, clarify)
apply (subgoal_tac "i < length (upt (0, x))")
 prefer 2
 apply (simp add: less_diff_conv)
 apply (rule_tac j = "succ (i #+ y) " in lt_trans2)
  apply simp
 apply simp
apply (subgoal_tac "i < length (upt (y, x))")
 apply (simp_all add: add_commute less_diff_conv)
done

(** sublist (a generalization of nth to sets) **)

definition
  sublist :: "[i, i] \<Rightarrow> i"  where
    "sublist(xs, A)\<equiv>
     map(fst, (filter(\<lambda>p. snd(p): A, zip(xs, upt(0,length(xs))))))"

lemma sublist_0 [simp]: "xs:list(A) \<Longrightarrow>sublist(xs, 0) =Nil"
by (unfold sublist_def, auto)

lemma sublist_Nil [simp]: "sublist(Nil, A) = Nil"
by (unfold sublist_def, auto)

lemma sublist_shift_lemma:
 "\<lbrakk>xs:list(B); i \<in> nat\<rbrakk> \<Longrightarrow>
  map(fst, filter(\<lambda>p. snd(p):A, zip(xs, upt(i,i #+ length(xs))))) =
  map(fst, filter(\<lambda>p. snd(p):nat \<and> snd(p) #+ i \<in> A, zip(xs,upt(0,length(xs)))))"
apply (erule list_append_induct)
apply (simp (no_asm_simp))
apply (auto simp add: add_commute length_app filter_append map_app_distrib)
done

lemma sublist_type [simp,TC]:
     "xs:list(B) \<Longrightarrow> sublist(xs, A):list(B)"
  unfolding sublist_def
apply (induct_tac "xs")
apply (auto simp add: filter_append map_app_distrib)
done

lemma upt_add_eq_append2:
     "\<lbrakk>i \<in> nat; j \<in> nat\<rbrakk> \<Longrightarrow> upt(0, i #+ j) = upt(0, i) @ upt(i, i #+ j)"
by (simp add: upt_add_eq_append [of 0] nat_0_le)

lemma sublist_append:
 "\<lbrakk>xs:list(B); ys:list(B)\<rbrakk> \<Longrightarrow>
  sublist(xs@ys, A) = sublist(xs, A) @ sublist(ys, {j \<in> nat. j #+ length(xs): A})"
  unfolding sublist_def
apply (erule_tac l = ys in list_append_induct, simp)
apply (simp (no_asm_simp) add: upt_add_eq_append2 app_assoc [symmetric])
apply (auto simp add: sublist_shift_lemma length_type map_app_distrib app_assoc)
apply (simp_all add: add_commute)
done

lemma sublist_Cons:
     "\<lbrakk>xs:list(B); x \<in> B\<rbrakk> \<Longrightarrow>
      sublist(Cons(x, xs), A) =
      (if 0 \<in> A then [x] else []) @ sublist(xs, {j \<in> nat. succ(j) \<in> A})"
apply (erule_tac l = xs in list_append_induct)
apply (simp (no_asm_simp) add: sublist_def)
apply (simp del: app_Cons add: app_Cons [symmetric] sublist_append, simp)
done

lemma sublist_singleton [simp]:
     "sublist([x], A) = (if 0 \<in> A then [x] else [])"
by (simp add: sublist_Cons)

lemma sublist_upt_eq_take [rule_format]:
    "xs:list(A) \<Longrightarrow> \<forall>n\<in>nat. sublist(xs,n) = take(n,xs)"
apply (erule list.induct, simp)
apply (clarify )
apply (erule natE)
apply (simp_all add: nat_eq_Collect_lt Ord_mem_iff_lt sublist_Cons)
done
declare sublist_upt_eq_take [simp]

lemma sublist_Int_eq:
     "xs \<in> list(B) \<Longrightarrow> sublist(xs, A \<inter> nat) = sublist(xs, A)"
apply (erule list.induct)
apply (simp_all add: sublist_Cons)
done

text\<open>Repetition of a List Element\<close>

consts   repeat :: "[i,i]\<Rightarrow>i"
primrec
  "repeat(a,0) = []"

  "repeat(a,succ(n)) = Cons(a,repeat(a,n))"

lemma length_repeat: "n \<in> nat \<Longrightarrow> length(repeat(a,n)) = n"
by (induct_tac n, auto)

lemma repeat_succ_app: "n \<in> nat \<Longrightarrow> repeat(a,succ(n)) = repeat(a,n) @ [a]"
apply (induct_tac n)
apply (simp_all del: app_Cons add: app_Cons [symmetric])
done

lemma repeat_type [TC]: "\<lbrakk>a \<in> A; n \<in> nat\<rbrakk> \<Longrightarrow> repeat(a,n) \<in> list(A)"
by (induct_tac n, auto)

end