(* 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_bin_plus
imports "../../Test_Base"
begin

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun toNat :: "Bin => int" where
"toNat (One) = 1"
| "toNat (ZeroAnd xs) = (toNat xs) + (toNat xs)"
| "toNat (OneAnd ys) = (1 + (toNat ys)) + (toNat ys)"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus :: "Bin => Bin => Bin" where
"plus (One) y = s y"
| "plus (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus z ys)"
| "plus (ZeroAnd z) (OneAnd xs) = OneAnd (plus z xs)"
| "plus (OneAnd x2) (One) = s (OneAnd x2)"
| "plus (OneAnd x2) (ZeroAnd zs) = OneAnd (plus x2 zs)"
| "plus (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus x2 ys2))"

theorem property0 :
  "((toNat (plus x y)) = ((toNat x) + (toNat y)))"
  oops

end


theory Ex024
  imports Main
begin

lemma "(A \<longleftrightarrow> B) \<longleftrightarrow> (\<not>A \<longleftrightarrow> \<not>B)"
proof -
  {
    assume a:"A \<longleftrightarrow> B"
    hence b:"A \<longrightarrow> B" by (rule iffE)
    from a have c:"B \<longrightarrow> A" by (rule iffE)
    {
      assume d:"\<not>A"
      {
        assume B
        with c have A by (rule mp)
        with d have False by contradiction
      }
      hence "\<not>B" by (rule notI)
    }
    moreover
    {
      assume e:"\<not>B"
      {
        assume A
        with b have B by (rule mp)
        with e have False by contradiction
      }
      hence "\<not>A" by (rule notI)
    }
    ultimately have "\<not>A \<longleftrightarrow> \<not>B" by (rule iffI)
  }
  moreover
  {
    assume f:"\<not>A \<longleftrightarrow> \<not>B"
    hence g:"\<not>A \<longrightarrow> \<not>B" by (rule iffE)
    from f have h:"\<not>B \<longrightarrow> \<not>A" by (rule iffE)
    {
      assume i:A
      {
        assume "\<not>B"
        with h have "\<not>A" by (rule mp)
        with i have False by contradiction
      }
      hence "\<not>\<not>B" by (rule notI)
      hence B by (rule notnotD)
    }
    moreover
    {
      assume j:B
      {
        assume "\<not>A"
        with g have "\<not>B" by (rule mp)
        with j have False by contradiction
      }
      hence "\<not>\<not>A" by (rule notI)
      hence A by (rule notnotD)
    }
    ultimately have "A \<longleftrightarrow> B" by (rule iffI)
  }
  ultimately show ?thesis by (rule iffI)
qed


(*  Title:      HOL/ex/HarmonicSeries.thy
    Author:     Benjamin Porter, 2006
*)

section \<open>Divergence of the Harmonic Series\<close>

theory HarmonicSeries
imports Complex_Main
begin

subsection \<open>Abstract\<close>

text \<open>The following document presents a proof of the Divergence of
Harmonic Series theorem formalised in the Isabelle/Isar theorem
proving system.

{\em Theorem:} The series $\sum_{n=1}^{\infty} \frac{1}{n}$ does not
converge to any number.

{\em Informal Proof:}
  The informal proof is based on the following auxillary lemmas:
  \begin{itemize}
  \item{aux: $\sum_{n=2^m-1}^{2^m} \frac{1}{n} \geq \frac{1}{2}$}
  \item{aux2: $\sum_{n=1}^{2^M} \frac{1}{n} = 1 + \sum_{m=1}^{M} \sum_{n=2^m-1}^{2^m} \frac{1}{n}$}
  \end{itemize}

  From {\em aux} and {\em aux2} we can deduce that $\sum_{n=1}^{2^M}
  \frac{1}{n} \geq 1 + \frac{M}{2}$ for all $M$.
  Now for contradiction, assume that $\sum_{n=1}^{\infty} \frac{1}{n}
  = s$ for some $s$. Because $\forall n. \frac{1}{n} > 0$ all the
  partial sums in the series must be less than $s$. However with our
  deduction above we can choose $N > 2*s - 2$ and thus
  $\sum_{n=1}^{2^N} \frac{1}{n} > s$. This leads to a contradiction
  and hence $\sum_{n=1}^{\infty} \frac{1}{n}$ is not summable.
  QED.
\<close>

subsection \<open>Formal Proof\<close>

lemma two_pow_sub:
  "0 < m \<Longrightarrow> (2::nat)^m - 2^(m - 1) = 2^(m - 1)"
  by (induct m) auto

text \<open>We first prove the following auxillary lemma. This lemma
simply states that the finite sums: $\frac{1}{2}$, $\frac{1}{3} +
\frac{1}{4}$, $\frac{1}{5} + \frac{1}{6} + \frac{1}{7} + \frac{1}{8}$
etc. are all greater than or equal to $\frac{1}{2}$. We do this by
observing that each term in the sum is greater than or equal to the
last term, e.g. $\frac{1}{3} > \frac{1}{4}$ and thus $\frac{1}{3} +
\frac{1}{4} > \frac{1}{4} + \frac{1}{4} = \frac{1}{2}$.\<close>

lemma harmonic_aux:
  "\<forall>m>0. (\<Sum>n\<in>{(2::nat)^(m - 1)+1..2^m}. 1/real n) \<ge> 1/2"
  (is "\<forall>m>0. (\<Sum>n\<in>(?S m). 1/real n) \<ge> 1/2")
proof
  fix m::nat
  obtain tm where tmdef: "tm = (2::nat)^m" by simp
  {
    assume mgt0: "0 < m"
    have "\<And>x. x\<in>(?S m) \<Longrightarrow> 1/(real x) \<ge> 1/(real tm)"
    proof -
      fix x::nat
      assume xs: "x\<in>(?S m)"
      have xgt0: "x>0"
      proof -
        from xs have
          "x \<ge> 2^(m - 1) + 1" by auto
        moreover from mgt0 have
          "2^(m - 1) + 1 \<ge> (1::nat)" by auto
        ultimately have
          "x \<ge> 1" by (rule xtrans)
        thus ?thesis by simp
      qed
      moreover from xs have "x \<le> 2^m" by auto
      ultimately have "inverse (real x) \<ge> inverse (real ((2::nat)^m))" by simp
      moreover
      from xgt0 have "real x \<noteq> 0" by simp
      then have
        "inverse (real x) = 1 / (real x)"
        by (rule nonzero_inverse_eq_divide)
      moreover from mgt0 have "real tm \<noteq> 0" by (simp add: tmdef)
      then have
        "inverse (real tm) = 1 / (real tm)"
        by (rule nonzero_inverse_eq_divide)
      ultimately show
        "1/(real x) \<ge> 1/(real tm)" by (auto simp add: tmdef)
    qed
    then have
      "(\<Sum>n\<in>(?S m). 1 / real n) \<ge> (\<Sum>n\<in>(?S m). 1/(real tm))"
      by (rule sum_mono)
    moreover have
      "(\<Sum>n\<in>(?S m). 1/(real tm)) = 1/2"
    proof -
      have
        "(\<Sum>n\<in>(?S m). 1/(real tm)) =
         (1/(real tm))*(\<Sum>n\<in>(?S m). 1)"
        by simp
      also have
        "\<dots> = ((1/(real tm)) * real (card (?S m)))"
        by (simp add: real_of_card)
      also have
        "\<dots> = ((1/(real tm)) * real (tm - (2^(m - 1))))"
        by (simp add: tmdef)
      also from mgt0 have
        "\<dots> = ((1/(real tm)) * real ((2::nat)^(m - 1)))"
        by (auto simp: tmdef dest: two_pow_sub)
      also have
        "\<dots> = (real (2::nat))^(m - 1) / (real (2::nat))^m"
        by (simp add: tmdef)
      also from mgt0 have
        "\<dots> = (real (2::nat))^(m - 1) / (real (2::nat))^((m - 1) + 1)"
        by auto
      also have "\<dots> = 1/2" by simp
      finally show ?thesis .
    qed
    ultimately have
      "(\<Sum>n\<in>(?S m). 1 / real n) \<ge> 1/2"
      by - (erule subst)
  }
  thus "0 < m \<longrightarrow> 1 / 2 \<le> (\<Sum>n\<in>(?S m). 1 / real n)" by simp
qed

text \<open>We then show that the sum of a finite number of terms from the
harmonic series can be regrouped in increasing powers of 2. For
example: $1 + \frac{1}{2} + \frac{1}{3} + \frac{1}{4} + \frac{1}{5} +
\frac{1}{6} + \frac{1}{7} + \frac{1}{8} = 1 + (\frac{1}{2}) +
(\frac{1}{3} + \frac{1}{4}) + (\frac{1}{5} + \frac{1}{6} + \frac{1}{7}
+ \frac{1}{8})$.\<close>

lemma harmonic_aux2 [rule_format]:
  "0<M \<Longrightarrow> (\<Sum>n\<in>{1..(2::nat)^M}. 1/real n) =
   (1 + (\<Sum>m\<in>{1..M}. \<Sum>n\<in>{(2::nat)^(m - 1)+1..2^m}. 1/real n))"
  (is "0<M \<Longrightarrow> ?LHS M = ?RHS M")
proof (induct M)
  case 0 show ?case by simp
next
  case (Suc M)
  have ant: "0 < Suc M" by fact
  {
    have suc: "?LHS (Suc M) = ?RHS (Suc M)"
    proof cases \<comment> \<open>show that LHS = c and RHS = c, and thus LHS = RHS\<close>
      assume mz: "M=0"
      {
        then have
          "?LHS (Suc M) = ?LHS 1" by simp
        also have
          "\<dots> = (\<Sum>n\<in>{(1::nat)..2}. 1/real n)" by simp
        also have
          "\<dots> = ((\<Sum>n\<in>{Suc 1..2}. 1/real n) + 1/(real (1::nat)))"
          by (subst sum.head)
             (auto simp: atLeastSucAtMost_greaterThanAtMost)
        also have
          "\<dots> = ((\<Sum>n\<in>{2..2::nat}. 1/real n) + 1/(real (1::nat)))"
          by (simp add: eval_nat_numeral)
        also have
          "\<dots> =  1/(real (2::nat)) + 1/(real (1::nat))" by simp
        finally have
          "?LHS (Suc M) = 1/2 + 1" by simp
      }
      moreover
      {
        from mz have
          "?RHS (Suc M) = ?RHS 1" by simp
        also have
          "\<dots> = (\<Sum>n\<in>{((2::nat)^0)+1..2^1}. 1/real n) + 1"
          by simp
        also have
          "\<dots> = (\<Sum>n\<in>{2::nat..2}. 1/real n) + 1"
          by (auto simp: atLeastAtMost_singleton')
        also have
          "\<dots> = 1/2 + 1"
          by simp
        finally have
          "?RHS (Suc M) = 1/2 + 1" by simp
      }
      ultimately show "?LHS (Suc M) = ?RHS (Suc M)" by simp
    next
      assume mnz: "M\<noteq>0"
      then have mgtz: "M>0" by simp
      with Suc have suc:
        "(?LHS M) = (?RHS M)" by blast
      have
        "(?LHS (Suc M)) =
         ((?LHS M) + (\<Sum>n\<in>{(2::nat)^M+1..2^(Suc M)}. 1 / real n))"
      proof -
        have
          "{1..(2::nat)^(Suc M)} =
           {1..(2::nat)^M}\<union>{(2::nat)^M+1..(2::nat)^(Suc M)}"
          by auto
        moreover have
          "{1..(2::nat)^M}\<inter>{(2::nat)^M+1..(2::nat)^(Suc M)} = {}"
          by auto
        moreover have
          "finite {1..(2::nat)^M}" and "finite {(2::nat)^M+1..(2::nat)^(Suc M)}"
          by auto
        ultimately show ?thesis
          by (auto intro: sum.union_disjoint)
      qed
      moreover
      {
        have
          "(?RHS (Suc M)) =
           (1 + (\<Sum>m\<in>{1..M}.  \<Sum>n\<in>{(2::nat)^(m - 1)+1..2^m}. 1/real n) +
           (\<Sum>n\<in>{(2::nat)^(Suc M - 1)+1..2^(Suc M)}. 1/real n))" by simp
        also have
          "\<dots> = (?RHS M) + (\<Sum>n\<in>{(2::nat)^M+1..2^(Suc M)}. 1/real n)"
          by simp
        also from suc have
          "\<dots> = (?LHS M) +  (\<Sum>n\<in>{(2::nat)^M+1..2^(Suc M)}. 1/real n)"
          by simp
        finally have
          "(?RHS (Suc M)) = \<dots>" by simp
      }
      ultimately show "?LHS (Suc M) = ?RHS (Suc M)" by simp
    qed
  }
  thus ?case by simp
qed

text \<open>Using @{thm [source] harmonic_aux} and @{thm [source] harmonic_aux2} we now show
that each group sum is greater than or equal to $\frac{1}{2}$ and thus
the finite sum is bounded below by a value proportional to the number
of elements we choose.\<close>

lemma harmonic_aux3 [rule_format]:
  shows "\<forall>(M::nat). (\<Sum>n\<in>{1..(2::nat)^M}. 1 / real n) \<ge> 1 + (real M)/2"
  (is "\<forall>M. ?P M \<ge> _")
proof (rule allI, cases)
  fix M::nat
  assume "M=0"
  then show "?P M \<ge> 1 + (real M)/2" by simp
next
  fix M::nat
  assume "M\<noteq>0"
  then have "M > 0" by simp
  then have
    "(?P M) =
     (1 + (\<Sum>m\<in>{1..M}. \<Sum>n\<in>{(2::nat)^(m - 1)+1..2^m}. 1/real n))"
    by (rule harmonic_aux2)
  also have
    "\<dots> \<ge> (1 + (\<Sum>m\<in>{1..M}. 1/2))"
  proof -
    let ?f = "(\<lambda>x. 1/2)"
    let ?g = "(\<lambda>x. (\<Sum>n\<in>{(2::nat)^(x - 1)+1..2^x}. 1/real n))"
    from harmonic_aux have "\<And>x. x\<in>{1..M} \<Longrightarrow> ?f x \<le> ?g x" by simp
    then have "(\<Sum>m\<in>{1..M}. ?g m) \<ge> (\<Sum>m\<in>{1..M}. ?f m)" by (rule sum_mono)
    thus ?thesis by simp
  qed
  finally have "(?P M) \<ge> (1 + (\<Sum>m\<in>{1..M}. 1/2))" .
  moreover
  {
    have
      "(\<Sum>m\<in>{1..M}. (1::real)/2) = 1/2 * (\<Sum>m\<in>{1..M}. 1)"
      by auto
    also have
      "\<dots> = 1/2*(real (card {1..M}))"
      by (simp only: real_of_card[symmetric])
    also have
      "\<dots> = 1/2*(real M)" by simp
    also have
      "\<dots> = (real M)/2" by simp
    finally have "(\<Sum>m\<in>{1..M}. (1::real)/2) = (real M)/2" .
  }
  ultimately show "(?P M) \<ge> (1 + (real M)/2)" by simp
qed

text \<open>The final theorem shows that as we take more and more elements
(see @{thm [source] harmonic_aux3}) we get an ever increasing sum. By assuming
the sum converges, the lemma @{thm [source] sum_less_suminf} ( @{thm
sum_less_suminf} ) states that each sum is bounded above by the
series' limit. This contradicts our first statement and thus we prove
that the harmonic series is divergent.\<close>

theorem DivergenceOfHarmonicSeries:
  shows "\<not>summable (\<lambda>n. 1/real (Suc n))"
  (is "\<not>summable ?f")
proof \<comment> \<open>by contradiction\<close>
  let ?s = "suminf ?f" \<comment> \<open>let ?s equal the sum of the harmonic series\<close>
  assume sf: "summable ?f"
  then obtain n::nat where ndef: "n = nat \<lceil>2 * ?s\<rceil>" by simp
  then have ngt: "1 + real n/2 > ?s" by linarith
  define j where "j = (2::nat)^n"
  have "(\<Sum>i<j. ?f i) < ?s"
    using sf by (simp add: sum_less_suminf)
  then have "(\<Sum>i\<in>{Suc 0..<Suc j}. 1/(real i)) < ?s"
    unfolding sum.shift_bounds_Suc_ivl by (simp add: atLeast0LessThan)
  with j_def have
    "(\<Sum>i\<in>{1..< Suc ((2::nat)^n)}. 1 / (real i)) < ?s" by simp
  then have
    "(\<Sum>i\<in>{1..(2::nat)^n}. 1 / (real i)) < ?s"
    by (simp only: atLeastLessThanSuc_atLeastAtMost)
  moreover from harmonic_aux3 have
    "(\<Sum>i\<in>{1..(2::nat)^n}. 1 / (real i)) \<ge> 1 + real n/2" by simp
  moreover from ngt have "1 + real n/2 > ?s" by simp
  ultimately show False by simp
qed

end


theory Chap4
imports Main Chap3_1 Chap3_3
begin

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun set :: "'a tree \<Rightarrow> 'a set" where
"set Tip = {}"
| "set (Node l a r) = {a} \<union> set l \<union> set r"

fun ord :: "int tree \<Rightarrow> bool" where
"ord Tip = True"
| "ord (Node l a r) = (ord l \<and> ord r \<and> (\<forall>x\<in>set l. x \<le> a) \<and> (\<forall>x\<in>set r. a \<le> x))"

fun ins :: "int \<Rightarrow> int tree \<Rightarrow> int tree" where
"ins a Tip = Node Tip a Tip"
| "ins a (Node l b r) = (
  if a < b then Node (ins a l) b r
  else if a = b then Node l b r
  else Node l b (ins a r))"

lemma ins_set: "set (ins a t) = {a} \<union> set t"
  apply (induction t)
  by auto
lemma "ord t \<Longrightarrow> ord (ins a t)"
  apply (induction t rule: ins.induct)
  using ins_set by auto

lemma "\<forall>x. \<exists>y. x = y"
  by auto

lemma "A \<subseteq> B \<inter> C \<Longrightarrow> A \<subseteq> B \<union> C"
  by auto

lemma "\<lbrakk> \<forall>xs \<in> A. \<exists>ys. xs = ys@ys; us \<in> A \<rbrakk> \<Longrightarrow> \<exists>n. length us = n+n"
  (* apply auto *)
  by fastforce

lemma
  assumes a1: "\<forall>x y. T x y \<or> T y x"
  assumes a2: "\<forall>x y. A x y \<and> A y x \<longrightarrow> x = y"
  assumes a3: "\<forall>x y. T x y \<longrightarrow> A x y"
  shows "\<forall>x y. A x y \<longrightarrow> T x y"
  apply (rule allI; rule allI)
  apply (rule impI)
  using a1 apply (erule_tac x=x in allE)
  apply (erule_tac x=y in allE)
  apply (erule disjE)
   apply assumption
  using a3 apply (erule_tac x=y in allE)
  apply (erule_tac x=x in allE)
  apply (erule impE)
   apply assumption
  using a2 apply (erule_tac x=x in allE)
  apply (erule_tac x=y in allE)
  apply (erule impE)
   apply (rule conjI)
    apply assumption+
  apply (rule_tac a=x and b=y in forw_subst)
   apply assumption
  apply (drule_tac a=x and b=y in back_subst)
   apply assumption
  apply (drule_tac P="T y" and s=x in subst)
  by assumption+

lemma
  assumes a1: "\<forall>x y. T x y \<or> T y x"
  assumes a2: "\<forall>x y. A x y \<and> A y x \<longrightarrow> x = y"
  assumes a3: "\<forall>x y. T x y \<longrightarrow> A x y"
  shows "\<forall>x y. A x y \<longrightarrow> T x y"
  using a1 a2 a3
  (* apply simp *)
  (* apply auto *)
  (* by fastforce *)
  by blast

lemma "\<lbrakk> xs @ ys = ys @ xs; length xs = length ys \<rbrakk> \<Longrightarrow> xs = ys"
  (* using append_eq_conv_conj *)
  (* apply simp *)
  (* apply auto *)
  (* apply fastforce *)
  (* apply blast *)
  text \<open>using sledgehammer\<close>
  (* using append_eq_append_conv by blast *)
  by (metis append_eq_conv_conj)

thm conjI[of "a=b" "False"]
thm conjI[of _ "False"]
thm conjI[where ?P="a=b" and ?Q="False"]

lemma "\<lbrakk> (a::nat) \<le> b; b \<le> c; c \<le> d; d \<le> e \<rbrakk> \<Longrightarrow> a \<le> e"
  by (blast intro: le_trans)

thm conjI[OF refl[of "a"] refl[of "b"]]
thm refl[of "a"]
thm conjI

lemma "Suc (Suc (Suc a)) \<le> b \<Longrightarrow> a \<le> b"
  thm Suc_leD
  by (blast dest: Suc_leD)

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

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

lemma "ev m \<Longrightarrow> evn m"
  apply (induction rule: ev.induct)
  by auto

lemma "ev m \<Longrightarrow> ev (m-2)"
  apply (induction rule: ev.induct)
  using ev0 apply simp
  by simp

thm evSS[OF evSS[OF ev0]]

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

lemma "evn n \<Longrightarrow> ev n"
  apply (induction n rule: evn.induct)
  by (simp_all add: ev0 evSS)

declare ev.intros[simp,intro]

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl: "star r x x"
| step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

lemma star_trans: "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
  apply (induction rule: star.induct)
   apply assumption
  by (metis step)

inductive palindrome :: "'a list \<Rightarrow> bool" where
empty: "palindrome []"
| singleton: "palindrome [x]"
| extend: "palindrome xs \<Longrightarrow> palindrome (a # xs @ [a])"

lemma "palindrome xs \<Longrightarrow> rev xs = xs"
  apply (induction rule: palindrome.induct)
  by auto

inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl': "star' r x x"
| step': "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

lemma f1: "star' r y z \<Longrightarrow> r x y \<Longrightarrow> star' r x z"
  apply (induction rule: star'.induct)
  by (auto intro: star'.intros)

lemma "star r x y \<Longrightarrow> star' r x y"
  apply (induction rule: star.induct)
   apply (simp add: refl')
  using f1 by force

lemma f2: "star r x y \<Longrightarrow> r y z \<Longrightarrow> star r x z"
  apply (induction rule: star.induct)
  by (auto intro: star.intros)

lemma "star' r x y \<Longrightarrow> star r x y"
  apply (induction rule: star'.induct)
   apply (simp add: refl)
  using f2 by force

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
"iter r 0 x x"
| "iter r n y z \<Longrightarrow> r x y \<Longrightarrow> iter r (n+1) x z"

lemma "star r x y \<Longrightarrow> \<exists>n. iter r n x y"
  apply (induction rule: star.induct)
  using iter.intros(1) apply force
  apply clarsimp
  using iter.intros(2) by force

datatype alphabet = a | b

inductive S :: "alphabet list \<Rightarrow> bool" where
"S []"
| "S w \<Longrightarrow> S (a#w@[b])"
| "S v \<Longrightarrow> S w \<Longrightarrow> S (v@w)"

inductive T :: "alphabet list \<Rightarrow> bool" where
"T []"
| "T v \<Longrightarrow> T w \<Longrightarrow> T (v@[a]@w@[b])"

lemma stinduct1:
  assumes "\<And>v. T v \<Longrightarrow> T (v @ u')"
shows "T u' \<Longrightarrow> T v' \<Longrightarrow> T w' \<Longrightarrow> T ((w' @ u') @ [a] @ v' @ [b])"
  using T.intros(2) assms by presburger

lemma stinduct: "T w \<Longrightarrow> T v \<Longrightarrow> T (v @ w)"
  apply (induction w arbitrary: v rule: T.induct)
   apply simp_all
  using stinduct1 by auto

lemma st: "S w \<Longrightarrow> T w"
  apply (induction rule: S.induct)
  using T.intros apply force+
  using stinduct by auto

lemma ts: "T w \<Longrightarrow> S w"
  apply (induction rule: T.induct)
  using S.intros apply force
  by (simp add: S.intros(2) S.intros(3))

lemma "S w = T w"
  using st ts by auto

inductive aval_rel :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
"aval_rel (N n) s n"
| "aval_rel (V v) s (s v)"
| "aval_rel e1 s x1 \<Longrightarrow> aval_rel e2 s x2 \<Longrightarrow> aval_rel (Plus e1 e2) s (x1 + x2)"

lemma relfn1:
"(\<And>x. Chap4.aval_rel e1 s x \<Longrightarrow> aval e1 s = x) \<Longrightarrow>
       (\<And>x. Chap4.aval_rel e2 s x \<Longrightarrow> aval e2 s = x) \<Longrightarrow>
       Chap4.aval_rel (Plus e1 e2) s x \<Longrightarrow> aval (Plus e1 e2) s = x"
  apply (cases "Plus e1 e2" s x rule: aval_rel.cases)
  by auto

lemma relfn: "aval_rel e s x \<Longrightarrow> aval e s = x"
  apply (induction e arbitrary: x)
  using Chap4.aval_rel.cases apply auto[2]
  using relfn1 by blast

lemma fnrel: "aval e s = x \<Longrightarrow> aval_rel e s x"
  apply (induction e arbitrary: x)
  using Chap4.aval_rel.intros by auto

lemma "aval e s = x \<longleftrightarrow> aval_rel e s x"
  using relfn fnrel by blast

inductive ok :: "nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool" where
"ok n [] n"
| "ok (Suc m) is n \<Longrightarrow> ok m (LOADI k#is) n"
| "ok (Suc m) is n \<Longrightarrow> ok m (LOAD x#is) n"
| "ok (Suc m) is n \<Longrightarrow> ok (Suc (Suc m)) (ADD#is) n"

lemma "ok n is n' \<Longrightarrow> length stk = n \<Longrightarrow> length (exec is s stk) = n'"
  apply (induction arbitrary: stk rule: ok.induct)
     apply simp_all
  apply (subgoal_tac "\<exists>i j stk'. stk = i#j#stk'")
   apply force
  by (metis Suc_length_conv)

end


theory SetCombinators
  imports SetComprehension UPair
begin

context GZF begin

subsection \<open>Intersection of a set of sets\<close>

definition Int :: "'a \<Rightarrow> 'a" (\<open>\<Inter> _\<close> [90] 90)
  where "\<Inter> x \<equiv> { b \<in> \<Union> x | \<forall>y \<in> x. b \<in> y }"

lemma Int_typ : "Int : SetOf Set \<rightarrow> Set"
  unfolding Int_def
  by (rule funI, rule collect_set[OF union_set], assumption)

lemmas Int_set = funE[OF Int_typ]

lemma Int_iff:
  assumes "x : SetOf Set"
  shows "a \<in> \<Inter> x \<longleftrightarrow> (ball x (\<lambda>y. a \<in> y)) \<and> x \<noteq> \<emptyset> "
proof
  assume "a \<in> \<Inter> x" hence "a \<in> \<Union> x" "ball x (\<lambda>y. a \<in> y)" unfolding Int_def
    using collectE[OF funE[OF Union_typ \<open>x : SetOf Set\<close>]] by auto
  thus "ball x (\<lambda>y. a \<in> y) \<and> x \<noteq> \<emptyset>" using union_emp[OF assms] by auto
next
  assume "ball x (\<lambda>y. a \<in> y) \<and> x \<noteq> \<emptyset>"
  hence ball:"ball x (\<lambda>y. a \<in> y)" and "x \<noteq> \<emptyset>" by simp_all
  have "a \<in> \<Union> x"
  proof (rule not_emptyE[OF subtypE[OF setof_set_subtyp assms] \<open>x \<noteq> \<emptyset>\<close>])
    fix y assume "y \<in> x" thus "a \<in> \<Union> x"
      using ball unionI[OF assms] unfolding ball_def rall_def by auto
  qed
  thus "a \<in> \<Inter> x" unfolding Int_def using ball collectI[OF funE[OF Union_typ assms]] by auto
qed

lemma IntI :
  assumes "x : SetOf Set"
  shows "\<lbrakk> \<And>y. y \<in> x \<Longrightarrow> a \<in> y ; x \<noteq> \<emptyset> \<rbrakk> \<Longrightarrow> a \<in> \<Inter> x"
  using Int_iff[OF assms] by auto

lemma IntD :
  assumes "x : SetOf Set"
  shows "\<lbrakk> a \<in> \<Inter> x ; y \<in> x \<rbrakk> \<Longrightarrow> a \<in> y"
  using Int_iff[OF assms] by auto

lemma IntE :
  assumes "x : SetOf Set"
  shows "\<lbrakk> a \<in> \<Inter> x ; y \<notin> x \<Longrightarrow> R; a \<in> y \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  using Int_iff[OF assms] by auto

subsection \<open>Set difference\<close>

definition diff :: "['a, 'a] \<Rightarrow> 'a" (infixl \<open>-\<close> 65)
  where "x - y \<equiv> { b \<in> x | b \<notin> y }"
(*   *)
(*Diff will return a set even if its second argument (y above) is not a set*)
lemma diff_typ : "diff : Set \<rightarrow> Set \<rightarrow> Set" unfolding diff_def
  by (rule funI, rule funI, use collect_set in auto)

lemmas diff_set = funE[OF funE[OF diff_typ]]

lemma diff_iff :
  assumes "x : Set"
    shows "a \<in> x - y \<longleftrightarrow> a \<in> x \<and> a \<notin> y"
  unfolding diff_def using collect_iff[OF assms] by simp

lemma diffI :
  assumes "x : Set"
    shows "\<lbrakk> a \<in> x ; a \<notin> y \<rbrakk> \<Longrightarrow> a \<in> x - y"
  using diff_iff[OF assms] by simp

lemma diffD1 :
  assumes "x : Set"
    shows "a \<in> x - y \<Longrightarrow> a \<in> x"
  using diff_iff[OF assms] by simp

lemma diffD2 :
  assumes "x : Set"
    shows "a \<in> x - y \<Longrightarrow> a \<notin> y"
  using diff_iff[OF assms] by simp

lemma diffE :
  assumes "x : Set"
    shows "\<lbrakk> a \<in> x - y ; \<lbrakk> a \<in> x ; a \<notin> y\<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  using diff_iff[OF assms] by simp

lemma diff_sub :
  assumes "x : Set" "y : Set" "z : Set"
    shows "x \<subseteq> y \<Longrightarrow> x - z \<subseteq> y - z"
  using subset_iff diff_iff diff_set assms by auto

lemma diff_subset1 :
  assumes "x : Set" "y : Set" "z : Set" "a : Set"
    shows "x \<subseteq> y \<Longrightarrow> a \<subseteq> (x - z) \<Longrightarrow> a \<subseteq> (y - z)"
  using subset_iff diff_iff funE[OF funE[OF diff_typ _] _] assms by auto

lemma diff_subset2 :
  assumes "x : Set" "y : Set" "z : Set"
    shows "x \<subseteq> (y - z) \<Longrightarrow> x \<subseteq> y"
  using subset_iff diff_iff[OF \<open>y : Set\<close>] diff_set assms by auto

lemma diff_emp :
  assumes "x : Set"
    shows "\<emptyset> - x = \<emptyset>"
proof -
  have "\<emptyset> - x : Set" by (rule diff_set[OF emp_set assms])
  show ?thesis using diff_iff[OF emp_set] equals0I[OF \<open>\<emptyset> - x : Set\<close>] by auto
qed

subsection \<open>Binary union and intersection\<close>

definition un :: "['a,'a] \<Rightarrow> 'a" (infixl \<open>\<union>\<close> 90) where
  "x \<union> y \<equiv> \<Union> upair x y"

lemma upair_setof : "x : Set \<Longrightarrow> y : Set \<Longrightarrow> upair x y : SetOf Set"
proof (rule setofI, rule upair_set)
  fix x y assume xy: "x : Set" "y : Set"
  thus "x : SetMem" "y : SetMem" by (simp_all only: set_setmem)
  moreover fix b assume "b \<in> upair x y"
  ultimately show "b : Set" using upair_iff xy by auto
qed

lemma un_typ : "(\<union>) : Set \<rightarrow> Set \<rightarrow> Set" unfolding un_def
  by (rule funI, rule funI, simp only: union_set[OF upair_setof])

lemmas un_set = funE[OF funE[OF un_typ]]

lemma un_iff :
  assumes "x : Set" "y : Set"
  shows "a \<in> x \<union> y \<longleftrightarrow> (a \<in> x \<or> a \<in> y)"
  unfolding un_def
  by (simp add: union_iff[OF upair_setof[OF assms]],
      use upair_iff set_setmem assms in auto)

lemma unI1 :
  assumes "x : Set" "y : Set"
  shows"a \<in> x \<Longrightarrow> a \<in> x \<union> y" by (simp add: un_iff assms)
lemma unI2 :
  assumes "x : Set" "y : Set"
  shows "b \<in> y \<Longrightarrow> b \<in> x \<union> y" by (simp add: un_iff assms)

lemma un_subset1 :
  assumes "x : Set" "y : Set"
  shows "x \<subseteq> x \<union> y"
  using subsetI unI1[OF assms] by simp

lemma un_subset2 :
  assumes "x : Set" "y : Set"
  shows "y \<subseteq> x \<union> y"
  using subsetI unI2[OF assms] by simp

lemma unE :
  assumes "x : Set" "y : Set"
  shows "\<lbrakk> a \<in> x \<union> y ; a \<in> x \<Longrightarrow> P ; a \<in> y \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (simp add: un_iff[OF assms], blast)

lemma unE' :
  assumes "x : Set" "y : Set"
  shows "\<lbrakk> a \<in> x \<union> y ; a \<in> x \<Longrightarrow> P ; \<lbrakk> a \<in> y ; a \<notin> x \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (simp add: un_iff[OF assms], blast)

lemma unCI :
  assumes "x : Set" "y : Set"
  shows "(a \<notin> y \<Longrightarrow> a \<in> x) \<Longrightarrow> a \<in> x \<union> y"
  by (simp add: un_iff[OF assms], blast)

subsection \<open>Rules for binary intersection\<close>

definition inter :: "['a,'a] \<Rightarrow> 'a" (infixl \<open>\<inter>\<close> 90) where
  "x \<inter> y \<equiv> \<Inter> upair x y"

lemma inter_typ : "(\<inter>) : Set \<rightarrow> Set \<rightarrow> Set"
  unfolding inter_def
  by (rule funI, rule funI, rule Int_set[OF upair_setof])

lemmas inter_set = funE[OF funE[OF inter_typ]]

lemma inter_iff :
  assumes "x : Set" "y : Set"
  shows "a \<in> x \<inter> y \<longleftrightarrow> (a \<in> x \<and> a \<in> y)"
  unfolding inter_def
  by (simp add: Int_iff[OF upair_setof[OF assms]],
      use upair_iff set_setmem assms in auto)

lemma interI :
  assumes "x : Set" "y : Set"
  shows "\<lbrakk> a \<in> x ; a \<in> y \<rbrakk> \<Longrightarrow> a \<in> x \<inter> y"
  by (simp add: inter_iff[OF assms])

lemma interD1 :
  assumes "x : Set" "y : Set"
  shows "a \<in> x \<inter> y \<Longrightarrow> a \<in> x"
  by (simp add: inter_iff assms)

lemma interD2 :
  assumes "x : Set" "y : Set"
  shows "a \<in> x \<inter> y \<Longrightarrow> a \<in> y"
  by (simp add: inter_iff assms)

lemma interE :
  assumes "x : Set" "y : Set"
  shows "\<lbrakk> a \<in> x \<inter> y ; \<lbrakk> a \<in> x ; a \<in> y \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (simp add: inter_iff assms)
end

subsection \<open>Binders for union and intersection\<close>

syntax
  "_Union" :: "[pttrn, 'a, 'a] \<Rightarrow> 'a"  (\<open>(3\<Union>_\<in>_./ _)\<close> 10)
  "_Inter" :: "[pttrn, 'a, 'a] \<Rightarrow> 'a"  (\<open>(3\<Inter>_\<in>_./ _)\<close> 10)
translations
  "\<Union>b\<in>x. B" == "CONST Union {B | b \<in> x}"
  "\<Inter>b\<in>x. B" == "CONST Int {B | b \<in> x}"

end


(*
    $Id: sol.thy,v 1.2 2004/11/23 15:14:35 webertj Exp $
*)

header {* A Riddle: Rich Grandfather *}

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

text {*
  First prove the following formula, which is valid in classical predicate
  logic, informally with pen and paper.  Use case distinctions and/or proof by
  contradiction.

  {\it  If every poor man has a rich father,\\
   then there is a rich man who has a rich grandfather.}
*}

theorem
  "\<forall>x. \<not> rich x \<longrightarrow> rich (father x) \<Longrightarrow>
  \<exists>x. rich (father (father x)) \<and> rich x" (*<*) oops (*>*)

text {*
\begin{tabbing}
{\bf Proof} \\
(1)\ \= We first show: @{term "\<exists>x. rich x"}. \\
Proof by contradiction. \\
    \> {\bf Assume} \=  @{term "\<not> (\<exists>x. rich x)"}. \\
    \>               \> Then @{term "\<forall>x. \<not> rich x"}. \\
    \>               \> We consider an arbitrary @{term "y"} with
                          @{term "\<not> rich y"}. \\
    \>               \> Then @{term "rich (father y)"}. \\
(2) \> Now we show the theorem. \\
Proof by cases. \\
    \> {\bf Case 1:} \> @{term "rich (father (father x))"}. \\
    \>               \> We are done. \\
    \> {\bf Case 2:} \> @{term "\<not> rich (father (father x))"}. \\
    \>               \> Then @{term "rich (father (father (father x)))"}. \\
    \>               \> Also @{term "rich (father x)"}, \\
    \>               \> because otherwise @{term "rich (father (father x))"}. \\
{\bf qed} \\
\end{tabbing}
*}

text {*
  Now prove the formula in Isabelle using a sequence of rule applications (i.e.\
  only using the methods @{term rule}, @{term erule} and @{term assumption}).
*}

theorem
  "\<forall>x. \<not> rich x \<longrightarrow> rich (father x) \<Longrightarrow>
  \<exists>x. rich (father (father x)) \<and> rich x"
apply (rule classical)
apply (rule exI)
apply (rule conjI)

  apply (rule classical)
  apply (rule allE) apply assumption
  apply (erule impE) apply assumption
  apply (erule notE)
  apply (rule exI)
  apply (rule conjI) apply assumption
  apply (rule classical)
  apply (erule allE)
  apply (erule notE)
  apply (erule impE) apply assumption
  apply assumption

apply (rule classical)
apply (rule allE) apply assumption
apply (erule impE) apply assumption
apply (erule notE)
apply (rule exI)
apply (rule conjI) apply assumption
apply (rule classical)
apply (erule allE)
apply (erule notE)
apply (erule impE) apply assumption
apply assumption
done

text {*
  Here is a proof in Isar that resembles the informal reasoning above:
*}

theorem rich_grandfather: "\<forall>x. \<not> rich x \<longrightarrow> rich (father x) \<Longrightarrow>
  \<exists>x. rich x \<and> rich (father (father x))"
proof -
  assume a: "\<forall>x. \<not> rich x \<longrightarrow> rich (father x)"
  txt {* (1) *} have "\<exists>x. rich x"
  proof (rule classical)
    fix y
    assume "\<not> (\<exists>x. rich x)"
    then have "\<forall>x. \<not> rich x" by simp
    then have "\<not> rich y" by simp
    with a have "rich (father y)" by simp
    then show ?thesis by rule
  qed
  then obtain x where x: "rich x" by auto
  txt {* (2) *} show ?thesis
  proof cases
    assume "rich (father (father x))"
    with x show ?thesis by auto
  next
    assume b: "\<not> rich (father (father x))"
    with a have "rich (father (father (father x)))" by simp
    moreover have "rich (father x)"
    proof (rule classical)
      assume "\<not> rich (father x)"
      with a have "rich (father (father x))" by simp
      with b show ?thesis by contradiction
    qed
    ultimately show ?thesis by auto
  qed
qed

(*<*) end (*>*)


(*  Title:      HOL/Library/Set_Algebras.thy
    Author:     Jeremy Avigad
    Author:     Kevin Donnelly
    Author:     Florian Haftmann, TUM
*)

section \<open>Algebraic operations on sets\<close>

theory Set_Algebras
  imports MainRLT
begin

text \<open>
  This library lifts operations like addition and multiplication to sets. It
  was designed to support asymptotic calculations. See the comments at the top
  of \<^file>\<open>BigO.thy\<close>.
\<close>

instantiation set :: (plus) plus
begin

definition plus_set :: "'a::plus set \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where set_plus_def: "A + B = {c. \<exists>a\<in>A. \<exists>b\<in>B. c = a + b}"

instance ..

end

instantiation set :: (times) times
begin

definition times_set :: "'a::times set \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where set_times_def: "A * B = {c. \<exists>a\<in>A. \<exists>b\<in>B. c = a * b}"

instance ..

end

instantiation set :: (zero) zero
begin

definition set_zero[simp]: "(0::'a::zero set) = {0}"

instance ..

end

instantiation set :: (one) one
begin

definition set_one[simp]: "(1::'a::one set) = {1}"

instance ..

end

definition elt_set_plus :: "'a::plus \<Rightarrow> 'a set \<Rightarrow> 'a set"  (infixl "+o" 70)
  where "a +o B = {c. \<exists>b\<in>B. c = a + b}"

definition elt_set_times :: "'a::times \<Rightarrow> 'a set \<Rightarrow> 'a set"  (infixl "*o" 80)
  where "a *o B = {c. \<exists>b\<in>B. c = a * b}"

abbreviation (input) elt_set_eq :: "'a \<Rightarrow> 'a set \<Rightarrow> bool"  (infix "=o" 50)
  where "x =o A \<equiv> x \<in> A"

instance set :: (semigroup_add) semigroup_add
  by standard (force simp add: set_plus_def add.assoc)

instance set :: (ab_semigroup_add) ab_semigroup_add
  by standard (force simp add: set_plus_def add.commute)

instance set :: (monoid_add) monoid_add
  by standard (simp_all add: set_plus_def)

instance set :: (comm_monoid_add) comm_monoid_add
  by standard (simp_all add: set_plus_def)

instance set :: (semigroup_mult) semigroup_mult
  by standard (force simp add: set_times_def mult.assoc)

instance set :: (ab_semigroup_mult) ab_semigroup_mult
  by standard (force simp add: set_times_def mult.commute)

instance set :: (monoid_mult) monoid_mult
  by standard (simp_all add: set_times_def)

instance set :: (comm_monoid_mult) comm_monoid_mult
  by standard (simp_all add: set_times_def)

lemma set_plus_intro [intro]: "a \<in> C \<Longrightarrow> b \<in> D \<Longrightarrow> a + b \<in> C + D"
  by (auto simp add: set_plus_def)

lemma set_plus_elim:
  assumes "x \<in> A + B"
  obtains a b where "x = a + b" and "a \<in> A" and "b \<in> B"
  using assms unfolding set_plus_def by fast

lemma set_plus_intro2 [intro]: "b \<in> C \<Longrightarrow> a + b \<in> a +o C"
  by (auto simp add: elt_set_plus_def)

lemma set_plus_rearrange: "(a +o C) + (b +o D) = (a + b) +o (C + D)"
  for a b :: "'a::comm_monoid_add"
  apply (auto simp add: elt_set_plus_def set_plus_def ac_simps)
   apply (rule_tac x = "ba + bb" in exI)
   apply (auto simp add: ac_simps)
  apply (rule_tac x = "aa + a" in exI)
  apply (auto simp add: ac_simps)
  done

lemma set_plus_rearrange2: "a +o (b +o C) = (a + b) +o C"
  for a b :: "'a::semigroup_add"
  by (auto simp add: elt_set_plus_def add.assoc)

lemma set_plus_rearrange3: "(a +o B) + C = a +o (B + C)"
  for a :: "'a::semigroup_add"
  apply (auto simp add: elt_set_plus_def set_plus_def)
   apply (blast intro: ac_simps)
  apply (rule_tac x = "a + aa" in exI)
  apply (rule conjI)
   apply (rule_tac x = "aa" in bexI)
    apply auto
  apply (rule_tac x = "ba" in bexI)
   apply (auto simp add: ac_simps)
  done

theorem set_plus_rearrange4: "C + (a +o D) = a +o (C + D)"
  for a :: "'a::comm_monoid_add"
  apply (auto simp add: elt_set_plus_def set_plus_def ac_simps)
   apply (rule_tac x = "aa + ba" in exI)
   apply (auto simp add: ac_simps)
  done

lemmas set_plus_rearranges = set_plus_rearrange set_plus_rearrange2
  set_plus_rearrange3 set_plus_rearrange4

lemma set_plus_mono [intro!]: "C \<subseteq> D \<Longrightarrow> a +o C \<subseteq> a +o D"
  by (auto simp add: elt_set_plus_def)

lemma set_plus_mono2 [intro]: "C \<subseteq> D \<Longrightarrow> E \<subseteq> F \<Longrightarrow> C + E \<subseteq> D + F"
  for C D E F :: "'a::plus set"
  by (auto simp add: set_plus_def)

lemma set_plus_mono3 [intro]: "a \<in> C \<Longrightarrow> a +o D \<subseteq> C + D"
  by (auto simp add: elt_set_plus_def set_plus_def)

lemma set_plus_mono4 [intro]: "a \<in> C \<Longrightarrow> a +o D \<subseteq> D + C"
  for a :: "'a::comm_monoid_add"
  by (auto simp add: elt_set_plus_def set_plus_def ac_simps)

lemma set_plus_mono5: "a \<in> C \<Longrightarrow> B \<subseteq> D \<Longrightarrow> a +o B \<subseteq> C + D"
  apply (subgoal_tac "a +o B \<subseteq> a +o D")
   apply (erule order_trans)
   apply (erule set_plus_mono3)
  apply (erule set_plus_mono)
  done

lemma set_plus_mono_b: "C \<subseteq> D \<Longrightarrow> x \<in> a +o C \<Longrightarrow> x \<in> a +o D"
  apply (frule set_plus_mono)
  apply auto
  done

lemma set_plus_mono2_b: "C \<subseteq> D \<Longrightarrow> E \<subseteq> F \<Longrightarrow> x \<in> C + E \<Longrightarrow> x \<in> D + F"
  apply (frule set_plus_mono2)
   prefer 2
   apply force
  apply assumption
  done

lemma set_plus_mono3_b: "a \<in> C \<Longrightarrow> x \<in> a +o D \<Longrightarrow> x \<in> C + D"
  apply (frule set_plus_mono3)
  apply auto
  done

lemma set_plus_mono4_b: "a \<in> C \<Longrightarrow> x \<in> a +o D \<Longrightarrow> x \<in> D + C"
  for a x :: "'a::comm_monoid_add"
  apply (frule set_plus_mono4)
  apply auto
  done

lemma set_zero_plus [simp]: "0 +o C = C"
  for C :: "'a::comm_monoid_add set"
  by (auto simp add: elt_set_plus_def)

lemma set_zero_plus2: "0 \<in> A \<Longrightarrow> B \<subseteq> A + B"
  for A B :: "'a::comm_monoid_add set"
  apply (auto simp add: set_plus_def)
  apply (rule_tac x = 0 in bexI)
   apply (rule_tac x = x in bexI)
    apply (auto simp add: ac_simps)
  done

lemma set_plus_imp_minus: "a \<in> b +o C \<Longrightarrow> a - b \<in> C"
  for a b :: "'a::ab_group_add"
  by (auto simp add: elt_set_plus_def ac_simps)

lemma set_minus_imp_plus: "a - b \<in> C \<Longrightarrow> a \<in> b +o C"
  for a b :: "'a::ab_group_add"
  apply (auto simp add: elt_set_plus_def ac_simps)
  apply (subgoal_tac "a = (a + - b) + b")
   apply (rule bexI)
    apply assumption
   apply (auto simp add: ac_simps)
  done

lemma set_minus_plus: "a - b \<in> C \<longleftrightarrow> a \<in> b +o C"
  for a b :: "'a::ab_group_add"
  apply (rule iffI)
   apply (rule set_minus_imp_plus)
   apply assumption
  apply (rule set_plus_imp_minus)
  apply assumption
  done

lemma set_times_intro [intro]: "a \<in> C \<Longrightarrow> b \<in> D \<Longrightarrow> a * b \<in> C * D"
  by (auto simp add: set_times_def)

lemma set_times_elim:
  assumes "x \<in> A * B"
  obtains a b where "x = a * b" and "a \<in> A" and "b \<in> B"
  using assms unfolding set_times_def by fast

lemma set_times_intro2 [intro!]: "b \<in> C \<Longrightarrow> a * b \<in> a *o C"
  by (auto simp add: elt_set_times_def)

lemma set_times_rearrange: "(a *o C) * (b *o D) = (a * b) *o (C * D)"
  for a b :: "'a::comm_monoid_mult"
  apply (auto simp add: elt_set_times_def set_times_def)
   apply (rule_tac x = "ba * bb" in exI)
   apply (auto simp add: ac_simps)
  apply (rule_tac x = "aa * a" in exI)
  apply (auto simp add: ac_simps)
  done

lemma set_times_rearrange2: "a *o (b *o C) = (a * b) *o C"
  for a b :: "'a::semigroup_mult"
  by (auto simp add: elt_set_times_def mult.assoc)

lemma set_times_rearrange3: "(a *o B) * C = a *o (B * C)"
  for a :: "'a::semigroup_mult"
  apply (auto simp add: elt_set_times_def set_times_def)
   apply (blast intro: ac_simps)
  apply (rule_tac x = "a * aa" in exI)
  apply (rule conjI)
   apply (rule_tac x = "aa" in bexI)
    apply auto
  apply (rule_tac x = "ba" in bexI)
   apply (auto simp add: ac_simps)
  done

theorem set_times_rearrange4: "C * (a *o D) = a *o (C * D)"
  for a :: "'a::comm_monoid_mult"
  apply (auto simp add: elt_set_times_def set_times_def ac_simps)
   apply (rule_tac x = "aa * ba" in exI)
   apply (auto simp add: ac_simps)
  done

lemmas set_times_rearranges = set_times_rearrange set_times_rearrange2
  set_times_rearrange3 set_times_rearrange4

lemma set_times_mono [intro]: "C \<subseteq> D \<Longrightarrow> a *o C \<subseteq> a *o D"
  by (auto simp add: elt_set_times_def)

lemma set_times_mono2 [intro]: "C \<subseteq> D \<Longrightarrow> E \<subseteq> F \<Longrightarrow> C * E \<subseteq> D * F"
  for C D E F :: "'a::times set"
  by (auto simp add: set_times_def)

lemma set_times_mono3 [intro]: "a \<in> C \<Longrightarrow> a *o D \<subseteq> C * D"
  by (auto simp add: elt_set_times_def set_times_def)

lemma set_times_mono4 [intro]: "a \<in> C \<Longrightarrow> a *o D \<subseteq> D * C"
  for a :: "'a::comm_monoid_mult"
  by (auto simp add: elt_set_times_def set_times_def ac_simps)

lemma set_times_mono5: "a \<in> C \<Longrightarrow> B \<subseteq> D \<Longrightarrow> a *o B \<subseteq> C * D"
  apply (subgoal_tac "a *o B \<subseteq> a *o D")
   apply (erule order_trans)
   apply (erule set_times_mono3)
  apply (erule set_times_mono)
  done

lemma set_times_mono_b: "C \<subseteq> D \<Longrightarrow> x \<in> a *o C \<Longrightarrow> x \<in> a *o D"
  apply (frule set_times_mono)
  apply auto
  done

lemma set_times_mono2_b: "C \<subseteq> D \<Longrightarrow> E \<subseteq> F \<Longrightarrow> x \<in> C * E \<Longrightarrow> x \<in> D * F"
  apply (frule set_times_mono2)
   prefer 2
   apply force
  apply assumption
  done

lemma set_times_mono3_b: "a \<in> C \<Longrightarrow> x \<in> a *o D \<Longrightarrow> x \<in> C * D"
  apply (frule set_times_mono3)
  apply auto
  done

lemma set_times_mono4_b: "a \<in> C \<Longrightarrow> x \<in> a *o D \<Longrightarrow> x \<in> D * C"
  for a x :: "'a::comm_monoid_mult"
  apply (frule set_times_mono4)
  apply auto
  done

lemma set_one_times [simp]: "1 *o C = C"
  for C :: "'a::comm_monoid_mult set"
  by (auto simp add: elt_set_times_def)

lemma set_times_plus_distrib: "a *o (b +o C) = (a * b) +o (a *o C)"
  for a b :: "'a::semiring"
  by (auto simp add: elt_set_plus_def elt_set_times_def ring_distribs)

lemma set_times_plus_distrib2: "a *o (B + C) = (a *o B) + (a *o C)"
  for a :: "'a::semiring"
  apply (auto simp add: set_plus_def elt_set_times_def ring_distribs)
   apply blast
  apply (rule_tac x = "b + bb" in exI)
  apply (auto simp add: ring_distribs)
  done

lemma set_times_plus_distrib3: "(a +o C) * D \<subseteq> a *o D + C * D"
  for a :: "'a::semiring"
  apply (auto simp: elt_set_plus_def elt_set_times_def set_times_def set_plus_def ring_distribs)
  apply auto
  done

lemmas set_times_plus_distribs =
  set_times_plus_distrib
  set_times_plus_distrib2

lemma set_neg_intro: "a \<in> (- 1) *o C \<Longrightarrow> - a \<in> C"
  for a :: "'a::ring_1"
  by (auto simp add: elt_set_times_def)

lemma set_neg_intro2: "a \<in> C \<Longrightarrow> - a \<in> (- 1) *o C"
  for a :: "'a::ring_1"
  by (auto simp add: elt_set_times_def)

lemma set_plus_image: "S + T = (\<lambda>(x, y). x + y) ` (S \<times> T)"
  by (fastforce simp: set_plus_def image_iff)

lemma set_times_image: "S * T = (\<lambda>(x, y). x * y) ` (S \<times> T)"
  by (fastforce simp: set_times_def image_iff)

lemma finite_set_plus: "finite s \<Longrightarrow> finite t \<Longrightarrow> finite (s + t)"
  by (simp add: set_plus_image)

lemma finite_set_times: "finite s \<Longrightarrow> finite t \<Longrightarrow> finite (s * t)"
  by (simp add: set_times_image)

lemma set_sum_alt:
  assumes fin: "finite I"
  shows "sum S I = {sum s I |s. \<forall>i\<in>I. s i \<in> S i}"
    (is "_ = ?sum I")
  using fin
proof induct
  case empty
  then show ?case by simp
next
  case (insert x F)
  have "sum S (insert x F) = S x + ?sum F"
    using insert.hyps by auto
  also have "\<dots> = {s x + sum s F |s. \<forall> i\<in>insert x F. s i \<in> S i}"
    unfolding set_plus_def
  proof safe
    fix y s
    assume "y \<in> S x" "\<forall>i\<in>F. s i \<in> S i"
    then show "\<exists>s'. y + sum s F = s' x + sum s' F \<and> (\<forall>i\<in>insert x F. s' i \<in> S i)"
      using insert.hyps
      by (intro exI[of _ "\<lambda>i. if i \<in> F then s i else y"]) (auto simp add: set_plus_def)
  qed auto
  finally show ?case
    using insert.hyps by auto
qed

lemma sum_set_cond_linear:
  fixes f :: "'a::comm_monoid_add set \<Rightarrow> 'b::comm_monoid_add set"
  assumes [intro!]: "\<And>A B. P A  \<Longrightarrow> P B  \<Longrightarrow> P (A + B)" "P {0}"
    and f: "\<And>A B. P A  \<Longrightarrow> P B \<Longrightarrow> f (A + B) = f A + f B" "f {0} = {0}"
  assumes all: "\<And>i. i \<in> I \<Longrightarrow> P (S i)"
  shows "f (sum S I) = sum (f \<circ> S) I"
proof (cases "finite I")
  case True
  from this all show ?thesis
  proof induct
    case empty
    then show ?case by (auto intro!: f)
  next
    case (insert x F)
    from \<open>finite F\<close> \<open>\<And>i. i \<in> insert x F \<Longrightarrow> P (S i)\<close> have "P (sum S F)"
      by induct auto
    with insert show ?case
      by (simp, subst f) auto
  qed
next
  case False
  then show ?thesis by (auto intro!: f)
qed

lemma sum_set_linear:
  fixes f :: "'a::comm_monoid_add set \<Rightarrow> 'b::comm_monoid_add set"
  assumes "\<And>A B. f(A) + f(B) = f(A + B)" "f {0} = {0}"
  shows "f (sum S I) = sum (f \<circ> S) I"
  using sum_set_cond_linear[of "\<lambda>x. True" f I S] assms by auto

lemma set_times_Un_distrib:
  "A * (B \<union> C) = A * B \<union> A * C"
  "(A \<union> B) * C = A * C \<union> B * C"
  by (auto simp: set_times_def)

lemma set_times_UNION_distrib:
  "A * \<Union>(M ` I) = (\<Union>i\<in>I. A * M i)"
  "\<Union>(M ` I) * A = (\<Union>i\<in>I. M i * A)"
  by (auto simp: set_times_def)

end


theory Chapter3
imports Main
begin
type_synonym vname = string
datatype aexp = N int | V vname | Plus aexp aexp

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

fun aval::"aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a1 a2) s = aval a1 s + aval a2 s"

value "aval (Plus (N 3) (V ''x'')) (((\<lambda>x.0) (''x'' := 7))(''y'' := 3))"

value "aval (Plus (N 3) (V ''x'')) "

fun asimp_const::"aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V x) = V x" |
"asimp_const (Plus a1 a2) =
(case (asimp_const a1, asimp_const a2) of
  (N n1, N n2) \<Rightarrow> N(n1 + n2) |
  (b1, b2) \<Rightarrow> Plus b1 b2)"

lemma "aval (asimp_const a) s = aval a s"
  apply (induction a)
    apply (auto split: aexp.split) (*split by the definition of the aexp type*)
  done

fun plus:: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i1) (N i2) = N(i1 + i2)" |
"plus (N i) a = (if i = 0 then a else Plus (N i) a)" |
"plus a (N i) = (if i = 0 then a else Plus a (N i))" |
"plus a1 a2 = Plus a1 a2"

lemma aval_plus: "aval (plus a1 a2) s = aval a1 s + aval a2 s"
  apply (induction rule: plus.induct)
  apply (auto)
  done

fun asimp::"aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a1 a2) = plus (asimp a1) (asimp a2)"

lemma aval_asimp: "aval (asimp a) s = aval a s"
  apply (induction a)
    apply (auto split: aexp.split)
  apply (simp add: aval_plus)
  done

fun optimal::"aexp \<Rightarrow> bool" where
"optimal (N i) = True" |
"optimal (V x) = True" |
"optimal (Plus (N i) (N j)) = False" |
"optimal (Plus b1 b2) = (optimal b1 \<and> optimal b2)"

lemma asimp_const_opt: "optimal (asimp_const a)"
  apply (induction a)
    apply (auto split: aexp.split)
  done

fun sum_vals::"aexp \<Rightarrow> int" where
"sum_vals (N i) = i" |
"sum_vals (V x) = 0" |
"sum_vals (Plus a1 a2) = (sum_vals a1) + (sum_vals a2)"

lemma sum_vals_plus: "sum_vals (plus e1 e2) = sum_vals e1 + sum_vals e2"
  apply (induction rule: plus.induct)
  apply (auto)
  done

lemma sum_vals_asimp: "sum_vals (asimp e) = sum_vals e"
  apply (induction e)
    apply (auto simp add: sum_vals_plus)
  done

fun sum_vars::"aexp \<Rightarrow> aexp" where
"sum_vars (N i) = N 0" |
"sum_vars (V x) = V x" |
"sum_vars (Plus a1 a2) = Plus (sum_vars a1) (sum_vars a2)"

lemma sum_vars_asimp: "aval (asimp (sum_vars e)) s = aval (sum_vars e) s"
  apply (induction e)
    apply (auto simp add: aval_plus)
  done

fun full_asimp::"aexp \<Rightarrow> aexp" where
"full_asimp e = asimp (Plus (sum_vars e) (N (sum_vals e)))"

lemma full_asimp: "aval (full_asimp a) s = aval a s"
  apply (induction a)
    apply (auto simp add: aval_plus sum_vars_asimp sum_vals_asimp)
  done

fun subst::"vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"subst x y (V n) = (if x = n then y else (V n))" |
"subst x y (N n) = N n" |
"subst x y (Plus a1 a2) = Plus (subst x y a1) (subst x y a2)"

lemma substitution_lemma: "aval (subst x a e) s = aval e (s(x := aval a s))"
  apply (induction e)
  apply (auto split: if_splits)
  done

lemma subst_eq: "aval a1 s = aval a2 s \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
  apply (induction a1 arbitrary: a2)
  apply (auto simp add: substitution_lemma)
  done

end


theory Exercise_2_6
imports Main
begin
datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun contents :: "'a tree \<Rightarrow> 'a list" where
  "contents Tip = []" |
  "contents (Node l a r) = (contents l)@(a#(contents r))"

fun treesum :: "nat tree \<Rightarrow> nat" where
  "treesum Tip = 0" |
  "treesum (Node l a r) = (treesum l) + a + (treesum r)"

fun listsum :: "nat list \<Rightarrow> nat" where
  "listsum [] = 0" |
  "listsum (x#xs) = x + (listsum xs)"

lemma listsum_app[simp]: "listsum (x@y) = (listsum x) + (listsum y)"
  apply(induction x)
  apply(auto)
  done

lemma treelist_sum: "treesum t = listsum(contents t)"
  apply(induction t)
  apply(auto)
  done


section \<open> Cardinality of the continuum \<close>

theory Continuum
  imports
    Lightweight_Cardinals
    Finite_Bijection
    HOL.Transcendental
    Real_Bit
    "Z_Toolkit.Countable_Set_Extra"
    "Z_Toolkit.Positive"
begin

subsection \<open> Cardinality $\mathfrak{c}$ \<close>

text \<open> This theory introduces definitions and type class that group Isabelle types that have
        cardinality of up to the cardinality of the continuum (i.e. $|\mathbb{R}| = \mathfrak{c}$). We can
        then use the type class to exhibit injections into a universe of types of up to cardinality
        $\mathfrak{c}$, which we can then can then be used to introduce deeply encoded types into the UTP model.
        Though restricting ourselves to types of cardinality $\mathfrak{c}$ may seem limiting, this seems
        to be a decently large universe that even for instance includes countable sets of real numbers.

        Countable types in HOL are specified using the @{term countable} predicate, which includes both
        types that are finite, and also countably infinite. Effectively then, the @{term countable} predicate
        characterises types with cardinality up to $\aleph_0$. We will create an analogous constant called
        \emph{continuum} that characterises types up to cardinality $\mathfrak{c}$.
        Since we don't have the continuum hypothesis in HOL, we explicitly require that types of up to cardinality $\mathfrak{c}$
        either exhibit an injection into the natural numbers (for types of finite or $\aleph_0$ cardinality)
        or a bijection with the set of natural numbers ($\mathbb{P}\,\mathbb{N}$). With informal justification by
        the continuum hypothesis there should be no types in between these two possibilities. \<close>

definition continuum :: "'a set \<Rightarrow> bool" where
"continuum A \<longleftrightarrow> (\<exists> to_nat :: 'a \<Rightarrow> nat. inj_on to_nat A) \<or> (\<exists> to_nat_set :: 'a \<Rightarrow> nat set. bij_betw to_nat_set A UNIV)"

abbreviation "\<N> \<equiv> UNIV :: nat set"
abbreviation "\<P>\<N> \<equiv> UNIV :: nat set set"

text \<open> The continuum can be equivalently characterised using HOL cardinals as types whose cardinality
        is less than or equal to $\aleph_0$, or else with cardinality equal to $\mathfrak{c}$. \<close>

lemma continuum_as_card:
  "continuum A \<longleftrightarrow> |A| \<le>o |\<N>| \<or> |A| =o |\<P>\<N>|"
  by (simp add: continuum_def card_of_ordIso[THEN sym] card_of_ordLeq[THEN sym])

text \<open> We now prove that certain sets are within the continuum; firstly empty sets. \<close>

lemma continuum_empty [simp]:
  "continuum {}"
  by (simp add: continuum_def)

lemma countable_continuum:
  "countable A \<Longrightarrow> continuum A"
  by (simp add: continuum_def countable_def)

lemma continuum_bij_betw:
  "\<lbrakk> continuum A; bij_betw f A B \<rbrakk> \<Longrightarrow> continuum B"
  by (simp add: continuum_as_card, meson bij_betw_inv_into card_of_ordIsoI ordIso_ordLeq_trans ordIso_transitive)

lemma continuum_prod_lemma:
  assumes "A \<noteq> {}" "|A| \<le>o |\<N>|" "|B| =o |\<P>\<N>|"
  shows "|A \<times> B| =o |\<P>\<N>|"
proof -
  have "|A| \<le>o |B|"
  proof -
    have "|\<N>| <o |\<P>\<N>|"
      by (rule card_of_set_type)
    with assms(2) have "|A| <o |\<P>\<N>|"
      using ordIso_ordLess_trans ordLess_lemma ordLess_transitive by blast
    with assms(3)[THEN ordIso_symmetric] have "|A| <o |B|"
      using ordLess_ordIso_trans by blast
    thus ?thesis
      using ordLess_imp_ordLeq by blast
  qed
  moreover from assms(3) have "infinite B"
    using Finite_Set.finite_set card_of_ordIso_finite by blast
  ultimately have "|A \<times> B| =o |B|"
    using assms(1) card_of_Times_infinite
      by (auto)
  with assms(3) show ?thesis
    using ordIso_transitive by (blast)
qed

text \<open> The product of two types, both of whose cardinality is up to $\mathfrak{c}$, is again $\mathfrak{c}$ \<close>

lemma continuum_prod:
  assumes "continuum A" "continuum B"
  shows "continuum (A \<times> B)"
proof (cases "A = {} \<or> B = {}")
  case True
  thus ?thesis by (auto)
next
  case False
  hence nemp: "A \<noteq> {}" "B \<noteq> {}"
    by (auto)

  with nemp have "|A| \<le>o |\<N>| \<Longrightarrow> |B| =o |\<P>\<N>| \<Longrightarrow> |A \<times> B| =o |\<P>\<N>|"
    by (auto intro: continuum_prod_lemma)

  moreover have "|A| =o |\<P>\<N>| \<Longrightarrow> |B| \<le>o |\<N>| \<Longrightarrow> |A \<times> B| =o |\<P>\<N>|"
  proof -
    assume as: "|A| =o |\<P>\<N>|" "|B| \<le>o |\<N>|"
    have "|A \<times> B| =o |B \<times> A|"
      using card_of_Times_commute by fastforce
    with as show ?thesis
      using nemp continuum_prod_lemma[of B A] ordIso_transitive
      by (auto)
  qed

  moreover have "|A| =o |\<P>\<N>| \<Longrightarrow> |B| =o |\<P>\<N>| \<Longrightarrow> |A \<times> B| =o |\<P>\<N>|"
  proof -
    assume as: "|A| =o |\<P>\<N>|" "|B| =o |\<P>\<N>|"
    have "|\<P>\<N> \<times> \<P>\<N>| =o |\<P>\<N>|"
      using card_of_Times_same_infinite
      by force
    moreover from as have "|A \<times> B| =o |\<P>\<N> \<times> \<P>\<N>|"
      by (rule card_of_Times_cong)
    ultimately show ?thesis
      using ordIso_transitive by blast
  qed

  ultimately show ?thesis using assms
    apply (simp add: continuum_as_card)
    apply (erule disjE; erule disjE)
    apply (blast intro: card_of_Times_ordLeq_infinite)
    apply (rule disjI2)
    apply (simp_all)
  done
qed

text \<open> A list of continuum sets is in the continuum \<close>

lemma continuum_lists:
  assumes "continuum A"
  shows "continuum (lists A)"
  by (meson assms bij_betw_inv continuum_bij_betw countable_continuum countable_lists lists_infinite_bij_betw uncountable_infinite)

text \<open> A countable set over a type of cardinality up to $\mathfrak{c}$ has cardinality up to $\mathfrak{c}$. \<close>

lemma continuum_csets:
  assumes "continuum A"
  shows "continuum (csets A)"
proof (cases "countable A")
  case True note count = this
  thus ?thesis
  proof (cases "finite A")
    case True
    hence "finite (csets A)"
      by (simp add: csets_def)
    thus ?thesis
      using countable_continuum uncountable_infinite by blast
  next
    case False
    with count obtain to_nat where "bij_betw to_nat A \<N>"
      by blast
    moreover hence "bij_betw (\<lambda> B. to_nat ` B) (Pow A) \<P>\<N>"
      using bij_betw_image_Pow by force
    moreover have "rcset ` csets A \<subseteq> Pow A"
      by (auto simp add: csets_def)
    ultimately have "bij_betw (\<lambda> B. to_nat ` B) (rcset ` csets A) \<P>\<N>"
      by (metis (no_types, lifting) Collect_mono Pow_def count countable_subset csets.rep_eq subset_antisym)
    moreover have "bij_betw rcset (csets A) (rcset ` csets A)"
      by (auto intro: bij_betwI' simp add: rcset_inject)
    ultimately have "bij_betw ((\<lambda> B. to_nat ` B) \<circ> rcset) (csets A) \<P>\<N>"
      by (simp add: bij_betw_def comp_inj_on image_comp)
    thus ?thesis
      by (auto simp add: continuum_def)
  qed
next
  case False
  then obtain to_nat_set :: "'a \<Rightarrow> nat set" where "bij_betw to_nat_set A \<P>\<N>"
    using assms continuum_def countableI by blast
  hence "bij_betw (\<lambda> B. to_nat_set `\<^sub>c B) (csets A) UNIV"
    by (metis bij_betw_image_csets csets_UNIV)
    thm bij_betw_trans
  hence "bij_betw (nat_set_cset_bij \<circ> (\<lambda> B. to_nat_set `\<^sub>c B)) (csets A) \<P>\<N>"
    using bij_betw_trans bij_nat_set_cset_bij by blast
  thus ?thesis
    by (auto simp add: continuum_def)
qed

subsection \<open> Continuum class \<close>

class continuum =
  assumes ex_continuum_inj: "(\<exists> to_nat :: 'a \<Rightarrow> nat. inj to_nat) \<or> (\<exists> to_nat_set :: 'a \<Rightarrow> nat set. bij to_nat_set)"
begin
  lemma continuum: "continuum (UNIV :: 'a set)"
    by (simp add: continuum_def ex_continuum_inj)
end

lemma continuum_classI: "continuum (UNIV :: 'a set) \<Longrightarrow> OFCLASS('a, continuum_class)"
  by (intro_classes, simp add: continuum_def)

lemma uncountable_continuum:
  "uncountable (UNIV :: 'a::continuum set) \<Longrightarrow> (\<exists> to_nat_set :: 'a \<Rightarrow> nat set. bij to_nat_set)"
  using countableI ex_continuum_inj by blast

definition to_nat_set :: "'a::continuum \<Rightarrow> nat set" where
  "to_nat_set = (if (countable (UNIV::'a set)) then (SOME f. inj f) else (SOME f. bij f))"

definition from_nat_set :: "nat set \<Rightarrow> 'a::continuum" where
  "from_nat_set = inv (to_nat_set :: 'a \<Rightarrow> nat set)"

lemma to_nat_set_inj [simp]: "inj to_nat_set"
proof (cases "countable (UNIV :: 'a set)")
  case False
  then obtain to_nat_set :: "'a \<Rightarrow> nat set" where "bij to_nat_set"
    using uncountable_continuum by auto
  thus ?thesis
    by (simp add: to_nat_set_def, metis bij_betw_imp_inj_on someI_ex)
next
  case True
  hence "(\<exists> to_nat :: 'a \<Rightarrow> nat. inj to_nat)"
    using ex_continuum_inj by blast
  then obtain to_nat :: "'a \<Rightarrow> nat" where "inj to_nat"
    by auto
  hence "inj (\<lambda> x. {to_nat x})"
    by (meson injD injI singleton_inject)
  thus ?thesis using True
    by (auto simp add: to_nat_set_def, metis someI_ex)
qed

lemma to_nat_set_bij:
  assumes "uncountable (UNIV :: 'a::continuum set)"
  shows "bij (to_nat_set :: 'a \<Rightarrow> nat set)"
proof -
  obtain to_nat_set :: "'a \<Rightarrow> nat set" where "bij to_nat_set"
    using assms uncountable_continuum by blast
  thus ?thesis
    by (auto simp add: to_nat_set_def assms, metis someI_ex)
qed

lemma inj_on_to_nat_set[simp, intro]: "inj_on to_nat_set S"
  using to_nat_set_inj by (auto simp: inj_on_def)

lemma surj_from_nat_set [simp]: "surj from_nat_set"
  unfolding from_nat_set_def by (simp add: inj_imp_surj_inv)

lemma to_nat_set_split [simp]: "to_nat_set x = to_nat_set y \<longleftrightarrow> x = y"
  using injD [OF to_nat_set_inj] by auto

lemma from_nat_set_to_nat_set [simp]:
  "from_nat_set (to_nat_set x) = x"
  by (simp add: from_nat_set_def)

text \<open> Every countable type is within the continuum \<close>

instance countable \<subseteq> continuum
  by (intro_classes, simp add: countable_infinite_type_inj_ex)

text \<open> We construct bijective versions of @{const to_nat_set} and @{const from_nat_set} \<close>

definition to_nat_set_bij :: "'a::{continuum, infinite} \<Rightarrow> nat set" where
"to_nat_set_bij = (SOME f. bij f)"

lemma to_nat_set_bij:
  "bij to_nat_set_bij"
  apply (auto simp add: bij_def)
  oops

text \<open> The real numbers are in the continuum -- this requires a proof that $|\mathbb{P}\,\mathbb{N}| = |\mathbb{R}|$
 that we have proved elsewhere. \<close>

instance real :: continuum
  using real_nats_bij by (intro_classes, blast)

text \<open> Any set over a countable type is within the continuum \<close>

instance set :: (countable) continuum
proof
  show "(\<exists>to_nat :: 'a set \<Rightarrow> nat. inj to_nat) \<or> (\<exists>to_nat_set :: 'a set \<Rightarrow> nat set. bij to_nat_set)"
  proof (cases "finite (UNIV :: 'a set)")
    case True
    hence "countable (UNIV :: 'a set set)"
      by (simp add: Finite_Set.finite_set countable_finite)
    then obtain to_nat :: "'a set \<Rightarrow> nat" where "inj to_nat"
      by auto
    thus ?thesis
      by (auto)
  next
    case False
    then obtain to_nat :: "'a \<Rightarrow> nat" where bij_to_nat: "bij to_nat"
      using to_nat_on_infinite[of "UNIV :: 'a set"] by auto

    let ?f = "(\<lambda> A. to_nat ` A) :: 'a set \<Rightarrow> nat set"

    from bij_to_nat have "bij ?f"
    proof -
      have "inj ?f"
        by (meson bij_betw_imp_inj_on bij_to_nat injI inj_image_eq_iff)
      moreover have "surj ?f"
      proof (clarsimp simp add: surj_def)
        fix y :: "nat set"
        have "y = to_nat ` inv to_nat ` y"
          by (simp add: bij_is_surj bij_to_nat image_f_inv_f)
        thus "\<exists>x::'a set. y = to_nat ` x"
          by (auto)
      qed
      ultimately show ?thesis
        by (simp add: bij_betw_def)
    qed
    thus ?thesis
      by (auto)
  qed
qed

text \<open> A product of two continuum types is within the continuum \<close>

instance prod :: (continuum, continuum) continuum
proof
  have "continuum (UNIV :: 'a set)" "continuum (UNIV :: 'b set)"
    by (simp_all add: continuum)
  hence "continuum ((UNIV :: 'a set) \<times> (UNIV :: 'b set))"
    by (rule continuum_prod)
  hence "continuum (UNIV :: ('a \<times> 'b) set)"
    by simp
  thus "(\<exists>to_nat :: ('a\<times>'b) \<Rightarrow> nat. inj to_nat) \<or> (\<exists>to_nat_set :: ('a\<times>'b) \<Rightarrow> nat set. bij to_nat_set)"
    by (simp add: continuum_def)
qed

text \<open> A list over a continuum type is within the continuum \<close>

instance list :: (continuum) continuum
proof
  have "continuum (UNIV :: 'a set)"
    by (simp_all add: continuum)
  hence "continuum (lists (UNIV :: 'a set))"
    using continuum_lists by blast
  thus "(\<exists>to_nat::'a list \<Rightarrow> nat. inj to_nat) \<or> (\<exists>to_nat_set::'a list \<Rightarrow> nat set. bij to_nat_set)"
    by (simp add: continuum_def)
qed

text \<open> A countable set over a continuum type is within the continuum \<close>

instance cset :: (continuum) continuum
proof
  have "continuum (UNIV :: 'a cset set)"
    by (metis continuum continuum_csets csets_UNIV)
  thus "(\<exists>to_nat :: 'a cset \<Rightarrow> nat. inj to_nat) \<or> (\<exists>to_nat_set :: 'a cset \<Rightarrow> nat set. bij to_nat_set)"
    by (simp add: continuum_def)
qed

text \<open> A positive number over a continuum type is within the continuum \<close>

lemma ge_num_infinite_if_no_top:
  "infinite {x::'a::{linorder, no_top}. n \<le> x}"
  apply (clarsimp)
  \<comment> \<open> From the assumption that the set is finite. \<close>
  apply (subgoal_tac "\<exists>y::'a. Max {x. n \<le> x} < y")
   apply (clarsimp)
   apply (metis Max_ge leD mem_Collect_eq order.strict_implies_order order_refl order_trans)
  using gt_ex apply (blast)
done

lemma less_zero_ordLeq_ge_zero:
  "|{x::'a::{ordered_ab_group_add}. x < 0}| \<le>o |{x::'a. 0 \<le> x}|"
  apply (rule_tac f = "uminus" in surj_imp_ordLeq)
  apply (simp add: image_def)
  apply (clarsimp)
  apply (rule_tac x = "- x" in exI)
  apply (simp)
done

instance pos :: ("{zero, linorder, no_top}") two ..

text \<open> The next theorem is not entirely trivial to prove! \<close>

instance pos :: ("{linordered_ab_group_add, no_top, continuum}") continuum
  apply (intro_classes)
  apply (case_tac "countable (UNIV :: 'a set)")
    \<comment> \<open> Subgoal 1 (Easy Case) \<close>
   apply (rule disjI1)
   apply (subgoal_tac "\<exists>to_nat::'a \<Rightarrow> nat. inj to_nat")
    \<comment> \<open> Subgoal 1.1 \<close>
    apply (clarsimp)
    apply (thin_tac "countable UNIV")
    apply (rule_tac x = "to_nat o Rep_pos" in exI)
    apply (rule inj_compose)
     apply (assumption)
    apply (meson Rep_pos_inject injI)
    \<comment> \<open> Subgoal 1.2 \<close>
   apply (blast)
    \<comment> \<open> Subgoal 2 \<close>
  apply (rule disjI2)
  apply (subst sym [OF equal_card_bij_betw])
  apply (rule equal_card_intro)
  apply (subgoal_tac "|UNIV::'a pos set| =o |{x::'a. 0 \<le> x}|")
    \<comment> \<open> Subgoal 2.1 \<close>
   apply (erule ordIso_transitive)
   apply (rule ordIso_symmetric)
   apply (subgoal_tac "|UNIV::nat set set| =o |UNIV::'a set|")
    \<comment> \<open> Subgoal 2.1.1 \<close>
    apply (erule ordIso_transitive)
    apply (subgoal_tac "(UNIV::'a set) = {x.0 \<le> x} \<union> {x. x < 0}")
    \<comment> \<open> Subgoal 2.1.1.1 \<close>
     apply (erule ssubst)
     apply (rule card_of_Un_infinite_simps(1))
      apply (rule ge_num_infinite_if_no_top)
     apply (rule less_zero_ordLeq_ge_zero)
    \<comment> \<open> Subgoal 2.1.1.2 \<close>
    apply (auto)
    \<comment> \<open> Subgoal 2.1.2 \<close>
   apply (rule_tac f = "from_nat_set" in card_of_ordIsoI)
   apply (rule_tac bij_betwI'; clarsimp?)
    \<comment> \<open> This is the only place where @{term "countable UNIV"} is needed. \<close>
    apply (metis bij_betw_imp_surj from_nat_set_def surj_f_inv_f to_nat_set_bij)
   apply (rule_tac x = "to_nat_set y" in exI)
   apply (clarsimp)
    \<comment> \<open> Subgoal 2.2 \<close>
  apply (rule_tac f = "Rep_pos" in card_of_ordIsoI)
  apply (rule_tac bij_betwI'; clarsimp?)
    apply (simp add: Rep_pos_inject)
  using Rep_pos apply (blast)
  apply (rule_tac x = "Abs_pos y" in exI)
  apply (simp add: Abs_pos_inverse)
done

end


section \<open>Baby examples\<close>

theory Baby
  imports "HOL-Library.Sum_of_Squares"
          "HOL-Decision_Procs.Approximation"
          "HOL-Analysis.Analysis"

begin

text \<open>a simplification rule for powers\<close>
thm power_Suc

text \<open>Kevin Buzzard's examples\<close>
lemma
  fixes x::real
  shows "(x+y)*(x+2*y)*(x+3*y) = x^3 + 6*x^2*y + 11*x*y^2 + 6*y^3"
  by (simp add: algebra_simps eval_nat_numeral)

lemma "sqrt 2 + sqrt 3 < sqrt 10"
proof -
  have "(sqrt 2 + sqrt 3)^2 < (sqrt 10)^2"
  proof (simp add: algebra_simps eval_nat_numeral)
    have "(2 * (sqrt 2 * sqrt 3))^2 < 5 ^ 2"
      by (simp add: algebra_simps eval_nat_numeral)
    then show "2 * (sqrt 2 * sqrt 3) < 5"
      by (smt (verit, best) power_mono)
  qed
  then show ?thesis
    by (simp add: real_less_rsqrt)
qed

lemma "sqrt 2 + sqrt 3 < sqrt 10"
  by (approximation 10)

lemma "x \<in> {0.999..1.001} \<Longrightarrow> \<bar>pi - 4 * arctan x\<bar> < 0.0021"
  by (approximation 20)

lemma "3.141592635389 < pi"
  by (approximation 30)

lemma
  fixes a::real
  shows "(a*b + b * c + c*a)^3 \<le> (a^2 + a * b + b^2) * (b^2 + b * c + c^2) * (c^2 + c*a + a^2)"
  by sos

lemma "sqrt 2 \<notin> \<rat>"
proof
  assume "sqrt 2 \<in> \<rat>"
  then obtain q::rat where "sqrt 2 = of_rat q"
    using Rats_cases by blast
  then have "q^2 = 2"
    by (metis abs_numeral of_rat_eq_iff of_rat_numeral_eq of_rat_power power2_eq_square
              real_sqrt_mult_self)
  then obtain m n where "coprime m n" "q = of_int m / of_int n"
    by (metis Fract_of_int_quotient Rat_cases)
  then have "of_int m ^ 2 / of_int n ^ 2 = (2::rat)"
    by (metis \<open>q\<^sup>2 = 2\<close> power_divide)
  then have 2: "of_int m ^ 2 = (2::rat) * of_int n ^ 2"
    by (metis division_ring_divide_zero double_eq_0_iff mult_2_right mult_zero_right
              nonzero_divide_eq_eq)
  then have "2 dvd m"
    by (metis (mono_tags, lifting) even_mult_iff even_numeral of_int_eq_iff of_int_mult
              of_int_numeral power2_eq_square)
  then obtain r where "m = 2*r"
    by blast
  then have "2 dvd n"
    by (smt (verit) "2" \<open>even m\<close> dvdE even_mult_iff mult.left_commute mult_cancel_left of_int_1
            of_int_add of_int_eq_iff of_int_mult one_add_one power2_eq_square)
  then show False
    using \<open>coprime m n\<close> \<open>m = 2 * r\<close> by simp
qed

subsection \<open>Material for a later post, about descriptions\<close>

lemma
  fixes \<B> :: "'a::metric_space set set" and L :: "nat list set"
  assumes "\<S> \<subseteq> {ball x r | x r. r>0}" and "L \<noteq> {}"
  shows "P \<S> L"
proof -
  have "\<And>B. B \<in> \<S> \<Longrightarrow> \<exists>x. \<exists>r>0. B = ball x r"
    using assms by blast
  then obtain centre rad where rad: "\<And>B. B \<in> \<S> \<Longrightarrow> rad B > 0"
                         and centre: "\<And>B. B \<in> \<S> \<Longrightarrow> B = ball (centre B) (rad B)"
    by metis
  define infrad where "infrad \<equiv> Inf (rad ` \<S>)"
  have "infrad \<le> rad B" if "B \<in> \<S>" for B
    by (smt (verit, best) bdd_below.I cINF_lower image_iff infrad_def rad that)

  have "\<exists>B \<in> \<S>. rad B = infrad" if "finite \<S>" "\<S> \<noteq> {}"
    by (smt (verit) empty_is_image finite_imageI finite_less_Inf_iff imageE infrad_def that)

  define minl where "minl = Inf (length ` L)"
  obtain l0 where  "l0 \<in> L" "length l0 = minl"
    by (metis Inf_nat_def1 empty_is_image imageE minl_def \<open>L \<noteq> {}\<close>)
  then have "length l0 \<le> length l" if "l \<in> L" for l
    by (simp add: cINF_lower minl_def that)

  show ?thesis
    sorry
qed

end


theory Exe4p5
  imports Main
begin

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

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

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
refl: "star r x x" |
step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
iter_refl: "iter r 0 x x" |
iter_step: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

lemma fixes r n x y
  assumes s: "iter r n x y"
  shows "star r x y"
proof -
  have "iter r n x y \<Longrightarrow> star r x y"
  proof (induction rule: iter.induct)
    case (iter_refl r x)
    then show ?case by (simp add: star.refl)
  next
    case (iter_step r x y n z)
    then show ?case by (simp add: star.step)
  qed
  thus ?thesis using s by simp
qed