theory VC4_to_mTSP_Poly_old
  imports Main tsp.Misc tsp.Berge tsp.CompleteGraph tsp.TravelingSalesman tsp.VertexCover
begin

(* OLD, NOT NEEDED; TODO: remove *)

text \<open>This theory formalizes a L-Reduction from Minimum-Vertex-Cover (VC4), with max. degree 4,
to metric-Traveling-Salesman (mTSP).\<close>

(* All edges are undirected, but are represent by tuples to more easily write executable functions. *)

text \<open>The function \<open>f\<close> translates from VC4 to mTSP. Let \<open>E\<close> be an instance of VC4 then \<open>f E\<close> is an
instance of mTSP.\<close>

text \<open>
({u,v},u,1) --- ({u,v},u,5) --- ({u,v},v,2)
     |                               |
({u,v},u,3) --- ({u,v},u,6) --- ({u,v},v,4)
     |                               |
({u,v},u,4) --- ({u,v},v,6) --- ({u,v},v,3)
     |                               |
({u,v},u,2) --- ({u,v},v,5) --- ({u,v},v,1)
\<close>

definition "H\<^sub>e u v \<equiv> (let e = {u,v} in
  {{(e,u,1::nat),(e,u,3)},
  {(e,u,1),(e,u,5)},
  {(e,u,2),(e,u,4)},
  {(e,u,2),(e,v,5)},
  {(e,u,3),(e,u,4)},
  {(e,u,3),(e,u,6)},
  {(e,u,4),(e,v,6)},

  {(e,v,1::nat),(e,v,3)},
  {(e,v,1),(e,v,5)},
  {(e,v,2),(e,v,4)},
  {(e,v,2),(e,u,5)},
  {(e,v,3),(e,v,4)},
  {(e,v,3),(e,v,6)},
  {(e,v,4),(e,u,6)}})"

(* definition "H\<^sub>e u v \<equiv> (let e = {u,v} in
  {{(e,u,1::nat),(e,u,2)},
  {(e,u,1),(e,u,6)},
  {(e,u,2),(e,u,3)},
  {(e,u,3),(e,u,4)},
  {(e,u,4),(e,u,5)},
  {(e,u,4),(e,v,4)},
  {(e,u,5),(e,u,6)},
  {(e,u,6),(e,v,6)},

  {(e,v,1),(e,v,2)},
  {(e,v,1),(e,v,6)},
  {(e,v,2),(e,v,3)},
  {(e,v,3),(e,v,4)},
  {(e,v,4),(e,v,5)},
  {(e,v,5),(e,v,6)}})" *)

abbreviation "H E \<equiv> \<Union> {H\<^sub>e u v | u v. {u,v} \<in> E}"

definition "f E \<equiv> (let V\<^sub>H = Vs (H E) in complete_graph V\<^sub>H)"

fun dist\<^sub>H\<^sub>e :: "('a set \<times> 'a \<times> nat) \<Rightarrow> ('a set \<times> 'a \<times> nat) \<Rightarrow> nat option" where
  "dist\<^sub>H\<^sub>e (e\<^sub>u,u,i) (e\<^sub>v,v,j) = undefined" (* TODO: Do I need the distance? Or just set it to \<ge> 12 *)

fun c\<^sub>H :: "'a set set \<Rightarrow> ('a set \<times> 'a \<times> nat) set \<Rightarrow> nat" where
  "c\<^sub>H E e =
  (if \<exists>u v. {u,v} \<in> E \<and> e \<in> H\<^sub>e u v then 1
  else if \<exists>u v. {u,v} \<in> E \<and> e \<subseteq> Vs (H\<^sub>e u v) then 12
  else if \<exists>v e\<^sub>1 e\<^sub>2 i j. e = {(e\<^sub>1,v,i),(e\<^sub>2,v,j)} \<and> e\<^sub>1 \<noteq> e\<^sub>2 then 4
  else 5)"

text \<open>The function \<open>g\<close> translates a feasible solution of mTSP to a feasible solution of VC4. Let \<open>E\<close>
be an instance of VC4 and let \<open>T\<close> be a feasible solution (Hamiltonian cycle) of \<open>f E\<close> then \<open>g (f E)\<close>
is a feasible solution of \<open>E\<close> (vertex cover).\<close>

fun g :: "('a set \<times> 'a \<times> nat) list \<Rightarrow> 'a list" where
  "g es = undefined" (* TODO *)

(* ----- auxiliary lemmas ----- *)

lemma finite_H\<^sub>e: "finite (H\<^sub>e u v)"
  unfolding H\<^sub>e_def Let_def by auto

lemma finite_Vs_H\<^sub>e: "finite (Vs (H\<^sub>e u v))"
  unfolding Vs_def H\<^sub>e_def Let_def by auto

lemma H\<^sub>e_symmetric: "H\<^sub>e u v = H\<^sub>e v u"
  unfolding H\<^sub>e_def Let_def by (simp add: insert_commute)

lemma Vs_H\<^sub>e_member_fst_edge: "(e,v',i) \<in> Vs (H\<^sub>e u v) \<Longrightarrow> e = {u,v}"
  unfolding H\<^sub>e_def Let_def Vs_def by auto

lemma graph_H\<^sub>e_aux1:
  assumes "u \<noteq> v" "e \<in> H\<^sub>e u v"
  obtains x y where "e = {x,y}" "x \<noteq> y"
  using assms[unfolded H\<^sub>e_def Let_def] by auto

lemma graph_H\<^sub>e_aux2: "u \<noteq> v \<Longrightarrow> (\<forall>e \<in> H\<^sub>e u v. \<exists>x y. e = {x,y} \<and> x \<noteq> y)"
  using graph_H\<^sub>e_aux1 by metis

lemma graph_H\<^sub>e:
  assumes "u \<noteq> v"
  shows "graph_invar (H\<^sub>e u v)"
  using graph_H\<^sub>e_aux2[OF assms(1)] finite_Vs_H\<^sub>e by fastforce

lemma complete_f: "is_complete (f E)"
  unfolding f_def Let_def by (rule complete_graph_is_complete)

lemma H_union: "H (E\<^sub>1 \<union> E\<^sub>2) = H E\<^sub>1 \<union> H E\<^sub>2"
  by blast

lemma Vs_H_union: "Vs (H (E\<^sub>1 \<union> E\<^sub>2)) = Vs (H E\<^sub>1) \<union> Vs (H E\<^sub>2)"
  by (simp only: H_union) (intro Vs_union)

lemma f_union: "f E\<^sub>1 \<union> f E\<^sub>2 \<subseteq> f (E\<^sub>1 \<union> E\<^sub>2)"
  by (simp only: f_def Let_def Vs_H_union) (intro complete_graph_union)

lemma f_insert_union:
  assumes "u \<noteq> v" "u \<in> Vs (f E\<^sub>1)" "v \<in> Vs (f E\<^sub>2)"
  shows "insert {u,v} (f E\<^sub>1) \<union> (f E\<^sub>2) \<subseteq> f (E\<^sub>1 \<union> E\<^sub>2)"
proof (intro insert_union_subset)
  show "f E\<^sub>1 \<union> f E\<^sub>2 \<subseteq> f (E\<^sub>1 \<union> E\<^sub>2)"
    by (rule f_union)

  have "u \<in> Vs (H E\<^sub>1)" "v \<in> Vs (H E\<^sub>2)"
    using assms(2,3)[unfolded f_def Let_def] complete_graph_Vs_subset by fastforce+
  moreover have "Vs (H E\<^sub>1) \<subseteq> Vs (H (E\<^sub>1 \<union> E\<^sub>2))" "Vs (H E\<^sub>2) \<subseteq> Vs (H (E\<^sub>1 \<union> E\<^sub>2))"
    using Vs_H_union[of E\<^sub>1 E\<^sub>2] by blast+
  ultimately have "u \<in> Vs (H (E\<^sub>1 \<union> E\<^sub>2))" "v \<in> Vs (H (E\<^sub>1 \<union> E\<^sub>2))"
    by auto
  thus "{u,v} \<in> f (E\<^sub>1 \<union> E\<^sub>2)"
    using assms(1) unfolding f_def Let_def by (intro complete_graph_memberI)
qed

context graph_abs
begin

lemma Vs_H\<^sub>e_subset: "{u,v} \<in> E \<Longrightarrow> Vs (H\<^sub>e u v) \<subseteq> Vs (H E)"
  by (intro Vs_subset) auto

lemma H\<^sub>e_subset_f:
  assumes "{u,v} \<in> E"
  shows "H\<^sub>e u v \<subseteq> f E"
  unfolding f_def Let_def
proof (intro graph_abs.subset_complete_graph; unfold_locales)
  show "graph_invar (H\<^sub>e u v)"
    using graph assms by (intro graph_H\<^sub>e) auto
  show "Vs (H\<^sub>e u v) \<subseteq> Vs (\<Union> {H\<^sub>e u v |u v. {u,v} \<in> E})"
    using assms by (intro Vs_H\<^sub>e_subset)
qed

lemma Vs_fE_member_fst_edge:
  assumes "({u,v},x,k) \<in> Vs (f E)"
  shows "{u,v} \<in> E"
proof -
  have "({u,v},x,k) \<in> Vs (H E)"
    using assms[unfolded f_def Let_def] using complete_graph_Vs_subset by fastforce
  then obtain e' where "e' \<in> H E" "({u,v},x,k) \<in> e'"
    by (elim vs_member_elim)
  moreover then obtain u' v' where "e' \<in> H\<^sub>e u' v'" "{u',v'} \<in> E"
    by auto
  ultimately have "({u,v},x,k) \<in> Vs (H\<^sub>e u' v')"
    by (intro vs_member_intro)
  hence "{u,v} = {u',v'}"
    by (simp add: Vs_H\<^sub>e_member_fst_edge)
  thus "{u,v} \<in> E"
    using \<open>{u',v'} \<in> E\<close> by auto
qed

lemma Vs_fE_member_iff: "({u,v},v,1) \<in> Vs (f E) \<longleftrightarrow> {u,v} \<in> E"
proof
  assume "({u,v},v,1) \<in> Vs (f E)"
  thus "{u,v} \<in> E"
    by (rule Vs_fE_member_fst_edge)
next
  assume "{u,v} \<in> E"
  moreover hence "{({u,v},v,1),({u,v},v,3)} \<in> H\<^sub>e u v"
    unfolding H\<^sub>e_def by (auto simp: Let_def)
  moreover hence "({u,v},v,1) \<in> Vs (H\<^sub>e u v)"
    by (intro vs_member_intro) auto
  ultimately show "({u,v},v,1) \<in> Vs (f E)"
    using Vs_subset[OF H\<^sub>e_subset_f] by auto
qed

lemma finite_union_H\<^sub>e_aux: "finite {H\<^sub>e u v | u v. {u,v} \<in> E}"
  using finite_E graph
proof (induction E)
  case (insert e E)
  moreover have "graph_invar E"
    using insert(4) by (rule graph_subset) auto
  moreover obtain u v where [simp]: "e = {u,v}"
    using insert by auto
  moreover have "{H\<^sub>e u v |u v. {u,v} \<in> insert e E} = {H\<^sub>e u v |u v. {u,v} \<in> E} \<union> {H\<^sub>e u v}"
    by (auto simp: doubleton_eq_iff H\<^sub>e_symmetric)
  ultimately show ?case
    by auto
qed auto

lemma finite_union_H\<^sub>e: "finite (H E)"
  by (rule finite_Union) (auto intro: finite_union_H\<^sub>e_aux finite_H\<^sub>e)

lemma finite_Vs_union_H\<^sub>e: "finite (Vs (H E))"
  unfolding Vs_def using finite_union_H\<^sub>e by (rule finite_Union) (auto simp: H\<^sub>e_def Let_def)

lemma graph_H': "graph_invar (H E)"
proof (intro graph_Un)
  show "finite {H\<^sub>e u v |u v. {u,v} \<in> E}"
    by (rule finite_union_H\<^sub>e_aux)
  fix a
  assume "a \<in> {H\<^sub>e u v |u v. {u,v} \<in> E}"
  then obtain u v where "a = H\<^sub>e u v" and "{u,v} \<in> E"
    by auto
  moreover hence "u \<noteq> v"
    using graph by auto
  ultimately show "graph_invar a"
    by (simp only: \<open>a = H\<^sub>e u v\<close>; intro graph_H\<^sub>e)
qed

lemma finite_fE: "finite (f E)"
  unfolding f_def Let_def using finite_Vs_union_H\<^sub>e by (rule finite_complete_graph)

lemma graph_fE: "graph_invar (f E)"
  unfolding f_def Let_def using finite_Vs_union_H\<^sub>e by (rule graph_complete_graph)

thm card_vertices_ge2

lemma card_Vs_H': "card (Vs (H E)) \<noteq> 1"
  sorry

lemma Vs_f_eq_Vs_H': "Vs (f E) = Vs (H E)"
  unfolding f_def Let_def using card_Vs_H' by (intro Vs_complete_graph_eq_V)

lemma split_vertex_fE:
  assumes "v' \<in> Vs (f E)"
  obtains e u k where "v' = (e,u,k)" "u \<in> e" "e \<in> E"
proof -
  have "v' \<in> Vs (H E)"
    using assms Vs_f_eq_Vs_H' by auto
  then obtain e' where "v' \<in> e'" "e' \<in> (H E)"
    by (elim vs_member_elim)
  moreover then obtain u v where "e' \<in> H\<^sub>e u v" "{u,v} \<in> E"
    by auto
  moreover then obtain u\<^sub>1 u\<^sub>2 k\<^sub>1 k\<^sub>2 where "e' = {({u,v},u\<^sub>1,k\<^sub>1),({u,v},u\<^sub>2,k\<^sub>2)}"
    "u\<^sub>1 \<in> {u,v}" "u\<^sub>2 \<in> {u,v}"
    unfolding H\<^sub>e_def Let_def by auto
  ultimately consider "v' = ({u,v},u\<^sub>1,k\<^sub>1)" "u\<^sub>1 \<in> {u,v}" "{u,v} \<in> E"
    | "v' = ({u,v},u\<^sub>2,k\<^sub>2)" "u\<^sub>2 \<in> {u,v}" "{u,v} \<in> E"
    by auto
  thus ?thesis
    using that by cases auto
qed (* see Vs_fE_member_iff *)

text \<open>There is a Hamiltonian path from \<open>({u,v},u,1)\<close> to \<open>({u,v},u,2)\<close> in \<open>H\<^sub>e u v\<close>.\<close>

lemma hp_in_H\<^sub>e_1:
  assumes "{u,v} \<in> E"
  obtains P where "is_hp (H\<^sub>e u v) ({u,v},u,1) P ({u,v},u,2)" "cost_of_path (c\<^sub>H E) P = 11"
proof -
  let ?e="{u,v}"
  let ?P="[(?e,u,1),(?e,u,5),(?e,v,2),(?e,v,4),(?e,u,6),(?e,u,3),
    (?e,u,4),(?e,v,6),(?e,v,3),(?e,v,1),(?e,v,5),(?e,u,2)]"
  have "u \<noteq> v"
    using assms graph by auto
  moreover hence "path (H\<^sub>e u v) ?P"
    by (auto simp: Vs_def H\<^sub>e_def Let_def doubleton_eq_iff)
  ultimately have "is_hp (H\<^sub>e u v) (?e,u,1) ?P (?e,u,2)"
    by (intro is_hpI)
      (auto intro: nonempty_path_walk_between simp: Vs_def H\<^sub>e_def Let_def doubleton_eq_iff)
  moreover have "\<And>e. e \<in> set (edges_of_path ?P) \<Longrightarrow> (c\<^sub>H E) e = 1"
    using assms path_ball_edges[OF \<open>path (H\<^sub>e u v) ?P\<close>] by (simp only: c\<^sub>H.simps) auto
  moreover hence "cost_of_path (c\<^sub>H E) ?P = 11 * 1"
    by (subst const_cost_of_path) simp+
  ultimately show ?thesis
    using that by auto
qed

end

context graph_abs2
begin

lemma f_inj_aux:
  assumes "e \<in> E\<^sub>1" "e \<notin> E\<^sub>2"
  shows "f E\<^sub>1 \<noteq> f E\<^sub>2"
proof -
  obtain u v where "e = {u,v}" "u \<noteq> v"
    using assms E\<^sub>1.graph by auto
  hence "({u,v},v,1) \<in> Vs (f E\<^sub>1)" "({u,v},v,1) \<notin> Vs (f E\<^sub>2)"
    using assms E\<^sub>1.Vs_fE_member_iff E\<^sub>2.Vs_fE_member_iff by auto
  hence "Vs (f E\<^sub>1) \<noteq> Vs (f E\<^sub>2)"
    by auto
  thus ?thesis
    by (intro graph_neq_vertex)
qed

lemma f_inj:
  assumes "E\<^sub>1 \<noteq> E\<^sub>2"
  shows "f E\<^sub>1 \<noteq> f E\<^sub>2"
proof -
  consider e where "e \<in> E\<^sub>1" "e \<notin> E\<^sub>2" | e where "e \<in> E\<^sub>2" "e \<notin> E\<^sub>1"
    using assms by auto
  thus ?thesis
  proof cases
    fix e
    assume "e \<in> E\<^sub>1" "e \<notin> E\<^sub>2"
    moreover then obtain u v where "e = {u,v}" "u \<noteq> v"
      using E\<^sub>1.graph by auto
    ultimately have "({u,v},v,1) \<in> Vs (f E\<^sub>1)" "({u,v},v,1) \<notin> Vs (f E\<^sub>2)"
      using assms E\<^sub>1.Vs_fE_member_iff E\<^sub>2.Vs_fE_member_iff by auto
    hence "Vs (f E\<^sub>1) \<noteq> Vs (f E\<^sub>2)"
      by auto
    thus ?thesis
      by (intro graph_neq_vertex)
  next
    fix e
    assume "e \<notin> E\<^sub>1" "e \<in> E\<^sub>2"
    moreover then obtain u v where "e = {u,v}" "u \<noteq> v"
      using E\<^sub>2.graph by auto
    ultimately have "({u,v},v,1) \<notin> Vs (f E\<^sub>1)" "({u,v},v,1) \<in> Vs (f E\<^sub>2)"
      using assms E\<^sub>1.Vs_fE_member_iff E\<^sub>2.Vs_fE_member_iff by auto
    hence "Vs (f E\<^sub>1) \<noteq> Vs (f E\<^sub>2)"
      by auto
    thus ?thesis
      by (intro graph_neq_vertex)
  qed
qed

end

context edge_subgraph_abs
begin

lemma hp_in_fuv:
  assumes "is_hp (H\<^sub>e u v) x P y"
  shows "is_hp (f {{u,v}}) x P y"
proof -
  have "H\<^sub>e u v \<subseteq> f {{u,v}}"
    by (intro E\<^sub>2.H\<^sub>e_subset_f) auto
  moreover have "Vs (H\<^sub>e u v) = Vs (f {{u,v}})"
    by (subst E\<^sub>2.Vs_f_eq_Vs_H'; rule arg_cong[of _ _ Vs]) (auto simp: doubleton_eq_iff H\<^sub>e_symmetric)
  ultimately show ?thesis
    using assms by (rule hp_subset)
qed

lemma hp_in_H\<^sub>e_1':
  obtains P where "is_hp (f {{u,v}}) ({u,v},u,1) P ({u,v},u,2)" "cost_of_path (c\<^sub>H E) P = 11"
proof -
  obtain P where "is_hp (H\<^sub>e u v) ({u,v},u,1) P ({u,v},u,2)" "cost_of_path (c\<^sub>H E) P = 11"
    using edge by (elim hp_in_H\<^sub>e_1)
  thus ?thesis
    apply (intro that)
    apply (rule hp_in_fuv)
    apply auto
    done
qed

end

context graph_abs
begin

lemma hp_in_H\<^sub>e_1':
  assumes "{u,v} \<in> E"
  obtains P where "is_hp (f {{u,v}}) ({u,v},u,1) P ({u,v},u,2)" "cost_of_path (c\<^sub>H E) P = 11"
  apply (rule edge_subgraph_abs.hp_in_H\<^sub>e_1')
  using assms by unfold_locales

end

(* text \<open>There is a Hamiltonian path from \<open>({u,v},u,3)\<close> to \<open>({u,v},v,3)\<close> in \<open>H\<^sub>e u v\<close>.\<close>

context graph_abs
begin

lemma hp_in_H\<^sub>e_2:
  assumes "{u,v} \<in> E"
  obtains P where "is_hp (H\<^sub>e u v) ({u,v},u,3) P ({u,v},v,3)" "cost_of_path (c\<^sub>H E) P = 11"
proof -
  let ?e="{u,v}"
  let ?P="[(?e,u,3),(?e,u,2),(?e,u,1),(?e,u,6),(?e,u,5),(?e,u,4),
    (?e,v,4),(?e,v,5),(?e,v,6),(?e,v,1),(?e,v,2),(?e,v,3)]"
  have "u \<noteq> v"
    using assms graph by auto
  moreover hence "path (H\<^sub>e u v) ?P"
    by (auto simp: Vs_def H\<^sub>e_def Let_def doubleton_eq_iff)
  ultimately have "is_hp (H\<^sub>e u v) (?e,u,3) ?P (?e,v,3)"
    by (intro is_hpI)
      (auto intro: nonempty_path_walk_between simp: Vs_def H\<^sub>e_def Let_def doubleton_eq_iff)
  moreover have "\<And>e. e \<in> set (edges_of_path ?P) \<Longrightarrow> (c\<^sub>H E) e = 1"
    using assms path_ball_edges[OF \<open>path (H\<^sub>e u v) ?P\<close>] by (simp only: c\<^sub>H.simps) auto
  moreover hence "cost_of_path (c\<^sub>H E) ?P = 11 * 1"
    by (subst const_cost_of_path) simp+
  ultimately show ?thesis
    using that by auto
qed

end

context edge_subgraph_abs
begin

lemma hp_in_H\<^sub>e_2':
  obtains P where "is_hp (f {{u,v}}) ({u,v},u,3) P ({u,v},v,3)" "cost_of_path (c\<^sub>H E) P = 11"
proof -
  obtain P where "is_hp (H\<^sub>e u v) ({u,v},u,3) P ({u,v},v,3)" "cost_of_path (c\<^sub>H E) P = 11"
    using edge by (elim hp_in_H\<^sub>e_2)
  thus ?thesis
    apply (intro that)
    apply (rule hp_in_fuv)
    apply auto
    done
qed

end

context graph_abs
begin

lemma hp_in_H\<^sub>e_2':
  assumes "{u,v} \<in> E"
  obtains P where "is_hp (f {{u,v}}) ({u,v},u,3) P ({u,v},v,3)" "cost_of_path (c\<^sub>H E) P = 11"
  apply (rule edge_subgraph_abs.hp_in_H\<^sub>e_2')
  using assms by unfold_locales

lemma "\<And>P. \<not> is_hp (H\<^sub>e u v) (e,u,1) P (e,u,3)"
  sorry (* TODO: How to proof this? *)

lemma "\<And>P. \<not> is_hp (H\<^sub>e u v) (e,u,3) P (e,u,1)"
  sorry (* TODO: How to proof this? *)

end *)

locale graph_abs2_edge =
  graph_abs2 E "{{u,v}}" for E u v +
  assumes "u \<noteq> v"
begin

lemma Vs_f_inter_empty:
  assumes "{u,v} \<notin> E" (is "?e \<notin> E")
  shows "Vs (f E) \<inter> Vs (f {?e}) = {}"
proof (rule inter_emptyI)
  fix v'
  assume "v' \<in> Vs (f {?e})"
  then obtain e u k where "v' = (?e,u,k)" "u \<in> e"
    by (elim E\<^sub>2.split_vertex_fE) auto
  thus "v' \<notin> Vs (f E)"
    using assms E\<^sub>1.split_vertex_fE by auto
qed

end

context graph_abs
begin

lemma Vs_fE_inter_empty:
  assumes "u \<noteq> v" and "{u,v} \<notin> E" (is "?e \<notin> E")
  shows "Vs (f E) \<inter> Vs (f {?e}) = {}"
  using assms by (intro graph_abs2_edge.Vs_f_inter_empty; unfold_locales) (auto simp: Vs_def)

end

(* locale hp_on_partition_aux =
  graph_abs E\<^sub>x for E\<^sub>x +
  fixes x u v w P
  assumes E\<^sub>x_not_empty: "E\<^sub>x \<noteq> {}"
    and e_notin_E\<^sub>x: "{x,u} \<notin> E\<^sub>x"
    and x_neq_u: "x \<noteq> u"

    and hp_in_fE\<^sub>x: "is_hp (f E\<^sub>x) ({x,v},x,1) P ({x,w},x,2)"
    and cost_of_hp_in_fE\<^sub>x: "cost_of_path (c\<^sub>H E\<^sub>x) P = 11 * card E\<^sub>x + 4 * (card E\<^sub>x - 1)"
begin

lemma graph_xu: "graph_invar {{x,u}}"
  using x_neq_u by (auto simp: Vs_def)

sublocale xu: graph_abs "{{x,u}}"
  using graph_xu by unfold_locales

lemma graph_Ex_xu: "graph_invar (insert {x,u} E\<^sub>x)"
proof -
  have "graph_invar (\<Union> {{{x,u}}, E\<^sub>x})"
    using graph graph_xu by (intro graph_Un) auto
  thus ?thesis
    by auto
qed

sublocale Ex_xu: graph_abs "insert {x,u} E\<^sub>x"
  using graph_Ex_xu by unfold_locales

lemma hp_in_fe:
  obtains P' where "is_hp (f {{x,u}}) ({x,u},x,1) P' ({x,u},x,2)"
    and "cost_of_path (c\<^sub>H {{x,u}}) P' = 11"
  by (rule xu.hp_in_H\<^sub>e_1') auto

lemma Vs_f_union_subset:
  "Vs (f (insert {x,u} E\<^sub>x)) \<subseteq> Vs (insert {({x,w},x,2),({x,u},x,1)} (f E\<^sub>x) \<union> f {{x,u}})"
  (is "_ \<subseteq> Vs ?fE'")
proof
  fix v'
  assume "v' \<in> Vs (f (insert {x,u} E\<^sub>x))"
  hence "v' \<in> Vs (H (insert {x,u} E\<^sub>x))"
    using Ex_xu.Vs_f_eq_Vs_H' by auto
  then obtain e where "v' \<in> e" "e \<in> H (insert {x,u} E\<^sub>x)"
    by (elim vs_member_elim)
  then obtain v w where "{v,w} \<in> insert {x,u} E\<^sub>x" "e \<in> H\<^sub>e v w"
    by auto
  then consider "{v,w} = {x,u}" | "{v,w} \<in> E\<^sub>x"
    by auto
  thus "v' \<in> Vs ?fE'"
  proof cases
    assume "{v,w} = {x,u}"
    hence "e \<in> H\<^sub>e x u"
      using \<open>e \<in> H\<^sub>e v w\<close> by (auto simp: H\<^sub>e_symmetric doubleton_eq_iff)
    hence "v' \<in> Vs (H {{x,u}})"
      using \<open>v' \<in> e\<close> by (intro vs_member_intro) auto
    hence "v' \<in> Vs (f {{x,u}})"
      using xu.Vs_f_eq_Vs_H' by auto
    moreover have "Vs (f {{x,u}}) \<subseteq> Vs ?fE'"
      by (subst Vs_union) simp
    ultimately show ?thesis
      by auto
  next
    assume "{v,w} \<in> E\<^sub>x"
    hence "e \<in> H E\<^sub>x"
      using \<open>e \<in> H\<^sub>e v w\<close> by auto
    hence "v' \<in> Vs (H E\<^sub>x)"
      using \<open>v' \<in> e\<close> by (intro vs_member_intro) auto
    hence "v' \<in> Vs (f E\<^sub>x)"
      using Vs_f_eq_Vs_H' by auto
    moreover have "Vs (f E\<^sub>x) \<subseteq> Vs ?fE'"
      apply (subst(7) insert_is_Un)
      apply (subst Vs_union)
      apply (subst Vs_union)
      apply auto
      done
    ultimately show ?thesis
      by auto
  qed
qed

lemma IH_step_app:
  assumes "is_hp (f {{x,u}}) ({x,u},x,1) P' ({x,u},x,2)"
  shows "is_hp (f (insert {x,u} E\<^sub>x)) ({x,v},x,1) (P @ P') ({x,u},x,2)"
proof (rule hp_subset)
  let ?fE'="insert {({x,w},x,2),({x,u},x,1)} (f E\<^sub>x) \<union> f {{x,u}}"

  have "walk_betw (f {{x,u}}) ({x,u},x,1) P' ({x,u},x,2)"
    using assms by (elim is_hpE)
  moreover have "walk_betw (f E\<^sub>x) ({x,v},x,1) P ({x,w},x,2)"
    using hp_in_fE\<^sub>x by (elim is_hpE)
  moreover hence "({x,w},x,2) \<in> Vs (f E\<^sub>x)"
    by auto
  moreover hence "{x,w} \<in> E\<^sub>x"
    by (auto elim: split_vertex_fE)
  moreover hence "({x,w},x,2) \<noteq> ({x,u},x,1)"
    using e_notin_E\<^sub>x by auto
  ultimately show "?fE' \<subseteq> f (insert {x,u} E\<^sub>x)"
    apply (subst insert_is_Un[of "{x,u}" E\<^sub>x])
    apply (subst Un_commute[of "{{x,u}}" E\<^sub>x])
    apply (intro f_insert_union)
    apply auto
    done
  hence "Vs ?fE' \<subseteq> Vs (f (insert {x,u} E\<^sub>x))"
    by (intro Vs_subset)
  moreover have "Vs (f (insert {x,u} E\<^sub>x)) \<subseteq> Vs ?fE'"
    by (intro Vs_f_union_subset)
  ultimately show "Vs ?fE' = Vs (f (insert {x,u} E\<^sub>x))"
    by auto

  show "is_hp ?fE' ({x,v},x,1) (P @ P') ({x,u},x,2)"
  proof (rule hp_append)
    show "is_hp (f E\<^sub>x) ({x,v},x,1) P ({x,w},x,2)"
      by (rule hp_in_fE\<^sub>x)

    show "is_hp (f {{x,u}}) ({x,u},x,1) P' ({x,u},x,2)"
      by (rule assms(1))

    show "Vs (f E\<^sub>x) \<inter> Vs (f {{x,u}}) = {}"
      using e_notin_E\<^sub>x x_neq_u by (intro Vs_fE_inter_empty)
  qed
qed

lemma IH_step_cost:
  assumes "P' \<noteq> []" "cost_of_path (c\<^sub>H {{x,u}}) P' = 11"
  shows "cost_of_path (c\<^sub>H (insert {x,u} E\<^sub>x)) (P @ P')
    = 11 * card (insert {x,u} E\<^sub>x) + 4 * (card (insert {x,u} E\<^sub>x) - 1)"
proof -
  let ?c="c\<^sub>H (insert {x,u} E\<^sub>x)"

  have "cost_of_path ?c P = 11 * card E\<^sub>x + 4 * (card E\<^sub>x - 1)"
    thm cost_of_hp_in_fE\<^sub>x cost_of_path_eq_cost
    sorry

  have "?c {last P, hd P'} = 4"
    sorry

  have "cost_of_path ?c P' = 11"
    thm assms
    thm cost_of_path_eq_cost
    sorry

  have "card E\<^sub>x \<ge> 1"
    using E\<^sub>x_not_empty finite_E card_0_eq by fastforce
  moreover hence "card (insert {x,u} E\<^sub>x) - 1 = card E\<^sub>x"
    using finite_E e_notin_E\<^sub>x by auto
  ultimately have "card (insert {x,u} E\<^sub>x) > 1"
    by auto

  have "walk_betw (f E\<^sub>x) ({x,v},x,1) P ({x,w},x,2)"
    using hp_in_fE\<^sub>x by (elim is_hpE)
  hence "P \<noteq> []"
    by (elim walk_between_nonempty_path)
  hence "cost_of_path ?c (P @ P') =
    cost_of_path ?c P + ?c {last P, hd P'} + cost_of_path ?c P'"
    using assms (1) by (rule cost_of_path_append)
  also have "... = 11 * card E\<^sub>x + 4 * (card E\<^sub>x - 1) + 4 + 11"
    by (simp only: \<open>cost_of_path ?c P = 11 * card E\<^sub>x + 4 * (card E\<^sub>x - 1)\<close>
        \<open>?c {last P, hd P'} = 4\<close> \<open>cost_of_path ?c P' = 11\<close>)
  also have "... = 11 * (card E\<^sub>x + 1) + 4 * card E\<^sub>x"
    using \<open>card E\<^sub>x \<ge> 1\<close> by auto
  also have "... = 11 * card (insert {x,u} E\<^sub>x) + 4 * (card (insert {x,u} E\<^sub>x) - 1)"
    using \<open>card (insert {x,u} E\<^sub>x) - 1 = card E\<^sub>x\<close> \<open>card (insert {x,u} E\<^sub>x) > 1\<close> by auto
  finally show ?thesis .
qed

lemma IH_step:
  obtains P' where "is_hp (f (insert {x,u} E\<^sub>x)) ({x,v},x,1) P' ({x,u},x,2)"
    and "cost_of_path (c\<^sub>H (insert {x,u} E\<^sub>x)) P'
      = 11 * card (insert {x,u} E\<^sub>x) + 4 * (card (insert {x,u} E\<^sub>x) - 1)"
proof -
  obtain P' where hp_P': "is_hp (f {{x,u}}) ({x,u},x,1) P' ({x,u},x,2)"
    and "cost_of_path (c\<^sub>H {{x,u}}) P' = 11"
    by (elim hp_in_fe)
  moreover hence "walk_betw (f {{x,u}}) ({x,u},x,1) P' ({x,u},x,2)"
    by (elim is_hpE)
  moreover hence "P' \<noteq> []"
    by (elim walk_between_nonempty_path)
  ultimately show ?thesis
    using IH_step_app IH_step_cost
    apply (intro that)
    apply auto
    done
qed

end

locale graph_abs_vertex =
  graph_abs E for E +
  fixes x E\<^sub>x
  assumes E\<^sub>x_subset: "E\<^sub>x \<subseteq> {e \<in> E. x \<in> e}"
begin

lemma E\<^sub>x_subset_E: "E\<^sub>x \<subseteq> E"
  using E\<^sub>x_subset by auto

sublocale graph_subgraph_abs E E\<^sub>x
  using E\<^sub>x_subset_E by unfold_locales

lemma hp_on_E\<^sub>x:
  assumes "E\<^sub>x \<noteq> {}"
  obtains u P v where "is_hp (f E\<^sub>x) ({x,u},x,1) P ({x,v},x,2)"
    "cost_of_path (c\<^sub>H E\<^sub>x) P = 11 * card E\<^sub>x + 4 * (card E\<^sub>x - 1)"
  using finite_subset[OF E\<^sub>x_subset_E finite_E] assms E\<^sub>x_subset E\<^sub>2.graph
proof (induction E\<^sub>x arbitrary: thesis rule: finite_ne_induct)
  case (singleton e)
  then obtain u where [simp]: "e = {x,u}" and "x \<noteq> u"
    by auto
  hence "graph_abs {e}" "{x,u} \<in> {e}"
    by unfold_locales (auto simp: doubleton_eq_iff Vs_def)
  then obtain P where "is_hp (f {e}) ({x,u},x,1) P ({x,u},x,2)" "cost_of_path (c\<^sub>H {e}) P = 11"
    by (rule graph_abs.hp_in_H\<^sub>e_1') auto
  moreover hence "cost_of_path (c\<^sub>H {e}) P = 11 * card {e} + 4 * (card {e} - 1)"
    by auto
  ultimately show ?case
    by (intro singleton(1))
next
  case (insert e E\<^sub>x)

  obtain u where [simp]: "e = {x,u}" and "x \<noteq> u"
    using insert(6,7) by (auto simp: doubleton_eq_iff)

  moreover have "graph_invar E\<^sub>x"
    using insert(7) by (rule graph_subset) auto
  ultimately obtain v P w where "is_hp (f E\<^sub>x) ({x,v},x,1) P ({x,w},x,2)"
    "cost_of_path (c\<^sub>H E\<^sub>x) P = 11 * card E\<^sub>x + 4 * (card E\<^sub>x - 1)"
    using insert
    apply (elim insert.IH)
    apply unfold_locales
    apply auto
    done
  hence "hp_on_partition_aux E\<^sub>x x u v w P"
    using \<open>graph_invar E\<^sub>x\<close> insert(2,3) \<open>x \<noteq> u\<close>
    apply unfold_locales
    apply simp+
    done
  then obtain P' where "is_hp (f (insert e E\<^sub>x)) ({x,v},x,1) P' ({x,u},x,2)" and
      "cost_of_path (c\<^sub>H (insert e E\<^sub>x)) P' = 11 * card (insert e E\<^sub>x) + 4 * (card (insert e E\<^sub>x) - 1)"
    apply (simp only: \<open>e = {x,u}\<close>)
    apply (elim hp_on_partition_aux.IH_step)
    apply auto
    done
  thus ?case
    apply (intro insert(5))
    apply blast+
    done
qed

end *)

lemma hp_on_E\<^sub>x:
  assumes "finite E\<^sub>x" "E\<^sub>x \<noteq> {}" and "\<And>e. e \<in> E\<^sub>x \<Longrightarrow> x \<in> e" "graph_invar E\<^sub>x"
  obtains u P v where "is_hp (f E\<^sub>x) ({x,u},x,1) P ({x,v},x,2)"
    "cost_of_path (c\<^sub>H E\<^sub>x) P = 11 * card E\<^sub>x + 4 * (card E\<^sub>x - 1)"
  using assms
proof (induction E\<^sub>x arbitrary: thesis rule: finite_ne_induct)
  case (singleton e)
  then obtain u where [simp]: "e = {x,u}" and "x \<noteq> u"
    by auto
  hence "graph_abs {e}"
    by unfold_locales (auto simp: doubleton_eq_iff Vs_def)
  then obtain P where "is_hp (f {e}) (e,x,1) P (e,x,2)" "cost_of_path (c\<^sub>H {e}) P = 11"
    by (rule graph_abs.hp_in_H\<^sub>e_1') auto
  moreover hence "cost_of_path (c\<^sub>H {e}) P = 11 * card {e} + 4 * (card {e} - 1)"
    by auto
  ultimately show ?case
    by (intro singleton(1)) simp
next
  case (insert e E\<^sub>x)
  obtain u where [simp]: "e = {x,u}" and x_neq_u: "x \<noteq> u"
    using insert(6,7) by (auto simp: doubleton_eq_iff)
  hence graph_e: "graph_abs {e}"
    by unfold_locales (auto simp: doubleton_eq_iff Vs_def)
  then obtain P' where hp_P': "is_hp (f {e}) (e,x,1) P' (e,x,2)"
    and cost_P': "cost_of_path (c\<^sub>H {e}) P' = 11"
    by (rule graph_abs.hp_in_H\<^sub>e_1') auto
  moreover have graph_E\<^sub>x: "graph_invar E\<^sub>x"
    using insert(7) by (rule graph_subset) auto
  ultimately obtain v P w where hp_P: "is_hp (f E\<^sub>x) ({x,v},x,1) P ({x,w},x,2)"
    and cost_P: "cost_of_path (c\<^sub>H E\<^sub>x) P = 11 * card E\<^sub>x + 4 * (card E\<^sub>x - 1)"
    using insert by (elim insert.IH) auto

  let ?eE\<^sub>x="insert e E\<^sub>x"
  let ?fE'="insert {({x,w},x,2),(e,x,1)} (f E\<^sub>x) \<union> f {e}"

  have "is_hp (f ?eE\<^sub>x) ({x,v},x,1) (P @ P') (e,x,2)"
  proof (rule hp_subset)
    have "walk_betw (f {e}) (e,x,1) P' (e,x,2)"
      using hp_P' by (elim is_hpE)
    moreover have "walk_betw (f E\<^sub>x) ({x,v},x,1) P ({x,w},x,2)"
      using hp_P by (elim is_hpE)
    moreover hence "({x,w},x,2) \<in> Vs (f E\<^sub>x)"
      by auto
    moreover hence "{x,w} \<in> E\<^sub>x"
      using graph_E\<^sub>x by (intro graph_abs.Vs_fE_member_fst_edge; unfold_locales) auto
    moreover hence "({x,w},x,2) \<noteq> (e,x,1)"
      using insert(3) by auto
    ultimately show "?fE' \<subseteq> f ?eE\<^sub>x"
      apply (subst insert_is_Un[of e E\<^sub>x])
      apply (subst Un_commute[of "{e}" E\<^sub>x])
      apply (intro f_insert_union)
        apply auto
      done
    hence "Vs ?fE' \<subseteq> Vs (f ?eE\<^sub>x)"
      by (intro Vs_subset)
    moreover have "Vs (f ?eE\<^sub>x) \<subseteq> Vs ?fE'"
    proof
      fix v'
      assume "v' \<in> Vs (f ?eE\<^sub>x)"
      hence "v' \<in> Vs (H ?eE\<^sub>x)"
        apply (subst graph_abs.Vs_f_eq_Vs_H'[symmetric])
        using insert(7) apply unfold_locales
        apply auto
        done
      then obtain e' where "v' \<in> e'" "e' \<in> H ?eE\<^sub>x"
        by (elim vs_member_elim)
      then obtain v w where "{v,w} \<in> ?eE\<^sub>x" "e' \<in> H\<^sub>e v w"
        by auto
      then consider "{v,w} = {x,u}" | "{v,w} \<in> E\<^sub>x"
        by auto
      thus "v' \<in> Vs ?fE'"
      proof cases
        assume "{v,w} = {x,u}"
        hence "e' \<in> H\<^sub>e x u"
          using \<open>e' \<in> H\<^sub>e v w\<close> by (auto simp: H\<^sub>e_symmetric doubleton_eq_iff)
        hence "v' \<in> Vs (H {{x,u}})"
          using \<open>v' \<in> e'\<close> by (intro vs_member_intro) auto
        hence "v' \<in> Vs (f {e})"
          using graph_e by (auto simp: graph_abs.Vs_f_eq_Vs_H')
        moreover have "Vs (f {{x,u}}) \<subseteq> Vs ?fE'"
          by (subst Vs_union) simp
        ultimately show ?thesis
          by auto
      next
        assume "{v,w} \<in> E\<^sub>x"
        hence "e' \<in> H E\<^sub>x"
          using \<open>e' \<in> H\<^sub>e v w\<close> by auto
        hence "v' \<in> Vs (H E\<^sub>x)"
          using \<open>v' \<in> e'\<close> by (intro vs_member_intro) auto
        hence "v' \<in> Vs (f E\<^sub>x)"
          apply (subst graph_abs.Vs_f_eq_Vs_H')
          using graph_E\<^sub>x apply unfold_locales by auto
        moreover have "Vs (f E\<^sub>x) \<subseteq> Vs ?fE'"
          apply (subst(5) insert_is_Un)
          apply (subst Vs_union)
          apply (subst Vs_union)
          apply auto
          done
        ultimately show ?thesis
          by auto
      qed
    qed
    ultimately show "Vs ?fE' = Vs (f ?eE\<^sub>x)"
      by auto

    show "is_hp ?fE' ({x,v},x,1) (P @ P') (e,x,2)"
      using hp_P hp_P'
      apply (rule hp_append)
      apply simp
      using graph_E\<^sub>x insert(3) x_neq_u
      apply (intro graph_abs.Vs_fE_inter_empty)
      apply unfold_locales
      apply auto
      done
  qed
  moreover have "cost_of_path (c\<^sub>H ?eE\<^sub>x) (P @ P') = 11 * card ?eE\<^sub>x + 4 * (card ?eE\<^sub>x - 1)"
    sorry (* TODO: need executable graph-model! *)
  ultimately show ?case
    apply (intro insert(5))
    apply simp
    apply blast
    done
qed

context graph_abs
begin

lemma hp_on_E\<^sub>x:
  assumes "E\<^sub>x \<noteq> {}" and E\<^sub>x_subset_E: "E\<^sub>x \<subseteq> {e \<in> E. x \<in> e}"
  obtains u P v where "is_hp (f E\<^sub>x) ({x,u},x,1) P ({x,v},x,2)"
    "cost_of_path (c\<^sub>H E\<^sub>x) P = 11 * card E\<^sub>x + 4 * (card E\<^sub>x - 1)"
proof (rule hp_on_E\<^sub>x)
  show "finite E\<^sub>x"
    using assms finite_E by (intro finite_subset[OF E\<^sub>x_subset_E]) auto
  show "E\<^sub>x \<noteq> {}" "\<And>e. e \<in> E\<^sub>x \<Longrightarrow> x \<in> e"
    using assms by auto
  show "graph_invar E\<^sub>x"
    using graph apply (rule graph_subset) using assms by auto
qed

lemma
  assumes "is_vc E X"
  obtains T where "is_hc (H E) T" "cost_of_path (c\<^sub>H E) T = 15 * card E + card X"
proof cases
  assume "E = {}"
  show ?thesis
    sorry
next
  assume "E \<noteq> {}" (* TODO: How do I obtain a partition of E? \<rightarrow> executable graph model! *)
  show ?thesis
    sorry
qed

lemma
  assumes opt_vc: "is_min_vc E OPT\<^sub>V\<^sub>C"
      and opt_mtsp: "is_tsp (H E) (c\<^sub>H E) OPT\<^sub>m\<^sub>T\<^sub>S\<^sub>P"
  shows "cost_of_path (c\<^sub>H E) OPT\<^sub>m\<^sub>T\<^sub>S\<^sub>P \<le> 15 * card E + card OPT\<^sub>V\<^sub>C"
  sorry

lemma
  assumes "is_hc (H E) T"
  obtains u P v where "is_hp (H E) u P v" "cost_of_path (c\<^sub>H E) P \<le> 0"
  sorry (* TODO: How do I formalize: contains a Hamiltonian path of each subgraph H\<^sub>e? *)

lemma
  assumes "is_hc (H E) T" "cost_of_path (c\<^sub>H E) T = 15 * card E + k"
  obtains X where "is_vc E X" "card x = k"
  sorry

end

(* ----- 1st condition for a L-reduction ----- *)

text \<open>\<open>(H,c\<^sub>H)\<close> is an instance of mTSP.\<close>
lemma "is_complete (H E)"
  sorry

lemma "(c\<^sub>H E) e \<ge> 0"
  sorry

lemma
  assumes "u \<in> Vs (H E)" "v \<in> Vs (H E)" "w \<in> Vs (H E)"
  shows "(c\<^sub>H E) {u,w} \<le> (c\<^sub>H E) {u,v} + (c\<^sub>H E) {v,w}"
  sorry

lemma l_reduction1:
  assumes opt_vc: "is_min_vc E OPT\<^sub>V\<^sub>C"
      and opt_mtsp: "is_tsp (f E) (c\<^sub>H E) OPT\<^sub>m\<^sub>T\<^sub>S\<^sub>P"
  shows "cost_of_path (c\<^sub>H E) OPT\<^sub>m\<^sub>T\<^sub>S\<^sub>P \<le> 61 * card OPT\<^sub>V\<^sub>C" (is "?c' OPT\<^sub>m\<^sub>T\<^sub>S\<^sub>P \<le> ?\<alpha> * ?c OPT\<^sub>V\<^sub>C")
  sorry

(* ----- 2nd condition for a L-reduction ----- *)

text \<open>The function \<open>g\<close> maps a feasible solution of mTSP to a feasible solution of VC4.\<close>
lemma
  assumes "is_hc H T"
  shows "is_vc E (set (g T))"
  sorry

lemma l_reduction2:
  assumes opt_vc: "is_min_vc E OPT\<^sub>V\<^sub>C"
      and opt_mtsp: "is_tsp H c\<^sub>H OPT\<^sub>m\<^sub>T\<^sub>S\<^sub>P"
      and "is_hc H T"
  shows "\<bar> int (card (set (g T))) - int (card OPT\<^sub>V\<^sub>C) \<bar>
    \<le> 1 * \<bar> int (cost_of_path c\<^sub>H T) - int (cost_of_path c\<^sub>H OPT\<^sub>m\<^sub>T\<^sub>S\<^sub>P) \<bar>"
    (is "\<bar> ?c (set (g T)) - ?c OPT\<^sub>V\<^sub>C \<bar> \<le> ?\<beta> * \<bar> ?c' T - ?c' OPT\<^sub>m\<^sub>T\<^sub>S\<^sub>P \<bar>")
  sorry

(* ----- executable refinement ----- *)

(* TODO *)

end


(*  Title:       Deriving class instances for datatypes
    Author:      Christian Sternagel and René Thiemann  <christian.sternagel|rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)
subsection \<open>Compare\<close>

theory Compare
imports Comparator
keywords "compare_code" :: thy_decl
begin

text \<open>This introduces a type class for having a proper comparator, similar to @{class linorder}.
  Since most of the Isabelle/HOL algorithms work on the latter, we also provide a method which
  turns linear-order based algorithms into comparator-based algorithms, where two consecutive
  invocations of linear orders and equality are merged into one comparator invocation.
  We further define a class which both define a linear order and a comparator, and where the
  induces orders coincide.\<close>

class compare =
  fixes compare :: "'a comparator"
  assumes comparator_compare: "comparator compare"
begin

lemma compare_Eq_is_eq [simp]:
  "compare x y = Eq \<longleftrightarrow> x = y"
  by (rule comparator.eq [OF comparator_compare])

lemma compare_refl [simp]:
  "compare x x = Eq"
  by simp

end

lemma (in linorder) le_lt_comparator_of:
  "le_of_comp comparator_of = (\<le>)" "lt_of_comp comparator_of = (<)"
  by (intro ext, auto simp: comparator_of_def le_of_comp_def lt_of_comp_def)+

class compare_order = ord + compare +
  assumes ord_defs: "le_of_comp compare = (\<le>) " "lt_of_comp compare = (<)"

text \<open> @{class compare_order} is @{class compare} and @{class linorder}, where comparator and orders
  define the same ordering.\<close>

subclass (in compare_order) linorder
  by (unfold ord_defs[symmetric], rule comparator.linorder, rule comparator_compare)

context compare_order
begin

lemma compare_is_comparator_of:
  "compare = comparator_of"
proof (intro ext)
  fix x y :: 'a
  show "compare x y = comparator_of x y"
    by  (unfold comparator_of_def, unfold ord_defs[symmetric] lt_of_comp_def,
      cases "compare x y", auto)
qed

lemmas two_comparisons_into_compare =
  comparator.two_comparisons_into_case_order[OF comparator_compare, unfolded ord_defs]

thm two_comparisons_into_compare
end

ML_file \<open>compare_code.ML\<close>

text \<open>\<open>Compare_Code.change_compare_code const ty-vars\<close> changes the code equations of some constant such that
  two consecutive comparisons via @{term "(<=)"}, @{term "(<)"}", or @{term "(=)"} are turned into one
  invocation of @{const compare}.
  The difference to a standard \<open>code_unfold\<close> is that here we change the code-equations
  where an additional sort-constraint on @{class compare_order} can be added. Otherwise, there would
  be no @{const compare}-function.\<close>

end


(*
  Theory: PDF_Transformations.thy
  Author: Manuel Eberl

  Provides lemmas for transformations of measure spaces with a density.
*)

header {* Measure Space Transformations *}

theory PDF_Transformations
imports Density_Predicates Lebesgue_Integral_Substitution PDF_Misc
begin

lemma Int_stable_Icc: "Int_stable (range (\<lambda>(a, b). {a .. b::real}))"
  by (auto simp: Int_stable_def)

lemma distr_mult_real:
  assumes "c \<noteq> 0" "has_density M lborel (f :: real \<Rightarrow> ereal)"
  shows "has_density (distr M borel (op * c)) lborel (\<lambda>x. f (x / c) * inverse (abs c))"
            (is "has_density ?M' _ ?f'")
proof
  from assms(2) have "M = density lborel f" by (rule has_densityD)
  also from assms have Mf: "f \<in> borel_measurable borel"
    by (auto dest: has_densityD)
  hence "distr (density lborel f) borel (op * c) = density lborel ?f'" (is "?M1 = ?M2")
  proof (intro measure_eqI)
    fix X assume X: "X \<in> sets (distr (density lborel f) borel (op * c))"
    with assms have "emeasure ?M1 X = \<integral>\<^sup>+x. f x * indicator X (c * x) \<partial>lborel"
      by (subst emeasure_distr, simp, simp, subst emeasure_density)
         (auto dest: has_densityD intro!: measurable_sets_borel nn_integral_cong
               split: split_indicator)
    also from assms(1) and X have "... = \<integral>\<^sup>+x. ?f' x * indicator X x \<partial>lborel"
      apply (subst lborel_distr_mult'[of "inverse c"], simp, subst nn_integral_density)
      apply (auto intro!: borel_measurable_ereal_times Mf) [4]
      apply (subst nn_integral_distr)
      apply (auto intro!: borel_measurable_ereal_times Mf simp: field_simps)
      done
    also from X have "... = emeasure ?M2 X"
      by (subst emeasure_density)
         (auto intro!: measurable_compose[OF borel_measurable_divide Mf]
                       borel_measurable_ereal_times)
    finally show "emeasure ?M1 X = emeasure ?M2 X" .
  qed simp
  finally show "distr M borel (op * c) = density lborel ?f'" .
qed (insert assms, auto dest: has_densityD intro!: ereal_0_le_mult)

lemma distr_uminus_real:
  assumes "has_density M lborel (f :: real \<Rightarrow> ereal)"
  shows "has_density (distr M borel uminus) lborel (\<lambda>x. f (- x))"
proof-
  from assms have "has_density (distr M borel (op * (- 1))) lborel
                       (\<lambda>x. f (x / -1) * ereal (inverse (abs (-1))))"
    by (intro distr_mult_real) simp_all
  also have "op * (-1) = (uminus :: real \<Rightarrow> real)" by (intro ext) simp
  also have "(\<lambda>x. f (x / -1) * ereal (inverse (abs (-1)))) = (\<lambda>x. f (-x))"
    by (intro ext) (simp add: one_ereal_def[symmetric])
  finally show ?thesis .
qed

lemma distr_plus_real:
  assumes "has_density M lborel (f :: real \<Rightarrow> ereal)"
  shows "has_density (distr M borel (op + c)) lborel (\<lambda>x. f (x - c))"
proof
  from assms have "M = density lborel f" by (rule has_densityD)
  also from assms have Mf: "f \<in> borel_measurable borel"
    by (auto dest: has_densityD)
  hence "distr (density lborel f) borel (op + c) = density lborel (\<lambda>x. f (x - c))" (is "?M1 = ?M2")
  proof (intro measure_eqI)
    fix X assume X: "X \<in> sets (distr (density lborel f) borel (op + c))"
    with assms have "emeasure ?M1 X = \<integral>\<^sup>+x. f x * indicator X (c + x) \<partial>lborel"
      by (subst emeasure_distr, simp, simp, subst emeasure_density)
         (auto dest: has_densityD intro!: measurable_sets_borel nn_integral_cong
               split: split_indicator)
    also from X have "... = \<integral>\<^sup>+x. f (x - c) * indicator X x \<partial>lborel"
      by (subst lborel_distr_plus[where c = "-c", symmetric], subst nn_integral_distr)
          (auto intro!: borel_measurable_ereal_times Mf
                measurable_compose[OF borel_measurable_uminus borel_measurable_indicator])
    also from X have "... = emeasure ?M2 X"
      by (subst emeasure_density)
         (auto simp: emeasure_density intro!: measurable_compose[OF borel_measurable_diff Mf])
    finally show "emeasure ?M1 X = emeasure ?M2 X" .
  qed simp
  finally show "distr M borel (op + c) = density lborel (\<lambda>x. f (x - c))" .
qed (insert assms, auto dest: has_densityD)

lemma count_space_uminus:
  "count_space UNIV = distr (count_space UNIV) (count_space UNIV) (uminus :: ('a :: ring \<Rightarrow> _))"
proof-
  have "surj (uminus :: 'a \<Rightarrow> 'a)"
  proof (rule surjI)
    fix x :: 'a show "- (- x) = x" by simp
  qed
  hence A: "(UNIV :: 'a set) = uminus ` UNIV" ..
  also have "count_space ... = distr (count_space UNIV) (count_space UNIV) uminus"
    by (subst count_space_image) (auto simp: A[symmetric] intro!: injI)
  finally show ?thesis .
qed

lemma count_space_plus:
  "count_space UNIV = distr (count_space UNIV) (count_space UNIV) (op + (c :: ('a :: ring)))"
proof-
  have "surj (op + c)"
  proof (rule surjI)
    fix x :: 'a show "c + (x - c) = x" by simp
  qed
  hence A: "(UNIV :: 'a set) = op + c ` UNIV" ..
  also have "count_space ... = distr (count_space UNIV) (count_space UNIV) (op + c)"
    by (subst count_space_image) (auto simp: A[symmetric] intro!: injI)
  finally show ?thesis .
qed

lemma distr_uminus_ring_count_space:
  assumes "has_density M (count_space UNIV) (f :: _ :: ring \<Rightarrow> ereal)"
  shows "has_density (distr M (count_space UNIV) uminus) (count_space UNIV) (\<lambda>x. f (- x))"
proof
  from assms have "M = density (count_space UNIV) f" by (rule has_densityD)
  also have "distr (density (count_space UNIV) f) (count_space UNIV) uminus =
               density (count_space UNIV)(\<lambda>x. f (- x))" (is "?M1 = ?M2")
  proof (intro measure_eqI)
    fix X assume X: "X \<in> sets (distr (density (count_space UNIV) f) (count_space UNIV) uminus)"
    with assms have "emeasure ?M1 X = \<integral>\<^sup>+x. f x * indicator X (-x) \<partial>count_space UNIV"
      by (subst emeasure_distr, simp, simp, subst emeasure_density)
         (auto dest: has_densityD intro!: measurable_sets_borel nn_integral_cong
               split: split_indicator)
    also from X have "... = emeasure ?M2 X"
      by (subst count_space_uminus) (simp_all add: nn_integral_distr emeasure_density)
    finally show "emeasure ?M1 X = emeasure ?M2 X" .
  qed simp
  finally show "distr M (count_space UNIV) uminus = density (count_space UNIV) (\<lambda>x. f (- x))" .
qed (insert assms, auto dest: has_densityD)

lemma distr_plus_ring_count_space:
  assumes "has_density M (count_space UNIV) (f :: _ :: ring \<Rightarrow> ereal)"
  shows "has_density (distr M (count_space UNIV) (op + c)) (count_space UNIV) (\<lambda>x. f (x - c))"
proof
  from assms have "M = density (count_space UNIV) f" by (rule has_densityD)
  also have "distr (density (count_space UNIV) f) (count_space UNIV) (op + c) =
               density (count_space UNIV)(\<lambda>x. f (x - c))" (is "?M1 = ?M2")
  proof (intro measure_eqI)
    fix X assume X: "X \<in> sets (distr (density (count_space UNIV) f) (count_space UNIV) (op + c))"
    with assms have "emeasure ?M1 X = \<integral>\<^sup>+x. f x * indicator X (c + x) \<partial>count_space UNIV"
      by (subst emeasure_distr, simp, simp, subst emeasure_density)
         (auto dest: has_densityD intro!: measurable_sets_borel nn_integral_cong
               split: split_indicator)
    also from X have "... = emeasure ?M2 X"
      by (subst count_space_plus[of "-c"]) (simp_all add: nn_integral_distr emeasure_density)
    finally show "emeasure ?M1 X = emeasure ?M2 X" .
  qed simp
  finally show "distr M (count_space UNIV) (op + c) = density (count_space UNIV) (\<lambda>x. f (x - c))" .
qed (insert assms, auto dest: has_densityD)

lemma subprob_density_distr_real_eq:
  assumes dens: "has_subprob_density M lborel f"
  assumes Mh: "h \<in> borel_measurable borel"
  assumes Mg: "g \<in> borel_measurable borel"
  assumes nonneg_g: "\<And>x. g x \<ge> 0"
  assumes measure_eq:
    "\<And>a b. a \<le> b \<Longrightarrow> emeasure (distr (density lborel f) lborel h) {a..b} =
                          emeasure (density lborel g) {a..b}"
  shows "has_subprob_density (distr M lborel (h :: real \<Rightarrow> real)) lborel g"
proof (rule has_subprob_densityI)
  from dens have sets_M: "sets M = sets borel" by (auto dest: has_subprob_densityD)
  have meas_M[simp]: "measurable M = measurable borel"
    by (intro ext, subst measurable_cong_sets[OF sets_M refl]) auto
  from Mh and dens show subprob_space: "subprob_space (distr M lborel h)"
    by (intro subprob_space.subprob_space_distr) (auto dest: has_subprob_densityD)
  show "distr M lborel h = density lborel g"
  proof (rule measure_eqI_generator_eq[OF Int_stable_Icc, of UNIV])
    {
      fix x :: real
      obtain n :: nat where "n > abs x" using reals_Archimedean2 by auto
      hence "\<exists>n::nat. x \<in> {-real n..real n}" by (intro exI[of _ n]) auto
    }
    thus "(\<Union>i::nat. {-real i..real i}) = UNIV" by blast
  next
    fix i :: nat
    from subprob_space have "emeasure (distr M lborel h) {-real i..real i} \<le> 1"
      by (intro subprob_space.subprob_measure_le_1) (auto dest: has_subprob_densityD)
    thus "emeasure (distr M lborel h) {- real i..real i} \<noteq> \<infinity>" by auto
  next
    fix X :: "real set" assume "X \<in> range (\<lambda>(a,b). {a..b})"
    then obtain a b where "X = {a..b}" by auto
    with dens show "emeasure (distr M lborel h) X = emeasure (density lborel g) X"
      by (cases "a \<le> b") (auto simp: measure_eq dest: has_subprob_densityD)
  qed (auto simp: borel_eq_atLeastAtMost)
qed (insert assms, auto)

lemma subprob_density_distr_real_exp:
  assumes dens: "has_subprob_density M lborel f"
  shows "has_subprob_density (distr M borel exp) lborel
           (\<lambda>x. if x > 0 then f (ln x) * inverse x else 0)"
           (is "has_subprob_density _ _ ?g")
proof (simp only: distr_lborel[symmetric], rule subprob_density_distr_real_eq[OF dens])
  fix x from dens show "?g x \<ge> 0" by (auto intro!: ereal_0_le_mult dest: has_subprob_densityD)
next
  from dens have Mg': "(\<lambda>x. f (ln x) * ereal (inverse x)) \<in> borel_measurable borel"
    by (intro borel_measurable_ereal_times borel_measurable_ereal
              measurable_compose[OF borel_measurable_ln]) (auto dest: has_subprob_densityD)
  thus Mg: "?g \<in> borel_measurable borel" by (intro measurable_If) simp_all
  from dens have Mf: "f \<in> borel_measurable borel" by (auto dest: has_subprob_densityD)

  fix a b :: real assume "a \<le> b"

  let ?A = "\<lambda>i. {inverse (Suc i) :: real ..}"
  let ?M1 = "distr (density lborel f) lborel exp" and ?M2 = "density lborel ?g"
  {
    fix x :: real assume "\<forall>i. x < inverse (Suc i)"
    hence "x \<le> 0" by (intro tendsto_le_const[OF _ LIMSEQ_inverse_real_of_nat])
                     (auto intro!: always_eventually less_imp_le)
  }
  hence decomp: "{a..b} = {x\<in>{a..b}. x \<le> 0} \<union> (\<Union>i. ?A i \<inter> {a..b})" (is "_ = ?C \<union> ?D")
    by (auto simp: not_le)
  have inv_le: "\<And>x i. x \<ge> inverse (real (Suc i)) \<Longrightarrow> \<not>(x \<le> 0)"
    by (subst not_le, erule dual_order.strict_trans1, simp)
  hence "emeasure ?M1 {a..b} = emeasure ?M1 ?C + emeasure ?M1 ?D"
    by (subst decomp, intro plus_emeasure[symmetric]) auto
  also have "emeasure ?M1 ?C = 0" by (subst emeasure_distr) auto
  also have "0 = emeasure ?M2 ?C"
    by (subst emeasure_density, simp add: Mg, simp, rule sym, subst nn_integral_0_iff)
       (auto intro!: borel_measurable_ereal_times measurable_If measurable_compose[OF _ Mf])
  also have "emeasure ?M1 (\<Union>i. ?A i \<inter> {a..b}) = (SUP i. emeasure ?M1 (?A i \<inter> {a..b}))"
    by (rule SUP_emeasure_incseq[symmetric])
       (auto simp: incseq_def max_def not_le dest: order.strict_trans1)
  also have "\<And>i. emeasure ?M1 (?A i \<inter> {a..b}) = emeasure ?M2 (?A i \<inter> {a..b})"
  proof (case_tac "inverse (Suc i) \<le> b")
    fix i assume True: "inverse (Suc i) \<le> b"
    let ?a = "inverse (Suc i)"
    from `a \<le> b` have A: "?A i \<inter> {a..b} = {max ?a a..b}" (is "?E = ?F") by auto
    hence "emeasure ?M1 ?E = emeasure ?M1 ?F" by simp
    also have "strict_mono_on ln {max (inverse (real (Suc i))) a..b}"
      by (rule strict_mono_onI, subst ln_less_cancel_iff) (auto dest: inv_le)
    with `a \<le> b` True dens
      have "emeasure ?M1 ?F = emeasure (density lborel (\<lambda>x. f (ln x) * inverse x)) ?F"
      by (intro emeasure_density_distr_interval)
         (auto simp: Mf not_less not_le range_exp dest: has_subprob_densityD dest!: inv_le
               intro!: DERIV_ln continuous_on_inverse continuous_on_id)
    also note A[symmetric]
    also have "emeasure (density lborel (\<lambda>x. f (ln x) * inverse x)) ?E = emeasure ?M2 ?E"
      by (subst (1 2) emeasure_density)
         (auto simp: Mg Mg' intro!: nn_integral_cong split: split_indicator dest!: inv_le)
    finally show "emeasure ?M1 (?A i \<inter> {a..b}) = emeasure ?M2 (?A i \<inter> {a..b})" .
  qed simp
  hence "(SUP i. emeasure ?M1 (?A i \<inter> {a..b})) = (SUP i. emeasure ?M2 (?A i \<inter> {a..b}))" by simp
  also have "... = emeasure ?M2 (\<Union>i. ?A i \<inter> {a..b})"
    by (rule SUP_emeasure_incseq)
       (auto simp: incseq_def max_def not_le dest: order.strict_trans1)
  also have "emeasure ?M2 ?C + emeasure ?M2 ?D = emeasure ?M2 (?C \<union> ?D)"
    by (rule plus_emeasure) (auto dest: inv_le)
  also note decomp[symmetric]
  finally show "emeasure ?M1 {a..b} = emeasure ?M2 {a..b}" .
qed simp

lemma subprob_density_distr_real_inverse_aux:
  assumes dens: "has_subprob_density M lborel f"
  shows "has_subprob_density (distr M lborel (\<lambda>x. - inverse x)) lborel
              (\<lambda>x. f (-inverse x) * ereal (inverse (x * x)))"
           (is "has_subprob_density _ _ ?g")
proof (rule subprob_density_distr_real_eq[OF dens])
  fix x from dens show "?g x \<ge> 0"
    by (auto intro!: ereal_0_le_mult dest: has_subprob_densityD simp: field_simps)
next
  from dens have Mf[measurable]: "f \<in> borel_measurable borel" by (auto dest: has_subprob_densityD)
  show Mg: "?g \<in> borel_measurable borel" by measurable

  have surj[simp]: "surj (\<lambda>x. - inverse x :: real)"
    by (intro surjI[of _ "\<lambda>x. - inverse x"]) (simp add: field_simps)
  fix a b :: real assume "a \<le> b"
  let ?A1 = "\<lambda>i. {..-inverse (Suc i) :: real}" and  ?A2 = "\<lambda>i. {inverse (Suc i) :: real ..}"
  let ?C = "if 0 \<in> {a..b} then {0} else {}"
  let ?M1 = "distr (density lborel f) lborel (\<lambda>x. - inverse x)" and ?M2 = "density lborel ?g"
  have inv_le: "\<And>x i. x \<ge> inverse (real (Suc i)) \<Longrightarrow> \<not>(x \<le> 0)"
    by (subst not_le, erule dual_order.strict_trans1, simp)
  have "\<And>x. x > 0 \<Longrightarrow> \<exists>i. x \<ge> inverse (Suc i)"
  proof (rule ccontr)
    fix x :: real assume "x > 0" "\<not>(\<exists>i. x \<ge> inverse (Suc i))"
    hence "x \<le> 0" by (intro tendsto_le_const[OF _ LIMSEQ_inverse_real_of_nat])
                      (auto intro!: always_eventually less_imp_le simp: not_le)
    with `x > 0` show False by simp
  qed
  hence A: "(\<Union>i. ?A2 i) = {0<..}" by (auto dest: inv_le)
  moreover have "\<And>x. x < 0 \<Longrightarrow> \<exists>i. x \<le> -inverse (Suc i)"
  proof (rule ccontr)
    fix x :: real assume "x < 0" "\<not>(\<exists>i. x \<le> -inverse (Suc i))"
    hence "x \<ge> 0"
      by (intro tendsto_ge_const[of sequentially], simp)
         (auto intro!: always_eventually less_imp_le LIMSEQ_inverse_real_of_nat_add_minus simp: not_le)
    with `x < 0` show False by simp
  qed
  hence B: "(\<Union>i. ?A1 i) = {..<0}" by (auto simp: le_minus_iff[of _ "inverse x" for x] dest!: inv_le)
  ultimately have C: "UNIV = (\<Union>i. ?A1 i) \<union> (\<Union>i. ?A2 i) \<union> {0}" by (subst A, subst B) force
  have UN_Int_distrib: "\<And>f A. (\<Union>i. f i) \<inter> A = (\<Union>i. f i \<inter> A)" by blast
  have decomp: "{a..b} = (\<Union>i. ?A1 i \<inter> {a..b}) \<union> (\<Union>i. ?A2 i \<inter> {a..b}) \<union> ?C" (is "_ = ?D \<union> ?E \<union> _")
    by (subst Int_UNIV_left[symmetric], simp only: C Int_Un_distrib2 UN_Int_distrib)
       (simp split: split_if)
  have "emeasure ?M1 {a..b} = emeasure ?M1 ?D + emeasure ?M1 ?E + emeasure ?M1 ?C"
    apply (subst decomp)
    apply (subst plus_emeasure[symmetric], simp, simp, simp)
    apply (subst plus_emeasure[symmetric])
    apply (auto dest!: inv_le simp: not_le le_minus_iff[of _ "inverse x" for x])
    done
  also have "(\<lambda>x. - inverse x) -` {0 :: real} = {0}" by (auto simp: field_simps)
  hence "emeasure ?M1 ?C = 0"
    by (subst emeasure_distr)  (auto split: split_if simp: emeasure_density Mf)
  also have "emeasure ?M2 {0} = 0" by (simp add: emeasure_density)
  hence "0 = emeasure ?M2 ?C"
    by (rule_tac sym, rule_tac order.antisym, rule_tac order.trans, rule_tac emeasure_mono[of _ "{0}"]) simp_all
  also have "emeasure ?M1 (\<Union>i. ?A1 i \<inter> {a..b}) = (SUP i. emeasure ?M1 (?A1 i \<inter> {a..b}))"
    by (rule SUP_emeasure_incseq[symmetric])
       (auto simp: incseq_def max_def not_le dest: order.strict_trans1)
  also have "\<And>i. emeasure ?M1 (?A1 i \<inter> {a..b}) = emeasure ?M2 (?A1 i \<inter> {a..b})"
  proof (case_tac "-inverse (Suc i) \<ge> a")
    fix i assume True: "-inverse (Suc i) \<ge> a"
    let ?a = "-inverse (Suc i)"
    from `a \<le> b` have A: "?A1 i \<inter> {a..b} = {a..min ?a b}" (is "?F = ?G") by auto
    hence "emeasure ?M1 ?F = emeasure ?M1 ?G" by simp
    also have "strict_mono_on (\<lambda>x. -inverse x) {a..min ?a b}"
      by (rule strict_mono_onI) (auto simp: le_minus_iff[of _ "inverse x" for x] dest!: inv_le)
    with `a \<le> b` True dens
      have "emeasure ?M1 ?G = emeasure ?M2 ?G"
      by (intro emeasure_density_distr_interval)
         (auto simp: Mf not_less dest: has_subprob_densityD inv_le
               intro!: DERIV_neg_inverse'' continuous_on_mult continuous_on_inverse continuous_on_id)
    also note A[symmetric]
    finally show "emeasure ?M1 (?A1 i \<inter> {a..b}) = emeasure ?M2 (?A1 i \<inter> {a..b})" .
  qed simp
  hence "(SUP i. emeasure ?M1 (?A1 i \<inter> {a..b})) = (SUP i. emeasure ?M2 (?A1 i \<inter> {a..b}))" by simp
  also have "... = emeasure ?M2 (\<Union>i. ?A1 i \<inter> {a..b})"
    by (rule SUP_emeasure_incseq)
       (auto simp: incseq_def max_def not_le dest: order.strict_trans1)
  also have "emeasure ?M1 (\<Union>i. ?A2 i \<inter> {a..b}) = (SUP i. emeasure ?M1 (?A2 i \<inter> {a..b}))"
    by (rule SUP_emeasure_incseq[symmetric])
       (auto simp: incseq_def max_def not_le dest: order.strict_trans1)
  also have "\<And>i. emeasure ?M1 (?A2 i \<inter> {a..b}) = emeasure ?M2 (?A2 i \<inter> {a..b})"
  proof (case_tac "inverse (Suc i) \<le> b")
    fix i assume True: "inverse (Suc i) \<le> b"
    let ?a = "inverse (Suc i)"
    from `a \<le> b` have A: "?A2 i \<inter> {a..b} = {max ?a a..b}" (is "?F = ?G") by auto
    hence "emeasure ?M1 ?F = emeasure ?M1 ?G" by simp
    also have "strict_mono_on (\<lambda>x. -inverse x) {max ?a a..b}"
      by (rule strict_mono_onI) (auto dest!: inv_le simp: not_le)
    with `a \<le> b` True dens
      have "emeasure ?M1 ?G = emeasure ?M2 ?G"
      by (intro emeasure_density_distr_interval)
         (auto simp: Mf not_less dest: has_subprob_densityD inv_le
               intro!: DERIV_neg_inverse'' continuous_on_mult continuous_on_inverse continuous_on_id)
    also note A[symmetric]
    finally show "emeasure ?M1 (?A2 i \<inter> {a..b}) = emeasure ?M2 (?A2 i \<inter> {a..b})" .
  qed simp
  hence "(SUP i. emeasure ?M1 (?A2 i \<inter> {a..b})) = (SUP i. emeasure ?M2 (?A2 i \<inter> {a..b}))" by simp
  also have "... = emeasure ?M2 (\<Union>i. ?A2 i \<inter> {a..b})"
    by (rule SUP_emeasure_incseq)
       (auto simp: incseq_def max_def not_le dest: order.strict_trans1)
  also have "emeasure ?M2 ?D + emeasure ?M2 ?E + emeasure ?M2 ?C = emeasure ?M2 {a..b}"
    apply (subst (4) decomp)
    apply (subst plus_emeasure, simp, simp)
    apply (auto dest!: inv_le simp: not_le le_minus_iff[of _ "inverse x" for x]) []
    apply (subst plus_emeasure)
    apply (auto dest!: inv_le simp: not_le le_minus_iff[of _ "inverse x" for x])
    done
  finally show "emeasure ?M1 {a..b} = emeasure ?M2 {a..b}" .
qed simp

lemma subprob_density_distr_real_inverse:
  assumes dens: "has_subprob_density M lborel f"
  shows "has_subprob_density (distr M borel inverse) lborel
              (\<lambda>x. f (inverse x) * ereal (inverse (x * x)))"
proof (unfold has_subprob_density_def, intro conjI)
  let ?g' = "(\<lambda>x. f (-inverse x) * ereal (inverse (x * x)))"
  have prob: "has_subprob_density (distr M lborel (\<lambda>x. -inverse x)) lborel ?g'"
    by (rule subprob_density_distr_real_inverse_aux[OF assms])
  from assms have sets_M: "sets M = sets borel" by (auto dest: has_subprob_densityD)
  have [simp]: "measurable M = measurable borel"
    by (intro ext, subst measurable_cong_sets[OF sets_M refl]) auto
  from prob have dens: "has_density (distr M lborel (\<lambda>x. -inverse x)) lborel
                 (\<lambda>x. f (-inverse x) * ereal (inverse (x * x)))"
    unfolding has_subprob_density_def by simp
  from distr_uminus_real[OF this]
    show "has_density (distr M borel inverse) lborel
              (\<lambda>x. f (inverse x) * ereal (inverse (x * x)))"
    by (simp add: distr_distr o_def distr_lborel cong: distr_cong)
  show "subprob_space (distr M borel inverse)"
    by (intro subprob_space.subprob_space_distr has_subprob_densityD[OF assms]) simp_all
qed

  from assms have sets_M: "sets M = sets borel" by (auto dest: has_densityD)
  hence [simp]: "space M = UNIV" by (subst sets_eq_imp_space_eq[OF sets_M]) simp
  from sets_M have [simp]: "measurable M = measurable borel"
    by (intro ext measurable_cong_sets) simp_all
  have M_add: "split op+ \<in> borel_measurable (borel :: (real \<times> real) measure)"
    by (simp add: borel_prod'[symmetric])

  show "distr M borel (split op+) = density lborel ?f'"
  proof (rule measure_eqI)
    fix X :: "real set" assume X: "X \<in> sets (distr M borel (split op+))"
    hence "emeasure (distr M borel (split op+)) X = emeasure M ((\<lambda>(x, y). x + y) -` X)"
      by (simp_all add: M_add emeasure_distr)
    also from X have "... = \<integral>\<^sup>+z. f z * indicator ((\<lambda>(x, y). x + y) -` X) z \<partial>(lborel \<Otimes>\<^sub>M lborel)"
      by (simp add: emeasure_density has_densityD[OF assms]
                     measurable_sets_borel[OF M_add] lborel_prod)
    also have "... = \<integral>\<^sup>+x. \<integral>\<^sup>+y. f (x, y) * indicator ((\<lambda>(x, y). x + y) -` X) (x,y) \<partial>lborel \<partial>lborel"
      apply (rule lborel.nn_integral_fst[symmetric])
      apply (rule borel_measurable_ereal_times, simp add: Mf lborel_prod)
      apply (rule borel_measurable_indicator, simp only: lborel_prod sets_lborel)
      apply (insert X, simp add: measurable_sets_borel[OF M_add])
      done
    also have "... = \<integral>\<^sup>+x. \<integral>\<^sup>+y. f (x, y) * indicator ((\<lambda>(x, y). x + y) -` X) (x,y)
                          \<partial>distr lborel borel (op + (-x)) \<partial>lborel"
      by (rule nn_integral_cong, subst lborel_distr_plus) simp
    also have "... = \<integral>\<^sup>+x. \<integral>\<^sup>+z. f (x, z-x) * indicator ((\<lambda>(x, y). x + y) -` X) (x, z-x)
                          \<partial>lborel \<partial>lborel"
      apply (rule nn_integral_cong, subst nn_integral_distr, simp)
      apply (intro borel_measurable_ereal_times, simp)
      apply (intro measurable_compose[OF measurable_Pair borel_measurable_indicator])
      apply (erule measurable_const, rule measurable_ident_sets[OF refl])
      apply (insert X, simp add: borel_prod measurable_sets_borel[OF M_add], simp)
      done
    also have "... = \<integral>\<^sup>+x. \<integral>\<^sup>+z. f (x, z-x) * indicator X z \<partial>lborel \<partial>lborel"
      by (intro nn_integral_cong) (simp split: split_indicator)
    also have "... = \<integral>\<^sup>+z. \<integral>\<^sup>+x. f (x, z-x) * indicator X z \<partial>lborel \<partial>lborel" using X
      by (subst lborel_pair.Fubini')
         (simp_all add: pair_sigma_finite_def)
    also have "... = \<integral>\<^sup>+z. (\<integral>\<^sup>+x. f (x, z-x) \<partial>lborel) * indicator X z \<partial>lborel"
      by (rule nn_integral_cong) (simp split: split_indicator)
    also have "... = emeasure (density lborel ?f') X" using X
      by (simp add: emeasure_density)
    finally show "emeasure (distr M borel (split op+)) X = emeasure (density lborel ?f') X" .
  qed (insert assms, auto dest: has_densityD)
qed (simp_all add: nn_integral_nonneg)

lemma distr_convolution_ring_count_space:
  assumes C: "countable (UNIV :: 'a set)"
  assumes "has_density M (count_space UNIV) (f :: (('a :: ring) \<times> 'a) \<Rightarrow> ereal)"
  shows "has_density (distr M (count_space UNIV) (split op+)) (count_space UNIV)
             (\<lambda>z. \<integral>\<^sup>+x. f (x, z - x) \<partial>count_space UNIV)"
            (is "has_density ?M' _ ?f'")
proof
  let ?CS = "count_space UNIV :: 'a measure" and ?CSP = "count_space UNIV :: ('a \<times> 'a) measure"
  show Mf': "(\<lambda>z. \<integral>\<^sup>+ x. f (x, z - x) \<partial>count_space UNIV) \<in> borel_measurable ?CS" by simp

  from assms have sets_M: "sets M = UNIV" and [simp]: "space M = UNIV"
    by (auto dest: has_densityD)
  from assms have [simp]: "measurable M = measurable (count_space UNIV)"
    by (intro ext measurable_cong_sets) (simp_all add: sets_M)

  interpret sigma_finite_measure ?CS by (rule sigma_finite_measure_count_space_countable[OF C])
  show "distr M ?CS (split op+) = density ?CS ?f'"
  proof (rule measure_eqI)
    fix X :: "'a set" assume X: "X \<in> sets (distr M ?CS (split op+))"
    hence "emeasure (distr M ?CS (split op+)) X = emeasure M ((\<lambda>(x, y). x + y) -` X)"
      by (simp_all add: emeasure_distr)
    also from X have "... = \<integral>\<^sup>+z. f z * indicator ((\<lambda>(x, y). x + y) -` X) z \<partial>(?CS \<Otimes>\<^sub>M ?CS)"
      by (simp add: emeasure_density has_densityD[OF assms(2)]
                     sets_M pair_measure_countable C)
    also have "... = \<integral>\<^sup>+x. \<integral>\<^sup>+y. f (x, y) * indicator ((\<lambda>(x, y). x + y) -` X) (x,y) \<partial>?CS \<partial>?CS"
      by (rule nn_integral_fst[symmetric]) (simp add: pair_measure_countable C)
    also have "... = \<integral>\<^sup>+x. \<integral>\<^sup>+y. f (x, y) * indicator ((\<lambda>(x, y). x + y) -` X) (x,y)
                          \<partial>distr ?CS ?CS (op + (-x)) \<partial>?CS"
      by (rule nn_integral_cong, subst count_space_plus) simp
    also have "... = \<integral>\<^sup>+x. \<integral>\<^sup>+z. f (x, z-x) * indicator ((\<lambda>(x, y). x + y) -` X) (x, z-x) \<partial>?CS \<partial>?CS"
      by (rule nn_integral_cong) (simp_all add: nn_integral_distr)
    also have "... = \<integral>\<^sup>+x. \<integral>\<^sup>+z. f (x, z-x) * indicator X z \<partial>?CS \<partial>?CS"
      by (intro nn_integral_cong) (simp split: split_indicator)
    also have "... = \<integral>\<^sup>+z. \<integral>\<^sup>+x. f (x, z-x) * indicator X z \<partial>?CS \<partial>?CS" using X
      by (subst pair_sigma_finite.Fubini')
         (simp_all add: pair_sigma_finite_def sigma_finite_measure_count_space_countable
                        C pair_measure_countable)
    also have "... = \<integral>\<^sup>+z. (\<integral>\<^sup>+x. f (x, z-x) \<partial>?CS) * indicator X z \<partial>?CS"
      by (rule nn_integral_cong) (simp split: split_indicator)
    also have "... = emeasure (density ?CS ?f') X" using X by (simp add: emeasure_density)
    finally show "emeasure (distr M ?CS (split op+)) X = emeasure (density ?CS ?f') X" .
  qed (insert assms, auto dest: has_densityD)
qed (simp_all add: nn_integral_nonneg)

end


(*  Title:      HOL/Bali/Basis.thy
    Author:     David von Oheimb
*)
subsection \<open>Definitions extending HOL as logical basis of Bali\<close>

theory Basis
imports Main
begin

subsubsection "misc"

ML \<open>fun strip_tac ctxt i = REPEAT (resolve_tac ctxt [impI, allI] i)\<close>

declare if_split_asm  [split] option.split [split] option.split_asm [split]
setup \<open>map_theory_simpset (fn ctxt => ctxt addloop ("split_all_tac", split_all_tac))\<close>
declare if_weak_cong [cong del] option.case_cong_weak [cong del]
declare length_Suc_conv [iff]

lemma Collect_split_eq: "{p. P (case_prod f p)} = {(a,b). P (f a b)}"
  by auto

lemma subset_insertD: "A \<subseteq> insert x B \<Longrightarrow> A \<subseteq> B \<and> x \<notin> A \<or> (\<exists>B'. A = insert x B' \<and> B' \<subseteq> B)"
  apply (case_tac "x \<in> A")
   apply (rule disjI2)
   apply (rule_tac x = "A - {x}" in exI)
   apply fast+
  done

abbreviation nat3 :: nat  ("3") where "3 \<equiv> Suc 2"
abbreviation nat4 :: nat  ("4") where "4 \<equiv> Suc 3"

(* irrefl_tranclI in Transitive_Closure.thy is more general *)
lemma irrefl_tranclI': "r\<inverse> \<inter> r\<^sup>+ = {} \<Longrightarrow> \<forall>x. (x, x) \<notin> r\<^sup>+"
  by (blast elim: tranclE dest: trancl_into_rtrancl)

lemma trancl_rtrancl_trancl: "\<lbrakk>(x, y) \<in> r\<^sup>+; (y, z) \<in> r\<^sup>*\<rbrakk> \<Longrightarrow> (x, z) \<in> r\<^sup>+"
  by (auto dest: tranclD rtrancl_trans rtrancl_into_trancl2)

lemma rtrancl_into_trancl3: "\<lbrakk>(a, b) \<in> r\<^sup>*; a \<noteq> b\<rbrakk> \<Longrightarrow> (a, b) \<in> r\<^sup>+"
  apply (drule rtranclD)
  apply auto
  done

lemma rtrancl_into_rtrancl2: "\<lbrakk>(a, b) \<in>  r; (b, c) \<in> r\<^sup>*\<rbrakk> \<Longrightarrow> (a, c) \<in> r\<^sup>*"
  by (auto intro: rtrancl_trans)

lemma triangle_lemma:
  assumes unique: "\<And>a b c. \<lbrakk>(a,b)\<in>r; (a,c)\<in>r\<rbrakk> \<Longrightarrow> b = c"
    and ax: "(a,x)\<in>r\<^sup>*" and ay: "(a,y)\<in>r\<^sup>*"
  shows "(x,y)\<in>r\<^sup>* \<or> (y,x)\<in>r\<^sup>*"
  using ax ay
proof (induct rule: converse_rtrancl_induct)
  assume "(x,y)\<in>r\<^sup>*"
  then show ?thesis by blast
next
  fix a v
  assume a_v_r: "(a, v) \<in> r"
    and v_x_rt: "(v, x) \<in> r\<^sup>*"
    and a_y_rt: "(a, y) \<in> r\<^sup>*"
    and hyp: "(v, y) \<in> r\<^sup>* \<Longrightarrow> (x, y) \<in> r\<^sup>* \<or> (y, x) \<in> r\<^sup>*"
  from a_y_rt show "(x, y) \<in> r\<^sup>* \<or> (y, x) \<in> r\<^sup>*"
  proof (cases rule: converse_rtranclE)
    assume "a = y"
    with a_v_r v_x_rt have "(y,x) \<in> r\<^sup>*"
      by (auto intro: rtrancl_trans)
    then show ?thesis by blast
  next
    fix w
    assume a_w_r: "(a, w) \<in> r"
      and w_y_rt: "(w, y) \<in> r\<^sup>*"
    from a_v_r a_w_r unique have "v=w" by auto
    with w_y_rt hyp show ?thesis by blast
  qed
qed

lemma rtrancl_cases:
  assumes "(a,b)\<in>r\<^sup>*"
  obtains (Refl) "a = b"
    | (Trancl) "(a,b)\<in>r\<^sup>+"
  apply (rule rtranclE [OF assms])
   apply (auto dest: rtrancl_into_trancl1)
  done

lemma Ball_weaken: "\<lbrakk>Ball s P; \<And> x. P x\<longrightarrow>Q x\<rbrakk>\<Longrightarrow>Ball s Q"
  by auto

lemma finite_SetCompr2:
  "finite {f y x |x y. P y}" if "finite (Collect P)"
    "\<forall>y. P y \<longrightarrow> finite (range (f y))"
proof -
  have "{f y x |x y. P y} = (\<Union>y\<in>Collect P. range (f y))"
    by auto
  with that show ?thesis by simp
qed

lemma list_all2_trans: "\<forall>a b c. P1 a b \<longrightarrow> P2 b c \<longrightarrow> P3 a c \<Longrightarrow>
    \<forall>xs2 xs3. list_all2 P1 xs1 xs2 \<longrightarrow> list_all2 P2 xs2 xs3 \<longrightarrow> list_all2 P3 xs1 xs3"
  apply (induct_tac xs1)
   apply simp
  apply (rule allI)
  apply (induct_tac xs2)
   apply simp
  apply (rule allI)
  apply (induct_tac xs3)
   apply auto
  done

subsubsection "pairs"

lemma surjective_pairing5:
  "p = (fst p, fst (snd p), fst (snd (snd p)), fst (snd (snd (snd p))),
    snd (snd (snd (snd p))))"
  by auto

lemma fst_splitE [elim!]:
  assumes "fst s' = x'"
  obtains x s where "s' = (x,s)" and "x = x'"
  using assms by (cases s') auto

lemma fst_in_set_lemma: "(x, y) \<in> set l \<Longrightarrow> x \<in> fst ` set l"
  by (induct l) auto

subsubsection "quantifiers"

lemma All_Ex_refl_eq2 [simp]: "(\<forall>x. (\<exists>b. x = f b \<and> Q b) \<longrightarrow> P x) = (\<forall>b. Q b \<longrightarrow> P (f b))"
  by auto

lemma ex_ex_miniscope1 [simp]: "(\<exists>w v. P w v \<and> Q v) = (\<exists>v. (\<exists>w. P w v) \<and> Q v)"
  by auto

lemma ex_miniscope2 [simp]: "(\<exists>v. P v \<and> Q \<and> R v) = (Q \<and> (\<exists>v. P v \<and> R v))"
  by auto

lemma ex_reorder31: "(\<exists>z x y. P x y z) = (\<exists>x y z. P x y z)"
  by auto

lemma All_Ex_refl_eq1 [simp]: "(\<forall>x. (\<exists>b. x = f b) \<longrightarrow> P x) = (\<forall>b. P (f b))"
  by auto

subsubsection "sums"

notation case_sum  (infixr "'(+')" 80)

primrec the_Inl :: "'a + 'b \<Rightarrow> 'a"
  where "the_Inl (Inl a) = a"

primrec the_Inr :: "'a + 'b \<Rightarrow> 'b"
  where "the_Inr (Inr b) = b"

datatype ('a, 'b, 'c) sum3 = In1 'a | In2 'b | In3 'c

primrec the_In1 :: "('a, 'b, 'c) sum3 \<Rightarrow> 'a"
  where "the_In1 (In1 a) = a"

primrec the_In2 :: "('a, 'b, 'c) sum3 \<Rightarrow> 'b"
  where "the_In2 (In2 b) = b"

primrec the_In3 :: "('a, 'b, 'c) sum3 \<Rightarrow> 'c"
  where "the_In3 (In3 c) = c"

abbreviation In1l :: "'al \<Rightarrow> ('al + 'ar, 'b, 'c) sum3"
  where "In1l e \<equiv> In1 (Inl e)"

abbreviation In1r :: "'ar \<Rightarrow> ('al + 'ar, 'b, 'c) sum3"
  where "In1r c \<equiv> In1 (Inr c)"

abbreviation the_In1l :: "('al + 'ar, 'b, 'c) sum3 \<Rightarrow> 'al"
  where "the_In1l \<equiv> the_Inl \<circ> the_In1"

abbreviation the_In1r :: "('al + 'ar, 'b, 'c) sum3 \<Rightarrow> 'ar"
  where "the_In1r \<equiv> the_Inr \<circ> the_In1"

ML \<open>
fun sum3_instantiate ctxt thm =
  map (fn s =>
    simplify (ctxt delsimps @{thms not_None_eq})
      (Rule_Insts.read_instantiate ctxt [((("t", 0), Position.none), "In" ^ s ^ " x")] ["x"] thm))
    ["1l","2","3","1r"]
\<close>
(* e.g. lemmas is_stmt_rews = is_stmt_def [of "In1l x", simplified] *)

subsubsection "quantifiers for option type"

syntax
  "_Oall" :: "[pttrn, 'a option, bool] \<Rightarrow> bool"   ("(3! _:_:/ _)" [0,0,10] 10)
  "_Oex"  :: "[pttrn, 'a option, bool] \<Rightarrow> bool"   ("(3? _:_:/ _)" [0,0,10] 10)

syntax (symbols)
  "_Oall" :: "[pttrn, 'a option, bool] \<Rightarrow> bool"   ("(3\<forall>_\<in>_:/ _)"  [0,0,10] 10)
  "_Oex"  :: "[pttrn, 'a option, bool] \<Rightarrow> bool"   ("(3\<exists>_\<in>_:/ _)"  [0,0,10] 10)

translations
  "\<forall>x\<in>A: P" \<rightleftharpoons> "\<forall>x\<in>CONST set_option A. P"
  "\<exists>x\<in>A: P" \<rightleftharpoons> "\<exists>x\<in>CONST set_option A. P"

subsubsection "Special map update"

text\<open>Deemed too special for theory Map.\<close>

definition chg_map :: "('b \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b)"
  where "chg_map f a m = (case m a of None \<Rightarrow> m | Some b \<Rightarrow> m(a\<mapsto>f b))"

lemma chg_map_new[simp]: "m a = None \<Longrightarrow> chg_map f a m = m"
  unfolding chg_map_def by auto

lemma chg_map_upd[simp]: "m a = Some b \<Longrightarrow> chg_map f a m = m(a\<mapsto>f b)"
  unfolding chg_map_def by auto

lemma chg_map_other [simp]: "a \<noteq> b \<Longrightarrow> chg_map f a m b = m b"
  by (auto simp: chg_map_def)

subsubsection "unique association lists"

definition unique :: "('a \<times> 'b) list \<Rightarrow> bool"
  where "unique = distinct \<circ> map fst"

lemma uniqueD: "unique l \<Longrightarrow> (x, y) \<in> set l \<Longrightarrow> (x', y') \<in> set l \<Longrightarrow> x = x' \<Longrightarrow> y = y'"
  unfolding unique_def o_def
  by (induct l) (auto dest: fst_in_set_lemma)

lemma unique_Nil [simp]: "unique []"
  by (simp add: unique_def)

lemma unique_Cons [simp]: "unique ((x,y)#l) = (unique l \<and> (\<forall>y. (x,y) \<notin> set l))"
  by (auto simp: unique_def dest: fst_in_set_lemma)

lemma unique_ConsD: "unique (x#xs) \<Longrightarrow> unique xs"
  by (simp add: unique_def)

lemma unique_single [simp]: "\<And>p. unique [p]"
  by simp

lemma unique_append [rule_format (no_asm)]: "unique l' \<Longrightarrow> unique l \<Longrightarrow>
    (\<forall>(x,y)\<in>set l. \<forall>(x',y')\<in>set l'. x' \<noteq> x) \<longrightarrow> unique (l @ l')"
  by (induct l) (auto dest: fst_in_set_lemma)

lemma unique_map_inj: "unique l \<Longrightarrow> inj f \<Longrightarrow> unique (map (\<lambda>(k,x). (f k, g k x)) l)"
  by (induct l) (auto dest: fst_in_set_lemma simp add: inj_eq)

lemma map_of_SomeI: "unique l \<Longrightarrow> (k, x) \<in> set l \<Longrightarrow> map_of l k = Some x"
  by (induct l) auto

subsubsection "list patterns"

definition lsplit :: "[['a, 'a list] \<Rightarrow> 'b, 'a list] \<Rightarrow> 'b"
  where "lsplit = (\<lambda>f l. f (hd l) (tl l))"

text \<open>list patterns -- extends pre-defined type "pttrn" used in abstractions\<close>
syntax
  "_lpttrn" :: "[pttrn, pttrn] \<Rightarrow> pttrn"    ("_#/_" [901,900] 900)
translations
  "\<lambda>y # x # xs. b" \<rightleftharpoons> "CONST lsplit (\<lambda>y x # xs. b)"
  "\<lambda>x # xs. b" \<rightleftharpoons> "CONST lsplit (\<lambda>x xs. b)"

lemma lsplit [simp]: "lsplit c (x#xs) = c x xs"
  by (simp add: lsplit_def)

lemma lsplit2 [simp]: "lsplit P (x#xs) y z = P x xs y z"
  by (simp add: lsplit_def)

end