section \<open>Path\<close>
theory Path
  imports Explain_Definition
begin

text \<open>A path is defined from a node to a descendant,
      the graph is represented by an array containing the parents of each node,
      as used in the union find algorithm.\<close>

inductive path :: "nat list \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> bool" where
  single: "n < length l \<Longrightarrow> path l n [n] n" |
  step: "r < length l \<Longrightarrow> l ! u = r \<Longrightarrow> l ! u \<noteq> u \<Longrightarrow>  path l u p v \<Longrightarrow> path l r (r # p) v"

lemma path_not_empty: "path l u p v \<Longrightarrow> p \<noteq> []"
  by(induction rule:path.induct,auto)

lemma path_concat1: "path l u p1 v \<Longrightarrow> path l v p2 w \<Longrightarrow> path l u (p1 @ tl p2) w"
proof(induction rule: path.induct)
  case (single n l)
  then show ?case
    by (metis append_Cons append_eq_append_conv2 append_self_conv list.distinct(1) list.exhaust_sel list.sel(1) list.sel(3) path.simps)
qed(simp add: path.step)

lemma path_concat2: "path l u p1 v \<Longrightarrow> path l v p2 w \<Longrightarrow> path l u (butlast p1 @ p2) w"
proof(induction rule: path.induct)
  case (step r l u p v)
  then show ?case
    using path.cases path.step by fastforce
qed simp

lemma path_snoc:
  "path l u p (l ! v) \<Longrightarrow> v < length l \<Longrightarrow> l ! v < length l \<Longrightarrow> l ! v \<noteq> v \<Longrightarrow> path l u (p @ [v]) v"
proof-
  assume p: "path l u p (l!v)" and "v < length l" and a: "l ! v < length l" and b:"l ! v \<noteq> v"
  then have "path l v [v] v"
    by (simp add: single)
  with a b have "path l (l!v) [l!v,v] v"
    by (simp add: step)
  with p path_concat1 show "path l u (p@[v]) v"
    by fastforce
qed

lemma path_divide1:
  "path l u (p1 @ p2) v \<Longrightarrow> p1 \<noteq> [] \<Longrightarrow> path l u p1 (last p1) \<and> path l (last p1) (last p1 # p2) v"
proof(induction l u "p1 @ p2" v arbitrary: p1 p2 rule: path.induct)
  case (single n l)
  then show ?case
    by (simp add: path.single)
next
  case (step r l u p v)
  show ?case
  proof(cases "p2")
    case Nil
    then show ?thesis
      by (metis append_self_conv last.simps path.step single step(1-6))
  next
    case (Cons a list)
    with step have "tl p1 \<noteq> [] \<Longrightarrow> path l u (tl p1) (last (tl p1)) \<and>
    path l (last (tl p1)) (last (tl p1) # p2) v"
      by (metis list.sel(3) tl_append2)
    with step path.step single show ?thesis
      by (metis hd_Cons_tl hd_append2 last_ConsL last_tl list.sel(1) self_append_conv2 tl_append2)
  qed
qed

lemma path_divide2: "path l u (p1 @ p2) v \<Longrightarrow> p2 \<noteq> [] \<Longrightarrow> path l u (p1 @ [hd p2]) (hd p2) \<and> path l (hd p2) p2 v"
proof(induction l u "p1 @ p2" v arbitrary: p1 p2 rule: path.induct)
  case (single n l)
  then show ?case
    by (simp add: path.single)
next
  case (step r l u p v)
  show ?case
  proof(cases "p1")
    case Nil
    then show ?thesis
      by (metis append_self_conv2 list.sel(1) path.step single step(1,2,3,4,6))
  next
    case (Cons a list)
    then show ?thesis
      using path.step step by auto
  qed
qed

lemma path_hd: "path l u p v \<Longrightarrow> hd p = u"
  by(induction rule: path.induct, auto)
lemma hd_path: "path l k p v \<Longrightarrow> hd p = u \<Longrightarrow> u = k"
  by(induction rule: path.induct, auto)

lemma path_last: "path l u p v \<Longrightarrow> last p = v"
proof(induction rule: path.induct)
  case (step r l u p v)
  then show ?case
    by (metis last_ConsR list.distinct(1) path.cases)
qed auto
lemma last_path: "path l k p v \<Longrightarrow> last p = u \<Longrightarrow> u = v"
proof(induction rule: path.induct)
  case (step r l u p v)
  then show ?case
    by (simp add: path_not_empty)
qed auto

lemma path_penultimate: "path l u p v \<Longrightarrow> length p > 1 \<Longrightarrow> last (butlast p) = l ! v"
proof(induction rule: path.induct)
  case (single n l)
  have "False"
    using single.prems by auto
  then show ?case by simp
next
  case (step r l u p v)
  then show ?case
  proof(cases "length p = 1")
    case True
    with step show ?thesis
      by (metis One_nat_def Suc_to_right butlast.simps(2) last_ConsL length_butlast less_numeral_extra(1) less_numeral_extra(3) list_decomp_1 list_tail_coinc path.cases path_last)
  next
    case False
    with step show ?thesis
      by (metis butlast.simps(2) last_ConsR length_Cons length_butlast less_SucE less_numeral_extra(3) list.size(3) zero_less_diff)
  qed
qed

corollary paths_iff:
  "path l u p1 v \<and> path l v p2 w \<longleftrightarrow> hd p2 = v \<and> last p1 = v \<and> p2 \<noteq> [] \<and> p1 \<noteq> [] \<and> path l u (p1 @ tl p2) w"
proof
  assume assms:"path l u p1 v \<and> path l v p2 w"
  then have "last p1 = v" and "hd p2 = v"
    using path_last path_hd by auto
  with assms have "p2 \<noteq> []" and "p1 \<noteq> []"
    by (metis list.discI path.cases)+
  then show "hd p2 = v \<and> last p1 = v \<and> p2 \<noteq> [] \<and> p1 \<noteq> [] \<and> path l u (p1 @ tl p2) w"
    using assms path_concat1 \<open>last p1 = v\<close> \<open>hd p2 = v\<close> by blast
next
  assume assms: "hd p2 = v \<and> last p1 = v \<and> p2 \<noteq> [] \<and> p1 \<noteq> [] \<and> path l u (p1 @ tl p2) w"
  then show "path l u p1 v \<and> path l v p2 w"
    by (metis path_divide1 list.collapse)
qed

inductive_cases path_single: "path l u [k] v"

lemma path_length_1: "path l u [k] v \<longleftrightarrow> u = k \<and> v = k \<and> length l > k"
proof
  assume "path l u [k] v"
  with path_single path_not_empty show "u = k \<and> v = k \<and> length l > k"
    by metis
next
  assume "u = k \<and> v = k \<and> length l > k"
  then show "path l u [k] v"
    by (simp add: single)
qed

lemma path_nodes_lt_length_l: "path l u p v \<Longrightarrow> u < length l \<and> v < length l"
  by (induction rule: path.induct, auto)

lemma path_unique_if_length_eq:
  assumes "path l x p1 v"
    and "path l y p2 v"
    and "ufa_invar l"
    and "length p1 = length p2"
  shows "p1 = p2 \<and> x = y"
  using assms proof(induction arbitrary: p2 y rule: path.induct)
  case (single n l)
  obtain k where "path l y [k] n" and "p2 = [k]"
    using list_decomp_1 single.prems by fastforce
  then show ?case
    by (simp add: path_length_1)
next
  case (step r l u p v)
  then have "tl p2 = p \<and> hd (tl p2) = u"
    by (metis len_greater_imp_nonempty length_tl list.sel(3) list_eq_iff_nth_eq path.cases path_hd)
  with step show ?case
    by (metis list.sel(3) path.cases path_hd path_not_empty)
qed

lemma path_properties:
  assumes "path l x p y"
  shows "p \<noteq> [] \<and> (\<forall> i > 0 . i < length p \<longrightarrow> l ! (p ! i) = (p ! (i - 1))) \<and> hd p = x \<and> last p = y
         \<and> (\<forall> i < length p . p ! i < length l) \<and> (\<forall> i > 0 . i < length p \<longrightarrow> p ! i \<noteq> (p ! (i - 1)))"
  using assms proof(induction rule: path.induct)
  case (single n l)
  then show ?case by auto
next
  case (step r l u p v)
  then have *:"(\<forall>i>1. i < Suc (length p) \<longrightarrow> l ! (p ! (i - 1)) = (r # p) ! (i - 1))"
    by (metis One_nat_def Suc_diff_1 Suc_lessD Suc_less_eq  nth_Cons_pos)
  from step have "(\<forall> i < length p. p!i < length l)" by simp
  then have **:"(\<forall> i < length (r#p). (r#p)!i < length l)"
    by (simp add: nth_Cons' step.hyps(1))
  with step  have "\<forall>i>0. i < length (r # p) \<longrightarrow> (r # p) ! i \<noteq> (r # p) ! (i - 1)"
    by (metis (no_types, lifting) One_nat_def Suc_pred hd_conv_nth length_Cons nat_neq_iff not_less_eq nth_Cons')
  with step show ?case
    by (metis * ** hd_conv_nth last_ConsR length_Cons list.discI list.sel(1) neq0_conv nth_Cons_pos zero_less_diff)
qed

corollary path_parent:
  assumes "path l x p y" "i < length p" "i > 0"
  shows "l ! (p ! i) = (p ! (i - 1))"
  using assms path_properties by presburger

lemma path_no_cycle:
  assumes invar: "ufa_invar l"
    and n: "n < length l"
    and path: "path l n p n"
  shows "p = [n]"
proof(rule ccontr)
  assume contr: "p \<noteq> [n]"
  have "p \<noteq> [] \<and> hd p = n \<and> last p = n"
    using assms(3) paths_iff by blast
  then have p_length: "length p > 1"
    by (metis contr last.simps less_one list_decomp_1 nat_neq_iff slice_complete slice_eq_bounds_empty)
  have "\<not> rep_of_dom (l, n)"
    using invar n path contr p_length
  proof(induction arbitrary: p rule: rep_of_induct)
    case (base i)
    from base(4) base(3) have "p = [i]"
      using path_single
      by(induction rule: path.induct,simp,blast)
    with base.prems(2) show ?case
      by simp
  next
    case (step i)
    from step(5,7) have penultimate: "last (butlast p) = l ! i"
      by (rule path_penultimate)
    have p:"(butlast p) @ [i] = p"
      by (metis paths_iff snoc_eq_iff_butlast step.prems(1))
    then have "path l i ((butlast p) @ [i]) i" and "(butlast p) \<noteq> []"
      using p step.prems(1,2) by auto
    then have "path l i (butlast p) (l ! i)"
      and "path l (l ! i) [l ! i, i] i"
      using path_divide1 penultimate
      by metis+
    then have "path l (l ! i) ([l ! i, i]@ tl (butlast p)) (l ! i)"
      using path_concat1 by blast
    then have "\<not> rep_of_dom (l, l ! i)"
      using step.IH by auto
    then show ?case
      using rep_of_domain by metis
  qed
  with assms show "False"
    using path_nodes_lt_length_l ufa_invarD(1) by auto
qed

lemma path_to_root_has_length_1: "ufa_invar l \<Longrightarrow> path l u p1 v \<Longrightarrow> l ! v = v \<Longrightarrow> p1 = [v]"
proof(induction "length p1" arbitrary: p1)
  case 0
  then show ?case
    by (simp add: path_not_empty)
next
  case (Suc x)
  then show ?case
  proof(cases x)
    case 0
    with path_length_1 Suc show ?thesis
      by (metis length_0_conv length_Suc_conv)
  next
    case Suc':(Suc nat)
    then have "path l u (butlast p1) (last (butlast p1))"
      using Suc path_divide1 path_divide2
      by (metis butlast_snoc len_greater_imp_nonempty length_Suc_rev_conv lessI)
    then have *: "path l u (butlast p1) (last (butlast p1))"
      using Suc path_divide1 path_divide2
      by metis
    with Suc have **: "l ! (p1 ! (length p1 - 1)) = (p1 ! (length p1 - 1 - 1))"
      by (metis diff_less length_butlast length_greater_0_conv path_properties zero_less_one)
    with Suc have "l ! v = last (butlast p1)"
      by (metis (mono_tags, lifting) Suc.prems(2) * diff_less last_conv_nth length_butlast length_greater_0_conv nth_butlast path_last path_not_empty zero_less_one)
    with Suc.prems have "v = last (butlast p1)"
      by auto
    with Suc have "p1 ! (length p1 - 1) = p1 ! (length p1 - 1 - 1)"
      by (metis ** last_conv_nth length_upt list.size(3) not_one_less_zero path_last upt_rec)
    with path_properties Suc have "False"
      by (metis *  diff_less length_butlast length_greater_0_conv zero_less_one)
    then show ?thesis by simp
  qed
qed

text \<open>The path between two nodes is unique.\<close>

theorem path_unique: "ufa_invar l \<Longrightarrow> path l u p1 v \<Longrightarrow> path l u p2 v \<Longrightarrow> p1 = p2"
proof-
  assume a1: "ufa_invar l" and a2: "path l u p1 v" and a3: "path l u p2 v"
  have a4: "v < length l"
    using a2 path_nodes_lt_length_l by auto
  show "p1 = p2"
    using a1 a4 a2 a3
  proof(induction arbitrary: p1 p2 rule: rep_of_induct)
    case (base i)
    then have "p1 = [i]" "p2 = [i]" using path_to_root_has_length_1
      by blast+
    then show ?case
      by blast
  next
    case (step i)
    then show ?case
    proof(cases "length p1 > 1 \<and> length p2 > 1")
      case True
      have **: "path l u (butlast p1) (last (butlast p1))"
        using step path_divide1 path_divide2
        by (metis True append_butlast_last_id length_butlast less_numeral_extra(3) less_or_eq_imp_le list.size(3) not_one_le_zero zero_less_diff)
      then have *: "path l u (butlast p2) (last (butlast p2))"
        using step path_divide1 path_divide2
        by (metis True append_butlast_last_id length_butlast less_numeral_extra(3) less_or_eq_imp_le list.size(3) not_one_le_zero zero_less_diff)
      then have "l ! (p2 ! (length p2 - 1)) = (p2 ! (length p2 - 1 - 1))"
        by (metis One_nat_def Suc_lessD True diff_less path_properties step.prems(2) zero_less_diff zero_less_one)
      then have last_p2: "l ! i = last (butlast p2)"
        by (metis (mono_tags, opaque_lifting) * butlast_update' last_list_update length_butlast list_update_id path_last path_not_empty step.prems(2))
      then have "l ! (p1 ! (length p1 - 1)) = (p1 ! (length p1 - 1 - 1))"
        using True path_properties step.prems(1) by force
      then have "l ! (p1 ! (length p1 - 1)) = last (butlast p1)"
        by (metis True last_conv_nth path_last path_not_empty path_penultimate step.prems(1))
      then have "l ! i = last (butlast p1)"
        using True path_penultimate step.prems(1) by auto
      with step show ?thesis
        by (metis last_p2 * ** append_butlast_last_id path_properties)
    next
      case False
      with path_not_empty have length_p: "length p1 = 1 \<or> length p2 = 1"
        by (metis length_0_conv less_one linorder_neqE_nat step.prems(1) step.prems(2))
      then have "i = u"
        by (metis list_decomp_1 path_length_1 step.prems)
      then have "p1 = [i] \<and> p2 = [i]"
        using a1 path_no_cycle step by blast
      then show ?thesis by simp
    qed
  qed
qed

lemma path_rep_eq: "path l v p u \<Longrightarrow> ufa_invar l \<Longrightarrow> rep_of l v = rep_of l u"
proof(induction rule: path.induct)
  case (single n l)
  then show ?case by auto
next
  case (step r l u p v)
  then have "rep_of l u = rep_of l r"
    using path_nodes_lt_length_l rep_of_idx by auto
  with step show ?case
    by simp
qed

lemma path_to_rep_of:
  assumes "ufa_invar l"
    and "x < length l"
  obtains p where "path l (rep_of l x) p x"
  using assms proof(induction arbitrary: thesis rule: rep_of_induct)
  case (base i)
  then have "rep_of l i = i"
    by (simp add: rep_of_refl)
  then show ?case
    using base path_length_1 by blast
next
  case (step i)
  from step(4) obtain p where p: "path l (rep_of l (l ! i)) p (l ! i)"
    by blast
  have "path l (l ! i) [l ! i, i] i"
    by (simp add: path.step single step ufa_invarD(2))
  then have "path l (rep_of l (l ! i)) (p @ [i]) i"
    using p path_concat1 by force
  then show ?case
    using rep_of_idx step by auto
qed

lemma path_root: "path l x p r \<Longrightarrow> l ! r = r \<Longrightarrow> x = r"
  by(induction rule: path.induct, auto)

lemma path_no_root: "path l y p x \<Longrightarrow> x \<noteq> y \<Longrightarrow> l ! x \<noteq> x"
  using path_root by auto

lemma path_butlast: "path l y p v \<Longrightarrow> y \<noteq> v \<Longrightarrow> path l y (butlast p) (l ! v)"
proof-
  assume path:"path l y p v"
    and "y \<noteq> v"
  then have "v < length l"
    by (simp add: path_nodes_lt_length_l)
  have "v \<noteq> l ! v"
    using \<open>y \<noteq> v\<close> path path_root by auto
  have "length p > 1"
    by (metis \<open>y \<noteq> v\<close> last.simps length_greater_0_conv less_one linorder_neq_iff list_decomp_1 nth_append_length path path.cases path_last path_not_empty)
  have penultimate: "last (butlast p) = l ! v"
    using \<open>1 < length p\<close> path path_penultimate by blast
  then have "path l (l ! v) [l ! v, v] v"
    by (metis (mono_tags, lifting) \<open>y \<noteq> v\<close> append_butlast_last_id hd_rev last.simps path path_divide1 path_hd path_last rev.simps)
  then show ?thesis
    by (metis penultimate \<open>y \<noteq> v\<close> append_butlast_last_id empty_append_eq_id list.sel(1) path path_divide1 path_hd path_last path_not_empty)
qed

lemma path_not_first_no_root:
  assumes "path l x p y"
    and "i < length p"
    and "i > 0"
  shows "l ! (p ! i) \<noteq> p ! i"
  using assms proof(induction arbitrary: i rule: path.induct)
  case (single n l)
  then show ?case by auto
next
  case (step r l u p v)
  have "(r # p) ! i = p ! (i - 1)"
    by (simp add: step.prems(2))
  then show ?case
  proof(cases "i = 1")
    case True
    with step show ?thesis
      by (metis \<open>(r # p) ! i = p ! (i - 1)\<close> cancel_comm_monoid_add_class.diff_cancel hd_conv_nth path_properties)
  next
    case False
    with step show ?thesis
      by (metis One_nat_def Suc_diff_1 Suc_less_eq \<open>(r # p) ! i = p ! (i - 1)\<close> length_Cons not_gr_zero)
  qed
qed

lemma nodes_path_lt_length_l:
  assumes "path l x p y"
    and "i < length p"
  shows "p ! i < length l"
proof-
  have "path l x (take i p @ [p ! i]) (p ! i)"
    by (metis Cons_nth_drop_Suc append_take_drop_id assms(1) assms(2) hd_drop_conv_nth list.discI path_divide2)
  then show ?thesis
    using path_nodes_lt_length_l by auto
qed

lemma nodes_path_rep_of:
  assumes "path l x p y"
    and "i < length p"
    and "ufa_invar l"
  shows "rep_of l (p ! i) = rep_of l x"
    and "rep_of l (p ! i) = rep_of l y"
proof-
  have "path l x (take i p @ [p ! i]) (p ! i)" "path l (p ! i) (drop i p) y"
    by (metis Cons_nth_drop_Suc append_take_drop_id assms(1) assms(2) hd_drop_conv_nth list.discI path_divide2)+
  with assms show "rep_of l (p ! i) = rep_of l x"
    and "rep_of l (p ! i) = rep_of l y"
    using path_rep_eq by metis+
qed

lemma path_root_rep_of_dom: "path l root p i \<Longrightarrow> l ! root = root \<Longrightarrow> rep_of_dom (l, i)"
proof(induction "length p" arbitrary: p i)
  case 0
  then have "length p > 0"
    using path_not_empty by auto
  then show ?case
    by (simp add: "0.hyps")
next
  case (Suc x)
  then show ?case proof(cases "x = 0")
    case True
    with Suc have "hd p = root" "last p = i"
      by (auto simp add: path_hd path_last)
    with True have "i = root"
      by (metis Suc.hyps(2) last_replicate le_antisym length_0_conv length_greater_0_conv lessI remdups_adj_length remdups_adj_length_ge1 remdups_adj_singleton_iff)
    then show ?thesis
      using Suc.prems(2) rep_of.domintros by auto
  next
    case False
    have "path l root (butlast p) (l ! i)"
      by (metis False Suc.hyps(2) Suc.prems(1) Suc.prems(2) length_Suc_rev_conv list.size(3) list_e_eq_lel(2) path.cases path_butlast path_root)
    have "x = length (butlast p)"
      by (simp add: Suc.hyps(2) Suc_to_right)
    then have "rep_of_dom (l, l ! i)"
      using Suc.hyps(1) Suc.prems(2) \<open>path l root (butlast p) (l ! i)\<close> by blast
    then show ?thesis
      using rep_of.domintros by blast
  qed
qed

lemma path_fun_upd:
  assumes "path l x p y" "i \<notin> set (tl p)"
  shows "path (CONST list_update l i k) x p y"
  using assms proof(induction rule: path.induct)
  case (single n l)
  then show ?case
    by (simp add: path.single)
next
  case (step r l u p v)
  then show ?case
    by (metis (no_types, lifting) in_set_tlD length_list_update list.sel(3) list.set_intros(1) nth_list_update_neq path.cases path.step)
qed

text \<open>The paths of nodes with a different root are disjoint.\<close>

lemma path_rep_of_neq_not_in_path:
  assumes "path l y\<^sub>2 p\<^sub>2 x\<^sub>2"
    "i\<^sub>2 < length p\<^sub>2"
    "rep_of l n \<noteq> rep_of l x\<^sub>2"
    "ufa_invar l"
  shows "n \<noteq> p\<^sub>2 ! i\<^sub>2"
proof
  assume n_in_path: "n = p\<^sub>2 ! i\<^sub>2"
  then have "rep_of l (p\<^sub>2 ! i\<^sub>2) = rep_of l x\<^sub>2"
    using nodes_path_rep_of(2) assms by blast
  with n_in_path have "rep_of l x\<^sub>2 = rep_of l n"
    by simp
  with assms show "False"
    by argo
qed

lemma path_rep_of_neq_disjoint:
  assumes "path l y\<^sub>1 p\<^sub>1 x\<^sub>1" "path l y\<^sub>2 p\<^sub>2 x\<^sub>2"
    "i\<^sub>1 < length p\<^sub>1" "i\<^sub>2 < length p\<^sub>2"
    "rep_of l x\<^sub>1 \<noteq> rep_of l x\<^sub>2"
    "ufa_invar l"
  shows "p\<^sub>1 ! i\<^sub>1 \<noteq> p\<^sub>2 ! i\<^sub>2"
  using assms proof(induction l y\<^sub>1 p\<^sub>1 x\<^sub>1 arbitrary: i\<^sub>1 rule: path.induct)
  case (single n l)
  then have "[n] ! i\<^sub>1 = n"
    by force
  then show ?case
    using path_rep_of_neq_not_in_path single.prems by auto
next
  case (step r l u p v)
  then show ?case
  proof(cases "i\<^sub>1")
    case 0
    then have "(r # p) ! i\<^sub>1 = r"
      by simp
    with step show ?thesis
      by (metis path_nodes_lt_length_l path_rep_eq path_rep_of_neq_not_in_path rep_of_idx)
  next
    case (Suc nat)
    then have "(r # p) ! i\<^sub>1 = p ! (i\<^sub>1 - 1)"
      by simp
    then show ?thesis
      using Suc step by auto
  qed
qed

lemma path_remove_left:
  assumes "path l i (i#pia) ia"
    "ufa_invar l"
  shows "i \<notin> set pia"
proof
  assume "i \<in> set pia"
  then obtain p\<^sub>1 p\<^sub>2 where "pia = p\<^sub>1 @ [i] @ p\<^sub>2"
    by (metis Cons_eq_append_conv append_Nil in_set_conv_decomp_first)
  with assms have "path l i ([i] @ p\<^sub>1 @ [i]) i"
    by (metis Cons_eq_appendI append_is_Nil_conv empty_append_eq_id list.sel(1) path_divide2 snoc_eq_iff_butlast)
  with path_unique assms show "False"
    by (metis append_self_conv last_ConsL path_divide1 snoc_eq_iff_butlast)
qed

lemma path_remove_right:
  assumes "path l ia pia i"
    "ufa_invar l"
  shows "i \<notin> set (butlast pia)"
proof
  have pia: "pia = (butlast pia) @ [i]"
    by (metis assms(1) path_last path_not_empty snoc_eq_iff_butlast)
  assume "i \<in> set (butlast pia)"
  then obtain p\<^sub>1 p\<^sub>2 where "butlast pia = p\<^sub>1 @ [i] @ p\<^sub>2"
    by (metis Cons_eq_append_conv append_Nil in_set_conv_decomp_first)
  with assms have "path l i ([i] @ p\<^sub>2 @ [i]) i"
    using pia path_divide2 by fastforce
  with path_unique assms show "False"
    by (metis append_self_conv last_ConsL path_divide1 snoc_eq_iff_butlast)
qed

lemma path_remove_child:
  assumes "path l ia pia (l ! i)"
    "ufa_invar l" "i < length l" "l ! i \<noteq> i"
  shows "i \<notin> set pia"
proof-
  from assms have "path l (l ! i) [l ! i, i] i"
    by (metis path.step single ufa_invarD(2))
  have pia: "path l ia (pia @ [i]) i"
    by (simp add: assms path_snoc ufa_invarD(2))
  with path_remove_right show ?thesis
    by (metis assms(2) butlast_snoc)
qed

lemma path_previous_node:
  assumes "path l y p x" "i < length p - 1" "p ! (i + 1) = n"
  shows "p ! i = l ! n"
  using assms proof(induction arbitrary: i rule: path.induct)
  case (single n l)
  then show ?case by auto
next
  case (step r l u p v)
  then show ?case proof(cases i)
    case 0
    have "p \<noteq> []"
      using path_not_empty step.hyps(4) by blast
    with step 0 have "hd p = n"
      by (simp add: hd_conv_nth)
    with step have "u = n"
      using hd_path by blast
    with step show ?thesis
      by (metis "0" nth_Cons_0)
  next
    case (Suc nat)
    with step show ?thesis by auto
  qed
qed

lemma path_hd_and_last:
  assumes "path l y p x" "length p > 1"
  shows "p = y # (tl (butlast p)) @ [x]"
proof-
  have "p = butlast p @ [x]"
    by (metis append_butlast_last_id assms(1) path_last path_not_empty)
  have "length (butlast p) > 0"
    using add.right_neutral assms(2) by auto
  then have "butlast p @ [x] = y # (tl (butlast p) @ [x])"
    by (metis Cons_eq_appendI assms(1) assms(2) hd_Cons_tl hd_butlast hd_path length_greater_0_conv)
  then show ?thesis
    using \<open>p = butlast p @ [x]\<close> by auto
qed

lemma path_longer:
  assumes "ufa_invar l" "path l b p1 a" "path l c p2 a" "length p1 > length p2"
  shows "path l b (take (length p1 - length p2 + 1) p1) c"
    (is "path l b ?p3 c")
proof-
  let ?p4 = "(drop (length p1 - length p2 + 1) p1)"
  have "path l b (?p3 @ ?p4) a"
    by (simp add: assms(2))
  moreover have "?p3 \<noteq> []"
    by (metis Suc_eq_plus1_left Zero_not_Suc ab_semigroup_add_class.add.commute assms(4) len_greater_imp_nonempty take_eq_Nil)
  ultimately have path_split: "path l b ?p3 (last ?p3)"  "path l (last ?p3) (last ?p3 # ?p4) a"
    using path_divide1 by blast+
  have "length (last ?p3 # ?p4) = length p2"
    by (metis (no_types, lifting) One_nat_def ab_semigroup_add_class.add.commute add_diff_cancel_right add_diff_inverse_nat assms(3) assms(4) length_drop length_greater_0_conv less_Suc_eq list.discI list.size(4) not_less_eq path.simps)
  then have "(last ?p3) = c"
    using path_unique_if_length_eq assms path_split by blast
  then show ?thesis
    using path_split(1) by blast
qed

lemma complement_of_subpath:
  assumes "ufa_invar l" "path l b p1 a" "path l c p2 a" "b \<notin> set p2"
  shows "path l b (take (length p1 - length p2 + 1) p1) c"
    (is "path l b ?p3 c")
proof-
  let ?p4 = "(drop (length p1 - length p2 + 1) p1)"
  have "length p1 > length p2"
  proof(rule ccontr)
    assume p2_longer: "\<not> length p2 < length p1"
    then have "b \<in> set p2" proof(cases "length p2 = length p1")
      case True
      then have "b = c"
        using assms(1) assms(2) assms(3) path_unique_if_length_eq by auto
      then show ?thesis
        by (metis assms(3) in_set_member member_rec(1) path.cases)
    next
      case False
      then have "length p1 < length p2"
        using p2_longer by linarith
      then obtain p5 where "path l c p5 b"
        using path_longer assms by blast
      then have "path l c (p5 @ tl p1) a"
        using assms(2) paths_iff by blast
      then show ?thesis
        by (metis (no_types, lifting) \<open>path l c p5 b\<close> assms(1) assms(2) assms(3) in_set_conv_decomp path.simps path_concat2 path_unique)
    qed
    then show "False" using assms(4)
      by blast
  qed
  then show ?thesis
    using assms(1) assms(2) assms(3) path_longer by blast
qed

lemma path_take_two:
  assumes "ufa_invar l" "i < length p" "i \<noteq> 0" "path l a p b"
  shows "path l (l ! (p ! i)) [l ! (p ! i), (p ! i)] (p ! i)"
proof
  show "l ! (p ! i) < length l" using assms
    by (simp add: nodes_path_lt_length_l ufa_invarD(2))
  show "l ! (p ! i) = l ! (p ! i)" ..
  show "l ! (p ! i) \<noteq> (p ! i)"
    by (metis assms(2) assms(3) assms(4) bot_nat_0.not_eq_extremum path_not_first_no_root)
  show "path l (p ! i) [p ! i] (p ! i)"
    using assms nodes_path_lt_length_l single by blast
qed

lemma path_contains_no_root:
  assumes "x \<in> set (tl p)" "ufa_invar l"
    "path l a p b"
  shows "l ! x \<noteq> x"
proof-
  from assms obtain i where "i < length (tl p)" "tl p ! i = x"
    by (meson in_set_conv_nth)
  with path_not_first_no_root assms show ?thesis
    by (metis List.nth_tl Suc_mono gr0_conv_Suc in_set_tlD length_Suc_conv length_pos_if_in_set list.sel(3))
qed

end


(*  Author:     Tobias Nipkow, 2007  *)

theory QElin_inf
imports LinArith
begin

subsection \<open>Quantifier elimination with infinitesimals \label{sec:lin-inf}\<close>

text\<open>This section formalizes Loos and Weispfenning's quantifier
elimination procedure based on (the simulation of)
infinitesimals~\<^cite>\<open>"LoosW93"\<close>.\<close>

fun asubst_peps :: "real * real list \<Rightarrow> atom \<Rightarrow> atom fm" ("asubst\<^sub>+") where
"asubst_peps (r,cs) (Less s (d#ds)) =
  (if d=0 then Atom(Less s ds) else
   let u = s - d*r; v = d *\<^sub>s cs + ds; less = Atom(Less u v)
   in if d<0 then less else Or less (Atom(Eq u v)))" |
"asubst_peps rcs (Eq r (d#ds)) = (if d=0 then Atom(Eq r ds) else FalseF)" |
"asubst_peps rcs a = Atom a"

abbreviation subst_peps :: "atom fm \<Rightarrow> real * real list \<Rightarrow> atom fm" ("subst\<^sub>+")
where "subst\<^sub>+ \<phi> rcs \<equiv> amap\<^sub>f\<^sub>m (asubst\<^sub>+ rcs) \<phi>"

definition "nolb f xs l x = (\<forall>y\<in>{l<..<x}. y \<notin> LB f xs)"

lemma nolb_And[simp]:
  "nolb (And f g) xs l x = (nolb f xs l x \<and> nolb g xs l x)"
apply(clarsimp simp:nolb_def)
apply blast
done

lemma nolb_Or[simp]:
  "nolb (Or f g) xs l x = (nolb f xs l x \<and> nolb g xs l x)"
apply(clarsimp simp:nolb_def)
apply blast
done

context notes [[simp_depth_limit=4]]
begin

definition "EQ2 = EQ"

lemma EQ2_Or[simp]: "EQ2 (Or f g) xs = (EQ2 f xs \<union> EQ2 g xs)"
by(auto simp:EQ2_def)

lemma EQ2_And[simp]: "EQ2 (And f g) xs = (EQ2 f xs \<union> EQ2 g xs)"
by(auto simp:EQ2_def)

lemma innermost_intvl2:
  "\<lbrakk> nqfree f; nolb f xs l x; l < x; x \<notin> EQ2 f xs; R.I f (x#xs); l < y; y \<le> x\<rbrakk>
  \<Longrightarrow> R.I f (y#xs)"
unfolding EQ2_def by(blast intro:innermost_intvl)

lemma I_subst_peps2:
 "nqfree f \<Longrightarrow> r+\<langle>cs,xs\<rangle> < x \<Longrightarrow> nolb f xs (r+\<langle>cs,xs\<rangle>) x
 \<Longrightarrow> \<forall>y \<in> {r+\<langle>cs,xs\<rangle> <.. x}. R.I f (y#xs) \<and> y \<notin> EQ2 f xs
 \<Longrightarrow> R.I (subst\<^sub>+ f (r,cs)) xs"
proof(induct f)
  case FalseF thus ?case
    by simp (metis antisym_conv1 linorder_neq_iff)
next
  case (Atom a)
  show ?case
  proof(cases "((r,cs),a)" rule:asubst_peps.cases)
    case (1 r cs s d ds)
    { assume "d=0" hence ?thesis using Atom 1 by auto }
    moreover
    { assume "d<0"
      have "s < d*x + \<langle>ds,xs\<rangle>" using Atom 1 by simp
      moreover have "d*x < d*(r + \<langle>cs,xs\<rangle>)" using \<open>d<0\<close> Atom 1
        by (simp add: mult_strict_left_mono_neg)
      ultimately have "s < d * (r + \<langle>cs,xs\<rangle>) + \<langle>ds,xs\<rangle>" by(simp add:algebra_simps)
      hence ?thesis using 1
        by (auto simp add: iprod_left_add_distrib algebra_simps)
    } moreover
    { let ?L = "(s - \<langle>ds,xs\<rangle>) / d" let ?U = "r + \<langle>cs,xs\<rangle>"
      assume "d>0"
      hence "?U < x" and "\<forall>y. ?U < y \<and> y < x \<longrightarrow> y \<noteq> ?L"
        and "\<forall>y. ?U < y \<and> y \<le> x \<longrightarrow> ?L < y" using Atom 1
        by(simp_all add:nolb_def depends\<^sub>R_def Ball_def field_simps)
      hence "?L < ?U \<or> ?L = ?U"
        by (metis linorder_neqE_linordered_idom order_refl)
      hence ?thesis using Atom 1 \<open>d>0\<close>
        by (simp add: iprod_left_add_distrib field_simps)
    } ultimately show ?thesis by force
  next
    case 2 thus ?thesis using Atom
      by (fastforce simp: nolb_def EQ2_def depends\<^sub>R_def field_simps split: if_split_asm)
  qed (insert Atom, auto)
next
  case Or thus ?case by(simp add:Ball_def)(metis order_refl innermost_intvl2)
qed simp_all

end

lemma I_subst_peps:
  "nqfree f \<Longrightarrow> R.I (subst\<^sub>+ f (r,cs)) xs \<Longrightarrow>
  (\<exists>leps>r+\<langle>cs,xs\<rangle>. \<forall>x. r+\<langle>cs,xs\<rangle> < x \<and> x \<le> leps \<longrightarrow> R.I f (x#xs))"
proof(induct f)
  case TrueF thus ?case by simp (metis less_add_one)
next
  case (Atom a)
  show ?case
  proof (cases "((r,cs),a)" rule: asubst_peps.cases)
    case (1 r cs s d ds)
    { assume "d=0" hence ?thesis using Atom 1 by auto (metis less_add_one) }
    moreover
    { assume "d<0"
      with Atom 1 have "r + \<langle>cs,xs\<rangle> < (s - \<langle>ds,xs\<rangle>)/d" (is "?a < ?b")
        by(simp add:field_simps iprod_left_add_distrib)
      then obtain x where "?a < x" "x < ?b" by(metis dense)
      hence " \<forall>y. ?a < y \<and> y \<le> x \<longrightarrow> s < d*y + \<langle>ds,xs\<rangle>"
        using \<open>d<0\<close> by (simp add:field_simps)
      (metis add_le_cancel_right mult_le_cancel_left order_antisym linear mult.commute xt1(8))
      hence ?thesis using 1 \<open>?a<x\<close> by auto
    } moreover
    { let ?a = "s - d * r" let ?b = "\<langle>d *\<^sub>s cs + ds,xs\<rangle>"
      assume "d>0"
      with Atom 1 have "?a < ?b \<or> ?a = ?b" by auto
      hence ?thesis
      proof
        assume "?a = ?b"
        thus ?thesis using \<open>d>0\<close> Atom 1
          by(simp add:field_simps iprod_left_add_distrib)
            (metis add_0_left add_less_cancel_right distrib_left mult.commute mult_strict_left_mono)
      next
        assume "?a < ?b"
        { fix x assume "r+\<langle>cs,xs\<rangle> < x \<and> x \<le> r+\<langle>cs,xs\<rangle> + 1"
          hence "d*(r + \<langle>cs,xs\<rangle>) < d*x"
            using \<open>d>0\<close> by(metis mult_strict_left_mono)
          hence "s < d*x + \<langle>ds,xs\<rangle>" using \<open>d>0\<close> \<open>?a < ?b\<close>
            by (simp add:algebra_simps iprod_left_add_distrib)
        }
        thus ?thesis using 1 \<open>d>0\<close>
          by(force simp: iprod_left_add_distrib)
      qed
    } ultimately show ?thesis by (metis less_linear)
  qed (insert Atom, auto split:if_split_asm intro: less_add_one)
next
  case And thus ?case
    apply clarsimp
    apply(rule_tac x="min leps lepsa" in exI)
    apply simp
    done
next
  case Or thus ?case by force
qed simp_all

definition
"qe_eps\<^sub>1(f) =
(let as = R.atoms\<^sub>0 f; lbs = lbounds as; ebs = ebounds as
 in list_disj (inf\<^sub>- f # map (subst\<^sub>+ f) lbs @ map (subst f) ebs))"

theorem I_eps1:
assumes "nqfree f" shows "R.I (qe_eps\<^sub>1 f) xs = (\<exists>x. R.I f (x#xs))"
  (is "?QE = ?EX")
proof
  let ?as = "R.atoms\<^sub>0 f" let ?ebs = "ebounds ?as"
  assume ?QE
  { assume "R.I (inf\<^sub>- f) xs"
    hence ?EX using \<open>?QE\<close> min_inf[of f xs] \<open>nqfree f\<close>
      by(auto simp add:qe_eps\<^sub>1_def amap_fm_list_disj)
  } moreover
  { assume "\<forall>x \<in> EQ f xs. \<not>R.I f (x#xs)"
           "\<not> R.I (inf\<^sub>- f) xs"
    with \<open>?QE\<close> \<open>nqfree f\<close> obtain r cs where "R.I (subst\<^sub>+ f (r,cs)) xs"
      by (fastforce simp: qe_eps\<^sub>1_def set_ebounds diff_divide_distrib eval_def I_subst \<open>nqfree f\<close>)
    then obtain leps where "R.I f (leps#xs)"
      using I_subst_peps[OF \<open>nqfree f\<close>] by fastforce
    hence ?EX .. }
  ultimately show ?EX by blast
next
  let ?as = "R.atoms\<^sub>0 f" let ?ebs = "ebounds ?as"
  assume ?EX
  then obtain x where x: "R.I f (x#xs)" ..
  { assume "R.I (inf\<^sub>- f) xs"
    hence ?QE using \<open>nqfree f\<close> by(auto simp:qe_eps\<^sub>1_def)
  } moreover
  { assume "\<exists>rcs \<in> set ?ebs. R.I (subst f rcs) xs"
    hence ?QE by(auto simp:qe_eps\<^sub>1_def) } moreover
  { assume "\<not> R.I (inf\<^sub>- f) xs"
    and "\<forall>rcs \<in> set ?ebs. \<not> R.I (subst f rcs) xs"
    hence noE: "\<forall>e \<in> EQ f xs. \<not> R.I f (e#xs)" using \<open>nqfree f\<close>
      by (force simp:set_ebounds I_subst diff_divide_distrib eval_def split:if_split_asm)
    hence "x \<notin> EQ f xs" using x by fastforce
    obtain l where "l \<in> LB f xs" "l < x"
      using LBex[OF \<open>nqfree f\<close> x \<open>\<not> R.I(inf\<^sub>- f) xs\<close> \<open>x \<notin> EQ f xs\<close>] ..
    have "\<exists>l\<in>LB f xs. l<x \<and> nolb f xs l x \<and>
            (\<forall>y. l < y \<and> y \<le> x \<longrightarrow> R.I f (y#xs))"
      using dense_interval[where P = "\<lambda>x. R.I f (x#xs)", OF finite_LB \<open>l\<in>LB f xs\<close> \<open>l<x\<close> x] x innermost_intvl[OF \<open>nqfree f\<close> _ _ \<open>x \<notin> EQ f xs\<close>]
      by (simp add:nolb_def)
    then obtain r c cs
      where *: "Less r (c#cs) \<in> set(R.atoms\<^sub>0 f) \<and> c>0 \<and>
            (r - \<langle>cs,xs\<rangle>)/c < x \<and> nolb f xs ((r - \<langle>cs,xs\<rangle>)/c) x
            \<and> (\<forall>y. (r - \<langle>cs,xs\<rangle>)/c < y \<and> y \<le> x \<longrightarrow> R.I f (y#xs))"
      by blast
    then have "R.I (subst\<^sub>+ f (r/c, (-1/c) *\<^sub>s cs)) xs" using noE
      by(auto intro!: I_subst_peps2[OF \<open>nqfree f\<close>]
        simp:EQ2_def diff_divide_distrib algebra_simps)
    with * have ?QE
      by(simp add:qe_eps\<^sub>1_def bex_Un set_lbounds) metis
  } ultimately show ?QE by blast
qed

lemma qfree_asubst_peps: "qfree (asubst\<^sub>+ rcs a)"
by(cases "(rcs,a)" rule:asubst_peps.cases) simp_all

lemma qfree_subst_peps: "nqfree \<phi> \<Longrightarrow> qfree (subst\<^sub>+ \<phi> rcs)"
by(induct \<phi>) (simp_all add:qfree_asubst_peps)

lemma qfree_qe_eps\<^sub>1: "nqfree \<phi> \<Longrightarrow> qfree(qe_eps\<^sub>1 \<phi>)"
apply(simp add:qe_eps\<^sub>1_def)
apply(rule qfree_list_disj)
apply (auto simp:qfree_min_inf qfree_subst_peps qfree_map_fm)
done

definition "qe_eps = R.lift_nnf_qe qe_eps\<^sub>1"

lemma qfree_qe_eps: "qfree(qe_eps \<phi>)"
by(simp add: qe_eps_def R.qfree_lift_nnf_qe qfree_qe_eps\<^sub>1)

lemma I_qe_eps: "R.I (qe_eps \<phi>) xs = R.I \<phi> xs"
by(simp add:qe_eps_def R.I_lift_nnf_qe qfree_qe_eps\<^sub>1 I_eps1)

end


theory proof3_3
  imports Main
begin
lemma "A \<le> B \<inter> C \<Longrightarrow> A \<le> B \<union> C"
  apply(auto)
  done

lemma "((P x \<longrightarrow> Q x) \<and> P x) \<longrightarrow> Q x"
  by auto

lemma "\<lbrakk> (a::nat)\<le>b; b\<le>c; c\<le>d; d\<le>e \<rbrakk> \<Longrightarrow> a \<le> e"
  apply(simp)
  done

lemma peirce: "(((P\<longrightarrow>Q)\<longrightarrow>P)\<longrightarrow>P)"
  apply(blast)
  done

lemma peirce2: "(((P\<longrightarrow>Q)\<longrightarrow>P)\<longrightarrow>P)"
proof
  assume 1: "(P\<longrightarrow>Q)\<longrightarrow>P"
  show P
  proof (rule classical)
    assume 2: "\<not>P"
    have "P\<longrightarrow>Q"
    proof
      assume P
      with 2 show Q by contradiction
    qed
    with 1 show P ..
  qed
qed

end


theory If
imports FOLP
begin

definition "if" :: "[o,o,o]=>o" where
  "if(P,Q,R) == P&Q | ~P&R"

schematic_lemma ifI:
  assumes "!!x. x : P ==> f(x) : Q"  "!!x. x : ~P ==> g(x) : R"
  shows "?p : if(P,Q,R)"
apply (unfold if_def)
apply (tactic {* fast_tac @{context} (FOLP_cs addIs @{thms assms}) 1 *})
done

schematic_lemma ifE:
  assumes 1: "p : if(P,Q,R)" and
    2: "!!x y. [| x : P; y : Q |] ==> f(x, y) : S" and
    3: "!!x y. [| x : ~P; y : R |] ==> g(x, y) : S"
  shows "?p : S"
apply (insert 1)
apply (unfold if_def)
apply (tactic {* fast_tac @{context} (FOLP_cs addIs [@{thm 2}, @{thm 3}]) 1 *})
done

schematic_lemma if_commute: "?p : if(P, if(Q,A,B), if(Q,C,D)) <-> if(Q, if(P,A,C), if(P,B,D))"
apply (rule iffI)
apply (erule ifE)
apply (erule ifE)
apply (rule ifI)
apply (rule ifI)
oops

ML {* val if_cs = FOLP_cs addSIs [@{thm ifI}] addSEs [@{thm ifE}] *}

schematic_lemma if_commute: "?p : if(P, if(Q,A,B), if(Q,C,D)) <-> if(Q, if(P,A,C), if(P,B,D))"
apply (tactic {* fast_tac @{context} if_cs 1 *})
done

schematic_lemma nested_ifs: "?p : if(if(P,Q,R), A, B) <-> if(P, if(Q,A,B), if(R,A,B))"
apply (tactic {* fast_tac @{context} if_cs 1 *})
done

end


theory Black_Box_Safe_Distance
imports Complex_Main
        "./Safe_Distance_Isar"
        "./Hybrid_Trace"
begin

type_synonym 'a tuple6 = "'a*'a*'a*'a*'a*'a"
type_synonym ivl = "float * float"

definition real_ivl_of_real::"nat \<Rightarrow> real \<Rightarrow> (real * real)" where
  "real_ivl_of_real p x = (truncate_down (Suc p) x, truncate_up (Suc p) x)"

lift_definition float_ivl_of_real::"nat \<Rightarrow> real \<Rightarrow> ivl" is real_ivl_of_real
  by (auto simp: real_ivl_of_real_def)

lemma real_of_rat_Fract[simp]: "real_of_rat (Fract a b) = a / b"
by (simp add: Fract_of_int_quotient of_rat_divide)

text \<open>
This theory is about formalising the safe distance rule. The safe distance rule is obtained
from Vienna Convention which basically states the following thing.

  ``The car at all times must maintain a safe distance towards the vehicle in front of it,
    such that whenever the vehicle in front and the ego vehicle apply maximum deceleration,
    there will not be a collision.''

To formalise this safe distance rule we have to define first what is a safe distance.
To define this safe distance, we have to model the physics of the movement of the vehicle.
The following model is sufficient.

  \<open>s = s\<^sub>0 + v\<^sub>0 * t + 1 / 2 * a\<^sub>0 * t\<^sup>2\<close>

The exact mathematical derivation of safe distance can be seen in theory \<open>Safe_Distance_Isar\<close>.

Another assumptions in this model are :
  1) Both vehicles are assumed to be point mass. The exact location of the ego vehicle
     is the frontmost occupancy of the ego vehicle. Similarly for the other vehicle,
     its exact location is the rearmost occupancy of the other vehicle.

  2) Both cars can never drive backward.
\<close>

text \<open>
  There are only two important variables in this scenario : position in x-axis and speed.
\<close>
datatype variable = position | speed | max_dec

text \<open>
  There are two relevant traffic participants: ego vehicle and the closest vehicle in front
  of the ego vehicle. We make "Ego" and "Other" as constructor for discrete variables.
\<close>
datatype type  = ego | other

text \<open>Relevant variables for this scenario is the product of these two types\<close>
type_synonym var = "type \<times> variable"

text \<open>Define a weaker type of trace which consists of discrete jumps only\<close>
type_synonym ('dv, 'v) discrete_trace = "('dv, 'v)jumps list"

text \<open>function to evaluate discrete trace for specific variable\<close>
fun eval_var :: "(var, real) discrete_trace \<Rightarrow> var \<Rightarrow> real list" where
"eval_var js v = map (\<lambda>j . j v) js"

fun nonneg_res :: "real list \<Rightarrow> bool" where
"nonneg_res rs = fold conj (map (\<lambda>r . 0 \<le> r) rs) True"

fun pos_res :: "real list \<Rightarrow> bool" where
"pos_res rs = fold conj (map (\<lambda>r . 0 < r) rs) True"

fun neg_res :: "real list \<Rightarrow> bool" where
"neg_res rs = fold conj (map (\<lambda>r . r < 0) rs) True"

text \<open>Predicate to ensure that the variable in the trace is always nonnegative\<close>
fun nonneg_data :: "(var, real) discrete_trace \<Rightarrow> var \<Rightarrow> bool" where
"nonneg_data js v = nonneg_res (eval_var js v)"

fun neg_data :: "(var, real) discrete_trace \<Rightarrow> var \<Rightarrow> bool" where
"neg_data js v = neg_res (eval_var js v)"

text \<open>Predicate to check that the position of the other vehicle is always in front of
   the position of ego vehicle.\<close>
fun always_in_front :: "(var, real) discrete_trace \<Rightarrow> bool" where
"always_in_front js =
  (let zs = zip (eval_var js (other, position)) (eval_var js (ego, position));
       rs = map (\<lambda>(x, y). x - y) zs in
       pos_res rs)"

definition no_collision_jumps :: "(var, real) jumps \<Rightarrow> bool" where
"no_collision_jumps j \<equiv> (let s\<^sub>e = j (ego, position); v\<^sub>e = j (ego, speed); a\<^sub>e = j (ego, max_dec);
                             s\<^sub>o = j (other, position); v\<^sub>o = j (other, speed); a\<^sub>o = j (other, max_dec) in
                                   \<not> (\<exists>t \<in> {t. 0 \<le> t} . movement.s a\<^sub>e v\<^sub>e s\<^sub>e t =
                                                         movement.s a\<^sub>o v\<^sub>o s\<^sub>o t))"

fun no_collision_trace :: "(var, real) discrete_trace \<Rightarrow> bool" where
"no_collision_trace js =  fold conj (map no_collision_jumps js) True"

lemma false_fold_conj: "fold conj as False = False"
proof (induct as)
  show "fold conj [] False = False" by auto
next
  fix a as
  assume asm: "fold conj as False = False"
  have "fold conj (a # as) False = (fold conj as \<circ> conj a) False" by simp
  also have "... = fold conj as (a \<and> False)" by simp
  also have "... = fold conj as False" by simp
  finally show "fold conj (a # as) False = False" using asm by simp
qed

lemma distrib_fold_conj:"(fold conj (a # as) init) = (a \<and> (fold conj as) init)"
proof -
  have "fold conj (a # as) init = (fold conj as \<circ> conj a) init" by (simp)
  also have "... = fold conj as (a \<and> init)" by simp
  also have "... = (a \<and> (fold conj as init))"
    proof (cases a)
      assume a
      hence 0: "fold conj as (a \<and> init) = fold conj as init" by simp
      from `a` have 1: "(a \<and> (fold conj as init)) = (fold conj as init)" by simp
      with 0 show ?thesis by simp
    next
      assume "\<not> a"
      hence 0: "fold conj as (a \<and> init) = fold conj as False" by simp
      also have "... = False" using false_fold_conj by simp
      also have "... = (a \<and> fold conj as init)" using `\<not> a` by simp
      finally show ?thesis by simp
    qed
  finally show ?thesis by simp
qed

lemma distrib_no_collision_trace:
"no_collision_trace (j # js) =  (no_collision_jumps j \<and> no_collision_trace js)"
proof -
  have "no_collision_trace  (j # js) = fold conj (map no_collision_jumps (j # js)) True"
  by (simp add:no_collision_trace.induct)
  also have "... = fold conj (no_collision_jumps j # (map no_collision_jumps js)) True" by simp
  also have "... = (no_collision_jumps j \<and> (fold conj (map no_collision_jumps js) True))"
  using distrib_fold_conj by metis
  finally show ?thesis by simp
qed

lemma nonneg_data_closed: "nonneg_data (j # js) v = ((0 \<le> j v) \<and> nonneg_data js v)"
proof -
  have "nonneg_data (j # js) v = nonneg_res (eval_var (j # js) v)" using nonneg_data.simps by simp
  also have "... = nonneg_res (map (\<lambda>j . j v) (j # js))" using eval_var.simps by simp
  also have "... = nonneg_res (j v # map (\<lambda>j . j v) js)" by simp
  also have "... = fold conj (map (\<lambda>r. 0 \<le> r) (j v # map (\<lambda>j . j v) js)) True" using nonneg_res.simps by simp
  also have "... = fold conj ((0 \<le> j v) # map (\<lambda>r. 0 \<le> r) (map (\<lambda>j . j v) js)) True" by simp
  also have "... = ((0 \<le> j v) \<and> fold conj (map (\<lambda>r . 0 \<le> r) (map (\<lambda>j . j v) js)) True)" by (metis distrib_fold_conj)
  also have "... = ((0 \<le> j v) \<and> nonneg_res (map (\<lambda>j . j v) js))" using nonneg_res.simps by simp
  also have "... = ((0 \<le> j v) \<and> nonneg_res (eval_var js v))" using eval_var.simps by simp
  also have "... = ((0 \<le> j v) \<and> nonneg_data js v)" using nonneg_data.simps by simp
  finally show ?thesis by simp
qed

lemma neg_data_closed: "neg_data (j # js) v = ((j v < 0) \<and> neg_data js v)"
proof -
  have "neg_data (j # js) v = neg_res (eval_var (j # js) v)" using neg_data.simps by simp
  also have "... = neg_res (map (\<lambda>j . j v) (j # js))" using eval_var.simps by simp
  also have "... = fold conj (map (\<lambda>r. r < 0) (j v # map (\<lambda>j. j v) js)) True" using neg_res.simps by simp
  also have "... = fold conj ((j v < 0) # map (\<lambda>r. r < 0) (map (\<lambda>j. j v) js)) True" by simp
  also have "... = ((j v < 0) \<and> fold conj (map (\<lambda>r . r < 0) (map (\<lambda>j . j v) js)) True)" by (metis distrib_fold_conj)
  also have "... = ((j v < 0) \<and> neg_res (map (\<lambda>j . j v) js))" using nonneg_res.simps by simp
  also have "... = ((j v < 0) \<and> neg_res (eval_var js v))" using eval_var.simps by simp
  also have "... = ((j v < 0) \<and> neg_data js v)" using nonneg_data.simps by simp
  finally show ?thesis by simp
qed

lemma always_in_front_closed: "always_in_front (j # js) =
                               ((0 < j (other, position) - j (ego, position)) \<and> always_in_front js)"
proof -
  have "always_in_front (j # js) =
         (let zs = zip (eval_var (j # js) (other, position)) (eval_var (j # js) (ego, position));
              rs = map (\<lambda>(x, y). x - y) zs in
              pos_res rs)" using always_in_front.simps by simp
  also have "... = (let zs = zip (j (other, position) # eval_var js (other, position))
                       (j (ego, position)   # eval_var js (ego, position))  ;
                       rs = map (\<lambda>(x, y). x - y) zs in
                       pos_res rs)" using eval_var.simps by simp
  also have "... = (let zs = (j (other, position), j (ego, position)) # zip (eval_var js (other, position))
                                                                  (eval_var js (ego, position));
                        rs = map (\<lambda>(x, y). x - y) zs in
                        pos_res rs)" by simp
  also have "... = (let zs = zip (eval_var js (other, position)) (eval_var js (ego, position));
                        z  = (j (other, position), j (ego, position));
                       rs  = map (\<lambda>(x, y). x - y) (z # zs) in
                       pos_res rs)" by simp
  also have "... = (let zs = zip (eval_var js (other, position)) (eval_var js (ego, position));
                        z  = (j (other, position), j (ego, position));
                       rs  = ((\<lambda>(x, y). x - y) z) # map (\<lambda>(x, y). x - y) zs  in
                       pos_res rs)" by simp
  also have "... = (let zs = zip (eval_var js (other, position)) (eval_var js (ego, position));
                        z  = (j (other, position), j (ego, position));
                        r  = ((\<lambda>(x, y). x - y) z);
                        rs = map (\<lambda>(x, y). x - y) zs  in
                        pos_res (r # rs))" by simp
  also have "... = (let zs = zip (eval_var js (other, position)) (eval_var js (ego, position));
                        z  = (j (other, position), j (ego, position));
                        r  = ((\<lambda>(x, y). x - y) z);
                        rs = map (\<lambda>(x, y). x - y) zs  in
                        fold conj (map (\<lambda>r . 0 < r) (r # rs)) True)" by simp
  also have "... = (let zs = zip (eval_var js (other, position)) (eval_var js (ego, position));
                        z  = (j (other, position), j (ego, position));
                        r  = ((\<lambda>(x, y). x - y) z);
                        rs = map (\<lambda>(x, y). x - y) zs  in
                        fold conj ((0 < r) # map (\<lambda>r . 0 < r) rs) True)" by simp
  also have "... = (let zs = zip (eval_var js (other, position)) (eval_var js (ego, position));
                        z  = (j (other, position), j (ego, position));
                        r  = ((\<lambda>(x, y). x - y) z);
                        rs = map (\<lambda>(x, y). x - y) zs  in
                        (0 < r) \<and> fold conj (map (\<lambda>r . 0 < r) rs) True)" using distrib_fold_conj by metis
  thus ?thesis by simp
qed

definition s\<^sub>e :: "(var, real) jumps \<Rightarrow> real" where
"s\<^sub>e j \<equiv> j (ego, position)"

definition s\<^sub>o :: "(var, real) jumps \<Rightarrow> real" where
"s\<^sub>o j \<equiv> j (other, position)"

definition v\<^sub>e :: "(var, real) jumps \<Rightarrow> real" where
"v\<^sub>e j \<equiv> j (ego, speed)"

definition v\<^sub>o :: "(var, real) jumps \<Rightarrow> real" where
"v\<^sub>o j \<equiv> j (other, speed)"

definition a\<^sub>e :: "(var, real) jumps \<Rightarrow> real" where
"a\<^sub>e j \<equiv> j (ego, max_dec)"

definition a\<^sub>o :: "(var, real) jumps \<Rightarrow> real" where
"a\<^sub>o j \<equiv> j (other, max_dec)"

fun check_bb_safe_dist :: "(var, real) discrete_trace \<Rightarrow> bool" where
"check_bb_safe_dist [] = True" |
"check_bb_safe_dist (j # js) = (let s\<^sub>e = j (ego, position); v\<^sub>e = j (ego, speed); a\<^sub>e = j (ego, max_dec);
                             s\<^sub>o = j (other, position); v\<^sub>o = j (other, speed); a\<^sub>o = j (other, max_dec) in
                             checker s\<^sub>e v\<^sub>e a\<^sub>e s\<^sub>o v\<^sub>o a\<^sub>o \<and> check_bb_safe_dist js)"

lemma check_precond_imp_safe_distance:
  assumes "check_precond a b c d e f"
  shows "safe_distance c b a f e d"
  using assms unfolding check_precond_def
  by unfold_locales auto

lemma checker_imp_check_precond:
  assumes "checker a b c d e f"
  shows  "check_precond a b c d e f"
  using assms by (auto simp: checker_def Let_def)

lemma nonneg_data_Cons:
  assumes "nonneg_data xs a"
  assumes "0 \<le> x a"
  shows "nonneg_data (x#xs) a"
  using assms by auto

lemma neg_data_Cons:
  assumes "neg_data xs a"
  assumes "x a < 0"
  shows "neg_data (x#xs) a"
  using assms by auto

lemma always_in_front_Cons:
  assumes "always_in_front xs"
  assumes "x (other, position) > x (ego, position)"
  shows "always_in_front (x#xs)"
  using assms by auto

theorem
  check_bb_safe_dist_eq:
  "check_bb_safe_dist bb_trace \<longleftrightarrow>
    nonneg_data bb_trace (ego, speed) \<and>
    nonneg_data bb_trace (other, speed) \<and>
    neg_data bb_trace (ego, max_dec) \<and>
    neg_data bb_trace (other, max_dec) \<and>
    always_in_front bb_trace \<and>
    no_collision_trace bb_trace"
proof
  assume if_asm: "check_bb_safe_dist bb_trace"
  then show
    "nonneg_data bb_trace (ego, speed) \<and>
    nonneg_data bb_trace (other, speed) \<and>
    neg_data bb_trace (ego, max_dec) \<and>
    neg_data bb_trace (other, max_dec) \<and>
    always_in_front bb_trace \<and>
    no_collision_trace bb_trace"
  proof (induction bb_trace)
    case Nil
    then show ?case by (auto)
  next
    case (Cons a bb_trace)
    from `check_bb_safe_dist (a # bb_trace)`
    have 0: "checker (s\<^sub>e a) (v\<^sub>e a) (a\<^sub>e a) (s\<^sub>o a) (v\<^sub>o a) (a\<^sub>o a) \<and> check_bb_safe_dist bb_trace"
      using s\<^sub>e_def v\<^sub>e_def s\<^sub>o_def v\<^sub>o_def a\<^sub>e_def a\<^sub>o_def
      by (simp add: check_bb_safe_dist.induct)

    hence ind_asm0: "check_bb_safe_dist bb_trace" by rule

    from ind_asm0[THEN Cons.IH] have
    ind_concl: "no_collision_trace bb_trace"
    and ind_pcs: "nonneg_data bb_trace (ego, speed)" "nonneg_data bb_trace (other, speed)"
      "neg_data bb_trace (ego, max_dec)" "neg_data bb_trace (other, max_dec)" "always_in_front bb_trace"
      by simp_all

    have eq: "no_collision_trace  (a # bb_trace) =
         (no_collision_jumps  a \<and>
          no_collision_trace  bb_trace)"
    using distrib_no_collision_trace by simp

    from 0 have chk: "checker (s\<^sub>e a) (v\<^sub>e a) (a\<^sub>e a) (s\<^sub>o a) (v\<^sub>o a) (a\<^sub>o a)" by rule
    then interpret safe_distance "a\<^sub>e a" "(v\<^sub>e a)" "(s\<^sub>e a)" "a\<^sub>o a" "v\<^sub>o a" "s\<^sub>o a"
      by (intro check_precond_imp_safe_distance checker_imp_check_precond)

    from `checker (s\<^sub>e a) (v\<^sub>e a) (a\<^sub>e a) (s\<^sub>o a) (v\<^sub>o a) (a\<^sub>o a)` have
         "(\<not> (\<exists>t\<in>{t. 0 \<le> t}. movement.s (a\<^sub>e a) (v\<^sub>e a) (s\<^sub>e a) t =
                              movement.s (a\<^sub>o a) (v\<^sub>o a) (s\<^sub>o a) t))"
    using soundness_correctness by (simp add: collision_def)

    hence "no_collision_jumps a"
    using v\<^sub>e_def s\<^sub>e_def v\<^sub>o_def s\<^sub>o_def a\<^sub>e_def a\<^sub>o_def no_collision_jumps_def
    by simp

    from this eq chk ind_concl show ?case
      using nonneg_vel_ego nonneg_vel_other in_front decelerate_ego decelerate_other
      by (safe intro!: nonneg_data_Cons neg_data_Cons always_in_front_Cons ind_pcs checker_imp_check_precond)
        (simp_all add: v\<^sub>e_def v\<^sub>o_def s\<^sub>e_def s\<^sub>o_def a\<^sub>e_def a\<^sub>o_def)
  qed
next
  assume only_if_asm: "nonneg_data bb_trace (ego, speed) \<and>
    nonneg_data bb_trace (other, speed) \<and>
    neg_data bb_trace (ego, max_dec) \<and>
    neg_data bb_trace (other, max_dec) \<and>
    always_in_front bb_trace \<and>
    no_collision_trace bb_trace"
  then show "check_bb_safe_dist bb_trace"
  proof (induction bb_trace)
    case Nil
    then show "check_bb_safe_dist []" by auto
  next
    case (Cons a bb_trace)
    then have "check_bb_safe_dist bb_trace"
      by (simp only: nonneg_data_closed neg_data_closed always_in_front_closed distrib_no_collision_trace)

    (* checking the safety of a *)
    from Cons have a0: "0 \<le> v\<^sub>e a" using nonneg_data_closed v\<^sub>e_def by simp
    from Cons have a1: "0 \<le> v\<^sub>o a" using nonneg_data_closed v\<^sub>o_def by simp
    from Cons have a2: "0 < s\<^sub>o a - s\<^sub>e a" using always_in_front_closed s\<^sub>o_def s\<^sub>e_def by simp
    from Cons have a3: "a\<^sub>e a < 0" using neg_data_closed a\<^sub>e_def by simp
    from Cons have a4: "a\<^sub>o a < 0" using neg_data_closed a\<^sub>o_def by simp
    from Cons have nc: "no_collision_jumps a"
    using distrib_no_collision_trace by simp

    from a0 a1 a2 a3 a4
    interpret safe_distance "a\<^sub>e a" "v\<^sub>e a" "s\<^sub>e a" "a\<^sub>o a" "v\<^sub>o a" "s\<^sub>o a"
      by unfold_locales auto
    (* use the soundness_correctness theorem here *)
    from nc a0 a1 a2 a3 a4 have left: "checker (s\<^sub>e a) (v\<^sub>e a) (a\<^sub>e a) (s\<^sub>o a) (v\<^sub>o a) (a\<^sub>o a)"
      unfolding soundness_correctness
      by (auto simp: no_collision_jumps_def check_precond_def collision_def)
        (simp add: s\<^sub>e_def v\<^sub>e_def s\<^sub>o_def v\<^sub>o_def a\<^sub>e_def a\<^sub>o_def)

    show ?case
      using left \<open>check_bb_safe_dist bb_trace\<close>
      by (simp add: s\<^sub>e_def v\<^sub>e_def s\<^sub>o_def v\<^sub>o_def a\<^sub>e_def a\<^sub>o_def)
  qed
qed

fun var_of_tuple6::"real tuple6 \<Rightarrow> (var, real) jumps"
  where
    "var_of_tuple6 (se, _, _, _, _, _) (ego, position) = se"
  | "var_of_tuple6 (_, ve, _, _, _, _) (ego, speed) = ve"
  | "var_of_tuple6 (_, _, ae, _, _, _) (ego, max_dec) = ae"
  | "var_of_tuple6 (_, _, _, so, _ ,_) (other, position) = so"
  | "var_of_tuple6 (_, _, _, _, vo ,_) (other, speed) = vo"
  | "var_of_tuple6 (_, _, _, _, _ ,ao) (other, max_dec) = ao"

definition interpret_tuple6::"real tuple6 list \<Rightarrow> (var, real) discrete_trace"
  where "interpret_tuple6 = map var_of_tuple6"

fun check_bb_safe_dist_wit' :: "nat \<Rightarrow> (ivl tuple6) list \<Rightarrow> bool list" where
"check_bb_safe_dist_wit' prec [] = []" |
"check_bb_safe_dist_wit' prec ((se, ve, ae, so, vo, ao) # js) =
  (checker' prec se ve ae so vo ao # check_bb_safe_dist_wit' prec js)"

fun numbering_result :: "bool list \<Rightarrow> (nat \<times> bool) list" where
"numbering_result res = zip [0..<(length res)] res"

fun filter_witness :: "bool list \<Rightarrow> nat list" where
"filter_witness res = map fst (filter (\<lambda>nres . snd nres = False) (numbering_result res))"

definition check_bb_safe_dist_wit'' :: "nat \<Rightarrow> (real tuple6) list \<Rightarrow> bool list" where
"check_bb_safe_dist_wit'' p trc =
  check_bb_safe_dist_wit' p
      (map (\<lambda>(a, b, c, d, e, f).
        (float_ivl_of_real p a,
         float_ivl_of_real p b,
         float_ivl_of_real p c,
         float_ivl_of_real p d,
         float_ivl_of_real p e,
         float_ivl_of_real p f)) trc)"

fun check_bb_safe_dist' :: "_ \<Rightarrow> nat \<Rightarrow> (ivl tuple6) list \<Rightarrow> bool" where
"check_bb_safe_dist' chk' prec [] = True" |
"check_bb_safe_dist' chk' prec ((se, ve, ae, so, vo, ao) # js) =
  (chk' prec se ve ae so vo ao \<and> check_bb_safe_dist' chk' prec js)"

definition trans6
  where "trans6 c chk'    se     ve     ae     so     vo     ao =
                  chk' (c se) (c ve) (c ae) (c so) (c vo) (c ao)"

primrec real_of_dec where
  "real_of_dec (m, e) =
    real_of_int (int_of_integer m) *
      (if e \<ge> 0 then 10 ^ (nat_of_integer e) else inverse (10 ^ (nat (-(int_of_integer e)))))"

lemma "real_of_dec (m, e) = int_of_integer m * 10 powr (int_of_integer e)"
proof -
  have 1: "e \<ge> 0 \<Longrightarrow> real (nat_of_integer e) = real_of_int (int_of_integer e)"
    using less_eq_integer.rep_eq nat_of_integer.rep_eq by auto
  have 2: "e \<le> 0 \<Longrightarrow> real_of_int (int_of_integer e) = - real (nat (- int_of_integer e))"
    using less_eq_integer.rep_eq by auto
  show ?thesis
    using 1
    apply (auto simp: real_of_dec_def powr_realpow[symmetric] divide_simps)
    apply (subst (asm) 2)
    apply (auto simp: powr_add[symmetric])
    done
qed

definition checker_dec
  where "checker_dec chk' p u =
    trans6 (float_ivl_of_real (nat_of_integer u) o real_of_dec) (chk' (nat_of_integer p))"

definition "checker_interval = checker_dec checker'"
definition "checker_symbolic = trans6 real_of_dec symbolic_checker"
definition "checker_rational = trans6 real_of_dec checker"
lemmas[code] = movement.p_def

lemma checker_kernel: "checker 0 54.93 (-5.6087) 62.58 54.90 (-5.6388)"
  by (simp add: checker_def Let_def check_precond_def first_safe_dist_def second_safe_dist_def
    suff_cond_safe_dist2_def rel_dist_to_stop_def power2_eq_square)

subsubsection\<open>Evaluation\<close>
text \<open>\label{sec:eval}\<close>

ML \<open>Char.isPunct\<close>
definition "testval = (40.99::real)"
export_code testval in SML
ML \<open>
  fun split_string s = String.fields (fn c => c = the (Char.fromString s))
  fun dec_of_string s =
    case split_string "." s
    of [r] => (the (IntInf.fromString r), 0)
    | [d1, d2] => (the (IntInf.fromString (d1 ^ d2)), ~ (String.size d2))
  fun check_string chk data =
    let
      val [id, so, _, ve, ae, _, vo, ao] = split_string "," data
(*      val _ = @{print} [(dec_of_string ve), (dec_of_string ae), (dec_of_string so), (dec_of_string vo), (dec_of_string ao)]*)
    in
      chk data (0, 0)
        (dec_of_string ve) (dec_of_string ae) (dec_of_string so) (dec_of_string vo) (dec_of_string ao)
    end
\<close>
ML \<open>
val prec = 12 (* 12 is roughly precision of input data, yields similar performance as Sturm *)
fun check_stream' chk i n y s =
  case TextIO.inputLine s of
    NONE => (TextIO.closeIn s; (y, i))
  | SOME l =>
    let
      val l = String.substring (l, 0, String.size l - 1)
(*       val _ = writeln l *)
      val c = check_string chk l
(*      val _ = if c then TextIO.print (IntInf.toString i ^ ": Yes\n") else TextIO.print (IntInf.toString i ^ ": No\n") *)
    in
      if i < n then check_stream' chk (i + 1) n (if c then y + 1 else y) s
      else (TextIO.closeIn s; (y, i))
    end
fun check_stream chk f n = check_stream' chk 0 n 0 (TextIO.openIn f)
val check_stream_symbolic = check_stream (fn _ => @{code checker_symbolic})
fun check_stream_interval prec uncer = check_stream (fn _ => @{code checker_interval} prec uncer)
val check_stream_rational = check_stream (fn _ => @{code checker_rational})
fun check_stream_delta prec uncer = check_stream (fn s => fn b => fn c => fn d => fn e => fn f => fn g =>
  let
    val c1 = @{code checker_rational} b c d e f g
    val c2 = @{code checker_interval} prec uncer b c d e f g
    val _ = if c1 andalso not c2 then writeln ("Incompletion at: " ^ s) else ()
  in c2 end
  )
\<close>

ML \<open>val filename = "/Users/immler/work/traffic/safe-distance/data/test_vector_first.csv"\<close>

ML \<open>
    val t_start = Timing.start ();
    check_stream_rational filename 1121215(*00*);
    val t_end = Timing.result t_start;
\<close>

ML \<open>check_stream_interval (* prec *) 12 (* uncertainty: 2^-7 *) 7 filename 2000\<close>
ML \<open>check_stream_rational filename 200000\<close>
ML \<open>check_stream_symbolic filename 2000\<close>
ML \<open>check_stream_delta 12 7 filename 200000\<close>

text \<open>438,62.58,6,54.90,-5.6088,4,54.90,-5.6088\<close>
text \<open> id,   so, ,   ve,     ae, ,   vo,     ao\<close>

context begin

private definition se::real where "se = 0"
private definition so::real where "so = 40.99"
private definition ve::real where "ve = 45.15"
private definition vo::real where "vo = 44.56"
private definition ae::real where "ae = -5.6088"
private definition ao::real where "ao = -5.6088"

ML \<open>map dec_of_string ["114.01", "50.00", "50.52", "-5.6088"]\<close>

lemmas test_defs = se_def so_def ve_def vo_def ae_def ao_def
thm checker_def[THEN meta_eq_to_obj_eq, unfolded Let_def, of se ve ae so vo ao]
value [code] "second_safe_dist ve ae vo ao < so - se"
lemma "second_safe_dist ve ae vo ao < so - se"
  unfolding second_safe_dist_def rel_dist_to_stop_def test_defs
  apply (approximation 10)
  done

value [code] "so - se \<le> first_safe_dist ve ae"
lemma "so - se \<le> first_safe_dist ve ae"
  unfolding rel_dist_to_stop_def test_defs first_safe_dist_def
  apply (approximation 10)
  done
value [code] "suff_cond_safe_dist2 se ve ae so vo ao"
lemma "suff_cond_safe_dist2 se ve ae so vo ao"
  unfolding checker_def check_precond_def first_safe_dist_def second_safe_dist_def
    suff_cond_safe_dist2_def Let_def t_stop_def s_stop_def
    rel_dist_to_stop_def
    discriminant_def
    not_le not_less
    de_Morgan_conj
    de_Morgan_disj
  unfolding test_defs
(*  apply (approximation 80) *)
  oops

value [code] "((4456 / 10\<^sup>2 - 4515 / 10\<^sup>2)\<^sup>2 -
    2 * (- (56088 / 10 ^ 4) - - (56088 / 10 ^ 4)) * (4099 / 10\<^sup>2 - 0)::real)"
value [code] "(4515 / 10\<^sup>2 - - (56088 / 10 ^ 4) / - (56088 / 10 ^ 4) * (4456 / 10\<^sup>2))\<^sup>2::real"

value[code] "trans6 (\<lambda>(i, j). (integer_of_int i, integer_of_int j)) (checker_interval (integer_of_nat 10) (integer_of_nat 10))
  (0, 0)
  (4515, -2)
  (-56088, -4)
  (4099, -2)
  (4456, -2)
  (-56088, -4)"
(* 0 ve ae so vo ao *)

end

end


theory Move_to_Front
imports Complex_Main Inversion
begin

section "Online Algorithm Move-to-Front"

text{* It was first proved by Sleator and Tarjan~\cite{SleatorT-CACM85} that
the Move-to-Front algorithm is 2-competitive. *}

(* The core idea, not used: *)
lemma sum_telescope:
fixes f :: "nat \<Rightarrow> 'a::linordered_ab_group_add"
shows "(\<Sum>i=0..<k. f(Suc i) - f i) = f k - f 0"
by(induction k) auto

(* The version with upper bounds, used: *)
lemma potential:
fixes t :: "nat \<Rightarrow> 'a::linordered_ab_group_add" and p :: "nat \<Rightarrow> 'a"
assumes p0: "p 0 = 0" and ppos: "\<And>n. p n \<ge> 0"
and ub: "\<And>n. t n + p(n+1) - p n \<le> u n"
shows "(\<Sum>i<n. t i) \<le> (\<Sum>i<n. u i)"
proof-
  let ?a = "\<lambda>n. t n + p(n+1) - p n"
  have 1: "(\<Sum>i<n. t i) = (\<Sum>i<n. ?a i) - p(n)"
    by(induction n) (simp_all add: p0)
  thus ?thesis
    by (metis (erased, lifting) add.commute diff_add_cancel le_add_same_cancel2 order.trans ppos setsum_mono ub)
qed

abbreviation "before x xs \<equiv> {y. y < x in xs}"
abbreviation "after x xs \<equiv> {y. x < y in xs}"

lemma finite_before[simp]: "finite (before x xs)"
apply(rule finite_subset[where B = "set xs"])
apply (auto dest: before_in_setD1)
done

lemma finite_after[simp]: "finite (after x xs)"
apply(rule finite_subset[where B = "set xs"])
apply (auto dest: before_in_setD2)
done

lemma before_conv_take:
  "x : set xs \<Longrightarrow> before x xs = set(take (index xs x) xs)"
by (auto simp add: before_in_def set_take_if_index index_le_size) (metis index_take leI)

lemma card_before: "distinct xs \<Longrightarrow> x : set xs \<Longrightarrow> card (before x xs) = index xs x"
using  index_le_size[of xs x]
by(simp add: before_conv_take distinct_card[OF distinct_take] min_def)

lemma card_subset_before:
  "distinct xs \<Longrightarrow> x : set xs \<Longrightarrow> A \<subseteq> before x xs \<Longrightarrow> card(A) \<le> index xs x"
by (metis before_conv_take card_before card_mono[OF finite_set])

lemma before_Un: "set xs = set ys \<Longrightarrow> x : set xs \<Longrightarrow>
  before x ys = before x xs \<inter> before x ys Un after x xs \<inter> before x ys"
by(auto)(metis before_in_setD1 not_before_in)

lemma before_disj: "dist_perm xs ys \<Longrightarrow> x : set xs \<Longrightarrow>
  before x xs \<inter> before x ys \<inter> (after x xs \<inter> before x ys) = {}"
by auto (metis no_before_inI)

lemma phi_diff_aux:
  "card (Inv xs ys \<union>
             {(y, x) |y. y < x in xs \<and> y < x in ys} -
             {(x, y) |y. x < y in xs \<and> y < x in ys}) =
   card(Inv xs ys) + card(before x xs \<inter> before x ys)
   - int(card(after x xs \<inter> before x ys))"
  (is "card(?I \<union> ?B - ?A) = card ?I + card ?b - int(card ?a)")
proof-
  have 1: "?I \<inter> ?B = {}" by(auto simp: Inv_def) (metis no_before_inI)
  have 2: "?A \<subseteq> ?I \<union> ?B" by(auto simp: Inv_def)
  have 3: "?A \<subseteq> ?I" by(auto simp: Inv_def)
  have "int(card(?I \<union> ?B - ?A)) = int(card ?I + card ?B) - int(card ?A)"
    using  card_mono[OF _ 3]
    by(simp add: card_Un_disjoint[OF _ _ 1] card_Diff_subset[OF _ 2])
  also have "card ?B = card (fst ` ?B)" by(auto simp: card_image inj_on_def)
  also have "fst ` ?B = ?b" by force
  also have "card ?A = card (snd ` ?A)" by(auto simp: card_image inj_on_def)
  also have "snd ` ?A = ?a" by force
  finally show ?thesis .
qed

lemma foldr_swap_inv:
  "\<forall>i\<in>set sws. Suc i < length xs \<Longrightarrow>
  set (foldr swapSuc sws xs) = set xs \<and>
  size(foldr swapSuc sws xs) = size xs \<and>
  distinct(foldr swapSuc sws xs) = distinct xs"
by (induct sws arbitrary: xs) (simp_all add: swapSuc_def)

lemma card_Inv_foldr_swapSuc:
  "\<forall>i\<in>set sws. Suc i < length xs \<Longrightarrow> distinct xs \<Longrightarrow>
  card (Inv xs (foldr swapSuc sws xs)) \<le> length sws"
by(induction sws)
  (auto simp add: Inv_swap foldr_swap_inv card_insert_if card_Diff_singleton_if)

locale MTF_Off =
fixes q :: "nat \<Rightarrow> 'a"
fixes init :: "'a list"
fixes sw_off :: "nat \<Rightarrow> nat list"
assumes dist_init[simp]: "distinct init"
assumes sw_off_size: "\<forall>i \<in> set(sw_off n). Suc i < size init"
begin

fun s_off :: "nat \<Rightarrow> 'a list" where
"s_off 0 = init" |
"s_off(Suc n) = foldr swapSuc (sw_off n) (s_off n)"

lemma length_s_off[simp]: "length(s_off n) = length init"
by (induction n) (simp_all add: foldr_swap_inv sw_off_size)

lemma dist_s_off[simp]: "distinct(s_off n)"
by(induction n)(simp_all add: foldr_swap_inv sw_off_size)

lemma set_s_off[simp]: "set(s_off n) = set init"
by(induction n)(simp_all add: foldr_swap_inv sw_off_size)

fun s_mtf :: "nat \<Rightarrow> 'a list" where
"s_mtf 0 = init" |
"s_mtf (Suc n) = mtf (q n) (s_mtf n)"

definition t_mtf :: "nat \<Rightarrow> int" where
"t_mtf n = index (s_mtf n) (q n) + 1"

definition T_mtf :: "nat \<Rightarrow> int" where
"T_mtf n = (\<Sum>i<n. t_mtf i)"

definition c_off :: "nat \<Rightarrow> int" where
"c_off n = index (s_off n) (q n) + 1"

definition p_off :: "nat \<Rightarrow> int" where
"p_off n = size(sw_off n)"

definition t_off :: "nat \<Rightarrow> int" where
"t_off n = c_off n + p_off n"

definition T_off :: "nat \<Rightarrow> int" where
"T_off n = (\<Sum>i<n. t_off i)"

lemma length_s_mtf[simp]: "length(s_mtf n) = length init"
by (induction n) simp_all

lemma dist_s_mtf[simp]: "distinct(s_mtf n)"
apply(induction n)
apply (simp)
apply (auto simp: mtf_def index_take set_drop_if_index)
apply (metis set_drop_if_index index_take less_Suc_eq_le linear)
done

lemma set_s_mtf[simp]: "set (s_mtf n) = set init"
by (induction n) (simp_all)

lemma dperm_inv: "dist_perm (s_off n) (s_mtf n)"
by (metis dist_s_mtf dist_s_off set_s_mtf set_s_off)

definition Phi :: "nat \<Rightarrow> int" ("\<Phi>") where
"Phi n = card(Inv (s_off n) (s_mtf n))"

lemma phi0: "Phi 0 = 0"
by(simp add: Phi_def)

lemma phi_pos: "Phi n \<ge> 0"
by(simp add: Phi_def)

lemma mtf_ub: "t_mtf n + Phi (n+1) - Phi n \<le> 2 * c_off n - 1 + p_off n"
proof -
  let ?xs = "s_off n" let ?ys = "s_mtf n" let ?x = "q n"
  let ?xs' = "foldr swapSuc (sw_off n) ?xs" let ?ys' = "mtf ?x ?ys"
  show ?thesis
  proof cases
  assume xin: "?x \<in> set ?ys"
  let ?bb = "before ?x ?xs \<inter> before ?x ?ys"
  let ?ab = "after ?x ?xs \<inter> before ?x ?ys"
  have phi_diff:
    "Phi (Suc n) - Phi n \<le> card ?bb - int(card ?ab) + size(sw_off n)"
  proof -
    have "Phi (Suc n) - Phi n = card (Inv ?xs' ?ys') - int(card (Inv ?xs ?ys))"
      by(simp add: Phi_def)
    also have "int(card (Inv ?xs' ?ys')) \<le> card(Inv ?xs' ?xs) + int(card(Inv ?xs ?ys'))"
      using card_Inv_tri_ineq[of ?xs' ?xs ?ys'] xin
      by (simp add: foldr_swap_inv sw_off_size)
    also have "card(Inv ?xs' ?xs) = card(Inv ?xs ?xs')"
      by (rule card_Inv_sym)
    also have "card(Inv ?xs ?xs') \<le> size(sw_off n)"
      by (metis card_Inv_foldr_swapSuc dist_s_off sw_off_size length_s_off)
    also have "card(Inv ?xs ?ys') \<le>
        card(Inv ?xs ?ys) + card ?bb - int(card ?ab)"
      using xin by(simp add: Inv_mtf phi_diff_aux)
    finally show ?thesis by(fastforce simp: Let_def)
  qed
  have t_mtf: "t_mtf n = card ?bb + card ?ab + 1"
  proof -
    have "index ?ys ?x = card (before ?x ?ys)" using xin
      by(simp add: card_before[OF dist_s_mtf])
    also have "\<dots> = card(?bb \<union> ?ab)"
      by (metis before_Un set_s_mtf set_s_off xin)
    also have "\<dots> = card ?bb + card ?ab"
      using xin by(simp add: card_Un_disjoint before_disj dperm_inv)
    finally show ?thesis by(simp add: t_mtf_def Let_def)
  qed
  show ?thesis using xin phi_diff card_subset_before[of "s_off n" "q n" "?bb"]
    by(simp add: t_mtf c_off_def p_off_def Let_def)
  next
    assume notin: "?x \<notin> set ?ys"
    have "int (card (Inv ?xs' ?ys)) - card (Inv ?xs ?ys) \<le> card(Inv ?xs ?xs')"
      using card_Inv_tri_ineq[OF _ dperm_inv, of ?xs' n]
            foldr_swap_inv[of "sw_off n" "s_off n"] sw_off_size[of n]
      by(simp add: card_Inv_sym)
    also have "\<dots> \<le> size(sw_off n)"
      by(simp add: card_Inv_foldr_swapSuc sw_off_size dperm_inv)
    finally show ?thesis using notin
      by(simp add: t_mtf_def c_off_def p_off_def Phi_def)
  qed
qed

text{* We ignore free exchanges because they are not necessary in an offline algorithm: *}

theorem Sleator_Tarjan: "T_mtf n \<le> (\<Sum>i<n. 2*c_off i + p_off i) - n"
proof-
  have "(\<Sum>i<n. t_mtf i) \<le> (\<Sum>i<n. 2*c_off i - 1 + p_off i)"
    by(rule potential[where p=Phi,OF phi0 phi_pos mtf_ub])
  also have "\<dots> = (\<Sum>i<n. (2*c_off i + p_off i) - 1)"
    by (simp add: diff_add_eq)
  also have "\<dots> = (\<Sum>i<n. 2*c_off i + p_off i) - n"
    by(simp add: sumr_diff_mult_const2[symmetric])
  finally show ?thesis by(simp add: T_mtf_def)
qed

lemma T_off_nneg: "0 \<le> (T_off n)"
by(auto simp add: setsum_nonneg T_off_def t_off_def c_off_def p_off_def)

lemma T_mtf_ub: "\<forall>i<n. q i \<in> set init \<Longrightarrow> (T_mtf n) \<le> n * size init"
proof(induction n)
  case 0 show ?case by(simp add: T_mtf_def)
next
  case (Suc n)  thus ?case
    using index_less_size_conv[of "s_mtf n" "q n"]
      by(simp add: T_mtf_def t_mtf_def less_Suc_eq del: index_less)
qed

corollary MTF_competitive: assumes "init \<noteq> []" and "\<forall>i<n. q i \<in> set init"
shows "T_mtf n \<le> (2 - 1/(size init)) * T_off n"
proof cases
  assume 0: "real(T_off n) \<le> n * (size init)"
  have "T_mtf n \<le> 2 * T_off n - n"
  proof -
    have "T_mtf n \<le> (\<Sum>i<n. 2*c_off i + p_off i) - n" by(rule Sleator_Tarjan)
    also have "(\<Sum>i<n. 2*c_off i + p_off i) \<le> (\<Sum>i<n. 2*(c_off i + p_off i))"
      by(rule setsum_mono) (simp add: p_off_def)
    also have "\<dots> \<le> 2 * T_off n" by (simp add: setsum_right_distrib T_off_def t_off_def)
    finally show ?thesis by simp
  qed
  hence "real(T_mtf n) \<le> 2 * real(T_off n) - n" by linarith
  also have "\<dots> = 2 * real(T_off n) - (n * size init) / size init"
    using assms(1) by simp
  also have "\<dots> \<le> 2 * real(T_off n) - T_off n / size init"
    by(rule diff_left_mono[OF  divide_right_mono[OF 0]]) simp
  also have "\<dots> = (2 - 1 / size init) * T_off n" by algebra
  finally show ?thesis .
next
  assume 0: "\<not> real(T_off n) \<le> n * (size init)"
  have "2 - 1 / size init \<ge> 1" using assms(1)
    by (auto simp add: field_simps neq_Nil_conv)
  have "real (T_mtf n) \<le> n * size init" using T_mtf_ub[OF assms(2)] by linarith
  also have "\<dots> < real(T_off n)" using 0 by linarith
  also have "\<dots> \<le> (2 - 1 / size init) * T_off n" using assms(1) T_off_nneg[of n]
    by(auto simp add: mult_le_cancel_right1 field_simps neq_Nil_conv
        simp del: real_of_int_setsum)
  finally show ?thesis by linarith
qed

end

end


section \<open>\isaheader{List Based Maps}\<close>
theory Impl_List_Map
imports
  "../../Iterator/Iterator"
  "../Gen/Gen_Map"
  "../Intf/Intf_Comp"
  "../Intf/Intf_Map"
begin

type_synonym ('k,'v) list_map = "('k\<times>'v) list"

definition "list_map_invar = distinct o map fst"

definition list_map_rel_internal_def:
    "list_map_rel Rk Rv \<equiv> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel O br map_of list_map_invar"

lemma list_map_rel_def:
    "\<langle>Rk,Rv\<rangle>list_map_rel = \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel O br map_of list_map_invar"
    unfolding list_map_rel_internal_def[abs_def] by (simp add: relAPP_def)

lemma list_rel_Range:
    "\<forall>x'\<in>set l'. x' \<in> Range R \<Longrightarrow> l' \<in> Range (\<langle>R\<rangle>list_rel)"
proof (induction l')
  case Nil thus ?case by force
next
  case (Cons x' xs')
    then obtain xs where "(xs,xs') \<in> \<langle>R\<rangle> list_rel" by force
    moreover from Cons.prems obtain x where "(x,x') \<in> R" by force
    ultimately have "(x#xs, x'#xs') \<in> \<langle>R\<rangle> list_rel" by simp
    thus ?case ..
qed

text \<open>All finite maps can be represented\<close>
lemma list_map_rel_range:
  "Range (\<langle>Rk,Rv\<rangle>list_map_rel) =
       {m. finite (dom m) \<and> dom m \<subseteq> Range Rk \<and> ran m \<subseteq> Range Rv}"
       (is "?A = ?B")
proof (intro equalityI subsetI)
  fix m' assume "m' \<in> ?A"
  then obtain l l' where A: "(l,l') \<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel" and
                         B: "m' = map_of l'" and C: "list_map_invar l'"
       unfolding list_map_rel_def br_def by blast
  {
    fix x' y' assume "m' x' = Some y'"
    with B have "(x',y') \<in> set l'" by (fast dest: map_of_SomeD)
    hence "x' \<in> Range Rk" and "y' \<in> Range Rv"
      by (induction rule: list_rel_induct[OF A], auto)
  }
  with B show "m' \<in> ?B" by (force dest: map_of_SomeD simp: ran_def)

next
  fix m' assume "m' \<in> ?B"
  hence A: "finite (dom m')" and B: "dom m' \<subseteq> Range Rk" and
        C: "ran m' \<subseteq> Range Rv" by simp_all
  from A have "finite (map_to_set m')" by (simp add: finite_map_to_set)
  from finite_distinct_list[OF this]
      obtain l' where l'_props: "distinct l'" "set l' = map_to_set m'" by blast
  hence *: "distinct (map fst l')"
      by (force simp: distinct_map inj_on_def map_to_set_def)
  from map_of_map_to_set[OF this] and l'_props
      have  "map_of l' = m'" by simp
  with * have "(l',m') \<in> br map_of list_map_invar"
      unfolding br_def list_map_invar_def o_def by simp

  moreover from B and C and l'_props
      have "\<forall>x \<in> set l'. x \<in> Range (\<langle>Rk,Rv\<rangle>prod_rel)"
      unfolding map_to_set_def ran_def prod_rel_def by force
  from list_rel_Range[OF this] obtain l where
      "(l,l') \<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel" by force

  ultimately show "m' \<in> ?A" unfolding list_map_rel_def by blast
qed

  lemmas [autoref_rel_intf] = REL_INTFI[of list_map_rel i_map]

  lemma list_map_rel_finite[autoref_ga_rules]:
    "finite_map_rel (\<langle>Rk,Rv\<rangle>list_map_rel)"
    unfolding finite_map_rel_def list_map_rel_def
    by (auto simp: br_def)

  lemma list_map_rel_sv[relator_props]:
    "single_valued Rk \<Longrightarrow> single_valued Rv \<Longrightarrow>
        single_valued (\<langle>Rk,Rv\<rangle>list_map_rel)"
    unfolding list_map_rel_def
    by tagged_solver

  (* TODO: Move to Misc *)

subsection \<open>Implementation\<close>

primrec list_map_lookup ::
    "('k \<Rightarrow> 'k \<Rightarrow> bool) \<Rightarrow> 'k \<Rightarrow> ('k,'v) list_map \<Rightarrow> 'v option" where
"list_map_lookup eq _ [] = None" |
"list_map_lookup eq k (y#ys) =
     (if eq (fst y) k then Some (snd y) else list_map_lookup eq k ys)"

primrec list_map_update_aux :: "('k \<Rightarrow> 'k \<Rightarrow> bool) \<Rightarrow> 'k \<Rightarrow> 'v \<Rightarrow>
    ('k,'v) list_map \<Rightarrow> ('k,'v) list_map \<Rightarrow> ('k,'v) list_map"where
"list_map_update_aux eq k v [] accu = (k,v) # accu" |
"list_map_update_aux eq k v (x#xs) accu =
    (if eq (fst x) k
        then (k,v) # xs @ accu
        else list_map_update_aux eq k v xs (x#accu))"

definition "list_map_update eq k v m \<equiv>
    list_map_update_aux eq k v m []"

primrec list_map_delete_aux :: "('k \<Rightarrow> 'k \<Rightarrow> bool) \<Rightarrow> 'k \<Rightarrow>
    ('k, 'v) list_map \<Rightarrow> ('k, 'v) list_map \<Rightarrow> ('k, 'v) list_map" where
"list_map_delete_aux eq k [] accu = accu" |
"list_map_delete_aux eq k (x#xs) accu =
    (if eq (fst x) k
        then xs @ accu
        else list_map_delete_aux eq k xs (x#accu))"

definition "list_map_delete eq k m \<equiv> list_map_delete_aux eq k m []"

definition list_map_isEmpty :: "('k,'v) list_map \<Rightarrow> bool"
    where "list_map_isEmpty \<equiv> List.null"

definition list_map_isSng :: "('k,'v) list_map \<Rightarrow> bool"
    where "list_map_isSng m = (case m of [x] \<Rightarrow> True | _ \<Rightarrow> False)"

definition list_map_size :: "('k,'v) list_map \<Rightarrow> nat"
    where "list_map_size \<equiv> length"

definition list_map_iteratei :: "('k,'v) list_map \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow>
    (('k\<times>'v) \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'b"
    where "list_map_iteratei \<equiv> foldli"

definition list_map_to_list :: "('k,'v) list_map \<Rightarrow> ('k\<times>'v) list"
    where "list_map_to_list = id"

subsection \<open>Parametricity\<close>

lemma list_map_autoref_empty[autoref_rules]:
  "([], op_map_empty)\<in>\<langle>Rk,Rv\<rangle>list_map_rel"
  by (auto simp: list_map_rel_def br_def list_map_invar_def)

lemma param_list_map_lookup[param]:
  "(list_map_lookup,list_map_lookup) \<in> (Rk \<rightarrow> Rk \<rightarrow> bool_rel) \<rightarrow>
       Rk \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>Rv\<rangle>option_rel"
unfolding list_map_lookup_def[abs_def] by parametricity

lemma list_map_autoref_lookup_aux:
  assumes eq: "GEN_OP eq (=) (Rk\<rightarrow>Rk\<rightarrow>Id)"
  assumes K: "(k, k') \<in> Rk"
  assumes M: "(m, m') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
  shows "(list_map_lookup eq k m, op_map_lookup k' (map_of m'))
               \<in> \<langle>Rv\<rangle>option_rel"
unfolding op_map_lookup_def
proof (induction rule: list_rel_induct[OF M, case_names Nil Cons])
  case Nil
    show ?case by simp
next
  case (Cons x x' xs xs')
    from eq have eq': "(eq,(=)) \<in> Rk \<rightarrow> Rk \<rightarrow> Id" by simp
    with eq'[param_fo] and K  and Cons
        show ?case by (force simp: prod_rel_def)
qed

lemma param_list_map_update_aux[param]:
  "(list_map_update_aux,list_map_update_aux) \<in> (Rk \<rightarrow> Rk \<rightarrow> bool_rel) \<rightarrow>
       Rk \<rightarrow> Rv \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel
        \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
unfolding list_map_update_aux_def[abs_def] by parametricity

lemma param_list_map_update[param]:
  "(list_map_update,list_map_update) \<in> (Rk \<rightarrow> Rk \<rightarrow> bool_rel) \<rightarrow>
       Rk \<rightarrow> Rv \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
unfolding list_map_update_def[abs_def] by parametricity

lemma list_map_autoref_update_aux1:
  assumes eq: "(eq,(=)) \<in> Rk \<rightarrow> Rk \<rightarrow> Id"
  assumes K: "(k, k') \<in> Rk"
  assumes V: "(v, v') \<in> Rv"
  assumes A: "(accu, accu') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
  assumes M: "(m, m') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
  shows "(list_map_update_aux eq k v m accu,
          list_map_update_aux (=) k' v' m' accu')
               \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
proof (insert A, induction arbitrary: accu accu'
           rule: list_rel_induct[OF M, case_names Nil Cons])
  case Nil
      thus ?case by (simp add: K V)
next
  case (Cons x x' xs xs')
    from eq have eq': "(eq,(=)) \<in> Rk \<rightarrow> Rk \<rightarrow> Id" by simp
    from eq'[param_fo] Cons(1) K
        have [simp]: "(eq (fst x) k) \<longleftrightarrow> ((fst x') = k')"
        by (force simp: prod_rel_def)
    show ?case
    proof (cases "eq (fst x) k")
      case False
        from Cons.prems and Cons.hyps have "(x # accu, x' # accu') \<in>
            \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel" by parametricity
        from Cons.IH[OF this] and False show ?thesis by simp
    next
      case True
        from Cons.prems and Cons.hyps have "(xs @ accu, xs' @ accu') \<in>
            \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel" by parametricity
        with K and V and True show ?thesis by simp
  qed
qed

lemma list_map_autoref_update1[param]:
  assumes eq: "(eq,(=)) \<in> Rk \<rightarrow> Rk \<rightarrow> Id"
  shows "(list_map_update eq, list_map_update (=)) \<in> Rk \<rightarrow> Rv \<rightarrow>
             \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
unfolding list_map_update_def[abs_def]
  by (intro fun_relI, erule (1) list_map_autoref_update_aux1[OF eq],
      simp_all)

(* TODO: Move - Perhaps. *)
lemma map_add_sng_right: "m ++ [k\<mapsto>v] = m(k \<mapsto> v)"
    unfolding map_add_def by force
lemma map_add_sng_right':
    "m ++ (\<lambda>a. if a = k then Some v else None) = m(k \<mapsto> v)"
    unfolding map_add_def by force

lemma list_map_autoref_update_aux2:
  assumes K: "(k, k') \<in> Id"
  assumes V: "(v, v') \<in> Id"
  assumes A: "(accu, accu') \<in> br map_of list_map_invar"
  assumes A1: "distinct (map fst (m @ accu))"
  assumes A2: "k \<notin> set (map fst accu)"
  assumes M: "(m, m') \<in> br map_of list_map_invar"
  shows "(list_map_update_aux (=) k v m accu,
          accu' ++ op_map_update k' v' m')
               \<in> br map_of list_map_invar" (is "(?f m accu, _) \<in> _")
using M A A1 A2
proof (induction m arbitrary: accu accu' m')
  case Nil
    with K V show ?case by (auto simp: br_def list_map_invar_def
        map_add_sng_right')
next
  case (Cons x xs accu accu' m')
    from Cons.prems have A: "m' = map_of (x#xs)" "accu' = map_of accu"
        unfolding br_def by simp_all
    show ?case
    proof (cases "(fst x) =  k")
      case True
        hence "((k, v) # xs @ accu, accu' ++ op_map_update k' v' m')
                   \<in> br map_of list_map_invar"
            using K V Cons.prems(3,4) unfolding br_def
            by (force simp add: A list_map_invar_def)
        also from True have "(k,v) # xs @ accu = ?f (x # xs) accu" by simp
        finally show ?thesis .
    next
      case False
        from Cons.prems(1) have B: "(xs, map_of xs) \<in> br map_of
            list_map_invar"by (simp add: br_def list_map_invar_def)
        from Cons.prems(2,3) have C: "(x#accu, map_of (x#accu)) \<in> br map_of
            list_map_invar" by (simp add: br_def list_map_invar_def)
        from Cons.prems(3) have D: "distinct (map fst (xs @ x # accu))"
            by simp
        from Cons.prems(4) and False have E: "k \<notin> set (map fst (x # accu))"
            by simp
        note Cons.IH[OF B C D E]
        also from False have "?f xs (x#accu) = ?f (x#xs) accu" by simp
        also from distinct_map_fstD[OF D]
            have F: "\<And>z. (fst x, z) \<in> set xs \<Longrightarrow> z = snd x" by force
        have "map_of (x # accu) ++ op_map_update k' v' (map_of xs) =
                  accu' ++ op_map_update k' v' m'"
            by (intro ext, auto simp: A F map_add_def
                    dest: map_of_SomeD split: option.split)
        finally show ?thesis .
    qed
qed

lemma list_map_autoref_update2[param]:
  shows "(list_map_update (=), op_map_update) \<in> Id \<rightarrow> Id \<rightarrow>
             br map_of list_map_invar \<rightarrow> br map_of list_map_invar"
unfolding list_map_update_def[abs_def]
apply (intro fun_relI)
apply (drule list_map_autoref_update_aux2
                 [where accu="[]" and accu'="Map.empty"])
apply (auto simp: br_def list_map_invar_def)
done

lemma list_map_autoref_update[autoref_rules]:
  assumes eq: "GEN_OP eq (=) (Rk\<rightarrow>Rk\<rightarrow>Id)"
  shows "(list_map_update eq, op_map_update) \<in>
      Rk \<rightarrow> Rv \<rightarrow> \<langle>Rk,Rv\<rangle>list_map_rel \<rightarrow> \<langle>Rk,Rv\<rangle>list_map_rel"
unfolding list_map_rel_def
apply (intro fun_relI, elim relcompE, intro relcompI, clarsimp)
apply (erule (2) list_map_autoref_update1[param_fo, OF eq[simplified]])
apply (rule list_map_autoref_update2[param_fo], simp_all)
done

context begin interpretation autoref_syn .
lemma list_map_autoref_update_dj[autoref_rules]:
    assumes "PRIO_TAG_OPTIMIZATION"
    assumes new: "SIDE_PRECOND_OPT (k' \<notin> dom m')"
    assumes K: "(k,k')\<in>Rk" and V: "(v,v')\<in>Rv"
    assumes M: "(l,m')\<in>\<langle>Rk, Rv\<rangle>list_map_rel"
    defines "R_annot \<equiv> Rk \<rightarrow> Rv \<rightarrow> \<langle>Rk,Rv\<rangle>list_map_rel \<rightarrow> \<langle>Rk,Rv\<rangle>list_map_rel"
    shows "
      ((k, v)#l,
        (OP op_map_update:::R_annot)$k'$v'$m')
      \<in> \<langle>Rk,Rv\<rangle>list_map_rel"
proof -
  from M obtain l' where A: "(l,l') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel" and
      B: "(l',m') \<in> br map_of list_map_invar"
      unfolding list_map_rel_def by blast
  hence "((k,v)#l, (k',v')#l')\<in>\<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
      and "((k',v')#l', m'(k' \<mapsto> v')) \<in> br map_of list_map_invar"
      using assms unfolding br_def list_map_invar_def
          by (simp_all add: dom_map_of_conv_image_fst)
  thus ?thesis
    unfolding autoref_tag_defs
    by (force simp: list_map_rel_def)
qed
end

lemma param_list_map_delete_aux[param]:
  "(list_map_delete_aux,list_map_delete_aux) \<in> (Rk \<rightarrow> Rk \<rightarrow> bool_rel) \<rightarrow>
       Rk \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel
        \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
unfolding list_map_delete_aux_def[abs_def] by parametricity

lemma param_list_map_delete[param]:
  "(list_map_delete,list_map_delete) \<in> (Rk \<rightarrow> Rk \<rightarrow> bool_rel) \<rightarrow>
       Rk \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
unfolding list_map_delete_def[abs_def] by parametricity

lemma list_map_autoref_delete_aux1:
  assumes eq: "(eq,(=)) \<in> Rk \<rightarrow> Rk \<rightarrow> Id"
  assumes K: "(k, k') \<in> Rk"
  assumes A: "(accu, accu') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
  assumes M: "(m, m') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
  shows "(list_map_delete_aux eq k m accu,
          list_map_delete_aux (=) k' m' accu')
               \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
proof (insert A, induction arbitrary: accu accu'
           rule: list_rel_induct[OF M, case_names Nil Cons])
  case Nil
      thus ?case by (simp add: K)
next
  case (Cons x x' xs xs')
    from eq have eq': "(eq,(=)) \<in> Rk \<rightarrow> Rk \<rightarrow> Id" by simp
    from eq'[param_fo] Cons(1) K
        have [simp]: "(eq (fst x) k) \<longleftrightarrow> ((fst x') = k')"
        by (force simp: prod_rel_def)
    show ?case
    proof (cases "eq (fst x) k")
      case False
        from Cons.prems and Cons.hyps have "(x # accu, x' # accu') \<in>
            \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel" by parametricity
        from Cons.IH[OF this] and False show ?thesis by simp
    next
      case True
        from Cons.prems and Cons.hyps have "(xs @ accu, xs' @ accu') \<in>
            \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel" by parametricity
        with K and True show ?thesis by simp
  qed
qed

lemma list_map_autoref_delete1[param]:
  assumes eq: "(eq,(=)) \<in> Rk \<rightarrow> Rk \<rightarrow> Id"
  shows "(list_map_delete eq, list_map_delete (=)) \<in> Rk \<rightarrow>
             \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
unfolding list_map_delete_def[abs_def]
  by (intro fun_relI, erule list_map_autoref_delete_aux1[OF eq],
      simp_all)

lemma list_map_autoref_delete_aux2:
  assumes K: "(k, k') \<in> Id"
  assumes A: "(accu, accu') \<in> br map_of list_map_invar"
  assumes A1: "distinct (map fst (m @ accu))"
  assumes A2: "k \<notin> set (map fst accu)"
  assumes M: "(m, m') \<in> br map_of list_map_invar"
  shows "(list_map_delete_aux (=) k m accu,
          accu' ++ op_map_delete k' m')
               \<in> br map_of list_map_invar" (is "(?f m accu, _) \<in> _")
using M A A1 A2
proof (induction m arbitrary: accu accu' m')
  case Nil
    with K show ?case by (auto simp: br_def list_map_invar_def
        map_add_sng_right')
next
  case (Cons x xs accu accu' m')
    from Cons.prems have A: "m' = map_of (x#xs)" "accu' = map_of accu"
        unfolding br_def by simp_all
    show ?case
    proof (cases "(fst x) =  k")
      case True
        with Cons.prems(3) have "map_of xs (fst x) = None"
          by (induction xs, simp_all)
        with fun_upd_triv[of "map_of xs" "fst x"]
        have "map_of xs |` (- {fst x}) = map_of xs"
          by (simp add: map_upd_eq_restrict)
        with True have"(xs @ accu, accu' ++ op_map_delete k' m')
                           \<in> br map_of list_map_invar"
            using K Cons.prems unfolding br_def
            by (auto simp add: A list_map_invar_def)
        thus ?thesis using True by simp
    next
      case False
        from False and K have [simp]: "fst x \<noteq> k'" by simp
        from Cons.prems(1) have B: "(xs, map_of xs) \<in> br map_of
            list_map_invar"by (simp add: br_def list_map_invar_def)
        from Cons.prems(2,3) have C: "(x#accu, map_of (x#accu)) \<in> br map_of
            list_map_invar" by (simp add: br_def list_map_invar_def)
        from Cons.prems(3) have D: "distinct (map fst (xs @ x # accu))"
            by simp
        from Cons.prems(4) and False have E: "k \<notin> set (map fst (x # accu))"
            by simp
        note Cons.IH[OF B C D E]
        also from False have "?f xs (x#accu) = ?f (x#xs) accu" by simp
        also from distinct_map_fstD[OF D]
            have F: "\<And>z. (fst x, z) \<in> set xs \<Longrightarrow> z = snd x" by force

        from Cons.prems(3) have "map_of xs (fst x) = None"
            by (induction xs, simp_all)
        hence "map_of (x # accu) ++ op_map_delete k' (map_of xs) =
               accu' ++ op_map_delete k' m'"
            apply (intro ext, simp add: map_add_def A
                                   split: option.split)
            apply (intro conjI impI allI)
            apply (auto simp: restrict_map_def)
            done
        finally show ?thesis .
    qed
qed

lemma list_map_autoref_delete[autoref_rules]:
  assumes eq: "GEN_OP eq (=) (Rk\<rightarrow>Rk\<rightarrow>Id)"
  shows "(list_map_delete eq, op_map_delete) \<in>
      Rk \<rightarrow> \<langle>Rk,Rv\<rangle>list_map_rel \<rightarrow> \<langle>Rk,Rv\<rangle>list_map_rel"
unfolding list_map_rel_def
apply (intro fun_relI, elim relcompE, intro relcompI, clarsimp)
apply (erule (1) list_map_autoref_delete1[param_fo, OF eq[simplified]])
apply (rule list_map_autoref_delete2[param_fo], simp_all)
done

lemma list_map_autoref_isEmpty[autoref_rules]:
  shows "(list_map_isEmpty, op_map_isEmpty) \<in>
             \<langle>Rk,Rv\<rangle>list_map_rel \<rightarrow> bool_rel"
unfolding list_map_isEmpty_def op_map_isEmpty_def[abs_def]
    list_map_rel_def br_def List.null_def[abs_def] by force

lemma param_list_map_isSng[param]:
  assumes "(l,l') \<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
  shows "(list_map_isSng l, list_map_isSng l') \<in> bool_rel"
unfolding list_map_isSng_def using assms by parametricity

(* TODO: clean up this mess *)
lemma list_map_autoref_isSng_aux:
  assumes "(l',m') \<in> br map_of list_map_invar"
  shows "(list_map_isSng l', op_map_isSng m') \<in> bool_rel"
using assms
unfolding list_map_isSng_def op_map_isSng_def br_def list_map_invar_def
apply (clarsimp split: list.split)
apply (intro conjI impI allI)
apply (metis map_upd_nonempty)
apply blast
apply (simp, metis fun_upd_apply option.distinct(1))
done

lemma list_map_autoref_isSng[autoref_rules]:
  "(list_map_isSng, op_map_isSng) \<in> \<langle>Rk,Rv\<rangle>list_map_rel \<rightarrow> bool_rel"
  unfolding list_map_rel_def
  by (blast dest!: param_list_map_isSng list_map_autoref_isSng_aux)

lemma list_map_autoref_size_aux:
  assumes "distinct (map fst x)"
  shows "card (dom (map_of x)) = length x"
proof-
  have "card (dom (map_of x)) = card (map_to_set (map_of x))"
      by (simp add: card_map_to_set)
  also from assms have "... = card (set x)"
      by (simp add: map_to_set_map_of)
  also from assms have "... = length x"
      by (force simp: distinct_card dest!: distinct_mapI)
  finally show ?thesis .
qed

lemma param_list_map_size[param]:
  "(list_map_size, list_map_size) \<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> nat_rel"
  unfolding list_map_size_def[abs_def] by parametricity

lemma list_map_autoref_size[autoref_rules]:
  shows "(list_map_size, op_map_size) \<in>
             \<langle>Rk,Rv\<rangle>list_map_rel \<rightarrow> nat_rel"
unfolding list_map_size_def[abs_def] op_map_size_def[abs_def]
    list_map_rel_def br_def list_map_invar_def
    by (force simp: list_map_autoref_size_aux list_rel_imp_same_length)

lemma autoref_list_map_is_iterator[autoref_ga_rules]:
  shows "is_map_to_list Rk Rv list_map_rel list_map_to_list"
unfolding is_map_to_list_def is_map_to_sorted_list_def
proof (clarify)
  fix l m'
  assume "(l,m') \<in> \<langle>Rk,Rv\<rangle>list_map_rel"
  then obtain l' where *: "(l,l')\<in>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel" "(l',m')\<in>br map_of list_map_invar"
    unfolding list_map_rel_def by blast
  then have "RETURN l' \<le> it_to_sorted_list (key_rel (\<lambda>_ _. True)) (map_to_set m')"
      unfolding it_to_sorted_list_def
      apply (intro refine_vcg)
      unfolding br_def list_map_invar_def key_rel_def[abs_def]
      apply (auto intro: distinct_mapI simp: map_to_set_map_of)
      done
  with * show
      "\<exists>l'. (list_map_to_list l, l') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel \<and>
            RETURN l' \<le> it_to_sorted_list (key_rel (\<lambda>_ _. True))
                             (map_to_set m')"
    unfolding list_map_to_list_def by force
qed

lemma pi_list_map[icf_proper_iteratorI]:
  "proper_it (list_map_iteratei m) (list_map_iteratei m)"
unfolding proper_it_def list_map_iteratei_def by blast

lemma pi'_list_map[icf_proper_iteratorI]:
  "proper_it' list_map_iteratei list_map_iteratei"
  by (rule proper_it'I, rule pi_list_map)

primrec list_map_pick_remove where
  "list_map_pick_remove [] = undefined"
| "list_map_pick_remove (kv#l) = (kv,l)"

context begin interpretation autoref_syn .
  lemma list_map_autoref_pick_remove[autoref_rules]:
    assumes NE: "SIDE_PRECOND (m\<noteq>Map.empty)"
    assumes R: "(l,m)\<in>\<langle>Rk,Rv\<rangle>list_map_rel"
    defines "Rres \<equiv> \<langle>(Rk\<times>\<^sub>rRv) \<times>\<^sub>r \<langle>Rk,Rv\<rangle>list_map_rel\<rangle>nres_rel"
    shows "(
        RETURN (list_map_pick_remove l),
        (OP op_map_pick_remove ::: \<langle>Rk,Rv\<rangle>list_map_rel \<rightarrow> Rres)$m
      ) \<in> Rres"
  proof -
    from NE R obtain k v lr where
      [simp]: "l=(k,v)#lr"
      by (cases l) (auto simp: list_map_rel_def br_def)

    thm list_map_rel_def
    from R obtain l' where
      LL': "(l,l')\<in>\<langle>Rk\<times>\<^sub>rRv\<rangle>list_rel" and
      L'M: "(l',m)\<in>br map_of list_map_invar"
      unfolding list_map_rel_def by auto
    from LL' obtain k' v' lr' where
      [simp]: "l' = (k',v')#lr'" and
        KVR: "(k,k')\<in>Rk" "(v,v')\<in>Rv" and
        LRR: "(lr,lr')\<in>\<langle>Rk\<times>\<^sub>rRv\<rangle>list_rel"
      by (fastforce elim!: list_relE)

    from L'M have
      MKV': "m k' = Some v'" and
      LRR': "(lr',m|`(-{k'}))\<in>br map_of list_map_invar"
      by (auto
        simp: restrict_map_def map_of_eq_None_iff br_def list_map_invar_def
        intro!: ext
        intro: sym)

    from LRR LRR' have LM: "(lr,m|`(-{k'}))\<in>\<langle>Rk,Rv\<rangle>list_map_rel"
      unfolding list_map_rel_def by auto

    show ?thesis
      apply (simp add: Rres_def)
      apply (refine_rcg SPEC_refine nres_relI refine_vcg)
      using LM KVR MKV'
      by auto
  qed
end

end