theory T84
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=7,timeout=86400]
oops
end


theory sort_SSortIsSort
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

fun ssortminimum :: "int => int list => int" where
"ssortminimum x (Nil2) = x"
| "ssortminimum x (Cons2 z ys) =
     (if z <= x then ssortminimum z ys else ssortminimum x ys)"

fun insert2 :: "int => int list => int list" where
"insert2 x (Nil2) = Cons2 x (Nil2)"
| "insert2 x (Cons2 z xs) =
     (if x <= z then Cons2 x (Cons2 z xs) else Cons2 z (insert2 x xs))"

fun isort :: "int list => int list" where
"isort (Nil2) = Nil2"
| "isort (Cons2 y xs) = insert2 y (isort xs)"

fun delete :: "int => int list => int list" where
"delete x (Nil2) = Nil2"
| "delete x (Cons2 z ys) =
     (if x = z then ys else Cons2 z (delete x ys))"

fun ssort :: "int list => int list" where
"ssort (Nil2) = Nil2"
| "ssort (Cons2 y ys) =
     Cons2
       (ssortminimum y ys)
       (ssort (delete (ssortminimum y ys) (Cons2 y ys)))"

(*hipster ssortminimum insert2 isort delete ssort *)

theorem x0 :
  "!! (x :: int list) . (ssort x) = (isort x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(*
  File: Indexed_PQueue.thy
  Author: Bohua Zhan
*)

section \<open>Indexed priority queues\<close>

theory Indexed_PQueue
  imports Arrays_Ex Mapping_Str
begin

text \<open>
  Verification of indexed priority queue: functional part. The data
  structure is also verified by Lammich in
  \cite{Refine_Imperative_HOL-AFP}.
\<close>

subsection \<open>Successor functions, eq-pred predicate\<close>

fun s1 :: "nat \<Rightarrow> nat" where "s1 m = 2 * m + 1"
fun s2 :: "nat \<Rightarrow> nat" where "s2 m = 2 * m + 2"

lemma s_inj [forward]:
  "s1 m = s1 m' \<Longrightarrow> m = m'" "s2 m = s2 m' \<Longrightarrow> m = m'" by auto
lemma s_neq [resolve]:
  "s1 m \<noteq> s2 m'" "s1 m > m" "s2 m > m" "s2 m > s1 m" using s1.simps s2.simps by presburger+
setup \<open>add_forward_prfstep_cond @{thm s_neq(2)} [with_term "s1 ?m"]\<close>
setup \<open>add_forward_prfstep_cond @{thm s_neq(3)} [with_term "s2 ?m"]\<close>
setup \<open>add_forward_prfstep_cond @{thm s_neq(4)} [with_term "s2 ?m", with_term "s1 ?m"]\<close>

inductive eq_pred :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
  "eq_pred n n"
| "eq_pred n m \<Longrightarrow> eq_pred n (s1 m)"
| "eq_pred n m \<Longrightarrow> eq_pred n (s2 m)"
setup \<open>add_case_induct_rule @{thm eq_pred.cases}\<close>
setup \<open>add_prop_induct_rule @{thm eq_pred.induct}\<close>
setup \<open>add_resolve_prfstep @{thm eq_pred.intros(1)}\<close>
setup \<open>fold add_backward_prfstep @{thms eq_pred.intros(2,3)}\<close>

lemma eq_pred_parent1 [forward]:
  "eq_pred i (s1 k) \<Longrightarrow> i \<noteq> s1 k \<Longrightarrow> eq_pred i k"
@proof @let "v = s1 k" @prop_induct "eq_pred i v" @qed

lemma eq_pred_parent2 [forward]:
  "eq_pred i (s2 k) \<Longrightarrow> i \<noteq> s2 k \<Longrightarrow> eq_pred i k"
@proof @let "v = s2 k" @prop_induct "eq_pred i v" @qed

lemma eq_pred_cases:
  "eq_pred i j \<Longrightarrow> eq_pred (s1 i) j \<or> eq_pred (s2 i) j \<or> j = i \<or> j = s1 i \<or> j = s2 i"
@proof @prop_induct "eq_pred i j" @qed
setup \<open>add_forward_prfstep_cond @{thm eq_pred_cases} [with_cond "?i \<noteq> s1 ?k", with_cond "?i \<noteq> s2 ?k"]\<close>

lemma eq_pred_le [forward]: "eq_pred i j \<Longrightarrow> i \<le> j"
@proof @prop_induct "eq_pred i j" @qed

subsection \<open>Heap property\<close>

text \<open>The corresponding tree is a heap\<close>
definition is_heap :: "('a \<times> 'b::linorder) list \<Rightarrow> bool" where [rewrite]:
  "is_heap xs = (\<forall>i j. eq_pred i j \<longrightarrow> j < length xs \<longrightarrow> snd (xs ! i) \<le> snd (xs ! j))"

lemma is_heapD:
  "is_heap xs \<Longrightarrow> j < length xs \<Longrightarrow> eq_pred i j \<Longrightarrow> snd (xs ! i) \<le> snd (xs ! j)" by auto2
setup \<open>add_forward_prfstep_cond @{thm is_heapD} [with_term "?xs ! ?j"]\<close>
setup \<open>del_prfstep_thm_eqforward @{thm is_heap_def}\<close>

subsection \<open>Bubble-down\<close>

text \<open>The corresponding tree is a heap, except k is not necessarily smaller than its descendents.\<close>
definition is_heap_partial1 :: "('a \<times> 'b::linorder) list \<Rightarrow> nat \<Rightarrow> bool" where [rewrite]:
  "is_heap_partial1 xs k = (\<forall>i j. eq_pred i j \<longrightarrow> i \<noteq> k \<longrightarrow> j < length xs \<longrightarrow> snd (xs ! i) \<le> snd (xs ! j))"

text \<open>Two cases of switching with s1 k.\<close>
lemma bubble_down1:
  "s1 k < length xs \<Longrightarrow> is_heap_partial1 xs k \<Longrightarrow> snd (xs ! k) > snd (xs ! s1 k) \<Longrightarrow>
   snd (xs ! s1 k) \<le> snd (xs ! s2 k) \<Longrightarrow> is_heap_partial1 (list_swap xs k (s1 k)) (s1 k)" by auto2
setup \<open>add_forward_prfstep_cond @{thm bubble_down1} [with_term "list_swap ?xs ?k (s1 ?k)"]\<close>

lemma bubble_down2:
  "s1 k < length xs \<Longrightarrow> is_heap_partial1 xs k \<Longrightarrow> snd (xs ! k) > snd (xs ! s1 k) \<Longrightarrow>
   s2 k \<ge> length xs \<Longrightarrow> is_heap_partial1 (list_swap xs k (s1 k)) (s1 k)" by auto2
setup \<open>add_forward_prfstep_cond @{thm bubble_down2} [with_term "list_swap ?xs ?k (s1 ?k)"]\<close>

text \<open>One case of switching with s2 k.\<close>
lemma bubble_down3:
  "s2 k < length xs \<Longrightarrow> is_heap_partial1 xs k \<Longrightarrow> snd (xs ! s1 k) > snd (xs ! s2 k) \<Longrightarrow>
   snd (xs ! k) > snd (xs ! s2 k) \<Longrightarrow> xs' = list_swap xs k (s2 k) \<Longrightarrow> is_heap_partial1 xs' (s2 k)" by auto2
setup \<open>add_forward_prfstep_cond @{thm bubble_down3} [with_term "?xs'"]\<close>

subsection \<open>Bubble-up\<close>

fun par :: "nat \<Rightarrow> nat" where
  "par m = (m - 1) div 2"
setup \<open>register_wellform_data ("par m", ["m \<noteq> 0"])\<close>

lemma ps_inverse [rewrite]: "par (s1 k) = k" "par (s2 k) = k" by simp+

lemma p_basic: "m \<noteq> 0 \<Longrightarrow> par m < m" by auto
setup \<open>add_forward_prfstep_cond @{thm p_basic} [with_term "par ?m"]\<close>

lemma p_cases: "m \<noteq> 0 \<Longrightarrow> m = s1 (par m) \<or> m = s2 (par m)" by auto
setup \<open>add_forward_prfstep_cond @{thm p_cases} [with_term "par ?m"]\<close>

lemma eq_pred_p_next:
  "i \<noteq> 0 \<Longrightarrow> eq_pred i j \<Longrightarrow> eq_pred (par i) j"
@proof @prop_induct "eq_pred i j" @qed
setup \<open>add_forward_prfstep_cond @{thm eq_pred_p_next} [with_term "par ?i"]\<close>

lemma heap_implies_hd_min [resolve]:
  "is_heap xs \<Longrightarrow> i < length xs \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> snd (hd xs) \<le> snd (xs ! i)"
@proof
  @strong_induct i
  @case "i = 0" @apply_induct_hyp "par i"
  @have "eq_pred (par i) i"
@qed

text \<open>The corresponding tree is a heap, except k is not necessarily greater than its ancestors.\<close>
definition is_heap_partial2 :: "('a \<times> 'b::linorder) list \<Rightarrow> nat \<Rightarrow> bool" where [rewrite]:
  "is_heap_partial2 xs k = (\<forall>i j. eq_pred i j \<longrightarrow> j < length xs \<longrightarrow> j \<noteq> k \<longrightarrow> snd (xs ! i) \<le> snd (xs ! j))"

lemma bubble_up1 [forward]:
  "k < length xs \<Longrightarrow> is_heap_partial2 xs k \<Longrightarrow> snd (xs ! k) < snd (xs ! par k) \<Longrightarrow> k \<noteq> 0 \<Longrightarrow>
   is_heap_partial2 (list_swap xs k (par k)) (par k)" by auto2

lemma bubble_up2 [forward]:
  "k < length xs \<Longrightarrow> is_heap_partial2 xs k \<Longrightarrow> snd (xs ! k) \<ge> snd (xs ! par k) \<Longrightarrow> k \<noteq> 0 \<Longrightarrow>
   is_heap xs" by auto2
setup \<open>del_prfstep_thm @{thm p_cases}\<close>

subsection \<open>Indexed priority queue\<close>

type_synonym 'a idx_pqueue = "(nat \<times> 'a) list \<times> nat option list"

fun index_of_pqueue :: "'a idx_pqueue \<Rightarrow> bool" where
  "index_of_pqueue (xs, m) = (
    (\<forall>i<length xs. fst (xs ! i) < length m \<and> m ! (fst (xs ! i)) = Some i) \<and>
    (\<forall>i. \<forall>k<length m. m ! k = Some i \<longrightarrow> i < length xs \<and> fst (xs ! i) = k))"
setup \<open>add_rewrite_rule @{thm index_of_pqueue.simps}\<close>

lemma index_of_pqueueD1:
  "i < length xs \<Longrightarrow> index_of_pqueue (xs, m) \<Longrightarrow>
   fst (xs ! i) < length m \<and> m ! (fst (xs ! i)) = Some i" by auto2
setup \<open>add_forward_prfstep_cond @{thm index_of_pqueueD1} [with_term "?xs ! ?i"]\<close>

lemma index_of_pqueueD2 [forward]:
  "k < length m \<Longrightarrow> index_of_pqueue (xs, m) \<Longrightarrow>
   m ! k = Some i \<Longrightarrow> i < length xs \<and> fst (xs ! i) = k" by auto2

lemma index_of_pqueueD3 [forward]:
  "index_of_pqueue (xs, m) \<Longrightarrow> p \<in> set xs \<Longrightarrow> fst p < length m"
@proof @obtain i where "i < length xs" "xs ! i = p" @qed
setup \<open>del_prfstep_thm_eqforward @{thm index_of_pqueue.simps}\<close>

lemma has_index_unique_key [forward]:
  "index_of_pqueue (xs, m) \<Longrightarrow> unique_keys_set (set xs)"
@proof
  @have "\<forall>a x y. (a, x) \<in> set xs \<longrightarrow> (a, y) \<in> set xs \<longrightarrow> x = y" @with
    @obtain i where "i < length xs" "xs ! i = (a, x)"
    @obtain j where "j < length xs" "xs ! j = (a, y)"
  @end
@qed

lemma has_index_keys_of [rewrite]:
  "index_of_pqueue (xs, m) \<Longrightarrow> has_key_alist xs k \<longleftrightarrow> (k < length m \<and> m ! k \<noteq> None)"
@proof
  @case "has_key_alist xs k" @with
    @obtain v' where "(k, v') \<in> set xs"
    @obtain i where "i < length xs \<and> xs ! i = (k, v')"
  @end
@qed

lemma has_index_distinct [forward]:
  "index_of_pqueue (xs, m) \<Longrightarrow> distinct xs"
@proof
  @have "\<forall>i<length xs. \<forall>j<length xs. i \<noteq> j \<longrightarrow> xs ! i \<noteq> xs ! j"
@qed

subsection \<open>Basic operations on indexed\_queue\<close>

fun idx_pqueue_swap_fun :: "(nat \<times> 'a) list \<times> nat option list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> 'a) list \<times> nat option list" where
  "idx_pqueue_swap_fun (xs, m) i j = (
    list_swap xs i j, ((m [fst (xs ! i) := Some j]) [fst (xs ! j) := Some i]))"

lemma index_of_pqueue_swap [forward_arg]:
  "i < length xs \<Longrightarrow> j < length xs \<Longrightarrow> index_of_pqueue (xs, m) \<Longrightarrow>
   index_of_pqueue (idx_pqueue_swap_fun (xs, m) i j)"
@proof @unfold "idx_pqueue_swap_fun (xs, m) i j" @qed

lemma fst_idx_pqueue_swap [rewrite]:
  "fst (idx_pqueue_swap_fun (xs, m) i j) = list_swap xs i j"
@proof @unfold "idx_pqueue_swap_fun (xs, m) i j" @qed

lemma snd_idx_pqueue_swap [rewrite]:
  "length (snd (idx_pqueue_swap_fun (xs, m) i j)) = length m"
@proof @unfold "idx_pqueue_swap_fun (xs, m) i j" @qed

fun idx_pqueue_push_fun :: "nat \<Rightarrow> 'a \<Rightarrow> 'a idx_pqueue \<Rightarrow> 'a idx_pqueue" where
  "idx_pqueue_push_fun k v (xs, m) = (xs @ [(k, v)], list_update m k (Some (length xs)))"

lemma idx_pqueue_push_correct [forward_arg]:
  "index_of_pqueue (xs, m) \<Longrightarrow> k < length m \<Longrightarrow> \<not>has_key_alist xs k \<Longrightarrow>
   r = idx_pqueue_push_fun k v (xs, m) \<Longrightarrow>
   index_of_pqueue r \<and> fst r = xs @ [(k, v)] \<and> length (snd r) = length m"
@proof @unfold "idx_pqueue_push_fun k v (xs, m)" @qed

fun idx_pqueue_pop_fun :: "'a idx_pqueue \<Rightarrow> 'a idx_pqueue" where
  "idx_pqueue_pop_fun (xs, m) = (butlast xs, list_update m (fst (last xs)) None)"

lemma idx_pqueue_pop_correct [forward_arg]:
  "index_of_pqueue (xs, m) \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> r = idx_pqueue_pop_fun (xs, m) \<Longrightarrow>
   index_of_pqueue r \<and> fst r = butlast xs \<and> length (snd r) = length m"
@proof
  @unfold "idx_pqueue_pop_fun (xs, m)"
  @have "length xs = length (butlast xs) + 1"
  @have "fst (xs ! length (butlast xs)) < length m"  (* TODO: remove? *)
@qed

subsection \<open>Bubble up and down\<close>

function idx_bubble_down_fun :: "'a::linorder idx_pqueue \<Rightarrow> nat \<Rightarrow> 'a idx_pqueue" where
  "idx_bubble_down_fun (xs, m) k = (
    if s2 k < length xs then
      if snd (xs ! s1 k) \<le> snd (xs ! s2 k) then
        if snd (xs ! k) > snd (xs ! s1 k) then
          idx_bubble_down_fun (idx_pqueue_swap_fun (xs, m) k (s1 k)) (s1 k)
        else (xs, m)
      else
        if snd (xs ! k) > snd (xs ! s2 k) then
          idx_bubble_down_fun (idx_pqueue_swap_fun (xs, m) k (s2 k)) (s2 k)
        else (xs, m)
    else if s1 k < length xs then
      if snd (xs ! k) > snd (xs ! s1 k) then
        idx_bubble_down_fun (idx_pqueue_swap_fun (xs, m) k (s1 k)) (s1 k)
      else (xs, m)
    else (xs, m))"
  by pat_completeness auto
  termination by (relation "measure (\<lambda>((xs,_),k). (length xs - k))") (simp_all, auto2+)

lemma idx_bubble_down_fun_correct:
  "r = idx_bubble_down_fun x k \<Longrightarrow> is_heap_partial1 (fst x) k \<Longrightarrow>
   is_heap (fst r) \<and> mset (fst r) = mset (fst x) \<and> length (snd r) = length (snd x)"
@proof @fun_induct "idx_bubble_down_fun x k" @with
  @subgoal "(x = (xs, m), k = k)"
  @unfold "idx_bubble_down_fun (xs, m) k"
  @case "s2 k < length xs" @with
    @case "snd (xs ! s1 k) \<le> snd (xs ! s2 k)"
  @end
  @case "s1 k < length xs" @end
@qed
setup \<open>add_forward_prfstep_cond @{thm idx_bubble_down_fun_correct} [with_term "?r"]\<close>

lemma idx_bubble_down_fun_correct2 [forward]:
  "index_of_pqueue x \<Longrightarrow> index_of_pqueue (idx_bubble_down_fun x k)"
@proof @fun_induct "idx_bubble_down_fun x k" @with
  @subgoal "(x = (xs, m), k = k)"
  @unfold "idx_bubble_down_fun (xs, m) k"
  @case "s2 k < length xs" @with
    @case "snd (xs ! s1 k) \<le> snd (xs ! s2 k)"
  @end
  @case "s1 k < length xs" @end
@qed

fun idx_bubble_up_fun :: "'a::linorder idx_pqueue \<Rightarrow> nat \<Rightarrow> 'a idx_pqueue" where
  "idx_bubble_up_fun (xs, m) k = (
    if k = 0 then (xs, m)
    else if k < length xs then
      if snd (xs ! k) < snd (xs ! par k) then
        idx_bubble_up_fun (idx_pqueue_swap_fun (xs, m) k (par k)) (par k)
      else (xs, m)
    else (xs, m))"

lemma idx_bubble_up_fun_correct:
  "r = idx_bubble_up_fun x k \<Longrightarrow> is_heap_partial2 (fst x) k \<Longrightarrow>
   is_heap (fst r) \<and> mset (fst r) = mset (fst x) \<and> length (snd r) = length (snd x)"
@proof @fun_induct "idx_bubble_up_fun x k" @with
  @subgoal "(x = (xs, m), k = k)"
  @unfold "idx_bubble_up_fun (xs, m) k" @end
@qed
setup \<open>add_forward_prfstep_cond @{thm idx_bubble_up_fun_correct} [with_term "?r"]\<close>

lemma idx_bubble_up_fun_correct2 [forward]:
  "index_of_pqueue x \<Longrightarrow> index_of_pqueue (idx_bubble_up_fun x k)"
@proof @fun_induct "idx_bubble_up_fun x k" @with
  @subgoal "(x = (xs, m), k = k)"
  @unfold "idx_bubble_up_fun (xs, m) k" @end
@qed

subsection \<open>Main operations\<close>

fun delete_min_idx_pqueue_fun :: "'a::linorder idx_pqueue \<Rightarrow> (nat \<times> 'a) \<times> 'a idx_pqueue" where
  "delete_min_idx_pqueue_fun (xs, m) = (
    let (xs', m') = idx_pqueue_swap_fun (xs, m) 0 (length xs - 1);
        a'' = idx_pqueue_pop_fun (xs', m')
     in (last xs', idx_bubble_down_fun a'' 0))"

lemma delete_min_idx_pqueue_correct:
  "index_of_pqueue (xs, m) \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> res = delete_min_idx_pqueue_fun (xs, m) \<Longrightarrow>
   index_of_pqueue (snd res)"
@proof @unfold "delete_min_idx_pqueue_fun (xs, m)" @qed
setup \<open>add_forward_prfstep_cond @{thm delete_min_idx_pqueue_correct} [with_term "?res"]\<close>

lemma hd_last_swap_eval_last [rewrite]:
  "xs \<noteq> [] \<Longrightarrow> last (list_swap xs 0 (length xs - 1)) = hd xs"
@proof
  @let "xs' = list_swap xs 0 (length xs - 1)"
  @have "last xs' = xs' ! (length xs - 1)"
@qed

text \<open>Correctness of delete-min.\<close>
theorem delete_min_idx_pqueue_correct2:
  "is_heap xs \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> res = delete_min_idx_pqueue_fun (xs, m) \<Longrightarrow> index_of_pqueue (xs, m) \<Longrightarrow>
   is_heap (fst (snd res)) \<and> fst res = hd xs \<and> length (snd (snd res)) = length m \<and>
   map_of_alist (fst (snd res)) = delete_map (fst (fst res)) (map_of_alist xs)"
@proof @unfold "delete_min_idx_pqueue_fun (xs, m)"
  @let "xs' = list_swap xs 0 (length xs - 1)"
  @have "is_heap_partial1 (butlast xs') 0"
@qed
setup \<open>add_forward_prfstep_cond @{thm delete_min_idx_pqueue_correct2} [with_term "?res"]\<close>

fun insert_idx_pqueue_fun :: "nat \<Rightarrow> 'a::linorder \<Rightarrow> 'a idx_pqueue \<Rightarrow> 'a idx_pqueue" where
  "insert_idx_pqueue_fun k v x = (
    let x' = idx_pqueue_push_fun k v x in
      idx_bubble_up_fun x' (length (fst x') - 1))"

lemma insert_idx_pqueue_correct [forward_arg]:
  "index_of_pqueue (xs, m) \<Longrightarrow> k < length m \<Longrightarrow> \<not>has_key_alist xs k \<Longrightarrow>
   index_of_pqueue (insert_idx_pqueue_fun k v (xs, m))"
@proof @unfold "insert_idx_pqueue_fun k v (xs, m)" @qed

text \<open>Correctness of insertion.\<close>
theorem insert_idx_pqueue_correct2:
  "index_of_pqueue (xs, m) \<Longrightarrow> is_heap xs \<Longrightarrow> k < length m \<Longrightarrow> \<not>has_key_alist xs k \<Longrightarrow>
   r = insert_idx_pqueue_fun k v (xs, m) \<Longrightarrow>
   is_heap (fst r) \<and> length (snd r) = length m \<and>
   map_of_alist (fst r) = map_of_alist xs { k \<rightarrow> v }"
@proof @unfold "insert_idx_pqueue_fun k v (xs, m)"
  @have "is_heap_partial2 (xs @ [(k, v)]) (length xs)"
@qed
setup \<open>add_forward_prfstep_cond @{thm insert_idx_pqueue_correct2} [with_term "?r"]\<close>

fun update_idx_pqueue_fun :: "nat \<Rightarrow> 'a::linorder \<Rightarrow> 'a idx_pqueue \<Rightarrow> 'a idx_pqueue" where
  "update_idx_pqueue_fun k v (xs, m) = (
    if m ! k = None then
      insert_idx_pqueue_fun k v (xs, m)
    else let
      i = the (m ! k);
      xs' = list_update xs i (k, v)
    in
      if snd (xs ! i) \<le> v then idx_bubble_down_fun (xs', m) i
      else idx_bubble_up_fun (xs', m) i)"

lemma update_idx_pqueue_correct [forward_arg]:
  "index_of_pqueue (xs, m) \<Longrightarrow> k < length m \<Longrightarrow>
   index_of_pqueue (update_idx_pqueue_fun k v (xs, m))"
@proof @unfold "update_idx_pqueue_fun k v (xs, m)"
  @let "i = the (m ! k)"
  @let "xs' = list_update xs i (k, v)"
  @case "m ! k = None"
  @have "index_of_pqueue (xs', m)"
@qed

text \<open>Correctness of update.\<close>
theorem update_idx_pqueue_correct2:
  "index_of_pqueue (xs, m) \<Longrightarrow> is_heap xs \<Longrightarrow> k < length m \<Longrightarrow>
   r = update_idx_pqueue_fun k v (xs, m) \<Longrightarrow>
   is_heap (fst r) \<and> length (snd r) = length m \<and>
   map_of_alist (fst r) = map_of_alist xs { k \<rightarrow> v }"
@proof @unfold "update_idx_pqueue_fun k v (xs, m)"
  @let "i = the (m ! k)"
  @let "xs' = list_update xs i (k, v)"
  @have "xs' = fst (xs', m)" (* TODO: remove *)
  @case "m ! k = None"
  @case "snd (xs ! the (m ! k)) \<le> v" @with
    @have "is_heap_partial1 xs' i"
  @end
  @have "is_heap_partial2 xs' i"
@qed
setup \<open>add_forward_prfstep_cond @{thm update_idx_pqueue_correct2} [with_term "?r"]\<close>

end


(*
    File: Fisher_Yates.thy
    Author: Manuel Eberl, TU München

    Definition and correctness proofs for two variants of the
    Fisher-Yates shuffle, an algorithm to shuffle an array in-place
    in linear time, i.e. produce a permutation uniformly at random.
*)
section \<open>Fisher--Yates shuffle\<close>
theory Fisher_Yates
  imports "HOL-Probability.Probability"
begin

(* TODO Move *)

lemma integral_pmf_of_multiset:
  "A \<noteq> {#} \<Longrightarrow> (\<integral>x. (f x :: real) \<partial>measure_pmf (pmf_of_multiset A)) =
     (\<Sum>x\<in>set_mset A. of_nat (count A x) * f x) / of_nat (size A)"
  by (subst integral_measure_pmf[where A = "set_mset A"])
     (simp_all add: sum_divide_distrib mult_ac)

lemma pmf_bind_pmf_of_multiset:
  "A \<noteq> {#} \<Longrightarrow> pmf (pmf_of_multiset A \<bind> f) y =
     (\<Sum>x\<in>set_mset A. real (count A x) * pmf (f x) y) / real (size A)"
  by (simp add: pmf_bind integral_pmf_of_multiset)

lemma pmf_map_inj_inv:
  assumes "inj_on f (set_pmf p)"
  assumes "\<And>x. f' (f x) = x"
  shows   "pmf (map_pmf f p) x = (if x \<in> range f then pmf p (f' x) else 0)"
proof (cases "x \<in> f ` set_pmf p")
  case True
  from this obtain y where y: "y \<in> set_pmf p" "x = f y" by blast
  with assms(1) have "pmf (map_pmf f p) x = pmf p y"
    by (simp add: pmf_map_inj)
  also from y assms(2)[of y] have "y = f' x" by simp
  finally show ?thesis using y by simp
next
  case False
  hence "x \<notin> set_pmf (map_pmf f p)" by simp
  hence "pmf (map_pmf f p) x = 0" by (simp add: set_pmf_eq)
  also from False have "0 = (if x \<in> range f then pmf p (f' x) else 0)"
    by (auto simp: assms(2) set_pmf_eq)
  finally show ?thesis .
qed
(* END MOVE *)

subsection \<open>Swapping elements in a list\<close>

definition swap where "swap xs i j = xs[i := xs!j, j := xs ! i]"

lemma length_swap [simp]: "length (swap xs i j) = length xs"
  by (simp add: swap_def)

lemma swap_eq_Nil_iff [simp]: "swap xs i j = [] \<longleftrightarrow> xs = []"
  by (simp add: swap_def)

lemma nth_swap: "i < length xs \<Longrightarrow> j < length xs \<Longrightarrow>
    swap xs i j ! k = (if k = i then xs ! j else if k = j then xs ! i else xs ! k)"
  by (auto simp: swap_def nth_list_update)

lemma map_swap: "i < length xs \<Longrightarrow> j < length xs \<Longrightarrow> map f (swap xs i j) = swap (map f xs) i j"
  by (simp add: swap_def map_update map_nth)

lemma swap_swap: "i < length xs \<Longrightarrow> j < length xs \<Longrightarrow> swap (swap xs i j) j i = xs"
  by (intro nth_equalityI) (auto simp: nth_swap nth_list_update)

lemma mset_swap: "i < length xs \<Longrightarrow> j < length xs \<Longrightarrow> mset (swap xs i j) = mset xs"
  by (simp add: mset_update swap_def nth_list_update)

lemma hd_swap_0: "i < length xs \<Longrightarrow> hd (swap xs 0 i) = xs ! i"
  unfolding swap_def by (subst hd_conv_nth) (subst nth_list_update | force)+

subsection \<open>Random Permutations\<close>

text \<open>
  First, we prove the intuitively obvious fact that choosing a random
  permutation of a multiset can be done by first randomly choosing the
  first element and then randomly choosing the rest of the list.
\<close>

lemma pmf_of_set_permutations_of_multiset_nonempty:
  assumes "(A :: 'a multiset) \<noteq> {#}"
  shows "pmf_of_set (permutations_of_multiset A) =
           do {x \<leftarrow> pmf_of_multiset A;
               xs \<leftarrow> pmf_of_set (permutations_of_multiset (A - {#x#}));
               return_pmf (x#xs)
              }" (is "?lhs = ?rhs")
proof (rule pmf_eqI)
  fix xs :: "'a list"
  show "pmf ?lhs xs = pmf ?rhs xs"
  proof (cases "xs \<in> permutations_of_multiset A")
    case False
    with assms have "xs \<notin> set_pmf ?lhs" by simp
    moreover from assms False have "xs \<notin> set_pmf ?rhs"
      by (auto simp: permutations_of_multiset_Cons_iff)
    ultimately show ?thesis by (simp add: set_pmf_eq)
  next
    case True
    with assms have nonempty: "xs \<noteq> []" by (auto dest: permutations_of_multisetD)
    hence range_Cons: "xs \<in> range ((#) x) \<longleftrightarrow> hd xs = x" for x
      by (cases xs) auto
    from True nonempty
      have hd_tl: "hd xs \<in># A \<and> tl xs \<in> permutations_of_multiset (A - {#hd xs#})"
      by (cases xs) (auto simp: permutations_of_multiset_Cons_iff)

    from assms have "pmf ?rhs xs =
      (\<Sum>x\<in>set_mset A. real (count A x) * pmf (map_pmf ((#) x)
        (pmf_of_set (permutations_of_multiset (A - {#x#})))) xs) / real (size A)" (is "_ = ?S / _")
      unfolding map_pmf_def [symmetric] by (simp add: pmf_bind_pmf_of_multiset)
    also have "?S =
      (\<Sum>x\<in>set_mset A. if x = hd xs then real (count A (hd xs)) /
         real (card (permutations_of_multiset (A - {#hd xs#}))) else 0)"
      using range_Cons hd_tl
      by (intro sum.cong refl, subst pmf_map_inj_inv[where f' = tl]) auto
    also have "\<dots> = real (count A (hd xs)) /
                      real (card (permutations_of_multiset (A - {#hd xs#})))"
      using hd_tl by (simp add: sum.delta)
    also from hd_tl have "\<dots> = real (size A) / real (card (permutations_of_multiset A))"
      by (simp add: divide_simps real_card_permutations_of_multiset_remove[of "hd xs"])
    also have " \<dots> / real (size A) = pmf (pmf_of_set (permutations_of_multiset A)) xs"
      using assms True by simp
    finally show ?thesis ..
  qed
qed

subsection \<open>Shuffling Lists\<close>

text \<open>
  We define shuffling of a list as choosing from the set of all lists
  that correspond to the same multiset uniformly at random.
\<close>
definition shuffle :: "'a list \<Rightarrow> 'a list pmf" where
  "shuffle xs = pmf_of_set (permutations_of_multiset (mset xs))"

lemma shuffle_empty [simp]: "shuffle [] = return_pmf []"
  by (simp add: shuffle_def pmf_of_set_singleton)

lemma shuffle_singleton [simp]: "shuffle [x] = return_pmf [x]"
  by (simp add: shuffle_def pmf_of_set_singleton)

text \<open>
  The crucial ingredient of the Fisher--Yates shuffle is the following lemma,
  which decomposes a shuffle into swapping the first element of the list with
  a random element of the remaining list and shuffling the new remaining list.

  With a random-access implementation of a list -- such as an array -- all of
  the required operations are cheap and the resulting algorithm runs in linear
  time.
\<close>
lemma shuffle_fisher_yates_step:
  assumes xs_nonempty [simp]: "xs \<noteq> []"
  shows "shuffle xs =
           do {i \<leftarrow> pmf_of_set {..<length xs};
               let ys = swap xs 0 i;
               zs \<leftarrow> shuffle (tl ys);
               return_pmf (hd ys # zs)
              }"
proof -
  have "shuffle xs = do {x \<leftarrow> pmf_of_multiset (mset xs);
             xs \<leftarrow> pmf_of_set (permutations_of_multiset (mset xs - {#x#}));
             return_pmf (x#xs)
            }" unfolding shuffle_def
    by (simp add: pmf_of_set_permutations_of_multiset_nonempty)
  also have "pmf_of_multiset (mset xs) =
               pmf_of_multiset (image_mset ((!) xs) (mset (upt 0 (length xs))))"
    by (subst mset_map [symmetric]) (simp add: map_nth)
  also have "\<dots> = map_pmf ((!) xs) (pmf_of_set {..<length xs})"
    by (subst map_pmf_of_set) (auto simp add: map_pmf_of_set atLeast0LessThan lessThan_empty_iff)
  also have "do {x \<leftarrow> map_pmf ((!) xs) (pmf_of_set {..<length xs});
                 ys \<leftarrow> pmf_of_set (permutations_of_multiset (mset xs - {#x#}));
                 return_pmf (x # ys)
                } =
             do {i \<leftarrow> pmf_of_set {..<length xs};
                 ys \<leftarrow> pmf_of_set (permutations_of_multiset (mset xs - {#xs ! i#}));
                 return_pmf (xs ! i # ys)
                }"
    by (simp add: map_pmf_def bind_assoc_pmf bind_return_pmf)
  also have "\<dots> = do {i \<leftarrow> pmf_of_set {..<length xs};
                      let ys = swap xs 0 i;
                      zs \<leftarrow> shuffle (tl (swap xs 0 i));
                      return_pmf (hd ys # zs)
                     }" unfolding Let_def shuffle_def
    by (intro bind_pmf_cong refl, subst (asm) set_pmf_of_set)
       (auto simp: lessThan_empty_iff mset_tl mset_swap hd_swap_0)
  finally show ?thesis by (simp add: Let_def)
qed

subsection \<open>Forward Fisher-Yates Shuffle\<close>

text \<open>
  The actual Fisher--Yates shuffle is now merely a kind of tail-recursive version of
  decomposition described above. Note that unlike the traditional Fisher--Yates shuffle,
  we shuffle the list from front to back, which is the more natural way to do it when
  working with linked lists.
\<close>

function fisher_yates_aux where
  "fisher_yates_aux i xs = (if i + 1 \<ge> length xs then return_pmf xs else
     do {j \<leftarrow> pmf_of_set {i..<length xs};
         fisher_yates_aux (i + 1) (swap xs i j)})"
by auto
termination by (relation "Wellfounded.measure (\<lambda>(i,xs). length xs - i)") simp_all

declare fisher_yates_aux.simps [simp del]

lemma fisher_yates_aux_correct:
  "fisher_yates_aux i xs = map_pmf (\<lambda>ys. take i xs @ ys) (shuffle (drop i xs))"
proof (induction i xs rule: fisher_yates_aux.induct)
  case (1 i xs)
  show ?case
  proof (cases "i + 1 \<ge> length xs")
    case True
    show ?thesis
    proof (cases "i \<ge> length xs")
      case False
      with True have "length xs = Suc i" and i: "i = length xs - 1" by simp_all
      hence "xs \<noteq> []" by auto
      hence "xs = butlast xs @ [last xs]" by (rule append_butlast_last_id [symmetric])
      also have "butlast xs = take i xs" by (simp add: butlast_conv_take i)
      finally have eq: "take i xs @ [last xs] = xs" ..
      moreover have "xs = take i xs @ drop i xs" by simp
      ultimately have "take i xs @ [last xs] = take i xs @ drop i xs" by (rule trans)
      hence "drop i xs = [last xs]" by (subst (asm) same_append_eq) simp_all
      with True show ?thesis by (simp add: eq fisher_yates_aux.simps)
    qed (simp_all add: fisher_yates_aux.simps)
  next
    case False
    from False have xs_nonempty [simp]: "xs \<noteq> []" by auto
    have "fisher_yates_aux i xs =
             pmf_of_set {i..<length xs} \<bind> (\<lambda>j. fisher_yates_aux (i+1) (swap xs i j))"
      using False by (subst fisher_yates_aux.simps) simp
    also have "{i..<length xs} = ((\<lambda>j. j + i) ` {..<length xs - i})"
      using False by (simp add: lessThan_atLeast0)
    also from False have "pmf_of_set \<dots> = map_pmf (\<lambda>j. j + i) (pmf_of_set {..<length xs - i})"
      by (subst map_pmf_of_set_inj) (simp_all add: lessThan_empty_iff)
    also from False have "length xs - i = length (drop i xs)" by simp
    also have "map_pmf (\<lambda>j. j + i) (pmf_of_set {..<length (drop i xs)}) \<bind>
                   (\<lambda>j. fisher_yates_aux (i + 1) (swap xs i j)) =
               pmf_of_set {..<length (drop i xs)} \<bind> (\<lambda>j. fisher_yates_aux (i + 1) (swap xs i (j+i)))"
      by (simp add: map_pmf_def bind_return_pmf bind_assoc_pmf)
    also have "\<dots> = do {j \<leftarrow> pmf_of_set {..<length (drop i xs)};
                        let ys = swap (drop i xs) 0 j;
                        zs \<leftarrow> shuffle (tl ys);
                        return_pmf (take i xs @ hd ys # zs)}" (is "_ = bind_pmf _ ?T")
    proof (intro bind_pmf_cong refl)
      fix j assume "j \<in> set_pmf (pmf_of_set {..<length (drop i xs)})"
      with False have j: "j < length (drop i xs)" by (simp_all add: lessThan_empty_iff)
      define ys where "ys = swap xs i (j + i)"
      have "fisher_yates_aux (i + 1) ys = map_pmf ((@) (take (i+1) ys)) (shuffle (drop (i+1) ys))"
        using False j unfolding ys_def by (intro "1.IH") simp_all
      also from False have "take (i+1) ys = take i ys @ [hd (drop i ys)]"
        by (simp add: ys_def take_hd_drop)
      also have "drop (i+1) ys = tl (drop i ys)" by (simp add: ys_def tl_drop drop_Suc)
      also from False j have "drop i ys = swap (drop i xs) 0 j"
        by (simp add: ys_def swap_def drop_update_swap add_ac)
      also from False j have "take i ys = take i xs"
        by (simp add: ys_def swap_def)
      finally show "fisher_yates_aux (i + 1) ys = ?T j"
        by (simp add: ys_def map_pmf_def Let_def bind_assoc_pmf bind_return_pmf)
    qed
    also from False have "\<dots> = map_pmf (\<lambda>zs. take i xs @ zs) (shuffle (drop i xs))"
      by (subst shuffle_fisher_yates_step[of "drop i xs"])
         (simp_all add: map_pmf_def Let_def bind_return_pmf bind_assoc_pmf)
    finally show ?thesis .
  qed
qed

definition fisher_yates where
  "fisher_yates = fisher_yates_aux 0"

lemma fisher_yates_correct: "fisher_yates xs = shuffle xs"
  unfolding fisher_yates_def
  by (subst fisher_yates_aux_correct) (simp_all add: map_pmf_def bind_return_pmf')

subsection \<open>Backwards Fisher-Yates Shuffle\<close>

text \<open>
  We can now easily derive the classical Fisher--Yates shuffle, which goes through
  the list from back to front and show its equivalence to the forward Fisher--Yates
  shuffle.
\<close>
fun fisher_yates_alt_aux where
  "fisher_yates_alt_aux i xs = (if i = 0 then return_pmf xs else
     do {j \<leftarrow> pmf_of_set {..i};
         fisher_yates_alt_aux (i - 1) (swap xs i j)})"

declare fisher_yates_alt_aux.simps [simp del]

lemma fisher_yates_alt_aux_altdef:
  "i < length xs \<Longrightarrow> fisher_yates_alt_aux i xs =
     map_pmf rev (fisher_yates_aux (length xs - i - 1) (rev xs))"
proof (induction i xs rule: fisher_yates_alt_aux.induct)
  case (1 i xs)
  show ?case
  proof (cases "i = 0")
    case False
    with "1.prems" have "map_pmf rev (fisher_yates_aux (length xs - i - 1) (rev xs)) =
      pmf_of_set {length xs - Suc i..<length xs} \<bind>
        (\<lambda>x. fisher_yates_aux (Suc (length xs - Suc i))
          (swap (rev xs) (length xs - Suc i) x) \<bind>
            (\<lambda>x. return_pmf (rev x)))"
      by (subst fisher_yates_aux.simps) (auto simp: map_pmf_def bind_return_pmf bind_assoc_pmf)
    also from "1.prems" False
      have bij: "bij_betw (\<lambda>j. length xs - Suc j) {..i} {length xs - Suc i..<length xs}"
      by (intro bij_betwI[where g = "\<lambda>j. length xs - Suc j"]) auto
    from bij have "{length xs - Suc i..<length xs} = (\<lambda>j. length xs - Suc j) ` {..i}"
      by (simp add: bij_betw_def)
    also from bij have "pmf_of_set \<dots> = map_pmf (\<lambda>j. length xs - Suc j) (pmf_of_set {..i})"
      by (subst map_pmf_of_set_inj) (auto simp: bij_betw_def)
    also have "map_pmf (\<lambda>j. length xs - Suc j) (pmf_of_set {..i}) \<bind>
                 (\<lambda>x. fisher_yates_aux (Suc (length xs - Suc i))
                   (swap (rev xs) (length xs - Suc i) x) \<bind> (\<lambda>x. return_pmf (rev x))) =
               pmf_of_set {..i} \<bind> (\<lambda>x. map_pmf rev (
                 fisher_yates_aux (length xs - i) (rev (swap xs i x))))"
      using "1.prems" False
      by (auto simp add: map_pmf_def bind_assoc_pmf bind_return_pmf Suc_diff_Suc
            swap_def rev_update rev_nth intro!: bind_pmf_cong)
    also have "\<dots> = pmf_of_set {..i} \<bind> (\<lambda>j. fisher_yates_alt_aux (i - 1) (swap xs i j))"
      using "1.prems" False "1.IH" [symmetric] by (auto intro!: bind_pmf_cong)
    also from "1.prems" False have "\<dots> = fisher_yates_alt_aux i xs"
      by (subst fisher_yates_alt_aux.simps[of i]) simp_all
    finally show ?thesis ..
  qed (insert "1.prems", simp_all add: fisher_yates_aux.simps fisher_yates_alt_aux.simps)
qed

definition fisher_yates_alt where
  "fisher_yates_alt xs = fisher_yates_alt_aux (length xs - 1) xs"

lemma fisher_yates_alt_aux_correct:
  "fisher_yates_alt xs = shuffle xs"
proof (cases "xs = []")
  case True
  thus ?thesis
    by (simp add: fisher_yates_alt_def fisher_yates_alt_aux.simps)
next
  case False
  thus ?thesis unfolding fisher_yates_alt_def
    by (subst fisher_yates_alt_aux_altdef)
       (simp_all add: fisher_yates_aux_correct shuffle_def map_pmf_of_set_inj)
qed

subsection \<open>Code generation test\<close>

text \<open>
  Isabelle's code generator allows us to produce executable code both for
  @{const shuffle} and for @{const fisher_yates} and @{const fisher_yates_alt}.
  However, this code does not produce a random sample (i.e. a single randomly
  permuted list) -- which is, in fact, the only purpose of the Fisher--Yates
  algorithm -- but the entire probability distribution consisting of $n!$
  lists, each with probability $1/n!$.

  In the future, it would be nice if Isabelle also had some code generation
  facility that supports generating sampling code.
\<close>

value [code] "shuffle ''abcd''"
value [code] "fisher_yates ''abcd''"
value [code] "fisher_yates_alt ''abcd''"

end


section \<open>Upper and Lower Solutions\<close>
theory Upper_Lower_Solution
imports Flow
begin

text \<open>Following  Walter~\<^cite>\<open>"walter"\<close> in section 9\<close>

lemma IVT_min:
  fixes f :: "real \<Rightarrow> 'b :: {linorder_topology,real_normed_vector,ordered_real_vector}"
  \<comment> \<open>generalize?\<close>
  assumes y: "f a \<le> y" "y \<le> f b" "a \<le> b"
  assumes *: "continuous_on {a .. b} f"
  notes [continuous_intros] = *[THEN continuous_on_subset]
  obtains x where "a \<le> x" "x \<le> b" "f x = y" "\<And>x'. a \<le> x' \<Longrightarrow> x' < x \<Longrightarrow> f x' < y"
proof -
  let ?s = "((\<lambda>x. f x - y) -` {0..}) \<inter> {a..b}"
  have "?s \<noteq> {}"
    using assms
    by auto
  have "closed ?s"
    by (rule closed_vimage_Int) (auto intro!: continuous_intros)
  moreover have "bounded ?s"
    by (rule bounded_Int) (simp add: bounded_closed_interval)
  ultimately have "compact ?s"
    using compact_eq_bounded_closed by blast
  from compact_attains_inf[OF this \<open>?s \<noteq> {}\<close>]
  obtain x where x: "a \<le> x" "x \<le> b" "f x \<ge> y"
    and min: "\<And>z. a \<le> z \<Longrightarrow> z \<le> b \<Longrightarrow> f z \<ge> y \<Longrightarrow> x \<le> z"
    by auto
  have "f x \<le> y"
  proof (rule ccontr)
    assume n: "\<not> f x \<le> y"
    then have "\<exists>z\<ge>a. z \<le> x \<and> (\<lambda>x. f x - y) z = 0"
      using x by (intro IVT') (auto intro!: continuous_intros simp: assms)
    then obtain z where z: "a \<le> z" "z \<le> x" "f z = y" by auto
    then have "a \<le> z" "z \<le> b" "f z \<ge> y" using x by auto
    from min [OF this] z n
    show False by auto
  qed
  then have "a \<le> x" "x \<le> b" "f x = y"
    using x
    by (auto )
  moreover have "f x' < y" if "a \<le> x'" "x' < x" for x'
    apply (rule ccontr)
    using min[of x'] that x
    by (auto simp: not_less)
  ultimately show ?thesis ..
qed

lemma filtermap_at_left_shift: "filtermap (\<lambda>x. x - d) (at_left a) = at_left (a - d::real)"
  by (simp add: filter_eq_iff eventually_filtermap eventually_at_filter filtermap_nhds_shift[symmetric])

context
  fixes v v' w w'::"real \<Rightarrow> real" and t0 t1 e::real
  assumes v': "(v has_vderiv_on v') {t0 <.. t1}"
    and w': "(w has_vderiv_on w') {t0 <.. t1}"
  assumes pos_ivl: "t0 < t1"
  assumes e_pos: "e > 0" and e_in: "t0 + e \<le> t1"
  assumes less:  "\<And>t. t0 < t \<Longrightarrow> t < t0 + e \<Longrightarrow> v t < w t"
begin

lemma first_intersection_crossing_derivatives:
  assumes na: "t0 < tg" "tg \<le> t1" "v tg \<ge> w tg"
  notes [continuous_intros] =
    vderiv_on_continuous_on[OF v', THEN continuous_on_subset]
    vderiv_on_continuous_on[OF w', THEN continuous_on_subset]
  obtains x0 where
    "t0 < x0" "x0 \<le> tg"
    "v' x0 \<ge> w' x0"
    "v x0 = w x0"
    "\<And>t. t0 < t \<Longrightarrow> t < x0 \<Longrightarrow> v t < w t"
proof -
  have "(v - w) (min tg (t0 + e / 2)) \<le> 0" "0 \<le> (v - w) tg"
    "min tg (t0 + e / 2) \<le> tg"
    "continuous_on {min tg (t0 + e / 2)..tg} (v - w)"
  using less[of "t0 + e / 2"]
    less[of tg]na \<open>e > 0\<close>
    by (auto simp: min_def intro!: continuous_intros)
  from IVT_min[OF this]
  obtain x0 where x0: "min tg (t0 + e / 2) \<le> x0" "x0 \<le> tg" "v x0 = w x0"
    "\<And>x'. min tg (t0 + e / 2) \<le> x' \<Longrightarrow> x' < x0 \<Longrightarrow> v x' < w x'"
    by auto
  then have x0_in: "t0 < x0" "x0 \<le> t1"
    using \<open>e > 0\<close> na(1,2)
    by (auto)
  note \<open>t0 < x0\<close> \<open>x0 \<le> tg\<close>
  moreover
  {
    from v' x0_in
    have "(v has_derivative (\<lambda>x. x * v' x0)) (at x0 within {t0<..<x0})"
      by (force intro: has_derivative_subset simp: has_vector_derivative_def has_vderiv_on_def)
    then have v: "((\<lambda>y. (v y - (v x0 + (y - x0) * v' x0)) / norm (y - x0)) \<longlongrightarrow> 0) (at x0 within {t0<..<x0})"
      unfolding has_derivative_within
      by (simp add: ac_simps)
    from w' x0_in
    have "(w has_derivative (\<lambda>x. x * w' x0)) (at x0 within {t0<..<x0})"
      by (force intro: has_derivative_subset simp: has_vector_derivative_def has_vderiv_on_def)
    then have w: "((\<lambda>y. (w y - (w x0 + (y - x0) * w' x0)) / norm (y - x0)) \<longlongrightarrow> 0) (at x0 within {t0<..<x0})"
      unfolding has_derivative_within
      by (simp add: ac_simps)

    have evs: "\<forall>\<^sub>F x in at x0 within {t0<..<x0}. min tg (t0 + e / 2) < x"
      "\<forall>\<^sub>F x in at x0 within {t0<..<x0}. t0 < x \<and> x < x0"
      using less na(1) na(3) x0(3) x0_in(1)
      by (force simp: min_def eventually_at_filter intro!: order_tendstoD[OF tendsto_ident_at])+
    then have "\<forall>\<^sub>F x in at x0 within {t0<..<x0}.
       (v x - (v x0 + (x - x0) * v' x0)) / norm (x - x0) - (w x - (w x0 + (x - x0) * w' x0)) / norm (x - x0) =
       (v x - w x) / norm (x - x0) + (v' x0 - w' x0)"
       apply eventually_elim
       using x0_in x0 less na \<open>t0 < t1\<close> sum_sqs_eq
       by (auto simp: divide_simps algebra_simps min_def intro!: eventuallyI split: if_split_asm)
    from this tendsto_diff[OF v w]
    have 1: "((\<lambda>x. (v x - w x) / norm (x - x0) + (v' x0 - w' x0)) \<longlongrightarrow> 0) (at x0 within {t0<..<x0})"
      by (force intro: tendsto_eq_rhs Lim_transform_eventually)
    moreover
    from evs have 2: "\<forall>\<^sub>F x in at x0 within {t0<..<x0}. (v x - w x) / norm (x - x0) + (v' x0 - w' x0) \<le> (v' x0 - w' x0)"
      by eventually_elim (auto simp: divide_simps intro!: less_imp_le x0(4))

    moreover
    have "at x0 within {t0<..<x0} \<noteq> bot"
      by (simp add: \<open>t0 < x0\<close> at_within_eq_bot_iff less_imp_le)

    ultimately
    have "0 \<le> v' x0 - w' x0"
      by (rule tendsto_upperbound)
    then have "v' x0 \<ge> w' x0" by simp
  }
  moreover note \<open>v x0 = w x0\<close>
  moreover
  have "t0 < t \<Longrightarrow> t < x0 \<Longrightarrow> v t < w t" for t
    by (cases "min tg (t0 + e / 2) \<le> t") (auto intro: x0 less)
  ultimately show ?thesis ..
qed

lemma defect_less:
  assumes b: "\<And>t. t0 < t \<Longrightarrow> t \<le> t1 \<Longrightarrow> v' t - f t (v t) < w' t - f t (w t)"
  notes [continuous_intros] =
    vderiv_on_continuous_on[OF v', THEN continuous_on_subset]
    vderiv_on_continuous_on[OF w', THEN continuous_on_subset]
  shows "\<forall>t \<in> {t0 <.. t1}. v t < w t"
proof (rule ccontr)
  assume " \<not> (\<forall>t\<in>{t0 <.. t1}. v t < w t)"
  then obtain tu where "t0 < tu" "tu \<le> t1" "v tu \<ge> w tu" by auto
  from first_intersection_crossing_derivatives[OF this]
  obtain x0 where "t0 < x0" "x0 \<le> tu" "w' x0 \<le> v' x0" "v x0 = w x0" "\<And>t. t0 < t \<Longrightarrow> t < x0 \<Longrightarrow> v t < w t"
    by metis
  with b[of x0] \<open>tu \<le> t1\<close>
  show False
    by simp
qed

end

lemma has_derivatives_less_lemma:
  fixes v v' ::"real \<Rightarrow> real"
  assumes v': "(v has_vderiv_on v') T"
  assumes y': "(y has_vderiv_on y') T"
  assumes lu: "\<And>t. t \<in> T \<Longrightarrow> t > t0 \<Longrightarrow> v' t - f t (v t) < y' t - f t (y t)"
  assumes lower: "v t0 \<le> y t0"
  assumes eq_imp: "v t0 = y t0 \<Longrightarrow> v' t0 < y' t0"
  assumes t: "t0 < t" "t0 \<in> T" "t \<in> T" "is_interval T"
  shows "v t < y t"
proof -
  have subset: "{t0 .. t} \<subseteq> T"
    by (rule atMostAtLeast_subset_convex) (auto simp: assms is_interval_convex)
  obtain d where "0 < d" "t0 < s \<Longrightarrow> s \<le> t \<Longrightarrow> s < t0 + d \<Longrightarrow> v s < y s" for s
  proof cases
    assume "v t0 = y t0"
    from this[THEN eq_imp]
    have *: "0 < y' t0 - v' t0"
      by simp
    have "((\<lambda>t. y t - v t) has_vderiv_on (\<lambda>t0. y' t0 - v' t0)) {t0 .. t}"
      by (auto intro!: derivative_intros y' v' has_vderiv_on_subset[OF _ subset])
    with \<open>t0 < t\<close>
    have d: "((\<lambda>t. y t - v t) has_real_derivative y' t0 - v' t0) (at t0 within {t0 .. t})"
      by (auto simp: has_vderiv_on_def has_real_derivative_iff_has_vector_derivative)
    from has_real_derivative_pos_inc_right[OF d *] \<open>v t0 = y t0\<close>
    obtain d where "d > 0" and vy: "h > 0 \<Longrightarrow> t0 + h \<le> t \<Longrightarrow> h < d \<Longrightarrow> v (t0 + h) < y (t0 + h)" for h
      by auto
    have vy: "t0 < s \<Longrightarrow> s \<le> t \<Longrightarrow> s < t0 + d \<Longrightarrow> v s < y s" for s
      using vy[of "s - t0"] by simp
    with \<open>d > 0\<close> show ?thesis ..
  next
    assume "v t0 \<noteq> y t0"
    then have "v t0 < y t0" using lower by simp
    moreover
    have "continuous_on {t0 .. t} v" "continuous_on {t0 .. t} y"
      by (auto intro!: vderiv_on_continuous_on assms has_vderiv_on_subset[OF _ subset])
    then have "(v \<longlongrightarrow> v t0) (at t0 within {t0 .. t})" "(y \<longlongrightarrow> y t0) (at t0 within {t0 .. t})"
      by (auto simp: continuous_on)
    ultimately have "\<forall>\<^sub>F x in at t0 within {t0 .. t}. 0 < y x - v x"
      by (intro order_tendstoD) (auto intro!: tendsto_eq_intros)
    then obtain d where "d > 0" "\<And>x. t0 < x \<Longrightarrow> x \<le> t \<Longrightarrow> x < t0 + d \<Longrightarrow> v x < y x"
      by atomize_elim (auto simp: eventually_at algebra_simps dist_real_def)
    then show ?thesis ..
  qed
  with \<open>d > 0\<close> \<open>t0 < t\<close>
  obtain e where "e > 0" "t0 + e \<le> t" "t0 < s \<Longrightarrow> s < t0 + e \<Longrightarrow> v s < y s" for s
    by atomize_elim (auto simp: min_def divide_simps intro!: exI[where x="min (d/2) ((t - t0) / 2)"]
        split: if_split_asm)
  from defect_less[
      OF has_vderiv_on_subset[OF v']
        has_vderiv_on_subset[OF y']
        \<open>t0 < t\<close>
        this lu]
  show "v t < y t" using \<open>t0 < t\<close> subset
    by (auto simp: subset_iff assms)
qed

lemma strict_lower_solution:
  fixes v v' ::"real \<Rightarrow> real"
  assumes sol: "(y solves_ode f) T X"
  assumes v': "(v has_vderiv_on v') T"
  assumes lower: "\<And>t. t \<in> T \<Longrightarrow> t > t0 \<Longrightarrow> v' t < f t (v t)"
  assumes iv: "v t0 \<le> y t0" "v t0 = y t0 \<Longrightarrow> v' t0 < f t0 (y t0)"
  assumes t: "t0 < t" "t0 \<in> T" "t \<in> T" "is_interval T"
  shows "v t < y t"
proof -
  note v'
  moreover
  note solves_odeD(1)[OF sol]
  moreover
  have 3: "v' t - f t (v t) < f t (y t) - f t (y t)" if "t \<in> T" "t > t0" for t
    using lower(1)[OF that]
    by arith
  moreover note iv
  moreover note t
  ultimately
  show "v t < y t"
    by (rule has_derivatives_less_lemma)
qed

lemma strict_upper_solution:
  fixes w w'::"real \<Rightarrow> real"
  assumes sol: "(y solves_ode f) T X"
  assumes w': "(w has_vderiv_on w') T"
    and upper: "\<And>t. t \<in> T \<Longrightarrow> t > t0 \<Longrightarrow> f t (w t) < w' t"
    and iv: "y t0 \<le> w t0" "y t0 = w t0 \<Longrightarrow> f t0 (y t0) < w' t0"
  assumes t: "t0 < t" "t0 \<in> T" "t \<in> T" "is_interval T"
  shows "y t < w t"
proof -
  note solves_odeD(1)[OF sol]
  moreover
  note w'
  moreover
  have "f t (y t) - f t (y t) < w' t - f t (w t)" if "t \<in> T" "t > t0" for t
    using upper(1)[OF that]
    by arith
  moreover note iv
  moreover note t
  ultimately
  show "y t < w t"
    by (rule has_derivatives_less_lemma)
qed

lemma uniform_limit_at_within_subset:
  assumes "uniform_limit S x l (at t within T)"
  assumes "U \<subseteq> T"
  shows "uniform_limit S x l (at t within U)"
  by (metis assms(1) assms(2) eventually_within_Un filterlim_iff subset_Un_eq)

lemma uniform_limit_le:
  fixes f::"'c \<Rightarrow> 'a \<Rightarrow> 'b::{metric_space, linorder_topology}"
  assumes I: "I \<noteq> bot"
  assumes u: "uniform_limit X f g I"
  assumes u': "uniform_limit X f' g' I"
  assumes "\<forall>\<^sub>F i in I. \<forall>x \<in> X. f i x \<le> f' i x"
  assumes "x \<in> X"
  shows "g x \<le> g' x"
proof -
  have "\<forall>\<^sub>F i in I. f i x \<le> f' i x" using assms by (simp add: eventually_mono)
  with I tendsto_uniform_limitI[OF u' \<open>x \<in> X\<close>] tendsto_uniform_limitI[OF u \<open>x \<in> X\<close>]
  show ?thesis by (rule tendsto_le)
qed

lemma uniform_limit_le_const:
  fixes f::"'c \<Rightarrow> 'a \<Rightarrow> 'b::{metric_space, linorder_topology}"
  assumes I: "I \<noteq> bot"
  assumes u: "uniform_limit X f g I"
  assumes "\<forall>\<^sub>F i in I. \<forall>x \<in> X. f i x \<le> h x"
  assumes "x \<in> X"
  shows "g x \<le> h x"
proof -
  have "\<forall>\<^sub>F i in I. f i x \<le> h x" using assms by (simp add: eventually_mono)
  then show ?thesis by (metis tendsto_upperbound I tendsto_uniform_limitI[OF u \<open>x \<in> X\<close>])
qed

lemma uniform_limit_ge_const:
  fixes f::"'c \<Rightarrow> 'a \<Rightarrow> 'b::{metric_space, linorder_topology}"
  assumes I: "I \<noteq> bot"
  assumes u: "uniform_limit X f g I"
  assumes "\<forall>\<^sub>F i in I. \<forall>x \<in> X. h x \<le> f i x"
  assumes "x \<in> X"
  shows "h x \<le> g x"
proof -
  have "\<forall>\<^sub>F i in I. h x \<le> f i x" using assms by (simp add: eventually_mono)
  then show ?thesis by (metis tendsto_lowerbound I tendsto_uniform_limitI[OF u \<open>x \<in> X\<close>])
qed

locale ll_on_open_real = ll_on_open T f X for T f and X::"real set"
begin

lemma lower_solution:
  fixes v v' ::"real \<Rightarrow> real"
  assumes sol: "(y solves_ode f) S X"
  assumes v': "(v has_vderiv_on v') S"
  assumes lower: "\<And>t. t \<in> S \<Longrightarrow> t > t0 \<Longrightarrow> v' t < f t (v t)"
  assumes iv: "v t0 \<le> y t0"
  assumes t: "t0 \<le> t" "t0 \<in> S" "t \<in> S" "is_interval S" "S \<subseteq> T"
  shows "v t \<le> y t"
proof cases
  assume "v t0 = y t0"
  have "{t0 -- t} \<subseteq> S" using t by (simp add: closed_segment_subset is_interval_convex)
  with sol have "(y solves_ode f) {t0 -- t} X" using order_refl by (rule solves_ode_on_subset)
  moreover note refl
  moreover
  have "{t0 -- t} \<subseteq> T" using \<open>{t0 -- t} \<subseteq> S\<close> \<open>S \<subseteq> T\<close> by (rule order_trans)
  ultimately have t_ex: "t \<in> existence_ivl t0 (y t0)"
    by (rule existence_ivl_maximal_segment)

  have t0_ex: "t0 \<in> existence_ivl t0 (y t0)"
    using in_existence_between_zeroI t_ex by blast
  have "t0 \<in> T" using assms(9) t(2) by blast

  from uniform_limit_flow[OF t0_ex t_ex] \<open>t0 \<le> t\<close>
  have "uniform_limit {t0..t} (flow t0) (flow t0 (y t0)) (at (y t0))" by simp
  then have "uniform_limit {t0..t} (flow t0) (flow t0 (y t0)) (at_right (y t0))"
    by (rule uniform_limit_at_within_subset) simp
  moreover
  {
    have "\<forall>\<^sub>F i in at (y t0). t \<in> existence_ivl t0 i"
      by (rule eventually_mem_existence_ivl) fact
    then have "\<forall>\<^sub>F i in at_right (y t0). t \<in> existence_ivl t0 i"
      unfolding eventually_at_filter
      by eventually_elim simp
    moreover have "\<forall>\<^sub>F i in at_right (y t0). i \<in> X"
    proof -
      have f1: "\<And>r ra rb. r \<notin> existence_ivl ra rb \<or> rb \<in> X"
        by (metis existence_ivl_reverse flow_in_domain flows_reverse)
      obtain rr :: "(real \<Rightarrow> bool) \<Rightarrow> (real \<Rightarrow> bool) \<Rightarrow> real" where
        "\<And>p f pa fa. (\<not> eventually p f \<or> eventually pa f \<or> p (rr p pa)) \<and>
          (\<not> eventually p fa \<or> \<not> pa (rr p pa) \<or> eventually pa fa)"
        by (metis (no_types) eventually_mono)
      then show ?thesis
        using f1 calculation by meson
    qed
    moreover have "\<forall>\<^sub>F i in at_right (y t0). y t0 < i"
      by (simp add: eventually_at_filter)
    ultimately have "\<forall>\<^sub>F i in at_right (y t0). \<forall>x\<in>{t0..t}. v x \<le> flow t0 i x"
    proof eventually_elim
      case (elim y')
      show ?case
      proof safe
        fix s assume s: "s \<in> {t0..t}"
        show "v s \<le> flow t0 y' s"
        proof cases
          assume "s = t0" with elim iv show ?thesis
            by (simp add: \<open>t0 \<in> T\<close> \<open>y' \<in> X\<close>)
        next
          assume "s \<noteq> t0" with s have "t0 < s" by simp
          have "{t0 -- s} \<subseteq> S" using \<open>{t0--t} \<subseteq> S\<close> closed_segment_eq_real_ivl s by auto
          from s elim have "{t0..s} \<subseteq> existence_ivl t0 y'"
            using ivl_subset_existence_ivl by blast
          with flow_solves_ode have sol: "(flow t0 y' solves_ode f) {t0 .. s} X"
            by (rule solves_ode_on_subset) (auto intro!: \<open>y' \<in> X\<close> \<open>t0 \<in> T\<close>)
          have "{t0 .. s} \<subseteq> S" using \<open>{t0 -- s} \<subseteq> S\<close> by (simp add: closed_segment_eq_real_ivl split: if_splits)
          with v' have v': "(v has_vderiv_on v') {t0 .. s}"
            by (rule has_vderiv_on_subset)
          from \<open>y t0 < y'\<close> \<open>v t0 = y t0\<close> have less_init: "v t0 < flow t0 y' t0"
            by (simp add: flow_initial_time_if \<open>t0 \<in> T\<close> \<open>y' \<in> X\<close>)
          from strict_lower_solution[OF sol v' lower less_imp_le[OF less_init] _ \<open>t0 < s\<close>]
            \<open>{t0 .. s} \<subseteq> S\<close>
            less_init \<open>t0 < s\<close>
          have "v s < flow t0 y' s" by (simp add: subset_iff is_interval_cc)
          then show ?thesis by simp
        qed
      qed
    qed
  }
  moreover have "t \<in> {t0 .. t}" using \<open>t0 \<le> t\<close> by simp
  ultimately have "v t \<le> flow t0 (y t0) t"
    by (rule uniform_limit_ge_const[OF trivial_limit_at_right_real])
  also have "flow t0 (y t0) t = y t"
    using sol t
    by (intro maximal_existence_flow) auto
  finally show ?thesis .
next
  assume "v t0 \<noteq> y t0" then have less: "v t0 < y t0" using iv by simp
  show ?thesis
    apply (cases "t0 = t")
    subgoal using iv by blast
    subgoal using strict_lower_solution[OF sol v' lower iv] less t by force
    done
qed

lemma upper_solution:
  fixes v v' ::"real \<Rightarrow> real"
  assumes sol: "(y solves_ode f) S X"
  assumes v': "(v has_vderiv_on v') S"
  assumes upper: "\<And>t. t \<in> S \<Longrightarrow> t > t0 \<Longrightarrow> f t (v t) < v' t"
  assumes iv: "y t0 \<le> v t0"
  assumes t: "t0 \<le> t" "t0 \<in> S" "t \<in> S" "is_interval S" "S \<subseteq> T"
  shows "y t \<le> v t"
proof cases
  assume "v t0 = y t0"
  have "{t0 -- t} \<subseteq> S" using t by (simp add: closed_segment_subset is_interval_convex)
  with sol have "(y solves_ode f) {t0 -- t} X" using order_refl by (rule solves_ode_on_subset)
  moreover note refl
  moreover
  have "{t0 -- t} \<subseteq> T" using \<open>{t0 -- t} \<subseteq> S\<close> \<open>S \<subseteq> T\<close> by (rule order_trans)
  ultimately have t_ex: "t \<in> existence_ivl t0 (y t0)"
    by (rule existence_ivl_maximal_segment)

  have t0_ex: "t0 \<in> existence_ivl t0 (y t0)"
    using in_existence_between_zeroI t_ex by blast
  have "t0 \<in> T" using assms(9) t(2) by blast

  from uniform_limit_flow[OF t0_ex t_ex] \<open>t0 \<le> t\<close>
  have "uniform_limit {t0..t} (flow t0) (flow t0 (y t0)) (at (y t0))" by simp
  then have "uniform_limit {t0..t} (flow t0) (flow t0 (y t0)) (at_left (y t0))"
    by (rule uniform_limit_at_within_subset) simp
  moreover
  {
    have "\<forall>\<^sub>F i in at (y t0). t \<in> existence_ivl t0 i"
      by (rule eventually_mem_existence_ivl) fact
    then have "\<forall>\<^sub>F i in at_left (y t0). t \<in> existence_ivl t0 i"
      unfolding eventually_at_filter
      by eventually_elim simp
    moreover have "\<forall>\<^sub>F i in at_left (y t0). i \<in> X"
    proof -
      have f1: "\<And>r ra rb. r \<notin> existence_ivl ra rb \<or> rb \<in> X"
        by (metis existence_ivl_reverse flow_in_domain flows_reverse)
      obtain rr :: "(real \<Rightarrow> bool) \<Rightarrow> (real \<Rightarrow> bool) \<Rightarrow> real" where
        "\<And>p f pa fa. (\<not> eventually p f \<or> eventually pa f \<or> p (rr p pa)) \<and>
          (\<not> eventually p fa \<or> \<not> pa (rr p pa) \<or> eventually pa fa)"
        by (metis (no_types) eventually_mono)
      then show ?thesis
        using f1 calculation by meson
    qed
    moreover have "\<forall>\<^sub>F i in at_left (y t0). i < y t0"
      by (simp add: eventually_at_filter)
    ultimately have "\<forall>\<^sub>F i in at_left (y t0). \<forall>x\<in>{t0..t}. flow t0 i x \<le> v x"
    proof eventually_elim
      case (elim y')
      show ?case
      proof safe
        fix s assume s: "s \<in> {t0..t}"
        show "flow t0 y' s \<le> v s"
        proof cases
          assume "s = t0" with elim iv show ?thesis
            by (simp add: \<open>t0 \<in> T\<close> \<open>y' \<in> X\<close>)
        next
          assume "s \<noteq> t0" with s have "t0 < s" by simp
          have "{t0 -- s} \<subseteq> S" using \<open>{t0--t} \<subseteq> S\<close> closed_segment_eq_real_ivl s by auto
          from s elim have "{t0..s} \<subseteq> existence_ivl t0 y'"
            using ivl_subset_existence_ivl by blast
          with flow_solves_ode have sol: "(flow t0 y' solves_ode f) {t0 .. s} X"
            by (rule solves_ode_on_subset) (auto intro!: \<open>y' \<in> X\<close> \<open>t0 \<in> T\<close>)
          have "{t0 .. s} \<subseteq> S" using \<open>{t0 -- s} \<subseteq> S\<close> by (simp add: closed_segment_eq_real_ivl split: if_splits)
          with v' have v': "(v has_vderiv_on v') {t0 .. s}"
            by (rule has_vderiv_on_subset)
          from \<open>y' < y t0\<close> \<open>v t0 = y t0\<close> have less_init: "flow t0 y' t0 < v t0"
            by (simp add: flow_initial_time_if \<open>t0 \<in> T\<close> \<open>y' \<in> X\<close>)
          from strict_upper_solution[OF sol v' upper less_imp_le[OF less_init] _ \<open>t0 < s\<close>]
            \<open>{t0 .. s} \<subseteq> S\<close>
            less_init \<open>t0 < s\<close>
          have "flow t0 y' s < v s" by (simp add: subset_iff is_interval_cc)
          then show ?thesis by simp
        qed
      qed
    qed
  }
  moreover have "t \<in> {t0 .. t}" using \<open>t0 \<le> t\<close> by simp
  ultimately have "flow t0 (y t0) t \<le> v t"
    by (rule uniform_limit_le_const[OF trivial_limit_at_left_real])
  also have "flow t0 (y t0) t = y t"
    using sol t
    by (intro maximal_existence_flow) auto
  finally show ?thesis .
next
  assume "v t0 \<noteq> y t0" then have less: "y t0 < v t0" using iv by simp
  show ?thesis
    apply (cases "t0 = t")
    subgoal using iv by blast
    subgoal using strict_upper_solution[OF sol v' upper iv] less t by force
    done
qed

end

end


theory Store
imports Aexp Bexp
begin

section\<open>Stores\<close>

text \<open>In this section, we introduce the type of stores, which we use to link program variables
with their symbolic counterpart during symbolic execution. We define the notion of consistency
of a pair of program and symbolic states w.r.t.\ a store. This notion will prove helpful when
defining various concepts and proving facts related to subsumption (see \verb?Conf.thy?). Finally, we
model substitutions that will be performed during symbolic execution (see \verb?SymExec.thy?) by two
operations: @{term adapt_aexp} and @{term adapt_bexp}.\<close>

subsection \<open>Basic definitions\<close>

subsubsection \<open>The @{term "store"} type-synonym\<close>

text \<open>Symbolic execution performs over configurations (see \verb?Conf.thy?), which are pairs made
of:
\begin{itemize}
\item a \emph{store} mapping program variables to symbolic variables,
\item a set of boolean expressions which records constraints over symbolic variables and whose
conjunction is the actual path predicate of the configuration.
\end{itemize}
We define stores as total functions from program variables to indexes.\<close>

type_synonym 'a store = "'a \<Rightarrow> nat"

subsubsection \<open>Symbolic variables of a store\<close>

text \<open>The symbolic variable associated to a program variable @{term "v"} by a store
@{term "s"} is the couple @{term "(v,s v)"}.\<close>

definition symvar ::
  "'a \<Rightarrow> 'a store \<Rightarrow> 'a symvar"
where
  "symvar v s \<equiv> (v,s v)"

text \<open>The function associating symbolic variables to program variables obtained from
@{term "s"} is injective.\<close>

lemma
  "inj (\<lambda> v. symvar v s)"
by (auto simp add : inj_on_def symvar_def)

text \<open>The sets of symbolic variables of a store is the image set of the function @{term "symvar"}.\<close>

definition symvars ::
  "'a store \<Rightarrow> 'a symvar set"
where
 "symvars s = (\<lambda> v. symvar v s) ` (UNIV::'a set)"

subsubsection \<open>Fresh symbolic variables\<close>

text \<open>A symbolic variable is said to be fresh for a store if it is not a member of its set of
symbolic variables.\<close>

definition fresh_symvar ::
  "'v symvar \<Rightarrow> 'v store \<Rightarrow> bool"
where
 "fresh_symvar sv s = (sv \<notin> symvars s)"

subsection \<open>Consistency\<close>

text \<open>We say that a program state @{term "\<sigma>"} and a symbolic state @{term "\<sigma>\<^sub>s\<^sub>y\<^sub>m"} are
\emph{consistent} with respect to a store @{term "s"} if, for each variable @{term "v"}, the
value associated by @{term "\<sigma>"} to @{term "v"} is equal to the value associated by @{term "\<sigma>\<^sub>s\<^sub>y\<^sub>m"}
to the symbolic variable associated to @{term "v"} by @{term "s"}.\<close>

definition consistent ::
  "('v,'d) state \<Rightarrow> ('v symvar, 'd) state \<Rightarrow> 'v store \<Rightarrow> bool"
where
  "consistent \<sigma> \<sigma>\<^sub>s\<^sub>y\<^sub>m s \<equiv> (\<forall> v. \<sigma>\<^sub>s\<^sub>y\<^sub>m (symvar v s) = \<sigma> v)"

text \<open>There always exists a couple of consistent states for a given store.\<close>

lemma
  "\<exists> \<sigma> \<sigma>\<^sub>s\<^sub>y\<^sub>m. consistent \<sigma> \<sigma>\<^sub>s\<^sub>y\<^sub>m s"
by (auto simp add : consistent_def)

text \<open>Moreover, given a store and a program (resp. symbolic) state, one can always build a symbolic
(resp. program) state such that the two states are coherent wrt.\ the store. The four following
lemmas show how to build the second state given the first one.\<close>

lemma consistent_eq1 :
  "consistent \<sigma> \<sigma>\<^sub>s\<^sub>y\<^sub>m s = (\<forall> sv \<in> symvars s. \<sigma>\<^sub>s\<^sub>y\<^sub>m sv = \<sigma> (fst sv))"
by (auto simp add : consistent_def symvars_def symvar_def)

lemma consistent_eq2 :
  "consistent \<sigma> \<sigma>\<^sub>s\<^sub>y\<^sub>m store = (\<sigma> = (\<lambda> v. \<sigma>\<^sub>s\<^sub>y\<^sub>m (symvar v store)))"
by (auto simp add : consistent_def)

lemma consistentI1 :
  "consistent \<sigma> (\<lambda> sv. \<sigma> (fst sv)) store"
using consistent_eq1 by fast

lemma consistentI2 :
  "consistent (\<lambda> v. \<sigma>\<^sub>s\<^sub>y\<^sub>m (symvar v store)) \<sigma>\<^sub>s\<^sub>y\<^sub>m store"
using consistent_eq2 by fast

subsection \<open>Adaptation of an arithmetic expression to a store\<close>

text \<open>Suppose that @{term "e"} is a term representing an arithmetic expression over program
variables and let @{term "s"} be a store. We call \emph{adaptation of @{term "e"} to @{term "s"}}
the term obtained by substituting occurrences of program variables in @{term "e"} by their
symbolic counterpart given by @{term "s"}. Since we model arithmetic expressions by total
functions and not terms, we define the adaptation of such expressions as follows.\<close>

definition adapt_aexp ::
  "('v,'d) aexp \<Rightarrow> 'v store \<Rightarrow> ('v symvar,'d) aexp"
where
  "adapt_aexp e s = (\<lambda> \<sigma>\<^sub>s\<^sub>y\<^sub>m. e (\<lambda> v. \<sigma>\<^sub>s\<^sub>y\<^sub>m (symvar v s)))"

text \<open>Given an arithmetic expression @{term "e"}, a program state @{term "\<sigma>"} and a symbolic
state @{term "\<sigma>\<^sub>s\<^sub>y\<^sub>m"} coherent with a store @{term "s"}, the value associated to @{term "\<sigma>\<^sub>s\<^sub>y\<^sub>m"} by
the adaptation of @{term "e"} to @{term "s"} is the same than the value associated by @{term "e"} to
@{term "\<sigma>"}. This confirms the fact that @{term "adapt_aexp"} models the act of substituting
occurrences of program variables by their symbolic counterparts in a term over program variables.\<close>

lemma adapt_aexp_is_subst :
  assumes "consistent \<sigma> \<sigma>\<^sub>s\<^sub>y\<^sub>m s"
  shows   "(adapt_aexp e s) \<sigma>\<^sub>s\<^sub>y\<^sub>m = e \<sigma>"
using assms by (simp add : consistent_eq2 adapt_aexp_def)

text \<open>As said earlier, we will later need to prove that symbolic execution preserves finiteness
of the set of symbolic variables in use, which requires that the adaptation of an arithmetic
expression to a store preserves finiteness of the set of variables of expressions. We proceed as
follows.\<close>

text \<open>First, we show that if @{term "v"} is a variable of an expression @{term "e"},
then the symbolic variable associated to @{term "v"} by a store is a variable of the adaptation of
@{term "e"} to this store.\<close>

lemma var_imp_symvar_var :
  assumes "v \<in> Aexp.vars e"
  shows   "symvar v s \<in> Aexp.vars (adapt_aexp e s)" (is "?sv \<in> Aexp.vars ?e'")
proof -
  obtain \<sigma> val where "e (\<sigma> (v := val)) \<noteq> e \<sigma>"
  using assms unfolding Aexp.vars_def by blast

  moreover
  have "(\<lambda>va. ((\<lambda>sv. \<sigma> (fst sv))(?sv := val)) (symvar va s)) = (\<sigma>(v := val))"
  by (auto simp add : symvar_def)

  ultimately
  show ?thesis
  unfolding Aexp.vars_def mem_Collect_eq
  using consistentI1[of \<sigma> s]
        consistentI2[of "(\<lambda>sv. \<sigma> (fst sv))(?sv:= val)" s]
  by (rule_tac ?x="\<lambda>sv. \<sigma> (fst sv)" in exI, rule_tac ?x="val" in exI)
     (simp add : adapt_aexp_is_subst)
qed

text \<open>On the other hand, if @{term "sv"} is a symbolic variable in the adaptation of an expression
to a store, then the program variable it represents is a variable of this expression. This requires
to prove that the set of variables of the adaptation of an expression to a store is a subset of the
symbolic variables of this store.\<close>

lemma symvars_of_adapt_aexp :
  "Aexp.vars (adapt_aexp e s) \<subseteq> symvars s" (is "Aexp.vars ?e' \<subseteq> symvars s")
unfolding subset_iff
proof (intro allI impI)
  fix sv

  assume "sv \<in> Aexp.vars ?e'"

  then obtain \<sigma>\<^sub>s\<^sub>y\<^sub>m val
  where "?e' (\<sigma>\<^sub>s\<^sub>y\<^sub>m (sv := val)) \<noteq> ?e' \<sigma>\<^sub>s\<^sub>y\<^sub>m"
  by (simp add : Aexp.vars_def, blast)

  hence "(\<lambda> x. (\<sigma>\<^sub>s\<^sub>y\<^sub>m (sv := val)) (symvar x s)) \<noteq> (\<lambda> x. \<sigma>\<^sub>s\<^sub>y\<^sub>m (symvar x s))"
  proof (intro notI)
    assume "(\<lambda>x. (\<sigma>\<^sub>s\<^sub>y\<^sub>m(sv := val)) (symvar x s)) = (\<lambda>x. \<sigma>\<^sub>s\<^sub>y\<^sub>m (symvar x s))"

    hence "?e' (\<sigma>\<^sub>s\<^sub>y\<^sub>m (sv := val)) = ?e' \<sigma>\<^sub>s\<^sub>y\<^sub>m"
    by (simp add : adapt_aexp_def)

    thus False
    using \<open>?e' (\<sigma>\<^sub>s\<^sub>y\<^sub>m (sv := val)) \<noteq> ?e' \<sigma>\<^sub>s\<^sub>y\<^sub>m\<close>
    by (elim notE)
  qed

  then obtain v
  where "(\<sigma>\<^sub>s\<^sub>y\<^sub>m (sv := val)) (symvar v s) \<noteq> \<sigma>\<^sub>s\<^sub>y\<^sub>m (symvar v s)"
  by blast

  hence "sv = symvar v s" by (case_tac "sv = symvar v s", simp_all)

  thus "sv \<in> symvars s" by (simp add : symvars_def)
qed

lemma symvar_var_imp_var :
  assumes "sv \<in> Aexp.vars (adapt_aexp e s)" (is "sv \<in> Aexp.vars ?e'")
  shows   "fst sv \<in> Aexp.vars e"
proof -
  obtain v where "sv = (v, s v)"
  using assms(1) symvars_of_adapt_aexp
  unfolding symvars_def symvar_def
  by blast

  obtain \<sigma>\<^sub>s\<^sub>y\<^sub>m val where "?e' (\<sigma>\<^sub>s\<^sub>y\<^sub>m (sv := val)) \<noteq> ?e' \<sigma>\<^sub>s\<^sub>y\<^sub>m"
  using assms unfolding Aexp.vars_def by blast

  moreover
  have "(\<lambda> v. (\<sigma>\<^sub>s\<^sub>y\<^sub>m (sv := val)) (symvar v s)) = (\<lambda> v. \<sigma>\<^sub>s\<^sub>y\<^sub>m (symvar v s)) (v := val)"
  using \<open>sv = (v, s v)\<close> by (auto simp add : symvar_def)

  ultimately
  show ?thesis
  using \<open>sv = (v, s v)\<close>
        consistentI2[of \<sigma>\<^sub>s\<^sub>y\<^sub>m s]
        consistentI2[of "\<sigma>\<^sub>s\<^sub>y\<^sub>m (sv := val)" s]
  unfolding Aexp.vars_def
  by (simp add : adapt_aexp_is_subst) blast
qed

text \<open>Thus, we have that the set of variables of the adaptation of an expression to a store is
the set of symbolic variables associated by this store to the variables of this
expression.\<close>

lemma adapt_aexp_vars :
  "Aexp.vars (adapt_aexp e s) = (\<lambda> v. symvar v s) ` Aexp.vars e"
unfolding set_eq_iff image_def mem_Collect_eq Bex_def
proof (intro allI iffI, goal_cases)
  case (1 sv)

  moreover
  have "sv = symvar (fst sv) s"
  using 1 symvars_of_adapt_aexp
  by (force simp add:  symvar_def symvars_def)

  ultimately
  show ?case using symvar_var_imp_var by blast
next
  case (2 sv) thus ?case using var_imp_symvar_var by fast
qed

text \<open>The fact that the adaptation of an arithmetic expression to a store preserves finiteness
of the set of variables trivially follows the previous lemma.\<close>

lemma finite_vars_imp_finite_adapt_a :
  assumes "finite (Aexp.vars e)"
  shows   "finite (Aexp.vars (adapt_aexp e s))"
unfolding adapt_aexp_vars using assms by auto

subsection \<open>Adaptation of a boolean expression to a store\<close>

text \<open>We proceed analogously for the adaptation of boolean expressions to a store.\<close>

definition adapt_bexp ::
  "('v,'d) bexp \<Rightarrow> 'v store \<Rightarrow> ('v symvar,'d) bexp"
where
  "adapt_bexp e s = (\<lambda> \<sigma>. e (\<lambda> x. \<sigma> (symvar x s)))"

lemma adapt_bexp_is_subst :
  assumes "consistent \<sigma> \<sigma>\<^sub>s\<^sub>y\<^sub>m s"
  shows   "(adapt_bexp e s) \<sigma>\<^sub>s\<^sub>y\<^sub>m = e \<sigma>"
using assms by (simp add : consistent_eq2 adapt_bexp_def)

lemma var_imp_symvar_var2 :
  assumes "v \<in> Bexp.vars e"
  shows   "symvar v s \<in> Bexp.vars (adapt_bexp e s)" (is "?sv \<in> Bexp.vars ?e'")
proof -
  obtain \<sigma> val where A : "e (\<sigma> (v := val)) \<noteq> e \<sigma>"
  using assms unfolding Bexp.vars_def by blast

  moreover
  have "(\<lambda>va. ((\<lambda>sv. \<sigma> (fst sv))(?sv := val)) (symvar va s)) = (\<sigma>(v := val))"
  by (auto simp add : symvar_def)

  ultimately
  show ?thesis
  unfolding Bexp.vars_def mem_Collect_eq
  using consistentI1[of \<sigma> s]
        consistentI2[of "(\<lambda>sv. \<sigma> (fst sv))(?sv:= val)" s]
  by (rule_tac ?x="\<lambda>sv. \<sigma> (fst sv)" in exI, rule_tac ?x="val" in exI)
     (simp add : adapt_bexp_is_subst)
qed

lemma symvars_of_adapt_bexp :
  "Bexp.vars (adapt_bexp e s) \<subseteq> symvars s" (is "Bexp.vars ?e' \<subseteq> ?SV")
proof
  fix sv
  assume "sv \<in> Bexp.vars ?e'"

  then obtain \<sigma>\<^sub>s\<^sub>y\<^sub>m val
  where "?e' (\<sigma>\<^sub>s\<^sub>y\<^sub>m (sv := val)) \<noteq> ?e' \<sigma>\<^sub>s\<^sub>y\<^sub>m"
  by (simp add : Bexp.vars_def, blast)

  hence "(\<lambda> x. (\<sigma>\<^sub>s\<^sub>y\<^sub>m (sv := val)) (symvar x s)) \<noteq> (\<lambda> x. \<sigma>\<^sub>s\<^sub>y\<^sub>m (symvar x s))"
  by (auto simp add : adapt_bexp_def)

  hence "\<exists> v. (\<sigma>\<^sub>s\<^sub>y\<^sub>m (sv := val)) (symvar v s) \<noteq> \<sigma>\<^sub>s\<^sub>y\<^sub>m (symvar v s)" by force

  then obtain v
  where "(\<sigma>\<^sub>s\<^sub>y\<^sub>m (sv := val)) (symvar v s) \<noteq> \<sigma>\<^sub>s\<^sub>y\<^sub>m (symvar v s)"
  by blast

  hence "sv = symvar v s" by (case_tac "sv = symvar v s", simp_all)

  thus "sv \<in> symvars s" by (simp add : symvars_def)
qed

  moreover
  have "(\<lambda> v. (\<sigma>\<^sub>s\<^sub>y\<^sub>m (sv := val)) (symvar v s)) = (\<lambda> v. \<sigma>\<^sub>s\<^sub>y\<^sub>m (symvar v s)) (v := val)"
  using \<open>sv = (v, s v)\<close> by (auto simp add : symvar_def)

  ultimately
  show ?thesis
  using \<open>sv = (v, s v)\<close>
        consistentI2[of \<sigma>\<^sub>s\<^sub>y\<^sub>m s]
        consistentI2[of "\<sigma>\<^sub>s\<^sub>y\<^sub>m (sv := val)" s]
  unfolding vars_def by (simp add : adapt_bexp_is_subst) blast
qed

lemma adapt_bexp_vars :
  "Bexp.vars (adapt_bexp e s) = (\<lambda> v. symvar v s) ` Bexp.vars e"
  (is "Bexp.vars ?e' = ?R")
unfolding set_eq_iff image_def mem_Collect_eq Bex_def
proof (intro allI iffI, goal_cases)
  case (1 sv)

  hence "fst sv \<in> vars e" by (rule symvar_var_imp_var2)

  moreover
  have "sv = symvar (fst sv) s"
  using 1 symvars_of_adapt_bexp
  by (force simp add:  symvar_def symvars_def)

  ultimately
  show ?case by blast
next
  case (2 sv)

  then obtain v where "v \<in> vars e" "sv = symvar v s" by blast

  thus ?case using var_imp_symvar_var2 by simp
qed

lemma finite_vars_imp_finite_adapt_b :
  assumes "finite (Bexp.vars e)"
  shows   "finite (Bexp.vars (adapt_bexp e s))"
unfolding adapt_bexp_vars using assms by auto

end


section "Permutation Lemmas"

theory PermutationLemmas
imports "HOL-Library.Multiset"
begin

  \<comment> \<open>following function is very close to that in multisets- now we can make the connection that x <~~> y iff the multiset of x is the same as that of y\<close>

subsection "perm, count equivalence"

lemma count_eq:
  \<open>count_list xs x = Multiset.count (mset xs) x\<close>
by (induction xs) simp_all

lemma perm_count: "mset A = mset B \<Longrightarrow> (\<forall> x. count_list A x = count_list B x)"
by (simp add: count_eq)

lemma count_0: "(\<forall>x. count_list B x = 0) = (B = [])"
by (simp add: count_list_0_iff)

lemma count_Suc: "count_list B a = Suc m \<Longrightarrow> a : set B"
by (metis Zero_not_Suc count_notin)

lemma count_perm: "!! B. (\<forall> x. count_list A x = count_list B x) \<Longrightarrow> mset A = mset B"
by (simp add: count_eq multiset_eq_iff)

lemma perm_count_conv: "mset A = mset B \<longleftrightarrow> (\<forall> x. count_list A x = count_list B x)"
by (simp add: count_eq multiset_eq_iff)

subsection "Properties closed under Perm and Contr hold for x iff hold for remdups x"

lemma remdups_append: "y : set ys --> remdups (ws@y#ys) = remdups (ws@ys)"
  apply (induct ws, simp)
  apply (case_tac "y = a", simp, simp)
  done

lemma perm_contr': assumes perm[rule_format]: "! xs ys. mset xs = mset ys --> (P xs = P ys)"
  and contr'[rule_format]: "! x xs. P(x#x#xs) = P (x#xs)"
  shows "! xs. length xs = n --> (P xs = P (remdups xs))"
  apply(induct n rule: nat_less_induct)
proof (safe)
  fix xs :: "'a list"
  assume a[rule_format]: "\<forall>m<length xs. \<forall>ys. length ys = m \<longrightarrow> P ys = P (remdups ys)"
  show "P xs = P (remdups xs)"
  proof (cases "distinct xs")
    case True
    thus ?thesis by(simp add:distinct_remdups_id)
  next
    case False
    from not_distinct_decomp[OF this] obtain ws ys zs y where xs: "xs = ws@[y]@ys@[y]@zs" by force
    have "P xs = P (ws@[y]@ys@[y]@zs)" by (simp add: xs)
    also have "... = P ([y,y]@ws@ys@zs)"
      apply(rule perm) apply(rule iffD2[OF perm_count_conv]) apply rule apply(simp) done
    also have "... = P ([y]@ws@ys@zs)" apply simp apply(rule contr') done
    also have "... = P (ws@ys@[y]@zs)"
      apply(rule perm) apply(rule iffD2[OF perm_count_conv]) apply rule apply(simp) done
    also have "... = P (remdups (ws@ys@[y]@zs))"
      apply(rule a) by(auto simp: xs)
    also have "(remdups (ws@ys@[y]@zs)) = (remdups xs)"
      apply(simp add: xs remdups_append) done
    finally show "P xs = P (remdups xs)" .
  qed
qed

lemma perm_contr: assumes perm: "! xs ys. mset xs = mset ys --> (P xs = P ys)"
  and contr': "! x xs. P(x#x#xs) = P (x#xs)"
  shows "(P xs = P (remdups xs))"
  apply(rule perm_contr'[OF perm contr', rule_format]) by force

subsection "List properties closed under Perm, Weak and Contr are monotonic in the set of the list"

definition
  rem :: "'a => 'a list => 'a list" where
  "rem x xs = filter (%y. y ~= x) xs"

lemma rem: "x ~: set (rem x xs)"
  by(simp add: rem_def)

lemma length_rem: "length (rem x xs) <= length xs"
  by(simp add: rem_def)

lemma rem_notin: "x ~: set xs ==> rem x xs = xs"
  apply(simp add: rem_def)
  apply(rule filter_True)
  apply force
  done

lemma perm_weak_filter': assumes perm[rule_format]: "! xs ys. mset xs = mset ys --> (P xs = P ys)"
  and weak[rule_format]: "! x xs. P xs --> P (x#xs)"
shows "! ys. P (ys@filter Q xs) --> P (ys@xs)"
proof (rule allI, rule impI)
  fix ys
  define zs where \<open>zs = filter (Not \<circ> Q) xs\<close>
  assume \<open>P (ys @ filter Q xs)\<close>
  then have \<open>P (filter Q xs @ ys)\<close>
    apply (subst perm) defer apply assumption apply simp done
  then have \<open>P (zs @ filter Q xs @ ys)\<close>
    apply (induction zs)
     apply (simp_all add: weak)
    done
  with zs_def show \<open>P (ys @ xs)\<close>
    apply (subst perm) defer apply assumption apply simp done
qed

lemma perm_weak_filter: assumes perm: "! xs ys. mset xs = mset ys --> (P xs = P ys)"
  and weak: "! x xs. P xs --> P (x#xs)"
  shows "P (filter Q xs) ==> P xs"
  using perm_weak_filter'[OF perm weak, rule_format, of "[]", simplified]
  by blast

  \<comment> \<open>right, now in a position to prove that in presence of perm, contr and weak, set x leq set y and x : ded implies y : ded\<close>

lemma perm_weak_contr_mono:
  assumes perm: "! xs ys. mset xs = mset ys --> (P xs = P ys)"
  and contr: "! x xs. P (x#x#xs) --> P (x#xs)"
  and weak: "! x xs. P xs --> P (x#xs)"
  and xy: "set x <= set y"
  and Px : "P x"
  shows "P y"
proof -
  from contr weak have contr': "! x xs. P(x#x#xs) = P (x#xs)" by blast

  define y' where "y' = filter (% z. z : set x) y"
  from xy have "set x = set y'" apply(simp add: y'_def) apply blast done
  hence rxry': "mset (remdups x) = mset (remdups y')"
    using set_eq_iff_mset_remdups_eq by auto

  from Px perm_contr[OF perm contr'] have Prx: "P (remdups x)" by simp
  with rxry' have "P (remdups y')" apply (subst perm) defer apply assumption apply simp done

  with perm_contr[OF perm contr'] have "P y'" by simp
  thus "P y"
    apply(simp add: y'_def)
    apply(rule perm_weak_filter[OF perm weak]) .
qed

(* No, not used
subsection "Following used in Soundness"

primrec multiset_of_list :: "'a list \<Rightarrow> 'a multiset"
where
  "multiset_of_list [] = {#}"
| "multiset_of_list (x#xs) = {#x#} + multiset_of_list xs"

lemma count_count[symmetric]: "count x A = Multiset.count (multiset_of_list A) x"
  by (induct A) simp_all

lemma perm_multiset: "A <~~> B = (multiset_of_list A = multiset_of_list B)"
  apply(simp add: perm_count_conv)
  apply(simp add: multiset_eq_iff)
  apply(simp add: count_count)
  done

lemma set_of_multiset_of_list: "set_of (multiset_of_list A) = set A"
  by (induct A) auto
*)
end


text \<open> Version 0.4, last changed 2018-02-27
  (C) fovefi ltd, www.fovefi.co
  (author: Lukas Bulwahn [lubu@fovefi.co], comments by Manfred Kerber [make@fovefi.co])

  Dually licenced under
  Creative Commons Attribution (CC-BY) 4.0 [https://creativecommons.org/licenses/by/4.0/]
  ISC License (1-clause BSD License)       [https://www.isc.org/downloads/software-support-policy/isc-license/]
  See LICENSE files for details.
  (Rationale for this dual licence: http://arxiv.org/abs/1107.3212)

  In this file, an abstract definition of the  percentile function in Isabelle is given.
  The percentile function is defined as a linear approximation between points defined for a partial
  function defined for finitely many elements.

  It is perhaps best been explained with the help of an example.
  Let us assume that you have a list of 5 real numbers xs = [7, 9, 1, 4, 5] in order to compute a
  particular percentile, e.g., of 0.75, first you order the list and get sxs = [1, 4, 5, 8, 10]. Then you put 5 values
  (length of the list) on the unit interval [0;1] at equal distances of 1/5, staying away 1/10 from
  the left and right border, that is, you get [0.1, 0.3, 0.5, 0.7, 0.9]. For these values you take
  as percentile the corresponding value in the sorted list, that is, the percentile at 0.1 is  1, at
  0.3 is 4, at 0.5 is 5, at 0.7 is 8, and at 0.9 is 10. For values between any two values, the linear
  interpolation between a = 0.7 and b = 0.9 is taken, that is, as f(a) + (f(b) - f(a))/(b - a) * (x - a).
  In the example percentile at 0.75 it is 8 + (10 - 8)/(0.9 - 0.7) * (0.75 - 0.7)  = 8 + 2/0.2 * 0.05,
  that is, 8 + 10 * 0.05 = 8.5.

  Note that in this file an abstract definition and properties of the percentile
  function are given. The percentile function is not computational. A corresponding computational
  version is given in the sister document Percentile_Code.thy.

  The documents is structured as follows, first in a section preliminaries some properties are given
  that are needed later. In the next section points are put on the unit interval in the way described
  above. The following section contains an abstract definition of the percentile function. Finally
  some important properties are proved:
  - boundedness (upper and lower bound)
  - monotonicity
  - Lipschitz continuity
 \<close>

theory Percentile
  imports Complex_Main Linear_Interpolation

begin

section \<open>Preliminaries\<close>

subsection \<open>Addition to List\<close>
text \<open> Sorting the empty list results in the empty list.\<close>
lemma sort_eq_Nil_iff:
  "sort xs = [] \<longleftrightarrow> xs = []"
by (cases xs) auto

text \<open> Every element in a list is smaller than or equal to the last element. \<close>
lemma sorted_leq_last:
  assumes "sorted xs"
  assumes "x \<in> set xs"
  shows "x \<le> last xs"
using assms
  by (metis eq_iff in_set_conv_decomp_last last.simps last_append last_in_set list.simps(3) sorted.simps(2) sorted_append)

section \<open>From list of reals to @{typ "real \<Rightarrow> real option"}\<close>

text \<open> In order to define the percentile of a list of real numbers, the unit interval is sub-divided by
  putting a number of equidistantly distributed points on the line. The first point is put half
  a distance from 0, the last half a distance from 1. The distance is 1/(length list).
  real option means that the result is a partial function, that is, for a given value it will return either
  None (if the value is not in the domain) or Some with the position (if it is in the domain). \<close>
definition equidistant_points_on_unit_interval_of :: "real list \<Rightarrow> real \<Rightarrow> real option"
where
  "equidistant_points_on_unit_interval_of ys = (let xs = map (\<lambda>x. (1 / length ys) * (x + 0.5)) [0..<length ys]
     in map_of (zip xs ys))"

text \<open> Some examples to exemplify the definition \<close>
value "(\<lambda>ys. map (\<lambda>x. (1 / length ys) * (x + 0.5)) [0..<length ys]) []"
value "(\<lambda>ys. map (\<lambda>x. (1 / length ys) * (x + 0.5)) [0..<length ys]) [(1 :: real)]"
value "(\<lambda>ys. map (\<lambda>x. (1 / length ys) * (x + 0.5)) [0..<length ys]) [1, (2 :: real)]"
value "(\<lambda>ys. map (\<lambda>x. (1 / length ys) * (x + 0.5)) [0..<length ys]) [1,2, (3 :: real)]"
value "(\<lambda>ys. map (\<lambda>x. (1 / length ys) * (x + 0.5)) [0..<length ys]) [1,2,3, (4 :: real)]"

text \<open> The number of equidistant points is finite.\<close>
lemma finite_equidistant_points_on_unit_interval_of [simp]:
  "finite (dom (equidistant_points_on_unit_interval_of ys))"
unfolding equidistant_points_on_unit_interval_of_def by simp

text \<open> In a well-ordered set, {a..<b} is the set of all elements between a and b (a included, b excluded)
  If this set is non-empty and finite, a is its minimum. \<close>
lemma Min_intv:
  assumes "{a..<b} \<noteq> {}"
 assumes "finite {a..<b}"
  shows "Min {a..<b} = a"
using assms by (auto intro: Min_eqI)

text \<open> For a set {a..<b} of natural numbers is the set of all elements between a and b
 (a included, b excluded). If that set is non-empty and finite, b-1 is its maxumum. \<close>
lemma Max_intv:
  assumes "{a..<b} \<noteq> {}"
  shows "Max {a..<(b :: nat)} = b - 1"
using assms by (auto intro!: Max_eqI)

text \<open> The values of equidistant_points_on_unit_interval_of are exactly the values given by its
  definition and none more. \<close>
lemma dom_equidistant_points_on_unit_interval_of:
  "dom (equidistant_points_on_unit_interval_of ys) = (\<lambda>x. (1 / length ys) * (x + 0.5)) ` {0..<length ys}"
proof -
  have "distinct (map (\<lambda>x. (1 / length ys) * (x + 0.5)) [0..<length ys])"
    by (auto intro!: inj_onI simp add: distinct_map )
  show ?thesis
    unfolding equidistant_points_on_unit_interval_of_def by (auto simp add: \<open>distinct _\<close>)
qed

text \<open> The minimal value of equidistant_points_on_unit_interval_of is at half the distant from 0. \<close>
lemma Min_equidistant_points_on_unit_interval_of:
  assumes "ys \<noteq> []"
  shows "Min (dom (equidistant_points_on_unit_interval_of ys)) = 1 / (2 * length ys)"
proof -
  have "incseq (\<lambda>x. (1 / length ys) * (x + 0.5))"
    by (auto simp add: incseq_def divide_right_mono)
  from this dom_equidistant_points_on_unit_interval_of show ?thesis
    using \<open>ys \<noteq> []\<close> \<open>incseq _\<close> by (auto simp add: mono_Min_commute[symmetric] Min_intv)
qed

text \<open> The maximal value of equidistant_points_on_unit_interval_of is at half the distant from 1. \<close>
lemma Max_equidistant_points_on_unit_interval_of:
  assumes "ys \<noteq> []"
  shows "Max (dom (equidistant_points_on_unit_interval_of ys)) = 1 - 1 / (2 * length ys)"
proof -
  have "incseq (\<lambda>x. (1 / length ys) * (x + 0.5))"
    by (auto simp add: incseq_def divide_right_mono)
  from this dom_equidistant_points_on_unit_interval_of show ?thesis
    using \<open>ys \<noteq> []\<close> \<open>incseq _\<close> apply (auto simp add: mono_Max_commute[symmetric] Max_intv)
    apply (subst of_nat_diff)
     defer
     apply simp
    apply (simp add: diff_divide_distrib)
    using not_less by fastforce
qed

text \<open> The following lemma states that the points where the function given by
  equidistant_points_on_unit_interval_of is
  defined are all in the interval between 1/(2 * length ys) and 1 - 1/(2 * length ys), that is,
  the minimal and maximal value as proved in the two lemmas above. \<close>
lemma defined_interval_of_equidistant_points_on_unit_interval_of:
  assumes "ys \<noteq> []"
  shows "defined_interval_of (equidistant_points_on_unit_interval_of ys) = {1 / (2 * length ys)..1 - 1 / (2 * length ys)}"
using assms unfolding defined_interval_of_def
apply (simp add:  Min_equidistant_points_on_unit_interval_of Max_equidistant_points_on_unit_interval_of)
proof -
  assume "ys \<noteq> []"
  then have "[] \<noteq> [0..<length ys]"
    by (metis length_greater_0_conv length_map map_nth)
  then have "\<exists>r. r \<in> {r. map_of (zip (map (\<lambda>n. 1 / real (length ys) * (real n + 5 / 10)) [0..<length ys]) ys) r \<noteq> None}"
    by fastforce
  then show "equidistant_points_on_unit_interval_of ys = Map.empty \<longrightarrow> \<not> 1 \<le> real (length ys)"
    using equidistant_points_on_unit_interval_of_def by force
qed

text \<open> On the points where (equidistant_points_on_unit_interval_of ys) is defined, the resulting values are the ys. \<close>

lemma ran_equidistant_points_on_unit_interval_of:
  "ran (equidistant_points_on_unit_interval_of ys) = set ys"
proof -
  have "length (map (\<lambda>x. (real x + 1 / 2) / real (length ys)) [0..<length ys]) = length ys"
    by simp
  have distinct: "distinct (map (\<lambda>x. (real x + 1 / 2) / real (length ys)) [0..<length ys])"
    by (auto simp add: distinct_map intro!: inj_onI)
  show ?thesis
    unfolding equidistant_points_on_unit_interval_of_def
    apply simp
    apply (rule ran_map_of_zip)
    apply (auto simp add: distinct)
    done
qed

section \<open>Definition of percentile\<close>

definition epsilon :: real
  where
    "epsilon  = 1 / 10"

text \<open> Percentile is a linear approximation of the equidistant points on the unit interval of the sorted list.
  E.g., for a list [3,1,4,8,6], the x percentile is determined by first sorting the list to [1,3,4,6,8],
  then the unit interval is subdivided by adding the 5 points 0.1, 0.3, 0.5, 0.7, and 0.9. The 0.1
  percentile is then 1, the 0.3 percentile 3, the 0.5 percentile 4, and so on. For values in between,
  e.g., the 0.4 percentile, a linear approximation of the 0.3 percentile and the 0.5 percentile is computed,
  that is, in this case the value is precisely between 3 and 4, that is, 3.5.
  Note that this expression deals with a priori infinite objects and is as a consequence not computational.
  A computational version of percentile can be found in Percentile_Code.thy. \<close>
definition percentile :: "real list \<Rightarrow> real \<Rightarrow> real"
where
  "percentile ys x = linear_approximation (equidistant_points_on_unit_interval_of (sort ys)) (x - epsilon)"

section \<open>Alternative definition of percentile implementation\<close>

lemma neighbors_alternative_pseudo_def:
  assumes "x \<notin> dom p"
  shows "neighbors p x = (Max {x' \<in> dom p. x' < x}, Min {x' \<in> dom p. x \<le> x'})"
proof -
  have "Max {x' \<in> dom p. x' \<le> x} = Max {x' \<in> dom p. x' < x}"
    by (smt Collect_cong assms)
  from this show ?thesis
    unfolding neighbors_def by simp
qed

lemma percentile_alternative_pseudo_def:
  assumes "x - epsilon \<noteq> 1 / (2 * length ys)"
  shows "percentile ys x =
    (let p = (equidistant_points_on_unit_interval_of (sort ys));
    (x1, x2) = (Max {x' \<in> dom p. x' < (x - epsilon)}, Min {x' \<in> dom p. (x - epsilon) \<le> x'});
    (y1, y2) = (the (p x1), the (p x2))
    in linear (x1, y1) (x2, y2) (x - epsilon)
    )"
proof (cases "(x - epsilon) \<in> dom (equidistant_points_on_unit_interval_of (sort ys))")
  case True
  have "finite (dom (equidistant_points_on_unit_interval_of (sort ys)))"
    by simp
  from True this show ?thesis
    unfolding percentile_def linear_approximation_def
    apply simp
    using \<open>finite (dom (equidistant_points_on_unit_interval_of (sort ys)))\<close>
    by (smt Collect_cong Pair_inject case_prod_conv defined_point_neighbors_eq linear_first linear_second neighbors_def)
next
  case False
  then show ?thesis
    unfolding percentile_def linear_approximation_def
    apply (subst neighbors_alternative_pseudo_def)
    apply simp
    apply (simp add: Let_def) done
qed

section \<open>Properties of Percentile\<close>

text \<open> The percentile function has an upper bound, the maximal value in the associated set. \<close>
lemma percentile_upper_bound:
  assumes "ys \<noteq> []"
  assumes "1 / (2 * length ys) \<le> (x - epsilon) \<and> (x - epsilon) \<le> 1 - 1 / (2 * length ys)"
  shows "percentile ys x \<le> Max (set ys)"
proof -
  have "percentile ys x = linear_approximation (equidistant_points_on_unit_interval_of (sort ys)) (x - epsilon)"
    unfolding percentile_def ..
  also have "\<dots> \<le> Max (ran (equidistant_points_on_unit_interval_of (sort ys)))"
  proof -
    have "finite (dom (equidistant_points_on_unit_interval_of (sort ys)))" by simp
    moreover have "(x - epsilon) \<in> defined_interval_of (equidistant_points_on_unit_interval_of (sort ys))"
      using defined_interval_of_equidistant_points_on_unit_interval_of
      using assms(1, 2) atLeastAtMost_iff
      by (simp add: sort_eq_Nil_iff)
    ultimately show ?thesis by (rule upper_bound)
  qed
  also have "\<dots> = Max (set ys)"
    using ran_equidistant_points_on_unit_interval_of \<open>ys \<noteq> []\<close> by simp
  finally show ?thesis .
qed

text \<open> The percentile function has a lower bound, the minimal value in the associated set. \<close>
lemma percentile_lower_bound:
  assumes "ys \<noteq> []"
  assumes "1 / (2 * length ys) \<le> (x - epsilon) \<and> (x - epsilon) \<le> 1 - 1 / (2 * length ys)"
  shows "Min (set ys) \<le> percentile ys x"
proof -
  have "Min (set ys) = Min (ran (equidistant_points_on_unit_interval_of (sort ys)))"
    using ran_equidistant_points_on_unit_interval_of \<open>ys \<noteq> []\<close> by simp
  also have "\<dots> \<le>  linear_approximation (equidistant_points_on_unit_interval_of (sort ys)) (x - epsilon)"
  proof -
    have "finite (dom (equidistant_points_on_unit_interval_of (sort ys)))" by simp
    moreover have "(x - epsilon) \<in> defined_interval_of (equidistant_points_on_unit_interval_of (sort ys))"
      using defined_interval_of_equidistant_points_on_unit_interval_of
      using assms(1, 2) atLeastAtMost_iff
      by (simp add: sort_eq_Nil_iff)
    ultimately show ?thesis by (rule lower_bound)
  qed
  also have "\<dots> = percentile ys x"
    unfolding percentile_def ..
  finally show ?thesis .
qed

text \<open> In a sorted list of distinct elements with indices i and j holds that i is smaller than
  (or equal to) j if and only if the ith element is smaller than (or equal to) the jth. \<close>
lemma nth_leq_iff_index_leq:
  assumes "distinct xs" "sorted xs"
  assumes "i < length xs" "j < length xs"
  shows "xs ! i \<le> xs ! j \<longleftrightarrow> i \<le> j"
  using assms
  by (metis antisym nat_le_linear nth_eq_iff_index_eq sorted_nth_mono)

text \<open> If x \<le> x' and both correspond to a value of equidistant_points_on_unit_interval_of, that is,
 * they are both defined then for the values y and y' it also holds that y \<le> y'. \<close>
lemma sorted_imp:
  assumes "sorted ys"
  assumes "equidistant_points_on_unit_interval_of ys x = Some y"
  assumes "equidistant_points_on_unit_interval_of ys x' = Some y'"
  assumes "x \<le> x'"
  shows "y \<le> y'"
proof -
  let ?xs = "map (\<lambda>x. (1 / length ys) * (x + 0.5)) [0..<length ys]"
  from assms(2) have "x \<in> dom (equidistant_points_on_unit_interval_of ys)" by blast
  from this obtain i where "x = ?xs ! i" and "i < length ys"
    unfolding equidistant_points_on_unit_interval_of_def
    apply auto
    by blast
  from assms(3) have "x' \<in> dom (equidistant_points_on_unit_interval_of ys)" by blast
  from this obtain i' where "x' = ?xs ! i'" and "i' < length ys"
    unfolding equidistant_points_on_unit_interval_of_def
    apply auto apply force done
  have "sorted ?xs \<and> distinct ?xs"  using inj_onI divide_right_mono distinct_map
    by (auto intro!: inj_onI simp add: divide_right_mono sorted_iff_nth_mono_less distinct_map)
  have "length ?xs = length ys" by auto
  from assms(2) \<open>x = _\<close> \<open>i < _\<close> have "y = ys ! i"
    unfolding equidistant_points_on_unit_interval_of_def
    using \<open>length _ = length _\<close> \<open>sorted _ \<and> distinct _\<close> by (metis map_of_zip_nth option.inject)
  from assms(3) \<open>x' = _\<close> \<open>i' < _\<close> have "y' = ys ! i'"
    unfolding equidistant_points_on_unit_interval_of_def
    using \<open>length _ = length _\<close> \<open>sorted _ \<and> distinct _\<close> by (metis map_of_zip_nth option.inject)
  from \<open>sorted _ \<and> distinct _\<close> \<open>x \<le> x'\<close> have "i \<le> i'"
    using \<open>x = _\<close> \<open>x' = _\<close> \<open>i < _\<close> \<open>i'< _\<close> \<open>length ?xs = length ys\<close>
    using nth_leq_iff_index_leq by fastforce
  show ?thesis
    using \<open>i \<le> i'\<close> \<open>y = ys ! i\<close> \<open>y' = ys ! i'\<close> \<open>i' < length ys\<close> \<open>sorted ys\<close>
    by (simp add: sorted_nth_mono)
qed

text \<open> The percentile function is (weakly) monotonic increasing. \<close>
lemma percentile_monotonic:
  assumes "ys \<noteq> []"
  assumes "1 / (2 * length ys) \<le> x - epsilon" "x'- epsilon \<le> 1 - 1 / (2 * length ys)"
  assumes "x \<le> x'"
  shows "percentile ys x \<le> percentile ys x'"
proof -
  have "percentile ys x = linear_approximation (equidistant_points_on_unit_interval_of (sort ys)) (x - epsilon)"
    unfolding percentile_def ..
  also have "\<dots> \<le> linear_approximation (equidistant_points_on_unit_interval_of (sort ys)) (x' - epsilon)"
  proof -
    from \<open>ys \<noteq> []\<close> have s: "sort ys \<noteq> []" by (simp add: sort_eq_Nil_iff)
    have "finite (dom (equidistant_points_on_unit_interval_of (sort ys)))" by simp
    moreover have "(x - epsilon) \<in> defined_interval_of (equidistant_points_on_unit_interval_of (sort ys))"
      using defined_interval_of_equidistant_points_on_unit_interval_of
      using assms s atLeastAtMost_iff
      by fastforce
    moreover have "(x' - epsilon) \<in> defined_interval_of (equidistant_points_on_unit_interval_of (sort ys))"
      using defined_interval_of_equidistant_points_on_unit_interval_of
      using assms atLeastAtMost_iff s by fastforce
    moreover have "\<forall>x x' y y'. x \<le> x' \<and> equidistant_points_on_unit_interval_of (sort ys) x = Some y
      \<and> equidistant_points_on_unit_interval_of (sort ys) x' = Some y' \<longrightarrow> y \<le> y'"
      using sorted_imp sorted_sort by blast
    moreover note \<open>x \<le> x'\<close>
    ultimately show ?thesis by (simp add: \<open>x \<le> x'\<close> linear_approximation_monotonic)
  qed
  also have "\<dots> \<le> percentile ys x'"
    unfolding percentile_def ..
  finally show ?thesis .
qed

text \<open> The percentile function is Lipschitz continuous. \<close>
lemma percentile_Lipschitz:
  assumes "ys \<noteq> []"
  assumes "1 / (2 * length ys) \<le> (x - epsilon) \<and> (x - epsilon) \<le> 1 - 1 / (2 * length ys)"
  assumes "1 / (2 * length ys) \<le> (x' - epsilon) \<and> (x' - epsilon) \<le> 1 - 1 / (2 * length ys)"
  shows "\<exists>K. \<bar>percentile ys x' - percentile ys x\<bar> \<le> K * \<bar>x' - x\<bar>"
proof -
  have "finite (dom (equidistant_points_on_unit_interval_of (sort ys)))" by simp
  moreover have "(x - epsilon) \<in> defined_interval_of (equidistant_points_on_unit_interval_of (sort ys))"
    using defined_interval_of_equidistant_points_on_unit_interval_of
    using assms(1, 2) atLeastAtMost_iff
    by (simp add: sort_eq_Nil_iff)
  moreover have "(x' - epsilon) \<in> defined_interval_of (equidistant_points_on_unit_interval_of (sort ys))"
    using defined_interval_of_equidistant_points_on_unit_interval_of
    using assms(1, 3) atLeastAtMost_iff
    by (simp add: sort_eq_Nil_iff)
  ultimately show ?thesis
    unfolding percentile_def using linear_approximation_Lipschitz by fastforce
qed

end