theory TC_To_ChrN
  imports Main "HOL-ex.Sketch_and_Explore" "HOL-Eisbach.Eisbach" "../CNF_SAT_To_TC/TS_To_TC" "TC_To_ChrN_Aux"
begin

subsection "Chromatic number definitions"

definition "chromaticNumber \<equiv> {(E,k). \<exists>c_Sets. is_k_colorable E k c_Sets \<and> k \<ge> 3}"

definition
  "TC_chrN E \<equiv> if (ugraph E) then ((
  {{(v1::nat,0::nat),(v2,0)}|v1 v2. {v1,v2}\<in> E} \<union>
  {{(v1,0),(0,k)}|v1 k. v1\<in> (\<Union> E) \<and> k \<in> {1..(card (\<Union>E))}} \<union>
  {{(0,k),(0,k')}|k k'. k \<in> {1..(card (\<Union>E))} \<and> k' \<in> {1..(card (\<Union>E))} \<and> k \<noteq> k'})
  ,(card (\<Union> E)+3))
else ({},0::nat)"

subsection "chromatic number lemmas"

lemma TC_chrN_edge_in_E_iff:"ugraph E \<Longrightarrow> {v1,v2} \<in> E  \<longleftrightarrow> {(v1::nat,0::nat),(v2,0)} \<in> fst(TC_chrN E)"
proof safe
  assume asms: "ugraph E" "{v1, v2} \<in> E "
  then show "{(v1, 0), (v2, 0)} \<in> fst (TC_chrN E)"
    unfolding TC_chrN_def
    by fastforce
next
  fix E v1 v2
  assume asms: "ugraph E" "{(v1, 0), (v2, 0)} \<in> fst (TC_chrN E)"
  obtain E' where E'_def2:"E' = fst (TC_chrN E)"
    by blast
  define E_nodes where E_nodes_def:
    "E_nodes = {{(v1::nat,0::nat),(v2,0)}|v1 v2. {v1,v2}\<in> E}"
  define con_nodes where con_nodes_def:
    "con_nodes = {{(v1,0),(0,k)}|v1 k. v1\<in> (\<Union> E) \<and> k \<in> {1..(card (\<Union>E))}}"
  define E'nodes where E'nodes_def:
    "E'nodes = {{(0::nat,k),(0,k')}|k k'. k \<in> {1..(card (\<Union>E))} \<and> k' \<in> {1..(card (\<Union>E))} \<and> k \<noteq> k'}"
  from asms(1) E'_def2 have E'_def: "E' = E_nodes \<union> con_nodes \<union> E'nodes"
    unfolding TC_chrN_def
    by (simp add: E_nodes_def con_nodes_def E'nodes_def)
  from E'_def2 asms(2) have v1v2inE':"{(v1, 0), (v2, 0)} \<in> E'"
    by blast
  from E'nodes_def have notin1:"{(v1, 0), (v2, 0)} \<notin> E'nodes"
    by fastforce
  have notZeroNode:"\<And>e. e\<in>con_nodes \<Longrightarrow> \<exists> a b. (a,b) \<in> e \<and> b \<noteq> 0"
    unfolding con_nodes_def
    by force
  have "\<And> a b c d. {(a, b), (c, d)} \<in> con_nodes \<Longrightarrow> b \<noteq> 0 \<or> d \<noteq> 0"
    using con_nodes_def notZeroNode
    by auto
  from this have notin2:"{(v1, 0), (v2, 0)} \<notin> con_nodes"
    by blast
  from notin1 notin2 v1v2inE' E'_def  have "{(v1, 0), (v2, 0)} \<in> E_nodes"
    by blast
  then show "{v1, v2} \<in> E"
    unfolding E_nodes_def
    by (smt doubleton_eq_iff mem_Collect_eq prod_set_simps(1))
qed

lemma nodesChromGraph:
    "(E',k) = TC_chrN E \<Longrightarrow> ugraph E \<Longrightarrow> \<Union>E' = \<Union>{{(v,0)}|v. v\<in>\<Union>E} \<union> \<Union>{{(0,n)|n. n\<in>{1..card (\<Union>E)}}}"
proof -
  fix E E' k
  assume asms:"(E',k) = TC_chrN E" "ugraph E"
  from asms have E_ugraph: "ugraph E"
    by blast
  from asms have E'_def2:"E' =
    {{(v1,0::nat),(v2,0)}|v1 v2. {v1,v2}\<in> E} \<union>
    {{(v1,0),(0,k)}|v1 k. v1\<in> (\<Union> E) \<and> k \<in> {1..(card (\<Union>E))} } \<union>
    {{(0, k), (0, k')} |k k'. k \<in> {1..card (\<Union> E)} \<and> k' \<in> {1..card (\<Union> E)} \<and> k \<noteq> k'}"
  unfolding TC_chrN_def
  by auto
  from E'_def2 have "\<Union>E' = \<Union> ({{(v1,0::nat),(v2,0)}|v1 v2. {v1,v2}\<in> E} \<union>
      {{(v1,0),(0,k)}|v1 k. v1\<in> (\<Union> E) \<and> k \<in> {1..(card (\<Union>E))} } \<union>
      {{(0, k), (0, k')} |k k'. k \<in> {1..card (\<Union> E)} \<and> k' \<in> {1..card (\<Union> E)} \<and> k \<noteq> k'})"
    by fastforce
  from E'_def2 have nodes_split1:"\<Union>E' = ( \<Union> {{(v1,0::nat),(v2,0)}|v1 v2. {v1,v2}\<in> E} \<union>
       \<Union> {{(v1,0),(0,k)}|v1 k. v1\<in> (\<Union> E) \<and> k \<in> {1..(card (\<Union>E))} } \<union>
       \<Union> {{(0, k), (0, k')} |k k'. k \<in> {1..card (\<Union> E)} \<and> k' \<in> {1..card (\<Union> E)} \<and> k \<noteq> k'})"
    by simp
  from this have nodes_split2:"\<Union> {{(v1,0),(0,k)}|v1 k. v1\<in> (\<Union> E) \<and> k \<in> {1..(card (\<Union>E))}} =
                  \<Union> {{(0,k)}|v1 k. v1\<in> (\<Union> E) \<and> k \<in> {1..(card (\<Union>E))}} \<union>
                  \<Union> {{(v1,0)}|v1 k. v1\<in> (\<Union> E) \<and> k \<in> {1..(card (\<Union>E))}}"
    by blast
  define node_split1 where node_split1_def:"node_split1= \<Union> ({{(v1,0::nat),(v2,0)}|v1 v2. {v1,v2}\<in> E})"
  define node_split2 where node_split2_def:"node_split2= \<Union> {{(0::nat,k)}|v1 k. v1\<in> (\<Union> E) \<and> k \<in> {1..(card (\<Union>E))}}"
  define node_split3 where node_split3_def:"node_split3= \<Union> {{(v1,0::nat)}|v1 k. v1\<in> (\<Union> E) \<and> k \<in> {1..(card (\<Union>E))}}"
  define node_split4 where node_split4_def:"node_split4=
            \<Union> {{(0::nat, k), (0, k')} |k k'. k \<in> {1..card (\<Union> E)} \<and> k' \<in> {1..card (\<Union> E)} \<and> k \<noteq> k'}"

  from nodes_split2 nodes_split1 have nodes_split:"\<Union>E' = node_split1 \<union>  node_split2 \<union>  node_split3 \<union>  node_split4"
    apply (simp add: node_split1_def node_split2_def node_split3_def node_split4_def)
    by auto
  have node_split_eq2':"\<Union>{{(v1,0)}|v1 k. v1\<in> (\<Union> E) \<and> k \<in> {1..(card (\<Union>E))}} =
        \<Union>{{(v1,0)}|v1. v1\<in> (\<Union> E)}"
  proof safe
    show "\<And>a b X v1 k Xa. k \<in> {1..card (\<Union> E)} \<Longrightarrow> v1 \<in> Xa \<Longrightarrow> Xa \<in> E \<Longrightarrow>
          (v1, 0) \<in> \<Union> {{(v1, 0)} |v1. v1 \<in> \<Union> E}"
      by blast
  next
    fix e
    fix v
    assume asms: "v\<in> e" "e: E"
    from asms(2) have "card e = 2"
      using E_ugraph
      unfolding ugraph_def
      by blast
    from this asms(2) have "card (\<Union> E) \<noteq> 0"
      by (metis E_ugraph Sup_upper card.infinite card_mono finite_Union
          not_numeral_le_zero ugraph_def zero_neq_numeral)
    from this asms show "(v, 0) \<in> \<Union> {u. \<exists>v1 k. u = {(v1, 0)} \<and> v1 \<in> \<Union> E \<and> k \<in> {1..card (\<Union> E)}}"
      using Icc_eq_insert_lb_nat by auto
  qed
  have node_split_eq3':"\<Union> {{(v1,0::nat),(v2,0)}|v1 v2. {v1,v2}\<in> E} = \<Union>{{(v,0::nat)}|v. v\<in>\<Union>E}"
  proof safe
    show "\<And>a b X v1 v2. {v1, v2} \<in> E \<Longrightarrow> (v1, 0) \<in> \<Union> {{(v, 0)} |v. v \<in> \<Union> E}" by blast
  next
    show "\<And>a b X v1 v2. {v1, v2} \<in> E \<Longrightarrow> (v2, 0) \<in> \<Union> {{(v, 0)} |v. v \<in> \<Union> E}" by blast
  next
    fix e
    fix v
    assume asms:"e \<in> E" "v\<in>e"
    from E_ugraph asms(1) have "card e = 2"
      unfolding ugraph_def
      by blast
    from this obtain v' where "e = {v, v'}"
      by (metis asms(2) card_2_iff doubleton_eq_iff insertE singleton_iff)
    from this asms(1) have "{v,v'} \<in> E"
      by blast
    from this show "(v, 0) \<in> \<Union> {{(v1, 0), (v2, 0)} |v1 v2. {v1, v2} \<in> E}"
      by blast
  qed
  have node_split_eq4':"\<Union> {{(0, k), (0, k')} |k k'. k \<in> {1..card (\<Union> E)} \<and> k' \<in> {1..card (\<Union> E)} \<and> k \<noteq> k'} =
        \<Union>{{(0,n)|n. n\<in>{1..card (\<Union>E)}}}"
  proof safe
    show "\<And>a b X k k'.
       k \<in> {1..card (\<Union> E)} \<Longrightarrow> k' \<in> {1..card (\<Union> E)} \<Longrightarrow> k \<noteq> k' \<Longrightarrow> (0, k) \<in> \<Union> {{(0, n) |n. n \<in> {1..card (\<Union> E)}}}"
      by blast
  next
    show "\<And>a b X k k'.
       k \<in> {1..card (\<Union> E)} \<Longrightarrow> k' \<in> {1..card (\<Union> E)} \<Longrightarrow> k \<noteq> k' \<Longrightarrow> (0, k') \<in> \<Union> {{(0, n) |n. n \<in> {1..card (\<Union> E)}}}"
      by blast
  next
    fix n ::nat
    assume asms:" n \<in> {1..card (\<Union> E)}"
    from this have asm1:"1 \<le> n"
      by simp
    from asms have asm2:"n\<le>card (\<Union> E)"
      by simp
    from asm1 asm2 have card1:"1 \<le> card (\<Union> E)"
      by linarith
    from this obtain e where e_def: "e\<in> E"
      by fastforce
    from this E_ugraph have "card e = 2"
      unfolding ugraph_def
      by blast
    from this e_def card1 have  "2 \<le> card (\<Union> E)"
      by (metis One_nat_def Suc_le_eq Union_upper card_ge_0_finite card_mono)
    from this obtain n'::"nat" where "n'\<in> {1..card (\<Union> E)} \<and> n \<noteq> n'"
      by (metis atLeastAtMost_iff card1 numeral_le_one_iff order_refl semiring_norm(69))
    from this asms show "(0, n) \<in> \<Union> {{(0, k), (0, k')} |k k'. k \<in> {1..card (\<Union> E)} \<and>
                                                         k' \<in> {1..card (\<Union> E)} \<and> k \<noteq> k'}"
      by blast
  qed
  have node_split_eq1:"node_split2 =
                  \<Union> {{(0,k)}|k. k \<in> {1..(card (\<Union>E))}}"
    apply (simp add: node_split2_def)
    by (metis (mono_tags, opaque_lifting) Sup_bot_conv(2)
        all_not_in_conv card.empty not_less_eq_eq)
  from node_split_eq2' have node_split_eq2: "node_split3 = \<Union>{{(v,0)}|v. v\<in> (\<Union> E)}"
    by (simp add: node_split3_def)
  from node_split_eq3' have node_split_eq3: "node_split1 = \<Union>{{(v,0::nat)}|v. v\<in>\<Union>E}"
    by (simp add: node_split1_def)
  from node_split_eq4' have node_split_eq4:"node_split4 = \<Union>{{(0,n)|n. n\<in>{1..card (\<Union>E)}}}"
    by (simp add: node_split4_def)
  from node_split_eq1 node_split_eq2 node_split_eq3 node_split_eq4 nodes_split have node_split_eq5:
    "\<Union>E' = \<Union>{{(v,0)}|v. v\<in>\<Union>E} \<union> \<Union>{{(0,n)|n. n\<in>{1..card (\<Union>E)}}}"
    by auto
  from this show "\<Union> E' = \<Union> {{(v, 0)} |v. v \<in> \<Union> E} \<union> \<Union> {{(0, n) |n. n \<in> {1..card (\<Union> E)}}}"
    by blast
qed

subsection "Three colorability to chromatic number"

lemma threeColToChroN:"\<And>E. E \<in> three_colorability \<Longrightarrow> TC_chrN E \<in> chromaticNumber"
proof -
  fix E :: "nat set set"
  assume asms:"E \<in> three_colorability"
  from asms obtain c1 c2 c3 where c_Sets_def:"is_k_colorable E 3 {c1,c2,c3} \<and> c1 \<noteq> c2  \<and> c1 \<noteq> c3  \<and> c2 \<noteq> c3 "
    unfolding three_colorability_def
    by (smt card_dif_elements choice3 insert_commute is_k_colorable_def mem_Collect_eq)
  from asms have E_ugraph:"ugraph E"
    unfolding three_colorability_def is_k_colorable_def is_colorable_def
    by blast
  obtain E' k where E'_def:"(E', k) = TC_chrN E"
    by (metis surj_pair)
  from E'_def E_ugraph have E'_def2:"E' =
      {{(v1,0::nat),(v2,0)}|v1 v2. {v1,v2}\<in> E} \<union>
      {{(v1,0),(0,k)}|v1 k. v1\<in> (\<Union> E) \<and> k \<in> {1..(card (\<Union>E))} } \<union>
      {{(0, k), (0, k')} |k k'. k \<in> {1..card (\<Union> E)} \<and> k' \<in> {1..card (\<Union> E)} \<and> k \<noteq> k'}"
    unfolding TC_chrN_def
    by auto
  from E'_def E_ugraph have k_def:"k = (card (\<Union> E)+3)"
    unfolding TC_chrN_def
    by simp

  from E'_def2 E_ugraph have E'_ugraph:"ugraph E'"

  proof -
    from E'_def2 E_ugraph have "finite E'"
      unfolding ugraph_def
      using chromatik_finite1 chromatik_finite2 chromatik_finite3
      by (smt E'_def E_ugraph card_eq_0_iff finite_UnI finite_Union
          prod.inject TC_chrN_def zero_neq_numeral)
    moreover from E'_def2 E_ugraph have "(\<forall>e\<in>{{(v1::nat, 0::nat), (v2, 0)} |v1 v2. {v1, v2} \<in> E}. card e = 2)"
      using chromatik_card2
      by blast
    moreover from E'_def2 E_ugraph have "(\<forall>e\<in>{{(v1, 0), (0, k)} |v1 k. v1 \<in> \<Union> E \<and> k \<in> {1..card (\<Union> E)}}. card e = 2)"
      by force
    ultimately show "ugraph E'"
      unfolding ugraph_def
      by (auto simp: E'_def2)
  qed

  obtain c_Sets' where c_Sets'_def: "c_Sets'={\<Union>{{(v,0)}|v. v:c1} , \<Union>{{(v,0)}|v. v:c2} , \<Union>{{(v,0)}|v. v:c3}}
                                            \<union> {{(0,n)}|n. n \<in> {1..card (\<Union> E)}}"
    by blast

  from E'_def E_ugraph have node_split_eq5:
    "\<Union>E' = \<Union>{{(v,0)}|v. v\<in>\<Union>E} \<union> \<Union>{{(0,n)|n. n\<in>{1..card (\<Union>E)}}}"
    using nodesChromGraph
    by presburger

  have node_split_eq6:"\<Union>{{(v,0::nat)}|v. v\<in>\<Union>E} =
    \<Union>{\<Union> {{(v, 0::nat)} |v. v \<in> c1}, \<Union> {{(v, 0)} |v. v \<in> c2}, \<Union> {{(v, 0)} |v. v \<in> c3}}"
  proof -
    define step1 where step1_def:"step1= \<Union> {{(v, 0::nat)} |v. v \<in> \<Union> E}"
    define step2 where step2_def:"step2= \<Union>({{(v,0::nat)}|v. v\<in>c1 \<or> v\<in> c2 \<or> v\<in> c3 })"
    define step3 where step3_def:"step3= \<Union> {\<Union> {{(v, 0::nat)} |v. v \<in> c1},
                                            \<Union> {{(v, 0)} |v. v \<in> c2},
                                            \<Union> {{(v, 0)} |v. v \<in> c3}}"
    from c_Sets_def have "\<Union>E = \<Union>{c1,c2,c3}"
      unfolding is_k_colorable_def is_colorable_def
      by linarith
    from this step2_def step1_def have step1:"step1 =step2"
      by auto
    have "\<Union>({{(v,0)}|v. v\<in>c1 \<or> v\<in> c2 \<or> v\<in> c3 }) =
                    \<Union>{\<Union> {{(v, 0::nat)} |v. v \<in> c1}, \<Union> {{(v, 0)} |v. v \<in> c2}, \<Union> {{(v, 0)} |v. v \<in> c3}}"
      by blast
    from this step2_def step3_def have step2:"step2 = step3"
      by simp
    from step1 step2 have "step1 = step3"
      by simp
    from this show ?thesis
      by (simp add: step1_def step3_def)
  qed

  from node_split_eq5 node_split_eq6 c_Sets'_def have c_Sets'_complete:"\<Union>E' = \<Union>c_Sets'"
  proof -
    define step1 where step1_def:"step1= \<Union>{{(v,0::nat)}|v. v\<in>\<Union>E}"
    define step2 where step2_def:"step2= \<Union>{{(0::nat,n)|n. n\<in>{1..card (\<Union>E)}}}"
    define step3 where step3_def:"step3= \<Union>{\<Union> {{(v, 0::nat)} |v. v \<in> c1}, \<Union> {{(v, 0)} |v. v \<in> c2},
                                            \<Union> {{(v, 0)} |v. v \<in> c3}}"
    from node_split_eq5 have E'eq:
      "\<Union>E' =step1 \<union> step2"
      by (simp add: step1_def step2_def)
    from node_split_eq6 have "step1 =  step3"
       by (simp add: step1_def step3_def)
    from E'eq this have "\<Union>E' = step3 \<union> step2"
      by fast
    from this show ?thesis
      apply (simp add: step2_def step3_def c_Sets'_def)
      by blast
  qed

  have EgraphE'nodesdisjoint:"{\<Union>{{(v,0)}|v. v:c1} , \<Union>{{(v,0)}|v. v:c2} , \<Union>{{(v,0)}|v. v:c3}}
                                            \<inter> {{(0,n)}|n. n \<in> {1..card (\<Union> E)}} = {}"
    by fastforce

  from c_Sets_def have c1c2_empty:"c1\<inter> c2 = {}"
    unfolding is_k_colorable_def is_colorable_def
    by auto

  from c_Sets_def have c1c3_empty:"c1\<inter> c3 = {}"
    unfolding is_k_colorable_def is_colorable_def
    by auto

  from c_Sets_def have c2c3_empty:"c2\<inter> c3 = {}"
    unfolding is_k_colorable_def is_colorable_def
    by auto

  from c1c2_empty have c1c2_empty':"\<Union>{{(v,0)}|v. v:c1} \<inter> \<Union>{{(v,0)}|v. v:c2} = {}"
    by auto

  from c1c3_empty have c1c3_empty':"\<Union>{{(v,0)}|v. v:c1} \<inter> \<Union>{{(v,0)}|v. v:c3} = {}"
    by auto

  from c2c3_empty have c2c3_empty':"\<Union>{{(v,0)}|v. v:c2} \<inter> \<Union>{{(v,0)}|v. v:c3} = {}"
    by auto

  have c1E'nodes_empty':"\<Union>{{(v,0)}|v. v:c1} \<inter> \<Union>{{(0,n)}|n. n \<in> {1..card (\<Union> E)}} = {}"
    by auto

  have c2E'nodes_empty':"\<Union>{{(v,0)}|v. v:c2} \<inter> \<Union>{{(0,n)}|n. n \<in> {1..card (\<Union> E)}} = {}"
    by auto

  have c3E'nodes_empty':"\<Union>{{(v,0)}|v. v:c3} \<inter> \<Union>{{(0,n)}|n. n \<in> {1..card (\<Union> E)}} = {}"
    by auto

  from c1c2_empty' c1c3_empty' c1E'nodes_empty' c1c3_empty have c1Csets_empty:
    "\<forall>c\<in>c_Sets'. c \<noteq> \<Union> {{(v, 0)} |v. v \<in> c1} \<longrightarrow> c \<inter> \<Union> {{(v, 0)} |v. v \<in> c1} = {}"
    by (auto simp: c_Sets'_def)

  from c1c2_empty' c2c3_empty' c2E'nodes_empty' c2c3_empty have c2Csets_empty:
    "\<forall>c\<in>c_Sets'. c \<noteq> \<Union> {{(v, 0)} |v. v \<in> c2} \<longrightarrow> c \<inter> \<Union> {{(v, 0)} |v. v \<in> c2} = {}"
    by (auto simp: c_Sets'_def)

  from c1c3_empty' c2c3_empty' c3E'nodes_empty' c2c3_empty have c3Csets_empty:
    "\<forall>c\<in>c_Sets'. c \<noteq> \<Union> {{(v, 0)} |v. v \<in> c3} \<longrightarrow> c \<inter> \<Union> {{(v, 0)} |v. v \<in> c3} = {}"
    by (auto simp: c_Sets'_def)

  have E'nodesCsets_empty:
    "\<forall>c\<in>c_Sets'. \<forall>c'\<in>{{(0,n)}|n. n \<in> {1..card (\<Union> E)}}. c \<noteq> c' \<longrightarrow> c \<inter> c' = {}"
    by (auto simp: c_Sets'_def)

  from c1Csets_empty c2Csets_empty c3Csets_empty E'nodesCsets_empty have color_disjoint:
    "\<forall>c\<in>c_Sets'. \<forall>c'\<in>c_Sets'. c \<noteq> c' \<longrightarrow> c \<inter> c' = {}"
    by (auto simp: c_Sets'_def)

  from E'_def have "E' = fst (TC_chrN E)"
    by (metis fst_conv)

  from this E_ugraph have edge_preserve:"\<forall> v1 v2. {v1,v2} \<in> E  \<longleftrightarrow> {(v1::nat,0::nat),(v2,0)} \<in>E'"
    using TC_chrN_edge_in_E_iff[where E = E]
    by auto

  from c_Sets_def have "\<forall>v\<in>c1. \<forall>v'\<in>c1. {v, v'} \<notin> E"
    unfolding is_k_colorable_def is_colorable_def
    by simp

  from this edge_preserve have c1'sound:"\<forall>v\<in>\<Union> {{(v, 0)} |v. v \<in> c1}. \<forall>v'\<in>\<Union> {{(v, 0)} |v. v \<in> c1}. {v, v'} \<notin> E'"
    by blast

  from c_Sets_def have "\<forall>v\<in>c2. \<forall>v'\<in>c2. {v, v'} \<notin> E"
    unfolding is_k_colorable_def is_colorable_def
    by simp

  from this edge_preserve have c2'sound:"\<forall>v\<in>\<Union> {{(v, 0)} |v. v \<in> c2}. \<forall>v'\<in>\<Union> {{(v, 0)} |v. v \<in> c2}. {v, v'} \<notin> E'"
    by blast

  from c_Sets_def have "\<forall>v\<in>c3. \<forall>v'\<in>c3. {v, v'} \<notin> E"
    unfolding is_k_colorable_def is_colorable_def
    by simp

  from this edge_preserve have c3'sound:"\<forall>v\<in>\<Union> {{(v, 0)} |v. v \<in> c3}. \<forall>v'\<in>\<Union> {{(v, 0)} |v. v \<in> c3}. {v, v'} \<notin> E'"
    by blast

  from E'_ugraph have E'nodes_sound:"\<forall>c\<in>{{(0,n)}|n. n \<in> {1..card (\<Union> E)}}. \<forall>v\<in>c. \<forall>v'\<in>c. {v, v'} \<notin> E'"
    unfolding ugraph_def
    by auto

  from c1'sound c2'sound c3'sound E'nodes_sound have c_Sets_sound:"\<forall>c\<in>c_Sets'. \<forall>v\<in>c. \<forall>v'\<in>c. {v, v'} \<notin> E'"
    by (simp add: c_Sets'_def)

  have c_Sets'fin1:"finite {\<Union>{{(v,0)}|v. v:c1} , \<Union>{{(v,0)}|v. v:c2} , \<Union>{{(v,0)}|v. v:c3}}"
    by blast

  have c_Sets'fin2:"finite {{(0,n)}|n. n \<in> {1..card (\<Union> E)}}"
    by simp

  from EgraphE'nodesdisjoint c_Sets'fin1 c_Sets'fin2 c_Sets'_def have c_Sets'_split:
                      "card c_Sets' =
                       card {\<Union>{{(v,0::nat)}|v. v:c1} , \<Union>{{(v,0)}|v. v:c2} , \<Union>{{(v,0)}|v. v:c3}} +
                       card {{(0::nat,n)}|n. n \<in> {1..card (\<Union> E)}}"
    using card_Un_disjoint [where A = "{\<Union>{{(v,0::nat)}|v. v:c1} , \<Union>{{(v,0)}|v. v:c2} , \<Union>{{(v,0)}|v. v:c3}}"
                              and B = "{{(0::nat,n)}|n. n \<in> {1..card (\<Union> E)}}"]
    by blast

  from c_Sets_def have c1c2_noteq:"c1 \<noteq> c2"
    by blast

  from c_Sets_def have c1c3_noteq:"c1 \<noteq> c3"
    by blast

  from c_Sets_def have c2c3_noteq:"c2 \<noteq> c3"
    by blast

  from this have c1'c2'_noteq:"\<Union>{{(v,0::nat)}|v. v:c1} \<noteq> \<Union>{{(v,0::nat)}|v. v:c2}"
  proof (cases "c1 = {}")
    case True
    from this c1c2_noteq have "c2 \<noteq> {}"
      by blast
    from this True obtain v where "v\<in>c2 \<and> v \<notin> c1"
      by blast
    from this have "(v,0::nat) \<notin> \<Union> {{(v, 0::nat)} |v. v \<in> c1} \<and>
                    (v,0::nat) \<in> \<Union> {{(v, 0::nat)} |v. v \<in> c2}"
      by blast
    then show ?thesis
      by metis
  next
    case False
    from this obtain v where "v\<in>c1 \<and> v \<notin> c2"
      using c1c2_empty by auto
    from this have "(v,0::nat) \<in> \<Union> {{(v, 0::nat)} |v. v \<in> c1} \<and>
                    (v,0::nat) \<notin> \<Union> {{(v, 0::nat)} |v. v \<in> c2}"
      by blast
    then show ?thesis
      by metis
  qed

from this have c1'c3'_noteq:"\<Union>{{(v,0::nat)}|v. v:c1} \<noteq> \<Union>{{(v,0::nat)}|v. v:c3}"
  proof (cases "c1 = {}")
    case True
    from this c1c3_noteq have "c3 \<noteq> {}"
      by blast
    from this True obtain v where "v\<in>c3 \<and> v \<notin> c1"
      by blast
    from this have "(v,0::nat) \<notin> \<Union> {{(v, 0::nat)} |v. v \<in> c1} \<and>
                    (v,0::nat) \<in> \<Union> {{(v, 0::nat)} |v. v \<in> c3}"
      by blast
    then show ?thesis
      by metis
  next
    case False
    from this obtain v where "v\<in>c1 \<and> v \<notin> c3"
      using c1c3_empty by auto
    from this have "(v,0::nat) \<in> \<Union> {{(v, 0::nat)} |v. v \<in> c1} \<and>
                    (v,0::nat) \<notin> \<Union> {{(v, 0::nat)} |v. v \<in> c3}"
      by blast
    then show ?thesis
      by metis
  qed

from this have c2'c3'_noteq:"\<Union>{{(v,0::nat)}|v. v:c2} \<noteq> \<Union>{{(v,0::nat)}|v. v:c3}"
  proof (cases "c2 = {}")
    case True
    from this c2c3_noteq have "c3 \<noteq> {}"
      by blast
    from this True obtain v where "v\<in>c3 \<and> v \<notin> c2"
      by blast
    from this have "(v,0::nat) \<notin> \<Union> {{(v, 0::nat)} |v. v \<in> c2} \<and>
                    (v,0::nat) \<in> \<Union> {{(v, 0::nat)} |v. v \<in> c3}"
      by blast
    then show ?thesis
      by metis
  next
    case False
    from this obtain v where "v\<in>c2 \<and> v \<notin> c3"
      using c2c3_empty by auto
    from this have "(v,0::nat) \<in> \<Union> {{(v, 0::nat)} |v. v \<in> c2} \<and>
                    (v,0::nat) \<notin> \<Union> {{(v, 0::nat)} |v. v \<in> c3}"
      by blast
    then show ?thesis
      by metis
  qed
  from c1'c2'_noteq c1'c3'_noteq c2'c3'_noteq have card_c_Sets1:
    "card {\<Union>{{(v,0::nat)}|v. v:c1} , \<Union>{{(v,0)}|v. v:c2} , \<Union>{{(v,0)}|v. v:c3}} = 3"
    by auto

  have card_c_Sets2:"card {{(0::nat, n)} |n. n \<in> {1..card (\<Union> E)}} = card (\<Union> E)"
    using card_additional_nodes[where x= "card (\<Union>E)"]
    by blast

  from card_c_Sets1 card_c_Sets2 c_Sets'_split have k_card: "card c_Sets' = k"
    by (simp add:  k_def c_Sets'_def)

  from k_def have kgreaterThr:"3 \<le> k"
    by simp

  from E'_def have "(E', k) \<in> chromaticNumber"
    unfolding chromaticNumber_def is_k_colorable_def is_colorable_def
    using c_Sets'_complete E'_ugraph color_disjoint c_Sets_sound k_card kgreaterThr
    by blast
  from this E'_def show "TC_chrN E \<in> chromaticNumber"
    by simp
qed

lemma chroNToThreeCol_ugraph:"\<And>E. ugraph E \<Longrightarrow> TC_chrN E \<in> chromaticNumber \<Longrightarrow> E \<in> three_colorability"
proof -
  fix E :: "nat set set"
  assume asms:"TC_chrN E \<in> chromaticNumber" "ugraph E"
  obtain E' k  where E'def_2:"(E',k)=TC_chrN E"
    by (metis surj_pair)
  from this asms have E'chrN:"(E',k) \<in> chromaticNumber"
    by simp
  from E'def_2 have E'_def_3:"fst (TC_chrN E) = E'"
    by (metis fstI)

  from E'def_2 asms have E'_def: "E' =
      {{(v1::nat,0::nat),(v2,0)}|v1 v2. {v1,v2}\<in> E} \<union>
      {{(v1,0),(0,k)}|v1 k. v1\<in> (\<Union> E) \<and> k \<in> {1..(card (\<Union>E))}} \<union>
      {{(0,k),(0,k')}|k k'. k \<in> {1..(card (\<Union>E))} \<and> k' \<in> {1..(card (\<Union>E))} \<and> k \<noteq> k'}"
    unfolding TC_chrN_def
    by simp
  from E'def_2 asms have k_def: "k =card (\<Union> E)+3"
    unfolding TC_chrN_def
    by simp
  from E'chrN obtain c_Sets' where c_Sets'_def:"is_k_colorable E' k c_Sets'"
    unfolding chromaticNumber_def
    by blast

  from c_Sets'_def k_def have c_Sets'_card:"card c_Sets' = card (\<Union> E)+3"
    unfolding is_k_colorable_def
    by blast

  from this have c_Sets'fin:"finite c_Sets'"
    using card.infinite by fastforce

  from c_Sets'_def have c_Sets'_complete:"\<Union>c_Sets' = \<Union>E'"
    unfolding is_k_colorable_def is_colorable_def
    by argo

  define E_nodes where E_nodes_def:"E_nodes = \<Union>{{(v,0::nat)}|v. v\<in>\<Union>E}"

  define E'_nodes where E'_nodes_def:"E'_nodes = \<Union>{{(0::nat,n)|n. n\<in>{1..card (\<Union>E)}}}"

  from E'def_2 asms(2) E_nodes_def E'_nodes_def have node_split_eq:
    "\<Union>E' = E_nodes \<union> E'_nodes"
    using nodesChromGraph
    by presburger

  from E_nodes_def E'_nodes_def have E'disjointparts: "E_nodes \<inter> E'_nodes = {}"
    by auto

  from this have E'nodesOwnColor:"\<And>v. v \<in> {(0,n)|n. n\<in>{1..card (\<Union>E)}} \<Longrightarrow> {v}\<in> c_Sets'"
  proof -
    fix v
    assume asms: "v \<in> {(0::nat,n)|n. n\<in>{1..card (\<Union>E)}}"
    from asms obtain n where n_def:"v = (0::nat,n) \<and> 1 \<le> n \<and> n \<le> card(\<Union>E)"
      by auto
    show "{v} \<in> c_Sets'"
    proof (cases "{v} \<in> c_Sets'")
      case True
      then show ?thesis by simp
    next
      case F1:False
      from asms c_Sets'_complete node_split_eq have "v\<in> \<Union>c_Sets'"
        by (simp add: E_nodes_def E'_nodes_def)
      from this F1 obtain color v' where color_def:"color \<in> c_Sets' \<and> v\<in> color \<and> v' \<in> color \<and> v\<noteq> v'"
        by (metis UnionE ex_in_conv insertCI mk_disjoint_insert)
      from color_def c_Sets'_complete have v'inE':"v' \<in> \<Union>E'"
        by blast
      from color_def c_Sets'_def have color_sound:"\<forall>v1\<in>color. \<forall>v2\<in>color. {v1,v2}\<notin> E'"
        unfolding is_k_colorable_def is_colorable_def
        by meson
      from this color_def have vv'notinE':"{v,v'}\<notin> E'"
        by blast
      then show ?thesis
      proof (cases "v' \<in> \<Union>{{(v,0)}|v. v\<in>\<Union>E}")
        case True
        from this asms E'_def have "{v,v'}\<in> E'"
          by auto
        from this vv'notinE' show ?thesis
          by simp
      next
        case False
        from this v'inE' node_split_eq have "v' \<in> \<Union>{{(0,n)|n. n\<in>{1..card (\<Union>E)}}}"
          by (auto simp: E_nodes_def E'_nodes_def)
        from this asms E'_def color_def have "{v,v'}\<in> E'"
          by blast
        from this vv'notinE' show ?thesis by simp
      qed
    qed
  qed

  from this have "{{(0, n)} |n. n \<in> {1..card (\<Union> E)}} \<subseteq> c_Sets'"
    by blast

  from this obtain E_colors where E_colors_def:"E_colors \<union> {{(0::nat, n)} |n. n \<in> {1..card (\<Union> E)}} = c_Sets' \<and>
                                                E_colors \<inter> {{(0::nat, n)} |n. n \<in> {1..card (\<Union> E)}} = {}"
    by auto

  from E_colors_def c_Sets'fin have fin1:"finite E_colors"
    by blast
  from E_colors_def c_Sets'fin have fin2:"finite {{(0, n)} |n. n \<in> {1..card (\<Union> E)}}"
    by simp

  from E_colors_def fin1 fin2  have c_Sets'_card_split:
    "card c_Sets' = card E_colors + card {{(0::nat, n)} |n. n \<in> {1..card (\<Union> E)}}"
    using card_Un_disjoint[where A= E_colors and B = "{{(0::nat, n)} |n. n \<in> {1..card (\<Union> E)}}" ]
    by blast

  have card_c_Sets2:"card {{(0::nat, n)} |n. n \<in> {1..card (\<Union> E)}} = card (\<Union> E)"
    using card_additional_nodes[where x= "card (\<Union>E)"]
    by blast

  from this c_Sets'_card c_Sets'_card_split have "card E_colors = 3"
    by linarith

  from this obtain c1' c2' c3' where E_colors_def':
    "E_colors = {c1',c2',c3'} \<and> c1' \<noteq> c2' \<and> c1' \<noteq> c3' \<and> c2' \<noteq> c3'"
    using choice3
    by (metis (no_types, lifting) card_dif_elements insert_commute)

  from this E_colors_def have E_color_in_c_Sets': "c1' \<in> c_Sets' \<and> c2' \<in> c_Sets' \<and> c3' \<in> c_Sets'"
    by blast

  from E_colors_def' E_color_in_c_Sets' c_Sets'_def  have c1'c2'disjoint:"c1' \<inter>  c2' = {}"
    unfolding is_k_colorable_def is_colorable_def
    by auto

  from E_colors_def' E_color_in_c_Sets' c_Sets'_def  have c1'c3'disjoint:"c1' \<inter>  c3' = {}"
    unfolding is_k_colorable_def is_colorable_def
    by auto

  from E_colors_def' E_color_in_c_Sets' c_Sets'_def  have c2'c3'disjoint:"c2' \<inter>  c3' = {}"
    unfolding is_k_colorable_def is_colorable_def
    by auto

  from E_color_in_c_Sets' c_Sets'_def  have c1'_color:"\<forall>v\<in>c1'. \<forall>v'\<in>c1'. {v, v'} \<notin> E'"
    unfolding is_k_colorable_def is_colorable_def
    by meson

  from E_color_in_c_Sets' c_Sets'_def  have c2'_color:"\<forall>v\<in>c2'. \<forall>v'\<in>c2'. {v, v'} \<notin> E'"
    unfolding is_k_colorable_def is_colorable_def
    by meson

  from E_color_in_c_Sets' c_Sets'_def  have c3'_color:"\<forall>v\<in>c3'. \<forall>v'\<in>c3'. {v, v'} \<notin> E'"
    unfolding is_k_colorable_def is_colorable_def
    by meson

  from E_colors_def E'_nodes_def have c_Sets'unioneq:"\<Union>c_Sets' = \<Union>E_colors \<union> E'_nodes"
    by blast

  have "\<And>v. v\<in> \<Union>E_colors \<Longrightarrow> v \<notin>E'_nodes"
  proof -
    fix v
    assume asms: "v\<in> \<Union>E_colors"
    show "v \<notin>E'_nodes"
    proof (cases "v \<notin>E'_nodes")
      case True
      then show ?thesis
        by blast
    next
      case F1:False
      from this have "v \<in> E'_nodes"
        by blast
      from this E'_nodes_def obtain c1 where c1_def:"v \<in> c1 \<and> c1\<in> {{(0, n)} |n. n \<in> {1..card (\<Union> E)}}"
        by blast
      from asms obtain c2 where c2_def:"v \<in> c2 \<and> c2\<in> E_colors"
        by blast
      from E_colors_def c1_def c2_def have c1c2noteq:"c1 \<noteq> c2"
        by blast
      from E_colors_def c1_def c2_def have "c1\<in> c_Sets' \<and> c2\<in> c_Sets'"
        by blast
      from this c_Sets'_def c1c2noteq have "c1\<inter> c2 = {}"
        unfolding is_k_colorable_def is_colorable_def
        by meson
      from this c1_def c2_def have "False"
        by blast
      then show ?thesis
        by blast
    qed
  qed

  from this have E_colorNodesDisjoint:"\<Union>E_colors \<inter> E'_nodes = {}"
    by blast
  from node_split_eq c_Sets'_complete c_Sets'unioneq have
    " E_nodes \<union> E'_nodes =
      \<Union> E_colors \<union> E'_nodes"
    by argo
  from this E_colorNodesDisjoint E'disjointparts have "\<Union>E_colors = E_nodes "
    using seteqUniondiff[where C = "\<Union>E_colors" and B= E_nodes and A = E'_nodes]
    by auto

  from this E_colors_def' have colorseteqnodes:"c1'\<union>c2'\<union>c3' =E_nodes"
    by auto

  from colorseteqnodes have c1'subset:"c1' \<subseteq> E_nodes"
    by blast

  from colorseteqnodes have c2'subset:"c2' \<subseteq> E_nodes"
    by blast

  from colorseteqnodes have c3'subset:"c3' \<subseteq> E_nodes"
    by blast

  obtain c1 where c1_def:"c1= \<Union>{{v}|v. (v,0)\<in> c1'}"
    by blast

  obtain c2 where c2_def:"c2= \<Union>{{v}|v. (v,0)\<in> c2'}"
    by blast

  obtain c3 where c3_def:"c3= \<Union>{{v}|v. (v,0)\<in> c3'}"
    by blast

  from c1_def c2_def E_colors_def' have c1c2Noteq:"c1 \<noteq> c2"
  proof (cases "c1= {}")
    case T:True
    from this  c1_def c1'subset E_nodes_def have "c1' = {}"
      by blast
    from this E_colors_def' have "c2' \<noteq> {}"
      by blast
    from this c2'subset E_nodes_def obtain v where "(v,0::nat)\<in> c2' \<and> v\<in>\<Union>E"
      by blast
    from this c2_def have "v\<in> c2"
      by blast
    from this T show ?thesis
      by blast
  next
    case False
    from this c1_def c1'subset E_nodes_def have "c1' \<noteq> {}"
      by blast
    from this c1'subset E_nodes_def c1'c2'disjoint obtain v where "(v,0::nat)\<in> c1' \<and> (v,0)\<notin> c2' \<and> v\<in>\<Union>E"
      by blast
    from this c1_def c2_def have "v\<in> c1 \<and> v \<notin> c2"
      by blast
    then show ?thesis
      by blast
  qed

    from c1_def c2_def E_colors_def' have c1c3Noteq:"c1 \<noteq> c3"
  proof (cases "c1= {}")
    case T:True
    from this  c1_def c1'subset E_nodes_def have "c1' = {}"
      by blast
    from this E_colors_def' have "c3' \<noteq> {}"
      by blast
    from this c3'subset E_nodes_def obtain v where "(v,0::nat)\<in> c3' \<and> v\<in>\<Union>E"
      by blast
    from this c3_def have "v\<in> c3"
      by blast
    from this T show ?thesis
      by blast
  next
    case False
    from this c1_def c1'subset E_nodes_def have "c1' \<noteq> {}"
      by blast
    from this c1'subset E_nodes_def c1'c3'disjoint obtain v where "(v,0::nat)\<in> c1' \<and> (v,0)\<notin> c3' \<and> v\<in>\<Union>E"
      by blast
    from this c1_def c3_def have "v\<in> c1 \<and> v \<notin> c3"
      by blast
    then show ?thesis
      by blast
  qed

    from c1_def c2_def E_colors_def' have c2c3Noteq:"c2 \<noteq> c3"
  proof (cases "c2= {}")
    case T:True
    from this  c2_def c2'subset E_nodes_def have "c2' = {}"
      by blast
    from this E_colors_def' have "c3' \<noteq> {}"
      by blast
    from this c3'subset E_nodes_def obtain v where "(v,0::nat)\<in> c3' \<and> v\<in>\<Union>E"
      by blast
    from this c3_def have "v\<in> c3"
      by blast
    from this T show ?thesis
      by blast
  next
    case False
    from this c2_def c2'subset E_nodes_def have "c2' \<noteq> {}"
      by blast
    from this c2'subset E_nodes_def c2'c3'disjoint obtain v where "(v,0::nat)\<in> c2' \<and> (v,0)\<notin> c3' \<and> v\<in>\<Union>E"
      by blast
    from this c2_def c3_def have "v\<in> c2 \<and> v \<notin> c3"
      by blast
    then show ?thesis
      by blast
  qed

  from c1c2Noteq c1c3Noteq c2c3Noteq have colorNoteq:"c1 \<noteq> c2 \<and> c1 \<noteq> c3 \<and> c2 \<noteq> c3"
    by blast

  have color_complete:"\<Union> E = \<Union> {c1, c2, c3}"
  proof -
    define step1 where step1_def:
      "step1 = \<Union> ({{v} |v. (v, 0) \<in> c1'} \<union> {{v} |v. (v, 0) \<in> c2'} \<union>  {{v} |v. (v, 0) \<in> c3'})"
    define step2 where step2_def:
      "step2 = \<Union>({{v} |v. (v, 0) \<in> c1' \<or>  (v, 0) \<in> c2' \<or>  (v, 0) \<in> c3' })"
    define step3 where step3_def:
      "step3 = \<Union>({{v} |v. (v, 0) \<in> E_nodes })"

    have "\<Union> {c1, c2, c3} = c1 \<union> c2 \<union> c3"
      by force
    from this c1_def c2_def c3_def have st1:
        "\<Union> {c1, c2, c3} =
        step1"
      by (auto simp: step1_def)
    from step1_def step2_def have st2:
      " step1 =  step2"
      by blast
    from colorseteqnodes step2_def step3_def have st3:"step2 = step3"
      by blast
    from E_nodes_def step3_def have st4:"step3 = \<Union>E"
      by blast
    from st1 st2 st3 st4 show ?thesis
      by argo
  qed

  from c1_def c2_def c1'c2'disjoint have c1c2disjoint: "c1 \<inter> c2 ={}"
    by blast
  from c1_def c3_def c1'c3'disjoint have c1c3disjoint: "c1 \<inter> c3 ={}"
    by blast
  from c2_def c3_def c2'c3'disjoint have c2c3disjoint: "c2 \<inter> c3 ={}"
    by blast
  from c1c2disjoint c1c3disjoint c2c3disjoint have colordisjoint:
    "\<forall>c\<in>{c1, c2, c3}. \<forall>c'\<in>{c1, c2, c3}. c \<noteq> c' \<longrightarrow> c \<inter> c' = {}"
    by blast

  have c1_iscolor:"\<And>v. \<And>v'. v\<in>c1 \<Longrightarrow> v'\<in>c1 \<Longrightarrow> {v, v'} \<notin> E"
  proof -
    fix v v'
    assume asms2: "v\<in> c1" "v'\<in> c1"
    from this c1_def have "(v,0)\<in> c1' \<and> (v',0)\<in> c1'"
      by blast
    from this c1'_color have "{(v,0),(v',0)}\<notin>E'"
      by blast
    from this asms(2) E'_def_3 show "{v,v'}\<notin> E"
      using TC_chrN_edge_in_E_iff
      by blast
  qed

  have c2_iscolor:"\<And>v. \<And>v'. v\<in>c2 \<Longrightarrow> v'\<in>c2 \<Longrightarrow> {v, v'} \<notin> E"
  proof -
    fix v v'
    assume asms2: "v\<in> c2" "v'\<in> c2"
    from this c2_def have "(v,0)\<in> c2' \<and> (v',0)\<in> c2'"
      by blast
    from this c2'_color have "{(v,0),(v',0)}\<notin>E'"
      by blast
    from this asms(2) E'_def_3 show "{v,v'}\<notin> E"
      using TC_chrN_edge_in_E_iff
      by blast
  qed

  have c3_iscolor:"\<And>v. \<And>v'. v\<in>c3 \<Longrightarrow> v'\<in>c3 \<Longrightarrow> {v, v'} \<notin> E"
  proof -
    fix v v'
    assume asms2: "v\<in> c3" "v'\<in> c3"
    from this c3_def have "(v,0)\<in> c3' \<and> (v',0)\<in> c3'"
      by blast
    from this c3'_color have "{(v,0),(v',0)}\<notin>E'"
      by blast
    from this asms(2) E'_def_3 show "{v,v'}\<notin> E"
      using TC_chrN_edge_in_E_iff
      by blast
  qed

  from c1_iscolor c2_iscolor c3_iscolor have is_color:"\<forall>c\<in>{c1, c2, c3}. \<forall>v\<in>c. \<forall>v'\<in>c. {v, v'} \<notin> E"
    by blast

  from asms(2) color_complete colordisjoint is_color have "is_colorable E {c1, c2, c3}"
    unfolding is_colorable_def
    by blast

  from this colorNoteq have "is_k_colorable E 3 {c1,c2,c3}"
    unfolding is_k_colorable_def
    by simp

  then show "E \<in> three_colorability"
    unfolding three_colorability_def
    by blast
qed

lemma chroNToThreeCol_notugraph:"\<And>E. \<not>ugraph E \<Longrightarrow> TC_chrN E \<in> chromaticNumber \<Longrightarrow> E \<in> three_colorability"
proof -
  fix E :: "nat set set"
  assume asms:"TC_chrN E \<in> chromaticNumber" "\<not> ugraph E"
  obtain E' k  where E'_def:"(E',k) =TC_chrN E"
    by (metis surj_pair)
  from this asms have E'_chrN:"(E',k) \<in> chromaticNumber"
    by simp
  from asms E'_def have "k = (0::nat)"
    unfolding TC_chrN_def
    by auto
  from this E'_chrN have "(E',0::nat) \<in> chromaticNumber"
    by auto
  from this have "False"
    unfolding chromaticNumber_def
    by fastforce
  then show "E \<in> three_colorability"
    by simp
qed

lemma chroNToThreeCol:"\<And>E. TC_chrN E \<in> chromaticNumber \<Longrightarrow> E \<in> three_colorability"
proof -
  fix E :: "nat set set"
  assume asms:"TC_chrN E \<in> chromaticNumber"
  show "E \<in> three_colorability"
  proof (cases "ugraph E")
    case True
    then show ?thesis
      using chroNToThreeCol_ugraph asms
      by blast
  next
    case False
    then show ?thesis
      using chroNToThreeCol_notugraph asms
      by blast
  qed
qed

theorem is_reduction_threeC_chrN:
  "is_reduction TC_chrN three_colorability chromaticNumber"
  unfolding is_reduction_def
  apply  safe
  subgoal using threeColToChroN
    by blast
  using chroNToThreeCol
  by blast

end


(*  Title:      HOL/Cardinals/Cardinal_Arithmetic.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Copyright   2012

Cardinal arithmetic.
*)

section {* Cardinal Arithmetic *}

theory Cardinal_Arithmetic
imports BNF_Cardinal_Arithmetic Cardinal_Order_Relation
begin

subsection {* Binary sum *}

lemma csum_Cnotzero2:
  "Cnotzero r2 \<Longrightarrow> Cnotzero (r1 +c r2)"
unfolding csum_def
by (metis Cnotzero_imp_not_empty Field_card_of Plus_eq_empty_conv card_of_card_order_on czeroE)

lemma single_cone:
  "|{x}| =o cone"
proof -
  let ?f = "\<lambda>x. ()"
  have "bij_betw ?f {x} {()}" unfolding bij_betw_def by auto
  thus ?thesis unfolding cone_def using card_of_ordIso by blast
qed

lemma cone_Cnotzero: "Cnotzero cone"
by (simp add: cone_not_czero Card_order_cone)

lemma cone_ordLeq_ctwo: "cone \<le>o ctwo"
unfolding cone_def ctwo_def card_of_ordLeq[symmetric] by auto

lemma csum_czero1: "Card_order r \<Longrightarrow> r +c czero =o r"
  unfolding czero_def csum_def Field_card_of
  by (rule ordIso_transitive[OF ordIso_symmetric[OF card_of_Plus_empty1] card_of_Field_ordIso])

lemma csum_czero2: "Card_order r \<Longrightarrow> czero +c r =o r"
  unfolding czero_def csum_def Field_card_of
  by (rule ordIso_transitive[OF ordIso_symmetric[OF card_of_Plus_empty2] card_of_Field_ordIso])

subsection {* Product *}

lemma Times_cprod: "|A \<times> B| =o |A| *c |B|"
by (simp only: cprod_def Field_card_of card_of_refl)

lemma card_of_Times_singleton:
fixes A :: "'a set"
shows "|A \<times> {x}| =o |A|"
proof -
  def f \<equiv> "\<lambda>(a::'a,b::'b). (a)"
  have "A \<subseteq> f ` (A <*> {x})" unfolding f_def by (auto simp: image_iff)
  hence "bij_betw f (A <*> {x}) A"  unfolding bij_betw_def inj_on_def f_def by fastforce
  thus ?thesis using card_of_ordIso by blast
qed

lemma cprod_assoc: "(r *c s) *c t =o r *c s *c t"
  unfolding cprod_def Field_card_of by (rule card_of_Times_assoc)

lemma cprod_czero: "r *c czero =o czero"
  unfolding cprod_def czero_def Field_card_of by (simp add: card_of_empty_ordIso)

lemma cprod_cone: "Card_order r \<Longrightarrow> r *c cone =o r"
  unfolding cprod_def cone_def Field_card_of
  by (drule card_of_Field_ordIso) (erule ordIso_transitive[OF card_of_Times_singleton])

lemma ordLeq_cprod1: "\<lbrakk>Card_order p1; Cnotzero p2\<rbrakk> \<Longrightarrow> p1 \<le>o p1 *c p2"
unfolding cprod_def by (metis Card_order_Times1 czeroI)

subsection {* Exponentiation *}

lemma cexp_czero: "r ^c czero =o cone"
unfolding cexp_def czero_def Field_card_of Func_empty by (rule single_cone)

lemma Pow_cexp_ctwo:
  "|Pow A| =o ctwo ^c |A|"
unfolding ctwo_def cexp_def Field_card_of by (rule card_of_Pow_Func)

lemma Cnotzero_cexp:
  assumes "Cnotzero q" "Card_order r"
  shows "Cnotzero (q ^c r)"
proof (cases "r =o czero")
  case False thus ?thesis
    apply -
    apply (rule Cnotzero_mono)
    apply (rule assms(1))
    apply (rule Card_order_cexp)
    apply (rule ordLeq_cexp1)
    apply (rule conjI)
    apply (rule notI)
    apply (erule notE)
    apply (rule ordIso_transitive)
    apply assumption
    apply (rule czero_ordIso)
    apply (rule assms(2))
    apply (rule conjunct2)
    apply (rule assms(1))
  done
next
  case True thus ?thesis
    apply -
    apply (rule Cnotzero_mono)
    apply (rule cone_Cnotzero)
    apply (rule Card_order_cexp)
    apply (rule ordIso_imp_ordLeq)
    apply (rule ordIso_symmetric)
    apply (rule ordIso_transitive)
    apply (rule cexp_cong2)
    apply assumption
    apply (rule conjunct2)
    apply (rule assms(1))
    apply (rule assms(2))
    apply (rule cexp_czero)
  done
qed

lemma Cinfinite_ctwo_cexp:
  "Cinfinite r \<Longrightarrow> Cinfinite (ctwo ^c r)"
unfolding ctwo_def cexp_def cinfinite_def Field_card_of
by (rule conjI, rule infinite_Func, auto)

lemma cone_ordLeq_iff_Field:
  assumes "cone \<le>o r"
  shows "Field r \<noteq> {}"
proof (rule ccontr)
  assume "\<not> Field r \<noteq> {}"
  hence "Field r = {}" by simp
  thus False using card_of_empty3
    card_of_mono2[OF assms] Cnotzero_imp_not_empty[OF cone_Cnotzero] by auto
qed

lemma cone_ordLeq_cexp: "cone \<le>o r1 \<Longrightarrow> cone \<le>o r1 ^c r2"
by (simp add: cexp_def cone_def Func_non_emp cone_ordLeq_iff_Field)

lemma Card_order_czero: "Card_order czero"
by (simp only: card_of_Card_order czero_def)

lemma cexp_mono2'':
  assumes 2: "p2 \<le>o r2"
  and n1: "Cnotzero q"
  and n2: "Card_order p2"
  shows "q ^c p2 \<le>o q ^c r2"
proof (cases "p2 =o (czero :: 'a rel)")
  case True
  hence "q ^c p2 =o q ^c (czero :: 'a rel)" using n1 n2 cexp_cong2 Card_order_czero by blast
  also have "q ^c (czero :: 'a rel) =o cone" using cexp_czero by blast
  also have "cone \<le>o q ^c r2" using cone_ordLeq_cexp cone_ordLeq_Cnotzero n1 by blast
  finally show ?thesis .
next
  case False thus ?thesis using assms cexp_mono2' czeroI by metis
qed

lemma csum_cexp: "\<lbrakk>Cinfinite r1; Cinfinite r2; Card_order q; ctwo \<le>o q\<rbrakk> \<Longrightarrow>
  q ^c r1 +c q ^c r2 \<le>o q ^c (r1 +c r2)"
apply (rule csum_cinfinite_bound)
apply (rule cexp_mono2)
apply (rule ordLeq_csum1)
apply (erule conjunct2)
apply assumption
apply (rule notE)
apply (rule cinfinite_not_czero[of r1])
apply (erule conjunct1)
apply assumption
apply (erule conjunct2)
apply (rule cexp_mono2)
apply (rule ordLeq_csum2)
apply (erule conjunct2)
apply assumption
apply (rule notE)
apply (rule cinfinite_not_czero[of r2])
apply (erule conjunct1)
apply assumption
apply (erule conjunct2)
apply (rule Card_order_cexp)
apply (rule Card_order_cexp)
apply (rule Cinfinite_cexp)
apply assumption
apply (rule Cinfinite_csum)
by (rule disjI1)

lemma csum_cexp': "\<lbrakk>Cinfinite r; Card_order q; ctwo \<le>o q\<rbrakk> \<Longrightarrow> q +c r \<le>o q ^c r"
apply (rule csum_cinfinite_bound)
    apply (metis Cinfinite_Cnotzero ordLeq_cexp1)
   apply (metis ordLeq_cexp2)
  apply blast+
by (metis Cinfinite_cexp)

lemma card_of_Sigma_ordLeq_Cinfinite:
  "\<lbrakk>Cinfinite r; |I| \<le>o r; \<forall>i \<in> I. |A i| \<le>o r\<rbrakk> \<Longrightarrow> |SIGMA i : I. A i| \<le>o r"
unfolding cinfinite_def by (blast intro: card_of_Sigma_ordLeq_infinite_Field)

lemma card_order_cexp:
  assumes "card_order r1" "card_order r2"
  shows "card_order (r1 ^c r2)"
proof -
  have "Field r1 = UNIV" "Field r2 = UNIV" using assms card_order_on_Card_order by auto
  thus ?thesis unfolding cexp_def Func_def by simp
qed

lemma Cinfinite_ordLess_cexp:
  assumes r: "Cinfinite r"
  shows "r <o r ^c r"
proof -
  have "r <o ctwo ^c r" using r by (simp only: ordLess_ctwo_cexp)
  also have "ctwo ^c r \<le>o r ^c r"
    by (rule cexp_mono1[OF ctwo_ordLeq_Cinfinite]) (auto simp: r ctwo_not_czero Card_order_ctwo)
  finally show ?thesis .
qed

lemma infinite_ordLeq_cexp:
  assumes "Cinfinite r"
  shows "r \<le>o r ^c r"
by (rule ordLess_imp_ordLeq[OF Cinfinite_ordLess_cexp[OF assms]])

lemma czero_cexp: "Cnotzero r \<Longrightarrow> czero ^c r =o czero"
  by (drule Cnotzero_imp_not_empty) (simp add: cexp_def czero_def card_of_empty_ordIso)

lemma Func_singleton:
fixes x :: 'b and A :: "'a set"
shows "|Func A {x}| =o |{x}|"
proof (rule ordIso_symmetric)
  def f \<equiv> "\<lambda>y a. if y = x \<and> a \<in> A then x else undefined"
  have "Func A {x} \<subseteq> f ` {x}" unfolding f_def Func_def by (force simp: fun_eq_iff)
  hence "bij_betw f {x} (Func A {x})" unfolding bij_betw_def inj_on_def f_def Func_def
    by (auto split: split_if_asm)
  thus "|{x}| =o |Func A {x}|" using card_of_ordIso by blast
qed

lemma cone_cexp: "cone ^c r =o cone"
  unfolding cexp_def cone_def Field_card_of by (rule Func_singleton)

lemma card_of_Func_squared:
  fixes A :: "'a set"
  shows "|Func (UNIV :: bool set) A| =o |A \<times> A|"
proof (rule ordIso_symmetric)
  def f \<equiv> "\<lambda>(x::'a,y) b. if A = {} then undefined else if b then x else y"
  have "Func (UNIV :: bool set) A \<subseteq> f ` (A \<times> A)" unfolding f_def Func_def
    by (auto simp: image_iff fun_eq_iff split: option.splits split_if_asm) blast
  hence "bij_betw f (A \<times> A) (Func (UNIV :: bool set) A)"
    unfolding bij_betw_def inj_on_def f_def Func_def by (auto simp: fun_eq_iff)
  thus "|A \<times> A| =o |Func (UNIV :: bool set) A|" using card_of_ordIso by blast
qed

lemma cexp_ctwo: "r ^c ctwo =o r *c r"
  unfolding cexp_def ctwo_def cprod_def Field_card_of by (rule card_of_Func_squared)

lemma card_of_Func_Plus:
  fixes A :: "'a set" and B :: "'b set" and C :: "'c set"
  shows "|Func (A <+> B) C| =o |Func A C \<times> Func B C|"
proof (rule ordIso_symmetric)
  def f \<equiv> "\<lambda>(g :: 'a => 'c, h::'b \<Rightarrow> 'c) ab. case ab of Inl a \<Rightarrow> g a | Inr b \<Rightarrow> h b"
  def f' \<equiv> "\<lambda>(f :: ('a + 'b) \<Rightarrow> 'c). (\<lambda>a. f (Inl a), \<lambda>b. f (Inr b))"
  have "f ` (Func A C \<times> Func B C) \<subseteq> Func (A <+> B) C"
    unfolding Func_def f_def by (force split: sum.splits)
  moreover have "f' ` Func (A <+> B) C \<subseteq> Func A C \<times> Func B C" unfolding Func_def f'_def by force
  moreover have "\<forall>a \<in> Func A C \<times> Func B C. f' (f a) = a" unfolding f'_def f_def Func_def by auto
  moreover have "\<forall>a' \<in> Func (A <+> B) C. f (f' a') = a'" unfolding f'_def f_def Func_def
    by (auto split: sum.splits)
  ultimately have "bij_betw f (Func A C \<times> Func B C) (Func (A <+> B) C)"
    by (intro bij_betw_byWitness[of _ f' f])
  thus "|Func A C \<times> Func B C| =o |Func (A <+> B) C|" using card_of_ordIso by blast
qed

lemma cexp_csum: "r ^c (s +c t) =o r ^c s *c r ^c t"
  unfolding cexp_def cprod_def csum_def Field_card_of by (rule card_of_Func_Plus)

subsection {* Powerset *}

definition cpow where "cpow r = |Pow (Field r)|"

lemma card_order_cpow: "card_order r \<Longrightarrow> card_order (cpow r)"
by (simp only: cpow_def Field_card_order Pow_UNIV card_of_card_order_on)

lemma cpow_greater_eq: "Card_order r \<Longrightarrow> r \<le>o cpow r"
by (rule ordLess_imp_ordLeq) (simp only: cpow_def Card_order_Pow)

lemma Cinfinite_cpow: "Cinfinite r \<Longrightarrow> Cinfinite (cpow r)"
unfolding cpow_def cinfinite_def by (metis Field_card_of card_of_Card_order infinite_Pow)

lemma Card_order_cpow: "Card_order (cpow r)"
unfolding cpow_def by (rule card_of_Card_order)

lemma cardSuc_ordLeq_cpow: "Card_order r \<Longrightarrow> cardSuc r \<le>o cpow r"
unfolding cpow_def by (metis Card_order_Pow cardSuc_ordLess_ordLeq card_of_Card_order)

lemma cpow_cexp_ctwo: "cpow r =o ctwo ^c r"
unfolding cpow_def ctwo_def cexp_def Field_card_of by (rule card_of_Pow_Func)

subsection {* Inverse image *}

lemma vimage_ordLeq:
assumes "|A| \<le>o k" and "\<forall> a \<in> A. |vimage f {a}| \<le>o k" and "Cinfinite k"
shows "|vimage f A| \<le>o k"
proof-
  have "vimage f A = (\<Union> a \<in> A. vimage f {a})" by auto
  also have "|\<Union> a \<in> A. vimage f {a}| \<le>o k"
  using UNION_Cinfinite_bound[OF assms] .
  finally show ?thesis .
qed

subsection {* Maximum *}

definition cmax where
  "cmax r s =
    (if cinfinite r \<or> cinfinite s then czero +c r +c s
     else natLeq_on (max (card (Field r)) (card (Field s))) +c czero)"

lemma cmax_com: "cmax r s =o cmax s r"
  unfolding cmax_def
  by (auto simp: max.commute intro: csum_cong2[OF csum_com] csum_cong2[OF czero_ordIso])

lemma cmax1:
  assumes "Card_order r" "Card_order s" "s \<le>o r"
  shows "cmax r s =o r"
unfolding cmax_def proof (split if_splits, intro conjI impI)
  assume "cinfinite r \<or> cinfinite s"
  hence Cinf: "Cinfinite r" using assms(1,3) by (metis cinfinite_mono)
  have "czero +c r +c s =o r +c s" by (rule csum_czero2[OF Card_order_csum])
  also have "r +c s =o r" by (rule csum_absorb1[OF Cinf assms(3)])
  finally show "czero +c r +c s =o r" .
next
  assume "\<not> (cinfinite r \<or> cinfinite s)"
  hence fin: "finite (Field r)" and "finite (Field s)" unfolding cinfinite_def by simp_all
  moreover
  { from assms(2) have "|Field s| =o s" by (rule card_of_Field_ordIso)
    also from assms(3) have "s \<le>o r" .
    also from assms(1) have "r =o |Field r|" by (rule ordIso_symmetric[OF card_of_Field_ordIso])
    finally have "|Field s| \<le>o |Field r|" .
  }
  ultimately have "card (Field s) \<le> card (Field r)" by (subst sym[OF finite_card_of_iff_card2])
  hence "max (card (Field r)) (card (Field s)) = card (Field r)" by (rule max_absorb1)
  hence "natLeq_on (max (card (Field r)) (card (Field s))) +c czero =
    natLeq_on (card (Field r)) +c czero" by simp
  also have "\<dots> =o natLeq_on (card (Field r))" by (rule csum_czero1[OF natLeq_on_Card_order])
  also have "natLeq_on (card (Field r)) =o |Field r|"
    by (rule ordIso_symmetric[OF finite_imp_card_of_natLeq_on[OF fin]])
  also from assms(1) have "|Field r| =o r" by (rule card_of_Field_ordIso)
  finally show "natLeq_on (max (card (Field r)) (card (Field s))) +c czero =o r" .
qed

lemma cmax2:
  assumes "Card_order r" "Card_order s" "r \<le>o s"
  shows "cmax r s =o s"
  by (metis assms cmax1 cmax_com ordIso_transitive)

lemma csum_absorb2: "Cinfinite r2 \<Longrightarrow> r1 \<le>o r2 \<Longrightarrow> r1 +c r2 =o r2"
  by (metis csum_absorb2')

lemma cprod_infinite2': "\<lbrakk>Cnotzero r1; Cinfinite r2; r1 \<le>o r2\<rbrakk> \<Longrightarrow> r1 *c r2 =o r2"
  unfolding ordIso_iff_ordLeq
  by (intro conjI cprod_cinfinite_bound ordLeq_cprod2 ordLeq_refl)
    (auto dest!: ordIso_imp_ordLeq not_ordLeq_ordLess simp: czero_def Card_order_empty)

context
  fixes r s
  assumes r: "Cinfinite r"
  and     s: "Cinfinite s"
begin

lemma cmax_csum: "cmax r s =o r +c s"
proof (cases "r \<le>o s")
  case True
  hence "cmax r s =o s" by (metis cmax2 r s)
  also have "s =o r +c s" by (metis True csum_absorb2 ordIso_symmetric s)
  finally show ?thesis .
next
  case False
  hence "s \<le>o r" by (metis ordLeq_total r s card_order_on_def)
  hence "cmax r s =o r" by (metis cmax1 r s)
  also have "r =o r +c s" by (metis `s \<le>o r` csum_absorb1 ordIso_symmetric r)
  finally show ?thesis .
qed

lemma cmax_cprod: "cmax r s =o r *c s"
proof (cases "r \<le>o s")
  case True
  hence "cmax r s =o s" by (metis cmax2 r s)
  also have "s =o r *c s" by (metis Cinfinite_Cnotzero True cprod_infinite2' ordIso_symmetric r s)
  finally show ?thesis .
next
  case False
  hence "s \<le>o r" by (metis ordLeq_total r s card_order_on_def)
  hence "cmax r s =o r" by (metis cmax1 r s)
  also have "r =o r *c s" by (metis Cinfinite_Cnotzero `s \<le>o r` cprod_infinite1' ordIso_symmetric r s)
  finally show ?thesis .
qed

end

lemma Card_order_cmax:
assumes r: "Card_order r" and s: "Card_order s"
shows "Card_order (cmax r s)"
unfolding cmax_def by (auto simp: Card_order_csum)

lemma ordLeq_cmax:
assumes r: "Card_order r" and s: "Card_order s"
shows "r \<le>o cmax r s \<and> s \<le>o cmax r s"
proof-
  {assume "r \<le>o s"
   hence ?thesis by (metis cmax2 ordIso_iff_ordLeq ordLeq_transitive r s)
  }
  moreover
  {assume "s \<le>o r"
   hence ?thesis using cmax_com by (metis cmax2 ordIso_iff_ordLeq ordLeq_transitive r s)
  }
  ultimately show ?thesis using r s ordLeq_total unfolding card_order_on_def by auto
qed

lemmas ordLeq_cmax1 = ordLeq_cmax[THEN conjunct1] and
       ordLeq_cmax2 = ordLeq_cmax[THEN conjunct2]

lemma finite_cmax:
assumes r: "Card_order r" and s: "Card_order s"
shows "finite (Field (cmax r s)) \<longleftrightarrow> finite (Field r) \<and> finite (Field s)"
proof-
  {assume "r \<le>o s"
   hence ?thesis by (metis cmax2 ordIso_finite_Field ordLeq_finite_Field r s)
  }
  moreover
  {assume "s \<le>o r"
   hence ?thesis by (metis cmax1 ordIso_finite_Field ordLeq_finite_Field r s)
  }
  ultimately show ?thesis using r s ordLeq_total unfolding card_order_on_def by auto
qed

end


section \<open>The Dynamic Representation of a Language\<close>

theory Semantics
  imports Main Behaviour Inf Transfer_Extras begin

text \<open>
The definition of programming languages is separated into two parts: an abstract semantics and a concrete program representation.
\<close>

definition finished :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" where
  "finished r x = (\<nexists>y. r x y)"

lemma finished_star:
  assumes "finished r x"
  shows "r\<^sup>*\<^sup>* x y \<Longrightarrow> x = y"
proof (induction y rule: rtranclp_induct)
  case base
  then show ?case by simp
next
  case (step y z)
  then show ?case
    using assms by (auto simp: finished_def)
qed

locale semantics =
  fixes
    step :: "'state \<Rightarrow> 'state \<Rightarrow> bool" (infix "\<rightarrow>" 50) and
    final :: "'state \<Rightarrow> bool"
  assumes
    final_finished: "final s \<Longrightarrow> finished step s"
begin

text \<open>
The semantics locale represents the semantics as an abstract machine.
It is expressed by a transition system with a transition relation @{term step}---usually written as an infix @{text \<rightarrow>} arrow---and final states @{term final}.
\<close>

lemma finished_step:
  "step s s' \<Longrightarrow> \<not>finished step s"
by (auto simp add: finished_def)

abbreviation eval :: "'state \<Rightarrow> 'state \<Rightarrow> bool" (infix "\<rightarrow>\<^sup>*" 50) where
  "eval \<equiv> step\<^sup>*\<^sup>*"

abbreviation inf_step :: "'state \<Rightarrow> bool" where
  "inf_step \<equiv> inf step"

notation
  inf_step ("'(\<rightarrow>\<^sup>\<infinity>')" [] 50) and
  inf_step ("_ \<rightarrow>\<^sup>\<infinity>" [55] 50)

lemma inf_not_finished: "s \<rightarrow>\<^sup>\<infinity> \<Longrightarrow> \<not> finished step s"
  using inf.cases finished_step by metis

lemma eval_deterministic:
  assumes
    deterministic: "\<And>x y z. step x y \<Longrightarrow> step x z \<Longrightarrow> y = z" and
    "s1 \<rightarrow>\<^sup>* s2" and "s1 \<rightarrow>\<^sup>* s3" and "finished step s2" and "finished step s3"
  shows "s2 = s3"
proof -
  have "right_unique step"
    using deterministic by (auto intro: right_uniqueI)
  with assms show ?thesis
    by (auto simp: finished_def intro: rtranclp_complete_run_right_unique)
qed

lemma step_converges_or_diverges: "(\<exists>s'. s \<rightarrow>\<^sup>* s' \<and> finished step s') \<or> s \<rightarrow>\<^sup>\<infinity>"
  by (smt (verit, del_insts) finished_def inf.coinduct rtranclp.intros(2) rtranclp.rtrancl_refl)

subsection \<open>Behaviour of a dynamic execution\<close>

inductive state_behaves :: "'state \<Rightarrow> 'state behaviour \<Rightarrow> bool" (infix "\<down>" 50) where
  state_terminates:
    "s1 \<rightarrow>\<^sup>* s2 \<Longrightarrow> finished step s2 \<Longrightarrow> final s2 \<Longrightarrow> s1 \<down> (Terminates s2)" |
  state_diverges:
    "s1 \<rightarrow>\<^sup>\<infinity> \<Longrightarrow> s1 \<down> Diverges" |
  state_goes_wrong:
    "s1 \<rightarrow>\<^sup>* s2 \<Longrightarrow> finished step s2 \<Longrightarrow> \<not> final s2 \<Longrightarrow> s1 \<down> (Goes_wrong s2)"

text \<open>
Even though the @{term step} transition relation in the @{locale semantics} locale need not be deterministic, if it happens to be, then the behaviour of a program becomes deterministic too.
\<close>

lemma right_unique_state_behaves:
  assumes
    "right_unique (\<rightarrow>)"
  shows "right_unique (\<down>)"
proof (rule right_uniqueI)
  fix s b1 b2
  assume "s \<down> b1" "s \<down> b2"
  thus "b1 = b2"
    by (auto simp: finished_def simp del: not_ex
        elim!: state_behaves.cases
        dest: rtranclp_complete_run_right_unique[OF \<open>right_unique (\<rightarrow>)\<close>, of s]
        dest: final_finished star_inf[OF \<open>right_unique (\<rightarrow>)\<close>, THEN inf_not_finished])
qed

lemma left_total_state_behaves: "left_total (\<down>)"
proof (rule left_totalI)
  fix s
  show "\<exists>b. s \<down> b"
    using step_converges_or_diverges[of s]
  proof (elim disjE exE conjE)
    fix s'
    assume "s \<rightarrow>\<^sup>* s'" and "finished (\<rightarrow>) s'"
    thus "\<exists>b. s \<down> b"
      by (cases "final s'") (auto intro: state_terminates state_goes_wrong)
  next
    assume "s \<rightarrow>\<^sup>\<infinity>"
    thus "\<exists>b. s \<down> b"
      by (auto intro: state_diverges)
  qed
qed

subsection \<open>Safe states\<close>

definition safe where
  "safe s \<longleftrightarrow> (\<forall>s'. step\<^sup>*\<^sup>* s s' \<longrightarrow> final s' \<or> (\<exists>s''. step s' s''))"

lemma final_safeI: "final s \<Longrightarrow> safe s"
  by (metis final_finished finished_star safe_def)

lemma step_safe: "step s s' \<Longrightarrow> safe s \<Longrightarrow> safe s'"
  by (simp add: converse_rtranclp_into_rtranclp safe_def)

lemma steps_safe: "step\<^sup>*\<^sup>* s s' \<Longrightarrow> safe s \<Longrightarrow> safe s'"
  by (meson rtranclp_trans safe_def)

lemma safe_state_behaves_not_wrong:
  assumes "safe s" and "s \<down> b"
  shows "\<not> is_wrong b"
  using \<open>s \<down> b\<close>
proof (cases rule: state_behaves.cases)
  case (state_goes_wrong s2)
  then show ?thesis
    using \<open>safe s\<close> by (auto simp: safe_def finished_def)
qed simp_all

end

end


theory Borda_Scoring_Rule

imports Scoring_Rules
        "Compositional_Structures/Basic_Modules/Borda_Scoring_Module"
        "Compositional_Structures/Elect_Composition"
begin

text
\<open>This is the Borda rule. On each ballot, each alternative is assigned a score
that depends on how many alternatives are ranked below. The sum of all such
scores for an alternative is hence called their Borda score. The alternative
with the highest Borda score is elected.\<close>

subsection \<open>Definition\<close>

fun borda_Scoring_Rule :: "'a Electoral_Module" where
  "borda_Scoring_Rule A p vs = elector Borda_scoring A p vs"

  lemma Borda_scoring_elect:
  shows "electoral_module (elector Borda_scoring)"
proof(unfold Borda_scoring.simps)
  show "electoral_module (elector (max_eliminator (scoring vec_A_borda)))"
    using scoring_mod_A by blast
qed

lemma borda_hom:
  shows "homogeneity (borda_Scoring_Rule)" unfolding Borda_scoring.simps borda_Scoring_Rule.simps
  using scoring_homogeneity elector_homogeneity by blast

lemma borda_reinforcement:
  shows "reinforcement (borda_Scoring_Rule)" unfolding Borda_scoring.simps borda_Scoring_Rule.simps
  using scoring_module_rein
  by blast

end