(* Author: Xingyuan Zhang, Chunhan Wu, Christian Urban *)
theory Myhill_2
  imports Myhill_1 "HOL-Library.Sublist"
begin

section \<open>Second direction of MN: \<open>regular language \<Rightarrow> finite partition\<close>\<close>

subsection \<open>Tagging functions\<close>

definition
   tag_eq :: "('a list \<Rightarrow> 'b) \<Rightarrow> ('a list \<times> 'a list) set" ("=_=")
where
   "=tag= \<equiv> {(x, y). tag x = tag y}"

abbreviation
   tag_eq_applied :: "'a list \<Rightarrow> ('a list \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> bool" ("_ =_= _")
where
   "x =tag= y \<equiv> (x, y) \<in> =tag="

lemma refined_intro:
  assumes "\<And>x y z. \<lbrakk>x =tag= y; x @ z \<in> A\<rbrakk> \<Longrightarrow> y @ z \<in> A"
  shows "=tag= \<subseteq> \<approx>A"
using assms unfolding str_eq_def tag_eq_def
apply(clarify, simp (no_asm_use))
by metis

lemma finite_eq_tag_rel:
  assumes rng_fnt: "finite (range tag)"
  shows "finite (UNIV // =tag=)"
proof -
  let "?f" =  "\<lambda>X. tag ` X" and ?A = "(UNIV // =tag=)"
  have "finite (?f ` ?A)"
  proof -
    have "range ?f \<subseteq> (Pow (range tag))" unfolding Pow_def by auto
    moreover
    have "finite (Pow (range tag))" using rng_fnt by simp
    ultimately
    have "finite (range ?f)" unfolding image_def by (blast intro: finite_subset)
    moreover
    have "?f ` ?A \<subseteq> range ?f" by auto
    ultimately show "finite (?f ` ?A)" by (rule rev_finite_subset)
  qed
  moreover
  have "inj_on ?f ?A"
  proof -
    { fix X Y
      assume X_in: "X \<in> ?A"
        and  Y_in: "Y \<in> ?A"
        and  tag_eq: "?f X = ?f Y"
      then obtain x y
        where "x \<in> X" "y \<in> Y" "tag x = tag y"
        unfolding quotient_def Image_def image_def tag_eq_def
        by (simp) (blast)
      with X_in Y_in
      have "X = Y"
        unfolding quotient_def tag_eq_def by auto
    }
    then show "inj_on ?f ?A" unfolding inj_on_def by auto
  qed
  ultimately show "finite (UNIV // =tag=)" by (rule finite_imageD)
qed

lemma refined_partition_finite:
  assumes fnt: "finite (UNIV // R1)"
  and refined: "R1 \<subseteq> R2"
  and eq1: "equiv UNIV R1" and eq2: "equiv UNIV R2"
  shows "finite (UNIV // R2)"
proof -
  let ?f = "\<lambda>X. {R1 `` {x} | x. x \<in> X}"
    and ?A = "UNIV // R2" and ?B = "UNIV // R1"
  have "?f ` ?A \<subseteq> Pow ?B"
    unfolding image_def Pow_def quotient_def by auto
  moreover
  have "finite (Pow ?B)" using fnt by simp
  ultimately
  have "finite (?f ` ?A)" by (rule finite_subset)
  moreover
  have "inj_on ?f ?A"
  proof -
    { fix X Y
      assume X_in: "X \<in> ?A" and Y_in: "Y \<in> ?A" and eq_f: "?f X = ?f Y"
      from quotientE [OF X_in]
      obtain x where "X = R2 `` {x}" by blast
      with equiv_class_self[OF eq2] have x_in: "x \<in> X" by simp
      then have "R1 ``{x} \<in> ?f X" by auto
      with eq_f have "R1 `` {x} \<in> ?f Y" by simp
      then obtain y
        where y_in: "y \<in> Y" and eq_r1_xy: "R1 `` {x} = R1 `` {y}" by auto
      with eq_equiv_class[OF _ eq1]
      have "(x, y) \<in> R1" by blast
      with refined have "(x, y) \<in> R2" by auto
      with quotient_eqI [OF eq2 X_in Y_in x_in y_in]
      have "X = Y" .
    }
    then show "inj_on ?f ?A" unfolding inj_on_def by blast
  qed
  ultimately show "finite (UNIV // R2)" by (rule finite_imageD)
qed

lemma tag_finite_imageD:
  assumes rng_fnt: "finite (range tag)"
  and     refined: "=tag=  \<subseteq> \<approx>A"
  shows "finite (UNIV // \<approx>A)"
proof (rule_tac refined_partition_finite [of "=tag="])
  show "finite (UNIV // =tag=)" by (rule finite_eq_tag_rel[OF rng_fnt])
next
  show "=tag= \<subseteq> \<approx>A" using refined .
next
  show "equiv UNIV =tag="
  and  "equiv UNIV (\<approx>A)"
    unfolding equiv_def str_eq_def tag_eq_def refl_on_def sym_def trans_def
    by auto
qed

subsection \<open>Base cases: @{const Zero}, @{const One} and @{const Atom}\<close>

lemma quot_zero_finiteI [intro]:
  shows "finite (UNIV // \<approx>{})"
unfolding quot_zero_eq by simp

lemma quot_one_subset:
  shows "UNIV // \<approx>{[]} \<subseteq> {{[]}, UNIV - {[]}}"
proof
  fix x
  assume "x \<in> UNIV // \<approx>{[]}"
  then obtain y where h: "x = {z. y \<approx>{[]} z}"
    unfolding quotient_def Image_def by blast
  { assume "y = []"
    with h have "x = {[]}" by (auto simp: str_eq_def)
    then have "x \<in> {{[]}, UNIV - {[]}}" by simp }
  moreover
  { assume "y \<noteq> []"
    with h have "x = UNIV - {[]}" by (auto simp: str_eq_def)
    then have "x \<in> {{[]}, UNIV - {[]}}" by simp }
  ultimately show "x \<in> {{[]}, UNIV - {[]}}" by blast
qed

lemma quot_one_finiteI [intro]:
  shows "finite (UNIV // \<approx>{[]})"
by (rule finite_subset[OF quot_one_subset]) (simp)

lemma quot_atom_subset:
  "UNIV // (\<approx>{[c]}) \<subseteq> {{[]},{[c]}, UNIV - {[], [c]}}"
proof
  fix x
  assume "x \<in> UNIV // \<approx>{[c]}"
  then obtain y where h: "x = {z. (y, z) \<in> \<approx>{[c]}}"
    unfolding quotient_def Image_def by blast
  show "x \<in> {{[]},{[c]}, UNIV - {[], [c]}}"
  proof -
    { assume "y = []" hence "x = {[]}" using h
        by (auto simp: str_eq_def) }
    moreover
    { assume "y = [c]" hence "x = {[c]}" using h
        by (auto dest!: spec[where x = "[]"] simp: str_eq_def) }
    moreover
    { assume "y \<noteq> []" and "y \<noteq> [c]"
      hence "\<forall> z. (y @ z) \<noteq> [c]" by (case_tac y, auto)
      moreover have "\<And> p. (p \<noteq> [] \<and> p \<noteq> [c]) = (\<forall> q. p @ q \<noteq> [c])"
        by (case_tac p, auto)
      ultimately have "x = UNIV - {[],[c]}" using h
        by (auto simp add: str_eq_def)
    }
    ultimately show ?thesis by blast
  qed
qed

lemma quot_atom_finiteI [intro]:
  shows "finite (UNIV // \<approx>{[c]})"
by (rule finite_subset[OF quot_atom_subset]) (simp)

subsection \<open>Case for @{const Plus}\<close>

definition
  tag_Plus :: "'a lang \<Rightarrow> 'a lang \<Rightarrow> 'a list \<Rightarrow> ('a lang \<times> 'a lang)"
where
  "tag_Plus A B \<equiv> \<lambda>x. (\<approx>A `` {x}, \<approx>B `` {x})"

lemma quot_plus_finiteI [intro]:
  assumes finite1: "finite (UNIV // \<approx>A)"
  and     finite2: "finite (UNIV // \<approx>B)"
  shows "finite (UNIV // \<approx>(A \<union> B))"
proof (rule_tac tag = "tag_Plus A B" in tag_finite_imageD)
  have "finite ((UNIV // \<approx>A) \<times> (UNIV // \<approx>B))"
    using finite1 finite2 by auto
  then show "finite (range (tag_Plus A B))"
    unfolding tag_Plus_def quotient_def
    by (rule rev_finite_subset) (auto)
next
  show "=tag_Plus A B= \<subseteq> \<approx>(A \<union> B)"
    unfolding tag_eq_def tag_Plus_def str_eq_def by auto
qed

subsection \<open>Case for \<open>Times\<close>\<close>

definition
  "Partitions x \<equiv> {(x\<^sub>p, x\<^sub>s). x\<^sub>p @ x\<^sub>s = x}"

lemma conc_partitions_elim:
  assumes "x \<in> A \<cdot> B"
  shows "\<exists>(u, v) \<in> Partitions x. u \<in> A \<and> v \<in> B"
using assms unfolding conc_def Partitions_def
by auto

lemma conc_partitions_intro:
  assumes "(u, v) \<in> Partitions x \<and> u \<in> A \<and>  v \<in> B"
  shows "x \<in> A \<cdot> B"
using assms unfolding conc_def Partitions_def
by auto

lemma equiv_class_member:
  assumes "x \<in> A"
  and "\<approx>A `` {x} = \<approx>A `` {y}"
  shows "y \<in> A"
using assms
apply(simp)
apply(simp add: str_eq_def)
apply(metis append_Nil2)
done

definition
  tag_Times :: "'a lang \<Rightarrow> 'a lang \<Rightarrow> 'a list \<Rightarrow> 'a lang \<times> 'a lang set"
where
  "tag_Times A B \<equiv> \<lambda>x. (\<approx>A `` {x}, {(\<approx>B `` {x\<^sub>s}) | x\<^sub>p x\<^sub>s. x\<^sub>p \<in> A \<and> (x\<^sub>p, x\<^sub>s) \<in> Partitions x})"

lemma tag_Times_injI:
  assumes a: "tag_Times A B x = tag_Times A B y"
  and     c: "x @ z \<in> A \<cdot> B"
  shows "y @ z \<in> A \<cdot> B"
proof -
  from c obtain u v where
    h1: "(u, v) \<in> Partitions (x @ z)" and
    h2: "u \<in> A" and
    h3: "v \<in> B" by (auto dest: conc_partitions_elim)
  from h1 have "x @ z = u @ v" unfolding Partitions_def by simp
  then obtain us
    where "(x = u @ us \<and> us @ z = v) \<or> (x @ us = u \<and> z = us @ v)"
    by (auto simp add: append_eq_append_conv2)
  moreover
  { assume eq: "x = u @ us" "us @ z = v"
    have "(\<approx>B `` {us}) \<in> snd (tag_Times A B x)"
      unfolding Partitions_def tag_Times_def using h2 eq
      by (auto simp add: str_eq_def)
    then have "(\<approx>B `` {us}) \<in> snd (tag_Times A B y)"
      using a by simp
    then obtain u' us' where
      q1: "u' \<in> A" and
      q2: "\<approx>B `` {us} = \<approx>B `` {us'}" and
      q3: "(u', us') \<in> Partitions y"
      unfolding tag_Times_def by auto
    from q2 h3 eq
    have "us' @ z \<in> B"
      unfolding Image_def str_eq_def by auto
    then have "y @ z \<in> A \<cdot> B" using q1 q3
      unfolding Partitions_def by auto
  }
  moreover
  { assume eq: "x @ us = u" "z = us @ v"
    have "(\<approx>A `` {x}) = fst (tag_Times A B x)"
      by (simp add: tag_Times_def)
    then have "(\<approx>A `` {x}) = fst (tag_Times A B y)"
      using a by simp
    then have "\<approx>A `` {x} = \<approx>A `` {y}"
      by (simp add: tag_Times_def)
    moreover
    have "x @ us \<in> A" using h2 eq by simp
    ultimately
    have "y @ us \<in> A" using equiv_class_member
      unfolding Image_def str_eq_def by blast
    then have "(y @ us) @ v \<in> A \<cdot> B"
      using h3 unfolding conc_def by blast
    then have "y @ z \<in> A \<cdot> B" using eq by simp
  }
  ultimately show "y @ z \<in> A \<cdot> B" by blast
qed

lemma quot_conc_finiteI [intro]:
  assumes fin1: "finite (UNIV // \<approx>A)"
  and     fin2: "finite (UNIV // \<approx>B)"
  shows "finite (UNIV // \<approx>(A \<cdot> B))"
proof (rule_tac tag = "tag_Times A B" in tag_finite_imageD)
  have "\<And>x y z. \<lbrakk>tag_Times A B x = tag_Times A B y; x @ z \<in> A \<cdot> B\<rbrakk> \<Longrightarrow> y @ z \<in> A \<cdot> B"
    by (rule tag_Times_injI)
       (auto simp add: tag_Times_def tag_eq_def)
  then show "=tag_Times A B= \<subseteq> \<approx>(A \<cdot> B)"
    by (rule refined_intro)
       (auto simp add: tag_eq_def)
next
  have *: "finite ((UNIV // \<approx>A) \<times> (Pow (UNIV // \<approx>B)))"
    using fin1 fin2 by auto
  show "finite (range (tag_Times A B))"
    unfolding tag_Times_def
    apply(rule finite_subset[OF _ *])
    unfolding quotient_def
    by auto
qed

subsection \<open>Case for @{const "Star"}\<close>

lemma star_partitions_elim:
  assumes "x @ z \<in> A\<star>" "x \<noteq> []"
  shows "\<exists>(u, v) \<in> Partitions (x @ z). strict_prefix u x \<and> u \<in> A\<star> \<and> v \<in> A\<star>"
proof -
  have "([], x @ z) \<in> Partitions (x @ z)" "strict_prefix [] x" "[] \<in> A\<star>" "x @ z \<in> A\<star>"
    using assms by (auto simp add: Partitions_def strict_prefix_def)
  then show "\<exists>(u, v) \<in> Partitions (x @ z). strict_prefix u x \<and> u \<in> A\<star> \<and> v \<in> A\<star>"
    by blast
qed

lemma finite_set_has_max2:
  "\<lbrakk>finite A; A \<noteq> {}\<rbrakk> \<Longrightarrow> \<exists> max \<in> A. \<forall> a \<in> A. length a \<le> length max"
apply(induct rule:finite.induct)
apply(simp)
by (metis (no_types) all_not_in_conv insert_iff linorder_le_cases order_trans)

lemma finite_strict_prefix_set:
  shows "finite {xa. strict_prefix xa (x::'a list)}"
apply (induct x rule:rev_induct, simp)
apply (subgoal_tac "{xa. strict_prefix xa (xs @ [x])} = {xa. strict_prefix xa xs} \<union> {xs}")
by (auto simp:strict_prefix_def)

lemma append_eq_cases:
  assumes a: "x @ y = m @ n" "m \<noteq> []"
  shows "prefix x m \<or> strict_prefix m x"
unfolding prefix_def strict_prefix_def using a
by (auto simp add: append_eq_append_conv2)

lemma star_spartitions_elim2:
  assumes a: "x @ z \<in> A\<star>"
  and     b: "x \<noteq> []"
  shows "\<exists>(u, v) \<in> Partitions x. \<exists> (u', v') \<in> Partitions z. strict_prefix u x \<and> u \<in> A\<star> \<and> v @ u' \<in> A \<and> v' \<in> A\<star>"
proof -
  define S where "S = {u | u v. (u, v) \<in> Partitions x \<and> strict_prefix u x \<and> u \<in> A\<star> \<and> v @ z \<in> A\<star>}"
  have "finite {u. strict_prefix u x}" by (rule finite_strict_prefix_set)
  then have "finite S" unfolding S_def
    by (rule rev_finite_subset) (auto)
  moreover
  have "S \<noteq> {}" using a b unfolding S_def Partitions_def
    by (auto simp: strict_prefix_def)
  ultimately have "\<exists> u_max \<in> S. \<forall> u \<in> S. length u \<le> length u_max"
    using finite_set_has_max2 by blast
  then obtain u_max v
    where h0: "(u_max, v) \<in> Partitions x"
    and h1: "strict_prefix u_max x"
    and h2: "u_max \<in> A\<star>"
    and h3: "v @ z \<in> A\<star>"
    and h4: "\<forall> u v. (u, v) \<in> Partitions x \<and> strict_prefix u x \<and> u \<in> A\<star> \<and> v @ z \<in> A\<star> \<longrightarrow> length u \<le> length u_max"
    unfolding S_def Partitions_def by blast
  have q: "v \<noteq> []" using h0 h1 b unfolding Partitions_def by auto
  from h3 obtain a b
    where i1: "(a, b) \<in> Partitions (v @ z)"
    and   i2: "a \<in> A"
    and   i3: "b \<in> A\<star>"
    and   i4: "a \<noteq> []"
    unfolding Partitions_def
    using q by (auto dest: star_decom)
  have "prefix v a"
  proof (rule ccontr)
    assume a: "\<not>(prefix v a)"
    from i1 have i1': "a @ b = v @ z" unfolding Partitions_def by simp
    then have "prefix a v \<or> strict_prefix v a" using append_eq_cases q by blast
    then have q: "strict_prefix a v" using a unfolding strict_prefix_def prefix_def by auto
    then obtain as where eq: "a @ as = v" unfolding strict_prefix_def prefix_def by auto
    have "(u_max @ a, as) \<in> Partitions x" using eq h0 unfolding Partitions_def by auto
    moreover
    have "strict_prefix (u_max @ a) x" using h0 eq q unfolding Partitions_def prefix_def strict_prefix_def by auto
    moreover
    have "u_max @ a \<in> A\<star>" using i2 h2 by simp
    moreover
    have "as @ z \<in> A\<star>" using i1' i2 i3 eq by auto
    ultimately have "length (u_max @ a) \<le> length u_max" using h4 by blast
    with i4 show "False" by auto
  qed
  with i1 obtain za zb
    where k1: "v @ za = a"
    and   k2: "(za, zb) \<in> Partitions z"
    and   k4: "zb = b"
    unfolding Partitions_def prefix_def
    by (auto simp add: append_eq_append_conv2)
  show "\<exists> (u, v) \<in> Partitions x. \<exists> (u', v') \<in> Partitions z. strict_prefix u x \<and> u \<in> A\<star> \<and> v @ u' \<in> A \<and> v' \<in> A\<star>"
    using h0 h1 h2 i2 i3 k1 k2 k4 unfolding Partitions_def by blast
qed

definition
  tag_Star :: "'a lang \<Rightarrow> 'a list \<Rightarrow> ('a lang) set"
where
  "tag_Star A \<equiv> \<lambda>x. {\<approx>A `` {v} | u v. strict_prefix u x \<and> u \<in> A\<star> \<and> (u, v) \<in> Partitions x}"

lemma tag_Star_non_empty_injI:
  assumes a: "tag_Star A x = tag_Star A y"
  and     c: "x @ z \<in> A\<star>"
  and     d: "x \<noteq> []"
  shows "y @ z \<in> A\<star>"
proof -
  obtain u v u' v'
    where a1: "(u,  v) \<in> Partitions x" "(u', v')\<in> Partitions z"
    and   a2: "strict_prefix u x"
    and   a3: "u \<in> A\<star>"
    and   a4: "v @ u' \<in> A"
    and   a5: "v' \<in> A\<star>"
    using c d by (auto dest: star_spartitions_elim2)
  have "(\<approx>A) `` {v} \<in> tag_Star A x"
    apply(simp add: tag_Star_def Partitions_def str_eq_def)
    using a1 a2 a3 by (auto simp add: Partitions_def)
  then have "(\<approx>A) `` {v} \<in> tag_Star A y" using a by simp
  then obtain u1 v1
    where b1: "v \<approx>A v1"
    and   b3: "u1 \<in> A\<star>"
    and   b4: "(u1, v1) \<in> Partitions y"
    unfolding tag_Star_def by auto
  have c: "v1 @ u' \<in> A\<star>" using b1 a4 unfolding str_eq_def by simp
  have "u1 @ (v1 @ u') @ v' \<in> A\<star>"
    using b3 c a5 by (simp only: append_in_starI)
  then show "y @ z \<in> A\<star>" using b4 a1
    unfolding Partitions_def by auto
qed

lemma tag_Star_empty_injI:
  assumes a: "tag_Star A x = tag_Star A y"
  and     c: "x @ z \<in> A\<star>"
  and     d: "x = []"
  shows "y @ z \<in> A\<star>"
proof -
  from a have "{} = tag_Star A y" unfolding tag_Star_def using d by auto
  then have "y = []"
    unfolding tag_Star_def Partitions_def strict_prefix_def prefix_def
    by (auto) (metis Nil_in_star append_self_conv2)
  then show "y @ z \<in> A\<star>" using c d by simp
qed

lemma quot_star_finiteI [intro]:
  assumes finite1: "finite (UNIV // \<approx>A)"
  shows "finite (UNIV // \<approx>(A\<star>))"
proof (rule_tac tag = "tag_Star A" in tag_finite_imageD)
  have "\<And>x y z. \<lbrakk>tag_Star A x = tag_Star A y; x @ z \<in> A\<star>\<rbrakk> \<Longrightarrow> y @ z \<in> A\<star>"
    by (case_tac "x = []") (blast intro: tag_Star_empty_injI tag_Star_non_empty_injI)+
  then show "=(tag_Star A)= \<subseteq> \<approx>(A\<star>)"
    by (rule refined_intro) (auto simp add: tag_eq_def)
next
  have *: "finite (Pow (UNIV // \<approx>A))"
     using finite1 by auto
  show "finite (range (tag_Star A))"
    unfolding tag_Star_def
    by (rule finite_subset[OF _ *])
       (auto simp add: quotient_def)
qed

subsection \<open>The conclusion of the second direction\<close>

lemma Myhill_Nerode2:
  fixes r::"'a rexp"
  shows "finite (UNIV // \<approx>(lang r))"
by (induct r) (auto)

end


section {* Map type: extra functions and properties *}

theory Map_Extra
imports
  Main
  "~~/src/HOL/Library/Countable_Set"
  "~~/src/HOL/Library/Char_ord"
  "~~/src/HOL/Library/Monad_Syntax"
begin

subsection {* Functional relations *}

definition functional :: "('a * 'b) set \<Rightarrow> bool" where
"functional g = inj_on fst g"

definition functional_list :: "('a * 'b) list \<Rightarrow> bool" where
"functional_list xs = (\<forall> x y z. ListMem (x,y) xs \<and> ListMem (x,z) xs \<longrightarrow> y = z)"

lemma functional_insert [simp]: "functional (insert (x,y) g) \<longleftrightarrow> (g``{x} \<subseteq> {y} \<and> functional g)"
  by (auto simp add:functional_def inj_on_def image_def)

(*
lemma functional_listD: "\<lbrakk>finite g; functional g\<rbrakk> \<Longrightarrow> functional_list (sorted_list_of_set g)"
  by (force simp add:functional_list_def ListMem_iff functional_def inj_on_def)
*)

lemma functional_list_nil[simp]: "functional_list []"
  by (simp add:functional_list_def ListMem_iff)

lemma functional_list: "functional_list xs \<longleftrightarrow> functional (set xs)"
  apply (induct xs)
  apply (simp add:functional_def)
  apply (simp add:functional_def functional_list_def ListMem_iff)
  apply (safe)
  apply (force)
  apply (force)
  apply (force)
  apply (force)
  apply (force)
  apply (force)
  apply (force)
  apply (force)
done

subsection {* Graphing maps *}

definition map_graph :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a * 'b) set" where
"map_graph f = {(x,y) | x y. f x = Some y}"

definition graph_map :: "('a * 'b) set \<Rightarrow> ('a \<rightharpoonup> 'b)" where
"graph_map g = (\<lambda> x. if (x \<in> fst ` g) then Some (SOME y. (x,y) \<in> g) else None)"

definition graph_map' :: "('a \<times> 'b) set \<rightharpoonup> ('a \<rightharpoonup> 'b)" where
"graph_map' R = (if (functional R) then Some (graph_map R) else None)"

lemma map_graph_mem_equiv: "(x, y) \<in> map_graph f \<longleftrightarrow> f(x) = Some y"
  by (simp add: map_graph_def)

lemma map_graph_functional[simp]: "functional (map_graph f)"
  by (simp add:functional_def map_graph_def inj_on_def)

lemma map_graph_countable [simp]: "countable (dom f) \<Longrightarrow> countable (map_graph f)"
  apply (auto simp add:map_graph_def countable_def)
  apply (rule_tac x="fa \<circ> fst" in exI)
  apply (auto simp add:inj_on_def dom_def)
  apply fastforce
done

lemma map_graph_inv [simp]: "graph_map (map_graph f) = f"
  by (auto intro!:ext simp add:map_graph_def graph_map_def image_def)

lemma graph_map_empty[simp]: "graph_map {} = empty"
  by (simp add:graph_map_def)

lemma graph_map_insert [simp]: "\<lbrakk>functional g; g``{x} \<subseteq> {y}\<rbrakk> \<Longrightarrow> graph_map (insert (x,y) g) = (graph_map g)(x \<mapsto> y)"
  by (rule ext, auto simp add:graph_map_def)

lemma dom_map_graph: "dom f = Domain(map_graph f)"
  by (simp add: map_graph_def dom_def image_def)

lemma ran_map_graph: "ran f = Range(map_graph f)"
  by (simp add: map_graph_def ran_def image_def)

lemma ran_map_add_subset:
  "ran (x ++ y) \<subseteq> (ran x) \<union> (ran y)"
  by (auto simp add:ran_def)

lemma finite_dom_graph: "finite (dom f) \<Longrightarrow> finite (map_graph f)"
  by (metis dom_map_graph finite_imageD fst_eq_Domain functional_def map_graph_functional)

lemma finite_dom_ran [simp]: "finite (dom f) \<Longrightarrow> finite (ran f)"
  by (metis finite_Range finite_dom_graph ran_map_graph)

lemma graph_map_inv [simp]: "functional g \<Longrightarrow> map_graph (graph_map g) = g"
  apply (auto simp add:map_graph_def graph_map_def functional_def)
  apply (metis (lifting, no_types) image_iff option.distinct(1) option.inject someI surjective_pairing)
  apply (simp add:inj_on_def)
  apply (metis fst_conv snd_conv some_equality)
  apply (metis (lifting) fst_conv image_iff)
done

lemma graph_map_dom: "dom (graph_map R) = fst ` R"
  by (simp add: graph_map_def dom_def)

lemma graph_map_countable_dom: "countable R \<Longrightarrow> countable (dom (graph_map R))"
  by (simp add: graph_map_dom)

lemma countable_ran:
  assumes "countable (dom f)"
  shows "countable (ran f)"
proof -
  have "countable (map_graph f)"
    by (simp add: assms)
  then have "countable (Range(map_graph f))"
    by (simp add: Range_snd)
  thus ?thesis
    by (simp add: ran_map_graph)
qed

lemma map_graph_inv' [simp]:
  "graph_map' (map_graph f) = Some f"
  by (simp add: graph_map'_def)

lemma map_graph_inj:
  "inj map_graph"
  by (metis injI map_graph_inv)

lemma map_eq_graph: "f = g \<longleftrightarrow> map_graph f = map_graph g"
  by (auto simp add: inj_eq map_graph_inj)

(*
lemma functional_list_graph: "\<lbrakk>functional_list xs; sorted xs; distinct xs\<rbrakk> \<Longrightarrow> map_of xs = graph_map (set xs)"
  apply (simp add:functional_list)
  apply (induct xs)
  apply (simp)
  apply (auto)
  apply (rule ext)
  apply (auto)
  apply (metis sorted_Cons)
done

lemma map_graph_list: "\<lbrakk>finite g; functional g\<rbrakk> \<Longrightarrow> map_of (sorted_list_of_set g) = graph_map g"
  apply (subgoal_tac "\<exists> xs. functional_list xs \<and> sorted xs \<and> distinct xs \<and> g = set xs")
  apply (auto)
  apply (simp add:sorted_list_of_set_sort_remdups distinct_remdups_id sorted_sort_id functional_list_graph)
  apply (auto dest:functional_listD)
done
*)

lemma map_le_graph: "f \<subseteq>\<^sub>m g \<longleftrightarrow> map_graph f \<subseteq> map_graph g"
  by (force simp add: map_le_def map_graph_def)

lemma map_graph_comp: "map_graph (g \<circ>\<^sub>m f) = (map_graph f) O (map_graph g)"
  apply (auto simp add: map_comp_def map_graph_def relcomp_unfold)
  apply (rename_tac a b)
  apply (case_tac "f a", auto)
done

subsection {* Map application *}

definition map_apply :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" ("_'(_')\<^sub>m" [999,0] 999) where
"map_apply = (\<lambda> f x. the (f x))"

subsection {* Map membership *}

fun map_member :: "'a \<times> 'b \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> bool" (infix "\<in>\<^sub>m" 50) where
"(k, v) \<in>\<^sub>m m \<longleftrightarrow> m(k) = Some(v)"

lemma map_ext:
  "\<lbrakk> \<And> x y. (x, y) \<in>\<^sub>m A \<longleftrightarrow> (x, y) \<in>\<^sub>m B \<rbrakk> \<Longrightarrow> A = B"
  by (rule ext, auto, metis not_Some_eq)

lemma map_member_alt_def:
  "(x, y) \<in>\<^sub>m A \<longleftrightarrow> (x \<in> dom A \<and> A(x)\<^sub>m = y)"
  by (auto simp add: map_apply_def)

lemma map_le_member:
  "f \<subseteq>\<^sub>m g \<longleftrightarrow> (\<forall> x y. (x,y) \<in>\<^sub>m f \<longrightarrow> (x,y) \<in>\<^sub>m g)"
  by (force simp add: map_le_def)

subsection {* Preimage *}

definition preimage :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'b set \<Rightarrow> 'a set" where
"preimage f B = {x \<in> dom(f). the(f(x)) \<in> B}"

lemma preimage_range: "preimage f (ran f) = dom f"
  by (auto simp add: preimage_def ran_def)

lemma dom_preimage: "dom (m \<circ>\<^sub>m f) = preimage f (dom m)"
  apply (auto simp add: dom_def preimage_def)
  apply (meson map_comp_Some_iff)
  apply (metis map_comp_def option.case_eq_if option.distinct(1))
done

lemma countable_preimage:
  "\<lbrakk> countable A; inj_on f (preimage f A) \<rbrakk> \<Longrightarrow> countable (preimage f A)"
  apply (auto simp add: countable_def)
  apply (rename_tac g)
  apply (rule_tac x="g \<circ> the \<circ> f" in exI)
  apply (rule inj_onI)
  apply (drule inj_onD)
  apply (auto simp add: preimage_def inj_onD)
done

subsection {* Minus operation for maps *}

definition map_minus :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b)" (infixl "--" 100)
where "map_minus f g = (\<lambda> x. if (f x = g x) then None else f x)"

lemma map_minus_apply [simp]: "y \<in> dom(f -- g) \<Longrightarrow> (f -- g)(y)\<^sub>m = f(y)\<^sub>m"
  by (auto simp add: map_minus_def dom_def map_apply_def)

lemma map_member_plus:
  "(x, y) \<in>\<^sub>m f ++ g \<longleftrightarrow> ((x \<notin> dom(g) \<and> (x, y) \<in>\<^sub>m f) \<or> (x, y) \<in>\<^sub>m g)"
  by (auto simp add: map_add_Some_iff)

lemma map_member_minus:
  "(x, y) \<in>\<^sub>m f -- g \<longleftrightarrow> (x, y) \<in>\<^sub>m f \<and> (\<not> (x, y) \<in>\<^sub>m g)"
  by (auto simp add: map_minus_def)

lemma map_minus_plus_commute:
  "dom(g) \<inter> dom(h) = {} \<Longrightarrow> (f -- g) ++ h = (f ++ h) -- g"
  apply (rule map_ext)
  apply (auto simp add: map_member_plus map_member_minus simp del: map_member.simps)
  apply (auto simp add: map_member_alt_def)
done

lemma map_graph_minus: "map_graph (f -- g) = map_graph f - map_graph g"
  by (auto simp add: map_minus_def map_graph_def, (meson option.distinct(1))+)

lemma map_minus_common_subset:
  "\<lbrakk> h \<subseteq>\<^sub>m f; h \<subseteq>\<^sub>m g \<rbrakk> \<Longrightarrow> (f -- h = g -- h) = (f = g)"
  by (auto simp add: map_eq_graph map_graph_minus map_le_graph)

text {* Create some extra intro/elim rules to help dealing with proof about
        option bind. *}

lemma option_bindSomeE [elim!]:
  "\<lbrakk> X >>= F = Some(v); \<And> x. \<lbrakk> X = Some(x); F(x) = Some(v) \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (case_tac X, auto)

lemma option_bindSomeI [intro]:
  "\<lbrakk> X = Some(x); F(x) = Some(y) \<rbrakk> \<Longrightarrow> X >>= F = Some(y)"
  by (simp)

lemma ifSomeE [elim]: "\<lbrakk> (if c then Some(x) else None) = Some(y); \<lbrakk> c; x = y \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (case_tac c, auto)

text {* A range restriction operator; only domain restriction is provided in HOL *}

definition ran_restrict_map :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'b set \<Rightarrow> 'a \<rightharpoonup> 'b" ("_\<upharpoonleft>\<^bsub>_\<^esub>" [111,110] 110) where
"ran_restrict_map f B = (\<lambda>x. do { v <- f(x); if (v \<in> B) then Some(v) else None })"

lemma ran_restrict_empty [simp]: "f\<upharpoonleft>\<^bsub>{}\<^esub> = Map.empty"
  by (simp add:ran_restrict_map_def)

lemma ran_restrict_ran [simp]: "f\<upharpoonleft>\<^bsub>ran(f) \<^esub> = f"
  apply (auto simp add:ran_restrict_map_def ran_def)
  apply (rule ext)
  apply (case_tac "f(x)", auto)
done

lemma ran_ran_restrict [simp]: "ran(f\<upharpoonleft>\<^bsub>B\<^esub>) = ran(f) \<inter> B"
  by (auto intro!:option_bindSomeI simp add:ran_restrict_map_def ran_def)

lemma dom_ran_restrict: "dom(f\<upharpoonleft>\<^bsub>B\<^esub>) \<subseteq> dom(f)"
  by (auto simp add:ran_restrict_map_def dom_def)

lemma ran_restrict_finite_dom [intro]:
  "finite(dom(f)) \<Longrightarrow> finite(dom(f\<upharpoonleft>\<^bsub>B\<^esub>))"
  by (metis finite_subset dom_ran_restrict)

lemma dom_Some [simp]: "dom (Some \<circ> f) = UNIV"
  by (auto)

definition map_inv :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('b \<rightharpoonup> 'a)" where
"map_inv f \<equiv> \<lambda> y. if (y \<in> ran f) then Some (SOME x. f x = Some y) else None"

definition map_id_on :: "'a set \<Rightarrow> ('a \<rightharpoonup> 'a)" where
"map_id_on xs \<equiv> \<lambda> x. if (x \<in> xs) then Some x else None"

lemma map_id_on_in [simp]:
  "x \<in> xs \<Longrightarrow> map_id_on xs x = Some x"
  by (simp add:map_id_on_def)

lemma map_id_on_out [simp]:
  "x \<notin> xs \<Longrightarrow> map_id_on xs x = None"
  by (simp add:map_id_on_def)

lemma map_id_dom [simp]: "dom (map_id_on xs) = xs"
  by (simp add:dom_def map_id_on_def)

lemma map_id_ran [simp]: "ran (map_id_on xs) = xs"
  by (force simp add:ran_def map_id_on_def)

lemma map_id_on_UNIV[simp]: "map_id_on UNIV = Some"
  by (simp add:map_id_on_def)

lemma map_id_on_inj [simp]:
  "inj_on (map_id_on xs) xs"
  by (simp add:inj_on_def)

lemma map_inv_empty [simp]: "map_inv empty = empty"
  by (simp add:map_inv_def)

lemma map_inv_id [simp]:
  "map_inv (map_id_on xs) = map_id_on xs"
  by (force simp add:map_inv_def map_id_on_def ran_def)

lemma map_inv_Some [simp]: "map_inv Some = Some"
  by (simp add:map_inv_def ran_def)

lemma map_inv_f_f [simp]:
  "\<lbrakk> inj_on f (dom f); f x = Some y \<rbrakk> \<Longrightarrow> map_inv f y = Some x"
  apply (auto simp add: map_inv_def)
  apply (rule some_equality)
  apply (auto simp add:inj_on_def dom_def ran_def)
done

lemma dom_map_inv [simp]:
  "dom (map_inv f) = ran f"
  by (auto simp add:map_inv_def)

lemma ran_map_inv [simp]:
  "inj_on f (dom f) \<Longrightarrow> ran (map_inv f) = dom f"
  apply (auto simp add:map_inv_def ran_def)
  apply (rule_tac x="a" in exI)
  apply (force intro:someI)
  apply (rule_tac x="y" in exI)
  apply (auto)
  apply (rule some_equality, simp_all)
  apply (auto simp add:inj_on_def dom_def)
done

lemma dom_image_ran: "f ` dom f = Some ` ran f"
  by (auto simp add:dom_def ran_def image_def)

lemma inj_map_inv [intro]:
  "inj_on f (dom f) \<Longrightarrow> inj_on (map_inv f) (ran f)"
  apply (auto simp add:map_inv_def inj_on_def dom_def ran_def)
  apply (frule_tac P="\<lambda> xa. f xa = Some x" in some_equality)
  apply (auto)
  apply (metis (mono_tags) option.sel someI)
done

lemma inj_map_bij: "inj_on f (dom f) \<Longrightarrow> bij_betw f (dom f) (Some ` ran f)"
  by (auto simp add:inj_on_def dom_def ran_def image_def bij_betw_def)

lemma map_inv_map_inv [simp]:
  assumes "inj_on f (dom f)"
  shows "map_inv (map_inv f) = f"
proof -

  from assms have "inj_on (map_inv f) (ran f)"
    by auto

  thus ?thesis
    apply (rule_tac ext)
    apply (case_tac "\<exists> y. map_inv f y = Some x")
    apply (auto)[1]
    apply (simp add:map_inv_def)
    apply (case_tac "y \<in> ran f", simp_all)
    apply (auto)
    apply (rule someI2_ex)
    apply (simp add:ran_def)
    apply (simp)
    apply (metis assms dom_image_ran dom_map_inv image_iff map_add_dom_app_simps(2) map_add_dom_app_simps(3) ran_map_inv)
  done
qed

lemma dom_left_map_add [simp]: "x \<in> dom g \<Longrightarrow> (f ++ g) x = g x"
  by (auto simp add:map_add_def dom_def)

lemma dom_right_map_add [simp]: "\<lbrakk> x \<notin> dom g; x \<in> dom f \<rbrakk> \<Longrightarrow> (f ++ g) x = f x"
  by (auto simp add:map_add_def dom_def)

lemma map_add_restrict:
  "f ++ g = (f |` (- dom g)) ++ g"
  by (rule ext, auto simp add: map_add_def restrict_map_def)

lemma map_self_adjoin_complete [intro]:
  assumes "dom f \<inter> ran f = {}" "inj_on f (dom f)"
  shows "inj_on (map_inv f ++ f) (dom f \<union> ran f)"
  apply (rule inj_onI)
  apply (insert assms)
  apply (case_tac "x \<in> dom f")
  apply (simp)
  apply (case_tac "y \<in> dom f")
  apply (simp add:inj_on_def)
  apply (case_tac "y \<in> ran f")
  apply (subgoal_tac "y \<in> dom (map_inv f)")
  apply (simp)
  apply (metis Int_iff domD empty_iff ranI ran_map_inv)
  apply (simp)
  apply (simp)
  apply (simp)
  apply (case_tac "y \<in> dom f")
  apply (simp)
  apply (case_tac "y \<in> ran f")
  apply (subgoal_tac "y \<in> dom (map_inv f)")
  apply (simp)
  apply (metis Int_iff domD empty_iff ranI ran_map_inv)
  apply (simp)
  apply (metis Int_iff domD empty_iff ranI ran_map_inv)
  apply (simp)
  apply (metis (lifting) inj_map_inv inj_on_contraD)
done

lemma inj_completed_map [intro]:
  "\<lbrakk> dom f = ran f; inj_on f (dom f) \<rbrakk> \<Longrightarrow> inj (Some ++ f)"
  apply (drule inj_map_bij)
  apply (auto simp add:bij_betw_def)
  apply (auto simp add:inj_on_def)[1]
  apply (case_tac "x \<in> dom f")
  apply (simp)
  apply (case_tac "y \<in> dom f")
  apply (simp)
  apply (simp add:ran_def)
  apply (case_tac "y \<in> dom f")
  apply (auto intro:ranI)
done

lemma bij_completed_map [intro]:
  "\<lbrakk> dom f = ran f; inj_on f (dom f) \<rbrakk> \<Longrightarrow>
   bij_betw (Some ++ f) UNIV (range Some)"
  apply (auto intro: inj_completed_map simp add:bij_betw_def)
  apply (case_tac "xa \<in> dom f")
  apply (simp)
  apply (metis domD rangeI)
  apply (simp)
  apply (simp add:image_def)
  apply (metis (full_types) dom_image_ran dom_left_map_add image_iff map_add_dom_app_simps(3))
done

lemma bij_map_Some:
  "bij_betw f a (Some ` b) \<Longrightarrow> bij_betw (the \<circ> f) a b"
  apply (simp add:bij_betw_def)
  apply (safe)
  apply (metis (hide_lams, no_types) comp_inj_on_iff f_the_inv_into_f inj_on_inverseI option.sel)
  apply (metis (hide_lams, no_types) comp_apply image_iff option.sel)
  apply (metis imageI image_comp option.sel)
done

lemma ran_map_add [simp]:
  "m`(dom m \<inter> dom n) = n`(dom m \<inter> dom n) \<Longrightarrow>
   ran(m++n) = ran n \<union> ran m"
  apply (auto simp add:ran_def)
  apply (metis map_add_find_right)
  apply (case_tac "a \<in> dom n")
  apply (subgoal_tac "\<exists> b. n b = Some x")
  apply (auto)
  apply (rule_tac x="b" in exI)
  apply (simp)
  apply (metis (hide_lams, no_types) IntI domI image_iff)
  apply (metis (full_types) map_add_None map_add_dom_app_simps(1) map_add_dom_app_simps(3) not_None_eq)
done

lemma ran_maplets [simp]:
  "\<lbrakk> length xs = length ys; distinct xs \<rbrakk> \<Longrightarrow> ran [xs [\<mapsto>] ys] = set ys"
    by (induct rule:list_induct2, simp_all)

lemma inj_map_add:
  "\<lbrakk> inj_on f (dom f); inj_on g (dom g); ran f \<inter> ran g = {} \<rbrakk> \<Longrightarrow>
   inj_on (f ++ g) (dom f \<union> dom g)"
  apply (auto simp add:inj_on_def)
  apply (metis (full_types) disjoint_iff_not_equal domI dom_left_map_add map_add_dom_app_simps(3) ranI)
  apply (metis domI)
  apply (metis disjoint_iff_not_equal ranI)
  apply (metis disjoint_iff_not_equal domIff map_add_Some_iff ranI)
  apply (metis domI)
done

lemma map_inv_add [simp]:
  assumes "inj_on f (dom f)" "inj_on g (dom g)"
          "dom f \<inter> dom g = {}" "ran f \<inter> ran g = {}"
  shows "map_inv (f ++ g) = map_inv f ++ map_inv g"
proof (rule ext)

  from assms have minj: "inj_on (f ++ g) (dom (f ++ g))"
    by (simp, metis inj_map_add sup_commute)

  fix x
  have "x \<in> ran g \<Longrightarrow> map_inv (f ++ g) x = (map_inv f ++ map_inv g) x"
  proof -
    assume ran:"x \<in> ran g"
    then obtain y where dom:"g y = Some x" "y \<in> dom g"
      by (auto simp add:ran_def)

    hence "(f ++ g) y = Some x"
      by simp

    with assms minj ran dom show "map_inv (f ++ g) x = (map_inv f ++ map_inv g) x"
      by simp
  qed

  moreover have "\<lbrakk> x \<notin> ran g; x \<in> ran f \<rbrakk> \<Longrightarrow> map_inv (f ++ g) x = (map_inv f ++ map_inv g) x"
  proof -
    assume ran:"x \<notin> ran g" "x \<in> ran f"
    with assms obtain y where dom:"f y = Some x" "y \<in> dom f" "y \<notin> dom g"
      by (auto simp add:ran_def)

    with ran have "(f ++ g) y = Some x"
      by (simp)

    with assms minj ran dom show "map_inv (f ++ g) x = (map_inv f ++ map_inv g) x"
      by simp
  qed

  moreover from assms minj have "\<lbrakk> x \<notin> ran g; x \<notin> ran f \<rbrakk> \<Longrightarrow> map_inv (f ++ g) x = (map_inv f ++ map_inv g) x"
    apply (auto simp add:map_inv_def ran_def map_add_def)
    apply (metis dom_left_map_add map_add_def map_add_dom_app_simps(3))
  done

  ultimately show "map_inv (f ++ g) x = (map_inv f ++ map_inv g) x"
    apply (case_tac "x \<in> ran g")
    apply (simp)
    apply (case_tac "x \<in> ran f")
    apply (simp_all)
  done
qed

lemma map_add_lookup [simp]:
  "x \<notin> dom f \<Longrightarrow> ([x \<mapsto> y] ++ f) x = Some y"
  by (simp add:map_add_def dom_def)

lemma map_add_Some: "Some ++ f = map_id_on (- dom f) ++ f"
  apply (rule ext)
  apply (case_tac "x \<in> dom f")
  apply (simp_all)
done

lemma distinct_map_dom:
  "x \<notin> set xs \<Longrightarrow> x \<notin> dom [xs [\<mapsto>] ys]"
  by (simp add:dom_def)

lemma distinct_map_ran:
  "\<lbrakk> distinct xs; y \<notin> set ys; length xs = length ys \<rbrakk> \<Longrightarrow>
   y \<notin> ran ([xs [\<mapsto>] ys])"
  apply (simp add:map_upds_def)
  apply (subgoal_tac "distinct (map fst (rev (zip xs ys)))")
  apply (simp add:ran_distinct)
  apply (metis (hide_lams, no_types) image_iff set_zip_rightD surjective_pairing)
  apply (simp add:zip_rev[THEN sym])
done

lemma maplets_lookup[rule_format,dest]:
  "\<lbrakk> length xs = length ys; distinct xs \<rbrakk> \<Longrightarrow>
     \<forall> y. [xs [\<mapsto>] ys] x = Some y \<longrightarrow> y \<in> set ys"
  by (induct rule:list_induct2, auto)

lemma maplets_distinct_inj [intro]:
  "\<lbrakk> length xs = length ys; distinct xs; distinct ys; set xs \<inter> set ys = {} \<rbrakk> \<Longrightarrow>
   inj_on [xs [\<mapsto>] ys] (set xs)"
  apply (induct rule:list_induct2)
  apply (simp_all)
  apply (rule conjI)
  apply (rule inj_onI)
  apply (case_tac "xa = x")
  apply (simp)
  apply (case_tac "xa = y")
  apply (simp)
  apply (simp)
  apply (case_tac "ya = x")
  apply (simp)
  apply (simp add:inj_on_def)
  apply (auto)
  apply (case_tac "xa = y")
  apply (simp)
  apply (metis maplets_lookup)
done

lemma map_inv_maplet[simp]: "map_inv [x \<mapsto> y] = [y \<mapsto> x]"
  by (auto simp add:map_inv_def)

lemma map_inv_maplets [simp]:
  "\<lbrakk> length xs = length ys; distinct xs; distinct ys; set xs \<inter> set ys = {} \<rbrakk> \<Longrightarrow>
  map_inv [xs [\<mapsto>] ys] = [ys [\<mapsto>] xs]"
  apply (induct rule:list_induct2)
  apply (simp_all)
  apply (subgoal_tac "map_inv ([xs [\<mapsto>] ys] ++ [x \<mapsto> y]) = map_inv [xs [\<mapsto>] ys] ++ map_inv [x \<mapsto> y]")
  apply (simp)
  apply (rule map_inv_add)
  apply (auto)
done

lemma maplets_lookup_nth [rule_format,simp]:
  "\<lbrakk> length xs = length ys; distinct xs \<rbrakk> \<Longrightarrow>
   \<forall> i < length ys. [xs [\<mapsto>] ys] (xs ! i) = Some (ys ! i)"
  apply (induct rule:list_induct2)
  apply (auto)
  apply (case_tac i)
  apply (simp_all)
  apply (metis nth_mem)
  apply (case_tac i)
  apply (auto)
done

theorem the_Some[simp]: "the \<circ> Some = id"
  by (simp add:comp_def id_def)

theorem map_inv_expand [simp]:
  "\<lbrakk> inj_on f (dom f); f x = Some y \<rbrakk> \<Longrightarrow> map_inv f y = Some x"
  apply (auto simp add:ran_def map_inv_def)
  apply (rule some_equality, simp)
  apply (metis map_inv_f_f option.inject)
done

theorem inv_map_inv:
  "\<lbrakk> inj_on f (dom f); ran f = dom f \<rbrakk>
  \<Longrightarrow> inv (the \<circ> (Some ++ f)) = the \<circ> map_inv (Some ++ f)"
  apply (rule ext)
  apply (simp add:map_add_Some)
  apply (simp add:inv_def)
  apply (case_tac "\<exists> y. f y = Some x")
  apply (erule exE)
  apply (subgoal_tac "x \<in> ran f")
  apply (subgoal_tac "y \<in> dom f")
  apply (simp)
  apply (rule some_equality)
  apply (simp)
  apply (metis (hide_lams, mono_tags) domD domI dom_left_map_add inj_on_contraD map_add_Some map_add_dom_app_simps(3) option.sel)
  apply (simp add:dom_def)
  apply (metis ranI)
  apply (simp)
  apply (subgoal_tac "x \<notin> ran f")
  apply (simp)
  apply (rule some_equality)
  apply (simp)
  apply (metis domD dom_left_map_add map_add_Some map_add_dom_app_simps(3) option.sel)
  apply (metis dom_image_ran image_iff)
done

lemma map_comp_dom: "dom (g \<circ>\<^sub>m f) \<subseteq> dom f"
  by (metis (lifting, full_types) Collect_mono dom_def map_comp_simps(1))

lemma map_comp_assoc: "f \<circ>\<^sub>m (g \<circ>\<^sub>m h) = f \<circ>\<^sub>m g \<circ>\<^sub>m h"
proof
  fix x
  show "(f \<circ>\<^sub>m (g \<circ>\<^sub>m h)) x = (f \<circ>\<^sub>m g \<circ>\<^sub>m h) x"
  proof (cases "h x")
    case None thus ?thesis
      by (auto simp add: map_comp_def)
  next
    case (Some y) thus ?thesis
      by (auto simp add: map_comp_def)
  qed
qed

lemma map_comp_runit [simp]: "f \<circ>\<^sub>m Some = f"
  by (simp add: map_comp_def)

lemma map_comp_lunit [simp]: "Some \<circ>\<^sub>m f = f"
proof
  fix x
  show "(Some \<circ>\<^sub>m f) x = f x"
  proof (cases "f x")
    case None thus ?thesis
      by (simp add: map_comp_def)
  next
    case (Some y) thus ?thesis
      by (simp add: map_comp_def)
  qed
qed

lemma map_comp_apply [simp]: "(f \<circ>\<^sub>m g) x = g(x) >>= f"
  by (auto simp add: map_comp_def option.case_eq_if)

text {* Merging of compatible maps *}

definition comp_map :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> bool" (infixl "\<parallel>\<^sub>m" 60) where
"comp_map f g = (\<forall> x \<in> dom(f) \<inter> dom(g). the(f(x)) = the(g(x)))"

lemma comp_map_unit: "Map.empty \<parallel>\<^sub>m f"
  by (simp add: comp_map_def)

lemma comp_map_refl: "f \<parallel>\<^sub>m f"
  by (simp add: comp_map_def)

lemma comp_map_sym: "f \<parallel>\<^sub>m g \<Longrightarrow> g \<parallel>\<^sub>m f"
  by (simp add: comp_map_def)

definition merge :: "('a \<rightharpoonup> 'b) set \<Rightarrow> 'a \<rightharpoonup> 'b" where
"merge fs =
  (\<lambda> x. if (\<exists> f \<in> fs. x \<in> dom(f)) then (THE y. \<forall> f \<in> fs. x \<in> dom(f) \<longrightarrow> f(x) = y) else None)"

lemma merge_empty: "merge {} = Map.empty"
  by (simp add: merge_def)

lemma merge_singleton: "merge {f} = f"
  apply (auto intro!: ext simp add: merge_def)
  using option.collapse apply fastforce
done

text {* Conversion between lists and maps *}

definition map_of_list :: "'a list \<Rightarrow> (nat \<rightharpoonup> 'a)" where
"map_of_list xs = (\<lambda> i. if (i < length xs) then Some (xs!i) else None)"

lemma map_of_list_nil [simp]: "map_of_list [] = Map.empty"
  by (simp add: map_of_list_def)

lemma dom_map_of_list [simp]: "dom (map_of_list xs) = {0..<length xs}"
  by (auto simp add: map_of_list_def dom_def)

lemma ran_map_of_list [simp]: "ran (map_of_list xs) = set xs"
  apply (simp add: ran_def map_of_list_def)
  apply (safe)
  apply (force)
  apply (meson in_set_conv_nth)
done

definition list_of_map :: "(nat \<rightharpoonup> 'a) \<Rightarrow> 'a list" where
"list_of_map f = (if (f = Map.empty) then [] else map (the \<circ> f) [0 ..< Suc(GREATEST x. x \<in> dom f)])"

lemma list_of_map_empty [simp]: "list_of_map Map.empty = []"
  by (simp add: list_of_map_def)

definition list_of_map' :: "(nat \<rightharpoonup> 'a) \<rightharpoonup> 'a list" where
"list_of_map' f = (if (\<exists> n. dom f = {0..<n}) then Some (list_of_map f) else None)"

lemma map_of_list_inv [simp]: "list_of_map (map_of_list xs) = xs"
proof (cases "xs = []")
  case True thus ?thesis by (simp)
next
  case False
  moreover hence "(GREATEST x. x \<in> dom (map_of_list xs)) = length xs - 1"
    by (auto intro: Greatest_equality)
  moreover from False have "map_of_list xs \<noteq> Map.empty"
    by (metis ran_empty ran_map_of_list set_empty)
  ultimately show ?thesis
    by (auto simp add: list_of_map_def map_of_list_def nth_equalityI)
qed
subsection {* Map comprehension *}

text {* Map comprehension simply converts a relation built through set comprehension into a map *}

syntax
  "_Mapcompr" :: "'a \<Rightarrow> 'b \<Rightarrow> idts \<Rightarrow> bool \<Rightarrow> 'a \<rightharpoonup> 'b"    ("(1[_ \<mapsto> _ |/_./ _])")

translations
  "_Mapcompr F G xs P" == "CONST graph_map {(F, G) | xs. P}"

lemma map_compr_eta:
  "[x \<mapsto> y | x y. (x, y) \<in>\<^sub>m f] = f"
  apply (rule ext)
  apply (auto simp add: graph_map_def)
  apply (metis (mono_tags, lifting) Domain.DomainI fst_eq_Domain mem_Collect_eq old.prod.case option.distinct(1) option.expand option.sel)
done

lemma map_compr_simple:
  "[x \<mapsto> F x y | x y. (x, y) \<in>\<^sub>m f] = (\<lambda> x. do { y \<leftarrow> f(x); Some(F x y) })"
  apply (rule ext)
  apply (auto simp add: graph_map_def image_Collect)
done

lemma map_compr_dom_simple [simp]:
  "dom [x \<mapsto> f x | x. P x] = {x. P x}"
  by (force simp add: graph_map_dom image_Collect)

lemma map_compr_ran_simple [simp]:
  "ran [x \<mapsto> f x | x. P x] = {f x | x. P x}"
  apply (auto simp add: graph_map_def ran_def)
  apply (metis (mono_tags, lifting) fst_eqD image_eqI mem_Collect_eq someI)
done

lemma map_compr_eval_simple [simp]:
  "[x \<mapsto> f x | x. P x] x = (if (P x) then Some (f x) else None)"
  by (auto simp add: graph_map_def image_Collect)

subsection {* Sorted lists from maps *}

definition sorted_list_of_map :: "('a::linorder \<rightharpoonup> 'b) \<Rightarrow> ('a \<times> 'b) list" where
"sorted_list_of_map f = map (\<lambda> k. (k, the (f k))) (sorted_list_of_set(dom(f)))"

lemma sorted_list_of_map_empty [simp]:
  "sorted_list_of_map Map.empty = []"
  by (simp add: sorted_list_of_map_def)

lemma sorted_list_of_map_inv:
  assumes "finite(dom(f))"
  shows "map_of (sorted_list_of_map f) = f"
proof -
  obtain A where "finite A" "A = dom(f)"
    by (simp add: assms)
  thus ?thesis
  proof (induct A rule: finite_induct)
    case empty thus ?thesis
      by (simp add: sorted_list_of_map_def, metis dom_empty empty_iff map_le_antisym map_le_def)
  next
    case (insert x A) thus ?thesis
      by (simp add: sorted_list_of_map_def, metis finite_insert map_of_map_keys sorted_list_of_set)
  qed
qed

declare map_member.simps [simp del]

subsection {* Extra map lemmas *}

lemma map_eqI:
  "\<lbrakk> dom f = dom g; \<forall> x\<in>dom(f). the(f x) = the(g x) \<rbrakk> \<Longrightarrow> f = g"
  by (metis domIff map_le_antisym map_le_def option.expand)

lemma map_restrict_dom_compl: "f |` (- dom f) = Map.empty"
  by (metis dom_eq_empty_conv dom_restrict inf_compl_bot)

lemma restrict_map_neg_disj:
  "dom(f) \<inter> A = {} \<Longrightarrow> f |` (- A) = f"
  by (auto simp add: restrict_map_def, rule ext, auto, metis disjoint_iff_not_equal domIff)

lemma map_plus_restrict_dist: "(f ++ g) |` A = (f |` A) ++ (g |` A)"
  by (auto simp add: restrict_map_def map_add_def)

lemma map_plus_eq_left:
  assumes "f ++ h = g ++ h"
  shows "(f |` (- dom h)) = (g |` (- dom h))"
proof -
  have "h |` (- dom h) = Map.empty"
    by (metis Compl_disjoint dom_eq_empty_conv dom_restrict)
  then have f2: "f |` (- dom h) = (f ++ h) |` (- dom h)"
    by (simp add: map_plus_restrict_dist)
  have "h |` (- dom h) = Map.empty"
    by (metis (no_types) Compl_disjoint dom_eq_empty_conv dom_restrict)
  then show ?thesis
    using f2 assms by (simp add: map_plus_restrict_dist)
qed

lemma map_add_split:
  "dom(f) = A \<union> B \<Longrightarrow> (f |` A) ++ (f |` B) = f"
  by (rule ext, auto simp add: map_add_def restrict_map_def option.case_eq_if)

lemma map_le_via_restrict:
  "f \<subseteq>\<^sub>m g \<longleftrightarrow> g |` dom(f) = f"
  by (auto simp add: map_le_def restrict_map_def dom_def fun_eq_iff)
end


theory week02B_demo imports Main begin

section{* Propositional logic *}

subsection{* Basic rules *}

text{* \<and> *}
thm conjI

thm conjunct2
thm conjE

text{* \<or> *}
thm disjI1
thm disjI2
thm disjE

text{* \<longrightarrow> *}
thm impI impE

subsection{* Examples *}

text{* a simple backward step: *}
lemma "A \<and> B" thm conjI
apply(rule conjI)
oops

text{* a simple backward proof: *}
lemma "B \<and> A \<longrightarrow> A \<and> B"
(*TODO*)
  apply(rule impI)
  apply(rule conjI)
   apply(erule conjE)
   apply assumption
  apply(erule conjE)
  apply assumption
  done

lemma "(A \<or> B) \<longrightarrow> (B \<or> A)"
(*TODO*)
  apply(rule impI)
  apply(erule disjE)
   apply(rule disjI2)
   apply assumption
  apply(rule disjI1)
  apply assumption
  done

lemma "\<lbrakk> B \<longrightarrow> C; A \<longrightarrow> B \<rbrakk> \<Longrightarrow> A \<longrightarrow> C"
  sorry

thm notI notE

lemma "\<not>A \<or> \<not>B \<Longrightarrow> \<not>(A \<and> B)"
(*TODO*)
  apply(erule disjE)
  apply(rule notI)
   apply(erule notE)
   apply(erule conjE)
   apply assumption
  apply(rule notI)
  apply(erule notE)
  apply(erule conjE)
  apply assumption
  done

text {* Case distinctions *}

lemma "P \<or> \<not>P"
  apply (case_tac "P")
  oops

thm FalseE

lemma "(\<not>P \<longrightarrow> False) \<longrightarrow> P"
oops

text{* Explicit backtracking: *}

lemma "\<lbrakk> P \<and> Q; A \<and> B \<rbrakk> \<Longrightarrow> A"
apply(erule conjE)
back
apply(assumption)
done
text {* UGLY! EVIL! AVOID! *}

text{* Implicit backtracking: chaining with , *}

lemma "\<lbrakk> P \<and> Q; A \<and> B \<rbrakk> \<Longrightarrow> A"
apply (erule conjE, assumption)
done

text{* OR: use rule_tac or erule_tac to instantiate the schematic variables of the rule *}

lemma "\<lbrakk> P \<and> Q; A \<and> B \<rbrakk> \<Longrightarrow> A"
apply (erule_tac P=A and Q=B in conjE)
apply assumption
done

text {* more rules *}
text{* \<and> *}
thm conjunct1 conjunct2

text{* \<or> *}
thm disjCI

lemma our_own_disjCI: "(\<not>Q \<longrightarrow> P) \<Longrightarrow> P \<or> Q"
(*TODO (with case_tac) *)
  apply(case_tac Q)
   apply(rule disjI2)
   apply assumption
  apply(rule disjI1)
  apply(erule impE)
   apply assumption
  apply assumption
  done

text{* \<longrightarrow> *}
thm mp

text{* = (iff) *}
thm iffI iffE iffD1 iffD2

text{* Equality *}
thm refl sym trans

text{* \<not> *}
thm notI notE

text{* Contradictions *}
thm FalseE ccontr classical excluded_middle

-- {* more rules *}

text {* defer and prefer *}
lemma "(A \<or> A) = (A \<and> A)"
  apply (rule iffI)
  prefer 2
  defer
  sorry

text{* classical propositional logic: *}
lemma Pierce: "((A \<longrightarrow> B) \<longrightarrow> A) \<longrightarrow> A"
  apply (rule impI)
  apply (rule classical)
  apply (erule impE)
   apply (rule impI)
   apply (erule notE)
   apply assumption
  apply assumption
  done

text {* Exercises *}

lemma "A \<and> B \<longrightarrow> A \<longrightarrow> B"
  oops

lemma "A \<longrightarrow> (B \<or> C) \<longrightarrow> (\<not> A \<or> \<not> B) \<longrightarrow> C"
  oops

lemma"((A \<longrightarrow> B) \<and> (B \<longrightarrow> A)) = (A = B)"
  oops

lemma "(A \<longrightarrow> (B \<and> C)) \<longrightarrow> (A \<longrightarrow> C)"
  oops

end


(*
  File:    Data_Structures/Selection.thy
  Author:  Manuel Eberl, TU München
*)
section \<open>The Median-of-Medians Selection Algorithm\<close>
theory Selection
  imports Complex_Main Sorting Time_Funs
begin

text \<open>
  Note that there is significant overlap between this theory (which is intended mostly for the
  Functional Data Structures book) and the Median-of-Medians AFP entry.
\<close>

subsection \<open>Auxiliary material\<close>

lemma replicate_numeral: "replicate (numeral n) x = x # replicate (pred_numeral n) x"
  by (simp add: numeral_eq_Suc)

lemma isort_correct: "isort xs = sort xs"
  using sorted_isort mset_isort by (metis properties_for_sort)

lemma sum_list_replicate [simp]: "sum_list (replicate n x) = n * x"
  by (induction n) auto

lemma mset_concat: "mset (concat xss) = sum_list (map mset xss)"
  by (induction xss) simp_all

lemma set_mset_sum_list [simp]: "set_mset (sum_list xs) = (\<Union>x\<in>set xs. set_mset x)"
  by (induction xs) auto

lemma filter_mset_image_mset:
  "filter_mset P (image_mset f A) = image_mset f (filter_mset (\<lambda>x. P (f x)) A)"
  by (induction A) auto

lemma filter_mset_sum_list: "filter_mset P (sum_list xs) = sum_list (map (filter_mset P) xs)"
  by (induction xs) simp_all

lemma sum_mset_mset_mono:
  assumes "(\<And>x. x \<in># A \<Longrightarrow> f x \<subseteq># g x)"
  shows   "(\<Sum>x\<in>#A. f x) \<subseteq># (\<Sum>x\<in>#A. g x)"
  using assms by (induction A) (auto intro!: subset_mset.add_mono)

lemma mset_filter_mono:
  assumes "A \<subseteq># B" "\<And>x. x \<in># A \<Longrightarrow> P x \<Longrightarrow> Q x"
  shows   "filter_mset P A \<subseteq># filter_mset Q B"
  by (rule mset_subset_eqI) (insert assms, auto simp: mset_subset_eq_count count_eq_zero_iff)

lemma size_mset_sum_mset_distrib: "size (sum_mset A :: 'a multiset) = sum_mset (image_mset size A)"
  by (induction A) auto

lemma sum_mset_mono:
  assumes "\<And>x. x \<in># A \<Longrightarrow> f x \<le> (g x :: 'a :: {ordered_ab_semigroup_add,comm_monoid_add})"
  shows   "(\<Sum>x\<in>#A. f x) \<le> (\<Sum>x\<in>#A. g x)"
  using assms by (induction A) (auto intro!: add_mono)

lemma filter_mset_is_empty_iff: "filter_mset P A = {#} \<longleftrightarrow> (\<forall>x. x \<in># A \<longrightarrow> \<not>P x)"
  by (auto simp: multiset_eq_iff count_eq_zero_iff)

lemma sort_eq_Nil_iff [simp]: "sort xs = [] \<longleftrightarrow> xs = []"
  by (metis set_empty set_sort)

lemma sort_mset_cong: "mset xs = mset ys \<Longrightarrow> sort xs = sort ys"
  by (metis sorted_list_of_multiset_mset)

lemma Min_set_sorted: "sorted xs \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> Min (set xs) = hd xs"
  by (cases xs; force intro: Min_insert2)

lemma hd_sort:
  fixes xs :: "'a :: linorder list"
  shows "xs \<noteq> [] \<Longrightarrow> hd (sort xs) = Min (set xs)"
  by (subst Min_set_sorted [symmetric]) auto

lemma length_filter_conv_size_filter_mset: "length (filter P xs) = size (filter_mset P (mset xs))"
  by (induction xs) auto

lemma sorted_filter_less_subset_take:
  assumes "sorted xs" and "i < length xs"
  shows   "{#x \<in># mset xs. x < xs ! i#} \<subseteq># mset (take i xs)"
  using assms
proof (induction xs arbitrary: i rule: list.induct)
  case (Cons x xs i)
  show ?case
  proof (cases i)
    case 0
    thus ?thesis using Cons.prems by (auto simp: filter_mset_is_empty_iff)
  next
    case (Suc i')
    have "{#y \<in># mset (x # xs). y < (x # xs) ! i#} \<subseteq># add_mset x {#y \<in># mset xs. y < xs ! i'#}"
      using Suc Cons.prems by (auto)
    also have "\<dots> \<subseteq># add_mset x (mset (take i' xs))"
      unfolding mset_subset_eq_add_mset_cancel using Cons.prems Suc
      by (intro Cons.IH) (auto)
    also have "\<dots> = mset (take i (x # xs))" by (simp add: Suc)
    finally show ?thesis .
  qed
qed auto

lemma sorted_filter_greater_subset_drop:
  assumes "sorted xs" and "i < length xs"
  shows   "{#x \<in># mset xs. x > xs ! i#} \<subseteq># mset (drop (Suc i) xs)"
  using assms
proof (induction xs arbitrary: i rule: list.induct)
  case (Cons x xs i)
  show ?case
  proof (cases i)
    case 0
    thus ?thesis by (auto simp: sorted_append filter_mset_is_empty_iff)
  next
    case (Suc i')
    have "{#y \<in># mset (x # xs). y > (x # xs) ! i#} \<subseteq># {#y \<in># mset xs. y > xs ! i'#}"
      using Suc Cons.prems by (auto simp: set_conv_nth)
    also have "\<dots> \<subseteq># mset (drop (Suc i') xs)"
      using Cons.prems Suc by (intro Cons.IH) (auto)
    also have "\<dots> = mset (drop (Suc i) (x # xs))" by (simp add: Suc)
    finally show ?thesis .
  qed
qed auto

subsection \<open>Chopping a list into equally-sized bits\<close>

fun chop :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list list" where
  "chop 0 _  = []"
| "chop _ [] = []"
| "chop n xs = take n xs # chop n (drop n xs)"

lemmas [simp del] = chop.simps

text \<open>
  This is an alternative induction rule for \<^const>\<open>chop\<close>, which is often nicer to use.
\<close>
lemma chop_induct' [case_names trivial reduce]:
  assumes "\<And>n xs. n = 0 \<or> xs = [] \<Longrightarrow> P n xs"
  assumes "\<And>n xs. n > 0 \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> P n (drop n xs) \<Longrightarrow> P n xs"
  shows   "P n xs"
  using assms
proof induction_schema
  show "wf (measure (length \<circ> snd))"
    by auto
qed (blast | simp)+

lemma chop_0 [simp]: "chop 0 xs = []"
  by (simp add: chop.simps)

lemma chop_Nil [simp]: "chop n [] = []"
  by (cases n) (auto simp: chop.simps)

lemma chop_reduce: "n > 0 \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> chop n xs = take n xs # chop n (drop n xs)"
  by (cases n; cases xs) (auto simp: chop.simps)

lemma concat_chop [simp]: "n > 0 \<Longrightarrow> concat (chop n xs) = xs"
  by (induction n xs rule: chop.induct; subst chop.simps) auto

lemma chop_elem_not_Nil [dest]: "ys \<in> set (chop n xs) \<Longrightarrow> ys \<noteq> []"
  by (induction n xs rule: chop.induct; subst (asm) chop.simps)
     (auto simp: eq_commute[of "[]"] split: if_splits)

lemma length_chop_part_le: "ys \<in> set (chop n xs) \<Longrightarrow> length ys \<le> n"
  by (induction n xs rule: chop.induct; subst (asm) chop.simps) (auto split: if_splits)

lemma length_chop:
  assumes "n > 0"
  shows   "length (chop n xs) = nat \<lceil>length xs / n\<rceil>"
proof -
  from \<open>n > 0\<close> have "real n * length (chop n xs) \<ge> length xs"
    by (induction n xs rule: chop.induct; subst chop.simps) (auto simp: field_simps)
  moreover from \<open>n > 0\<close> have "real n * length (chop n xs) < length xs + n"
    by (induction n xs rule: chop.induct; subst chop.simps)
       (auto simp: field_simps split: nat_diff_split_asm)+
  ultimately have "length (chop n xs) \<ge> length xs / n" and "length (chop n xs) < length xs / n + 1"
    using assms by (auto simp: field_simps)
  thus ?thesis by linarith
qed

lemma sum_msets_chop: "n > 0 \<Longrightarrow> (\<Sum>ys\<leftarrow>chop n xs. mset ys) = mset xs"
  by (subst mset_concat [symmetric]) simp_all

lemma UN_sets_chop: "n > 0 \<Longrightarrow> (\<Union>ys\<in>set (chop n xs). set ys) = set xs"
  by (simp only: set_concat [symmetric] concat_chop)

lemma chop_append: "d dvd length xs \<Longrightarrow> chop d (xs @ ys) = chop d xs @ chop d ys"
  by (induction d xs rule: chop_induct') (auto simp: chop_reduce dvd_imp_le)

lemma chop_replicate [simp]: "d > 0 \<Longrightarrow> chop d (replicate d xs) = [replicate d xs]"
  by (subst chop_reduce) auto

lemma chop_replicate_dvd [simp]:
  assumes "d dvd n"
  shows   "chop d (replicate n x) = replicate (n div d) (replicate d x)"
proof (cases "d = 0")
  case False
  from assms obtain k where k: "n = d * k"
    by blast
  have "chop d (replicate (d * k) x) = replicate k (replicate d x)"
    using False by (induction k) (auto simp: replicate_add chop_append)
  thus ?thesis using False by (simp add: k)
qed auto

lemma chop_concat:
  assumes "\<forall>xs\<in>set xss. length xs = d" and "d > 0"
  shows   "chop d (concat xss) = xss"
  using assms
proof (induction xss)
  case (Cons xs xss)
  have "chop d (concat (xs # xss)) = chop d (xs @ concat xss)"
    by simp
  also have "\<dots> = chop d xs @ chop d (concat xss)"
    using Cons.prems by (intro chop_append) auto
  also have "chop d xs = [xs]"
    using Cons.prems by (subst chop_reduce) auto
  also have "chop d (concat xss) = xss"
    using Cons.prems by (intro Cons.IH) auto
  finally show ?case by simp
qed auto

subsection \<open>Selection\<close>

definition select :: "nat \<Rightarrow> ('a :: linorder) list \<Rightarrow> 'a" where
  "select k xs = sort xs ! k"

lemma select_0: "xs \<noteq> [] \<Longrightarrow> select 0 xs = Min (set xs)"
  by (simp add: hd_sort select_def flip: hd_conv_nth)

lemma select_mset_cong: "mset xs = mset ys \<Longrightarrow> select k xs = select k ys"
  using sort_mset_cong[of xs ys] unfolding select_def by auto

lemma
  assumes "n < length xs"
  shows   size_less_than_select: "size {#y \<in># mset xs. y < select n xs#} \<le> n"
    and   size_greater_than_select: "size {#y \<in># mset xs. y > select n xs#} < length xs - n"
proof -
  have "size {#y \<in># mset (sort xs). y < select n xs#} \<le> size (mset (take n (sort xs)))"
    unfolding select_def using assms
    by (intro size_mset_mono sorted_filter_less_subset_take) auto
  thus "size {#y \<in># mset xs. y < select n xs#} \<le> n"
    by simp
  have "size {#y \<in># mset (sort xs). y > select n xs#} \<le> size (mset (drop (Suc n) (sort xs)))"
    unfolding select_def using assms
    by (intro size_mset_mono sorted_filter_greater_subset_drop) auto
  thus "size {#y \<in># mset xs. y > select n xs#} < length xs - n"
    using assms by simp
qed

subsection \<open>The designated median of a list\<close>

definition median where "median xs = select ((length xs - 1) div 2) xs"

lemma median_in_set [intro, simp]:
  assumes "xs \<noteq> []"
  shows   "median xs \<in> set xs"
proof -
  from assms have "length xs > 0" by auto
  hence "(length xs - 1) div 2 < length xs" by linarith
  thus ?thesis by (simp add: median_def)
qed

lemma size_less_than_median: "size {#y \<in># mset xs. y < median xs#} \<le> (length xs - 1) div 2"
proof (cases "xs = []")
  case False
  hence "length xs > 0"
    by auto
  hence less: "(length xs - 1) div 2 < length xs"
    by linarith
  show "size {#y \<in># mset xs. y < median xs#} \<le> (length xs - 1) div 2"
    using size_less_than_select[OF less] by (simp add: median_def)
qed auto

lemma size_greater_than_median: "size {#y \<in># mset xs. y > median xs#} \<le> length xs div 2"
proof (cases "xs = []")
  case False
  hence "length xs > 0"
    by auto
  hence less: "(length xs - 1) div 2 < length xs"
    by linarith
  have "size {#y \<in># mset xs. y > median xs#} < length xs - (length xs - 1) div 2"
    using size_greater_than_select[OF less] by (simp add: median_def)
  also have "\<dots> = length xs div 2 + 1"
    using \<open>length xs > 0\<close> by linarith
  finally show "size {#y \<in># mset xs. y > median xs#} \<le> length xs div 2"
    by simp
qed auto

lemmas median_props = size_less_than_median size_greater_than_median

subsection \<open>A recurrence for selection\<close>

definition partition3 :: "'a \<Rightarrow> 'a :: linorder list \<Rightarrow> 'a list \<times> 'a list \<times> 'a list" where
  "partition3 x xs = (filter (\<lambda>y. y < x) xs, filter (\<lambda>y. y = x) xs, filter (\<lambda>y. y > x) xs)"

lemma partition3_code [code]:
  "partition3 x [] = ([], [], [])"
  "partition3 x (y # ys) =
     (case partition3 x ys of (ls, es, gs) \<Rightarrow>
        if y < x then (y # ls, es, gs) else if x = y then (ls, y # es, gs) else (ls, es, y # gs))"
  by (auto simp: partition3_def)

lemma sort_append:
  assumes "\<forall>x\<in>set xs. \<forall>y\<in>set ys. x \<le> y"
  shows   "sort (xs @ ys) = sort xs @ sort ys"
  using assms by (intro properties_for_sort) (auto simp: sorted_append)

lemma select_append:
  assumes "\<forall>y\<in>set ys. \<forall>z\<in>set zs. y \<le> z"
  shows   "k < length ys \<Longrightarrow> select k (ys @ zs) = select k ys"
    and   "k \<in> {length ys..<length ys + length zs} \<Longrightarrow>
             select k (ys @ zs) = select (k - length ys) zs"
  using assms by (simp_all add: select_def sort_append nth_append)

lemma select_append':
  assumes "\<forall>y\<in>set ys. \<forall>z\<in>set zs. y \<le> z" and "k < length ys + length zs"
  shows   "select k (ys @ zs) = (if k < length ys then select k ys else select (k - length ys) zs)"
  using assms by (auto intro!: select_append)

theorem select_rec_partition:
  assumes "k < length xs"
  shows "select k xs = (
           let (ls, es, gs) = partition3 x xs
           in
             if k < length ls then select k ls
             else if k < length ls + length es then x
             else select (k - length ls - length es) gs
          )" (is "_ = ?rhs")
proof -
  define ls es gs where "ls = filter (\<lambda>y. y < x) xs" and "es = filter (\<lambda>y. y = x) xs"
                    and "gs = filter (\<lambda>y. y > x) xs"
  define nl ne where [simp]: "nl = length ls" "ne = length es"
  have mset_eq: "mset xs = mset ls + mset es + mset gs"
    unfolding ls_def es_def gs_def by (induction xs) auto
  have length_eq: "length xs = length ls + length es + length gs"
    unfolding ls_def es_def gs_def
    using [[simp_depth_limit = 1]] by (induction xs) auto
  have [simp]: "select i es = x" if "i < length es" for i
  proof -
    have "select i es \<in> set (sort es)" unfolding select_def
      using that by (intro nth_mem) auto
    thus ?thesis
      by (auto simp: es_def)
  qed

  have "select k xs = select k (ls @ (es @ gs))"
    by (intro select_mset_cong) (simp_all add: mset_eq)
  also have "\<dots> = (if k < nl then select k ls else select (k - nl) (es @ gs))"
    unfolding nl_ne_def using assms
    by (intro select_append') (auto simp: ls_def es_def gs_def length_eq)
  also have "\<dots> = (if k < nl then select k ls else if k < nl + ne then x
                    else select (k - nl - ne) gs)"
  proof (rule if_cong)
    assume "\<not>k < nl"
    have "select (k - nl) (es @ gs) =
                 (if k - nl < ne then select (k - nl) es else select (k - nl - ne) gs)"
      unfolding nl_ne_def using assms \<open>\<not>k < nl\<close>
      by (intro select_append') (auto simp: ls_def es_def gs_def length_eq)
    also have "\<dots> = (if k < nl + ne then x else select (k - nl - ne) gs)"
      using \<open>\<not>k < nl\<close> by auto
    finally show "select (k - nl) (es @ gs) = \<dots>" .
  qed simp_all
  also have "\<dots> = ?rhs"
    by (simp add: partition3_def ls_def es_def gs_def)
  finally show ?thesis .
qed

subsection \<open>The size of the lists in the recursive calls\<close>

text \<open>
  We now derive an upper bound for the number of elements of a list that are smaller
  (resp. bigger) than the median of medians with chopping size 5. To avoid having to do the
  same proof twice, we do it generically for an operation \<open>\<prec>\<close> that we will later instantiate
  with either \<open><\<close> or \<open>>\<close>.
\<close>

context
  fixes xs :: "'a :: linorder list"
  fixes M defines "M \<equiv> median (map median (chop 5 xs))"
begin

lemma size_median_of_medians_aux:
  fixes R :: "'a :: linorder \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<prec>" 50)
  assumes R: "R \<in> {(<), (>)}"
  shows "size {#y \<in># mset xs. y \<prec> M#} \<le> nat \<lceil>0.7 * length xs + 3\<rceil>"
proof -
  define n and m where [simp]: "n = length xs" and "m = length (chop 5 xs)"
  text \<open>We define an abbreviation for the multiset of all the chopped-up groups:\<close>

  text \<open>We then split that multiset into those groups whose medians is less than @{term M}
        and the rest.\<close>
  define Y_small ("Y\<^sub>\<prec>") where "Y\<^sub>\<prec> = filter_mset (\<lambda>ys. median ys \<prec> M) (mset (chop 5 xs))"
  define Y_big ("Y\<^sub>\<succeq>") where "Y\<^sub>\<succeq> = filter_mset (\<lambda>ys. \<not>(median ys \<prec> M)) (mset (chop 5 xs))"
  have "m = size (mset (chop 5 xs))" by (simp add: m_def)
  also have "mset (chop 5 xs) = Y\<^sub>\<prec> + Y\<^sub>\<succeq>" unfolding Y_small_def Y_big_def
    by (rule multiset_partition)
  finally have m_eq: "m = size Y\<^sub>\<prec> + size Y\<^sub>\<succeq>" by simp

  text \<open>At most half of the lists have a median that is smaller than the median of medians:\<close>
  have "size Y\<^sub>\<prec> = size (image_mset median Y\<^sub>\<prec>)" by simp
  also have "image_mset median Y\<^sub>\<prec> = {#y \<in># mset (map median (chop 5 xs)). y \<prec> M#}"
    unfolding Y_small_def by (subst filter_mset_image_mset [symmetric]) simp_all
  also have "size \<dots> \<le> (length (map median (chop 5 xs))) div 2"
    unfolding M_def using median_props[of "map median (chop 5 xs)"] R by auto
  also have "\<dots> = m div 2" by (simp add: m_def)
  finally have size_Y\<^sub>_small: "size Y\<^sub>\<prec> \<le> m div 2" .

  text \<open>We estimate the number of elements less than @{term M} by grouping them into elements
      coming from @{term "Y\<^sub>\<prec>"} and elements coming from @{term "Y\<^sub>\<succeq>"}:\<close>
  have "{#y \<in># mset xs. y \<prec> M#} = {#y \<in># (\<Sum>ys\<leftarrow>chop 5 xs. mset ys). y \<prec> M#}"
    by (subst sum_msets_chop) simp_all
  also have "\<dots> = (\<Sum>ys\<leftarrow>chop 5 xs. {#y \<in># mset ys. y \<prec> M#})"
    by (subst filter_mset_sum_list) (simp add: o_def)
  also have "\<dots> = (\<Sum>ys\<in>#mset (chop 5 xs). {#y \<in># mset ys. y \<prec> M#})"
    by (subst sum_mset_sum_list [symmetric]) simp_all
  also have "mset (chop 5 xs) = Y\<^sub>\<prec> + Y\<^sub>\<succeq>"
    by (simp add: Y_small_def Y_big_def not_le)
  also have "(\<Sum>ys\<in>#\<dots>. {#y \<in># mset ys. y \<prec> M#}) =
               (\<Sum>ys\<in>#Y\<^sub>\<prec>. {#y \<in># mset ys. y \<prec> M#}) + (\<Sum>ys\<in>#Y\<^sub>\<succeq>. {#y \<in># mset ys. y \<prec> M#})"
    by simp

  text \<open>Next, we overapproximate the elements contributed by @{term "Y\<^sub>\<prec>"}: instead of those elements
        that are smaller than the median, we take \<^emph>\<open>all\<close> the elements of each group.
        For the elements contributed by @{term "Y\<^sub>\<succeq>"}, we overapproximate by taking all those that
        are less than their median instead of only those that are less than @{term M}.\<close>
  also have "\<dots> \<subseteq># (\<Sum>ys\<in>#Y\<^sub>\<prec>. mset ys) + (\<Sum>ys\<in>#Y\<^sub>\<succeq>. {#y \<in># mset ys. y \<prec> median ys#})"
    using R
    by (intro subset_mset.add_mono sum_mset_mset_mono mset_filter_mono) (auto simp: Y_big_def)
  finally have "size {# y \<in># mset xs. y \<prec> M#} \<le> size \<dots>"
    by (rule size_mset_mono)
  hence "size {# y \<in># mset xs. y \<prec> M#} \<le>
           (\<Sum>ys\<in>#Y\<^sub>\<prec>. length ys) + (\<Sum>ys\<in>#Y\<^sub>\<succeq>. size {#y \<in># mset ys. y \<prec> median ys#})"
    by (simp add: size_mset_sum_mset_distrib multiset.map_comp o_def)

  text \<open>Next, we further overapproximate the first sum by noting that each group has
        at most size 5.\<close>
  also have "(\<Sum>ys\<in>#Y\<^sub>\<prec>. length ys) \<le> (\<Sum>ys\<in>#Y\<^sub>\<prec>. 5)"
    by (intro sum_mset_mono) (auto simp: Y_small_def length_chop_part_le)
  also have "\<dots> = 5 * size Y\<^sub>\<prec>" by simp

  text \<open>Next, we note that each group in @{term "Y\<^sub>\<succeq>"} can have at most 2 elements that are
        smaller than its median.\<close>
  also have "(\<Sum>ys\<in>#Y\<^sub>\<succeq>. size {#y \<in># mset ys. y \<prec> median ys#}) \<le>
               (\<Sum>ys\<in>#Y\<^sub>\<succeq>. length ys div 2)"
  proof (intro sum_mset_mono, goal_cases)
    fix ys assume "ys \<in># Y\<^sub>\<succeq>"
    hence "ys \<noteq> []"
      by (auto simp: Y_big_def)
    thus "size {#y \<in># mset ys. y \<prec> median ys#} \<le> length ys div 2"
      using R median_props[of ys] by auto
  qed
  also have "\<dots> \<le> (\<Sum>ys\<in>#Y\<^sub>\<succeq>. 2)"
    by (intro sum_mset_mono div_le_mono diff_le_mono)
       (auto simp: Y_big_def dest: length_chop_part_le)
  also have "\<dots> = 2 * size Y\<^sub>\<succeq>" by simp

  text \<open>Simplifying gives us the main result.\<close>
  also have "5 * size Y\<^sub>\<prec> + 2 * size Y\<^sub>\<succeq> = 2 * m + 3 * size Y\<^sub>\<prec>"
    by (simp add: m_eq)
  also have "\<dots> \<le> 3.5 * m"
    using \<open>size Y\<^sub>\<prec> \<le> m div 2\<close> by linarith
  also have "\<dots> = 3.5 * \<lceil>n / 5\<rceil>"
    by (simp add: m_def length_chop)
  also have "\<dots> \<le> 0.7 * n + 3.5"
    by linarith
  finally have "size {#y \<in># mset xs. y \<prec> M#} \<le> 0.7 * n + 3.5"
    by simp
  thus "size {#y \<in># mset xs. y \<prec> M#} \<le> nat \<lceil>0.7 * n + 3\<rceil>"
    by linarith
qed

lemma size_less_than_median_of_medians:
  "size {#y \<in># mset xs. y < M#} \<le> nat \<lceil>0.7 * length xs + 3\<rceil>"
  using size_median_of_medians_aux[of "(<)"] by simp

lemma size_greater_than_median_of_medians:
  "size {#y \<in># mset xs. y > M#} \<le> nat \<lceil>0.7 * length xs + 3\<rceil>"
  using size_median_of_medians_aux[of "(>)"] by simp

end

subsection \<open>Efficient algorithm\<close>

text \<open>
  We handle the base cases and computing the median for the chopped-up sublists of size 5
  using the naive selection algorithm where we sort the list using insertion sort.
\<close>
definition slow_select where
  "slow_select k xs = isort xs ! k"

definition slow_median where
  "slow_median xs = slow_select ((length xs - 1) div 2) xs"

lemma slow_select_correct: "slow_select k xs = select k xs"
  by (simp add: slow_select_def select_def isort_correct)

lemma slow_median_correct: "slow_median xs = median xs"
  by (simp add: median_def slow_median_def slow_select_correct)

text \<open>
  The definition of the selection algorithm is complicated somewhat by the fact that its
  termination is contingent on its correctness: if the first recursive call were to return an
  element for \<open>x\<close> that is e.g. smaller than all list elements, the algorithm would not terminate.

  Therefore, we first prove partial correctness, then termination, and then combine the two
  to obtain total correctness.
\<close>
function mom_select where
  "mom_select k xs = (
     if length xs \<le> 20 then
       slow_select k xs
     else
       let M = mom_select (((length xs + 4) div 5 - 1) div 2) (map slow_median (chop 5 xs));
           (ls, es, gs) = partition3 M xs
       in
         if k < length ls then mom_select k ls
         else if k < length ls + length es then M
         else mom_select (k - length ls - length es) gs
      )"
  by auto

text \<open>
  If @{const "mom_select"} terminates, it agrees with @{const select}:
\<close>
lemma mom_select_correct_aux:
  assumes "mom_select_dom (k, xs)" and "k < length xs"
  shows   "mom_select k xs = select k xs"
  using assms
proof (induction rule: mom_select.pinduct)
  case (1 k xs)
  show "mom_select k xs = select k xs"
  proof (cases "length xs \<le> 20")
    case True
    thus "mom_select k xs = select k xs" using "1.prems" "1.hyps"
      by (subst mom_select.psimps) (auto simp: select_def slow_select_correct)
  next
    case False
    define x where
      "x = mom_select (((length xs + 4) div 5 - 1) div 2) (map slow_median (chop 5 xs))"
    define ls es gs where "ls = filter (\<lambda>y. y < x) xs" and "es = filter (\<lambda>y. y = x) xs"
                      and "gs = filter (\<lambda>y. y > x) xs"
    define nl ne where "nl = length ls" and "ne = length es"
    note defs = nl_def ne_def x_def ls_def es_def gs_def
    have tw: "(ls, es, gs) = partition3 x xs"
      unfolding partition3_def defs One_nat_def ..
    have length_eq: "length xs = nl + ne + length gs"
      unfolding nl_def ne_def ls_def es_def gs_def
      using [[simp_depth_limit = 1]] by (induction xs) auto
    note IH = "1.IH"(2,3)[OF False x_def tw refl refl]

    have "mom_select k xs = (if k < nl then mom_select k ls else if k < nl + ne then x
                                else mom_select (k - nl - ne) gs)" using "1.hyps" False
      by (subst mom_select.psimps) (simp_all add: partition3_def flip: defs One_nat_def)
    also have "\<dots> = (if k < nl then select k ls else if k < nl + ne then x
                       else select (k - nl - ne) gs)"
      using IH length_eq "1.prems" by (simp add: ls_def es_def gs_def nl_def ne_def)
    also have "\<dots> = select k xs" using \<open>k < length xs\<close>
      by (subst (3) select_rec_partition[of _ _ x]) (simp_all add: nl_def ne_def flip: tw)
    finally show "mom_select k xs = select k xs" .
  qed
qed

text \<open>
  @{const mom_select} indeed terminates for all inputs:
\<close>
lemma mom_select_termination: "All mom_select_dom"
proof (relation "measure (length \<circ> snd)"; (safe)?)
  fix k :: nat and xs :: "'a list"
  assume "\<not> length xs \<le> 20"
  thus "((((length xs + 4) div 5 - 1) div 2, map slow_median (chop 5 xs)), k, xs)
           \<in> measure (length \<circ> snd)"
    by (auto simp: length_chop nat_less_iff ceiling_less_iff)
next
  fix k :: nat and xs ls es gs :: "'a list"
  define x where "x = mom_select (((length xs + 4) div 5 - 1) div 2) (map slow_median (chop 5 xs))"
  assume A: "\<not> length xs \<le> 20"
            "(ls, es, gs) = partition3 x xs"
            "mom_select_dom (((length xs + 4) div 5 - 1) div 2,
                             map slow_median (chop 5 xs))"
  have less: "((length xs + 4) div 5 - 1) div 2 < nat \<lceil>length xs / 5\<rceil>"
    using A(1) by linarith

  text \<open>For termination, it suffices to prove that @{term x} is in the list.\<close>
  have "x = select (((length xs + 4) div 5 - 1) div 2) (map slow_median (chop 5 xs))"
    using less unfolding x_def by (intro mom_select_correct_aux A) (auto simp: length_chop)
  also have "\<dots> \<in> set (map slow_median (chop 5 xs))"
    using less by (intro select_in_set) (simp_all add: length_chop)
  also have "\<dots> \<subseteq> set xs"
    unfolding set_map
  proof safe
    fix ys assume ys: "ys \<in> set (chop 5 xs)"
    hence "median ys \<in> set ys"
      by auto
    also have "set ys \<subseteq> \<Union>(set ` set (chop 5 xs))"
      using ys by blast
    also have "\<dots> = set xs"
      by (rule UN_sets_chop) simp_all
    finally show "slow_median ys \<in> set xs"
      by (simp add: slow_median_correct)
  qed
  finally have "x \<in> set xs" .
  thus "((k, ls), k, xs) \<in> measure (length \<circ> snd)"
   and "((k - length ls - length es, gs), k, xs) \<in> measure (length \<circ> snd)"
    using A(1,2) by (auto simp: partition3_def intro!: length_filter_less[of x])
qed

termination mom_select by (rule mom_select_termination)

lemmas [simp del] = mom_select.simps

lemma mom_select_correct: "k < length xs \<Longrightarrow> mom_select k xs = select k xs"
  using mom_select_correct_aux and mom_select_termination by blast

subsection \<open>Running time analysis\<close>

fun T_partition3 :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
  "T_partition3 x [] = 1"
| "T_partition3 x (y # ys) = T_partition3 x ys + 1"

lemma T_partition3_eq: "T_partition3 x xs = length xs + 1"
  by (induction x xs rule: T_partition3.induct) auto

definition T_slow_select :: "nat \<Rightarrow> 'a :: linorder list \<Rightarrow> nat" where
  "T_slow_select k xs = T_isort xs + T_nth (isort xs) k + 1"

definition T_slow_median :: "'a :: linorder list \<Rightarrow> nat" where
  "T_slow_median xs = T_slow_select ((length xs - 1) div 2) xs + 1"

lemma T_slow_select_le: "T_slow_select k xs \<le> length xs ^ 2 + 3 * length xs + 3"
proof -
  have "T_slow_select k xs \<le> (length xs + 1)\<^sup>2 + (length (isort xs) + 1) + 1"
    unfolding T_slow_select_def
    by (intro add_mono T_isort_length) (auto simp: T_nth_eq)
  also have "\<dots> = length xs ^ 2 + 3 * length xs + 3"
    by (simp add: isort_correct algebra_simps power2_eq_square)
  finally show ?thesis .
qed

lemma T_slow_median_le: "T_slow_median xs \<le> length xs ^ 2 + 3 * length xs + 4"
  unfolding T_slow_median_def using T_slow_select_le[of "(length xs - 1) div 2" xs] by simp

fun T_chop :: "nat \<Rightarrow> 'a list \<Rightarrow> nat" where
  "T_chop 0 _  = 1"
| "T_chop _ [] = 1"
| "T_chop n xs = T_take n xs + T_drop n xs + T_chop n (drop n xs)"

lemmas [simp del] = T_chop.simps

lemma T_chop_Nil [simp]: "T_chop d [] = 1"
  by (cases d) (auto simp: T_chop.simps)

lemma T_chop_0 [simp]: "T_chop 0 xs = 1"
  by (auto simp: T_chop.simps)

lemma T_chop_reduce:
  "n > 0 \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> T_chop n xs = T_take n xs + T_drop n xs + T_chop n (drop n xs)"
  by (cases n; cases xs) (auto simp: T_chop.simps)

lemma T_chop_le: "T_chop d xs \<le> 5 * length xs + 1"
  by (induction d xs rule: T_chop.induct) (auto simp: T_chop_reduce T_take_eq T_drop_eq)

text \<open>
  The option \<open>domintros\<close> here allows us to explicitly reason about where the function does and
  does not terminate. With this, we can skip the termination proof this time because we can
  reuse the one for \<^const>\<open>mom_select\<close>.
\<close>
function (domintros) T_mom_select :: "nat \<Rightarrow> 'a :: linorder list \<Rightarrow> nat" where
  "T_mom_select k xs = (
     if length xs \<le> 20 then
       T_slow_select k xs
     else
       let xss = chop 5 xs;
           ms = map slow_median xss;
           idx = (((length xs + 4) div 5 - 1) div 2);
           x = mom_select idx ms;
           (ls, es, gs) = partition3 x xs;
           nl = length ls;
           ne = length es
       in
         (if k < nl then T_mom_select k ls
          else if k < nl + ne then 0
          else T_mom_select (k - nl - ne) gs) +
         T_mom_select idx ms + T_chop 5 xs + T_map T_slow_median xss +
         T_partition3 x xs + T_length ls + T_length es + 1
      )"
  by auto

termination T_mom_select
proof (rule allI, safe)
  fix k :: nat and xs :: "'a :: linorder list"
  have "mom_select_dom (k, xs)"
    using mom_select_termination by blast
  thus "T_mom_select_dom (k, xs)"
    by (induction k xs rule: mom_select.pinduct)
       (rule T_mom_select.domintros, simp_all)
qed

lemmas [simp del] = T_mom_select.simps

function T'_mom_select :: "nat \<Rightarrow> nat" where
  "T'_mom_select n =
     (if n \<le> 20 then
        463
      else
        T'_mom_select (nat \<lceil>0.2*n\<rceil>) + T'_mom_select (nat \<lceil>0.7*n+3\<rceil>) + 17 * n + 50)"
  by force+
termination by (relation "measure id"; simp; linarith)

lemmas [simp del] = T'_mom_select.simps

lemma T'_mom_select_ge: "T'_mom_select n \<ge> 463"
  by (induction n rule: T'_mom_select.induct; subst T'_mom_select.simps) auto

lemma T'_mom_select_mono:
  "m \<le> n \<Longrightarrow> T'_mom_select m \<le> T'_mom_select n"
proof (induction n arbitrary: m rule: less_induct)
  case (less n m)
  show ?case
  proof (cases "m \<le> 20")
    case True
    hence "T'_mom_select m = 463"
      by (subst T'_mom_select.simps) auto
    also have "\<dots> \<le> T'_mom_select n"
      by (rule T'_mom_select_ge)
    finally show ?thesis .
  next
    case False
    hence "T'_mom_select m =
             T'_mom_select (nat \<lceil>0.2*m\<rceil>) + T'_mom_select (nat \<lceil>0.7*m + 3\<rceil>) + 17 * m + 50"
      by (subst T'_mom_select.simps) auto
    also have "\<dots> \<le> T'_mom_select (nat \<lceil>0.2*n\<rceil>) + T'_mom_select (nat \<lceil>0.7*n + 3\<rceil>) + 17 * n + 50"
      using \<open>m \<le> n\<close> and False by (intro add_mono less.IH; linarith)
    also have "\<dots> = T'_mom_select n"
      using \<open>m \<le> n\<close> and False by (subst T'_mom_select.simps) auto
    finally show ?thesis .
  qed
qed

lemma T_mom_select_le_aux: "T_mom_select k xs \<le> T'_mom_select (length xs)"
proof (induction k xs rule: T_mom_select.induct)
  case (1 k xs)
  define n where [simp]: "n = length xs"
  define x where
    "x = mom_select (((length xs + 4) div 5 - 1) div 2) (map slow_median (chop 5 xs))"
  define ls es gs where "ls = filter (\<lambda>y. y < x) xs" and "es = filter (\<lambda>y. y = x) xs"
                    and "gs = filter (\<lambda>y. y > x) xs"
  define nl ne where "nl = length ls" and "ne = length es"
  note defs = nl_def ne_def x_def ls_def es_def gs_def
  have tw: "(ls, es, gs) = partition3 x xs"
    unfolding partition3_def defs One_nat_def ..
  note IH = "1.IH"(1,2,3)[OF _ refl refl refl x_def tw refl refl refl refl]

  show ?case
  proof (cases "length xs \<le> 20")
    case True \<comment> \<open>base case\<close>
    hence "T_mom_select k xs \<le> (length xs)\<^sup>2 + 3 * length xs + 3"
      using T_slow_select_le[of k xs] by (subst T_mom_select.simps) auto
    also have "\<dots> \<le> 20\<^sup>2 + 3 * 20 + 3"
      using True by (intro add_mono power_mono) auto
    also have "\<dots> \<le> 463"
      by simp
    also have "\<dots> = T'_mom_select (length xs)"
      using True by (simp add: T'_mom_select.simps)
    finally show ?thesis by simp
  next
    case False \<comment> \<open>recursive case\<close>
    have "((n + 4) div 5 - 1) div 2 < nat \<lceil>n / 5\<rceil>"
      using False unfolding n_def by linarith
    hence "x = select (((n + 4) div 5 - 1) div 2) (map slow_median (chop 5 xs))"
      unfolding x_def n_def by (intro mom_select_correct) (auto simp: length_chop)
    also have "((n + 4) div 5 - 1) div 2 = (nat \<lceil>n / 5\<rceil> - 1) div 2"
      by linarith
    also have "select \<dots> (map slow_median (chop 5 xs)) = median (map slow_median (chop 5 xs))"
      by (auto simp: median_def length_chop)
    finally have x_eq: "x = median (map slow_median (chop 5 xs))" .

    text \<open>The cost of computing the medians of all the subgroups:\<close>
    define T_ms where "T_ms = T_map T_slow_median (chop 5 xs)"
    have "T_ms \<le> 9 * n + 45"
    proof -
      have "T_ms = (\<Sum>ys\<leftarrow>chop 5 xs. T_slow_median ys) + length (chop 5 xs) + 1"
        by (simp add: T_ms_def T_map_eq)
      also have "(\<Sum>ys\<leftarrow>chop 5 xs. T_slow_median ys) \<le> (\<Sum>ys\<leftarrow>chop 5 xs. 44)"
      proof (intro sum_list_mono)
        fix ys assume "ys \<in> set (chop 5 xs)"
        hence "length ys \<le> 5"
          using length_chop_part_le by blast
        have "T_slow_median ys \<le> (length ys) ^ 2 + 3 * length ys + 4"
          by (rule T_slow_median_le)
        also have "\<dots> \<le> 5 ^ 2 + 3 * 5 + 4"
          using \<open>length ys \<le> 5\<close> by (intro add_mono power_mono) auto
        finally show "T_slow_median ys \<le> 44" by simp
      qed
      also have "(\<Sum>ys\<leftarrow>chop 5 xs. 44) + length (chop 5 xs) + 1 =
                   45 * nat \<lceil>real n / 5\<rceil> + 1"
        by (simp add: map_replicate_const length_chop)
      also have "\<dots> \<le> 9 * n + 45"
        by linarith
      finally show "T_ms \<le> 9 * n + 45" by simp
    qed

    text \<open>The cost of the first recursive call (to compute the median of medians):\<close>
    define T_rec1 where
      "T_rec1 = T_mom_select (((length xs + 4) div 5 - 1) div 2) (map slow_median (chop 5 xs))"
    have "T_rec1 \<le> T'_mom_select (length (map slow_median (chop 5 xs)))"
      using False unfolding T_rec1_def by (intro IH(3)) auto
    hence "T_rec1 \<le> T'_mom_select (nat \<lceil>0.2 * n\<rceil>)"
      by (simp add: length_chop)

    text \<open>The cost of the second recursive call (to compute the final result):\<close>
    define T_rec2 where "T_rec2 = (if k < nl then T_mom_select k ls
                                 else if k < nl + ne then 0
                                 else T_mom_select (k - nl - ne) gs)"
    consider "k < nl" | "k \<in> {nl..<nl+ne}" | "k \<ge> nl+ne"
      by force
    hence "T_rec2 \<le> T'_mom_select (nat \<lceil>0.7 * n + 3\<rceil>)"
    proof cases
      assume "k < nl"
      hence "T_rec2 = T_mom_select k ls"
        by (simp add: T_rec2_def)
      also have "\<dots> \<le> T'_mom_select (length ls)"
        by (rule IH(1)) (use \<open>k < nl\<close> False in \<open>auto simp: defs\<close>)
      also have "length ls \<le> nat \<lceil>0.7 * n + 3\<rceil>"
        unfolding ls_def using size_less_than_median_of_medians[of xs]
        by (auto simp: length_filter_conv_size_filter_mset slow_median_correct[abs_def] x_eq)
      hence "T'_mom_select (length ls) \<le> T'_mom_select (nat \<lceil>0.7 * n + 3\<rceil>)"
        by (rule T'_mom_select_mono)
      finally show ?thesis .
    next
      assume "k \<in> {nl..<nl + ne}"
      hence "T_rec2 = 0"
        by (simp add: T_rec2_def)
      thus ?thesis
        using T'_mom_select_ge[of "nat \<lceil>0.7 * n + 3\<rceil>"] by simp
    next
      assume "k \<ge> nl + ne"
      hence "T_rec2 = T_mom_select (k - nl - ne) gs"
        by (simp add: T_rec2_def)
      also have "\<dots> \<le> T'_mom_select (length gs)"
        unfolding nl_def ne_def by (rule IH(2)) (use \<open>k \<ge> nl + ne\<close> False in \<open>auto simp: defs\<close>)
      also have "length gs \<le> nat \<lceil>0.7 * n + 3\<rceil>"
        unfolding gs_def using size_greater_than_median_of_medians[of xs]
        by (auto simp: length_filter_conv_size_filter_mset slow_median_correct[abs_def] x_eq)
      hence "T'_mom_select (length gs) \<le> T'_mom_select (nat \<lceil>0.7 * n + 3\<rceil>)"
        by (rule T'_mom_select_mono)
      finally show ?thesis .
    qed

    text \<open>Now for the final inequality chain:\<close>
    have "T_mom_select k xs = T_rec2 + T_rec1 + T_ms + n + nl + ne + T_chop 5 xs + 4" using False
      by (subst T_mom_select.simps, unfold Let_def tw [symmetric] defs [symmetric])
         (simp_all add: nl_def ne_def T_rec1_def T_rec2_def T_partition3_eq
                        T_length_eq T_ms_def)
    also have "nl \<le> n" by (simp add: nl_def ls_def)
    also have "ne \<le> n" by (simp add: ne_def es_def)
    also note \<open>T_ms \<le> 9 * n + 45\<close>
    also have "T_chop 5 xs \<le> 5 * n + 1"
      using T_chop_le[of 5 xs] by simp
    also note \<open>T_rec1 \<le> T'_mom_select (nat \<lceil>0.2*n\<rceil>)\<close>
    also note \<open>T_rec2 \<le> T'_mom_select (nat \<lceil>0.7*n + 3\<rceil>)\<close>
    finally have "T_mom_select k xs \<le>
                    T'_mom_select (nat \<lceil>0.7*n + 3\<rceil>) + T'_mom_select (nat \<lceil>0.2*n\<rceil>) + 17 * n + 50"
      by simp
    also have "\<dots> = T'_mom_select n"
      using False by (subst T'_mom_select.simps) auto
    finally show ?thesis by simp
  qed
qed

subsection \<open>Akra--Bazzi Light\<close>

lemma akra_bazzi_light_aux1:
  fixes a b :: real and n n0 :: nat
  assumes ab: "a > 0" "a < 1" "n > n0"
  assumes "n0 \<ge> (max 0 b + 1) / (1 - a)"
  shows "nat \<lceil>a*n+b\<rceil> < n"
proof -
  have "a * real n + max 0 b \<ge> 0"
    using ab by simp
  hence "real (nat \<lceil>a*n+b\<rceil>) \<le> a * n + max 0 b + 1"
    by linarith
  also {
    have "n0 \<ge> (max 0 b + 1) / (1 - a)"
      by fact
    also have "\<dots> < real n"
      using assms by simp
    finally have "a * real n + max 0 b + 1 < real n"
      using ab by (simp add: field_simps)
  }
  finally show "nat \<lceil>a*n+b\<rceil> < n"
    using \<open>n > n0\<close> by linarith
qed

lemma akra_bazzi_light_aux2:
  fixes f :: "nat \<Rightarrow> real"
  fixes n\<^sub>0 :: nat and a b c d :: real and C1 C2 C\<^sub>1 C\<^sub>2 :: real
  assumes bounds: "a > 0" "c > 0" "a + c < 1" "C\<^sub>1 \<ge> 0"
  assumes rec: "\<forall>n>n\<^sub>0. f n = f (nat \<lceil>a*n+b\<rceil>) + f (nat \<lceil>c*n+d\<rceil>) + C\<^sub>1 * n + C\<^sub>2"
  assumes ineqs: "n\<^sub>0 > (max 0 b + max 0 d + 2) / (1 - a - c)"
                 "C\<^sub>3 \<ge> C\<^sub>1 / (1 - a - c)"
                 "C\<^sub>3 \<ge> (C\<^sub>1 * n\<^sub>0 + C\<^sub>2 + C\<^sub>4) / ((1 - a - c) * n\<^sub>0 - max 0 b - max 0 d - 2)"
                 "\<forall>n\<le>n\<^sub>0. f n \<le> C\<^sub>4"
  shows   "f n \<le> C\<^sub>3 * n + C\<^sub>4"
proof (induction n rule: less_induct)
  case (less n)
  have "0 \<le> C\<^sub>1 / (1 - a - c)"
    using bounds by auto
  also have "\<dots> \<le> C\<^sub>3"
    by fact
  finally have "C\<^sub>3 \<ge> 0" .

  show ?case
  proof (cases "n > n\<^sub>0")
    case False
    hence "f n \<le> C\<^sub>4"
      using ineqs(4) by auto
    also have "\<dots> \<le> C\<^sub>3 * real n + C\<^sub>4"
      using bounds \<open>C\<^sub>3 \<ge> 0\<close> by auto
    finally show ?thesis .
  next
    case True
    have nonneg: "a * n \<ge> 0" "c * n \<ge> 0"
      using bounds by simp_all

    have "(max 0 b + 1) / (1 - a) \<le> (max 0 b + max 0 d + 2) / (1 - a - c)"
      using bounds by (intro frac_le) auto
    hence "n\<^sub>0 \<ge> (max 0 b + 1) / (1 - a)"
      using ineqs(1) by linarith
    hence rec_less1: "nat \<lceil>a*n+b\<rceil> < n"
      using bounds \<open>n > n\<^sub>0\<close> by (intro akra_bazzi_light_aux1[of _ n\<^sub>0]) auto

    have "(max 0 d + 1) / (1 - c) \<le> (max 0 b + max 0 d + 2) / (1 - a - c)"
      using bounds by (intro frac_le) auto
    hence "n\<^sub>0 \<ge> (max 0 d + 1) / (1 - c)"
      using ineqs(1) by linarith
    hence rec_less2: "nat \<lceil>c*n+d\<rceil> < n"
      using bounds \<open>n > n\<^sub>0\<close> by (intro akra_bazzi_light_aux1[of _ n\<^sub>0]) auto

    have "f n = f (nat \<lceil>a*n+b\<rceil>) + f (nat \<lceil>c*n+d\<rceil>) + C\<^sub>1 * n + C\<^sub>2"
      using \<open>n > n\<^sub>0\<close> by (subst rec) auto
    also have "\<dots> \<le> (C\<^sub>3 * nat \<lceil>a*n+b\<rceil> + C\<^sub>4) + (C\<^sub>3 * nat \<lceil>c*n+d\<rceil> + C\<^sub>4) + C\<^sub>1 * n + C\<^sub>2"
      using rec_less1 rec_less2 by (intro add_mono less.IH) auto
    also have "\<dots> \<le> (C\<^sub>3 * (a*n+max 0 b+1) + C\<^sub>4) + (C\<^sub>3 * (c*n+max 0 d+1) + C\<^sub>4) + C\<^sub>1 * n + C\<^sub>2"
      using bounds \<open>C\<^sub>3 \<ge> 0\<close> nonneg by (intro add_mono mult_left_mono order.refl; linarith)
    also have "\<dots> = C\<^sub>3 * n  +  ((C\<^sub>3 * (max 0 b + max 0 d + 2) + 2 * C\<^sub>4 + C\<^sub>2) -
                                 (C\<^sub>3 * (1 - a - c) - C\<^sub>1) * n)"
      by (simp add: algebra_simps)
    also have "\<dots> \<le> C\<^sub>3 * n  +  ((C\<^sub>3 * (max 0 b + max 0 d + 2) + 2 * C\<^sub>4 + C\<^sub>2) -
                                 (C\<^sub>3 * (1 - a - c) - C\<^sub>1) * n\<^sub>0)"
      using \<open>n > n\<^sub>0\<close> ineqs(2) bounds
      by (intro add_mono diff_mono order.refl mult_left_mono) (auto simp: field_simps)
    also have "(C\<^sub>3 * (max 0 b + max 0 d + 2) + 2 * C\<^sub>4 + C\<^sub>2) - (C\<^sub>3 * (1 - a - c) - C\<^sub>1) * n\<^sub>0 \<le> C\<^sub>4"
      using ineqs bounds by (simp add: field_simps)
    finally show "f n \<le> C\<^sub>3 * real n + C\<^sub>4"
      by (simp add: mult_right_mono)
  qed
qed

lemma akra_bazzi_light:
  fixes f :: "nat \<Rightarrow> real"
  fixes n\<^sub>0 :: nat and a b c d C\<^sub>1 C\<^sub>2 :: real
  assumes bounds: "a > 0" "c > 0" "a + c < 1" "C\<^sub>1 \<ge> 0"
  assumes rec: "\<forall>n>n\<^sub>0. f n = f (nat \<lceil>a*n+b\<rceil>) + f (nat \<lceil>c*n+d\<rceil>) + C\<^sub>1 * n + C\<^sub>2"
  shows "\<exists>C\<^sub>3 C\<^sub>4. \<forall>n. f n \<le> C\<^sub>3 * real n + C\<^sub>4"
proof -
  define n\<^sub>0' where "n\<^sub>0' = max n\<^sub>0 (nat \<lceil>(max 0 b + max 0 d + 2) / (1 - a - c) + 1\<rceil>)"
  define C\<^sub>4 where "C\<^sub>4 = Max (f ` {..n\<^sub>0'})"
  define C\<^sub>3 where "C\<^sub>3 = max (C\<^sub>1 / (1 - a - c))
                         ((C\<^sub>1 * n\<^sub>0' + C\<^sub>2 + C\<^sub>4) / ((1 - a - c) * n\<^sub>0' - max 0 b - max 0 d - 2))"

  have "f n \<le> C\<^sub>3 * n + C\<^sub>4" for n
  proof (rule akra_bazzi_light_aux2[OF bounds _])
    show "\<forall>n>n\<^sub>0'. f n = f (nat \<lceil>a*n+b\<rceil>) + f (nat \<lceil>c*n+d\<rceil>) + C\<^sub>1 * n + C\<^sub>2"
      using rec by (auto simp: n\<^sub>0'_def)
  next
    show "C\<^sub>3 \<ge> C\<^sub>1 / (1 - a - c)"
     and "C\<^sub>3 \<ge> (C\<^sub>1 * n\<^sub>0' + C\<^sub>2 + C\<^sub>4) / ((1 - a - c) * n\<^sub>0' - max 0 b - max 0 d - 2)"
      by (simp_all add: C\<^sub>3_def)
  next
    have "(max 0 b + max 0 d + 2) / (1 - a - c) < nat \<lceil>(max 0 b + max 0 d + 2) / (1 - a - c) + 1\<rceil>"
      by linarith
    also have "\<dots> \<le> n\<^sub>0'"
      by (simp add: n\<^sub>0'_def)
    finally show "(max 0 b + max 0 d + 2) / (1 - a - c) < real n\<^sub>0'" .
  next
    show "\<forall>n\<le>n\<^sub>0'. f n \<le> C\<^sub>4"
      by (auto simp: C\<^sub>4_def)
  qed
  thus ?thesis by blast
qed

lemma akra_bazzi_light_nat:
  fixes f :: "nat \<Rightarrow> nat"
  fixes n\<^sub>0 :: nat and a b c d :: real and C\<^sub>1 C\<^sub>2 :: nat
  assumes bounds: "a > 0" "c > 0" "a + c < 1" "C\<^sub>1 \<ge> 0"
  assumes rec: "\<forall>n>n\<^sub>0. f n = f (nat \<lceil>a*n+b\<rceil>) + f (nat \<lceil>c*n+d\<rceil>) + C\<^sub>1 * n + C\<^sub>2"
  shows "\<exists>C\<^sub>3 C\<^sub>4. \<forall>n. f n \<le> C\<^sub>3 * n + C\<^sub>4"
proof -
  have "\<exists>C\<^sub>3 C\<^sub>4. \<forall>n. real (f n) \<le> C\<^sub>3 * real n + C\<^sub>4"
    using assms by (intro akra_bazzi_light[of a c C\<^sub>1 n\<^sub>0 f b d C\<^sub>2]) auto
  then obtain C\<^sub>3 C\<^sub>4 where le: "\<forall>n. real (f n) \<le> C\<^sub>3 * real n + C\<^sub>4"
    by blast
  have "f n \<le> nat \<lceil>C\<^sub>3\<rceil> * n + nat \<lceil>C\<^sub>4\<rceil>" for n
  proof -
    have "real (f n) \<le> C\<^sub>3 * real n + C\<^sub>4"
      using le by blast
    also have "\<dots> \<le> real (nat \<lceil>C\<^sub>3\<rceil>) * real n + real (nat \<lceil>C\<^sub>4\<rceil>)"
      by (intro add_mono mult_right_mono; linarith)
    also have "\<dots> = real (nat \<lceil>C\<^sub>3\<rceil> * n + nat \<lceil>C\<^sub>4\<rceil>)"
      by simp
    finally show ?thesis by linarith
  qed
  thus ?thesis by blast
qed

lemma T'_mom_select_le': "\<exists>C\<^sub>1 C\<^sub>2. \<forall>n. T'_mom_select n \<le> C\<^sub>1 * n + C\<^sub>2"
proof (rule akra_bazzi_light_nat)
  show "\<forall>n>20. T'_mom_select n = T'_mom_select (nat \<lceil>0.2 * n + 0\<rceil>) +
                 T'_mom_select (nat \<lceil>0.7 * n + 3\<rceil>) + 17 * n + 50"
    using T'_mom_select.simps by auto
qed auto

end