theory Isar_Demo
imports Main
begin

section{* An introductory example *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume 0: "surj f"
  from 0 have 1: "\<forall>A. \<exists>a. A = f a" by(simp add: surj_def)
  from 1 have 2: "\<exists>a. {x. x \<notin> f x} = f a" by blast
  from 2 show "False" by blast
qed

text{* A bit shorter: *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume 0: "surj f"
  from 0 have 1: "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  from 1 show "False" by blast
qed

subsection{* this, then, hence and thus *}

text{* Avoid labels, use this: *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  from this have "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  from this show "False" by blast
qed

text{* then = from this *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  then have "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  then show "False" by blast
qed

text{* hence = then have, thus = then show *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  thus "False" by blast
qed

subsection{* Structured statements: fixes, assumes, shows *}

lemma
  fixes f :: "'a \<Rightarrow> 'a set"
  assumes s: "surj f"
  shows "False"
proof -  --"no automatic proof step!"
  have "\<exists> a. {x. x \<notin> f x} = f a" using s
    by(auto simp: surj_def)
  thus "False" by blast
qed

section{* Proof patterns *}

lemma "P \<longleftrightarrow> Q"
proof
  assume "P"
  show "Q" sorry
next
  assume "Q"
  show "P" sorry
qed

lemma "A = (B::'a set)"
proof
  show "A \<subseteq> B" sorry
next
  show "B \<subseteq> A" sorry
qed

lemma "A \<subseteq> B"
proof
  fix a
  assume "a \<in> A"
  show "a \<in> B" sorry
qed

text{* Contradiction *}

lemma P
proof (rule ccontr)
  assume "\<not>P"
  show "False" sorry
qed

text{* Case distinction *}

lemma "R"
proof cases
  assume "P"
  show "R" sorry
next
  assume "\<not> P"
  show "R" sorry
qed

lemma "R"
proof -
  have "P \<or> Q" sorry
  then show "R"
  proof
    assume "P"
    show "R" sorry
  next
    assume "Q"
    show "R" sorry
  qed
qed

text{* obtain example *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  then obtain a where "{x. x \<notin> f x} = f a" by blast
  hence "a \<notin> f a \<longleftrightarrow> a \<in> f a" by blast
  thus "False" by blast
qed

text{* Interactive exercise: *}

lemma assumes "EX x. ALL y. P x y" shows "ALL y. EX x. P x y"
oops

section{* Streamlining proofs *}

subsection{* Pattern matching and ?-variables *}

text{* Show EX *}

lemma "EX xs. length xs = 0" (is "EX xs. ?P xs")
proof
  show "?P([])" by simp
qed

text{* Multiple EX easier with forward proof: *}

lemma "EX x y :: int. x < z & z < y" (is "EX x y. ?P x y")
proof -
  have "?P (z - 1) (z + 1)" by arith
  thus ?thesis by blast
qed

subsection{* Quoting facts: *}

lemma assumes "x < (0::int)" shows "x*x > 0"
proof -
  from `x<0` show ?thesis by(metis mult_neg_neg)
qed

subsection {* Example: Top Down Proof Development *}

text{* The key idea: case distinction on length: *}

lemma "(EX ys zs. xs = ys @ zs \<and> length ys = length zs) |
  (EX ys zs. xs = ys @ zs & length ys = length zs + 1)"
proof cases
  assume "EX n. length xs = n+n"
  show ?thesis sorry
next
  assume "\<not> (EX n. length xs = n+n)"
  show ?thesis sorry
qed

text{* A proof skeleton: *}

lemma "(EX ys zs. xs = ys @ zs \<and> length ys = length zs) |
  (EX ys zs. xs = ys @ zs & length ys = length zs + 1)"
proof cases
  assume "EX n. length xs = n+n"
  then obtain n where "length xs = n+n" by blast
  let ?ys = "take n xs"
  let ?zs = "take n (drop n xs)"
  have "xs = ?ys @ ?zs \<and> length ?ys = length ?zs" sorry
  thus ?thesis by blast
next
  assume "\<not> (EX n. length xs = n+n)"
  then obtain n where "length xs = Suc(n+n)" sorry
  let ?ys = "take (Suc n) xs"
  let ?zs = "take n (drop (Suc n) xs)"
  have "xs = ?ys @ ?zs \<and> length ?ys = length ?zs + 1" sorry
  then show ?thesis by blast
qed

text{* The complete proof: *}

lemma "(EX ys zs. xs = ys @ zs \<and> length ys = length zs) |
  (EX ys zs. xs = ys @ zs & length ys = length zs + 1)"
proof cases
  assume "EX n. length xs = n+n"
  then obtain n where "length xs = n+n" by blast
  let ?ys = "take n xs"
  let ?zs = "take n (drop n xs)"
  have "xs = ?ys @ ?zs \<and> length ?ys = length ?zs"
    by (metis `length xs = n + n` add_diff_cancel_right' append_Nil2 append_eq_conv_conj length_append length_drop take_add)
  thus ?thesis by blast
next
  assume "\<not> (EX n. length xs = n+n)"
  hence "EX n. length xs = Suc(n+n)" by arith
  then obtain n where l: "length xs = Suc(n+n)" by blast
  let ?ys = "take (Suc n) xs"
  let ?zs = "take n (drop (Suc n) xs)"
  have 1: "xs = ?ys @ ?zs"
    by (metis l add_Suc_right add_Suc_shift le_refl take_add take_all)
  have 2: "length ?ys = length ?zs + 1" using l by simp
  from 1 2 show ?thesis by blast
qed

subsection {* moreover *}

lemma assumes "A \<and> B" shows "B \<and> A"
proof -
  from `A \<and> B` have "A" by auto
  moreover
  from `A \<and> B` have "B" by auto
  ultimately show "B \<and> A" by auto
qed

subsection{* Raw proof blocks *}

lemma fixes k :: int assumes "k dvd (n+k)" shows "k dvd n"
proof -
  { fix a assume a: "n+k = k*a"
    have "EX b. n = k*b"
    proof
      show "n = k*(a - 1)" using a by(simp add: algebra_simps)
    qed }
  with assms show ?thesis by (auto simp add: dvd_def)
qed

end


(*  Title:       Cauchy's Mean Theorem
    Author:      Benjamin Porter <Benjamin.Porter at gmail.com>, 2006
                 cleaned up a bit by Tobias Nipkow, 2007
    Maintainer:  Benjamin Porter <Benjamin.Porter at gmail.com>
*)

header {* Cauchy's Mean Theorem *}

theory CauchysMeanTheorem
imports Complex_Main
begin

section {* Abstract *}

text {* The following document presents a proof of Cauchy's Mean
theorem formalised in the Isabelle/Isar theorem proving system.

{\em Theorem}: For any collection of positive real numbers the
geometric mean is always less than or equal to the arithmetic mean. In
mathematical terms: $$\sqrt[n]{x_1 x_2 \dots x_n} \leq \frac{x_1 +
\dots + x_n}{n}$$ We will use the term {\em mean} to denote the
arithmetic mean and {\em gmean} to denote the geometric mean.

{\em Informal Proof}:

This proof is based on the proof presented in [1]. First we need an
auxiliary lemma (the proof of which is presented formally below) that
states:

Given two pairs of numbers of equal sum, the pair with the greater
product is the pair with the least difference. Using this lemma we now
present the proof -

Given any collection $C$ of positive numbers with mean $M$ and product
$P$ and with some element not equal to M we can choose two elements
from the collection, $a$ and $b$ where $a>M$ and $b<M$. Remove these
elements from the collection and replace them with two new elements,
$a'$ and $b'$ such that $a' = M$ and $a' + b' = a + b$. This new
collection $C'$ now has a greater product $P'$ but equal mean with
respect to $C$. We can continue in this fashion until we have a
collection $C_n$ such that $P_n > P$ and $M_n = M$, but $C_n$ has all
its elements equal to $M$ and thus $P_n = M^n$. Using the definition
of geometric and arithmetic means above we can see that for any
collection of positive elements $E$ it is always true that gmean E
$\leq$ mean E. QED.

[1] Dorrie, H. "100 Great Problems of Elementary Mathematics." 1965, Dover.
*}

section {* Formal proof *}

(* ============================================================================= *)
(* ============================================================================= *)
(* ============================================================================= *)

subsection {* Collection sum and product *}

text {* The finite collections of numbers will be modelled as
lists. We then define sum and product operations over these lists. *}

subsubsection {* Sum and product definitions *}

definition
  listsum :: "(real list) \<Rightarrow> real" ("\<Sum>:_" [999] 998) where
  "listsum xs = foldr op+ xs 0"

definition
  listprod :: "(real list) \<Rightarrow> real" ("\<Prod>:_" [999] 998) where
  "listprod xs = foldr op* xs 1"

lemma listsum_empty [simp]: "\<Sum>:[] = 0"
  unfolding listsum_def by simp

lemma listsum_cons [simp]: "\<Sum>:(a#b) = a + \<Sum>:b"
  unfolding listsum_def by (induct b) simp_all

lemma listprod_empty [simp]: "\<Prod>:[] = 1"
  unfolding listprod_def by simp

lemma listprod_cons [simp]: "\<Prod>:(a#b) = a * \<Prod>:b"
  unfolding listprod_def by (induct b) simp_all

subsubsection {* Properties of sum and product *}

text {* We now present some useful properties of sum and product over
collections. *}

text {* These lemmas just state that if all the elements in a
collection $C$ are less (greater than) than some value $m$, then the
sum will less than (greater than) $m*length(C)$. *}

lemma listsum_mono_lt [rule_format]:
  fixes xs::"real list"
  shows "xs \<noteq> [] \<and> (\<forall>x\<in> set xs. x < m)
         \<longrightarrow> ((\<Sum>:xs) < (m*(real (length xs))))"
proof (induct xs)
  case Nil show ?case by simp
next
  case (Cons y ys)
  {
    assume ant: "y#ys \<noteq> [] \<and> (\<forall>x\<in>set(y#ys). x < m)"
    hence ylm: "y < m" by simp
    have "\<Sum>:(y#ys) < m * real (length (y#ys))"
    proof cases
      assume "ys \<noteq> []"
      moreover with ant have "\<forall>x\<in>set ys. x < m" by simp
      moreover with calculation Cons have "\<Sum>:ys < m*real (length ys)" by simp
      hence "\<Sum>:ys + y < m*real(length ys) + y" by simp
      with ylm have "\<Sum>:(y#ys) < m*(real(length ys) + 1)" by(simp add:field_simps)
      with real_of_nat_Suc have "\<Sum>:(y#ys) < m*(real(length ys + 1))"
        apply -
        apply (drule meta_spec [of _ "length ys"])
        apply (subst(asm) eq_sym_conv)
        by simp
      hence "\<Sum>:(y#ys) < m*(real (length(y#ys)))" by simp
      thus ?thesis .
    next
      assume "\<not> (ys \<noteq> [])"
      hence "ys = []" by simp
      with ylm show ?thesis by simp
    qed
  }
  thus ?case by simp
qed

lemma listsum_mono_gt [rule_format]:
  fixes xs::"real list"
  shows "xs \<noteq> [] \<and> (\<forall>x\<in>set xs. x > m)
         \<longrightarrow> ((\<Sum>:xs) > (m*(real (length xs))))"
txt {* proof omitted *}
(*<*)
proof (induct xs)
  case Nil show ?case by simp
next
  case (Cons y ys)
  {
    assume ant: "y#ys \<noteq> [] \<and> (\<forall>x\<in>set(y#ys). x > m)"
    hence ylm: "y > m" by simp
    have "\<Sum>:(y#ys) > m * real (length (y#ys))"
    proof cases
      assume "ys \<noteq> []"
      moreover with ant have "\<forall>x\<in>set ys. x > m" by simp
      moreover with calculation Cons have "\<Sum>:ys > m*real (length ys)" by simp
      hence "\<Sum>:ys + y > m*real(length ys) + y" by simp
      with ylm have "\<Sum>:(y#ys) > m*(real(length ys) + 1)" by(simp add:field_simps)
      with real_of_nat_Suc have "\<Sum>:(y#ys) > m*(real(length ys + 1))"
        apply -
        apply (drule meta_spec [of _ "length ys"])
        apply (subst(asm) eq_sym_conv)
        by simp
      hence "\<Sum>:(y#ys) > m*(real (length(y#ys)))" by simp
      thus ?thesis .
    next
      assume "\<not> (ys \<noteq> [])"
      hence "ys = []" by simp
      with ylm show ?thesis by simp
    qed
  }
  thus ?case by simp
(*>*)
qed

text {* If $a$ is in $C$ then the sum of the collection $D$ where $D$
is $C$ with $a$ removed is the sum of $C$ minus $a$. *}

lemma listsum_rmv1:
  "a \<in> set xs \<Longrightarrow> \<Sum>:(remove1 a xs) = \<Sum>:xs - a"
by (induct xs) auto

text {* A handy addition and division distribution law over collection
sums. *}

lemma list_sum_distrib_aux:
  shows "(\<Sum>:xs/n + \<Sum>:xs) = (1 + (1/n)) * \<Sum>:xs"
proof (induct xs)
  case Nil show ?case by simp
next
  case (Cons x xs)
  show ?case
  proof -
    have
      "\<Sum>:(x#xs)/n = x/n + \<Sum>:xs/n"
      by (simp add: add_divide_distrib)
    also with Cons have
      "\<dots> = x/n + (1+1/n)*\<Sum>:xs - \<Sum>:xs"
      by simp
    finally have
      "\<Sum>:(x#xs) / n + \<Sum>:(x#xs) = x/n + (1+1/n)*\<Sum>:xs - \<Sum>:xs + \<Sum>:(x#xs)"
      by simp
    also have
      "\<dots> = x/n + (1+(1/n)- 1)*\<Sum>:xs + \<Sum>:(x#xs)"
      by (subst mult_1_left [symmetric, of "\<Sum>:xs"]) (simp add: field_simps)
    also have
      "\<dots> = x/n + (1/n)*\<Sum>:xs + \<Sum>:(x#xs)"
      by simp
    also have
      "\<dots> = (1/n)*\<Sum>:(x#xs) + 1*\<Sum>:(x#xs)" by(simp add: divide_simps)
    finally show ?thesis by (simp add: field_simps)
  qed
qed

lemma remove1_retains_prod:
  fixes a::real and xs::"real list"
  shows "a : set xs \<longrightarrow> \<Prod>:xs = \<Prod>:(remove1 a xs) * a"
  (is "?P xs")
proof (induct xs)
  case Nil
  show ?case by simp
next
  case (Cons aa list)
  assume plist: "?P list"
  show "?P (aa#list)"
  proof
    assume aml: "a : set(aa#list)"
    show "\<Prod>:(aa # list) = \<Prod>:remove1 a (aa # list) * a"
    proof (cases)
      assume aeq: "a = aa"
      hence
        "remove1 a (aa#list) = list"
        by simp
      hence
        "\<Prod>:(remove1 a (aa#list)) = \<Prod>:list"
        by simp
      moreover with aeq have
        "\<Prod>:(aa#list) = \<Prod>:list * a"
        by simp
      ultimately show
        "\<Prod>:(aa#list) = \<Prod>:remove1 a (aa # list) * a"
        by simp
    next
      assume naeq: "a \<noteq> aa"
      with aml have aml2: "a : set list" by simp
      from naeq have
        "remove1 a (aa#list) = aa#(remove1 a list)"
        by simp
      moreover hence
        "\<Prod>:(remove1 a (aa#list)) = aa * \<Prod>:(remove1 a list)"
        by simp
      moreover from aml2 plist have
        "\<Prod>:list = \<Prod>:(remove1 a list) * a"
        by simp
      ultimately show
        "\<Prod>:(aa#list) = \<Prod>:remove1 a (aa # list) * a"
        by simp
    qed
  qed
qed

text {* The final lemma of this section states that if all elements
are positive and non-zero then the product of these elements is also
positive and non-zero. *}

lemma el_gt0_imp_prod_gt0 [rule_format]:
  fixes xs::"real list"
  shows "\<forall>y. y : set xs \<longrightarrow> y > 0 \<Longrightarrow> \<Prod>:xs > 0"
proof (induct xs)
  case Nil show ?case by simp
next
  case (Cons a xs)
  have exp: "\<Prod>:(a#xs) = \<Prod>:xs * a" by simp
  with Cons have "a > 0" by simp
  with exp Cons show ?case by simp
qed

(* ============================================================================= *)
(* ============================================================================= *)
(* ============================================================================= *)

subsection {* Auxiliary lemma *}

text {* This section presents a proof of the auxiliary lemma required
for this theorem. *}

lemma prod_exp:
  fixes x::real
  shows "4*(x*y) = (x+y)^2 - (x-y)^2"
  by (simp add: power2_diff power2_sum)

lemma abs_less_imp_sq_less [rule_format]:
  fixes x::real and y::real and z::real and w::real
  assumes diff: "abs (x-y) < abs (z-w)"
  shows "(x-y)^2 < (z-w)^2"
proof cases
  assume "x=y"
  hence "abs (x-y) = 0" by simp
  moreover with diff have "abs(z-w) > 0" by simp
  hence "(z-w)^2 > 0" by simp
  ultimately show ?thesis by auto
next
  assume "x\<noteq>y"
  hence "abs (x - y) > 0" by simp
  with diff have "(abs (x-y))^2 < (abs (z-w))^2"
    by - (drule power_strict_mono [where a="abs (x-y)" and n=2 and b="abs (z-w)"], auto)
  thus ?thesis by simp
qed

text {* The required lemma (phrased slightly differently than in the
informal proof.) Here we show that for any two pairs of numbers with
equal sums the pair with the least difference has the greater
product. *}

lemma le_diff_imp_gt_prod [rule_format]:
  fixes x::real and y::real and z::real and w::real
  assumes diff: "abs (x-y) < abs (z-w)" and sum: "x+y = z+w"
  shows "x*y > z*w"
proof -
  from sum have "(x+y)^2 = (z+w)^2" by simp
  moreover from diff have "(x-y)^2 < (z-w)^2" by (rule abs_less_imp_sq_less)
  ultimately have "(x+y)^2 - (x-y)^2 > (z+w)^2 - (z-w)^2" by auto
  thus "x*y > z*w" by (simp only: prod_exp [symmetric])
qed

(* ============================================================================= *)
(* ============================================================================= *)
(* ============================================================================= *)

subsection {* Mean and GMean *}

text {* Now we introduce definitions and properties of arithmetic and
geometric means over collections of real numbers. *}

subsubsection {* Definitions *}

text {* {\em Arithmetic mean} *}

definition
  mean :: "(real list)\<Rightarrow>real" where
  "mean s = (\<Sum>:s / real (length s))"

text {* {\em Geometric mean} *}

definition
  gmean :: "(real list)\<Rightarrow>real" where
  "gmean s = root (length s) (\<Prod>:s)"

subsubsection {* Properties *}

text {* Here we present some trival properties of {\em mean} and {\em gmean}. *}

lemma list_mean_eq_iff:
  fixes one::"real list" and two::"real list"
  assumes
    se: "( \<Sum>:one = \<Sum>:two )" and
    le: "(length one = length two)"
  shows "(mean one = mean two)"
proof -
  from se le have
    "(\<Sum>:one / real (length one)) = (\<Sum>:two / real (length two))"
    by auto
  thus ?thesis unfolding mean_def .
qed

lemma list_gmean_gt_iff:
  fixes one::"real list" and two::"real list"
  assumes
    gz1: "\<Prod>:one > 0" and gz2: "\<Prod>:two > 0" and
    ne1: "one \<noteq> []" and ne2: "two \<noteq> []" and
    pe: "(\<Prod>:one > \<Prod>:two)" and
    le: "(length one = length two)"
  shows "(gmean one > gmean two)"
  unfolding gmean_def
  using le ne2 pe by simp

text {* This slightly more complicated lemma shows that for every non-empty collection with mean $M$, adding another element $a$ where $a=M$ results in a new list with the same mean $M$. *}

lemma list_mean_cons [rule_format]:
  fixes xs::"real list"
  shows "xs \<noteq> [] \<longrightarrow> mean ((mean xs)#xs) = mean xs"
proof
  assume lne: "xs \<noteq> []"
  obtain len where ld: "len = real (length xs)" by simp
  with lne have lgt0: "len > 0" by simp
  hence lnez: "len \<noteq> 0" by simp
  from lgt0 have l1nez: "len + 1 \<noteq> 0" by simp
  from ld have mean: "mean xs = \<Sum>:xs / len" unfolding mean_def by simp
  with ld real_of_nat_add real_of_one mean_def
  have "mean ((mean xs)#xs) = (\<Sum>:xs/len + \<Sum>:xs) / (1+len)"
    by simp
  also from list_sum_distrib_aux have
    "\<dots> = (1 + (1/len))*\<Sum>:xs / (1+len)" by simp
  also with lnez have
    "\<dots> = (len + 1)*\<Sum>:xs / (len * (1+len))"
    apply -
    apply (drule mult_divide_mult_cancel_left
      [symmetric, where c="len" and a="(1 + 1 / len) * \<Sum>:xs" and b="1+len"])
    apply (clarsimp simp:field_simps)
    done
  also from l1nez have "\<dots> = \<Sum>:xs / len"
    apply (subst mult.commute [where a="len"])
    apply (drule mult_divide_mult_cancel_left
      [where c="len+1" and a="\<Sum>:xs" and b="len"])
    by (simp add: ac_simps ac_simps)
  finally show "mean ((mean xs)#xs) = mean xs" by (simp add: mean)
qed

text {* For a non-empty collection with positive mean, if we add a positive number to the collection then the mean remains positive. *}

lemma mean_gt_0 [rule_format]:
  "xs\<noteq>[] \<and> 0 < x \<and> 0 < (mean xs) \<longrightarrow> 0 < (mean (x#xs))"
proof
  assume a: "xs \<noteq> [] \<and> 0 < x \<and> 0 < mean xs"
  hence xgt0: "0 < x" and mgt0: "0 < mean xs" by auto
  from a have lxsgt0: "length xs \<noteq> 0" by simp
  from mgt0 have xsgt0: "0 < \<Sum>:xs"
  proof -
    have "mean xs = \<Sum>:xs / real (length xs)" unfolding mean_def by simp
    hence "\<Sum>:xs = mean xs * real (length xs)" by simp
    moreover from lxsgt0 have "real (length xs) > 0" by simp
    moreover with calculation lxsgt0 mgt0 show ?thesis by auto
  qed
  with xgt0 have "\<Sum>:(x#xs) > 0" by simp
  thus "0 < (mean (x#xs))"
  proof -
    assume "0 < \<Sum>:(x#xs)"
    moreover have "real (length (x#xs)) > 0" by simp
    ultimately show ?thesis unfolding mean_def by simp
  qed
qed

(* ============================================================================= *)
(* ============================================================================= *)
(* ============================================================================= *)

subsection {* @{text "list_neq"}, @{text "list_eq"} *}

text {* This section presents a useful formalisation of the act of removing all the elements from a collection that are equal (not equal) to a particular value. We use this to extract all the non-mean elements from a collection as is required by the proof. *}

subsubsection {* Definitions *}

text {* @{text "list_neq"} and @{text "list_eq"} just extract elements from a collection that are not equal (or equal) to some value. *}

abbreviation
  list_neq :: "('a list) \<Rightarrow> 'a \<Rightarrow> ('a list)" where
  "list_neq xs el == filter (\<lambda>x. x\<noteq>el) xs"

abbreviation
  list_eq :: "('a list) \<Rightarrow> 'a \<Rightarrow> ('a list)" where
  "list_eq xs el == filter (\<lambda>x. x=el) xs"

subsubsection {* Properties *}

text {* This lemma just proves a required fact about @{text
  "list_neq"}, {\em remove1} and {\em length}. *}

lemma list_neq_remove1 [rule_format]:
  shows "a\<noteq>m \<and> a : set xs
  \<longrightarrow> length (list_neq (remove1 a xs) m) < length (list_neq xs m)"
  (is "?A xs \<longrightarrow> ?B xs" is "?P xs")
proof (induct xs)
  case Nil show ?case by simp
next
  case (Cons x xs)
  note `?P xs`
  {
    assume a: "?A (x#xs)"
    hence
      a_ne_m: "a\<noteq>m" and
      a_mem_x_xs: "a : set(x#xs)"
      by auto
    have b: "?B (x#xs)"
    proof cases
      assume "xs = []"
      with a_ne_m a_mem_x_xs show ?thesis
        apply (cases "x=a")
        by auto
    next
      assume xs_ne: "xs \<noteq> []"
      with a_ne_m a_mem_x_xs show ?thesis
      proof cases
        assume "a=x" with a_ne_m show ?thesis by simp
      next
        assume a_ne_x: "a\<noteq>x"
        with a_mem_x_xs have a_mem_xs: "a : set xs" by simp
        with xs_ne a_ne_m Cons have
          rel: "length (list_neq (remove1 a xs) m) < length (list_neq xs m)"
          by simp
        show ?thesis
        proof cases
          assume x_e_m: "x=m"
          with Cons xs_ne a_ne_m a_mem_xs show ?thesis by simp
        next
          assume x_ne_m: "x\<noteq>m"
          from a_ne_x have
            "remove1 a (x#xs) = x#(remove1 a xs)"
            by simp
          hence
            "length (list_neq (remove1 a (x#xs)) m) =
             length (list_neq (x#(remove1 a xs)) m)"
            by simp
          also with x_ne_m have
            "\<dots> = 1 + length (list_neq (remove1 a xs) m)"
            by simp
          finally have
            "length (list_neq (remove1 a (x#xs)) m) =
             1 + length (list_neq (remove1 a xs) m)"
            by simp
          moreover with x_ne_m a_ne_x have
            "length (list_neq (x#xs) m) =
             1 + length (list_neq xs m)"
            by simp
          moreover with rel show ?thesis by simp
        qed
      qed
    qed
  }
  thus "?P (x#xs)" by simp
qed

text {* We now prove some facts about @{text "list_eq"}, @{text "list_neq"}, length, sum and product. *}

lemma list_eq_sum [simp]:
  fixes xs::"real list"
  shows "\<Sum>:(list_eq xs m) = (m * (real (length (list_eq xs m))))"
apply (induct_tac xs)
apply simp
apply clarsimp
apply (subst real_of_nat_Suc)
apply (simp add:field_simps)
done

lemma list_eq_prod [simp]:
  fixes xs::"real list"
  shows "\<Prod>:(list_eq xs m) = (m ^ (length (list_eq xs m)))"
apply (induct_tac xs)
apply simp
apply clarsimp
done

lemma listsum_split:
  fixes xs::"real list"
  shows "\<Sum>:xs = (\<Sum>:(list_neq xs m) + \<Sum>:(list_eq xs m))"
apply (induct xs)
apply simp
apply clarsimp
done

lemma listprod_split:
  fixes xs::"real list"
  shows "\<Prod>:xs = (\<Prod>:(list_neq xs m) * \<Prod>:(list_eq xs m))"
apply (induct xs)
apply simp
apply clarsimp
done

lemma listsum_length_split:
  fixes xs::"real list"
  shows "length xs = length (list_neq xs m) + length (list_eq xs m)"
apply (induct xs)
apply simp+
done

(* ============================================================================= *)
(* ============================================================================= *)
(* ============================================================================= *)

subsection {* Element selection *}

text {* We now show that given after extracting all the elements not equal to the mean there exists one that is greater then (or less than) the mean. *}

lemma pick_one_gt:
  fixes xs::"real list" and m::real
  defines m: "m \<equiv> (mean xs)" and neq: "noteq \<equiv> list_neq xs m"
  assumes asum: "noteq\<noteq>[]"
  shows "\<exists>e. e : set noteq \<and> e > m"
proof (rule ccontr)
  let ?m = "(mean xs)"
  let ?neq = "list_neq xs ?m"
  let ?eq = "list_eq xs ?m"
  from list_eq_sum have "(\<Sum>:?eq) = ?m * (real (length ?eq))" by simp
  from asum have neq_ne: " ?neq \<noteq> []" unfolding m neq .
  assume not_el: "\<not>(\<exists>e. e : set noteq \<and> m < e)"
  hence not_el_exp: "\<not>(\<exists>e. e : set ?neq \<and> ?m < e)" unfolding m neq .
  hence "\<forall>e. \<not>(e : set ?neq) \<or> \<not>(e > ?m)" by simp
  hence "\<forall>e. e : set ?neq \<longrightarrow> \<not>(e > ?m)" by blast
  hence "\<forall>e. e : set ?neq \<longrightarrow> e \<le> ?m" by (simp add: linorder_not_less)
  hence "\<forall>e. e : set ?neq \<longrightarrow> e < ?m" by (simp add:order_le_less)
  with assms listsum_mono_lt have "(\<Sum>:?neq) < ?m * (real (length ?neq))" by blast
  hence
    "(\<Sum>:?neq) + (\<Sum>:?eq) < ?m * (real (length ?neq)) + (\<Sum>:?eq)" by simp
  also have
    "\<dots> = (?m * ((real (length ?neq) + (real (length ?eq)))))"
      by (simp add:field_simps)
  also have
    "\<dots> = (?m * (real (length xs)))"
      apply (subst real_of_nat_add [symmetric])
      by (simp add: listsum_length_split [symmetric])
  also have
    "\<dots> = \<Sum>:xs"
      by (simp add: list_sum_mean [symmetric])
  also from not_el calculation show False by (simp only: listsum_split [symmetric])
qed

lemma pick_one_lt:
  fixes xs::"real list" and m::real
  defines m: "m \<equiv> (mean xs)" and neq: "noteq \<equiv> list_neq xs m"
  assumes asum: "noteq\<noteq>[]"
  shows "\<exists>e. e : set noteq \<and> e < m"
proof (rule ccontr) -- "reductio ad absurdum"
  let ?m = "(mean xs)"
  let ?neq = "list_neq xs ?m"
  let ?eq = "list_eq xs ?m"
  from list_eq_sum have "(\<Sum>:?eq) = ?m * (real (length ?eq))" by simp
  from asum have neq_ne: " ?neq \<noteq> []" unfolding m neq .
  assume not_el: "\<not>(\<exists>e. e : set noteq \<and> m > e)"
  hence not_el_exp: "\<not>(\<exists>e. e : set ?neq \<and> ?m > e)" unfolding m neq .
  hence "\<forall>e. \<not>(e : set ?neq) \<or> \<not>(e < ?m)" by simp
  hence "\<forall>e. e : set ?neq \<longrightarrow> \<not>(e < ?m)" by blast
  hence "\<forall>e. e : set ?neq \<longrightarrow> e \<ge> ?m" by (simp add: linorder_not_less)
  hence "\<forall>e. e : set ?neq \<longrightarrow> e > ?m" by (auto simp: order_le_less)
  with assms listsum_mono_gt have "(\<Sum>:?neq) > ?m * (real (length ?neq))" by blast
  hence
    "(\<Sum>:?neq) + (\<Sum>:?eq) > ?m * (real (length ?neq)) + (\<Sum>:?eq)" by simp
  also have
    "(?m * (real (length ?neq)) + (\<Sum>:?eq)) =
     (?m * (real (length ?neq)) + (?m * (real (length ?eq))))"
    by simp
  also have
    "\<dots> = (?m * ((real (length ?neq) + (real (length ?eq)))))"
      by (simp add:field_simps)
  also have
    "\<dots> = (?m * (real (length xs)))"
      apply (subst real_of_nat_add [symmetric])
      by (simp add: listsum_length_split [symmetric])
  also have
    "\<dots> = \<Sum>:xs"
      by (simp add: list_sum_mean [symmetric])
  also from not_el calculation show False by (simp only: listsum_split [symmetric])
qed

(* =================================================================== *)
(* =================================================================== *)
(* =================================================================== *)
(* =================================================================== *)

subsection {* Abstract properties *}

text {* In order to maintain some comprehension of the following proofs we now introduce some properties of collections. *}

subsubsection {* Definitions *}

text {* {\em het}: The heterogeneity of a collection is the number of elements not equal to its mean. A heterogeneity of zero implies the all the elements in the collection are the same (i.e. homogeneous). *}

definition
  het :: "real list \<Rightarrow> nat" where
  "het l = length (list_neq l (mean l))"

lemma het_gt_0_imp_noteq_ne: "het l > 0 \<Longrightarrow> list_neq l (mean l) \<noteq> []"
  unfolding het_def by simp

lemma het_gt_0I: assumes a: "a \<in> set xs" and b: "b \<in> set xs" and neq: "a \<noteq> b"
  shows "het xs > 0"
proof (rule ccontr)
  assume "\<not> ?thesis"
  hence "het xs = 0" by auto
  from this[unfolded het_def] have "list_neq xs (mean xs) = []" by simp
  from arg_cong[OF this, of set] have mean: "\<And> x. x \<in> set xs \<Longrightarrow> x = mean xs" by auto
  from mean[OF a] mean[OF b] neq show False by auto
qed

text {* @{text "\<gamma>-eq"}: Two lists are $\gamma$-equivalent if and only
if they both have the same number of elements and the same arithmetic
means. *}

definition
  \<gamma>_eq :: "((real list)*(real list)) \<Rightarrow> bool" where
  "\<gamma>_eq a \<longleftrightarrow> mean (fst a) = mean (snd a) \<and> length (fst a) = length (snd a)"

text {* @{text "\<gamma>_eq"} is transitive and symmetric. *}

lemma \<gamma>_eq_sym: "\<gamma>_eq (a,b) = \<gamma>_eq (b,a)"
  unfolding \<gamma>_eq_def by auto

lemma \<gamma>_eq_trans:
  "\<gamma>_eq (x,y) \<Longrightarrow> \<gamma>_eq (y,z) \<Longrightarrow> \<gamma>_eq (x,z)"
  unfolding \<gamma>_eq_def by simp

text {* {\em pos}: A list is positive if all its elements are greater than 0. *}

definition
  pos :: "real list \<Rightarrow> bool" where
  "pos l \<longleftrightarrow> (if l=[] then False else \<forall>e. e : set l \<longrightarrow> e > 0)"

lemma pos_empty [simp]: "pos [] = False" unfolding pos_def by simp
lemma pos_single [simp]: "pos [x] = (x > 0)" unfolding pos_def by simp
lemma pos_imp_ne: "pos xs \<Longrightarrow> xs\<noteq>[]" unfolding pos_def by auto

lemma pos_cons [simp]:
  "xs \<noteq> [] \<longrightarrow> pos (x#xs) =
   (if (x>0) then pos xs else False)"
  (is "?P x xs" is "?A xs \<longrightarrow> ?S x xs")
proof (simp add: split_if, rule impI)
  assume xsne: "xs \<noteq> []"
  hence pxs_simp:
    "pos xs = (\<forall>e. e : set xs \<longrightarrow> e > 0)"
    unfolding pos_def by simp
  show
    "(0 < x \<longrightarrow> pos (x # xs) = pos xs) \<and>
     (\<not> 0 < x \<longrightarrow> \<not> pos (x # xs))"
  proof
    {
      assume xgt0: "0 < x"
      {
        assume pxs: "pos xs"
        with pxs_simp have "\<forall>e. e : set xs \<longrightarrow> e > 0" by simp
        with xgt0 have "\<forall>e. e : set (x#xs) \<longrightarrow> e > 0" by simp
        hence "pos (x#xs)" unfolding pos_def by simp
      }
      moreover
      {
        assume pxxs: "pos (x#xs)"
        hence "\<forall>e. e : set (x#xs) \<longrightarrow> e > 0" unfolding pos_def by simp
        hence "\<forall>e. e : set xs \<longrightarrow> e > 0" by simp
        with xsne have "pos xs" unfolding pos_def by simp
      }
      ultimately have "pos (x # xs) = pos xs"
        apply -
        apply (rule iffI)
        apply auto
        done
    }
    thus "0 < x \<longrightarrow> pos (x # xs) = pos xs" by simp
  next
    {
      assume xngt0: "\<not> (0<x)"
      {
        assume pxs: "pos xs"
        with pxs_simp have "\<forall>e. e : set xs \<longrightarrow> e > 0" by simp
        with xngt0 have "\<not> (\<forall>e. e : set (x#xs) \<longrightarrow> e > 0)" by auto
        hence "\<not> (pos (x#xs))" unfolding pos_def by simp
      }
      moreover
      {
        assume pxxs: "\<not>pos xs"
        with xsne have "\<not> (\<forall>e. e : set xs \<longrightarrow> e > 0)" unfolding pos_def by simp
        hence "\<not> (\<forall>e. e : set (x#xs) \<longrightarrow> e > 0)" by auto
        hence "\<not> (pos (x#xs))" unfolding pos_def by simp
      }
      ultimately have "\<not> pos (x#xs)" by auto
    }
    thus "\<not> 0 < x \<longrightarrow> \<not> pos (x # xs)" by simp
  qed
qed

subsubsection {* Properties *}

text {* Here we prove some non-trivial properties of the abstract properties. *}

text {* Two lemmas regarding {\em pos}. The first states the removing
an element from a positive collection (of more than 1 element) results
in a positive collection. The second asserts that the mean of a
positive collection is positive. *}

lemma pos_imp_rmv_pos:
  assumes "(remove1 a xs)\<noteq>[]" "pos xs" shows "pos (remove1 a xs)"
proof -
  from assms have pl: "pos xs" and rmvne: "(remove1 a xs)\<noteq>[]" by auto
  from pl have "xs \<noteq> []" by (rule pos_imp_ne)
  with pl pos_def have "\<forall>x. x : set xs \<longrightarrow> x > 0" by simp
  hence "\<forall>x. x : set (remove1 a xs) \<longrightarrow> x > 0"
    using set_remove1_subset[of _ xs] by(blast)
  with rmvne show "pos (remove1 a xs)" unfolding pos_def by simp
qed

lemma pos_mean: "pos xs \<Longrightarrow> mean xs > 0"
proof (induct xs)
  case Nil thus ?case by(simp add: pos_def)
next
  case (Cons x xs)
  show ?case
  proof cases
    assume xse: "xs = []"
    hence "pos (x#xs) = (x > 0)" by simp
    with Cons(2) have "x>0" by(simp)
    with xse have "0 < mean (x#xs)" by(auto simp:mean_def)
    thus ?thesis by simp
  next
    assume xsne: "xs \<noteq> []"
    show ?thesis
    proof cases
      assume pxs: "pos xs"
      with Cons(1) have z_le_mxs: "0 < mean xs" by(simp)
      {
        assume ass: "x > 0"
        with ass z_le_mxs xsne have "0 < mean (x#xs)"
          apply -
          apply (rule mean_gt_0)
          by simp
      }
      moreover
      {
        from xsne pxs have "0 < x"
        proof cases
          assume "0 < x" thus ?thesis by simp
        next
          assume "\<not>(0 < x)"
          with xsne pos_cons have "pos (x#xs) = False" by simp
          with Cons(2) show ?thesis by simp
        qed
      }
      ultimately have "0 < mean (x#xs)" by simp
      thus ?thesis by simp
    next
      assume npxs: "\<not>pos xs"
      with xsne pos_cons have "pos (x#xs) = False"  by simp
      thus ?thesis using Cons(2) by simp
    qed
  qed
qed

text {* We now show that homogeneity of a non-empty collection $x$
implies that its product is equal to @{text "(mean x)^(length x)"}. *}

lemma listprod_het0:
  shows "x\<noteq>[] \<and> het x = 0 \<Longrightarrow> \<Prod>:x = (mean x) ^ (length x)"
proof -
  assume "x\<noteq>[] \<and> het x = 0"
  hence xne: "x\<noteq>[]" and hetx: "het x = 0" by auto
  from hetx have lz: "length (list_neq x (mean x)) = 0" unfolding het_def .
  hence "\<Prod>:(list_neq x (mean x)) = 1" by simp
  with listprod_split have "\<Prod>:x = \<Prod>:(list_eq x (mean x))"
    apply -
    apply (drule meta_spec [of _ x])
    apply (drule meta_spec [of _ "mean x"])
    by simp
  also with list_eq_prod have
    "\<dots> = (mean x) ^ (length (list_eq x (mean x)))" by simp
  also with calculation lz listsum_length_split have
    "\<Prod>:x = (mean x) ^ (length x)"
    apply -
    apply (drule meta_spec [of _ x])
    apply (drule meta_spec [of _ "mean x"])
    by simp
  thus ?thesis by simp
qed

text {* Furthermore we present an important result - that a
homogeneous collection has equal geometric and arithmetic means. *}

lemma het_base:
  shows "pos x \<and> het x = 0 \<Longrightarrow> gmean x = mean x"
proof -
  assume ass: "pos x \<and> het x = 0"
  hence
    xne: "x\<noteq>[]" and
    hetx: "het x = 0" and
    posx: "pos x"
    by auto
  from posx pos_mean have mxgt0: "mean x > 0" by simp
  from xne have lxgt0: "length x > 0" by simp
  with ass listprod_het0 have
    "root (length x) (\<Prod>:x) = root (length x) ((mean x)^(length x))"
    by simp
  also from lxgt0 mxgt0 real_root_power_cancel have "\<dots> = mean x" by auto
  finally show "gmean x = mean x" unfolding gmean_def .
qed

(* =================================================================== *)
(* =================================================================== *)
(* =================================================================== *)
(* =================================================================== *)

subsection {* Existence of a new collection *}

text {* We now present the largest and most important proof in this
document. Given any positive and non-homogeneous collection of real
numbers there exists a new collection that is $\gamma$-equivalent,
positive, has a strictly lower heterogeneity and a greater geometric
mean. *}

lemma new_list_gt_gmean:
  fixes xs :: "real list" and m :: real
  and neq and eq
  defines
    m: "m \<equiv> mean xs" and
    neq: "noteq \<equiv> list_neq xs m" and
    eq: "eq \<equiv> list_eq xs m"
  assumes pos_xs: "pos xs" and het_gt_0: "het xs > 0"
  shows
  "\<exists>xs'. gmean xs' > gmean xs \<and> \<gamma>_eq (xs',xs) \<and>
          het xs' < het xs \<and> pos xs'"
proof -
  from pos_xs pos_imp_ne have
    pos_els: "\<forall>y. y : set xs \<longrightarrow> y > 0" by (unfold pos_def, simp)
  with el_gt0_imp_prod_gt0 have pos_asm: "\<Prod>:xs > 0" by simp
  from neq het_gt_0 het_gt_0_imp_noteq_ne m have
    neqne: "noteq \<noteq> []" by simp

  txt {* Pick two elements from xs, one greater than m, one less than m. *}
  from assms pick_one_gt neqne obtain \<alpha> where
    \<alpha>_def: "\<alpha> : set noteq \<and> \<alpha> > m" unfolding neq m by auto
  from assms pick_one_lt neqne obtain \<beta> where
    \<beta>_def: "\<beta> : set noteq \<and> \<beta> < m" unfolding neq m by auto
  from \<alpha>_def \<beta>_def have \<alpha>_gt: "\<alpha> > m" and \<beta>_lt: "\<beta> < m" by auto
  from \<alpha>_def \<beta>_def have el_neq: "\<beta> \<noteq> \<alpha>" by simp
  from neqne neq have xsne: "xs \<noteq> []" by auto

  from \<beta>_def have \<beta>_mem: "\<beta> : set xs" by (auto simp: neq)
  from \<alpha>_def have \<alpha>_mem: "\<alpha> : set xs" by (auto simp: neq)

  from pos_xs pos_def xsne \<alpha>_mem \<beta>_mem \<alpha>_def \<beta>_def have
    \<alpha>_pos: "\<alpha> > 0" and \<beta>_pos: "\<beta> > 0" by auto

  -- "remove these elements from xs, and insert two new elements"
  obtain left_over where lo: "left_over = (remove1 \<beta> (remove1 \<alpha> xs))" by simp
  obtain b where bdef: "m + b = \<alpha> + \<beta>"
    by (drule meta_spec [of _ "\<alpha> + \<beta> - m"], simp)

  from m pos_xs pos_def pos_mean have m_pos: "m > 0" by simp
  with bdef \<alpha>_pos \<beta>_pos \<alpha>_gt \<beta>_lt have b_pos: "b > 0" by simp

  obtain new_list where nl: "new_list = m#b#(left_over)" by auto

  from el_neq \<beta>_mem \<alpha>_mem have "\<beta> : set xs \<and> \<alpha> : set xs \<and> \<beta> \<noteq> \<alpha>" by simp
  hence "\<alpha> : set (remove1 \<beta> xs) \<and> \<beta> : set(remove1 \<alpha> xs)" by (auto simp add: in_set_remove1)
  moreover hence "(remove1 \<alpha> xs) \<noteq> [] \<and> (remove1 \<beta> xs) \<noteq> []" by (auto)
  ultimately have
    mem : "\<alpha> : set(remove1 \<beta> xs) \<and> \<beta> : set(remove1 \<alpha> xs) \<and>
          (remove1 \<alpha> xs) \<noteq> [] \<and> (remove1 \<beta> xs) \<noteq> []" by simp
  -- "prove that new list is positive"
  from nl have nl_pos: "pos new_list"
  proof cases
    assume "left_over = []"
    with nl b_pos m_pos show ?thesis by simp
  next
    assume lone: "left_over \<noteq> []"
    from mem pos_imp_rmv_pos pos_xs have "pos (remove1 \<alpha> xs)" by simp
    with lo lone pos_imp_rmv_pos have "pos left_over" by simp
    with lone mem nl m_pos b_pos show ?thesis by simp
  qed

  -- "now show that the new list has the same mean as the old list"
  with mem nl lo bdef \<alpha>_mem \<beta>_mem
    have "\<Sum>:new_list = \<Sum>:xs"
      apply clarsimp
      apply (subst listsum_rmv1)
        apply simp
      apply (subst listsum_rmv1)
        apply simp
      apply clarsimp
    done
  moreover from lo nl \<beta>_mem \<alpha>_mem mem have
    leq: "length new_list = length xs"
    apply -
    apply (erule conjE)+
    apply (clarsimp)
    apply (subst length_remove1, simp)
    apply (simp add: length_remove1)
    apply (auto dest!:length_pos_if_in_set)
    done
  ultimately have eq_mean: "mean new_list = mean xs" by (rule list_mean_eq_iff)

  -- "finally show that the new list has a greater gmean than the old list"
  have gt_gmean: "gmean new_list > gmean xs"
  proof -
    from bdef \<alpha>_gt \<beta>_lt have "abs (m - b) < abs (\<alpha> - \<beta>)" by arith
    moreover from bdef have "m+b = \<alpha>+\<beta>" .
    ultimately have mb_gt_gt: "m*b > \<alpha>*\<beta>" by (rule le_diff_imp_gt_prod)
    moreover from nl have
      "\<Prod>:new_list = \<Prod>:left_over * (m*b)" by auto
    moreover
    from lo \<alpha>_mem \<beta>_mem mem remove1_retains_prod have
      xsprod: "\<Prod>:xs = \<Prod>:left_over * (\<alpha>*\<beta>)" by auto
    moreover from xsne have
      "xs \<noteq> []" .
    moreover from nl have
      nlne: "new_list \<noteq> []" by simp
    moreover from pos_asm lo have
      "\<Prod>:left_over > 0"
      proof -
        from pos_asm have "\<Prod>:xs > 0" .
        moreover
        from xsprod have "\<Prod>:xs = \<Prod>:left_over * (\<alpha>*\<beta>)" .
        ultimately have "\<Prod>:left_over * (\<alpha>*\<beta>) > 0" by simp
        moreover
        from pos_els \<alpha>_mem \<beta>_mem have "\<alpha> > 0" and "\<beta> > 0" by auto
        hence "\<alpha>*\<beta> > 0" by simp
        ultimately show "\<Prod>:left_over > 0"
          apply -
          apply (rule zero_less_mult_pos2 [where a="(\<alpha> * \<beta>)"])
          by auto
      qed
    ultimately have "\<Prod>:new_list > \<Prod>:xs"
      by simp
    moreover with pos_asm nl have "\<Prod>:new_list > 0" by auto
    moreover from calculation pos_asm xsne nlne leq list_gmean_gt_iff
    show "gmean new_list > gmean xs" by simp
  qed

  -- "auxiliary info"
  from \<beta>_lt have \<beta>_ne_m: "\<beta> \<noteq> m" by simp
  from mem have
    \<beta>_mem_rmv_\<alpha>: "\<beta> : set (remove1 \<alpha> xs)" and rmv_\<alpha>_ne: "(remove1 \<alpha> xs) \<noteq> []" by auto

  from \<alpha>_def have \<alpha>_ne_m: "\<alpha> \<noteq> m" by simp

  -- "now show that new list is more homogeneous"
  have lt_het: "het new_list < het xs"
  proof cases
    assume bm: "b=m"
    with het_def have
      "het new_list = length (list_neq new_list (mean new_list))"
      by simp
    also with m nl eq_mean have
      "\<dots> = length (list_neq (m#b#(left_over)) m)"
      by simp
    also with bm have
      "\<dots> = length (list_neq left_over m)"
      by simp
    also with lo \<beta>_def \<alpha>_def have
      "\<dots> = length (list_neq (remove1 \<beta> (remove1 \<alpha> xs)) m)"
      by simp
    also from \<beta>_ne_m \<beta>_mem_rmv_\<alpha> rmv_\<alpha>_ne have
      "\<dots> < length (list_neq (remove1 \<alpha> xs) m)"
      apply -
      apply (rule list_neq_remove1)
      by simp
    also from \<alpha>_mem \<alpha>_ne_m xsne have
      "\<dots> < length (list_neq xs m)"
      apply -
      apply (rule list_neq_remove1)
      by simp
    also with m het_def have "\<dots> = het xs" by simp
    finally show "het new_list < het xs" .
  next
    assume bnm: "b\<noteq>m"
    with het_def have
      "het new_list = length (list_neq new_list (mean new_list))"
      by simp
    also with m nl eq_mean have
      "\<dots> = length (list_neq (m#b#(left_over)) m)"
      by simp
    also with bnm have
      "\<dots> = length (b#(list_neq left_over m))"
      by simp
    also have
      "\<dots> = 1 + length (list_neq left_over m)"
      by simp
    also with lo \<beta>_def \<alpha>_def have
      "\<dots> = 1 + length (list_neq (remove1 \<beta> (remove1 \<alpha> xs)) m)"
      by simp
    also from \<beta>_ne_m \<beta>_mem_rmv_\<alpha> rmv_\<alpha>_ne have
      "\<dots> < 1 + length (list_neq (remove1 \<alpha> xs) m)"
      apply -
      apply (simp only: nat_add_left_cancel_less)
      apply (rule list_neq_remove1)
      by simp
    finally have
      "het new_list \<le> length (list_neq (remove1 \<alpha> xs) m)"
      by simp
    also from \<alpha>_mem \<alpha>_ne_m xsne have "\<dots> < length (list_neq xs m)"
      apply -
      apply (rule list_neq_remove1)
      by simp
    also with m het_def have "\<dots> = het xs" by simp
    finally show "het new_list < het xs" .
  qed

      -- "thus thesis by existence of newlist"
  from \<gamma>_eq_def lt_het gt_gmean eq_mean leq nl_pos show ?thesis by auto
qed

text {* Furthermore we show that for all non-homogeneous positive
collections there exists another collection that is
$\gamma$-equivalent, positive, has a greater geometric mean {\em and}
is homogeneous. *}

lemma existence_of_het0 [rule_format]:
  shows "\<forall>x. p = het x \<and> p > 0 \<and> pos x \<longrightarrow>
  (\<exists>y. gmean y > gmean x \<and> \<gamma>_eq (x,y) \<and> het y = 0 \<and> pos y)"
  (is "?Q p" is "\<forall>x. (?A x p \<longrightarrow> ?S x)")
proof (induct p rule: nat_less_induct)
  fix n
  assume ind: "\<forall>m<n. ?Q m"
  {
    fix x
    assume ass: "?A x n"
    hence "het x > 0" and "pos x" by auto
    with new_list_gt_gmean have
      "\<exists>y. gmean y > gmean x \<and> \<gamma>_eq (x,y) \<and> het y < het x \<and> pos y"
      apply -
      apply (drule meta_spec [of _ x])
      apply (drule meta_mp)
        apply assumption
      apply (drule meta_mp)
        apply assumption
      apply (subst(asm) \<gamma>_eq_sym)
      apply simp
      done
    then obtain \<beta> where
      \<beta>_def: "gmean \<beta> > gmean x \<and> \<gamma>_eq (x,\<beta>) \<and> het \<beta> < het x \<and> pos \<beta>" ..
    then obtain b where bdef: "b = het \<beta>" by simp
    with ass \<beta>_def have "b < n" by auto
    with ind have "?Q b" by simp
    with \<beta>_def have
      ind2: "b = het \<beta> \<and> 0 < b \<and> pos \<beta> \<longrightarrow>
      (\<exists>y. gmean \<beta> < gmean y \<and> \<gamma>_eq (\<beta>, y) \<and> het y = 0 \<and> pos y)" by simp
    {
      assume "\<not>(0<b)"
      hence "b=0" by simp
      with bdef have "het \<beta> = 0" by simp
      with \<beta>_def have "?S x" by auto
    }
    moreover
    {
      assume "0 < b"
      with bdef ind2 \<beta>_def have "?S \<beta>" by simp
      then obtain \<gamma> where
        "gmean \<beta> < gmean \<gamma> \<and> \<gamma>_eq (\<beta>, \<gamma>) \<and> het \<gamma> = 0 \<and> pos \<gamma>" ..
      with \<beta>_def have "gmean x < gmean \<gamma> \<and> \<gamma>_eq (x,\<gamma>) \<and> het \<gamma> = 0 \<and> pos \<gamma>"
        apply clarsimp
        apply (rule \<gamma>_eq_trans)
        by auto
      hence "?S x" by auto
    }
    ultimately have "?S x" by auto
  }
  thus "?Q n" by simp
qed

subsection {* Cauchy's Mean Theorem *}

text {* We now present the final proof of the theorem. For any
positive collection we show that its geometric mean is less than or
equal to its arithmetic mean. *}

theorem CauchysMeanTheorem:
  fixes z::"real list"
  assumes "pos z"
  shows "gmean z \<le> mean z"
proof -
  from `pos z` have zne: "z\<noteq>[]" by (rule pos_imp_ne)
  show "gmean z \<le> mean z"
  proof cases
    assume "het z = 0"
    with `pos z` zne het_base have "gmean z = mean z" by simp
    thus ?thesis by simp
  next
    assume "het z \<noteq> 0"
    hence "het z > 0" by simp
    moreover obtain k where "k = het z" by simp
    moreover with calculation `pos z` existence_of_het0 have
      "\<exists>y. gmean y > gmean z \<and> \<gamma>_eq (z,y) \<and> het y = 0 \<and> pos y" by auto
    then obtain \<alpha> where
      "gmean \<alpha> > gmean z \<and> \<gamma>_eq (z,\<alpha>) \<and> het \<alpha> = 0 \<and> pos \<alpha>" ..
    with het_base \<gamma>_eq_def pos_imp_ne have
      "mean z = mean \<alpha>" and
      "gmean \<alpha> > gmean z" and
      "gmean \<alpha> = mean \<alpha>" by auto
    hence "gmean z < mean z" by simp
    thus ?thesis by simp
  qed
qed

text {* In the equality version we prove that the geometric mean
  is identical to the arithmetic mean iff the collection is
  homogeneous. *}
theorem CauchysMeanTheorem_Eq:
  fixes z::"real list"
  assumes "pos z"
  shows "gmean z = mean z \<longleftrightarrow> het z = 0"
proof
  assume "het z = 0"
  with het_base[of z] `pos z` show "gmean z = mean z" by auto
next
  assume eq: "gmean z = mean z"
  show "het z = 0"
  proof (rule ccontr)
    assume "het z \<noteq> 0"
    hence "het z > 0" by auto
    moreover obtain k where "k = het z" by simp
    moreover with calculation `pos z` existence_of_het0 have
      "\<exists>y. gmean y > gmean z \<and> \<gamma>_eq (z,y) \<and> het y = 0 \<and> pos y" by auto
    then obtain \<alpha> where
      "gmean \<alpha> > gmean z \<and> \<gamma>_eq (z,\<alpha>) \<and> het \<alpha> = 0 \<and> pos \<alpha>" ..
    with het_base \<gamma>_eq_def pos_imp_ne have
      "mean z = mean \<alpha>" and
      "gmean \<alpha> > gmean z" and
      "gmean \<alpha> = mean \<alpha>" by auto
    hence "gmean z < mean z" by simp
    thus False using eq by auto
  qed
qed

corollary CauchysMeanTheorem_Less:
  fixes z::"real list"
  assumes "pos z" and "het z > 0"
  shows "gmean z < mean z"
  using
    CauchysMeanTheorem[OF `pos z`]
    CauchysMeanTheorem_Eq[OF `pos z`]
    `het z > 0`
    by auto

end


(*  Title:      Sort.thy
    Author:     Danijela Petrovi\'c, Facylty of Mathematics, University of Belgrade *)

header {* Verification of Imperative Heap Sort *}

theory HeapImperative
imports Heap
begin

primrec left :: "'a Tree \<Rightarrow> 'a Tree" where
  "left (T v l r) = l"

abbreviation left_val :: "'a Tree \<Rightarrow> 'a" where
  "left_val t \<equiv> val (left t)"

primrec right :: "'a Tree \<Rightarrow> 'a Tree" where
  "right (T v l r) = r"

abbreviation right_val :: "'a Tree \<Rightarrow> 'a" where
  "right_val t \<equiv> val (right t)"

abbreviation set_val :: "'a Tree \<Rightarrow> 'a \<Rightarrow> 'a Tree" where
  "set_val t x \<equiv> T x (left t) (right t)"

text{* The first step is to implement function {\em siftDown}. If some node
does not satisfy heap property, this function moves it down the heap
until it does. For a node is checked weather it satisfies heap property or not. If it
does nothing is changed. If it does not, value of the root node
becomes a value of the larger child and the value of that child
becomes the value of the root node. This is the reason this function
is called {\tt siftDown} -- value of the node is places down in the
heap. Now, the problem is that the child node may not satisfy the heap
property and that is the reason why function {\tt siftDown} is
recursively applied. *}

fun siftDown :: "'a::linorder Tree \<Rightarrow> 'a Tree" where
   "siftDown E = E"
|  "siftDown (T v E E) = T v E E"
|  "siftDown (T v l E) =
        (if v \<ge> val l then T v l E else T (val l) (siftDown (set_val l v)) E)"
|  "siftDown (T v E r) =
        (if v \<ge> val r then T v E r else T (val r) E (siftDown (set_val r v)))"
|  "siftDown (T v l r) =
        (if val l \<ge> val r then
            if v \<ge> val l then T v l r else T (val l) (siftDown (set_val l v)) r
        else
            if v \<ge> val r then T v l r else T (val r) l (siftDown (set_val r v)))"

lemma siftDown_Node:
  assumes "t = T v l r"
  shows "\<exists> l' v' r'. siftDown t = T v' l' r' \<and> v' \<ge> v"
using assms
apply(induct t rule:siftDown.induct)
by auto

lemma siftDown_in_tree:
  assumes "t \<noteq> E"
  shows "in_tree (val (siftDown t)) t"
using assms
apply(induct t rule:siftDown.induct)
by auto

lemma siftDown_in_tree_set:
  shows "in_tree v t \<longleftrightarrow> in_tree v (siftDown t)"
proof
  assume "in_tree v t"
  thus "in_tree v (siftDown t)"
    apply (induct t rule:siftDown.induct)
    by auto
next
  assume " in_tree v (siftDown t)"
  thus "in_tree v t"
  proof (induct t rule:siftDown.induct)
    case 1
    thus ?case
      by auto
  next
    case (2 v1)
    thus ?case
      by auto
  next
    case (3 v2 v1 l1 r1)
    show ?case
    proof(cases "v2 \<ge> v1")
      case True
      thus ?thesis
        using 3
        by auto
    next
      case False
      show ?thesis
      proof(cases "v1 = v")
        case True
        thus ?thesis
          using 3 False
          by auto
      next
        case False
        hence "in_tree v (siftDown (set_val (T v1 l1 r1) v2))"
          using `\<not> v2 \<ge> v1` 3(2)
          by auto
        hence "in_tree v (T v2 l1 r1)"
          using 3(1) `\<not> v2 \<ge> v1`
          by auto
        thus ?thesis
        proof(cases "v2 = v")
          case True
          thus ?thesis
            by auto
        next
          case False
          hence "in_tree v (T v1 l1 r1)"
            using `in_tree v (T v2 l1 r1)`
            by auto
          thus ?thesis
            by auto
        qed
      qed
    qed
  next
    case (4 v2 v1 l1 r1)
    show ?case
    proof(cases "v2 \<ge> v1")
      case True
      thus ?thesis
        using 4
        by auto
    next
      case False
      show ?thesis
      proof(cases "v1 = v")
        case True
        thus ?thesis
          using 4 False
          by auto
      next
        case False
        hence "in_tree v (siftDown (set_val (T v1 l1 r1) v2))"
          using `\<not> v2 \<ge> v1` 4(2)
          by auto
        hence "in_tree v (T v2 l1 r1)"
          using 4(1) `\<not> v2 \<ge> v1`
          by auto
        thus ?thesis
        proof(cases "v2 = v")
          case True
          thus ?thesis
            by auto
        next
          case False
          hence "in_tree v (T v1 l1 r1)"
            using `in_tree v (T v2 l1 r1)`
            by auto
          thus ?thesis
            by auto
        qed
      qed
    qed
  next
    case ("5_1" v' v1 l1 r1 v2 l2 r2)
    show ?case
    proof(cases "v = v' \<or> v= v1 \<or> v = v2")
      case True
      thus ?thesis
        by auto
    next
      case False
      show ?thesis
      proof(cases "v1 \<ge> v2")
        case True
        show ?thesis
        proof(cases "v' \<ge> v1")
          case True
          thus ?thesis
            using `v1 \<ge> v2` "5_1"
            by auto
        next
          case False
          thus ?thesis
          proof(cases "in_tree v (T v2 l2 r2)")
            case True
            thus ?thesis
              by auto
          next
            case False
            hence "in_tree v (siftDown (set_val (T v1 l1 r1) v'))"
              using "5_1"(3) `\<not> in_tree v (T v2 l2 r2)` `v1 \<ge> v2` `\<not> v' \<ge> v1`
              using ` \<not> (v = v' \<or> v = v1 \<or> v = v2)`
              by auto
            hence "in_tree v (T v' l1 r1)"
              using "5_1"(1) `v1 \<ge> v2` `\<not> v' \<ge> v1`
              by auto
            hence "in_tree v (T v1 l1 r1)"
              using  `\<not> (v = v' \<or> v = v1 \<or> v = v2)`
              by auto
            thus ?thesis
              by auto
          qed
        qed
      next
        case False
        show ?thesis
        proof(cases "v' \<ge> v2")
          case True
          thus ?thesis
            using `\<not> v1 \<ge> v2` "5_1"
            by auto
        next
          case False
          thus ?thesis
          proof(cases "in_tree v (T v1 l1 r1)")
            case True
            thus ?thesis
              by auto
          next
            case False
            hence "in_tree v (siftDown (set_val (T v2 l2 r2) v'))"
              using "5_1"(3) `\<not> in_tree v (T v1 l1 r1)` `\<not> v1 \<ge> v2` `\<not> v' \<ge> v2`
              using ` \<not> (v = v' \<or> v = v1 \<or> v = v2)`
              by auto
            hence "in_tree v (T v' l2 r2)"
              using "5_1"(2) `\<not> v1 \<ge> v2` `\<not> v' \<ge> v2`
              by auto
            hence "in_tree v (T v2 l2 r2)"
              using  `\<not> (v = v' \<or> v = v1 \<or> v = v2)`
              by auto
            thus ?thesis
              by auto
          qed
        qed
      qed
    qed
  next
    case ("5_2" v' v1 l1 r1 v2 l2 r2)
    show ?case
    proof(cases "v = v' \<or> v= v1 \<or> v = v2")
      case True
      thus ?thesis
        by auto
    next
      case False
      show ?thesis
      proof(cases "v1 \<ge> v2")
        case True
        show ?thesis
        proof(cases "v' \<ge> v1")
          case True
          thus ?thesis
            using `v1 \<ge> v2` "5_2"
            by auto
        next
          case False
          thus ?thesis
          proof(cases "in_tree v (T v2 l2 r2)")
            case True
            thus ?thesis
              by auto
          next
            case False
            hence "in_tree v (siftDown (set_val (T v1 l1 r1) v'))"
              using "5_2"(3) `\<not> in_tree v (T v2 l2 r2)` `v1 \<ge> v2` `\<not> v' \<ge> v1`
              using ` \<not> (v = v' \<or> v = v1 \<or> v = v2)`
              by auto
            hence "in_tree v (T v' l1 r1)"
              using "5_2"(1) `v1 \<ge> v2` `\<not> v' \<ge> v1`
              by auto
            hence "in_tree v (T v1 l1 r1)"
              using  `\<not> (v = v' \<or> v = v1 \<or> v = v2)`
              by auto
            thus ?thesis
              by auto
          qed
        qed
      next
        case False
        show ?thesis
        proof(cases "v' \<ge> v2")
          case True
          thus ?thesis
            using `\<not> v1 \<ge> v2` "5_2"
            by auto
        next
          case False
          thus ?thesis
          proof(cases "in_tree v (T v1 l1 r1)")
            case True
            thus ?thesis
              by auto
          next
            case False
            hence "in_tree v (siftDown (set_val (T v2 l2 r2) v'))"
              using "5_2"(3) `\<not> in_tree v (T v1 l1 r1)` `\<not> v1 \<ge> v2` `\<not> v' \<ge> v2`
              using ` \<not> (v = v' \<or> v = v1 \<or> v = v2)`
              by auto
            hence "in_tree v (T v' l2 r2)"
              using "5_2"(2) `\<not> v1 \<ge> v2` `\<not> v' \<ge> v2`
              by auto
            hence "in_tree v (T v2 l2 r2)"
              using  `\<not> (v = v' \<or> v = v1 \<or> v = v2)`
              by auto
            thus ?thesis
              by auto
          qed
        qed
      qed
    qed
  qed
qed

lemma siftDown_heap_is_heap:
  assumes "is_heap l" "is_heap r" "t = T v l r"
  shows "is_heap (siftDown t)"
using assms
proof (induct t arbitrary: v l r  rule:siftDown.induct)
  case 1
  thus ?case
    by simp
next
  case (2 v')
  show ?case
    by simp
next
  case (3 v2 v1 l1 r1)
  show ?case
  proof (cases "v2 \<ge> v1")
    case True
    thus ?thesis
      using 3(2) 3(4)
      by auto
  next
    case False
    show ?thesis
    proof-
      let ?t = "siftDown (T v2 l1 r1)"
      obtain l' v' r' where *: "?t = T v' l' r'" "v' \<ge> v2"
        using siftDown_Node[of "T v2 l1 r1" v2 l1 r1]
        by auto
      have "l = T v1 l1 r1"
        using 3(4)
        by auto
      hence "is_heap l1" "is_heap r1"
        using 3(2)
        apply (induct l rule:is_heap.induct)
        by auto
      hence "is_heap ?t"
        using 3(1)[of l1 r1 v2] False 3
        by auto
      show ?thesis
      proof (cases "v' = v2")
        case True
        thus ?thesis
          using False `is_heap ?t` *
          by auto
      next
        case False
        have "in_tree v' ?t"
          using *
          using siftDown_in_tree[of ?t]
          by simp
        hence "in_tree v' (T v2 l1 r1)"
          using siftDown_in_tree_set[symmetric, of v' "T v2 l1 r1"]
          by auto
        hence "in_tree v' (T v1 l1 r1)"
          using False
          by simp
        hence "v1 \<ge> v'"
          using 3
          using is_heap_max[of v' "T v1 l1 r1"]
          by auto
        thus ?thesis
          using `is_heap ?t` * `\<not> v2 \<ge> v1`
          by auto
      qed
    qed
  qed
next
  case (4 v2 v1 l1 r1)
  show ?case
  proof(cases "v2 \<ge> v1")
    case True
    thus ?thesis
      using 4(2-4)
      by auto
  next
    case False
    let ?t = "siftDown (T v2 l1 r1)"
    obtain v' l' r' where *: "?t = T v' l' r'" "v' \<ge> v2"
      using siftDown_Node[of "T v2 l1 r1" v2 l1 r1]
      by auto
    have "r = T v1 l1 r1"
      using 4(4)
      by auto
    hence "is_heap l1" "is_heap r1"
      using 4(3)
      apply (induct r rule:is_heap.induct)
      by auto
    hence "is_heap ?t"
      using False  4(1)[of l1 r1 v2]
      by auto
    show ?thesis
    proof(cases "v' = v2")
      case True
      thus ?thesis
        using * `is_heap ?t` False
        by auto
    next
      case False
      have "in_tree v' ?t"
        using *
        using siftDown_in_tree[of ?t]
        by auto
      hence "in_tree v' (T v2 l1 r1)"
        using * siftDown_in_tree_set[of v' "T v2 l1 r1"]
        by auto
      hence "in_tree v' (T v1 l1 r1)"
        using False
        by auto
      hence "v1 \<ge> v'"
        using is_heap_max[of v' "T v1 l1 r1"] 4
        by auto
      thus ?thesis
        using `is_heap ?t` False *
        by auto
    qed
  qed
next
  case ("5_1" v1 v2 l2 r2 v3 l3 r3)
  show ?case
  proof(cases "v2 \<ge> v3")
    case True
    show ?thesis
    proof(cases "v1 \<ge> v2")
      case True
      thus ?thesis
        using `v2 \<ge> v3` "5_1"
        by auto
    next
      case False
      let ?t = "siftDown (T v1 l2 r2)"
      obtain l' v' r' where *: "?t = T v' l' r'" "v' \<ge> v1"
        using siftDown_Node
        by blast
      have "is_heap l2" "is_heap r2"
        using "5_1"(3, 5)
        apply(induct l rule:is_heap.induct)
        by auto
      hence "is_heap ?t"
        using "5_1"(1)[of l2 r2 v1] `v2 \<ge> v3` False
        by auto
      have "v2 \<ge> v'"
      proof(cases "v' = v1")
        case True
        thus ?thesis
          using False
          by auto
      next
        case False
        have "in_tree v' ?t"
          using * siftDown_in_tree
          by auto
        hence "in_tree v' (T v1 l2 r2)"
          using siftDown_in_tree_set[of v' "T v1 l2 r2"]
          by auto
        hence "in_tree v' (T v2 l2 r2)"
          using False
          by auto
        thus ?thesis
          using is_heap_max[of v' "T v2 l2 r2"] "5_1"
          by auto
      qed
      thus ?thesis
        using `is_heap ?t` `v2 \<ge> v3` * False "5_1"
        by auto
    qed
  next
    case False
    show ?thesis
    proof(cases "v1 \<ge> v3")
      case True
      thus ?thesis
        using `\<not> v2 \<ge> v3` "5_1"
        by auto
    next
      case False
      let ?t = "siftDown (T v1 l3 r3)"
      obtain l' v' r' where *: "?t = T v' l' r'" "v' \<ge> v1"
        using siftDown_Node
        by blast
      have "is_heap l3" "is_heap r3"
        using "5_1"(4, 5)
        apply(induct r rule:is_heap.induct)
        by auto
      hence "is_heap ?t"
        using "5_1"(2)[of l3 r3 v1] `\<not> v2 \<ge> v3` False
        by auto
      have "v3 \<ge> v'"
      proof(cases "v' = v1")
        case True
        thus ?thesis
          using False
          by auto
      next
        case False
        have "in_tree v' ?t"
          using * siftDown_in_tree
          by auto
        hence "in_tree v' (T v1 l3 r3)"
          using siftDown_in_tree_set[of v' "T v1 l3 r3"]
          by auto
        hence "in_tree v' (T v3 l3 r3)"
          using False
          by auto
        thus ?thesis
          using is_heap_max[of v' "T v3 l3 r3"] "5_1"
          by auto
      qed
      thus ?thesis
        using `is_heap ?t` `\<not> v2 \<ge> v3` * False "5_1"
        by auto
    qed
  qed
next
  case ("5_2" v1 v2 l2 r2 v3 l3 r3)
  show ?case
  proof(cases "v2 \<ge> v3")
    case True
    show ?thesis
    proof(cases "v1 \<ge> v2")
      case True
      thus ?thesis
        using `v2 \<ge> v3` "5_2"
        by auto
    next
      case False
      let ?t = "siftDown (T v1 l2 r2)"
      obtain l' v' r' where *: "?t = T v' l' r'" "v1 \<le> v'"
        using siftDown_Node
        by blast
      have "is_heap l2" "is_heap r2"
        using "5_2"(3, 5)
        apply(induct l rule:is_heap.induct)
        by auto
      hence "is_heap ?t"
        using "5_2"(1)[of l2 r2 v1] `v2 \<ge> v3` False
        by auto
      have "v2 \<ge> v'"
      proof(cases "v' = v1")
        case True
        thus ?thesis
          using False
          by auto
      next
        case False
        have "in_tree v' ?t"
          using * siftDown_in_tree
          by auto
        hence "in_tree v' (T v1 l2 r2)"
          using siftDown_in_tree_set[of v' "T v1 l2 r2"]
          by auto
        hence "in_tree v' (T v2 l2 r2)"
          using False
          by auto
        thus ?thesis
          using is_heap_max[of v' "T v2 l2 r2"] "5_2"
          by auto
      qed
      thus ?thesis
        using `is_heap ?t` `v2 \<ge> v3` * False "5_2"
        by auto
    qed
  next
    case False
    show ?thesis
    proof(cases "v1 \<ge> v3")
      case True
      thus ?thesis
        using `\<not> v2 \<ge> v3` "5_2"
        by auto
    next
      case False
      let ?t = "siftDown (T v1 l3 r3)"
      obtain l' v' r' where *: "?t = T v' l' r'" "v' \<ge> v1"
        using siftDown_Node
        by blast
      have "is_heap l3" "is_heap r3"
        using "5_2"(4, 5)
        apply(induct r rule:is_heap.induct)
        by auto
      hence "is_heap ?t"
        using "5_2"(2)[of l3 r3 v1] `\<not> v2 \<ge> v3` False
        by auto
      have "v3 \<ge> v'"
      proof(cases "v' = v1")
        case True
        thus ?thesis
          using False
          by auto
      next
        case False
        have "in_tree v' ?t"
          using * siftDown_in_tree
          by auto
        hence "in_tree v' (T v1 l3 r3)"
          using siftDown_in_tree_set[of v' "T v1 l3 r3"]
          by auto
        hence "in_tree v' (T v3 l3 r3)"
          using False
          by auto
        thus ?thesis
          using is_heap_max[of v' "T v3 l3 r3"] "5_2"
          by auto
      qed
      thus ?thesis
        using `is_heap ?t` `\<not> v2 \<ge> v3` * False "5_2"
        by auto
    qed
  qed
qed

text{* Definition of the function {\em heapify} which
makes a heap from any given binary tree. *}

primrec heapify where
   "heapify E = E"
|  "heapify (T v l r) = siftDown (T v (heapify l) (heapify r))"

lemma heapify_heap_is_heap:
  "is_heap (heapify t)"
proof(induct t)
  case E
  thus ?case
    by auto
next
  case (T v l r)
  thus ?case
    using siftDown_heap_is_heap[of "heapify l" "heapify r" "T v (heapify l) (heapify r)" v]
    by auto
qed

text{* Definition of {\em removeLeaf} function.  Function returns two values. The first one
is the value of romoved leaf element. The second returned value is tree without that leaf. *}

fun removeLeaf:: "'a::linorder Tree \<Rightarrow> 'a \<times> 'a Tree" where
  "removeLeaf (T v E E) = (v, E)"
| "removeLeaf (T v l E) = (fst (removeLeaf l), T v (snd (removeLeaf l)) E)"
| "removeLeaf (T v E r) = (fst (removeLeaf r), T v E (snd (removeLeaf r)))"
| "removeLeaf (T v l r) = (fst (removeLeaf l), T v (snd (removeLeaf l)) r)"

text{* Function {\em of\_list\_tree} makes a binary tree from any given
list. *}

primrec of_list_tree:: "'a::linorder list \<Rightarrow> 'a Tree" where
  "of_list_tree [] = E"
| "of_list_tree (v # tail) = T v (of_list_tree tail) E"

text{* By applying {\em heapify} binary tree is transformed into
heap.  *}

definition hs_of_list where
  "hs_of_list l = heapify (of_list_tree l)"

text{* Definition of function {\em hs\_remove\_max}. As it is already well
established, finding maximum is not a problem, since it is in the root
element of the heap. The root element is replaced with leaf of the
heap and that leaf is erased from its previous position. However, now
the new root element may not satisfy heap property and that is the
reason to apply function {\em siftDown}. *}

definition hs_remove_max :: "'a::linorder Tree \<Rightarrow> 'a \<times> 'a Tree" where
  "hs_remove_max t \<equiv>
     (let v' = fst (removeLeaf t);
          t' = snd (removeLeaf t) in
     (if t' = E then (val t, E)
      else (val t, siftDown (set_val t' v'))))"

definition hs_is_empty where
[simp]: "hs_is_empty t \<longleftrightarrow>  t = E"

lemma siftDown_multiset:
  "multiset (siftDown t) = multiset t"
proof(induct t rule:siftDown.induct)
  case 1
  thus ?case
    by simp
next
  case (2 v)
  thus ?case
    by simp
next
  case (3 v1 v l r)
  thus ?case
  proof(cases "v \<le> v1")
    case True
    thus ?thesis
      by auto
  next
    case False
    hence "multiset (siftDown (T v1 (T v l r) E)) =
           multiset l + {#v1#} + multiset r + {#v#}"
      using 3
      by auto
    moreover
    have "multiset (T v1 (T v l r) E) =
          multiset l + {#v#} + multiset r + {#v1#}"
      by auto
    moreover
    have "multiset l + {#v1#} + multiset r + {#v#} =
          multiset l + {#v#} + multiset r + {#v1#}"
      by (metis union_commute union_lcomm)
    ultimately
    show ?thesis
      by auto
  qed
next
  case (4 v1 v l r)
  thus ?case
  proof(cases "v \<le> v1")
    case True
    thus ?thesis
      by auto
  next
    case False
    have "multiset (set_val (T v l r) v1) =
          multiset l + {#v1#} + multiset r"
      by auto
    hence "multiset (siftDown (T v1 E (T v l r))) =
           {#v#} +  multiset (set_val (T v l r) v1)"
      using 4 False
      by auto
    hence "multiset (siftDown (T v1 E (T v l r))) =
           {#v#} + multiset l + {#v1#} + multiset r"
      using `multiset (set_val (T v l r) v1) =
             multiset l + {#v1#} + multiset r`
      by (metis union_commute union_lcomm)
    moreover
    have "multiset (T v1 E (T v l r)) =
          {#v1#} + multiset l + {#v#} + multiset r"
      by (metis calculation comm_monoid_add_class.add.left_neutral
          multiset.simps(1) multiset.simps(2) union_commute union_lcomm)
    moreover
    have "{#v#} + multiset l + {#v1#} + multiset r =
          {#v1#} + multiset l + {#v#} + multiset r"
      by (metis union_commute union_lcomm)
    ultimately
    show ?thesis
      by auto
  qed
next
  case ("5_1" v v1 l1 r1 v2 l2 r2)
  thus ?case
  proof(cases "v1 \<ge> v2")
    case True
    thus ?thesis
    proof(cases "v \<ge> v1")
      case True
      thus ?thesis
        using `v1 \<ge> v2`
        by auto
    next
      case False
      hence "multiset (siftDown (T v (T v1 l1 r1) (T v2 l2 r2))) =
             multiset l1 + {#v#} + multiset r1 + {#v1#} +
             multiset (T v2 l2 r2)"
        using `v1 \<ge> v2` "5_1"(1)
        by auto
      moreover
      have "multiset (T v (T v1 l1 r1) (T v2 l2 r2)) =
              multiset l1 + {#v1#} + multiset r1 + {#v#} +
              multiset(T v2 l2 r2)"
        by auto
      moreover
      have "multiset l1 + {#v1#} + multiset r1 + {#v#} +
            multiset(T v2 l2 r2) =
                multiset l1 + {#v#} + multiset r1 + {#v1#} +
                multiset (T v2 l2 r2)"
        by (metis union_commute union_lcomm)
      ultimately
      show ?thesis
        by auto
    qed
  next
    case False
    show ?thesis
    proof(cases "v \<ge> v2")
      case True
      thus ?thesis
        using False
        by auto
    next
      case False
      hence "multiset (siftDown (T v (T v1 l1 r1) (T v2 l2 r2))) =
             multiset (T v1 l1 r1) + {#v2#} +
             multiset l2 + {#v#} + multiset r2"
        using `\<not> v1 \<ge> v2` "5_1"(2)
        by (simp add: ac_simps)
      moreover
      have
        "multiset (T v (T v1 l1 r1) (T v2 l2 r2)) =
         multiset (T v1 l1 r1) + {#v#} + multiset l2 +
         {#v2#} + multiset r2"
        by (metis (hide_lams, no_types) multiset.simps(2)
            union_assoc union_commute union_lcomm)
      moreover
      have
        "multiset (T v1 l1 r1) + {#v#} + multiset l2 + {#v2#} +
         multiset r2 =
            multiset (T v1 l1 r1) + {#v2#} + multiset l2 +
            {#v#} + multiset r2"
        by (metis union_commute union_lcomm)
      ultimately
      show ?thesis
        by auto
    qed
  qed
next
  case ("5_2" v v1 l1 r1 v2 l2 r2)
  thus ?case
  proof(cases "v1 \<ge> v2")
    case True
    thus ?thesis
    proof(cases "v \<ge> v1")
      case True
      thus ?thesis
        using `v1 \<ge> v2`
        by auto
    next
      case False
      hence "multiset (siftDown (T v (T v1 l1 r1) (T v2 l2 r2))) =
               multiset l1 + {#v#} + multiset r1 + {#v1#} +
               multiset (T v2 l2 r2)"
        using `v1 \<ge> v2` "5_2"(1)
        by auto
      moreover
      have "multiset (T v (T v1 l1 r1) (T v2 l2 r2)) =
              multiset l1 + {#v1#} + multiset r1 +
              {#v#} + multiset(T v2 l2 r2)"
        by auto
      moreover
      have "multiset l1 + {#v1#} + multiset r1 + {#v#} +
            multiset(T v2 l2 r2) =
              multiset l1 + {#v#} + multiset r1 + {#v1#} +
              multiset (T v2 l2 r2)"
        by (metis union_commute union_lcomm)
      ultimately
      show ?thesis
        by auto
    qed
  next
    case False
    show ?thesis
    proof(cases "v \<ge> v2")
      case True
      thus ?thesis
        using False
        by auto
    next
      case False
      hence "multiset (siftDown (T v (T v1 l1 r1) (T v2 l2 r2))) =
               multiset (T v1 l1 r1) + {#v2#} + multiset l2 + {#v#} +
               multiset r2"
        using `\<not> v1 \<ge> v2` "5_2"(2)
        by (simp add: ac_simps)
      moreover
      have "multiset (T v (T v1 l1 r1) (T v2 l2 r2)) =
              multiset (T v1 l1 r1) + {#v#} + multiset l2 + {#v2#} +
              multiset r2"
        by (metis (hide_lams, no_types) multiset.simps(2)
            union_assoc union_commute union_lcomm)
      moreover
      have "multiset (T v1 l1 r1) + {#v#} + multiset l2 + {#v2#} +
            multiset r2 =
              multiset (T v1 l1 r1) + {#v2#} + multiset l2 + {#v#} +
              multiset r2"
        by (metis union_commute union_lcomm)
      ultimately
      show ?thesis
        by auto
    qed
  qed
qed

lemma multiset_of_list_tree:
 "multiset (of_list_tree l) = multiset_of l"
proof(induct l)
  case Nil
  thus ?case
    by auto
next
  case (Cons v tail)
  hence "multiset (of_list_tree (v # tail)) = multiset_of tail + {#v#}"
    by auto
  also have "... = multiset_of (v # tail)"
    by auto
  finally show "multiset (of_list_tree (v # tail)) = multiset_of (v # tail)"
    by auto
qed

lemma multiset_heapify:
  "multiset (heapify t) = multiset t"
proof(induct t)
  case E
  thus ?case
    by auto
next
  case (T v l r)
  hence "multiset (heapify (T v l r)) = multiset l + {#v#} + multiset r"
    using siftDown_multiset[of "T v (heapify l) (heapify r)"]
    by auto
  thus ?case
    by auto
qed

lemma multiset_heapify_of_list_tree:
  "multiset (heapify (of_list_tree l)) = multiset_of l"
using multiset_heapify[of "of_list_tree l"]
using multiset_of_list_tree[of l]
by auto

lemma removeLeaf_val_val:
  assumes "snd (removeLeaf t) \<noteq> E" "t \<noteq> E"
  shows "val t = val (snd (removeLeaf t))"
using assms
apply (induct t rule:removeLeaf.induct)
by auto

lemma removeLeaf_heap_is_heap:
  assumes "is_heap t" "t \<noteq> E"
  shows "is_heap (snd (removeLeaf t))"
using assms
proof(induct t rule:removeLeaf.induct)
  case (1 v)
  thus ?case
    by auto
next
  case (2 v v1 l1 r1)
  have "is_heap (T v1 l1 r1)"
    using 2(3)
    by auto
  hence "is_heap (snd (removeLeaf (T v1 l1 r1)))"
    using 2(1)
    by auto
  let ?t = "(snd (removeLeaf (T v1 l1 r1)))"
  show ?case
  proof(cases "?t = E")
    case True
    thus ?thesis
      by auto
  next
    case False
    have "v \<ge> v1"
      using 2(3)
      by auto
    hence "v \<ge> val ?t"
      using False removeLeaf_val_val[of "T v1 l1 r1"]
      by auto
    hence "is_heap (T v (snd (removeLeaf (T v1 l1 r1))) E)"
      using `is_heap (snd (removeLeaf (T v1 l1 r1)))`
      by (metis Tree.exhaust is_heap.simps(2) is_heap.simps(4))
    thus ?thesis
      using 2
      by auto
  qed
next
  case (3 v v1 l1 r1)
  have "is_heap (T v1 l1 r1)"
    using 3(3)
    by auto
  hence "is_heap (snd (removeLeaf (T v1 l1 r1)))"
    using 3(1)
    by auto
  let ?t = "(snd (removeLeaf (T v1 l1 r1)))"
  show ?case
  proof(cases "?t = E")
    case True
    thus ?thesis
      by auto
  next
    case False
    have "v \<ge> v1"
      using 3(3)
      by auto
    hence "v \<ge> val ?t"
      using False removeLeaf_val_val[of "T v1 l1 r1"]
      by auto
    hence "is_heap (T v E (snd (removeLeaf (T v1 l1 r1))))"
      using `is_heap (snd (removeLeaf (T v1 l1 r1)))`
      by (metis False Tree.exhaust is_heap.simps(3))
    thus ?thesis
      using 3
      by auto
  qed
next
  case ("4_1" v v1 l1 r1 v2 l2 r2)
  have "is_heap (T v1 l1 r1)" "is_heap (T v2 l2 r2)" "v \<ge> v1" "v \<ge> v2"
    using "4_1"(3)
    by (simp add:is_heap.simps(5))+
  hence "is_heap (snd (removeLeaf (T v1 l1 r1)))"
    using "4_1"(1)
    by auto
  let ?t = "(snd (removeLeaf (T v1 l1 r1)))"
  show ?case
  proof(cases "?t = E")
    case True
    thus ?thesis
      using `is_heap (T v2 l2 r2)` `v \<ge> v2`
      by auto
  next
    case False
    then obtain v1' l1' r1' where "?t = T v1' l1' r1'"
      by (metis Tree.exhaust)
    hence "is_heap (T v1' l1' r1')"
      using `is_heap (snd (removeLeaf (T v1 l1 r1)))`
      by auto
    have "v \<ge> v1"
      using "4_1"(3)
      by auto
    hence "v \<ge> val ?t"
      using False removeLeaf_val_val[of "T v1 l1 r1"]
      by auto
    hence "v \<ge> v1'"
      using `?t = T v1' l1' r1'`
      by auto
    hence "is_heap (T v (T v1' l1' r1') (T v2 l2 r2))"
      using `is_heap (T v1' l1' r1')`
      using `is_heap (T v2 l2 r2)` `v \<ge> v2`
      by (simp add: is_heap.simps(5))
    thus ?thesis
      using "4_1" `?t = T v1' l1' r1'`
      by auto
  qed
next
  case ("4_2" v v1 l1 r1 v2 l2 r2)
  have "is_heap (T v1 l1 r1)" "is_heap (T v2 l2 r2)" "v \<ge> v1" "v \<ge> v2"
    using "4_2"(3)
    by (simp add:is_heap.simps(5))+
  hence "is_heap (snd (removeLeaf (T v1 l1 r1)))"
    using "4_2"(1)
    by auto
  let ?t = "(snd (removeLeaf (T v1 l1 r1)))"
  show ?case
  proof(cases "?t = E")
    case True
    thus ?thesis
      using `is_heap (T v2 l2 r2)` `v \<ge> v2`
      by auto
  next
    case False
    then obtain v1' l1' r1' where "?t = T v1' l1' r1'"
      by (metis Tree.exhaust)
    hence "is_heap (T v1' l1' r1')"
      using `is_heap (snd (removeLeaf (T v1 l1 r1)))`
      by auto
    have "v \<ge> v1"
      using "4_2"(3)
      by auto
    hence "v \<ge> val ?t"
      using False removeLeaf_val_val[of "T v1 l1 r1"]
      by auto
    hence "v \<ge> v1'"
      using `?t = T v1' l1' r1'`
      by auto
    hence "is_heap (T v (T v1' l1' r1') (T v2 l2 r2))"
      using `is_heap (T v1' l1' r1')`
      using `is_heap (T v2 l2 r2)` `v \<ge> v2`
      by (simp add: is_heap.simps(5))
    thus ?thesis
      using "4_2" `?t = T v1' l1' r1'`
      by auto
  qed
next
  case 5
  thus ?case
    by auto
qed

text{* Difined functions satisfy conditions of locale {\em Collection} and thus represent
       interpretation of this locale. *}

interpretation HS: Collection "E" hs_is_empty hs_of_list multiset
proof
  fix t
  assume "hs_is_empty t"
  thus "t = E"
    by auto
next
  show "hs_is_empty E"
    by auto
next
  show "multiset E = {#}"
    by auto
next
  fix l
  show "multiset (hs_of_list l) = multiset_of l"
    unfolding hs_of_list_def
    using multiset_heapify_of_list_tree[of l]
    by auto
qed

lemma removeLeaf_multiset:
  assumes "(v', t') = removeLeaf t" "t \<noteq> E"
  shows "{#v'#} + multiset t' = multiset t"
using assms
proof(induct t arbitrary: v' t' rule:removeLeaf.induct)
  case 1
  thus ?case
    by auto
next
  case (2 v v1 l1 r1)
  have "t' = T v (snd (removeLeaf (T v1 l1 r1))) E"
    using 2(3)
    by auto
  have "v' = fst (removeLeaf (T v1 l1 r1))"
    using 2(3)
    by auto
  hence "{#v'#} + multiset t' =
           {#fst (removeLeaf (T v1 l1 r1))#} +
           multiset (snd (removeLeaf (T v1 l1 r1))) +
           {#v#}"
    using `t' = T v (snd (removeLeaf (T v1 l1 r1))) E`
    by (simp add: ac_simps)
  have "{#fst (removeLeaf (T v1 l1 r1))#} +
        multiset (snd (removeLeaf (T v1 l1 r1))) =
          multiset (T v1 l1 r1)"
    using 2(1)
    by auto
  hence "{#v'#} + multiset t' = multiset (T v1 l1 r1) + {#v#}"
    using `{#v'#} + multiset t' =
           {#fst (removeLeaf (T v1 l1 r1))#} +
           multiset (snd (removeLeaf (T v1 l1 r1))) + {#v#}`
    by auto
  thus ?case
    by auto
next
  case (3 v v1 l1 r1)
  have "t' = T v E (snd (removeLeaf (T v1 l1 r1)))"
    using 3(3)
    by auto
  have "v' = fst (removeLeaf (T v1 l1 r1))"
    using 3(3)
    by auto
  hence "{#v'#} + multiset t' =
          {#fst (removeLeaf (T v1 l1 r1))#} +
          multiset (snd (removeLeaf (T v1 l1 r1))) +
          {#v#}"
    using `t' = T v E (snd (removeLeaf (T v1 l1 r1)))`
    by (simp add: ac_simps)
  have "{#fst (removeLeaf (T v1 l1 r1))#} +
        multiset (snd (removeLeaf (T v1 l1 r1))) =
          multiset (T v1 l1 r1)"
    using 3(1)
    by auto
  hence "{#v'#} + multiset t' = multiset (T v1 l1 r1) + {#v#}"
    using `{#v'#} + multiset t' =
           {#fst (removeLeaf (T v1 l1 r1))#} +
           multiset (snd (removeLeaf (T v1 l1 r1))) + {#v#}`
    by auto
  thus ?case
    by (metis comm_monoid_add_class.add.right_neutral
        multiset.simps(1) multiset.simps(2) union_commute)
next
  case ("4_1" v v1 l1 r1 v2 l2 r2)
  have "t' = T v (snd (removeLeaf (T v1 l1 r1))) (T v2 l2 r2)"
    using "4_1"(3)
    by auto
  have "v' = fst (removeLeaf (T v1 l1 r1))"
    using "4_1"(3)
    by auto
  hence "{#v'#} + multiset t' =
         {#fst (removeLeaf (T v1 l1 r1))#} +
         multiset (snd (removeLeaf (T v1 l1 r1))) +
         {#v#} + multiset (T v2 l2 r2)"
    using `t' = T v (snd (removeLeaf (T v1 l1 r1))) (T v2 l2 r2)`
    by (metis multiset.simps(2) union_assoc)
  have "{#fst (removeLeaf (T v1 l1 r1))#} +
        multiset (snd (removeLeaf (T v1 l1 r1))) =
          multiset (T v1 l1 r1)"
    using "4_1"(1)
    by auto
  hence "{#v'#} + multiset t' =
           multiset (T v1 l1 r1) + {#v#} + multiset (T v2 l2 r2)"
    using `{#v'#} + multiset t' =
           {#fst (removeLeaf (T v1 l1 r1))#} +
           multiset (snd (removeLeaf (T v1 l1 r1))) +
           {#v#} + multiset (T v2 l2 r2)`
    by auto
  thus ?case
    by auto
next
  case ("4_2" v v1 l1 r1 v2 l2 r2)
  have "t' = T v (snd (removeLeaf (T v1 l1 r1))) (T v2 l2 r2)"
    using "4_2"(3)
    by auto
  have "v' = fst (removeLeaf (T v1 l1 r1))"
    using "4_2"(3)
    by auto
  hence "{#v'#} + multiset t' =
         {#fst (removeLeaf (T v1 l1 r1))#} +
         multiset (snd (removeLeaf (T v1 l1 r1))) +
         {#v#} + multiset (T v2 l2 r2)"
    using `t' = T v (snd (removeLeaf (T v1 l1 r1))) (T v2 l2 r2)`
    by (metis multiset.simps(2) union_assoc)
  have "{#fst (removeLeaf (T v1 l1 r1))#} +
        multiset (snd (removeLeaf (T v1 l1 r1))) =
          multiset (T v1 l1 r1)"
    using "4_2"(1)
    by auto
  hence "{#v'#} + multiset t' =
         multiset (T v1 l1 r1) + {#v#} + multiset (T v2 l2 r2)"
    using `{#v'#} + multiset t' =
           {#fst (removeLeaf (T v1 l1 r1))#} +
           multiset (snd (removeLeaf (T v1 l1 r1))) +
           {#v#} + multiset (T v2 l2 r2)`
    by auto
  thus ?case
    by auto
next
  case 5
  thus ?case
    by auto
qed

lemma set_val_multiset:
  assumes "t \<noteq> E"
  shows "multiset (set_val t v') +  {#val t#} = {#v'#} + multiset t"
proof-
  obtain v l r where "t = T v l r"
    using assms
    by (metis Tree.exhaust)
  hence "multiset (set_val t v') + {#val t#} =
         multiset l + {#v'#} + multiset r + {#v#}"
    by auto
  have "{#v'#} + multiset t =
        {#v'#} + multiset l + {#v#} + multiset r"
    using `t = T v l r`
    by (metis multiset.simps(2) union_assoc)
  have "{#v'#} + multiset l + {#v#} + multiset r =
        multiset l + {#v'#} + multiset r + {#v#}"
    by (metis union_commute union_lcomm)
  thus ?thesis
    using `multiset (set_val t v') + {#val t#} =
           multiset l + {#v'#} + multiset r + {#v#}`
    using `{#v'#} + multiset t =
           {#v'#} + multiset l + {#v#} + multiset r`
    by auto
qed

lemma hs_remove_max_multiset:
  assumes "(m, t') = hs_remove_max t" "t \<noteq> E"
  shows "{#m#} + multiset t' = multiset t"
proof-
  let ?v1 = "fst (removeLeaf t)"
  let ?t1 = "snd (removeLeaf t)"
  show ?thesis
  proof(cases "?t1 = E")
    case True
    hence "{#m#} + multiset t' = {#m#}"
      using assms
      unfolding hs_remove_max_def
      by auto
    have "?v1 = val t"
      using True assms(2)
      apply (induct t rule:removeLeaf.induct)
      by auto
    hence "?v1 = m"
      using assms(1) True
      unfolding hs_remove_max_def
      by auto
    hence "multiset t = {#m#}"
      using removeLeaf_multiset[of ?v1 ?t1 t] True assms(2)
      by (metis empty_neutral(2) multiset.simps(1) pair_collapse)
    thus ?thesis
      using `{#m#} + multiset t' = {#m#}`
      by auto
  next
    case False
    hence "t' = siftDown (set_val ?t1 ?v1)"
      using assms(1)
      by (auto simp add: hs_remove_max_def) (metis prod.inject)
    hence "multiset t' + {#val ?t1#} = multiset t"
      using siftDown_multiset[of "set_val ?t1 ?v1"]
      using set_val_multiset[of ?t1 ?v1] False
      using removeLeaf_multiset[of ?v1 ?t1 t] assms(2)
      by auto
    have "val ?t1 = val t"
      using False assms(2)
      apply (induct t rule:removeLeaf.induct)
      by auto
    have "val t = m"
      using assms(1) False
      using `t' = siftDown (set_val ?t1 ?v1)`
      unfolding hs_remove_max_def
      by (metis (full_types) fst_conv removeLeaf.simps(1))
    hence "val ?t1 = m"
      using `val ?t1 = val t`
      by auto
    hence "multiset t' + {#m#} = multiset t"
      using `multiset t' + {#val ?t1#} = multiset t`
      by metis
    thus ?thesis
      by (metis union_commute)
  qed
qed

text{* Difined functions satisfy conditions of locale {\em Heap} and thus represent
       interpretation of this locale. *}

interpretation Heap "E" hs_is_empty hs_of_list multiset id hs_remove_max
proof
  fix t
  show "multiset t = multiset (id t)"
    by auto
next
  fix t
  show " is_heap (id (hs_of_list t))"
    unfolding hs_of_list_def
    using heapify_heap_is_heap[of "of_list_tree t"]
    by auto
next
  fix t
  show "(id t = E) = hs_is_empty t"
    by auto
next
  fix t m t'
  assume "\<not> hs_is_empty t" "(m, t') = hs_remove_max t"
  thus "multiset t' + {#m#} = multiset t"
    using hs_remove_max_multiset[of m t' t]
    by (auto, metis union_commute)
next
  fix t v' t'
  assume "\<not> hs_is_empty t" "is_heap (id t)" "(v', t') = hs_remove_max t"
  let ?v1 = "fst (removeLeaf t)"
  let ?t1 = "snd (removeLeaf t)"
  have "is_heap ?t1"
    using `\<not> hs_is_empty t` `is_heap (id t)`
    using removeLeaf_heap_is_heap[of t]
    by auto
  show "is_heap (id t')"
  proof(cases "?t1 = E")
    case True
    hence "t' = E"
      using `(v', t') = hs_remove_max t`
      unfolding hs_remove_max_def
      by auto
    thus ?thesis
      by auto
  next
    case False
    then obtain v_t1 l_t1 r_t1 where "?t1 = T v_t1 l_t1 r_t1"
      by (metis Tree.exhaust)
    hence "is_heap l_t1" "is_heap r_t1"
      using `is_heap ?t1`
      by (auto, metis (full_types) Tree.exhaust
         is_heap.simps(1) is_heap.simps(4) is_heap.simps(5))
         (metis (full_types) Tree.exhaust
          is_heap.simps(1) is_heap.simps(3) is_heap.simps(5))
    have "set_val ?t1 ?v1 = T ?v1 l_t1 r_t1"
      using `?t1 = T v_t1 l_t1 r_t1`
      by auto
    hence "is_heap (siftDown (set_val ?t1 ?v1))"
      using `is_heap l_t1` `is_heap r_t1`
      using siftDown_heap_is_heap[of l_t1 r_t1 "set_val ?t1 ?v1" ?v1]
      by auto
    have "t' = siftDown (set_val ?t1 ?v1)"
      using `(v', t') = hs_remove_max t` False
      by (auto simp add: hs_remove_max_def) (metis prod.inject)
    thus ?thesis
      using `is_heap (siftDown (set_val ?t1 ?v1))`
      by auto
  qed
next
  fix t m t'
  let ?t1 = "snd (removeLeaf t)"
  assume "\<not> hs_is_empty t" "(m, t') = hs_remove_max t"
  hence "m = val t"
    apply (simp add: hs_remove_max_def)
    apply (cases "?t1 = E")
    by (auto, metis prod.inject)
  thus "m = val (id t)"
    by auto
qed

end