section\<open>Showing equivalence of links: An example\<close>

theory Example
imports Link_Algebra
begin

text\<open>We prove that a link diagram with a single crossing is equivalent to the
unknot\<close>

lemma prelim_cup_compress:
 " ((basic (cup#[])) \<circ> (basic (vert # vert # []))) ~
      ((basic [])\<circ>(basic (cup#[])))"
proof-
 have "domain_wall (basic (cup # [])) = 0"
       by auto
 moreover have "codomain_wall (basic (cup # [])) = 2"
       by auto
 moreover
     have "make_vert_block (nat (codomain_wall (basic (cup # []))))
                                    = (vert # vert # [])"
       unfolding make_vert_block_def
       by auto
 moreover have "is_tangle_diagram   ((basic (cup#[])) \<circ> (basic (vert # vert # [])))"
      using is_tangle_diagram.simps by auto
 ultimately
  have "compress_bottom
          ((basic (cup#[])) \<circ> (basic (vert # vert # [])))
          ((basic []) \<circ>(basic (cup#[])))"
      using compress_bottom_def by (metis is_tangle_diagram.simps(1))
 then have "compress  ((basic (cup#[])) \<circ> (basic (vert # vert # [])))
      ((basic [])\<circ>(basic (cup#[])))"
      using compress_def by auto
 then have "linkrel ((basic (cup#[])) \<circ> (basic (vert # vert # [])))
      ((basic [])\<circ>(basic (cup#[])))"
      unfolding linkrel_def by auto
 then show ?thesis
     using Tangle_Equivalence.equality compress_bottom_def
           Tangle_Moves.compress_bottom_def Tangle_Moves.compress_def
           Tangle_Moves.linkrel_def
     by auto
 qed

lemma cup_compress:
 "(basic (cup#[])) \<circ> (basic (vert # vert # [])) ~ (basic (cup#[]))"
 proof-
 have " ((basic (cup#[])) \<circ> (basic (vert # vert # []))) ~
      ((basic [])\<circ>(basic (cup#[])))"
         using prelim_cup_compress  by auto
 moreover have "((basic [])\<circ>(basic (cup#[]))) ~  (basic (cup#[]))"
         using domain_compose refl sym Tangle_Equivalence.domain_compose
         Tangle_Equivalence.sym domain.simps(2) domain_block.simps
         domain_wall.simps(1)
         is_tangle_diagram.simps(1) monoid_add_class.add.right_neutral
         by auto
 ultimately show ?thesis using trans by (metis Example.transitive)
 qed

abbreviation x::"wall"
where
"x \<equiv>   (basic [cup,cup])\<circ>(basic [vert,over,vert]) \<circ> (basic [cap,cap])"

abbreviation y::"wall"
where
"y \<equiv>    (basic [cup]) \<circ> (basic [cap])"

lemma uncross_straighten_left_over:"left_over ~ straight_line"
proof-
 have "uncross right_over left_over"
        using uncross_positive_flip_def uncross_def by auto
 then have "linkrel right_over left_over"
    using linkrel_def by auto
 then have "right_over ~ left_over"
    using Tangle_Equivalence.equality by auto
 then have 1:"left_over ~ right_over"
    using Tangle_Equivalence.sym by auto
  have "uncross right_over straight_line"
        using uncross_positive_straighten_def uncross_def by auto
 then have "linkrel right_over straight_line"
    using linkrel_def by auto
 then have 2:"right_over ~ straight_line"
    using Tangle_Equivalence.equality by auto
  have "(left_over ~  straight_line) \<and> (right_over ~ straight_line)
         \<Longrightarrow> ?thesis"
            using transitive by auto
 then show ?thesis using 1 2 transitive  by blast
 qed

theorem Example:
  "x ~ y"
proof-
 have 1:"left_over ~ straight_line"
    using Tangle_Equivalence.equality uncross_straighten_left_over by auto
 moreover have 2:"straight_line ~ straight_line"
   using refl by auto
 have 3:"(left_over \<otimes> straight_line) ~ (straight_line \<otimes> straight_line)"
 proof-
  have "is_tangle_diagram (left_over)"
    unfolding is_tangle_diagram_def by auto
  moreover have "is_tangle_diagram (straight_line)"
    unfolding is_tangle_diagram_def by auto
  ultimately show ?thesis using 1 2 by (metis Tangle_Equivalence.tensor_eq)
 qed
 then have 4:
  "((basic (cup#[])) \<circ> (left_over \<otimes> straight_line))
           ~   ((basic (cup#[])) \<circ> (straight_line \<otimes> straight_line))"
 proof-
  have "is_tangle_diagram (left_over \<otimes> straight_line)"
        by auto
  moreover have "is_tangle_diagram (straight_line \<otimes> straight_line)"
        by auto
  moreover have "is_tangle_diagram (basic (cup#[]))"
         by auto
  moreover have "domain_wall (left_over \<otimes> straight_line) = (codomain_wall (basic (cup#[])))"
        unfolding domain_wall_def by auto
  moreover have "domain_wall (straight_line \<otimes> straight_line) = (codomain_wall (basic (cup#[])))"
        unfolding domain_wall_def by auto
  moreover have "(basic (cup#[])) ~ (basic (cup#[]))"
        using refl by auto
  ultimately show ?thesis
        using compose_eq 3  by (metis Tangle_Equivalence.compose_eq)
 qed
 moreover have 5:"  (basic [cup])\<circ> (straight_line \<otimes> straight_line)
                 ~ (basic [cup])"
 proof-
  have 0:
   "(basic ([cup])) \<circ> (straight_line \<otimes> straight_line) = (basic [cup]) \<circ>(basic [vert,vert])
                                                         \<circ> (basic [vert,vert])\<circ>(basic [vert,vert])"
           by auto
  let ?x ="(basic (cup#[]))
   \<circ>(basic (vert#vert#[])) \<circ> (basic (vert#vert#[]))
   \<circ> (basic (vert#vert#[]))"
  let ?x1 = " (basic (vert#vert#[]))\<circ> (basic (vert#vert#[]))"
  have 1:"?x ~ ((basic (cup#[])) \<circ> ?x1)"
  proof-
   have "(basic (cup#[]))\<circ>(basic (vert # vert # [])) ~ (basic (cup#[]))"
        using cup_compress by auto
   moreover have "is_tangle_diagram  (basic (cup#[]))"
        using is_tangle_diagram_def by auto
   moreover have "is_tangle_diagram ((basic (cup#[]))\<circ>(basic (vert # vert # [])))"
        using is_tangle_diagram_def by auto
   moreover have "is_tangle_diagram (?x1)"
        by auto
   moreover have "?x1 ~ ?x1"
        using refl by auto
   moreover have
     "codomain_wall (basic (cup#[])) = domain_wall  (basic (vert#vert#[]))"
        by auto
   moreover have "(basic (cup#[])) ~ (basic (cup#[]))"
         using refl by auto
   ultimately show ?thesis
         using compose_eq codomain_wall_compose compose_leftassociativity
               converse_composition_of_tangle_diagrams domain_wall_compose
         by (metis Tangle_Equivalence.compose_eq is_tangle_diagram.simps(1))
  qed
  have 2: " ((basic (cup#[])) \<circ> ?x1) ~ (basic (cup#[]))"
  proof-
   have "
     ((basic (cup # []))\<circ>(basic (vert # vert # [])))\<circ>(basic (vert # vert # []))
          ~ ((basic(cup#[]))\<circ>(basic(vert#vert#[])))"
   proof-
    have "(basic (cup#[]))\<circ>(basic (vert # vert # [])) ~ (basic (cup#[]))"
         using cup_compress by auto
    moreover have "(basic(vert#vert#[])) ~ (basic(vert#vert#[]))"
         using refl by auto
    moreover have "is_tangle_diagram  (basic (cup#[]))"
         using is_tangle_diagram_def by auto
    moreover have "is_tangle_diagram ((basic (cup#[]))\<circ>(basic (vert # vert # [])))"
         using is_tangle_diagram_def by auto
    moreover have "is_tangle_diagram ((basic(vert#vert#[])))"
         by auto
    moreover have
         "codomain_wall ((basic (cup#[]))\<circ>  (basic(vert#vert#[])))
                       = domain_wall  (basic(vert#vert#[]))  "
         by auto
    moreover
         have "codomain_wall (basic (cup#[])) = domain_wall (basic(vert#vert#[]))"
         by auto
    ultimately show ?thesis
                 using compose_eq
                 by (metis Tangle_Equivalence.compose_eq)
   qed
   then have "((basic (cup#[])) \<circ> ?x1) ~
           ((basic(cup#[]))\<circ>(basic(vert#vert#[])))"
         by auto
   then show ?thesis using cup_compress trans
         by (metis (full_types) Example.transitive)
  qed
  from 0 1 2 show ?thesis using trans transp_def trans compose_Nil
          by (metis (hide_lams, no_types) Example.transitive)
 qed
 let ?y = "((basic ([])) \<circ> (basic (cup#[])))  "
 let ?temp = "(basic (vert#over#vert#[]))\<circ>(basic (cap#vert#vert#[])) "
 have 45:"(left_over \<otimes> straight_line) =
          ((basic (cup#vert#vert#[])) \<circ> ?temp)"
          using tensor.simps by (metis compose_Nil concatenates_Cons concatenates_Nil)
 then have 55:"(basic (cup#[])) \<circ> (left_over \<otimes> straight_line)
             =  (basic (cup#[])) \<circ>  (basic (cup#vert#vert#[])) \<circ> ?temp"
          by auto
 then have
  "(basic (cup#[])) \<circ> (basic (cup#vert#vert#[]))
      =  (basic (([]) \<otimes>(cup#[])))\<circ>(basic ((cup#[])\<otimes>(vert#vert#[])))"
          using concatenate.simps  by auto
 then have 6:
 "(basic (cup#[])) \<circ> (basic (cup#vert#vert#[]))
          = ((basic ([]))\<circ>(basic (cup#[])))
            \<otimes>((basic (cup#[])) \<circ>(basic (vert#vert#[])))"
          using tensor.simps by auto
 then have "((basic (cup#[])) \<circ>(basic (vert#vert#[])))
                   ~ (basic ([]))\<circ>(basic (cup#[]))"
          using prelim_cup_compress by auto
 moreover have "((basic ([]))\<circ>(basic (cup#[])))
                       ~ ((basic ([]))\<circ>(basic (cup#[])))"
          using refl by auto
 moreover have "is_tangle_diagram ((basic (cup#[])) \<circ>(basic (vert#vert#[])))"
          by auto
 moreover have "is_tangle_diagram ((basic ([]))\<circ>(basic (cup#[]))) "
          by auto
 ultimately have 7:"?y \<otimes> ((basic (cup#[])) \<circ>(basic (vert#vert#[])))~ ((?y) \<otimes> (?y))"
          using tensor_eq cup_compress Nil_right_tensor is_tangle_diagram.simps(1) refl
          by (metis Tangle_Equivalence.tensor_eq)
 then have " ((?y) \<otimes> (?y)) = (basic (([]) \<otimes> ([])))
                   \<circ> ((basic (cup#[])) \<otimes> (basic (cup#[])))"
          using tensor.simps(4)  by (metis compose_Nil)
 then have "  ((?y) \<otimes> (?y)) = (basic ([])) \<circ>((basic (cup#cup#[])))"
          using tensor.simps(1) concatenate_def by auto
 then have "(?y) \<otimes> ((basic (cup#[])) \<circ>(basic (vert#vert#[])))
             ~ (basic ([])) \<circ>(basic (cup#cup#[]))"
          using 7 by auto
 moreover have "(basic ([]))\<circ>(basic (cup#cup#[]))~(basic (cup#cup#[]))"
 proof-
  have "domain_wall (basic (cup#cup#[])) = 0"
          by auto
  then show ?thesis using domain_compose sym
          by (metis Tangle_Equivalence.domain_compose Tangle_Equivalence.sym is_tangle_diagram.simps(1))
 qed
 ultimately have "(?y) \<otimes> ((basic (cup#[])) \<circ>(basic (vert#vert#[])))
               ~  (basic (cup#cup#[]))"
          using trans  by (metis (full_types) Example.transitive)
 then have " (basic(cup#[]))\<circ>(basic(cup#vert#vert#[]))~(basic(cup#cup#[]))"
          by auto
 moreover have "?temp ~ ?temp"
          using refl by auto
 moreover  have "is_tangle_diagram ((basic(cup#[]))\<circ>(basic(cup#vert#vert#[])))"
          by auto
 moreover have "is_tangle_diagram (basic(cup#cup#[]))"
          by auto
 moreover have "is_tangle_diagram  (?temp)"
          by auto
 moreover have "codomain_wall  ((basic(cup#[]))\<circ>(basic(cup#vert#vert#[])))
                    = domain_wall ?temp"
          by auto
 moreover have "codomain_wall (basic(cup#cup#[])) = domain_wall ?temp"
          by auto
 ultimately have 8:" ((basic(cup#[]))\<circ>(basic(cup#vert#vert#[]))) \<circ>(?temp)
                       ~ (basic(cup#cup#[])) \<circ> (?temp)"
          using compose_eq by (metis Tangle_Equivalence.compose_eq)
 then have "((basic [cup,cup]) \<circ> (?temp))
                 ~ (basic [cup] \<circ> (left_over \<otimes> straight_line))"
          using 55 compose_leftassociativity sym wall.simps
          by (metis Tangle_Equivalence.sym compose_Nil)
 moreover have "(basic [cup]) \<circ> (left_over \<otimes> straight_line)
                    ~ (basic [cup]) \<circ> (straight_line \<otimes> straight_line)"
          using 4 by auto
 ultimately have "((basic [cup,cup]) \<circ> (?temp))
                  ~ (basic [cup]) \<circ> (straight_line \<otimes> straight_line)"
  proof-
   have "((basic [cup,cup]) \<circ> (?temp))
                 ~ (basic [cup] \<circ> (left_over \<otimes> straight_line))"
          using 8 55 compose_leftassociativity sym wall.simps  Tangle_Equivalence.sym compose_Nil
          by (metis)
   moreover have "(basic [cup]) \<circ> (left_over \<otimes> straight_line)
                    ~ (basic [cup]) \<circ> (straight_line \<otimes> straight_line)"
          using 4 by auto
   moreover have "(((basic [cup,cup]) \<circ> (?temp))
                 ~ (basic [cup] \<circ> (left_over \<otimes> straight_line)))
        \<and> ((basic [cup]) \<circ> (left_over \<otimes> straight_line)
                    ~ (basic [cup]) \<circ> (straight_line \<otimes> straight_line))
           \<Longrightarrow> ?thesis"
          using Example.transitive by auto
   ultimately show ?thesis by auto
  qed
  then have "(basic ([cup,cup])) \<circ> (?temp)  ~ (basic (cup # []))"
         using trans transp_def 5 by (metis Example.transitive)
  moreover have "(basic (cap#[])) ~ (basic (cap#[]))"
         using refl by auto
  moreover have "is_tangle_diagram ((basic(cup#cup#[])) \<circ> (?temp))"
         by auto
  moreover have "is_tangle_diagram (basic (cup # []))"
         by auto
  moreover have "is_tangle_diagram (basic (cap # []))"
         by auto
  moreover have "codomain_wall ((basic(cup#cup#[])) \<circ> (?temp))
                   = domain_wall (basic (cap # []))"
         by auto
  moreover have "codomain_wall (basic(cup#[])) = domain_wall (basic (cap # []))"
         by auto
 ultimately have 9:"((basic(cup#cup#[])) \<circ> (?temp)) \<circ> (basic (cap#[]))
                     ~ (basic (cup#[])) \<circ> (basic (cap#[]))"
         using Tangle_Equivalence.compose_eq by metis
  let ?z = "((basic(cup#cup#[])) \<circ> (basic(vert#over#vert#[])))"
  have 10:"((basic(cup#cup#[])) \<circ> (?temp)) \<circ> (basic (cap#[]))
              = ?z \<circ> ((basic(cap#vert#vert#[])) \<circ> (basic (cap#[])))"
         by auto
  then have 11:"((basic(cap#vert#vert#[])) \<circ> (basic (cap#[])))
                           = ((basic ((cap#[])\<otimes>(vert#vert#[])))\<circ>(basic (([]) \<otimes>(cap#[]))))"
          unfolding concatenate_def by auto
  then have 12:" ((basic(cap#vert#vert#[])) \<circ> (basic (cap#[])))
                       = ((basic (cap#[]))\<circ>(basic ([])))\<otimes>((basic (vert#vert#[]))\<circ>(basic (cap#[])))"
          using tensor.simps by auto
  let ?w = "((basic (cap#[]))\<circ>(basic ([])))"
  have 13:"((basic (vert#vert#[]))\<circ>(basic (cap#[]))) ~ ?w"
  proof-
   have "codomain_wall (basic (cap#[])) = 0"
        by auto
   then have "domain_wall (basic (cap#[])) = 2" by auto
   then have "(vert#vert#[])
                          = make_vert_block (nat (domain_wall (basic (cap#[]))))"
     by (simp add: make_vert_block_def)
   then have "compress_top  ((basic (vert#vert#[]))\<circ>(basic (cap#[]))) ?w"
        using compress_top_def by auto
   then have "compress ((basic (vert#vert#[]))\<circ>(basic (cap#[]))) ?w"
        using compress_def by auto
   then have "linkrel  ((basic (vert#vert#[]))\<circ>(basic (cap#[]))) ?w"
        using linkrel_def by auto
   then have " ((basic (vert#vert#[]))\<circ>(basic (cap#[]))) ~ ?w"
        using Tangle_Equivalence.equality by auto
   then show ?thesis by simp
  qed
  moreover have "is_tangle_diagram ((basic (vert#vert#[]))\<circ>(basic (cap#[])))"
        by auto
  moreover have "is_tangle_diagram ?w"
        by auto
  moreover have "?w ~ ?w"
        using refl by auto
  ultimately have 14:"(?w) \<otimes> ((basic (vert#vert#[]))\<circ>(basic (cap#[]))) ~ ((?w)\<otimes> (?w))"
        using Tangle_Equivalence.tensor_eq by metis
  then have "((basic(cap#vert#vert#[])) \<circ> (basic (cap#[]))) ~ ((?w)\<otimes> (?w))"
        using 13 by auto
  moreover have " ((?w)\<otimes> (?w)) = (basic (cap#cap#[])) \<circ> (basic ([]))"
        using tensor.simps by auto
  ultimately have "((basic(cap#vert#vert#[]))\<circ>(basic (cap#[])))~ (basic (cap#cap#[]))\<circ>(basic ([]))"
        by auto
  moreover have "?z ~ ?z"
        using refl by auto
  moreover have "domain_wall ((basic(cap#cap#[])) \<circ> (basic ([])))
                                = codomain_wall (?z)"
        by auto
  moreover have "domain_wall (((basic(cap#vert#vert#[])) \<circ> (basic (cap#[]))))
                                = codomain_wall (?z)"
        by auto
  moreover have "is_tangle_diagram ((basic(cap#vert#vert#[])) \<circ> (basic (cap#[])))"
        by auto
  moreover have "is_tangle_diagram (?z)"
        by auto
  moreover have "is_tangle_diagram  ((basic(cap#cap#[])) \<circ> (basic ([])))"
        by auto
  ultimately have 14:" (?z) \<circ>  ((basic(cap#vert#vert#[])) \<circ> (basic (cap#[])))
                      ~ (?z) \<circ> ((basic(cap#cap#[])) \<circ> (basic ([])))" (is "?aa ~ ?bb")
        using Tangle_Equivalence.compose_eq by metis
  moreover  have 15: "((?z) \<circ> ((basic(cap#cap#[]))) \<circ> (basic ([])))
                ~ ((?z) \<circ> (basic(cap#cap#[])))" (is "?bb ~ ?cc")
        using Tangle_Equivalence.codomain_compose  Tangle_Equivalence.sym
               \<open>is_tangle_diagram (basic [cap, cap] \<circ> basic [])\<close> codomain_wall_compose
               compose_leftassociativity converse_composition_of_tangle_diagrams
               domain_block.simps(1) domain_wall.simps(1)
        by (metis (hide_lams, mono_tags) Tangle_Equivalence.compose_eq
                Tangle_Equivalence.refl
                \<open>codomain_wall (basic [cup, cup])
                         = domain_wall (basic [vert, over, vert] \<circ> basic [cap, vert, vert])\<close>
                   \<open>domain_wall (basic [cap, cap] \<circ> basic [])
          = codomain_wall (basic [cup, cup] \<circ> basic [vert, over, vert])\<close>
                          comp_of_tangle_dgms domain_wall_compose is_tangle_diagram.simps(1))
  ultimately have "(?aa ~ ?bb)\<and> (?bb ~ ?cc) \<Longrightarrow>?aa ~ ?cc"
        using transitive by auto
  then have 16:"?aa ~ ?cc"
        using 14 15 by auto
  then have 17:" ((basic (cup#[]))\<circ>(basic (cap#[])))~ ?aa"
        using 9 10 Tangle_Equivalence.trans  Tangle_Equivalence.sym
        by (metis (hide_lams, no_types))
  have "(((basic (cup#[]))\<circ>(basic (cap#[])))~ ?aa)\<and>(?aa ~ ?cc)
            \<Longrightarrow> ((basic (cup#[]))\<circ>(basic (cap#[])))~ ?cc"
        using transitive by auto
  then have "((basic (cup#[]))\<circ>(basic (cap#[])))~ ?cc"
            using 17 16 by auto
  then show ?thesis using Tangle_Equivalence.sym by auto
qed

end


theory List_Demo
imports Main
begin

datatype 'a list = Nil | Cons "'a" "'a list"

datatype 'a ll = Nil | Cons "'a * 'a" "'a ll"

datatype 'a tree = Leaf | Node "'a tree" 'a "'a tree"

term "Nil"

declare [[names_short]]

fun app :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"app Nil ys = ys" |
"app (Cons x xs) ys = Cons x (app xs ys)"

(* Associativity of append.
  Intuitively: It makes no difference if we first append xs and ys,
  and then append zs to the result, or if we first append ys and zs,
  and append the result to xs.
*)
lemma "app (app xs ys) zs = app xs (app ys zs)"
  apply (induction xs)
  apply auto
  done

(*
  Reverse a list ... we'll come here later!
*)
fun rev :: "'a list \<Rightarrow> 'a list" where
"rev Nil = Nil" |
"rev (Cons x xs) = app (rev xs) (Cons x Nil)"

value "rev(Cons True (Cons False Nil))"

value "rev(Cons a (Cons b Nil))"

theorem rev_rev: "rev (rev xs) = xs"
apply (induction xs)
apply (auto)
(* For now, we are stuck here: We'll later see how to complete the proof. *)
oops (* Oops cancels unsuccessful proof attempt. *)

end


theory CommOr
  imports Main
begin

text\<open> Apply style \<close>
lemma lem_w_1 : "(p \<or> q) \<longrightarrow> (q \<or> p)"
  apply (rule impI)
  apply (erule disjE)
   apply (rule disjI2)
   apply assumption
  apply (rule disjI1)
  apply assumption
  done

text\<open> Apply style proof, more verbose than the preceding proof \<close>
lemma lem_w_2 : "(p \<or> q) \<longrightarrow> (q \<or> p)"
  apply (rule impI)
  apply (rule disjE)
    apply assumption
   apply (rule disjI2)
   apply assumption
  apply (rule disjI1)
  apply assumption
  done

text\<open> Isar style \<close>
lemma lem_x_1 : "(p \<or> q) \<longrightarrow> (q \<or> p)"
proof
  assume A : "(p \<or> q)"
  from A show "(q \<or> p)"
  proof
    assume "p" thus "(q \<or> p)" by (rule disjI2)
    (* you can substitute '..' for 'by (rule disjI2)'*)
  next
    assume "q" thus "(q \<or> p)" by (rule disjI1)
    (* you can substitute '..' for 'by (rule disjI1)'*)
  qed
qed

end


section\<open>Lemmas about undirected graphs\<close>

theory Ugraph_Lemmas
imports
  Prob_Lemmas
  Girth_Chromatic.Girth_Chromatic
begin

text\<open>The complete graph is a graph where all possible edges are present. It is wellformed by
definition.\<close>

definition complete :: "nat set \<Rightarrow> ugraph" where
  "complete V = (V, all_edges V)"

lemma complete_wellformed: "uwellformed (complete V)"
  unfolding complete_def uwellformed_def all_edges_def
  by simp

text\<open>If the set of vertices is finite, the set of edges in the complete graph is finite.\<close>

lemma all_edges_finite: "finite V \<Longrightarrow> finite (all_edges V)"
  unfolding all_edges_def
  by simp

corollary complete_finite_edges: "finite V \<Longrightarrow> finite (uedges (complete V))"
  unfolding complete_def using all_edges_finite
  by simp

text\<open>The sets of possible edges of disjoint sets of vertices are disjoint.\<close>

lemma all_edges_disjoint: "S \<inter> T = {} \<Longrightarrow> all_edges S \<inter> all_edges T = {}"
  unfolding all_edges_def
  by force

text\<open>A graph is called `finite' if its set of edges and its set of vertices are finite.\<close>

definition "finite_graph G \<equiv> finite (uverts G) \<and> finite (uedges G)"

text\<open>The complete graph is finite.\<close>

corollary complete_finite: "finite V \<Longrightarrow> finite_graph (complete V)"
  using complete_finite_edges unfolding finite_graph_def complete_def
  by simp

text\<open>A graph is called `nonempty' if it contains at least one vertex and at least one edge.\<close>

definition "nonempty_graph G \<equiv> uverts G \<noteq> {} \<and> uedges G \<noteq> {}"

text\<open>A random graph is both wellformed and finite.\<close>

lemma (in edge_space) wellformed_and_finite:
  assumes "E \<in> Pow S_edges"
  shows "finite_graph (edge_ugraph E)" "uwellformed (edge_ugraph E)"
unfolding finite_graph_def
proof
  show "finite (uverts (edge_ugraph E))"
    unfolding edge_ugraph_def S_verts_def by simp
next
  show "finite (uedges (edge_ugraph E))"
    using assms unfolding edge_ugraph_def S_edges_def by (auto intro: all_edges_finite)
next
  show "uwellformed (edge_ugraph E)"
    using complete_wellformed unfolding edge_ugraph_def S_edges_def complete_def uwellformed_def by force
qed

text\<open>The probability for a random graph to have $e$ edges is $p ^ e$.\<close>

lemma (in edge_space) cylinder_empty_prob:
  "A \<subseteq> S_edges \<Longrightarrow> prob (cylinder S_edges A {}) = p ^ (card A)"
  using cylinder_prob by auto

subsection\<open>Subgraphs\<close>

definition subgraph :: "ugraph \<Rightarrow> ugraph \<Rightarrow> bool" where
  "subgraph G' G \<equiv> uverts G' \<subseteq> uverts G \<and> uedges G' \<subseteq> uedges G"

lemma subgraph_refl: "subgraph G G"
  unfolding subgraph_def
  by simp

lemma subgraph_trans: "subgraph G'' G' \<Longrightarrow> subgraph G' G \<Longrightarrow> subgraph G'' G"
  unfolding subgraph_def
  by auto

lemma subgraph_antisym: "subgraph G G' \<Longrightarrow> subgraph G' G \<Longrightarrow> G = G'"
  unfolding subgraph_def
  by (auto simp add: Product_Type.prod_eqI)

lemma subgraph_complete:
  assumes "uwellformed G"
  shows "subgraph G (complete (uverts G))"
proof -
  {
    fix e
    assume "e \<in> uedges G"
    with assms have "card e = 2" and u: "\<And>u. u \<in> e \<Longrightarrow> u \<in> uverts G"
      unfolding uwellformed_def by auto
    moreover then obtain u v where "e = {u, v}" "u \<noteq> v"
      by (metis card_2_elements)
    ultimately have "e = mk_uedge (u, v)" "u \<in> uverts G" "v \<in> uverts G"
      by auto
    hence "e \<in> all_edges (uverts G)"
      unfolding all_edges_def using \<open>u \<noteq> v\<close> by fastforce
  }
  thus ?thesis
    unfolding complete_def subgraph_def by auto
qed

corollary wellformed_all_edges: "uwellformed G \<Longrightarrow> uedges G \<subseteq> all_edges (uverts G)"
  using subgraph_complete subgraph_def complete_def by simp

corollary max_edges_graph:
  assumes "uwellformed G" "finite (uverts G)"
  shows "card (uedges G) \<le> (card (uverts G))^2"
proof -
  have "card (uedges G) \<le> card (uverts G) choose 2"
    by (metis all_edges_finite assms card_all_edges card_mono wellformed_all_edges)
  thus ?thesis
    by (metis binomial_le_pow le0 neq0_conv order.trans zero_less_binomial_iff)
qed

lemma subgraph_finite: "\<lbrakk> finite_graph G; subgraph G' G \<rbrakk> \<Longrightarrow> finite_graph G'"
  unfolding finite_graph_def subgraph_def
  by (metis rev_finite_subset)

corollary wellformed_finite:
  assumes "finite (uverts G)" and "uwellformed G"
  shows "finite_graph G"
proof (rule subgraph_finite[where G = "complete (uverts G)"])
  show "subgraph G (complete (uverts G))"
    using assms by (simp add: subgraph_complete)
next
  have "finite (uedges (complete (uverts G)))"
    using complete_finite_edges[OF assms(1)] .
  thus "finite_graph (complete (uverts G))"
    unfolding finite_graph_def complete_def using assms(1) by auto
qed

definition subgraphs :: "ugraph \<Rightarrow> ugraph set" where
"subgraphs G = {G'. subgraph G' G}"

definition nonempty_subgraphs :: "ugraph \<Rightarrow> ugraph set" where
"nonempty_subgraphs G = {G'. uwellformed G' \<and> subgraph G' G \<and> nonempty_graph G'}"

lemma subgraphs_finite:
  assumes "finite_graph G"
  shows "finite (subgraphs G)"
proof -
  have "subgraphs G = {(V', E'). V' \<subseteq> uverts G \<and> E' \<subseteq> uedges G}"
    unfolding subgraphs_def subgraph_def by force
  moreover have "finite (uverts G)" "finite (uedges G)"
    using assms unfolding finite_graph_def by auto
  ultimately show ?thesis
    by simp
qed

corollary nonempty_subgraphs_finite: "finite_graph G \<Longrightarrow> finite (nonempty_subgraphs G)"
using subgraphs_finite
unfolding nonempty_subgraphs_def subgraphs_def
by auto

subsection\<open>Induced subgraphs\<close>

definition induced_subgraph :: "uvert set \<Rightarrow> ugraph \<Rightarrow> ugraph" where
"induced_subgraph V G = (V, uedges G \<inter> all_edges V)"

lemma induced_is_subgraph:
  "V \<subseteq> uverts G \<Longrightarrow> subgraph (induced_subgraph V G) G"
  "V \<subseteq> uverts G \<Longrightarrow> subgraph (induced_subgraph V G) (complete V)"
unfolding subgraph_def induced_subgraph_def complete_def
by simp+

lemma induced_wellformed: "uwellformed G \<Longrightarrow> V \<subseteq> uverts G \<Longrightarrow> uwellformed (induced_subgraph V G)"
unfolding uwellformed_def induced_subgraph_def all_edges_def
by force

lemma subgraph_union_induced:
  assumes "uverts H\<^sub>1 \<subseteq> S" and "uverts H\<^sub>2 \<subseteq> T"
  assumes "uwellformed H\<^sub>1" and "uwellformed H\<^sub>2"
  shows "subgraph H\<^sub>1 (induced_subgraph S G) \<and> subgraph H\<^sub>2 (induced_subgraph T G) \<longleftrightarrow>
         subgraph (uverts H\<^sub>1 \<union> uverts H\<^sub>2, uedges H\<^sub>1 \<union> uedges H\<^sub>2) (induced_subgraph (S \<union> T) G)"
unfolding induced_subgraph_def subgraph_def
apply auto
using all_edges_mono apply blast
using all_edges_mono apply blast
using assms(1,2) wellformed_all_edges[OF assms(3)] wellformed_all_edges[OF assms(4)] all_edges_mono[OF assms(1)] all_edges_mono[OF assms(2)]
apply auto
done

lemma (in edge_space) induced_subgraph_prob:
  assumes "uverts H \<subseteq> V" and "uwellformed H" and "V \<subseteq> S_verts"
  shows "prob {es \<in> space P. subgraph H (induced_subgraph V (edge_ugraph es))} = p ^ card (uedges H)" (is "prob ?A = _")
proof -
  have "prob ?A = prob (cylinder S_edges (uedges H) {})"
    unfolding cylinder_def space_eq subgraph_def induced_subgraph_def edge_ugraph_def S_edges_def
    by (rule arg_cong[OF Collect_cong]) (metis (no_types) assms(1,2) Pow_iff all_edges_mono fst_conv inf_absorb1 inf_bot_left le_inf_iff snd_conv wellformed_all_edges)
  also have "\<dots> = p ^ card (uedges H)"
    proof (rule cylinder_empty_prob)
      have "uedges H \<subseteq> all_edges (uverts H)"
        by (rule wellformed_all_edges[OF assms(2)])
      also have "all_edges (uverts H) \<subseteq> all_edges S_verts"
        using assms by (auto simp: all_edges_mono[OF subset_trans])
      finally show "uedges H \<subseteq> S_edges"
        unfolding S_edges_def .
    qed
  finally show ?thesis
    .
qed

subsection\<open>Graph isomorphism\<close>

text\<open>We define graph isomorphism slightly different than in the literature. The usual definition
is that two graphs are isomorphic iff there exists a bijection between the vertex sets which
preserves the adjacency. However, this complicates many proofs.

Instead, we define the intuitive mapping operation on graphs. An isomorphism between two graphs
arises if there is a suitable mapping function from the first to the second graph. Later, we show
that this operation can be inverted.\<close>

fun map_ugraph :: "(nat \<Rightarrow> nat) \<Rightarrow> ugraph \<Rightarrow> ugraph" where
"map_ugraph f (V, E) = (f ` V, (\<lambda>e. f ` e) ` E)"

definition isomorphism :: "ugraph \<Rightarrow> ugraph \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> bool" where
"isomorphism G\<^sub>1 G\<^sub>2 f \<equiv> bij_betw f (uverts G\<^sub>1) (uverts G\<^sub>2) \<and> G\<^sub>2 = map_ugraph f G\<^sub>1"

abbreviation isomorphic :: "ugraph \<Rightarrow> ugraph \<Rightarrow> bool" ("_ \<simeq> _") where
"G\<^sub>1 \<simeq> G\<^sub>2 \<equiv> uwellformed G\<^sub>1 \<and> uwellformed G\<^sub>2 \<and> (\<exists>f. isomorphism G\<^sub>1 G\<^sub>2 f)"

lemma map_ugraph_id: "map_ugraph id = id"
unfolding fun_eq_iff
by simp

lemma map_ugraph_trans: "map_ugraph (g \<circ> f) = (map_ugraph g) \<circ> (map_ugraph f)"
  by (simp add: fun_eq_iff image_image)

lemma map_ugraph_wellformed:
  assumes "uwellformed G" and "inj_on f (uverts G)"
  shows "uwellformed (map_ugraph f G)"
unfolding uwellformed_def
proof safe
  fix e'
  assume "e' \<in> uedges (map_ugraph f G)"
  hence "e' \<in> (\<lambda>e. f ` e) ` (uedges G)"
    by (metis map_ugraph.simps snd_conv surjective_pairing)
  then obtain e where e: "e' = f ` e" "e \<in> uedges G"
    by blast
  hence "card e = 2" "e \<subseteq> uverts G"
    using assms(1) unfolding uwellformed_def by blast+
  thus "card e' = 2"
    using e(1) by (simp add: card_inj_subs[OF assms(2)])

  fix u'
  assume "u' \<in> e'"
  hence "u' \<in> f ` e"
    using e by force
  then obtain u where u: "u' = f u" "u \<in> e"
    by blast
  hence "u \<in> uverts G"
    using assms(1) e(2) unfolding uwellformed_def by blast
  hence "u' \<in> f ` uverts G"
    using u(1) by simp
  thus "u' \<in> uverts (map_ugraph f G)"
    by (metis map_ugraph.simps fst_conv surjective_pairing)
qed

lemma map_ugraph_finite: "finite_graph G \<Longrightarrow> finite_graph (map_ugraph f G)"
unfolding finite_graph_def
by (metis finite_imageI fst_conv map_ugraph.simps snd_conv surjective_pairing)

lemma map_ugraph_preserves_sub:
  assumes "subgraph G\<^sub>1 G\<^sub>2"
  shows "subgraph (map_ugraph f G\<^sub>1) (map_ugraph f G\<^sub>2)"
proof -
  have "f ` uverts G\<^sub>1 \<subseteq> f ` uverts G\<^sub>2" "(\<lambda>e. f ` e) ` uedges G\<^sub>1 \<subseteq> (\<lambda>e. f ` e) ` uedges G\<^sub>2"
    using assms(1) unfolding subgraph_def by auto
  thus ?thesis
    unfolding subgraph_def by (metis map_ugraph.simps fst_conv snd_conv surjective_pairing)
qed

lemma isomorphic_refl: "uwellformed G \<Longrightarrow> G \<simeq> G"
unfolding isomorphism_def
by (metis bij_betw_id id_def map_ugraph_id)

lemma isomorphic_trans:
  assumes "G\<^sub>1 \<simeq> G\<^sub>2" and "G\<^sub>2 \<simeq> G\<^sub>3"
  shows "G\<^sub>1 \<simeq> G\<^sub>3"
proof -
  from assms obtain f\<^sub>1 f\<^sub>2 where
    bij: "bij_betw f\<^sub>1 (uverts G\<^sub>1) (uverts G\<^sub>2)" "bij_betw f\<^sub>2 (uverts G\<^sub>2) (uverts G\<^sub>3)" and
    map: "G\<^sub>2 = map_ugraph f\<^sub>1 G\<^sub>1" "G\<^sub>3 = map_ugraph f\<^sub>2 G\<^sub>2"
    unfolding isomorphism_def by blast

  let ?f = "f\<^sub>2 \<circ> f\<^sub>1"
  have "bij_betw ?f (uverts G\<^sub>1) (uverts G\<^sub>3)"
    using bij by (simp add: bij_betw_comp_iff)
  moreover have "G\<^sub>3 = map_ugraph ?f G\<^sub>1"
    using map by (simp add: map_ugraph_trans)
  moreover have "uwellformed G\<^sub>1" "uwellformed G\<^sub>3"
    using assms unfolding isomorphism_def by simp+
  ultimately show "G\<^sub>1 \<simeq> G\<^sub>3"
    unfolding isomorphism_def by blast
qed

lemma isomorphic_sym:
  assumes "G\<^sub>1 \<simeq> G\<^sub>2"
  shows "G\<^sub>2 \<simeq> G\<^sub>1"
proof safe
  from assms obtain f where "isomorphism G\<^sub>1 G\<^sub>2 f"
    by blast
  hence bij: "bij_betw f (uverts G\<^sub>1) (uverts G\<^sub>2)" and map: "G\<^sub>2 = map_ugraph f G\<^sub>1"
    unfolding isomorphism_def by auto

  let ?f' = "inv_into (uverts G\<^sub>1) f"
  have bij': "bij_betw ?f' (uverts G\<^sub>2) (uverts G\<^sub>1)"
    by (rule bij_betw_inv_into) fact
  moreover have "uverts G\<^sub>1 = ?f' ` uverts G\<^sub>2"
    using bij' unfolding bij_betw_def by force
  moreover have "uedges G\<^sub>1 = (\<lambda>e. ?f' ` e) ` uedges G\<^sub>2"
    proof -
      have "uedges G\<^sub>1 = id ` uedges G\<^sub>1"
        by simp
      also have "\<dots> = (\<lambda>e. ?f' ` (f ` e)) ` uedges G\<^sub>1"
        proof (rule image_cong)
          fix a
          assume "a \<in> uedges G\<^sub>1"
          hence "a \<subseteq> uverts G\<^sub>1"
            using assms unfolding isomorphism_def uwellformed_def by blast
          thus "id a = inv_into (uverts G\<^sub>1) f ` f ` a"
            by (metis (full_types) id_def bij bij_betw_imp_inj_on inv_into_image_cancel)
        qed simp
      also have "\<dots> = (\<lambda>e. ?f' ` e) ` ((\<lambda>e. f ` e) ` uedges G\<^sub>1)"
        by (rule image_image[symmetric])
      also have "\<dots> = (\<lambda>e. ?f' ` e) ` uedges G\<^sub>2"
        using bij map by (metis map_ugraph.simps prod.collapse snd_eqD)
      finally show ?thesis
        .
    qed
  ultimately have "isomorphism G\<^sub>2 G\<^sub>1 ?f'"
    unfolding isomorphism_def by (metis map_ugraph.simps split_pairs)
  thus "\<exists>f. isomorphism G\<^sub>2 G\<^sub>1 f"
    by blast
qed (auto simp: assms)

lemma isomorphic_cards:
  assumes "G\<^sub>1 \<simeq> G\<^sub>2"
  shows
    "card (uverts G\<^sub>1) = card (uverts G\<^sub>2)" (is "?V")
    "card (uedges G\<^sub>1) = card (uedges G\<^sub>2)" (is "?E")
proof -
  from assms obtain f where
    bij: "bij_betw f (uverts G\<^sub>1) (uverts G\<^sub>2)" and
    map: "G\<^sub>2 = map_ugraph f G\<^sub>1"
    unfolding isomorphism_def by blast
  from assms have wellformed: "uwellformed G\<^sub>1" "uwellformed G\<^sub>2"
    by simp+

  show ?V
    by (rule bij_betw_same_card[OF bij])

  let ?g = "\<lambda>e. f ` e"
  have "bij_betw ?g (Pow (uverts G\<^sub>1)) (Pow (uverts G\<^sub>2))"
    by (rule bij_lift[OF bij])
  moreover have "uedges G\<^sub>1 \<subseteq> Pow (uverts G\<^sub>1)"
    using wellformed(1) unfolding uwellformed_def by blast
  ultimately have "card (?g ` uedges G\<^sub>1) = card (uedges G\<^sub>1)"
    unfolding bij_betw_def by (metis card_inj_subs)
  thus ?E
    by (metis map map_ugraph.simps snd_conv surjective_pairing)
qed

subsection\<open>Isomorphic subgraphs\<close>

text\<open>The somewhat sloppy term `isomorphic subgraph' denotes a subgraph which is isomorphic to a
fixed other graph. For example, saying that a graph contains a triangle usually means that it
contains \emph{any} triangle, not the specific triangle with the nodes $1$, $2$ and $3$. Hence, such
a graph would have a triangle as an isomorphic subgraph.\<close>

definition subgraph_isomorphic :: "ugraph \<Rightarrow> ugraph \<Rightarrow> bool" ("_ \<sqsubseteq> _") where
"G' \<sqsubseteq> G \<equiv> uwellformed G \<and> (\<exists>G''. G' \<simeq> G'' \<and> subgraph G'' G)"

lemma subgraph_is_subgraph_isomorphic: "\<lbrakk> uwellformed G'; uwellformed G; subgraph G' G \<rbrakk> \<Longrightarrow> G' \<sqsubseteq> G"
unfolding subgraph_isomorphic_def
by (metis isomorphic_refl)

lemma isomorphic_is_subgraph_isomorphic: "G\<^sub>1 \<simeq> G\<^sub>2 \<Longrightarrow> G\<^sub>1 \<sqsubseteq> G\<^sub>2"
unfolding subgraph_isomorphic_def
by (metis subgraph_refl)

lemma subgraph_isomorphic_refl: "uwellformed G \<Longrightarrow> G \<sqsubseteq> G"
unfolding subgraph_isomorphic_def
by (metis isomorphic_refl subgraph_refl)

lemma subgraph_isomorphic_pre_iso_closed:
  assumes "G\<^sub>1 \<simeq> G\<^sub>2" and "G\<^sub>2 \<sqsubseteq> G\<^sub>3"
  shows "G\<^sub>1 \<sqsubseteq> G\<^sub>3"
unfolding subgraph_isomorphic_def
proof
  show "uwellformed G\<^sub>3"
    using assms unfolding subgraph_isomorphic_def by blast
next
  from assms(2) obtain G\<^sub>2' where "G\<^sub>2 \<simeq> G\<^sub>2'" "subgraph G\<^sub>2' G\<^sub>3"
    unfolding subgraph_isomorphic_def by blast
  moreover with assms(1) have "G\<^sub>1 \<simeq> G\<^sub>2'"
    by (metis isomorphic_trans)
  ultimately show "\<exists>G''. G\<^sub>1 \<simeq> G'' \<and> subgraph G'' G\<^sub>3"
    by blast
qed

lemma subgraph_isomorphic_pre_subgraph_closed:
  assumes "uwellformed G\<^sub>1" and "subgraph G\<^sub>1 G\<^sub>2" and "G\<^sub>2 \<sqsubseteq> G\<^sub>3"
  shows "G\<^sub>1 \<sqsubseteq> G\<^sub>3"
unfolding subgraph_isomorphic_def
proof
  show "uwellformed G\<^sub>3"
    using assms unfolding subgraph_isomorphic_def by blast
next
  from assms(3) obtain G\<^sub>2' where "G\<^sub>2 \<simeq> G\<^sub>2'" "subgraph G\<^sub>2' G\<^sub>3"
    unfolding subgraph_isomorphic_def by blast
  then obtain f where bij: "bij_betw f (uverts G\<^sub>2) (uverts G\<^sub>2')" "G\<^sub>2' = map_ugraph f G\<^sub>2"
    unfolding isomorphism_def by blast
  let ?G\<^sub>1' = "map_ugraph f G\<^sub>1"

  have "bij_betw f (uverts G\<^sub>1) (f ` uverts G\<^sub>1)"
    using bij(1) assms(2) unfolding subgraph_def by (auto intro: bij_betw_subset)
  moreover hence "uwellformed ?G\<^sub>1'"
    using map_ugraph_wellformed[OF assms(1)] unfolding bij_betw_def ..
  ultimately have "G\<^sub>1 \<simeq> ?G\<^sub>1'"
    using assms(1) unfolding isomorphism_def by (metis map_ugraph.simps fst_conv surjective_pairing)
  moreover have "subgraph ?G\<^sub>1' G\<^sub>3" (* Yes, I will TOTALLY understand that step tomorrow. *)
    using subgraph_trans[OF map_ugraph_preserves_sub[OF assms(2)]] bij(2) \<open>subgraph G\<^sub>2' G\<^sub>3\<close> by simp
  ultimately show "\<exists>G''. G\<^sub>1 \<simeq> G'' \<and> subgraph G'' G\<^sub>3"
    by blast
qed

lemmas subgraph_isomorphic_pre_closed = subgraph_isomorphic_pre_subgraph_closed subgraph_isomorphic_pre_iso_closed

lemmas subgraph_isomorphic_post_closed = subgraph_isomorphic_post_iso_closed

lemmas subgraph_isomorphic_closed = subgraph_isomorphic_pre_closed subgraph_isomorphic_post_closed

subsection\<open>Density\<close>

text\<open>The density of a graph is the quotient of the number of edges and the number of vertices of
a graph.\<close>

definition density :: "ugraph \<Rightarrow> real" where
"density G = card (uedges G) / card (uverts G)"

text\<open>The maximum density of a graph is the density of its densest nonempty subgraph.\<close>

definition max_density :: "ugraph \<Rightarrow> real" where
"max_density G = Lattices_Big.Max (density ` nonempty_subgraphs G)"

text\<open>We prove some obvious results about the maximum density, such as that there is a subgraph
which has the maximum density and that the (maximum) density is preserved by isomorphisms. The
proofs are a bit complicated by the fact that most facts about @{term Lattices_Big.Max} require
non-emptiness of the target set, but we need that anyway to get a value out of it.\<close>

lemma max_density_is_max:
  assumes "finite_graph G" and "finite_graph G'" and "nonempty_graph G'" and "uwellformed G'" and "subgraph G' G"
  shows "density G' \<le> max_density G"
unfolding max_density_def
proof (rule Max_ge)
  show "finite (density ` nonempty_subgraphs G)"
    using assms(1) by (simp add: nonempty_subgraphs_finite)
next
  show "density G' \<in> density ` nonempty_subgraphs G"
    unfolding nonempty_subgraphs_def using assms by blast
qed

lemma max_density_gr_zero:
  assumes "finite_graph G" and "nonempty_graph G" and "uwellformed G"
  shows "0 < max_density G"
proof -
  have "0 < card (uverts G)" "0 < card (uedges G)"
    using assms unfolding finite_graph_def nonempty_graph_def by auto
  hence "0 < density G"
    unfolding density_def by simp
  also have "density G \<le> max_density G"
    using assms by (simp add: max_density_is_max subgraph_refl)
  finally show ?thesis
    .
qed

lemma isomorphic_density:
  assumes "G\<^sub>1 \<simeq> G\<^sub>2"
  shows "density G\<^sub>1 = density G\<^sub>2"
unfolding density_def
using isomorphic_cards[OF assms]
by simp

lemma isomorphic_max_density:
  assumes "G\<^sub>1 \<simeq> G\<^sub>2" and "nonempty_graph G\<^sub>1" and "nonempty_graph G\<^sub>2" and "finite_graph G\<^sub>1" and "finite_graph G\<^sub>2"
  shows "max_density G\<^sub>1 = max_density G\<^sub>2"
proof -
  \<comment> \<open>The proof strategy is not completely straightforward. We first show that if two graphs are
       isomorphic, the maximum density of one graph is less or equal than the maximum density of
       the other graph. The reason is that this proof is quite long and the desired result directly
       follows from the symmetry of the isomorphism relation.\footnote{Some famous mathematician
       once said that if you prove that $a \le b$ and $b \le a$, you know \emph{that} these
       numbers are equal, but not \emph{why}. Since many proofs in this work are mostly opaque to
       me, I can live with that.}\<close>
  {
    fix A B
    assume A: "nonempty_graph A" "finite_graph A"
    assume iso: "A \<simeq> B"

    then obtain f where f: "B = map_ugraph f A" "bij_betw f (uverts A) (uverts B)"
      unfolding isomorphism_def by blast
    have wellformed: "uwellformed A"
      using iso unfolding isomorphism_def by simp
    \<comment> \<open>We observe that the set of densities of the subgraphs does not change if we map the
         subgraphs first.\<close>
    have "density ` nonempty_subgraphs A = density ` (map_ugraph f ` nonempty_subgraphs A)"
      proof (rule image_comp_cong)
        fix G
        assume "G \<in> nonempty_subgraphs A"
        hence "uverts G \<subseteq> uverts A" "uwellformed G"
          unfolding nonempty_subgraphs_def subgraph_def by simp+
        hence "inj_on f (uverts G)"
          using f(2) unfolding bij_betw_def by (metis subset_inj_on)
        hence "G \<simeq> map_ugraph f G"
          unfolding isomorphism_def bij_betw_def
          by (metis map_ugraph.simps fst_conv surjective_pairing map_ugraph_wellformed \<open>uwellformed G\<close>)
        thus "density G = density (map_ugraph f G)"
          by (fact isomorphic_density)
      qed
    \<comment> \<open>Additionally, we show that the operations @{term nonempty_subgraphs} and @{term map_ugraph}
         can be swapped without changing the densities. This is an obvious result, because
         @{term map_ugraph} does not change the structure of a graph. Still, the proof is a bit
         hairy, which is why we only show inclusion in one direction and use symmetry of isomorphism
         later.\<close>
    also have "\<dots> \<subseteq> density ` nonempty_subgraphs (map_ugraph f A)"
      proof (rule image_mono, rule subsetI)
        fix G''
        assume "G'' \<in> map_ugraph f ` nonempty_subgraphs A"
        then obtain G' where G_subst: "G'' = map_ugraph f G'" "G' \<in> nonempty_subgraphs A"
          by blast
        hence G': "subgraph G' A" "nonempty_graph G'" "uwellformed G'"
          unfolding nonempty_subgraphs_def by auto
        hence "inj_on f (uverts G')"
          using f unfolding bij_betw_def subgraph_def by (metis subset_inj_on)
        hence "uwellformed G''"
          using map_ugraph_wellformed G' G_subst by simp
        moreover have "nonempty_graph G''"
          using G' G_subst unfolding nonempty_graph_def by (metis map_ugraph.simps fst_conv snd_conv surjective_pairing empty_is_image)
        moreover have "subgraph G'' (map_ugraph f A)"
          using map_ugraph_preserves_sub G' G_subst by simp
        ultimately show "G'' \<in> nonempty_subgraphs (map_ugraph f A)"
          unfolding nonempty_subgraphs_def by simp
      qed
    finally have "density ` nonempty_subgraphs A \<subseteq> density ` nonempty_subgraphs (map_ugraph f A)"
      .
    hence "max_density A \<le> max_density (map_ugraph f A)"
      unfolding max_density_def
      proof (rule Max_mono)
        have "A \<in> nonempty_subgraphs A"
          using A iso unfolding nonempty_subgraphs_def by (simp add: subgraph_refl)
        thus "density ` nonempty_subgraphs A \<noteq> {}"
          by blast
      next
        have "finite (nonempty_subgraphs (map_ugraph f A))"
          by (rule nonempty_subgraphs_finite[OF map_ugraph_finite[OF A(2)]])
        thus "finite (density ` nonempty_subgraphs (map_ugraph f A))"
          by blast
      qed
    hence "max_density A \<le> max_density B"
      by (subst f)
  }
  then show ?thesis
    by (meson assms isomorphic_sym order_antisym_conv)
qed

subsection\<open>Fixed selectors\<close>

text\<open>\label{sec:selector}
In the proof of the main theorem in the lecture notes, the concept of a ``fixed copy'' of a graph is
fundamental.

Let $H$ be a fixed graph. A `fixed selector' is basically a function mapping a set with the same
size as the vertex set of $H$ to a new graph which is isomorphic to $H$ and its vertex set is the
same as the input set.\footnote{We call such a selector \emph{fixed} because its result is
deterministic.}\<close>

definition "is_fixed_selector H f = (\<forall>V. finite V \<and> card (uverts H) = card V \<longrightarrow> H \<simeq> f V \<and> uverts (f V) = V)"

text\<open>Obviously, there may be many possible fixed selectors for a given graph. First, we show
that there is always at least one. This is sufficient, because we can always obtain that one and
use its properties without knowing exactly which one we chose.\<close>

lemma ex_fixed_selector:
  assumes "uwellformed H" and "finite_graph H"
  obtains f where "is_fixed_selector H f"
proof
  \<comment> \<open>I guess this is the only place in the whole work where we make use of a nifty little HOL
       feature called \emph{SOME}, which is basically Hilbert's choice operator. The reason is that
       any bijection between the the vertex set of @{term H} and the input set gives rise to a
       fixed selector function. In the lecture notes, a specific bijection was defined, but this
       is shorter and more elegant.\<close>
  let ?bij = "\<lambda>V. SOME g. bij_betw g (uverts H) V"
  let ?f = "\<lambda>V. map_ugraph (?bij V) H"
  {
    fix V :: "uvert set"
    assume "finite V" "card (uverts H) = card V"
    moreover have "finite (uverts H)"
      using assms unfolding finite_graph_def by simp
    ultimately have "bij_betw (?bij V) (uverts H) V"
      by (metis finite_same_card_bij someI_ex)
    moreover hence *: "uverts (?f V) = V \<and> uwellformed (?f V)"
      using map_ugraph_wellformed[OF assms(1)]
      by (metis bij_betw_def map_ugraph.simps fst_conv surjective_pairing)
    ultimately have **: "H \<simeq> ?f V"
      unfolding isomorphism_def using assms(1) by auto
    note * **
  }
  thus "is_fixed_selector H ?f"
    unfolding is_fixed_selector_def by blast
qed

lemma fixed_selector_induced_subgraph:
  assumes "is_fixed_selector H f" and "card (uverts H) = card V" and "finite V"
  assumes sub: "subgraph (f V) (induced_subgraph V G)" and V: "V \<subseteq> uverts G" and G: "uwellformed G"
  shows "H \<sqsubseteq> G"
  by (meson G V assms induced_is_subgraph(1) is_fixed_selector_def sub subgraph_isomorphic_def subgraph_trans)

end


theory FiniteListGraph
imports
  FiniteGraph
  "Transitive-Closure.Transitive_Closure_List_Impl"
begin

section \<open>Specification of a finite graph, implemented by lists\<close>

text\<open>A graph \<open>G=(V,E)\<close> consits of a list of vertices @{term V}, also called nodes,
       and a list of edges @{term E}. The edges are tuples of vertices.
       Using lists instead of sets, code can be easily created.\<close>

  record 'v list_graph =
    nodesL :: "'v list"
    edgesL :: "('v \<times>'v) list"

text\<open>Correspondence the FiniteGraph\<close>
  definition list_graph_to_graph :: "'v list_graph \<Rightarrow> 'v graph" where
    "list_graph_to_graph G = \<lparr> nodes = set (nodesL G), edges = set (edgesL G) \<rparr>"

  definition wf_list_graph_axioms :: "'v list_graph \<Rightarrow> bool" where
    "wf_list_graph_axioms G \<longleftrightarrow> fst` set (edgesL G) \<subseteq> set (nodesL G) \<and> snd` set (edgesL G) \<subseteq> set (nodesL G)"

  lemma wf_list_graph_iff_wf_graph: "wf_graph (list_graph_to_graph G) \<longleftrightarrow> wf_list_graph_axioms G"
  unfolding list_graph_to_graph_def wf_graph_def wf_list_graph_axioms_def
  by simp

  text\<open>We say a @{typ "'v list_graph"} is valid if it fulfills the graph axioms and its lists are distinct\<close>
  definition wf_list_graph::"('v) list_graph \<Rightarrow> bool" where
   "wf_list_graph G = (distinct (nodesL G) \<and> distinct (edgesL G) \<and> wf_list_graph_axioms G)"

section\<open>FiniteListGraph operations\<close>

  text \<open>Adds a node to a graph.\<close>
  definition add_node :: "'v \<Rightarrow> 'v list_graph \<Rightarrow> 'v list_graph" where
    "add_node v G = \<lparr> nodesL = (if v \<in> set (nodesL G) then nodesL G else v#nodesL G), edgesL=edgesL G \<rparr>"

  text \<open>Adds an edge to a graph.\<close>
  definition add_edge :: "'v \<Rightarrow> 'v \<Rightarrow> 'v list_graph \<Rightarrow> 'v list_graph" where
    "add_edge v v' G = (add_node v (add_node v' G)) \<lparr>edgesL := (if (v, v') \<in> set (edgesL G) then edgesL G else (v, v')#edgesL G) \<rparr>"

  text \<open>Deletes a node from a graph. Also deletes all adjacent edges.\<close>
  definition delete_node :: "'v \<Rightarrow> 'v list_graph \<Rightarrow> 'v list_graph" where
  "delete_node v G = \<lparr>
    nodesL = remove1 v (nodesL G), edgesL = [(e1,e2) \<leftarrow> (edgesL G). e1 \<noteq> v \<and> e2 \<noteq> v]
    \<rparr>"

  text \<open>Deletes an edge from a graph.\<close>
  definition delete_edge :: "'v \<Rightarrow> 'v \<Rightarrow> 'v list_graph \<Rightarrow> 'v list_graph" where
    "delete_edge v v' G = \<lparr>nodesL = nodesL G, edgesL = [(e1,e2) \<leftarrow> edgesL G. e1 \<noteq> v \<or> e2 \<noteq> v'] \<rparr>"

  fun delete_edges::"'v list_graph \<Rightarrow> ('v \<times> 'v) list \<Rightarrow> 'v list_graph" where
    "delete_edges G [] = G"|
    "delete_edges G ((v,v')#es) = delete_edges (delete_edge v v' G) es"

text \<open>extended graph operations\<close>
   text \<open>Reflexive transitive successors of a node. Or: All reachable nodes for v including v.\<close>
    definition succ_rtran :: "'v list_graph \<Rightarrow> 'v \<Rightarrow> 'v list" where
      "succ_rtran G v = rtrancl_list_impl (edgesL G) [v]"

   text \<open>Transitive successors of a node. Or: All reachable nodes for v.\<close>
    definition succ_tran :: "'v list_graph \<Rightarrow> 'v \<Rightarrow> 'v list" where
      "succ_tran G v = trancl_list_impl (edgesL G) [v]"

   text \<open>The number of reachable nodes from v\<close>
    definition num_reachable :: "'v list_graph \<Rightarrow> 'v \<Rightarrow> nat" where
      "num_reachable G v = length (succ_tran G v)"

    definition num_reachable_norefl :: "'v list_graph \<Rightarrow> 'v \<Rightarrow> nat" where
      "num_reachable_norefl G v = length ([ x \<leftarrow> succ_tran G v. x \<noteq> v])"

subsection\<open>undirected graph simulation\<close>
  text \<open>Create undirected graph from directed graph by adding backward links\<close>
  fun backlinks :: "('v \<times> 'v) list \<Rightarrow> ('v \<times> 'v) list" where
    "backlinks [] = []" |
    "backlinks ((e1, e2)#es) = (e2, e1)#(backlinks es)"

  definition undirected :: "'v list_graph \<Rightarrow> 'v list_graph"
    where "undirected G \<equiv> \<lparr> nodesL = nodesL G, edgesL = remdups (edgesL G @ backlinks (edgesL G)) \<rparr>"

section\<open>Correctness lemmata\<close>

  \<comment> \<open>add node\<close>
  lemma add_node_wf: "wf_list_graph G \<Longrightarrow> wf_list_graph (add_node v G)"
  unfolding wf_list_graph_def wf_list_graph_axioms_def add_node_def
  by auto

  lemma add_node_set_nodes: "set (nodesL (add_node v G)) = set (nodesL G) \<union> {v}"
  unfolding add_node_def
  by auto

  lemma add_node_set_edges: "set (edgesL (add_node v G)) = set (edgesL G)"
  unfolding add_node_def
  by auto

  lemma add_node_correct: "FiniteGraph.add_node v (list_graph_to_graph G) = list_graph_to_graph (add_node v G)"
  unfolding FiniteGraph.add_node_def list_graph_to_graph_def
  by (simp add: add_node_set_edges add_node_set_nodes)

  lemma add_node_wf2: "wf_graph (list_graph_to_graph G) \<Longrightarrow> wf_graph (list_graph_to_graph (add_node v G))"
  by (subst add_node_correct[symmetric]) simp

  \<comment> \<open>add edge\<close>
  lemma add_edge_wf: "wf_list_graph G \<Longrightarrow> wf_list_graph (add_edge v v' G)"
  unfolding wf_list_graph_def add_edge_def add_node_def wf_list_graph_axioms_def
  by auto

  lemma add_edge_set_nodes: "set (nodesL (add_edge v v' G)) = set (nodesL G) \<union> {v,v'}"
  unfolding add_edge_def add_node_def
  by auto

  lemma add_edge_set_edges: "set (edgesL (add_edge v v' G)) = set (edgesL G) \<union> {(v,v')}"
  unfolding add_edge_def add_node_def
  by auto

  lemma add_edge_correct: "FiniteGraph.add_edge v v' (list_graph_to_graph G) = list_graph_to_graph (add_edge v v' G)"
  unfolding FiniteGraph.add_edge_def add_edge_def list_graph_to_graph_def
  by (auto simp: add_node_set_nodes)

  lemma add_edge_wf2: "wf_graph (list_graph_to_graph G) \<Longrightarrow> wf_graph (list_graph_to_graph (add_edge v v' G))"
  by (subst add_edge_correct[symmetric]) simp

  \<comment> \<open>delete node\<close>
  lemma delete_node_wf: "wf_list_graph G \<Longrightarrow> wf_list_graph (delete_node v G)"
  unfolding wf_list_graph_def delete_node_def wf_list_graph_axioms_def
  by auto

  lemma delete_node_set_edges:
    "set (edgesL (delete_node v G)) = {(a,b). (a, b) \<in> set (edgesL G) \<and> a \<noteq> v \<and> b \<noteq> v}"
  unfolding delete_node_def
  by auto

  lemma delete_node_correct:
    assumes "wf_list_graph G"
    shows "FiniteGraph.delete_node v (list_graph_to_graph G) = list_graph_to_graph (delete_node v G)"
  using assms
  unfolding FiniteGraph.delete_node_def delete_node_def list_graph_to_graph_def wf_list_graph_def
  by auto

  \<comment> \<open>delete edge\<close>
  lemma delete_edge_set_nodes: "set (nodesL (delete_edge v v' G)) = set (nodesL G)"
  unfolding delete_edge_def
  by simp

  lemma delete_edge_set_edges:
    "set (edgesL (delete_edge v v' G)) = {(a,b). (a,b) \<in> set (edgesL G) \<and> (a,b) \<noteq> (v,v')}"
  unfolding delete_edge_def
  by auto

  lemma delete_edge_wf: "wf_list_graph G \<Longrightarrow> wf_list_graph (delete_edge v v' G)"
  unfolding wf_list_graph_def delete_edge_def wf_list_graph_axioms_def
  by auto

  lemma delete_edge_commute: "delete_edge a1 a2 (delete_edge b1 b2 G) = delete_edge b1 b2 (delete_edge a1 a2 G)"
  unfolding delete_edge_def
  by simp metis (* auto doesn't seem to like filter_cong *)

  lemma delete_edge_correct: "FiniteGraph.delete_edge v v' (list_graph_to_graph G) = list_graph_to_graph (delete_edge v v' G)"
  unfolding FiniteGraph.delete_edge_def delete_edge_def list_graph_to_graph_def
  by auto

  lemma delete_edge_wf2: "wf_graph (list_graph_to_graph G) \<Longrightarrow> wf_graph (list_graph_to_graph (delete_edge v v' G))"
  by (subst delete_edge_correct[symmetric]) simp

  \<comment> \<open>delete edges\<close>
  lemma delete_edges_wf: "wf_list_graph G \<Longrightarrow> wf_list_graph (delete_edges G E)"
  by (induction E arbitrary: G) (auto simp: delete_edge_wf)

  lemma delete_edges_set_nodes: "set (nodesL (delete_edges G E)) = set (nodesL G)"
  by (induction E arbitrary: G) (auto simp: delete_edge_set_nodes)

  lemma delete_edges_nodes: "nodesL (delete_edges G es) = nodesL G"
  by (induction es arbitrary: G) (auto simp: delete_edge_def)

  lemma delete_edges_set_edges: "set (edgesL (delete_edges G E)) = set (edgesL G) - set E"
  by (induction E arbitrary: G) (auto simp: delete_edge_def delete_edge_set_nodes)

  lemma delete_edges_set_edges2:
    "set (edgesL (delete_edges G E)) = {(a,b). (a,b) \<in> set (edgesL G) \<and> (a,b) \<notin> set E}"
  by (auto simp: delete_edges_set_edges)

  lemma delete_edges_length: "length (edgesL (delete_edges G f)) \<le> length (edgesL G)"
  proof (induction f arbitrary:G)
    case (Cons f fs)
    thus ?case
      apply (cases f, hypsubst)
      apply (subst delete_edges.simps(2))
      apply (metis delete_edge_length le_trans)
      done
  qed simp

  lemma delete_edges_chain: "delete_edges G (as @ bs) = delete_edges (delete_edges G as) bs"
  proof (induction as arbitrary: bs G)
    case (Cons f fs)
    thus ?case
      by (cases f) auto
  qed simp

  lemma delete_edges_delete_edge_commute:
    "delete_edges (delete_edge a1 a2 G) as = delete_edge a1 a2 (delete_edges G as)"
  proof (induction as arbitrary: G a1 a2)
    case (Cons f fs)
    thus ?case
      by (cases f) (simp add: delete_edge_commute)
  qed simp

  lemma delete_edges_commute:
    "delete_edges (delete_edges G as) bs = delete_edges (delete_edges G bs) as"
  proof (induction as arbitrary: bs G)
    case (Cons f fs)
    thus ?case
      by (cases f) (simp add: delete_edges_delete_edge_commute)
  qed simp

  lemma delete_edges_as_filter:
    "delete_edges G l = \<lparr> nodesL = nodesL G,  edgesL = [x \<leftarrow> edgesL G. x \<notin> set l] \<rparr>"
  proof (induction l)
    case (Cons f fs)
    thus ?case
      apply (cases f)
      apply (simp add: delete_edges_delete_edge_commute)
      apply (simp add: delete_edge_def)
      apply (metis (lifting, full_types) prod.exhaust case_prodI split_conv)
      done
  qed simp

  declare delete_edges.simps[simp del] (*do not automatically expand definition*)

  lemma delete_edges_correct:
    "FiniteGraph.delete_edges (list_graph_to_graph G) (set E) = list_graph_to_graph (delete_edges G E)"
  unfolding list_graph_to_graph_def FiniteGraph.delete_edges_def
  by (auto simp add: delete_edges_as_filter )

  lemma delete_edges_wf2:
    "wf_graph (list_graph_to_graph G) \<Longrightarrow> wf_graph (list_graph_to_graph (delete_edges G E))"
  by (subst delete_edges_correct[symmetric]) simp

  \<comment> \<open>helper about reflexive transitive closure impl\<close>
  lemma distinct_relpow_impl:
    "distinct L \<Longrightarrow> distinct new \<Longrightarrow> distinct have \<Longrightarrow> distinct (new@have) \<Longrightarrow>
     distinct (relpow_impl (\<lambda>as. remdups (map snd [(a, b)\<leftarrow>L . a \<in> set as])) (\<lambda>xs ys. [x\<leftarrow>xs . x \<notin> set ys] @ ys) (\<lambda>x xs. x \<in> set xs) new have M)"
  proof (induction M arbitrary: "new" "have")
    case Suc
    hence
      "distinct ([x\<leftarrow>new . x \<notin> set have] @ have)"
      "set ([n\<leftarrow>remdups (map snd [(a, b)\<leftarrow>L . a \<in> set new]) . (n \<in> set new \<longrightarrow> n \<in> set have) \<and> n \<notin> set have]) \<inter> set ([x\<leftarrow>new . x \<notin> set have] @ have) = {}"
      by auto

    with Suc show ?case
      by auto
  qed auto

  lemma distinct_rtrancl_list_impl: "distinct L \<Longrightarrow> distinct ls \<Longrightarrow> distinct (rtrancl_list_impl L ls)"
  unfolding rtrancl_list_impl_def rtrancl_impl_def
  by (simp add:distinct_relpow_impl)

  lemma distinct_trancl_list_impl: "distinct L \<Longrightarrow> distinct ls \<Longrightarrow> distinct (trancl_list_impl L ls)"
  unfolding trancl_list_impl_def trancl_impl_def
  by (simp add:distinct_relpow_impl)

  \<comment> \<open>succ rtran\<close>
  value "succ_rtran \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr> 1"

  lemma succ_rtran_correct: "FiniteGraph.succ_rtran (list_graph_to_graph G) v = set (succ_rtran G v)"
  unfolding FiniteGraph.succ_rtran_def succ_rtran_def list_graph_to_graph_def
  by (simp add: rtrancl_list_impl)

  lemma distinct_succ_rtran: "wf_list_graph G \<Longrightarrow> distinct (succ_rtran G v)"
  unfolding succ_rtran_def wf_list_graph_def
  by (auto intro: distinct_rtrancl_list_impl)

  lemma succ_rtran_set: "set (succ_rtran G v) = {e2. (v,e2) \<in> (set (edgesL G))\<^sup>*}"
  unfolding succ_rtran_def
  by (simp add: rtrancl_list_impl)

  \<comment> \<open>succ tran\<close>
  lemma distinct_succ_tran: "wf_list_graph G \<Longrightarrow> distinct (succ_tran G v)"
  unfolding succ_tran_def wf_list_graph_def
  by (auto intro: distinct_trancl_list_impl)

  lemma succ_tran_set: "set (succ_tran G v) = {e2. (v,e2) \<in> (set (edgesL G))\<^sup>+}"
  unfolding succ_tran_def
  by (simp add: trancl_list_impl)

  value "succ_tran \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr> 1"

  lemma succ_tran_correct: "FiniteGraph.succ_tran (list_graph_to_graph G) v = set (succ_tran G v)"
  unfolding FiniteGraph.succ_tran_def succ_tran_def list_graph_to_graph_def
  by (simp add:trancl_list_impl)

  \<comment> \<open>num_reachable\<close>
  lemma num_reachable_correct:
    "wf_list_graph G \<Longrightarrow> FiniteGraph.num_reachable (list_graph_to_graph G) v = num_reachable G v"
  unfolding num_reachable_def FiniteGraph.num_reachable_def
  by (metis List.distinct_card distinct_succ_tran succ_tran_correct)

  \<comment> \<open>num_reachable_norefl\<close>
  lemma num_reachable_norefl_correct:
    "wf_list_graph G \<Longrightarrow>
     FiniteGraph.num_reachable_norefl (list_graph_to_graph G) v = num_reachable_norefl G v"
 unfolding num_reachable_norefl_def FiniteGraph.num_reachable_norefl_def
 by (metis (full_types) List.distinct_card distinct_filter distinct_succ_tran set_minus_filter_out succ_tran_correct)

  \<comment> \<open>backlinks, i.e. backflows in formal def\<close>
  lemma backlinks_alt: "backlinks E = [(snd e, fst e). e \<leftarrow> E]"
  by (induction E) auto

  lemma backlinks_set: "set (backlinks E) = {(e2, e1). (e1, e2) \<in> set E}"
  by (induction E) auto

  lemma undirected_nodes_set: "set (edgesL (undirected G)) = set (edgesL G) \<union> {(e2, e1). (e1, e2) \<in> set (edgesL G)}"
  unfolding undirected_def
  by (simp add: backlinks_set)

  lemma undirected_succ_tran_set: "set (succ_tran (undirected G) v) = {e2. (v,e2) \<in> (set (edgesL (undirected G)))\<^sup>+}"
  by (fact succ_tran_set)

  lemma backlinks_in_nodes_G: "\<lbrakk> fst ` set (edgesL G) \<subseteq> set (nodesL G); snd ` set (edgesL G) \<subseteq> set (nodesL G) \<rbrakk> \<Longrightarrow>
    fst` set (edgesL (undirected G)) \<subseteq> set (nodesL (undirected G)) \<and> snd` set (edgesL (undirected G)) \<subseteq> set (nodesL (undirected G))"
  unfolding undirected_def
  by(auto simp: backlinks_set)

  lemma backlinks_distinct: "distinct E \<Longrightarrow> distinct (backlinks E)"
  by (induction E) (auto simp: backlinks_alt)

  lemma backlinks_subset: "set (backlinks X) \<subseteq> set (backlinks Y) \<longleftrightarrow> set X \<subseteq> set Y"
  by (auto simp: backlinks_set)

  lemma backlinks_correct: "FiniteGraph.backflows (set E) = set (backlinks E)"
  unfolding backflows_def
  by(simp add: backlinks_set)

  \<comment> \<open>undirected\<close>
  lemma undirected_wf: "wf_list_graph G \<Longrightarrow> wf_list_graph (undirected G)"
  unfolding wf_list_graph_def wf_list_graph_axioms_def
  by (simp add:backlinks_in_nodes_G) (simp add: undirected_def)

  lemma undirected_correct:
    "FiniteGraph.undirected (list_graph_to_graph G) = list_graph_to_graph (undirected G)"
  unfolding FiniteGraph.undirected_def undirected_def list_graph_to_graph_def
  by (simp add: backlinks_set)

lemmas wf_list_graph_wf =
  add_node_wf
  add_edge_wf
  delete_node_wf
  delete_edge_wf
  delete_edges_wf
  undirected_wf

lemmas list_graph_correct =
  add_node_correct
  add_edge_correct
  delete_node_correct
  delete_edge_correct
  delete_edges_correct
  succ_rtran_correct
  succ_tran_correct
  num_reachable_correct
  undirected_correct

end


theory axioms_class_existence
imports ntuples
begin

section{* Axioms of Class Existence *}

text{* Mendelson introduces seven ``Axioms of Class Existence''
       instead of the axiom schema of separation for classes.
       We shall first introduce these axioms and then prove
       that for any first order formula with one free variable,
       whose bounded quantifiers are about sets, the following
       axioms provide us with a class that contains exactly those
       sets that satisfy this formula for any class parameter that
       occurs in the formula. Before we give the Axioms of Class
       existence, we need to be able to talk about triples, apart
       from tuples. *}

axiomatization
  intersection :: "Class \<Rightarrow> Class \<Rightarrow> Class" (infixl "\<inter>" 80)
and
  complement :: "Class \<Rightarrow> Class" ("Co")
and
  domain :: "Class \<Rightarrow> Class" ("dom")
  where
    B1: "\<exists>X::Class. \<forall>u v::Set. ((\<langle>u, v\<rangle> \<in> X) \<longleftrightarrow> u \<in> v)"
      --"belongs-relation"
and B2: "\<forall>u::Set. (u \<in> (X\<inter>Y) \<longleftrightarrow> u\<in>X \<and> u\<in>Y)"
      -- "intersection"
and B3: "\<forall>u::Set. (u \<in> Co(X) \<longleftrightarrow> u \<notin> X)"
      -- "complement"
and B4: "\<forall>u::Set. (u \<in> dom(X)\<longleftrightarrow>(\<exists>v::Set. (\<langle>u, v\<rangle>\<in>X)))"
      -- "domain"
and B5: "\<exists>Z::Class. \<forall>u v::Set.(\<langle>u, v\<rangle>\<in>Z\<longleftrightarrow>u\<in>X)"
      -- "projection to the first coordinate"
and B6: "\<exists>Z::Class. \<forall>u v w::Set. (\<langle>u, v, w\<rangle>\<in>Z \<longleftrightarrow> \<langle>v, w, u\<rangle>\<in>X)"
      -- "permutation of coordinates, all move 'to the left'"
and B7: "\<exists>Z::Class. \<forall>u v w::Set. (\<langle>u, v, w\<rangle>\<in>Z \<longleftrightarrow> \<langle>u, w, v\<rangle>\<in>X)"
      -- "permutation of the last two coordinates"

(* page 231 *)

(* The following are the uniqueness lemmas mentioned in the comments in the
           beginning of page 231. *)

lemma intersection_unique: "\<exists>! Z :: Class. \<forall> u :: Set. (u\<in>Z \<longleftrightarrow> (u\<in>X \<and> u\<in>Y))"
unfolding Ex1_def
proof (rule exI, rule conjI)
  def Z \<equiv> "X\<inter>Y"
  show "(\<forall>u::Set. u \<in> Z \<longleftrightarrow> (u \<in> X \<and> u \<in> Y))" using B2 Z_def by simp
  thus "(\<forall>Z'. (\<forall>u::Set. u \<in> Z' \<longleftrightarrow> (u \<in> X \<and> u \<in> Y)) \<longrightarrow> (Z' = Z)) "
    by (simp add: set_extensionality)
qed

(* Same proof below! *)

lemma complement_unique: "\<exists>! Z :: Class. \<forall> u :: Set. (u\<in>Z \<longleftrightarrow> u\<notin>X)"
unfolding Ex1_def
proof (rule exI, rule conjI)
  def Z \<equiv> "Co X"
  show "(\<forall>u::Set. u \<in> Z \<longleftrightarrow> (u \<notin> X))" using B3 Z_def by simp
  thus "(\<forall>Z'. (\<forall>u::Set. u \<in> Z' \<longleftrightarrow> (u \<notin> X)) \<longrightarrow> (Z' = Z)) "
    by (simp add: set_extensionality)
qed

(* And again "same". *)

text{* \textbf{FOMUS workshop exercise:} *}

lemma domain_unique: "\<exists>!Z::Class. \<forall>u::Set. (u\<in>Z \<longleftrightarrow> (\<exists>v::Set. (\<langle>u,v\<rangle>\<in>X)))"
sorry

abbreviation union :: "Class \<Rightarrow> Class \<Rightarrow> Class" (infixl "\<union>" 80)
where "X\<union>Y \<equiv> Co( Co(X) \<inter> Co(Y) )"

abbreviation Class_difference :: "Class \<Rightarrow> Class \<Rightarrow> Class"
  (infixl "\<setminus>" 80)
where "X\<setminus>Y \<equiv> X \<inter> (Co(Y))"

text{* The last abbreviation in Mendelson's list of page 231
       is one for the universal set. We have this already so we
       prove the following lemma instead. *}

text{* The following is Exercise 4.9 in Mendelson. *}

lemma Ex4_9_a: "\<forall>u :: Set. u \<in> X \<union> Y \<longleftrightarrow> u \<in> X \<or> u \<in> Y"
  by (simp add: B2 B3)

lemma Ex4_9_b: "\<forall>u :: Set. u \<in> \<V>"
  by (metis Quotient_Set Quotient_rep_reflp Quotient_to_Domainp Set.domain_eq Set.pcr_cr_eq)

lemma Ex4_9_c: "\<forall>u::Set. u \<in> X \<setminus> Y \<longleftrightarrow> u \<in> X \<and> u \<notin> Y"
  by (simp add: B2 B3)

lemma Ex4_10_a: "X \<inter> Y = Y \<inter> X"
using Ex4_2 B2 by auto

lemma Ex4_10_b: "X \<union> Y = Y \<union> X"
using Ex4_2 B2 B3 by auto

lemma Ex4_10_c: "X \<subseteq> Y \<longleftrightarrow> (X \<inter> Y = X)"
proof
  assume "X \<subseteq> Y"
  with subclass'_def B2 Ex4_2 show "X \<inter> Y = X" by auto
  next
  assume assm: "X \<inter> Y = X"
  have "\<forall>Z. (Z \<in> X \<longrightarrow> Z \<in> Y)"
  proof
    fix Z
    show "Z \<in> X \<longrightarrow> Z \<in> Y"
    proof (rule ccontr, simp)
      assume assm2: "Z \<in> X \<and> Z \<notin> Y"
      then have "Z \<notin> Y" ..
      with assm B2 have "Z \<notin> X" by (metis Abs_Set_inverse Ex4_1 mem_Collect_eq universe)
      with assm2 show "False" by simp
    qed
  qed
  with subclass'_def show "X \<subseteq> Y" by auto
qed

lemma Ex4_10_d: "X \<subseteq> Y \<longleftrightarrow> (X \<union> Y = Y)"
proof
  show "X \<subseteq> Y \<Longrightarrow> X \<union> Y = Y" using Ex4_2 B2 B3 subclass'_def by auto
  next
  assume assm: "X \<union> Y = Y"
  have "\<forall>Z \<in> X. (Z \<in> Y)" unfolding forall_in_def
  proof
    fix Z::Set
    show "Z \<in> X \<longrightarrow> Z \<in> Y"
    proof (rule ccontr, simp)
      assume assm1: "Z \<in> X \<and> Z \<notin> Y"
      then have "Z \<notin> Y" ..
      with assm have "Z \<notin> X \<union> Y" by simp
      then have "Z \<notin> X" using Ex4_9_a by blast
      with assm1 show "False" by simp
    qed
  qed
  with subclass'_def forall_in_def  show "X \<subseteq> Y" by (metis Abs_Set_inverse CollectI Ex4_1 universe)
qed

lemma Ex4_10_e: "(X \<inter> Y) \<inter> Z = X \<inter> (Y \<inter> Z)"
using Ex4_2 B2 by auto

lemma Ex4_10_f: "(X \<union> Y) \<union> Z = X \<union> (Y \<union> Z)"
using Ex4_2 B2 B3 by auto

lemma Ex4_10_g: "X \<inter> X = X"
using Ex4_2 B2 by auto

lemma Ex4_10_h: "X \<union> X = X"
using Ex4_2 B2 B3 by auto

lemma Ex4_10_i: "X \<inter> \<emptyset> = \<emptyset>"
using Ex4_2 empty_set B2 by auto

lemma Ex4_10_j: "X \<union> \<emptyset> = X"
using Ex4_2 empty_set B2 B3 by auto

lemma Ex4_10_k: "X \<inter> \<V> = X"
proof -
  have "\<forall>x::Set. x \<in> X \<inter> \<V> \<longleftrightarrow> x \<in> X"
  proof
    fix x
    show "x \<in> X \<inter> \<V> = x \<in> X"
    proof
      assume "x \<in> X \<inter> \<V>"
      with B2 show "x \<in> X" using Ex4_1 Ex4_10_c subclass'_def universe by metis
      next
      show "x \<in> X \<Longrightarrow> x \<in> X \<inter> \<V>" using Ex4_1 Ex4_10_c subclass'_def universe by metis
    qed
  qed
  then show "X \<inter> \<V> = X" using Ex4_2 by simp
qed

lemma Ex4_10_l: "X \<union> \<V> = \<V>"
using Ex4_10_h Ex4_10_i by (metis Ex4_10_a Ex4_10_j Ex4_10_k)

lemma Ex4_10_m: "Co(X \<union> Y) = Co(X) \<inter> Co(Y)"
using Ex4_10_g Ex4_10_h by auto

lemma Ex4_10_n: "Co(X \<inter> Y) = Co(X) \<union> Co(Y)"
using Ex4_10_g Ex4_10_h by auto

lemma Ex4_10_o: "X\<setminus>X = \<emptyset>"
using B2 B3 Ex4_2 empty_set by auto

lemma Ex4_10_p: "\<V>\<setminus>X = Co(X)"
using Ex4_10_k Ex4_10_a by metis

lemma Ex4_10_q: "X \<setminus> (X \<setminus> Y) = X \<inter> Y"
proof -
  from B2 have "\<forall>x::Set. x \<in> X \<inter> (Co(X \<inter> Co(Y))) \<longleftrightarrow> x \<in> X \<and> x \<in> Co(X \<inter> Co(Y))" by simp
  with B3 have "\<forall>x::Set. x \<in> X \<inter> (Co(X \<inter> Co(Y))) \<longleftrightarrow> x \<in> X \<and> x \<notin> (X \<inter> Co(Y))" by simp
  with B2 have "\<forall>x::Set. x \<in> X \<inter> (Co(X \<inter> Co(Y))) \<longleftrightarrow> x \<in> X \<and> x \<notin> Co(Y)" by auto
  with B3 have "\<forall>x::Set. x \<in> X \<inter> (Co(X \<inter> Co(Y))) \<longleftrightarrow> x \<in> X \<and> x \<in> Y" by simp
  with B2 have "\<forall>x::Set. x \<in> X \<inter> (Co(X \<inter> Co(Y))) \<longleftrightarrow> x \<in> X \<inter> Y" by simp
  then show "X \<inter> (Co(X \<inter> Co(Y))) = X \<inter> Y" using Ex4_2 by simp
qed

lemma Ex4_10_r: "Y \<subseteq> Co(X) \<longrightarrow> X \<setminus> Y = X" by (metis Ex4_10_a Ex4_10_d Ex4_10_g Ex4_10_h)

lemma Ex4_10_s: "Co(Co(X)) = X" using Ex4_10_g Ex4_10_h by auto

lemma Ex4_10_t: "Co(\<V>) = \<emptyset>" by (metis Ex4_10_o Ex4_10_p)

lemma Ex4_10_u: "X \<inter> (Y \<union> Z) = (X \<inter> Y) \<union> (X \<inter> Z)"
using B2 B3 Ex4_2 Ex4_9_a by auto

lemma Ex4_10_v: "X \<union> (Y \<inter> Z) = (X \<union> Y) \<inter> (X \<union> Z)"
using B2 B3 Ex4_9_a Ex4_2  by auto

text{* Exercise 4.11. *}

lemma Ex_4_11_a: "\<forall>X. \<exists>Z. \<forall>u v. \<langle>u, v\<rangle> \<in> Z \<longleftrightarrow> \<langle>v, u\<rangle> \<in> X"
proof
  fix X
  obtain C where "\<forall>u v w. \<langle>v, u, w\<rangle> \<in> C \<longleftrightarrow> \<langle>v, u\<rangle> \<in> X" using B5 by blast
  moreover obtain D where "\<forall>u v w. \<langle>v, w, u\<rangle> \<in> D \<longleftrightarrow> \<langle>v, u, w\<rangle> \<in> C" using B7 by blast
  moreover obtain E where "\<forall>u v w. \<langle>u, v, w\<rangle> \<in> E \<longleftrightarrow> \<langle>v, w, u\<rangle> \<in> D" using B6 by blast
  ultimately have "\<forall>u v. \<langle>u, v\<rangle> \<in> dom(E) \<longleftrightarrow> \<langle>v, u\<rangle> \<in> X" using B4 by simp
  thus "\<exists>Z. \<forall>u v. \<langle>u, v\<rangle> \<in> Z \<longleftrightarrow> \<langle>v, u\<rangle> \<in> X" ..
qed

lemma Ex_4_11_b: "\<forall>X. \<exists>Z. \<forall>u v w. \<langle>u, v, w\<rangle> \<in> Z \<longleftrightarrow> \<langle>u, w\<rangle> \<in> X"
proof
  fix X
  obtain C where "\<forall>u v w. \<langle>u, w, v\<rangle> \<in> C \<longleftrightarrow> \<langle>u, w\<rangle> \<in> X" using B5 by blast
  moreover obtain D where "\<forall>u v w. \<langle>u, v, w\<rangle> \<in> D \<longleftrightarrow> \<langle>u, w, v\<rangle> \<in> C" using B7 by blast
  ultimately show "\<exists>Z. \<forall>u v w. \<langle>u, v, w\<rangle> \<in> Z \<longleftrightarrow> \<langle>u, w\<rangle> \<in> X" by blast
qed

lemma Ex_4_11_c: "\<forall>X. \<exists>Z. \<forall>v. \<forall>i :: nat \<Rightarrow> Set. \<langle>\<dots>, i(n), v\<rangle> \<in> Z \<longleftrightarrow> \<langle>\<dots>, i(n)\<rangle> \<in> X"
using B5 by blast

(* page 232 *)

lemma Ex_4_11_d: "\<forall>X. \<exists>Z. \<forall>i :: nat \<Rightarrow> Set. ( \<langle>\<dots>,i(n + k)\<rangle> \<in> Z \<longleftrightarrow> \<langle>\<dots>,i(n)\<rangle> \<in> X)"
proof (induction k, simp_all, blast)
  fix k::nat
  assume IH:  "\<forall>X. \<exists>Z. \<forall>i. (\<langle>\<dots>, i(n + k)\<rangle>) \<in> Z \<longleftrightarrow> \<langle>\<dots>, i(n)\<rangle> \<in> X"
  show "\<forall>X. \<exists>Z. \<forall>i. \<langle>\<dots>, i(n + k), i(Suc (n + k))\<rangle> \<in> Z \<longleftrightarrow> \<langle>\<dots>, i(n)\<rangle> \<in> X"
  proof (rule allI)
    fix X::Class
    obtain C where C_def: "\<forall>i. \<langle>\<dots>, i(n + k)\<rangle> \<in> C \<longleftrightarrow> \<langle>\<dots>, i(n)\<rangle> \<in> X" using IH by blast
    obtain D where "\<forall>v. \<forall>i. \<langle>\<dots>, i(n + k), v\<rangle> \<in> D \<longleftrightarrow> \<langle>\<dots>, i(n + k)\<rangle> \<in> C"
      using Ex_4_11_c by blast
    hence "\<forall>i. \<langle>\<dots>, i(Suc (n + k))\<rangle> \<in> D \<longleftrightarrow> \<langle>\<dots>, i(n + k)\<rangle> \<in> C" using Tuple_All by simp
    thus "\<exists>Z. \<forall>i. \<langle>\<dots>, i(n + k), i(Suc (n + k))\<rangle> \<in> Z \<longleftrightarrow> \<langle>\<dots>, i(n)\<rangle> \<in> X"
      using C_def by auto
  qed
qed

lemma Ex4_11_e: "\<forall>X. \<exists>Z. \<forall>x::nat\<Rightarrow>Set. \<forall>xn::Set. (\<langle>\<dots>, x(k + m), xn\<rangle> \<in> Z \<longleftrightarrow> \<langle>\<dots>, x(k), xn\<rangle> \<in> X)"
proof (induct m)
  show "\<forall>X. \<exists>Z. \<forall>x xn. \<langle>\<dots>,x(k + 0), xn\<rangle> \<in> Z \<longleftrightarrow> \<langle>\<dots>,x(k), xn\<rangle> \<in> X" by auto
  fix m
  assume "\<forall>X. \<exists>Z. \<forall>x::nat\<Rightarrow>Set. \<forall>xn::Set. \<langle>\<dots>, x(k + m), xn\<rangle> \<in> Z \<longleftrightarrow> \<langle>\<dots>, x(k), xn\<rangle> \<in> X"
  thus "\<forall>X. \<exists>Z. \<forall>x::nat\<Rightarrow>Set. \<forall>xn::Set. \<langle>\<dots>, x(k + Suc m), xn\<rangle> \<in> Z \<longleftrightarrow> \<langle>\<dots>, x(k), xn\<rangle> \<in> X"
  proof -
    fix m::nat
    assume IA: "\<forall>X. \<exists>Z. \<forall>x::nat\<Rightarrow>Set. \<forall>xn::Set. \<langle>\<dots>, x(k + m), xn\<rangle> \<in> Z \<longleftrightarrow> \<langle>\<dots>, x(k), xn\<rangle> \<in> X"
    show "\<forall>X. \<exists>Z. \<forall>x::nat\<Rightarrow>Set. \<forall>xn::Set. \<langle>\<dots>, x(k + Suc m), xn\<rangle> \<in> Z  \<longleftrightarrow> \<langle>\<dots>, x(k), xn\<rangle> \<in> X"
    proof
      fix X
      have "\<exists>Z. \<forall>x::nat\<Rightarrow>Set. \<forall>xn::Set. \<forall>v. (\<langle>\<dots>, x(k+m), v, xn\<rangle> \<in> Z \<longleftrightarrow> \<langle>\<dots>, x(k+m), xn\<rangle> \<in> X)"
        using Ex_4_11_b by blast
      then obtain Z1 where "\<forall>x. \<forall>xn. \<forall>v.   (\<langle>\<dots>, x(k+m), v, xn\<rangle> \<in> Z1 \<longleftrightarrow> \<langle>\<dots>, x(k+m), xn\<rangle> \<in> X)"
        by blast
      from IA have "\<exists>Z. \<forall>x::nat\<Rightarrow>Set. \<forall>xn::Set. \<langle>\<dots>, x(k+m), xn\<rangle> \<in> Z \<longleftrightarrow> \<langle>\<dots>, x(k),xn\<rangle> \<in> X"
        by blast
      then obtain Z2 where z2: "\<forall>x::nat\<Rightarrow>Set. \<forall>xn::Set. \<langle>\<dots>, x(k+m), xn\<rangle> \<in> Z2 \<longleftrightarrow> \<langle>\<dots>, x(k), xn\<rangle> \<in> X"
        by blast
      have "\<exists>Z. \<forall>x::nat\<Rightarrow>Set. \<forall>xn::Set. \<forall>v. (\<langle>\<dots>, x(k+m), v, xn\<rangle> \<in> Z \<longleftrightarrow> \<langle>\<dots>, x(k+m), xn\<rangle> \<in> Z2)"
        using Ex_4_11_b by blast
      hence *: "\<exists>Z. \<forall>x::nat\<Rightarrow>Set. \<forall>xn::Set. \<forall>v. (\<langle>\<dots>, x(k+m), v, xn\<rangle> \<in> Z \<longleftrightarrow> \<langle>\<dots>, x(k), xn\<rangle> \<in> X)"
        using z2 by blast
      then obtain Z where z_def: "\<forall>x::nat\<Rightarrow>Set. \<forall>xn::Set. \<forall>v.
        (\<langle>\<dots>, x(k+m), v, xn\<rangle> \<in> Z \<longleftrightarrow> \<langle>\<dots>,x(k), xn\<rangle> \<in> X)" by blast
      have #: "\<forall>Z. \<forall>xn::Set. \<forall>x::nat\<Rightarrow>Set. \<exists>v.
        (\<langle>\<dots>, x(k + Suc m), xn\<rangle> \<in> Z \<longleftrightarrow> \<langle>\<dots>, x(k+m), v, xn\<rangle> \<in> Z)" by auto
      then have "\<forall>xn::Set. \<forall>x::nat\<Rightarrow>Set. (\<langle>\<dots>, x(k + Suc m), xn\<rangle> \<in> Z \<longleftrightarrow> \<langle>\<dots>, x(k), xn\<rangle> \<in> X)"
        using z_def by blast
      then show "\<exists>Z. \<forall>x::nat\<Rightarrow>Set. \<forall>xn::Set. \<langle>\<dots>, x(k + Suc m), xn\<rangle> \<in> Z \<longleftrightarrow> \<langle>\<dots>, x(k), xn\<rangle> \<in> X"
        by auto
    qed
  qed
qed

lemma Ex_4_11_f: "\<forall>X. \<exists>Z. \<forall>x. \<forall>v :: nat \<Rightarrow> Set. \<langle>\<dots>, v(m), x\<rangle> \<in> Z \<longleftrightarrow> x \<in> X"
proof
  fix X
  obtain C where "\<forall>u x. \<langle>x, u\<rangle> \<in> C \<longleftrightarrow> x \<in> X" using B5 by blast
  then obtain D where "\<forall>u x. \<langle>u, x\<rangle> \<in> D \<longleftrightarrow> x \<in> X" using Ex_4_11_a by fast
  then show "\<exists>Z. \<forall>x. \<forall>v :: nat \<Rightarrow> Set. \<langle>\<dots>, v(m), x\<rangle> \<in> Z \<longleftrightarrow> x \<in> X" by blast
qed

lemma Ex4_11_g: "\<forall>X. \<exists>Z. \<forall>x::nat\<Rightarrow>Set. \<langle>\<dots>, x(n)\<rangle> \<in> Z \<longleftrightarrow> (\<exists>y::Set. \<langle>\<dots>, x(n), y\<rangle> \<in> X)"
using B4 by blast

text{* \textbf{FOMUS workshop extra exercise:} *}

lemma Ex4_11_h: "\<forall>X. \<exists>Z. \<forall>u v w::Set. (\<langle>v, u, w\<rangle> \<in> Z \<longleftrightarrow> \<langle>u, w\<rangle> \<in> X)"
sorry

lemma Ex4_11_i: "\<forall>X. \<exists>Z. \<forall>v::nat\<Rightarrow>Set. \<forall>u w::Set. \<langle>\<dots>, v(n), u, w\<rangle> \<in> Z \<longleftrightarrow> \<langle>u, w\<rangle> \<in> X"
using Ex4_11_h by blast

end