(*  Title:  Kuratowski.thy
    Author: Lars Noschinski, TU München
*)

theory Kuratowski
imports
  Arc_Walk
  Digraph_Component
  Subdivision
  "HOL-Library.Rewrite"
begin

section {* Kuratowski Subgraphs *}

text {*
  We consider the underlying undirected graphs. The underlying undirected graph is represented as a
  symmetric digraph.
*}

subsection {* Public definitions *}

definition complete_digraph :: "nat \<Rightarrow> ('a,'b) pre_digraph \<Rightarrow> bool" ("K\<^bsub>_\<^esub>") where
  "complete_digraph n G \<equiv> graph G \<and> card (verts G) = n \<and> arcs_ends G = {(u,v). (u,v) \<in> verts G \<times> verts G \<and> u \<noteq> v}"

definition complete_bipartite_digraph :: "nat \<Rightarrow> nat \<Rightarrow> ('a, 'b) pre_digraph \<Rightarrow> bool" ("K\<^bsub>_,_\<^esub>") where
  "complete_bipartite_digraph m n G \<equiv> graph G \<and> (\<exists>U V. verts G = U \<union> V \<and> U \<inter> V = {}
    \<and> card U = m \<and> card V = n \<and> arcs_ends G = U \<times> V \<union> V \<times> U)"

definition kuratowski_planar :: "('a,'b) pre_digraph \<Rightarrow> bool" where
  "kuratowski_planar G \<equiv> \<not>(\<exists>H. subgraph H G \<and> (\<exists>K rev_K rev_H. subdivision (K, rev_K) (H, rev_H) \<and> (K\<^bsub>3,3\<^esub> K \<or> K\<^bsub>5\<^esub> K)))"

lemma complete_digraph_pair_def: "K\<^bsub>n\<^esub> (with_proj G)
  \<longleftrightarrow> finite (pverts G) \<and> card (pverts G) = n \<and> parcs G = {(u,v). (u,v) \<in> (pverts G \<times> pverts G) \<and> u \<noteq> v}" (is "_ = ?R")
proof
  assume A: "K\<^bsub>n\<^esub> G"
  then interpret graph "with_proj G" by (simp add: complete_digraph_def)
  show ?R using A finite_verts by (auto simp: complete_digraph_def)
next
  assume A: ?R
  moreover
  then have "finite (pverts G \<times> pverts G)" "parcs G \<subseteq> pverts G \<times> pverts G"
    by auto
  then have "finite (parcs G)" by (rule rev_finite_subset)
  ultimately interpret pair_graph G
    by unfold_locales (auto simp:  symmetric_def split: prod.splits intro: symI)
  show "K\<^bsub>n\<^esub> G" using A finite_verts by (auto simp: complete_digraph_def)
qed

lemma complete_bipartite_digraph_pair_def: "K\<^bsub>m,n\<^esub> (with_proj G) \<longleftrightarrow> finite (pverts G)
    \<and> (\<exists>U V. pverts G = U \<union> V \<and> U \<inter> V = {} \<and> card U = m \<and> card V = n \<and> parcs G = U \<times> V \<union> V \<times> U)" (is "_ = ?R")
proof
  assume A: "K\<^bsub>m,n\<^esub> G"
  then interpret graph G by (simp add: complete_bipartite_digraph_def)
  show ?R using A finite_verts by (auto simp: complete_bipartite_digraph_def)
next
  assume A: ?R
  then interpret pair_graph G
    by unfold_locales (fastforce simp: complete_bipartite_digraph_def symmetric_def split: prod.splits intro: symI)+
  show "K\<^bsub>m,n\<^esub> G" using A by (auto simp: complete_bipartite_digraph_def)
qed

lemma pair_graphI_complete:
  assumes "K\<^bsub>n\<^esub> (with_proj G)"
  shows "pair_graph G"
proof -
  from assms interpret graph "with_proj G" by (simp add: complete_digraph_def)
  show "pair_graph G"
    using finite_arcs finite_verts sym_arcs wellformed no_loops by unfold_locales simp_all
qed

lemma pair_graphI_complete_bipartite:
  assumes "K\<^bsub>m,n\<^esub> (with_proj G)"
  shows "pair_graph G"
proof -
  from assms interpret graph "with_proj G" by (simp add: complete_bipartite_digraph_def)
  show "pair_graph G"
    using finite_arcs finite_verts sym_arcs wellformed no_loops by unfold_locales simp_all
qed

subsection {* Inner vertices of a walk *}

context pre_digraph begin

definition (in pre_digraph) inner_verts :: "'b awalk \<Rightarrow> 'a list" where
  "inner_verts p \<equiv> tl (map (tail G) p)"

lemma inner_verts_Nil[simp]: "inner_verts [] = []" by (auto simp: inner_verts_def)

lemma inner_verts_singleton[simp]: "inner_verts [x] = []" by (auto simp: inner_verts_def)

lemma (in wf_digraph) inner_verts_Cons:
  assumes "awalk u (e # es) v"
  shows "inner_verts (e # es) = (if es \<noteq> [] then head G e # inner_verts es else [])"
  using assms by (induct es) (auto simp: inner_verts_def)

lemma (in - ) inner_verts_with_proj_def:
  "pre_digraph.inner_verts (with_proj G) p = tl (map fst p)"
  unfolding pre_digraph.inner_verts_def by simp

lemma inner_verts_conv: "inner_verts p = butlast (tl (awalk_verts u p))"
  unfolding inner_verts_def awalk_verts_conv by simp

lemma (in wf_digraph) set_inner_verts:
  assumes "apath u p v"
  shows "set (inner_verts p) = set (awalk_verts u p) - {u,v}"
proof (cases "length p < 2")
  case True with assms show ?thesis
    by (cases p) (auto simp: inner_verts_conv[of _ u] apath_def)
next
  case False
  have "awalk_verts u p = u # inner_verts p @ [v]"
    using assms False length_awalk_verts[of u p] inner_verts_conv[of p u]
    by (cases "awalk_verts u p") (auto simp: apath_def awalk_conv)
  then show ?thesis using assms by (auto simp: apath_def)
qed

lemma in_set_inner_verts_appendI_l:
  assumes "u \<in> set (inner_verts p)"
  shows "u \<in> set (inner_verts (p @ q))"
  using assms
by (induct p) (auto simp: inner_verts_def)

lemma in_set_inner_verts_appendI_r:
  assumes "u \<in> set (inner_verts q)"
  shows "u \<in> set (inner_verts (p @ q))"
  using assms
by (induct p) (auto simp: inner_verts_def dest: list_set_tl)

end

subsection {* Progressing Walks *}

text {*
  We call a walk \emph{progressing} if it does not contain the sequence
  @{term "[(x,y), (y,x)]"}. This concept is relevant in particular
  for @{term iapath}s: If all of the inner vertices have degree at
  most 2 this implies that such a walk is a trail and even a path.
*}

definition progressing :: "('a \<times> 'a) awalk \<Rightarrow> bool" where
  "progressing p \<equiv> \<forall>xs x y ys. p \<noteq> xs @ (x,y) # (y,x) # ys"

lemma progressing_Nil: "progressing []"
  by (auto simp: progressing_def)

lemma progressing_single: "progressing [e]"
  by (auto simp: progressing_def)

lemma progressing_ConsD:
  assumes "progressing (e # es)" shows "progressing es"
  using assms unfolding progressing_def by (metis (no_types) append_eq_Cons_conv)

lemma progressing_Cons:
  "progressing (x # xs) \<longleftrightarrow> (xs = [] \<or> (xs \<noteq> [] \<and> \<not>(fst x = snd (hd xs) \<and> snd x = fst (hd xs)) \<and> progressing xs))" (is "?L = ?R")
proof
  assume ?L
  show ?R
  proof (cases xs)
    case Nil then show ?thesis by auto
  next
    case (Cons x' xs')
    then have "\<And>u v. (x # x' # xs') \<noteq> [] @ (u,v) # (v,u) # xs'" using \<open>?L\<close> unfolding progressing_def by metis
    then have "\<not>(fst x = snd x' \<and> snd x = fst x')" by (cases x) (cases x', auto)
    with Cons show ?thesis using \<open>?L\<close> by (auto dest: progressing_ConsD)
  qed
next
  assume ?R then show ?L unfolding progressing_def
    by (auto simp add: Cons_eq_append_conv)
qed

lemma progressing_Cons_Cons:
  "progressing ((u,v) # (v,w) # es) \<longleftrightarrow> u \<noteq> w \<and> progressing ((v,w) # es)" (is "?L \<longleftrightarrow> ?R")
  by (auto simp: progressing_Cons)

lemma progressing_appendD1:
  assumes "progressing (p @ q)" shows "progressing p"
  using assms unfolding progressing_def by (metis append_Cons append_assoc)

lemma progressing_appendD2:
  assumes "progressing (p @ q)" shows "progressing q"
  using assms unfolding progressing_def by (metis append_assoc)

lemma progressing_rev_path:
  "progressing (rev_path p) = progressing p" (is "?L = ?R")
proof
  assume ?L
  show ?R unfolding progressing_def
  proof (intro allI notI)
    fix xs x y ys l1 l2 assume "p = xs @ (x,y) # (y,x) # ys"
    then have "rev_path p = rev_path ys @ (x,y) # (y,x) # rev_path xs"
      by simp
    then show False using `?L` unfolding progressing_def by auto
  qed
next
  assume ?R
  show ?L unfolding progressing_def
  proof (intro allI notI)
    fix xs x y ys l1 l2 assume "rev_path p = xs @ (x,y) # (y,x) # ys"
    then have "rev_path (rev_path p) = rev_path ys @ (x,y) # (y,x) # rev_path xs"
      by simp
    then show False using `?R` unfolding progressing_def by auto
  qed
qed

lemma progressing_append_iff:
  shows "progressing (xs @ ys) \<longleftrightarrow> progressing xs \<and> progressing ys
      \<and> (xs \<noteq> [] \<and> ys \<noteq> [] \<longrightarrow> (fst (last xs) \<noteq> snd (hd ys) \<or> snd (last xs) \<noteq> fst (hd ys)))"
proof (induct ys arbitrary: xs)
  case Nil then show ?case by (auto simp: progressing_Nil)
next
  case (Cons y' ys')
  let "_ = ?R" = ?case
  have *: "xs \<noteq> [] \<Longrightarrow> hd (rev_path xs) = prod.swap (last xs)" by (induct xs) auto

  have "progressing (xs @ y' # ys') \<longleftrightarrow> progressing ((xs @ [y']) @ ys')"
    by simp
  also have "\<dots> \<longleftrightarrow> progressing (xs @ [y']) \<and> progressing ys' \<and> (ys' \<noteq> [] \<longrightarrow> (fst y' \<noteq> snd (hd ys') \<or> snd y' \<noteq> fst (hd ys')))"
    by (subst Cons) simp
  also have "\<dots> \<longleftrightarrow> ?R"
    by (auto simp: progressing_Cons progressing_Nil progressing_rev_path[where p="xs @ _",symmetric] * progressing_rev_path prod.swap_def)
  finally show ?case .
qed

subsection {* Walks with Restricted Vertices *}

definition verts3 :: "('a, 'b) pre_digraph \<Rightarrow> 'a set" where
  "verts3 G \<equiv> {v \<in> verts G. 2 < in_degree G v}"

text {* A path were only the end nodes may be in @{term V} *}

definition (in pre_digraph) gen_iapath :: "'a set \<Rightarrow> 'a \<Rightarrow> 'b awalk \<Rightarrow> 'a \<Rightarrow> bool" where
  "gen_iapath V u p v \<equiv> u \<in> V \<and> v \<in> V \<and> apath u p v \<and> set (inner_verts p) \<inter> V = {} \<and> p \<noteq> []"

abbreviation (in pre_digraph) (input) iapath :: "'a \<Rightarrow> 'b awalk \<Rightarrow> 'a \<Rightarrow> bool" where
  "iapath u p v \<equiv> gen_iapath (verts3 G) u p v"

definition gen_contr_graph :: "('a,'b) pre_digraph \<Rightarrow> 'a set \<Rightarrow> 'a pair_pre_digraph" where
  "gen_contr_graph G V \<equiv> \<lparr>
     pverts = V,
     parcs = {(u,v). \<exists>p. pre_digraph.gen_iapath G V u p v}
     \<rparr>"

abbreviation (input) contr_graph :: "'a pair_pre_digraph \<Rightarrow> 'a pair_pre_digraph" where
  "contr_graph G \<equiv> gen_contr_graph G (verts3 G)"

subsection {* Properties of subdivisions *}

lemma (in pair_sym_digraph) verts3_subdivide:
  assumes "e \<in> parcs G" "w \<notin> pverts G"
  shows"verts3 (subdivide G e w) = verts3 G"
proof -
  let ?sG = "subdivide G e w"
  obtain u v where e_conv[simp]: "e = (u,v)" by (cases e) auto

  from `w \<notin> pverts G`
  have w_arcs: "(u,w) \<notin> parcs G" "(v,w) \<notin> parcs G" "(w,u) \<notin> parcs G" "(w,v) \<notin> parcs G"
    by (auto dest: wellformed)
  have G_arcs: "(u,v) \<in> parcs G" "(v,u) \<in> parcs G"
    using `e \<in> parcs G` by (auto simp: arcs_symmetric)

  have "{v \<in> pverts G. 2 < in_degree G v} = {v \<in> pverts G. 2 < in_degree ?sG v}"
  proof -
    { fix x assume "x \<in> pverts G"
      def card_eq \<equiv> "\<lambda>x. in_degree ?sG x = in_degree G x"

      have "in_arcs ?sG u = (in_arcs G u - {(v,u)}) \<union> {(w,u)}"
           "in_arcs ?sG v = (in_arcs G v - {(u,v)}) \<union> {(w,v)}"
        using w_arcs G_arcs by auto
      then have "card_eq u" "card_eq v"
        unfolding card_eq_def in_degree_def using w_arcs G_arcs
        apply -
        apply (cases "finite (in_arcs G u)"; simp add: card_Suc_Diff1 del: card_Diff_insert)
        apply (cases "finite (in_arcs G v)"; simp add: card_Suc_Diff1 del: card_Diff_insert)
        done
      moreover
      have "x \<notin> {u,v} \<Longrightarrow> in_arcs ?sG x = in_arcs G x"
        using `x \<in> pverts G` `w \<notin> pverts G` by (auto simp: )
      then have "x \<notin> {u,v} \<Longrightarrow> card_eq x" by (simp add: in_degree_def card_eq_def)
      ultimately have "card_eq x" by fast
      then have "in_degree G x = in_degree ?sG x"
        unfolding card_eq_def by simp }
    then show ?thesis by auto
  qed
  also have "\<dots> = {v\<in>pverts ?sG. 2 < in_degree ?sG v}"
  proof -
    have "in_degree ?sG w \<le> 2"
    proof -
      have "in_arcs ?sG w = {(u,w), (v,w)}"
        using `w \<notin> pverts G` G_arcs(1) by (auto simp: wellformed')
      then show ?thesis
        unfolding in_degree_def by (auto simp: card_insert_if)
    qed
    then show ?thesis using G_arcs assms by auto
  qed
  finally show ?thesis by (simp add: verts3_def)
qed

lemma sd_path_Nil_iff:
  "sd_path e w p = [] \<longleftrightarrow> p = []"
  by (cases "(e,w,p)" rule: sd_path.cases) auto

lemma (in pair_sym_digraph) gen_iapath_sd_path:
  fixes e :: "'a \<times> 'a" and w :: 'a
  assumes elems: "e \<in> parcs G" "w \<notin> pverts G"
  assumes V: "V \<subseteq> pverts G"
  assumes path: "gen_iapath V u p v"
  shows "pre_digraph.gen_iapath (subdivide G e w) V u (sd_path e w p) v"
proof -
  obtain x y where e_conv: "e = (x,y)" by (cases e) auto
  interpret S: pair_sym_digraph "subdivide G e w"
    using elems by (auto intro: pair_sym_digraph_subdivide)

  from path have "apath u p v" by (auto simp: gen_iapath_def)
  then have apath_sd: "S.apath u (sd_path e w p) v" and
    set_ev_sd: "set (S.awalk_verts u (sd_path e w p)) \<subseteq> set (awalk_verts u p) \<union> {w}"
    using elems by (rule apath_sd_path set_awalk_verts_sd_path)+
  have "w \<notin> {u,v}" using elems `apath u p v`
    by (auto simp: apath_def awalk_hd_in_verts awalk_last_in_verts)

  have "set (S.inner_verts (sd_path e w p)) = set (S.awalk_verts u (sd_path e w p)) - {u,v}"
    using apath_sd by (rule S.set_inner_verts)
  also have "\<dots> \<subseteq> set (awalk_verts u p) \<union> {w} - {u,v}"
    using set_ev_sd by auto
  also have "\<dots> = set (inner_verts p) \<union> {w}"
    using set_inner_verts[OF `apath u p v`] `w \<notin> {u,v}` by blast
  finally have "set (S.inner_verts (sd_path e w p)) \<inter> V \<subseteq> (set (inner_verts p) \<union> {w}) \<inter> V"
    using V by blast
  also have "\<dots> \<subseteq> {}"
    using path elems V unfolding gen_iapath_def by auto
  finally show ?thesis
    using apath_sd elems path by (auto simp: gen_iapath_def S.gen_iapath_def sd_path_Nil_iff)
qed

lemma (in pair_sym_digraph)
  assumes elems: "e \<in> parcs G" "w \<notin> pverts G"
  assumes V: "V \<subseteq> pverts G"
  assumes path: "pre_digraph.gen_iapath (subdivide G e w) V u p v"
  shows gen_iapath_co_path: "gen_iapath V u (co_path e w p) v" (is ?thesis_path)
    and set_awalk_verts_co_path': "set (awalk_verts u (co_path e w p)) = set (awalk_verts u p) - {w}" (is ?thesis_set)
proof -
  interpret S: pair_sym_digraph "subdivide G e w"
    using elems by (rule pair_sym_digraph_subdivide)

  have uv: "u \<in> pverts G" "v \<in> pverts G" "S.apath u p v" using V path by (auto simp: S.gen_iapath_def)
  note co = apath_co_path[OF elems uv] set_awalk_verts_co_path[OF elems uv]

  show ?thesis_set by (fact co)
  show ?thesis_path using co path unfolding gen_iapath_def S.gen_iapath_def using elems
    by (clarsimp simp add: set_inner_verts[of u] S.set_inner_verts[of u]) blast
qed

subsection {* Pair Graphs *}

context pair_sym_digraph begin

lemma gen_iapath_rev_path:
  "gen_iapath V v (rev_path p) u = gen_iapath V u p v" (is "?L = ?R")
proof -
  { fix u p v assume "gen_iapath V u p v"
    then have "butlast (tl (awalk_verts v (rev_path p))) = rev (butlast (tl (awalk_verts u p)))"
      by (auto simp: tl_rev butlast_rev butlast_tl awalk_verts_rev_path gen_iapath_def apath_def)
    with `gen_iapath V u p v` have "gen_iapath V v (rev_path p) u"
      by (auto simp: gen_iapath_def apath_def inner_verts_conv[symmetric] awalk_verts_rev_path) }
  note RL = this
  show ?thesis by (auto dest: RL intro: RL)
qed

lemma inner_verts_rev_path:
  assumes "awalk u p v"
  shows "inner_verts (rev_path p) = rev (inner_verts p)"
by (metis assms butlast_rev butlast_tl awalk_verts_rev_path inner_verts_conv tl_rev)

end

context pair_pseudo_graph begin

lemma apath_imp_progressing:
  assumes "apath u p v" shows "progressing p"
proof (rule ccontr)
  assume "\<not>?thesis"
  then obtain xs x y ys where *: "p = xs @ (x,y) # (y,x) # ys"
    unfolding progressing_def by auto
  then  have "\<not>apath u p v"
    by (simp add: apath_append_iff apath_simps hd_in_awalk_verts)
  then show False using assms by auto
qed

lemma awalk_Cons_deg2_unique:
  assumes "awalk u p v" "p \<noteq> []"
  assumes "in_degree G u \<le> 2"
  assumes "awalk u1 (e1 # p) v" "awalk u2 (e2 # p) v"
  assumes "progressing (e1 # p)" "progressing (e2 # p)"
  shows "e1 = e2"
proof (cases p)
  case (Cons e es)
  show ?thesis
  proof (rule ccontr)
    assume "e1 \<noteq> e2"
    def x \<equiv> "snd e"
    then have e_unf:"e = (u,x)" using `awalk u p v`  Cons by (auto simp: awalk_simps)
    then have ei_unf: "e1 = (u1, u)" "e2 = (u2, u)"
      using Cons assms by (auto simp: apath_simps prod_eqI)
    with Cons assms `e = (u,x)` `e1 \<noteq> e2` have "u1 \<noteq> u2" "x \<noteq> u1" "x \<noteq> u2"
      by (auto simp: progressing_Cons_Cons)
    moreover have "{(u1, u), (u2, u), (x,u)} \<subseteq> parcs G"
      using e_unf ei_unf Cons assms by (auto simp: awalk_simps intro: arcs_symmetric)
    then have "finite (in_arcs G u)"
      and "{(u1, u), (u2, u), (x,u)} \<subseteq> in_arcs G u" by auto
    then have "card ({(u1, u), (u2, u), (x,u)}) \<le> in_degree G u"
      unfolding in_degree_def by (rule card_mono)
    ultimately show "False" using `in_degree G u \<le> 2` by auto
  qed
qed (simp add: `p \<noteq> []`)

lemma same_awalk_by_same_end:
  assumes V: "verts3 G \<subseteq> V" "V \<subseteq> pverts G"
    and walk: "awalk u p v" "awalk u q w" "hd p = hd q" "p \<noteq> []" "q \<noteq> []"
    and progress: "progressing p" "progressing q"
    and tail: "v \<in> V" "w \<in> V"
    and inner_verts: "set (inner_verts p) \<inter> V = {}"
      "set (inner_verts q) \<inter> V = {}"
  shows "p = q"
  using walk progress inner_verts
proof (induct p q arbitrary: u rule: list_induct2'[case_names Nil_Nil Cons_Nil Nil_Cons Cons_Cons])
  case (Cons_Cons a as b bs)
  from \<open>hd (a # _) = hd _\<close> have "a = b" by simp

  { fix a as v b bs w
    assume A: "awalk u (a # as) v" "awalk u (b # bs) w"
        "set (inner_verts (b # bs)) \<inter> V = {}" "v \<in> V" "a = b" "as = []"
    then have "bs = []" by - (rule ccontr, auto simp: inner_verts_Cons awalk_simps)
  } note Nil_imp_Nil = this

  show ?case
  proof (cases "as = []")
    case True
    then have "bs = []" using Cons_Cons.prems \<open>a = b\<close> tail by (metis Nil_imp_Nil)
    then show ?thesis using True \<open>a = b\<close> by simp
  next
    case False
    then have "bs \<noteq> []" using Cons_Cons.prems \<open>a = b\<close> tail by (metis Nil_imp_Nil)

    obtain a' as' where "as = a' # as'" using \<open>as \<noteq> []\<close> by (cases as) simp
    obtain b' bs' where "bs = b' # bs'" using \<open>bs \<noteq> []\<close> by (cases bs) simp

    let ?arcs = "{(fst a, snd a), (snd a', snd a), (snd b', snd a)}"

    have "card {fst a, snd a', snd b'} = card (fst ` ?arcs)" by auto
    also have "\<dots> = card ?arcs" by (rule card_image) (cases a, auto)
    also have "\<dots> \<le> in_degree G (snd a)"
    proof -
      have "?arcs \<subseteq> in_arcs G (snd a)"
        using \<open>progressing (a # as)\<close> \<open>progressing (b # bs)\<close> \<open>awalk _ (a # as) _\<close> \<open>awalk _ (b # bs) _\<close>
        unfolding \<open>a = b\<close> \<open>as = _\<close> \<open>bs = _\<close>
        by (cases b; cases a') (auto simp: progressing_Cons_Cons awalk_simps intro: arcs_symmetric)
      with _show ?thesis unfolding in_degree_def by (rule card_mono) auto
    qed
    also have "\<dots> \<le> 2"
    proof -
      have "snd a \<notin> V" "snd a \<in> pverts G"
        using Cons_Cons.prems \<open>as \<noteq> []\<close> by (auto simp: inner_verts_Cons)
      then show ?thesis using V by (auto simp: verts3_def)
    qed
    finally have "fst a = snd a' \<or> fst a = snd b' \<or> snd a' = snd b'"
      by (auto simp: card_insert_if split: if_splits)
    then have "hd as = hd bs"
      using \<open>progressing (a # as)\<close> \<open>progressing (b # bs)\<close> \<open>awalk _ (a # as) _\<close> \<open>awalk _ (b # bs) _\<close>
      unfolding \<open>a = b\<close> \<open>as = _\<close> \<open>bs = _\<close>
      by (cases b, cases a', cases b') (auto simp: progressing_Cons_Cons awalk_simps)
    then show ?thesis
      using \<open>as \<noteq> []\<close> \<open>bs \<noteq> []\<close> Cons_Cons.prems
      by (auto dest: progressing_ConsD simp: awalk_simps inner_verts_Cons intro!: Cons_Cons)
  qed
qed simp_all

lemma same_awalk_by_common_arc:
  assumes V: "verts3 G \<subseteq> V" "V \<subseteq> pverts G"
  assumes walk: "awalk u p v" "awalk w q x"
  assumes progress: "progressing p" "progressing q"
  assumes iv_not_in_V: "set (inner_verts p) \<inter> V = {}" "set (inner_verts q) \<inter> V = {}"
  assumes ends_in_V: "{u,v,w,x} \<subseteq> V"
  assumes arcs: "e \<in> set p" "e \<in> set q"
  shows "p = q"
proof -
  from arcs obtain p1 p2 where p_decomp: "p = p1 @ e # p2" by (metis in_set_conv_decomp_first)
  from arcs obtain q1 q2 where q_decomp: "q = q1 @ e # q2" by (metis in_set_conv_decomp_first)

  { def p1' \<equiv> "rev_path (p1 @ [e])" and q1' \<equiv> "rev_path (q1 @ [e])"
    then have decomp: "p = rev_path p1' @ p2" "q = rev_path q1' @ q2"
      and "awlast u (rev_path p1') = snd e" "awlast w (rev_path q1') = snd e"
      using p_decomp q_decomp walk by (auto simp: awlast_append awalk_verts_rev_path)
    then have walk': "awalk (snd e) p1' u" "awalk (snd e) q1' w"
      using walk by auto
    moreover have "hd p1' = hd q1'" "p1' \<noteq> []" "q1' \<noteq> []" by (auto simp: p1'_def q1'_def)
    moreover have "progressing p1'" "progressing q1'"
      using progress unfolding decomp by (auto dest: progressing_appendD1 simp: progressing_rev_path)
    moreover
    have "set (inner_verts (rev_path p1')) \<inter> V = {}" "set (inner_verts (rev_path q1')) \<inter> V = {}"
      using iv_not_in_V unfolding decomp
      by (auto intro: in_set_inner_verts_appendI_l in_set_inner_verts_appendI_r)
    then have "u \<in> V" "w \<in> V" "set (inner_verts p1') \<inter> V = {}" "set (inner_verts q1') \<inter> V = {}"
      using ends_in_V iv_not_in_V walk unfolding decomp
      by (auto simp: inner_verts_rev_path)
    ultimately have "p1' = q1'" by (rule same_awalk_by_same_end[OF V]) }
  moreover
  { def p2' \<equiv> "e # p2" and q2' \<equiv> "e # q2"
    then have decomp: "p = p1 @ p2'" "q = q1 @ q2'"
      using p_decomp q_decomp by (auto simp: awlast_append)
    moreover
    have "awlast u p1 = fst e" "awlast w q1 = fst e"
      using p_decomp q_decomp walk by auto
    ultimately
    have *: "awalk (fst e) p2' v" "awalk (fst e) q2' x"
      using walk by auto
    moreover have "hd p2' = hd q2'" "p2' \<noteq> []" "q2' \<noteq> []" by (auto simp: p2'_def q2'_def)
    moreover have "progressing p2'" "progressing q2'"
      using progress unfolding decomp by (auto dest: progressing_appendD2)
    moreover
    have "v \<in> V" "x \<in> V" "set (inner_verts p2') \<inter> V = {}" "set (inner_verts q2') \<inter> V = {}"
      using ends_in_V iv_not_in_V unfolding decomp
      by (auto intro: in_set_inner_verts_appendI_l in_set_inner_verts_appendI_r)
    ultimately have "p2' = q2'" by (rule same_awalk_by_same_end[OF V]) }
  ultimately
  show "p = q" using p_decomp q_decomp by (auto simp: rev_path_eq)
qed

lemma same_gen_iapath_by_common_arc:
  assumes V: "verts3 G \<subseteq> V" "V \<subseteq> pverts G"
  assumes path: "gen_iapath V u p v" "gen_iapath V w q x"
  assumes arcs: "e \<in> set p" "e \<in> set q"
  shows "p = q"
proof -
  from path have awalk: "awalk u p v" "awalk w q x" "progressing p" "progressing q"
      and in_V: "set (inner_verts p) \<inter> V = {}" "set (inner_verts q) \<inter> V = {}" "{u,v,w,x} \<subseteq> V"
    by (auto simp: gen_iapath_def apath_imp_progressing apath_def)
  from V awalk in_V arcs show ?thesis by (rule same_awalk_by_common_arc)
qed

end

subsection {* Slim graphs *}

text {*
  We define the notion of a slim graph. The idea is that for a slim graph @{term G}, @{term G}
  is a subdivision of @{term "contr_graph G"}.
*}

context pair_pre_digraph begin

definition (in pair_pre_digraph) is_slim :: "'a set \<Rightarrow> bool" where
  "is_slim V \<equiv>
    (\<forall>v \<in> pverts G. v \<in> V \<or>
      in_degree G v \<le> 2 \<and> (\<exists>x p y. gen_iapath V x p y \<and> v \<in> set (awalk_verts x p))) \<and>
    (\<forall>e \<in> parcs G. fst e \<noteq> snd e \<and> (\<exists>x p y. gen_iapath V x p y \<and> e \<in> set p)) \<and>
    (\<forall>u v p q. (gen_iapath V u p v \<and> gen_iapath V u q v) \<longrightarrow> p = q) \<and>
    V \<subseteq> pverts G"

definition direct_arc :: "'a \<times> 'a \<Rightarrow> 'a \<times> 'a" where
  "direct_arc uv \<equiv> SOME e. {fst uv , snd uv} = {fst e, snd e}"

definition choose_iapath :: "'a \<Rightarrow> 'a \<Rightarrow> ('a \<times> 'a) awalk" where
  "choose_iapath u v \<equiv> (let
      chosen_path = (\<lambda>u v. SOME p. iapath u p v)
    in if direct_arc (u,v) = (u,v) then chosen_path u v else rev_path (chosen_path v u))"

(* XXX: Replace "parcs (contr_graph G)" by its definition *)
definition slim_paths :: "('a \<times> ('a \<times> 'a) awalk \<times> 'a) set" where
  "slim_paths \<equiv> (\<lambda>e. (fst e, choose_iapath (fst e) (snd e), snd e)) ` parcs (contr_graph G)"

definition slim_verts :: "'a set" where
  "slim_verts \<equiv> verts3 G \<union> (\<Union>(u,p,_) \<in> slim_paths. set (awalk_verts u p))"

definition slim_arcs :: "'a rel" where
  "slim_arcs \<equiv> \<Union>(_,p,_) \<in> slim_paths. set p"

text {* Computes a slim subgraph for an arbitrary @{term pair_digraph} *}
definition slim :: "'a pair_pre_digraph" where
  "slim \<equiv> \<lparr> pverts = slim_verts, parcs = slim_arcs \<rparr>"

end

context pair_sym_digraph begin

lemma choose_iapath:
  assumes "\<exists>p. iapath u p v"
  shows "iapath u (choose_iapath u v) v"
proof (cases "direct_arc (u,v) = (u,v)")
  def chosen \<equiv> "\<lambda>u v. SOME p. iapath u p v"
  { case True
    have "iapath u (chosen u v) v"
      unfolding chosen_def by (rule someI_ex) (rule assms)
    then show ?thesis using True by (simp add: choose_iapath_def chosen_def) }

  { case False
    from assms obtain p where "iapath u p v" by auto
    then have "iapath v (rev_path p) u"
      by (simp add: gen_iapath_rev_path)
    then have "iapath v (chosen v u) u"
      unfolding chosen_def by (rule someI)
    then show ?thesis using False
      by (simp add: choose_iapath_def chosen_def gen_iapath_rev_path) }
qed

lemma slim_simps: "pverts slim = slim_verts" "parcs slim = slim_arcs"
  by (auto simp: slim_def)

lemma slim_paths_in_G_E:
  assumes "(u,p,v) \<in> slim_paths" obtains "iapath u p v" "u \<noteq> v"
  using assms choose_iapath
  by (fastforce simp: gen_contr_graph_def slim_paths_def dest: iapath_dist_ends)

lemma verts_slim_in_G: "pverts slim \<subseteq> pverts G"
  by (auto simp: slim_simps slim_verts_def verts3_def gen_iapath_def apath_def
    elim!: slim_paths_in_G_E elim!: awalkE)

lemma verts3_in_slim_G[simp]:
  assumes "x \<in> verts3 G" shows "x \<in> pverts slim"
using assms by (auto simp: slim_simps slim_verts_def)

lemma arcs_slim_in_G: "parcs slim \<subseteq> parcs G"
  by (auto simp: slim_simps slim_arcs_def gen_iapath_def apath_def
      elim!: slim_paths_in_G_E elim!: awalkE)

lemma slim_paths_in_slimG:
  assumes "(u,p,v) \<in> slim_paths"
  shows "pre_digraph.gen_iapath slim (verts3 G) u p v \<and> p \<noteq> []"
proof -
  from assms have arcs: "\<And>e. e \<in> set p \<Longrightarrow> e \<in> parcs slim"
    by (auto simp: slim_simps slim_arcs_def)
  moreover
  from assms have "gen_iapath (verts3 G) u p v" and "p \<noteq> []"
    by (auto simp: gen_iapath_def elim!: slim_paths_in_G_E)
  ultimately show ?thesis
    by (auto simp: pre_digraph.gen_iapath_def pre_digraph.apath_def pre_digraph.awalk_def
      inner_verts_with_proj_def)
qed

lemma direct_arc_swapped:
  "direct_arc (u,v) = direct_arc (v,u)"
by (simp add: direct_arc_def insert_commute)

  have "\<exists>p::'a \<times> 'a. {u,v} = {fst p, snd p}" by (rule exI[where x="(u,v)"]) auto
  then have "{u,v} = {fst (f {u,v}), snd (f {u,v})}"
    unfolding f_def by (rule someI_ex)
  then have "f {u,v} = (u,v) \<or> f {u,v} = (v,u)"
    by (auto simp: doubleton_eq_iff prod_eq_iff)
  then show ?thesis by (auto simp: direct_arc_def f_def)
qed

lemma rev_path_choose_iapath:
  assumes "u \<noteq> v"
  shows "rev_path (choose_iapath u v) = choose_iapath v u"
  using assms direct_arc_chooses[of u v]
  by (auto simp: choose_iapath_def direct_arc_swapped)

lemma no_loops_in_iapath: "gen_iapath V u p v \<Longrightarrow> a \<in> set p \<Longrightarrow> fst a \<noteq> snd a"
  by (auto simp: gen_iapath_def no_loops_in_apath)

lemma pair_bidirected_digraph_slim: "pair_bidirected_digraph slim"
proof
  fix e assume A: "e \<in> parcs slim"
  then obtain u p v where "(u,p,v) \<in> slim_paths" "e \<in> set p" by (auto simp: slim_simps slim_arcs_def)
  with A have "iapath u p v" by (auto elim: slim_paths_in_G_E)
  with `e \<in> set p` have "fst e \<in> set (awalk_verts u p)" "snd e \<in> set (awalk_verts u p)"
    by (auto simp: set_awalk_verts gen_iapath_def apath_def)
  moreover
  from `_ \<in> slim_paths` have "set (awalk_verts u p) \<subseteq> pverts slim"
    by (auto simp: slim_simps slim_verts_def)
  ultimately
  show "fst e \<in> pverts slim" "snd e \<in> pverts slim" by auto

  show "fst e \<noteq> snd e"
    using \<open>iapath u p v\<close> \<open>e \<in> set p \<close> by (auto dest: no_loops_in_iapath)
next
  { fix e assume "e \<in> parcs slim"
    then obtain u p v where "(u,p,v) \<in> slim_paths" and "e \<in> set p"
      by (auto simp: slim_simps slim_arcs_def)
    moreover
    then have "iapath u p v" and "p \<noteq> []" and "u \<noteq> v" by (auto elim: slim_paths_in_G_E)
    then have "iapath v (rev_path p) u" and "rev_path p \<noteq> []" and "v \<noteq> u"
      by (auto simp: gen_iapath_rev_path)
    then have "(v,u) \<in> parcs (contr_graph G)"
      by (auto simp: gen_contr_graph_def)
    moreover
    from `iapath u p v` have "u \<noteq> v"
      by (auto simp: gen_iapath_def dest: apath_nonempty_ends)
    ultimately
    have "(v, rev_path p, u) \<in> slim_paths"
      by (auto simp: slim_paths_def rev_path_choose_iapath intro: rev_image_eqI)
    moreover
    from `e \<in> set p` have "(snd e, fst e) \<in> set (rev_path p)"
      by (induct p) auto
    ultimately have "(snd e, fst e) \<in> parcs slim"
     by (auto simp: slim_simps slim_arcs_def) }
  then show "symmetric slim"
    unfolding symmetric_conv by simp (metis fst_conv snd_conv)
qed

lemma (in pair_pseudo_graph) pair_graph_slim: "pair_graph slim"
proof -
  interpret slim: pair_bidirected_digraph slim by (rule pair_bidirected_digraph_slim)
  show ?thesis
  proof
    show "finite (pverts slim)"
      using verts_slim_in_G finite_verts by (rule finite_subset)
    show "finite (parcs slim)"
      using arcs_slim_in_G finite_arcs by (rule finite_subset)
  qed
qed

lemma subgraph_slim: "subgraph slim G"
proof (rule subgraphI)
  interpret H: pair_bidirected_digraph "slim"
    by (rule pair_bidirected_digraph_slim) intro_locales

  show "verts slim \<subseteq> verts G" "arcs slim \<subseteq> arcs G"
    by (auto simp: verts_slim_in_G arcs_slim_in_G)
  show "compatible G slim" ..
  show "wf_digraph slim" "wf_digraph G"
    by unfold_locales
qed

lemma giapath_if_slim_giapath:
  assumes "pre_digraph.gen_iapath slim (verts3 G) u p v"
  shows "gen_iapath (verts3 G) u p v"
using assms verts_slim_in_G arcs_slim_in_G
by (auto simp: pre_digraph.gen_iapath_def pre_digraph.apath_def pre_digraph.awalk_def
  inner_verts_with_proj_def)

lemma slim_giapath_if_giapath:
assumes "gen_iapath (verts3 G) u p v"
  shows "\<exists>p. pre_digraph.gen_iapath slim (verts3 G) u p v" (is "\<exists>p. ?P p")
proof
  from assms have choose_arcs: "\<And>e. e \<in> set (choose_iapath u v) \<Longrightarrow> e \<in> parcs slim"
    by (fastforce simp: slim_simps slim_arcs_def slim_paths_def gen_contr_graph_def)
  moreover
  from assms have choose: "iapath u (choose_iapath u v) v"
    by (intro choose_iapath) (auto simp: gen_iapath_def)
  ultimately show "?P (choose_iapath u v)"
    by (auto simp: pre_digraph.gen_iapath_def pre_digraph.apath_def pre_digraph.awalk_def
      inner_verts_with_proj_def)
qed

lemma contr_graph_slim_eq:
   "gen_contr_graph slim (verts3 G) = contr_graph G"
  using giapath_if_slim_giapath slim_giapath_if_giapath by (fastforce simp: gen_contr_graph_def)

end

context pair_pseudo_graph begin

lemma verts3_slim_in_verts3:
  assumes "v \<in> verts3 slim" shows "v \<in> verts3 G"
proof -
  from assms have "2 < in_degree slim v" by (auto simp: verts3_def)
  also have "\<dots> \<le> in_degree G v" using subgraph_slim by (rule subgraph_in_degree)
  finally show ?thesis using assms subgraph_slim by (fastforce simp: verts3_def)
qed

lemma slim_is_slim:
  "pair_pre_digraph.is_slim slim (verts3 G)"
proof (unfold pair_pre_digraph.is_slim_def, safe)
  interpret S: pair_graph slim by (rule pair_graph_slim)
  { fix v assume "v \<in> pverts slim" "v \<notin> verts3 G"
    then have "in_degree G v \<le> 2"
      using verts_slim_in_G by (auto simp: verts3_def)
    then show "in_degree slim v \<le> 2"
      using subgraph_in_degree[OF subgraph_slim, of v] by fastforce
  next
    fix w assume "w \<in> pverts slim" "w \<notin> verts3 G"
    then obtain u p v where upv: "(u, p, v) \<in> slim_paths" "w \<in> set (awalk_verts u p)"
      by (auto simp: slim_simps slim_verts_def)
    moreover
    then have "S.gen_iapath (verts3 G) u p v"
      using slim_paths_in_slimG by auto
    ultimately
    show "\<exists>x q y. S.gen_iapath (verts3 G) x q y
      \<and> w \<in> set (awalk_verts x q)"
      by auto
  next
    fix u v assume "(u,v) \<in> parcs slim"
    then obtain x p y where "(x, p, y) \<in> slim_paths" "(u,v) \<in> set p"
      by (auto simp: slim_simps slim_arcs_def)
    then have "S.gen_iapath (verts3 G) x p y \<and> (u,v) \<in> set p"
      using slim_paths_in_slimG by auto
    then show "\<exists>x p y. S.gen_iapath (verts3 G) x p y \<and> (u,v) \<in> set p"
      by blast
  next
    fix u v assume "(u,v) \<in> parcs slim" "fst (u,v) = snd (u,v)"
    then show False by (auto simp: S.no_loops')
  next
    fix u v p q
    assume paths: "S.gen_iapath (verts3 G) u p v"
          "S.gen_iapath (verts3 G) u q v"

    have V: "verts3 slim \<subseteq> verts3 G" "verts3 G \<subseteq> pverts slim"
      by (auto simp: verts3_slim_in_verts3)

    have "p = [] \<or> q = [] \<Longrightarrow> p = q" using paths
      by (auto simp: S.gen_iapath_def dest: S.apath_ends)
    moreover
    { assume "p \<noteq> []" "q \<noteq> []"
      { fix u p v assume "p \<noteq> []" and path: "S.gen_iapath (verts3 G) u p v"
        then obtain e where "e \<in> set p" by (metis last_in_set)
        then have "e \<in> parcs slim" using path by (auto simp: S.gen_iapath_def S.apath_def)
        then obtain x r y where "(x,r,y) \<in> slim_paths" "e \<in> set r"
          by (auto simp: slim_simps slim_arcs_def)
        then have "S.gen_iapath (verts3 G) x r y" by (metis slim_paths_in_slimG)
        with `e \<in> set r` `e \<in> set p` path have "p = r"
          by (auto intro: S.same_gen_iapath_by_common_arc[OF V])
        then have "x = u" "y = v" using path `S.gen_iapath (verts3 G) x r y` `p = r` `p \<noteq> []`
          by (auto simp: S.gen_iapath_def S.apath_def dest: S.awalk_ends)
        then have "(u,p,v) \<in> slim_paths" using `p = r` `(x,r,y) \<in> slim_paths` by simp }
      note obt = this
      from `p \<noteq> []` `q \<noteq> []` paths have "(u,p,v) \<in> slim_paths" "(u,q,v) \<in> slim_paths"
        by (auto intro: obt)
      then have "p = q" by (auto simp: slim_paths_def)
    }
    ultimately show "p = q" by metis
  }
qed auto

end

context pair_sym_digraph begin

lemma
  assumes p: "gen_iapath (pverts G) u p v"
  shows gen_iapath_triv_path: "p = [(u,v)]"
    and gen_iapath_triv_arc: "(u,v) \<in> parcs G"
proof -
  have "set (inner_verts p) = {}"
  proof -
    have *: "\<And>A B :: 'a set. \<lbrakk>A \<subseteq> B; A \<inter> B = {}\<rbrakk> \<Longrightarrow> A = {}" by blast
    have "set (inner_verts p) = set (awalk_verts u p) - {u, v}"
      using p by (simp add: set_inner_verts gen_iapath_def)
    also have "\<dots> \<subseteq> pverts G"
      using p unfolding gen_iapath_def apath_def awalk_conv by auto
    finally show ?thesis
      using p by (rule_tac *) (auto simp: gen_iapath_def)
  qed
  then have "inner_verts p = []" by simp
  then show "p = [(u,v)]" using p
    by (cases p) (auto simp: gen_iapath_def apath_def inner_verts_def split: if_split_asm)
  then show "(u,v) \<in> parcs G"
    using p by (auto simp: gen_iapath_def apath_def)
qed

lemma gen_contr_triv:
  assumes "is_slim V" "pverts G = V" shows "gen_contr_graph G V = G"
proof -
  let ?gcg = "gen_contr_graph G V"

  from assms have "pverts ?gcg = pverts G"
    by (auto simp: gen_contr_graph_def is_slim_def)
  moreover
  have "parcs ?gcg = parcs G"
  proof (rule set_eqI, safe)
    fix u v assume "(u,v) \<in> parcs ?gcg"
    then obtain p where "gen_iapath V u p v"
      by (auto simp: gen_contr_graph_def)
    then show "(u,v) \<in> parcs G"
      using gen_iapath_triv_arc `pverts G = V` by auto
  next
    fix u v assume "(u,v) \<in> parcs G"
    with assms obtain x p y where path: "gen_iapath V x p y" "(u,v) \<in> set p" "u \<noteq> v"
      by (auto simp: is_slim_def)
    with `pverts G = V` have "p = [(x,y)]" by (intro gen_iapath_triv_path) auto
    then show "(u,v) \<in> parcs ?gcg"
      using path by (auto simp: gen_contr_graph_def)
  qed
  ultimately
  show "?gcg = G" by auto
qed

lemma is_slim_no_loops:
  assumes "is_slim V" "a \<in> arcs G" shows "fst a \<noteq> snd a"
  using assms by (auto simp: is_slim_def)

end

subsection {* Contraction Preserves Kuratowski-Subgraph-Property *}

lemma (in pair_pseudo_graph) in_degree_contr:
  assumes "v \<in> V" and V: "verts3 G \<subseteq> V" "V \<subseteq> verts G"
  shows "in_degree (gen_contr_graph G V) v \<le> in_degree G v"
proof -
  have fin: "finite {(u, p). gen_iapath V u p v}"
  proof -
    have "{(u, p). gen_iapath V u p v} \<subseteq> (\<lambda>(u,p,_). (u,p)) ` {(u,p,v). apath u p v}"
      by (force simp: gen_iapath_def)
    with apaths_finite_triple show ?thesis by (rule finite_surj)
  qed

  have io_snd: "inj_on snd {(u,p). gen_iapath V u p v}"
    by (rule inj_onI) (auto simp: gen_iapath_def apath_def dest: awalk_ends)

  have io_last: "inj_on last {p. \<exists>u. gen_iapath V u p v}"
  proof (rule inj_onI, safe)
    fix u1 u2 p1 p2
    assume A: "last p1 = last p2" and B: "gen_iapath V u1 p1 v" "gen_iapath V u2 p2 v"
    from B have "last p1 \<in> set p1" "last p2 \<in> set p2" by (auto simp: gen_iapath_def)
    with A have "last p1 \<in> set p1" "last p1 \<in> set p2" by simp_all
    with V[simplified] B show "p1 = p2" by (rule same_gen_iapath_by_common_arc)
  qed

  have "in_degree (gen_contr_graph G V) v = card ((\<lambda>(u,_). (u,v)) ` {(u,p). gen_iapath V u p v})"
  proof -
    have "in_arcs (gen_contr_graph G V) v = (\<lambda>(u,_). (u,v)) ` {(u,p). gen_iapath V u p v}"
      by (auto simp: gen_contr_graph_def)
    then show ?thesis unfolding in_degree_def by simp
  qed
  also have "\<dots> \<le> card {(u,p). gen_iapath V u p v}"
    using fin by (rule card_image_le)
  also have "\<dots> = card (snd ` {(u,p). gen_iapath V u p v})"
    using io_snd by (rule card_image[symmetric])
  also have "snd ` {(u,p). gen_iapath V u p v} = {p. \<exists>u. gen_iapath V u p v}"
    by (auto intro: rev_image_eqI)
  also have "card \<dots> = card (last ` ...)"
    using io_last by (rule card_image[symmetric])
  also have "\<dots> \<le> in_degree G v"
    unfolding in_degree_def
  proof (rule card_mono)
    show "last ` {p. \<exists>u. gen_iapath V u p v} \<subseteq> in_arcs G v"
    proof -
      have "\<And>u p. awalk u p v \<Longrightarrow> p \<noteq> [] \<Longrightarrow> last p \<in> parcs G"
        by (auto simp: awalk_def)
      moreover
      { fix u p assume "awalk u p v" "p \<noteq> []"
        then have "snd (last p) = v" by (induct p arbitrary: u) (auto simp: awalk_simps) }
      ultimately
      show ?thesis unfolding in_arcs_def by (auto simp: gen_iapath_def apath_def)
    qed
  qed auto
  finally show ?thesis .
qed

lemma (in pair_graph) contracted_no_degree2_simp:
  assumes subd: "subdivision_pair G H"
  assumes two_less_deg2: "verts3 G = pverts G"
  shows "contr_graph H = G"
  using subd
proof (induct rule: subdivision_pair_induct)
  case base

  { fix e assume "e \<in> parcs G"
    then have "gen_iapath (pverts G) (fst e) [(fst e, snd e)] (snd e)" "e \<in> set [(fst e, snd e)]"
      using no_loops[of "(fst e, snd e)"] by (auto simp: gen_iapath_def apath_simps )
    then have "\<exists>u p v. gen_iapath (pverts G) u p v \<and> e \<in> set p" by blast }
  moreover
  { fix u p v assume "gen_iapath (pverts G) u p v"
    from `gen_iapath _ u p v` have "p = [(u,v)]"
      unfolding gen_iapath_def apath_def
      by safe (cases p, case_tac [2] list, auto simp: awalk_simps inner_verts_def) }
  ultimately have "is_slim (verts3 G)" unfolding is_slim_def two_less_deg2
    by (blast dest: no_loops_in_iapath)
  then show ?case by (simp add: gen_contr_triv two_less_deg2)
next
  case (divide e w H)
  let ?sH = "subdivide H e w"
  from `subdivision_pair G H` interpret H: pair_bidirected_digraph H
    by (rule bidirected_digraphI_subdivision)
  from divide(1,2) interpret S: pair_sym_digraph ?sH by (rule H.pair_sym_digraph_subdivide)
  obtain u v where e_conv:"e = (u,v)" by (cases e) auto
  have "contr_graph ?sH = contr_graph H"
  proof -
    have V_cond: "verts3 H \<subseteq> pverts H" by (auto simp: verts3_def)
    have "verts3 H = verts3 ?sH"
      using divide by (simp add: H.verts3_subdivide)
    then have v: "pverts (contr_graph ?sH) = pverts (contr_graph H)"
      by (auto simp: gen_contr_graph_def)
    moreover
    then have "parcs (contr_graph ?sH) = parcs (contr_graph H)"
      unfolding gen_contr_graph_def
      by (auto dest: H.gen_iapath_co_path[OF divide(1,2) V_cond]
          H.gen_iapath_sd_path[OF divide(1,2) V_cond])
    ultimately show ?thesis by auto
  qed
  then show ?case using divide by simp
qed

(* could be generalized *)
lemma verts3_K33:
  assumes "K\<^bsub>3,3\<^esub> (with_proj G)"
  shows "verts3 G = verts G"
proof -
  { fix v assume "v \<in> pverts G"
    from assms obtain U V where cards: "card U = 3" "card V=3"
      and UV: "U \<inter> V = {}" "pverts G = U \<union> V" "parcs G = U \<times> V \<union> V \<times> U"
      unfolding complete_bipartite_digraph_pair_def by blast
    have "2 < in_degree G v"
    proof (cases "v \<in> U")
      case True
      then have "in_arcs G v = V \<times> {v}" using UV by fastforce
      then show ?thesis using cards by (auto simp: card_cartesian_product in_degree_def)
    next
      case False
      then have "in_arcs G v = U \<times> {v}" using `v \<in> _` UV by fastforce
      then show ?thesis using cards by (auto simp: card_cartesian_product in_degree_def)
    qed }
  then show ?thesis by (auto simp: verts3_def)
qed

(* could be generalized *)
lemma verts3_K5:
  assumes "K\<^bsub>5\<^esub> (with_proj G)"
  shows "verts3 G = verts G"
proof -
  interpret pgG: pair_graph G using assms by (rule pair_graphI_complete)
  { fix v assume "v \<in> pverts G"
    have "2 < (4 :: nat)" by simp
    also have "4 = card (pverts G - {v})"
      using assms `v \<in> pverts G` unfolding complete_digraph_def by auto
    also have "pverts G - {v} = {u \<in> pverts G. u \<noteq> v}"
      by auto
    also have "card \<dots> = card ({u \<in> pverts G. u \<noteq> v} \<times> {v})" (is "_ = card ?A")
      by auto
    also have "?A = in_arcs G v"
      using assms `v \<in> pverts G` unfolding complete_digraph_def by safe auto
    also have "card \<dots> = in_degree G v"
      unfolding in_degree_def ..
    finally have "2 < in_degree G v" . }
  then show ?thesis unfolding verts3_def by auto
qed

lemma K33_contractedI:
  assumes subd: "subdivision_pair G H"
  assumes k33: "K\<^bsub>3,3\<^esub> G"
  shows "K\<^bsub>3,3\<^esub> (contr_graph H)"
proof -
  interpret pgG: pair_graph G using k33 by (rule pair_graphI_complete_bipartite)
  show ?thesis
    using assms by (auto simp: pgG.contracted_no_degree2_simp verts3_K33)
qed

lemma K5_contractedI:
  assumes subd: "subdivision_pair G H"
  assumes k5: "K\<^bsub>5\<^esub> G"
  shows "K\<^bsub>5\<^esub> (contr_graph H)"
proof -
  interpret pgG: pair_graph G using k5 by (rule pair_graphI_complete)
  show ?thesis
    using assms by (auto simp add: pgG.contracted_no_degree2_simp verts3_K5)
qed

subsection {* Final proof *}

context pair_sym_digraph begin

lemma gcg_subdivide_eq:
  assumes mem: "e \<in> parcs G" "w \<notin> pverts G"
  assumes V: "V \<subseteq> pverts G"
  shows "gen_contr_graph (subdivide G e w) V = gen_contr_graph G V"
proof -
  interpret sdG: pair_sym_digraph "subdivide G e w"
    using mem by (rule pair_sym_digraph_subdivide)
  { fix u p v assume "sdG.gen_iapath V u p v"
    have "gen_iapath V u (co_path e w p) v"
      using mem V `sdG.gen_iapath V u p v` by (rule gen_iapath_co_path)
    then have "\<exists>p. gen_iapath V u p v" ..
  } note A = this
  moreover
  { fix u p v assume "gen_iapath V u p v"
    have "sdG.gen_iapath V u (sd_path e w p) v"
      using mem V `gen_iapath V u p v` by (rule gen_iapath_sd_path)
    then have "\<exists>p. sdG.gen_iapath V u p v" ..
  } note B = this
  ultimately show ?thesis using assms by (auto simp: gen_contr_graph_def)
qed

lemma co_path_append:
  assumes "[last p1, hd p2] \<notin> {[(fst e,w),(w,snd e)], [(snd e,w),(w,fst e)]}"
  shows "co_path e w (p1 @ p2) = co_path e w p1 @ co_path e w p2"
using assms
proof (induct p1 rule: co_path_induct)
  case single then show ?case by (cases p2) auto
next
  case (co e1 e2 es) then show ?case by (cases es) auto
next
  case (corev e1 e2 es) then show ?case by (cases es) auto
qed auto

lemma exists_co_path_decomp1:
  assumes mem: "e \<in> parcs G" "w \<notin> pverts G"
  assumes p: "pre_digraph.apath (subdivide G e w) u p v" "(fst e, w) \<in> set p" "w \<noteq> v"
  shows "\<exists>p1 p2. p = p1 @ (fst e, w) # (w, snd e) # p2"
proof -
  let ?sdG = "subdivide G e w"
  interpret sdG: pair_sym_digraph ?sdG
    using mem by (rule pair_sym_digraph_subdivide)
  obtain p1 p2 z where p_decomp: "p = p1 @ (fst e, w) # (w, z) # p2" "fst e \<noteq> z" "w \<noteq> z"
    by atomize_elim (rule sdG.apath_succ_decomp[OF p])
  then have "(fst e,w) \<in> parcs ?sdG" "(w, z) \<in> parcs ?sdG"
    using p by (auto simp: sdG.apath_def)
  with `fst e \<noteq> z` have "z = snd e"
    using mem by (cases e) (auto simp: wellformed')
  with p_decomp show ?thesis by fast
qed

lemma is_slim_if_subdivide:
  assumes "pair_pre_digraph.is_slim (subdivide G e w) V"
  assumes mem1: "e \<in> parcs G" "w \<notin> pverts G" and mem2: "w \<notin> V"
  shows "is_slim V"
proof -
  let ?sdG = "subdivide G e w"
  interpret sdG: pair_sym_digraph "subdivide G e w"
    using mem1 by (rule pair_sym_digraph_subdivide)
  obtain u v where "e = (u,v)" by (cases e) auto
  with mem1 have "u \<in> pverts G" "v \<in> pverts G" by (auto simp: wellformed')
  with mem1  have "u \<noteq> w" "v \<noteq> w" by auto

  let ?w_parcs = "{(u,w), (v,w), (w,u), (w, v)}"
  have sdg_new_parcs: "?w_parcs \<subseteq> parcs ?sdG"
    using `e = (u,v)` by auto
  have sdg_no_parcs: "(u,v) \<notin> parcs ?sdG" "(v,u) \<notin> parcs ?sdG"
    using `e = (u,v)` `u \<noteq> w` `v \<noteq> w` by auto

  { fix z assume A: "z \<in> pverts G"
    have "in_degree ?sdG z = in_degree G z"
    proof -
      { assume "z \<noteq> u" "z \<noteq> v"
        then have "in_arcs ?sdG z = in_arcs G z"
          using `e = (u,v)` mem1 A by auto
        then have "in_degree ?sdG z = in_degree G z" by (simp add: in_degree_def) }
      moreover
      { assume "z = u"
        then have "in_arcs G z = in_arcs ?sdG z \<union> {(v,u)} - {(w,u)}"
          using `e = (u,v)` mem1 by (auto simp: intro: arcs_symmetric wellformed')
        moreover
        have "card (in_arcs ?sdG z \<union> {(v,u)} - {(w,u)}) = card (in_arcs ?sdG z)"
          using sdg_new_parcs sdg_no_parcs `z = u` by (cases "finite (in_arcs ?sdG z)") (auto simp: in_arcs_def)
        ultimately have "in_degree ?sdG z= in_degree G z" by (simp add: in_degree_def) }
      moreover
      { assume "z = v"
        then have "in_arcs G z = in_arcs ?sdG z \<union> {(u,v)} - {(w,v)}"
          using `e = (u,v)` mem1 A by (auto simp: wellformed')
        moreover
        have "card (in_arcs ?sdG z \<union> {(u,v)} - {(w,v)}) = card (in_arcs ?sdG z)"
          using sdg_new_parcs sdg_no_parcs `z = v` by (cases "finite (in_arcs ?sdG z)") (auto simp: in_arcs_def)
        ultimately have "in_degree ?sdG z= in_degree G z" by (simp add: in_degree_def) }
      ultimately show ?thesis by metis
    qed }
  note in_degree_same = this

  have V_G: "V \<subseteq> pverts G" "verts3 G \<subseteq> V"
  proof -
    have "V \<subseteq> pverts ?sdG" "pverts ?sdG = pverts G \<union> {w}" "verts3 ?sdG \<subseteq> V" "verts3 G \<subseteq> verts3 ?sdG"
      using `sdG.is_slim V` `e = (u,v)` in_degree_same mem1
      unfolding sdG.is_slim_def verts3_def
      by (fast, simp, fastforce, force)
    then show "V \<subseteq> pverts G" "verts3 G \<subseteq> V" using `w \<notin> V` by auto
  qed

  have pverts: "\<forall>v\<in>pverts G. v \<in> V \<or> in_degree G v \<le> 2 \<and> (\<exists>x p y. gen_iapath V x p y \<and> v \<in> set (awalk_verts x p))"
  proof -
    { fix z assume A: "z \<in> pverts G" "z \<notin> V"
      have "z \<in> pverts ?sdG" using `e = (u,v)` A mem1 by auto
      then have "in_degree ?sdG z \<le> 2"
        using `sdG.is_slim V` A by (auto simp: sdG.is_slim_def)
      with in_degree_same[OF `z \<in> pverts G`] have idg: "in_degree G z \<le> 2" by auto

      from A have "z \<in> pverts ?sdG" "z \<notin> V" using `e = (u,v)` mem1 by auto
      then obtain x' q y' where "sdG.gen_iapath V x' q y'" "z \<in> set (sdG.awalk_verts x' q)"
        using `sdG.is_slim V` unfolding sdG.is_slim_def by metis
      then have "gen_iapath V x' (co_path e w q) y'" "z \<in> set (awalk_verts x' (co_path e w q))"
        using A mem1 V_G by (auto simp: set_awalk_verts_co_path' intro: gen_iapath_co_path)
      with idg have "in_degree G z \<le> 2 \<and> (\<exists>x p y. gen_iapath V x p y \<and> z \<in> set (awalk_verts x p))"
        by metis }
    then show ?thesis by auto
  qed

  have parcs: "\<forall>e\<in>parcs G. fst e \<noteq> snd e \<and> (\<exists>x p y. gen_iapath V x p y \<and> e \<in> set p)"
  proof (intro ballI conjI)
    fix e' assume "e' \<in> parcs G"

    show "(\<exists>x p y. gen_iapath V x p y \<and> e' \<in> set p)"
    proof (cases "e' \<in> parcs ?sdG")
      case True
      then obtain x p y where "sdG.gen_iapath V x p y" "e' \<in> set p"
        using `sdG.is_slim V` by (auto simp: sdG.is_slim_def)
      with `e \<in> parcs G` `w \<notin> pverts G` V_G have "gen_iapath V x (co_path e w p) y"
        by (auto intro: gen_iapath_co_path)

      from `e' \<in> parcs G` have "e' \<notin> ?w_parcs" using mem1 by (auto simp: wellformed')
      with `e' \<in> set p` have "e' \<in> set (co_path e w p)"
        by (induct p rule: co_path_induct) (force simp: `e = (u,v)`)+
      then show "\<exists>x p y. gen_iapath V x p y \<and> e' \<in> set p "
        using `gen_iapath V x (co_path e w p) y`  by fast
    next
      assume "e' \<notin> parcs ?sdG"
      def a \<equiv> "fst e'" and b \<equiv> "snd e'"
      then have "e' = (a,b)" and ab: "(a,b) = (u,v) \<or> (a,b) = (v,u)"
        using `e' \<in> parcs G` `e' \<notin> parcs ?sdG` `e = (u,v)` mem1 by auto
      obtain x p y where "sdG.gen_iapath V x p y" "(a,w) \<in> set p"
        using `sdG.is_slim V` sdg_new_parcs ab by (auto simp: sdG.is_slim_def)
      with `e \<in> parcs G` `w \<notin> pverts G` V_G have "gen_iapath V x (co_path e w p) y"
        by (auto intro: gen_iapath_co_path)

      have "(a,b) \<in> parcs G" "subdivide G (a,b) w = subdivide G e w"
        using mem1 `e = (u,v)` `e' = (a,b)` ab
        by (auto intro: arcs_symmetric simp: subdivide.simps)
      then have "pre_digraph.apath (subdivide G (a,b) w) x p y" "w \<noteq> y"
        using mem2 `sdG.gen_iapath V x p y` by (auto simp: sdG.gen_iapath_def)
      then obtain p1 p2 where "p = p1 @ (a,w) # (w,b) # p2"
        using exists_co_path_decomp1 `(a,b) \<in> parcs G` `w \<notin> pverts G` `(a,w) \<in> set p` `w \<noteq> y`
        by atomize_elim auto
      moreover
      then have "co_path e w ((a,w) # (w,b) # p2) = (a,b) # co_path e w p2"
        unfolding `e = (u,v)` using ab by auto
      ultimately
      have "(a,b) \<in> set (co_path e w p)"
        unfolding `e = (u,v)` using ab `u \<noteq> w` `v \<noteq> w`
        by (induct p rule: co_path_induct) (auto simp: co_path_append)
      then show ?thesis
        using `gen_iapath V x (co_path e w p) y` `e' = (a,b)` by fast
    qed
    then show "fst e' \<noteq> snd e'" by (blast dest: no_loops_in_iapath)
  qed

  have unique: "\<forall>u v p q. (gen_iapath V u p v \<and> gen_iapath V u q v) \<longrightarrow> p = q"
  proof safe
    fix x y p q assume A: "gen_iapath V x p y" "gen_iapath V x q y"
    then have "set p \<subseteq> parcs G" "set q \<subseteq> parcs G"
      by (auto simp: gen_iapath_def apath_def)
    then have w_p: "(u,w) \<notin> set p" "(v,w) \<notin> set p" and w_q: "(u,w) \<notin> set q" "(v,w) \<notin> set q"
      using mem1 by (auto simp: wellformed')

    from A have "sdG.gen_iapath V x (sd_path e w p) y" "sdG.gen_iapath V x (sd_path e w q) y"
      using mem1 V_G by (auto intro: gen_iapath_sd_path)
    then have "sd_path e w p = sd_path e w q"
      using `sdG.is_slim V` unfolding sdG.is_slim_def by metis
    then have "co_path e w (sd_path e w p) = co_path e w (sd_path e w q)" by simp
    then show "p = q" using w_p w_q `e = (u,v)` by (simp add: co_sd_id)
  qed

  from pverts parcs V_G unique show ?thesis by (auto simp: is_slim_def)
qed

end

context pair_pseudo_graph begin

lemma subdivision_gen_contr:
  assumes "is_slim V"
  shows "subdivision_pair (gen_contr_graph G V) G"
using assms using pair_pseudo_graph
proof (induct "card (pverts G - V)" arbitrary: G)
  case 0
  interpret G: pair_pseudo_graph G by fact
  have "pair_bidirected_digraph G"
    using G.pair_sym_arcs 0 by unfold_locales (auto simp: G.is_slim_def)
  with 0 show ?case
    by (auto intro: subdivision_pair_intros simp: G.gen_contr_triv G.is_slim_def)
next
  case (Suc n)
  interpret G: pair_pseudo_graph G by fact

  from `Suc n = card (pverts G - V)`
  have "pverts G - V \<noteq> {}"
    by (metis Nat.diff_le_self Suc_n_not_le_n card_Diff_subset_Int diff_Suc_Suc empty_Diff finite.emptyI inf_bot_left)
  then obtain w where "w \<in> pverts G - V" by auto
  then obtain x q y where q: "G.gen_iapath V x q y" "w \<in> set (G.awalk_verts x q)" "in_degree G w \<le> 2"
    using `G.is_slim V` by (auto simp: G.is_slim_def)
  then have "w \<noteq> x" "w \<noteq> y" "w \<notin> V" using `w \<in> pverts G - V` by (auto simp: G.gen_iapath_def)
  then obtain e where "e \<in> set q" "snd e = w"
    using `w \<in> pverts G - V` q
    unfolding G.gen_iapath_def G.apath_def G.awalk_conv
    by (auto simp: G.awalk_verts_conv')
  moreover def u \<equiv> "fst e"
  ultimately obtain q1 q2 v where q_decomp: "q = q1 @ (u, w) # (w, v) # q2" "u \<noteq> v" "w \<noteq> v"
    using q `w \<noteq> y` unfolding G.gen_iapath_def by atomize_elim (rule G.apath_succ_decomp, auto)
  with q have qi_walks: "G.awalk x q1 u" "G.awalk v q2 y"
    by (auto simp: G.gen_iapath_def G.apath_def G.awalk_Cons_iff)

  from q q_decomp have uvw_arcs1: "(u,w) \<in> parcs G" "(w,v) \<in> parcs G"
    by (auto simp: G.gen_iapath_def G.apath_def)
  then have uvw_arcs2: "(w,u) \<in> parcs G" "(v,w) \<in> parcs G"
    by (blast intro: G.arcs_symmetric)+

  have "u \<noteq> w" "v \<noteq> w" using q_decomp q
    by (auto simp: G.gen_iapath_def G.apath_append_iff G.apath_simps)

  have in_arcs: "in_arcs G w = {(u,w), (v,w)}"
  proof -
    have "{(u,w), (v,w)} \<subseteq> in_arcs G w"
      using uvw_arcs1 uvw_arcs2 by (auto simp: )
    moreover note `in_degree G w \<le> 2`
    moreover have "card {(u,w), (v,w)} = 2" using `u \<noteq> v` by auto
    ultimately
    show ?thesis by - (rule card_seteq[symmetric], auto simp: in_degree_def)
  qed
  have out_arcs: "out_arcs G w \<subseteq> {(w,u), (w,v)}" (is "?L \<subseteq> ?R")
  proof
    fix e assume "e \<in> out_arcs G w"
    then have "(snd e, fst e) \<in> in_arcs G w"
      by (auto intro: G.arcs_symmetric)
    then show "e \<in> {(w, u), (w, v)}" using in_arcs by auto
  qed

  have "(u,v) \<notin> parcs G"
  proof
    assume "(u,v) \<in> parcs G"
    have "G.gen_iapath V x (q1 @ (u,v) # q2) y"
    proof -
      have awalk': "G.awalk x (q1 @ (u,v) # q2) y"
        using qi_walks `(u,v) \<in> parcs G`
        by (auto simp: G.awalk_simps)

      have "G.awalk x q y" using `G.gen_iapath V x q y` by (auto simp: G.gen_iapath_def G.apath_def)

      have "distinct (G.awalk_verts x (q1 @ (u,v) # q2))"
        using awalk' `G.gen_iapath V x q y` unfolding q_decomp
        by (auto simp: G.gen_iapath_def G.apath_def G.awalk_verts_append)
      moreover
      have "set (G.inner_verts (q1 @ (u,v) # q2)) \<subseteq> set (G.inner_verts q)"
        using awalk' `G.awalk x q y` unfolding q_decomp
        by (auto simp: butlast_append G.inner_verts_conv[of _ x] G.awalk_verts_append
          intro: in_set_butlast_appendI)
      then have "set (G.inner_verts (q1 @ (u,v) # q2)) \<inter> V = {}"
        using `G.gen_iapath V x q y` by (auto simp: G.gen_iapath_def)
      ultimately show ?thesis using awalk' `G.gen_iapath V x q y` by (simp add: G.gen_iapath_def G.apath_def)
    qed
    then have "(q1 @ (u,v) # q2) = q"
      using `G.gen_iapath V x q y` `G.is_slim V` unfolding G.is_slim_def by metis
    then show False unfolding q_decomp by simp
  qed
  then have "(v,u) \<notin> parcs G" by (auto intro: G.arcs_symmetric)

  def G' \<equiv> "\<lparr>pverts = pverts G - {w},
      parcs = {(u,v), (v,u)} \<union> (parcs G - {(u,w), (w,u), (v,w), (w,v)})\<rparr>"

  have mem_G': "(u,v) \<in> parcs G'" "w \<notin> pverts G'" by (auto simp: G'_def)

  interpret pd_G': pair_fin_digraph G'
  proof
    fix e assume A: "e \<in> parcs G'"
    have "e \<in> parcs G \<and> e \<noteq> (u, w) \<and> e \<noteq> (w, u) \<and> e \<noteq> (v, w) \<and> e \<noteq> (w, v) \<Longrightarrow> fst e \<noteq> w"
      "e \<in> parcs G \<and> e \<noteq> (u, w) \<and> e \<noteq> (w, u) \<and> e \<noteq> (v, w) \<and> e \<noteq> (w, v) \<Longrightarrow> snd e \<noteq> w"
      using out_arcs in_arcs by auto
    with A uvw_arcs1 show "fst e \<in> pverts G'" "snd e \<in> pverts G'"
      using `u \<noteq> w` `v \<noteq> w` by (auto simp: G'_def G.wellformed')
  next
  qed (auto simp: G'_def arc_to_ends_def)

  interpret spd_G': pair_pseudo_graph G'
  proof (unfold_locales, simp add: symmetric_def)
    have "sym {(u,v), (v,u)}" "sym (parcs G)" "sym {(u, w), (w, u), (v, w), (w, v)}"
      using `symmetric G` by (auto simp: symmetric_def sym_def)
    then have "sym ({(u,v), (v,u)} \<union> (parcs G - {(u,w), (w,u), (v,w), (w,v)}))"
      by (intro sym_Un) (auto simp: sym_diff)
    then show "sym (parcs G')" unfolding G'_def by simp
  qed

  have card_G': "n = card (pverts G' - V)"
  proof -
    have "pverts G - V = insert w (pverts G' - V)"
      using `w \<in> pverts G - V` by (auto simp: G'_def)
    then show ?thesis using `Suc n = card (pverts G - V)` mem_G' by simp
  qed

  have G_is_sd: "G = subdivide G' (u,v) w" (is "_ = ?sdG'")
    using `w \<in> pverts G - V` `(u,v) \<notin> parcs G` `(v,u) \<notin> parcs G`  uvw_arcs1 uvw_arcs2
    by (intro pair_pre_digraph.equality) (auto simp: G'_def)

  have gcg_sd: "gen_contr_graph (subdivide G' (u,v) w) V = gen_contr_graph G' V"
  proof -
    have "V \<subseteq> pverts G"
      using `G.is_slim V` by (auto simp: G.is_slim_def verts3_def)
    moreover
    have "verts3 G' = verts3 G"
      by (simp only: G_is_sd spd_G'.verts3_subdivide[OF `(u,v) \<in> parcs G'` `w \<notin> pverts G'`])
    ultimately
    have V: "V \<subseteq> pverts G'"
      using `w \<in> pverts G - V` by (auto simp: G'_def)
    with mem_G' show ?thesis by (rule spd_G'.gcg_subdivide_eq)
  qed

  have is_slim_G': "pd_G'.is_slim V" using `G.is_slim V` mem_G' `w \<notin> V`
    unfolding G_is_sd by (rule spd_G'.is_slim_if_subdivide)
  with mem_G' have "subdivision_pair (gen_contr_graph G' V) (subdivide G' (u, v) w)"
    by (intro Suc card_G' subdivision_pair_intros) auto
  then show ?case by (simp add: gcg_sd G_is_sd)
qed

lemma  contr_is_subgraph_subdivision:
  shows "\<exists>H. subgraph (with_proj H) G \<and> subdivision_pair (contr_graph G) H"
proof -
  interpret sG: pair_graph slim by (rule pair_graph_slim)

  have "subdivision_pair (gen_contr_graph slim (verts3 G)) slim "
    by (rule sG.subdivision_gen_contr) (rule slim_is_slim)
  then show ?thesis unfolding contr_graph_slim_eq by (blast intro: subgraph_slim)
qed

theorem kuratowski_contr:
  fixes K :: "'a pair_pre_digraph"
  assumes subgraph_K: "subgraph K G"
  assumes spd_K: "pair_pseudo_graph K"
  assumes kuratowski: "K\<^bsub>3,3\<^esub> (contr_graph K) \<or> K\<^bsub>5\<^esub> (contr_graph K)"
  shows "\<not>kuratowski_planar G"
proof -
  interpret spd_K: pair_pseudo_graph K by (fact spd_K)
  obtain H where subgraph_H: "subgraph (with_proj H) K"
      and subdiv_H:"subdivision_pair (contr_graph K) H"
    by atomize_elim (rule spd_K.contr_is_subgraph_subdivision)
  have grI: "\<And>K. (K\<^bsub>3,3\<^esub> K \<or> K\<^bsub>5\<^esub> K) \<Longrightarrow> graph K"
    by (auto simp: complete_digraph_def complete_bipartite_digraph_def)
  from subdiv_H and kuratowski
  have "\<exists>K. subdivision_pair K H \<and> (K\<^bsub>3,3\<^esub> K \<or> K\<^bsub>5\<^esub> K)" by blast
  then have "\<exists>K rev_K rev_H. subdivision (K, rev_K) (H, rev_H) \<and> (K\<^bsub>3,3\<^esub> K \<or> K\<^bsub>5\<^esub> K)"
    by (auto intro: grI pair_graphI_graph)
  then show ?thesis using subgraph_H subgraph_K
    unfolding kuratowski_planar_def by (auto intro: subgraph_trans)
qed

theorem certificate_characterization:
  defines "kuratowski \<equiv> \<lambda>G :: 'a pair_pre_digraph. K\<^bsub>3,3\<^esub> G \<or> K\<^bsub>5\<^esub> G"
  shows "kuratowski (contr_graph G)
    \<longleftrightarrow> (\<exists>H. kuratowski H \<and> subdivision_pair H slim \<and> verts3 G = verts3 slim)" (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L
  interpret S: pair_graph slim by (rule pair_graph_slim)
  have "subdivision_pair (contr_graph G) slim"
  proof -
    have *: "S.is_slim (verts3 G)" by (rule slim_is_slim)
    show ?thesis using contr_graph_slim_eq S.subdivision_gen_contr[OF *] by auto
  qed
  moreover
  have "verts3 slim = verts3 G" (is "?l = ?r")
  proof safe
    fix v assume "v \<in> ?l" then show "v \<in> ?r"
      using verts_slim_in_G verts3_slim_in_verts3 by auto
  next
    fix v assume "v \<in> ?r"
    have "v \<in> verts3 (contr_graph G)"
    proof -
      have "v \<in> verts (contr_graph G)"
        using `v \<in> ?r` by (auto simp: verts3_def gen_contr_graph_def)
      then show ?thesis
        using `?L` unfolding kuratowski_def by (auto simp: verts3_K33 verts3_K5)
    qed
    then have "v \<in> verts3 (gen_contr_graph slim (verts3 G))" unfolding contr_graph_slim_eq .
    then have "2 < in_degree (gen_contr_graph slim (verts3 G)) v"
      unfolding verts3_def by auto
    also have "\<dots> \<le> in_degree slim v"
      using `v \<in> ?r` verts3_slim_in_verts3 by (auto intro: S.in_degree_contr)
    finally show "v \<in> verts3 slim"
      using verts3_in_slim_G `v \<in> ?r` unfolding verts3_def by auto
  qed
  ultimately show ?R using `?L` by auto
next
  assume ?R
  then have "kuratowski (gen_contr_graph slim (verts3 G))"
    unfolding kuratowski_def
    by (auto intro: K33_contractedI K5_contractedI)
  then show ?L unfolding contr_graph_slim_eq .
qed

definition (in pair_pre_digraph) certify :: "'a pair_pre_digraph \<Rightarrow> bool" where
  "certify cert \<equiv> let C = contr_graph cert in subgraph cert G \<and> (K\<^bsub>3,3\<^esub> C \<or> K\<^bsub>5\<^esub>C)"

theorem certify_complete:
  assumes "pair_pseudo_graph cert"
  assumes "subgraph cert G"
  assumes "\<exists>H. subdivision_pair H cert \<and> (K\<^bsub>3,3\<^esub> H \<or> K\<^bsub>5\<^esub> H)"
  shows "certify cert"
  unfolding certify_def
  using assms by (auto simp: Let_def intro: K33_contractedI K5_contractedI)

theorem certify_sound:
  assumes "pair_pseudo_graph cert"
  assumes "certify cert"
  shows" \<not>kuratowski_planar G"
  using assms by (intro kuratowski_contr) (auto simp: certify_def Let_def)

theorem certify_characterization:
  assumes "pair_pseudo_graph cert"
  shows "certify cert \<longleftrightarrow> subgraph cert G \<and> verts3 cert = verts3 (pair_pre_digraph.slim cert)
      \<and>(\<exists>H. (K\<^bsub>3,3\<^esub> (with_proj H) \<or> K\<^bsub>5\<^esub> H) \<and> subdivision_pair H (pair_pre_digraph.slim cert))"
      (is "?L \<longleftrightarrow> ?R")
  by (auto simp only: simp_thms certify_def Let_def pair_pseudo_graph.certificate_characterization[OF assms])

end

end


(*  Title:      HOL/ex/Set_Comprehension_Pointfree_Examples.thy
    Author:     Lukas Bulwahn, Rafal Kolanski
    Copyright   2012 TU Muenchen
*)

section \<open>Examples for the set comprehension to pointfree simproc\<close>

theory Set_Comprehension_Pointfree_Examples
imports Main
begin

declare [[simproc add: finite_Collect]]

lemma
  "finite (UNIV::'a set) ==> finite {p. EX x::'a. p = (x, x)}"
  by simp

lemma
  "finite A ==> finite B ==> finite {f a b| a b. a : A \<and> b : B}"
  by simp

lemma
  "finite B ==> finite A' ==> finite {f a b| a b. a : A \<and> a : A' \<and> b : B}"
  by simp

lemma
  "finite A ==> finite B ==> finite {f a b| a b. a : A \<and> b : B \<and> b : B'}"
  by simp

lemma
  "finite A ==> finite B ==> finite C ==> finite {f a b c| a b c. a : A \<and> b : B \<and> c : C}"
  by simp

lemma
  "finite A ==> finite B ==> finite C ==> finite D ==>
     finite {f a b c d| a b c d. a : A \<and> b : B \<and> c : C \<and> d : D}"
  by simp

lemma
  "finite A ==> finite B ==> finite C ==> finite D ==> finite E ==>
    finite {f a b c d e | a b c d e. a : A \<and> b : B \<and> c : C \<and> d : D \<and> e : E}"
  by simp

lemma
  "finite A ==> finite B ==> finite C ==> finite D ==> finite E \<Longrightarrow>
    finite {f a d c b e | e b c d a. b : B \<and> a : A \<and> e : E' \<and> c : C \<and> d : D \<and> e : E \<and> b : B'}"
  by simp

lemma
  "\<lbrakk> finite A ; finite B ; finite C ; finite D \<rbrakk>
  \<Longrightarrow> finite ({f a b c d| a b c d. a : A \<and> b : B \<and> c : C \<and> d : D})"
  by simp

lemma
  "finite ((\<lambda>(a,b,c,d). f a b c d) ` (A \<times> B \<times> C \<times> D))
  \<Longrightarrow> finite ({f a b c d| a b c d. a : A \<and> b : B \<and> c : C \<and> d : D})"
  by simp

lemma
  "finite S ==> finite {s'. EX s:S. s' = f a e s}"
  by simp

lemma
  "finite A ==> finite B ==> finite {f a b| a b. a : A \<and> b : B \<and> a \<notin> Z}"
  by simp

lemma
  "finite A ==> finite B ==> finite R ==> finite {f a b x y| a b x y. a : A \<and> b : B \<and> (x,y) \<in> R}"
by simp

lemma
  "finite A ==> finite B ==> finite R ==> finite {f a b x y| a b x y. a : A \<and> (x,y) \<in> R \<and> b : B}"
by simp

lemma
  "finite A ==> finite B ==> finite R ==> finite {f a (x, b) y| y b x a. a : A \<and> (x,y) \<in> R \<and> b : B}"
by simp

lemma
  "finite A ==> finite AA ==> finite B ==> finite {f a b| a b. (a : A \<or> a : AA) \<and> b : B \<and> a \<notin> Z}"
by simp

lemma
  "finite A1 ==> finite A2 ==> finite A3 ==> finite A4 ==> finite A5 ==> finite B ==>
     finite {f a b c | a b c. ((a : A1 \<and> a : A2) \<or> (a : A3 \<and> (a : A4 \<or> a : A5))) \<and> b : B \<and> a \<notin> Z}"
apply simp
oops

lemma "finite B ==> finite {c. EX x. x : B & c = a * x}"
by simp

lemma
  "finite A ==> finite B ==> finite {f a * g b |a b. a : A & b : B}"
by simp

lemma
  "finite S ==> inj (%(x, y). g x y) ==> finite {f x y| x y. g x y : S}"
  by (auto intro: finite_vimageI)

lemma
  "finite A ==> finite S ==> inj (%(x, y). g x y) ==> finite {f x y z | x y z. g x y : S & z : A}"
  by (auto intro: finite_vimageI)

lemma
  "finite S ==> finite A ==> inj (%(x, y). g x y) ==> inj (%(x, y). h x y)
    ==> finite {f a b c d | a b c d. g a c : S & h b d : A}"
  by (auto intro: finite_vimageI)

lemma
  assumes "finite S" shows "finite {(a,b,c,d). ([a, b], [c, d]) : S}"
using assms by (auto intro!: finite_vimageI simp add: inj_on_def)
  (* injectivity to be automated with further rules and automation *)

schematic_goal (* check interaction with schematics *)
  "finite {x :: ?'A \<Rightarrow> ?'B \<Rightarrow> bool. \<exists>a b. x = Pair_Rep a b}
   = finite ((\<lambda>(b :: ?'B, a:: ?'A). Pair_Rep a b) ` (UNIV \<times> UNIV))"
  by simp

declare [[simproc del: finite_Collect]]

section \<open>Testing simproc in code generation\<close>

definition union :: "nat set => nat set => nat set"
where
  "union A B = {x. x : A \<or> x : B}"

definition common_subsets :: "nat set => nat set => nat set set"
where
  "common_subsets S1 S2 = {S. S \<subseteq> S1 \<and> S \<subseteq> S2}"

definition products :: "nat set => nat set => nat set"
where
  "products A B = {c. EX a b. a : A & b : B & c = a * b}"

export_code products in Haskell

export_code union common_subsets products in Haskell

end


(*  Title:      IntNatAux.thy
    Author:     Roelof Oosterhuis
                2007  Rijksuniversiteit Groningen
*)

header {* Powers, prime numbers and divisibility *}

theory IntNatAux
imports
  "~~/src/HOL/Old_Number_Theory/Factorization"
  "~~/src/HOL/Old_Number_Theory/EvenOdd"
begin

text {* Contains lemmas about divisibility and coprimality of powers, as well as some results about parities and small powers. Most lemmas are developed for the integers as well as for the natural numbers. *}

subsection {* Auxiliary results *}

lemma make_relprime:
  "(a \<noteq> 0 \<or> b \<noteq> 0) \<Longrightarrow> \<exists> c d. a = gcd a b*c \<and> b = gcd a b*d \<and> gcd c d = 1"
proof -
  assume ab0: "a\<noteq>0 \<or> b\<noteq>0"
  let ?g = "gcd a b"
  have "?g dvd a \<and> ?g dvd b" by auto
  then obtain c d where abcd: "a = ?g*c \<and> b = ?g*d" by (auto simp add: dvd_def)
  moreover have "gcd c d=1"
  proof -
    from abcd have "?g*gcd c d=?g" by (auto simp add: gcd_mult_distrib2)
    moreover with ab0 have "?g \<noteq> 0" by (simp add: gcd_zero)
    ultimately show ?thesis by simp
  qed
  ultimately show ?thesis by auto
qed

lemma factor_exists_general: "(a::nat) \<noteq> 0 \<Longrightarrow> (\<exists> ps. primel ps \<and> prod ps = a)"
proof -
  assume a0: "a\<noteq>0"
  show ?thesis
  proof (case_tac "a=1")
    assume "a=1" hence "primel [] \<and> prod [] = a" by (auto simp add: primel_def)
    thus ?thesis by auto
  next
    assume "a\<noteq>1" with a0 have "a>Suc 0" by auto
    thus ?thesis by (rule factor_exists)
  qed
qed

lemma make_zrelprime: "(a \<noteq> 0 \<or> b \<noteq> 0)
  \<Longrightarrow> \<exists> c d. a = zgcd a b*c \<and> b = zgcd a b*d \<and> zgcd c d=1"
proof -
  assume ab0: "a \<noteq> 0 \<or> b \<noteq> 0"
  let ?g = "zgcd a b"
  have "?g dvd a \<and> ?g dvd b" by auto
  then obtain c d where abcd: "a = ?g*c \<and> b = ?g*d" by (auto simp add: dvd_def)
  moreover have "zgcd c d = 1"
  proof -
    from abcd have "?g * zgcd c d = ?g"
      by (auto simp add: zgcd_zmult_distrib2 zgcd_geq_zero)
    moreover with ab0 have "?g \<noteq> 0" by (auto simp add: zgcd_def gcd_zero)
    ultimately show ?thesis by auto
  qed
  ultimately show ?thesis by auto
qed

lemma int_nat_abs_eq_abs: "int(nat\<bar>x::int\<bar>) = \<bar>x\<bar>"
  by simp

lemma prime_impl_zprime_int: "prime (a::nat) \<Longrightarrow> zprime (int a)"
proof -
  assume pra: "prime a"
  show "zprime (int a)"
  proof -
    from pra have agr1: "1 < int a" by (unfold prime_def, auto)
    moreover have "!!m. m \<ge> 0 \<and> m dvd int a \<and> m \<noteq> int a \<Longrightarrow> m=1"
    proof -
      { fix m assume m: "m \<ge> 0 \<and> m dvd int a \<and> m \<noteq> int a"
        then obtain k::int where k: "int a = m*k" by (auto simp add: dvd_def)
        from m have "int (nat m) = m" by auto
        with k have "int a = (int (nat m)) * k" by simp
        hence "nat (int a) = nat ( (int (nat m)) * k )" by simp
        hence "a = nat ( (int (nat m)) * k )" by (simp only: nat_int)
        also have "\<dots> = (nat m) * (nat k)" by (simp add: nat_int nat_mult_distrib)
        finally have "nat m dvd a" by auto
        with pra have "nat m = a \<or> nat m = 1" by (auto simp add: prime_def)
        moreover from m have "nat m \<noteq> a" by auto
        ultimately have "nat m = 1" by auto
        hence "m = 1" by arith }
      thus "!!m. m \<ge> 0 \<and> m dvd int a \<and> m \<noteq> int a \<Longrightarrow> m=1" by auto
    qed
    ultimately show ?thesis by (auto simp add: zprime_def)
  qed
qed

lemma zprime_factor_exists: "(a::int) > 1 \<Longrightarrow> \<exists> p. zprime p \<and> p dvd a"
proof -
  assume a1: "a > 1" hence a: "int (nat a) = a" by (auto simp add: int_nat_eq)
  with a1 have "nat a > 1" by auto
  hence "\<exists> l. primel l \<and> prod l = nat a" by (simp only: factor_exists)
  then obtain l where l: "primel l \<and> prod l = nat a" by (auto)
  show ?thesis
  proof (cases l)
    case Nil with l have "nat a = 1" by auto
    with a1 show ?thesis by arith
  next
    case (Cons p ps)
    with l have "nat a = p*prod ps" and p: "prime p" by (auto simp add: primel_def)
    hence "int (nat a) = (int p)*int(prod ps)"
      by (auto simp add: int_mult)
    with a p have "zprime (int p) \<and> int p dvd a"
      by (auto simp add: prime_impl_zprime_int)
    thus ?thesis by blast
  qed
qed

lemma best_division_abs: "(x::int) > 0 \<Longrightarrow> \<exists> n. 2 * \<bar>y - n*x\<bar> \<le> x"
proof -
  assume x0: "x>0"
  then obtain b where b: "b \<ge> 0 \<and> b < x \<and> [y = b] (mod x)"
    by (blast dest: zcong_zless_unique)
  hence "x dvd (y-b)" by (simp only: zcong_def)
  then obtain m where "y-b = x*m" by (auto simp add: dvd_def)
  hence m: "b = y - m*x" by (simp only: ac_simps)
  show ?thesis
  proof (cases)
    assume "2*\<bar>b\<bar> \<le> x"
    with m show ?thesis by auto
  next
    assume "\<not> 2*\<bar>b\<bar> \<le> x"
    with b have bx: "2*b > x" by auto
    hence bx1: "2*(x-b) < x" by auto
    from b have bx2: "b-x < 0" by auto
    obtain n where "n = m+1" by simp
    hence "y - n*x = y - m*x - x" by (simp only: distrib_right mult_1_left)
    with m have n: "y - n*x = b-x" by simp
    with bx2 have pos: "-y + n*x > 0" by simp
    moreover from n bx1 have "2*(-y + n*x) < x" by simp
    ultimately have "2*\<bar>y - n*x\<bar> < x" by simp
    hence "2*\<bar>y - n*x\<bar> \<le> x" by (unfold zabs_def, auto)
    thus ?thesis by auto
  qed
qed

lemma best_odd_division_abs: "\<lbrakk> (x::int) > 0; x \<in> zOdd \<rbrakk>
  \<Longrightarrow> \<exists> n. 2 * \<bar>y - n*x\<bar> < x"
proof -
  assume "x>0" and odd: "x \<in> zOdd"
  then obtain n where n: "2 * \<bar>y - n*x\<bar> \<le> x" by (auto dest: best_division_abs)
  moreover have "x \<noteq> 2 * \<bar>y - n*x\<bar>"
  proof (rule ccontr, clarsimp)
    assume "x = 2*\<bar>y - n*x\<bar>"
    hence "x \<in> zEven" by (unfold zEven_def, auto)
    with odd show False by (auto simp only: odd_iff_not_even)
  qed
  ultimately have "2*\<bar>y - n*x\<bar> < x" by simp
  thus ?thesis by auto
qed

lemma zprime_2: "zprime 2"
  apply (auto simp add: zprime_def)
  apply (frule zdvd_imp_le, simp)
  apply (auto simp add: order_le_less dvd_def)
done

lemma zgcd1_iff_no_common_primedivisor:
  "(zgcd a b=1) = (\<not>(\<exists> p. zprime p \<and> p dvd a \<and> p dvd b))"
proof (rule ccontr, auto)
  fix p assume ab: "zgcd a b=1" and "p dvd a" and "p dvd b" and p: "zprime p"
  hence "p dvd a \<and> p dvd b" by simp
  hence "p dvd zgcd a b" by (simp add: zgcd_greatest_iff)
  with ab p show False by (unfold zprime_def, auto)
next
  let ?g = "zgcd a b"
  assume ps: "\<forall> p. zprime p \<longrightarrow> p dvd a \<longrightarrow> \<not> p dvd b"
  assume g1: "?g \<noteq> 1"
  moreover have "?g \<noteq> 0"
  proof (rule ccontr, simp)
    assume "a = 0 \<and> b = 0"
    hence "2 dvd a \<and> 2 dvd b" by simp
    with ps show False by (auto simp add: zprime_2)
  qed
  moreover have "?g \<ge> 0" by (rule zgcd_geq_zero)
  ultimately have "?g > 1" by arith
  then obtain p where "zprime p \<and> p dvd ?g"
    by (frule_tac a="?g" in zprime_factor_exists, auto)
  hence "zprime p \<and> p dvd a \<and> p dvd b" by (simp add: zgcd_greatest_iff)
  with ps show False by auto
qed

lemma pos_zmult_pos: "a > (0::int) \<Longrightarrow> a*b > 0 \<Longrightarrow> b > 0"
  apply (case_tac "b = 0", auto)
  apply (rule ccontr, subgoal_tac "b < 0", auto)
  apply (subgoal_tac "a*b < a*0", auto dest: zmult_zless_mono2)
done

subsection {* Parity of integers *}

lemma power_preserves_even: "n>0 \<Longrightarrow> (x^n \<in> zEven) = (x \<in> zEven)"
  apply (induct n, auto simp add: even_times_either)
  apply (case_tac "n\<noteq>0", auto dest: even_product)
done

lemma power_preserves_odd: "n>0 \<Longrightarrow> (x^n \<in> zOdd) = (x \<in> zOdd)"
  apply (induct n, auto, rule odd_mult_odd_prop, auto)
  apply (case_tac "n\<noteq>0", auto dest: odd_times_odd)
done

lemma even_plus_odd: "a \<in> zEven \<Longrightarrow> b \<in> zOdd \<Longrightarrow> a+b \<in> zOdd"
  apply (auto simp add: zEven_def zOdd_def)
  apply (rule_tac x="k+ka" in exI, auto)
done

lemma odd_plus_odd: "a \<in> zOdd \<Longrightarrow> b \<in> zOdd \<Longrightarrow> a+b \<in> zEven"
  apply (auto simp add: zEven_def zOdd_def)
  apply (rule_tac x="1+k+ka" in exI, auto)
done

lemma even_plus_odd_prop1: "a+b \<in> zOdd \<Longrightarrow> a \<in> zOdd \<Longrightarrow> b \<in> zEven"
  by (subgoal_tac "a+b - a \<in> zEven", auto dest: odd_minus_odd)

lemma even_plus_odd_prop2: "a+b \<in> zOdd \<Longrightarrow> a \<in> zEven \<Longrightarrow> b \<in> zOdd"
  by (subgoal_tac "a+b - a \<in> zOdd", auto dest: odd_minus_even)

subsection {* Powers of natural numbers *}

lemma gcd_1_power_left_distrib: "gcd a b = 1 \<Longrightarrow> gcd (a^n) b = 1"
  by (induct n, auto simp add: gcd_mult_cancel)

text {* NB: the next (identical) lemma is just added to illustrate the difference between Isar and Isabelle scripting. *}
lemma alternative_gcd_1_power_left_distrib: "gcd a b = 1 \<Longrightarrow> gcd(a^n) b = 1"
proof -
  assume ab: "gcd a b=1"
  thus "gcd (a^n) b = 1"
  proof (induct n)
    case 0
    show "gcd (a^0) b = 1" by auto
  next
    case (Suc n)
    hence "gcd (a^n) b = 1" by simp
    with ab have "gcd (a*a^n) b = 1" by (simp only: gcd_mult_cancel)
    thus "gcd (a^Suc n) b = 1" by simp
  qed
qed

lemma gcd_1_power_distrib: "gcd a b = 1 \<Longrightarrow> gcd(a^n) (b^n) = 1"
proof -
  assume "gcd a b=1"
  hence "gcd (a^n) b = 1" by (rule gcd_1_power_left_distrib)
  hence "gcd b (a^n) = 1" by (simp only: gcd_commute)
  hence "gcd (b^n) (a^n) = 1" by (rule gcd_1_power_left_distrib)
  thus "gcd (a^n) (b^n) = 1" by (simp only: gcd_commute)
qed

lemma gcd_power_distrib: "gcd a b ^ n = gcd (a^n) (b^n)"
proof cases
  assume "a=0 \<and> b=0"
  thus ?thesis by (auto simp add: power_0_left)
next
  let ?g = "gcd a b"
  assume "\<not> (a=0 \<and> b=0)"
  hence "a \<noteq> 0 \<or> b \<noteq> 0" by simp
  then obtain c d where abcd: "a = ?g*c \<and> b = ?g*d \<and> gcd c d=1"
    by (frule_tac a="a" in make_relprime, auto)
  moreover have "(?g*c)^n = ?g^n * c^n \<and> (?g*d)^n = ?g^n * d^n"
    by (simp add: power_mult_distrib)
  ultimately have "gcd (a^n) (b^n) = ?g^n * gcd (c^n) (d^n)" by (simp only: gcd_mult_distrib2)
  moreover from abcd have "gcd (c^n) (d^n) = 1" by (simp only: gcd_1_power_distrib)
  ultimately show ?thesis by simp
qed

text {* Useful lemma: if prime $p | a^n$ then $p | a$. *}

lemma prime_dvd_power: "\<lbrakk> prime p; p dvd a^n \<rbrakk> \<Longrightarrow> p dvd a"
proof (induct n)
  case 0 hence "prime p \<and> p = 1" by auto
  thus ?thesis by auto
next case (Suc n) hence IH: "prime p \<and> p dvd a^n \<Longrightarrow> p dvd a" by auto
  assume p: "prime p" and "p dvd a^Suc n"
  hence "p dvd a*a^n" by simp
  with p have "p dvd a \<or> p dvd a^n" by (simp add: prime_dvd_mult)
  with IH and p show "p dvd a" by auto
qed

lemma prime_power_dvd_cancel_right:
  "\<lbrakk> prime p; \<not> p dvd b; p^n dvd a*b \<rbrakk> \<Longrightarrow> p^n dvd a"
proof -
  assume p: "prime p" and pb: "\<not> p dvd b"
  hence p1: "p>1"  by (simp add: prime_def)
  have "!!a. p^n dvd a*b \<longrightarrow> p^n dvd a"
  proof (induct n)
    case 0 thus ?case by auto
  next
    case (Suc n) hence IH: "!!a. p^n dvd a*b \<longrightarrow> p^n dvd a" .
    fix a show "p^Suc n dvd a*b \<longrightarrow> p^Suc n dvd a"
    proof (auto)
      assume ppnab: "p*p^n dvd a*b"
      hence "p dvd a*b" by (rule dvd_mult_left)
      with p have "p dvd a \<or> p dvd b" by (rule prime_dvd_mult)
      with pb have "p dvd a" by simp
      then obtain k where apk: "a = p * k" by (auto simp add: dvd_def)
      with ppnab have "p*p^n dvd p*(k*b)" by (auto simp add: ac_simps)
      with p1 have "p^n dvd k*b" by (auto dest: dvd_mult_cancel)
      with IH have "p^n dvd k" ..
      with apk show "p*p^n dvd a" by (simp add: mult_dvd_mono)
    qed
  qed
  thus "p^n dvd a*b \<Longrightarrow> p^n dvd a" ..
qed

text {* Helping lemma: if $n > 0$ then $a^n | b^n \Longleftrightarrow a | b$. *}

lemma nat_power_dvd_mono: "n \<noteq> 0 \<Longrightarrow> (a^n dvd b^n) = (a dvd (b::nat))"
proof
  assume "n \<noteq> 0"
  then obtain m where mn: "n = Suc m"
    by (frule_tac n="n" in not0_implies_Suc, auto)
  assume "a^n dvd b^n"
  then obtain k where k: "b^n = a^n * k" by (auto simp add: dvd_def)
  moreover have "gcd (a^n) ((a^n)*k) = (a^n) * gcd 1 k" by (simp add: gcd_mult_distrib2)
  ultimately have "gcd (a^n) (b^n) = a^n" by (auto simp add: gcd_commute gcd_1)
  hence "gcd a b^n = a^n" by (simp add: gcd_power_distrib)
  with mn have "a = gcd a b" by (rule_tac n="m" in power_inject_base, auto)
  moreover have "gcd a b dvd b" by (rule gcd_dvd2)
  ultimately show "a dvd b" by simp
next
  assume "a dvd b"
  then obtain k where "b = a * k" by (auto simp add: dvd_def)
  hence "b^n = a^n * k^n" by (simp only: power_mult_distrib)
  thus "a^n dvd b^n" by auto
qed
(*
lemma primel_add_prime: "\<lbrakk> primel xs; primel ys; prime p; prod xs = p * prod ys \<rbrakk>
  \<Longrightarrow> length xs = 1 + length ys"
proof -
  assume "primel xs" and "primel ys" and "prime p" and "prod xs = p * prod ys"
  moreover hence "prod xs = prod (p#ys) \<and> primel (p#ys)"
    by (unfold primel_def, auto)
  ultimately have "xs <~~> (p#ys)" by (simp add: factor_unique)
  hence "length xs = length (p#ys)" by (rule perm_length)
  thus ?thesis by (simp add: length_append)
qed

lemma primel_add_factor: "\<lbrakk> primel xs; primel ys; g > 1; prod xs = g * prod ys \<rbrakk>
  \<Longrightarrow> length xs > length ys"
proof -
  assume pxs: "primel xs" and pys: "primel ys" and g1: "g > 1"
    and prod: "prod xs = g * prod ys"
  hence "\<exists> zs. primel zs \<and> prod zs = g" by (simp only: factor_exists)
  then obtain zs where zs: "primel zs \<and> prod zs = g" by auto
  with g1 have "zs \<noteq> []" by auto
  hence lzspos: "length zs > 0" by auto
  from zs and prod have prodxyz: "prod xs = prod (zs@ys)" by (simp add: prod_append)
  from pys and zs have "primel (zs@ys)" by (simp add: primel_append)
  with pxs and prodxyz have perm: "xs <~~> (zs@ys)" by (simp add: factor_unique)
  hence "length xs = length (zs@ys)" by (rule perm_length)
  hence "length xs = length zs + length ys" by (simp add: length_append)
  with lzspos show "length xs > length ys" by auto
qed
*)
text {* Theorem: if $n>0$ and $\gcd a b=1$ and $ab=c^n$ then $\exists k: a = k^n$. Proof uses induction on the number of prime factors of $c$. *}

theorem nat_relprime_power_divisors:
  assumes npos: "n\<noteq>0" and abcn: "a*b = c^n" and relprime: "gcd a b = 1"
  shows "\<exists> k. a = k^n"
proof -
  from npos obtain m where mn: "n = Suc m"
    by (frule_tac n="n" in not0_implies_Suc, auto)
  show ?thesis
  proof (case_tac "c=0")
    assume "c=0" with abcn npos mn have "a*b = 0" by (auto simp only: power_0_Suc)
    hence "a=0 \<or> b=0" by auto
    moreover
    { assume "a=0" with mn npos have "a = 0^n" by (auto simp only: power_0_Suc)
      hence ?thesis by blast }
    moreover
    { assume "b=0" with relprime have "a = 1^n" by (auto simp only: gcd_0 power_one)
      hence ?thesis by blast }
    ultimately show ?thesis by blast
  next
    assume "c\<noteq>0" then obtain xs where xs: "primel xs \<and> prod xs = c"
      by (frule_tac a="c" in factor_exists_general, auto)
    moreover have
      "!!a b. (primel xs \<and> a*b = (prod xs)^n \<and> gcd a b=1) \<Longrightarrow> \<exists>k. a = k^n"
    proof (induct xs)
      case Nil
      hence "a = 1^n" by simp
      thus "\<exists> k. a = k^n" ..
    next
      case (Cons p ps)
      hence ass: "primel ps \<and> prime p \<and> a*b=p^n*(prod ps)^n \<and> gcd a b=1 "
        and IH: "!!a b. primel ps \<and> a*b = (prod ps)^n \<and> gcd a b=1 \<Longrightarrow> \<exists> k. a = k^n"
        by (auto simp add: primel_def power_mult_distrib)
      hence pnab: "p^n dvd a*b" and pn0: "p^n \<noteq> 0"
        by (auto simp add: prime_def)
      moreover
      { assume pa: "p dvd a"
        have "\<not> p dvd b"
        proof (rule ccontr, simp)
          assume "p dvd b"
          with pa have "p dvd gcd a b" by (simp add: gcd_greatest_iff)
          with ass show "False" by (auto simp add: prime_def)
        qed
        with ass pnab have "p^n dvd a" by (simp add: prime_power_dvd_cancel_right)
        then obtain A where A: "a = p^n * A" by (auto simp add: dvd_def)
        with ass pn0 have "A*b = (prod ps)^n" by auto
        moreover have "gcd A b=1"
        proof -
          let ?g = "gcd A b"
          have "?g dvd A \<and> ?g dvd b" by (simp add: gcd_greatest)
          with A have "?g dvd a \<and> ?g dvd b" by (simp add: dvd_mult)
          hence "?g dvd gcd a b" by (simp only: gcd_greatest)
          with ass show "?g = 1" by auto
        qed
        moreover from IH ass have
          "A*b = (prod ps)^n \<and> gcd A b=1 \<Longrightarrow> \<exists> k. A = k^n" by auto
        ultimately have "\<exists> k. A = k^n" by auto
        then obtain k where "A = k^n" by auto
        with A have "a = (p*k)^n" by (auto simp add: power_mult_distrib)
        hence "\<exists> k. a = k^n" by blast }
      moreover
      { assume "\<not> p dvd a"
        moreover from ass pnab have "p^n dvd b*a \<and> prime p"
          by (auto simp only: ac_simps)
        ultimately have "p^n dvd b" by (simp add: prime_power_dvd_cancel_right)
        then obtain B where B: "b = p^n * B" by (auto simp add: dvd_def)
        with ass pn0 have "a*B = (prod ps)^n" by auto
        moreover have "gcd a B=1"
        proof -
          let ?g = "gcd a B"
          have "?g dvd a \<and> ?g dvd B" by (simp add: gcd_greatest)
          with B have "?g dvd a \<and> ?g dvd b" by (simp add: dvd_mult)
          hence "?g dvd gcd a b" by (simp only: gcd_greatest)
          with ass show "?g = 1" by auto
        qed
        moreover from IH ass have
          "a*B = (prod ps)^n \<and> gcd a B=1 \<Longrightarrow> \<exists> k. a = k^n" by auto
        ultimately have "\<exists> k. a = k^n" by auto }
      ultimately show "\<exists> k. a = k^n" by auto
    qed
    moreover from abcn relprime have "gcd a b=1 \<and> a*b=c^n" by simp
    ultimately show ?thesis by auto
  qed
qed

subsection {* Powers of integers *}

text {* Now turn to the case of integers. This lemma is based on its equivalent for the natural numbers. *}

corollary int_relprime_power_divisors:
  assumes abcn: "a*b = c^n" and n: "n>1" and relprime: "zgcd a b = 1"
  shows "\<exists> k. \<bar>a\<bar> = k^n"
proof -
  let ?a1 = "nat\<bar>a\<bar>"
  let ?b1 = "nat\<bar>b\<bar>"
  let ?c1 = "nat\<bar>c\<bar>"
  from relprime have absrelprime: "gcd ?a1 ?b1 = 1" by (auto simp only: zgcd_def)
  have "\<bar>a*b\<bar> = \<bar>a\<bar>*\<bar>b\<bar>" by (simp add: abs_mult)
  with abcn have "\<bar>c\<bar>^n = \<bar>a\<bar>*\<bar>b\<bar>" by (simp add: power_abs)
  hence "int(?c1^n) = int(?a1*?b1)" by (simp only: int_nat_abs_eq_abs int_mult int_power)
  hence "?a1*?b1 = ?c1^n" by (simp only: int_int_eq)
  with absrelprime and n have "\<exists> k. ?a1 = k^n" by (simp only: nat_relprime_power_divisors)
  then obtain k::nat where alpha: "?a1 = k^n" by auto
  moreover have "int ?a1 = \<bar>a\<bar>" by (simp add: int_nat_eq)
  ultimately have "\<bar>a\<bar> = int(k^n)" by simp
  hence "\<bar>a\<bar> = int(k)^n" by (simp only: int_power)
  thus ?thesis by auto
qed

corollary int_triple_relprime_power_divisors:
  "\<lbrakk> a*b*c = d^n; n > 1; zgcd a b = 1; zgcd b c = 1; zgcd c a = 1 \<rbrakk>
  \<Longrightarrow> \<exists> k l m. \<bar>a\<bar> = k^n \<and> \<bar>b\<bar> = l^n \<and> \<bar>c\<bar> = m^n"
proof -
  assume abcd: "a*b*c = d^n" and n1: "n > 1"
    and ab: "zgcd a b = 1" and bc: "zgcd b c = 1" and ca: "zgcd c a = 1"
  hence ba: "zgcd b a = 1" and cb: "zgcd c b = 1" and ac: "zgcd a c = 1"
    by (auto simp only: zgcd_commute)
  from ba ca have "zgcd (b*c) a = 1" by (simp only: zgcd_zmult_cancel)
  with abcd have "a*(b*c) = d^n \<and> zgcd a (b*c) = 1" by (simp add: zgcd_commute)
  with n1 have k: "\<exists> k. \<bar>a\<bar> = k^n" by (auto dest: int_relprime_power_divisors)
  from ab cb have "zgcd (a*c) b = 1" by (simp only: zgcd_zmult_cancel)
  with abcd have "b*(a*c) = d^n \<and> zgcd b (a*c) = 1"
    by (simp add: zgcd_commute ac_simps)
  with n1 have l: "\<exists> l. \<bar>b\<bar> = l^n" by (auto dest: int_relprime_power_divisors)
  from ac bc have "zgcd (a*b) c = 1" by (simp only: zgcd_zmult_cancel)
  with abcd have "c*(a*b) = d^n \<and> zgcd c (a*b) = 1"
    by (simp add: zgcd_commute ac_simps)
  with n1 have m: "\<exists> m. \<bar>c\<bar> = m^n" by (auto dest: int_relprime_power_divisors)
  from k l m show ?thesis by auto
qed

lemma neg_odd_power: "\<lbrakk> x \<in> zOdd; x \<ge> 0 \<rbrakk> \<Longrightarrow> (-a::int)^(nat x) = -(a^(nat x))"
proof -
  assume "x \<in> zOdd" and "0 \<le> x"
  hence "-(a^(nat x)) = (-1)^(nat x) * a^(nat x)" by (simp add: neg_one_odd_power)
  also have "\<dots> = (-1*a)^(nat x)" by (simp only: power_mult_distrib)
  finally show ?thesis by simp
qed

lemma neg_even_power: "\<lbrakk> x \<in> zEven; x \<ge> 0 \<rbrakk> \<Longrightarrow> (-a::int)^(nat x) = a^(nat x)"
proof -
  assume "x \<in> zEven" and "x \<ge> 0"
  hence "a^(nat x) = (-1)^(nat x) * a^(nat x)" by (simp add: neg_one_even_power)
  also have "\<dots> = (-1*a)^(nat x)" by (simp only: power_mult_distrib)
  finally show ?thesis by simp
qed

corollary int_relprime_odd_power_divisors:
  "\<lbrakk> a*b = c^(nat x); nat x > 1; x \<in> zOdd; zgcd a b = 1 \<rbrakk> \<Longrightarrow> \<exists> k. a = k^(nat x)"
proof -
  assume "a*b = c^(nat x)" and x1: "nat x > 1" and odd: "x \<in> zOdd" and "zgcd a b=1"
  hence "\<exists> k. \<bar>a\<bar> = k^(nat x)" by (simp only: int_relprime_power_divisors)
  then obtain k where k: "\<bar>a\<bar> = k^(nat x)" by blast
  { assume "a \<noteq> k^(nat x)"
    with k have "a = -(k^(nat x))" by arith
    with x1 odd have "a = (-k)^(nat x)" by (simp add: neg_odd_power) }
  thus ?thesis by blast
qed

corollary int_triple_relprime_odd_power_divisors:
  "\<lbrakk> a*b*c = d^(nat x); nat x>1; x\<in>zOdd; zgcd a b = 1; zgcd b c = 1; zgcd c a = 1 \<rbrakk>
  \<Longrightarrow> \<exists> k l m. a = k^(nat x) \<and> b = l^(nat x) \<and> c = m^(nat x)"
proof -
  assume abcd: "a*b*c = d^(nat x)" and x1: "nat x > 1" and odd: "x \<in> zOdd"
    and ab: "zgcd a b = 1" and bc: "zgcd b c = 1" and ca: "zgcd c a = 1"
  hence ba: "zgcd b a = 1" and cb: "zgcd c b = 1" and ac: "zgcd a c = 1"
    by (auto simp only: zgcd_commute)
  { from ba ca have "zgcd (b*c) a = 1" by (simp only: zgcd_zmult_cancel)
    with abcd have "a*(b*c) = d^(nat x) \<and> zgcd a (b*c) = 1"
      by (simp add: zgcd_commute)
    with x1 odd have "\<exists> k. a = k^(nat x)"
      by (auto dest: int_relprime_odd_power_divisors) }
  moreover
  { from ab cb have "zgcd (a*c) b = 1" by (simp only: zgcd_zmult_cancel)
    with abcd have "b*(a*c) = d^(nat x) \<and> zgcd b (a*c) = 1"
      by (simp add: zgcd_commute ac_simps)
    with x1 odd have "\<exists> l. b = l^(nat x)"
      by (auto dest: int_relprime_odd_power_divisors) }
  moreover
  { from ac bc have "zgcd (a*b) c = 1" by (simp only: zgcd_zmult_cancel)
    with abcd have "c*(a*b) = d^(nat x) \<and> zgcd c (a*b) = 1"
      by (simp add: zgcd_commute ac_simps)
    with x1 odd have m: "\<exists> m. c = m^(nat x)"
      by (auto dest: int_relprime_odd_power_divisors) }
  ultimately show ?thesis by auto
qed

lemma zgcd_1_power_left_distrib: "zgcd a b = 1 \<Longrightarrow> zgcd (a^n) b = 1"
  by (induct n, auto simp add: zgcd_zmult_cancel)

lemma zgcd_1_power_distrib: "zgcd a b = 1 \<Longrightarrow> zgcd (a^n) (b^n) = 1"
proof -
  assume "zgcd a b = 1"
  hence "zgcd (a^n) b = 1" by (rule zgcd_1_power_left_distrib)
  hence "zgcd b (a^n) = 1" by (simp only: zgcd_commute)
  hence "zgcd (b^n) (a^n) = 1" by (rule zgcd_1_power_left_distrib)
  thus "zgcd (a^n) (b^n) = 1" by (simp only: zgcd_commute)
qed

lemma zgcd_power_distrib: "zgcd a b ^ n = zgcd (a^n) (b^n)"
proof cases
  assume "a=0 \<and> b=0"
  thus ?thesis by (auto simp add: power_0_left)
next
  let ?g = "zgcd a b"
  assume "\<not> (a=0 \<and> b=0)"
  hence ab0: "a \<noteq> 0 \<or> b \<noteq> 0" by simp
  hence non0: "zgcd a b \<noteq> 0" "zgcd (a^n) (b^n) \<noteq> 0"
    by (auto simp add: zgcd_def gcd_zero power_eq_0_iff)
  moreover have "zgcd a b \<ge> 0" "zgcd (a^n) (b^n) \<ge> 0" by (simp_all add: zgcd_geq_zero)
  ultimately have "zgcd a b ^ n > 0" "zgcd (a^n) (b^n) > 0"
    unfolding less_le by simp_all
  moreover from ab0 obtain c d where abcd: "a = ?g*c \<and> b = ?g*d \<and> zgcd c d = 1"
    by (frule_tac a="a" in make_zrelprime, auto)
  moreover have "(?g*c)^n = ?g^n * c^n \<and> (?g*d)^n = ?g^n * d^n"
    by (simp add: power_mult_distrib)
  ultimately have gabcdn: "zgcd (a^n) (b^n) = ?g^n * zgcd (c^n) (d^n)"
    by (auto simp add: zgcd_zmult_distrib2)
  moreover from abcd have "zgcd (c^n) (d^n) = 1" by (simp only: zgcd_1_power_distrib)
  ultimately show ?thesis by auto
qed

lemma zprime_zdvd_zmult_general: "\<lbrakk> zprime p; p dvd m*n \<rbrakk> \<Longrightarrow> p dvd m \<or> p dvd n"
  apply (case_tac "m \<ge> 0", simp only: zprime_zdvd_zmult)
  apply (subgoal_tac "-m \<ge> 0 \<and> p dvd (-m)*n", subgoal_tac "p dvd -m \<or> p dvd n")
  prefer 2
  apply (rule_tac m="-m" in zprime_zdvd_zmult, auto)
done

lemma zprime_zdvd_power: "\<lbrakk> zprime p; p dvd a^n \<rbrakk> \<Longrightarrow> p dvd a"
  apply (induct n, auto)
  apply (frule_tac m="a" and n="a^n" in zprime_zdvd_zmult_general)
  apply auto
done

lemma zpower_zdvd_mono: "n \<noteq> 0 \<Longrightarrow> (a^n dvd b^n) = (a dvd (b::int))"
proof
  assume "n \<noteq> 0"
  then obtain m where mn: "n = Suc m"
    by (frule_tac n="n" in not0_implies_Suc, auto)
  assume "a^n dvd b^n"
  then obtain k where k: "b^n = a^n * k" by (auto simp add: dvd_def)
  moreover have "zgcd (a^n*1) (a^n*k) = \<bar>a^n\<bar> * zgcd 1 k"
    by (rule_tac k="a^n" in zgcd_zmult_distrib2_abs)
  ultimately have "zgcd (a^n) (b^n) = \<bar>a^n\<bar>"
    by (auto simp add: zgcd_commute zgcd_1)
  hence "zgcd a b^n = \<bar>a\<bar>^n \<and> zgcd a b \<ge> 0 \<and> \<bar>a\<bar> \<ge> 0"
    by (simp add: zgcd_power_distrib power_abs zgcd_geq_zero)
  with mn have "\<bar>a\<bar> = zgcd a b" by (auto intro: power_inject_base [of _ m])
  moreover have "zgcd a b dvd b" by (rule zgcd_zdvd2 [of a])
  ultimately have "\<bar>a\<bar> dvd b" by simp
  thus "a dvd b" by simp
next
  assume "a dvd b"
  then obtain k where k: "b = a * k" by (auto simp add: dvd_def)
  hence "b^n = a^n * k^n" by (simp only: power_mult_distrib)
  thus "a^n dvd b^n" by auto
qed

lemma zprime_power_zdvd_cancel_right:
  "\<lbrakk> zprime p; \<not> p dvd b; p^n dvd a*b \<rbrakk> \<Longrightarrow> p^n dvd a"
proof -
  assume p: "zprime p" and pb: "\<not> p dvd b"
  hence p1: "p > 1" by (simp add: zprime_def)
  have "!!a. p^n dvd a*b \<longrightarrow> p^n dvd a"
  proof (induct n)
    case 0 thus ?case by auto
  next
    case (Suc n) hence IH: "!!a. p^n dvd a*b \<longrightarrow> p^n dvd a" .
    fix a show "p^Suc n dvd a*b \<longrightarrow> p^Suc n dvd a"
    proof (auto)
      assume ppnab: "p*p^n dvd a*b"
      hence "p dvd a*b" by (auto simp add: dvd_def mult.assoc)
      with p have "p dvd a \<or> p dvd b" by (rule zprime_zdvd_zmult_general)
      with pb have "p dvd a" by simp
      then obtain k where apk: "a = p*k" by (auto simp add: dvd_def)
      with ppnab have "p*p^n dvd p*(k*b)" by (auto simp add: ac_simps)
      with p1 have "p^n dvd k*b" by (auto dest: zdvd_mult_cancel)
      with IH have "p^n dvd k" ..
      with apk show "p*p^n dvd a" by (simp add: mult_dvd_mono)
    qed
  qed
  thus "p^n dvd a*b \<Longrightarrow> p^n dvd a" ..
qed

lemma zprime_power_zdvd_cancel_left:
  "\<lbrakk> zprime p; \<not> p dvd a; p^n dvd a*b \<rbrakk> \<Longrightarrow> p^n dvd b"
  apply (subgoal_tac "p^n dvd b*a")
  apply (auto dest: zprime_power_zdvd_cancel_right)
  apply (simp add: ac_simps)
done

subsection {* Facts about small powers of integers *}

lemma zadd_power2: "((a::int)+b)^2 = a^2 + 2*a*b + b^2"
  by (simp add: eval_nat_numeral field_simps)

lemma zdiff_power2: "((a::int)-b)^2 = a^2 - 2*a*b + b^2"
  by (simp add: eval_nat_numeral field_simps)

lemma zspecial_product: "((a::int) + b) * (a - b) = a^2 - b^2"
  by (simp add: eval_nat_numeral field_simps)

lemma abs_power2_distrib: "\<bar>a^2\<bar> = \<bar>a::int\<bar>^2"
  by (simp add: power2_eq_square abs_mult)

lemma power2_eq_iff_abs_eq: "((a::int)^2 = b^2) = (\<bar>a\<bar> = \<bar>b\<bar>)"
proof
  assume "a^2 = b^2"
  hence "(a+b)*(a-b) = 0" by (simp add: zspecial_product)
  hence "a=b \<or> a=-b" by auto
  thus "\<bar>a\<bar> = \<bar>b\<bar>" by auto
next
  assume "\<bar>a\<bar> = \<bar>b\<bar>"
  hence "\<bar>a\<bar>^2 = \<bar>b\<bar>^2" by simp
  thus "a^2 = b^2" by (simp only: power2_abs)
qed

lemma power2_eq1_iff: "(a::int)^2 = 1 \<Longrightarrow> \<bar>a\<bar>=1"
  by (auto simp add: zmult_eq_1_iff power2_eq_square abs_mult)

lemma zadd_power3: "((a::int)+b)^3 = a^3 + 3*a^2*b + 3*a*b^2 + b^3"
  by (simp add: eval_nat_numeral field_simps)

lemma zdiff_power3: "((a::int)-b)^3 = a^3 - 3*a^2*b + 3*a*b^2 - b^3"
  by (simp add: eval_nat_numeral field_simps)

lemma power3_minus: "(-a::int)^3 = -(a^3)"
proof -
  have "(3::int) \<in> zOdd \<and> (3::int) \<ge> 0" by (unfold zOdd_def, auto)
  hence "(-a)^(nat 3) = -(a^(nat 3))" by (simp only: neg_odd_power)
  thus ?thesis by simp
qed

lemma abs_power3_distrib: "\<bar>(x::int)^3\<bar> = \<bar>x\<bar>^3"
  by (simp add: eval_nat_numeral field_simps abs_mult)

lemma cube_square: "(a::int)*a^2 = a^3"
  by (simp add: eval_nat_numeral field_simps)

lemma quartic_square_square: "(x^2)^2 = (x::int)^4"
  by (simp add: eval_nat_numeral field_simps)

lemma power2_ge_self: "x^2 \<ge> (x::int)"
proof (cases)
  assume nonpos: "x\<le>0"
  have "0 \<le> x^2" by (rule zero_le_power2)
  with nonpos show ?thesis by (rule order_trans)
next
  assume "\<not> x \<le> 0" hence x1: "x \<ge> 1" by simp
  thus ?thesis
  proof (cases)
    assume "x = 1"
    thus ?thesis by simp
  next
    assume "\<not> x = 1" with x1 have x2: "1<x" by simp
    hence "0<x" by simp
    with x2 have "x*1 < x*x" by (rule zmult_zless_mono2)
    thus ?thesis by (simp only: power2_eq_square)
  qed
qed

end