(*  Title:      HOL/Hahn_Banach/Subspace.thy
    Author:     Gertrud Bauer, TU Munich
*)

section \<open>Subspaces\<close>

theory Subspace
imports Vector_Space "HOL-Library.Set_Algebras"
begin

subsection \<open>Definition\<close>

text \<open>
  A non-empty subset \<open>U\<close> of a vector space \<open>V\<close> is a \<^emph>\<open>subspace\<close> of \<open>V\<close>, iff
  \<open>U\<close> is closed under addition and scalar multiplication.
\<close>

locale subspace =
  fixes U :: "'a::{minus, plus, zero, uminus} set" and V
  assumes non_empty [iff, intro]: "U \<noteq> {}"
    and subset [iff]: "U \<subseteq> V"
    and add_closed [iff]: "x \<in> U \<Longrightarrow> y \<in> U \<Longrightarrow> x + y \<in> U"
    and mult_closed [iff]: "x \<in> U \<Longrightarrow> a \<cdot> x \<in> U"

notation (symbols)
  subspace  (infix "\<unlhd>" 50)

declare vectorspace.intro [intro?] subspace.intro [intro?]

lemma subspace_subset [elim]: "U \<unlhd> V \<Longrightarrow> U \<subseteq> V"
  by (rule subspace.subset)

lemma (in subspace) subsetD [iff]: "x \<in> U \<Longrightarrow> x \<in> V"
  using subset by blast

lemma subspaceD [elim]: "U \<unlhd> V \<Longrightarrow> x \<in> U \<Longrightarrow> x \<in> V"
  by (rule subspace.subsetD)

lemma rev_subspaceD [elim?]: "x \<in> U \<Longrightarrow> U \<unlhd> V \<Longrightarrow> x \<in> V"
  by (rule subspace.subsetD)

lemma (in subspace) diff_closed [iff]:
  assumes "vectorspace V"
  assumes x: "x \<in> U" and y: "y \<in> U"
  shows "x - y \<in> U"
proof -
  interpret vectorspace V by fact
  from x y show ?thesis by (simp add: diff_eq1 negate_eq1)
qed

text \<open>
  \<^medskip>
  Similar as for linear spaces, the existence of the zero element in every
  subspace follows from the non-emptiness of the carrier set and by vector
  space laws.
\<close>

lemma (in subspace) zero [intro]:
  assumes "vectorspace V"
  shows "0 \<in> U"
proof -
  interpret V: vectorspace V by fact
  have "U \<noteq> {}" by (rule non_empty)
  then obtain x where x: "x \<in> U" by blast
  then have "x \<in> V" .. then have "0 = x - x" by simp
  also from \<open>vectorspace V\<close> x x have "\<dots> \<in> U" by (rule diff_closed)
  finally show ?thesis .
qed

lemma (in subspace) neg_closed [iff]:
  assumes "vectorspace V"
  assumes x: "x \<in> U"
  shows "- x \<in> U"
proof -
  interpret vectorspace V by fact
  from x show ?thesis by (simp add: negate_eq1)
qed

text \<open>\<^medskip> Further derived laws: every subspace is a vector space.\<close>

lemma (in subspace) vectorspace [iff]:
  assumes "vectorspace V"
  shows "vectorspace U"
proof -
  interpret vectorspace V by fact
  show ?thesis
  proof
    show "U \<noteq> {}" ..
    fix x y z assume x: "x \<in> U" and y: "y \<in> U" and z: "z \<in> U"
    fix a b :: real
    from x y show "x + y \<in> U" by simp
    from x show "a \<cdot> x \<in> U" by simp
    from x y z show "(x + y) + z = x + (y + z)" by (simp add: add_ac)
    from x y show "x + y = y + x" by (simp add: add_ac)
    from x show "x - x = 0" by simp
    from x show "0 + x = x" by simp
    from x y show "a \<cdot> (x + y) = a \<cdot> x + a \<cdot> y" by (simp add: distrib)
    from x show "(a + b) \<cdot> x = a \<cdot> x + b \<cdot> x" by (simp add: distrib)
    from x show "(a * b) \<cdot> x = a \<cdot> b \<cdot> x" by (simp add: mult_assoc)
    from x show "1 \<cdot> x = x" by simp
    from x show "- x = - 1 \<cdot> x" by (simp add: negate_eq1)
    from x y show "x - y = x + - y" by (simp add: diff_eq1)
  qed
qed

text \<open>The subspace relation is reflexive.\<close>

lemma (in vectorspace) subspace_refl [intro]: "V \<unlhd> V"
proof
  show "V \<noteq> {}" ..
  show "V \<subseteq> V" ..
next
  fix x y assume x: "x \<in> V" and y: "y \<in> V"
  fix a :: real
  from x y show "x + y \<in> V" by simp
  from x show "a \<cdot> x \<in> V" by simp
qed

text \<open>The subspace relation is transitive.\<close>

lemma (in vectorspace) subspace_trans [trans]:
  "U \<unlhd> V \<Longrightarrow> V \<unlhd> W \<Longrightarrow> U \<unlhd> W"
proof
  assume uv: "U \<unlhd> V" and vw: "V \<unlhd> W"
  from uv show "U \<noteq> {}" by (rule subspace.non_empty)
  show "U \<subseteq> W"
  proof -
    from uv have "U \<subseteq> V" by (rule subspace.subset)
    also from vw have "V \<subseteq> W" by (rule subspace.subset)
    finally show ?thesis .
  qed
  fix x y assume x: "x \<in> U" and y: "y \<in> U"
  from uv and x y show "x + y \<in> U" by (rule subspace.add_closed)
  from uv and x show "a \<cdot> x \<in> U" for a by (rule subspace.mult_closed)
qed

subsection \<open>Linear closure\<close>

text \<open>
  The \<^emph>\<open>linear closure\<close> of a vector \<open>x\<close> is the set of all scalar multiples of
  \<open>x\<close>.
\<close>

definition lin :: "('a::{minus,plus,zero}) \<Rightarrow> 'a set"
  where "lin x = {a \<cdot> x | a. True}"

lemma linI [intro]: "y = a \<cdot> x \<Longrightarrow> y \<in> lin x"
  unfolding lin_def by blast

lemma linI' [iff]: "a \<cdot> x \<in> lin x"
  unfolding lin_def by blast

lemma linE [elim]:
  assumes "x \<in> lin v"
  obtains a :: real where "x = a \<cdot> v"
  using assms unfolding lin_def by blast

text \<open>Every vector is contained in its linear closure.\<close>

lemma (in vectorspace) x_lin_x [iff]: "x \<in> V \<Longrightarrow> x \<in> lin x"
proof -
  assume "x \<in> V"
  then have "x = 1 \<cdot> x" by simp
  also have "\<dots> \<in> lin x" ..
  finally show ?thesis .
qed

lemma (in vectorspace) "0_lin_x" [iff]: "x \<in> V \<Longrightarrow> 0 \<in> lin x"
proof
  assume "x \<in> V"
  then show "0 = 0 \<cdot> x" by simp
qed

text \<open>Any linear closure is a subspace.\<close>

lemma (in vectorspace) lin_subspace [intro]:
  assumes x: "x \<in> V"
  shows "lin x \<unlhd> V"
proof
  from x show "lin x \<noteq> {}" by auto
next
  show "lin x \<subseteq> V"
  proof
    fix x' assume "x' \<in> lin x"
    then obtain a where "x' = a \<cdot> x" ..
    with x show "x' \<in> V" by simp
  qed
next
  fix x' x'' assume x': "x' \<in> lin x" and x'': "x'' \<in> lin x"
  show "x' + x'' \<in> lin x"
  proof -
    from x' obtain a' where "x' = a' \<cdot> x" ..
    moreover from x'' obtain a'' where "x'' = a'' \<cdot> x" ..
    ultimately have "x' + x'' = (a' + a'') \<cdot> x"
      using x by (simp add: distrib)
    also have "\<dots> \<in> lin x" ..
    finally show ?thesis .
  qed
  fix a :: real
  show "a \<cdot> x' \<in> lin x"
  proof -
    from x' obtain a' where "x' = a' \<cdot> x" ..
    with x have "a \<cdot> x' = (a * a') \<cdot> x" by (simp add: mult_assoc)
    also have "\<dots> \<in> lin x" ..
    finally show ?thesis .
  qed
qed

text \<open>Any linear closure is a vector space.\<close>

lemma (in vectorspace) lin_vectorspace [intro]:
  assumes "x \<in> V"
  shows "vectorspace (lin x)"
proof -
  from \<open>x \<in> V\<close> have "subspace (lin x) V"
    by (rule lin_subspace)
  from this and vectorspace_axioms show ?thesis
    by (rule subspace.vectorspace)
qed

subsection \<open>Sum of two vectorspaces\<close>

text \<open>
  The \<^emph>\<open>sum\<close> of two vectorspaces \<open>U\<close> and \<open>V\<close> is the set of all sums of
  elements from \<open>U\<close> and \<open>V\<close>.
\<close>

lemma sum_def: "U + V = {u + v | u v. u \<in> U \<and> v \<in> V}"
  unfolding set_plus_def by auto

lemma sumE [elim]:
    "x \<in> U + V \<Longrightarrow> (\<And>u v. x = u + v \<Longrightarrow> u \<in> U \<Longrightarrow> v \<in> V \<Longrightarrow> C) \<Longrightarrow> C"
  unfolding sum_def by blast

lemma sumI [intro]:
    "u \<in> U \<Longrightarrow> v \<in> V \<Longrightarrow> x = u + v \<Longrightarrow> x \<in> U + V"
  unfolding sum_def by blast

lemma sumI' [intro]:
    "u \<in> U \<Longrightarrow> v \<in> V \<Longrightarrow> u + v \<in> U + V"
  unfolding sum_def by blast

text \<open>\<open>U\<close> is a subspace of \<open>U + V\<close>.\<close>

lemma subspace_sum1 [iff]:
  assumes "vectorspace U" "vectorspace V"
  shows "U \<unlhd> U + V"
proof -
  interpret vectorspace U by fact
  interpret vectorspace V by fact
  show ?thesis
  proof
    show "U \<noteq> {}" ..
    show "U \<subseteq> U + V"
    proof
      fix x assume x: "x \<in> U"
      moreover have "0 \<in> V" ..
      ultimately have "x + 0 \<in> U + V" ..
      with x show "x \<in> U + V" by simp
    qed
    fix x y assume x: "x \<in> U" and "y \<in> U"
    then show "x + y \<in> U" by simp
    from x show "a \<cdot> x \<in> U" for a by simp
  qed
qed

text \<open>The sum of two subspaces is again a subspace.\<close>

lemma sum_subspace [intro?]:
  assumes "subspace U E" "vectorspace E" "subspace V E"
  shows "U + V \<unlhd> E"
proof -
  interpret subspace U E by fact
  interpret vectorspace E by fact
  interpret subspace V E by fact
  show ?thesis
  proof
    have "0 \<in> U + V"
    proof
      show "0 \<in> U" using \<open>vectorspace E\<close> ..
      show "0 \<in> V" using \<open>vectorspace E\<close> ..
      show "(0::'a) = 0 + 0" by simp
    qed
    then show "U + V \<noteq> {}" by blast
    show "U + V \<subseteq> E"
    proof
      fix x assume "x \<in> U + V"
      then obtain u v where "x = u + v" and
        "u \<in> U" and "v \<in> V" ..
      then show "x \<in> E" by simp
    qed
  next
    fix x y assume x: "x \<in> U + V" and y: "y \<in> U + V"
    show "x + y \<in> U + V"
    proof -
      from x obtain ux vx where "x = ux + vx" and "ux \<in> U" and "vx \<in> V" ..
      moreover
      from y obtain uy vy where "y = uy + vy" and "uy \<in> U" and "vy \<in> V" ..
      ultimately
      have "ux + uy \<in> U"
        and "vx + vy \<in> V"
        and "x + y = (ux + uy) + (vx + vy)"
        using x y by (simp_all add: add_ac)
      then show ?thesis ..
    qed
    fix a show "a \<cdot> x \<in> U + V"
    proof -
      from x obtain u v where "x = u + v" and "u \<in> U" and "v \<in> V" ..
      then have "a \<cdot> u \<in> U" and "a \<cdot> v \<in> V"
        and "a \<cdot> x = (a \<cdot> u) + (a \<cdot> v)" by (simp_all add: distrib)
      then show ?thesis ..
    qed
  qed
qed

text \<open>The sum of two subspaces is a vectorspace.\<close>

lemma sum_vs [intro?]:
    "U \<unlhd> E \<Longrightarrow> V \<unlhd> E \<Longrightarrow> vectorspace E \<Longrightarrow> vectorspace (U + V)"
  by (rule subspace.vectorspace) (rule sum_subspace)

subsection \<open>Direct sums\<close>

text \<open>
  The sum of \<open>U\<close> and \<open>V\<close> is called \<^emph>\<open>direct\<close>, iff the zero element is the only
  common element of \<open>U\<close> and \<open>V\<close>. For every element \<open>x\<close> of the direct sum of
  \<open>U\<close> and \<open>V\<close> the decomposition in \<open>x = u + v\<close> with \<open>u \<in> U\<close> and \<open>v \<in> V\<close> is
  unique.
\<close>

lemma decomp:
  assumes "vectorspace E" "subspace U E" "subspace V E"
  assumes direct: "U \<inter> V = {0}"
    and u1: "u1 \<in> U" and u2: "u2 \<in> U"
    and v1: "v1 \<in> V" and v2: "v2 \<in> V"
    and sum: "u1 + v1 = u2 + v2"
  shows "u1 = u2 \<and> v1 = v2"
proof -
  interpret vectorspace E by fact
  interpret subspace U E by fact
  interpret subspace V E by fact
  show ?thesis
  proof
    have U: "vectorspace U"  (* FIXME: use interpret *)
      using \<open>subspace U E\<close> \<open>vectorspace E\<close> by (rule subspace.vectorspace)
    have V: "vectorspace V"
      using \<open>subspace V E\<close> \<open>vectorspace E\<close> by (rule subspace.vectorspace)
    from u1 u2 v1 v2 and sum have eq: "u1 - u2 = v2 - v1"
      by (simp add: add_diff_swap)
    from u1 u2 have u: "u1 - u2 \<in> U"
      by (rule vectorspace.diff_closed [OF U])
    with eq have v': "v2 - v1 \<in> U" by (simp only:)
    from v2 v1 have v: "v2 - v1 \<in> V"
      by (rule vectorspace.diff_closed [OF V])
    with eq have u': " u1 - u2 \<in> V" by (simp only:)

    show "u1 = u2"
    proof (rule add_minus_eq)
      from u1 show "u1 \<in> E" ..
      from u2 show "u2 \<in> E" ..
      from u u' and direct show "u1 - u2 = 0" by blast
    qed
    show "v1 = v2"
    proof (rule add_minus_eq [symmetric])
      from v1 show "v1 \<in> E" ..
      from v2 show "v2 \<in> E" ..
      from v v' and direct show "v2 - v1 = 0" by blast
    qed
  qed
qed

text \<open>
  An application of the previous lemma will be used in the proof of the
  Hahn-Banach Theorem (see page \pageref{decomp-H-use}): for any element
  \<open>y + a \<cdot> x\<^sub>0\<close> of the direct sum of a vectorspace \<open>H\<close> and the linear closure
  of \<open>x\<^sub>0\<close> the components \<open>y \<in> H\<close> and \<open>a\<close> are uniquely determined.
\<close>

lemma decomp_H':
  assumes "vectorspace E" "subspace H E"
  assumes y1: "y1 \<in> H" and y2: "y2 \<in> H"
    and x': "x' \<notin> H"  "x' \<in> E"  "x' \<noteq> 0"
    and eq: "y1 + a1 \<cdot> x' = y2 + a2 \<cdot> x'"
  shows "y1 = y2 \<and> a1 = a2"
proof -
  interpret vectorspace E by fact
  interpret subspace H E by fact
  show ?thesis
  proof
    have c: "y1 = y2 \<and> a1 \<cdot> x' = a2 \<cdot> x'"
    proof (rule decomp)
      show "a1 \<cdot> x' \<in> lin x'" ..
      show "a2 \<cdot> x' \<in> lin x'" ..
      show "H \<inter> lin x' = {0}"
      proof
        show "H \<inter> lin x' \<subseteq> {0}"
        proof
          fix x assume x: "x \<in> H \<inter> lin x'"
          then obtain a where xx': "x = a \<cdot> x'"
            by blast
          have "x = 0"
          proof cases
            assume "a = 0"
            with xx' and x' show ?thesis by simp
          next
            assume a: "a \<noteq> 0"
            from x have "x \<in> H" ..
            with xx' have "inverse a \<cdot> a \<cdot> x' \<in> H" by simp
            with a and x' have "x' \<in> H" by (simp add: mult_assoc2)
            with \<open>x' \<notin> H\<close> show ?thesis by contradiction
          qed
          then show "x \<in> {0}" ..
        qed
        show "{0} \<subseteq> H \<inter> lin x'"
        proof -
          have "0 \<in> H" using \<open>vectorspace E\<close> ..
          moreover have "0 \<in> lin x'" using \<open>x' \<in> E\<close> ..
          ultimately show ?thesis by blast
        qed
      qed
      show "lin x' \<unlhd> E" using \<open>x' \<in> E\<close> ..
    qed (rule \<open>vectorspace E\<close>, rule \<open>subspace H E\<close>, rule y1, rule y2, rule eq)
    then show "y1 = y2" ..
    from c have "a1 \<cdot> x' = a2 \<cdot> x'" ..
    with x' show "a1 = a2" by (simp add: mult_right_cancel)
  qed
qed

text \<open>
  Since for any element \<open>y + a \<cdot> x'\<close> of the direct sum of a vectorspace \<open>H\<close>
  and the linear closure of \<open>x'\<close> the components \<open>y \<in> H\<close> and \<open>a\<close> are unique, it
  follows from \<open>y \<in> H\<close> that \<open>a = 0\<close>.
\<close>

lemma decomp_H'_H:
  assumes "vectorspace E" "subspace H E"
  assumes t: "t \<in> H"
    and x': "x' \<notin> H"  "x' \<in> E"  "x' \<noteq> 0"
  shows "(SOME (y, a). t = y + a \<cdot> x' \<and> y \<in> H) = (t, 0)"
proof -
  interpret vectorspace E by fact
  interpret subspace H E by fact
  show ?thesis
  proof (rule, simp_all only: split_paired_all split_conv)
    from t x' show "t = t + 0 \<cdot> x' \<and> t \<in> H" by simp
    fix y and a assume ya: "t = y + a \<cdot> x' \<and> y \<in> H"
    have "y = t \<and> a = 0"
    proof (rule decomp_H')
      from ya x' show "y + a \<cdot> x' = t + 0 \<cdot> x'" by simp
      from ya show "y \<in> H" ..
    qed (rule \<open>vectorspace E\<close>, rule \<open>subspace H E\<close>, rule t, (rule x')+)
    with t x' show "(y, a) = (y + a \<cdot> x', 0)" by simp
  qed
qed

text \<open>
  The components \<open>y \<in> H\<close> and \<open>a\<close> in \<open>y + a \<cdot> x'\<close> are unique, so the function
  \<open>h'\<close> defined by \<open>h' (y + a \<cdot> x') = h y + a \<cdot> \<xi>\<close> is definite.
\<close>

lemma h'_definite:
  fixes H
  assumes h'_def:
    "\<And>x. h' x =
      (let (y, a) = SOME (y, a). (x = y + a \<cdot> x' \<and> y \<in> H)
       in (h y) + a * xi)"
    and x: "x = y + a \<cdot> x'"
  assumes "vectorspace E" "subspace H E"
  assumes y: "y \<in> H"
    and x': "x' \<notin> H"  "x' \<in> E"  "x' \<noteq> 0"
  shows "h' x = h y + a * xi"
proof -
  interpret vectorspace E by fact
  interpret subspace H E by fact
  from x y x' have "x \<in> H + lin x'" by auto
  have "\<exists>!(y, a). x = y + a \<cdot> x' \<and> y \<in> H" (is "\<exists>!p. ?P p")
  proof (rule ex_ex1I)
    from x y show "\<exists>p. ?P p" by blast
    fix p q assume p: "?P p" and q: "?P q"
    show "p = q"
    proof -
      from p have xp: "x = fst p + snd p \<cdot> x' \<and> fst p \<in> H"
        by (cases p) simp
      from q have xq: "x = fst q + snd q \<cdot> x' \<and> fst q \<in> H"
        by (cases q) simp
      have "fst p = fst q \<and> snd p = snd q"
      proof (rule decomp_H')
        from xp show "fst p \<in> H" ..
        from xq show "fst q \<in> H" ..
        from xp and xq show "fst p + snd p \<cdot> x' = fst q + snd q \<cdot> x'"
          by simp
      qed (rule \<open>vectorspace E\<close>, rule \<open>subspace H E\<close>, (rule x')+)
      then show ?thesis by (cases p, cases q) simp
    qed
  qed
  then have eq: "(SOME (y, a). x = y + a \<cdot> x' \<and> y \<in> H) = (y, a)"
    by (rule some1_equality) (simp add: x y)
  with h'_def show "h' x = h y + a * xi" by (simp add: Let_def)
qed

end


section \<open>Calculating parity efficiently using merge sort\<close>

theory Parity_Merge_Sort
imports Parity_Extras
begin

type_synonym 'a counter = "nat \<times> 'a"

abbreviation bind :: "'a counter \<Rightarrow> ('a \<Rightarrow> 'b counter) \<Rightarrow> 'b counter"
  where "bind m f \<equiv> case m of (c, r) \<Rightarrow> case f r of (c', r') \<Rightarrow> (c + c', r')"

fun
  merge_sorted :: "nat list \<Rightarrow> nat list \<Rightarrow> nat list counter"
where
  "merge_sorted [] ys = (0, ys)"
| "merge_sorted xs [] = (0, xs)"
| "merge_sorted (x # xs) (y # ys)
    = (if x \<le> y
        then bind (merge_sorted xs (y # ys)) (Pair 0               \<circ> op # x)
        else bind (merge_sorted (x # xs) ys) (Pair (1 + length xs) \<circ> op # y))"

lemma merge_sorted_occ:
  "occ (snd (merge_sorted xs ys)) = occ (xs @ ys)"
  by (induct xs ys rule: merge_sorted.induct) (auto simp: append_occ split: prod.splits)

lemma merge_sorted_set:
  "set (snd (merge_sorted xs ys)) = set xs \<union> set ys"
  by (rule equalityI; rule subsetI) (auto simp: occ_member merge_sorted_occ append_occ)

lemma prod_split_case: "P (case p of (x,y) \<Rightarrow> f x y) = P (f (fst p) (snd p))"
  by (auto split: prod.splits)

lemma merge_sorted_sorted_parity:
  "sorted xs \<Longrightarrow> sorted ys
    \<Longrightarrow> sorted (snd (merge_sorted xs ys))
        \<and> parity (xs @ ys) = even (fst (merge_sorted xs ys))"
  proof (induct xs ys rule: merge_sorted.induct)
    case (3 x xs y ys)
      have sorted: "sorted xs" "sorted ys" "\<forall> x' \<in> set xs. x \<le> x'" "\<forall> y' \<in> set ys. y \<le> y'"
        using 3(3,4) by (auto simp: sorted_Cons)
      show ?case
      proof cases
        assume le: "x \<le> y"
        have
          hd: "\<forall> y' \<in> set ys. x \<le> y'" and
          so: "sorted (snd (merge_sorted xs (y # ys)))" and
          pa: "parity (xs @ y # ys) = even (fst (merge_sorted xs (y # ys)))"
          using le sorted 3 by auto
        have "parity (x # xs @ y # ys) = even (fst (merge_sorted (x # xs) (y # ys)))"
          by auto (auto simp: le pa sorted hd prod_split_case filter_le_empty)
        thus ?thesis
          by (auto simp: le prod_split_case merge_sorted_set sorted hd
                 intro!: sorted.Cons[OF _ so])
      next
        assume gt: "\<not> x \<le> y"
        have
          le: "y \<le> x"
              "\<forall> x' \<in> set xs. y \<le> x'" and
          lt: "y < x"
              "\<forall> x' \<in> set xs. y < x'" and
          ts: "sorted (snd (merge_sorted (x # xs) ys))" and
          tp: "parity (x # xs @ ys) = even (fst (merge_sorted (x # xs) ys))"
          using gt sorted 3 by auto
        have sh: "parity (xs @ y # ys) = (parity (xs @ ys) = even (length xs))"
          using lt(2) proof (induct xs)
            case Nil show ?case by (simp add: sorted filter_le_empty)
          qed (simp; blast)
        have "parity (x # xs @ y # ys) = even (fst (merge_sorted (x # xs) (y # ys)))"
          by auto (auto simp: sh gt prod_split_case tp[symmetric])
        thus ?thesis
          by (auto simp: gt le prod_split_case merge_sorted_set sorted
                 intro!: sorted.Cons[OF _ ts])
      qed
  qed (auto dest!: sorted_parity)

lemmas merge_sorted_sorted = conjunct1[OF merge_sorted_sorted_parity]
lemmas merge_sorted_parity = conjunct2[OF merge_sorted_sorted_parity]

lemmas merge_sorted_simps =
  merge_sorted_sorted
  sorted_parity[OF merge_sorted_sorted]
  merge_sorted_parity

fun
  merge_pairs :: "nat list list \<Rightarrow> nat list list counter"
where
  "merge_pairs (xs # ys # zss) =
    bind (merge_sorted xs ys) (\<lambda>zs. bind (merge_pairs zss) (Pair 0 \<circ> op # zs))"
| "merge_pairs xss = (0, xss)"

lemma merge_pairs_occ:
  "occ (concat (snd (merge_pairs zss))) = occ (concat zss)"
  proof (induct zss rule: merge_pairs.induct)
    case (1 xs ys zss) show ?case using 1[OF prod.collapse]
      by (auto simp: merge_sorted_occ append_occ prod_split_case)
  qed auto

lemma sum_list_merge_pairs:
  "(\<Sum> x \<leftarrow> snd (merge_sorted xs ys). length [y \<leftarrow> concat (snd (merge_pairs zss)) . y < x])
    = (\<Sum> x \<leftarrow> xs @ ys. length [y \<leftarrow> concat zss . y < x])"
  by (intro sum_list_cong merge_sorted_occ length_filter_cong merge_pairs_occ refl)

lemma merge_pairs_sorted_parity:
  assumes "\<forall> xs \<in> set xss. sorted xs"
  shows "(\<forall> xs \<in> set (snd (merge_pairs xss)). sorted xs)
            \<and> parity (concat xss) =
                (even (fst (merge_pairs xss)) = parity (concat (snd (merge_pairs xss))))"
        (is "?sorted xss \<and> ?parity xss")
  using assms proof (induct xss rule: merge_pairs.induct)
    case (1 xs ys zss)
    have hyp: "sorted xs" "sorted ys" "\<forall> zs \<in> set zss. sorted zs"
      using 1(2) by auto
    have IH: "?sorted zss" "?parity zss"
      by (auto simp: 1(1)[OF prod.collapse hyp(3)])
    show ?case
      apply (subst concat_cons_cons)
      by (auto simp add: prod_split_case IH merge_sorted_simps[OF hyp(1,2)]
                         parity_app[where xs="xs@ys"]
                         parity_app[where xs="snd (merge_sorted xs ys)"]
                         sum_list_merge_pairs
               simp del: append_assoc map_append)
  qed auto

lemmas merge_pairs_sorted = conjunct1[OF merge_pairs_sorted_parity]
lemmas merge_pairs_parity = conjunct2[OF merge_pairs_sorted_parity]

function (sequential)
  merge_lists :: "nat list list \<Rightarrow> nat list counter"
where
  "merge_lists []   = (0, [])"
| "merge_lists [xs] = (0, xs)"
| "merge_lists xss  = bind (merge_pairs xss) merge_lists"
  by pat_completeness auto

lemma merge_pairs_length_bound: "length (snd (merge_pairs xss)) < Suc (length xss)"
  proof (induct xss rule: merge_pairs.induct)
    case (1 xs ys zss) show ?case
      using 1[OF prod.collapse] by (auto simp: prod_split_case)
  qed auto

termination merge_lists
  by (relation "measure length") (auto simp: prod_split_case merge_pairs_length_bound)

lemma merge_lists_occ:
  "occ (snd (merge_lists xss)) = occ (concat xss)"
  proof (induct xss rule: merge_lists.induct)
    case (3 xs ys zss)
    show ?case using 3[OF prod.collapse]
      by (simp add: add.assoc prod_split_case append_occ merge_sorted_occ merge_pairs_occ)
  qed auto

lemma merge_lists_sorted_parity:
  "\<forall> xs \<in> set xss. sorted xs
    \<Longrightarrow> sorted (snd (merge_lists xss))
        \<and> parity (concat xss) = even (fst (merge_lists xss))"
  proof (induct xss rule: merge_lists.induct)
    case (3 xs ys zss)
    have hyp: "sorted xs" "sorted ys" "\<forall> zs \<in> set zss. sorted zs"
      using 3(2) by auto
    show ?case
      apply (subst concat_cons_cons)
      using 3(1)[OF prod.collapse merge_pairs_sorted, OF 3(2)]
      by (auto simp add: prod_split_case
                         parity_app[where xs="xs@ys"]
                         parity_app[where xs="snd (merge_sorted xs ys)"]
                         merge_sorted_simps[OF hyp(1,2)]
                         merge_pairs_parity[OF hyp(3)]
                         sum_list_merge_pairs
               simp del: append_assoc map_append)
  qed (auto elim: sorted_parity)

lemmas merge_lists_sorted = conjunct1[OF merge_lists_sorted_parity]
lemmas merge_lists_parity = conjunct2[OF merge_lists_sorted_parity]

definition "merge_pre \<equiv> merge_lists \<circ> map (\<lambda>x. [x])"

definition "sort_merge \<equiv> snd \<circ> merge_pre"
definition "parity_merge \<equiv> even \<circ> fst \<circ> merge_pre"

lemma sort_merge_occ: "occ (sort_merge xs) = occ xs"
  by (simp add: sort_merge_def merge_pre_def merge_lists_occ)

lemma sort_merge: "sorted (sort_merge xs)"
  by (simp add: sort_merge_def merge_pre_def merge_lists_sorted)

lemma parity_merge: "parity_merge = parity"
  by (auto simp: parity_merge_def merge_pre_def merge_lists_parity[symmetric])

end


(*<*)theory Star imports Main begin(*>*)

section\<open>The Reflexive Transitive Closure\<close>

text\<open>\label{sec:rtc}
\index{reflexive transitive closure!defining inductively|(}%
An inductive definition may accept parameters, so it can express
functions that yield sets.
Relations too can be defined inductively, since they are just sets of pairs.
A perfect example is the function that maps a relation to its
reflexive transitive closure.  This concept was already
introduced in \S\ref{sec:Relations}, where the operator \<open>\<^sup>*\<close> was
defined as a least fixed point because inductive definitions were not yet
available. But now they are:
\<close>

inductive_set
  rtc :: "('a \<times> 'a)set \<Rightarrow> ('a \<times> 'a)set"   ("_*" [1000] 999)
  for r :: "('a \<times> 'a)set"
where
  rtc_refl[iff]:  "(x,x) \<in> r*"
| rtc_step:       "\<lbrakk> (x,y) \<in> r; (y,z) \<in> r* \<rbrakk> \<Longrightarrow> (x,z) \<in> r*"

text\<open>\noindent
The function \<^term>\<open>rtc\<close> is annotated with concrete syntax: instead of
\<open>rtc r\<close> we can write \<^term>\<open>r*\<close>. The actual definition
consists of two rules. Reflexivity is obvious and is immediately given the
\<open>iff\<close> attribute to increase automation. The
second rule, @{thm[source]rtc_step}, says that we can always add one more
\<^term>\<open>r\<close>-step to the left. Although we could make @{thm[source]rtc_step} an
introduction rule, this is dangerous: the recursion in the second premise
slows down and may even kill the automatic tactics.

The above definition of the concept of reflexive transitive closure may
be sufficiently intuitive but it is certainly not the only possible one:
for a start, it does not even mention transitivity.
The rest of this section is devoted to proving that it is equivalent to
the standard definition. We start with a simple lemma:
\<close>

lemma [intro]: "(x,y) \<in> r \<Longrightarrow> (x,y) \<in> r*"
by(blast intro: rtc_step)

text\<open>\noindent
Although the lemma itself is an unremarkable consequence of the basic rules,
it has the advantage that it can be declared an introduction rule without the
danger of killing the automatic tactics because \<^term>\<open>r*\<close> occurs only in
the conclusion and not in the premise. Thus some proofs that would otherwise
need @{thm[source]rtc_step} can now be found automatically. The proof also
shows that \<open>blast\<close> is able to handle @{thm[source]rtc_step}. But
some of the other automatic tactics are more sensitive, and even \<open>blast\<close> can be lead astray in the presence of large numbers of rules.

To prove transitivity, we need rule induction, i.e.\ theorem
@{thm[source]rtc.induct}:
@{thm[display]rtc.induct}
It says that \<open>?P\<close> holds for an arbitrary pair @{thm (prem 1) rtc.induct}
if \<open>?P\<close> is preserved by all rules of the inductive definition,
i.e.\ if \<open>?P\<close> holds for the conclusion provided it holds for the
premises. In general, rule induction for an $n$-ary inductive relation $R$
expects a premise of the form $(x@1,\dots,x@n) \in R$.

Now we turn to the inductive proof of transitivity:
\<close>

lemma rtc_trans: "\<lbrakk> (x,y) \<in> r*; (y,z) \<in> r* \<rbrakk> \<Longrightarrow> (x,z) \<in> r*"
apply(erule rtc.induct)

txt\<open>\noindent
Unfortunately, even the base case is a problem:
@{subgoals[display,indent=0,goals_limit=1]}
We have to abandon this proof attempt.
To understand what is going on, let us look again at @{thm[source]rtc.induct}.
In the above application of \<open>erule\<close>, the first premise of
@{thm[source]rtc.induct} is unified with the first suitable assumption, which
is \<^term>\<open>(x,y) \<in> r*\<close> rather than \<^term>\<open>(y,z) \<in> r*\<close>. Although that
is what we want, it is merely due to the order in which the assumptions occur
in the subgoal, which it is not good practice to rely on. As a result,
\<open>?xb\<close> becomes \<^term>\<open>x\<close>, \<open>?xa\<close> becomes
\<^term>\<open>y\<close> and \<open>?P\<close> becomes \<^term>\<open>\<lambda>u v. (u,z) \<in> r*\<close>, thus
yielding the above subgoal. So what went wrong?

When looking at the instantiation of \<open>?P\<close> we see that it does not
depend on its second parameter at all. The reason is that in our original
goal, of the pair \<^term>\<open>(x,y)\<close> only \<^term>\<open>x\<close> appears also in the
conclusion, but not \<^term>\<open>y\<close>. Thus our induction statement is too
general. Fortunately, it can easily be specialized:
transfer the additional premise \<^prop>\<open>(y,z)\<in>r*\<close> into the conclusion:\<close>
(*<*)oops(*>*)
lemma rtc_trans[rule_format]:
  "(x,y) \<in> r* \<Longrightarrow> (y,z) \<in> r* \<longrightarrow> (x,z) \<in> r*"

txt\<open>\noindent
This is not an obscure trick but a generally applicable heuristic:
\begin{quote}\em
When proving a statement by rule induction on $(x@1,\dots,x@n) \in R$,
pull all other premises containing any of the $x@i$ into the conclusion
using $\longrightarrow$.
\end{quote}
A similar heuristic for other kinds of inductions is formulated in
\S\ref{sec:ind-var-in-prems}. The \<open>rule_format\<close> directive turns
\<open>\<longrightarrow>\<close> back into \<open>\<Longrightarrow>\<close>: in the end we obtain the original
statement of our lemma.
\<close>

apply(erule rtc.induct)

txt\<open>\noindent
Now induction produces two subgoals which are both proved automatically:
@{subgoals[display,indent=0]}
\<close>

 apply(blast)
apply(blast intro: rtc_step)
done

text\<open>
Let us now prove that \<^term>\<open>r*\<close> is really the reflexive transitive closure
of \<^term>\<open>r\<close>, i.e.\ the least reflexive and transitive
relation containing \<^term>\<open>r\<close>. The latter is easily formalized
\<close>

inductive_set
  rtc2 :: "('a \<times> 'a)set \<Rightarrow> ('a \<times> 'a)set"
  for r :: "('a \<times> 'a)set"
where
  "(x,y) \<in> r \<Longrightarrow> (x,y) \<in> rtc2 r"
| "(x,x) \<in> rtc2 r"
| "\<lbrakk> (x,y) \<in> rtc2 r; (y,z) \<in> rtc2 r \<rbrakk> \<Longrightarrow> (x,z) \<in> rtc2 r"

text\<open>\noindent
and the equivalence of the two definitions is easily shown by the obvious rule
inductions:
\<close>

lemma "(x,y) \<in> rtc2 r \<Longrightarrow> (x,y) \<in> r*"
apply(erule rtc2.induct)
  apply(blast)
 apply(blast)
apply(blast intro: rtc_trans)
done

lemma "(x,y) \<in> r* \<Longrightarrow> (x,y) \<in> rtc2 r"
apply(erule rtc.induct)
 apply(blast intro: rtc2.intros)
apply(blast intro: rtc2.intros)
done

text\<open>
So why did we start with the first definition? Because it is simpler. It
contains only two rules, and the single step rule is simpler than
transitivity.  As a consequence, @{thm[source]rtc.induct} is simpler than
@{thm[source]rtc2.induct}. Since inductive proofs are hard enough
anyway, we should always pick the simplest induction schema available.
Hence \<^term>\<open>rtc\<close> is the definition of choice.
\index{reflexive transitive closure!defining inductively|)}

\begin{exercise}\label{ex:converse-rtc-step}
Show that the converse of @{thm[source]rtc_step} also holds:
@{prop[display]"[| (x,y) \<in> r*; (y,z) \<in> r |] ==> (x,z) \<in> r*"}
\end{exercise}
\begin{exercise}
Repeat the development of this section, but starting with a definition of
\<^term>\<open>rtc\<close> where @{thm[source]rtc_step} is replaced by its converse as shown
in exercise~\ref{ex:converse-rtc-step}.
\end{exercise}
\<close>
(*<*)
lemma rtc_step2[rule_format]: "(x,y) \<in> r* \<Longrightarrow> (y,z) \<in> r \<longrightarrow> (x,z) \<in> r*"
apply(erule rtc.induct)
 apply blast
apply(blast intro: rtc_step)
done

end
(*>*)


theory Permutations_2
imports
  "HOL-Library.Permutations"
  Executable_Permutations
  Graph_Theory.Funpow
begin

section \<open>Modifying Permutations\<close>

abbreviation funswapid :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<rightleftharpoons>\<^sub>F" 90) where
  "x \<rightleftharpoons>\<^sub>F y \<equiv> Fun.swap x y id"

definition perm_swap :: "'a \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" where
  "perm_swap x y f \<equiv> x \<rightleftharpoons>\<^sub>F y o f o x \<rightleftharpoons>\<^sub>F y"

definition perm_rem :: "'a \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" where
  "perm_rem x f \<equiv> if f x \<noteq> x then x \<rightleftharpoons>\<^sub>F f x o f else f"

text \<open>
  An example:

  @{lemma "perm_rem (2 :: nat) (list_succ [1,2,3,4]) x = list_succ [1,3,4] x"
      by (auto simp: perm_rem_def Fun.swap_def list_succ_def)}
\<close>

lemma perm_swap_id[simp]: "perm_swap a b id = id"
  by (auto simp: perm_swap_def)

lemma perm_rem_permutes:
  assumes "f permutes S \<union> {x}"
  shows "perm_rem x f permutes S"
  using assms by (auto simp: permutes_def perm_rem_def) (metis swap_id_eq)+

lemma perm_rem_same:
  assumes "bij f" "f y = y" shows "perm_rem x f y = f y"
  using assms by (auto simp: perm_rem_def swap_id_eq bij_iff)

lemma perm_rem_simps:
  assumes "bij f"
  shows
  "x = y \<Longrightarrow> perm_rem x f y = x"
  "f y = x \<Longrightarrow> perm_rem x f y = f x"
  "y \<noteq> x \<Longrightarrow> f y \<noteq> x \<Longrightarrow> perm_rem x f y = f y"
  using assms
  apply (auto simp: perm_rem_def )
  by (metis bij_iff id_apply swap_apply(3))

lemma bij_swap_compose: "bij (x \<rightleftharpoons>\<^sub>F y o f) \<longleftrightarrow> bij f"
  by (metis UNIV_I bij_betw_comp_iff2 bij_betw_id bij_swap_iff subsetI)

lemma bij_perm_rem[simp]: "bij (perm_rem x f) \<longleftrightarrow> bij f"
  by (simp add: perm_rem_def bij_swap_compose)

lemma perm_rem_conv: "\<And>f x y. bij f \<Longrightarrow> perm_rem x f y = (
    if x = y then x
    else if f y = x then f (f y)
    else f y)"
  by (auto simp: perm_rem_simps)

lemma perm_rem_commutes:
  assumes "bij f" shows "perm_rem a (perm_rem b f) = perm_rem b (perm_rem a f)"
proof -
  have bij_simp: "\<And>x y. f x = f y \<longleftrightarrow> x = y"
    using assms by (auto simp: bij_iff)
  show ?thesis using assms by (auto simp: perm_rem_conv bij_simp fun_eq_iff)
qed

lemma perm_rem_id[simp]: "perm_rem a id = id"
  by (simp add: perm_rem_def)

lemma bij_eq_iff:
  assumes "bij f" shows "f x = f y \<longleftrightarrow> x = y"
  using assms by (metis bij_iff)

lemma swap_swap_id[simp]: "(x \<rightleftharpoons>\<^sub>F y) ((x \<rightleftharpoons>\<^sub>F y) z) = z"
  by (simp add: swap_id_eq)

lemma in_funswapid_image_iff: "\<And>a b x S. x \<in> (a \<rightleftharpoons>\<^sub>F b) ` S \<longleftrightarrow> (a \<rightleftharpoons>\<^sub>F b) x \<in> S"
  by (metis bij_def bij_id bij_swap_iff inj_image_mem_iff swap_swap_id)

lemma perm_swap_comp: "perm_swap a b (f \<circ> g) x = perm_swap a b f (perm_swap a b g x)"
  by (auto simp: perm_swap_def)

lemma bij_perm_swap_iff[simp]: "bij (perm_swap a b f) \<longleftrightarrow> bij f"
  by (auto simp: perm_swap_def bij_swap_compose bij_comp comp_swap)

lemma funpow_perm_swap: "perm_swap a b f ^^ n = perm_swap a b (f ^^ n)"
  by (induct n) (auto simp: perm_swap_def fun_eq_iff)

lemma orbit_perm_swap: "orbit (perm_swap a b f) x = (a \<rightleftharpoons>\<^sub>F b) ` orbit f ((a \<rightleftharpoons>\<^sub>F b) x)"
  by (auto simp: orbit_altdef funpow_perm_swap) (auto simp: perm_swap_def)

lemma has_dom_perm_swap: "has_dom (perm_swap a b f) S = has_dom f ((a \<rightleftharpoons>\<^sub>F b) ` S)"
  by (auto simp: has_dom_def perm_swap_def inj_image_mem_iff) (metis image_iff swap_swap_id)

lemma perm_restrict_dom_subset:
  assumes "has_dom f A" shows "perm_restrict f A = f"
proof -
  from assms have "\<And>x. x \<notin> A \<Longrightarrow> f x = x" by (auto simp: has_dom_def)
  then show ?thesis by (auto simp: perm_restrict_def fun_eq_iff)
qed

lemma has_domD: "has_dom f S \<Longrightarrow> x \<notin> S \<Longrightarrow> f x = x"
  by (auto simp: has_dom_def)

lemma has_domI: "(\<And>x. x \<notin> S \<Longrightarrow> f x = x) \<Longrightarrow> has_dom f S"
  by (auto simp: has_dom_def)

lemma perm_swap_permutes2:
  assumes "f permutes ((x \<rightleftharpoons>\<^sub>F y) ` S)"
  shows "perm_swap x y f permutes S"
  using assms
  by (auto simp: perm_swap_def permutes_conv_has_dom has_dom_perm_swap[unfolded perm_swap_def])
    (metis bij_swap_iff bij_swap_compose_bij comp_id comp_swap)

section \<open>Cyclic Permutations\<close>

lemma cyclic_on_perm_swap:
  assumes "cyclic_on f S" shows "cyclic_on (perm_swap x y f) ((x \<rightleftharpoons>\<^sub>F y) ` S)"
  using assms by (rule cyclic_on_FOO) (auto simp: perm_swap_def swap_swap_id)

lemma orbit_perm_rem:
  assumes "bij f" "x \<noteq> y" shows "orbit (perm_rem y f) x = orbit f x - {y}" (is "?L = ?R")
proof (intro set_eqI iffI)
  fix z assume "z \<in> ?L"
  then show "z \<in> ?R"
    using assms by induct (auto simp: perm_rem_conv bij_iff intro: orbit.intros)
next
  fix z assume A: "z \<in> ?R"

  { assume "z \<in> orbit f x"
    then have "(z \<noteq> y \<longrightarrow> z \<in> ?L) \<and> (z = y \<longrightarrow> f z \<in> ?L)"
    proof induct
      case base with assms show ?case by (auto intro: orbit_eqI(1) simp: perm_rem_conv)
    next
      case (step z) then show ?case
        using assms by (cases "y = z") (auto intro: orbit_eqI simp: perm_rem_conv)
    qed
  } with A show "z \<in> ?L" by auto
qed

lemma orbit_perm_rem_eq:
  assumes "bij f" shows "orbit (perm_rem y f) x = (if x = y then {y} else orbit f x - {y})"
  using assms by (simp add: orbit_eq_singleton_iff orbit_perm_rem perm_rem_simps)

lemma cyclic_on_perm_rem:
  assumes "cyclic_on f S" "bij f" "S \<noteq> {x}" shows "cyclic_on (perm_rem x f) (S - {x})"
  using assms[unfolded cyclic_on_alldef] by (simp add: cyclic_on_def orbit_perm_rem_eq) auto

end


header {*Monotone Convergence*}

theory MonConv
imports Complex_Main
begin

text {* A sensible requirement for an integral operator is that it be
  ``well-behaved'' with respect to limit functions. To become just a
  little more
  precise, it is expected that the limit operator may be interchanged
  with the integral operator under conditions that are as weak as
  possible. To this
  end, the notion of monotone convergence is introduced and later
  applied in the definition of the integral.

  In fact, we distinguish three types of monotone convergence here:
  There are converging sequences of real numbers, real functions and
  sets. Monotone convergence could even be defined more generally for
  any type in the axiomatic type class\footnote{For the concept of axiomatic type
  classes, see \cite{Nipkow93,wenzelax}} @{text ord} of ordered
  types like this.

  @{prop "mon_conv u f \<equiv> (\<forall>n. u n \<le> u (Suc n)) \<and> Sup (range u) = f"}

  However, this employs the general concept of a least upper bound.
  For the special types we have in mind, the more specific
  limit --- respective union --- operators are available, combined with many theorems
  about their properties. For the type of real- (or rather ordered-) valued functions,
  the less-or-equal relation is defined pointwise.

  @{thm le_fun_def [no_vars]}
  *}

(*monotone convergence*)

text {*Now the foundations are laid for the definition of monotone
  convergence. To express the similarity of the different types of
  convergence, a single overloaded operator is used.*}

consts
  mon_conv:: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a::ord \<Rightarrow> bool" ("_\<up>_" [60,61] 60)

defs (overloaded)
  real_mon_conv: "x\<up>(y::real) \<equiv> (\<forall>n. x n \<le> x (Suc n)) \<and> x ----> y"
  realfun_mon_conv:
  "u\<up>(f::'a \<Rightarrow> real) \<equiv> (\<forall>n. u n \<le> u (Suc n)) \<and>  (\<forall>w. (\<lambda>n. u n w) ----> f w)"
  set_mon_conv: "A\<up>(B::'a set) \<equiv> (\<forall>n. A n \<le> A (Suc n)) \<and> B = (\<Union>n. A n)"

theorem realfun_mon_conv_iff: "(u\<up>f) = (\<forall>w. (\<lambda>n. u n w)\<up>((f w)::real))"
  by (auto simp add: real_mon_conv realfun_mon_conv le_fun_def)

text {* The long arrow signifies convergence of real sequences as
  defined in the theory @{text SEQ} \cite{Fleuriot:2000:MNR}. Monotone convergence
  for real functions is simply pointwise monotone convergence.

  Quite a few properties of these definitions will be necessary later,
  and they are listed now, giving only few select proofs. *}

    (*This theorem, too, could be proved just the same for any ord
  Type!*)

lemma assumes mon_conv: "x\<up>(y::real)"
  shows mon_conv_mon: "(x i) \<le> (x (m+i))"
(*<*)proof (induct m)
  case 0
  show ?case by simp

next
  case (Suc n)
  also
  from mon_conv have "x (n+i) \<le> x (Suc n+i)"
    by (simp add: real_mon_conv)
  finally show ?case .
qed(*>*)

lemma limseq_shift_iff: "(\<lambda>m. x (m+i)) ----> y = x ----> y"
(*<*)proof (induct i)
  case 0 show ?case by simp
next
  case (Suc n)
  also have "(\<lambda>m. x (m + n)) ----> y = (\<lambda>m. x (Suc m + n)) ----> y"
    by (rule LIMSEQ_Suc_iff[THEN sym])
  also have "\<dots> = (\<lambda>m. x (m + Suc n)) ----> y"
    by simp
  finally show ?case .
qed(*>*)

    (*This, too, could be established in general*)
theorem assumes mon_conv: "x\<up>(y::real)"
  shows real_mon_conv_le: "x i \<le> y"
proof -
  from mon_conv have "(\<lambda>m. x (m+i)) ----> y"
    by (simp add: real_mon_conv limseq_shift_iff)
  also from mon_conv have "\<forall>m\<ge>0. x i \<le> x (m+i)" by (simp add: mon_conv_mon)
  ultimately show ?thesis by (rule LIMSEQ_le_const[OF _ exI[where x=0]])
qed

theorem assumes mon_conv: "x\<up>(y::('a \<Rightarrow> real))"
  shows realfun_mon_conv_le: "x i \<le> y"
proof -
  {fix w
    from mon_conv have "(\<lambda>i. x i w)\<up>(y w)"
      by (simp add: realfun_mon_conv_iff)
    hence "x i w \<le> y w"
      by (rule real_mon_conv_le)
  }
  thus ?thesis by (simp add: le_fun_def)
qed

lemma assumes mon_conv: "x\<up>(y::real)"
  and less: "z < y"
  shows real_mon_conv_outgrow: "\<exists>n. \<forall>m. n \<le> m \<longrightarrow> z < x m"
proof -
  from less have less': "0 < y-z"
    by simp
  have "\<exists>n.\<forall>m. n \<le> m \<longrightarrow> \<bar>x m - y\<bar> < y - z"
  proof -
    from mon_conv have aux: "\<And>r. r > 0 \<Longrightarrow> \<exists>n. \<forall>m. n \<le> m \<longrightarrow> \<bar>x m - y\<bar> < r"
    unfolding real_mon_conv LIMSEQ_def dist_real_def by auto
    with less' show "\<exists>n. \<forall>m. n \<le> m \<longrightarrow> \<bar>x m - y\<bar> < y - z" by auto
  qed
  also
  { fix m
    from mon_conv have "x m \<le> y"
      by (rule real_mon_conv_le)
    hence "\<bar>x m - y\<bar> = y - x m"
      by arith
    also assume "\<bar>x m - y\<bar> < y - z"
    ultimately have "z < x m"
      by arith
  }
  ultimately show ?thesis
    by blast
qed

theorem real_mon_conv_times:
  assumes xy: "x\<up>(y::real)" and nn: "0\<le>z"
  shows "(\<lambda>m. z*x m)\<up>(z*y)"
(*<*)proof -
  from assms have "\<And>n. z*x n \<le> z*x (Suc n)"
    by (simp add: real_mon_conv mult_left_mono)
  also from xy have "(\<lambda>m. z*x m)---->(z*y)"
    by (simp add: real_mon_conv tendsto_const tendsto_mult)
  ultimately show ?thesis by (simp add: real_mon_conv)
qed(*>*)

theorem realfun_mon_conv_times:
  assumes xy: "x\<up>(y::'a\<Rightarrow>real)" and nn: "0\<le>z"
  shows "(\<lambda>m w. z*x m w)\<up>(\<lambda>w. z*y w)"
(*<*)proof -
  from assms have "\<And>w. (\<lambda>m. z*x m w)\<up>(z*y w)"
    by (simp add: realfun_mon_conv_iff real_mon_conv_times)
  thus ?thesis by (auto simp add: realfun_mon_conv_iff)
qed(*>*)

theorem real_mon_conv_add:
  assumes xy: "x\<up>(y::real)" and ab: "a\<up>(b::real)"
  shows "(\<lambda>m. x m + a m)\<up>(y + b)"
(*<*)proof -
  { fix n
    from assms have "x n \<le> x (Suc n)" and "a n \<le> a (Suc n)"
      by (simp_all add: real_mon_conv)
    hence "x n + a n \<le> x (Suc n) + a (Suc n)"
      by simp
  }
  also from assms have "(\<lambda>m. x m + a m)---->(y + b)" by (simp add: real_mon_conv tendsto_add)
  ultimately show ?thesis by (simp add: real_mon_conv)
qed(*>*)

theorem realfun_mon_conv_add:
  assumes xy: "x\<up>(y::'a\<Rightarrow>real)" and ab: "a\<up>(b::'a \<Rightarrow> real)"
  shows "(\<lambda>m w. x m w + a m w)\<up>(\<lambda>w. y w + b w)"
(*<*)proof -
  from assms have "\<And>w. (\<lambda>m. x m w + a m w)\<up>(y w + b w)"
    by (simp add: realfun_mon_conv_iff real_mon_conv_add)
  thus ?thesis by (auto simp add: realfun_mon_conv_iff)
qed(*>*)

theorem real_mon_conv_bound:
  assumes mon: "\<And>n. c n \<le> c (Suc n)"
  and bound: "\<And>n. c n \<le> (x::real)"
  shows "\<exists>l. c\<up>l \<and> l\<le>x"
proof -
  from incseq_convergent[of c x] mon bound
  obtain l where "c ----> l" "\<forall>i. c i \<le> l"
    by (auto simp: incseq_Suc_iff)
  moreover -- {*This is like $\isacommand{also}$ but lacks the transitivity step.*}
  with bound have "l \<le> x"
    by (intro LIMSEQ_le_const2) auto
  ultimately show ?thesis
    by (auto simp: real_mon_conv mon)
qed

theorem real_mon_conv_dom:
  assumes xy: "x\<up>(y::real)" and mon: "\<And>n. c n \<le> c (Suc n)"
  and dom: "c \<le> x"
  shows "\<exists>l. c\<up>l \<and> l\<le>y"
proof -
  from dom have "\<And>n. c n \<le> x n" by (simp add: le_fun_def)
  also from xy have "\<And>n. x n \<le> y" by (simp add: real_mon_conv_le)
  also note mon
  ultimately show ?thesis by (simp add: real_mon_conv_bound)
qed

text{*\newpage*}
theorem realfun_mon_conv_bound:
  assumes mon: "\<And>n. c n \<le> c (Suc n)"
  and bound: "\<And>n. c n \<le> (x::'a \<Rightarrow> real)"
  shows "\<exists>l. c\<up>l \<and> l\<le>x"
(*<*)proof
  def r \<equiv> "\<lambda>t. SOME l. (\<lambda>n. c n t)\<up>l \<and> l\<le>x t"
  { fix t
    from mon have m2: "\<And>n. c n t \<le> c (Suc n) t" by (simp add: le_fun_def)
    also
    from bound have "\<And>n. c n t \<le> x t" by (simp add: le_fun_def)

    ultimately have "\<exists>l. (\<lambda>n. c n t)\<up>l \<and> l\<le>x t" (is "\<exists>l. ?P l")
      by (rule real_mon_conv_bound)
    hence "?P (SOME l. ?P l)" by (rule someI_ex)
    hence "(\<lambda>n. c n t)\<up>r t \<and> r t\<le>x t" by (simp add: r_def)
  }
  thus "c\<up>r \<and> r \<le> x" by (simp add: realfun_mon_conv_iff le_fun_def)
qed (*>*)

text {*This brings the theory to an end. Notice how the definition of the limit of a
  real sequence is visible in the proof to @{text
  real_mon_conv_outgrow}, a lemma that will be used for a
  monotonicity proof of the integral of simple functions later on.*}(*<*)
  (*Another set construction. Needed in ImportPredSet, but Set is shadowed beyond
  reconstruction there.
  Before making disjoint, we first need an ascending series of sets*)

primrec mk_mon::"(nat \<Rightarrow> 'a set) \<Rightarrow> nat \<Rightarrow> 'a set"
where
  "mk_mon A 0 = A 0"
| "mk_mon A (Suc n) = A (Suc n) \<union> mk_mon A n"

lemma "mk_mon A \<up> (\<Union>i. A i)"
proof (unfold set_mon_conv)
  { fix n
    have "mk_mon A n \<subseteq> mk_mon A (Suc n)"
      by auto
  }
  also
  have "(\<Union>i. mk_mon A i) = (\<Union>i. A i)"
  proof
    { fix i x
      assume "x \<in> mk_mon A i"
      hence "\<exists>j. x \<in> A j"
        by (induct i) auto
      hence "x \<in> (\<Union>i. A i)"
        by simp
    }
    thus "(\<Union>i. mk_mon A i) \<subseteq> (\<Union>i. A i)"
      by auto

    { fix i
      have "A i \<subseteq> mk_mon A i"
        by (induct i) auto
    }
    thus "(\<Union>i. A i) \<subseteq> (\<Union>i. mk_mon A i)"
      by auto
  qed
  ultimately show "(\<forall>n. mk_mon A n \<subseteq> mk_mon A (Suc n)) \<and> UNION UNIV A = (\<Union>n. mk_mon A n)"
    by simp
qed(*>*)

end


theory Gronwall
imports Vector_Derivative_On
begin

subsection \<open>Gronwall\<close>

lemma derivative_quotient_bound:
  assumes g_deriv_on: "(g has_vderiv_on g') {a .. b}"
  assumes frac_le: "\<And>t. t \<in> {a .. b} \<Longrightarrow> g' t / g t \<le> K"
  assumes g'_cont: "continuous_on {a .. b} g'"
  assumes g_pos: "\<And>t. t \<in> {a .. b} \<Longrightarrow> g t > 0"
  assumes t_in: "t \<in> {a .. b}"
  shows "g t \<le> g a * exp (K * (t - a))"
proof -
  have g_deriv: "\<And>t. t \<in> {a .. b} \<Longrightarrow> (g has_real_derivative g' t) (at t within {a .. b})"
    using g_deriv_on
    by (auto simp: has_vderiv_on_def has_real_derivative_iff_has_vector_derivative[symmetric])
  from assms have g_nonzero: "\<And>t. t \<in> {a .. b} \<Longrightarrow> g t \<noteq> 0"
    by fastforce
  have frac_integrable: "\<And>t. t \<in> {a .. b} \<Longrightarrow> (\<lambda>t. g' t / g t) integrable_on {a..t}"
    by (force simp: g_nonzero intro: assms has_field_derivative_subset[OF g_deriv]
      continuous_on_subset[OF g'_cont] continuous_intros integrable_continuous_real
      continuous_on_subset[OF vderiv_on_continuous_on[OF g_deriv_on]])
  have "\<And>t. t \<in> {a..b} \<Longrightarrow> ((\<lambda>t. g' t / g t) has_integral ln (g t) - ln (g a)) {a .. t}"
    by (rule fundamental_theorem_of_calculus)
      (auto intro!: derivative_eq_intros assms has_field_derivative_subset[OF g_deriv]
        simp: has_real_derivative_iff_has_vector_derivative[symmetric])
  hence *: "\<And>t. t \<in> {a .. b} \<Longrightarrow> ln (g t) - ln (g a) = integral {a .. t} (\<lambda>t. g' t / g t)"
    using integrable_integral[OF frac_integrable]
    by (rule has_integral_unique[where f = "\<lambda>t. g' t / g t"])
  from * t_in have "ln (g t) - ln (g a) = integral {a .. t} (\<lambda>t. g' t / g t)" .
  also have "\<dots> \<le> integral {a .. t} (\<lambda>_. K)"
    using \<open>t \<in> {a .. b}\<close>
    by (intro integral_le) (auto intro!: frac_integrable frac_le integral_le)
  also have "\<dots> = K * (t - a)" using \<open>t \<in> {a .. b}\<close>
    by simp
  finally have "ln (g t) \<le> K * (t - a) + ln (g a)" (is "?lhs \<le> ?rhs")
    by simp
  hence "exp ?lhs \<le> exp ?rhs"
    by simp
  thus ?thesis
    using \<open>t \<in> {a .. b}\<close> g_pos
    by (simp add: ac_simps exp_add del: exp_le_cancel_iff)
qed

lemma derivative_quotient_bound_left:
  assumes g_deriv_on: "(g has_vderiv_on g') {a .. b}"
  assumes frac_ge: "\<And>t. t \<in> {a .. b} \<Longrightarrow> K \<le> g' t / g t"
  assumes g'_cont: "continuous_on {a .. b} g'"
  assumes g_pos: "\<And>t. t \<in> {a .. b} \<Longrightarrow> g t > 0"
  assumes t_in: "t \<in> {a..b}"
  shows "g t \<le> g b * exp (K * (t - b))"
proof -
  have g_deriv: "\<And>t. t \<in> {a .. b} \<Longrightarrow> (g has_real_derivative g' t) (at t within {a .. b})"
    using g_deriv_on
    by (auto simp: has_vderiv_on_def has_real_derivative_iff_has_vector_derivative[symmetric])
  from assms have g_nonzero: "\<And>t. t \<in> {a..b} \<Longrightarrow> g t \<noteq> 0"
    by fastforce
  have frac_integrable: "\<And>t. t \<in> {a .. b} \<Longrightarrow> (\<lambda>t. g' t / g t) integrable_on {t..b}"
    by (force simp: g_nonzero intro: assms has_field_derivative_subset[OF g_deriv]
      continuous_on_subset[OF g'_cont] continuous_intros integrable_continuous_real
      continuous_on_subset[OF vderiv_on_continuous_on[OF g_deriv_on]])
  have "\<And>t. t \<in> {a..b} \<Longrightarrow> ((\<lambda>t. g' t / g t) has_integral ln (g b) - ln (g t)) {t..b}"
    by (rule fundamental_theorem_of_calculus)
      (auto intro!: derivative_eq_intros assms has_field_derivative_subset[OF g_deriv]
        simp: has_real_derivative_iff_has_vector_derivative[symmetric])
  hence *: "\<And>t. t \<in> {a..b} \<Longrightarrow> ln (g b) - ln (g t) = integral {t..b} (\<lambda>t. g' t / g t)"
    using integrable_integral[OF frac_integrable]
    by (rule has_integral_unique[where f = "\<lambda>t. g' t / g t"])
  have "K * (b - t) = integral {t..b} (\<lambda>_. K)"
    using \<open>t \<in> {a..b}\<close>
    by simp
  also have "... \<le> integral {t..b} (\<lambda>t. g' t / g t)"
    using \<open>t \<in> {a..b}\<close>
    by (intro integral_le) (auto intro!: frac_integrable frac_ge integral_le)
  also have "... = ln (g b) - ln (g t)"
    using * t_in by simp
  finally have "K * (b - t) + ln (g t) \<le> ln (g b)" (is "?lhs \<le> ?rhs")
    by simp
  hence "exp ?lhs \<le> exp ?rhs"
    by simp
  hence "g t * exp (K * (b - t)) \<le> g b"
    using \<open>t \<in> {a..b}\<close> g_pos
    by (simp add: ac_simps exp_add del: exp_le_cancel_iff)
  hence "g t / exp (K * (t - b)) \<le> g b"
    by (simp add: algebra_simps exp_diff)
  thus ?thesis
    by (simp add: field_simps)
qed

lemma gronwall_general:
  fixes g K C a b and t::real
  defines "G \<equiv> \<lambda>t. C + K * integral {a..t} (\<lambda>s. g s)"
  assumes g_le_G: "\<And>t. t \<in> {a..b} \<Longrightarrow> g t \<le> G t"
  assumes g_cont: "continuous_on {a..b} g"
  assumes g_nonneg: "\<And>t. t \<in> {a..b} \<Longrightarrow> 0 \<le> g t"
  assumes pos: "0 < C" "K > 0"
  assumes "t \<in> {a..b}"
  shows "g t \<le> C * exp (K * (t - a))"
proof -
  have G_pos: "\<And>t. t \<in> {a..b} \<Longrightarrow> 0 < G t"
    by (auto simp: G_def intro!: add_pos_nonneg mult_nonneg_nonneg Henstock_Kurzweil_Integration.integral_nonneg
      integrable_continuous_real assms intro: less_imp_le continuous_on_subset)
  have "g t \<le> G t" using assms by auto
  also
  {
    have "(G has_vderiv_on (\<lambda>t. K * g t)) {a..b}"
      by (auto intro!: derivative_eq_intros integral_has_vector_derivative g_cont
        simp add: G_def has_vderiv_on_def)
    moreover
    {
      fix t assume "t \<in> {a..b}"
      hence "K * g t / G t \<le> K * G t / G t"
        using pos g_le_G G_pos
        by (intro divide_right_mono mult_left_mono) (auto intro!: less_imp_le)
      also have "\<dots> = K"
        using G_pos[of t] \<open>t \<in> {a .. b}\<close> by simp
      finally have "K * g t / G t \<le> K" .
    }
    ultimately have "G t \<le> G a * exp (K * (t - a))"
      apply (rule derivative_quotient_bound)
      using \<open>t \<in> {a..b}\<close>
      by (auto intro!: continuous_intros g_cont G_pos simp: field_simps pos)
  }
  also have "G a = C"
    by (simp add: G_def)
  finally show ?thesis
    by simp
qed

lemma gronwall_general_left:
  fixes g K C a b and t::real
  defines "G \<equiv> \<lambda>t. C + K * integral {t..b} (\<lambda>s. g s)"
  assumes g_le_G: "\<And>t. t \<in> {a..b} \<Longrightarrow> g t \<le> G t"
  assumes g_cont: "continuous_on {a..b} g"
  assumes g_nonneg: "\<And>t. t \<in> {a..b} \<Longrightarrow> 0 \<le> g t"
  assumes pos: "0 < C" "K > 0"
  assumes "t \<in> {a..b}"
  shows "g t \<le> C * exp (-K * (t - b))"
proof -
  have G_pos: "\<And>t. t \<in> {a..b} \<Longrightarrow> 0 < G t"
    by (auto simp: G_def intro!: add_pos_nonneg mult_nonneg_nonneg Henstock_Kurzweil_Integration.integral_nonneg
      integrable_continuous_real assms intro: less_imp_le continuous_on_subset)
  have "g t \<le> G t" using assms by auto
  also
  {
    have "(G has_vderiv_on (\<lambda>t. -K * g t)) {a..b}"
      by (auto intro!: derivative_eq_intros g_cont integral_has_vector_derivative'
          simp add: G_def has_vderiv_on_def)
    moreover
    {
      fix t assume "t \<in> {a..b}"
      hence "K * g t / G t \<le> K * G t / G t"
        using pos g_le_G G_pos
        by (intro divide_right_mono mult_left_mono) (auto intro!: less_imp_le)
      also have "\<dots> = K"
        using G_pos[of t] \<open>t \<in> {a .. b}\<close> by simp
      finally have "K * g t / G t \<le> K" .
      hence "-K \<le> -K * g t / G t"
        by simp
    }
    ultimately
    have "G t \<le> G b * exp (-K * (t - b))"
      apply (rule derivative_quotient_bound_left)
      using \<open>t \<in> {a..b}\<close>
      by (auto intro!: continuous_intros g_cont G_pos simp: field_simps pos)
  }
  also have "G b = C"
    by (simp add: G_def)
  finally show ?thesis
    by simp
qed

lemma gronwall_general_segment:
  fixes a b::real
  assumes "\<And>t. t \<in> closed_segment a b \<Longrightarrow> g t \<le> C + K * integral (closed_segment a t) g"
    and "continuous_on (closed_segment a b) g"
    and "\<And>t. t \<in> closed_segment a b \<Longrightarrow> 0 \<le> g t"
    and "0 < C"
    and "0 < K"
    and "t \<in> closed_segment a b"
  shows "g t \<le> C * exp (K * abs (t - a))"
proof cases
  assume "a \<le> b"
  then have *: "abs (t - a) = t -a" using assms by (auto simp: closed_segment_eq_real_ivl)
  show ?thesis
    unfolding *
    using assms
    by (intro gronwall_general[where b=b]) (auto intro!: simp: closed_segment_eq_real_ivl \<open>a \<le> b\<close>)
next
  assume "\<not>a \<le> b"
  then have *: "K * abs (t - a) = - K * (t - a)" using assms by (auto simp: closed_segment_eq_real_ivl algebra_simps)
  {
    fix s :: real
    assume a1: "b \<le> s"
    assume a2: "s \<le> a"
    assume a3: "\<And>t. b \<le> t \<and> t \<le> a \<Longrightarrow> g t \<le> C + K * integral (if a \<le> t then {a..t} else {t..a}) g"
    have "s = a \<or> s < a"
      using a2 by (meson less_eq_real_def)
    then have "g s \<le> C + K * integral {s..a} g"
      using a3 a1 by fastforce
  } then show ?thesis
    unfolding *
    using assms  \<open>\<not>a \<le> b\<close>
    by (intro gronwall_general_left)
      (auto intro!: simp: closed_segment_eq_real_ivl)
qed

lemma gronwall_more_general_segment:
  fixes a b c::real
  assumes "\<And>t. t \<in> closed_segment a b \<Longrightarrow> g t \<le> C + K * integral (closed_segment c t) g"
    and cont: "continuous_on (closed_segment a b) g"
    and "\<And>t. t \<in> closed_segment a b \<Longrightarrow> 0 \<le> g t"
    and "0 < C"
    and "0 < K"
    and t: "t \<in> closed_segment a b"
    and c: "c \<in> closed_segment a b"
  shows "g t \<le> C * exp (K * abs (t - c))"
proof -
  from t c have "t \<in> closed_segment c a \<or> t \<in> closed_segment c b"
    by (auto simp: closed_segment_eq_real_ivl split_ifs)
  then show ?thesis
  proof
    assume "t \<in> closed_segment c a"
    moreover
    have subs: "closed_segment c a \<subseteq> closed_segment a b" using t c
      by (auto simp: closed_segment_eq_real_ivl split_ifs)
    ultimately show ?thesis
      by (intro gronwall_general_segment[where b=a])
        (auto intro!: assms intro: continuous_on_subset)
  next
    assume "t \<in> closed_segment c b"
    moreover
    have subs: "closed_segment c b \<subseteq> closed_segment a b" using t c
      by (auto simp: closed_segment_eq_real_ivl)
    ultimately show ?thesis
      by (intro gronwall_general_segment[where b=b])
        (auto intro!: assms intro: continuous_on_subset)
  qed
qed

lemma gronwall:
  fixes g K C and t::real
  defines "G \<equiv> \<lambda>t. C + K * integral {0..t} (\<lambda>s. g s)"
  assumes g_le_G: "\<And>t. 0 \<le> t \<Longrightarrow> t \<le> a \<Longrightarrow> g t \<le> G t"
  assumes g_cont: "continuous_on {0..a} g"
  assumes g_nonneg: "\<And>t. 0 \<le> t \<Longrightarrow> t \<le> a \<Longrightarrow> 0 \<le> g t"
  assumes pos: "0 < C" "0 < K"
  assumes "0 \<le> t" "t \<le> a"
  shows "g t \<le> C * exp (K * t)"
  apply(rule gronwall_general[where a=0, simplified, OF assms(2-6)[unfolded G_def]])
  using assms(7,8)
  by simp_all

lemma gronwall_left:
  fixes g K C and t::real
  defines "G \<equiv> \<lambda>t. C + K * integral {t..0} (\<lambda>s. g s)"
  assumes g_le_G: "\<And>t. a \<le> t \<Longrightarrow> t \<le> 0 \<Longrightarrow> g t \<le> G t"
  assumes g_cont: "continuous_on {a..0} g"
  assumes g_nonneg: "\<And>t. a \<le> t \<Longrightarrow> t \<le> 0 \<Longrightarrow> 0 \<le> g t"
  assumes pos: "0 < C" "0 < K"
  assumes "a \<le> t" "t \<le> 0"
  shows "g t \<le> C * exp (-K * t)"
  apply(simp, rule gronwall_general_left[where b=0, simplified, OF assms(2-6)[unfolded G_def]])
  using assms(7,8)
  by simp_all

end


(*
    $Id: sol.thy,v 1.5 2012/01/04 13:40:21 webertj Exp $
    Author: Tobias Nipkow
*)

header {* Context-Free Grammars *}

(*<*) theory sol imports Main begin (*>*)

text {* This exercise is concerned with context-free grammars (CFGs).
Please read Section~7.4 in the tutorial which explains how to model
CFGs as inductive definitions.  Our particular example is about
defining valid sequences of parentheses. *}

subsection {* Two grammars *}

text {* The most natural definition of valid sequences of parentheses is this:
\[ S \quad\to\quad \varepsilon \quad\mid\quad '('~S~')' \quad\mid\quad S~S \]
where $\varepsilon$ is the empty word.

A second, somewhat unusual grammar is the following one:
\[ T \quad\to\quad \varepsilon \quad\mid\quad T~'('~T~')' \]

Model both grammars as inductive sets $S$ and $T$ and prove $S = T$. *}

text {* The alphabet: *}

datatype alpha = A | B

text {* Standard grammar: *}

inductive_set S :: "alpha list set" where
S1: "[] : S" |
S2: "w : S \<Longrightarrow> A#w@[B] : S" |
S3: "v : S \<Longrightarrow> w : S \<Longrightarrow> v @ w : S"

declare S1 [iff] S2[intro!,simp]

text {* Nonstandard grammar: *}

inductive_set T :: "alpha list set" where
T1: "[] : T" |
T23: "v : T \<Longrightarrow> w : T \<Longrightarrow> v @ A # w @ [B]: T"

declare T1 [iff]

text {* @{text T} is a subset of @{text S}: *}

lemma T2S: "w : T \<Longrightarrow> w : S"
  apply (erule T.induct)
    apply simp
  apply (blast intro: S3)
done

text {* @{text S} is a subset of @{text T}: *}

lemma T2: "w : T \<Longrightarrow> A#w@[B] : T"
  using T23[where v = "[]"] by simp

lemma T3: "v : T \<Longrightarrow> u : T \<Longrightarrow> u@v : T"
  apply (erule T.induct)
    apply fastforce
  apply (simp add: append_assoc[symmetric] del:append_assoc)
  apply (blast intro: T23)
done

lemma S2T: "w : S \<Longrightarrow> w : T"
  apply (erule S.induct)
      apply simp
    apply (blast intro: T2)
  apply (blast intro: T3)
done

text {* @{text "S = T"}: *}

lemma "S = T"
  by (blast intro: S2T T2S)

subsection {* A recursive function *}

text {* Instead of a grammar, we can also define valid sequences of
parentheses via a test function:  traverse the word from left to right
while counting how many closing parentheses are still needed.  If the
counter is 0 at the end, the sequence is valid.

Define this recursive function and prove that a word is in $S$ iff it
is accepted by your function.  The $\Longrightarrow$ direction is easy,
the other direction more complicated. *}

fun balanced :: "alpha list \<Rightarrow> nat \<Rightarrow> bool" where
  "balanced []    0       = True"
| "balanced (A#w) n       = balanced w (Suc n)"
| "balanced (B#w) (Suc n) = balanced w n"
| "balanced w     n       = False"

text {* Correctness of the recognizer w.r.t.\ @{text S}: *}

lemma [simp]: "\<lbrakk>balanced v n; balanced w 0\<rbrakk> \<Longrightarrow> balanced (v @ w) n"
  apply (induct v n rule: balanced.induct)
  apply simp_all
done

lemma "w : S \<Longrightarrow> balanced w 0"
  apply (erule S.induct)
  apply simp_all
done

text {* Completeness of the recognizer w.r.t.\ @{text S}: *}

lemma AB: assumes u: "u \<in> S" shows "\<And>v w. u = v@w \<Longrightarrow> v @ A # B # w \<in> S"
using u
proof(induct)
  case S1 thus ?case by simp
next
  case (S2 u)
  have uS: "u \<in> S" and
       IH: "\<And>v w. u = v @ w \<Longrightarrow> v @ A # B # w \<in> S" and
       asm: "A # u @ [B] = v @ w" by fact+
  show "v @ A # B # w \<in> S"
  proof (cases v)
    case Nil
    hence "w = A # u @ [B]" using asm by simp
    hence "w \<in> S" using uS by simp
    hence "[A,B] @ w \<in> S" by(blast intro:S3)
    thus ?thesis using Nil by simp
  next
    case (Cons x v')
    show ?thesis
    proof (cases w rule:rev_cases)
      case Nil
      from uS have "(A # u @ [B]) @ [A,B] \<in> S" by(blast intro:S3)
      thus ?thesis using Nil Cons asm by auto
    next
      case (snoc w' y)
      hence u: "u = v' @ w'" and [simp]: "x = A & y = B"
	using Cons asm by auto
      from u have "v' @ A # B # w' \<in> S" by(rule IH)
      hence "A # (v' @ A # B # w') @ [B] \<in> S" by(rule S.S2)
      thus ?thesis using Cons snoc by auto
    qed
  qed
next
  case (S3 v' w')
  have v'S: "v' \<in> S" and w'S: "w' \<in> S"
   and IHv: "\<And>v w. v' = v @ w \<Longrightarrow> v @ A # B # w \<in> S"
   and IHw: "\<And>v w. w' = v @ w \<Longrightarrow> v @ A # B # w \<in> S"
   and asm: "v' @ w' = v @ w" by fact+
  then obtain r where "v' = v @ r \<and> r @ w' = w \<or> v' @ r = v \<and> w' = r @ w"
    (is "?A \<or> ?B")
    by (auto simp:append_eq_append_conv2)
  thus "v @ A # B # w \<in> S"
  proof
    assume A: ?A
    hence "v @ A # B # r \<in> S" using IHv by blast
    hence "(v @ A # B # r) @ w' \<in> S" using w'S by(rule S.S3)
    thus ?thesis using A by auto
  next
    assume B: ?B
    hence "r @ A # B # w \<in> S" using IHw by blast
    with v'S have "v' @ (r @ A # B # w) \<in> S" by(rule S.S3)
    thus ?thesis using B by auto
  qed
qed

text {* The same lemma for friends of the apply style: *}

lemma "u \<in> S \<Longrightarrow> ALL v w. u = v@w \<longrightarrow> v @ A # B # w \<in> S"
apply(erule S.induct)
  apply simp
 apply(rename_tac u)
 apply (clarsimp simp:Cons_eq_append_conv)
 apply(rule conjI)
  apply (clarsimp)
  apply(subgoal_tac "[A,B] @ (A # u @ [B]) : S")
   apply(simp)
  apply(blast intro:S3)
 apply(clarsimp simp:append_eq_append_conv2 Cons_eq_append_conv)
 apply(rename_tac w w1 w2)
 apply(erule disjE)
  apply clarsimp
  apply(subgoal_tac "A # (w1 @ A # B # w2) @ [B] : S")
   apply simp
  apply(blast intro:S3)
 apply clarsimp
 apply(erule disjE)
  apply clarsimp
  apply(subgoal_tac "A # (u @ [A,B]) @ [B] : S")
   apply(simp)
  apply(blast intro:S3)
 apply clarsimp
 apply(subgoal_tac "(A # u @ [B]) @ [A,B] : S")
  apply(simp)
 apply(blast intro:S3)
apply(clarsimp simp:append_eq_append_conv2)
apply(rename_tac u v w x y)
apply(erule disjE)
 apply clarsimp
 apply(subgoal_tac "(w @ A # B # y) @ v : S")
  apply(simp)
 apply(blast intro:S3)
apply clarsimp
apply(blast intro:S3)
done

lemma "balanced w n \<Longrightarrow> replicate n A @ w : S"
  apply (induct w n rule: balanced.induct)
  apply simp_all
    apply (simp add: replicate_app_Cons_same)
  apply (simp add: AB replicate_app_Cons_same[symmetric])
done

(*<*) end (*>*)