(*  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>
*)

chapter \<open>Cauchy's Mean Theorem\<close>

theory CauchysMeanTheorem
imports Complex_Main
begin

section \<open>Abstract\<close>

text \<open>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.
\<close>

section \<open>Formal proof\<close>

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

subsection \<open>Collection sum and product\<close>

text \<open>The finite collections of numbers will be modelled as
lists. We then define sum and product operations over these lists.\<close>

subsubsection \<open>Sum and product definitions\<close>

notation (input) sum_list ("\<Sum>:_" [999] 998)

notation (input) prod_list ("\<Prod>:_" [999] 998)

subsubsection \<open>Properties of sum and product\<close>

text \<open>We now present some useful properties of sum and product over
collections.\<close>

text \<open>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)$.\<close>

lemma sum_list_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)
      then have "\<Sum>:(y#ys) < m*(real(length ys + 1))"
        by (simp add: algebra_simps)
      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 sum_list_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 \<open>proof omitted\<close>
(*<*)
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)
      then have "\<Sum>:(y#ys) > m*(real(length ys + 1))"
        by (simp add: algebra_simps)
      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 \<open>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$.\<close>

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

text \<open>A handy addition and division distribution law over collection
sums.\<close>

lemma list_sum_distrib_aux:
  shows "(\<Sum>:xs/(n :: 'a :: archimedean_field) + \<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 and xs::"'a :: comm_ring_1 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 \<open>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.\<close>

lemma el_gt0_imp_prod_gt0 [rule_format]:
  fixes xs::"'a :: archimedean_field 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 \<open>Auxiliary lemma\<close>

text \<open>This section presents a proof of the auxiliary lemma required
for this theorem.\<close>

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 \<open>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.\<close>

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 \<open>Mean and GMean\<close>

text \<open>Now we introduce definitions and properties of arithmetic and
geometric means over collections of real numbers.\<close>

subsubsection \<open>Definitions\<close>

text \<open>{\em Arithmetic mean}\<close>

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

text \<open>{\em Geometric mean}\<close>

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

subsubsection \<open>Properties\<close>

text \<open>Here we present some trival properties of {\em mean} and {\em gmean}.\<close>

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 \<open>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$.\<close>

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 of_nat_add of_int_1 mean_def
  have "mean ((mean xs)#xs) = (\<Sum>:xs/len + \<Sum>:xs) / (1+len)"
    by simp
  also from list_sum_distrib_aux[of xs] 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 \<open>For a non-empty collection with positive mean, if we add a positive number to the collection then the mean remains positive.\<close>

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 \<open>\<open>list_neq\<close>, \<open>list_eq\<close>\<close>

text \<open>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.\<close>

subsubsection \<open>Definitions\<close>

text \<open>\<open>list_neq\<close> and \<open>list_eq\<close> just extract elements from a collection that are not equal (or equal) to some value.\<close>

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 \<open>Properties\<close>

text \<open>This lemma just proves a required fact about \<open>list_neq\<close>, {\em remove1} and {\em length}.\<close>

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 \<open>?P xs\<close>
  {
    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 \<open>We now prove some facts about \<open>list_eq\<close>, \<open>list_neq\<close>, length, sum and product.\<close>

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 (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 sum_list_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 sum_list_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 \<open>Element selection\<close>

text \<open>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.\<close>

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 sum_list_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 of_nat_add [symmetric])
      by (simp add: sum_list_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: sum_list_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) \<comment> \<open>reductio ad absurdum\<close>
  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 sum_list_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 of_nat_add [symmetric])
      by (simp add: sum_list_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: sum_list_split [symmetric])
qed

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

subsection \<open>Abstract properties\<close>

text \<open>In order to maintain some comprehension of the following proofs we now introduce some properties of collections.\<close>

subsubsection \<open>Definitions\<close>

text \<open>{\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).\<close>

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 \<open>\<open>\<gamma>-eq\<close>: Two lists are $\gamma$-equivalent if and only
if they both have the same number of elements and the same arithmetic
means.\<close>

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 \<open>\<open>\<gamma>_eq\<close> is transitive and symmetric.\<close>

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 \<open>{\em pos}: A list is positive if all its elements are greater than 0.\<close>

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: if_split, 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 \<open>Properties\<close>

text \<open>Here we prove some non-trivial properties of the abstract properties.\<close>

text \<open>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.\<close>

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 \<open>We now show that homogeneity of a non-empty collection $x$
implies that its product is equal to \<open>(mean x)^(length x)\<close>.\<close>

lemma prod_list_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 prod_list_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 sum_list_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 \<open>Furthermore we present an important result - that a
homogeneous collection has equal geometric and arithmetic means.\<close>

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 prod_list_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 \<open>Existence of a new collection\<close>

text \<open>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.\<close>

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[of xs] 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 \<open>Pick two elements from xs, one greater than m, one less than m.\<close>
  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

  \<comment> \<open>remove these elements from xs, and insert two new elements\<close>
  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
  \<comment> \<open>prove that new list is positive\<close>
  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

  \<comment> \<open>now show that the new list has the same mean as the old list\<close>
  with mem nl lo bdef \<alpha>_mem \<beta>_mem
    have "\<Sum>:new_list = \<Sum>:xs"
      apply clarsimp
      apply (subst sum_list_rmv1)
        apply simp
      apply (subst sum_list_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)

  \<comment> \<open>finally show that the new list has a greater gmean than the old list\<close>
  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[where 'a = real] 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

  \<comment> \<open>auxiliary info\<close>
  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

  \<comment> \<open>now show that new list is more homogeneous\<close>
  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

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

text \<open>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.\<close>

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 \<open>Cauchy's Mean Theorem\<close>

text \<open>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.\<close>

theorem CauchysMeanTheorem:
  fixes z::"real list"
  assumes "pos z"
  shows "gmean z \<le> mean z"
proof -
  from \<open>pos z\<close> have zne: "z\<noteq>[]" by (rule pos_imp_ne)
  show "gmean z \<le> mean z"
  proof cases
    assume "het z = 0"
    with \<open>pos z\<close> 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 \<open>pos z\<close> 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 \<open>In the equality version we prove that the geometric mean
  is identical to the arithmetic mean iff the collection is
  homogeneous.\<close>
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] \<open>pos z\<close> 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 \<open>pos z\<close> 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 \<open>pos z\<close>]
    CauchysMeanTheorem_Eq[OF \<open>pos z\<close>]
    \<open>het z > 0\<close>
    by auto

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
(*<*)
theory ICF_Userguide
imports
  "../ICF/Collections"
  "../Lib/Code_Target_ICF"
begin
(*>*)

text_raw \<open>\isasection{Isabelle Collections Framework Userguide}\label{thy:Userguide}\<close>

section "Introduction"
text \<open>
  This is the Userguide for the (old) Isabelle Collection Framework.
  It does not cover the Generic Collection Framework, nor the
  Automatic Refinement Framework.

  The Isabelle Collections Framework defines interfaces of various collection types and provides some standard implementations and generic algorithms.

  The relation between the data structures of the collection framework and standard Isabelle types (e.g. for sets and maps) is established by abstraction functions.

  Amongst others, the following interfaces and data-structures are provided by the Isabelle Collections Framework (For a complete list, see the overview section
  in the implementations chapter of the proof document):
  \begin{itemize}
    \item Set and map implementations based on (associative) lists, red-black trees, hashing and tries.
    \item An implementation of a FIFO-queue based on two stacks.
    \item Annotated lists implemented by finger trees.
    \item Priority queues implemented by binomial heaps, skew binomial heaps, and annotated lists (via finger trees).
  \end{itemize}

  The red-black trees are imported from the standard isabelle library. The binomial and skew binomial heaps are
  imported from the {\em Binomial-Heaps} entry of the archive of formal proofs. The finger trees are imported from
  the {\em Finger-Trees} entry of the archive of formal proofs.
\<close>

subsection "Getting Started"
text \<open>
  To get started with the Isabelle Collections Framework (assuming that you are already familiar with Isabelle/HOL and Isar),
  you should first read the introduction (this section), that provides many basic examples. More examples are in the examples/ subdirectory of the collection
  framework.
  Section~\ref{sec:userguide.structure} explains the concepts of the Isabelle Collections Framework in more detail.
  Section~\ref{sec:userguide.ext} provides information on extending the framework along with detailed examples, and
  Section~\ref{sec:userguide.design} contains a discussion on the design of this framework.
  There is also a paper \cite{LammichLochbihler2010ITP} on the design of the Isabelle Collections Framework available.
\<close>

subsection "Introductory Example"
text \<open>
  We introduce the Isabelle Collections Framework by a simple example.

  Given a set of elements represented by a red-black tree, and a list,
  we want to filter out all elements that are not contained in the set.
  This can be done by Isabelle/HOL's @{const filter}-function\footnote{Note that Isabelle/HOL uses the list comprehension syntax @{term [source] "[x\<leftarrow>l. P x]"}
  as syntactic sugar for filtering a list.}:
\<close>

definition rbt_restrict_list :: "'a::linorder rs \<Rightarrow> 'a list \<Rightarrow> 'a list"
where "rbt_restrict_list s l == [ x\<leftarrow>l. rs.memb x s ]"

text \<open>
  The type @{typ "'a rs"} is the type of sets backed by red-black trees.
  Note that the element type of sets backed by red-black trees must be
  of sort \<open>linorder\<close>.
  The function @{const rs.memb} tests membership on such sets.
\<close>

text \<open>Next, we show correctness of our function:\<close>
lemma rbt_restrict_list_correct:
  assumes [simp]: "rs.invar s"
  shows "rbt_restrict_list s l = [x\<leftarrow>l. x\<in>rs.\<alpha> s]"
  by (simp add: rbt_restrict_list_def rs.memb_correct)

text \<open>
  The lemma @{thm [source] rs.memb_correct}: @{thm [display] rs.memb_correct[no_vars]}

  states correctness of the @{const rs.memb}-function.
  The function @{const rs.\<alpha>} maps a red-black-tree to the set that it represents.
  Moreover, we have to explicitely keep track of the invariants of the used data structure,
  in this case red-black trees.
  The premise @{thm (prem 1) rs.memb_correct} represents the invariant assumption for the collection data structure.
  Red-black-trees are invariant-free, so this defaults to @{term "True"}.
  For uniformity reasons, these (unnecessary) invariant assumptions are present in all correctness lemmata.

  Many of the correctness lemmas for standard RBT-set-operations are summarized by the lemma @{thm [source] rs.correct}:
    @{thm [display] rs.correct[no_vars]}
\<close>

text \<open>
  All implementations provided by this library are compatible with the Isabelle/HOL code-generator.
  Now follow some examples of using the code-generator.
  Note that the code generator can only generate code for plain constants
  without arguments, while the operations like @{const rs.memb} have arguments,
  that are only hidden by an abbreviation.
\<close>

text \<open>
  There are conversion functions from lists to sets and, vice-versa, from sets to lists:
\<close>

definition "conv_tests \<equiv> (
  rs.from_list [1::int .. 10],
  rs.to_list (rs.from_list [1::int .. 10]),
  rs.to_sorted_list (rs.from_list [1::int,5,6,7,3,4,9,8,2,7,6]),
  rs.to_rev_list (rs.from_list [1::int,5,6,7,3,4,9,8,2,7,6])
)"

ML_val \<open>@{code conv_tests}\<close>

text \<open>
  Note that sets make no guarantee about ordering, hence the only thing we can
  prove about conversion from sets to lists is:
    @{thm [source] rs.to_list_correct}: @{thm [display] rs.to_list_correct[no_vars]}

  Some sets, like red-black-trees, also support conversion to sorted lists,
  and we have:
    @{thm [source] rs.to_sorted_list_correct}: @{thm [display] rs.to_sorted_list_correct[no_vars]} and
    @{thm [source] rs.to_rev_list_correct}: @{thm [display] rs.to_rev_list_correct[no_vars]}
\<close>

definition "restrict_list_test \<equiv> rbt_restrict_list (rs.from_list [1::nat,2,3,4,5]) [1::nat,9,2,3,4,5,6,5,4,3,6,7,8,9]"

ML_val \<open>@{code restrict_list_test}\<close>

definition "big_test n = (rs.from_list [(1::int)..n])"

ML_val \<open>@{code big_test} (@{code int_of_integer} 9000)\<close>

subsection "Theories"
text \<open>
  To make available the whole collections framework to your formalization,
  import the theory @{theory Collections.Collections} which includes everything. Here is a
  small selection:
  \begin{description}
    \item[@{theory Collections.SetSpec}] Specification of sets and set functions
    \item[@{theory Collections.SetGA}] Generic algorithms for sets
    \item[@{theory Collections.SetStdImpl}] Standard set implementations (list, rb-tree, hashing, tries)
    \item[@{theory Collections.MapSpec}] Specification of maps
    \item[@{theory Collections.MapGA}] Generic algorithms for maps
    \item[@{theory Collections.MapStdImpl}] Standard map implementations (list,rb-tree, hashing, tries)
    \item[@{theory Collections.ListSpec}] Specification of lists
    \item[@{theory Collections.Fifo}] Amortized fifo queue
    \item[@{theory Collections.DatRef}] Data refinement for the while combinator
  \end{description}

\<close>

subsection "Iterators"
text \<open>An important concept when using collections are iterators. An iterator is a kind of generalized fold-functional.
  Like the fold-functional, it applies a function to all elements of a set and modifies a state. There are
  no guarantees about the iteration order. But, unlike the fold functional, you can prove useful properties of iterations
  even if the function is not left-commutative. Proofs about iterations are done in invariant style, establishing an
  invariant over the iteration.

  The iterator combinator for red-black tree sets is @{const rs.iterate}, and the proof-rule that is usually used is:
    @{thm [source] rs.iteratei_rule_P}: @{thm [display] rs.iteratei_rule_P[no_vars]}

  The invariant @{term I} is parameterized with the set of remaining elements that have not yet been iterated over and the
  current state. The invariant has to hold for all elements remaining and the initial state: @{term "I (rs.\<alpha> S) \<sigma>0"}.
  Moreover, the invariant has to be preserved by an iteration step:
    @{term [display] "\<And>x it \<sigma>. \<lbrakk>x \<in> it; it \<subseteq> rs.\<alpha> S; I it \<sigma>\<rbrakk> \<Longrightarrow> I (it - {x}) (f x \<sigma>)"}
  And the proposition to be shown for the final state must be a consequence of the invarant for no
  elements remaining: @{term "\<And>\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"}.

  A generalization of iterators are {\em interruptible iterators} where iteration is only continues while some condition on the state holds.
  Reasoning over interruptible iterators is also done by invariants:
    @{thm [source] rs.iteratei_rule_P}: @{thm [display] rs.iteratei_rule_P[no_vars]}

  Here, interruption of the iteration is handled by the premise
    @{term [display] "\<And>\<sigma> it. \<lbrakk>it \<subseteq> rs.\<alpha> S; it \<noteq> {}; \<not> c \<sigma>; I it \<sigma>\<rbrakk> \<Longrightarrow> P \<sigma>"}
  that shows the proposition from the invariant for any intermediate state of the
  iteration where the continuation condition
  does not hold (and thus the iteration is interrupted).
\<close>

text \<open>
  As an example of reasoning about results of iterators, we implement a function
  that converts a hashset to a list that contains precisely the elements of the set.
\<close>

definition "hs_to_list' s == hs.iteratei s (\<lambda>_. True) (#) []"

text \<open>
  The correctness proof works by establishing the invariant that the list contains
  all elements that have already been iterated over.
  Again @{term "hs.invar s"} denotes the invariant for hashsets which defaults to @{term "True"}.
\<close>
lemma hs_to_list'_correct:
  assumes INV: "hs.invar s"
  shows "set (hs_to_list' s) = hs.\<alpha> s"
  apply (unfold hs_to_list'_def)
  apply (rule_tac
    I="\<lambda>it \<sigma>. set \<sigma> = hs.\<alpha> s - it"
    in hs.iterate_rule_P[OF INV])
  txt \<open>The resulting proof obligations are easily discharged using auto:\<close>
  apply auto
  done

text \<open>
  As an example for an interruptible iterator,
  we define a bounded existential-quantification over the list elements.
  As soon as the first element is found that fulfills the predicate,
  the iteration is interrupted.
  The state of the iteration is simply a boolean, indicating the (current) result of the quantification:
\<close>

definition "hs_bex s P == hs.iteratei s (\<lambda>\<sigma>. \<not> \<sigma>) (\<lambda>x \<sigma>. P x) False"

lemma hs_bex_correct:
  "hs.invar s \<Longrightarrow> hs_bex s P \<longleftrightarrow> (\<exists>x\<in>hs.\<alpha> s. P x)"
  apply (unfold hs_bex_def)
  txt \<open>The invariant states that the current result matches the result of the quantification
    over the elements already iterated over:\<close>
  apply (rule_tac
    I="\<lambda>it \<sigma>. \<sigma> \<longleftrightarrow> (\<exists>x\<in>hs.\<alpha> s - it. P x)"
    in hs.iteratei_rule_P)
  txt \<open>The resulting proof obligations are easily discharged by auto:\<close>
  apply auto
  done

section "Structure of the Framework"
text_raw \<open>\label{sec:userguide.structure}\<close>
text \<open>
  The concepts of the framework are roughly based on the object-oriented concepts of interfaces, implementations and generic algorithms.

  The concepts used in the framework are the following:
  \begin{description}
    \item[Interfaces] An interface describes some concept by providing an abstraction mapping $\alpha$ to a related Isabelle/HOL-concept.
      The definition is generic in the datatype used to implement the concept (i.e. the concrete data structure). An interface is specified by means
      of a locale that fixes the abstraction mapping and an invariant.
      For example, the set-interface contains an abstraction mapping to sets, and is specified by the locale \<open>SetSpec.set\<close>.
      An interface roughly matches the concept of a (collection) interface in Java, e.g. {\em java.util.Set}.

    \item[Functions] A function specifies some functionality involving interfaces. A function is specified by means of a locale.
                      For example, membership query for a set is specified by the locale @{const [source] SetSpec.set_memb} and
                      equality test between two sets is a function specified by @{const [source] SetSpec.set_equal}.
                      A function roughly matches a method declared in an interface, e.g. {\em java.util.Set\#contains, java.util.Set\#equals}.

    \item[Operation Records] In order to reference an interface with a standard
      set of operations, those operations are summarized in a record, and there
      is a locale that fixes this record, and makes available all operations.
      For example, the locale @{const [source] SetSpec.StdSet} fixes a record
      of standard set operations and assumes their correctness. It also defines
      abbreviations to easily access the members of the record. Internally,
      all the standard operations, like @{const hs.memb}, are introduced by
      interpretation of such an operation locale.

    \item[Generic Algorithms] A generic algorithm specifies, in a generic way,
      how to implement a function using other functions. Usually, a generic
      algorithm lives in a locale that imports the necessary operation locales.
      For example, the locale @{const SetGA.cart_loc} defines a generic
      algorithm for the cartesian product between two sets.

      There is no direct match of generic algorithms in the Java
      Collections Framework. The most related concept are abstract
      collection interfaces, that provide some default algorithms,
      e.g. {\em java.util.AbstractSet}.  The concept of {\em Algorithm} in
      the C++ Standard Template Library \cite{C++STL} matches the concept
      of Generic Algorithm quite well.

    \item[Implementation] An implementation of an interface provides a
       data structure for that interface together with an abstraction
       mapping and an invariant. Moreover, it provides implementations
       for some (or all) functions of that interface.  For example,
       red-black trees are an implementation of the set-interface,
       with the abstraction mapping @{const rs.\<alpha>} and invariant
       @{const rs.invar}; and the constant @{const rs.ins} implements
       the insert-function, as can be verified by
       @{lemma "set_ins rs.\<alpha> rs.invar rs.ins" by unfold_locales}.
       An implementation matches a concrete collection
       interface in Java, e.g. {\em java.util.TreeSet}, and the
       methods implemented by such an interface, e.g. {\em
       java.util.TreeSet\#add}.

    \item[Instantiation] An instantiation of a generic algorithm
        provides actual implementations for the used functions. For
        example, the generic cartesian-product algorithm can be
        instantiated to use red-black-trees for both arguments, and output
        a list, as will be illustrated below in Section~\ref{sec:inst_gen_algo}.
        While some of the functions
        of an implementation need to be implemented specifically, many
        functions may be obtained by instantiating generic algorithms.
        In Java, instantiation of a generic algorithm is matched most
        closely by inheriting from an abstract collection
        interface. In the C++ Standard Template Library instantiation
        of generic algorithms is done implicitely by the compiler.

  \end{description}

\<close>

  subsection "Instantiation of Generic Algorithms" text_raw \<open>\label{sec:inst_gen_algo}\<close>

  text \<open>A generic algorithm is instantiated by interpreting its locale with
    the wanted implementations. For example, to obtain a cartesian product
    between two red-black trees, yielding a list, we can do the following:\<close>
  setup Locale_Code.open_block
  interpretation rrl: cart_loc rs_ops rs_ops ls_ops by unfold_locales
  setup Locale_Code.close_block
  setup \<open>ICF_Tools.revert_abbrevs "rrl"\<close>

  text \<open>It is then available under the expected name:\<close>
  term "rrl.cart"

  text \<open>Note the three lines of boilerplate code, that work around some
    technical problems of Isabelle/HOL: The \<open>Locale_Code.open_block\<close> and
    \<open>Locale_Code.close_block\<close> commands set up code generation for any
    locale that is interpreted in between them. They also have to be specified
    if an existing locale that already has interpretations is extended by
    new definitions.

    The \<open>ICF_Tools.revert_abbrevs "rrl"\<close> reverts all
    abbreviations introduced by the locale, such that the displayed
    information becomes nicer.
\<close>

  subsection "Naming Conventions"
  text \<open>
    The Isabelle Collections Framework follows these general naming conventions.
    Each implementation has a two-letter (or three-letter) and a one-letter (or two-letter) abbreviation, that are used as prefixes for the related constants, lemmas and instantiations.

    The two-letter and three-letter abbreviations should be unique over all interfaces and instantiations, the one-letter abbreviations should be unique
    over all implementations of the same interface.
    Names that reference the implementation of only one interface are prefixed with that implementation's two-letter abbreviation (e.g. @{const hs.ins} for insertion into a HashSet (hs,h)),
    names that reference more than one implementation are prefixed with the one-letter (or two-letter) abbreviations (e.g. @{const rrl.cart} for the cartesian
    product between two RBT-Sets, yielding a list-set)

    The most important abbreviations are:
    \begin{description}
      \item[lm,l] List Map
      \item[lmi,li] List Map with explicit invariant
      \item[rm,r] RB-Tree Map
      \item[hm,h] Hash Map
      \item[ahm,a] Array-based hash map
      \item[tm,t] Trie Map
      \item[ls,l] List Set
      \item[lsi,li] List Set with explicit invariant
      \item[rs,r] RB-Tree Set
      \item[hs,h] Hash Set
      \item[ahs,a] Array-based hash map
      \item[ts,t] Trie Set
    \end{description}

    Each function \<open>name\<close> of an interface \<open>interface\<close> is declared in a locale \<open>interface_name\<close>. This locale provides a fact \<open>name_correct\<close>. For example, there is the locale @{const set_ins} providing
    the fact @{thm [source] set_ins.ins_correct}.
    An implementation instantiates the locales of all implemented functions, using its two-letter abbreviation as instantiation prefix. For example, the HashSet-implementation instantiates the locale @{const set_ins}
    with the prefix {\em hs}, yielding the lemma @{thm [source] hs.ins_correct}. Moreover, an implementation with two-letter abbreviation {\em aa} provides a lemma \<open>aa.correct\<close>
    that summarizes the correctness facts for the basic
    operations. It should only contain those facts that are safe to be used with the simplifier. E.g., the correctness facts for basic operations on hash sets are available via the lemma @{thm [source] hs.correct}.

\<close>

section "Extending the Framework"
text_raw \<open>\label{sec:userguide.ext}\<close>
text \<open>
  The best way to add new features, i.e., interfaces, functions,
  generic algorithms, or implementations to the collection framework is to use
  one of the existing items as example.
\<close>

section "Design Issues"
text_raw \<open>\label{sec:userguide.design}\<close>
  text \<open>
    In this section, we motivate some of the design decisions of the Isabelle Collections Framework and report our experience with alternatives.
    Many of the design decisions are justified by restrictions of Isabelle/HOL and the code generator, so that there may be better
    options if those restrictions should vanish from future releases of Isabelle/HOL.
\<close>

  text \<open>
    The main design goals of this development are:
    \begin{enumerate}
      \item\label{dg_unified} Make available various implementations of collections under a unified interface.
      \item\label{dg_extensible} It should be easy to extend the framework by new interfaces, functions, algorithms, and implementations.
      \item\label{dg_concise} Allow simple and concise reasoning over functions using collections.
      \item\label{dg_genalgo} Allow generic algorithms, that are independent of the actual data structure that is used.
      \item\label{dg_exec} Support generation of executable code.
      \item\label{dg_control} Let the user precisely control what data structures are used in the implementation.
    \end{enumerate}
\<close>

  subsection \<open>Data Refinement\<close>
  text \<open>
    In order to allow simple reasoning over collections, we use a data refinement approach. Each collection
    interface has an abstraction function that maps it on a related Isabelle/HOL concept (abstract level).
    The specification of functions are also relative to the abstraction.
    This allows most of the correctness reasoning to be done on the abstract level. On this level,
    the tool support is more elaborated and one is not yet fixed to a concrete implementation.
    In a next step, the abstract specification is refined to use an actual implementation (concrete level). The correctness properties
    proven on the abstract level usually transfer easily to the concrete level.

    Moreover, the user has precise control how the refinement is done, i.e. what data structures are used. An alternative would be to do refinement
    completely automatic, as e.g. done in the code generator setup of the Theory~{\em Executable-Set}. This has the advantage that it induces less writing overhead.
    The disadvantage is that the user looses a great amount of control over the refinement. For example, in {\em Executable-Set}, all sets have to be represented by lists,
    and there is no possibility to represent one set differently from another.

    For a more detailed discussion of the data refinement issue, we refer to
    the monadic refinement framework, that is available in the AFP
    (@{url "http://isa-afp.org/entries/Refine_Monadic.shtml"})
\<close>

  subsection \<open>Operation Records\<close>
  text \<open>
    In order to allow convenient access to the most frequently used functions
    of an interface,
    we have grouped them together in a record, and defined a locale that only
    fixes this record. This greatly reduces the boilerplate required to define
    a new (generic) algorithm, as only the operation locale (instead of every
    single function) has to be included in the locale for the generic algorithm.

    Note however, that parameters of locales are monomorphic inside the locale.
    Thus, we have to import an own instance for the locale for every element
    type of a set, or key/value type of a map.
    For iterators, where this problem was most annoying, we have installed a
    workaround that allows polymorphic iterators even inside locales.
\<close>

  subsection \<open>Locales for Generic Algorithms\<close>
  text \<open>
    A generic algorithm is defined within a locale, that includes the required
    functions (or operation locales). If many instances of the same interface
    are required, prefixes are used to distinguish between them. This makes
    the code for a generic algorithm quite consise and readable.

    However, there are some technical issues that one has to consider:
    \begin{itemize}
      \item  When fixing parameters in the declaration of the locale, their
        types will be inferred independently of the definitions later done in
        the locale context. In order to get the correct types, one has to add
        explicit type constraints.
      \item The code generator has problems with generating code from
        definitions inside a locale. Currently, the \<open>Locale_Code\<close>-package
        provides a rather convenient workaround for that issue: It requires the
        user to enclose interpretations and definitions of new constants inside
        already interpreted locales within two special commands, that set up
        the code generator appropriately.
    \end{itemize}
\<close>

  subsection \<open>Explicit Invariants vs Typedef\<close>
  text \<open>
    The interfaces of this framework use explicit invariants.
    This provides a more general specification which allows some operations to
    be implemented more efficiently, cf. @{const "lsi.ins_dj"}
    in @{theory Collections.ListSetImpl_Invar}.

    Most implementations, however, hide the invariant in a typedef and setup
    the code generator appropriately.
    In that case, the invariant is just @{term "\<lambda>_. True"}, and removed
    automatically by the simplifier and classical reasoner.
    However, it still shows up in some premises and conclusions due to
    uniformity reasons.
\<close>

(*<*)
end
(*>*)


(*
Author:  Christian Sternagel <c.sternagel@gmail.com>
Author:  René Thiemann <rene.thiemann@uibk.ac.at>
License: LGPL
*)
section \<open>First-Order Terms\<close>

theory Term
  imports Main
begin

datatype (funs_term : 'f, vars_term : 'v) "term" =
  is_Var: Var (the_Var: 'v) |
  Fun 'f (args : "('f, 'v) term list")
where
  "args (Var _) = []"

abbreviation "is_Fun t \<equiv> \<not> is_Var t"

lemma is_VarE [elim]:
  "is_Var t \<Longrightarrow> (\<And>x. t = Var x \<Longrightarrow> P) \<Longrightarrow> P"
  by (cases t) auto

lemma is_FunE [elim]:
  "is_Fun t \<Longrightarrow> (\<And>f ts. t = Fun f ts \<Longrightarrow> P) \<Longrightarrow> P"
  by (cases t) auto

lemma inj_on_Var[simp]: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "inj_on Var A"
  by (rule inj_onI) simp

lemma member_image_the_Var_image_subst: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  assumes is_var_\<sigma>: "\<forall>x. is_Var (\<sigma> x)"
  shows "x \<in> the_Var ` \<sigma> ` V \<longleftrightarrow> Var x \<in> \<sigma> ` V"
  using is_var_\<sigma> image_iff
  by (metis (no_types, opaque_lifting) term.collapse(1) term.sel(1))

lemma image_the_Var_image_subst_renaming_eq: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  assumes is_var_\<sigma>: "\<forall>x. is_Var (\<rho> x)"
  shows "the_Var ` \<rho> ` V = (\<Union>x \<in> V. vars_term (\<rho> x))"
proof (rule Set.equalityI; rule Set.subsetI)
  from is_var_\<sigma> show "\<And>x. x \<in> the_Var ` \<rho> ` V \<Longrightarrow> x \<in> (\<Union>x\<in>V. vars_term (\<rho> x))"
    using term.set_sel(3) by force
next
  from is_var_\<sigma> show "\<And>x. x \<in> (\<Union>x\<in>V. vars_term (\<rho> x)) \<Longrightarrow> x \<in> the_Var ` \<rho> ` V"
    by (smt (verit, best) Term.term.simps(17) UN_iff image_eqI singletonD term.collapse(1))
qed

text \<open>Reorient equations of the form @{term "Var x = t"} and @{term "Fun f ss = t"} to facilitate
  simplification.\<close>
setup \<open>
  Reorient_Proc.add
    (fn Const (@{const_name Var}, _) $ _ => true | _ => false)
  #> Reorient_Proc.add
    (fn Const (@{const_name Fun}, _) $ _ $ _ => true | _ => false)
\<close>

simproc_setup reorient_Var ("Var x = t") = Reorient_Proc.proc
simproc_setup reorient_Fun ("Fun f ss = t") = Reorient_Proc.proc

text \<open>The \emph{root symbol} of a term is defined by:\<close>
fun root :: "('f, 'v) term \<Rightarrow> ('f \<times> nat) option"
where
  "root (Var x) = None" |
  "root (Fun f ts) = Some (f, length ts)"

lemma finite_vars_term [simp]:
  "finite (vars_term t)"
  by (induct t) simp_all

lemma finite_Union_vars_term:
  "finite (\<Union>t \<in> set ts. vars_term t)"
  by auto

text \<open>A substitution is a mapping \<open>\<sigma>\<close> from variables to terms. We call a substitution that
  alters the type of variables a generalized substitution, since it does not have all properties
  that are expected of (standard) substitutions (e.g., there is no empty substitution).\<close>
type_synonym ('f, 'v, 'w) gsubst = "'v \<Rightarrow> ('f, 'w) term"
type_synonym ('f, 'v) subst  = "('f, 'v, 'v) gsubst"

fun subst_apply_term :: "('f, 'v) term \<Rightarrow> ('f, 'v, 'w) gsubst \<Rightarrow> ('f, 'w) term" (infixl "\<cdot>" 67)
  where
    "Var x \<cdot> \<sigma> = \<sigma> x"
  | "Fun f ss \<cdot> \<sigma> = Fun f (map (\<lambda>t. t \<cdot> \<sigma>) ss)"

definition
  subst_compose :: "('f, 'u, 'v) gsubst \<Rightarrow> ('f, 'v, 'w) gsubst \<Rightarrow> ('f, 'u, 'w) gsubst"
  (infixl "\<circ>\<^sub>s" 75)
  where
    "\<sigma> \<circ>\<^sub>s \<tau> = (\<lambda>x. (\<sigma> x) \<cdot> \<tau>)"

lemma subst_subst_compose [simp]:
  "t \<cdot> (\<sigma> \<circ>\<^sub>s \<tau>) = t \<cdot> \<sigma> \<cdot> \<tau>"
  by (induct t \<sigma> rule: subst_apply_term.induct) (simp_all add: subst_compose_def)

lemma subst_compose_assoc:
  "\<sigma> \<circ>\<^sub>s \<tau> \<circ>\<^sub>s \<mu> = \<sigma> \<circ>\<^sub>s (\<tau> \<circ>\<^sub>s \<mu>)"
proof (rule ext)
  fix x show "(\<sigma> \<circ>\<^sub>s \<tau> \<circ>\<^sub>s \<mu>) x = (\<sigma> \<circ>\<^sub>s (\<tau> \<circ>\<^sub>s \<mu>)) x"
  proof -
    have "(\<sigma> \<circ>\<^sub>s \<tau> \<circ>\<^sub>s \<mu>) x = \<sigma>(x) \<cdot> \<tau> \<cdot> \<mu>" by (simp add: subst_compose_def)
    also have "\<dots> = \<sigma>(x) \<cdot> (\<tau> \<circ>\<^sub>s \<mu>)" by simp
    finally show ?thesis by (simp add: subst_compose_def)
  qed
qed

lemma subst_apply_term_empty [simp]:
  "t \<cdot> Var = t"
proof (induct t)
  case (Fun f ts)
  from map_ext [rule_format, of ts _ id, OF Fun] show ?case by simp
qed simp

interpretation subst_monoid_mult: monoid_mult "Var" "(\<circ>\<^sub>s)"
  by (unfold_locales) (simp add: subst_compose_assoc, simp_all add: subst_compose_def)

lemma term_subst_eq:
  assumes "\<And>x. x \<in> vars_term t \<Longrightarrow> \<sigma> x = \<tau> x"
  shows "t \<cdot> \<sigma> = t \<cdot> \<tau>"
  using assms by (induct t) (auto)

lemma term_subst_eq_rev:
  "t \<cdot> \<sigma> = t \<cdot> \<tau> \<Longrightarrow> \<forall>x \<in> vars_term t. \<sigma> x = \<tau> x"
  by (induct t) simp_all

lemma term_subst_eq_conv:
  "t \<cdot> \<sigma> = t \<cdot> \<tau> \<longleftrightarrow> (\<forall>x \<in> vars_term t. \<sigma> x = \<tau> x)"
  using term_subst_eq [of t \<sigma> \<tau>] and term_subst_eq_rev [of t \<sigma> \<tau>] by auto

lemma subst_term_eqI:
  assumes "(\<And>t. t \<cdot> \<sigma> = t \<cdot> \<tau>)"
  shows "\<sigma> = \<tau>"
  using assms [of "Var x" for x] by (intro ext) simp

definition subst_domain :: "('f, 'v) subst \<Rightarrow> 'v set"
  where
    "subst_domain \<sigma> = {x. \<sigma> x \<noteq> Var x}"

fun subst_range :: "('f, 'v) subst \<Rightarrow> ('f, 'v) term set"
  where
    "subst_range \<sigma> = \<sigma> ` subst_domain \<sigma>"

text \<open>The variables introduced by a substitution.\<close>
definition range_vars :: "('f, 'v) subst \<Rightarrow> 'v set"
where
  "range_vars \<sigma> = \<Union>(vars_term ` subst_range \<sigma>)"

lemma mem_range_varsI: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  assumes "\<sigma> x = Var y" and "x \<noteq> y"
  shows "y \<in> range_vars \<sigma>"
  unfolding range_vars_def UN_iff
proof (rule bexI[of _ "Var y"])
  show "y \<in> vars_term (Var y)"
    by simp
next
  from assms show "Var y \<in> subst_range \<sigma>"
    by (simp_all add: subst_domain_def)
qed

lemma subst_domain_Var [simp]:
  "subst_domain Var = {}"
  by (simp add: subst_domain_def)

lemma subst_range_Var[simp]: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "subst_range Var = {}"
  by simp

lemma range_vars_Var[simp]: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "range_vars Var = {}"
  by (simp add: range_vars_def)

lemma subst_apply_term_ident: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "vars_term t \<inter> subst_domain \<sigma> = {} \<Longrightarrow> t \<cdot> \<sigma> = t"
proof (induction t)
  case (Var x)
  thus ?case
    by (simp add: subst_domain_def)
next
  case (Fun f ts)
  thus ?case
    by (auto intro: list.map_ident_strong)
qed

lemma vars_term_subst_apply_term: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "vars_term (t \<cdot> \<sigma>) = (\<Union>x \<in> vars_term t. vars_term (\<sigma> x))"
  by (induction t) (auto simp add: insert_Diff_if subst_domain_def)

corollary vars_term_subst_apply_term_subset: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "vars_term (t \<cdot> \<sigma>) \<subseteq> vars_term t - subst_domain \<sigma> \<union> range_vars \<sigma>"
  unfolding vars_term_subst_apply_term
proof (induction t)
  case (Var x)
  show ?case
    by (cases "\<sigma> x = Var x") (auto simp add: range_vars_def subst_domain_def)
next
  case (Fun f xs)
  thus ?case by auto
qed

definition is_renaming :: "('f, 'v) subst \<Rightarrow> bool"
  where
    "is_renaming \<sigma> \<longleftrightarrow> (\<forall>x. is_Var (\<sigma> x)) \<and> inj_on \<sigma> (subst_domain \<sigma>)"

lemma inv_renaming_sound: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  assumes is_var_\<rho>: "\<forall>x. is_Var (\<rho> x)" and "inj \<rho>"
  shows "\<rho> \<circ>\<^sub>s (Var \<circ> (inv (the_Var \<circ> \<rho>))) = Var"
proof -
  define \<rho>' where "\<rho>' = the_Var \<circ> \<rho>"
  have \<rho>_def: "\<rho> = Var \<circ> \<rho>'"
    unfolding \<rho>'_def using is_var_\<rho> by auto

  from is_var_\<rho> \<open>inj \<rho>\<close> have "inj \<rho>'"
    unfolding inj_def \<rho>_def comp_def by fast
  hence "inv \<rho>' \<circ> \<rho>' = id"
    using inv_o_cancel[of \<rho>'] by simp
  hence "Var \<circ> (inv \<rho>' \<circ> \<rho>') = Var"
    by simp
  hence "\<forall>x. (Var \<circ> (inv \<rho>' \<circ> \<rho>')) x = Var x"
    by metis
  hence "\<forall>x. ((Var \<circ> \<rho>') \<circ>\<^sub>s (Var \<circ> (inv \<rho>'))) x = Var x"
    unfolding subst_compose_def by auto
  thus "\<rho> \<circ>\<^sub>s (Var \<circ> (inv \<rho>')) = Var"
    using \<rho>_def by auto
qed

lemma ex_inverse_of_renaming: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  assumes "\<forall>x. is_Var (\<rho> x)" and "inj \<rho>"
  shows "\<exists>\<tau>. \<rho> \<circ>\<^sub>s \<tau> = Var"
  using inv_renaming_sound[OF assms] by blast

lemma vars_term_subst:
  "vars_term (t \<cdot> \<sigma>) = \<Union>(vars_term ` \<sigma> ` vars_term t)"
  by (induct t) simp_all

lemma range_varsE [elim]:
  assumes "x \<in> range_vars \<sigma>"
    and "\<And>t. x \<in> vars_term t \<Longrightarrow> t \<in> subst_range \<sigma> \<Longrightarrow> P"
  shows "P"
  using assms by (auto simp: range_vars_def)

lemma range_vars_subst_compose_subset:
  "range_vars (\<sigma> \<circ>\<^sub>s \<tau>) \<subseteq> (range_vars \<sigma> - subst_domain \<tau>) \<union> range_vars \<tau>" (is "?L \<subseteq> ?R")
proof
  fix x
  assume "x \<in> ?L"
  then obtain y where "y \<in> subst_domain (\<sigma> \<circ>\<^sub>s \<tau>)"
    and "x \<in> vars_term ((\<sigma> \<circ>\<^sub>s \<tau>) y)" by (auto simp: range_vars_def)
  then show "x \<in> ?R"
  proof (cases)
    assume "y \<in> subst_domain \<sigma>" and "x \<in> vars_term ((\<sigma> \<circ>\<^sub>s \<tau>) y)"
    moreover then obtain v where "v \<in> vars_term (\<sigma> y)"
      and "x \<in> vars_term (\<tau> v)" by (auto simp: subst_compose_def vars_term_subst)
    ultimately show ?thesis
      by (cases "v \<in> subst_domain \<tau>") (auto simp: range_vars_def subst_domain_def)
  qed (auto simp: range_vars_def subst_compose_def subst_domain_def)
qed

definition "subst x t = Var (x := t)"

lemma subst_simps [simp]:
  "subst x t x = t"
  "subst x (Var x) = Var"
  by (auto simp: subst_def)

lemma subst_subst_domain [simp]:
  "subst_domain (subst x t) = (if t = Var x then {} else {x})"
proof -
  { fix y
    have "y \<in> {y. subst x t y \<noteq> Var y} \<longleftrightarrow> y \<in> (if t = Var x then {} else {x})"
      by (cases "x = y", auto simp: subst_def) }
  then show ?thesis by (simp add: subst_domain_def)
qed

lemma subst_subst_range [simp]:
  "subst_range (subst x t) = (if t = Var x then {} else {t})"
  by (cases "t = Var x") (auto simp: subst_domain_def subst_def)

lemma subst_apply_left_idemp [simp]:
  assumes "\<sigma> x = t \<cdot> \<sigma>"
  shows "s \<cdot> subst x t \<cdot> \<sigma> = s \<cdot> \<sigma>"
  using assms by (induct s) (auto simp: subst_def)

lemma subst_compose_left_idemp [simp]:
  assumes "\<sigma> x = t \<cdot> \<sigma>"
  shows "subst x t \<circ>\<^sub>s \<sigma> = \<sigma>"
  by (rule subst_term_eqI) (simp add: assms)

lemma subst_ident [simp]:
  assumes "x \<notin> vars_term t"
  shows "t \<cdot> subst x u = t"
proof -
  have "t \<cdot> subst x u = t \<cdot> Var"
    by (rule term_subst_eq) (auto simp: assms subst_def)
  then show ?thesis by simp
qed

lemma subst_self_idemp [simp]:
  "x \<notin> vars_term t \<Longrightarrow> subst x t \<circ>\<^sub>s subst x t = subst x t"
  by (metis subst_simps(1) subst_compose_left_idemp subst_ident)

type_synonym ('f, 'v) terms = "('f, 'v) term set"

text \<open>Applying a substitution to every term of a given set.\<close>
abbreviation
  subst_apply_set :: "('f, 'v) terms \<Rightarrow> ('f, 'v, 'w) gsubst \<Rightarrow> ('f, 'w) terms" (infixl "\<cdot>\<^sub>s\<^sub>e\<^sub>t" 60)
  where
    "T \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma> \<equiv> (\<lambda>t. t \<cdot> \<sigma>) ` T"

text \<open>Composition of substitutions\<close>
lemma subst_compose: "(\<sigma> \<circ>\<^sub>s \<tau>) x = \<sigma> x \<cdot> \<tau>" by (auto simp: subst_compose_def)

lemmas subst_subst = subst_subst_compose [symmetric]

lemma subst_apply_eq_Var:
  assumes "s \<cdot> \<sigma> = Var x"
  obtains y where "s = Var y" and "\<sigma> y = Var x"
  using assms by (induct s) auto

lemma subst_domain_subst_compose:
  "subst_domain (\<sigma> \<circ>\<^sub>s \<tau>) =
    (subst_domain \<sigma> - {x. \<exists>y. \<sigma> x = Var y \<and> \<tau> y = Var x}) \<union>
    (subst_domain \<tau> - subst_domain \<sigma>)"
  by (auto simp: subst_domain_def subst_compose_def elim: subst_apply_eq_Var)

text \<open>A substitution is idempotent iff the variables in its range are disjoint from its domain.
  (See also "Term Rewriting and All That" \<^cite>\<open>\<open>Lemma 4.5.7\<close> in "AllThat"\<close>.)\<close>
lemma subst_idemp_iff:
  "\<sigma> \<circ>\<^sub>s \<sigma> = \<sigma> \<longleftrightarrow> subst_domain \<sigma> \<inter> range_vars \<sigma> = {}"
proof
  assume "\<sigma> \<circ>\<^sub>s \<sigma> = \<sigma>"
  then have "\<And>x. \<sigma> x \<cdot> \<sigma> = \<sigma> x \<cdot> Var" by simp (metis subst_compose_def)
  then have *: "\<And>x. \<forall>y\<in>vars_term (\<sigma> x). \<sigma> y = Var y"
    unfolding term_subst_eq_conv by simp
  { fix x y
    assume "\<sigma> x \<noteq> Var x" and "x \<in> vars_term (\<sigma> y)"
    with * [of y] have False by simp }
  then show "subst_domain \<sigma> \<inter> range_vars \<sigma> = {}"
    by (auto simp: subst_domain_def range_vars_def)
next
  assume "subst_domain \<sigma> \<inter> range_vars \<sigma> = {}"
  then have *: "\<And>x y. \<sigma> x = Var x \<or> \<sigma> y = Var y \<or> x \<notin> vars_term (\<sigma> y)"
    by (auto simp: subst_domain_def range_vars_def)
  have "\<And>x. \<forall>y\<in>vars_term (\<sigma> x). \<sigma> y = Var y"
  proof
    fix x y
    assume "y \<in> vars_term (\<sigma> x)"
    with * [of y x] show "\<sigma> y = Var y" by auto
  qed
  then show "\<sigma> \<circ>\<^sub>s \<sigma> = \<sigma>"
    by (simp add: subst_compose_def term_subst_eq_conv [symmetric])
qed

lemma subst_compose_apply_eq_apply_lhs: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  assumes
    "range_vars \<sigma> \<inter> subst_domain \<delta> = {}"
    "x \<notin> subst_domain \<delta>"
  shows "(\<sigma> \<circ>\<^sub>s \<delta>) x = \<sigma> x"
proof (cases "\<sigma> x")
  case (Var y)
  show ?thesis
  proof (cases "x = y")
    case True
    with Var have \<open>\<sigma> x = Var x\<close>
      by simp
    moreover from \<open>x \<notin> subst_domain \<delta>\<close> have "\<delta> x = Var x"
      by (simp add: disjoint_iff subst_domain_def)
    ultimately show ?thesis
      by (simp add: subst_compose_def)
  next
    case False
    have "y \<in> range_vars \<sigma>"
      unfolding range_vars_def UN_iff
    proof (rule bexI)
      show "y \<in> vars_term (Var y)"
        by simp
    next
      from Var False show "Var y \<in> subst_range \<sigma>"
        by (simp_all add: subst_domain_def)
    qed
    hence "y \<notin> subst_domain \<delta>"
      using \<open>range_vars \<sigma> \<inter> subst_domain \<delta> = {}\<close>
      by (simp add: disjoint_iff)
    with Var show ?thesis
      unfolding subst_compose_def
      by (simp add: subst_domain_def)
  qed
next
  case (Fun f ys)
  hence "Fun f ys \<in> subst_range \<sigma> \<or> (\<forall>y\<in>set ys. y \<in> subst_range \<sigma>)"
    using subst_domain_def by fastforce
  hence "\<forall>x \<in> vars_term (Fun f ys). x \<in> range_vars \<sigma>"
    by (metis UN_I range_vars_def term.distinct(1) term.sel(4) term.set_cases(2))
  hence "Fun f ys \<cdot> \<delta> = Fun f ys \<cdot> Var"
    unfolding term_subst_eq_conv
    using \<open>range_vars \<sigma> \<inter> subst_domain \<delta> = {}\<close>
    by (simp add: disjoint_iff subst_domain_def)
  hence "Fun f ys \<cdot> \<delta> = Fun f ys"
    by simp
  with Fun show ?thesis
    by (simp add: subst_compose_def)
qed

lemma subst_apply_term_subst_apply_term_eq_subst_apply_term_lhs: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  assumes "range_vars \<sigma> \<inter> subst_domain \<delta> = {}" and "vars_term t \<inter> subst_domain \<delta> = {}"
  shows "t \<cdot> \<sigma> \<cdot> \<delta> = t \<cdot> \<sigma>"
proof -
  from assms have "\<And>x. x \<in> vars_term t \<Longrightarrow> (\<sigma> \<circ>\<^sub>s \<delta>) x = \<sigma> x"
    using subst_compose_apply_eq_apply_lhs by fastforce
  hence "t \<cdot> \<sigma> \<circ>\<^sub>s \<delta> = t \<cdot> \<sigma>"
    using term_subst_eq_conv[of t "\<sigma> \<circ>\<^sub>s \<delta>" \<sigma>] by metis
  thus ?thesis
    by simp
qed

fun num_funs :: "('f, 'v) term \<Rightarrow> nat"
  where
    "num_funs (Var x) = 0" |
    "num_funs (Fun f ts) = Suc (sum_list (map num_funs ts))"

lemma num_funs_0:
  assumes "num_funs t = 0"
  obtains x where "t = Var x"
  using assms by (induct t) auto

lemma num_funs_subst:
  "num_funs (t \<cdot> \<sigma>) \<ge> num_funs t"
  by (induct t) (simp_all, metis comp_apply sum_list_mono)

lemma sum_list_map_num_funs_subst:
  assumes "sum_list (map (num_funs \<circ> (\<lambda>t. t \<cdot> \<sigma>)) ts) = sum_list (map num_funs ts)"
  shows "\<forall>i < length ts. num_funs (ts ! i \<cdot> \<sigma>) = num_funs (ts ! i)"
  using assms
proof (induct ts)
  case (Cons t ts)
  then have "num_funs (t \<cdot> \<sigma>) + sum_list (map (num_funs \<circ> (\<lambda>t. t \<cdot> \<sigma>)) ts)
    = num_funs t + sum_list (map num_funs ts)" by (simp add: o_def)
  moreover have "num_funs (t \<cdot> \<sigma>) \<ge> num_funs t" by (metis num_funs_subst)
  moreover have "sum_list (map (num_funs \<circ> (\<lambda>t. t \<cdot> \<sigma>)) ts) \<ge> sum_list (map num_funs ts)"
    using num_funs_subst [of _ \<sigma>] by (induct ts) (auto intro: add_mono)
  ultimately show ?case using Cons by (auto) (case_tac i, auto)
qed simp

lemma is_Fun_num_funs_less:
  assumes "x \<in> vars_term t" and "is_Fun t"
  shows "num_funs (\<sigma> x) < num_funs (t \<cdot> \<sigma>)"
  using assms
proof (induct t)
  case (Fun f ts)
  then obtain u where u: "u \<in> set ts" "x \<in> vars_term u" by auto
  then have "num_funs (u \<cdot> \<sigma>) \<le> sum_list (map (num_funs \<circ> (\<lambda>t. t \<cdot> \<sigma>)) ts)"
    by (intro member_le_sum_list) simp
  moreover have "num_funs (\<sigma> x) \<le> num_funs (u \<cdot> \<sigma>)"
    using Fun.hyps [OF u] and u  by (cases u; simp)
  ultimately show ?case by simp
qed simp

lemma finite_subst_domain_subst:
  "finite (subst_domain (subst x y))"
  by simp

lemma subst_domain_compose:
  "subst_domain (\<sigma> \<circ>\<^sub>s \<tau>) \<subseteq> subst_domain \<sigma> \<union> subst_domain \<tau>"
  by (auto simp: subst_domain_def subst_compose_def)

lemma vars_term_disjoint_imp_unifier:
  fixes \<sigma> :: "('f, 'v, 'w) gsubst"
  assumes "vars_term s \<inter> vars_term t = {}"
    and "s \<cdot> \<sigma> = t \<cdot> \<tau>"
  shows "\<exists>\<mu> :: ('f, 'v, 'w) gsubst. s \<cdot> \<mu> = t \<cdot> \<mu>"
proof -
  let ?\<mu> = "\<lambda>x. if x \<in> vars_term s then \<sigma> x else \<tau> x"
  have "s \<cdot> \<sigma> = s \<cdot> ?\<mu>"
    unfolding term_subst_eq_conv
    by (induct s) (simp_all)
  moreover have "t \<cdot> \<tau> = t \<cdot> ?\<mu>"
    using assms(1)
    unfolding term_subst_eq_conv
    by (induct s arbitrary: t) (auto)
  ultimately have "s \<cdot> ?\<mu> = t \<cdot> ?\<mu>" using assms(2) by simp
  then show ?thesis by blast
qed

lemma vars_term_subset_subst_eq:
  assumes "vars_term t \<subseteq> vars_term s"
    and "s \<cdot> \<sigma> = s \<cdot> \<tau>"
  shows "t \<cdot> \<sigma> = t \<cdot> \<tau>"
  using assms by (induct t) (induct s, auto)

subsection \<open>Restrict the Domain of a Substitution\<close>

definition restrict_subst_domain where \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "restrict_subst_domain V \<sigma> x \<equiv> (if x \<in> V then \<sigma> x else Var x)"

lemma restrict_subst_domain_empty[simp]: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "restrict_subst_domain {} \<sigma> = Var"
  unfolding restrict_subst_domain_def by auto

lemma restrict_subst_domain_Var[simp]: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "restrict_subst_domain V Var = Var"
  unfolding restrict_subst_domain_def by auto

lemma subst_domain_restrict_subst_domain[simp]: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "subst_domain (restrict_subst_domain V \<sigma>) = V \<inter> subst_domain \<sigma>"
  unfolding restrict_subst_domain_def subst_domain_def by auto

lemma subst_apply_term_restrict_subst_domain: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "vars_term t \<subseteq> V \<Longrightarrow> t \<cdot> restrict_subst_domain V \<sigma> = t \<cdot> \<sigma>"
  by (rule term_subst_eq) (simp add: restrict_subst_domain_def subsetD)

subsection \<open>Rename the Domain of a Substitution\<close>

definition rename_subst_domain where \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "rename_subst_domain \<rho> \<sigma> x =
    (if Var x \<in> \<rho> ` subst_domain \<sigma> then
      \<sigma> (the_inv \<rho> (Var x))
    else
      Var x)"

lemma rename_subst_domain_Var_lhs[simp]: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "rename_subst_domain Var \<sigma> = \<sigma>"
  by (rule ext) (simp add: rename_subst_domain_def inj_image_mem_iff the_inv_f_f subst_domain_def)

lemma rename_subst_domain_Var_rhs[simp]: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "rename_subst_domain \<rho> Var = Var"
  by (rule ext) (simp add: rename_subst_domain_def)

lemma subst_domain_rename_subst_domain_subset: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  assumes is_var_\<rho>: "\<forall>x. is_Var (\<rho> x)"
  shows "subst_domain (rename_subst_domain \<rho> \<sigma>) \<subseteq> the_Var ` \<rho> ` subst_domain \<sigma>"
  by (auto simp add: subst_domain_def rename_subst_domain_def
      member_image_the_Var_image_subst[OF is_var_\<rho>])

lemma subst_range_rename_subst_domain_subset: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  assumes "inj \<rho>"
  shows "subst_range (rename_subst_domain \<rho> \<sigma>) \<subseteq> subst_range \<sigma>"
proof (intro Set.equalityI Set.subsetI)
  fix t assume "t \<in> subst_range (rename_subst_domain \<rho> \<sigma>)"
  then obtain x where
    t_def: "t = rename_subst_domain \<rho> \<sigma> x" and
    "rename_subst_domain \<rho> \<sigma> x \<noteq> Var x"
    by (auto simp: image_iff subst_domain_def)

  show "t \<in> subst_range \<sigma>"
  proof (cases \<open>Var x \<in> \<rho> ` subst_domain \<sigma>\<close>)
    case True
    then obtain x' where "\<rho> x' = Var x" and "x' \<in> subst_domain \<sigma>"
      by auto
    then show ?thesis
      using the_inv_f_f[OF \<open>inj \<rho>\<close>, of x']
      by (simp add: t_def rename_subst_domain_def)
  next
    case False
    hence False
      using \<open>rename_subst_domain \<rho> \<sigma> x \<noteq> Var x\<close>
      by (simp add: t_def rename_subst_domain_def)
    thus ?thesis ..
  qed
qed

lemma range_vars_rename_subst_domain_subset: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  assumes "inj \<rho>"
  shows "range_vars (rename_subst_domain \<rho> \<sigma>) \<subseteq> range_vars \<sigma>"
  unfolding range_vars_def
  using subst_range_rename_subst_domain_subset[OF \<open>inj \<rho>\<close>]
  by (metis Union_mono image_mono)

lemma renaming_cancels_rename_subst_domain: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  assumes is_var_\<rho>: "\<forall>x. is_Var (\<rho> x)" and "inj \<rho>" and vars_t: "vars_term t \<subseteq> subst_domain \<sigma>"
  shows "t \<cdot> \<rho> \<cdot> rename_subst_domain \<rho> \<sigma> = t \<cdot> \<sigma>"
  unfolding subst_subst
proof (intro term_subst_eq ballI)
  fix x assume "x \<in> vars_term t"
  with vars_t have x_in: "x \<in> subst_domain \<sigma>"
    by blast

  obtain x' where \<rho>_x: "\<rho> x = Var x'"
    using is_var_\<rho> by (meson is_Var_def)
  with x_in have x'_in: "Var x' \<in> \<rho> ` subst_domain \<sigma>"
    by (metis image_eqI)

  have "(\<rho> \<circ>\<^sub>s rename_subst_domain \<rho> \<sigma>) x = \<rho> x \<cdot> rename_subst_domain \<rho> \<sigma>"
    by (simp add: subst_compose_def)
  also have "\<dots> = rename_subst_domain \<rho> \<sigma> x'"
    using \<rho>_x by simp
  also have "\<dots> = \<sigma> (the_inv \<rho> (Var x'))"
    by (simp add: rename_subst_domain_def if_P[OF x'_in])
  also have "\<dots> = \<sigma> (the_inv \<rho> (\<rho> x))"
    by (simp add: \<rho>_x)
  also have "\<dots> = \<sigma> x"
    using \<open>inj \<rho>\<close> by (simp add: the_inv_f_f)
  finally show "(\<rho> \<circ>\<^sub>s rename_subst_domain \<rho> \<sigma>) x = \<sigma> x"
    by simp
qed

subsection \<open>Rename the Domain and Range of a Substitution\<close>

definition rename_subst_domain_range where \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "rename_subst_domain_range \<rho> \<sigma> x =
    (if Var x \<in> \<rho> ` subst_domain \<sigma> then
      ((Var o the_inv \<rho>) \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<rho>) (Var x)
    else
      Var x)"

lemma rename_subst_domain_range_Var_lhs[simp]: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "rename_subst_domain_range Var \<sigma> = \<sigma>"
  by (rule ext) (simp add: rename_subst_domain_range_def inj_image_mem_iff the_inv_f_f
      subst_domain_def subst_compose_def)

lemma rename_subst_domain_range_Var_rhs[simp]: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "rename_subst_domain_range \<rho> Var = Var"
  by (rule ext) (simp add: rename_subst_domain_range_def)

lemma subst_compose_renaming_rename_subst_domain_range: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  fixes \<sigma> \<rho> :: "('f, 'v) subst"
  assumes is_var_\<rho>: "\<forall>x. is_Var (\<rho> x)" and "inj \<rho>"
  shows "\<rho> \<circ>\<^sub>s rename_subst_domain_range \<rho> \<sigma> = \<sigma> \<circ>\<^sub>s \<rho>"
proof (rule ext)
  fix x
  from is_var_\<rho> obtain x' where "\<rho> x = Var x'"
    by (meson is_Var_def is_renaming_def)
  with \<open>inj \<rho>\<close> have inv_\<rho>_x': "the_inv \<rho> (Var x') = x"
    by (metis the_inv_f_f)

  show "(\<rho> \<circ>\<^sub>s rename_subst_domain_range \<rho> \<sigma>) x = (\<sigma> \<circ>\<^sub>s \<rho>) x"
  proof (cases "x \<in> subst_domain \<sigma>")
    case True
    hence "Var x' \<in> \<rho> ` subst_domain \<sigma>"
      using \<open>\<rho> x = Var x'\<close> by (metis imageI)
    thus ?thesis
      by (simp add: \<open>\<rho> x = Var x'\<close> rename_subst_domain_range_def subst_compose_def inv_\<rho>_x')
  next
    case False
    hence "Var x' \<notin> \<rho> ` subst_domain \<sigma>"
    proof (rule contrapos_nn)
      assume "Var x' \<in> \<rho> ` subst_domain \<sigma>"
      hence "\<rho> x \<in> \<rho> ` subst_domain \<sigma>"
        unfolding \<open>\<rho> x = Var x'\<close> .
      thus "x \<in> subst_domain \<sigma>"
        unfolding inj_image_mem_iff[OF \<open>inj \<rho>\<close>] .
    qed
    with False \<open>\<rho> x = Var x'\<close> show ?thesis
      by (simp add: subst_compose_def subst_domain_def rename_subst_domain_range_def)
  qed
qed

corollary subst_apply_term_renaming_rename_subst_domain_range: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  \<comment> \<open>This might be easier to find with @{command find_theorems}.\<close>
  fixes t :: "('f, 'v) term" and \<sigma> \<rho> :: "('f, 'v) subst"
  assumes is_var_\<rho>: "\<forall>x. is_Var (\<rho> x)" and "inj \<rho>"
  shows "t \<cdot> \<rho> \<cdot> rename_subst_domain_range \<rho> \<sigma> = t \<cdot> \<sigma> \<cdot> \<rho>"
  unfolding subst_subst
  unfolding subst_compose_renaming_rename_subst_domain_range[OF assms]
  by (rule refl)

end