theory k_coloring
imports Main TeoriaCompacidadIngles
begin

type_synonym 'v digraph =  "('v set) \<times> (('v \<times> 'v) set)"

abbreviation vert :: "'v digraph \<Rightarrow> 'v set"  ("V[_]" [80] 80) where
  "V[G]  \<equiv> fst G"

abbreviation edge :: "'v digraph \<Rightarrow> ('v \<times> 'v) set" ("E[_]" [80] 80) where
  "E[G] \<equiv> snd G"

definition is_graph :: "'v digraph \<Rightarrow> bool" where
  "is_graph G \<equiv> \<forall> u v. (u,v) \<in> E[G] \<longrightarrow> u \<in> V[G] \<and> v \<in> V[G] \<and> u \<noteq> v"

definition is_induced_subgraph :: "'v digraph \<Rightarrow>'v digraph \<Rightarrow> bool" where
  "is_induced_subgraph H G \<equiv>
  (V[H] \<subseteq> V[G]) \<and> E[H] = E[G] \<inter> ((V[H]) \<times> (V[H]))"

lemma
  assumes "is_graph G" and "is_induced_subgraph H G"
  shows "is_graph H"
proof(unfold is_graph_def)
  show "\<forall>u v. (u, v) \<in> E[H] \<longrightarrow> u \<in> V[H] \<and> v \<in> V[H] \<and> u \<noteq> v"
  proof((rule allI)+, rule impI)
    fix u v
    assume "(u, v) \<in> E[H]"
    show  "u \<in> V[H] \<and> v \<in> V[H] \<and> u \<noteq> v"
    proof-
      have  "(u, v) \<in> E[G] \<inter> (V[H]) \<times> (V[H])" using `(u, v) \<in> E[H]` assms(2)
        by(unfold is_induced_subgraph_def,auto)
      hence 1:  "(u, v) \<in> E[G]" and 2: "u \<in> V[H] \<and> v \<in> V[H]"  by auto
      have "u \<noteq> v" using 1  `is_graph G`  by(unfold is_graph_def,auto)
      thus  "u \<in> V[H] \<and> v \<in> V[H] \<and> u \<noteq> v" using 2 by auto
    qed
  qed
qed

definition finite_graph :: "'v digraph \<Rightarrow> bool"  where
  "finite_graph G \<equiv> finite (V[G]) \<and> finite (E[G])"

definition coloring :: "('v \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> 'v digraph \<Rightarrow> bool" where
 "coloring c k G  \<equiv>
  (\<forall>u. u\<in>V[G]\<longrightarrow> c(u)\<le>k) \<and> (\<forall>u v.(u,v)\<in>E[G] \<longrightarrow> c(u)\<noteq>c(v))"

definition colorable ::  "'v digraph \<Rightarrow> nat \<Rightarrow>  bool" where
 "colorable G k \<equiv> \<exists>c. coloring c k G"

primrec atomic_disjunctions :: "'v \<Rightarrow> nat \<Rightarrow> ('v \<times> nat)formula"  where
 "atomic_disjunctions v  0 = atom (v, 0)"
| "atomic_disjunctions v (Suc k) =
  (atom (v, Suc k)) \<or>. (atomic_disjunctions v  k)"

definition \<F> :: "'v digraph \<Rightarrow> nat \<Rightarrow> (('v \<times> nat)formula) set"  where
   "\<F> G k \<equiv> (\<Union>v\<in>V[G]. {atomic_disjunctions v  k})"

definition \<G> :: "'v digraph \<Rightarrow> nat \<Rightarrow> ('v \<times> nat)formula set"  where
   "\<G> G k \<equiv> {\<not>.(atom (v, i) \<and>. atom(v,j))
                         | v i j. (v\<in>V[G]) \<and> (0\<le>i \<and> 0\<le>j \<and> i\<le>k \<and> j\<le>k \<and> i\<noteq>j)}"

definition \<H> :: "'v digraph \<Rightarrow> nat \<Rightarrow> ('v \<times> nat)formula set"  where
   "\<H> G k \<equiv> {\<not>.(atom (u, i) \<and>. atom(v,i))
                         |u v i . (u\<in>V[G] \<and> v\<in>V[G] \<and> (u,v)\<in>E[G]) \<and> (0\<le>i \<and> i\<le>k)} "

definition \<T> :: "'v digraph \<Rightarrow> nat \<Rightarrow> ('v \<times> nat)formula set"  where
   "\<T> G k  \<equiv> (\<F> G k) \<union> (\<G> G k) \<union> (\<H> G k)"

primrec vertices_formula :: "('v \<times> nat)formula  \<Rightarrow> 'v set" where
  "vertices_formula FF = {}"
| "vertices_formula TT = {}"
| "vertices_formula (atom P) =  {fst P}"
| "vertices_formula (\<not>. F) = vertices_formula F"
| "vertices_formula (F \<and>. G) = vertices_formula F \<union> vertices_formula G"
| "vertices_formula (F \<or>. G) = vertices_formula F \<union> vertices_formula G"
| "vertices_formula (F \<rightarrow>.G) = vertices_formula F \<union> vertices_formula G"

definition vertices_set_formulas :: "('v \<times> nat)formula set  \<Rightarrow> 'v set" where
"vertices_set_formulas S = (\<Union>F\<in> S. vertices_formula F)"

lemma finite_vertices:
  shows "finite (vertices_formula F)"
  by(induct F, auto)

lemma vertices_disjunction:
  assumes "F = atomic_disjunctions v  k" shows "vertices_formula F = {v}"
proof-
  have  "F = atomic_disjunctions v  k \<Longrightarrow> vertices_formula F = {v}"
  proof(induct k arbitrary: F)
    case 0
    assume  "F = atomic_disjunctions v 0"
    hence "F =  atom (v, 0 )" by auto
    thus "vertices_formula F = {v}" by auto
  next
    case(Suc k)
    have "F =(atom (v, Suc k )) \<or>. (atomic_disjunctions v  k)"
      using Suc(2) by auto
    hence "vertices_formula F = vertices_formula (atom (v, Suc k )) \<union> vertices_formula (atomic_disjunctions v  k)" by auto
    hence "vertices_formula F = {v} \<union> vertices_formula (atomic_disjunctions v  k)"
      by auto
    hence "vertices_formula F = {v} \<union> {v}" using Suc(1) by auto
    thus "vertices_formula F = {v}" by auto
  qed
  thus  ?thesis using assms by auto
qed

lemma all_vertices_colored:
  shows "vertices_set_formulas (\<F> G k) \<subseteq> V[G]"
proof
  fix x
  assume hip: "x \<in> vertices_set_formulas (\<F> G k)" show  "x \<in> V[G]"
  proof-
    have "x \<in> (\<Union>F\<in>(\<F> G k). vertices_formula F)" using hip
      by(unfold vertices_set_formulas_def,auto)
    hence "\<exists>F\<in>(\<F> G k). x \<in> vertices_formula F" by auto
    then obtain F where "F\<in>(\<F> G k)" and x: "x \<in> vertices_formula F" by auto
    hence "\<exists> v\<in>V[G]. F\<in>{atomic_disjunctions v  k}" by (unfold \<F>_def, auto)
    then obtain v where v: "v\<in>V[G]" and "F\<in>{atomic_disjunctions v  k}" by auto
    hence "F = atomic_disjunctions v  k" by auto
    hence "vertices_formula F = {v}"
      using vertices_disjunction[OF `F = atomic_disjunctions v  k`] by auto
    hence "x = v" using x by auto
    thus ?thesis using v by auto
  qed
qed

lemma vertices_maximumC:
  shows "vertices_set_formulas(\<G> G k) \<subseteq> V[G]"
proof
  fix x
  assume hip: "x \<in> vertices_set_formulas (\<G> G k)" show  "x \<in> V[G]"
  proof-
    have "x \<in> (\<Union>F\<in>(\<G> G k). vertices_formula F)" using hip
      by(unfold vertices_set_formulas_def,auto)
    hence "\<exists>F\<in>(\<G> G k). x \<in> vertices_formula F" by auto
    then obtain F where "F\<in>(\<G> G k)" and x: "x \<in> vertices_formula F"
      by auto
    hence "\<exists>v i j. v\<in>V[G] \<and> F =  \<not>.(atom (v, i) \<and>. atom(v,j))"
      by (unfold \<G>_def, auto)
    then obtain v i j where  "v\<in>V[G]"  and "F =  \<not>.(atom (v, i) \<and>. atom(v,j))"
      by auto
    hence v: "v\<in>V[G]"  and "F =  \<not>.(atom (v, i) \<and>. atom(v,j))" by auto
    hence v: "v\<in>V[G]"  and "vertices_formula F = {v}" by auto
    thus "x \<in> V[G]" using x by auto
  qed
qed

lemma distinct_verticesC:
  shows "vertices_set_formulas(\<H> G k)\<subseteq> V[G]"
proof
  fix x
  assume hip: "x \<in> vertices_set_formulas (\<H> G k)" show "x \<in> V[G]"
  proof-
    have "x \<in> (\<Union>F\<in>(\<H> G k). vertices_formula F)" using hip
      by(unfold vertices_set_formulas_def,auto)
    hence "\<exists>F\<in>(\<H> G k) . x \<in> vertices_formula F" by auto
    then obtain F where "F\<in>(\<H> G k)" and x: "x \<in> vertices_formula F"
      by auto
    hence "\<exists>u v i . u\<in>V[G] \<and>  v\<in>V[G] \<and>  F =  \<not>.(atom (u, i) \<and>. atom(v,i))"
      by (unfold \<H>_def, auto)
    then obtain u v i
      where "u\<in>V[G]" and "v\<in>V[G]"  and "F = \<not>.(atom (u, i) \<and>. atom(v,i))"
      by auto
    hence  "u\<in>V[G]" and  "v\<in>V[G]" and "F = \<not>.(atom (u, i) \<and>. atom(v,i))"
      by auto
    hence u: "u\<in>V[G]" and v: "v\<in>V[G]" and "vertices_formula F = {u, v}"
      by auto
    hence "x=u \<or> x=v"  using x by auto
    thus "x \<in> V[G]" using u v  by auto
  qed
qed

lemma vv:
  shows "vertices_set_formulas (A \<union> B) = (vertices_set_formulas A) \<union> (vertices_set_formulas B)"
  by(unfold  vertices_set_formulas_def, auto)

lemma vv1:
  assumes "F\<in>(\<F> G k)"
  shows "(vertices_formula F) \<subseteq> (vertices_set_formulas (\<F> G k))"
proof
  fix x
  assume hip: "x \<in> vertices_formula F"
  show  "x \<in> vertices_set_formulas (\<F> G k)"
  proof-
    have "\<exists>F. F\<in>(\<F> G k) \<and> x \<in> vertices_formula F" using assms hip by auto
    thus  ?thesis by(unfold vertices_set_formulas_def, auto)
  qed
qed

lemma vv2:
  assumes  "F\<in>(\<G> G k)"
  shows "(vertices_formula F) \<subseteq> (vertices_set_formulas (\<G> G k))"
proof
  fix x
  assume hip: "x \<in> vertices_formula F"
  show  "x \<in> vertices_set_formulas (\<G> G k)"
  proof-
    have "\<exists>F. F\<in>(\<G> G k) \<and> x \<in> vertices_formula F" using assms hip by auto
    thus ?thesis by(unfold vertices_set_formulas_def, auto)
  qed
qed

lemma vv3:
  assumes  "F\<in>(\<H> G k)"
  shows "(vertices_formula F) \<subseteq> (vertices_set_formulas (\<H> G k))"
proof
  fix x
  assume hip: "x \<in> vertices_formula F"
  show  "x \<in> vertices_set_formulas (\<H> G k)"
  proof-
    have "\<exists>F. F\<in>(\<H> G k) \<and> x \<in> vertices_formula F" using assms hip by auto
    thus ?thesis by(unfold vertices_set_formulas_def, auto)
  qed
qed

lemma aa:
  shows "vertices_set_formulas (\<T> G k) \<subseteq> V[G]"
proof
  fix x
  assume hip: "x \<in> vertices_set_formulas (\<T> G k)" show "x \<in> V[G]"
  proof-
    have  "x \<in> vertices_set_formulas ((\<F> G k) \<union> (\<G> G k)  \<union> (\<H> G k))"
      using hip by (unfold \<T>_def,auto)
    hence "x \<in> vertices_set_formulas ((\<F> G k) \<union> (\<G> G k)) \<union>
    vertices_set_formulas(\<H> G k)"
      using vv[of "(\<F> G k) \<union> (\<G> G k)"] by auto
    hence "x \<in> vertices_set_formulas ((\<F> G k) \<union> (\<G> G k)) \<or>
    x \<in> vertices_set_formulas(\<H> G k)"
      by auto
    thus ?thesis
    proof(rule disjE)
      assume hip: "x \<in> vertices_set_formulas (\<F> G k \<union> \<G> G k)"
      hence "x \<in> (\<Union>F\<in> (\<F> G k) \<union> (\<G> G k). vertices_formula F)"
        by(unfold  vertices_set_formulas_def, auto)
      then obtain F
      where F: "F\<in>(\<F> G k) \<union> (\<G> G k)" and x: "x \<in> vertices_formula F" by auto
      from F have  "(vertices_formula F) \<subseteq> (vertices_set_formulas (\<F> G k))
      \<or> vertices_formula F \<subseteq> (vertices_set_formulas (\<G> G k))"
        using vv1 vv2 by blast
      hence "x \<in> vertices_set_formulas (\<F> G k) \<or> x \<in> vertices_set_formulas (\<G> G k)"
        using x by auto
      thus "x \<in> V[G]"
        using all_vertices_colored[of "G" "k"] vertices_maximumC[of "G" "k"] by auto
      next
      assume "x \<in> vertices_set_formulas (\<H> G k)"
      hence
      "x \<in> (\<Union>F\<in>(\<H> G k). vertices_formula F)"
        by(unfold  vertices_set_formulas_def, auto)
      then obtain F where F:  "F\<in>(\<H> G k)" and x: "x \<in> vertices_formula F"
        by auto
      from F have "(vertices_formula F) \<subseteq> (vertices_set_formulas (\<H> G k))"
        using vv3 by blast
      hence "x \<in> vertices_set_formulas (\<H> G k)" using x by auto
      thus "x \<in> V[G]" using distinct_verticesC[of "G" "k"]
        by auto
    qed
  qed
qed

lemma vsf:
  assumes "G \<subseteq> H"
  shows "vertices_set_formulas G \<subseteq> vertices_set_formulas H"
  using assms by(unfold vertices_set_formulas_def, auto)

lemma vertices_subset_formulas:
  assumes "S \<subseteq> (\<T> G k)"
  shows "vertices_set_formulas S \<subseteq> V[G]"
proof-
  have "vertices_set_formulas S \<subseteq> vertices_set_formulas (\<T> G k)"
  using assms vsf by auto
  thus ?thesis using aa[of "G"] by auto
qed

definition subgraph_aux :: "'v digraph \<Rightarrow> 'v set \<Rightarrow>'v digraph" where
  "subgraph_aux G V \<equiv>  (V, E[G] \<inter> (V \<times> V))"

lemma induced_subgraph:
 assumes "is_graph G" and "S \<subseteq>(\<T> G k)"
 shows "is_induced_subgraph (subgraph_aux G (vertices_set_formulas S)) G"
proof-
  let ?V = "vertices_set_formulas S"
  let ?H = "(?V, E[G] \<inter> (?V \<times> ?V))"
  have 1: "E[?H] =  E[G] \<inter> (?V \<times> ?V)" and 2: "V[?H]= ?V"  by auto
  have "(V[?H] \<subseteq> V[G])" using 2 assms(2) vertices_subset_formulas[of S G ] by auto
  moreover
  have "E[?H] = (E[G] \<inter> ((V[?H]) \<times> (V[?H])))" using 1 2 by auto
  ultimately
  have  "is_induced_subgraph ?H G" by(unfold is_induced_subgraph_def, auto)
  thus ?thesis  by(unfold subgraph_aux_def, auto)
qed

lemma finite_subgraph:
  assumes "is_graph G" and "S \<subseteq> (\<T> G k)" and "finite S"
  shows "finite_graph (subgraph_aux G (vertices_set_formulas S))"
proof-
  let ?V = "vertices_set_formulas S"
  let ?H = "(?V, E[G] \<inter> (?V \<times> ?V))"
  have 1: "E[?H] =  E[G] \<inter> (?V \<times> ?V)" and 2: "V[?H]= ?V"  by auto
  have 3: "finite ?V" using `finite S` finite_vertices
    by(unfold vertices_set_formulas_def, auto)
  hence  "finite (V[?H])" using 2 by auto
  moreover
  have  "finite (E[G] \<inter> (?V \<times> ?V))" using 3 by auto
  hence "finite (E[?H])" using 1 by auto
  ultimately have  "finite_graph ?H" by(unfold finite_graph_def, auto)
  thus ?thesis  by(unfold subgraph_aux_def, auto)
qed

fun graph_interpretation :: "'v digraph \<Rightarrow> ('v \<Rightarrow> nat) \<Rightarrow> (('v \<times> nat) \<Rightarrow> v_truth)"  where
"graph_interpretation G f = (\<lambda>(v,i).(if v \<in> V[G] \<and> f(v) = i  then Ttrue else Ffalse))"

lemma value1:
  assumes "v \<in> V[G]" and "f(v)\<le> k"  and  "F = atomic_disjunctions v  k"
  shows "t_v_evaluation (graph_interpretation G f) F = Ttrue"
proof-
  let ?i = "f(v)"
  have "0 \<le> ?i" by auto
   {have  "v \<in> V[G] \<Longrightarrow> 0 \<le> ?i \<Longrightarrow> ?i\<le>k \<Longrightarrow> F = atomic_disjunctions v  k \<Longrightarrow>
   t_v_evaluation (graph_interpretation G f) F = Ttrue"
  proof(induct k arbitrary: F)
    case 0
    have "?i = 0" using "0" (2-3)  by auto
    hence "t_v_evaluation (graph_interpretation G f) (atom (v, 0)) =  Ttrue"
      using `v \<in> V[G]`  by auto
    thus ?case using  "0" (4)  by auto
    next
    case(Suc k)
    from Suc(1) Suc(2) Suc(3) Suc(4) Suc(5) show ?case
    proof(cases)
      assume "(Suc  k) = ?i"
      hence "t_v_evaluation (graph_interpretation G f) (atom (v,Suc  k )) =  Ttrue"
      using Suc(2) Suc(3) Suc(5) by auto
      hence
      "t_v_evaluation (graph_interpretation G f) (atom (v, Suc  k)
       \<or>.atomic_disjunctions v  k) = Ttrue"
      using v_disjunction_def by auto
      thus ?case using  Suc(5) by auto
      next
      assume 1: "(Suc  k) \<noteq> ?i"
      hence "t_v_evaluation (graph_interpretation G f) (atom (v, Suc k)) =  Ffalse"
        using Suc(5) by auto
      moreover
      have "?i < (Suc  k)" using Suc(4) 1  by auto
      hence "?i \<le> k" by auto
      hence "t_v_evaluation (graph_interpretation G f) (atomic_disjunctions v k) = Ttrue"
      using  Suc(1) Suc(2) Suc(3)  Suc(5)  by auto
      thus ?case using  Suc(5)  v_disjunction_def by auto
    qed
  qed
 }
  thus ?thesis using assms by auto
qed

lemma t_value_vertex:
  assumes  "t_v_evaluation (graph_interpretation G f) (atom (v, i)) = Ttrue"
  shows  "f(v)=i"
proof(rule ccontr)
  assume  "f v \<noteq> i" hence "t_v_evaluation (graph_interpretation G f) (atom (v, i)) \<noteq> Ttrue" by auto
  hence "t_v_evaluation (graph_interpretation G f) (atom (v, i)) = Ffalse"
  using non_Ttrue[of "graph_interpretation G f" "atom (v, i)"] by auto
  thus False using assms by simp
qed

lemma value2:
  assumes  "i\<noteq>j" and "F =\<not>.(atom (v, i) \<and>. atom (v, j))"
  shows "t_v_evaluation (graph_interpretation G f) F = Ttrue"
proof(rule ccontr)
  assume "t_v_evaluation (graph_interpretation G f) F \<noteq> Ttrue"
  hence  "t_v_evaluation (graph_interpretation G f) (\<not>.(atom (v, i) \<and>. atom (v, j))) \<noteq> Ttrue"
    using assms(2) by auto
  hence "t_v_evaluation (graph_interpretation G f) (\<not>.(atom (v, i) \<and>. atom (v, j))) = Ffalse" using
  non_Ttrue[of "graph_interpretation G f" "\<not>.(atom (v, i) \<and>. atom (v, j))" ]
    by auto
  hence  "t_v_evaluation (graph_interpretation G f) ((atom (v, i) \<and>. atom (v, j))) = Ttrue"
  using  NegationValues1[of "graph_interpretation G f" "(atom (v, i) \<and>. atom (v, j))"] by auto
  hence "t_v_evaluation (graph_interpretation G f) (atom (v, i)) = Ttrue" and
  "t_v_evaluation (graph_interpretation G f) (atom (v, j)) = Ttrue"
  using ConjunctionValues[of "graph_interpretation G f" "atom (v, i)" "atom (v, j)"] by auto
  hence "f(v)=i" and "f(v)=j" using t_value_vertex by auto
  hence "i=j" by auto
  thus False using assms(1) by auto
qed

lemma value3:
  assumes "f(u)\<noteq>f(v)" and  "F =\<not>.(atom (u, i) \<and>. atom (v, i))"
  shows "t_v_evaluation (graph_interpretation G f) F = Ttrue"
proof(rule ccontr)
  assume "t_v_evaluation (graph_interpretation G f) F \<noteq> Ttrue"
  hence(*and "finite S"*)
  "t_v_evaluation (graph_interpretation G f) (\<not>.(atom (u, i) \<and>. atom (v, i))) \<noteq> Ttrue"
    using assms(2) by auto
  hence "t_v_evaluation (graph_interpretation G f) (\<not>.(atom (u, i) \<and>. atom (v, i))) = Ffalse"
    using
  non_Ttrue[of "graph_interpretation G f" "\<not>.(atom (u, i) \<and>. atom (v, i))"]
    by auto
  hence  "t_v_evaluation (graph_interpretation G f) ((atom (u, i) \<and>. atom (v, i))) = Ttrue"
    using  NegationValues1[of "graph_interpretation G f" "(atom (u, i) \<and>. atom (v, i))"]
    by auto
  hence "t_v_evaluation (graph_interpretation G f) (atom (u, i)) = Ttrue" and
  "t_v_evaluation (graph_interpretation G f) (atom (v, i)) = Ttrue"
    using ConjunctionValues[of "graph_interpretation G f" "atom (u, i)" "atom (v, i)"]
    by auto
  hence "f(u)=i" and "f(v)=i" using t_value_vertex by auto
  hence "f(u)=f(v)" by auto
  thus False using assms(1) by auto
qed

theorem coloring_satisfiable:
  assumes "is_graph G" and "S \<subseteq> (\<T> G k)" and
  "coloring f k (subgraph_aux G (vertices_set_formulas S))"
  shows "satisfiable S"
proof-
  let ?V = "vertices_set_formulas S"
  let ?H = "subgraph_aux G ?V"
  have "(graph_interpretation ?H f) model S"
  proof(unfold model_def)
    show "\<forall> F \<in> S. t_v_evaluation (graph_interpretation ?H f) F  = Ttrue"
    proof
      fix F assume "F \<in> S"
      show  "t_v_evaluation (graph_interpretation ?H f) F  = Ttrue"
      proof-
        have 1:  "vertices_formula F \<subseteq>?V"
        proof
          fix v
          assume "v \<in> (vertices_formula F)" thus "v \<in> ?V"
          using `F \<in> S` by(unfold vertices_set_formulas_def,auto)
        qed
        have "F \<in> (\<F> G k) \<union> (\<G> G k)  \<union> (\<H> G k)"
        using  `F \<in> S` assms(2)  by(unfold \<T>_def,auto)
        hence  "F \<in> (\<F> G k) \<or> F \<in> (\<G> G k) \<or> F \<in> (\<H> G k)" by auto
        thus ?thesis
        proof(rule disjE)
          assume "F \<in> (\<F> G k)"
          hence "\<exists>v\<in>V[G]. F = atomic_disjunctions v  k"  by(unfold \<F>_def,auto)
          then obtain v
          where v: "v\<in>V[G]" and F: "F = atomic_disjunctions v k"
            by auto
          have "v\<in>?V" using F vertices_disjunction[of "F"] 1 by auto
          hence "v\<in> V[?H]" by(unfold subgraph_aux_def, auto)
          hence "f(v)\<le> k" using coloring_def[of "f" "k" "?H"] assms(3) by auto
          thus ?thesis using F  value1[OF `v\<in>V[?H]`] by auto
          next
          assume "F \<in> (\<G> G k) \<or> F \<in> (\<H> G k)"
          thus ?thesis
          proof(rule disjE)
            assume "F \<in> (\<G> G k)"
            hence "\<exists>v.\<exists>i.\<exists>j. F = \<not>.(atom (v, i) \<and>. atom(v,j)) \<and> ( i\<noteq>j)"
            by(unfold \<G>_def, auto)
            then obtain v i j
            where "F = \<not>.(atom (v, i) \<and>. atom(v,j))" and "(i\<noteq>j)"
            by auto
            thus "t_v_evaluation (graph_interpretation ?H f) F = Ttrue"
            using value2[OF `i\<noteq>j` `F = \<not>.(atom (v, i) \<and>. atom(v,j))`]
            by auto
            next
            assume " F \<in> (\<H> G k)"
            hence  "\<exists>u.\<exists>v.\<exists>i.(F = \<not>.(atom (u, i) \<and>. atom(v,i)) \<and>  (u,v)\<in>E[G])"
            by(unfold \<H>_def, auto)
            then obtain u v i
            where F:  "F = \<not>.(atom (u, i) \<and>. atom(v,i))" and uv: "(u,v)\<in>E[G]"
            by auto
            have "vertices_formula F = {u,v}" using F by auto
            hence "{u,v} \<subseteq> ?V" using 1 by auto
            hence "(u,v)\<in>E[?H]" using uv  by(unfold subgraph_aux_def, auto)
            hence  "f(u) \<noteq>f(v)" using  coloring_def[of "f" "k" "?H"] assms(3)
              by auto
            show ?thesis
              using value3[OF `f(u) \<noteq>f(v)` `F = \<not>.(atom (u, i) \<and>. atom(v,i))`]
              by auto
          qed
        qed
      qed
    qed
  qed
  thus "satisfiable S" by(unfold satisfiable_def, auto)
qed

lemma diag_nat:
  shows "\<forall>yz.\<exists>x. (y,z) = diag x"
  using enumeration_natxnat by(unfold enumeration_def,auto)

lemma Enum_Formulas_Vertices:
  assumes "\<exists>g. enumeration (g:: nat \<Rightarrow>'v)"
  shows "\<exists>f. enumeration (f:: nat \<Rightarrow>('v \<times> nat)formula)"
proof-
  from assms obtain g where e: "enumeration (g:: nat \<Rightarrow>'v)" by auto
  have  "enumeration ((\<lambda>m.(g(fst(diag m)),snd(diag m))):: nat \<Rightarrow>('v \<times> nat))"
  proof(unfold enumeration_def)
    show  "\<forall>y::('v \<times> nat). \<exists>m. y = (g (fst (diag m)), snd (diag m))"
    proof
      fix y::"('v \<times> nat)"
      show "\<exists>m. y = (g (fst (diag m)), snd (diag m))"
      proof-
        have  "y = ((fst y), (snd y))" by auto
        from e have  "\<forall>w::'v. \<exists>n. w = (g n)" by(unfold enumeration_def, auto)
        hence  "\<exists>n. (fst y) = (g n)" by auto
        then obtain n where n: "(fst y) = (g n)" by auto
        have "\<exists>m. (n, (snd y)) = diag m" using diag_nat by auto
        hence "\<exists>m. (n, (snd y)) = (fst (diag m), snd (diag m))" by simp
        hence "\<exists>m.((fst y), (snd y)) = (g(fst (diag m)), snd (diag m))"
          using n by blast
        thus "\<exists>m. y = (g (fst (diag m)), snd (diag m))" by auto
      qed
    qed
  qed
  thus "\<exists>f. enumeration (f:: nat \<Rightarrow>('v \<times> nat)formula)"
    using EnumerationFormulasP1 by auto
qed

(* Good replacing EnumeracionFormulasP1 above *)

fun graph_coloring ::  "(('v \<times> nat) \<Rightarrow> v_truth) \<Rightarrow> nat  \<Rightarrow> ('v \<Rightarrow> nat)"
  where
"graph_coloring I k = (\<lambda>v.(THE i. (t_v_evaluation I (atom (v,i)) = Ttrue) \<and> 0\<le>i \<and> i\<le>k))"

lemma unicity:
  assumes "(t_v_evaluation I (atom (v, i)) = Ttrue \<and> 0\<le>i \<and> i \<le> k)"
  and "\<forall>j. (0\<le>j \<and> j\<le>k \<and> i\<noteq>j) \<longrightarrow> (t_v_evaluation I (\<not>.(atom (v, i) \<and>. atom(v,j))) = Ttrue)"
  shows "\<forall>j. (0\<le>j \<and> j\<le>k \<and> i\<noteq>j) \<longrightarrow>  t_v_evaluation I (atom (v, j)) = Ffalse"
proof(rule allI, rule impI)
  fix j
  assume hip: "0\<le>j \<and> j\<le>k \<and> i\<noteq>j"
  show "t_v_evaluation I (atom (v, j)) = Ffalse"
  proof(rule ccontr)
    assume "t_v_evaluation I (atom (v, j)) \<noteq> Ffalse"
    hence "t_v_evaluation I (atom (v, j)) = Ttrue" using CasosValor by blast
    hence 1: "t_v_evaluation I (atom (v, i) \<and>. atom(v,j))  = Ttrue"
      using assms(1) v_conjunction_def by auto
    have "t_v_evaluation I (\<not>.(atom (v, i) \<and>. atom(v,j))) = Ttrue"
      using hip assms(2)  by auto
    hence "t_v_evaluation I (atom (v, i) \<and>. atom(v,j)) = Ffalse"
      using NegationValues2  by blast
    thus False using 1  by auto
  qed
qed

lemma existence:
  assumes "(t_v_evaluation I (atom (v, i)) = Ttrue \<and> 0\<le>i \<and> i \<le> k)"
  and  "\<forall>j. (0\<le>j \<and> j\<le>k \<and> i\<noteq>j) \<longrightarrow>  t_v_evaluation I (atom (v, j)) = Ffalse"
shows  "(\<forall>x. (t_v_evaluation I (atom (v, x)) = Ttrue \<and> 0\<le>x \<and> x \<le> k) \<longrightarrow> x = i)"
proof(rule allI)
  fix x
  show "t_v_evaluation I (atom (v, x)) = Ttrue \<and> 0 \<le> x \<and> x \<le> k \<longrightarrow> x = i"
  proof(rule impI)
    assume hip: "t_v_evaluation I (atom (v, x)) = Ttrue \<and> 0\<le>x \<and> x \<le> k" show "x = i"
    proof(rule ccontr)
      assume 1:  "x \<noteq> i"
      have  "0\<le>x \<and> x \<le> k" using hip by auto
      hence "t_v_evaluation I (atom (v, x)) = Ffalse" using 1 assms(2) by auto
      thus False using hip by auto
    qed
  qed
qed

lemma exist_unicity1:
  assumes  "(t_v_evaluation I (atom (v, i)) = Ttrue \<and> 0\<le>i \<and> i \<le> k)"
  and "\<forall>j. (0\<le>j \<and> j\<le>k \<and> i\<noteq>j) \<longrightarrow> (t_v_evaluation I (\<not>.(atom (v, i) \<and>. atom(v,j))) = Ttrue)"
shows "(\<forall>x. (t_v_evaluation I (atom (v, x)) = Ttrue \<and> 0\<le>x \<and> x \<le> k) \<longrightarrow> x = i)"
using assms  unicity[of "I" "v" "i" "k" ] existence[of "I" "v" "i" "k"]  by blast

lemma exist_unicity2:
  assumes "(t_v_evaluation I (atom (v, i)) = Ttrue \<and> 0\<le>i \<and> i \<le> k )" and
  "(\<And>x. (t_v_evaluation I (atom (v, x)) = Ttrue \<and> 0\<le>x \<and> x \<le> k) \<Longrightarrow> x = i)"
shows "(THE a. (t_v_evaluation I (atom (v,a)) = Ttrue \<and> 0\<le>a \<and> a \<le> k )) = i"
  using assms by (rule the_equality)

lemma exist_unicity:
  assumes "(t_v_evaluation I (atom (v, i)) = Ttrue \<and> 0\<le>i \<and> i\<le>k )" and
  "\<forall>j. (0\<le>j \<and> j\<le>k \<and> i\<noteq>j) \<longrightarrow> (t_v_evaluation I (\<not>.(atom (v, i) \<and>. atom(v,j))) = Ttrue)"
shows "(THE a. (t_v_evaluation I (atom (v,a)) = Ttrue \<and> 0\<le>a \<and> a \<le> k )) = i"
 using assms  exist_unicity1[of "I" "v" "i" "k" ] exist_unicity2[of "I" "v" "i" "k"] by blast

lemma unique_color:
  assumes  "v \<in> V[G]"
  shows "\<forall>i j.(0\<le>i \<and> 0\<le>j \<and> i\<le>k \<and> j\<le>k \<and> i\<noteq>j) \<longrightarrow>  (\<not>.(atom (v, i) \<and>. atom(v,j))\<in> (\<G> G k))"
proof(rule allI )+
  fix i j
  show "0 \<le> i \<and> 0 \<le> j \<and> i \<le> k \<and> j \<le> k \<and> i \<noteq> j \<longrightarrow> \<not>.(atom (v, i) \<and>. atom (v, j)) \<in> (\<G> G k)"
  proof(rule impI)
    assume "0 \<le> i \<and> 0 \<le> j \<and> i \<le> k \<and> j \<le> k \<and> i \<noteq> j"
    thus "\<not>.(atom (v, i) \<and>. atom (v, j)) \<in> (\<G> G k)"
      using `v \<in> V[G]` by(unfold  \<G>_def, auto)
  qed
qed

lemma different_colors:
  assumes  "u \<in> V[G]" and  "v\<in>V[G]" and "(u,v)\<in>E[G]"
  shows  "\<forall>i.(0\<le>i \<and> i\<le>k) \<longrightarrow>  (\<not>.(atom (u, i) \<and>. atom(v,i))\<in> (\<H> G k))"
proof(rule allI)
  fix i
  show "0\<le>i \<and> i\<le>k \<longrightarrow>  (\<not>.(atom (u, i) \<and>. atom(v,i))\<in> (\<H> G k))"
  proof(rule impI)
    assume "0\<le>i \<and> i\<le>k"
    thus  "\<not>.(atom (u, i) \<and>. atom(v,i))\<in> (\<H> G k)"
      using assms  by(unfold  \<H>_def, auto)
  qed
qed

lemma atom_value:
  assumes "(t_v_evaluation I (atomic_disjunctions u  k)) = Ttrue"
  shows "\<exists>i.(t_v_evaluation I (atom (u,i)) = Ttrue) \<and> 0\<le>i \<and> i\<le>k"
proof-
  have "(t_v_evaluation I (atomic_disjunctions u  k)) = Ttrue \<Longrightarrow>
  \<exists>i.(t_v_evaluation I (atom (u,i)) = Ttrue) \<and> 0\<le>i \<and> i\<le>k"
  proof(induct k)
    case(0)
    assume "(t_v_evaluation I (atomic_disjunctions u 0)) = Ttrue"
    thus "\<exists>i. t_v_evaluation I (atom (u, i)) = Ttrue \<and> 0\<le>i \<and>  i \<le> 0" by auto
    next
    case(Suc k)
    from Suc(1) Suc(2) show ?case
    proof-
      have "t_v_evaluation I (atom (u, (Suc k)) \<or>. (atomic_disjunctions u k)) = Ttrue"
        using Suc(2) by auto
      hence "t_v_evaluation I (atom (u, (Suc k))) = Ttrue \<or>
      (t_v_evaluation I (atomic_disjunctions u k)) = Ttrue"
        using  DisjunctionValues[of I "(atom (u, (Suc k)))"] by auto
      thus ?case
      proof(rule disjE)
        assume "t_v_evaluation I (atom (u, (Suc k))) = Ttrue"
        thus ?case  by(rule_tac  x= "Suc k" in exI, auto)
        next
        assume "t_v_evaluation I (atomic_disjunctions u k) = Ttrue"
        thus ?case using Suc(1) by auto
      qed
    qed
  qed
  thus ?thesis using assms by auto
qed

lemma coloring_function:
  assumes "u \<in> V[G]" and "I model (\<T> G k)"
  shows "\<exists>!i. (t_v_evaluation I (atom (u,i)) = Ttrue \<and> 0\<le>i \<and> i\<le>k) \<and> graph_coloring I k u = i"
proof-
  from  `u \<in> V[G]`
  have "atomic_disjunctions u  k \<in> \<F> G k" by(induct, unfold  \<F>_def, auto)
  hence  "atomic_disjunctions u  k \<in> \<T> G k"  by(unfold  \<T>_def, auto)
  hence "(t_v_evaluation I (atomic_disjunctions u  k)) = Ttrue"
    using assms(2) model_def[of I "\<T> G k"] by auto
  hence "\<exists>i.(t_v_evaluation I (atom (u,i)) = Ttrue \<and> 0\<le>i \<and> i\<le>k)"
    using atom_value by auto
  then obtain i where i: "(t_v_evaluation I (atom (u,i)) = Ttrue) \<and> 0\<le>i \<and>  i\<le>k"
    by auto
  moreover
  have "\<forall>i j.(0\<le>i \<and> 0\<le>j \<and> i\<le>k \<and> j\<le>k \<and> i\<noteq>j)\<longrightarrow>
  (\<not>.(atom (u, i) \<and>.atom(u,j))\<in> (\<G> G k))"
  using `u \<in> V[G]` unique_color[of "u"] by auto
  hence "\<forall>j.(0\<le>j  \<and> j\<le>k \<and> i\<noteq>j) \<longrightarrow>  (\<not>.(atom (u, i) \<and>. atom(u,j))\<in> \<T> G k)"
  using i  by(unfold  \<T>_def, auto)
  hence
  "\<forall>j. (0\<le>j \<and> j\<le>k \<and> i\<noteq>j) \<longrightarrow> (t_v_evaluation I (\<not>.(atom (u, i) \<and>. atom(u,j)))  = Ttrue)"
  using assms(2)  model_def[of I "\<T> G k"] by blast
  hence "(THE a. (t_v_evaluation I (atom (u,a)) = Ttrue \<and> 0\<le>a \<and> a \<le> k ))= i"
    using i exist_unicity[of "I" "u"] by blast
  hence "graph_coloring I k u = i" by auto
  hence
  "(t_v_evaluation I (atom (u,i)) = Ttrue \<and> 0\<le>i \<and>  i\<le>k) \<and>
   graph_coloring I k u = i"
    using i by auto
  thus ?thesis  by auto
qed

lemma \<H>1:
  assumes "(t_v_evaluation I (atom (u, a)) = Ttrue \<and> 0\<le>a \<and> a\<le>k )" and  "(t_v_evaluation I (atom (v, b)) = Ttrue \<and> 0\<le>b \<and> b\<le>k)"
  and "\<forall>i.(0\<le>i \<and> i\<le>k) \<longrightarrow> (t_v_evaluation I (\<not>.(atom (u, i) \<and>. atom(v,i))) = Ttrue)"
  shows "a\<noteq>b"
proof(rule ccontr)
  assume  "\<not> a \<noteq> b"
  hence "a=b" by auto
  hence "t_v_evaluation I (atom (u, a)) = Ttrue" and  "t_v_evaluation I (atom (v, a)) = Ttrue" using assms by auto
  hence "t_v_evaluation I (atom (u, a) \<and>. atom(v,a)) = Ttrue" using v_conjunction_def by auto
  hence "t_v_evaluation I (\<not>.(atom (u, a) \<and>. atom(v,a))) = Ffalse" using v_negation_def by auto
  moreover
  have "0\<le>a \<and> a\<le>k" using assms(1) by auto
  hence "t_v_evaluation I (\<not>.(atom (u, a) \<and>. atom(v,a))) = Ttrue" using assms(3) by auto
  finally show False by auto
qed

lemma distinct_colors:
  assumes "is_graph G" and "(u,v) \<in> E[G]" and I: "I model (\<T> G k)"
  shows "graph_coloring I k u \<noteq> graph_coloring I k v"
proof-
  have "u \<noteq> v" and "u \<in> V[G]" and "v \<in> V[G]"  using  `(u,v) \<in> E[G]` `is_graph G`
    by(unfold is_graph_def, auto)
  have "\<exists>!i. (t_v_evaluation I (atom (u,i)) = Ttrue \<and> 0\<le>i \<and>  i\<le>k) \<and>  graph_coloring I k u = i"
  using coloring_function[OF `u \<in> V[G]`  I]  by blast
  then obtain i where i1: "(t_v_evaluation I (atom (u,i)) = Ttrue \<and> 0\<le>i \<and> i\<le>k)" and i2: "graph_coloring I k u = i"
    by auto
  have  "\<exists>!j. (t_v_evaluation I (atom (v,j)) = Ttrue \<and> 0\<le>j \<and>  j\<le>k) \<and> graph_coloring I k v = j"
  using coloring_function[OF `v \<in> V[G]`  I]  by blast
  then obtain j where j1: "(t_v_evaluation I (atom (v,j)) = Ttrue \<and> 0\<le>j \<and> j\<le>k)" and
   j2: "graph_coloring I k v = j" by auto
  have  "\<forall>i.(0\<le>i \<and> i\<le>k) \<longrightarrow>  (\<not>.(atom (u, i) \<and>. atom(v,i))\<in> \<H> G k)"
  using `u \<in> V[G]` `v \<in> V[G]`  `(u,v) \<in> E[G]`  by(unfold  \<H>_def, auto)
  hence "\<forall>i. (0\<le>i \<and> i\<le>k) \<longrightarrow> \<not>.(atom (u, i) \<and>. atom(v,i)) \<in> \<T> G k"
  by(unfold  \<T>_def, auto)
  hence  "\<forall>i. (0\<le>i \<and> i\<le>k) \<longrightarrow> (t_v_evaluation I  (\<not>.(atom (u, i) \<and>. atom(v,i))) = Ttrue)"
  using assms(2) I model_def[of I "\<T> G k"] by blast
  hence "i \<noteq> j" using i1 j1 \<H>1[of "I" "u" "i"  "k" "v" "j"] by blast
  thus ?thesis using i2 j2 by auto
qed

theorem satisfactible_coloring:
  assumes "is_graph G" and  "satisfiable (\<T> G k)"
  shows  "colorable G k"
proof(unfold colorable_def)
  show "\<exists>f. coloring f k G"
  proof-
    from assms(2) have "\<exists>I. I model (\<T> G k)"  by(unfold satisfiable_def)
    then obtain I where I: "I model (\<T> G k)" by auto
    hence  "coloring (graph_coloring I k) k G"
    proof(unfold coloring_def)
      show
      "(\<forall>u. u \<in> V[G] \<longrightarrow> (graph_coloring I  k u) \<le> k) \<and> (\<forall>u v. (u, v) \<in> E[G]
      \<longrightarrow> graph_coloring I k u \<noteq> graph_coloring I k v)"
      proof(rule conjI)
        show "\<forall>u. u \<in> V[G] \<longrightarrow> graph_coloring I k u \<le> k"
        proof(rule allI, rule impI)
          fix u
          assume  "u \<in> V[G]"
          show "graph_coloring I k u \<le> k"
            using coloring_function[OF `u \<in> V[G]` I] by blast
        qed
        next
          show
          "\<forall>u v. (u, v) \<in> E[G] \<longrightarrow>
          graph_coloring I k u \<noteq> graph_coloring I k v"
          proof(rule allI,rule allI,rule impI)
          fix u v
          assume "(u,v) \<in> E[G]"
          thus "graph_coloring I k u \<noteq> graph_coloring I k v"
          using  distinct_colors[OF `is_graph G` `(u,v) \<in> E[G]`  I]  by blast
        qed
      qed
    qed
    thus "\<exists>f. coloring f k G" by auto
  qed
qed

theorem coloring:
  assumes "is_graph (G::('vertices set) \<times> (('vertices \<times> 'vertices) set))"
  and "\<exists>g. enumeration (g:: nat \<Rightarrow>'vertices)"
  and "\<forall>H. (is_induced_subgraph H G \<and> finite_graph H \<longrightarrow> colorable H k)"
  shows "colorable G k"
proof-
  have "\<forall> S. S \<subseteq> (\<T> G k) \<and> (finite S) \<longrightarrow> satisfiable S"
  proof(rule allI, rule impI)
    fix S assume "S \<subseteq> (\<T> G k) \<and> (finite S)"
    hence hip1:  "S \<subseteq> (\<T> G k)" and  hip2: "finite S" by auto
    show "satisfiable S"
    proof -
      let ?V = "vertices_set_formulas S"
      let ?H = "(?V, E[G] \<inter> (?V \<times> ?V))"
      have "is_induced_subgraph ?H G"
        using assms(1) hip1 induced_subgraph[of G S k]
        by(unfold subgraph_aux_def, auto)
      moreover
      have "finite_graph ?H"
        using assms(1) hip1 hip2 finite_subgraph[of G S k]
        by(unfold subgraph_aux_def, auto)
      ultimately
      have "colorable ?H k" using assms(3) by auto
      hence  "\<exists>f. coloring f k ?H" by(unfold colorable_def, auto)
      then obtain f where "coloring f k ?H" by auto
      thus "satisfiable S" using coloring_satisfiable[OF assms(1) hip1]
        by(unfold subgraph_aux_def, auto)
    qed
  qed
  hence "satisfiable (\<T> G k)" using
   Compacteness_Theorem[OF Enum_Formulas_Vertices[OF
  `\<exists>g. enumeration (g:: nat \<Rightarrow>'v)` ], of "(\<T> G k)"]
  by auto
  thus ?thesis using assms(1) satisfactible_coloring by blast
qed
end


theory Llist_of_tree_of
    imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer

codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

codatatype 'a Tree = is_Leaf: Leaf |
           Node (left: "'a Tree") (val: 'a) (right: "'a Tree")
where
  "left Leaf = Leaf"
| "right Leaf = Leaf"

primcorec chop :: "'a Tree \<Rightarrow> 'a Tree"
where
  "is_Leaf t \<or> is_Leaf (left t) \<and> is_Leaf (right t) \<Longrightarrow> is_Leaf (chop t)"
| "val (chop t) = (if is_Leaf (left t) then val (right t) else val (left t))"
| "left (chop t) = (if is_Leaf (left t) then left (right t) else right t)"
| "right (chop t) = (if is_Leaf (left t) then right (right t) else chop (left t))"

(* Converts Llist to right-leaning tree *)
primcorec tree_of :: "'a Llist \<Rightarrow> 'a Tree"
where
  "lnull xs \<Longrightarrow> is_Leaf (tree_of xs)"
| "left (tree_of xs) = Leaf"
| "val (tree_of xs) = lhd xs"
| "right (tree_of xs) = tree_of (ltl xs)"

primcorec llist_of :: "'a Tree \<Rightarrow> 'a Llist"
where
  "is_Leaf t \<Longrightarrow> lnull (llist_of t)"
| "lhd (llist_of t) = val t"
| "ltl (llist_of t) = llist_of (chop t)"
(*hipster tree_of*)
lemma lemma_a [thy_expl]: "Node Leaf y Leaf = tree_of (LCons y LNil)"
  apply (coinduction  arbitrary: y rule: Llist_of_tree_of.Tree.coinduct_strong)
  by (simp_all add: tree_of.ctr(1))

lemma lemma_aa [thy_expl]: "Node Leaf y (tree_of z) = tree_of (LCons y z)"
  apply (coinduction  arbitrary: y z rule: Llist_of_tree_of.Tree.coinduct_strong)
  by simp
(*hipster tree_of llist_of*)
lemma unknown [thy_expl]: "left (left (left y)) = Leaf"
  oops

lemma unknown [thy_expl]: "ltl (ltl (ltl y)) = LNil"
  oops
(*hipster chop*)
lemma unknown [thy_expl]: "left (left (left y)) = Leaf"
  oops
lemma chop_tree_of [simp]: "chop (tree_of xs) = tree_of (ltl xs)"
apply(cases xs)
apply simp_all
done
theorem llist_of_tree_of: "llist_of (tree_of xs) = xs"
  by hipster_coinduct_sledgehammer
apply(coinduction arbitrary: xs)
  by (simp add: chop.code llist_of.code tree_of.ctr(2))
end


section "Atoms"
theory PolyAtoms
  imports ExecutiblePolyProps
begin

subsection "Definition"

datatype (atoms: 'a) fm =
  TrueF | FalseF | Atom 'a | And "'a fm" "'a fm" | Or "'a fm" "'a fm" |
  Neg "'a fm" | ExQ "'a fm" | AllQ "'a fm" | ExN "nat" "'a fm" | AllN "nat" "'a fm"

definition neg where
  "neg \<phi> = (if \<phi>=TrueF then FalseF else if \<phi>=FalseF then TrueF else Neg \<phi>)"

definition "and" :: "'a fm \<Rightarrow> 'a fm \<Rightarrow> 'a fm" where
  "and \<phi>\<^sub>1 \<phi>\<^sub>2 =
 (if \<phi>\<^sub>1=TrueF then \<phi>\<^sub>2 else if \<phi>\<^sub>2=TrueF then \<phi>\<^sub>1 else
  if \<phi>\<^sub>1=FalseF \<or> \<phi>\<^sub>2=FalseF then FalseF else And \<phi>\<^sub>1 \<phi>\<^sub>2)"

definition or :: "'a fm \<Rightarrow> 'a fm \<Rightarrow> 'a fm" where
  "or \<phi>\<^sub>1 \<phi>\<^sub>2 =
 (if \<phi>\<^sub>1=FalseF then \<phi>\<^sub>2 else if \<phi>\<^sub>2=FalseF then \<phi>\<^sub>1 else
  if \<phi>\<^sub>1=TrueF \<or> \<phi>\<^sub>2=TrueF then TrueF else Or \<phi>\<^sub>1 \<phi>\<^sub>2)"

definition list_conj :: "'a fm list \<Rightarrow> 'a fm" where
  "list_conj fs = foldr and fs TrueF"

definition list_disj :: "'a fm list \<Rightarrow> 'a fm" where
  "list_disj fs = foldr or fs FalseF"

text "
The atom datatype corresponds to the defined in Tobias's LinearQuantifierElim.
"

datatype atom = Less "real mpoly" | Eq "real mpoly" | Leq "real mpoly" | Neq "real mpoly"

text
  "
For each atom, the real mpoly corresponds to a polynomial from the Polynomials library where
we allow for real valued coefficients.

The variables in the polynomials are in De Bruijn notation where variable 0 corresponds to the
variable of the innermost quantifier, then variable 1 is the next quantifier out from that, and
so on. Any variable number greater than the number of quantifiers is a free variable. This means
that we have a list of infinite free variables we can pick from and if we want to refer to the
ith free variable (indexed at 0)  within an atom that is bound in j quantifiers, then we would use
var (i+j).

The polynomials are all standardized so that they are compared to a 0 on the right. This means
the atom Less p corresponds to $p\\leq0$ and the atom Eq p corresponds to $p=0$ and so on. This
restriction doesn't lose any generality and having all 4 of these kinds of atoms prevents loss
of efficiency as the negation of these atoms do not introduce additional logical connectives. The
following aNeg function demonstrates this.
"

fun aNeg :: "atom \<Rightarrow> atom" where
  "aNeg (Less p) = Leq (-p)" |
  "aNeg (Eq p) = Neq p" |
  "aNeg (Leq p) = Less (-p)" |
  "aNeg (Neq p) = Eq p"

subsection "Evaluation"

text "
In order to do any proofs with these atoms, we need a method of comparing two atoms to check if they
are equal. Instead of trying to manipulate the polynomials to a standard form to compare them, it
is a lot easier to plug in values for every variable and check if the results are equal. If every
single real value input for each variable matches in truth value for both atoms, then they are equal.

aEval a l corresponds to plugging in the real value list l into the variables of atom a and then
evaluating the truth value of it
"
fun aEval :: "atom \<Rightarrow> real list \<Rightarrow> bool" where
  "aEval (Eq p) L = (insertion (nth_default 0 L) p = 0)" |
  "aEval (Less p) L = (insertion (nth_default 0 L) p < 0)" |
  "aEval (Leq p) L = (insertion (nth_default 0 L) p \<le> 0)" |
  "aEval (Neq p) L = (insertion (nth_default 0 L) p \<noteq> 0)"

text "
aNeg\\_aEval shows the general format for how things are proven equal. Plugging in the values to an
original atom a will results in the opposite truth value if we transformed with the aNeg function.
"
lemma aNeg_aEval : "aEval a L \<longleftrightarrow> (\<not> aEval (aNeg a) L)"
  apply(cases a)
     apply(auto)
     apply(smt insertionNegative)
    apply(smt insertionNegative)
   apply(smt insertionNegative)
  apply(smt insertionNegative)
  done

text "
We can extend this to formulas instead of just atoms. Given a formula in prenex normal form,
we simply iterate through and apply the quantifiers
"

fun eval :: "atom fm \<Rightarrow> real list \<Rightarrow> bool" where
  "eval (Atom a) \<Gamma> = aEval a \<Gamma>" |
  "eval (TrueF) _ = True" |
  "eval (FalseF) _ = False" |
  "eval (And \<phi> \<psi>) \<Gamma> = ((eval \<phi> \<Gamma>) \<and> (eval \<psi> \<Gamma>))" |
  "eval (Or \<phi> \<psi>) \<Gamma> = ((eval \<phi> \<Gamma>) \<or> (eval \<psi> \<Gamma>))" |
  "eval (Neg \<phi>) \<Gamma> = (\<not> (eval \<phi> \<Gamma>))" |
  "eval (ExQ \<phi>) \<Gamma> = (\<exists>x. (eval \<phi> (x#\<Gamma>)))" |
  "eval (AllQ \<phi>) \<Gamma> = (\<forall>x. (eval \<phi> (x#\<Gamma>)))"|
  "eval (AllN i \<phi>) \<Gamma> = (\<forall>l. length l = i \<longrightarrow> (eval \<phi> (l @ \<Gamma>)))"|
  "eval (ExN i \<phi>) \<Gamma> = (\<exists>l. length l = i \<and> (eval \<phi> (l @ \<Gamma>)))"

lemma "eval (ExQ (Or (Atom A) (Atom B))) xs =  eval (Or (ExQ(Atom A)) (ExQ(Atom B))) xs"
  by(auto)

lemma eval_neg_neg : "eval (neg (neg f)) L \<longleftrightarrow> eval f L"
  by (simp add: neg_def)

lemma eval_neg : "(\<not> eval (neg f) L) \<longleftrightarrow> eval f L"
  by (simp add: neg_def)

lemma eval_and : "eval (and a b) L \<longleftrightarrow> (eval a L \<and> eval b L)"
  by (simp add: and_def)

lemma eval_or : "eval (or a b) L \<longleftrightarrow> (eval a L \<or> eval b L)"
  by (simp add: or_def)

lemma eval_Or : "eval (Or a b) L \<longleftrightarrow> (eval a L \<or> eval b L)"
  by (simp)

lemma eval_And : "eval (And a b) L \<longleftrightarrow> (eval a L \<and> eval b L)"
  by (simp)

lemma eval_not : "eval (neg a) L \<longleftrightarrow> \<not>(eval a L)"
  by (simp add: neg_def)

lemma eval_true : "eval TrueF L"
  by simp

lemma eval_false : "\<not>(eval FalseF L)"
  by simp

lemma eval_Neg : "eval (Neg \<phi>) L = eval (neg \<phi>) L"
  by (simp add: eval_not)

lemma eval_Neg_Neg : "eval (Neg (Neg \<phi>)) L = eval \<phi> L"
  by (simp add: eval_not)

lemma eval_Neg_And : "eval (Neg (And \<phi> \<psi>)) L = eval (Or (Neg \<phi>) (Neg \<psi>)) L"
  by simp

lemma aEval_leq : "aEval (Leq p) L = (aEval (Less p) L \<or> aEval (Eq p) L)"
  by auto

text "This function is misleading because it is true iff
  the variable given doesn't occur as a free variable in the atom fm"
fun freeIn :: "nat \<Rightarrow> atom fm \<Rightarrow> bool" where
  "freeIn var (Atom(Eq p)) = (var \<notin> (vars p))"|
  "freeIn var (Atom(Less p)) = (var \<notin> (vars p))"|
  "freeIn var (Atom(Leq p)) = (var \<notin> (vars p))"|
  "freeIn var (Atom(Neq p)) = (var \<notin> (vars p))"|
  "freeIn var (TrueF) = True"|
  "freeIn var (FalseF) = True"|
  "freeIn var (And a b) = ((freeIn var a) \<and> (freeIn var b))"|
  "freeIn var (Or a b) = ((freeIn var a) \<and> (freeIn var b))"|
  "freeIn var (Neg a) = freeIn var a"|
  "freeIn var (ExQ a) = freeIn (var+1) a"|
  "freeIn var (AllQ a) = freeIn (var+1) a"|
  "freeIn var (AllN i a) = freeIn (var+i) a"|
  "freeIn var (ExN i a) = freeIn (var+i) a"

fun liftmap :: "(nat \<Rightarrow> atom \<Rightarrow> atom fm) \<Rightarrow> atom fm \<Rightarrow> nat \<Rightarrow> atom fm" where
  "liftmap f TrueF var = TrueF"|
  "liftmap f FalseF var = FalseF"|
  "liftmap f (Atom a) var = f var a"|
  "liftmap f (And \<phi> \<psi>) var = And (liftmap f \<phi> var) (liftmap f \<psi> var)"|
  "liftmap f (Or \<phi> \<psi>) var = Or (liftmap f \<phi> var) (liftmap f \<psi> var)"|
  "liftmap f (Neg \<phi>) var = Neg (liftmap f \<phi> var)"|
  "liftmap f (ExQ \<phi>) var = ExQ (liftmap f \<phi> (var+1))"|
  "liftmap f (AllQ \<phi>) var = AllQ (liftmap f \<phi> (var+1))"|
  "liftmap f (AllN i \<phi>) var = AllN i (liftmap f \<phi> (var+i))"|
  "liftmap f (ExN i \<phi>) var = ExN i (liftmap f \<phi> (var+i))"

(*
fun greatestFreeVariable :: "atom fm \<Rightarrow> nat option" where
"greatestFreeVariable F = None"

fun is_closed :: "atom fm \<Rightarrow> real list \<Rightarrow> bool" where
"is_closed F xs = (case greatestFreeVariable F of Some x \<Rightarrow> (x = length xs) | None \<Rightarrow> (0=length xs))"
*)

fun depth :: "'a fm \<Rightarrow> nat"where
  "depth TrueF = 1"|
  "depth FalseF = 1"|
  "depth (Atom _) = 1"|
  "depth (And \<phi> \<psi>) = max (depth \<phi>) (depth \<psi>) + 1"|
  "depth (Or \<phi> \<psi>) = max (depth \<phi>) (depth \<psi>) + 1"|
  "depth (Neg \<phi>) = depth \<phi> + 1"|
  "depth (ExQ \<phi>) = depth \<phi> + 1"|
  "depth (AllQ \<phi>) = depth \<phi> + 1"|
  "depth (AllN i \<phi>) = depth \<phi> + 1"|
  "depth (ExN i \<phi>) = depth \<phi> + 1"

value "AllQ (And
    (ExQ (Atom (Eq (Var 1 * Var 2 - (Var 0)^2 * Var 3))))
    (Neg (AllQ (Atom (Leq (Const 5 * (Var 1)^2 - Var 0)))))
)"

fun negation_free :: "atom fm \<Rightarrow> bool" where
  "negation_free TrueF = True" |
  "negation_free FalseF = True " |
  "negation_free (Atom a) = True" |
  "negation_free (And \<phi>\<^sub>1 \<phi>\<^sub>2) = ((negation_free \<phi>\<^sub>1) \<and> (negation_free \<phi>\<^sub>2))" |
  "negation_free (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = ((negation_free \<phi>\<^sub>1) \<and> (negation_free \<phi>\<^sub>2))" |
  "negation_free (ExQ \<phi>) = negation_free \<phi>" |
  "negation_free (AllQ \<phi>) = negation_free \<phi>" |
  "negation_free (AllN i \<phi>) = negation_free \<phi>" |
  "negation_free (ExN i \<phi>) = negation_free \<phi>" |
  "negation_free (Neg _) = False"

subsection "Useful Properties"

lemma sum_eq : "eval (Atom(Eq p)) L \<longrightarrow> eval (Atom(Eq q)) L \<longrightarrow> eval (Atom(Eq(p + q))) L"
  by (simp add: insertion_add)

lemma freeIn_list_conj : "(\<forall>f\<in>set(F). freeIn var f) \<Longrightarrow> freeIn var (list_conj F)"
proof(induct F)
  case Nil
  then show ?case by(simp add: list_conj_def)
next
  case (Cons a F)
  then show ?case by (simp add: PolyAtoms.and_def list_conj_def)
qed

lemma freeIn_list_disj :
  assumes "\<forall>f\<in>set (L::atom fm list). freeIn var f"
  shows "freeIn var (list_disj L)"
  using assms
proof(induction L)
  case Nil
  then show ?case unfolding list_disj_def  by auto
next
  case (Cons a L)
  then show ?case unfolding list_disj_def or_def by simp
qed

lemma var_not_in_aEval : "freeIn var (Atom \<phi>) \<Longrightarrow> (\<exists>x. aEval \<phi> (list_update L var x)) = (\<forall>x. aEval \<phi> (list_update L var x))"
proof(induction \<phi>)
  case (Less p)
  then show ?case
    apply(auto)
    using not_contains_insertion
    by metis
next
  case (Eq p)
  then show ?case
    apply(auto)
    using not_contains_insertion
    by blast
next
  case (Leq p)
  then show ?case
    apply(auto)
    using not_contains_insertion
    by metis
next
  case (Neq p)
  then show ?case
    apply(auto)
    using not_contains_insertion
    by metis
qed

lemma var_not_in_aEval2 : "freeIn 0 (Atom \<phi>) \<Longrightarrow> (\<exists>x. aEval \<phi> (x#L)) = (\<forall>x. aEval \<phi> (x#L))"
  by (metis list_update_code(2) var_not_in_aEval)

lemma plugInLinear :
  assumes lLength : "length L>var"
  assumes nonzero : "B\<noteq>0"
  assumes hb : "\<forall>v. insertion (nth_default 0 (list_update L var v)) b = B"
  assumes hc : "\<forall>v. insertion (nth_default 0 (list_update L var v)) c = C"
  shows "aEval (Eq(b*Var var + c)) (list_update L var (-C/B))"
  by(simp add: lLength insertion_add insertion_mult nonzero hb hc insertion_var)

subsection "Some eval results"
lemma doubleExist : "eval (ExN 2 A) L = eval (ExQ (ExQ A)) L"
  apply(simp)
proof(safe)
  fix l
  assume h : "length l = 2" "eval A (l @ L)"
  show "\<exists>x xa. eval A (xa # x # L)"
  proof(cases l)
    case Nil
    then show ?thesis using h by auto
  next
    case (Cons a list)
    then have Cons' : "l = a # list" by auto
    then show ?thesis proof(cases list)
      case Nil
      then show ?thesis using h Cons  by auto
    next
      case (Cons b list)
      show ?thesis
        apply(rule exI[where x=b])apply(rule exI[where x=a])
        using h Cons' Cons  by auto
    qed
  qed
next
  fix x xa
  assume h : "eval A (xa # x # L)"
  show "\<exists>l. length l = 2 \<and> eval A (l @ L)"
    apply(rule exI[where x="[xa,x]"]) using h by simp
qed

lemma doubleForall : "eval (AllN 2 A) L = eval (AllQ (AllQ A)) L"
  apply(simp)using doubleExist eval_neg by fastforce

lemma unwrapExist : "eval (ExN (j + 1) A) L = eval (ExQ (ExN j A)) L"
  apply simp
  apply safe
  subgoal for l
    apply(rule exI[where x="nth l j"])
    apply(rule exI[where x="take j l"])
    apply auto
    by (metis Cons_nth_drop_Suc append.assoc append_Cons append_eq_append_conv_if append_take_drop_id lessI)
  subgoal for x l
    apply(rule exI[where x="l @ [x]"])
    by auto
  done

lemma unwrapExist' : "eval (ExN (j + 1) A) L =  eval (ExN j (ExQ A)) L"
  apply simp
  apply safe
  subgoal for l
    apply(rule exI[where x="drop 1 l"])
    apply auto
    apply(rule exI[where x="nth l 0"])
    by (metis Cons_nth_drop_Suc append_Cons drop0 zero_less_Suc)
  subgoal for l x
    apply(rule exI[where x="x#l"])
    by auto
  done

lemma unwrapExist'' : "eval (ExN (i + j) A) L = eval (ExN i(ExN j A)) L"
  apply simp
  apply safe
  subgoal for l
    apply(rule exI[where x="drop j l"])
    apply auto
    apply(rule exI[where x="take j l"])
    apply auto
    by (metis append.assoc append_take_drop_id)
  subgoal for l la
    apply(rule exI[where x="la@l"])
    by auto
  done

lemma unwrapForall : "eval (AllN (j + 1) A) L = eval (AllQ (AllN j A)) L"
  using unwrapExist[of j "neg A" L] eval_neg by fastforce

lemma unwrapForall' : "eval (AllN (j + 1) A) L =  eval (AllN j (AllQ A)) L"
  using unwrapExist'[of j "neg A" L] eval_neg by fastforce

lemma unwrapForall'' : "eval (AllN (i + j) A) L = eval (AllN i(AllN j A)) L"
  using unwrapExist''[of i j "neg A" L] eval_neg by fastforce

lemma var_not_in_eval : "\<forall>var. \<forall>L. (freeIn var \<phi> \<longrightarrow> ((\<exists>x. eval \<phi> (list_update L var x)) = (\<forall>x. eval \<phi> (list_update L var x))))"
proof(induction \<phi>)
  case TrueF
  then show ?case by(auto)
next
  case FalseF
  then show ?case by(auto)
next
  case (Atom x)
  then show ?case
    using var_not_in_aEval eval.simps(1) by blast
next
  case (And \<phi>1 \<phi>2)
  then show ?case by (meson eval.simps(4) freeIn.simps(7))
next
  case (Or \<phi>1 \<phi>2)
  then show ?case by fastforce
next
  case (Neg \<phi>)
  then show ?case by (meson eval.simps(6) freeIn.simps(9))
next
  case (ExQ \<phi>)
  fix xa L var x
  have  "(xa::real) # L[var := x] = (xa#L)[var+1:=x]"
    by simp
  then show ?case using ExQ
    by (metis Suc_eq_plus1 eval.simps(7) freeIn.simps(10) list_update_code(3))
next
  case (AllQ \<phi>)
  fix xa L var x
  have  "(xa::real) # L[var := x] = (xa#L)[var+1:=x]"
    by simp
  then show ?case using AllQ
    by (metis Suc_eq_plus1 eval.simps(8) freeIn.simps(11) list_update_code(3))
next
  case (ExN i \<phi>)
  {fix xa L var x
    assume "length (xa::real list) = i"
    have  "xa @ L[var := x] = (xa@L)[var+i:=x]"
      by (simp add: \<open>length xa = i\<close> list_update_append)
  }
  then show ?case using ExN
    by (metis eval.simps(10) freeIn.simps(13))
next
  case (AllN i \<phi>)
  {fix xa L var x
    assume "length (xa::real list) = i"
    have  "xa @ L[var := x] = (xa@L)[var+i:=x]"
      by (simp add: \<open>length xa = i\<close> list_update_append)
  }
  then show ?case using AllN
    by (metis eval.simps(9) freeIn.simps(12))
qed

lemma var_not_in_eval2 : "\<forall>L. (freeIn 0 \<phi> \<longrightarrow> ((\<exists>x. eval \<phi> (x#L)) = (\<forall>x. eval \<phi> (x#L))))"
  by (metis list_update_code(2) var_not_in_eval)

lemma var_not_in_eval3 :
  assumes "freeIn var \<phi>"
  assumes "length xs' = var"
  shows "((\<exists>x. eval \<phi> (xs'@x#L)) = (\<forall>x. eval \<phi> (xs'@x#L)))"
  using assms
  by (metis list_update_length var_not_in_eval)

lemma eval_list_conj : "eval (list_conj F) L = (\<forall>f\<in>set(F). eval f L)"
proof -
  { fix f F
    have h : "eval (foldr and F f) L = (eval f L \<and> (\<forall>f \<in> set F. eval f L))"
      apply(induct F)
       apply simp
      using eval_and by auto
  } then show ?thesis
    by(simp add:list_conj_def)
qed

lemma eval_list_disj : "eval (list_disj F) L = (\<exists>f\<in>set(F). eval f L)"
proof -
  { fix f F
    have h : "eval (foldr or F f) L = (eval f L \<or> (\<exists>f \<in> set F. eval f L))"
      apply(induct F)
       apply simp
      using eval_or by auto
  } then show ?thesis
    by(simp add:list_disj_def)
qed
end