subsection \<open>Transition Systems\<close>

text \<open> We define transition systems, their valid traces,
and state rechability.\<close>

(*<*)
theory Transition_System
  imports Trivia
begin
(*>*)

subsubsection \<open>Traces\<close>

type_synonym 'trans trace = "'trans list"

locale Transition_System =
fixes istate :: "'state"
  and validTrans :: "'trans \<Rightarrow> bool"
  and srcOf :: "'trans \<Rightarrow> 'state"
  and tgtOf :: "'trans \<Rightarrow> 'state"
begin

fun srcOfTr where "srcOfTr tr = srcOf(hd tr)" (* source of *)
fun tgtOfTr where "tgtOfTr tr = tgtOf(last tr)" (* target of *)

fun srcOfTrFrom where
  "srcOfTrFrom s [] = s"
| "srcOfTrFrom s tr = srcOfTr tr"

lemma srcOfTrFrom_srcOfTr[simp]:
  "tr \<noteq> [] \<Longrightarrow> srcOfTrFrom s tr = srcOfTr tr"
  by (cases tr) auto

fun tgtOfTrFrom where
  "tgtOfTrFrom s [] = s"
| "tgtOfTrFrom s tr = tgtOfTr tr"

lemma tgtOfTrFrom_tgtOfTr[simp]:
  "tr \<noteq> [] \<Longrightarrow> tgtOfTrFrom s tr = tgtOfTr tr"
  by (cases tr) auto

text \<open>Traces allowed by the system (starting in any given state),
with two alternative definitions: growing from the left and growing from the right:\<close>

inductive valid :: "'trans trace \<Rightarrow> bool" where
Singl[simp,intro!]:
"validTrans trn
 \<Longrightarrow>
 valid [trn]"
|
Cons[intro]:
"\<lbrakk>validTrans trn; tgtOf trn = srcOf (hd tr); valid tr\<rbrakk>
 \<Longrightarrow>
 valid (trn # tr)"

inductive_cases valid_SinglE[elim!]: "valid [trn]"
inductive_cases valid_ConsE[elim]: "valid (trn # tr)"

inductive valid2 :: "'trans trace \<Rightarrow> bool" where
Singl[simp,intro!]:
"validTrans trn
 \<Longrightarrow>
 valid2 [trn]"
|
Rcons[intro]:
"\<lbrakk>valid2 tr; tgtOf (last tr) = srcOf trn; validTrans trn\<rbrakk>
 \<Longrightarrow>
 valid2 (tr ## trn)"

inductive_cases valid2_SinglE[elim!]: "valid2 [trn]"
inductive_cases valid2_RconsE[elim]: "valid2 (tr ## trn)"

lemma Nil_not_valid[simp]: "\<not> valid []"
by (metis valid.simps neq_Nil_conv)

lemma Nil_not_valid2[simp]: "\<not> valid2 []"
by (metis valid2.cases append_Nil butlast.simps butlast_snoc not_Cons_self2)

lemma valid_Rcons:
assumes "valid tr" and "tgtOf (last tr) = srcOf trn" and "validTrans trn"
shows "valid (tr ## trn)"
using assms proof(induct arbitrary: trn)
  case (Cons trn tr trna)
  thus ?case by (cases tr) auto
qed auto

lemma valid_hd_Rcons[simp]:
assumes "valid tr"
shows "hd (tr ## tran) = hd tr"
by (metis Nil_not_valid assms hd_append)

lemma valid2_hd_Rcons[simp]:
assumes "valid2 tr"
shows "hd (tr ## tran) = hd tr"
by (metis Nil_not_valid2 assms hd_append)

lemma valid2_last_Cons[simp]:
assumes "valid2 tr"
shows "last (tran # tr) = last tr"
by (metis Nil_not_valid2 assms last.simps)

lemma valid2_Cons:
assumes "valid2 tr" and "tgtOf trn = srcOf (hd tr)" and "validTrans trn"
shows "valid2 (trn # tr)"
using assms proof(induct arbitrary: trn)
  case Singl  show ?case
  unfolding two_singl_Rcons apply(rule valid2.Rcons) using Singl
  by (auto intro: valid2.Singl)
next
  case Rcons show ?case
  unfolding append.append_Cons[symmetric] apply(rule valid2.Rcons) using Rcons by auto
qed

lemma valid_valid2: "valid = valid2"
proof(rule ext, safe)
  fix tr assume "valid tr"  thus "valid2 tr"
  by (induct) (auto intro: valid2.Singl valid2_Cons)
next
  fix tr assume "valid2 tr"  thus "valid tr"
  by (induct) (auto intro: valid.Singl valid_Rcons)
qed

lemma valid_Cons_iff:
"valid (trn # tr) \<longleftrightarrow> validTrans trn \<and> ((tgtOf trn = srcOf (hd tr) \<and> valid tr) \<or> tr = [])"
unfolding valid.simps[of "trn # tr"] by auto

lemma valid_append:
"tr \<noteq> [] \<Longrightarrow> tr1 \<noteq> [] \<Longrightarrow>
 valid (tr @ tr1) \<longleftrightarrow> valid tr \<and> valid tr1 \<and> tgtOf (last tr) = srcOf (hd tr1)"
by (induct tr) (auto simp add: valid_Cons_iff)

lemmas valid2_valid = valid_valid2[symmetric]

(* validFrom includes empty traces too (unlike valid): *)
definition validFrom :: "'state \<Rightarrow> 'trans trace \<Rightarrow> bool" where
"validFrom s tr \<equiv> tr = [] \<or> (valid tr \<and> srcOf (hd tr) = s)"

lemma validFrom_Nil[simp,intro!]: "validFrom s []"
unfolding validFrom_def by auto

lemma validFrom_valid[simp,intro]: "valid tr \<and> srcOf (hd tr) = s \<Longrightarrow> validFrom s tr"
unfolding validFrom_def by auto

lemma validFrom_append:
"validFrom s (tr @ tr1) \<longleftrightarrow> (tr = [] \<and> validFrom s tr1) \<or> (tr \<noteq> [] \<and> validFrom s tr \<and> validFrom (tgtOf (last tr)) tr1)"
unfolding validFrom_def using valid_append
by (cases "tr = [] \<or> tr1 = []") fastforce+

lemma validFrom_Cons:
"validFrom s (trn # tr) \<longleftrightarrow> validTrans trn \<and> srcOf trn = s \<and> validFrom (tgtOf trn) tr"
unfolding validFrom_def by auto

subsubsection \<open>Reachability\<close>

(* Reachable states: *)
inductive reach :: "'state \<Rightarrow> bool" where
Istate: "reach istate"
|
Step: "reach s \<Longrightarrow> validTrans trn \<Longrightarrow> srcOf trn = s \<Longrightarrow> tgtOf trn = s' \<Longrightarrow> reach s'"

(* traces versus reachability: *)
lemma valid_reach_src_tgt:
assumes "valid tr" and "reach (srcOf (hd tr))"
shows "reach (tgtOf (last tr))"
using assms Step by induct auto

lemma valid_init_reach:
assumes "valid tr" and "srcOf (hd tr) = istate"
shows "reach (tgtOf (last tr))"
using valid_reach_src_tgt assms reach.Istate by metis

lemma reach_init_valid:
assumes "reach s"
shows
"s = istate
 \<or>
 (\<exists> tr. valid tr \<and> srcOf (hd tr) = istate \<and> tgtOf (last tr) = s)"
using assms proof induction
  case (Step s trn s')
  thus ?case proof(elim disjE exE conjE)
    assume s: "s = istate"
    show ?thesis
    apply (intro disjI2 exI[of _ "[trn]"])
    using s Step by auto
  next
    fix tr assume v: "valid tr" and s: "srcOf (hd tr) = istate" and t: "tgtOf (last tr) = s"
    show ?thesis
    apply (intro disjI2 exI[of _ "tr ## trn"])
    using Step v t s by (auto intro: valid_Rcons)
  qed
qed auto

lemma reach_validFrom:
assumes "reach s'"
shows "\<exists> s tr. s = istate \<and> (s = s' \<or> (validFrom s tr \<and> tgtOf (last tr) = s'))"
using reach_init_valid[OF assms] unfolding validFrom_def by auto

inductive reachFrom :: "'state \<Rightarrow> 'state \<Rightarrow> bool"
  for s :: "'state"
where
  Refl[intro]: "reachFrom s s"
| Step: "\<lbrakk>reachFrom s s'; validTrans trn; srcOf trn = s'; tgtOf trn = s''\<rbrakk> \<Longrightarrow> reachFrom s s''"

lemma reachFrom_Step1:
"\<lbrakk>validTrans trn; srcOf trn = s; tgtOf trn = s'\<rbrakk> \<Longrightarrow> reachFrom s s'"
by (auto intro: reachFrom.Step)

lemma reachFrom_Step_Left:
"reachFrom s' s'' \<Longrightarrow> validTrans trn \<Longrightarrow> srcOf trn = s \<Longrightarrow> tgtOf trn = s' \<Longrightarrow> reachFrom s s''"
by (induction s'' rule: reachFrom.induct) (auto intro: reachFrom.Step)

lemma reachFrom_trans: "reachFrom s0 s1 \<Longrightarrow> reachFrom s1 s2 \<Longrightarrow> reachFrom s0 s2"
by (induction s1 arbitrary: s2 rule: reachFrom.induct) (auto intro: reachFrom_Step_Left)

lemma reachFrom_reach: "reachFrom s s' \<Longrightarrow> reach s \<Longrightarrow> reach s'"
by (induction rule: reachFrom.induct) (auto intro: reach.Step)

lemma valid_validTrans_set:
assumes "valid tr" and "trn \<in>\<in> tr"
shows "validTrans trn"
using assms by (induct tr arbitrary: trn) auto

lemma validFrom_validTrans_set:
assumes "validFrom s tr" and "trn \<in>\<in> tr"
shows "validTrans trn"
by (metis assms validFrom_def empty_iff list.set valid_validTrans_set)

lemma valid_validTrans_nth:
assumes v: "valid tr" and i: "i < length tr"
shows "validTrans (tr!i)"
using valid_validTrans_set[OF v] i by auto

lemma valid_validTrans_nth_srcOf_tgtOf:
assumes v: "valid tr" and i: "Suc i < length tr"
shows "srcOf (tr!(Suc i)) = tgtOf (tr!i)"
by (metis Cons_nth_drop_Suc valid_append Suc_lessD append_self_conv2 hd_drop_conv_nth i id_take_nth_drop list.distinct(1) v valid_ConsE)

lemma validFrom_reach: "validFrom s tr \<Longrightarrow> reach s \<Longrightarrow> tr \<noteq> [] \<Longrightarrow> reach (tgtOf (last tr))"
by (intro valid_reach_src_tgt) (auto simp add: validFrom_def)

end (* locale Transition_System *)

(*<*)
end
(*>*)


theory Infra imports Main
begin

(******************************************************************************)
subsection \<open>Prover configuration\<close>
(******************************************************************************)

declare if_split_asm [split]

(******************************************************************************)
subsection \<open>Forward reasoning ("attributes")\<close>
(******************************************************************************)

text \<open>The following lemmas are used to produce intro/elim rules from
set definitions and relation definitions.\<close>

lemmas set_def_to_intro = eqset_imp_iff [THEN iffD2]
lemmas set_def_to_dest = eqset_imp_iff [THEN iffD1]
lemmas set_def_to_elim = set_def_to_dest [elim_format]

lemmas setc_def_to_intro =
  set_def_to_intro [where B="{x. P x}", simplified] for P

lemmas setc_def_to_dest =
  set_def_to_dest [where B="{x. P x}", simplified] for P

lemmas setc_def_to_elim = setc_def_to_dest [elim_format]

lemmas rel_def_to_intro = setc_def_to_intro [where x="(s, t)"] for s t
lemmas rel_def_to_dest = setc_def_to_dest [where x="(s, t)"] for s t
lemmas rel_def_to_elim = rel_def_to_dest [elim_format]

(******************************************************************************)
subsection \<open>General results\<close>
(******************************************************************************)

subsubsection \<open>Maps\<close>
(******************************************************************************)

text \<open>We usually remove @{term"domIff"} from the simpset and clasets due
to annoying behavior. Sometimes the lemmas below are more well-behaved than
@{term "domIff"}. Usually to be used as "dest: dom\_lemmas". However, adding
them as permanent dest rules slows down proofs too much, so we refrain from
doing this.\<close>

lemma map_definedness:
  "f x = Some y \<Longrightarrow> x \<in> dom f"
by (simp add: domIff)

lemma map_definedness_contra:
  "\<lbrakk> f x = Some y; z \<notin> dom f \<rbrakk> \<Longrightarrow> x \<noteq> z"
by (auto simp add: domIff)

lemmas dom_lemmas = map_definedness map_definedness_contra

subsubsection \<open>Set\<close>
(******************************************************************************)

declare image_comp[symmetric, simp]
(*
lemma image_comp [simp]: "(g o f)`A = g`f`A"
by (auto)
*)

lemma vimage_image_subset: "A \<subseteq> f-`(f`A)"
by (auto simp add: image_def vimage_def)

subsubsection \<open>Relations\<close>
(******************************************************************************)

lemma Image_compose [simp]:
  "(R1 O R2)``A  = R2``(R1``A)"
by (auto)

subsubsection \<open>Lists\<close>
(******************************************************************************)

lemma map_id: "map id = id"      (* already in simpset *)
by (simp)

\<comment> \<open>Do NOT add the following equation to the simpset! (looping)\<close>
lemma map_comp: "map (g o f) = map g o map f"
by (simp)

declare map_comp_map [simp del]

lemma take_prefix: "\<lbrakk> take n l = xs \<rbrakk> \<Longrightarrow> \<exists>xs'. l = xs @ xs'"
by (induct l arbitrary: n xs, auto)
   (case_tac n, auto)

subsubsection \<open>Finite sets\<close>
(******************************************************************************)

text \<open>Cardinality.\<close>

declare arg_cong [where f=card, intro]

lemma finite_positive_cardI [intro!]:
  "\<lbrakk> A \<noteq> {}; finite A \<rbrakk> \<Longrightarrow> 0 < card A"
by (auto)

lemma finite_positive_cardD [dest!]:
  "\<lbrakk> 0 < card A; finite A \<rbrakk> \<Longrightarrow> A \<noteq> {}"
by (auto)

lemma finite_zero_cardI [intro!]:
  "\<lbrakk> A = {}; finite A \<rbrakk> \<Longrightarrow> card A = 0"
by (auto)

lemma finite_zero_cardD [dest!]:
  "\<lbrakk> card A = 0; finite A \<rbrakk> \<Longrightarrow> A = {}"
by (auto)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_MSortBUIsSort
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun map :: "('a => 'b) => 'a list => 'b list" where
  "map f (nil2) = nil2"
| "map f (cons2 y xs) = cons2 (f y) (map f xs)"

fun lmerge :: "int list => int list => int list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if z <= x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun pairwise :: "(int list) list => (int list) list" where
  "pairwise (nil2) = nil2"
| "pairwise (cons2 xs (nil2)) = cons2 xs (nil2)"
| "pairwise (cons2 xs (cons2 ys xss)) =
     cons2 (lmerge xs ys) (pairwise xss)"

(*fun did not finish the proof*)
function mergingbu :: "(int list) list => int list" where
  "mergingbu (nil2) = nil2"
| "mergingbu (cons2 xs (nil2)) = xs"
| "mergingbu (cons2 xs (cons2 z x2)) =
     mergingbu (pairwise (cons2 xs (cons2 z x2)))"
  by pat_completeness auto

fun msortbu :: "int list => int list" where
  "msortbu x = mergingbu (map (% (y :: int) => cons2 y (nil2)) x)"

fun insert :: "int => int list => int list" where
  "insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if x <= z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "int list => int list" where
  "isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

theorem property0 :
  "((msortbu xs) = (isort xs))"
  oops

end


(*  Author: Tobias Nipkow  *)

header "Tries (List Version)"

theory Tries
imports Maps
begin

subsection {* Association lists *}

primrec rem_alist :: "'key \<Rightarrow> ('key * 'val)list \<Rightarrow>  ('key * 'val)list" where
"rem_alist k [] = []" |
"rem_alist k (p#ps) = (if fst p = k then ps else p # rem_alist k ps)"

lemma rem_alist_id[simp]: "k \<notin> fst ` set al \<Longrightarrow> rem_alist k al = al"
by(induct al, auto)

lemma set_rem_alist:
  "distinct(map fst al) \<Longrightarrow> set (rem_alist a al) =
   (set al) - {(a,the(map_of al a))}"
apply(induct al)
 apply simp
apply simp
apply fastforce
done

lemma fst_set_rem_alist[simp]:
  "distinct(map fst al) \<Longrightarrow> fst ` set (rem_alist a al) = fst ` (set al) - {a}"
apply(induct al)
 apply simp
apply simp
apply blast
done
(*
lemma fst_set_rem_alist[simp]:
  "set (rem_alist a al) = (set al) - {(a,map_of al a)}"
apply(induct al)
 apply simp
apply simp
apply blast
done
*)
lemma distinct_map_fst_rem_alist[simp]:
  "distinct (map fst al) \<Longrightarrow> distinct (map fst (rem_alist a al))"
by(induct al) simp_all

lemma map_of_rem_distinct_alist: "distinct(map fst al) \<Longrightarrow>
  map_of(rem_alist k al) = (map_of al)(k := None)"
apply(induct al)
 apply simp
apply clarify
apply(rule ext)
apply auto
apply(erule ssubst)
apply simp
done

lemma map_of_rem_alist[simp]:
 "k' \<noteq> k \<Longrightarrow> map_of (rem_alist k al) k' = map_of al k'"
by(induct al, auto)

subsection {* Tries *}

datatype ('a,'v)tries = Tries  "'v list"  "('a * ('a,'v)tries)list"

primrec "values" :: "('a,'v)tries \<Rightarrow> 'v list" where
  "values(Tries vs al) = vs"

primrec alist :: "('a,'v)tries \<Rightarrow> ('a * ('a,'v)tries)list" where
  "alist(Tries vs al) = al"

fun inv :: "('a,'v)tries \<Rightarrow> bool" where
"inv(Tries _ al) = (distinct(map fst al) & (\<forall>(a,t) \<in> set al. inv t))"

primrec lookup :: "('a,'v)tries \<Rightarrow> 'a list \<Rightarrow> 'v list" where
"lookup t [] = values t" |
"lookup t (a#as) = (case map_of (alist t) a of
                      None \<Rightarrow> []
                    | Some at \<Rightarrow> lookup at as)"

primrec update :: "('a,'v)tries \<Rightarrow> 'a list \<Rightarrow> 'v list \<Rightarrow> ('a,'v)tries" where
"update t []     vs = Tries vs (alist t)" |
"update t (a#as) vs =
   (let tt = (case map_of (alist t) a of
                None \<Rightarrow> Tries [] [] | Some at \<Rightarrow> at)
    in Tries (values t) ((a,update tt as vs) # rem_alist a (alist t)))"

primrec insert :: "('a,'v)tries \<Rightarrow> 'a list \<Rightarrow> 'v      \<Rightarrow> ('a,'v)tries" where
"insert t []     v = Tries (v # values t) (alist t)" |
"insert t (a#as) vs =
   (let tt = (case map_of (alist t) a of
                None \<Rightarrow> Tries [] [] | Some at \<Rightarrow> at)
    in Tries (values t) ((a,insert tt as vs) # rem_alist a (alist t)))"

lemma lookup_empty[simp]: "lookup (Tries [] []) as = []"
by(case_tac as, simp_all)

theorem lookup_update:
 "lookup (update t as vs) bs =
 (if as=bs then vs else lookup t bs)"
apply(induct as arbitrary: t v bs)
 apply clarsimp
 apply(case_tac bs)
  apply simp
 apply simp
apply clarsimp
apply(case_tac bs)
 apply (auto simp add:Let_def split:option.split)
done

theorem insert_conv:
 "insert t as v = update t as (v#lookup t as)"
apply(induct as arbitrary: t)
apply (auto simp:Let_def split:option.split)
done

lemma inv_insert: "inv t \<Longrightarrow> inv(insert t as v)"
apply(induct as arbitrary: t)
apply(case_tac t)
apply simp
apply(case_tac t)
apply simp
apply (auto simp:set_rem_alist split: option.split)
done

lemma inv_update: "inv t \<Longrightarrow> inv(update t as v)"
apply(induct as arbitrary: t)
apply(case_tac t)
apply simp
apply(case_tac t)
apply simp
apply (auto simp:set_rem_alist split: option.split)
done

definition trie_of_list :: "('b \<Rightarrow> 'a list) \<Rightarrow> 'b list \<Rightarrow> ('a,'b)tries" where
"trie_of_list key = foldl (%t v. insert t (key v) v) (Tries [] [])"

lemma inv_foldl_insert:
  "inv t \<Longrightarrow> inv (foldl (%t v. insert t (key v) v) t xs)"
apply(induct xs arbitrary: t)
apply(auto simp: inv_insert)
done

lemma inv_of_list: "inv (trie_of_list k xs)"
unfolding trie_of_list_def
apply(rule inv_foldl_insert)
apply simp
done

lemma in_set_lookup_of_list:
 "v \<in> set(lookup (trie_of_list key vs) (key v)) = (v \<in> set vs)"
proof -
  have "!!t.
 v \<in> set(lookup (foldl (%t v. insert t (key v) v) t vs) (key v)) =
 (v \<in> set vs \<union> set(lookup t (key v)))"
    apply(induct vs)
     apply (simp add:trie_of_list_def)
    apply (simp add:trie_of_list_def)
    apply(simp add:insert_conv lookup_update)
    apply blast
    done
  thus ?thesis by(simp add:trie_of_list_def)
qed

definition set_of :: "('a,'b)tries \<Rightarrow> 'b set" where
"set_of t = Union {gs. \<exists>a. gs = set(lookup t a)}"

lemma set_of_empty[simp]: "set_of (Tries [] []) = {}"
by(simp add: set_of_def)

lemma set_of_insert[simp]:
  "set_of (insert t a x) = Set.insert x (set_of t)"
by(auto simp: set_of_def insert_conv lookup_update)

lemma set_of_foldl_insert:
  "set_of (foldl (%t v. insert t (key v) v) t xs) =
   set xs Un set_of t"
by(induct xs arbitrary: t) auto

lemma set_of_of_list[simp]:
  "set_of(trie_of_list key xs) = set xs"
by(simp add: trie_of_list_def set_of_foldl_insert)

lemma in_set_lookup_set_ofD:
  "x\<in>set (lookup t a) \<Longrightarrow> x \<in> set_of t"
by(auto simp: set_of_def)

fun all :: "('v \<Rightarrow> bool) \<Rightarrow> ('a,'v)tries \<Rightarrow> bool" where
"all P (Tries vs al) =
 ((\<forall>v \<in> set vs. P v) \<and> (\<forall>(a,t) \<in> set al. all P t))"

interpretation map:
  maps "Tries [] []" update lookup inv
proof
  case goal1 show ?case by(rule ext) simp
next
  case goal2 show ?case by(rule ext) (simp add:lookup_update)
next
  case goal3 show ?case by(simp)
next
  case goal4 thus ?case by(simp add:inv_update)
qed

lemma set_of_conv: "set_of = maps.set_of lookup"
by(rule ext) (auto simp add: set_of_def map.set_of_def)

hide_const (open) inv lookup update insert set_of all

end


(* Author: Gerwin Klein, Tobias Nipkow *)

theory Big_Step imports "./Com" begin

subsection "Big-Step Semantics of Commands"

text {*
The big-step semantics is a straight-forward inductive definition
with concrete syntax. Note that the first parameter is a tuple,
so the syntax becomes @{text "(c,s) \<Rightarrow> s'"}.
*}

text_raw{*\snip{BigStepdef}{0}{1}{% *}
inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip: "(SKIP,s) \<Rightarrow> s" |
Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:
"\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
\<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
Or1: "(a, s1) \<Rightarrow> s2 \<Longrightarrow> (a OR b, s1) \<Rightarrow> s2" |
Or2: "(b, s1) \<Rightarrow> s2 \<Longrightarrow> (a OR b, s1) \<Rightarrow> s2"
text_raw{*}%endsnip*}

text_raw{*\snip{BigStepEx}{1}{2}{% *}
schematic_goal ex: "(''x'' ::= N 5;; ''y'' ::= V ''x'', s) \<Rightarrow> ?t"
apply(rule Seq)
apply(rule Assign)
apply simp
apply(rule Assign)
done
text_raw{*}%endsnip*}

thm ex[simplified]

text{* We want to execute the big-step rules: *}

code_pred big_step .

text{* For inductive definitions we need command
       \texttt{values} instead of \texttt{value}. *}

values "{t. (SKIP, \<lambda>_. 0) \<Rightarrow> t}"

text{* We need to translate the result state into a list
to display it. *}

values "{map t [''x''] |t. (SKIP, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x''] |t. (''x'' ::= N 2, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x'',''y''] |t.
  (WHILE Less (V ''x'') (V ''y'') DO (''x'' ::= Plus (V ''x'') (N 5)),
   <''x'' := 0, ''y'' := 13>) \<Rightarrow> t}"

text{* Proof automation: *}

text {* The introduction rules are good for automatically
construction small program executions. The recursive cases
may require backtracking, so we declare the set as unsafe
intro rules. *}
declare big_step.intros [intro]

text{* The standard induction rule
@{thm [display] big_step.induct [no_vars]} *}

thm big_step.induct

text{*
This induction schema is almost perfect for our purposes, but
our trick for reusing the tuple syntax means that the induction
schema has two parameters instead of the @{text c}, @{text s},
and @{text s'} that we are likely to encounter. Splitting
the tuple parameter fixes this:
*}
lemmas big_step_induct = big_step.induct[split_format(complete)]
thm big_step_induct
text {*
@{thm [display] big_step_induct [no_vars]}
*}

subsection "Rule inversion"

text{* What can we deduce from @{prop "(SKIP,s) \<Rightarrow> t"} ?
That @{prop "s = t"}. This is how we can automatically prove it: *}

inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"
thm SkipE

text{* This is an \emph{elimination rule}. The [elim] attribute tells auto,
blast and friends (but not simp!) to use it automatically; [elim!] means that
it is applied eagerly.

Similarly for the other commands: *}

inductive_cases AssignE[elim!]: "(x ::= a,s) \<Rightarrow> t"
thm AssignE
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
thm IfE
inductive_cases OrE[elim!]: "(a OR b, s) \<Rightarrow> t"

inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"
thm WhileE
text{* Only [elim]: [elim!] would not terminate. *}

text{* An automatic example: *}

lemma "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t \<Longrightarrow> t = s"
by blast

text{* Rule inversion by hand via the ``cases'' method: *}

lemma assumes "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t"
shows "t = s"
proof-
  from assms show ?thesis
  proof cases  --"inverting assms"
    case IfTrue thm IfTrue
    thus ?thesis by blast
  next
    case IfFalse thus ?thesis by blast
  qed
qed

(* Using rule inversion to prove simplification rules: *)
lemma assign_simp:
  "(x ::= a,s) \<Rightarrow> s' \<longleftrightarrow> (s' = s(x := aval a s))"
  by auto

text {* An example combining rule inversion and derivations *}
lemma Seq_assoc:
  "(c1;; c2;; c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
proof
  assume "(c1;; c2;; c3, s) \<Rightarrow> s'"
  then obtain s1 s2 where
    c1: "(c1, s) \<Rightarrow> s1" and
    c2: "(c2, s1) \<Rightarrow> s2" and
    c3: "(c3, s2) \<Rightarrow> s'" by auto
  from c2 c3
  have "(c2;; c3, s1) \<Rightarrow> s'" by (rule Seq)
  with c1
  show "(c1;; (c2;; c3), s) \<Rightarrow> s'" by (rule Seq)
next
  -- "The other direction is analogous"
  assume "(c1;; (c2;; c3), s) \<Rightarrow> s'"
  thus "(c1;; c2;; c3, s) \<Rightarrow> s'" by auto
qed

subsection "Command Equivalence"

text {*
  We call two statements @{text c} and @{text c'} equivalent wrt.\ the
  big-step semantics when \emph{@{text c} started in @{text s} terminates
  in @{text s'} iff @{text c'} started in the same @{text s} also terminates
  in the same @{text s'}}. Formally:
*}
text_raw{*\snip{BigStepEquiv}{0}{1}{% *}
abbreviation
  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"
text_raw{*}%endsnip*}

text {*
Warning: @{text"\<sim>"} is the symbol written \verb!\ < s i m >! (without spaces).

  As an example, we show that loop unfolding is an equivalence
  transformation on programs:
*}
lemma unfold_while:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)" (is "?w \<sim> ?iw")
proof -
  -- "to show the equivalence, we look at the derivation tree for"
  -- "each side and from that construct a derivation tree for the other side"
  { fix s t assume "(?w, s) \<Rightarrow> t"
    -- "as a first thing we note that, if @{text b} is @{text False} in state @{text s},"
    -- "then both statements do nothing:"
    { assume "\<not>bval b s"
      hence "t = s" using `(?w,s) \<Rightarrow> t` by blast
      hence "(?iw, s) \<Rightarrow> t" using `\<not>bval b s` by blast
    }
    moreover
    -- "on the other hand, if @{text b} is @{text True} in state @{text s},"
    -- {* then only the @{text WhileTrue} rule can have been used to derive @{text "(?w, s) \<Rightarrow> t"} *}
    { assume "bval b s"
      with `(?w, s) \<Rightarrow> t` obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      -- "now we can build a derivation tree for the @{text IF}"
      -- "first, the body of the True-branch:"
      hence "(c;; ?w, s) \<Rightarrow> t" by (rule Seq)
      -- "then the whole @{text IF}"
      with `bval b s` have "(?iw, s) \<Rightarrow> t" by (rule IfTrue)
    }
    ultimately
    -- "both cases together give us what we want:"
    have "(?iw, s) \<Rightarrow> t" by blast
  }
  moreover
  -- "now the other direction:"
  { fix s t assume "(?iw, s) \<Rightarrow> t"
    -- "again, if @{text b} is @{text False} in state @{text s}, then the False-branch"
    -- "of the @{text IF} is executed, and both statements do nothing:"
    { assume "\<not>bval b s"
      hence "s = t" using `(?iw, s) \<Rightarrow> t` by blast
      hence "(?w, s) \<Rightarrow> t" using `\<not>bval b s` by blast
    }
    moreover
    -- "on the other hand, if @{text b} is @{text True} in state @{text s},"
    -- {* then this time only the @{text IfTrue} rule can have be used *}
    { assume "bval b s"
      with `(?iw, s) \<Rightarrow> t` have "(c;; ?w, s) \<Rightarrow> t" by auto
      -- "and for this, only the Seq-rule is applicable:"
      then obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      -- "with this information, we can build a derivation tree for the @{text WHILE}"
      with `bval b s`
      have "(?w, s) \<Rightarrow> t" by (rule WhileTrue)
    }
    ultimately
    -- "both cases together again give us what we want:"
    have "(?w, s) \<Rightarrow> t" by blast
  }
  ultimately
  show ?thesis by blast
qed

text {* Luckily, such lengthy proofs are seldom necessary.  Isabelle can
prove many such facts automatically.  *}

lemma while_unfold:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)"
by blast

lemma triv_if:
  "(IF b THEN c ELSE c) \<sim> c"
by blast

lemma commute_if:
  "(IF b1 THEN (IF b2 THEN c11 ELSE c12) ELSE c2)
   \<sim>
   (IF b2 THEN (IF b1 THEN c11 ELSE c2) ELSE (IF b1 THEN c12 ELSE c2))"
by blast

lemma sim_while_cong_aux:
  "(WHILE b DO c,s) \<Rightarrow> t  \<Longrightarrow> c \<sim> c' \<Longrightarrow>  (WHILE b DO c',s) \<Rightarrow> t"
apply(induction "WHILE b DO c" s t arbitrary: b c rule: big_step_induct)
 apply blast
apply blast
done

lemma sim_while_cong: "c \<sim> c' \<Longrightarrow> WHILE b DO c \<sim> WHILE b DO c'"
by (metis sim_while_cong_aux)

text {* Command equivalence is an equivalence relation, i.e.\ it is
reflexive, symmetric, and transitive. Because we used an abbreviation
above, Isabelle derives this automatically. *}

lemma sim_refl:  "c \<sim> c" by simp
lemma sim_sym:   "(c \<sim> c') = (c' \<sim> c)" by auto
lemma sim_trans: "c \<sim> c' \<Longrightarrow> c' \<sim> c'' \<Longrightarrow> c \<sim> c''" by auto

lemma "(c1 OR c2) \<sim> (c2 OR c1)"
by auto

text_raw{*}%endsnip*}

end


(*  Title:      HOL/Proofs/Lambda/ListOrder.thy
    Author:     Tobias Nipkow
    Copyright   1998 TU Muenchen
*)

section \<open>Lifting an order to lists of elements\<close>

theory ListOrder
imports Main
begin

declare [[syntax_ambiguity_warning = false]]

text \<open>
  Lifting an order to lists of elements, relating exactly one
  element.
\<close>

definition
  step1 :: "('a => 'a => bool) => 'a list => 'a list => bool" where
  "step1 r =
    (\<lambda>ys xs. \<exists>us z z' vs. xs = us @ z # vs \<and> r z' z \<and> ys =
      us @ z' # vs)"

lemma step1_converse [simp]: "step1 (r^--1) = (step1 r)^--1"
  apply (unfold step1_def)
  apply (blast intro!: order_antisym)
  done

lemma in_step1_converse [iff]: "(step1 (r^--1) x y) = ((step1 r)^--1 x y)"
  apply auto
  done

lemma not_Nil_step1 [iff]: "\<not> step1 r [] xs"
  apply (unfold step1_def)
  apply blast
  done

lemma not_step1_Nil [iff]: "\<not> step1 r xs []"
  apply (unfold step1_def)
  apply blast
  done

lemma Cons_step1_Cons [iff]:
    "(step1 r (y # ys) (x # xs)) =
      (r y x \<and> xs = ys \<or> x = y \<and> step1 r ys xs)"
  apply (unfold step1_def)
  apply (rule iffI)
   apply (erule exE)
   apply (rename_tac ts)
   apply (case_tac ts)
    apply fastforce
   apply force
  apply (erule disjE)
   apply blast
  apply (blast intro: Cons_eq_appendI)
  done

lemma append_step1I:
  "step1 r ys xs \<and> vs = us \<or> ys = xs \<and> step1 r vs us
    ==> step1 r (ys @ vs) (xs @ us)"
  apply (unfold step1_def)
  apply auto
   apply blast
  apply (blast intro: append_eq_appendI)
  done

lemma Cons_step1E [elim!]:
  assumes "step1 r ys (x # xs)"
    and "!!y. ys = y # xs \<Longrightarrow> r y x \<Longrightarrow> R"
    and "!!zs. ys = x # zs \<Longrightarrow> step1 r zs xs \<Longrightarrow> R"
  shows R
  using assms
  apply (cases ys)
   apply (simp add: step1_def)
  apply blast
  done

lemma Snoc_step1_SnocD:
  "step1 r (ys @ [y]) (xs @ [x])
    ==> (step1 r ys xs \<and> y = x \<or> ys = xs \<and> r y x)"
  apply (unfold step1_def)
  apply (clarify del: disjCI)
  apply (rename_tac vs)
  apply (rule_tac xs = vs in rev_exhaust)
   apply force
  apply simp
  apply blast
  done

lemma Cons_acc_step1I [intro!]:
    "Wellfounded.accp r x ==> Wellfounded.accp (step1 r) xs \<Longrightarrow> Wellfounded.accp (step1 r) (x # xs)"
  apply (induct arbitrary: xs set: Wellfounded.accp)
  apply (erule thin_rl)
  apply (erule accp_induct)
  apply (rule accp.accI)
  apply blast
  done

lemma lists_accD: "listsp (Wellfounded.accp r) xs ==> Wellfounded.accp (step1 r) xs"
  apply (induct set: listsp)
   apply (rule accp.accI)
   apply simp
  apply (rule accp.accI)
  apply (fast dest: accp_downward)
  done

lemma ex_step1I:
  "[| x \<in> set xs; r y x |]
    ==> \<exists>ys. step1 r ys xs \<and> y \<in> set ys"
  apply (unfold step1_def)
  apply (drule in_set_conv_decomp [THEN iffD1])
  apply force
  done

lemma lists_accI: "Wellfounded.accp (step1 r) xs ==> listsp (Wellfounded.accp r) xs"
  apply (induct set: Wellfounded.accp)
  apply clarify
  apply (rule accp.accI)
  apply (drule_tac r=r in ex_step1I, assumption)
  apply blast
  done

end


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

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