(* Author: Xingyuan Zhang, Chunhan Wu, Christian Urban *)
theory Myhill_2
  imports Myhill_1 "~~/src/HOL/Library/Sublist"
begin

section {* Second direction of MN: @{text "regular language \<Rightarrow> finite partition"} *}

subsection {* Tagging functions *}

definition
   tag_eq :: "('a list \<Rightarrow> 'b) \<Rightarrow> ('a list \<times> 'a list) set" ("=_=")
where
   "=tag= \<equiv> {(x, y). tag x = tag y}"

abbreviation
   tag_eq_applied :: "'a list \<Rightarrow> ('a list \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> bool" ("_ =_= _")
where
   "x =tag= y \<equiv> (x, y) \<in> =tag="

lemma refined_intro:
  assumes "\<And>x y z. \<lbrakk>x =tag= y; x @ z \<in> A\<rbrakk> \<Longrightarrow> y @ z \<in> A"
  shows "=tag= \<subseteq> \<approx>A"
using assms unfolding str_eq_def tag_eq_def
apply(clarify, simp (no_asm_use))
by metis

lemma finite_eq_tag_rel:
  assumes rng_fnt: "finite (range tag)"
  shows "finite (UNIV // =tag=)"
proof -
  let "?f" =  "\<lambda>X. tag ` X" and ?A = "(UNIV // =tag=)"
  have "finite (?f ` ?A)"
  proof -
    have "range ?f \<subseteq> (Pow (range tag))" unfolding Pow_def by auto
    moreover
    have "finite (Pow (range tag))" using rng_fnt by simp
    ultimately
    have "finite (range ?f)" unfolding image_def by (blast intro: finite_subset)
    moreover
    have "?f ` ?A \<subseteq> range ?f" by auto
    ultimately show "finite (?f ` ?A)" by (rule rev_finite_subset)
  qed
  moreover
  have "inj_on ?f ?A"
  proof -
    { fix X Y
      assume X_in: "X \<in> ?A"
        and  Y_in: "Y \<in> ?A"
        and  tag_eq: "?f X = ?f Y"
      then obtain x y
        where "x \<in> X" "y \<in> Y" "tag x = tag y"
        unfolding quotient_def Image_def image_def tag_eq_def
        by (simp) (blast)
      with X_in Y_in
      have "X = Y"
        unfolding quotient_def tag_eq_def by auto
    }
    then show "inj_on ?f ?A" unfolding inj_on_def by auto
  qed
  ultimately show "finite (UNIV // =tag=)" by (rule finite_imageD)
qed

lemma refined_partition_finite:
  assumes fnt: "finite (UNIV // R1)"
  and refined: "R1 \<subseteq> R2"
  and eq1: "equiv UNIV R1" and eq2: "equiv UNIV R2"
  shows "finite (UNIV // R2)"
proof -
  let ?f = "\<lambda>X. {R1 `` {x} | x. x \<in> X}"
    and ?A = "UNIV // R2" and ?B = "UNIV // R1"
  have "?f ` ?A \<subseteq> Pow ?B"
    unfolding image_def Pow_def quotient_def by auto
  moreover
  have "finite (Pow ?B)" using fnt by simp
  ultimately
  have "finite (?f ` ?A)" by (rule finite_subset)
  moreover
  have "inj_on ?f ?A"
  proof -
    { fix X Y
      assume X_in: "X \<in> ?A" and Y_in: "Y \<in> ?A" and eq_f: "?f X = ?f Y"
      from quotientE [OF X_in]
      obtain x where "X = R2 `` {x}" by blast
      with equiv_class_self[OF eq2] have x_in: "x \<in> X" by simp
      then have "R1 ``{x} \<in> ?f X" by auto
      with eq_f have "R1 `` {x} \<in> ?f Y" by simp
      then obtain y
        where y_in: "y \<in> Y" and eq_r1_xy: "R1 `` {x} = R1 `` {y}" by auto
      with eq_equiv_class[OF _ eq1]
      have "(x, y) \<in> R1" by blast
      with refined have "(x, y) \<in> R2" by auto
      with quotient_eqI [OF eq2 X_in Y_in x_in y_in]
      have "X = Y" .
    }
    then show "inj_on ?f ?A" unfolding inj_on_def by blast
  qed
  ultimately show "finite (UNIV // R2)" by (rule finite_imageD)
qed

lemma tag_finite_imageD:
  assumes rng_fnt: "finite (range tag)"
  and     refined: "=tag=  \<subseteq> \<approx>A"
  shows "finite (UNIV // \<approx>A)"
proof (rule_tac refined_partition_finite [of "=tag="])
  show "finite (UNIV // =tag=)" by (rule finite_eq_tag_rel[OF rng_fnt])
next
  show "=tag= \<subseteq> \<approx>A" using refined .
next
  show "equiv UNIV =tag="
  and  "equiv UNIV (\<approx>A)"
    unfolding equiv_def str_eq_def tag_eq_def refl_on_def sym_def trans_def
    by auto
qed

subsection {* Base cases: @{const Zero}, @{const One} and @{const Atom} *}

lemma quot_zero_finiteI [intro]:
  shows "finite (UNIV // \<approx>{})"
unfolding quot_zero_eq by simp

lemma quot_one_subset:
  shows "UNIV // \<approx>{[]} \<subseteq> {{[]}, UNIV - {[]}}"
proof
  fix x
  assume "x \<in> UNIV // \<approx>{[]}"
  then obtain y where h: "x = {z. y \<approx>{[]} z}"
    unfolding quotient_def Image_def by blast
  { assume "y = []"
    with h have "x = {[]}" by (auto simp: str_eq_def)
    then have "x \<in> {{[]}, UNIV - {[]}}" by simp }
  moreover
  { assume "y \<noteq> []"
    with h have "x = UNIV - {[]}" by (auto simp: str_eq_def)
    then have "x \<in> {{[]}, UNIV - {[]}}" by simp }
  ultimately show "x \<in> {{[]}, UNIV - {[]}}" by blast
qed

lemma quot_one_finiteI [intro]:
  shows "finite (UNIV // \<approx>{[]})"
by (rule finite_subset[OF quot_one_subset]) (simp)

lemma quot_atom_subset:
  "UNIV // (\<approx>{[c]}) \<subseteq> {{[]},{[c]}, UNIV - {[], [c]}}"
proof
  fix x
  assume "x \<in> UNIV // \<approx>{[c]}"
  then obtain y where h: "x = {z. (y, z) \<in> \<approx>{[c]}}"
    unfolding quotient_def Image_def by blast
  show "x \<in> {{[]},{[c]}, UNIV - {[], [c]}}"
  proof -
    { assume "y = []" hence "x = {[]}" using h
        by (auto simp: str_eq_def) }
    moreover
    { assume "y = [c]" hence "x = {[c]}" using h
        by (auto dest!: spec[where x = "[]"] simp: str_eq_def) }
    moreover
    { assume "y \<noteq> []" and "y \<noteq> [c]"
      hence "\<forall> z. (y @ z) \<noteq> [c]" by (case_tac y, auto)
      moreover have "\<And> p. (p \<noteq> [] \<and> p \<noteq> [c]) = (\<forall> q. p @ q \<noteq> [c])"
        by (case_tac p, auto)
      ultimately have "x = UNIV - {[],[c]}" using h
        by (auto simp add: str_eq_def)
    }
    ultimately show ?thesis by blast
  qed
qed

lemma quot_atom_finiteI [intro]:
  shows "finite (UNIV // \<approx>{[c]})"
by (rule finite_subset[OF quot_atom_subset]) (simp)

subsection {* Case for @{const Plus} *}

definition
  tag_Plus :: "'a lang \<Rightarrow> 'a lang \<Rightarrow> 'a list \<Rightarrow> ('a lang \<times> 'a lang)"
where
  "tag_Plus A B \<equiv> \<lambda>x. (\<approx>A `` {x}, \<approx>B `` {x})"

lemma quot_plus_finiteI [intro]:
  assumes finite1: "finite (UNIV // \<approx>A)"
  and     finite2: "finite (UNIV // \<approx>B)"
  shows "finite (UNIV // \<approx>(A \<union> B))"
proof (rule_tac tag = "tag_Plus A B" in tag_finite_imageD)
  have "finite ((UNIV // \<approx>A) \<times> (UNIV // \<approx>B))"
    using finite1 finite2 by auto
  then show "finite (range (tag_Plus A B))"
    unfolding tag_Plus_def quotient_def
    by (rule rev_finite_subset) (auto)
next
  show "=tag_Plus A B= \<subseteq> \<approx>(A \<union> B)"
    unfolding tag_eq_def tag_Plus_def str_eq_def by auto
qed

subsection {* Case for @{text "Times"} *}

definition
  "Partitions x \<equiv> {(x\<^sub>p, x\<^sub>s). x\<^sub>p @ x\<^sub>s = x}"

lemma conc_partitions_elim:
  assumes "x \<in> A \<cdot> B"
  shows "\<exists>(u, v) \<in> Partitions x. u \<in> A \<and> v \<in> B"
using assms unfolding conc_def Partitions_def
by auto

lemma conc_partitions_intro:
  assumes "(u, v) \<in> Partitions x \<and> u \<in> A \<and>  v \<in> B"
  shows "x \<in> A \<cdot> B"
using assms unfolding conc_def Partitions_def
by auto

lemma equiv_class_member:
  assumes "x \<in> A"
  and "\<approx>A `` {x} = \<approx>A `` {y}"
  shows "y \<in> A"
using assms
apply(simp)
apply(simp add: str_eq_def)
apply(metis append_Nil2)
done

definition
  tag_Times :: "'a lang \<Rightarrow> 'a lang \<Rightarrow> 'a list \<Rightarrow> 'a lang \<times> 'a lang set"
where
  "tag_Times A B \<equiv> \<lambda>x. (\<approx>A `` {x}, {(\<approx>B `` {x\<^sub>s}) | x\<^sub>p x\<^sub>s. x\<^sub>p \<in> A \<and> (x\<^sub>p, x\<^sub>s) \<in> Partitions x})"

lemma tag_Times_injI:
  assumes a: "tag_Times A B x = tag_Times A B y"
  and     c: "x @ z \<in> A \<cdot> B"
  shows "y @ z \<in> A \<cdot> B"
proof -
  from c obtain u v where
    h1: "(u, v) \<in> Partitions (x @ z)" and
    h2: "u \<in> A" and
    h3: "v \<in> B" by (auto dest: conc_partitions_elim)
  from h1 have "x @ z = u @ v" unfolding Partitions_def by simp
  then obtain us
    where "(x = u @ us \<and> us @ z = v) \<or> (x @ us = u \<and> z = us @ v)"
    by (auto simp add: append_eq_append_conv2)
  moreover
  { assume eq: "x = u @ us" "us @ z = v"
    have "(\<approx>B `` {us}) \<in> snd (tag_Times A B x)"
      unfolding Partitions_def tag_Times_def using h2 eq
      by (auto simp add: str_eq_def)
    then have "(\<approx>B `` {us}) \<in> snd (tag_Times A B y)"
      using a by simp
    then obtain u' us' where
      q1: "u' \<in> A" and
      q2: "\<approx>B `` {us} = \<approx>B `` {us'}" and
      q3: "(u', us') \<in> Partitions y"
      unfolding tag_Times_def by auto
    from q2 h3 eq
    have "us' @ z \<in> B"
      unfolding Image_def str_eq_def by auto
    then have "y @ z \<in> A \<cdot> B" using q1 q3
      unfolding Partitions_def by auto
  }
  moreover
  { assume eq: "x @ us = u" "z = us @ v"
    have "(\<approx>A `` {x}) = fst (tag_Times A B x)"
      by (simp add: tag_Times_def)
    then have "(\<approx>A `` {x}) = fst (tag_Times A B y)"
      using a by simp
    then have "\<approx>A `` {x} = \<approx>A `` {y}"
      by (simp add: tag_Times_def)
    moreover
    have "x @ us \<in> A" using h2 eq by simp
    ultimately
    have "y @ us \<in> A" using equiv_class_member
      unfolding Image_def str_eq_def by blast
    then have "(y @ us) @ v \<in> A \<cdot> B"
      using h3 unfolding conc_def by blast
    then have "y @ z \<in> A \<cdot> B" using eq by simp
  }
  ultimately show "y @ z \<in> A \<cdot> B" by blast
qed

lemma quot_conc_finiteI [intro]:
  assumes fin1: "finite (UNIV // \<approx>A)"
  and     fin2: "finite (UNIV // \<approx>B)"
  shows "finite (UNIV // \<approx>(A \<cdot> B))"
proof (rule_tac tag = "tag_Times A B" in tag_finite_imageD)
  have "\<And>x y z. \<lbrakk>tag_Times A B x = tag_Times A B y; x @ z \<in> A \<cdot> B\<rbrakk> \<Longrightarrow> y @ z \<in> A \<cdot> B"
    by (rule tag_Times_injI)
       (auto simp add: tag_Times_def tag_eq_def)
  then show "=tag_Times A B= \<subseteq> \<approx>(A \<cdot> B)"
    by (rule refined_intro)
       (auto simp add: tag_eq_def)
next
  have *: "finite ((UNIV // \<approx>A) \<times> (Pow (UNIV // \<approx>B)))"
    using fin1 fin2 by auto
  show "finite (range (tag_Times A B))"
    unfolding tag_Times_def
    apply(rule finite_subset[OF _ *])
    unfolding quotient_def
    by auto
qed

subsection {* Case for @{const "Star"} *}

lemma star_partitions_elim:
  assumes "x @ z \<in> A\<star>" "x \<noteq> []"
  shows "\<exists>(u, v) \<in> Partitions (x @ z). prefix u x \<and> u \<in> A\<star> \<and> v \<in> A\<star>"
proof -
  have "([], x @ z) \<in> Partitions (x @ z)" "prefix [] x" "[] \<in> A\<star>" "x @ z \<in> A\<star>"
    using assms by (auto simp add: Partitions_def prefix_def)
  then show "\<exists>(u, v) \<in> Partitions (x @ z). prefix u x \<and> u \<in> A\<star> \<and> v \<in> A\<star>"
    by blast
qed

lemma finite_set_has_max2:
  "\<lbrakk>finite A; A \<noteq> {}\<rbrakk> \<Longrightarrow> \<exists> max \<in> A. \<forall> a \<in> A. length a \<le> length max"
apply(induct rule:finite.induct)
apply(simp)
by (metis (no_types) all_not_in_conv insert_iff linorder_le_cases order_trans)

lemma finite_prefix_set:
  shows "finite {xa. prefix xa (x::'a list)}"
apply (induct x rule:rev_induct, simp)
apply (subgoal_tac "{xa. prefix xa (xs @ [x])} = {xa. prefix xa xs} \<union> {xs}")
by (auto simp:prefix_def)

lemma append_eq_cases:
  assumes a: "x @ y = m @ n" "m \<noteq> []"
  shows "prefixeq x m \<or> prefix m x"
unfolding prefixeq_def prefix_def using a
by (auto simp add: append_eq_append_conv2)

lemma star_spartitions_elim2:
  assumes a: "x @ z \<in> A\<star>"
  and     b: "x \<noteq> []"
  shows "\<exists>(u, v) \<in> Partitions x. \<exists> (u', v') \<in> Partitions z. prefix u x \<and> u \<in> A\<star> \<and> v @ u' \<in> A \<and> v' \<in> A\<star>"
proof -
  def S \<equiv> "{u | u v. (u, v) \<in> Partitions x \<and> prefix u x \<and> u \<in> A\<star> \<and> v @ z \<in> A\<star>}"
  have "finite {u. prefix u x}" by (rule finite_prefix_set)
  then have "finite S" unfolding S_def
    by (rule rev_finite_subset) (auto)
  moreover
  have "S \<noteq> {}" using a b unfolding S_def Partitions_def
    by (auto simp: prefix_def)
  ultimately have "\<exists> u_max \<in> S. \<forall> u \<in> S. length u \<le> length u_max"
    using finite_set_has_max2 by blast
  then obtain u_max v
    where h0: "(u_max, v) \<in> Partitions x"
    and h1: "prefix u_max x"
    and h2: "u_max \<in> A\<star>"
    and h3: "v @ z \<in> A\<star>"
    and h4: "\<forall> u v. (u, v) \<in> Partitions x \<and> prefix u x \<and> u \<in> A\<star> \<and> v @ z \<in> A\<star> \<longrightarrow> length u \<le> length u_max"
    unfolding S_def Partitions_def by blast
  have q: "v \<noteq> []" using h0 h1 b unfolding Partitions_def by auto
  from h3 obtain a b
    where i1: "(a, b) \<in> Partitions (v @ z)"
    and   i2: "a \<in> A"
    and   i3: "b \<in> A\<star>"
    and   i4: "a \<noteq> []"
    unfolding Partitions_def
    using q by (auto dest: star_decom)
  have "prefixeq v a"
  proof (rule ccontr)
    assume a: "\<not>(prefixeq v a)"
    from i1 have i1': "a @ b = v @ z" unfolding Partitions_def by simp
    then have "prefixeq a v \<or> prefix v a" using append_eq_cases q by blast
    then have q: "prefix a v" using a unfolding prefix_def prefixeq_def by auto
    then obtain as where eq: "a @ as = v" unfolding prefix_def prefixeq_def by auto
    have "(u_max @ a, as) \<in> Partitions x" using eq h0 unfolding Partitions_def by auto
    moreover
    have "prefix (u_max @ a) x" using h0 eq q unfolding Partitions_def prefix_def prefixeq_def by auto
    moreover
    have "u_max @ a \<in> A\<star>" using i2 h2 by simp
    moreover
    have "as @ z \<in> A\<star>" using i1' i2 i3 eq by auto
    ultimately have "length (u_max @ a) \<le> length u_max" using h4 by blast
    with i4 show "False" by auto
  qed
  with i1 obtain za zb
    where k1: "v @ za = a"
    and   k2: "(za, zb) \<in> Partitions z"
    and   k4: "zb = b"
    unfolding Partitions_def prefix_def
    by (auto simp add: append_eq_append_conv2)
  show "\<exists> (u, v) \<in> Partitions x. \<exists> (u', v') \<in> Partitions z. prefix u x \<and> u \<in> A\<star> \<and> v @ u' \<in> A \<and> v' \<in> A\<star>"
    using h0 h1 h2 i2 i3 k1 k2 k4 unfolding Partitions_def by blast
qed

definition
  tag_Star :: "'a lang \<Rightarrow> 'a list \<Rightarrow> ('a lang) set"
where
  "tag_Star A \<equiv> \<lambda>x. {\<approx>A `` {v} | u v. prefix u x \<and> u \<in> A\<star> \<and> (u, v) \<in> Partitions x}"

lemma tag_Star_non_empty_injI:
  assumes a: "tag_Star A x = tag_Star A y"
  and     c: "x @ z \<in> A\<star>"
  and     d: "x \<noteq> []"
  shows "y @ z \<in> A\<star>"
proof -
  obtain u v u' v'
    where a1: "(u,  v) \<in> Partitions x" "(u', v')\<in> Partitions z"
    and   a2: "prefix u x"
    and   a3: "u \<in> A\<star>"
    and   a4: "v @ u' \<in> A"
    and   a5: "v' \<in> A\<star>"
    using c d by (auto dest: star_spartitions_elim2)
  have "(\<approx>A) `` {v} \<in> tag_Star A x"
    apply(simp add: tag_Star_def Partitions_def str_eq_def)
    using a1 a2 a3 by (auto simp add: Partitions_def)
  then have "(\<approx>A) `` {v} \<in> tag_Star A y" using a by simp
  then obtain u1 v1
    where b1: "v \<approx>A v1"
    and   b3: "u1 \<in> A\<star>"
    and   b4: "(u1, v1) \<in> Partitions y"
    unfolding tag_Star_def by auto
  have c: "v1 @ u' \<in> A\<star>" using b1 a4 unfolding str_eq_def by simp
  have "u1 @ (v1 @ u') @ v' \<in> A\<star>"
    using b3 c a5 by (simp only: append_in_starI)
  then show "y @ z \<in> A\<star>" using b4 a1
    unfolding Partitions_def by auto
qed

lemma tag_Star_empty_injI:
  assumes a: "tag_Star A x = tag_Star A y"
  and     c: "x @ z \<in> A\<star>"
  and     d: "x = []"
  shows "y @ z \<in> A\<star>"
proof -
  from a have "{} = tag_Star A y" unfolding tag_Star_def using d by auto
  then have "y = []"
    unfolding tag_Star_def Partitions_def prefix_def prefixeq_def
    by (auto) (metis Nil_in_star append_self_conv2)
  then show "y @ z \<in> A\<star>" using c d by simp
qed

lemma quot_star_finiteI [intro]:
  assumes finite1: "finite (UNIV // \<approx>A)"
  shows "finite (UNIV // \<approx>(A\<star>))"
proof (rule_tac tag = "tag_Star A" in tag_finite_imageD)
  have "\<And>x y z. \<lbrakk>tag_Star A x = tag_Star A y; x @ z \<in> A\<star>\<rbrakk> \<Longrightarrow> y @ z \<in> A\<star>"
    by (case_tac "x = []") (blast intro: tag_Star_empty_injI tag_Star_non_empty_injI)+
  then show "=(tag_Star A)= \<subseteq> \<approx>(A\<star>)"
    by (rule refined_intro) (auto simp add: tag_eq_def)
next
  have *: "finite (Pow (UNIV // \<approx>A))"
     using finite1 by auto
  show "finite (range (tag_Star A))"
    unfolding tag_Star_def
    by (rule finite_subset[OF _ *])
       (auto simp add: quotient_def)
qed

subsection {* The conclusion of the second direction *}

lemma Myhill_Nerode2:
  fixes r::"'a rexp"
  shows "finite (UNIV // \<approx>(lang r))"
by (induct r) (auto)

end


section \<open>Monotonic Boolean Transformers\<close>

theory Mono_Bool_Tran
imports
  LatticeProperties.Complete_Lattice_Prop
  LatticeProperties.Conj_Disj
begin

text\<open>
The type of monotonic transformers is the type associated to the set of monotonic
functions from a partially ordered set (poset) to itself. The type of monotonic
transformers with the pointwise extended order is also a poset.
The monotonic transformers with composition and identity
form a monoid, and the monoid operation is compatible with the order.

Gradually we extend the algebraic structure of monotonic transformers to
lattices, and complete lattices. We also introduce a dual operator
($(\mathsf{dual}\;f) p = - f (-p)$) on monotonic transformers over
a boolean algebra. However the monotonic transformers over a boolean
algebra are not closed to the pointwise extended negation operator.

Finally we introduce an iteration operator on monotonic transformers
over a complete lattice.
\<close>

unbundle lattice_syntax

lemma Inf_comp_fun:
  "\<Sqinter>M \<circ> f = (\<Sqinter>m\<in>M. m \<circ> f)"
  by (simp add: fun_eq_iff image_comp)

lemma INF_comp_fun:
  "(\<Sqinter>a\<in>A. g a) \<circ> f = (\<Sqinter>a\<in>A. g a \<circ> f)"
  by (simp add: fun_eq_iff image_comp)

lemma Sup_comp_fun:
  "\<Squnion>M \<circ> f = (\<Squnion>m\<in>M. m \<circ> f)"
  by (simp add: fun_eq_iff image_comp)

lemma SUP_comp_fun:
  "(\<Squnion>a\<in>A. g a) \<circ> f = (\<Squnion>a\<in>A. g a \<circ> f)"
  by (simp add: fun_eq_iff image_comp)

lemma (in order) mono_const [simp]:
  "mono (\<lambda>_. c)"
  by (auto intro: monoI)

lemma (in order) mono_id [simp]:
  "mono id"
  by (auto intro: order_class.monoI)

lemma (in order) mono_comp [simp]:
  "mono f \<Longrightarrow> mono g \<Longrightarrow> mono (f \<circ> g)"
  by (auto intro!: monoI elim!: monoE order_class.monoE)

lemma (in bot) mono_bot [simp]:
  "mono \<bottom>"
  by (auto intro: monoI)

lemma (in top) mono_top [simp]:
  "mono \<top>"
  by (auto intro: monoI)

lemma (in semilattice_inf) mono_inf [simp]:
  assumes "mono f" and "mono g"
  shows "mono (f \<sqinter> g)"
proof
  fix a b
  assume "a \<le> b"
  have "f a \<sqinter> g a \<le> f a" by simp
  also from \<open>mono f\<close> \<open>a \<le> b\<close> have "\<dots> \<le> f b" by (auto elim: monoE)
  finally have *: "f a \<sqinter> g a \<le> f b" .
  have "f a \<sqinter> g a \<le> g a" by simp
  also from \<open>mono g\<close> \<open>a \<le> b\<close> have "\<dots> \<le> g b" by (auto elim: monoE)
  finally have **: "f a \<sqinter> g a \<le> g b" .
  from * ** show "(f \<sqinter> g) a \<le> (f \<sqinter> g) b" by auto
qed

lemma (in semilattice_sup) mono_sup [simp]:
  assumes "mono f" and "mono g"
  shows "mono (f \<squnion> g)"
proof
  fix a b
  assume "a \<le> b"
  from \<open>mono f\<close> \<open>a \<le> b\<close> have "f a \<le> f b" by (auto elim: monoE)
  also have "f b \<le> f b \<squnion> g b" by simp
  finally have *: "f a \<le> f b \<squnion> g b" .
  from \<open>mono g\<close> \<open>a \<le> b\<close> have "g a \<le> g b" by (auto elim: monoE)
  also have "g b \<le> f b \<squnion> g b" by simp
  finally have **: "g a \<le> f b \<squnion> g b" .
  from * ** show "(f \<squnion> g) a \<le> (f \<squnion> g) b" by auto
qed

lemma (in complete_lattice) mono_Inf [simp]:
  assumes "A \<subseteq> {f :: 'a \<Rightarrow> 'b:: complete_lattice. mono f}"
  shows "mono (\<Sqinter>A)"
proof
  fix a b
  assume "a \<le> b"
  { fix f
    assume "f \<in> A"
    with assms have "mono f" by auto
    with \<open>a \<le> b\<close> have "f a \<le> f b" by (auto elim: monoE)
  }
  then have "(\<Sqinter>f\<in>A. f a) \<le> (\<Sqinter>f\<in>A. f b)"
    by (auto intro: complete_lattice_class.INF_greatest complete_lattice_class.INF_lower2)
  then show "(\<Sqinter>A) a \<le> (\<Sqinter>A) b" by simp
qed

lemma (in complete_lattice) mono_Sup [simp]:
  assumes "A \<subseteq> {f :: 'a \<Rightarrow> 'b:: complete_lattice. mono f}"
  shows "mono (\<Squnion>A)"
proof
  fix a b
  assume "a \<le> b"
  { fix f
    assume "f \<in> A"
    with assms have "mono f" by auto
    with \<open>a \<le> b\<close> have "f a \<le> f b" by (auto elim: monoE)
  }
  then have "(\<Squnion>f\<in>A. f a) \<le> (\<Squnion>f\<in>A. f b)"
    by (auto intro: complete_lattice_class.SUP_least complete_lattice_class.SUP_upper2)
  then show "(\<Squnion>A) a \<le> (\<Squnion>A) b" by simp
qed

typedef (overloaded) 'a MonoTran = "{f::'a::order \<Rightarrow> 'a . mono f}"
proof
  show "id \<in> ?MonoTran" by simp
qed

setup_lifting type_definition_MonoTran

instantiation MonoTran :: (order) order
begin

lift_definition less_eq_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran \<Rightarrow> bool"
  is less_eq .

lift_definition less_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran \<Rightarrow> bool"
  is less .

instance
  by intro_classes (transfer, auto intro: order_antisym)+

end

instantiation MonoTran :: (order) monoid_mult
begin

lift_definition one_MonoTran :: "'a MonoTran"
  is id
  by (fact mono_id)

lift_definition times_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran \<Rightarrow> 'a MonoTran"
  is comp
  by (fact mono_comp)

instance
  by intro_classes (transfer, auto)+

end

instantiation MonoTran :: (order_bot) order_bot
begin

lift_definition bot_MonoTran :: "'a MonoTran"
  is \<bottom>
  by (fact mono_bot)

instance
  by intro_classes (transfer, simp)

end

instantiation MonoTran :: (order_top) order_top
begin

lift_definition top_MonoTran :: "'a MonoTran"
  is \<top>
  by (fact mono_top)

instance
  by intro_classes (transfer, simp)

end

instantiation MonoTran :: (lattice) lattice
begin

lift_definition inf_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran \<Rightarrow> 'a MonoTran"
  is inf
  by (fact mono_inf)

lift_definition sup_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran \<Rightarrow> 'a MonoTran"
  is sup
  by (fact mono_sup)

instance
  by intro_classes (transfer, simp)+

end

instance MonoTran :: (distrib_lattice) distrib_lattice
  by intro_classes (transfer, rule sup_inf_distrib1)

instantiation MonoTran :: (complete_lattice) complete_lattice
begin

lift_definition Inf_MonoTran :: "'a MonoTran set \<Rightarrow> 'a MonoTran"
  is Inf
  by (rule mono_Inf) auto

lift_definition Sup_MonoTran :: "'a MonoTran set \<Rightarrow> 'a MonoTran"
  is Sup
  by (rule mono_Sup) auto

instance
  by intro_classes (transfer, simp add: Inf_lower Sup_upper Inf_greatest Sup_least)+

end

context includes lifting_syntax
begin

lemma [transfer_rule]:
  "(rel_set A ===> (A ===> pcr_MonoTran HOL.eq) ===> pcr_MonoTran HOL.eq) (\<lambda>A f. \<Squnion>(f ` A)) (\<lambda>A f. \<Squnion>(f ` A))"
  by transfer_prover

end

instance MonoTran :: (complete_distrib_lattice) complete_distrib_lattice
proof (intro_classes, transfer)
  fix A :: "('a \<Rightarrow> 'a) set set"
  assume " \<forall>A\<in>A. Ball A mono"
  from this have [simp]: "{f ` A |f. \<forall>Y\<in>A. f Y \<in> Y} = {x. (\<exists>f. (\<forall>x. (\<forall>x\<in>x. mono x) \<longrightarrow> mono (f x)) \<and> x = f ` A \<and> (\<forall>Y\<in>A. f Y \<in> Y)) \<and> (\<forall>x\<in>x. mono x)}"
    apply safe
      apply (rule_tac x = "\<lambda> x . if x \<in> A then f x else \<bottom>" in exI)
      apply (simp add: if_split image_def)
    by blast+

  show " \<Sqinter>(Sup ` A) \<le> \<Squnion>(Inf ` {x. (\<exists>f\<in>Collect (pred_fun (\<lambda>A. Ball A mono) mono). x = f ` A \<and> (\<forall>Y\<in>A. f Y \<in> Y)) \<and> Ball x mono})"
    by (simp add: Inf_Sup)
qed

definition
  "dual_fun (f::'a::boolean_algebra \<Rightarrow> 'a) = uminus \<circ> f \<circ> uminus"

lemma dual_fun_apply [simp]:
  "dual_fun f p = - f (- p)"
  by (simp add: dual_fun_def)

lemma mono_dual_fun [simp]:
  "mono f \<Longrightarrow> mono (dual_fun f)"
  apply (rule monoI)
  apply (erule monoE)
  apply auto
  done

lemma (in order) mono_inf_fun [simp]:
  fixes x :: "'b::semilattice_inf"
  shows "mono (inf x)"
  by (auto intro!: order_class.monoI semilattice_inf_class.inf_mono)

lemma (in order) mono_sup_fun [simp]:
  fixes x :: "'b::semilattice_sup"
  shows "mono (sup x)"
  by (auto intro!: order_class.monoI semilattice_sup_class.sup_mono)

lemma mono_comp_fun:
  fixes f :: "'a::order \<Rightarrow> 'b::order"
  shows "mono f \<Longrightarrow> mono ((\<circ>) f)"
  by (rule monoI) (auto simp add: le_fun_def elim: monoE)

definition
  "Omega_fun f g = inf g \<circ> comp f"

lemma Omega_fun_apply [simp]:
  "Omega_fun f g h p = (g p \<sqinter> f (h p))"
  by (simp add: Omega_fun_def)

lemma mono_Omega_fun [simp]:
  "mono f \<Longrightarrow> mono (Omega_fun f g)"
  unfolding Omega_fun_def
  by (auto intro: mono_comp mono_comp_fun)

lemma mono_mono_Omega_fun [simp]:
  fixes f :: "'b::order \<Rightarrow> 'a::semilattice_inf" and g :: "'c::semilattice_inf \<Rightarrow> 'a"
  shows "mono f \<Longrightarrow> mono g \<Longrightarrow> mono_mono (Omega_fun f g)"
  apply (auto simp add: mono_mono_def Omega_fun_def)
  apply (rule mono_comp)
  apply (rule mono_inf_fun)
  apply (rule mono_comp_fun)
  apply assumption
  done

definition
  "omega_fun f = lfp (Omega_fun f id)"

definition
  "star_fun f = gfp (Omega_fun f id)"

lemma mono_omega_fun [simp]:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f"
  shows "mono (omega_fun f)"
proof
  fix a b :: 'a
  assume "a \<le> b"
  from assms have "mono (lfp (Omega_fun f id))"
    by (auto intro: mono_mono_Omega_fun)
  with \<open>a \<le> b\<close> show "omega_fun f a \<le> omega_fun f b"
    by (auto simp add: omega_fun_def elim: monoE)
qed

lemma mono_star_fun [simp]:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f"
  shows "mono (star_fun f)"
proof
  fix a b :: 'a
  assume "a \<le> b"
  from assms have "mono (gfp (Omega_fun f id))"
    by (auto intro: mono_mono_Omega_fun)
  with \<open>a \<le> b\<close> show "star_fun f a \<le> star_fun f b"
    by (auto simp add: star_fun_def elim: monoE)
qed

lemma lfp_omega_lowerbound:
  "mono f \<Longrightarrow> Omega_fun f g A \<le> A \<Longrightarrow> omega_fun f \<circ> g \<le> A"
  apply (simp add: omega_fun_def)
  apply (rule_tac P = "\<lambda> x . x \<circ> g \<le> A" and f = "Omega_fun f id" in lfp_ordinal_induct)
  apply simp_all
  apply (simp add: le_fun_def o_def inf_fun_def id_def Omega_fun_def)
  apply auto
  apply (rule_tac y = "f (A x) \<sqinter> g x" in order_trans)
  apply simp_all
  apply (rule_tac y = "f (S (g x))" in order_trans)
  apply simp_all
  apply (simp add: mono_def) apply (auto simp add: ac_simps)
  apply (unfold Sup_comp_fun)
  apply (rule SUP_least)
  by auto

lemma gfp_omega_upperbound:
  "mono f \<Longrightarrow> A \<le> Omega_fun f g A \<Longrightarrow> A \<le> star_fun f \<circ> g"
  apply (simp add: star_fun_def)
  apply (rule_tac P = "\<lambda> x . A \<le> x \<circ> g" and f = "Omega_fun f id" in gfp_ordinal_induct)
  apply simp_all
  apply (simp add: le_fun_def o_def inf_fun_def id_def Omega_fun_def)
  apply auto
  apply (rule_tac y = "f (A x) \<sqinter> g x" in order_trans)
  apply simp_all
  apply (rule_tac y = "f (A x)" in order_trans)
  apply simp_all
  apply (simp add: mono_def)
  apply (unfold Inf_comp_fun)
  apply (rule INF_greatest)
  by auto

lemma lfp_omega_greatest:
  assumes "\<And>u. Omega_fun f g u \<le> u \<Longrightarrow> A \<le> u"
  shows "A \<le> omega_fun f \<circ> g"
  apply (unfold omega_fun_def)
  apply (simp add: lfp_def)
  apply (unfold Inf_comp_fun)
  apply (rule INF_greatest)
  apply simp
  apply (rule assms)
  apply (simp add: le_fun_def)
  done

lemma gfp_star_least:
  assumes "\<And>u. u \<le> Omega_fun f g u \<Longrightarrow> u \<le> A"
  shows "star_fun f \<circ> g \<le> A"
  apply (unfold star_fun_def)
  apply (simp add: gfp_def)
  apply (unfold Sup_comp_fun)
  apply (rule SUP_least)
  apply simp
  apply (rule assms)
  apply (simp add: le_fun_def)
  done

lemma lfp_omega:
  "mono f \<Longrightarrow> omega_fun f \<circ> g = lfp (Omega_fun f g)"
  apply (rule antisym)
  apply (rule lfp_omega_lowerbound)
  apply simp_all
  apply (simp add: lfp_def)
  apply (rule Inf_greatest)
  apply safe
  apply (rule_tac y = "Omega_fun f g x" in order_trans)
  apply simp_all
  apply (rule_tac f = " Omega_fun f g" in monoD)
  apply simp_all
  apply (rule Inf_lower)
  apply simp
  apply (rule lfp_omega_greatest)
  apply (simp add: lfp_def)
  apply (rule Inf_lower)
  by simp

lemma gfp_star:
  "mono f \<Longrightarrow> star_fun f \<circ> g = gfp (Omega_fun f g)"
  apply (rule antisym)
  apply (rule gfp_star_least)
  apply (simp add: gfp_def)
  apply (rule Sup_upper, simp)
  apply (rule gfp_omega_upperbound)
  apply simp_all
  apply (simp add: gfp_def)
  apply (rule Sup_least)
  apply safe
  apply (rule_tac y = "Omega_fun f g x" in order_trans)
  apply simp_all
  apply (rule_tac f = " Omega_fun f g" in monoD)
  apply simp_all
  apply (rule Sup_upper)
  by simp

definition
  "assert_fun p q = (p \<sqinter> q :: 'a::semilattice_inf)"

lemma mono_assert_fun [simp]:
  "mono (assert_fun p)"
  apply (simp add: assert_fun_def mono_def, safe)
  by (rule_tac y = x in order_trans, simp_all)

lemma assert_fun_le_id [simp]: "assert_fun p \<le> id"
  by (simp add: assert_fun_def id_def le_fun_def)

lemma assert_fun_disjunctive [simp]: "assert_fun (p::'a::distrib_lattice) \<in> Apply.disjunctive"
  by (simp add: assert_fun_def Apply.disjunctive_def inf_sup_distrib)

definition
  "assertion_fun = range assert_fun"

lemma assert_cont:
  "(x :: 'a::boolean_algebra \<Rightarrow> 'a)  \<le> id \<Longrightarrow> x \<in> Apply.disjunctive \<Longrightarrow> x = assert_fun (x \<top>)"
  apply (rule antisym)
  apply (simp_all add: le_fun_def assert_fun_def, safe)
  apply (rule_tac f = x in  monoD, simp_all)
  apply (subgoal_tac "x top = sup (x xa) (x (-xa))")
  apply simp
  apply (subst inf_sup_distrib)
  apply simp
  apply (rule_tac y = "inf (- xa) xa" in order_trans)
  supply [[simproc del: boolean_algebra_cancel_inf]]
  apply (simp del: compl_inf_bot)
  apply (rule_tac y = "x (- xa)" in order_trans)
  apply simp
  apply simp
  apply simp
  apply (cut_tac x = x and y = xa and z = "-xa" in Apply.disjunctiveD, simp)
  apply (subst (asm) sup_commute)
  apply (subst (asm) compl_sup_top)
  by simp

lemma assertion_fun_disj_less_one: "assertion_fun = Apply.disjunctive \<inter> {x::'a::boolean_algebra \<Rightarrow> 'a . x \<le> id}"
  apply safe
  apply (simp_all add: assertion_fun_def, auto simp add: image_def)
  apply (rule_tac x = "x \<top>" in exI)
  by (rule assert_cont, simp_all)

lemma assert_fun_dual: "((assert_fun p) o \<top>) \<sqinter> (dual_fun (assert_fun p)) = assert_fun p"
  by (simp add: fun_eq_iff inf_fun_def dual_fun_def o_def assert_fun_def top_fun_def inf_sup_distrib)

lemma assertion_fun_dual: "x \<in> assertion_fun \<Longrightarrow> (x o \<top>) \<sqinter> (dual_fun x) = x"
  by (simp add: assertion_fun_def, safe, simp add: assert_fun_dual)

lemma assertion_fun_MonoTran [simp]: "x \<in> assertion_fun \<Longrightarrow> mono x"
  by (unfold assertion_fun_def, auto)

lemma assertion_fun_le_one [simp]: "x \<in> assertion_fun \<Longrightarrow> x \<le> id"
  by (unfold assertion_fun_def, auto)

end


theory TS_To_XC
  imports TS_To_XC_aux
begin

section "useful definitions and the reduction function"

definition literal_sets
  :: "'a three_sat  \<Rightarrow> 'a xc_element set set" where
"literal_sets F = {{l}| l. l \<in> (literals_of_sat F)}"

definition clauses_with_literals
  :: "'a three_sat \<Rightarrow> 'a xc_element set set" where
"clauses_with_literals F = {{C c, l} |c l. C c \<in> (clauses_of_sat F) \<and> l \<in> (literals_of_sat F)
        \<and> l \<in> {L a c | a. a \<in> c}}"

definition var_true_literals
  :: "'a three_sat \<Rightarrow> 'a xc_element set set" where
"var_true_literals F =
  {{V v} \<union> {l. l \<in> (literals_of_sat F)
  \<and> (\<exists>c. C c\<in> (clauses_of_sat F) \<and> L (Neg v) c = l)} |v. V v \<in> (vars_of_sat F)}"

definition var_false_literals
    :: "'a three_sat \<Rightarrow> 'a xc_element set set" where
"var_false_literals F =
  {{V v} \<union> {l. l \<in> (literals_of_sat F)
  \<and> (\<exists>c. C c\<in> (clauses_of_sat F) \<and> L (Pos v) c = l)} |v. V v \<in> (vars_of_sat F)}"

abbreviation "comp_X F \<equiv>
  vars_of_sat F \<union> clauses_of_sat F \<union> literals_of_sat F"
abbreviation "comp_S F \<equiv>
    literal_sets F \<union> clauses_with_literals F
  \<union> var_true_literals F \<union> var_false_literals F"

definition ts_xc :: "'a three_sat \<Rightarrow> 'a xc_element set * 'a xc_element set set" where
"ts_xc F = (comp_X F, comp_S F)"

lemma ts_xc_is_collection: "\<Union> (comp_S F) \<subseteq> (comp_X F)"
proof -
  let ?vars = "vars_of_sat F"
  let ?clauses = "clauses_of_sat F"
  let ?literals = "literals_of_sat F"

  let ?ls = "literal_sets F"
  let ?cs = "clauses_with_literals F"
  let ?vt = "var_true_literals F"
  let ?vf = "var_false_literals F"

  have x_part: "(comp_X F) = ?vars \<union> ?clauses \<union> ?literals"
    using ts_xc_def[of F]
    by (auto simp: Let_def)
  have s_part: "(comp_S F) = ?ls \<union> ?cs \<union> ?vt \<union> ?vf"
    using ts_xc_def[of F]
    by (auto simp: Let_def)
  have "\<Union>?ls = ?literals"
    unfolding literal_sets_def
    by blast
  moreover have "\<Union>?cs \<subseteq> ?literals \<union> ?clauses"
    unfolding clauses_with_literals_def
    by blast
  moreover have "\<Union>?vt \<subseteq> ?literals \<union> ?vars"
    unfolding var_true_literals_def
    by blast
  moreover have "\<Union>?vf \<subseteq> ?literals \<union> ?vars"
    unfolding var_false_literals_def
    by blast
  ultimately have "\<Union> (?ls \<union> ?cs \<union> ?vt \<union> ?vf) \<subseteq> ?vars \<union> ?clauses \<union> ?literals"
    by blast
  with x_part s_part show ?thesis
    by force
qed

section "the proof for the soundness"

subsection "the construction of the cover"

definition constr_cover_clause
  :: "'a lit set \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a xc_element set set" where
"constr_cover_clause c \<sigma> =
  (SOME s. \<exists>p \<in> c. (\<sigma>\<up>) p \<and> s = {{C c, L p c}} \<union> {{L q c} | q. q \<in> c \<and> q \<noteq> p \<and> (\<sigma>\<up>) q})"

lemma constr_cover_clause_unfold:
assumes "\<sigma> \<Turnstile> F" "c \<in> set F"
shows "\<exists>p\<in>c. (\<sigma>\<up>) p \<and> constr_cover_clause c \<sigma> = {{C c, L p c}} \<union> {{L q c} | q. q \<in> c \<and> q \<noteq> p \<and> (\<sigma>\<up>) q}"
proof-
  from assms have "\<exists>p \<in>c. (\<sigma>\<up>) p"
    unfolding models_def lift_def
    by blast
  thus "\<exists>p\<in>c. (\<sigma>\<up>) p \<and> constr_cover_clause c \<sigma> = {{C c, L p c}} \<union> {{L q c} | q. q \<in> c \<and> q \<noteq> p \<and> (\<sigma>\<up>) q}"
   unfolding constr_cover_clause_def
   apply auto
   apply (rule someI_ex)
   by blast
qed

definition vars_sets
  :: "'a three_sat \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a xc_element set set" where
"vars_sets F \<sigma> =
  {x_set | x_set. \<exists>x \<in> vars F.
       (if (\<sigma>\<up>) (Pos x) then (V x) \<in> x_set \<and> x_set \<in> var_true_literals F
        else (V x) \<in> x_set \<and> x_set \<in> var_false_literals F)}"

definition clause_sets
  :: "'a three_sat \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a xc_element set set set" where
  "clause_sets F \<sigma> =
      {constr_cover_clause c \<sigma> |c. c \<in> set F}"

definition constr_cover
  :: "'a three_sat \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a xc_element set set" where
"constr_cover F \<sigma> \<equiv>
  (if F \<in> cnf_sat
  then vars_sets F \<sigma> \<union> \<Union> (clause_sets F \<sigma>)
  else {})"

subsubsection "The constructed set is a collection"

lemma constr_cover_clause_is_collection:
assumes "\<sigma> \<Turnstile> F" "c \<in> set F"
 shows "constr_cover_clause c \<sigma> \<subseteq> (comp_S F)"
proof standard
  let ?s = "constr_cover_clause c \<sigma>"
  fix x
  assume prem: "x \<in> ?s"
  from assms have "\<exists>p \<in>c. (\<sigma>\<up>) p"
    unfolding models_def lift_def
    by blast
  from assms have  "\<exists>p\<in>c. (\<sigma>\<up>) p \<and> ?s = {{C c, L p c}} \<union> {{L q c} | q. q \<in> c \<and> q \<noteq> p \<and> (\<sigma>\<up>) q}"
   using constr_cover_clause_unfold
   by blast
  then obtain p where
    p_def: "?s = {{C c, L p c}} \<union> {{L q c} | q. q \<in> c \<and> q \<noteq> p \<and> (\<sigma>\<up>) q}"
      "(\<sigma>\<up>) p" "p \<in> c"
     using \<open>\<exists>p \<in>c. (\<sigma>\<up>) p\<close> by blast
  with assms(2) have "\<forall>p \<in> c. {L p c} \<in> literal_sets F"
    unfolding literal_sets_def literals_of_sat_def
    by fastforce
  hence "\<forall>p \<in> c. {{L q c} | q. q \<in> c \<and> q \<noteq> p \<and> (\<sigma>\<up>) q} \<subseteq> literal_sets F"
    by blast
  moreover from assms(2) have "\<forall>p \<in> c. {C c, L p c} \<in> clauses_with_literals F"
    unfolding clauses_with_literals_def literals_of_sat_def
    by force
  ultimately have "x \<in> (literal_sets F \<union> clauses_with_literals F)"
    using prem p_def
    by auto
  then show "x \<in> comp_S F"
    by blast
qed

lemma constr_cover_is_collection:
  "\<sigma> \<Turnstile> F \<Longrightarrow> constr_cover F \<sigma> \<subseteq> (comp_S F)"
unfolding constr_cover_def vars_sets_def clause_sets_def
apply auto
using constr_cover_clause_is_collection
by blast

subsubsection "The constructed set is a cover"

paragraph "covers all variables"
lemma vars_in_vars_set_aux1:
  "\<forall>x\<in>vars_sets F \<sigma>. \<exists>v \<in> vars F. V v \<in> x"
unfolding vars_sets_def
by auto

lemma vars_in_vars_set_aux2:
  "\<forall>v\<in> vars F. \<exists>x \<in> var_true_literals F. V v \<in> x"
unfolding var_true_literals_def vars_of_sat_def
by auto

lemma vars_in_vars_set_aux3:
  "\<forall>v\<in> vars F. \<exists>x \<in> var_false_literals F. V v \<in> x"
unfolding var_false_literals_def vars_of_sat_def
by auto

lemmas vars_in_vars_set_aux=
vars_in_vars_set_aux1 vars_in_vars_set_aux2 vars_in_vars_set_aux3

lemma vars_in_vars_set:
  "vars_of_sat F \<subseteq> \<Union> (vars_sets F \<sigma>)"
unfolding vars_of_sat_def vars_sets_def
using vars_in_vars_set_aux
by (auto, meson)

paragraph "covers all clauses"

lemma clause_in_clause_set_aux:
assumes "\<sigma> \<Turnstile> F" "c \<in> set F"
shows  "C c \<in> \<Union>(constr_cover_clause c \<sigma>)"
using constr_cover_clause_unfold [OF assms]
by fastforce

lemma clause_in_clause_set:
assumes "\<sigma> \<Turnstile> F"
shows "clauses_of_sat F \<subseteq> \<Union> (\<Union>(clause_sets F \<sigma>))"
unfolding clause_sets_def  clauses_of_sat_def
using clause_in_clause_set_aux[OF assms]
by (auto, fastforce)

paragraph "covers all false literals"

lemma double_neg_id:
  "\<not> (\<sigma>\<up>) (Neg a) \<longleftrightarrow> (\<sigma>\<up>) (Pos a)"
unfolding models_def lift_def
by simp

lemma false_literal_in_vars_sets_aux:
assumes "\<not> (\<sigma>\<up>) x" "x \<in> c" "c \<in> set F"
shows " \<exists>s \<in> vars_sets F \<sigma>. L x c \<in> s"
proof (cases x)
  case (Pos a)
  then show ?thesis
  proof -
    let ?s = "{V a} \<union> {l \<in> literals_of_sat F. \<exists>c. C c \<in> clauses_of_sat F \<and> L (Pos a) c = l}"

    have "a \<in> vars F"
      using assms(2-3) Pos by (force simp add: vars_correct)
    moreover then have "?s \<in> var_false_literals F"
      unfolding var_false_literals_def vars_of_sat_def
      by blast
    moreover have "\<not> (\<sigma>\<up>) (Pos a)"
      using Pos assms(1) by blast
    ultimately have "?s \<in> vars_sets F \<sigma>"
      unfolding vars_sets_def
      by force
    moreover have "L x c \<in> ?s"
      using Pos assms(2-3) by simp
    ultimately show ?thesis
      by meson
  qed
next
  case (Neg b)
  then show ?thesis
  proof -
    let ?s = "{V b} \<union> {l \<in> literals_of_sat F. \<exists>c. C c \<in> clauses_of_sat F \<and> L (Neg b) c = l}"
    have "b \<in> vars F"
      using assms(2-3) Neg by (force simp add: vars_correct)
    moreover then have "?s \<in> var_true_literals F"
      unfolding var_true_literals_def vars_of_sat_def
      by blast
    moreover have "(\<sigma>\<up>) (Pos b)"
      using Neg assms(1)
      by (force simp add: double_neg_id)
    ultimately have "?s \<in> vars_sets F \<sigma>"
      unfolding vars_sets_def
      by force
    moreover have "L x c \<in> ?s"
      using Neg assms(2-3) by simp
    ultimately show ?thesis
      by meson
  qed
qed

lemma false_literal_in_vars_sets:
"\<lbrakk>\<not> (\<sigma>\<up>) x; x \<in> c; c \<in> set F\<rbrakk> \<Longrightarrow> L x c \<in> \<Union>(vars_sets F \<sigma>)"
using false_literal_in_vars_sets_aux
by fast

paragraph "covers all true literals"

lemma true_literals_in_clause_sets_aux:
assumes "\<sigma> \<Turnstile> F" "(\<sigma>\<up>) x" "x \<in> c" "c \<in> set F"
shows "L x c \<in> \<Union>(constr_cover_clause c \<sigma>)"
proof -
let ?s = "constr_cover_clause c \<sigma>"

from constr_cover_clause_unfold[OF assms(1) assms(4)]
have "\<exists>p\<in>c. (\<sigma>\<up>) p \<and> ?s = {{C c, L p c}} \<union> {{L q c} |q. q \<in> c \<and> q \<noteq> p \<and> (\<sigma>\<up>) q}"
  by blast
then obtain p where p_def:
"p \<in> c" "(\<sigma>\<up>) p" "?s = {{C c, L p c}} \<union> {{L q c} |q. q \<in> c \<and> q \<noteq> p \<and> (\<sigma>\<up>) q}"
  by blast
hence "\<Union>?s = {C c} \<union> {L q c|q. q \<in> c \<and> (\<sigma>\<up>) q}"
  by blast
then show ?thesis
  using assms(2-3) by blast
qed

lemma true_literals_in_clause_sets:
"\<lbrakk>\<sigma> \<Turnstile> F;(\<sigma>\<up>) x; x \<in> c; c \<in> set F\<rbrakk> \<Longrightarrow> L x c \<in> \<Union> (\<Union>(clause_sets F \<sigma>))"
unfolding clause_sets_def
using true_literals_in_clause_sets_aux
by fast

paragraph "Integration of all true and false literals"

lemma literals_in_construction_aux:
assumes "\<sigma> \<Turnstile> F" "x \<in> c" "c \<in> set F" "F \<in> cnf_sat"
shows "L x c \<in> \<Union>(constr_cover F \<sigma>)"
proof (cases "(\<sigma>\<up>) x")
  case True
  with assms have "L x c \<in> \<Union> (\<Union>(clause_sets F \<sigma>))"
    using true_literals_in_clause_sets
    by blast
  then show ?thesis
    unfolding constr_cover_def
    using assms(4)
    by simp
next
  case False
  with assms have "L x c \<in> \<Union>(vars_sets F \<sigma>)"
    using false_literal_in_vars_sets
    by blast
  then show ?thesis
    unfolding constr_cover_def
    using assms(4)
    by simp
qed

corollary literals_in_construction:
"\<sigma> \<Turnstile> F \<Longrightarrow> literals_of_sat F \<subseteq> \<Union>(constr_cover F \<sigma>)"
proof -
  assume "\<sigma> \<Turnstile> F"
  hence "F \<in> cnf_sat"
    unfolding cnf_sat_def sat_def
    by blast
  with \<open>\<sigma> \<Turnstile> F\<close> have "\<forall>c\<in>set F. \<forall>x\<in>c.  L x c \<in> \<Union> (constr_cover F \<sigma>)"
    using literals_in_construction_aux
    by blast
  then show "literals_of_sat F \<subseteq> \<Union>(constr_cover F \<sigma>)"
    unfolding literals_of_sat_def
    by fastforce
qed

subsubsection "The constructed sets are pairwise disjoint"

paragraph "clause_sets are disjoint"

lemma clause_sets_disj:
assumes "\<sigma> \<Turnstile> F"
shows  "disjoint (\<Union> (clause_sets F \<sigma>))"
  unfolding clause_sets_def
  apply (rule disjointI)
  apply (auto)
  using constr_cover_clause_unfold[OF assms]
  apply (smt (z3) Un_iff empty_iff insertE mem_Collect_eq
    xc_element.simps(2) xc_element.simps(3) xc_element.simps(9))+
  done

paragraph "vars_sets are disjoint"

abbreviation "true_literals v F \<equiv> {V v} \<union> {l. l \<in> (literals_of_sat F)
  \<and> (\<exists>c. C c\<in> (clauses_of_sat F) \<and> L (Neg v) c = l)}"
abbreviation "false_literals v F \<equiv> {V v} \<union> {l. l \<in> (literals_of_sat F)
  \<and> (\<exists>c. C c\<in> (clauses_of_sat F) \<and> L (Pos v) c = l)}"

lemma true_false_literals_noteq:
  "v \<in> vars F \<Longrightarrow> true_literals v F \<noteq> false_literals v F"
proof -
  assume "v \<in> vars F"
  then have "(v \<in> var ` \<Union> (set F))"
    using vars_correct[of v F] by blast
  then have "\<exists>c\<in> set F. v \<in> var ` c"
    by blast
  have "\<exists>c. C c \<in> (clauses_of_sat F) \<and>
    (L (Neg v) c \<in> (literals_of_sat F) \<or> L (Pos v) c \<in> (literals_of_sat F))"
    unfolding literals_of_sat_def clauses_of_sat_def
    using comp_literals_correct[of F "{}"]
    apply auto
    using \<open>\<exists>c\<in> set F. v \<in> var ` c\<close>
    by (metis imageE var.elims)
  then show  "true_literals v F \<noteq> false_literals v F"
    by fast
qed

lemma true_literals_not_in_false:
  "v \<in> vars F \<Longrightarrow> \<forall>u\<in> vars F. true_literals v F \<noteq> false_literals u F"
proof
  fix u
  assume  "v \<in> vars F" "u \<in> vars F"
  have "\<forall>x\<in> true_literals v F. x = V v \<or> (\<exists>c. x = L (Neg v) c)"
    by blast
  moreover have "\<forall>x\<in> false_literals u F. x = V u \<or> (\<exists>c. x = L (Pos u) c)"
    by blast
  ultimately show "true_literals v F \<noteq> false_literals u F"
    apply (cases "v\<noteq>u")
    using true_false_literals_noteq[OF \<open>v \<in> vars F\<close>]
    by blast+
qed

lemma false_literals_not_in_true:
  "v \<in> vars F \<Longrightarrow> \<forall>u\<in> vars F. false_literals v F \<noteq> true_literals u F"
proof
  fix u
  assume  "v \<in> vars F" "u \<in> vars F"
  have "\<forall>x\<in> true_literals v F. x = V v \<or> (\<exists>c. x = L (Neg v) c)"
    by blast
  moreover have "\<forall>x\<in> false_literals u F. x = V u \<or> (\<exists>c. x = L (Pos u) c)"
    by blast
  ultimately show "false_literals v F \<noteq> true_literals u F"
    apply (cases "v\<noteq>u")
    using true_false_literals_noteq[OF \<open>v \<in> vars F\<close>] by blast+
qed

lemma vars_sets_true_assignment:
"\<lbrakk>(\<sigma>\<up>) (Pos v); v \<in> vars F\<rbrakk> \<Longrightarrow> true_literals v F \<in> vars_sets F \<sigma> \<and> false_literals v F \<notin> vars_sets F \<sigma>"
proof standard
  assume "(\<sigma>\<up>) (Pos v)" "v \<in> vars F"
  have "true_literals v F \<in> var_true_literals F"
    unfolding var_true_literals_def vars_of_sat_def
    using \<open>v \<in> vars F\<close>
    by blast
  then show "true_literals v F \<in> vars_sets F \<sigma>"
    unfolding vars_sets_def
    using \<open>(\<sigma>\<up>) (Pos v)\<close> \<open>v \<in> vars F\<close>
    by auto
  from \<open>v \<in> vars F\<close> have "false_literals v F \<notin> var_true_literals F"
    unfolding var_true_literals_def vars_of_sat_def
    using false_literals_not_in_true
    by force
  then show "false_literals v F \<notin> vars_sets F \<sigma>"
    unfolding vars_sets_def
    using \<open>(\<sigma>\<up>) (Pos v)\<close> \<open>v \<in> vars F\<close>
    by auto
qed

lemma vars_sets_false_assignment:
"\<lbrakk>\<not> (\<sigma>\<up>) (Pos v); v \<in> vars F\<rbrakk> \<Longrightarrow> true_literals v F \<notin> vars_sets F \<sigma> \<and> false_literals v F \<in> vars_sets F \<sigma>"
proof standard
  assume "\<not> (\<sigma>\<up>) (Pos v)" "v \<in> vars F"
  have "false_literals v F \<in> var_false_literals F"
    unfolding var_false_literals_def vars_of_sat_def
    using \<open>v \<in> vars F\<close>
    by blast
  then show "false_literals v F \<in> vars_sets F \<sigma>"
    unfolding vars_sets_def
    using \<open>\<not> (\<sigma>\<up>) (Pos v)\<close> \<open>v \<in> vars F\<close>
    by fastforce
  from \<open>v \<in> vars F\<close> have "true_literals v F \<notin> var_false_literals F"
    unfolding var_false_literals_def vars_of_sat_def
    using true_literals_not_in_false
    by force
  then show "true_literals v F \<notin> vars_sets F \<sigma>"
    unfolding vars_sets_def
    using \<open>\<not> (\<sigma>\<up>) (Pos v)\<close> \<open>v \<in> vars F\<close>
    by auto
qed

lemma vars_sets_bipartite:
  "v \<in> vars F
    \<Longrightarrow> (true_literals v F \<notin> vars_sets F \<sigma> \<and> false_literals v F \<in> vars_sets F \<sigma>)
        \<or> (true_literals v F \<in> vars_sets F \<sigma> \<and> false_literals v F \<notin> vars_sets F \<sigma>)"
  using vars_sets_false_assignment vars_sets_true_assignment
  by fast

lemma vars_sets_subset:
  "vars_sets F \<sigma> \<subseteq> (var_true_literals F \<union> var_false_literals F)"
  unfolding vars_sets_def var_true_literals_def var_false_literals_def
  by auto

lemma var_true_literals_disj:
  "disjoint (var_true_literals F)"
  apply (rule disjointI)
  unfolding var_true_literals_def
  by auto

lemma var_false_literals_disj:
  "disjoint (var_false_literals F)"
  apply (rule disjointI)
  unfolding var_false_literals_def
  by auto

lemma vars_sets_disj_aux:
assumes "A \<in> vars_sets F \<sigma>"
shows "\<forall>s\<in>vars_sets F \<sigma>. s \<noteq> A \<longrightarrow> s \<inter> A = {}"
proof
  fix s
  assume "s \<in> vars_sets F \<sigma>"
  show "s \<noteq> A \<longrightarrow> s \<inter> A = {}"
  proof
    assume "s \<noteq> A"
    consider
      "s \<in> var_false_literals F \<and> A \<in> var_false_literals F" |
      "s \<in> var_false_literals F \<and> A \<in> var_true_literals F \<or>
        s \<in> var_true_literals F \<and> A \<in> var_false_literals F" |
      "s \<in> var_true_literals F \<and> A \<in> var_true_literals F"
        using vars_sets_subset assms \<open>s \<in> vars_sets F \<sigma>\<close>
        by blast
    then show "s \<inter> A = {}"
    proof (cases)
      case 1
      then show ?thesis
      using disjointD var_false_literals_disj \<open>s \<noteq> A\<close>
      by blast
    next
      case 2
      then show ?thesis
      unfolding var_false_literals_def var_true_literals_def vars_of_sat_def
      using assms \<open>s \<in> vars_sets F \<sigma>\<close> vars_sets_bipartite
      by fast
    next
      case 3
      then show ?thesis
      using disjointD var_true_literals_disj \<open>s \<noteq> A\<close>
      by blast
    qed
  qed
qed

lemma vars_sets_disj:
"disjoint (vars_sets F \<sigma>)"
  apply (rule disjointI)
  using vars_sets_disj_aux
  by blast

paragraph "clause sets and var sets are disjoint to each other"

lemma vars_sets_only_false_literals_aux:
"\<forall>s\<in>vars_sets F \<sigma>. \<forall>x \<in> s. x \<in> vars_of_sat F \<or> (x \<in> literals_of_sat F \<and> \<not>(\<sigma>\<Up>) x)"
unfolding vars_sets_def
apply auto
unfolding var_false_literals_def var_true_literals_def
using double_neg_id
by fastforce+

corollary vars_sets_only_false_literals:
"\<forall>x\<in>\<Union>(vars_sets F \<sigma>). x \<in> vars_of_sat F \<or> (x \<in> literals_of_sat F \<and> \<not>(\<sigma>\<Up>) x)"
using vars_sets_only_false_literals_aux
by blast

lemma constr_cover_clause_only_true_literals_aux1:
assumes "\<sigma> \<Turnstile> F" "c \<in> set F"
shows "\<forall>s\<in> constr_cover_clause c \<sigma>. \<forall>x\<in>s. x \<in> clauses_of_sat F \<or> (x \<in> literals_of_sat F \<and> (\<sigma>\<Up>) x)"
proof  auto
  fix s x
  assume prems: "s \<in> constr_cover_clause c \<sigma>" "x \<in> s" "x \<notin> clauses_of_sat F"
  obtain p where p_def:"p \<in> c" "(\<sigma>\<up>) p"
  "constr_cover_clause c \<sigma> = {{C c, L p c}} \<union> {{L q c} |q. q \<in> c \<and> q \<noteq> p \<and> (\<sigma>\<up>) q}"
    using constr_cover_clause_unfold[OF assms]
    by blast
  hence "x \<in> {L q c |q. q \<in> c \<and> (\<sigma>\<up>) q}"
    using prems assms unfolding clauses_of_sat_def
    by blast
  with assms(2) show "(\<sigma>\<Up>) x" "x \<in> literals_of_sat F"
    unfolding literals_of_sat_def
    by fastforce+
qed

corollary constr_cover_clause_only_true_literals_aux2:
assumes "\<sigma> \<Turnstile> F"
shows "\<forall>s\<in> \<Union>(clause_sets F \<sigma>). \<forall>x\<in>s. x \<in> clauses_of_sat F \<or> (x \<in> literals_of_sat F \<and> (\<sigma>\<Up>) x)"
unfolding clause_sets_def
using constr_cover_clause_only_true_literals_aux1[OF assms]
by blast

corollary constr_cover_clause_only_true_literals:
assumes "\<sigma> \<Turnstile> F"
shows "\<forall>x\<in> \<Union>(\<Union>(clause_sets F \<sigma>)). x \<in> clauses_of_sat F \<or> (x \<in> literals_of_sat F \<and> (\<sigma>\<Up>) x)"
using constr_cover_clause_only_true_literals_aux2[OF assms]
by blast

lemma vars_clauses_set_disj:
assumes "\<sigma> \<Turnstile> F"
shows "\<Union>(vars_sets F \<sigma>) \<inter> \<Union> (\<Union> (clause_sets F \<sigma>)) = {}"
using assms constr_cover_clause_only_true_literals vars_sets_only_false_literals
unfolding vars_of_sat_def clauses_of_sat_def literals_of_sat_def
by fastforce

corollary constr_cover_disj:
"\<sigma> \<Turnstile> F \<Longrightarrow> disjoint ((vars_sets F \<sigma>) \<union> (\<Union> (clause_sets F \<sigma>)))"
using disjoint_union vars_sets_disj clause_sets_disj vars_clauses_set_disj
by blast

subsection "The soundness lemma"

lemma ts_xc_sound_aux:
  "\<sigma> \<Turnstile> F \<Longrightarrow> cover (constr_cover F \<sigma>) (comp_X F)"
  unfolding cover_def
  proof
    assume prems: "\<sigma> \<Turnstile> F"
    show "\<Union> (constr_cover F \<sigma>) = comp_X F"
    proof (standard, goal_cases)
      case 1
      have "constr_cover F \<sigma> \<subseteq> comp_S F"
        using constr_cover_is_collection prems by blast
      moreover have "F \<in> cnf_sat"
        unfolding cnf_sat_def sat_def
        using prems by blast
      ultimately show ?case
        using ts_xc_is_collection by blast
    next
      case 2
      have "F \<in> cnf_sat"
        unfolding cnf_sat_def sat_def
        using prems by blast
      have "vars_of_sat F \<subseteq> \<Union> (constr_cover F \<sigma>)"
        unfolding constr_cover_def
        using vars_in_vars_set \<open>F \<in> cnf_sat\<close>
        by auto
      moreover have "clauses_of_sat F \<subseteq> \<Union> (constr_cover F \<sigma>)"
        unfolding constr_cover_def
        using clause_in_clause_set[OF prems(1)] \<open>F \<in> cnf_sat\<close>
        by auto
      moreover have "literals_of_sat F \<subseteq> \<Union> (constr_cover F \<sigma>)"
        using prems literals_in_construction
        by blast
      ultimately show ?case
        by blast
    qed
  next
    assume prems: "\<sigma> \<Turnstile> F"
    have "F \<in> cnf_sat"
      unfolding cnf_sat_def sat_def
      using prems by blast
    show "disjoint (constr_cover F \<sigma>)"
      unfolding constr_cover_def
      using prems constr_cover_disj
      by auto
  qed

lemma ts_xc_sound:
  "F \<in> cnf_sat \<Longrightarrow> ts_xc F \<in> exact_cover"
  proof (goal_cases)
    let ?X = "comp_X F"
    let ?S = "comp_S F"
  case 1
    hence prems: "\<exists>\<sigma>. \<sigma> \<Turnstile> F"
      unfolding cnf_sat_def sat_def
      by blast
    then obtain \<sigma> where sig_def: "\<sigma> \<Turnstile> F"
      by blast
    have "(?X, ?S) \<in> exact_cover"
      apply (rule exact_cover_I)
      apply (rule constr_cover_is_collection[OF sig_def])
      apply (rule ts_xc_is_collection)
      apply (rule ts_xc_sound_aux[OF sig_def])
      done
    then show ?case
      unfolding ts_xc_def
      by simp
  qed

section "The proof of the completeness"

definition "constr_model S' F =
(\<lambda>x.
    if (\<exists>s \<in> S'. \<exists>c \<in> set F. s = {C c, L (Pos x) c} \<and> (Pos x) \<in> c)
    then True
    else if (\<exists>s \<in> S'. \<exists>c \<in> set F. s = {C c, L (Neg x) c} \<and> (Neg x) \<in> c)
    then False
    else False)"

lemma clause_only_binary:
  "\<forall>c \<in> clauses_of_sat F. \<forall>s\<in>(comp_S F). c \<in> s \<longrightarrow> s \<in> clauses_with_literals F"
proof standard
  fix c
  assume prems: "c \<in> clauses_of_sat F"
  hence "\<forall>s \<in> literal_sets F. c \<notin> s"
        "\<forall>s \<in> var_true_literals F. c \<notin> s"
        "\<forall>s \<in> var_false_literals F. c \<notin> s"
    unfolding literal_sets_def var_true_literals_def var_false_literals_def
      clauses_of_sat_def literals_of_sat_def
    by fastforce+
  then show "\<forall>s\<in>(comp_S F). c \<in> s \<longrightarrow> s \<in> clauses_with_literals F"
    by blast
qed

lemma clauses_with_literals_satisfiability:
  "s \<in> clauses_with_literals F \<Longrightarrow> C c \<in> s \<Longrightarrow> (\<exists>l \<in> c. s = {C c, L l c})"
  unfolding clauses_with_literals_def
  by blast

lemma constr_model_exists:
  "\<lbrakk>S' \<subseteq> S; cover S' X; ts_xc F = (X, S)\<rbrakk>
    \<Longrightarrow> (\<forall>c\<in> set F. \<exists>s\<in> S'. \<exists>l \<in> c. s = {C c, L l c})"
proof
  fix c
  assume "S' \<subseteq> S" "cover S' X" "ts_xc F = (X, S)"
  "c \<in> set F"
  from \<open>c \<in> set F\<close> have "C c \<in> clauses_of_sat F"
    unfolding clauses_of_sat_def
    by simp
  moreover from \<open>ts_xc F = (X, S)\<close>
  have "S = comp_S F" "X = comp_X F"
    unfolding ts_xc_def
    by force+
  ultimately
  have prem: "\<forall>s\<in>S. C c \<in> s \<longrightarrow> s \<in> clauses_with_literals F"
    using clause_only_binary
    by blast

  from \<open>C c \<in> clauses_of_sat F\<close> \<open>X = comp_X F\<close>
  have "C c \<in> X"
    by fastforce
  with \<open>cover S' X\<close> have "\<exists>s \<in> S'. C c \<in> s"
    unfolding cover_def
    by blast
  moreover from \<open>S' \<subseteq> S\<close>
  have "\<forall>s \<in> S'. C c \<in> s \<longrightarrow> s \<in> clauses_with_literals F"
    using prem
    by blast
  ultimately obtain s where "s \<in> S'" "C c \<in> s" "s \<in> clauses_with_literals F"
    by blast
  hence "(\<exists>l \<in> c. s = {C c, L l c})"
    using clauses_with_literals_satisfiability
    by blast
  with \<open>s \<in> S'\<close> show "\<exists>s \<in> S'. \<exists>l\<in>c. s = {C c, L l c}"
    by blast
qed

lemma vars_only_in_true_false_literals:
assumes "s \<in> comp_S F" "V x \<in> s"
shows "s = true_literals x F \<or> s = false_literals x F"
proof -
have "V x \<notin> \<Union>(literal_sets F)"
  unfolding literal_sets_def literals_of_sat_def
  by force
with assms(2) have limit1: "s \<notin> literal_sets F"
  by fastforce

have "V x \<notin> \<Union>(clauses_with_literals F)"
  unfolding clauses_with_literals_def clauses_of_sat_def
  by blast
with assms(2) have limit2: "s \<notin> clauses_with_literals F"
  by fastforce

from limit1 limit2 assms(1)
have "s \<in> var_true_literals F \<or> s \<in> var_false_literals F"
  by blast
then consider "s \<in> var_true_literals F" | "s \<in> var_false_literals F"
  by blast
then show ?thesis
  proof (cases)
    case 1
    with assms(2) have "s = true_literals x F"
      unfolding var_true_literals_def
      by fastforce
    then show ?thesis
      by blast
  next
    case 2
    with assms(2) have "s = false_literals x F"
      unfolding var_false_literals_def
      by fastforce
    then show ?thesis
      by blast
  qed
qed

lemma constr_model_disj_aux:
assumes  "cover S' (comp_X F)" "S' \<subseteq> (comp_S F)" "{C c, L (Pos x) c} \<in> S'"
shows "\<not>(\<exists>c'. {C c', L (Neg x) c'} \<in> S')"
proof
  assume "\<exists>c'. {C c', L (Neg x) c'} \<in> S'"
  then obtain c' where c'_def: "{C c', L (Neg x) c'} \<in> S'"
    by blast
  show "False"
  proof (cases "c = c'")
    case True
    from assms(1) have "disjoint S'"
      unfolding cover_def
      by blast
    with c'_def assms(3) disjointD True
    show ?thesis
      by blast
  next
    case False
    from assms(1) assms(3) c'_def
    have "C c \<in> comp_X F" "C c' \<in> comp_X F"
      unfolding cover_def
      by blast+
    hence "C c \<in> clauses_of_sat F" "C c' \<in> clauses_of_sat F"
      unfolding vars_of_sat_def literals_of_sat_def
      by simp+

    moreover from assms(2-3) c'_def
    have "{C c, L (Pos x) c} \<in> comp_S F" "{C c', L (Neg x) c'} \<in> comp_S F"
      by blast+
    ultimately have
    "{C c, L (Pos x) c} \<in> clauses_with_literals F"
    "{C c', L (Neg x) c'} \<in> clauses_with_literals F"
      using clause_only_binary
      by blast+
    hence c_x_unfold:
    "C c \<in> clauses_of_sat F" "C c' \<in> clauses_of_sat F"
    "Pos x \<in> c" "Neg x \<in> c'"
      unfolding clauses_with_literals_def
      by (simp add: doubleton_eq_iff)+
    with \<open>C c \<in> clauses_of_sat F\<close> have "x \<in> vars F"
      unfolding clauses_of_sat_def vars_correct
      by force
    hence "V x \<in> vars_of_sat F"
      unfolding vars_of_sat_def
      by simp
    then have "V x \<in> comp_X F"
      by simp
    with assms(1) have "\<exists>s \<in> S'. V x \<in> s"
      unfolding cover_def
      by blast
    then obtain s where s_def: "s \<in> S'" "V x \<in> s"
      by blast
    hence "s \<in> comp_S F"
      using assms(2)
      by blast
    with \<open>V x \<in> s\<close> have
    "s = true_literals x F \<or> s = false_literals x F"
      using vars_only_in_true_false_literals[of s F x]
      by fastforce
    then consider "s = true_literals x F" | "s = false_literals x F"
      by blast
    then show ?thesis
    proof (cases)
      case 1
      have "L (Neg x) c' \<in> comp_literals F {}"
        using c_x_unfold
        unfolding clauses_of_sat_def
        by auto
      hence "L (Neg x) c' \<in> true_literals x F"
        by simp
      moreover have "L (Neg x) c' \<in> {C c', L (Neg x) c'}"
        by blast
      moreover from assms(1)
      have "disjoint S'"
        unfolding cover_def
        by blast
      ultimately show ?thesis
        using disjointD[of S', OF _ c'_def s_def(1)] 1
        by blast
    next
      case 2
      have "L (Pos x) c \<in> comp_literals F {}"
        using c_x_unfold
        unfolding clauses_of_sat_def
        by auto
      hence "L (Pos x) c \<in> false_literals x F"
        by simp
      moreover have "L (Pos x) c \<in> {C c, L (Pos x) c}"
        by blast
      moreover from assms(1)
      have "disjoint S'"
        unfolding cover_def
        by blast
      ultimately show ?thesis
        using disjointD[of S', OF _ assms(3) s_def(1)] 2
        by blast
    qed
  qed
qed

lemma ts_xc_complete:
  "ts_xc F \<in> exact_cover \<Longrightarrow> F \<in> cnf_sat"
proof -
  let ?X = "comp_X F"
  let ?S = "comp_S F"

  assume "ts_xc F \<in> exact_cover"
  then have "ts_xc F = (?X, ?S)"
    unfolding ts_xc_def
    by simp
  with \<open>ts_xc F \<in> exact_cover\<close>
  have "\<exists>S' \<subseteq> ?S. cover S' ?X"
    using exact_cover_D ts_xc_is_collection
    by metis
  then obtain S' where S'_def: "cover S' ?X" "S' \<subseteq> ?S"
    by blast
  with \<open>ts_xc F = (?X, ?S)\<close>
  have prem: "\<forall>c\<in> set F. \<exists>s\<in> S'. \<exists>l \<in> c. s = {C c, L l c}"
   using constr_model_exists[of S' ?S ?X]
   by presburger

   let ?\<sigma> = "constr_model S' F"
   have "\<forall>c\<in> set F. \<exists>s\<in> S'. \<exists>l \<in> c. s = {C c, L l c} \<and> (?\<sigma> \<up>) l"
   proof
     fix c
     assume "c \<in> set F"
     then have "\<exists>s\<in> S'. \<exists>l \<in> c. s = {C c, L l c}"
       using prem
       by blast
     then obtain s l where s_def: "s \<in> S'" "l \<in> c" "s = {C c, L l c}"
       by blast

     have "(?\<sigma>\<up>) l"
      unfolding constr_model_def lift_def
      apply (cases l)
      using s_def \<open>c \<in> set F\<close> apply force
      apply auto
      using constr_model_disj_aux[OF S'_def] s_def
      by blast
     with s_def \<open>c \<in> set F\<close>
     show "\<exists>s\<in>S'. \<exists>l\<in>c. s = {C c, L l c} \<and> (?\<sigma>\<up>) l"
       by blast
   qed
   then have "?\<sigma> \<Turnstile> F"
     unfolding models_def
     by blast
   then show ?thesis
     unfolding cnf_sat_def sat_def
     by blast
qed

theorem is_reduction_ts_xc:
"is_reduction ts_xc cnf_sat exact_cover"
  unfolding is_reduction_def
  using ts_xc_sound ts_xc_complete
  by blast

end