theory Chapter5
imports Main
begin

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"

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

text\<open>
\section*{Chapter 5}

\exercise
Give a readable, structured proof of the following lemma:
\<close>
lemma assumes T: "\<forall>x y. T x y \<or> T y x"
  and A: "\<forall>x y. A x y \<and> A y x \<longrightarrow> x = y"
  and TA: "\<forall>x y. T x y \<longrightarrow> A x y" and "A x y"
  shows "T x y"
(* your definition/proof here *)
proof (cases "T x y")
  assume "T x y"
  thus ?thesis by auto
next
  assume "\<not>(T x y)"
  hence "T y x" using T by auto
  hence "A y x" using TA by auto
  hence "x = y" using A `A x y` by auto
  hence "T x y" using `T y x` `A y x` by auto
  thus ?thesis by auto
qed

text\<open>
Each step should use at most one of the assumptions @{text T}, @{text A}
or @{text TA}.
\endexercise

\exercise
Give a readable, structured proof of the following lemma:
\<close>
lemma "(\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs)
      \<or> (\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs + 1)"
(* your definition/proof here *)
proof cases
  assume "2 dvd (length xs)"
  hence "\<exists>k. 2 * k = (length xs)" by auto
  then obtain k where "2 * k = (length xs)" by auto
  then moreover obtain ys zs where "(ys = (take k xs)) \<and> (zs = (drop k xs))" by auto
  ultimately have "length ys = length zs \<and> xs = ys @ zs" by auto
  then show ?thesis by auto
next
  assume "\<not>(2 dvd (length xs))"
  hence "\<exists>k. (2 * k + 1) = (length xs)" by (metis oddE)
  then obtain k where "2 * k + 1 = (length xs)" by auto
  then moreover obtain ys zs where "(ys = (take (k + 1) xs)) \<and> (zs = (drop (k + 1) xs))" by auto
  ultimately have "length ys = length zs + 1 \<and> xs = ys @ zs" by auto
  then show ?thesis by auto
qed

text\<open>
Hint: There are predefined functions @{const take} and {const drop} of type
@{typ "nat \<Rightarrow> 'a list \<Rightarrow> 'a list"} such that @{text"take k [x\<^sub>1,\<dots>] = [x\<^sub>1,\<dots>,x\<^sub>k]"}
and @{text"drop k [x\<^sub>1,\<dots>] = [x\<^bsub>k+1\<^esub>,\<dots>]"}. Let sledgehammer find and apply
the relevant @{const take} and @{const drop} lemmas for you.
\endexercise

\exercise
Give a structured proof by rule inversion:
\<close>
inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS: "ev n \<Longrightarrow> ev(Suc(Suc n))"

lemma assumes a: "ev(Suc(Suc n))" shows "ev n"
proof -
  show ?thesis using assms
  proof cases
    case evSS
    then show ?thesis by auto
  qed
qed

text\<open>
\exercise
Give a structured proof by rule inversions:
\<close>

lemma "\<not> ev(Suc(Suc(Suc 0)))"
proof
  assume "ev (Suc (Suc (Suc 0)))"
  then show False using ev.cases by auto
qed

text\<open>
If there are no cases to be proved you can close
a proof immediateley with \isacom{qed}.
\endexercise

\exercise
Recall predicate @{const star} from Section 4.5 and @{const iter}
from Exercise~\ref{exe:iter}.
\<close>

lemma "iter r n x y \<Longrightarrow> star r x y"
proof (induction n x y rule: iter.induct)
  case (iter_0 x)
  then show "star r x x" by (simp add: star.refl)
next
  case (iter_Suc x y n z)
  have "star r y z" using iter_Suc.IH by simp
  moreover have "r x y" using iter_Suc.hyps by simp
  ultimately show "star r x z" by (simp add: star.refl star.step)
qed

text\<open>
Prove this lemma in a structured style, do not just sledgehammer each case of the
required induction.
\endexercise

\exercise
Define a recursive function
\<close>

fun elems :: "'a list \<Rightarrow> 'a set" where
"elems Nil = {}" |
"elems (x#xs) = {x} \<union> (elems xs)"
(* your definition/proof here *)

text\<open> that collects all elements of a list into a set. Prove \<close>

lemma "x \<in> elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys"
proof (cases xs)
  case (Cons a list)
  then show ?thesis
  proof cases
    assume "a = x"
    moreover obtain ys where ys: "(ys::'a list) = []" by auto
    moreover obtain zs where zs: "zs = xs" by auto
    moreover have "x \<notin> elems ys" by (simp add: calculation(2))
    moreover have idk: "xs = ys @ zs" using ys zs by auto
    ultimately show ?thesis using local.Cons by fastforce
  next
    show ?thesis proof -
      assume 0: "xs = a#list \<and> a \<noteq> x"
      assume IH: "(x \<in> elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys)"
      assume 1: "x \<in> elems xs"
      then obtain ys ys1 zs zs1 where
        "x \<notin> elems ys"
        "ys = a#ys1"
        "xs = a#ys1 @ zs"
        "zs = x#zs1"
        using 0 IH by (metis append_eq_Cons_conv list.inject local.Cons)
      hence "xs = ys @ x # zs1 \<and> x \<notin> elems ys" by simp
      thus show ?thesis sorry
    qed
  qed
qed

text\<open>
\endexercise

\exercise
Extend Exercise~\ref{exe:cfg} with a function that checks if some
\mbox{@{text "alpha list"}} is a balanced
string of parentheses. More precisely, define a recursive function \<close>
(* your definition/proof here *)
fun balanced :: "nat \<Rightarrow> alpha list \<Rightarrow> bool" where
(* your definition/proof here *)

text\<open> such that @{term"balanced n w"}
is true iff (informally) @{text"a\<^sup>n @ w \<in> S"}. Formally, prove \<close>

corollary "balanced n w \<longleftrightarrow> S (replicate n a @ w)"

text\<open> where @{const replicate} @{text"::"} @{typ"nat \<Rightarrow> 'a \<Rightarrow> 'a list"} is predefined
and @{term"replicate n x"} yields the list @{text"[x, \<dots>, x]"} of length @{text n}.
\<close>

end


theory Pugh
 imports "HOL-Analysis.Analysis"
begin

(*
problem_number:2_12a
natural language statement:
Let $(p_n)$ be a sequence and $f:\mathbb{N}\to\mathbb{N}$ a bijection. The sequence $(q_k)_{k\in\mathbb{N}}$ with $q_k=p_{f(k)}$ is called a rearrangement of $(p_n)$. Show that if $f$ is an injection, the limit of a sequence is unaffected by rearrangement.
lean statement:
theorem exercise_2_12a (f : \<nat> \<rightarrow> \<nat>) (p : \<nat> \<rightarrow> \<real>) (a : \<real>)
  (hf : injective f) (hp : tendsto p at_top (𝓝 a)) :
  tendsto (\<lambda> n, p (f n)) at_top (𝓝 a) :=

codex statement:
theorem lim_of_rearrangement_of_injective:
  fixes f::"nat \<Rightarrow> nat" and p::"nat \<Rightarrow> 'a::real_normed_vector"
  assumes "inj f" "convergent p"
  shows "convergent (\<lambda>n. p (f n))"
Our comment on the codex statement: a start, but the real meaning was not preserved
 *)
theorem exercise_2_12a:
  fixes f::"nat \<Rightarrow> nat" and p::"nat \<Rightarrow> 'a::real_normed_vector"
  assumes "inj f"
  shows "(\<lambda>n. p (f n)) \<longlonglongrightarrow> a  \<longleftrightarrow>  p \<longlonglongrightarrow> a"
  oops

(*
problem_number:2_12b
natural language statement:
Let $(p_n)$ be a sequence and $f:\mathbb{N}\to\mathbb{N}$ a bijection. The sequence $(q_k)_{k\in\mathbb{N}}$ with $q_k=p_{f(k)}$ is called a rearrangement of $(p_n)$. Show that if $f$ is a surjection, the limit of a sequence is unaffected by rearrangement.
lean statement:
theorem exercise_2_12b (f : \<nat> \<rightarrow> \<nat>) (p : \<nat> \<rightarrow> \<real>) (a : \<real>)
  (hf : surjective f) (hp : tendsto p at_top (𝓝 a)) :
  tendsto (\<lambda> n, p (f n)) at_top (𝓝 a) :=

codex statement:
theorem lim_of_rearrangement_of_surjection:
  fixes f::"nat \<Rightarrow> nat" and p::"nat \<Rightarrow> 'a::real_normed_vector"
  assumes "bij f" "surj f" "\<forall>n. p n = q (f n)" "convergent p"
  shows "convergent q \<and> lim p = lim q"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_2_12b: (*The informal versions of both exercises are ambiguous: is it given that the original sequence converges?*)
  fixes f::"nat \<Rightarrow> nat" and p::"nat \<Rightarrow> 'a::real_normed_vector"
  assumes "surj f"
  shows "(\<lambda>n. p (f n)) \<longlonglongrightarrow> a  \<longleftrightarrow>  p \<longlonglongrightarrow> a"
  oops

(*
problem_number:2_26
natural language statement:
Prove that a set $U \subset M$ is open if and only if none of its points are limits of its complement.
lean statement:
theorem exercise_2_26 {M : Type*} [topological_space M]
  (U : set M) : is_open U \<longleftrightarrow> \<forall> x \<in> U, \<not> cluster_pt x (𝓟 Uᶜ) :=

codex statement:
theorem open_iff_no_limit_point_of_complement:
  fixes U::"'a::metric_space set"
  shows "open U \<longleftrightarrow> \<forall>x\<in>U. \<not>(x islimpt (-U))"
Our comment on the codex statement:  Syntactically correct, but with the addition of parentheses, good (type class version)
 *)
theorem exercise_2_26:
  fixes U::"'a::metric_space set"
  shows "open U \<longleftrightarrow> (\<forall>x\<in>U. \<not>(x islimpt (-U)))"
  oops

(*
problem_number:2_29
natural language statement:
Let $\mathcal{T}$ be the collection of open subsets of a metric space $\mathrm{M}$, and $\mathcal{K}$ the collection of closed subsets. Show that there is a bijection from $\mathcal{T}$ onto $\mathcal{K}$.
lean statement:
theorem exercise_2_29 (M : Type* ) [metric_space M]
  (O C : set (set M))
  (hO : O = {s | is_open s})
  (hC : C = {s | is_closed s}) :
  \<exists> f : O \<rightarrow> C, bijective f :=

codex statement:
theorem bijection_open_closed:
  fixes M::"'a::metric_space set"
  shows "bij_betw (\<lambda>U. closure U) (open_sets M) (closed_sets M)"
Our comment on the codex statement:  interesting but clearly wrong guess of the bijection (which must be complementation)
 *)
theorem exercise_2_29:
  fixes M::"'a::metric_space set"
  shows "\<exists>f. bij_betw f {S. open S} {S. closed S}"
  oops

(*
problem_number:2_32a
natural language statement:
Show that every subset of $\mathbb{N}$ is clopen.
lean statement:
theorem exercise_2_32a (A : set \<nat>) : is_clopen A :=

codex statement:
theorem clopen_of_subset_nat:
  fixes A::"nat set"
  shows "closed_in (top_of_set UNIV) A \<and> open_in (top_of_set UNIV) A"
Our comment on the codex statement: close, but it didn't know about discrete_topology
 *)
theorem exercise_2_32a:
  fixes A::"nat set"
    shows "closedin (discrete_topology UNIV) A \<and> openin (discrete_topology UNIV) A"
  by simp

(*
problem_number:2_41
natural language statement:
Let $\|\cdot\|$ be any norm on $\mathbb{R}^{m}$ and let $B=\left\{x \in \mathbb{R}^{m}:\|x\| \leq 1\right\}$. Prove that $B$ is compact.
lean statement:
theorem exercise_2_41 (m : \<nat>) {X : Type*} [normed_space \<real> ((fin m) \<rightarrow> \<real>)] :
  is_compact (metric.closed_ball 0 1) :=

codex statement:
theorem compact_of_norm_leq_one:
  fixes m::nat and f::"nat \<Rightarrow> real"
  assumes "norm f \<le> 1"
  shows "compact {x::'a::euclidean_space. \<forall>i. norm (x$i) \<le> f i}"
Our comment on the codex statement: seemingly inserted its own definition of norm, and we can't capture "any norm"
 *)
theorem exercise_2_41:
  shows "compact {x. norm x \<le> 1}"
  oops

(*
problem_number:2_46
natural language statement:
Assume that $A, B$ are compact, disjoint, nonempty subsets of $M$. Prove that there are $a_0 \in A$ and $b_0 \in B$ such that for all $a \in A$ and $b \in B$ we have $d(a_0, b_0) \leq d(a, b)$.
lean statement:
theorem exercise_2_46 {M : Type*} [metric_space M]
  {A B : set M} (hA : is_compact A) (hB : is_compact B)
  (hAB : disjoint A B) (hA₀ : A \<noteq> \<emptyset>) (hB₀ : B \<noteq> \<emptyset>) :
  \<exists> a₀ b₀, a₀ \<in> A \<and> b₀ \<in> B \<and> \<forall> (a : M) (b : M),
  a \<in> A \<rightarrow> b \<in> B \<rightarrow> dist a₀ b₀ \<le> dist a b :=

codex statement:
theorem exists_min_distance_of_compact_disjoint_nonempty:
  fixes A B::"'a::metric_space set"
  assumes "compact A" "compact B" "A \<inter> B = {}" "A \<noteq> {}" "B \<noteq> {}"
  shows "\<exists>a b. a\<in>A \<and> b\<in>B \<and> (\<forall>a'\<in>A. \<forall>b'\<in>B. dist a b \<le> dist a' b')"
Our comment on the codex statement: perfect!
 *)
theorem exercise_2_46:
  fixes A B::"'a::metric_space set"
  assumes "compact A" "compact B" "A \<inter> B = {}" "A \<noteq> {}" "B \<noteq> {}"
  shows "\<exists>a0 b0. a0\<in>A \<and> b0\<in>B \<and> (\<forall>a\<in>A. \<forall>b\<in>B. dist a0 b0 \<le> dist a b)"
  oops

(*
problem_number:2_48
natural language statement:
Prove that there is an embedding of the line as a closed subset of the plane, and there is an embedding of the line as a bounded subset of the plane, but there is no embedding of the line as a closed and bounded subset of the plane.
lean statement:

codex statement:
theorem exists_embedding_of_line_as_closed_subset_of_plane:
  fixes f::"real \<Rightarrow> 'a::euclidean_space"
  assumes "continuous_on UNIV f" "inj_on f UNIV" "f ` UNIV \<subseteq> (UNIV::'a set)"
  shows "closedin (subtopology euclidean (UNIV::'a set)) (f ` UNIV)"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_2_48:
  shows "\<exists>f::real \<Rightarrow> complex. inj f \<and> closed (range f)"
        "\<exists>f::real \<Rightarrow> complex. inj f \<and> bounded (range f)"
        "\<nexists>f::real \<Rightarrow> complex. inj f \<and> closed (range f) \<and> bounded (range f)"
  oops

(*
problem_number:2_56
natural language statement:
Prove that the 2-sphere is not homeomorphic to the plane.
lean statement:

codex statement:
theorem sphere_not_homeomorphic_to_plane:
  fixes S::"real^2 set"
  assumes "S homeomorphic (sphere (0,1))"
  shows False
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_2_56: "\<not> sphere (0::real^3) 1 homeomorphic (UNIV::complex set)"
  oops

(*
problem_number:2_57
natural language statement:
Show that if $S$ is connected, it is not true in general that its interior is connected.
lean statement:
theorem exercise_2_57 {X : Type*} [topological_space X]
  : \<exists> (S : set X), is_connected S \<and> \<not> is_connected (interior S) :=

codex statement:
theorem interior_not_connected_of_connected:
  fixes S::"'a::euclidean_space set"
  assumes "connected S"
  shows "\<exists>T. open T \<and> connected T \<and> interior T \<subseteq> S \<and> interior T \<noteq> \<emptyset> \<and> interior T \<noteq> S"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_2_57:
    shows "\<exists>S. connectedin X S \<and> \<not> connectedin X (X interior_of S)"
oops

(*
problem_number:2_79
natural language statement:
Prove that if $M$ is nonempty compact, locally path-connected and connected then it is path-connected.
lean statement:
theorem exercise_2_79
  {M : Type*} [topological_space M] [compact_space M]
  [loc_path_connected_space M] (hM : nonempty M)
  (hM : connected_space M) : path_connected_space M :=

codex statement:
theorem path_connected_of_nonempty_compact_locally_path_connected_connected:
  fixes M::"'a::topological_space set"
  assumes "compact M" "nonempty M" "locally path_connected M" "connected M"
  shows "path_connected M"
Our comment on the codex statement:  This version does not need the first two assumptions (why is the second one ever required)
 *)
theorem exercise_2_79:
  fixes M::"'a::topological_space set"
  assumes "compact M" "M\<noteq>{}" "locally path_connected M" "connected M"
  shows "path_connected M"
  by (simp add: assms(3) assms(4) connected_component_eq_self path_component_eq_connected_component_set path_connected_component_set)

(*
problem_number:2_85
natural language statement:
Suppose that $M$ is compact and that $\mathcal{U}$ is an open covering of $M$ which is redundant in the sense that each $p \in M$ is contained in at least two members of $\mathcal{U}$. Show that $\mathcal{U}$ reduces to a finite subcovering with the same property.
lean statement:
theorem exercise_2_85
  (M : Type* ) [topological_space M] [compact_space M]
  (U : set (set M)) (hU : \<forall> p, \<exists> (U_1 U_2 \<in> U), p \<in> U_1 \<and> p \<in> U_2 \<and> U_1 \<noteq> U_2) :
  \<exists> (V : set (set M)), set.finite V \<and>
  \<forall> p, \<exists> (V_1 V_2 \<in> V), p \<in> V_1 \<and> p \<in> V_2 \<and> V_1 \<noteq> V_2 :=

codex statement:
theorem finite_subcovering_of_redundant_open_covering:
  fixes M::"'a::metric_space set" and U::"'a set set"
  assumes "compact M" "\<forall>p\<in>M. \<exists>U_1 U_2. U_1\<in>U \<and> U_2\<in>U \<and> p\<in>U_1 \<and> p\<in>U_2"
  shows "\<exists>U'. finite U' \<and> U' \<subseteq> U \<and> \<forall>p\<in>M. \<exists>U_1 U_2. U_1\<in>U' \<and> U_2\<in>U' \<and> p\<in>U_1 \<and> p\<in>U_2"
Our comment on the codex statement:  very good except for missing parentheses
 *)
theorem exercise_2_85:
  fixes M::"'a::metric_space set" and \<U>::"'a set set"
  assumes "compact M" "\<forall>p\<in>M. \<exists>V W. V\<in>\<U> \<and> W\<in>\<U> \<and> p\<in>V \<and> p\<in>W"
  shows "\<exists>\<U>'. finite \<U>' \<and> \<U>' \<subseteq> \<U> \<and> (\<forall>p\<in>M. \<exists>V W. V\<in>\<U>' \<and> W\<in>\<U>' \<and> p\<in>V \<and> p\<in>W)"
  oops

(*
problem_number:2_92
natural language statement:
Give a direct proof that the nested decreasing intersection of nonempty covering compact sets is nonempty.
lean statement:
theorem exercise_2_92 {\<alpha> : Type*} [topological_space \<alpha>]
  {s : \<nat> \<rightarrow> set \<alpha>}
  (hs : \<forall> i, is_compact (s i))
  (hs : \<forall> i, (s i).nonempty)
  (hs : \<forall> i, (s i) \<supset> (s (i + 1))) :
  (\<Inter> i, s i).nonempty :=

codex statement:
theorem nonempty_intersection_of_nested_compact_covering_sets:
  fixes K::"nat \<Rightarrow> 'a::metric_space set"
  assumes "\<forall>n. compact (K n)" "\<forall>n. K n \<subseteq> K (Suc n)" "\<forall>n. K n \<noteq> {}"
  shows "\<exists>x. \<forall>n. x \<in> K n"
Our comment on the codex statement:  the sunset inclusion was in the wrong direction! (What does "covering" mean here?)
 *)
theorem exercise_2_92:
  fixes K::"nat \<Rightarrow> 'a::metric_space set"
  assumes "\<forall>n. compact (K n)" "\<forall>n. K (Suc n) \<subseteq> K n" "\<forall>n. K n \<noteq> {}"
  shows "\<exists>x. \<forall>n. x \<in> K n"
  oops

(*
problem_number:2_109
natural language statement:
A metric on $M$ is an ultrametric if for all $x, y, z \in M$, $d(x, z) \leq \max \{d(x, y), d(y, z)\} .$ Show that a metric space with an ultrametric is totally disconnected.
lean statement:
theorem exercise_2_109
  {M : Type*} [metric_space M]
  (h : \<forall> x y z : M, dist x z = max (dist x y) (dist y z)) :
  totally_disconnected_space M :=

codex statement:
theorem totally_disconnected_of_ultrametric:
  fixes M::"'a::metric_space metric"
  assumes "\<forall>x y z. dist x z \<le> max (dist x y) (dist y z)"
  shows "totally_disconnected (UNIV::'a set)"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_2_109: undefined oops

(*
problem_number:2_126
natural language statement:
Suppose that $E$ is an uncountable subset of $\mathbb{R}$. Prove that there exists a point $p \in \mathbb{R}$ at which $E$ condenses.
lean statement:
theorem exercise_2_126 {E : set \<real>}
  (hE : \<not> set.countable E) : \<exists> (p : \<real>), cluster_pt p (𝓟 E) :=

codex statement:
theorem exists_condensation_point_of_uncountable_subset:
  fixes E::"real set"
  assumes "uncountable E"
  shows "\<exists>p. condensation_point E p"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_2_126:
  fixes E::"real set"
  assumes "uncountable E"
  shows "\<exists>p. p islimpt E"
  oops

(*
problem_number:2_137
natural language statement:
Let $P$ be a closed perfect subset of a separable complete metric space $M$. Prove that each point of $P$ is a condensation point of $P$.
lean statement:
theorem exercise_2_137
  {M : Type*} [metric_space M] [separable_space M] [complete_space M]
  {P : set M} (hP : is_closed P)
  (hP' : is_closed P \<and> P = {x | cluster_pt x (𝓟 P)}) :
  \<forall> x \<in> P, \<forall> n \<in> (𝓝 x), \<not> set.countable n :=

codex statement:
theorem condensation_point_of_closed_perfect_subset:
  fixes P::"'a::metric_space set"
  assumes "closed P" "perfect P" "separable (UNIV::'a set)"
  shows "\<forall>x\<in>P. condensation_point P x"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_2_137: undefined oops

(*
problem_number:2_138
natural language statement:
Given a Cantor space $M \subset R^2$, given a line segment $[p, q] \subset R^2$ with $p, q \not\in M$, and given an $\epsilon > 0$, prove that there exists a path $A$ in the $\epsilon$-neighborhood of $[p, q]$ that joins $p$ to $q$ and is disjoint from $M$.
lean statement:

codex statement:
theorem exists_path_disjoint_of_Cantor_space:
  fixes M::"real set" and p q::"real^2" and \<epsilon>::real
  assumes "Cantor_space M" "p \<in> (UNIV::real^2 set) - M" "q \<in> (UNIV::real^2 set) - M" "\<epsilon> > 0"
  shows "\<exists>A. path A \<and> path_image A \<subseteq> ball p \<epsilon> \<union> ball q \<epsilon> \<and> pathstart A = p \<and> pathfinish A = q \<and> path_image A \<inter> M = {}"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_2_138: undefined oops

(*
problem_number:3_1
natural language statement:
Assume that $f \colon \mathbb{R} \rightarrow \mathbb{R}$ satisfies $|f(t)-f(x)| \leq|t-x|^{2}$ for all $t, x$. Prove that $f$ is constant.
lean statement:
theorem exercise_3_1 {f : \<real> \<rightarrow> \<real>}
  (hf : \<forall> x y, |f x - f y| \<le> |x - y| ^ 2) :
  \<exists> c, f = \<lambda> x, c :=

codex statement:
theorem constant_of_abs_diff_leq_square_diff:
  fixes f::"real \<Rightarrow> real"
  assumes "\<forall>x t. abs (f t - f x) \<le> (abs (t - x))^2"
  shows "f constant_on UNIV"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_3_1:
  fixes f::"real \<Rightarrow> real"
  assumes "\<forall>x t. \<bar>f t - f x\<bar> \<le> \<bar>t - x\<bar>^2"
  shows "f constant_on UNIV"
  oops

(*
problem_number:3_4
natural language statement:
Prove that $\sqrt{n+1}-\sqrt{n} \rightarrow 0$ as $n \rightarrow \infty$.
lean statement:
theorem exercise_3_4 (n : \<nat>) :
  tendsto (\<lambda> n, (sqrt (n + 1) - sqrt n)) at_top (𝓝 0) :=

codex statement:
theorem sqrt_succ_sub_sqrt_tendsto_zero:
  shows "(\<Sum>i=0..n. 1/(sqrt (real (Suc i)) + sqrt (real i))) \<longrightarrow> 0"
Our comment on the codex statement: This went completely wrong!
 *)
theorem exercise_3_4:
  shows "(\<lambda>n. sqrt (real (Suc n)) - sqrt (real n)) \<longlonglongrightarrow> 0"
  oops

(*
problem_number:3_11a
natural language statement:
Let $f \colon (a, b) \rightarrow \mathbb{R}$ be given.  If $f''(x)$ exists, prove that \[\lim_{h \rightarrow 0} \frac{f(x - h) - 2f(x) + f(x + h)}{h^2} = f''(x).\]
lean statement:
theorem exercise_3_11a
  {f : \<real> \<rightarrow> \<real>} {a b x : \<real>}
  (h1 : differentiable_within_at \<real> f (set.Ioo a b) x)
  (h2 : differentiable_within_at \<real> (deriv f) (set.Ioo a b) x) :
  \<exists> l, tendsto (\<lambda> h, (f (x - h) - 2 * f x + f (x + h)) / h ^ 2) (𝓝 0) (𝓝 l)
  \<and> deriv (deriv f) x = l :=

codex statement:
theorem limit_of_diff_of_diff_eq_diff_of_diff:
  fixes f::"real \<Rightarrow> real"
  assumes "\<forall>x. (f has_real_derivative f' x) (at x)" "\<forall>x. (f has_real_derivative f'' x) (at x)"
  shows "(f'' ---> f'' x) (at x)"
Our comment on the codex statement:  Conclusion completely wrong
 *)
theorem exercise_3_11a:
  fixes f::"real \<Rightarrow> real"
  assumes "a < x" "x < b"
    and "(f has_derivative f') (at x within {a<..<b})"
    and "(f' has_derivative f'') (at x within {a<..<b})"
  shows "((\<lambda>h. (f (x - h) - 2 * f x + f (x + h)) / h ^ 2) \<longlongrightarrow> f'' x) (at 0)"
  oops

(*
problem_number:3_17c-i
natural language statement:
Show that the bump function $\beta(x)=e^{2} e(1-x) \cdot e(x+1)$ is smooth.
lean statement:

codex statement:
theorem smooth_of_bump_function:
  fixes x::real
  assumes "x\<in>{-1..1}"
  shows "\<forall>n. (\<partial>^n) (\<lambda>x. exp 2 * exp (-x) * exp (x+1)) x = exp 2 * exp (-x) * exp (x+1)"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem "exercise_3_17c-i": undefined oops (* we have no way to express smoothness*)

(*
problem_number:3_17c-ii
natural language statement:
Show that the bump function $\beta(x)=e^{2} e(1-x) \cdot e(x+1)$ is identically 0 outside the interval $(-1, 1)$.
lean statement:

codex statement:
theorem bump_function_is_zero_outside_interval:
  fixes x::real
  shows "x\<le>-1 \<or> x\<ge>1 \<longrightarrow> (\<lambda>x. exp 2 * exp (-x) * exp (x+1)) x = 0"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem "exercise_3_17c-ii": undefined oops (* impossible to interpret this formula, and the conclusion seems to be false*)

(*
problem_number:3_18
natural language statement:
Let $L$ be any closed set in $\mathbb{R}$. Prove that there is a smooth function $f \colon \mathbb{R} \rightarrow [0, 1]$ such that $f(x) = 0$ if and only if $x \in L$.
lean statement:

codex statement:
theorem exists_smooth_function_of_closed_set:
  fixes L::"real set"
  assumes "closed L"
  shows "\<exists>f. (\<forall>x. f x = 0 \<longleftrightarrow> x\<in>L) \<and> (\<forall>x. f differentiable (at x))"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_3_18: undefined oops (* we have no way to express smoothness*)

(*
problem_number:3_43a
natural language statement:
Let $\psi(x) = x \sin 1/x$ for $0 < x \leq 1$ and $\psi(0) = 0$.  If $f \colon [-1, 1] \rightarrow \mathbb{R}$ is Riemann integrable, prove that $f \circ \psi$ is Riemann integrable.
lean statement:

codex statement:
theorem riemann_integrable_of_riemann_integrable_comp:
  fixes f::"real \<Rightarrow> real" and \<psi>::"real \<Rightarrow> real"
  assumes "continuous_on {0..1} \<psi>" "f integrable_on {-1..1}"
  shows "(f \<circ> \<psi>) integrable_on {0..1}"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_3_43a: undefined oops (* we do not have Riemann integrals*)

(*
problem_number:3_53
natural language statement:
Given $f, g \in \mathcal{R}$, prove that $\max(f, g)$ and $\min(f, g)$ are Riemann integrable, where $\max(f, g)(x) = \max(f(x), g(x))$ and $\min(f, g)(x) = \min(f(x), g(x))$.
lean statement:

codex statement:
theorem max_min_integrable:
  fixes f g::"real \<Rightarrow> real"
  assumes "f integrable_on {a..b}" "g integrable_on {a..b}"
  shows "(\<lambda>x. max (f x) (g x)) integrable_on {a..b}" "(\<lambda>x. min (f x) (g x)) integrable_on {a..b}"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_3_53: undefined oops(* we do not have Riemann integrals*)

(*
problem_number:3_59
natural language statement:
Prove that if $a_n \geq 0$ and $\sum a_n$ converges then $\sum \sqrt{a_n}/n$ converges.
lean statement:

codex statement:
theorem convergent_of_convergent_sum_sqrt_div_n:
  fixes a::"nat \<Rightarrow> real"
  assumes "\<forall>n. 0 \<le> a n" "summable a"
  shows "summable (\<lambda>n. sqrt (a n) / n)"
Our comment on the codex statement: Perfect!
 *)
theorem exercise_3_59:
  fixes a::"nat \<Rightarrow> real"
  assumes "\<forall>n. 0 \<le> a n" "summable a"
  shows "summable (\<lambda>n. sqrt (a n) / n)"
  oops

(*
problem_number:3_63
natural language statement:
Prove that $\sum 1/k(\log(k))^p$ converges when $p > 1$ and diverges when $p \leq 1$.
lean statement:
theorem exercise_3_63a (p : \<real>) (f : \<nat> \<rightarrow> \<real>) (hp : p > 1)
  (h : f = \<lambda> k, (1 : \<real>) / (k * (log k) ^ p)) :
  \<exists> l, tendsto f at_top (𝓝 l) :=

codex statement:
theorem sum_of_inverse_log_pow_p_converges_of_p_gt_1:
  fixes p::real
  assumes "p > 1"
  shows "summable (\<lambda>n. 1 / (real n * (log (real n)) ^ p))"
Our comment on the codex statement:  correct except for log (should be ln) and ^ (should be powr)
 *)
theorem exercise_3_63a:
  fixes p::real
  assumes "p > 1"
  shows "summable (\<lambda>n. 1 / (real n * (ln (real n) powr p)))"
  oops

theorem exercise_3_63b:
  fixes p::real
  assumes "p \<le> 1"
  shows "\<not> summable (\<lambda>n. 1 / (real n * (ln (real n) powr p)))"
  oops

(*
problem_number:4_15a
natural language statement:
A continuous, strictly increasing function $\mu \colon (0, \infty) \rightarrow (0, \infty)$ is a modulus of continuity if $\mu(s) \rightarrow 0$ as $s \rightarrow 0$. A function $f \colon [a, b] \rightarrow \mathbb{R}$ has modulus of continuity $\mu$ if $|f(s) - f(t)| \leq \mu(|s - t|)$ for all $s, t \in [a, b]$. Prove that a function is uniformly continuous if and only if it has a modulus of continuity.
lean statement:
theorem exercise_4_15a {\<alpha> : Type*}
  (a b : \<real>) (F : set (\<real> \<rightarrow> \<real>)) :
  (\<forall> (x : \<real>) (\<epsilon> > 0), \<exists> (U \<in> (𝓝 x)),
  (\<forall> (y z \<in> U) (f : \<real> \<rightarrow> \<real>), f \<in> F \<rightarrow> (dist (f y) (f z) < \<epsilon>)))
  \<longleftrightarrow>
  \<exists> (\<mu> : \<real> \<rightarrow> \<real>), \<forall> (x : \<real>), (0 : \<real>) \<le> \<mu> x \<and> tendsto \<mu> (𝓝 0) (𝓝 0) \<and>
  (\<forall> (s t : \<real>) (f : \<real> \<rightarrow> \<real>), f \<in> F \<rightarrow> |(f s) - (f t)| \<le> \<mu> (|s - t|)) :=

codex statement:
theorem uniform_continuous_iff_has_modulus_of_continuity:
  fixes f::"'a::metric_space \<Rightarrow> 'b::metric_space" and \<mu>::"'a \<Rightarrow> 'b"
  assumes "continuous_on UNIV \<mu>" "strict_mono \<mu>" "\<mu> \<longrightarrow> 0 at_top" "\<forall>s t. s \<in> UNIV \<longrightarrow> t \<in> UNIV \<longrightarrow> dist s t \<le> \<mu> (dist s t)"
  shows "uniformly_continuous_on UNIV f"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)

definition "is_modulus_continuity
  \<equiv> \<lambda> \<mu>. continuous_on {0<..} \<mu> \<and> strict_mono_on {0<..} \<mu> \<and> \<mu> \<in> {0<..} \<rightarrow> {0<..} \<and> (\<mu> \<longlongrightarrow> 0) (at 0 within {0<..})"

definition "has_modulus_continuity
  \<equiv> \<lambda> \<mu> f a b. is_modulus_continuity \<mu> \<and> (\<forall>x \<in> {a..b}. \<forall>y \<in> {a..b}. \<bar>f x - f y\<bar> \<le> \<mu>\<bar>x-y\<bar>)"

theorem exercise_4_15a:
  fixes f::"real \<Rightarrow> real"
  shows "uniformly_continuous_on {a..b} f \<longleftrightarrow> (\<exists>\<mu>. has_modulus_continuity \<mu> f a b)"
  oops

(*
problem_number:4_15b
natural language statement:
A continuous, strictly increasing function $\mu \colon (0, \infty) \rightarrow (0, \infty)$ is a modulus of continuity if $\mu(s) \rightarrow 0$ as $s \rightarrow 0$. A function $f \colon [a, b] \rightarrow \mathbb{R}$ has modulus of continuity $\mu$ if $|f(s) - f(t)| \leq \mu(|s - t|)$ for all $s, t \in [a, b]$. Prove that a family of functions is equicontinuous if and only if its members.
lean statement:

codex statement:
theorem equicontinuous_of_modulus_of_continuity:
  fixes f::"'a::metric_space \<Rightarrow> 'b::metric_space" and g::"'a::metric_space \<Rightarrow> 'b::metric_space"
  assumes "\<forall>x. continuous (at x) f" "\<forall>x. continuous (at x) g" "\<forall>x. continuous (at x within s) f" "\<forall>x. continuous (at x within s) g"
  shows "uniformly_continuous_on s f" "uniformly_continuous_on s g"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_4_15b:
  fixes \<F>::"(real \<Rightarrow> real) set"
  assumes "a<b"
  shows "(\<forall>e>0. \<exists>d>0. \<forall>f \<in> \<F>. \<forall>x \<in> {a..b}. \<forall>x' \<in> {a..b}. \<bar>x'-x\<bar> < d \<longrightarrow> \<bar>f x' - f x\<bar> < e)
     \<longleftrightarrow> (\<exists>\<mu>. \<forall>f \<in> \<F>. has_modulus_continuity \<mu> f a b)"
  oops

(*
problem_number:4_19
natural language statement:
If $M$ is compact and $A$ is dense in $M$, prove that for each $\delta > 0$ there is a finite subset $\{a_1, \ldots , a_k\} \subset A$ which is $\delta$-dense in $M$ in the sense that each $x \in M$ lies within distance $\delta$ of at least one of the points $a_1,\ldots, a_k$.
lean statement:
theorem exercise_4_19 {M : Type*} [metric_space M]
  [compact_space M] (A : set M) (hA : dense A) (\<delta> : \<real>) (h\<delta> : \<delta> > 0) :
  \<exists> (A_fin : set M), A_fin \<subset> A \<and> set.finite A_fin \<and> \<forall> (x : M), \<exists> i \<in> A_fin, dist x i < \<delta> :=

codex statement:
theorem exists_finite_delta_dense_of_compact_dense:
  fixes M::"'a::metric_space set" and A::"'a set"
  assumes "compact M" "A \<subseteq> M" "dense A"
  shows "\<exists>A'. finite A' \<and> A' \<subseteq> A \<and> \<forall>x\<in>M. \<exists>a\<in>A'. dist x a < \<delta>"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_4_19:
  fixes M::"'a::metric_space set" and A::"'a set"
  assumes "compact M" "A \<subseteq> M" "M \<subseteq> closure A" "\<delta> > 0"
  shows "\<exists>A'. finite A' \<and> A' \<subseteq> A \<and> (\<forall>x\<in>M. \<exists>a\<in>A'. dist x a < \<delta>)"
  oops

(*
problem_number:4_36a
natural language statement:
Suppose that the ODE $x' = f(x)$ on $\mathbb{R}$ is bounded, $|f(x)| \leq M$ for all x. Prove that no solution of the ODE escapes to infinity in finite time.
lean statement:

codex statement:
theorem no_solution_escapes_to_infinity_in_finite_time:
  fixes f::"real \<Rightarrow> real"
  assumes "\<forall>x. abs (f x) \<le> M"
  shows "\<forall>x0 t. \<exists>x. x0 + t * f x0 = x"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_4_36a: undefined oops

(*
problem_number:4_42
natural language statement:
Prove that $\mathbb{R}$ cannot be expressed as the countable union of Cantor sets.
lean statement:

codex statement:
theorem cantor_set_not_union_of_countable_cantor_sets:
  fixes C::"real set"
  assumes "\<forall>x\<in>C. \<exists>a b. x = a + b \<and> a \<in> cantor \<and> b \<in> cantor" "countable C"
  shows "False"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_4_42: undefined oops(* we do not have a formalisation of Cantor sets*)

(*
problem_number:5_2
natural language statement:
Let $L$ be the vector space of continuous linear transformations from a normed space $V$ to a normed space $W$. Show that the operator norm makes $L$ a normed space.
lean statement:
theorem exercise_5_2 {V : Type*} [normed_add_comm_group V]
  [normed_space \<complex> V] {W : Type*} [normed_add_comm_group W] [normed_space \<complex> W] :
  normed_space \<complex> (continuous_linear_map (id \<complex>) V W) :=

codex statement:
theorem norm_of_linear_transformation_is_norm:
  fixes V::"'a::real_normed_vector normed_vector" and W::"'b::real_normed_vector normed_vector"
  assumes "linear f"
  shows "norm f = \<parallel>f\<parallel>"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_5_2: undefined oops

(*
problem_number:5_20
natural language statement:
Assume that $U$ is a connected open subset of $\mathbb{R}^n$ and $f \colon U \rightarrow \mathbb{R}^m$ is differentiable everywhere on $U$. If $(Df)_p = 0$ for all $p \in U$, show that $f$ is constant.
lean statement:

codex statement:
theorem constant_of_differentiable_zero:
  fixes f::"'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
  assumes "connected U" "open U" "\<forall>x\<in>U. f differentiable (at x)" "\<forall>x\<in>U. (D f) x = 0"
  shows "f constant_on U"
Our comment on the codex statement:  not bad, but we have no D!
 *)

theorem exercise_5_20:
  fixes f::"'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
  assumes "connected U" "open U" "\<forall>x\<in>U. (f has_derivative (\<lambda>x. 0)) (at x)"
  shows "f constant_on U"
  by (smt (verit, best) assms constant_on_def has_derivative_zero_unique_connected)

(*
problem_number:5_22
natural language statement:
If $Y$ is a metric space and $f \colon [a, b] \times Y \rightarrow \mathbb{R}$ is continuous, show that $F(y) = \int^b_a f(x,y) dx$ is continuous.
lean statement:

codex statement:
theorem continuous_of_continuous_integral:
  fixes f::"'a::metric_space \<Rightarrow> 'b::metric_space \<Rightarrow> 'c::metric_space"
  assumes "continuous_on (UNIV::'a set) (\<lambda>y. \<integral> {a..b} (f x y) dx)"
  shows "continuous_on (UNIV::'b set) (\<lambda>y. \<integral> {a..b} (f x y) dx)"
Our comment on the codex statement:  Wrong all the way
 *)
theorem exercise_5_22:   (*Lebesgue integrals seem to be expected here*)
  fixes f::"real * 'a::metric_space \<Rightarrow> real"
  assumes "continuous_on UNIV f"
    shows "\<forall>y\<in>Y. integrable (lebesgue_on {a..b}) (\<lambda>x. f (x,y))" "continuous_on Y (\<lambda>y. integral\<^sup>L (lebesgue_on {a..b}) (\<lambda>x. f (x,y)))"
  oops

(*
problem_number:5_43a
natural language statement:
Suppose that $T \colon R^n \rightarrow R^m$ has rank $k$.  Show there exists a $\delta > 0$ such that if $S \colon R^n \rightarrow R^m$ and $||S - T|| < \delta$ then $S$ has rank $\geq k$.
lean statement:

codex statement:
theorem exists_delta_of_rank_leq_rank_of_norm_lt_delta:
  fixes T::"'a::euclidean_space \<Rightarrow> 'b::euclidean_space" and S::"'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
  assumes "linear T" "linear S" "rank T = k"
  shows "\<exists>\<delta>>0. \<forall>S. linear S \<longrightarrow> (\<parallel>S - T\<parallel> < \<delta> \<longrightarrow> rank S \<ge> k)"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_5_43a: undefined oops

(*
problem_number:6_38
natural language statement:
If $f$ and $g$ are integrable prove that their maximum and minimum are integrable.
lean statement:

codex statement:
theorem integrable_max_min:
  fixes f g::"'a::euclidean_space \<Rightarrow> 'b::banach"
  assumes "integrable M f" "integrable M g"
  shows "integrable M (\<lambda>x. max (f x) (g x))" "integrable M (\<lambda>x. min (f x) (g x))"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_6_38:
  fixes f g::"'a::euclidean_space \<Rightarrow> real"
  assumes "integrable M f" "integrable M g"
  shows "integrable M (\<lambda>x. max (f x) (g x))" "integrable M (\<lambda>x. min (f x) (g x))"
  using assms by blast+

(*
problem_number:6_39
natural language statement:
Suppose that $f$ and $g$ are measurable and their squares are integrable. Prove that $fg$ is measurable, integrable, and $\int fg \leq \sqrt{\int f^2} \sqrt{\int g^2}$.
lean statement:

codex statement:
theorem integrable_of_integrable_square:
  fixes f g::"'a::euclidean_space \<Rightarrow> real"
  assumes "integrable lborel f" "integrable lborel g"
  shows "integrable lborel (\<lambda>x. f x * g x)"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_6_39:
  fixes f g::"'a::euclidean_space \<Rightarrow> real"
  assumes "f \<in> borel_measurable borel" "integrable lborel (\<lambda>x. f x ^ 2)"
  assumes "g \<in> borel_measurable borel" "integrable lborel (\<lambda>x. g x ^ 2)"
  shows "(\<lambda>x. f x * g x) \<in> borel_measurable borel" "integrable lborel (\<lambda>x. f x * g x)"
        "integral\<^sup>L lborel (\<lambda>x. f x * g x) \<le> sqrt (integral\<^sup>L lborel (\<lambda>x. f x ^ 2)) * sqrt (integral\<^sup>L lborel (\<lambda>x. g x ^ 2))"
   apply (simp add: borel_measurable_times assms)
  oops

(*
problem_number:6_43
natural language statement:
Prove that $g(y) = \int_0^\infty e^{-x} \sin(x + y) dx$ is differentiable and find $g'(y)$.
lean statement:

codex statement:
theorem diff_integral_of_exp_sin:
  fixes y::real
  shows "((\<lambda>x. exp (-x) * sin (x + y)) has_vector_derivative (exp (-y) * cos y)) (at y)"
Our comment on the codex statement: Rather scrambled
 *)
theorem exercise_6_43:
  fixes y::real
  shows "(\<lambda>y::real. integral\<^sup>L (lebesgue_on {0<..}) (\<lambda>x. exp (-x) * sin (x + y))) differentiable_on {0<..}"
  oops

(*
problem_number:6_49a
natural language statement:
Prove that $f \colon \mathbb{R} \rightarrow \mathbb{R}$ is Lebesgue measurable if and only if the preimage of every Borel set is a Lebesgue measurable.
lean statement:

codex statement:
theorem lebesgue_measurable_of_preimage_borel_is_lebesgue_measurable:
  fixes f::"'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
  assumes "\<forall>s. borel_measurable s \<longrightarrow> borel_measurable (f -` s)"
  shows "lebesgue_measurable f"
Our comment on the codex statement:  not completely wrong
 *)
theorem exercise_6_49a:  (*Not sure I have formalised measurable sets and functions correctly*)
  assumes "\<forall>S. S \<in> fmeasurable borel \<longrightarrow> (f -` S) \<in> fmeasurable borel"
  shows "f \<in> measurable borel borel"
  oops

end


(* Author: Anthony Bordg, University of Cambridge, apdb3@cam.ac.uk *)

section \<open>Complex Vectors\<close>

theory Complex_Vectors
imports
  Quantum
  VectorSpace.VectorSpace
begin

subsection \<open>The Vector Space of Complex Vectors of Dimension n\<close>

definition module_cpx_vec:: "nat \<Rightarrow> (complex, complex vec) module" where
"module_cpx_vec n \<equiv> module_vec TYPE(complex) n"

definition cpx_rng:: "complex ring" where
"cpx_rng \<equiv> \<lparr>carrier = UNIV, mult = (*), one = 1, zero = 0, add = (+)\<rparr>"

lemma cpx_cring_is_field [simp]:
  "field cpx_rng"
  apply unfold_locales
                   apply (auto intro: right_inverse simp: cpx_rng_def Units_def field_simps)
  by (metis add.right_neutral add_diff_cancel_left' add_uminus_conv_diff)

lemma cpx_abelian_monoid [simp]:
  "abelian_monoid cpx_rng"
  using cpx_cring_is_field
  by (simp add: field_def abelian_group_def cring_def domain_def ring_def)

lemma vecspace_cpx_vec [simp]:
  "vectorspace cpx_rng (module_cpx_vec n)"
  apply unfold_locales
                      apply (auto simp: cpx_rng_def module_cpx_vec_def module_vec_def Units_def field_simps)
    apply (auto intro: right_inverse add_inv_exists_vec)
  by (metis add.right_neutral add_diff_cancel_left' add_uminus_conv_diff)

definition state_basis:: "nat \<Rightarrow> nat \<Rightarrow> complex vec" where
"state_basis n i \<equiv> unit_vec (2^n) i"

definition unit_vectors:: "nat \<Rightarrow> (complex vec) set" where
"unit_vectors n \<equiv> {unit_vec n i | i::nat. 0 \<le> i \<and> i < n}"

lemma unit_vectors_carrier_vec [simp]:
  "unit_vectors n \<subseteq> carrier_vec n"
  using unit_vectors_def by auto

lemma (in Module.module) finsum_over_singleton [simp]:
  assumes "f x \<in> carrier M"
  shows "finsum M f {x} = f x"
  using assms by simp

lemma lincomb_over_singleton [simp]:
  assumes "x \<in> carrier_vec n" and "f \<in> {x} \<rightarrow> UNIV"
  shows "module.lincomb (module_cpx_vec n) f {x} = f x \<cdot>\<^sub>v x"
  using assms module.lincomb_def module_cpx_vec module_cpx_vec_def module.finsum_over_singleton
  by (smt module_vec_simps(3) module_vec_simps(4) smult_carrier_vec)

lemma dim_vec_lincomb [simp]:
  assumes "finite F" and "f: F \<rightarrow> UNIV" and "F \<subseteq> carrier_vec n"
  shows "dim_vec (module.lincomb (module_cpx_vec n) f F) = n"
  using assms
proof(induct F)
  case empty
  show "dim_vec (module.lincomb (module_cpx_vec n) f {}) = n"
  proof -
    have "module.lincomb (module_cpx_vec n) f {} = 0\<^sub>v n"
      using module.lincomb_def abelian_monoid.finsum_empty module_cpx_vec_def vecspace_cpx_vec vectorspace_def
      by (smt abelian_group_def Module.module_def module_vec_simps(2))
    thus ?thesis by simp
  qed
next
  case (insert x F)
  hence "module.lincomb (module_cpx_vec n) f (insert x F) =
    (f x \<cdot>\<^sub>v x) \<oplus>\<^bsub>module_cpx_vec n\<^esub> module.lincomb (module_cpx_vec n) f F"
    using module_cpx_vec_def module_vec_def module_cpx_vec module.lincomb_insert cpx_rng_def insert_subset
    by (smt Pi_I' UNIV_I Un_insert_right module_vec_simps(4) partial_object.select_convs(1) sup_bot.comm_neutral)
  hence "dim_vec (module.lincomb (module_cpx_vec n) f (insert x F)) =
    dim_vec (module.lincomb (module_cpx_vec n) f F)"
    using index_add_vec by (simp add: module_cpx_vec_def module_vec_simps(1))
  thus "dim_vec (module.lincomb (module_cpx_vec n) f (insert x F)) = n"
    using insert.hyps(3) insert.prems(2) by simp
qed

lemma lincomb_vec_index [simp]:
  assumes "finite F" and a2:"i < n" and "F \<subseteq> carrier_vec n" and "f: F \<rightarrow> UNIV"
  shows "module.lincomb (module_cpx_vec n) f F $ i = (\<Sum>v\<in>F. f v * (v $ i))"
  using assms
proof(induct F)
  case empty
  then show "module.lincomb (module_cpx_vec n) f {} $ i = (\<Sum>v\<in>{}. f v * v $ i)"
    apply auto
    using a2 module.lincomb_def abelian_monoid.finsum_empty module_cpx_vec_def
    by (metis (mono_tags) abelian_group_def index_zero_vec(1) module_cpx_vec Module.module_def module_vec_simps(2))
next
  case(insert x F)
  have "module.lincomb (module_cpx_vec n) f (insert x F) =
      f x \<cdot>\<^sub>v x \<oplus>\<^bsub>module_cpx_vec n\<^esub> module.lincomb (module_cpx_vec n) f F"
    using module.lincomb_insert module_cpx_vec insert.hyps(1) module_cpx_vec_def module_vec_def
      insert.prems(2) insert.hyps(2) insert.prems(3) insert_def
    by (smt Pi_I' UNIV_I Un_insert_right cpx_rng_def insert_subset module_vec_simps(4)
        partial_object.select_convs(1) sup_bot.comm_neutral)
  then have "module.lincomb (module_cpx_vec n) f (insert x F) $ i =
      (f x \<cdot>\<^sub>v x) $ i + module.lincomb (module_cpx_vec n) f F $ i"
    using index_add_vec(1) a2 dim_vec_lincomb
    by (metis Pi_split_insert_domain  insert.hyps(1) insert.prems(2) insert.prems(3) insert_subset
        module_cpx_vec_def module_vec_simps(1))
  hence "module.lincomb (module_cpx_vec n) f (insert x F) $ i = f x * x $ i + (\<Sum>v\<in>F. f v * v $ i)"
    using index_smult_vec a2 insert.prems(2) insert_def insert.hyps(3) by auto
  with insert show "module.lincomb (module_cpx_vec n) f (insert x F) $ i = (\<Sum>v\<in>insert x F. f v * v $ i)"
    by auto
qed

lemma unit_vectors_is_lin_indpt [simp]:
  "module.lin_indpt cpx_rng (module_cpx_vec n) (unit_vectors n)"
proof
  assume "module.lin_dep cpx_rng (module_cpx_vec n) (unit_vectors n)"
  hence "\<exists>A a v. (finite A \<and> A \<subseteq> (unit_vectors n) \<and> (a \<in> A \<rightarrow> UNIV) \<and>
    (module.lincomb (module_cpx_vec n) a A = \<zero>\<^bsub>module_cpx_vec n\<^esub>) \<and> (v \<in> A) \<and> (a v \<noteq> \<zero>\<^bsub>cpx_rng\<^esub>))"
    using module.lin_dep_def cpx_rng_def module_cpx_vec by (smt Pi_UNIV UNIV_I)
  moreover obtain A and a and v where f1:"finite A" and f2:"A \<subseteq> (unit_vectors n)" and "a \<in> A \<rightarrow> UNIV"
    and f4:"module.lincomb (module_cpx_vec n) a A = \<zero>\<^bsub>module_cpx_vec n\<^esub>" and f5:"v \<in> A" and
    f6:"a v \<noteq> \<zero>\<^bsub>cpx_rng\<^esub>"
    using calculation by blast
  moreover obtain i where f7:"v = unit_vec n i" and f8:"i < n"
    using unit_vectors_def calculation by auto
  ultimately have f9:"module.lincomb (module_cpx_vec n) a A $ i = (\<Sum>u\<in>A. a u * (u $ i))"
    using lincomb_vec_index
    by (smt carrier_dim_vec index_unit_vec(3) mem_Collect_eq subset_iff sum.cong unit_vectors_def)
  moreover have "\<forall>u\<in>A.\<forall>j<n. u = unit_vec n j \<longrightarrow> j \<noteq> i \<longrightarrow> a u * (u $ i) = 0"
    using unit_vectors_def index_unit_vec by (simp add: f8)
  then have "(\<Sum>u\<in>A. a u * (u $ i)) = (\<Sum>u\<in>A. if u=v then a v * v $ i else 0)"
    using f2 unit_vectors_def f7 by (smt mem_Collect_eq subsetCE sum.cong)
  also have "\<dots> = a v * (v $ i)"
    using abelian_monoid.finsum_singleton[of cpx_rng v A "\<lambda>u\<in>A. a u * (u $ i)"] cpx_abelian_monoid
      f5 f1 cpx_rng_def by simp
  also have "\<dots> = a v"
    using f7 index_unit_vec f8 by simp
  also have "\<dots> \<noteq> 0"
    using f6 by (simp add: cpx_rng_def)
  finally show False
    using f4 module_cpx_vec_def module_vec_def index_zero_vec f8 f9 by (simp add: module_vec_simps(2))
qed

lemma unit_vectors_is_genset [simp]:
  "module.gen_set cpx_rng (module_cpx_vec n) (unit_vectors n)"
proof
  show "module.span cpx_rng (module_cpx_vec n) (unit_vectors n) \<subseteq> carrier (module_cpx_vec n)"
    using module.span_def dim_vec_lincomb carrier_vec_def cpx_rng_def
    by (smt Collect_mono index_unit_vec(3) module.span_is_subset2 module_cpx_vec module_cpx_vec_def
        module_vec_simps(3) unit_vectors_def)
next
  show "carrier (module_cpx_vec n) \<subseteq> module.span cpx_rng (module_cpx_vec n) (unit_vectors n)"
  proof
    fix v
    assume a1:"v \<in> carrier (module_cpx_vec n)"
    define A a lc where "A = {unit_vec n i ::complex vec| i::nat. i < n \<and> v $ i \<noteq> 0}" and
      "a = (\<lambda>u\<in>A. u \<bullet> v)" and "lc = module.lincomb (module_cpx_vec n) a A"
    then have f1:"finite A" by simp
    have f2:"A \<subseteq> carrier_vec n"
      using carrier_vec_def A_def by auto
    have f3:"a \<in> A \<rightarrow> UNIV"
      using a_def by simp
    then have f4:"dim_vec v = dim_vec lc"
      using f1 f2 f3 a1 module_cpx_vec_def dim_vec_lincomb lc_def by (simp add: module_vec_simps(3))
    then have f5:"i < n \<Longrightarrow> lc $ i = (\<Sum>u\<in>A. u \<bullet> v * u $ i)" for i
      using lincomb_vec_index lc_def a_def f1 f2 f3 by simp
    then have "i < n \<Longrightarrow> j < n \<Longrightarrow> j \<noteq> i \<Longrightarrow> unit_vec n j \<bullet> v * unit_vec n j $ i = 0" for i j by simp
    then have "i < n \<Longrightarrow> lc $ i = (\<Sum>u\<in>A. if u = unit_vec n i then v $ i else 0)" for i
      using a1 A_def f5 scalar_prod_left_unit
      by (smt f4 carrier_vecI dim_vec_lincomb f1 f2 f3 index_unit_vec(2) lc_def
          mem_Collect_eq mult.right_neutral sum.cong)
    then have "i < n \<Longrightarrow> lc $ i = v $ i" for i
      using abelian_monoid.finsum_singleton[of cpx_rng i] A_def cpx_rng_def by simp
    then have f6:"v = lc"
      using eq_vecI f4 dim_vec_lincomb f1 f2 lc_def by auto
    have "A \<subseteq> unit_vectors n"
      using A_def unit_vectors_def by auto
    thus "v \<in> module.span cpx_rng (module_cpx_vec n) (unit_vectors n)"
      using f6 module.span_def[of cpx_rng "module_cpx_vec n"] lc_def f1 f2 cpx_rng_def module_cpx_vec
      by (smt Pi_I' UNIV_I mem_Collect_eq partial_object.select_convs(1))
  qed
qed

lemma unit_vectors_is_basis [simp]:
  "vectorspace.basis cpx_rng (module_cpx_vec n) (unit_vectors n)"
proof -
  fix n
  have "unit_vectors n \<subseteq> carrier (module_cpx_vec n)"
    using unit_vectors_def module_cpx_vec_def module_vec_simps(3) by fastforce
  then show ?thesis
    using vectorspace.basis_def unit_vectors_is_lin_indpt unit_vectors_is_genset vecspace_cpx_vec
    by(smt carrier_dim_vec index_unit_vec(3) mem_Collect_eq module_cpx_vec_def module_vec_simps(3)
        subsetI unit_vectors_def)
qed

lemma state_qbit_is_lincomb [simp]:
  "state_qbit n =
  {module.lincomb (module_cpx_vec (2^n)) a A|a A.
    finite A \<and> A\<subseteq>(unit_vectors (2^n)) \<and> a\<in> A \<rightarrow> UNIV \<and> \<parallel>module.lincomb (module_cpx_vec (2^n)) a A\<parallel> = 1}"
proof
  show "state_qbit n
    \<subseteq> {module.lincomb (module_cpx_vec (2^n)) a A |a A.
        finite A \<and> A \<subseteq> unit_vectors (2^n) \<and> a \<in> A \<rightarrow> UNIV \<and> \<parallel>module.lincomb (module_cpx_vec (2^n)) a A\<parallel> = 1}"
  proof
    fix v
    assume a1:"v \<in> state_qbit n"
    then show "v \<in> {module.lincomb (module_cpx_vec (2^n)) a A |a A.
               finite A \<and> A \<subseteq> unit_vectors (2^n) \<and> a \<in> A \<rightarrow> UNIV \<and> \<parallel>module.lincomb (module_cpx_vec (2^n)) a A\<parallel> = 1}"
    proof -
      obtain a and A where "finite A" and "a\<in> A \<rightarrow> UNIV" and "A \<subseteq> unit_vectors (2^n)" and
        "v = module.lincomb (module_cpx_vec (2^n)) a A"
        using a1 state_qbit_def unit_vectors_is_basis vectorspace.basis_def module.span_def
        vecspace_cpx_vec module_cpx_vec module_cpx_vec_def module_vec_def carrier_vec_def
        by(smt Pi_UNIV UNIV_I mem_Collect_eq module_vec_simps(3))
      thus ?thesis
        using a1 state_qbit_def by auto
    qed
  qed
  show "{module.lincomb (module_cpx_vec (2 ^ n)) a A |a A.
     finite A \<and> A \<subseteq> unit_vectors (2 ^ n) \<and> a \<in> A \<rightarrow> UNIV \<and> \<parallel>module.lincomb (module_cpx_vec (2 ^ n)) a A\<parallel> = 1}
    \<subseteq> state_qbit n"
  proof
    fix v
    assume "v \<in> {module.lincomb (module_cpx_vec (2 ^ n)) a A |a A.
              finite A \<and> A \<subseteq> unit_vectors (2 ^ n) \<and> a \<in> A \<rightarrow> UNIV \<and> \<parallel>module.lincomb (module_cpx_vec (2 ^ n)) a A\<parallel> = 1}"
    then show "v \<in> state_qbit n"
      using state_qbit_def dim_vec_lincomb unit_vectors_carrier_vec by(smt mem_Collect_eq order_trans)
  qed
qed

end


section "Binomial Heaps"

theory BinomialHeap
imports Main "HOL-Library.Multiset" "Eval_Base.Eval_Base"
begin

locale BinomialHeapStruc_loc
begin

subsection \<open>Datatype Definition\<close>

text \<open>Binomial heaps are lists of binomial trees.\<close>
datatype ('e, 'a) BinomialTree =
  Node (val: 'e) (prio: "'a::linorder") (rank: nat) (children: "('e , 'a) BinomialTree list")
type_synonym ('e, 'a) BinomialQueue_inv = "('e, 'a::linorder) BinomialTree list"

text \<open>Combine two binomial trees (of rank $r$) to one (of rank $r+1$).\<close>
fun  link :: "('e, 'a::linorder) BinomialTree \<Rightarrow> ('e, 'a) BinomialTree \<Rightarrow>
  ('e, 'a) BinomialTree" where
  "link (Node e1 a1 r1 ts1) (Node e2 a2 r2 ts2) =
   (if  a1\<le>a2
     then (Node e1 a1 (Suc r1) ((Node e2 a2 r2 ts2)#ts1))
     else (Node e2 a2 (Suc r2) ((Node e1 a1 r1 ts1)#ts2)))"

subsubsection "Abstraction to Multiset"
text \<open>Return a multiset with all (element, priority) pairs from a queue.\<close>
fun tree_to_multiset
  :: "('e, 'a::linorder) BinomialTree \<Rightarrow> ('e \<times> 'a) multiset"
and queue_to_multiset
  :: "('e, 'a::linorder) BinomialQueue_inv \<Rightarrow> ('e \<times> 'a) multiset" where
  "tree_to_multiset (Node e a r ts) = {#(e,a)#} + queue_to_multiset ts" |
  "queue_to_multiset [] = {#}" |
  "queue_to_multiset (t#q) = tree_to_multiset t + queue_to_multiset q"

lemma qtmset_append_union[simp]: "queue_to_multiset (q @ q') =
  queue_to_multiset q + queue_to_multiset q'"
  apply2(induct q)
  apply(simp)
  apply(simp add: union_ac)
done

lemma qtmset_rev[simp]: "queue_to_multiset (rev q) = queue_to_multiset q"
  apply2(induct q)
  apply(simp)
  apply(simp add: union_ac)
done

subsubsection "Invariant"

text \<open>We first formulate the invariant for single binomial trees,
  and then extend the invariant to binomial heaps (lists of binomial trees).
  The invariant for trees claims that a tree labeled rank $0$ has no children,
  and a tree labeled rank $r+1$ is the result of a link operation of
  two rank $r$ trees.
\<close>
function tree_invar :: "('e, 'a::linorder) BinomialTree \<Rightarrow> bool" where
  "tree_invar (Node e a 0 ts) = (ts = [])" |
  "tree_invar (Node e a (Suc r) ts) =
  (\<exists> e1 a1 ts1 e2 a2 ts2.
    tree_invar (Node e1 a1 r ts1) \<and>
    tree_invar (Node e2 a2 r ts2) \<and>
    (Node e a (Suc r) ts) = link (Node e1 a1 r ts1) (Node e2 a2 r ts2))"
by pat_completeness auto
termination
  apply(relation "measure (\<lambda>t. rank t)")
  apply auto
done

text \<open>A queue satisfies the invariant, iff all trees inside the queue satisfy
  the invariant, and the queue contains only trees of distinct rank and
  is ordered by rank\<close>

text \<open>First part: All trees of the queue satisfy the tree invariant:\<close>
definition queue_invar :: "('e, 'a::linorder) BinomialQueue_inv \<Rightarrow> bool" where
  "queue_invar q \<equiv> (\<forall>t \<in> set q. tree_invar t)"

text \<open>Second part: Trees have distinct rank, and are ordered by
  ascending rank:\<close>
fun rank_invar :: "('e, 'a::linorder) BinomialQueue_inv \<Rightarrow> bool" where
  "rank_invar [] = True" |
  "rank_invar [t] = True" |
  "rank_invar (t # t' # bq) = (rank t < rank t' \<and> rank_invar (t' # bq))"

lemma queue_invar_simps[simp]:
  "queue_invar []"
  "queue_invar (t#q) \<longleftrightarrow> tree_invar t \<and> queue_invar q"
  "queue_invar (q@q') \<longleftrightarrow> queue_invar q \<and> queue_invar q'"
  unfolding queue_invar_def by auto

text \<open>Invariant for binomial queues:\<close>
definition "invar q == queue_invar q \<and> rank_invar q"

lemma mset_link[simp]: "(tree_to_multiset (link t1 t2))
  = (tree_to_multiset t1) + (tree_to_multiset t2)"
  by(cases t1, cases t2, auto simp add: union_ac)

lemma link_tree_invar:
  "\<lbrakk>tree_invar t1; tree_invar t2; rank t1 = rank t2\<rbrakk> \<Longrightarrow> tree_invar (link t1 t2)"
  by (cases t1, cases t2, simp, blast)

lemma invar_children:
  assumes "tree_invar ((Node e a r ts)::(('e, 'a::linorder) BinomialTree))"
  shows "queue_invar ts" using assms
  unfolding queue_invar_def
proof2(induct r arbitrary: e a ts)
  case 0
  then show ?case by simp
next
  case (Suc r)
  from Suc(2) obtain e1 a1 ts1 e2 a2 ts2 where
    O: "tree_invar (Node e1 a1 r ts1)"  "tree_invar (Node e2 a2 r ts2)"
    "(Node e a (Suc r) ts) = link (Node e1 a1 r ts1) (Node e2 a2 r ts2)"
    by (simp only: tree_invar.simps) blast
  from Suc(1)[OF O(1)] O(2)
  have case1: "queue_invar ((Node e2 a2 r ts2) # ts1)"
    unfolding queue_invar_def by simp
  from Suc(1)[OF O(2)] O(1)
  have case2: "queue_invar ((Node e1 a1 r ts1) # ts2)"
    unfolding queue_invar_def by simp
  from O(3) have "ts = (if a1\<le>a2
    then (Node e2 a2 r ts2) # ts1
    else (Node e1 a1 r ts1) # ts2)" by auto
  with case1 case2 show ?case unfolding queue_invar_def by simp
qed

lemma invar_children': "tree_invar t \<Longrightarrow> queue_invar (children t)"
  by (cases t) (auto simp add: invar_children)

lemma rank_link: "rank t = rank t' \<Longrightarrow> rank (link t t') = rank t + 1"
apply (cases t)
apply (cases t')
apply(auto)
done

lemma rank_invar_not_empty_hd: "\<lbrakk>rank_invar (t # bq); bq \<noteq> []\<rbrakk> \<Longrightarrow>
  rank t < rank (hd bq)"
apply2(induct bq arbitrary: t)
apply(auto)
done

lemma rank_invar_to_set: "rank_invar (t # bq) \<Longrightarrow>
  \<forall> t' \<in> set bq. rank t < rank t'"
apply2(induct bq arbitrary: t)
apply(simp)
apply (metis nat_less_le rank_invar.simps(3) set_ConsD xt1(7))
done

lemma set_to_rank_invar: "\<lbrakk>\<forall> t' \<in> set bq. rank t < rank t'; rank_invar bq\<rbrakk>
  \<Longrightarrow>  rank_invar (t # bq)"
apply2(induct bq arbitrary: t)
apply(simp)
by (metis list.sel(1) hd_in_set list.distinct(1) rank_invar.simps(3))

lemma rank_invar_hd_cons:
  "\<lbrakk>rank_invar bq; rank t < rank (hd bq)\<rbrakk> \<Longrightarrow> rank_invar (t # bq)"
apply(cases bq)
apply(auto)
done

lemma rank_invar_cons: "rank_invar (t # bq) \<Longrightarrow> rank_invar bq"
apply(cases bq)
apply(auto)
done

lemma invar_cons_up:
  "\<lbrakk>invar (t # bq); rank t' < rank t; tree_invar t'\<rbrakk> \<Longrightarrow> invar (t' # t # bq)"
  unfolding invar_def
  by (cases bq) simp_all

lemma invar_cons_down: "invar (t # bq) \<Longrightarrow> invar bq"
  unfolding invar_def
  by (cases bq) simp_all

lemma invar_app_single:
  "\<lbrakk>invar bq; \<forall>t \<in> set bq. rank t < rank t'; tree_invar t'\<rbrakk>
   \<Longrightarrow> invar (bq @ [t'])"
proof2 (induct bq)
  case Nil
  then show ?case by (simp add: invar_def)
next
  case (Cons a bq)
  from \<open>invar (a # bq)\<close> have "invar bq" by (rule invar_cons_down)
  with Cons have "invar (bq @ [t'])" by simp
  with Cons show ?case by (cases bq) (simp_all add: invar_def)
qed

subsubsection "Heap Ordering"
fun heap_ordered :: "('e, 'a::linorder) BinomialTree \<Rightarrow> bool" where
  "heap_ordered (Node e a r ts) = (\<forall>x \<in> set_mset(queue_to_multiset ts). a \<le> snd x)"

text \<open>The invariant for trees implies heap order.\<close>
lemma tree_invar_heap_ordered:
  assumes "tree_invar t"
  shows "heap_ordered t"
proof (cases t)
  case (Node e a nat list)
  with assms show ?thesis
  proof2 (induct nat arbitrary: t e a list)
    case 0
    then show ?case by simp
  next
    case (Suc nat t)
    then obtain t1 e1 a1 ts1 t2 e2 a2 ts2 where
      O: "tree_invar t1"  "tree_invar t2" "t = link t1 t2"
      and t1[simp]: "t1 = (Node e1 a1 nat ts1)"
      and t2[simp]: "t2 = (Node e2 a2 nat ts2)"
      by (simp only: tree_invar.simps) blast
    from O(3) have "t = (if  a1\<le>a2
      then (Node e1 a1 (Suc nat) (t2 # ts1))
      else (Node e2 a2 (Suc nat) (t1 # ts2)))" by simp
    with Suc(1)[OF O(1) t1] Suc(1)[OF O(2) t2]
    show ?case by (cases "a1 \<le> a2") auto
  qed
qed

subsubsection "Height and Length"
text \<open>
  Although complexity of HOL-functions cannot be expressed within
  HOL, we can express the height and length of a binomial heap.
  By showing that both, height and length, are logarithmic in the number
  of contained elements, we give strong evidence that our functions have
  logarithmic complexity in the number of elements.
\<close>

text \<open>Height of a tree and queue\<close>
fun height_tree :: "('e, ('a::linorder)) BinomialTree \<Rightarrow> nat" and
    height_queue :: "('e, ('a::linorder)) BinomialQueue_inv \<Rightarrow> nat"
  where
  "height_tree (Node e a r ts) = height_queue ts" |
  "height_queue [] = 0" |
  "height_queue (t # ts) = max (Suc (height_tree t)) (height_queue ts)"

lemma link_length: "size (tree_to_multiset (link t1 t2)) =
  size (tree_to_multiset t1) + size (tree_to_multiset t2)"
  apply(cases t1)
  apply(cases t2)
  apply simp
  done

lemma tree_rank_estimate:
  "tree_invar (Node e a r ts) \<Longrightarrow>
    size (tree_to_multiset (Node e a r ts)) = (2::nat)^r"
proof2 (induct r arbitrary: e a ts)
  case 0
  then show ?case by simp
next
  case (Suc r)
  from Suc(2) obtain e1 a1 ts1 e2 a2 ts2 where link:
    "(Node e a (Suc r) ts) = link (Node e1 a1 r ts1) (Node e2 a2 r ts2)"
    and inv1: "tree_invar (Node e1 a1 r ts1) "
    and inv2: "tree_invar (Node e2 a2 r ts2)" by simp blast
  from link_length[of "(Node e1 a1 r ts1)" "(Node e2 a2 r ts2)"]
    Suc(1)[OF inv1] Suc(1)[OF inv2] link
  show ?case by simp
qed

lemma tree_rank_height:
  "tree_invar (Node e a r ts) \<Longrightarrow> height_tree (Node e a r ts) = r"
proof2 (induct r arbitrary: e a ts)
  case 0
  then show ?case by simp
next
  case (Suc r)
  from Suc(2) obtain e1 a1 ts1 e2 a2 ts2 where link:
    "(Node e a (Suc r) ts) = link (Node e1 a1 r ts1) (Node e2 a2 r ts2)"
    and inv1: "tree_invar (Node e1 a1 r ts1) "
    and inv2: "tree_invar (Node e2 a2 r ts2)" by simp blast
  with link Suc(1)[OF inv1] Suc(1)[OF inv2] Suc(2) show ?case
    by (cases "a1 \<le> a2") simp_all
qed

text \<open>A binomial tree of height $h$ contains exactly $2^{h}$ elements\<close>
theorem tree_height_estimate:
  "tree_invar t \<Longrightarrow> size (tree_to_multiset t) = (2::nat)^(height_tree t)"
  apply (cases t, simp only:)
  apply (frule tree_rank_estimate)
  apply (frule tree_rank_height)
  apply (simp only: )
  done

(*lemma size_mset_tree_Node: "tree_invar (Node e a r ts) \<Longrightarrow>
  size (tree_to_multiset (Node e a r ts)) = (2::nat)^r"
  apply(induct r arbitrary: e a ts, simp)
proof -
  case goal1
  from goal1(2) obtain e1 a1 ts1 e2 a2 ts2 where link:
    "(Node e a (Suc r) ts) = link (Node e1 a1 r ts1) (Node e2 a2 r ts2)"
    and inv1: "tree_invar (Node e1 a1 r ts1) "
    and inv2: "tree_invar (Node e2 a2 r ts2)" by simp blast
  from link_length[of "(Node e1 a1 r ts1)" "(Node e2 a2 r ts2)"]
    goal1(1)[OF inv1] goal1(1)[OF inv2] link
  show ?case by simp
qed*)

lemma size_mset_tree: "tree_invar t \<Longrightarrow>
  size (tree_to_multiset t) = (2::nat)^(rank t)"
  by (cases t) (simp only: tree_rank_estimate BinomialTree.sel(3))

lemma invar_butlast: "invar (bq @ [t]) \<Longrightarrow> invar bq"
  unfolding invar_def
  apply2 (induct bq) apply simp apply (case_tac bq)
  by (simp_all)

lemma invar_last_max: "invar (bq @ [m]) \<Longrightarrow> \<forall> t \<in> set bq. rank t < rank m"
  unfolding invar_def
  apply2 (induct bq) apply simp apply (case_tac bq) apply simp by simp

lemma invar_length: "invar bq \<Longrightarrow> length bq \<le> Suc (rank (last bq))"
proof2 (induct bq rule: rev_induct)
  case Nil thus ?case by simp
next
  case (snoc x xs)
  show ?case proof (cases xs)
    case Nil thus ?thesis by simp
  next
    case [simp]: (Cons xxs xx)
    from snoc.hyps[OF invar_butlast[OF snoc.prems]] have
      IH: "length xs \<le> Suc (rank (last xs))" .
    also from invar_last_max[OF snoc.prems] last_in_set[of xs] have
      "Suc (rank (last xs)) \<le> rank (last (xs @ [x]))"
      by auto
    finally show ?thesis by simp
  qed
qed

lemma size_queue_sum_list:
  "size (queue_to_multiset bq) = sum_list (map (size \<circ> tree_to_multiset) bq)"
  apply2 (induct bq) by simp_all

text \<open>
  A binomial heap of length $l$ contains at least $2^l - 1$ elements.
\<close>
theorem queue_length_estimate_lower:
  "invar bq \<Longrightarrow> (size (queue_to_multiset bq)) \<ge> 2^(length bq) - 1"
proof2 (induct bq rule: rev_induct)
  case Nil thus ?case by simp
next
  case (snoc x xs)
  from snoc.hyps[OF invar_butlast[OF snoc.prems]]
  have IH: "2 ^ length xs \<le> Suc (size (queue_to_multiset xs))" by simp
  have size_q:
    "size (queue_to_multiset (xs @ [x])) =
    size (queue_to_multiset xs) + size (tree_to_multiset x)"
    by (simp add: size_queue_sum_list)
  also
  from snoc.prems have inv_x: "tree_invar x" by (simp add: invar_def)
  hence "size (tree_to_multiset x) = 2 ^ rank x" by (simp add: size_mset_tree)
  finally have
    eq: "size (queue_to_multiset (xs @ [x])) =
         size (queue_to_multiset xs) + (2::nat)^(rank x)" .
  from invar_length[OF snoc.prems] have "length xs \<le> rank x" by simp
  hence snd: "(2::nat) ^ length xs \<le> (2::nat) ^ rank x" by simp
  have
    "(2::nat) ^ length (xs @ [x]) = (2::nat) ^ (length xs) + (2::nat) ^ (length xs)"
    by simp
  with IH have
    "2 ^ length (xs @ [x]) \<le> Suc (size (queue_to_multiset xs)) + 2 ^ length xs"
    by simp
  with snd have "2 ^ length (xs @ [x]) \<le>
    Suc (size (queue_to_multiset xs)) + 2 ^ rank x"
    by arith
  with eq show ?case by simp
qed

subsection \<open>Operations\<close>

subsubsection "Empty"
lemma empty_correct[simp]:
  "invar Nil"
  "queue_to_multiset Nil = {#}"
  by (simp_all add: invar_def)

text \<open>The empty multiset is represented by exactly the empty queue\<close>
lemma empty_iff: "t=Nil \<longleftrightarrow> queue_to_multiset t = {#}"
  apply (cases t)
  apply auto
  apply (case_tac a)
  apply auto
  done

subsubsection "Insert"
text \<open>Inserts a binomial tree into a binomial queue, such that the queue
  does not contain two trees of same rank.\<close>
fun  ins :: "('e, 'a::linorder) BinomialTree \<Rightarrow> ('e, 'a) BinomialQueue_inv \<Rightarrow>
  ('e, 'a) BinomialQueue_inv" where
  "ins t [] = [t]" |
  "ins t' (t # bq) = (if (rank t') < (rank t)
    then t' # t # bq
    else (if (rank t) < (rank t')
            then t # (ins t' bq)
            else ins (link t' t) bq))"

text \<open>Inserts an element with priority into the queue.\<close>
definition insert :: "'e \<Rightarrow> 'a::linorder \<Rightarrow> ('e, 'a) BinomialQueue_inv \<Rightarrow>
  ('e, 'a) BinomialQueue_inv" where
  "insert e a bq = ins (Node e a 0 []) bq"

lemma insert_mset: "queue_invar q \<Longrightarrow>
  queue_to_multiset (insert e a q) = queue_to_multiset q + {# (e,a) #}"
by(simp add: ins_mset union_ac insert_def)

lemma ins_queue_invar: "\<lbrakk>tree_invar t; queue_invar q\<rbrakk> \<Longrightarrow> queue_invar (ins t q)"
proof2 (induct q arbitrary: t)
  case (Cons a q)
  note iv = Cons.hyps
  show ?case
  proof (cases "rank t = rank a")
    case [simp]: True
    from Cons.prems have
      inv_a: "tree_invar a" and inv_q: "queue_invar q"
      by (simp_all)
    note inv_link = link_tree_invar[OF \<open>tree_invar t\<close> inv_a True]
    from iv[OF inv_link inv_q] show ?thesis by simp
  next
    case False
    with Cons show ?thesis by auto
  qed
qed simp

lemma insert_queue_invar:
  assumes "queue_invar q"
  shows "queue_invar (insert e a q)"
proof -
  have inv: "tree_invar (Node e a 0 [])" by simp
  from ins_queue_invar[OF inv assms] show ?thesis by (simp add: insert_def)
qed

lemma  rank_ins: "(rank_invar (t # bq) \<Longrightarrow>
  (rank (hd (ins t' (t # bq))) \<ge> rank t) \<or>
  (rank (hd (ins t' (t # bq))) \<ge> rank t'))"
  apply(auto)
  apply2(induct bq arbitrary: t t')
  apply(simp add: rank_link)
proof goal_cases
  case prems: (1 a bq t t')
  thus ?case
    apply(cases "rank (link t' t) = rank a")
    apply(auto simp add: rank_link)
  proof goal_cases
    case 1
    note * = this and \<open>\<And>t' t. \<lbrakk>rank_invar (t # bq); rank t' = rank t\<rbrakk>
      \<Longrightarrow> rank t \<le> rank (hd (ins (link t' t) bq))\<close>[of a "(link t' t)"]
    show ?case
    proof (cases "rank (hd (ins (link (link t' t) a) bq)) = rank a")
      case True
      with * show ?thesis by simp
    next
      case False
      with * have "rank a \<le> rank (hd (ins (link (link t' t) a) bq))"
        by (simp add: rank_link)
      with * show ?thesis by simp
    qed
  qed
qed

lemma rank_ins2: "rank_invar bq \<Longrightarrow>
  rank t \<le> rank (hd (ins t bq)) \<or>
  (rank (hd (ins t bq)) = rank (hd bq) \<and> bq \<noteq> [])"
  apply2(induct bq arbitrary: t)
  apply(auto)
proof goal_cases
  case prems: (1 a bq t)
  hence r: "rank (link t a) = rank a + 1" by (simp add: rank_link)
  from prems r and prems(1)[of "(link t a)"] show ?case by (cases bq) auto
qed

lemma rank_invar_ins: "rank_invar bq \<Longrightarrow> rank_invar (ins t bq)"
  apply2(induct bq arbitrary: t)
  apply(simp)
  apply(auto)
proof goal_cases
  case prems: (1 a bq t)
  hence inv: "rank_invar (ins t bq)" by (cases bq) simp_all
  from prems have hd: "bq \<noteq> [] \<Longrightarrow> rank a < rank (hd bq)"
    by (cases bq) auto
  from prems have "rank t \<le> rank (hd (ins t bq)) \<or>
    (rank (hd (ins t bq)) = rank (hd bq) \<and> bq \<noteq> [])"
    by (simp add: rank_ins2 rank_invar_cons)
  with prems have "rank a < rank (hd (ins t bq)) \<or>
    (rank (hd (ins t bq)) = rank (hd bq) \<and> bq \<noteq> [])" by auto
  with prems and inv and hd show ?case by (auto simp add: rank_invar_hd_cons)
next
  case prems: (2 a bq t)
  hence inv: "rank_invar bq" by (cases bq) simp_all
  with prems and prems(1)[of "(link t a)"] show ?case by simp
qed

lemma rank_invar_insert: "rank_invar bq \<Longrightarrow> rank_invar (insert e a bq)"
  by (simp add: rank_invar_ins insert_def)

lemma insert_correct:
  assumes I: "invar q"
  shows
  "invar (insert e a q)"
  "queue_to_multiset (insert e a q) = queue_to_multiset q + {# (e,a) #}"
  using insert_queue_invar[of q] rank_invar_insert[of q] insert_mset[of q] I
  unfolding invar_def by auto

subsubsection "Meld"
text \<open>Melds two queues.\<close>
fun meld :: "('e, 'a::linorder) BinomialQueue_inv \<Rightarrow> ('e, 'a) BinomialQueue_inv
  \<Rightarrow> ('e, 'a) BinomialQueue_inv"
  where
  "meld [] bq = bq" |
  "meld bq [] = bq" |
  "meld (t1#bq1) (t2#bq2) =
   (if (rank t1) < (rank t2)
       then t1 # (meld bq1 (t2 # bq2))
       else (
         if (rank t2 < rank t1)
            then t2 # (meld (t1 # bq1) bq2)
            else ins (link t1 t2) (meld bq1 bq2)
       )
    )"

lemma meld_queue_invar:
  "\<lbrakk>queue_invar q; queue_invar q'\<rbrakk> \<Longrightarrow> queue_invar (meld q q')"
proof2 (induct q q' rule: meld.induct)
  case 1
  then show ?case by simp
next
  case 2
  then show ?case by simp
next
  case (3 t1 bq1 t2 bq2)
  consider (lt) "rank t1 < rank t2" | (gt) "rank t1 > rank t2" | (eq) "rank t1 = rank t2"
    by atomize_elim auto
  then show ?case
  proof cases
    case lt
    from 3(4) have inv_bq1: "queue_invar bq1" by simp
    from 3(4) have inv_t1: "tree_invar t1" by simp
    from 3(1)[OF lt inv_bq1 3(5)] inv_t1 lt
    show ?thesis by simp
  next
    case gt
    from 3(5) have inv_bq2: "queue_invar bq2" by simp
    from 3(5) have inv_t2: "tree_invar t2" by simp
    from gt have "\<not> rank t1 < rank t2" by simp
    from 3(2)[OF this gt 3(4) inv_bq2] inv_t2 gt
    show ?thesis by simp
  next
    case eq
    from 3(4) have inv_bq1: "queue_invar bq1" by simp
    from 3(4) have inv_t1: "tree_invar t1" by simp
    from 3(5) have inv_bq2: "queue_invar bq2" by simp
    from 3(5) have inv_t2: "tree_invar t2" by simp
    note inv_link = link_tree_invar[OF inv_t1 inv_t2 eq]
    from eq have *: "\<not> rank t1 < rank t2" "\<not> rank t2 < rank t1" by simp_all
    note inv_meld = 3(3)[OF * inv_bq1 inv_bq2]
    from ins_queue_invar[OF inv_link inv_meld] *
    show ?thesis by simp
  qed
qed

lemma rank_ins_min: "rank_invar bq \<Longrightarrow>
  rank (hd (ins t bq)) \<ge> min (rank t) (rank (hd bq))"
  apply2(induct bq arbitrary: t)
  apply(auto)
proof goal_cases
  case prems: (1 a bq t)
  hence inv: "rank_invar bq" by (cases bq) simp_all
  from prems have r: "rank (link t a) = rank a + 1" by (simp add: rank_link)
  with prems and inv and prems(1)[of "(link t a)"] show ?case by (cases bq) auto
qed

lemma rank_invar_meld_strong:
  "\<lbrakk>rank_invar bq1; rank_invar bq2\<rbrakk> \<Longrightarrow> rank_invar (meld bq1 bq2) \<and>
  rank (hd (meld bq1 bq2)) \<ge> min (rank (hd bq1)) (rank (hd bq2))"
proof2 (induct bq1 bq2 rule: meld.induct)
  case 1
  then show ?case by simp
next
  case 2
  then show ?case by simp
next
  case (3 t1 bq1 t2 bq2)
  from 3 have inv1: "rank_invar bq1" by (cases bq1) simp_all
  from 3 have inv2: "rank_invar bq2" by (cases bq2) simp_all

  from inv1 and inv2 and 3 show ?case
  proof (auto, goal_cases)
    let ?t = "t2"
    let ?bq = "bq2"
    let ?meld = "rank t2 < rank (hd (meld (t1 # bq1) bq2))"
    case prems: 1
    hence "?bq \<noteq> [] \<Longrightarrow> rank ?t < rank (hd ?bq)"
      by (simp add: rank_invar_not_empty_hd)
    with prems have ne: "?bq \<noteq> [] \<Longrightarrow> ?meld" by simp
    from prems have "?bq = [] \<Longrightarrow> ?meld" by simp
    with ne have "?meld" by (cases "?bq = []")
    with prems show ?case by (simp add: rank_invar_hd_cons)
  next \<comment> \<open>analog\<close>
    let ?t = "t1"
    let ?bq = "bq1"
    let ?meld = "rank t1 < rank (hd (meld bq1 (t2 # bq2)))"
    case prems: 2
    hence "?bq \<noteq> [] \<Longrightarrow> rank ?t < rank (hd ?bq)"
      by (simp add: rank_invar_not_empty_hd)
    with prems have ne: "?bq \<noteq> [] \<Longrightarrow> ?meld" by simp
    from prems have "?bq = [] \<Longrightarrow> ?meld" by simp
    with ne have "?meld" by (cases "?bq = []")
    with prems show ?case by (simp add: rank_invar_hd_cons)
  next
    case 3
    thus ?case by (simp add: rank_invar_ins)
  next
    case prems: 4 (* Ab hier wirds hässlich *)
    then have r: "rank (link t1 t2) = rank t2 + 1"
      by (simp add: rank_link)
    have m: "meld bq1 [] = bq1" by (cases bq1, auto)

    from inv1 and inv2 and prems
    have mm: "min (rank (hd bq1)) (rank (hd bq2)) \<le> rank (hd (meld bq1 bq2))"
      by simp
    from \<open>rank_invar (t1 # bq1)\<close> have "bq1 \<noteq> [] \<Longrightarrow> rank t1 < rank (hd bq1)"
      by (simp add: rank_invar_not_empty_hd)
    with prems have r1: "bq1 \<noteq> [] \<Longrightarrow> rank t2 < rank (hd bq1)" by simp
    from \<open>rank_invar (t2 # bq2)\<close>
    have r2: "bq2 \<noteq> [] \<Longrightarrow> rank t2 < rank (hd bq2)"
      by (simp add: rank_invar_not_empty_hd)

    from inv1 r r1 rank_ins_min[of bq1 "(link t1 t2)"]
    have abc1: "bq1 \<noteq> [] \<Longrightarrow> rank t2 \<le> rank (hd (ins (link t1 t2) bq1))"
      by simp
    from inv2 r r2 rank_ins_min[of bq2 "(link t1 t2)"]
    have abc2: "bq2 \<noteq> [] \<Longrightarrow> rank t2 \<le> rank (hd (ins (link t1 t2) bq2))"
      by simp
    from r1 r2 mm have
      "\<lbrakk>bq1 \<noteq> []; bq2 \<noteq> []\<rbrakk> \<Longrightarrow> rank t2 < rank (hd (meld bq1 bq2))" by simp
    with \<open>rank_invar (meld bq1 bq2)\<close>
      r rank_ins_min[of "meld bq1 bq2" "link t1 t2"]
    have "\<lbrakk>bq1 \<noteq> []; bq2 \<noteq> []\<rbrakk> \<Longrightarrow>
      rank t2 < rank (hd (ins (link t1 t2) (meld bq1 bq2)))" by simp
    thm rank_ins_min[of "meld bq1 bq2" "link t1 t2"]
    with inv1 and inv2 and r m r1 show ?case
      apply(cases "bq2 = []")
      apply(cases "bq1 = []")
      apply(simp)
      apply(auto simp add: abc1)
      apply(cases "bq1 = []")
      apply(simp)
      apply(auto simp add: abc2)
      done
  qed
qed

lemma rank_invar_meld:
  "\<lbrakk>rank_invar bq1; rank_invar bq2\<rbrakk> \<Longrightarrow> rank_invar (meld bq1 bq2)"
  by (simp only: rank_invar_meld_strong)

lemma meld_mset: "\<lbrakk>queue_invar q; queue_invar q'\<rbrakk> \<Longrightarrow>
  queue_to_multiset (meld q q') =
  queue_to_multiset q + queue_to_multiset q'"
apply2(induct q q' rule: meld.induct)
  by(auto simp add: link_tree_invar meld_queue_invar ins_mset union_ac)

lemma meld_correct:
  assumes "invar q" "invar q'"
  shows
  "invar (meld q q')"
  "queue_to_multiset (meld q q') = queue_to_multiset q + queue_to_multiset q'"
  using assms
  unfolding invar_def
  by (simp_all add: meld_queue_invar rank_invar_meld meld_mset)

subsubsection "Find Minimal Element"
text \<open>Finds the tree containing the minimal element.\<close>
fun getMinTree :: "('e, 'a::linorder) BinomialQueue_inv \<Rightarrow>
  ('e, 'a) BinomialTree" where
  "getMinTree [t] = t" |
  "getMinTree (t#bq) = (if prio t \<le> prio (getMinTree bq)
     then t else (getMinTree bq))"

lemma mintree_exists: "(bq \<noteq> []) = (getMinTree bq \<in> set bq)"
proof2 (induct bq)
  case Nil
  then show ?case by simp
next
  case (Cons _ bq)
  then show ?case by (cases bq) simp_all
qed

lemma treehead_in_multiset:
  "t \<in> set bq \<Longrightarrow> (val t, prio t) \<in># queue_to_multiset bq"
  apply2 (induct bq) by (simp, cases t, auto)

lemma heap_ordered_single:
"heap_ordered t = (\<forall>x \<in> set_mset (tree_to_multiset t). prio t \<le> snd x)"
  by (cases t) auto

lemma getMinTree_cons:
  "prio (getMinTree (y # x # xs)) \<le> prio (getMinTree (x # xs))"
  apply2 (induct xs rule: getMinTree.induct) by simp_all

lemma getMinTree_min_tree:
  "t \<in> set bq  \<Longrightarrow> prio (getMinTree bq) \<le> prio t"
  apply2(induct bq arbitrary: t rule: getMinTree.induct)
  apply simp
  defer
  apply simp
proof goal_cases
  case prems: (1 t v va ta)
  thus ?case
    apply (cases "ta = t")
    apply auto[1]
    apply (metis getMinTree_cons prems(1) prems(3) set_ConsD xt1(6))
    done
qed

lemma getMinTree_min_prio:
  assumes "queue_invar bq"
    and "y \<in> set_mset (queue_to_multiset bq)"
  shows "prio (getMinTree bq) \<le> snd y"
proof -
  from assms have "bq \<noteq> []" by (cases bq) simp_all
  with assms have "\<exists> t \<in> set bq. (y \<in> set_mset ((tree_to_multiset t)))"
  proof2 (induct bq)
    case Nil
    then show ?case by simp
  next
    case (Cons a bq)
    thus ?case
      apply(cases "y \<in> set_mset (tree_to_multiset a)")
      apply simp
      apply(cases bq)
      apply simp_all
      done
  qed
  from this obtain t where O:
    "t \<in> set bq"
    "y \<in> set_mset (tree_to_multiset t)" by blast
  obtain e a r ts where [simp]: "t = (Node e a r ts)" by (cases t) blast
  from O assms(1) have inv: "tree_invar t" by (simp add: queue_invar_def)
  from tree_invar_heap_ordered[OF inv] heap_ordered.simps[of e a r ts] O
  have "prio t \<le> snd y" by auto
  with getMinTree_min_tree[OF O(1)] show ?thesis by simp
qed

text \<open>Finds the minimal Element in the queue.\<close>
definition findMin :: "('e, 'a::linorder) BinomialQueue_inv \<Rightarrow> ('e \<times> 'a)" where
  "findMin bq = (let min = getMinTree bq in (val min, prio min))"

lemma findMin_correct:
  assumes I: "invar q"
  assumes NE: "q \<noteq> Nil"
  shows
  "findMin q \<in># queue_to_multiset q"
  "\<forall>y\<in>set_mset (queue_to_multiset q). snd (findMin q) \<le> snd y"
proof -
  from NE have "getMinTree q \<in> set q" by (simp only: mintree_exists)
  thus "findMin q \<in># queue_to_multiset q"
    by (simp add: treehead_in_multiset Let_def findMin_def)
  show "\<forall>y\<in>set_mset (queue_to_multiset q). snd (findMin q) \<le> snd y"
    using I[unfolded invar_def]
    by (auto simp add: getMinTree_min_prio Let_def findMin_def)
qed

subsubsection "Delete Minimal Element"

text \<open>Removes the first tree, which has the priority $a$ within his root.\<close>
fun remove1Prio :: "'a \<Rightarrow> ('e, 'a::linorder) BinomialQueue_inv \<Rightarrow>
  ('e, 'a) BinomialQueue_inv" where
  "remove1Prio a [] = []" |
  "remove1Prio a (t#bq) =
  (if (prio t) = a then bq else t # (remove1Prio a bq))"

text \<open>Returns the queue without the minimal element.\<close>
definition deleteMin :: "('e, 'a::linorder) BinomialQueue_inv \<Rightarrow>
  ('e, 'a) BinomialQueue_inv" where
  "deleteMin bq \<equiv> (let min = getMinTree bq in
                    meld (rev (children min))
                         (remove1Prio (prio min) bq))"

lemma queue_invar_rev: "queue_invar q \<Longrightarrow> queue_invar (rev q)"
  by (simp add: queue_invar_def)

lemma queue_invar_remove1: "queue_invar q \<Longrightarrow> queue_invar (remove1 t q)"
  by (auto simp add: queue_invar_def)

lemma qtm_in_set_subset: "t \<in> set q \<Longrightarrow>
  tree_to_multiset t \<subseteq># queue_to_multiset q"
proof2(induct q)
  case Nil
  then show ?case by simp
next
  case (Cons a q)
  show ?case
  proof (cases "t = a")
    case True
    then show ?thesis by simp
  next
    case False
    with Cons have t_in_q: "t \<in> set q" by simp
    have "queue_to_multiset q \<subseteq># queue_to_multiset (a # q)"
      by simp
    from subset_mset.order_trans[OF Cons(1)[OF t_in_q] this] show ?thesis .
  qed
qed

lemma remove1Prio_remove1[simp]:
  "remove1Prio (prio (getMinTree bq)) bq = remove1 (getMinTree bq) bq"
proof2 (induct bq)
  case Nil thus ?case by simp
next
  case (Cons t bq)
  note iv = Cons
  thus ?case
  proof (cases "t = getMinTree (t # bq)")
    case True
    with iv show ?thesis by simp
  next
    case False
    hence ne: "bq \<noteq> []" by auto
    with False have down: "getMinTree (t # bq) = getMinTree bq"
      apply2 (induct bq rule: getMinTree.induct) by auto
    from ne False have "prio t \<noteq> prio (getMinTree bq)"
      apply2 (induct bq rule: getMinTree.induct) by auto
    with down iv False ne show ?thesis by simp
  qed
qed

lemma deleteMin_queue_invar:
  assumes INV: "queue_invar q"
  assumes NE: "q \<noteq> Nil"
  shows "queue_invar (deleteMin q)"
proof (cases q)
  case Nil
  with assms show ?thesis by simp
next
  case Cons
  from NE and mintree_exists[of q] INV
  have inv_min: "tree_invar (getMinTree q)" by (simp add: queue_invar_def)
  note inv_children = invar_children'[OF inv_min]
  note inv_rev = queue_invar_rev[OF inv_children]
  note inv_rem = queue_invar_remove1[OF INV, of "getMinTree q"]
  from meld_queue_invar[OF inv_rev inv_rem] show ?thesis
    by (simp add: deleteMin_def Let_def)
qed

lemma children_rank_less:
  assumes "tree_invar t"
  shows "\<forall>t' \<in> set (children t). rank t' < rank t"
proof (cases t)
  case (Node e a nat list)
  with assms show ?thesis
  proof2 (induct nat arbitrary: t e a list)
    case 0
    then show ?case by simp
  next
    case (Suc nat)
    then obtain e1 a1 ts1 e2 a2 ts2 where
      O: "tree_invar (Node e1 a1 nat ts1)" "tree_invar (Node e2 a2 nat ts2)"
        "t = link (Node e1 a1 nat ts1) (Node e2 a2 nat ts2)"
      by (simp only: tree_invar.simps) blast
    hence ch_id: "children t =
      (if a1 \<le> a2 then (Node e2 a2 nat ts2)#ts1
       else (Node e1 a1 nat ts1)#ts2)" by simp
    from O Suc(1)[of "Node e1 a1 nat ts1" "e1" "a1" "ts1"]
    have  p1: "\<forall>t'\<in>set ((Node e2 a2 nat ts2) # ts1). rank t' < Suc nat" by auto
    from O Suc(1)[of "Node e2 a2 nat ts2" "e2" "a2" "ts2"]
    have p2: "\<forall>t'\<in>set ((Node e1 a1 nat ts1) # ts2). rank t' < Suc nat" by auto
    from Suc(3) p1 p2 ch_id show ?case by simp
  qed
qed

lemma strong_rev_children:
  assumes "tree_invar t"
  shows "invar (rev (children t))"
  unfolding invar_def
proof (cases t)
  case (Node e a nat list)
  with assms show "queue_invar (rev (children t)) \<and> rank_invar (rev (children t))"
  proof2 (induct "nat" arbitrary: t e a list)
    case 0
    then show ?case by simp
  next
    case (Suc nat)
    then obtain e1 a1 ts1 e2 a2 ts2 where
      O: "tree_invar (Node e1 a1 nat ts1)" "tree_invar (Node e2 a2 nat ts2)"
        "t = link (Node e1 a1 nat ts1) (Node e2 a2 nat ts2)"
      by (simp only: tree_invar.simps) blast
    hence ch_id: "children t =
      (if a1 \<le> a2 then (Node e2 a2 nat ts2)#ts1
       else (Node e1 a1 nat ts1)#ts2)" by simp
    from O Suc(1)[of "Node e1 a1 nat ts1" "e1" "a1" "ts1"]
    have rev_ts1: "invar (rev ts1)" by (simp add: invar_def)
    from O children_rank_less[of "Node e1 a1 nat ts1"]
    have  "\<forall>t\<in>set (rev ts1). rank t < rank (Node e2 a2 nat ts2)" by simp
    with O rev_ts1 invar_app_single[of "rev ts1" "Node e2 a2 nat ts2"]
    have p1: "invar (rev ((Node e2 a2 nat ts2) # ts1))" by simp
    from O Suc(1)[of "Node e2 a2 nat ts2" "e2" "a2" "ts2"]
    have rev_ts2: "invar (rev ts2)" by (simp add: invar_def)
    from O children_rank_less[of "Node e2 a2 nat ts2"]
    have "\<forall>t\<in>set (rev ts2). rank t < rank (Node e1 a1 nat ts1)" by simp
    with O rev_ts2 invar_app_single[of "rev ts2" "Node e1 a1 nat ts1"]
    have p2: "invar (rev ((Node e1 a1 nat ts1) # ts2))" by simp
    from p1 p2 ch_id show ?case by (simp add: invar_def)
  qed
qed

lemma first_less: "rank_invar (t # bq) \<Longrightarrow> \<forall>t' \<in> set bq. rank t < rank t'"
  apply2(induct bq arbitrary: t)
  apply (simp)
  apply (metis order_le_less rank_invar.simps(3) set_ConsD xt1(7))
  done

lemma strong_remove1: "invar bq \<Longrightarrow> invar (remove1 t bq)"
proof2 (induct bq arbitrary: t)
  case Nil
  then show ?case by simp
next
  case (Cons a bq)
  show ?case
  proof (cases "t=a")
    case True
    from Cons(2) have "invar bq" by (rule invar_cons_down)
    with True show ?thesis by simp
  next
    case False
    from Cons(2) have "invar bq" by (rule invar_cons_down)
    with Cons(1)[of "t"] have si1: "invar (remove1 t bq)" .
    from False have "invar (remove1 t (a # bq)) = invar (a # (remove1 t bq))"
      by simp
    show ?thesis
    proof (cases "remove1 t bq")
      case Nil
      with si1 Cons(2) False show ?thesis by (simp add: invar_def)
    next
      case Cons': (Cons aa list)
      from Cons have "tree_invar a" by (simp add: invar_def)
      from Cons first_less[of "a" "bq"] have "\<forall>t \<in> set (remove1 t bq). rank a < rank t"
        by (metis notin_set_remove1 invar_def)
      with Cons' have "rank a < rank aa" by simp
      with si1 Cons(2) False Cons' invar_cons_up[of "aa" "list" "a"] show ?thesis
        by (simp add: invar_def)
    qed
  qed
qed

theorem deleteMin_invar:
  assumes "invar bq"
    and "bq \<noteq> []"
  shows "invar (deleteMin bq)"
proof -
  have eq: "invar (deleteMin bq) =
    invar (meld (rev (children (getMinTree bq))) (remove1 (getMinTree bq) bq))"
    by (simp add: deleteMin_def Let_def)
  from assms mintree_exists[of "bq"] have ti: "tree_invar (getMinTree bq)"
    by (simp add: invar_def Let_def queue_invar_def)
  with strong_rev_children[of "getMinTree bq"]
  have m1: "invar (rev (children (getMinTree bq)))" .
  from strong_remove1[of "bq" "getMinTree bq"] assms(1)
  have m2: "invar (remove1 (getMinTree bq) bq)" .
  from meld_correct(1)[of "rev (children (getMinTree bq))"
    "remove1 (getMinTree bq) bq"] m1 m2
  have "invar (meld (rev (children (getMinTree bq))) (remove1 (getMinTree bq) bq))" .
  with eq show ?thesis ..
qed

lemma children_mset: "queue_to_multiset (children t) =
  tree_to_multiset t - {# (val t, prio t) #}"
proof (cases t)
  case (Node e a nat list)
  thus ?thesis apply2 (induct list) by simp_all
qed

lemma deleteMin_mset:
  assumes "queue_invar q"
    and "q \<noteq> Nil"
  shows "queue_to_multiset (deleteMin q) = queue_to_multiset q - {# (findMin q) #}"
proof -
  from assms mintree_exists[of "q"] have min_in_q: "getMinTree q \<in> set q" by auto
  with assms(1) have inv_min: "tree_invar (getMinTree q)"
    by (simp add: queue_invar_def)
  from assms(2) have q_ne: "q \<noteq> []" .
  note inv_children = invar_children'[OF inv_min]
  note inv_rev = queue_invar_rev[OF inv_children]
  note inv_rem = queue_invar_remove1[OF assms(1), of "getMinTree q"]
  note m_meld = meld_mset[OF inv_rev inv_rem]
  note m_rem = remove1_mset[OF min_in_q]
  note m_rev = qtmset_rev[of "children (getMinTree q)"]
  note m_children = children_mset[of "getMinTree q"]
  note min_subset_q = qtm_in_set_subset[OF min_in_q]
  let ?Q = "queue_to_multiset q"
  let ?MT = "tree_to_multiset (getMinTree q)"
  from q_ne have head_subset_min:
    "{# (val (getMinTree q), prio (getMinTree q)) #} \<subseteq># ?MT"
    by(cases "getMinTree q") simp
  let ?Q = "queue_to_multiset q"
  let ?MT = "tree_to_multiset (getMinTree q)"
  from m_meld m_rem m_rev m_children
    multiset_diff_union_assoc[OF head_subset_min, of "?Q - ?MT"]
    mset_subset_eq_multiset_union_diff_commute[OF min_subset_q, of "?MT"]
  show ?thesis by (simp add: deleteMin_def union_ac Let_def findMin_def)
qed

lemma deleteMin_correct:
  assumes INV: "invar q"
  assumes NE: "q \<noteq> Nil"
  shows
  "invar (deleteMin q)"
  "queue_to_multiset (deleteMin q) = queue_to_multiset q - {# (findMin q) #}"
  using deleteMin_invar deleteMin_mset INV NE
  unfolding invar_def
  by auto

end

interpretation BinomialHeapStruc: BinomialHeapStruc_loc .

subsection "Hiding the Invariant"
subsubsection "Datatype"
typedef (overloaded) ('e, 'a) BinomialHeap =
  "{q :: ('e,'a::linorder) BinomialHeapStruc.BinomialQueue_inv. BinomialHeapStruc.invar q }"
  apply (rule_tac x="Nil" in exI)
  apply auto
  done

lemma Rep_BinomialHeap_invar[simp]:
  "BinomialHeapStruc.invar (Rep_BinomialHeap x)"
  using Rep_BinomialHeap
  by (auto)

lemma [simp, code abstype]: "Abs_BinomialHeap (Rep_BinomialHeap q) = q"
  by (rule Rep_BinomialHeap_inverse)

locale BinomialHeap_loc
begin
  subsubsection "Operations"

  definition [code]:
    "to_mset t == BinomialHeapStruc.queue_to_multiset (Rep_BinomialHeap t)"

  definition empty where "empty == Abs_BinomialHeap Nil"
  lemma [code abstract, simp]: "Rep_BinomialHeap empty = []"
    by (unfold empty_def) simp

  definition [code]: "isEmpty q == Rep_BinomialHeap q = Nil"
  lemma empty_rep: "q=empty \<longleftrightarrow> Rep_BinomialHeap q = Nil"
    apply (auto simp add: empty_def)
    apply (metis Rep_BinomialHeap_inverse)
    done

  lemma isEmpty_correct: "isEmpty q \<longleftrightarrow> q=empty"
    by (simp add: empty_rep isEmpty_def)

  definition
    insert
    :: "'e  \<Rightarrow> ('a::linorder) \<Rightarrow> ('e,'a) BinomialHeap \<Rightarrow> ('e,'a) BinomialHeap"
    where "insert e a q ==
            Abs_BinomialHeap (BinomialHeapStruc.insert e a (Rep_BinomialHeap q))"
  lemma [code abstract]:
    "Rep_BinomialHeap (insert e a q)
    = BinomialHeapStruc.insert e a (Rep_BinomialHeap q)"
    by (simp add: insert_def BinomialHeapStruc.insert_correct)

  definition [code]: "findMin q == BinomialHeapStruc.findMin (Rep_BinomialHeap q)"

  definition "deleteMin q ==
    if q=empty then empty
    else Abs_BinomialHeap (BinomialHeapStruc.deleteMin (Rep_BinomialHeap q))"

  text \<open>
    In this lemma, we do not use equality, but case-distinction for checking
    non-emptyness. That prevents the code generator from introducing
    an equality-class parameter for the entry type \<open>'a\<close>.
\<close>
  lemma [code abstract]: "Rep_BinomialHeap (deleteMin q) =
    (case (Rep_BinomialHeap q) of [] \<Rightarrow> [] |
     _ \<Rightarrow> BinomialHeapStruc.deleteMin (Rep_BinomialHeap q))"
  proof (cases "Rep_BinomialHeap q")
    case Nil
    show ?thesis
      apply (simp add: Nil)
      apply (auto simp add: deleteMin_def BinomialHeapStruc.deleteMin_correct
      BinomialHeapStruc.empty_iff empty_rep Nil)
      done
  next
    case (Cons a b)
    hence NE: "Rep_BinomialHeap q \<noteq> []" by auto
    show ?thesis
      apply (simp add: Cons)
      apply (fold Cons)
      using NE
      by (auto simp add: deleteMin_def BinomialHeapStruc.deleteMin_correct
        BinomialHeapStruc.empty_iff empty_rep)
  qed

  (*
  lemma [code abstract]: "Rep_BinomialHeap (deleteMin q) =
    (if (Rep_BinomialHeap q = []) then []
     else BinomialHeapStruc.deleteMin (Rep_BinomialHeap q))"
    by (auto simp add: deleteMin_def BinomialHeapStruc.deleteMin_correct
      BinomialHeapStruc.empty_iff empty_rep)
      *)

  definition "meld q1 q2 ==
    Abs_BinomialHeap (BinomialHeapStruc.meld (Rep_BinomialHeap q1)
                                             (Rep_BinomialHeap q2))"
  lemma [code abstract]:
    "Rep_BinomialHeap (meld q1 q2)
    = BinomialHeapStruc.meld (Rep_BinomialHeap q1) (Rep_BinomialHeap q2)"
    by (simp add: meld_def BinomialHeapStruc.meld_correct)

  subsubsection "Correctness"

  lemma empty_correct: "to_mset q = {#} \<longleftrightarrow> q=empty"
    by (simp add: to_mset_def BinomialHeapStruc.empty_iff empty_rep)

  lemma to_mset_of_empty[simp]: "to_mset empty = {#}"
    by (simp add: empty_correct)

  lemma insert_correct: "to_mset (insert e a q) = to_mset q + {#(e,a)#}"
    apply (unfold insert_def to_mset_def)
    apply (simp add: BinomialHeapStruc.insert_correct)
    done

  lemma findMin_correct:
    assumes "q\<noteq>empty"
    shows
    "findMin q \<in># to_mset q"
    "\<forall>y\<in>set_mset (to_mset q). snd (findMin q) \<le> snd y"
    using assms
    apply (unfold findMin_def to_mset_def)
    apply (simp_all add: empty_rep BinomialHeapStruc.findMin_correct)
    done

  lemma deleteMin_correct:
    assumes "q\<noteq>empty"
    shows "to_mset (deleteMin q) = to_mset q - {# findMin q #}"
    using assms
    apply (unfold findMin_def deleteMin_def to_mset_def)
    apply (simp_all add: empty_rep BinomialHeapStruc.deleteMin_correct)
    done

  lemma meld_correct:
    shows "to_mset (meld q q') = to_mset q + to_mset q'"
    apply (unfold to_mset_def meld_def)
    apply (simp_all add: BinomialHeapStruc.meld_correct)
    done

  text \<open>Correctness lemmas to be used with simplifier\<close>
  lemmas correct = empty_correct deleteMin_correct meld_correct

  end
  interpretation BinomialHeap: BinomialHeap_loc .

subsection "Documentation"

(*#DOC
  fun [no_spec] BinomialHeap.to_mset
    Abstraction to multiset.

  fun BinomialHeap.empty
    The empty heap. ($O(1)$)

  fun BinomialHeap.isEmpty
    Checks whether heap is empty. Mainly used to work around
    code-generation issues. ($O(1)$)

  fun BinomialHeap.insert
    Inserts element ($O(\log(n))$)

  fun BinomialHeap.findMin
    Returns a minimal element ($O(\log(n))$)

  fun BinomialHeap.deleteMin
    Deletes {\em the} element that is returned by {\em find\_min}

  fun [long_type] BinomialHeap.meld
    Melds two heaps ($O(\log(n+m))$)

*)

text \<open>
    \underline{@{term_type "BinomialHeap.to_mset"}}\\
        Abstraction to multiset.\\

    \underline{@{term_type "BinomialHeap.empty"}}\\
        The empty heap. ($O(1)$)\\
    {\bf Spec} \<open>BinomialHeap.empty_correct\<close>:
    @{thm [display] BinomialHeap.empty_correct[no_vars]}

    \underline{@{term_type "BinomialHeap.isEmpty"}}\\
        Checks whether heap is empty. Mainly used to work around
    code-generation issues. ($O(1)$)\\
    {\bf Spec} \<open>BinomialHeap.isEmpty_correct\<close>:
    @{thm [display] BinomialHeap.isEmpty_correct[no_vars]}

    \underline{@{term_type "BinomialHeap.insert"}}\\
        Inserts element ($O(\log(n))$)\\
    {\bf Spec} \<open>BinomialHeap.insert_correct\<close>:
    @{thm [display] BinomialHeap.insert_correct[no_vars]}

    \underline{@{term_type "BinomialHeap.findMin"}}\\
        Returns a minimal element ($O(\log(n))$)\\
    {\bf Spec} \<open>BinomialHeap.findMin_correct\<close>:
    @{thm [display] BinomialHeap.findMin_correct[no_vars]}

    \underline{@{term_type "BinomialHeap.deleteMin"}}\\
        Deletes {\em the} element that is returned by {\em find\_min}\\
    {\bf Spec} \<open>BinomialHeap.deleteMin_correct\<close>:
    @{thm [display] BinomialHeap.deleteMin_correct[no_vars]}

    \underline{@{term "BinomialHeap.meld"}}
    @{term_type [display] "BinomialHeap.meld"}
        Melds two heaps ($O(\log(n+m))$)\\
    {\bf Spec} \<open>BinomialHeap.meld_correct\<close>:
    @{thm [display] BinomialHeap.meld_correct[no_vars]}

\<close>

end


theory le
imports Main
        "../data/Natu"
        "$HIPSTER_HOME/IsaHipster"

begin

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

(*hipster le*)

lemma lemma_a [thy_expl]: "le x2 x2 = True"
by (hipster_induct_schemes le.simps)

lemma lemma_aa [thy_expl]: "le x2 (S x2) = True"
by (hipster_induct_schemes le.simps)

lemma lemma_ab [thy_expl]: "le (S x2) x2 = False"
by (hipster_induct_schemes le.simps)

(*hipster_cond le*)
lemma lemma_ac [thy_expl]: "le x2 y2 \<Longrightarrow> le x2 (S y2) = True"
by (hipster_induct_schemes le.simps)

lemma lemma_ad [thy_expl]: "le y2 x2 \<Longrightarrow> le (S x2) y2 = False"
by (hipster_induct_schemes le.simps)

(* false
lemma unknown [thy_expl]: "le y y \<and> le x z \<Longrightarrow> le x (S Z) = le x (S y)"
oops *)

lemma lemma_ae [thy_expl]: "le y x \<and> le x y \<Longrightarrow> x = y"
by (hipster_induct_schemes le.simps Nat.exhaust)

ML \<open>
fun rprems_tac ctxt = Goal.norm_hhf_tac ctxt THEN' CSUBGOAL (fn (goal, i) =>
      let
        fun non_atomic (Const ("==>", _) $ _ $ _) = true
          | non_atomic (Const ("all", _) $ _) = true
          | non_atomic _ = false;

        val ((_, goal'), ctxt') = Variable.focus_cterm goal ctxt;
        val goal'' = Drule.cterm_rule
          (singleton (Variable.export ctxt' ctxt)) goal';
        val Rs = filter (non_atomic o Thm.term_of)
          (Drule.strip_imp_prems goal'');
        val _ = @{print} Rs
        val _ = @{print} goal''

        val ethms = Rs |> map (fn R =>
          (Raw_Simplifier.norm_hhf ctxt' (Thm.trivial R)));
      in eresolve_tac ethms i end
  );\<close>

lemma le_trans [thy_expl]: "le z y \<and> le x z \<Longrightarrow> le x y = True"
by (hipster_induct_schemes le.simps Nat.exhaust)
(*
apply(induct x y arbitrary: z rule: le.induct) (* or: x, z *)
apply(simp_all)
apply(metis le.simps Nat.exhaust thy_expl)
apply(metis le.simps Nat.exhaust thy_expl)

by (hipster_induct_schemes le.simps Nat.exhaust)*)
(*
apply(induct x arbitrary: y rule: le.induct) (* or: x, z *)
apply(simp_all)
apply(metis le.simps  thy_expl)
by(metis le.simps Nat.exhaust thy_expl)*)

(* false
lemma unknown [thy_expl]: "le x z \<and> le z z \<Longrightarrow> le x (S y) = True"
oops *)

end