section  \<open>Undirected Graphs\<close>
theory Undirected_Graph
imports
  Main
  "HOL-Library.Extended_Nat"
  "HOL-Eisbach.Eisbach"
begin

  (* TODO: Move *)
  lemma split_sym_rel:
    fixes G :: "'a rel"
    assumes "sym G" "irrefl G"
    obtains E where "E\<inter>E\<inverse> = {}" "G = E \<union> E\<inverse>"
  proof -
    obtain R :: "'a rel"
    where WO: "well_order_on UNIV R" using Zorn.well_order_on ..

    let ?E = "G \<inter> R"

    from \<open>irrefl G\<close> have [simp, intro!]: "(x,x)\<notin>G" for x by (auto simp: irrefl_def)

    have "?E \<inter> ?E\<inverse> = {}"
      using WO unfolding well_order_on_def linear_order_on_def partial_order_on_def antisym_def
      by fastforce
    moreover
    have "G = ?E \<union> ?E\<inverse>"
      apply (auto dest: symD[OF \<open>sym G\<close>])
      using WO unfolding well_order_on_def linear_order_on_def total_on_def
      by force
    ultimately show ?thesis by (rule that)
  qed

  (* TODO: Move *)
  lemma map_eq_append_conv: "map f xs = ys\<^sub>1@ys\<^sub>2 \<longleftrightarrow> (\<exists>xs\<^sub>1 xs\<^sub>2. xs = xs\<^sub>1@xs\<^sub>2 \<and> map f xs\<^sub>1 = ys\<^sub>1 \<and> map f xs\<^sub>2 = ys\<^sub>2)"
    apply rule
    subgoal
      apply (rule exI[where x="take (length ys\<^sub>1) xs"])
      apply (rule exI[where x="drop (length ys\<^sub>1) xs"])
      apply (drule sym)
      by (auto simp: append_eq_conv_conj take_map drop_map)
    subgoal by auto
    done

  lemma sym_inv_eq[simp]: "sym E \<Longrightarrow> E\<inverse> = E" unfolding sym_def by auto

  (* TODO: Move *)
  lemma insert_inv[simp]: "(insert e E)\<inverse> = insert (prod.swap e) (E\<inverse>)"
    by (cases e) auto

  (* TODO: Move *)
  lemma inter_compl_eq_diff[simp]: "x \<inter> - s = x - s"
    by auto

  subsection \<open>Nodes and Edges\<close>

  typedef 'v ugraph = "{ (V::'v set , E). E \<subseteq> V\<times>V \<and> finite V \<and> sym E \<and> irrefl E }"
    unfolding sym_def irrefl_def by blast

  setup_lifting type_definition_ugraph

  lift_definition nodes_internal :: "'v ugraph \<Rightarrow> 'v set" is fst .
  lift_definition edges_internal :: "'v ugraph \<Rightarrow> ('v\<times>'v) set" is snd .
  lift_definition graph_internal :: "'v set \<Rightarrow> ('v\<times>'v) set \<Rightarrow> 'v ugraph"
    is "\<lambda>V E. if finite V \<and> finite E then (V\<union>fst`E\<union>snd`E, (E\<union>E\<inverse>)-Id) else ({},{})"
    by (auto simp: sym_def irrefl_def; force)

  definition nodes :: "'v ugraph \<Rightarrow> 'v set" where "nodes = nodes_internal"
  definition edges :: "'v ugraph \<Rightarrow> ('v\<times>'v) set" where "edges = edges_internal"
  definition graph :: "'v set \<Rightarrow> ('v\<times>'v) set \<Rightarrow> 'v ugraph" where "graph = graph_internal"

  lemma edges_subset: "edges g \<subseteq> nodes g \<times> nodes g"
    unfolding edges_def nodes_def by transfer auto

  lemma nodes_finite[simp, intro!]: "finite (nodes g)"
    unfolding edges_def nodes_def by transfer auto

  lemma edges_sym: "sym (edges g)"
    unfolding edges_def nodes_def by transfer auto

  lemma edges_irrefl: "irrefl (edges g)"
    unfolding edges_def nodes_def by transfer auto

  lemma nodes_graph: "\<lbrakk>finite V; finite E\<rbrakk> \<Longrightarrow> nodes (graph V E) = V\<union>fst`E\<union>snd`E"
    unfolding edges_def nodes_def graph_def by transfer auto

  lemma edges_graph: "\<lbrakk>finite V; finite E\<rbrakk> \<Longrightarrow> edges (graph V E) = (E\<union>E\<inverse>)-Id"
    unfolding edges_def nodes_def graph_def by transfer auto

  lemmas graph_accs = nodes_graph edges_graph

  lemma nodes_edges_graph_presentation:
    "\<lbrakk>finite V; finite E\<rbrakk> \<Longrightarrow> nodes (graph V E) = V \<union> fst`E \<union> snd`E \<and> edges (graph V E) = E\<union>E\<inverse> - Id"
    by (simp add: graph_accs)

  lemma graph_eq[simp]: "graph (nodes g) (edges g) = g"
    unfolding edges_def nodes_def graph_def
    apply transfer
    unfolding sym_def irrefl_def
    apply (clarsimp split: prod.splits)
    by (fastforce simp: finite_subset)

  lemma edges_finite[simp, intro!]: "finite (edges g)"
    using edges_subset finite_subset by fastforce

  lemma graph_cases[cases type]:
    obtains V E where "g = graph V E" "finite V" "finite E" "E\<subseteq>V\<times>V" "sym E" "irrefl E"
  proof -
    show ?thesis
      apply (rule that[of "nodes g" "edges g"])
      using edges_subset edges_sym edges_irrefl[of g]
      by auto
  qed

  lemma graph_eq_iff: "g=g' \<longleftrightarrow> nodes g = nodes g' \<and> edges g = edges g'"
    unfolding edges_def nodes_def graph_def by transfer auto

  lemma edges_sym': "(u,v)\<in>edges g \<Longrightarrow> (v,u)\<in>edges g" using edges_sym by (blast intro: symD)
  lemma edges_irrefl'[simp,intro!]: "(u,u)\<notin>edges g"
    by (meson edges_irrefl irrefl_def)

  lemma edges_irreflI[simp, intro]: "(u,v)\<in>edges g \<Longrightarrow> u\<noteq>v" by auto

  lemma edgesT_diff_sng_inv_eq[simp]: "(edges T - {(x, y), (y, x)})\<inverse> = edges T - {(x, y), (y, x)}"
    using edges_sym' by fast

  lemma nodesI[simp,intro]: assumes "(u,v)\<in>edges g" shows "u\<in>nodes g" "v\<in>nodes g"
    using assms edges_subset by auto

  lemma split_edges_sym: "\<exists>E. E\<inter>E\<inverse> = {} \<and> edges g = E \<union> E\<inverse>"
    using split_sym_rel[OF edges_sym edges_irrefl, of g] by metis

  subsection \<open>Connectedness Relation\<close>

  lemma rtrancl_edges_sym': "(u,v)\<in>(edges g)\<^sup>* \<Longrightarrow> (v,u)\<in>(edges g)\<^sup>*"
    by (simp add: edges_sym symD sym_rtrancl)

  lemma trancl_edges_subset: "(edges g)\<^sup>+ \<subseteq> nodes g \<times> nodes g"
    by (simp add: edges_subset trancl_subset_Sigma)

  lemma find_crossing_edge:
    assumes "(u,v)\<in>E\<^sup>*" "u\<in>V" "v\<notin>V"
    obtains u' v' where "(u',v')\<in>E\<inter>V\<times>-V"
    using assms apply (induction rule: converse_rtrancl_induct)
    by auto

  subsection \<open>Constructing Graphs\<close>

  (*
  lift_definition make_graph :: "'v set \<Rightarrow> ('v\<times>'v) set \<Rightarrow> 'v ugraph" is
    "\<lambda>V E. if finite V \<and> finite E then (V\<union>fst`E\<union>snd`E, (E\<union>E\<inverse>)-Id) else ({},{})"
    by (auto simp: sym_def irrefl_def; force)

  lift_definition graph_empty :: "'v ugraph" is "({},{})" by (auto simp: sym_def irrefl_def)
  lift_definition ins_node :: "'v \<Rightarrow> 'v ugraph \<Rightarrow> 'v ugraph" is "\<lambda>v (V,E). (insert v V,E)" by auto
  lift_definition ins_edge :: "'v\<times>'v \<Rightarrow> 'v ugraph \<Rightarrow> 'v ugraph"
    is "\<lambda>(u,v) (V,E). if u\<noteq>v then ({u,v}\<union>V, {(u,v),(v,u)}\<union>E) else (insert u V,E)"
    by (auto simp: sym_def irrefl_def split: if_splits)

  lift_definition graph_join :: "'v ugraph \<Rightarrow> 'v ugraph \<Rightarrow> 'v ugraph" is "\<lambda>(V,E) (V',E'). (V\<union>V', E\<union>E')"
    by (auto simp: sym_def irrefl_def)

  lift_definition restrict_nodes :: "'v ugraph \<Rightarrow> 'v set \<Rightarrow> 'v ugraph" is "\<lambda>(V,E) V'. (V\<inter>V', E \<inter> (V'\<times>V'))"
    by (auto simp: sym_def irrefl_def)

  lift_definition restrict_edges :: "'v ugraph \<Rightarrow> ('v\<times>'v) set \<Rightarrow> 'v ugraph" is "\<lambda>(V,E) E'. (V, E \<inter> (E'\<union>E'\<inverse>))"
    by (auto simp: sym_def irrefl_def)
  *)

  definition "graph_empty \<equiv> graph {} {}"
  definition "ins_node v g \<equiv> graph (insert v (nodes g)) (edges g)"
  definition "ins_edge e g \<equiv> graph (nodes g) (insert e (edges g))"
  definition "graph_join g\<^sub>1 g\<^sub>2 \<equiv> graph (nodes g\<^sub>1 \<union> nodes g\<^sub>2) (edges g\<^sub>1 \<union> edges g\<^sub>2)"
  definition "restrict_nodes g V \<equiv> graph (nodes g \<inter> V) (edges g \<inter> V\<times>V)"
  definition "restrict_edges g E \<equiv> graph (nodes g) (edges g \<inter> (E\<union>E\<inverse>))"

  definition "nodes_edges_consistent V E \<equiv> finite V \<and> irrefl E \<and> sym E \<and> E \<subseteq> V\<times>V"

  lemma graph_empty_accs[simp]:
    "nodes graph_empty = {}"
    "edges graph_empty = {}"
    unfolding graph_empty_def by (auto)

  lemma edges_ins_edge_ss: "edges g \<subseteq> edges (ins_edge e g)"
    by (auto simp: edges_ins_edge)

  lemma nodes_join[simp]: "nodes (graph_join g\<^sub>1 g\<^sub>2) = nodes g\<^sub>1 \<union> nodes g\<^sub>2"
    and edges_join[simp]: "edges (graph_join g\<^sub>1 g\<^sub>2) = edges g\<^sub>1 \<union> edges g\<^sub>2"
    unfolding graph_join_def
    by (auto simp: graph_accs dest: edges_sym')

  lemma nodes_restrict_nodes[simp]: "nodes (restrict_nodes g V) = nodes g \<inter> V"
    and edges_restrict_nodes[simp]: "edges (restrict_nodes g V) = edges g \<inter> V\<times>V"
    unfolding restrict_nodes_def
    by (auto simp: graph_accs dest: edges_sym')

  lemma nodes_restrict_edges[simp]: "nodes (restrict_edges g E) = nodes g"
    and edges_restrict_edges[simp]: "edges (restrict_edges g E) = edges g \<inter> (E\<union>E\<inverse>)"
    unfolding restrict_edges_def
    by (auto simp: graph_accs dest: edges_sym')

  lemma unrestricte_edges: "edges (restrict_edges g E) \<subseteq> edges g" by auto
  lemma unrestrictn_edges: "edges (restrict_nodes g V) \<subseteq> edges g" by auto

  lemma unrestrict_nodes: "nodes (restrict_edges g E) \<subseteq> nodes g" by auto

  subsection \<open>Paths\<close>

  fun path where
    "path g u [] v \<longleftrightarrow> u=v"
  | "path g u (e#ps) w \<longleftrightarrow> (\<exists>v. e=(u,v) \<and> e\<in>edges g \<and> path g v ps w)"

  lemma path_emptyI[intro!]: "path g u [] u" by auto

  lemma path_append[simp]: "path g u (p1@p2) w \<longleftrightarrow> (\<exists>v. path g u p1 v \<and> path g v p2 w)"
    by (induction p1 arbitrary: u) auto

  lemma path_transs1[trans]:
    "path g u p v \<Longrightarrow> (v,w)\<in>edges g \<Longrightarrow> path g u (p@[(v,w)]) w"
    "(u,v)\<in>edges g \<Longrightarrow> path g v p w \<Longrightarrow> path g u ((u,v)#p) w"
    "path g u p1 v \<Longrightarrow> path g v p2 w \<Longrightarrow> path g u (p1@p2) w"
    by auto

  lemma path_graph_empty[simp]: "path graph_empty u p v \<longleftrightarrow> v=u \<and> p=[]" by (cases p) auto

  abbreviation "revp p \<equiv> rev (map prod.swap p)"
  lemma revp_alt: "revp p = rev (map (\<lambda>(u,v). (v,u)) p)" by auto

  lemma path_rev[simp]: "path g u (revp p) v \<longleftrightarrow> path g v p u"
    by (induction p arbitrary: v) (auto dest: edges_sym')

  lemma path_rev_sym[sym]: "path g v p u \<Longrightarrow> path g u (revp p) v" by simp

  lemma path_transs2[trans]:
    "path g u p v \<Longrightarrow> (w,v)\<in>edges g \<Longrightarrow> path g u (p@[(v,w)]) w"
    "(v,u)\<in>edges g \<Longrightarrow> path g v p w \<Longrightarrow> path g u ((u,v)#p) w"
    "path g u p1 v \<Longrightarrow> path g w p2 v \<Longrightarrow> path g u (p1@revp p2) w"
    by (auto dest: edges_sym')

  lemma path_edges: "path g u p v \<Longrightarrow> set p \<subseteq> edges g"
    by (induction p arbitrary: u) auto

  lemma path_graph_cong: "path g\<^sub>1 u p v \<Longrightarrow> \<lbrakk>set p \<subseteq> edges g\<^sub>1 \<Longrightarrow> set p \<subseteq> edges g\<^sub>2\<rbrakk> \<Longrightarrow> path g\<^sub>2 u p v"
    apply (frule path_edges; simp)
    apply (induction p arbitrary: u)
    apply auto
    done

  lemma path_endpoints:
    assumes "path g u p v" "p\<noteq>[]" shows "u\<in>nodes g" "v\<in>nodes g"
    subgoal using assms by (cases p) (auto intro: nodesI)
    subgoal using assms by (cases p rule: rev_cases) (auto intro: nodesI)
    done

  lemma path_mono: "edges g \<subseteq> edges g' \<Longrightarrow> path g u p v \<Longrightarrow> path g' u p v"
    by (meson path_edges path_graph_cong subset_trans)

  lemmas unrestricte_path = path_mono[OF unrestricte_edges]
  lemmas unrestrictn_path = path_mono[OF unrestrictn_edges]

  lemma unrestrict_path_edges: "path (restrict_edges g E) u p v \<Longrightarrow> path g u p v"
    by (induction p arbitrary: u) auto

  lemma unrestrict_path_nodes: "path (restrict_nodes g E) u p v \<Longrightarrow> path g u p v"
    by (induction p arbitrary: u) auto

  subsubsection \<open>Paths and Connectedness\<close>

  lemma rtrancl_edges_iff_path: "(u,v)\<in>(edges g)\<^sup>* \<longleftrightarrow> (\<exists>p. path g u p v)"
    apply rule
    subgoal
      apply (induction rule: converse_rtrancl_induct)
      apply (auto dest: path_transs1)
      done
    apply clarify
    subgoal for p by (induction p arbitrary: u; force)
    done

  lemma rtrancl_edges_pathE: assumes "(u,v)\<in>(edges g)\<^sup>*" obtains p where "path g u p v"
    using assms by (auto simp: rtrancl_edges_iff_path)

  lemma path_rtrancl_edgesD: "path g u p v \<Longrightarrow> (u,v)\<in>(edges g)\<^sup>*"
    by (auto simp: rtrancl_edges_iff_path)

  subsubsection \<open>Simple Paths\<close>

  definition "uedge \<equiv> \<lambda>(a,b). {a,b}"

  definition "simple p \<equiv> distinct (map uedge p)"

  lemma in_uedge_conv[simp]: "x\<in>uedge (u,v) \<longleftrightarrow> x=u \<or> x=v"
    by (auto simp: uedge_def)

  lemma uedge_eq_iff: "uedge (a,b) = uedge (c,d) \<longleftrightarrow> a=c \<and> b=d \<or> a=d \<and> b=c"
    by (auto simp: uedge_def doubleton_eq_iff)

  lemma uedge_degen[simp]: "uedge (a,a) = {a}"
    by (auto simp: uedge_def)

  lemma uedge_in_set_eq: "uedge (u, v) \<in> uedge ` S \<longleftrightarrow> (u,v)\<in>S \<or> (v,u)\<in>S"
    by (auto simp: uedge_def doubleton_eq_iff)

  lemma simple_empty[simp]: "simple []"
    by (auto simp: simple_def)

  lemma simple_cons[simp]: "simple (e#p) \<longleftrightarrow> uedge e \<notin> uedge ` set p \<and> simple p"
    by (auto simp: simple_def)

  subsubsection \<open>Splitting Paths\<close>

  lemma find_crossing_edge_on_path:
    assumes "path g u p v" "\<not>P u" "P v"
    obtains u' v' where "(u',v')\<in>set p" "\<not>P u'" "P v'"
    using assms by (induction p arbitrary: u) auto

  lemma find_crossing_edges_on_path:
    assumes P: "path g u p v" and "P u" "P v"
    obtains "\<forall>(u,v)\<in>set p. P u \<and> P v"
          | u\<^sub>1 v\<^sub>1 v\<^sub>2 u\<^sub>2 p\<^sub>1 p\<^sub>2 p\<^sub>3 where "p=p\<^sub>1@[(u\<^sub>1,v\<^sub>1)]@p\<^sub>2@[(u\<^sub>2,v\<^sub>2)]@p\<^sub>3" "P u\<^sub>1" "\<not>P v\<^sub>1" "\<not>P u\<^sub>2" "P v\<^sub>2"
  proof (cases "\<forall>(u,v)\<in>set p. P u \<and> P v")
    case True with that show ?thesis by blast
  next
    case False
    with P \<open>P u\<close> have "\<exists>(u\<^sub>1,v\<^sub>1)\<in>set p. P u\<^sub>1 \<and> \<not>P v\<^sub>1"
      apply clarsimp apply (induction p arbitrary: u) by auto
    then obtain u\<^sub>1 v\<^sub>1 where "(u\<^sub>1,v\<^sub>1)\<in>set p" and PRED1: "P u\<^sub>1" "\<not>P v\<^sub>1" by blast
    then obtain p\<^sub>1 p\<^sub>2\<^sub>3 where [simp]: "p=p\<^sub>1@[(u\<^sub>1,v\<^sub>1)]@p\<^sub>2\<^sub>3" by (auto simp: in_set_conv_decomp)
    with P have "path g v\<^sub>1 p\<^sub>2\<^sub>3 v" by auto
    from find_crossing_edge_on_path[where P=P, OF this \<open>\<not>P v\<^sub>1\<close> \<open>P v\<close>] obtain u\<^sub>2 v\<^sub>2
      where "(u\<^sub>2,v\<^sub>2)\<in>set p\<^sub>2\<^sub>3" "\<not>P u\<^sub>2" "P v\<^sub>2" .
    then show thesis using PRED1
      by (auto simp: in_set_conv_decomp intro: that)
  qed

  lemma find_crossing_edge_rtrancl:
    assumes "(u,v)\<in>(edges g)\<^sup>*" "\<not>P u" "P v"
    obtains u' v' where "(u',v')\<in>edges g" "\<not>P u'" "P v'"
    using assms
    by (metis converse_rtrancl_induct)

  lemma path_change:
    assumes "u\<in>S" "v\<notin>S" "path g u p v" "simple p"
    obtains x y p1 p2 where
      "(x,y) \<in> set p" "x \<in> S" "y \<notin> S"
      "path (restrict_edges g (-{(x,y),(y,x)})) u p1 x"
      "path (restrict_edges g (-{(x,y),(y,x)})) y p2 v"
  proof -
    from find_crossing_edge_on_path[where P="\<lambda>x. x\<notin>S"] assms obtain x y where
      1: "(x,y)\<in>set p" "x\<in>S" "y\<notin>S" by blast
    then obtain p1 p2 where [simp]: "p=p1@[(x,y)]@p2" by (auto simp: in_set_conv_decomp)

    let ?g' = "restrict_edges g (-{(x,y),(y,x)})"

    from \<open>path g u p v\<close> have P1: "path g u p1 x" and P2: "path g y p2 v" by auto
    from \<open>simple p\<close> have "uedge (x,y)\<notin>set (map uedge p1)" "uedge (x,y)\<notin>set (map uedge p2)" by auto
    then have "path ?g' u p1 x" "path ?g' y p2 v"
      using path_graph_cong[OF P1, of ?g'] path_graph_cong[OF P2, of ?g']
      by (auto simp: uedge_in_set_eq)
    with 1 show ?thesis by (blast intro: that)
  qed

  subsection \<open>Cycles\<close>

  definition "cycle_free g \<equiv> \<nexists>p u. p\<noteq>[] \<and> simple p \<and> path g u p u"

  lemma cycle_free_alt_in_nodes:
    "cycle_free g \<equiv> \<nexists>p u. p\<noteq>[] \<and> u\<in>nodes g \<and> simple p \<and> path g u p u"
    by (smt cycle_free_def path_endpoints(2))

  lemma cycle_freeI:
    assumes "\<And>p u. \<lbrakk> path g u p u; p\<noteq>[]; simple p \<rbrakk> \<Longrightarrow> False"
    shows "cycle_free g"
    using assms unfolding cycle_free_def by auto

  lemma cycle_freeD:
    assumes "cycle_free g" "path g u p u" "p\<noteq>[]" "simple p"
    shows False
    using assms unfolding cycle_free_def by auto

  lemma cycle_free_antimono: "edges g \<subseteq> edges g' \<Longrightarrow> cycle_free g' \<Longrightarrow> cycle_free g"
    unfolding cycle_free_def
    by (auto dest: path_mono)

  lemma cycle_free_empty[simp]: "cycle_free graph_empty" unfolding cycle_free_def by auto

  lemma cycle_free_no_edges: "edges g = {} \<Longrightarrow> cycle_free g"
    by (rule cycle_freeI) (auto simp: neq_Nil_conv)

    with Cons.IH[of u' p''] Cons.prems show ?case by simp
  qed

  subsubsection \<open>Characterization by Removing Edge\<close>

  lemma cycle_free_alt: "cycle_free g \<longleftrightarrow> (\<forall>e\<in>edges g. e\<notin>(edges (restrict_edges g (-{e,prod.swap e})))\<^sup>*)"
    apply (rule)
    apply (clarsimp simp del: edges_restrict_edges)
    subgoal premises prems for u v proof -
      note edges_restrict_edges[simp del]
      let ?rg = "(restrict_edges g (- {(u,v), (v,u)}))"
      from \<open>(u, v) \<in> (edges ?rg)\<^sup>*\<close>
      obtain p where P: "path ?rg u p v" and "simple p"
        by (auto simp: rtrancl_edges_iff_path elim: simplify_pathE)
      from P have "path g u p v" by (rule unrestricte_path)
      also note \<open>(u, v) \<in> edges g\<close> finally have "path g u (p @ [(v, u)]) u" .
      moreover from path_edges[OF P] have "uedge (u,v) \<notin> set (map uedge p)"
        by (auto simp: uedge_eq_iff edges_restrict_edges)
      with \<open>simple p\<close> have "simple (p @ [(v, u)])"
        by (auto simp: uedge_eq_iff uedge_in_set_eq)
      ultimately show ?thesis using \<open>cycle_free g\<close>
        unfolding cycle_free_def by blast
    qed
    apply (clarsimp simp: cycle_free_def)
    subgoal premises prems for p u proof -
      from \<open>p\<noteq>[]\<close> \<open>path g u p u\<close> obtain v p' where
        [simp]: "p=(u,v)#p'" and "(u,v)\<in>edges g" "path g v p' u"
        by (cases p) auto
      from \<open>simple p\<close> have "simple p'" "uedge (u,v) \<notin> set (map uedge p')" by auto
      hence "(u,v)\<notin>set p'" "(v,u)\<notin>set p'" by (auto simp: uedge_in_set_eq)
      with \<open>path g v p' u\<close> have "path (restrict_edges g (-{(u,v),(v,u)})) v p' u" (is "path ?rg _ _ _")
        by (erule_tac path_graph_cong) auto

      hence "(u,v)\<in>(edges ?rg)\<^sup>*"
        by (meson path_rev rtrancl_edges_iff_path)
      with prems(1) \<open>(u,v)\<in>edges g\<close> show False by auto
    qed
    done

  lemma cycle_free_altI:
    assumes "\<And>u v. \<lbrakk> (u,v)\<in>edges g; (u,v)\<in>(edges g - {(u,v),(v,u)})\<^sup>* \<rbrakk> \<Longrightarrow> False"
    shows "cycle_free g"
    unfolding cycle_free_alt using assms by (force)

  lemma cycle_free_altD:
    assumes "cycle_free g"
    assumes "(u,v)\<in>edges g"
    shows "(u,v)\<notin>(edges g - {(u,v),(v,u)})\<^sup>*"
    using assms unfolding cycle_free_alt by (auto)

  lemma remove_redundant_edge:
    assumes "(u, v) \<in> (edges g - {(u, v), (v, u)})\<^sup>*"
    shows "(edges g - {(u, v), (v, u)})\<^sup>* = (edges g)\<^sup>*" (is "?E'\<^sup>* = _")
  proof
    show "?E'\<^sup>* \<subseteq> (edges g)\<^sup>*"
      by (simp add: Diff_subset rtrancl_mono)
  next
    show "(edges g)\<^sup>* \<subseteq> ?E'\<^sup>*"
    proof clarify
      fix a b assume "(a,b)\<in>(edges g)\<^sup>*" then
      show "(a,b)\<in>?E'\<^sup>*"
      proof induction
        case base
        then show ?case by simp
      next
        case (step b c)
        then show ?case
        proof (cases "(b,c)\<in>{(u,v),(v,u)}")
          case True

          have SYME: "sym (?E'\<^sup>*)"
            apply (rule sym_rtrancl)
            using edges_sym[of g]
            by (auto simp: sym_def)
          with step.IH assms have
            IH': "(b,a) \<in> ?E'\<^sup>*" (*and A': "(v,u) \<in> (?E')\<^sup>*"*)
            by (auto intro: symD)

          from True show ?thesis apply safe
            subgoal using assms step.IH by simp
            subgoal using assms IH' apply (rule_tac symD[OF SYME]) by simp
            done

        next
          case False
          then show ?thesis
            by (meson DiffI rtrancl.rtrancl_into_rtrancl step.IH step.hyps(2))
        qed

      qed
    qed
  qed

  subsection \<open>Connected Graphs\<close>

  definition connected
    where "connected g \<equiv> nodes g \<times> nodes g \<subseteq> (edges g)\<^sup>*"

  lemma connectedI[intro?]:
    assumes "\<And>u v. \<lbrakk>u\<in>nodes g; v\<in>nodes g\<rbrakk> \<Longrightarrow> (u,v)\<in>(edges g)\<^sup>*"
    shows "connected g"
    using assms unfolding connected_def by auto

  subsection \<open>Component Containing Node\<close>
  definition "reachable_nodes g r \<equiv> (edges g)\<^sup>*``{r}"
  definition "component_of g r \<equiv> ins_node r (restrict_nodes g (reachable_nodes g r))"

  lemma reachable_nodes_refl[simp, intro!]: "r \<in> reachable_nodes g r" by (auto simp: reachable_nodes_def)
  lemma reachable_nodes_step: "edges g `` reachable_nodes g r \<subseteq> reachable_nodes g r"
    by (auto simp: reachable_nodes_def)

  lemma reachable_nodes_steps: "(edges g)\<^sup>* `` reachable_nodes g r \<subseteq> reachable_nodes g r"
    by (auto simp: reachable_nodes_def)

  lemma reachable_nodes_step':
    assumes "u \<in> reachable_nodes g r" "(u, v) \<in> edges g"
    shows "v\<in>reachable_nodes g r" "(u, v) \<in> edges (component_of g r)"
  proof -
    show "v \<in> reachable_nodes g r"
      by (meson ImageI assms(1) assms(2) reachable_nodes_step rev_subsetD)
    then show "(u, v) \<in> edges (component_of g r)"
      by (simp add: assms(1) assms(2) component_of_def)
  qed

  lemma reachable_nodes_steps':
    assumes "u \<in> reachable_nodes g r" "(u, v) \<in> (edges g)\<^sup>*"
    shows "v\<in>reachable_nodes g r" "(u, v) \<in> (edges (component_of g r))\<^sup>*"
  proof -
    show "v\<in>reachable_nodes g r" using reachable_nodes_steps assms by fast
    show "(u, v) \<in> (edges (component_of g r))\<^sup>*"
      using assms(2,1)
      apply (induction rule: converse_rtrancl_induct)
      apply auto
      by (smt converse_rtrancl_into_rtrancl reachable_nodes_step')
  qed

  lemma reachable_not_node: "r\<notin>nodes g \<Longrightarrow> reachable_nodes g r = {r}"
    by (force elim: converse_rtranclE simp: reachable_nodes_def intro: nodesI)

  lemma nodes_of_component[simp]: "nodes (component_of g r) = reachable_nodes g r"
    unfolding component_of_def apply (auto simp: reachable_nodes_def)
    by (metis nodesI(2) rtranclE)

  lemma component_connected[simp, intro!]: "connected (component_of g r)"
  proof (rule connectedI; simp)
    fix u v
    assume A: "u \<in> reachable_nodes g r" "v \<in> reachable_nodes g r"
    hence "(u,r)\<in>(edges g)\<^sup>*" "(r,v)\<in>(edges g)\<^sup>*" by (auto simp: reachable_nodes_def dest: rtrancl_edges_sym')
    hence "(u,v)\<in>(edges g)\<^sup>*" by (rule rtrancl_trans)
    with A show "(u, v) \<in> (edges (component_of g r))\<^sup>*" by (rule_tac reachable_nodes_steps'(2))
  qed

  lemma component_edges_subset: "edges (component_of g r) \<subseteq> edges g"
    by (auto simp: component_of_def)

  lemma component_path: "u\<in>nodes (component_of g r) \<Longrightarrow>
    path (component_of g r) u p v \<longleftrightarrow> path g u p v"
    apply rule
    subgoal by (erule path_mono[OF component_edges_subset])
    subgoal by (induction p arbitrary: u) (auto simp: reachable_nodes_step')
    done

  lemma component_cycle_free: "cycle_free g \<Longrightarrow> cycle_free (component_of g r)"
    by (meson component_edges_subset cycle_free_antimono)

  lemma component_of_connected_graph: "\<lbrakk>connected g; r\<in>nodes g\<rbrakk> \<Longrightarrow> component_of g r = g"
    unfolding graph_eq_iff
    apply auto
    subgoal by (metis Image_singleton_iff nodesI(2) reachable_nodes_def rtranclE)
    subgoal by (simp add: connectedD reachable_nodes_def)
    subgoal by (simp add: component_of_def)
    subgoal by (simp add: \<open>\<And>x. \<lbrakk>connected g; r \<in> nodes g; x \<in> nodes g\<rbrakk> \<Longrightarrow> x \<in> reachable_nodes g r\<close> nodesI(1) reachable_nodes_step'(2))
    done

  lemma component_of_not_node: "r\<notin>nodes g \<Longrightarrow> component_of g r = graph {r} {}"
    by (clarsimp simp: graph_eq_iff component_of_def reachable_not_node graph_accs)

  subsection \<open>Trees\<close>

  definition "tree g \<equiv> connected g \<and> cycle_free g "

  lemma tree_empty[simp]: "tree graph_empty" by (simp add: tree_def)

  lemma component_of_tree: "tree T \<Longrightarrow> tree (component_of T r)"
    unfolding tree_def using component_connected component_cycle_free by auto

  subsubsection \<open>Joining and Splitting Trees on Single Edge\<close>

  lemma join_connected:
    assumes CONN: "connected g\<^sub>1" "connected g\<^sub>2"
    assumes IN_NODES: "u\<in>nodes g\<^sub>1" "v\<in>nodes g\<^sub>2"
    shows "connected (ins_edge (u,v) (graph_join g\<^sub>1 g\<^sub>2))" (is "connected ?g'")
    unfolding connected_def
  proof clarify
    fix a b
    assume A: "a\<in>nodes ?g'" "b\<in>nodes ?g'"

    have ESS: "(edges g\<^sub>1)\<^sup>* \<subseteq> (edges ?g')\<^sup>*" "(edges g\<^sub>2)\<^sup>* \<subseteq> (edges ?g')\<^sup>*"
      using edges_ins_edge_ss
      by (force intro!: rtrancl_mono)+

    have UV: "(u,v)\<in>(edges ?g')\<^sup>*"
      by (simp add: edges_ins_edge r_into_rtrancl)

    show "(a,b)\<in>(edges ?g')\<^sup>*"
    proof -
      {
        assume "a\<in>nodes g\<^sub>1" "b\<in>nodes g\<^sub>1"
        hence ?thesis using \<open>connected g\<^sub>1\<close> ESS(1) unfolding connected_def by blast
      } moreover {
        assume "a\<in>nodes g\<^sub>2" "b\<in>nodes g\<^sub>2"
        hence ?thesis using \<open>connected g\<^sub>2\<close> ESS(2) unfolding connected_def by blast
      } moreover {
        assume "a\<in>nodes g\<^sub>1" "b\<in>nodes g\<^sub>2"
        with connectedD[OF CONN(1)] connectedD[OF CONN(2)] ESS
        have ?thesis by (meson UV IN_NODES contra_subsetD rtrancl_trans)
      } moreover {
        assume "a\<in>nodes g\<^sub>2" "b\<in>nodes g\<^sub>1"
        with connectedD[OF CONN(1)] connectedD[OF CONN(2)] ESS
        have ?thesis
          by (meson UV IN_NODES contra_subsetD rtrancl_edges_sym' rtrancl_trans)
      }
      ultimately show ?thesis using A IN_NODES by auto
    qed
  qed

  lemma join_cycle_free:
    assumes CYCF: "cycle_free g\<^sub>1" "cycle_free g\<^sub>2"
    assumes DJ: "nodes g\<^sub>1 \<inter> nodes g\<^sub>2 = {}"
    assumes IN_NODES: "u\<in>nodes g\<^sub>1" "v\<in>nodes g\<^sub>2"
    shows "cycle_free (ins_edge (u,v) (graph_join g\<^sub>1 g\<^sub>2))" (is "cycle_free ?g'")
  proof (rule cycle_freeI)
    fix p a
    assume P: "path ?g' a p a" "p\<noteq>[]" "simple p"
    from path_endpoints[OF this(1,2)] IN_NODES have A_NODE: "a\<in>nodes g\<^sub>1 \<union> nodes g\<^sub>2" by auto
    thus False proof
      assume N1: "a\<in>nodes g\<^sub>1"
      have "set p \<subseteq> nodes g\<^sub>1 \<times> nodes g\<^sub>1"
      proof (cases rule: find_crossing_edges_on_path[where P="\<lambda>x. x\<in>nodes g\<^sub>1", OF P(1) N1 N1])
        case 1
        then show ?thesis by auto
      next
        case (2 u\<^sub>1 v\<^sub>1 v\<^sub>2 u\<^sub>2 p\<^sub>1 p\<^sub>2 p\<^sub>3)
        then show ?thesis using \<open>simple p\<close> P
          apply clarsimp
          apply (drule path_edges)+
          apply (cases "u=v"; clarsimp simp: edges_ins_edge uedge_in_set_eq)
          apply (metis DJ IntI IN_NODES empty_iff)
          by (metis DJ IntI empty_iff nodesI uedge_eq_iff)

      qed
      hence "set p \<subseteq> edges g\<^sub>1" using DJ edges_subset path_edges[OF P(1)] IN_NODES
        by (auto simp: edges_ins_edge split: if_splits; blast)
      hence "path g\<^sub>1 a p a" by (meson P(1) path_graph_cong)
      thus False using cycle_freeD[OF CYCF(1)] P(2,3) by blast
    next
      assume N2: "a\<in>nodes g\<^sub>2"
      have "set p \<subseteq> nodes g\<^sub>2 \<times> nodes g\<^sub>2"
      proof (cases rule: find_crossing_edges_on_path[where P="\<lambda>x. x\<in>nodes g\<^sub>2", OF P(1) N2 N2])
        case 1
        then show ?thesis by auto
      next
        case (2 u\<^sub>1 v\<^sub>1 v\<^sub>2 u\<^sub>2 p\<^sub>1 p\<^sub>2 p\<^sub>3)
        then show ?thesis using \<open>simple p\<close> P
          apply clarsimp
          apply (drule path_edges)+
          apply (cases "u=v"; clarsimp simp: edges_ins_edge uedge_in_set_eq)
          apply (metis DJ IntI IN_NODES empty_iff)
          by (metis DJ IntI empty_iff nodesI uedge_eq_iff)

      qed
      hence "set p \<subseteq> edges g\<^sub>2" using DJ edges_subset path_edges[OF P(1)] IN_NODES
        by (auto simp: edges_ins_edge split: if_splits; blast)
      hence "path g\<^sub>2 a p a" by (meson P(1) path_graph_cong)
      thus False using cycle_freeD[OF CYCF(2)] P(2,3) by blast
    qed
  qed

  lemma join_trees:
    assumes TREE: "tree g\<^sub>1" "tree g\<^sub>2"
    assumes DJ: "nodes g\<^sub>1 \<inter> nodes g\<^sub>2 = {}"
    assumes IN_NODES: "u\<in>nodes g\<^sub>1" "v\<in>nodes g\<^sub>2"
    shows "tree (ins_edge (u,v) (graph_join g\<^sub>1 g\<^sub>2))"
    using assms join_cycle_free join_connected unfolding tree_def by metis

  lemma split_tree:
    assumes "tree T" "(x,y)\<in>edges T"
    defines "E' \<equiv> (edges T - {(x,y),(y,x)})"
    obtains T1 T2 where
      "tree T1" "tree T2"
      "nodes T1 \<inter> nodes T2 = {}" "nodes T = nodes T1 \<union> nodes T2"
      "edges T1 \<union> edges T2 = E'"
      "nodes T1 = { u. (x,u)\<in>E'\<^sup>*}" "nodes T2 = { u. (y,u)\<in>E'\<^sup>*}"
      "x\<in>nodes T1" "y\<in>nodes T2"
  proof -
    (* TODO: Use component_of here! *)
    define N1 where "N1 = { u. (x,u)\<in>E'\<^sup>* }"
    define N2 where "N2 = { u. (y,u)\<in>E'\<^sup>* }"

    define T1 where "T1 = restrict_nodes T N1"
    define T2 where "T2 = restrict_nodes T N2"

    have SYME: "sym (E'\<^sup>*)"
      apply (rule sym_rtrancl)
      using edges_sym[of T] by (auto simp: sym_def E'_def)

    from assms have "connected T" "cycle_free T" unfolding tree_def by auto
    from \<open>cycle_free T\<close> have "cycle_free T1" "cycle_free T2"
      unfolding T1_def T2_def
      using cycle_free_antimono unrestrictn_edges by blast+

    from \<open>(x,y) \<in> edges T\<close> have XYN: "x\<in>nodes T" "y\<in>nodes T" using edges_subset by auto
    from XYN have [simp]: "nodes T1 = N1" "nodes T2 = N2"
      unfolding T1_def T2_def N1_def N2_def unfolding E'_def apply auto
      by (metis DiffD1 nodesI(2) rtrancl.simps)+

    have "x\<in>N1" "y\<in>N2" by (auto simp: N1_def N2_def)

    have "N1 \<inter> N2 = {}"
    proof (safe;simp)
      fix u
      assume "u\<in>N1" "u\<in>N2"
      hence "(x,u)\<in>E'\<^sup>*" "(u,y)\<in>E'\<^sup>*" by (auto simp: N1_def N2_def symD[OF SYME])
      with cycle_free_altD[OF \<open>cycle_free T\<close> \<open>(x,y)\<in>edges T\<close>] show False unfolding E'_def
        by (meson rtrancl_trans)
    qed

    have N1C: "E'``N1 \<subseteq> N1"
      unfolding N1_def
      apply clarsimp
      by (simp add: rtrancl.rtrancl_into_rtrancl)

    have N2C: "E'``N2 \<subseteq> N2"
      unfolding N2_def
      apply clarsimp
      by (simp add: rtrancl.rtrancl_into_rtrancl)

    have XE1: "(x,u) \<in> (edges T1)\<^sup>*" if "u\<in>N1" for u
    proof -
      from that have "(x,u)\<in>E'\<^sup>*" by (auto simp: N1_def)
      then show ?thesis using \<open>x\<in>N1\<close>
        unfolding T1_def
      proof (induction rule: converse_rtrancl_induct)
        case (step y z)
        with N1C have "z\<in>N1" by auto
        with step.hyps(1) step.prems have "(y,z)\<in>Restr (edges T) N1" unfolding E'_def by auto
        with step.IH[OF \<open>z\<in>N1\<close>] show ?case
          by (metis converse_rtrancl_into_rtrancl edges_restrict_nodes)
      qed auto
    qed

    have XE2: "(y,u) \<in> (edges T2)\<^sup>*" if "u\<in>N2" for u
    proof -
      from that have "(y,u)\<in>E'\<^sup>*" by (auto simp: N2_def)
      then show ?thesis using \<open>y\<in>N2\<close>
        unfolding T2_def
      proof (induction rule: converse_rtrancl_induct)
        case (step y z)
        with N2C have "z\<in>N2" by auto
        with step.hyps(1) step.prems have "(y,z)\<in>Restr (edges T) N2" unfolding E'_def by auto
        with step.IH[OF \<open>z\<in>N2\<close>] show ?case
          by (metis converse_rtrancl_into_rtrancl edges_restrict_nodes)
      qed auto
    qed

    have "connected T1"
      apply rule
      apply simp
      apply (drule XE1)+
      by (meson rtrancl_edges_sym' rtrancl_trans)

    have "connected T2"
      apply rule
      apply simp
      apply (drule XE2)+
      by (meson rtrancl_edges_sym' rtrancl_trans)

    have "u\<in>N1 \<union> N2" if "u\<in>nodes T" for u
    proof -
      from connectedD[OF \<open>connected T\<close> \<open>x\<in>nodes T\<close> that ]
      obtain p where P: "path T x p u" "simple p"
        by (auto simp: rtrancl_edges_iff_path elim: simplify_pathE)
      show ?thesis proof cases
        assume "(x,y)\<notin>set p \<and> (y,x)\<notin>set p"
        with P(1) have "path (restrict_edges T E') x p u"
          unfolding E'_def by (erule_tac path_graph_cong) auto
        from path_rtrancl_edgesD[OF this]
        show ?thesis unfolding N1_def E'_def by auto
      next
        assume "\<not>((x,y)\<notin>set p \<and> (y,x)\<notin>set p)"
        with P obtain p' where "uedge (x,y)\<notin>set (map uedge p')" "path T y p' u \<or> path T x p' u"
          apply (auto simp: in_set_conv_decomp)
          by (metis uedge_eq_iff)
        hence "path (restrict_edges T E') y p' u \<or> path (restrict_edges T E') x p' u"
          apply (clarsimp simp: uedge_in_set_eq E'_def)
          by (smt ComplD DiffI Int_iff UnCI edges_restrict_edges insertE path_graph_cong subset_Compl_singleton subset_iff)
        then show ?thesis unfolding N1_def N2_def E'_def by (auto dest: path_rtrancl_edgesD)
      qed
    qed
    then have "nodes T = N1 \<union> N2"
      unfolding N1_def N2_def using XYN
      apply (auto intro: nodesI simp: E'_def)
      by (metis DiffD1 nodesI(2) rtrancl.cases)+

    have "edges T1 \<union> edges T2 \<subseteq> E'"
      unfolding T1_def T2_def E'_def using \<open>N1 \<inter> N2 = {}\<close> \<open>x \<in> N1\<close> \<open>y \<in> N2\<close> by auto
    also have "edges T1 \<union> edges T2 \<supseteq> E'"
    proof -
      note ED1 = nodesI[where g=T, unfolded \<open>nodes T = N1\<union>N2\<close>]
      have "E' \<subseteq> edges T" by (auto simp: E'_def)
      thus "edges T1 \<union> edges T2 \<supseteq> E'"
        unfolding T1_def T2_def
        using ED1 N1C N2C by (auto; blast)
    qed
    finally have "edges T1 \<union> edges T2 = E'" .

    show ?thesis
      apply (rule that[of T1 T2, unfolded tree_def]; (intro conjI)?; fact?)
      apply simp_all
      apply fact+
      done
  qed

  subsection \<open>Spanning Trees\<close>

  definition "is_spanning_tree G T \<equiv> tree T \<and> nodes T = nodes G \<and> edges T \<subseteq> edges G"

  (* TODO: Move *)
  lemma connected_singleton[simp]: "connected (ins_node u graph_empty)"
    unfolding connected_def by auto

  lemma path_singleton[simp]: "path (ins_node u graph_empty) v p w \<longleftrightarrow> v=w \<and> p=[]"
    by (cases p) auto

  lemma tree_singleton[simp]: "tree (ins_node u graph_empty)"
    by (simp add: cycle_free_no_edges tree_def)

  (* TODO: Move *)
  lemma tree_add_edge_in_out:
    assumes "tree T"
    assumes "u\<in>nodes T" "v\<notin>nodes T"
    shows "tree (ins_edge (u,v) T)"
  proof -
    from assms have [simp]: "u\<noteq>v" by auto
    have "ins_edge (u,v) T = ins_edge (u,v) (graph_join T (ins_node v graph_empty))"
      by (auto simp: graph_eq_iff)
    also have "tree \<dots>"
      apply (rule join_trees)
      using assms
      by auto
    finally show ?thesis .
  qed

  text \<open>Remove edges on cycles until the graph is cycle free\<close>
  lemma ex_spanning_tree:
    "connected g \<Longrightarrow> \<exists>t. is_spanning_tree g t"
    using edges_finite[of g]
  proof (induction "edges g" arbitrary: g rule: finite_psubset_induct)
    case psubset
    show ?case proof (cases "cycle_free g")
      case True with \<open>connected g\<close> show ?thesis by (auto simp: is_spanning_tree_def tree_def)
    next
      case False
      then obtain u v where EDGE: "(u,v)\<in>edges g" and RED: "(u,v)\<in>(edges g - {(u,v),(v,u)})\<^sup>*"
        using cycle_free_altI by metis
      from \<open>connected g\<close> have "connected (restrict_edges g (- {(u,v),(v,u)}))" (is "connected ?g'")
        unfolding connected_def
        by (auto simp: remove_redundant_edge[OF RED])
      moreover have "edges ?g' \<subset> edges g" using EDGE by auto
      ultimately obtain t where "is_spanning_tree ?g' t" using psubset.hyps(2)[of ?g'] by blast
      hence "is_spanning_tree g t" by (auto simp: is_spanning_tree_def)
      thus ?thesis ..
    qed
  qed

  section \<open>Weighted Undirected Graphs\<close>

  definition weight :: "('v set \<Rightarrow> nat) \<Rightarrow> 'v ugraph \<Rightarrow> nat"
    where "weight w g \<equiv> (\<Sum>e\<in>edges g. w (uedge e)) div 2"

  lemma weight_alt: "weight w g = (\<Sum>e\<in>uedge`edges g. w e)"
  proof -
    from split_edges_sym[of g] obtain E where "edges g = E \<union> E\<inverse>" and "E\<inter>E\<inverse>={}" by auto
    hence [simp, intro!]: "finite E" by (metis edges_finite finite_Un)
    hence [simp, intro!]: "finite (E\<inverse>)" by blast

    have [simp]: "(\<Sum>e\<in>E\<inverse>. w (uedge e)) = (\<Sum>e\<in>E. w (uedge e))"
      apply (rule sum.reindex_cong[where l=prod.swap and A="E\<inverse>" and B="E"])
      apply (auto simp: uedge_def insert_commute)
      done

    have [simp]: "inj_on uedge E" using \<open>E\<inter>E\<inverse>=_\<close>
      by (auto simp: uedge_def inj_on_def doubleton_eq_iff)

    have "weight w g = (\<Sum>e\<in>E. w (uedge e))"
      unfolding weight_def \<open>edges g = _\<close> using \<open>E\<inter>E\<inverse>={}\<close>
      by (auto simp: sum.union_disjoint)
    also have "\<dots> = (\<Sum>e\<in>uedge`E. w e)"
      using sum.reindex[of uedge E w]
      by auto
    also have "uedge`E = uedge`(edges g)"
      unfolding \<open>edges g = _\<close> uedge_def using \<open>E\<inter>E\<inverse>={}\<close>
      by auto
    finally show ?thesis .
  qed

  lemma weight_empty[simp]: "weight w graph_empty = 0" unfolding weight_def by auto

  lemma weight_ins_edge[simp]: "\<lbrakk>u\<noteq>v; (u,v)\<notin>edges g\<rbrakk> \<Longrightarrow> weight w (ins_edge (u,v) g) = w {u,v} + weight w g"
    unfolding weight_def
    apply clarsimp
    apply (subst sum.insert)
    by (auto dest: edges_sym' simp: uedge_def insert_commute)

  lemma uedge_img_disj_iff[simp]: "uedge`edges g\<^sub>1 \<inter> uedge`edges g\<^sub>2 = {} \<longleftrightarrow> edges g\<^sub>1 \<inter> edges g\<^sub>2 = {}"
    by (auto simp: uedge_eq_iff dest: edges_sym')+

  lemma weight_join[simp]: "edges g\<^sub>1 \<inter> edges g\<^sub>2 = {} \<Longrightarrow> weight w (graph_join g\<^sub>1 g\<^sub>2) = weight w g\<^sub>1 + weight w g\<^sub>2"
    unfolding weight_alt by (auto simp: sum.union_disjoint image_Un)

  lemma weight_cong: "edges g\<^sub>1 = edges g\<^sub>2 \<Longrightarrow> weight w g\<^sub>1 = weight w g\<^sub>2"
    by (auto simp: weight_def)

  lemma weight_mono: "edges g \<subseteq> edges g' \<Longrightarrow> weight w g \<le> weight w g'"
    unfolding weight_alt apply (rule sum_mono2) by auto

  lemma weight_ge_edge:
    assumes "(x,y)\<in>edges T"
    shows "weight w T \<ge> w {x,y}"
    using assms unfolding weight_alt
    by (auto simp: uedge_def intro: member_le_sum)

  lemma weight_del_edge[simp]:
    assumes "(x,y)\<in>edges T"
    shows "weight w (restrict_edges T (- {(x, y), (y, x)})) = weight w T - w {x,y}"
  proof -
    define E where "E = uedge ` edges T - {{x,y}}"
    have [simp]: "(uedge ` (edges T - {(x, y), (y, x)})) = E"
      by (safe; simp add: E_def uedge_def doubleton_eq_iff; blast)

    from assms have [simp]: "uedge ` edges T = insert {x,y} E"
      unfolding E_def by force

    have [simp]: "{x,y}\<notin>E" unfolding E_def by blast

    then show ?thesis
      unfolding weight_alt
      apply simp
      by (metis E_def \<open>uedge ` edges T = insert {x, y} E\<close> insertI1 sum_diff1_nat)
  qed

  subsection \<open>Minimum Spanning Trees\<close>

  definition "is_MST w g t \<equiv> is_spanning_tree g t
    \<and> (\<forall>t'. is_spanning_tree g t' \<longrightarrow> weight w t \<le> weight w t')"

  lemma exists_MST: "connected g \<Longrightarrow> \<exists>t. is_MST w g t"
    using ex_has_least_nat[of "is_spanning_tree g"] ex_spanning_tree unfolding is_MST_def by blast

end


theory Poincare_Circles
  imports Poincare_Distance
begin
(* -------------------------------------------------------------------------- *)
section\<open>H-circles in the Poincar\'e model\<close>
(* -------------------------------------------------------------------------- *)

text\<open>Circles consist of points that are at the same distance from the center.\<close>
definition poincare_circle :: "complex_homo \<Rightarrow> real \<Rightarrow> complex_homo set" where
  "poincare_circle z r = {z'. z' \<in> unit_disc \<and> poincare_distance z z' = r}"

text\<open>Each h-circle in the Poincar\'e model is represented by an Euclidean circle in the model ---
the center and radius of that euclidean circle are determined by the following formulas.\<close>
definition poincare_circle_euclidean :: "complex_homo \<Rightarrow> real \<Rightarrow> euclidean_circle" where
  "poincare_circle_euclidean z r =
      (let R = (cosh r - 1) / 2;
           z' = to_complex z;
           cz = 1 - (cmod z')\<^sup>2;
           k = cz * R + 1
        in (z' / k, cz * sqrt(R * (R + 1)) / k))"

text\<open>That Euclidean circle has a positive radius and is always fully within the disc.\<close>
lemma poincare_circle_in_disc:
  assumes "r > 0" and "z \<in> unit_disc" and "(ze, re) = poincare_circle_euclidean z r"
  shows "cmod ze < 1" "re > 0" "\<forall> x \<in> circle ze re. cmod x < 1"
proof-
  let ?R = "(cosh r - 1) / 2"
  let ?z' = "to_complex z"
  let ?cz = "1 - (cmod ?z')\<^sup>2"
  let ?k = "?cz * ?R + 1"
  let ?ze = "?z' / ?k"
  let ?re = "?cz * sqrt(?R * (?R + 1)) / ?k"

  from \<open>z \<in> unit_disc\<close>
  obtain z' where z': "z = of_complex z'"
    using inf_or_of_complex[of z]
    by auto

  hence "z' = ?z'"
    by simp

  obtain cz where cz: "cz = (1 - (cmod z')\<^sup>2)"
    by auto

  have "cz > 0" "cz \<le> 1"
    using \<open>z \<in> unit_disc\<close> z' cz
    using unit_disc_cmod_square_lt_1
    by fastforce+

  obtain R where R: "R = ?R"
    by blast

  have "R > 0"
    using cosh_gt_1[of r] \<open>r > 0\<close>
    by (subst R) simp

  obtain k where k: "k = cz * R + 1"
    by auto

  have "k > 1"
    using k \<open>R > 0\<close> \<open>cz > 0\<close>
    by simp

  hence "cmod k = k"
    by simp

  let ?RR = "cz * sqrt(R * (R + 1)) / k"

  have "cmod z' + cz * sqrt(R * (R + 1)) < k"
  proof-
    have "((R+1)-R)\<^sup>2 > 0"
      by simp
    hence "(R+1)\<^sup>2 - 2*R*(R+1) + R\<^sup>2 > 0"
      unfolding power2_diff
      by (simp add: field_simps)
    hence "(R+1)\<^sup>2 + 2*R*(R+1) + R\<^sup>2 - 4*R*(R+1) > 0"
      by simp
    hence "(2*R+1)\<^sup>2 / 4 > R*(R+1)"
      using power2_sum[of "R+1" R]
      by (simp add: field_simps)
    hence "sqrt(R*(R+1)) < (2*R+1) / 2"
      using \<open>R > 0\<close>
      by (smt arith_geo_mean_sqrt power_divide real_sqrt_four real_sqrt_pow2 zero_le_mult_iff)
    hence "sqrt(R*(R+1)) - R < 1/2"
      by (simp add: field_simps)
    hence "(1 + (cmod z')) * (sqrt(R*(R+1)) - R) < (1 + (cmod z')) *  (1 / 2)"
      by (subst mult_strict_left_mono, simp, smt norm_not_less_zero, simp)
    also have "... < 1"
      using \<open>z \<in> unit_disc\<close> z'
      by auto
    finally have "(1 - cmod z') * ((1 + cmod z') * (sqrt(R*(R+1)) - R)) < (1 - cmod z') * 1"
      using \<open>z \<in> unit_disc\<close> z'
      by (subst mult_strict_left_mono, simp_all)
    hence "cz * (sqrt (R*(R+1)) - R) < 1 - cmod z'"
      using square_diff_square_factored[of 1 "cmod z'"]
      by (subst cz, subst (asm) mult.assoc[symmetric], simp add: power2_eq_square field_simps)
    hence "cmod z' + cz * sqrt(R*(R+1)) < 1 + R * cz"
      by (simp add: field_simps)
    thus ?thesis
      using k
      by (simp add: field_simps)
  qed
  hence "cmod z' / k + cz * sqrt(R * (R + 1)) / k < 1"
    using \<open>k > 1\<close>
    unfolding add_divide_distrib[symmetric]
    by simp
  hence "cmod (z' / k) + cz * sqrt(R * (R + 1)) / k < 1"
    using \<open>k > 1\<close>
    by simp
  hence "cmod ?ze + ?re < 1"
    using k cz \<open>R = ?R\<close> z'
    by simp

  moreover

  have "cz * sqrt(R * (R + 1)) / k > 0"
    using \<open>cz > 0\<close> \<open>R > 0\<close> \<open>k > 1\<close>
    by auto
  hence "?re > 0"
    using k cz \<open>R = ?R\<close> z'
    by simp

  moreover

  have "cmod ?ze < 1"
    using \<open>cmod ?ze + ?re < 1\<close> \<open>?re > 0\<close>
    by simp

  moreover

  have "ze = ?ze" "re = ?re"
    using \<open>(ze, re) = poincare_circle_euclidean z r\<close>
    unfolding poincare_circle_euclidean_def Let_def
    by simp_all

  moreover

  have "\<forall> x \<in> circle ze re. cmod x \<le> cmod ze + re"
    using norm_triangle_ineq2[of _ ze]
    unfolding circle_def
    by (smt mem_Collect_eq)

  ultimately

  show "cmod ze < 1" "re > 0" "\<forall> x \<in> circle ze re. cmod x < 1"
    by auto
qed

text\<open>The connection between the points on the h-circle and its corresponding Euclidean circle.\<close>
lemma poincare_circle_is_euclidean_circle:
  assumes "z \<in> unit_disc" and "r > 0"
  shows  "let (Ze, Re) = poincare_circle_euclidean z r
           in of_complex ` (circle Ze Re) = poincare_circle z r"
proof-
  {
    fix x
    let ?z = "to_complex z"

    from assms obtain z' where z': "z = of_complex z'" "cmod z' < 1"
      using inf_or_of_complex[of z]
      by auto

    have *: "\<And> x. cmod x < 1 \<Longrightarrow> 1 - (cmod x)\<^sup>2 > 0"
      by (metis less_iff_diff_less_0 minus_diff_eq mult.left_neutral neg_less_0_iff_less norm_mult_less norm_power power2_eq_square)

    let ?R = "(cosh r - 1) / 2"
    obtain R where R: "R = ?R"
      by blast

    let ?cx = "1 - (cmod x)\<^sup>2" and ?cz = "1 - (cmod z')\<^sup>2"  and ?czx = "(cmod (z' - x))\<^sup>2"

    let ?k = "1 + R * ?cz"
    obtain k where k: "k = ?k"
      by blast
    have "R > 0"
      using R cosh_gt_1[OF \<open>r > 0\<close>]
      by simp

    hence "k > 1"
      using assms z' k *[of z']
      by auto
    hence **: "cor k \<noteq> 0"
      by (smt of_real_eq_0_iff)

    have "of_complex x \<in> poincare_circle z r \<longleftrightarrow> cmod x < 1 \<and> poincare_distance z (of_complex x) = r"
      unfolding poincare_circle_def
      by auto
    also have "... \<longleftrightarrow> cmod x < 1 \<and> poincare_distance_formula' ?z x = cosh r"
      using poincare_distance_formula[of z "of_complex x"] cosh_dist[of z "of_complex x"]
      unfolding poincare_distance_formula_def
      using assms
      using arcosh_cosh_real
      by auto
    also have "... \<longleftrightarrow> cmod x < 1 \<and> ?czx / (?cz * ?cx) = ?R"
      using z'
      by (simp add: field_simps)
    also have "... \<longleftrightarrow> cmod x < 1 \<and> ?czx = ?R * ?cx * ?cz"
      using assms z' *[of z'] *[of x]
      using nonzero_divide_eq_eq[of "(1 - (cmod x)\<^sup>2) * (1 - (cmod z')\<^sup>2)" "(cmod (z' - x))\<^sup>2" ?R]
      by (auto, simp add: field_simps)
    also have "... \<longleftrightarrow> cmod x < 1 \<and> (z' - x) * (cnj z' - cnj x) = R * ?cz * (1 - x * cnj x)" (is "_ \<longleftrightarrow> _ \<and> ?l = ?r")
    proof-
      let ?l = "(z' - x) * (cnj z' - cnj x)" and ?r = "R * (1 - Re (z' * cnj z')) * (1 - x * cnj x)"
      have "is_real ?l"
        using eq_cnj_iff_real[of "?l"]
        by simp
      moreover
      have "is_real ?r"
        using eq_cnj_iff_real[of "1 - x * cnj x"]
        using Im_complex_of_real[of "R * (1 - Re (z' * cnj z'))"]
        by simp
      ultimately
      show ?thesis
        apply (subst R[symmetric])
        apply (subst cmod_square)+
        apply (subst complex_eq_if_Re_eq, simp_all add: field_simps)
        done
    qed
    also have "... \<longleftrightarrow> cmod x < 1 \<and> z' * cnj z' - x * cnj z' - cnj x * z' + x * cnj x = R * ?cz - R * ?cz * x * cnj x"
      unfolding right_diff_distrib left_diff_distrib
      by (simp add: field_simps)
    also have "... \<longleftrightarrow> cmod x < 1 \<and> k * (x * cnj x) - x * cnj z' - cnj x * z' + z' * cnj z' = R * ?cz" (is "_ \<longleftrightarrow> _ \<and> ?lhs = ?rhs")
      by (subst k) (auto simp add: field_simps)
    also have "... \<longleftrightarrow> cmod x < 1 \<and> (k * x * cnj x - x * cnj z' - cnj x * z' + z' * cnj z') / k = (R * ?cz) / k"
      using **
      by (auto simp add: Groups.mult_ac(1))
    also have "... \<longleftrightarrow> cmod x < 1 \<and> x * cnj x - x * cnj z' / k - cnj x * z' / k + z' * cnj z' / k = (R * ?cz) / k"
      using **
      unfolding add_divide_distrib diff_divide_distrib
      by auto
    also have "... \<longleftrightarrow> cmod x < 1 \<and> (x - z'/k) * cnj(x - z'/k) = (R * ?cz) / k + (z' / k) * cnj(z' / k) - z' * cnj z' / k"
      by (auto simp add: field_simps diff_divide_distrib)
    also have "... \<longleftrightarrow> cmod x < 1 \<and> (cmod (x - z'/k))\<^sup>2 = (R * ?cz) / k + (cmod z')\<^sup>2 / k\<^sup>2 - (cmod z')\<^sup>2 / k"
      apply (subst complex_mult_cnj_cmod)+
      apply (subst complex_eq_if_Re_eq)
      apply (simp_all add: power_divide)
      done
    also have "... \<longleftrightarrow> cmod x < 1 \<and> (cmod (x - z'/k))\<^sup>2 = (R * ?cz * k + (cmod z')\<^sup>2 - (cmod z')\<^sup>2 * k) / k\<^sup>2"
      using **
      unfolding add_divide_distrib diff_divide_distrib
      by (simp add: power2_eq_square)
    also have "... \<longleftrightarrow> cmod x < 1 \<and> (cmod (x - z'/k))\<^sup>2 = ?cz\<^sup>2 * R * (R + 1) / k\<^sup>2" (is "_ \<longleftrightarrow> _ \<and> ?a\<^sup>2 = ?b")
    proof-
      have *: "R * (1 - (cmod z')\<^sup>2) * k + (cmod z')\<^sup>2 - (cmod z')\<^sup>2 * k = (1 - (cmod z')\<^sup>2)\<^sup>2 * R * (R + 1)"
        by (subst k)+ (simp add: field_simps power2_diff)
      thus ?thesis
        by (subst *, simp)
    qed
    also have "... \<longleftrightarrow> cmod x < 1 \<and> cmod (x - z'/k) = ?cz * sqrt (R * (R + 1)) / k"
      using \<open>R > 0\<close> *[of z'] ** \<open>k > 1\<close> \<open>z \<in> unit_disc\<close> z'
      using real_sqrt_unique[of ?a ?b, symmetric]
      by (auto simp add: real_sqrt_divide real_sqrt_mult power_divide power_mult_distrib)
    finally
    have "of_complex x \<in> poincare_circle z r \<longleftrightarrow> cmod x < 1 \<and> x \<in> circle (z'/k) (?cz * sqrt(R * (R+1)) / k)"
      unfolding circle_def z' k R
      by simp
    hence "of_complex x \<in> poincare_circle z r \<longleftrightarrow> (let (Ze, Re) = poincare_circle_euclidean z r in cmod x < 1 \<and> x \<in> circle Ze Re)"
      unfolding poincare_circle_euclidean_def Let_def circle_def
      using z' R k
      by (simp add: field_simps)
    hence "of_complex x \<in> poincare_circle z r \<longleftrightarrow> (let (Ze, Re) = poincare_circle_euclidean z r in x \<in> circle Ze Re)"
      using poincare_circle_in_disc[OF \<open>r > 0\<close> \<open>z \<in> unit_disc\<close>]
      by auto
  } note * = this
  show ?thesis
    unfolding Let_def
  proof safe
    fix Ze Re x
    assume "poincare_circle_euclidean z r = (Ze, Re)" "x \<in> circle Ze Re"
    thus "of_complex x \<in> poincare_circle z r"
      using *[of x]
      by simp
  next
    fix Ze Re x
    assume **: "poincare_circle_euclidean z r = (Ze, Re)" "x \<in> poincare_circle z r"
    then obtain x' where x': "x = of_complex x'"
      unfolding poincare_circle_def
      using inf_or_of_complex[of x]
      by auto
    hence "x' \<in> circle Ze Re"
      using *[of x'] **
      by simp
    thus "x \<in> of_complex ` circle Ze Re"
      using x'
      by auto
  qed
qed

subsection \<open>Intersection of circles in special positions\<close>

text \<open>Two h-circles centered at the x-axis intersect at mutually conjugate points\<close>
lemma intersect_poincare_circles_x_axis:
  assumes z: "is_real z1" and "is_real z2" and "r1 > 0" and "r2 > 0" and
             "-1 < Re z1" and "Re z1 < 1" and "-1 < Re z2" and "Re z2 < 1" and
             "z1 \<noteq> z2"
  assumes x1: "x1 \<in> poincare_circle (of_complex z1) r1 \<inter> poincare_circle (of_complex z2) r2" and
          x2: "x2 \<in> poincare_circle (of_complex z1) r1 \<inter> poincare_circle (of_complex z2) r2" and
              "x1 \<noteq> x2"
  shows "x1 = conjugate x2"
proof-
  have in_disc: "of_complex z1 \<in> unit_disc" "of_complex z2 \<in> unit_disc"
    using assms
    by (auto simp add: cmod_eq_Re)

  obtain x1' x2' where x': "x1 = of_complex x1'" "x2 = of_complex x2'"
    using x1 x2
    using inf_or_of_complex[of x1] inf_or_of_complex[of x2]
    unfolding poincare_circle_def
    by auto

  obtain Ze1 Re1 where 1: "(Ze1, Re1) = poincare_circle_euclidean (of_complex z1) r1"
    by (metis poincare_circle_euclidean_def)
  obtain Ze2 Re2 where 2: "(Ze2, Re2) = poincare_circle_euclidean (of_complex z2) r2"
    by (metis poincare_circle_euclidean_def)
  have circle: "x1' \<in> circle Ze1 Re1 \<inter> circle Ze2 Re2"  "x2' \<in> circle Ze1 Re1 \<inter> circle Ze2 Re2"
    using poincare_circle_is_euclidean_circle[of "of_complex z1" r1]
    using poincare_circle_is_euclidean_circle[of "of_complex z2" r2]
    using assms 1 2 \<open>of_complex z1 \<in> unit_disc\<close> \<open>of_complex z2 \<in> unit_disc\<close> x'
    by auto (metis image_iff of_complex_inj)+

  have "is_real Ze1" "is_real Ze2"
    using 1 2 \<open>is_real z1\<close> \<open>is_real z2\<close>
    by (simp_all add: poincare_circle_euclidean_def Let_def)

  have "Re1 > 0" "Re2 > 0"
    using 1 2 in_disc \<open>r1 > 0\<close> \<open>r2 > 0\<close>
    using poincare_circle_in_disc(2)[of r1 "of_complex z1" Ze1 Re1]
    using poincare_circle_in_disc(2)[of r2 "of_complex z2" Ze2 Re2]
    by auto

  have "Ze1 \<noteq> Ze2"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    hence eq: "Ze1 = Ze2" "Re1 = Re2"
      using circle(1)
      unfolding circle_def
      by auto

    let ?A = "Ze1 - Re1" and ?B = "Ze1 + Re1"
    have "?A \<in> circle Ze1 Re1" "?B \<in> circle Ze1 Re1"
      using \<open>Re1 > 0\<close>
      unfolding circle_def
      by simp_all
    hence "of_complex ?A \<in> poincare_circle (of_complex z1) r1" "of_complex ?B \<in> poincare_circle (of_complex z1) r1"
          "of_complex ?A \<in> poincare_circle (of_complex z2) r2" "of_complex ?B \<in> poincare_circle (of_complex z2) r2"
      using eq
      using poincare_circle_is_euclidean_circle[OF \<open>of_complex z1 \<in> unit_disc\<close> \<open>r1 > 0\<close>]
      using poincare_circle_is_euclidean_circle[OF \<open>of_complex z2 \<in> unit_disc\<close> \<open>r2 > 0\<close>]
      using 1 2
      by auto blast+
    hence "poincare_distance (of_complex z1) (of_complex ?A) = poincare_distance (of_complex z1) (of_complex ?B)"
          "poincare_distance (of_complex z2) (of_complex ?A) = poincare_distance (of_complex z2) (of_complex ?B)"
          "-1 < Re (Ze1 - Re1)" "Re (Ze1 - Re1) < 1" "-1 < Re (Ze1 + Re1)" "Re (Ze1 + Re1) < 1"
      using \<open>is_real Ze1\<close> \<open>is_real Ze2\<close>
      unfolding poincare_circle_def
      by (auto simp add: cmod_eq_Re)
    hence "z1 = z2"
      using unique_midpoint_x_axis[of "Ze1 - Re1" "Ze1 + Re1"]
      using \<open>is_real Ze1\<close> \<open>is_real z1\<close> \<open>is_real z2\<close> \<open>Re1 > 0\<close> \<open>-1 < Re z1\<close> \<open>Re z1 < 1\<close> \<open>-1 < Re z2\<close> \<open>Re z2 < 1\<close>
      by auto
    thus False
      using \<open>z1 \<noteq> z2\<close>
      by simp
  qed

  hence *: "(Re x1')\<^sup>2 + (Im x1')\<^sup>2 - 2 * Re x1' * Ze1 + Ze1 * Ze1 - cor (Re1 * Re1) = 0"
           "(Re x1')\<^sup>2 + (Im x1')\<^sup>2 - 2 * Re x1' * Ze2 + Ze2 * Ze2 - cor (Re2 * Re2) = 0"
           "(Re x2')\<^sup>2 + (Im x2')\<^sup>2 - 2 * Re x2' * Ze1 + Ze1 * Ze1 - cor (Re1 * Re1) = 0"
           "(Re x2')\<^sup>2 + (Im x2')\<^sup>2 - 2 * Re x2' * Ze2 + Ze2 * Ze2 - cor (Re2 * Re2) = 0"
    using circle_equation[of Re1 Ze1] circle_equation[of Re2 Ze2] circle
    using eq_cnj_iff_real[of Ze1] \<open>is_real Ze1\<close> \<open>Re1 > 0\<close>
    using eq_cnj_iff_real[of Ze2] \<open>is_real Ze2\<close> \<open>Re2 > 0\<close>
    using complex_add_cnj[of x1']  complex_add_cnj[of x2']
    using distrib_left[of Ze1 x1' "cnj x1'"] distrib_left[of Ze2 x1' "cnj x1'"]
    using distrib_left[of Ze1 x2' "cnj x2'"] distrib_left[of Ze2 x2' "cnj x2'"]
    by (auto simp add: complex_mult_cnj power2_eq_square field_simps)

  hence "- 2 * Re x1' * Ze1 + Ze1 * Ze1 - cor (Re1 * Re1) = - 2 * Re x1' * Ze2 + Ze2 * Ze2 - cor (Re2 * Re2)"
        "- 2 * Re x2' * Ze1 + Ze1 * Ze1 - cor (Re1 * Re1) = - 2 * Re x2' * Ze2 + Ze2 * Ze2 - cor (Re2 * Re2)"
    by (smt add_diff_cancel_right' add_diff_eq eq_iff_diff_eq_0 minus_diff_eq mult_minus_left of_real_minus)+
  hence "2 * Re x1' * (Ze2 - Ze1) =  (Ze2 * Ze2 - cor (Re2 * Re2)) - (Ze1 * Ze1 - cor (Re1 * Re1))"
        "2 * Re x2' * (Ze2 - Ze1) =  (Ze2 * Ze2 - cor (Re2 * Re2)) - (Ze1 * Ze1 - cor (Re1 * Re1))"
    by simp_all (simp add: field_simps)+
  hence "2 * Re x1' * (Ze2 - Ze1) = 2 * Re x2' * (Ze2 - Ze1)"
    by simp
  hence "Re x1' = Re x2'"
    using \<open>Ze1 \<noteq> Ze2\<close>
    by simp
  moreover
  hence "(Im x1')\<^sup>2 = (Im x2')\<^sup>2"
    using *(1) *(3)
    by (simp add: \<open>is_real Ze1\<close> complex_eq_if_Re_eq)
  hence "Im x1' = Im x2' \<or> Im x1' = -Im x2'"
    using power2_eq_iff
    by blast
  ultimately
  show ?thesis
    using x' `x1 \<noteq> x2`
    using complex.expand
    by (metis cnj.code complex_surj conjugate_of_complex)
qed

text \<open>Two h-circles of the same radius centered at mutually conjugate points intersect at the x-axis\<close>
lemma intersect_poincare_circles_conjugate_centers:
  assumes in_disc: "z1 \<in> unit_disc" "z2 \<in> unit_disc" and
          "z1 \<noteq> z2" and "z1 = conjugate z2" and "r > 0" and
          u: "u \<in> poincare_circle z1 r \<inter> poincare_circle z2 r"
  shows "is_real (to_complex u)"
proof-
  obtain z1e r1e z2e r2e where
   euclidean: "(z1e, r1e) = poincare_circle_euclidean z1 r"
              "(z2e, r2e) = poincare_circle_euclidean z2 r"
    by (metis poincare_circle_euclidean_def)
  obtain z1' z2' where z': "z1 = of_complex z1'" "z2 = of_complex z2'"
    using inf_or_of_complex[of z1] inf_or_of_complex[of z2] in_disc
    by auto
  obtain u' where u': "u = of_complex u'"
    using u inf_or_of_complex[of u]
    by (auto simp add: poincare_circle_def)
  have "z1' = cnj z2'"
    using \<open>z1 = conjugate z2\<close> z'
    by (auto simp add: of_complex_inj)
  moreover
  let ?cz = "1 - (cmod z2')\<^sup>2"
  let ?den = "?cz * (cosh r - 1) / 2 + 1"
  have "?cz > 0"
    using in_disc z'
    by (simp add: cmod_def)
  hence "?den \<ge> 1"
    using cosh_gt_1[OF \<open>r > 0\<close>]
    by auto
  hence "?den \<noteq> 0"
    by simp
  hence "cor ?den \<noteq> 0"
    using of_real_eq_0_iff
    by blast
  ultimately
  have "r1e = r2e" "z1e = cnj z2e" "z1e \<noteq> z2e"
    using z' euclidean \<open>z1 \<noteq> z2\<close>
    unfolding poincare_circle_euclidean_def Let_def
    by simp_all metis

  hence "u' \<in> circle (cnj z2e) r2e \<inter> circle z2e r2e" "z2e \<noteq> cnj z2e"
    using euclidean u u'
    using poincare_circle_is_euclidean_circle[of z1 r]
    using poincare_circle_is_euclidean_circle[of z2 r]
    using in_disc \<open>r > 0\<close>
    by auto (metis image_iff of_complex_inj)+
  hence "(cmod (u' - z2e))\<^sup>2 = (cmod(u' - cnj z2e))\<^sup>2"
    by (simp add: circle_def)
  hence "(u' - z2e) * (cnj u' - cnj z2e) = (u' - cnj z2e) * (cnj u' - z2e)"
    by (metis complex_cnj_cnj complex_cnj_diff complex_norm_square)
  hence "(z2e - cnj z2e) * (u' - cnj u') = 0"
    by (simp add: field_simps)
  thus ?thesis
    using u' \<open>z2e \<noteq> cnj z2e\<close> eq_cnj_iff_real[of u']
    by simp
qed

subsection \<open>Congruent triangles\<close>

text\<open>For every pair of triangles such that its three pairs of sides are pairwise equal there is an
h-isometry (a unit disc preserving Möbius transform, eventually composed with a conjugation) that
maps one triangle onto the other.\<close>
lemma unit_disc_fix_f_congruent_triangles:
  assumes
    in_disc: "u \<in> unit_disc" "v \<in> unit_disc" "w \<in> unit_disc" and
    in_disc': "u' \<in> unit_disc" "v' \<in> unit_disc" "w' \<in> unit_disc" and
    d: "poincare_distance u v = poincare_distance u' v'"
       "poincare_distance v w = poincare_distance v' w'"
       "poincare_distance u w = poincare_distance u' w'"
  shows
    "\<exists> M. unit_disc_fix_f M \<and> M u = u' \<and> M v = v' \<and> M w = w'"
proof (cases "u = v \<or> u = w \<or> v = w")
  case True
  thus ?thesis
    using assms
    using poincare_distance_eq_0_iff[of u' v']
    using poincare_distance_eq_0_iff[of v' w']
    using poincare_distance_eq_0_iff[of u' w']
    using poincare_distance_eq_ex_moebius[of v w v' w']
    using poincare_distance_eq_ex_moebius[of u w u' w']
    using poincare_distance_eq_ex_moebius[of u v u' v']
    by (metis unit_disc_fix_f_def)
next
  case False

  have "\<forall> w u' v' w'. w \<in> unit_disc \<and> u' \<in> unit_disc \<and> v' \<in> unit_disc \<and> w' \<in> unit_disc \<and> w \<noteq> u \<and> w \<noteq> v \<and>
    poincare_distance u v = poincare_distance u' v' \<and>
    poincare_distance v w = poincare_distance v' w' \<and>
    poincare_distance u w = poincare_distance u' w' \<longrightarrow>
    (\<exists> M. unit_disc_fix_f M \<and> M u = u' \<and> M v = v' \<and> M w = w')" (is "?P u v")
  proof (rule wlog_positive_x_axis[where P="?P"])
    show "v \<in> unit_disc" "u \<in> unit_disc"
      by fact+
  next
    show "u \<noteq> v"
      using False
      by simp
  next
    fix x
    assume x: "is_real x" "0 < Re x" "Re x < 1"

    hence "of_complex x \<noteq> 0\<^sub>h"
      using of_complex_zero_iff[of x]
      by (auto simp add: complex.expand)

    show "?P 0\<^sub>h (of_complex x)"
    proof safe
      fix w u' v' w'
      assume in_disc: "w \<in> unit_disc" "u' \<in> unit_disc" "v' \<in> unit_disc" "w' \<in> unit_disc"
      assume "poincare_distance 0\<^sub>h (of_complex x) = poincare_distance u' v'"
      then obtain M' where M': "unit_disc_fix M'" "moebius_pt M' u' = 0\<^sub>h" "moebius_pt M' v' = (of_complex x)"
        using poincare_distance_eq_ex_moebius[of u' v' "0\<^sub>h" "of_complex x"] in_disc x
        by (auto simp add: cmod_eq_Re)

      let ?w = "moebius_pt M' w'"
      have "?w \<in> unit_disc"
        using \<open>unit_disc_fix M'\<close> \<open>w' \<in> unit_disc\<close>
        by simp

      assume "w \<noteq> 0\<^sub>h" "w \<noteq> of_complex x"
      hence dist_gt_0: "poincare_distance 0\<^sub>h w > 0" "poincare_distance (of_complex x) w > 0"
        using poincare_distance_eq_0_iff[of "0\<^sub>h" w] in_disc poincare_distance_ge0[of "0\<^sub>h" w]
        using poincare_distance_eq_0_iff[of "of_complex x" w] in_disc poincare_distance_ge0[of "of_complex x" w]
        using x
        by (simp_all add: cmod_eq_Re)

      assume "poincare_distance (of_complex x) w = poincare_distance v' w'"
             "poincare_distance 0\<^sub>h w = poincare_distance u' w'"
      hence "poincare_distance 0\<^sub>h ?w = poincare_distance 0\<^sub>h w"
            "poincare_distance (of_complex x) ?w = poincare_distance (of_complex x) w"
        using M'(1) M'(2)[symmetric] M'(3)[symmetric] in_disc
        using unit_disc_fix_preserve_poincare_distance[of M' u' w']
        using unit_disc_fix_preserve_poincare_distance[of M' v' w']
        by simp_all
      hence "?w \<in> poincare_circle 0\<^sub>h (poincare_distance 0\<^sub>h w) \<inter> poincare_circle (of_complex x) (poincare_distance (of_complex x) w)"
            "w \<in> poincare_circle 0\<^sub>h (poincare_distance 0\<^sub>h w) \<inter> poincare_circle (of_complex x) (poincare_distance (of_complex x) w)"
        using \<open>?w \<in> unit_disc\<close> \<open>w \<in> unit_disc\<close>
        unfolding poincare_circle_def
        by simp_all
      hence "?w = w \<or> ?w = conjugate w"
        using intersect_poincare_circles_x_axis[of 0 x "poincare_distance 0\<^sub>h w" "poincare_distance (of_complex x) w" ?w w] x
        using \<open>of_complex x \<noteq> 0\<^sub>h\<close> dist_gt_0
        using poincare_distance_eq_0_iff
        by auto
      thus "\<exists>M. unit_disc_fix_f M \<and> M 0\<^sub>h = u' \<and> M (of_complex x) = v' \<and> M w = w'"
      proof
        assume "moebius_pt M' w' = w"
        thus ?thesis
          using M'
          using moebius_pt_invert[of M' u' "0\<^sub>h"]
          using moebius_pt_invert[of M' v' "of_complex x"]
          using moebius_pt_invert[of M' w' "w"]
          apply (rule_tac x="moebius_pt (-M')" in exI)
          apply (simp add: unit_disc_fix_f_def)
          apply (rule_tac x="-M'" in exI, simp)
          done
      next
        let ?M = "moebius_pt (-M') \<circ> conjugate"
        assume "moebius_pt M' w' = conjugate w"
        hence "?M w = w'"
          using moebius_pt_invert[of  M' w' "conjugate w"]
          by simp
        moreover
        have "?M 0\<^sub>h = u'" "?M (of_complex x) = v'"
          using moebius_pt_invert[of M' u' "0\<^sub>h"]
          using moebius_pt_invert[of M' v' "of_complex x"]
          using M' \<open>is_real x\<close> eq_cnj_iff_real[of x]
          by simp_all
        moreover
        have "unit_disc_fix_f ?M"
          using \<open>unit_disc_fix M'\<close>
          unfolding unit_disc_fix_f_def
          by (rule_tac x="-M'" in exI, simp)
        ultimately
        show ?thesis
          by blast
      qed
    qed
  next
    fix M u v
    assume 1: "unit_disc_fix M" "u \<in> unit_disc" "v \<in> unit_disc"
    let ?Mu = "moebius_pt M u" and ?Mv = "moebius_pt M v"
    assume 2: "?P ?Mu ?Mv"
    show "?P u v"
    proof safe
      fix w u' v' w'
      let ?Mw = "moebius_pt M w" and ?Mu' = "moebius_pt M u'" and ?Mv' = "moebius_pt M v'" and ?Mw' = "moebius_pt M w'"
      assume "w \<in> unit_disc" "u' \<in> unit_disc" "v' \<in> unit_disc" "w' \<in> unit_disc" "w \<noteq> u" "w \<noteq> v"
             "poincare_distance u v = poincare_distance u' v'"
             "poincare_distance v w = poincare_distance v' w'"
             "poincare_distance u w = poincare_distance u' w'"
      then obtain M' where M': "unit_disc_fix_f M'" "M' ?Mu = ?Mu'" "M' ?Mv = ?Mv'" "M' ?Mw = ?Mw'"
        using 1 2[rule_format, of ?Mw ?Mu' ?Mv' ?Mw']
        by auto

      let ?M = "moebius_pt (-M) \<circ> M' \<circ> moebius_pt M"
      show "\<exists>M. unit_disc_fix_f M \<and> M u = u' \<and> M v = v' \<and> M w = w'"
      proof (rule_tac x="?M" in exI, safe)
        show "unit_disc_fix_f ?M"
          using M'(1) \<open>unit_disc_fix M\<close>
          by (subst unit_disc_fix_f_comp, subst unit_disc_fix_f_comp, simp_all)
      next
        show "?M u = u'" "?M v = v'" "?M w = w'"
          using M'
          by auto
      qed
    qed
  qed
  thus ?thesis
    using assms False
    by auto
qed

end


theory BasicAlgebra
imports Main
begin

(* this is just me messing around reminding myself of basic Isabelle syntax *)

locale group =
  fixes mult :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<cdot>" 50)
  and id :: "'a"
  and inv :: "'a \<Rightarrow> 'a"
  assumes lmultinv [simp] : "(inv x) \<cdot> x = id"
  and rmultinv [simp] : "x \<cdot> (inv x) = id"
  and lmultid [simp] : "id \<cdot> x = x"
  and rmultid [simp] : "x \<cdot> id = x"
  and assoc : "(x \<cdot> (y \<cdot> z)) = ((x \<cdot> y) \<cdot> z)"

lemma (in group) unique_id:
  fixes id' :: "'a"
  assumes "\<And> x. id' \<cdot> x = x" (* why do we have to quantify the x here? *)
  and "\<And> x. x \<cdot> id' = x"
  shows "id = id'"
  proof -
  have "id' \<cdot> id = id" using assms by blast
  moreover have "id' \<cdot> id = id'" by simp
  ultimately show ?thesis by simp
  qed

thm group_def

datatype Nat = Zero | Succ Nat

fun addy :: "Nat \<Rightarrow> Nat \<Rightarrow> Nat" (infixl "\<oplus>" 50) where
"addy Zero n = n"|
"addy (Succ n) m = Succ (addy n m)"

fun subby :: "Nat \<Rightarrow> Nat \<Rightarrow> Nat" where
"subby Zero i = Zero" |
"subby i Zero = i" |
"subby (Succ i) (Succ j) = subby i j"

fun gt :: "Nat \<Rightarrow> Nat \<Rightarrow> bool" where
"gt (Succ i) Zero = True" |
"gt Zero i = False" |
"gt (Succ i) (Succ j) = gt i j"

fun lt :: "Nat \<Rightarrow> Nat \<Rightarrow> bool" where
"lt i Zero = False" |
"lt Zero (Succ i) = True" |
"lt (Succ i) (Succ j) = lt i j"

theorem addy_assoc : "n \<oplus> (m \<oplus> l) = ((n \<oplus> m) \<oplus> l)"
proof (induction n)
case Zero
 show ?case by simp
case (Succ n)
 thus ?case by simp
qed

datatype Integer = IZ | IPos Nat | INeg Nat

fun iaddy :: "Integer \<Rightarrow> Integer \<Rightarrow> Integer" (infixl "\<bullet>" 50) where
"iaddy IZ i = i" |
"iaddy i IZ = i" |
"iaddy (IPos i) (IPos j) = IPos (Succ (i \<oplus> j))"|
"iaddy (INeg i) (INeg j) = INeg (Succ (i \<oplus> j))"|
"iaddy (IPos i) (INeg j) = (if (gt i j)
  then (IPos (subby i (Succ j))) else
    (if (lt i j) then (INeg (subby j (Succ i))) else IZ))"|
"iaddy (INeg i) (IPos j) = (if (gt i j)
  then (INeg (subby i (Succ j))) else
    (if (lt i j) then (IPos (subby j (Succ i))) else IZ))"

lemma iassoc : "(m \<bullet> (n \<bullet> l)) = ((m \<bullet> n) \<bullet> l)"
proof (induction m)
case IZ
  show ?case by simp
case (IPos m)
  show ?case apply -
             apply (cases n)
             apply simp
             apply (cases l)
             apply simp
             apply (simp add: addy_assoc)
             apply simp (* in progress *)


(* Author: Alexander Bentkamp, Universität des Saarlandes
*)
section \<open>Missing Lemmas of Finite\_Set\<close>
theory DL_Missing_Finite_Set
imports Main
begin

lemma card_even[simp]: "card {a \<in> Collect even. a < 2 * n} = n"
proof (induction n)
  case 0
  then show ?case by auto
next
  case (Suc n)
  have "{a \<in> Collect even. a < 2 * Suc n} = insert (2*n) {a \<in> Collect even. a < 2 * n}"
    using le_eq_less_or_eq less_Suc_eq_le subset_antisym by force
  show ?case
    unfolding \<open>{a \<in> Collect even. a < 2 * Suc n} = insert (2*n) {a \<in> Collect even. a < 2 * n}\<close>
    using Suc card_insert_disjoint[of "{a \<in> Collect even. a < 2 * n}" "2*n"]
    by (simp add: finite_M_bounded_by_nat less_not_refl2)
qed

lemma card_odd[simp]: "card {a \<in> Collect odd. a < 2 * n} = n"
proof (induction n)
  case 0
  then show ?case by auto
next
  case (Suc n)
  have "{a \<in> Collect odd. a < 2 * Suc n} = insert (2*n+1) {a \<in> Collect odd. a < 2 * n}"
    using le_eq_less_or_eq less_Suc_eq_le subset_antisym by force
  show ?case
    unfolding \<open>{a \<in> Collect odd. a < 2 * Suc n} = insert (2*n+1) {a \<in> Collect odd. a < 2 * n}\<close>
    using Suc card_insert_disjoint[of "{a \<in> Collect even. a < 2 * n}" "2*n"]
    by (simp add: finite_M_bounded_by_nat less_not_refl2)
qed

end


theory CS_Ch5
imports Main
begin

lemma "\<not> surj (f :: 'a \<Rightarrow> 'a set)"
proof
  assume 0: "surj f"
  from 0 have 1: "\<forall>A. \<exists> a. A = f a" by (simp add: surj_def)
  from 1 have 2: "\<exists>a. {x. x \<notin> f x} = f a" by blast
  from 2 show "False" by blast
qed

lemma
fixes a b :: int
assumes "b dvd (a + b)"
shows "b dvd a"
proof -
  { fix k assume k: "a + b = b * k"
    have "\<exists>k'. a = b*k'"
    proof
      show "a = b*(k - 1)" using k by (simp add: algebra_simps)
    qed }
  then show ?thesis using assms by (auto simp add: dvd_def)
qed

(* 5.1 *)

lemma assumes T: "\<forall>x y. T x y \<or> T y x"
  and A: "\<forall>x y. A x y \<and> A y x \<longrightarrow> x = y"
  and TA: "\<forall>x y. T x y \<longrightarrow> A x y" and "A x y"
  shows "T x y"
proof (rule ccontr)
  assume "\<not> T x y"
  hence "T y x" using T by auto
  hence "A y x" using TA by simp
  hence "x = y" using assms by simp
  hence "T x x" using assms by (auto)
  hence "T x y" using assms and `x = y` by (auto)
  thus "False" using `\<not> T x y` by auto
qed

(* 5.2 *)

lemma not2k_is_2y_plus_1: "\<exists>l. a = 2 * l + 1 \<Longrightarrow> \<forall>k. (a :: nat) \<noteq> 2 * k" by presburger

lemma shows "(\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs) \<or> (\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs + 1)" (is "?L \<or> ?R")
proof cases
  assume k2: "even (length xs)"
  then obtain k where "length xs = 2 * k" using evenE by metis
  let ?x = "take k xs"
  let ?y = "drop k xs"
  have "(xs = ?x @ ?y \<and> length ?x = length ?y)" by (simp add: `length xs = 2 * k`)
  thus ?thesis by metis
next
  assume nk2: "odd (length xs)"
  then obtain l where "length xs = 2 * l + 1" using oddE by metis
  let ?x = "take (l+1) xs"
  let ?y = "drop (l+1) xs"
  have "length ?x = length ?y + 1" using `length xs = 2 * l + 1` by simp
  moreover have "xs = ?x @ ?y" by simp
  ultimately have "(xs = ?x @ ?y \<and> length ?x = length ?y + 1)" by simp
  hence th: "?L \<or> ?R" by metis
  thus ?thesis by metis
qed

inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS: "ev n \<Longrightarrow> ev (Suc (Suc n))"

(* 5.3 *)

lemma
assumes a: "ev (Suc (Suc n))"
shows "ev n"
proof -
  from a show "ev n"
  proof cases
    case evSS thus "ev n" by simp
  qed
qed

(* 5.4 *)

lemma
shows "\<not>ev (Suc (Suc (Suc 0)))"
proof
  assume "ev (Suc (Suc (Suc 0)))" thus False
  proof cases
    assume "ev (Suc 0)" thus False by cases
  qed
qed

(* 5.5 *)

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl: "star r x x" |
step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
iter0: "iter r 0 x x" |
iterstep: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (n+1) x z"

lemma
shows "iter r n x y \<Longrightarrow> star r x y"
proof (induction rule: iter.induct)
  case iter0 show ?case by (rule star.refl)
next
  case iterstep thus ?case by (auto intro: star.step)
qed

(* 5.6 *)

fun elems :: "'a list \<Rightarrow> 'a set" where
"elems [] = {}" |
"elems (x # xs) = {x} \<union> elems xs"

(* I don't think I like the case shorthand, but it sure does shorten proofs *)
lemma
fixes xs :: "'a list"
shows "x \<in> elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys"
proof (induction xs)
  case Nil
  (* personally I would have wanted to do a proof-by-contradiction here, but the simplifier
     seems to be able to handle this sort of case when it's simple enough *)
  thus ?case by simp
next
  case (Cons a as)
  show ?case
  proof cases
    (* a and as (such that xs = a # as) becomes a "Skolem variable". I don't know precisely what this means yet,
       but it seems to behave normally *)
    assume "x = a"
    then obtain zs where ac: "a # as = x # zs" by simp
    let ?ys = "[] :: 'a list"
    from ac have "a # as = ?ys @ x # zs" by simp
    have s: "x \<notin> elems ?ys" by simp
    from ac s show ?case by blast
    (* seems to be the easiest way to get the existential introduced.
       unfortunately/fortunately, blast also knows how to solve the goal outright without any
       of this manual fluffery! I think the point of this exercise is practice with structured
       proofs, so I'll leave it in.*)
   next
    assume "x \<noteq> a"
    from this `x \<in> elems (a # as)` have "x \<in> elems as" by simp
    from this Cons.IH obtain ys zs where "as = ys @ x # zs \<and> x \<notin> elems ys" by auto
    (* interestingly, this is a case where auto works but simp doesn't.
       I need to check the manual to see precisely what these proof methods do.
    *)
    from this `x \<noteq> a` Cons.IH obtain ys' where "a # as = ys' @ x # zs \<and> x \<notin> elems ys'" by force
    thus ?case by blast
  qed
qed

end


(*
    $Id: sol.thy,v 1.4 2011/06/28 18:11:38 webertj Exp $
    Author: Martin Strecker
*)

header {* Sets as Lists *}

(*<*) theory sol imports Main begin (*>*)

text {* Finite sets can obviously be implemented by lists.  In the
following, you will be asked to implement the set operations union,
intersection and difference and to show that these implementations are
correct.  Thus, for a function *}

primrec list_union :: "['a list, 'a list] \<Rightarrow> 'a list" where
  "list_union xs []     = xs"
| "list_union xs (y#ys) = (let result = list_union xs ys in if y : set result then result else y#result)"

text {* to be defined by you it has to be shown that *}

lemma "set (list_union xs ys) = set xs \<union> set ys"
  apply (induct "ys")
    apply simp
  apply (simp add: Let_def)
  apply auto
done

text {* In addition, the functions should be space efficient in the
sense that one obtains lists without duplicates (@{text "distinct"})
whenever the parameters of the functions are duplicate-free.  Thus, for
example, *}

lemma [rule_format]:
  "distinct xs \<longrightarrow> distinct ys \<longrightarrow> (distinct (list_union xs ys))"
  apply (induct "ys")
  apply (auto simp add: Let_def)
done

text {* \emph{Hint:} @{text "distinct"} is defined in @{text List.thy}. *}

text {* We omit the definitions and correctness proofs for set
intersection and set difference. *}

subsubsection {* Quantification over Sets *}

text {* Define a (non-trivial) set @{text S} such that the following
proposition holds: *}

lemma "((\<forall> x \<in> A. P x) \<and> (\<forall> x \<in> B. P x)) \<longrightarrow> (\<forall> x \<in> S. P x)"
(*<*)oops(*>*)

lemma "((\<forall> x \<in> A. P x) \<and> (\<forall> x \<in> B. P x)) \<longrightarrow> (\<forall> x \<in> A\<union>B. P x)"
  by auto

text {* Define a (non-trivial) predicate @{text P} such that *}

lemma "\<forall> x \<in> A. P (f x) \<Longrightarrow>  \<forall> y \<in> f ` A. Q y"
(*<*)oops(*>*)

lemma "\<forall> x \<in> A. Q (f x) \<Longrightarrow>  \<forall> y \<in> f ` A. Q y"
  by auto

(*<*) end (*>*)


(*  Title:      HOL/Hahn_Banach/Subspace.thy
    Author:     Gertrud Bauer, TU Munich
*)

section \<open>Subspaces\<close>

theory Subspace
imports Vector_Space "~~/src/HOL/Library/Set_Algebras"
begin

subsection \<open>Definition\<close>

text \<open>
  A non-empty subset \<open>U\<close> of a vector space \<open>V\<close> is a \<^emph>\<open>subspace\<close> of \<open>V\<close>, iff
  \<open>U\<close> is closed under addition and scalar multiplication.
\<close>

locale subspace =
  fixes U :: "'a::{minus, plus, zero, uminus} set" and V
  assumes non_empty [iff, intro]: "U \<noteq> {}"
    and subset [iff]: "U \<subseteq> V"
    and add_closed [iff]: "x \<in> U \<Longrightarrow> y \<in> U \<Longrightarrow> x + y \<in> U"
    and mult_closed [iff]: "x \<in> U \<Longrightarrow> a \<cdot> x \<in> U"

notation (symbols)
  subspace  (infix "\<unlhd>" 50)

declare vectorspace.intro [intro?] subspace.intro [intro?]

lemma subspace_subset [elim]: "U \<unlhd> V \<Longrightarrow> U \<subseteq> V"
  by (rule subspace.subset)

lemma (in subspace) subsetD [iff]: "x \<in> U \<Longrightarrow> x \<in> V"
  using subset by blast

lemma subspaceD [elim]: "U \<unlhd> V \<Longrightarrow> x \<in> U \<Longrightarrow> x \<in> V"
  by (rule subspace.subsetD)

lemma rev_subspaceD [elim?]: "x \<in> U \<Longrightarrow> U \<unlhd> V \<Longrightarrow> x \<in> V"
  by (rule subspace.subsetD)

lemma (in subspace) diff_closed [iff]:
  assumes "vectorspace V"
  assumes x: "x \<in> U" and y: "y \<in> U"
  shows "x - y \<in> U"
proof -
  interpret vectorspace V by fact
  from x y show ?thesis by (simp add: diff_eq1 negate_eq1)
qed

text \<open>
  \<^medskip>
  Similar as for linear spaces, the existence of the zero element in every
  subspace follows from the non-emptiness of the carrier set and by vector
  space laws.
\<close>

lemma (in subspace) zero [intro]:
  assumes "vectorspace V"
  shows "0 \<in> U"
proof -
  interpret V: vectorspace V by fact
  have "U \<noteq> {}" by (rule non_empty)
  then obtain x where x: "x \<in> U" by blast
  then have "x \<in> V" .. then have "0 = x - x" by simp
  also from \<open>vectorspace V\<close> x x have "\<dots> \<in> U" by (rule diff_closed)
  finally show ?thesis .
qed

lemma (in subspace) neg_closed [iff]:
  assumes "vectorspace V"
  assumes x: "x \<in> U"
  shows "- x \<in> U"
proof -
  interpret vectorspace V by fact
  from x show ?thesis by (simp add: negate_eq1)
qed

text \<open>\<^medskip> Further derived laws: every subspace is a vector space.\<close>

lemma (in subspace) vectorspace [iff]:
  assumes "vectorspace V"
  shows "vectorspace U"
proof -
  interpret vectorspace V by fact
  show ?thesis
  proof
    show "U \<noteq> {}" ..
    fix x y z assume x: "x \<in> U" and y: "y \<in> U" and z: "z \<in> U"
    fix a b :: real
    from x y show "x + y \<in> U" by simp
    from x show "a \<cdot> x \<in> U" by simp
    from x y z show "(x + y) + z = x + (y + z)" by (simp add: add_ac)
    from x y show "x + y = y + x" by (simp add: add_ac)
    from x show "x - x = 0" by simp
    from x show "0 + x = x" by simp
    from x y show "a \<cdot> (x + y) = a \<cdot> x + a \<cdot> y" by (simp add: distrib)
    from x show "(a + b) \<cdot> x = a \<cdot> x + b \<cdot> x" by (simp add: distrib)
    from x show "(a * b) \<cdot> x = a \<cdot> b \<cdot> x" by (simp add: mult_assoc)
    from x show "1 \<cdot> x = x" by simp
    from x show "- x = - 1 \<cdot> x" by (simp add: negate_eq1)
    from x y show "x - y = x + - y" by (simp add: diff_eq1)
  qed
qed

text \<open>The subspace relation is reflexive.\<close>

lemma (in vectorspace) subspace_refl [intro]: "V \<unlhd> V"
proof
  show "V \<noteq> {}" ..
  show "V \<subseteq> V" ..
next
  fix x y assume x: "x \<in> V" and y: "y \<in> V"
  fix a :: real
  from x y show "x + y \<in> V" by simp
  from x show "a \<cdot> x \<in> V" by simp
qed

text \<open>The subspace relation is transitive.\<close>

lemma (in vectorspace) subspace_trans [trans]:
  "U \<unlhd> V \<Longrightarrow> V \<unlhd> W \<Longrightarrow> U \<unlhd> W"
proof
  assume uv: "U \<unlhd> V" and vw: "V \<unlhd> W"
  from uv show "U \<noteq> {}" by (rule subspace.non_empty)
  show "U \<subseteq> W"
  proof -
    from uv have "U \<subseteq> V" by (rule subspace.subset)
    also from vw have "V \<subseteq> W" by (rule subspace.subset)
    finally show ?thesis .
  qed
  fix x y assume x: "x \<in> U" and y: "y \<in> U"
  from uv and x y show "x + y \<in> U" by (rule subspace.add_closed)
  from uv and x show "a \<cdot> x \<in> U" for a by (rule subspace.mult_closed)
qed

subsection \<open>Linear closure\<close>

text \<open>
  The \<^emph>\<open>linear closure\<close> of a vector \<open>x\<close> is the set of all scalar multiples of
  \<open>x\<close>.
\<close>

definition lin :: "('a::{minus,plus,zero}) \<Rightarrow> 'a set"
  where "lin x = {a \<cdot> x | a. True}"

lemma linI [intro]: "y = a \<cdot> x \<Longrightarrow> y \<in> lin x"
  unfolding lin_def by blast

lemma linI' [iff]: "a \<cdot> x \<in> lin x"
  unfolding lin_def by blast

lemma linE [elim]:
  assumes "x \<in> lin v"
  obtains a :: real where "x = a \<cdot> v"
  using assms unfolding lin_def by blast

text \<open>Every vector is contained in its linear closure.\<close>

lemma (in vectorspace) x_lin_x [iff]: "x \<in> V \<Longrightarrow> x \<in> lin x"
proof -
  assume "x \<in> V"
  then have "x = 1 \<cdot> x" by simp
  also have "\<dots> \<in> lin x" ..
  finally show ?thesis .
qed

lemma (in vectorspace) "0_lin_x" [iff]: "x \<in> V \<Longrightarrow> 0 \<in> lin x"
proof
  assume "x \<in> V"
  then show "0 = 0 \<cdot> x" by simp
qed

text \<open>Any linear closure is a subspace.\<close>

lemma (in vectorspace) lin_subspace [intro]:
  assumes x: "x \<in> V"
  shows "lin x \<unlhd> V"
proof
  from x show "lin x \<noteq> {}" by auto
next
  show "lin x \<subseteq> V"
  proof
    fix x' assume "x' \<in> lin x"
    then obtain a where "x' = a \<cdot> x" ..
    with x show "x' \<in> V" by simp
  qed
next
  fix x' x'' assume x': "x' \<in> lin x" and x'': "x'' \<in> lin x"
  show "x' + x'' \<in> lin x"
  proof -
    from x' obtain a' where "x' = a' \<cdot> x" ..
    moreover from x'' obtain a'' where "x'' = a'' \<cdot> x" ..
    ultimately have "x' + x'' = (a' + a'') \<cdot> x"
      using x by (simp add: distrib)
    also have "\<dots> \<in> lin x" ..
    finally show ?thesis .
  qed
  fix a :: real
  show "a \<cdot> x' \<in> lin x"
  proof -
    from x' obtain a' where "x' = a' \<cdot> x" ..
    with x have "a \<cdot> x' = (a * a') \<cdot> x" by (simp add: mult_assoc)
    also have "\<dots> \<in> lin x" ..
    finally show ?thesis .
  qed
qed

text \<open>Any linear closure is a vector space.\<close>

lemma (in vectorspace) lin_vectorspace [intro]:
  assumes "x \<in> V"
  shows "vectorspace (lin x)"
proof -
  from \<open>x \<in> V\<close> have "subspace (lin x) V"
    by (rule lin_subspace)
  from this and vectorspace_axioms show ?thesis
    by (rule subspace.vectorspace)
qed

subsection \<open>Sum of two vectorspaces\<close>

text \<open>
  The \<^emph>\<open>sum\<close> of two vectorspaces \<open>U\<close> and \<open>V\<close> is the set of all sums of
  elements from \<open>U\<close> and \<open>V\<close>.
\<close>

lemma sum_def: "U + V = {u + v | u v. u \<in> U \<and> v \<in> V}"
  unfolding set_plus_def by auto

lemma sumE [elim]:
    "x \<in> U + V \<Longrightarrow> (\<And>u v. x = u + v \<Longrightarrow> u \<in> U \<Longrightarrow> v \<in> V \<Longrightarrow> C) \<Longrightarrow> C"
  unfolding sum_def by blast

lemma sumI [intro]:
    "u \<in> U \<Longrightarrow> v \<in> V \<Longrightarrow> x = u + v \<Longrightarrow> x \<in> U + V"
  unfolding sum_def by blast

lemma sumI' [intro]:
    "u \<in> U \<Longrightarrow> v \<in> V \<Longrightarrow> u + v \<in> U + V"
  unfolding sum_def by blast

text \<open>\<open>U\<close> is a subspace of \<open>U + V\<close>.\<close>

lemma subspace_sum1 [iff]:
  assumes "vectorspace U" "vectorspace V"
  shows "U \<unlhd> U + V"
proof -
  interpret vectorspace U by fact
  interpret vectorspace V by fact
  show ?thesis
  proof
    show "U \<noteq> {}" ..
    show "U \<subseteq> U + V"
    proof
      fix x assume x: "x \<in> U"
      moreover have "0 \<in> V" ..
      ultimately have "x + 0 \<in> U + V" ..
      with x show "x \<in> U + V" by simp
    qed
    fix x y assume x: "x \<in> U" and "y \<in> U"
    then show "x + y \<in> U" by simp
    from x show "a \<cdot> x \<in> U" for a by simp
  qed
qed

text \<open>The sum of two subspaces is again a subspace.\<close>

lemma sum_subspace [intro?]:
  assumes "subspace U E" "vectorspace E" "subspace V E"
  shows "U + V \<unlhd> E"
proof -
  interpret subspace U E by fact
  interpret vectorspace E by fact
  interpret subspace V E by fact
  show ?thesis
  proof
    have "0 \<in> U + V"
    proof
      show "0 \<in> U" using \<open>vectorspace E\<close> ..
      show "0 \<in> V" using \<open>vectorspace E\<close> ..
      show "(0::'a) = 0 + 0" by simp
    qed
    then show "U + V \<noteq> {}" by blast
    show "U + V \<subseteq> E"
    proof
      fix x assume "x \<in> U + V"
      then obtain u v where "x = u + v" and
        "u \<in> U" and "v \<in> V" ..
      then show "x \<in> E" by simp
    qed
  next
    fix x y assume x: "x \<in> U + V" and y: "y \<in> U + V"
    show "x + y \<in> U + V"
    proof -
      from x obtain ux vx where "x = ux + vx" and "ux \<in> U" and "vx \<in> V" ..
      moreover
      from y obtain uy vy where "y = uy + vy" and "uy \<in> U" and "vy \<in> V" ..
      ultimately
      have "ux + uy \<in> U"
        and "vx + vy \<in> V"
        and "x + y = (ux + uy) + (vx + vy)"
        using x y by (simp_all add: add_ac)
      then show ?thesis ..
    qed
    fix a show "a \<cdot> x \<in> U + V"
    proof -
      from x obtain u v where "x = u + v" and "u \<in> U" and "v \<in> V" ..
      then have "a \<cdot> u \<in> U" and "a \<cdot> v \<in> V"
        and "a \<cdot> x = (a \<cdot> u) + (a \<cdot> v)" by (simp_all add: distrib)
      then show ?thesis ..
    qed
  qed
qed

text \<open>The sum of two subspaces is a vectorspace.\<close>

lemma sum_vs [intro?]:
    "U \<unlhd> E \<Longrightarrow> V \<unlhd> E \<Longrightarrow> vectorspace E \<Longrightarrow> vectorspace (U + V)"
  by (rule subspace.vectorspace) (rule sum_subspace)

subsection \<open>Direct sums\<close>

text \<open>
  The sum of \<open>U\<close> and \<open>V\<close> is called \<^emph>\<open>direct\<close>, iff the zero element is the only
  common element of \<open>U\<close> and \<open>V\<close>. For every element \<open>x\<close> of the direct sum of
  \<open>U\<close> and \<open>V\<close> the decomposition in \<open>x = u + v\<close> with \<open>u \<in> U\<close> and \<open>v \<in> V\<close> is
  unique.
\<close>

lemma decomp:
  assumes "vectorspace E" "subspace U E" "subspace V E"
  assumes direct: "U \<inter> V = {0}"
    and u1: "u1 \<in> U" and u2: "u2 \<in> U"
    and v1: "v1 \<in> V" and v2: "v2 \<in> V"
    and sum: "u1 + v1 = u2 + v2"
  shows "u1 = u2 \<and> v1 = v2"
proof -
  interpret vectorspace E by fact
  interpret subspace U E by fact
  interpret subspace V E by fact
  show ?thesis
  proof
    have U: "vectorspace U"  (* FIXME: use interpret *)
      using \<open>subspace U E\<close> \<open>vectorspace E\<close> by (rule subspace.vectorspace)
    have V: "vectorspace V"
      using \<open>subspace V E\<close> \<open>vectorspace E\<close> by (rule subspace.vectorspace)
    from u1 u2 v1 v2 and sum have eq: "u1 - u2 = v2 - v1"
      by (simp add: add_diff_swap)
    from u1 u2 have u: "u1 - u2 \<in> U"
      by (rule vectorspace.diff_closed [OF U])
    with eq have v': "v2 - v1 \<in> U" by (simp only:)
    from v2 v1 have v: "v2 - v1 \<in> V"
      by (rule vectorspace.diff_closed [OF V])
    with eq have u': " u1 - u2 \<in> V" by (simp only:)

    show "u1 = u2"
    proof (rule add_minus_eq)
      from u1 show "u1 \<in> E" ..
      from u2 show "u2 \<in> E" ..
      from u u' and direct show "u1 - u2 = 0" by blast
    qed
    show "v1 = v2"
    proof (rule add_minus_eq [symmetric])
      from v1 show "v1 \<in> E" ..
      from v2 show "v2 \<in> E" ..
      from v v' and direct show "v2 - v1 = 0" by blast
    qed
  qed
qed

text \<open>
  An application of the previous lemma will be used in the proof of the
  Hahn-Banach Theorem (see page \pageref{decomp-H-use}): for any element
  \<open>y + a \<cdot> x\<^sub>0\<close> of the direct sum of a vectorspace \<open>H\<close> and the linear closure
  of \<open>x\<^sub>0\<close> the components \<open>y \<in> H\<close> and \<open>a\<close> are uniquely determined.
\<close>

lemma decomp_H':
  assumes "vectorspace E" "subspace H E"
  assumes y1: "y1 \<in> H" and y2: "y2 \<in> H"
    and x': "x' \<notin> H"  "x' \<in> E"  "x' \<noteq> 0"
    and eq: "y1 + a1 \<cdot> x' = y2 + a2 \<cdot> x'"
  shows "y1 = y2 \<and> a1 = a2"
proof -
  interpret vectorspace E by fact
  interpret subspace H E by fact
  show ?thesis
  proof
    have c: "y1 = y2 \<and> a1 \<cdot> x' = a2 \<cdot> x'"
    proof (rule decomp)
      show "a1 \<cdot> x' \<in> lin x'" ..
      show "a2 \<cdot> x' \<in> lin x'" ..
      show "H \<inter> lin x' = {0}"
      proof
        show "H \<inter> lin x' \<subseteq> {0}"
        proof
          fix x assume x: "x \<in> H \<inter> lin x'"
          then obtain a where xx': "x = a \<cdot> x'"
            by blast
          have "x = 0"
          proof cases
            assume "a = 0"
            with xx' and x' show ?thesis by simp
          next
            assume a: "a \<noteq> 0"
            from x have "x \<in> H" ..
            with xx' have "inverse a \<cdot> a \<cdot> x' \<in> H" by simp
            with a and x' have "x' \<in> H" by (simp add: mult_assoc2)
            with \<open>x' \<notin> H\<close> show ?thesis by contradiction
          qed
          then show "x \<in> {0}" ..
        qed
        show "{0} \<subseteq> H \<inter> lin x'"
        proof -
          have "0 \<in> H" using \<open>vectorspace E\<close> ..
          moreover have "0 \<in> lin x'" using \<open>x' \<in> E\<close> ..
          ultimately show ?thesis by blast
        qed
      qed
      show "lin x' \<unlhd> E" using \<open>x' \<in> E\<close> ..
    qed (rule \<open>vectorspace E\<close>, rule \<open>subspace H E\<close>, rule y1, rule y2, rule eq)
    then show "y1 = y2" ..
    from c have "a1 \<cdot> x' = a2 \<cdot> x'" ..
    with x' show "a1 = a2" by (simp add: mult_right_cancel)
  qed
qed

text \<open>
  Since for any element \<open>y + a \<cdot> x'\<close> of the direct sum of a vectorspace \<open>H\<close>
  and the linear closure of \<open>x'\<close> the components \<open>y \<in> H\<close> and \<open>a\<close> are unique, it
  follows from \<open>y \<in> H\<close> that \<open>a = 0\<close>.
\<close>

lemma decomp_H'_H:
  assumes "vectorspace E" "subspace H E"
  assumes t: "t \<in> H"
    and x': "x' \<notin> H"  "x' \<in> E"  "x' \<noteq> 0"
  shows "(SOME (y, a). t = y + a \<cdot> x' \<and> y \<in> H) = (t, 0)"
proof -
  interpret vectorspace E by fact
  interpret subspace H E by fact
  show ?thesis
  proof (rule, simp_all only: split_paired_all split_conv)
    from t x' show "t = t + 0 \<cdot> x' \<and> t \<in> H" by simp
    fix y and a assume ya: "t = y + a \<cdot> x' \<and> y \<in> H"
    have "y = t \<and> a = 0"
    proof (rule decomp_H')
      from ya x' show "y + a \<cdot> x' = t + 0 \<cdot> x'" by simp
      from ya show "y \<in> H" ..
    qed (rule \<open>vectorspace E\<close>, rule \<open>subspace H E\<close>, rule t, (rule x')+)
    with t x' show "(y, a) = (y + a \<cdot> x', 0)" by simp
  qed
qed

text \<open>
  The components \<open>y \<in> H\<close> and \<open>a\<close> in \<open>y + a \<cdot> x'\<close> are unique, so the function
  \<open>h'\<close> defined by \<open>h' (y + a \<cdot> x') = h y + a \<cdot> \<xi>\<close> is definite.
\<close>

lemma h'_definite:
  fixes H
  assumes h'_def:
    "\<And>x. h' x =
      (let (y, a) = SOME (y, a). (x = y + a \<cdot> x' \<and> y \<in> H)
       in (h y) + a * xi)"
    and x: "x = y + a \<cdot> x'"
  assumes "vectorspace E" "subspace H E"
  assumes y: "y \<in> H"
    and x': "x' \<notin> H"  "x' \<in> E"  "x' \<noteq> 0"
  shows "h' x = h y + a * xi"
proof -
  interpret vectorspace E by fact
  interpret subspace H E by fact
  from x y x' have "x \<in> H + lin x'" by auto
  have "\<exists>!(y, a). x = y + a \<cdot> x' \<and> y \<in> H" (is "\<exists>!p. ?P p")
  proof (rule ex_ex1I)
    from x y show "\<exists>p. ?P p" by blast
    fix p q assume p: "?P p" and q: "?P q"
    show "p = q"
    proof -
      from p have xp: "x = fst p + snd p \<cdot> x' \<and> fst p \<in> H"
        by (cases p) simp
      from q have xq: "x = fst q + snd q \<cdot> x' \<and> fst q \<in> H"
        by (cases q) simp
      have "fst p = fst q \<and> snd p = snd q"
      proof (rule decomp_H')
        from xp show "fst p \<in> H" ..
        from xq show "fst q \<in> H" ..
        from xp and xq show "fst p + snd p \<cdot> x' = fst q + snd q \<cdot> x'"
          by simp
      qed (rule \<open>vectorspace E\<close>, rule \<open>subspace H E\<close>, (rule x')+)
      then show ?thesis by (cases p, cases q) simp
    qed
  qed
  then have eq: "(SOME (y, a). x = y + a \<cdot> x' \<and> y \<in> H) = (y, a)"
    by (rule some1_equality) (simp add: x y)
  with h'_def show "h' x = h y + a * xi" by (simp add: Let_def)
qed

end