theory Fib
imports Main
begin

subsection "Basic Functions"

text \<open>This set of basic functions assumes that the function to be tabulated (\<open>f\<close>)
has type \<open>nat \<Rightarrow> nat\<close>. This needs to be adjusted for other types.
In the worst case one may have to redefine these basic functions on the fly
to suit particular \<open>f\<close>'s.\<close>

type_synonym tab = "nat \<Rightarrow> nat option"

text \<open>Defined to avoid \<open>\<noteq> None\<close> because that gets modified by the standard
simplifier and rule setup.\<close>
definition is_None :: "'a option \<Rightarrow> bool" where
"is_None x = (x = None)"

text \<open>Partial correctness of table wrt function:\<close>
definition pcorrect :: "(nat \<Rightarrow> nat) \<Rightarrow> tab \<Rightarrow> bool" where
"pcorrect f t = (\<forall>i. \<not> is_None (t i) \<longrightarrow> the(t i) = f i)"

lemma pcorrect_upd:
  "pcorrect f t \<Longrightarrow> m = f n \<Longrightarrow> pcorrect f (t(n := Some m))"
by (simp add: pcorrect_def)

lemma pcorrect_not_None:
  "pcorrect f t \<Longrightarrow> m = f n \<Longrightarrow> \<not> is_None (t n) \<Longrightarrow> (t n = Some m) = True"
by(auto simp add: pcorrect_def is_None_def)

lemma map_le_updR: "t \<subseteq>\<^sub>m t' \<Longrightarrow> is_None (t n) \<Longrightarrow> t \<subseteq>\<^sub>m t'(n \<mapsto> m)"
by (metis is_None_def fun_upd_triv map_le_imp_upd_le)

lemma map_le_id_upR: "pcorrect f t \<Longrightarrow> f n = m \<Longrightarrow> t \<subseteq>\<^sub>m t(n \<mapsto> m)"
apply(simp add: pcorrect_def)
by (metis fun_upd_triv map_le_imp_upd_le map_le_refl map_le_updR option.exhaust_sel)

subsection "Application fib"

fun fib :: "nat \<Rightarrow> nat" where
"fib 0 = 0" |
"fib (Suc 0) = 1" |
"fib (Suc(Suc n)) = fib(Suc n) + fib n"

fun fib' :: "nat \<Rightarrow> tab \<Rightarrow> tab" where
"fib' 0 t = (if is_None (t 0) then t(0 := Some 0) else t)" |
"fib' (Suc 0) t = (if is_None (t 1) then t(1 := Some 1) else t)" |
"fib' (Suc(Suc n)) t = (if is_None(t (Suc(Suc n))) then
   let t1 = fib' (Suc n) t; t2 = fib' n t1
   in t2((Suc(Suc n)) := Some(the(t1(Suc n)) + the(t2 n))) else t)"

text \<open>A first proof where the proposition consists of 3 conjuncts:\<close>

lemma fib'_correct_aux: "pcorrect fib t \<Longrightarrow>
  t \<subseteq>\<^sub>m fib' n t \<and> pcorrect fib (fib' n t) \<and> fib' n t n = Some(fib n)"
proof(induction n arbitrary: t rule: fib.induct)
  case 1
  show ?case (is "?A \<and> ?B \<and> ?C")
  proof (intro conjI)
    show ?A using 1 by (simp add: map_le_id_upR del: fun_upd_apply)
    show ?B using 1 by(simp add: pcorrect_upd del: fun_upd_apply)
    show ?C using 1 using [[simp_depth_limit=3]] by (simp add: pcorrect_not_None)
  qed
next
  case 2
  show ?case (is "?A \<and> ?B \<and> ?C")
  proof (intro conjI)
    show ?A using 2 by (simp add: map_le_id_upR del: fun_upd_apply)
    show ?B using 2 by(simp add: pcorrect_upd del: fun_upd_apply)
    show ?C using 2 using [[simp_depth_limit=3]] by (simp add: pcorrect_not_None)
  qed
next
  case (3 n)
  note IH1 = "3.IH"(1)[OF "3.prems"]
  note IH2 = "3.IH"(2)[OF conjunct1[OF conjunct2[OF IH1]]]
  note map_le = map_le_trans[OF conjunct1[OF IH1] conjunct1[OF IH2]]
  note pcorr = conjunct1 [OF conjunct2[OF IH2]]
  note result1 = conjunct2 [OF conjunct2[OF IH1]]
  note result2 = conjunct2 [OF conjunct2[OF IH2]]
  show ?case (is "?A \<and> ?B \<and> ?C")
  proof (intro conjI)
    show ?A apply (auto simp: Let_def)
      by(erule map_le_updR[OF map_le])
    show ?B using "3.prems"
      apply(auto simp: result1 result2 Let_def)
      apply(rule pcorrect_upd[OF pcorr])
      apply simp
      done
    show ?C using "3.prems"
      by (simp add: result1 result2 Let_def pcorrect_not_None)
  qed
qed

corollary fib'_correct: "fib' n empty n = Some(fib n)"
using fib'_correct_aux[of empty n]
by(simp add: pcorrect_def is_None_def)

text \<open>Second proof where parts of the main proposition are hidden in a definition:\<close>

definition correct_tab :: "(nat \<Rightarrow> nat) \<Rightarrow> tab \<Rightarrow> tab \<Rightarrow> bool" where
"correct_tab f t t' = (t \<subseteq>\<^sub>m t' \<and> pcorrect f t')"

lemma pcorrect_if_correct_tab: "correct_tab f t t' \<Longrightarrow> pcorrect f t'"
by(simp add: correct_tab_def)

lemma correct_tab_id:
  "pcorrect f t \<Longrightarrow> correct_tab f t t"
by(auto simp: correct_tab_def)

lemma correct_tab_upd1:
  "pcorrect f t \<Longrightarrow> f n = m \<Longrightarrow> correct_tab f t (t(n \<mapsto> m))"
by(auto simp: correct_tab_def map_le_id_upR pcorrect_upd)

lemma correct_tab_upd2:
  "\<lbrakk> pcorrect f t; correct_tab f t t'; f n = m \<rbrakk>
  \<Longrightarrow> correct_tab f t (t'(n \<mapsto> m))"
by (meson correct_tab_def map_le_id_upR map_le_trans pcorrect_upd)

lemma correct_tab_trans:
  "correct_tab f t t' \<Longrightarrow> correct_tab f t' t'' \<Longrightarrow> correct_tab f t t''"
by(auto simp: correct_tab_def intro: map_le_trans)

lemma fib'_correct_aux2: "pcorrect fib t \<Longrightarrow>
  correct_tab fib t (fib' n t) \<and> fib' n t n = Some(fib n)"
proof(induction n arbitrary: t rule: fib.induct)
  case 1
  show ?case
    using 1 by (simp add: correct_tab_id correct_tab_upd1 pcorrect_not_None)
next
  case 2
  show ?case
    using 2 by (simp add: correct_tab_id correct_tab_upd1 pcorrect_not_None)
next
  case 3
  note IH1 = "3.IH"(1)[OF "3.prems"]
  note corrtab1 = conjunct1[OF IH1]
  note IH2 = "3.IH"(2)[OF pcorrect_if_correct_tab[OF corrtab1]]
  note corrtab2 = conjunct1[OF IH2]
  note corrtab12 = correct_tab_trans[OF corrtab1 corrtab2]
  note results = conjunct2[OF IH1] conjunct2[OF IH2]
  show ?case
    apply(auto simp: correct_tab_id[OF "3.prems"] pcorrect_not_None[OF "3.prems"] results Let_def)
    apply(rule correct_tab_upd2[OF "3.prems" corrtab12])
    by (simp add: results)
qed

corollary fib'_correct2: "fib' n empty n = Some(fib n)"
using fib'_correct_aux2[of empty n]
by(simp add: pcorrect_def is_None_def)

end


(*<*)
theory hw08bonustmpl
  imports
    Main
    "HOL-Data_Structures.Tree23_Set"
begin
(*>*)

fun join :: "'a tree23 \<Rightarrow> 'a tree23 \<Rightarrow> 'a up\<^sub>i"
where
  "join Leaf Leaf = T\<^sub>i Leaf"
| "join (Node2 t1 a t2) (Node2 t3 b t4) = (
    case (join t2 t3) of
      T\<^sub>i t23 \<Rightarrow> T\<^sub>i (Node3 t1 a t23 b t4)
    | Up\<^sub>i t2' x t3' \<Rightarrow> Up\<^sub>i (Node2 t1 a t2') x (Node2 t3' b t4)
  )"
| "join (Node2 t1 a t2) (Node3 t3 b t4 c t5) = (
    case (join t2 t3) of
      T\<^sub>i t23 \<Rightarrow> Up\<^sub>i (Node2 t1 a t23) b (Node2 t4 c t5)
    | Up\<^sub>i t2' x t3' \<Rightarrow> Up\<^sub>i (Node2 t1 a t2') x (Node3 t3' b t4 c t5)
)"
| "join (Node3 t1 a t2 b t3) (Node2 t4 c t5) = (
    case (join t3 t4) of
      T\<^sub>i t34 \<Rightarrow> Up\<^sub>i (Node2 t1 a t2) b (Node2 t34 c t5)
    | Up\<^sub>i t3' x t4' \<Rightarrow> Up\<^sub>i (Node2 t1 a t2) b (Node3 t3' x t4' c t5)
)"
| "join (Node3 t1 a t2 b t3) (Node3 t4 c t5 d t6) = (
    case (join t3 t4) of
      T\<^sub>i t34 \<Rightarrow> Up\<^sub>i (Node2 t1 a t2) b (Node3 t34 c t5 d t6)
    | Up\<^sub>i t3' x t4' \<Rightarrow> Up\<^sub>i (Node3 t1 a t2 b t3') x (Node3 t4' c t5 d t6)
)"
| "join _ _ = T\<^sub>i Leaf"

fun del' :: "'a::linorder \<Rightarrow> 'a tree23 \<Rightarrow> 'a up\<^sub>d" where
  "del' x Leaf = T\<^sub>d Leaf"
| "del' x (Node2 Leaf a Leaf) = (if (x = a) then (Up\<^sub>d Leaf) else T\<^sub>d(Node2 Leaf a Leaf))"
| "del' x (Node3 Leaf a Leaf b Leaf) = T\<^sub>d(if x = a then Node2 Leaf b Leaf else
     if x = b then Node2 Leaf a Leaf
     else Node3 Leaf a Leaf b Leaf)"
| "del' x (Node2 l a r) =  (case cmp x a of
     LT \<Rightarrow> node21 (del' x l) a r |
     GT \<Rightarrow> node22 l a (del' x r) |
     EQ \<Rightarrow>  T\<^sub>d(tree\<^sub>i(join l r)))"
|"del' x (Node3 l a m b r) =
  (case cmp x a of
     LT \<Rightarrow> node31 (del' x l) a m b r |
     EQ \<Rightarrow>  T\<^sub>d(Node2 tree\<^sub>i((join (l m)::'a tree23) d r)) |
     GT \<Rightarrow>
       (case cmp x b of
          LT \<Rightarrow> node32 l a (del x m) b r |
          EQ \<Rightarrow> let (b',r') = del_min r in node33 l a m b' r' |
          GT \<Rightarrow> node33 l a m b (del x r)))"

fun del :: "'a::linorder \<Rightarrow> 'a tree23 \<Rightarrow> 'a up\<^sub>d" where
"del x Leaf = T\<^sub>d Leaf" |
"del x (Node2 Leaf a Leaf) =
  (if x = a then Up\<^sub>d Leaf else T\<^sub>d(Node2 Leaf a Leaf))" |
"del x (Node3 Leaf a Leaf b Leaf) =
  T\<^sub>d(if x = a then Node2 Leaf b Leaf else
     if x = b then Node2 Leaf a Leaf
     else Node3 Leaf a Leaf b Leaf)" |
"del x (Node2 l a r) =
  (case cmp x a of
     LT \<Rightarrow> node21 (del x l) a r |
     GT \<Rightarrow> node22 l a (del x r) |
     EQ \<Rightarrow> let (a',t) = del_min r in node22 l a' t)" |
"del x (Node3 l a m b r) =
  (case cmp x a of
     LT \<Rightarrow> node31 (del x l) a m b r |
     EQ \<Rightarrow> let (a',m') = del_min m in node32 l a' m' b r |
     GT \<Rightarrow>
       (case cmp x b of
          LT \<Rightarrow> node32 l a (del x m) b r |
          EQ \<Rightarrow> let (b',r') = del_min r in node33 l a m b' r' |
          GT \<Rightarrow> node33 l a m b (del x r)))"

(* These are the two essential lemmas needed to instantiate the
  set_by_ordered infrastructure with the new del function:

  (You're not required to repeat the instantiation proof, just these two lemmas are enough. )
*)
lemma inorder_del': "\<lbrakk> bal t ; sorted(inorder t) \<rbrakk> \<Longrightarrow>
  inorder(tree\<^sub>d (del' x t)) = del_list x (inorder t)"
  sorry

lemma bal_tree\<^sub>d_del: "bal t \<Longrightarrow> bal(tree\<^sub>d(del' x t))"
  sorry

text \<open>A few hints:
  \<^item> Prove auxiliary lemmas on \<open>join\<close> that are suitable to discharge your proof obligations, and
    disable simplification of join for your main proof (\<open>declare join.simps[simp del]\<close>).
    This will make proof obligations more readable.
  \<^item> Case splitting by \<open>simp\<close> or \<open>auto\<close> may take quite a long time.
    Use \<open>split!:\<close> instead of \<open>split:\<close> to make it a bit faster.

\<close>

(* In case you are interested how to instantiate the infrastructure with
  the new delete function: *)

definition delete' :: "'a::linorder \<Rightarrow> 'a tree23 \<Rightarrow> 'a tree23" where
  "delete' x t = tree\<^sub>d(del' x t)"

interpretation Set_by_Ordered
where empty = Leaf and isin = isin and insert = insert and delete = delete'
and inorder = inorder and inv = bal
proof (standard, goal_cases)
  case 2 thus ?case by(simp add: isin_set)
next
  case 3 thus ?case by(simp add: inorder_insert)
next
  case 4 thus ?case by(simp add: delete'_def inorder_del')
next
  case 6 thus ?case by(simp add: bal_insert)
next
  case 7 thus ?case by(simp add: delete'_def bal_tree\<^sub>d_del)
qed simp+

(*<*)
end
(*>*)


(* Author: Tobias Nipkow *)

section \<open>Weight-Balanced Trees Have Logarithmic Height\<close>

text \<open>This theory is based on the original definition of weight-balanced trees
\cite{NievergeltR72,NievergeltR73}
where the size of the child of a node must be a minimum and a maximum fraction
of the size of the node.\<close>

theory Weight_Balanced_Trees_log
imports
  Complex_Main
  "HOL-Library.Tree"
begin

(* FIXME mod field_simps *)
lemmas neq0_if = less_imp_neq dual_order.strict_implies_not_eq

locale WBT0 =
fixes \<alpha> :: real
assumes alpha_pos: "0 < \<alpha>" and alpha_ub: "\<alpha> \<le> 1/2"
begin

fun wbt :: "'a tree \<Rightarrow> bool" where
"wbt Leaf = True" |
"wbt (Node l _ r) = (wbt l \<and> wbt r \<and> (let ratio = size1 l / (size1 l + size1 r)
  in \<alpha> \<le> ratio \<and> ratio \<le> 1 - \<alpha>))"

lemma height_size1_exp:
  "wbt t \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> 2 \<le> (1-\<alpha>) ^ (height t - 1) * size1 t"
proof(induction  t)
  case Leaf thus ?case by simp
next
  case (Node l a r)
  have 0: "0 \<le> (1 - \<alpha>) ^ k" for k using alpha_ub by simp
  let ?t = "Node l a r" let ?s = "size1 ?t"
  from Node.prems(1) have 1: "size1 l \<le> (1-\<alpha>) * ?s" and 2: "size1 r \<le> (1-\<alpha>) * ?s"
    by (auto simp: Let_def field_simps add_pos_pos neq0_if)
  show ?case
  proof (cases "l = Leaf \<and> r = Leaf")
    case True thus ?thesis by simp
  next
    case not_Leafs: False
    show ?thesis
    proof (cases "height l \<le> height r")
      case hlr: True
      hence r: "r \<noteq> Leaf" and hr: "height r \<noteq> 0" using not_Leafs by (auto)
      have "2 \<le> (1-\<alpha>) ^ (height r - 1) * size1 r"
        using Node.IH(2)[OF _ r] Node.prems by simp
      also have "\<dots> \<le> (1-\<alpha>) ^ (height r - 1) * ((1-\<alpha>) * ?s)"
        by(rule mult_left_mono[OF 2 0])
      also have "\<dots> = (1-\<alpha>) ^ (height r - 1 + 1) * ?s" by simp
      also have "\<dots> = (1-\<alpha>) ^ (height r) * ?s"
        using hr by (auto simp del: eq_height_0)
      finally show ?thesis using hlr by (simp)
    next
      case hlr: False
      hence l: "l \<noteq> Leaf" and hl: "height l \<noteq> 0" using not_Leafs by (auto)
      have "2 \<le> (1-\<alpha>) ^ (height l - 1) * size1 l"
        using Node.IH(1)[OF _ l] Node.prems by simp
      also have "\<dots> \<le> (1-\<alpha>) ^ (height l - 1) * ((1-\<alpha>) * ?s)"
        by(rule mult_left_mono[OF 1 0])
      also have "\<dots> = (1-\<alpha>) ^ (height l - 1 + 1) * ?s" by simp
      also have "\<dots> = (1-\<alpha>) ^ (height l) * ?s"
        using hl by (auto simp del: eq_height_0)
      finally show ?thesis using hlr by (simp)
    qed
  qed
qed

lemma height_size1_log: assumes "wbt t" "t \<noteq> Leaf"
shows "height t \<le> (log 2 (size1 t) - 1) / log 2 (1/(1-\<alpha>)) + 1"
proof -
  have "1 \<le> log 2 ((1-\<alpha>) ^ (height t - 1) * size1 t)"
    using height_size1_exp[OF assms] by simp
  hence "1 \<le> log 2 ((1-\<alpha>) ^ (height t - 1)) + log 2 (size1 t)"
    using alpha_ub by(simp add: log_mult)
  hence "1 \<le> (height t - 1) * log 2 (1-\<alpha>) + log 2 (size1 t)"
    using alpha_ub by(simp add: log_nat_power)
  hence "- (height t - 1) * log 2 (1-\<alpha>) \<le> log 2 (size1 t) - 1"
    by(simp add: algebra_simps)
  hence "(height t - 1) * log 2 (1/(1-\<alpha>)) \<le> log 2 (size1 t) - 1"
    using alpha_ub by(simp add: log_divide)
  hence "height t - 1 \<le> (log 2 (size1 t) - 1) / log 2 (1/(1-\<alpha>))"
    using alpha_pos alpha_ub by(simp add: field_simps log_divide)
  thus ?thesis by(simp)
qed

end

end


(*
Auction Theory Toolbox (http://formare.github.io/auctions/)

Authors:
* Marco B. Caminati http://caminati.co.nr
* Manfred Kerber <mnfrd.krbr@gmail.com>
* Christoph Lange <math.semantic.web@gmail.com>
* Colin Rowat <c.rowat@bham.ac.uk>

Dually licenced under
* Creative Commons Attribution (CC-BY) 3.0
* ISC License (1-clause BSD License)
See LICENSE file for details
(Rationale for this dual licence: http://arxiv.org/abs/1107.3212)
*)

section \<open>Locus where a function or a list (of linord type) attains its maximum value\<close>

theory Argmax
imports Main

begin

text \<open>Structural induction is used in proofs on lists.\<close>
lemma structInduct: assumes "P []" and "\<forall>x xs. P (xs) \<longrightarrow> P (x#xs)"
                    shows "P l"
      using assms list_nonempty_induct by (metis)

text \<open>the subset of elements of a set where a function reaches its maximum\<close>
fun argmax :: "('a \<Rightarrow> 'b::linorder) \<Rightarrow> 'a set \<Rightarrow> 'a set"
    where "argmax f A = { x \<in> A . f x = Max (f ` A) }"

(* For reasons we do not understand we have to duplicate the definition as a lemma
   in order to prove lm16 in CombinatorialAuctions.thy. *)
lemma argmaxLemma: "argmax f A = { x \<in> A . f x = Max (f ` A) }"
  by simp

lemma maxLemma:
  assumes "x \<in> X" "finite X"
  shows "Max (f`X) >= f x"
  (is "?L >= ?R") using assms
  by (metis (opaque_lifting, no_types) Max.coboundedI finite_imageI image_eqI)

lemma lm01:
  "argmax f A = A \<inter> f -` {Max (f ` A)}"
  by force

lemma lm02:
  assumes "y \<in> f`A"
  shows "A \<inter> f -` {y} \<noteq> {}"
  using assms by blast

lemma argmaxEquivalence:
  assumes "\<forall>x\<in>X. f x = g x"
  shows "argmax f X = argmax g X"
  using assms argmaxLemma Collect_cong image_cong
  by (metis(no_types,lifting))

text \<open>The arg max of a function over a non-empty set is non-empty.\<close>
corollary argmax_non_empty_iff: assumes "finite X" "X \<noteq> {}"
                                shows "argmax f X \<noteq>{}"
                                using assms Max_in finite_imageI image_is_empty lm01 lm02
                                by (metis(no_types))

text \<open>The previous definition of argmax operates on sets. In the following we define a corresponding notion on lists. To this end, we start with defining a filter predicate and are looking for the elements of a list satisfying a given predicate;
but, rather than returning them directly, we return the (sorted) list of their indices.
This is done, in different ways, by @{term filterpositions} and @{term filterpositions2}.\<close>

(* Given a list l, filterpositions yields the indices of its elements which satisfy a given pred P*)
definition filterpositions :: "('a => bool) => 'a list => nat list"
           where "filterpositions P l = map snd (filter (P o fst) (zip l (upt 0 (size l))))"
(* That is, you take the list [a0, a1, ..., an] pair with the indices [0, 1, ..., n], i.e., you get
   [(a0,0), (a1,1), ..., (an,n)] look where the predicate (P o fst) holds and return the list of the
   corresponding snd elements. *)

(* Alternative definition, making use of list comprehension. In the next line the type info is
   commented out, since the type inference can be left to Isabelle. *)
definition filterpositions2 (*  :: "('a => bool) => 'a list => nat list" *)
           where "filterpositions2 P l = [n. n \<leftarrow> [0..<size l], P (l!n)]"

definition maxpositions (*:: "'a::linorder list => nat list"*)
           where "maxpositions l = filterpositions2 (%x . x \<ge> Max (set l)) l"

lemma lm03: "maxpositions l = [n. n\<leftarrow>[0..<size l], l!n \<ge> Max(set l)]"
      unfolding maxpositions_def filterpositions2_def by fastforce

(* argmaxList takes a function and a list as arguments and looks for the positions of the elements at which the function applied to the list element is maximal, e.g.,
for the list [9, 3, 5, 9, 13] and the function `modulo 8', the function applied to the list would give the list [1, 3, 5, 1, 5], that is, argmaxList will return [2, 4]. *)
definition argmaxList (*:: "('a => ('b::linorder)) => 'a list => 'a list"*)
           where "argmaxList f l = map (nth l) (maxpositions (map f l))"

(* The following lemmas state some relationships between different representation such as map and list comprehension *)
lemma lm04: "[n . n <- l, P n] = [n . n <- l, n \<in> set l, P n]"
proof -
(*sledgehammer-generated proof.
  Commented out the first three lines (they look quite useless), making it more readable.
  assume "\<forall>v0. SMT2.fun_app uu__ v0 = (if P v0 then [v0] else [])"
  assume "\<forall>v0. SMT2.fun_app uua__ v0 = (if v0 \<in> set l then if P v0 then [v0] else [] else [])"
  obtain v3_0 :: "('a \<Rightarrow> 'a list) \<Rightarrow> 'a list \<Rightarrow> ('a \<Rightarrow> 'a list) \<Rightarrow> 'a" where *)
  have "map (\<lambda>uu. if P uu then [uu] else []) l =
    map (\<lambda>uu. if uu \<in> set l then if P uu then [uu] else [] else []) l" by simp
  thus "concat (map (\<lambda>n. if P n then [n] else []) l) =
    concat (map (\<lambda>n. if n \<in> set l then if P n then [n] else [] else []) l)" by presburger
qed

lemma lm05: "[n . n <- [0..<m], P n] = [n . n <- [0..<m], n \<in> set [0..<m], P n]"
      using lm04 by fast
 (* sledgehammer suggested:  concat_map_singleton map_ident  map_ext by smt*)

lemma lm06: fixes f m P
            shows "(map f [n . n <- [0..<m], P n]) = [ f n . n <- [0..<m], P n]"
      by (induct m) auto

(* Base case stating the property for the empty list *)
lemma map_commutes_a: "[f n . n <- [], Q (f n)] = [x <- (map f []). Q x]"
      by simp

(* Step case where the element x is added to the list xs *)
lemma map_commutes_b: "\<forall> x xs. ([f n . n <- xs,     Q (f n)] = [x <- (map f xs).     Q x] \<longrightarrow>
                                [f n . n <- (x#xs), Q (f n)] = [x <- (map f (x#xs)). Q x])"
      by simp

(* General case comprising the two previous cases. *)
lemma map_commutes: fixes f::"'a => 'b" fixes Q::"'b => bool" fixes xs::"'a list"
                    shows "[f n . n <- xs, Q (f n)] = [x <- (map f xs). Q x]"
      using map_commutes_a map_commutes_b structInduct by fast

lemma lm07: fixes f l
            shows "maxpositions (map f l) =
                   [n . n <- [0..<size l], f (l!n) \<ge> Max (f`(set l))]"
            (is "maxpositions (?fl) = _") (* Pattern matching abbreviation ?fl corresponds to (map f l). Used in the proof, not part of lemma itself *)
proof -
  have "maxpositions ?fl =
  [n. n <- [0..<size ?fl], n\<in> set[0..<size ?fl], ?fl!n \<ge> Max (set ?fl)]"
  using lm04 unfolding filterpositions2_def maxpositions_def .
  also have "... =
  [n . n <- [0..<size l], (n<size l), (?fl!n  \<ge> Max (set ?fl))]" by simp
  also have "... =
  [n . n <- [0..<size l], (n<size l) \<and> (f (l!n)  \<ge> Max (set ?fl))]"
  using nth_map by (metis (poly_guards_query, opaque_lifting)) also have "... =
  [n . n <- [0..<size l], (n\<in> set [0..<size l]),(f (l!n)  \<ge> Max (set ?fl))]"
  using atLeastLessThan_iff le0 set_upt by (metis(no_types))
  also have "... =
  [n . n <- [0..<size l], f (l!n) \<ge> Max (set ?fl)]" using lm05 by presburger
  finally show ?thesis by auto
qed

lemma lm08: fixes f l
            shows "argmaxList f l =
                   [ l!n . n <- [0..<size l], f (l!n) \<ge> Max (f`(set l))]"
      unfolding lm07 argmaxList_def by (metis lm06)

text\<open>The theorem expresses that argmaxList is the list of arguments greater equal the Max of the list.\<close>

theorem argmaxadequacy: fixes f::"'a => ('b::linorder)" fixes l::"'a list"
                        shows "argmaxList f l = [ x <- l. f x \<ge> Max (f`(set l))]"
                        (is "?lh=_") (* pattern match ?lh abbreviates "argmaxList f l" *)
proof -
  let ?P="% y::('b::linorder) . y \<ge> Max (f`(set l))"
  let ?mh="[nth l n . n <- [0..<size l], ?P (f (nth l n))]"
  let ?rh="[ x <- (map (nth l) [0..<size l]). ?P (f x)]"
  have "?lh = ?mh" using lm08 by fast
  also have "... = ?rh" using map_commutes by fast
  also have "...= [x <- l. ?P (f x)]" using map_nth by metis
  finally show ?thesis by force
qed

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>Lexical order on functions\<close>

theory Fun_Lexorder
imports Main
begin

definition less_fun :: "('a::linorder \<Rightarrow> 'b::linorder) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
where
  "less_fun f g \<longleftrightarrow> (\<exists>k. f k < g k \<and> (\<forall>k' < k. f k' = g k'))"

lemma less_funI:
  assumes "\<exists>k. f k < g k \<and> (\<forall>k' < k. f k' = g k')"
  shows "less_fun f g"
  using assms by (simp add: less_fun_def)

lemma less_funE:
  assumes "less_fun f g"
  obtains k where "f k < g k" and "\<And>k'. k' < k \<Longrightarrow> f k' = g k'"
  using assms unfolding less_fun_def by blast

lemma less_fun_asym:
  assumes "less_fun f g"
  shows "\<not> less_fun g f"
proof
  from assms obtain k1 where k1: "f k1 < g k1" "\<And>k'. k' < k1 \<Longrightarrow> f k' = g k'"
    by (blast elim!: less_funE)
  assume "less_fun g f" then obtain k2 where k2: "g k2 < f k2" "\<And>k'. k' < k2 \<Longrightarrow> g k' = f k'"
    by (blast elim!: less_funE)
  show False proof (cases k1 k2 rule: linorder_cases)
    case equal with k1 k2 show False by simp
  next
    case less with k2 have "g k1 = f k1" by simp
    with k1 show False by simp
  next
    case greater with k1 have "f k2 = g k2" by simp
    with k2 show False by simp
  qed
qed

lemma less_fun_irrefl:
  "\<not> less_fun f f"
proof
  assume "less_fun f f"
  then obtain k where k: "f k < f k"
    by (blast elim!: less_funE)
  then show False by simp
qed

lemma less_fun_trans:
  assumes "less_fun f g" and "less_fun g h"
  shows "less_fun f h"
proof (rule less_funI)
  from `less_fun f g` obtain k1 where k1: "f k1 < g k1" "\<And>k'. k' < k1 \<Longrightarrow> f k' = g k'"
    by (blast elim!: less_funE)
  from `less_fun g h` obtain k2 where k2: "g k2 < h k2" "\<And>k'. k' < k2 \<Longrightarrow> g k' = h k'"
    by (blast elim!: less_funE)
  show "\<exists>k. f k < h k \<and> (\<forall>k'<k. f k' = h k')"
  proof (cases k1 k2 rule: linorder_cases)
    case equal with k1 k2 show ?thesis by (auto simp add: exI [of _ k2])
  next
    case less with k2 have "g k1 = h k1" "\<And>k'. k' < k1 \<Longrightarrow> g k' = h k'" by simp_all
    with k1 show ?thesis by (auto intro: exI [of _ k1])
  next
    case greater with k1 have "f k2 = g k2" "\<And>k'. k' < k2 \<Longrightarrow> f k' = g k'" by simp_all
    with k2 show ?thesis by (auto intro: exI [of _ k2])
  qed
qed

lemma order_less_fun:
  "class.order (\<lambda>f g. less_fun f g \<or> f = g) less_fun"
  by (rule order_strictI) (auto intro: less_fun_trans intro!: less_fun_irrefl less_fun_asym)

lemma less_fun_trichotomy:
  assumes "finite {k. f k \<noteq> g k}"
  shows "less_fun f g \<or> f = g \<or> less_fun g f"
proof -
  { def K \<equiv> "{k. f k \<noteq> g k}"
    assume "f \<noteq> g"
    then obtain k' where "f k' \<noteq> g k'" by auto
    then have [simp]: "K \<noteq> {}" by (auto simp add: K_def)
    with assms have [simp]: "finite K" by (simp add: K_def)
    def q \<equiv> "Min K"
    then have "q \<in> K" and "\<And>k. k \<in> K \<Longrightarrow> k \<ge> q" by auto
    then have "\<And>k. \<not> k \<ge> q \<Longrightarrow> k \<notin> K" by blast
    then have *: "\<And>k. k < q \<Longrightarrow> f k = g k" by (simp add: K_def)
    from `q \<in> K` have "f q \<noteq> g q" by (simp add: K_def)
    then have "f q < g q \<or> f q > g q" by auto
    with * have "less_fun f g \<or> less_fun g f"
      by (auto intro!: less_funI)
  } then show ?thesis by blast
qed

end