(*
    Author:   Benedikt Seidl
    Author:   Salomon Sickert
    License:  BSD
*)

section \<open>Disjunctive Normal Form of LTL formulas\<close>

theory Disjunctive_Normal_Form
imports
  LTL Equivalence_Relations "HOL-Library.FSet"
"Eval_Base.Eval_Base"
begin

text \<open>
  We use the propositional representation of LTL formulas to define
  the minimal disjunctive normal form of our formulas. For this purpose
  we define the minimal product \<open>\<otimes>\<^sub>m\<close> and union \<open>\<union>\<^sub>m\<close>.
  In the end we show that for a set \<open>\<A>\<close> of literals,
  @{term "\<A> \<Turnstile>\<^sub>P \<phi>"} if, and only if, there exists a subset
  of \<open>\<A>\<close> in the minimal DNF of \<open>\<phi>\<close>.
\<close>

subsection \<open>Definition of Minimum Sets\<close>

definition (in ord) min_set :: "'a set \<Rightarrow> 'a set" where
  "min_set X = {y \<in> X. \<forall>x \<in> X. x \<le> y \<longrightarrow> x = y}"

lemma min_set_iff:
  "x \<in> min_set X \<longleftrightarrow> x \<in> X \<and> (\<forall>y \<in> X. y \<le> x \<longrightarrow> y = x)"
  unfolding min_set_def by blast

lemma min_set_subset:
  "min_set X \<subseteq> X"
  by (auto simp: min_set_def)

lemma min_set_idem[simp]:
  "min_set (min_set X) = min_set X"
  by (auto simp: min_set_def)

lemma min_set_empty[simp]:
  "min_set {} = {}"
  using min_set_subset by blast

lemma min_set_singleton[simp]:
  "min_set {x} = {x}"
  by (auto simp: min_set_def)

lemma min_set_obtains_helper:
  "A \<in> B \<Longrightarrow> \<exists>C. C |\<subseteq>| A \<and> C \<in> min_set B"
proof2 (induction "fcard A" arbitrary: A rule: less_induct)
  case less

  then have "(\<forall>A'. A' \<notin> B \<or> \<not> A' |\<subseteq>| A \<or> A' = A) \<or> (\<exists>A'. A' |\<subseteq>| A \<and> A' \<in> min_set B)"
    by (metis (no_types) dual_order.trans order.not_eq_order_implies_strict pfsubset_fcard_mono)

  then show ?case
    using less.prems min_set_def by auto
qed

lemma min_set_obtains:
  assumes "A \<in> B"
  obtains C where "C |\<subseteq>| A" and "C \<in> min_set B"
  using min_set_obtains_helper assms by metis

subsection \<open>Minimal operators on sets\<close>

definition product :: "'a fset set \<Rightarrow> 'a fset set \<Rightarrow> 'a fset set" (infixr "\<otimes>" 65)
  where "A \<otimes> B = {a |\<union>| b | a b. a \<in> A \<and> b \<in> B}"

definition min_product :: "'a fset set \<Rightarrow> 'a fset set \<Rightarrow> 'a fset set" (infixr "\<otimes>\<^sub>m" 65)
  where "A \<otimes>\<^sub>m B = min_set (A \<otimes> B)"

definition min_union :: "'a fset set \<Rightarrow> 'a fset set \<Rightarrow> 'a fset set" (infixr "\<union>\<^sub>m" 65)
  where "A \<union>\<^sub>m B = min_set (A \<union> B)"

definition product_set :: "'a fset set set \<Rightarrow> 'a fset set" ("\<Otimes>")
  where "\<Otimes> X = Finite_Set.fold product {{||}} X"

definition min_product_set :: "'a fset set set \<Rightarrow> 'a fset set" ("\<Otimes>\<^sub>m")
  where "\<Otimes>\<^sub>m X = Finite_Set.fold min_product {{||}} X"

lemma min_product_idem[simp]:
  "A \<otimes>\<^sub>m A = min_set A"
  by (auto simp: min_product_def product_def min_set_def) fastforce

lemma min_union_idem[simp]:
  "A \<union>\<^sub>m A = min_set A"
  by (simp add: min_union_def)

lemma product_empty[simp]:
  "A \<otimes> {} = {}"
  "{} \<otimes> A = {}"
  by (simp_all add: product_def)

lemma min_product_empty[simp]:
  "A \<otimes>\<^sub>m {} = {}"
  "{} \<otimes>\<^sub>m A = {}"
  by (simp_all add: min_product_def)

lemma min_union_empty[simp]:
  "A \<union>\<^sub>m {} = min_set A"
  "{} \<union>\<^sub>m A = min_set A"
  by (simp_all add: min_union_def)

lemma product_empty_singleton[simp]:
  "A \<otimes> {{||}} = A"
  "{{||}} \<otimes> A = A"
  by (simp_all add: product_def)

lemma min_product_empty_singleton[simp]:
  "A \<otimes>\<^sub>m {{||}} = min_set A"
  "{{||}} \<otimes>\<^sub>m A = min_set A"
  by (simp_all add: min_product_def)

lemma product_singleton_singleton:
  "A \<otimes> {{|x|}} = finsert x ` A"
  "{{|x|}} \<otimes> A = finsert x ` A"
  unfolding product_def by blast+

lemma product_mono:
  "A \<subseteq> B \<Longrightarrow> A \<otimes> C \<subseteq> B \<otimes> C"
  "B \<subseteq> C \<Longrightarrow> A \<otimes> B \<subseteq> A \<otimes> C"
  unfolding product_def by auto

lemma product_finite:
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite (A \<otimes> B)"
  by (simp add: product_def finite_image_set2)

lemma min_product_finite:
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite (A \<otimes>\<^sub>m B)"
  by (metis min_product_def product_finite min_set_finite)

lemma min_union_finite:
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite (A \<union>\<^sub>m B)"
  by (simp add: min_union_def min_set_finite)

lemma product_set_infinite[simp]:
  "infinite X \<Longrightarrow> \<Otimes> X = {{||}}"
  by (simp add: product_set_def)

lemma min_product_set_infinite[simp]:
  "infinite X \<Longrightarrow> \<Otimes>\<^sub>m X = {{||}}"
  by (simp add: min_product_set_def)

lemma product_comm:
  "A \<otimes> B = B \<otimes> A"
  unfolding product_def by blast

lemma min_union_comm:
  "A \<union>\<^sub>m B = B \<union>\<^sub>m A"
  unfolding min_union_def
  by (simp add: sup.commute)

lemma product_iff:
  "x \<in> A \<otimes> B \<longleftrightarrow> (\<exists>a \<in> A. \<exists>b \<in> B. x = a |\<union>| b)"
  unfolding product_def by blast

lemma min_product_iff:
  "x \<in> A \<otimes>\<^sub>m B \<longleftrightarrow> (\<exists>a \<in> A. \<exists>b \<in> B. x = a |\<union>| b) \<and> (\<forall>a \<in> A. \<forall>b \<in> B. a |\<union>| b |\<subseteq>| x \<longrightarrow> a |\<union>| b = x)"
  unfolding min_product_def min_set_iff product_iff product_def by blast

lemma min_union_iff:
  "x \<in> A \<union>\<^sub>m B \<longleftrightarrow> x \<in> A \<union> B \<and> (\<forall>a \<in> A. a |\<subseteq>| x \<longrightarrow> a = x) \<and> (\<forall>b \<in> B. b |\<subseteq>| x \<longrightarrow> b = x)"
  unfolding min_union_def min_set_iff by blast

  then obtain a b where "a \<in> min_set A" and "b \<in> B" and "x = a |\<union>| b" and 1: "\<forall>a \<in> min_set A. \<forall>b \<in> B. a |\<union>| b |\<subseteq>| x \<longrightarrow> a |\<union>| b = x"
    unfolding min_product_iff by blast

  moreover

  {
    fix a' b'
    assume "a' \<in> A" and "b' \<in> B" and "a' |\<union>| b' |\<subseteq>| x"

    then obtain a'' where "a'' |\<subseteq>| a'" and "a'' \<in> min_set A"
      using min_set_obtains by metis

    then have "a'' |\<union>| b' = x"
      by (metis (full_types) 1 \<open>b' \<in> B\<close> \<open>a' |\<union>| b' |\<subseteq>| x\<close> dual_order.trans le_sup_iff)

    then have "a' |\<union>| b' = x"
      using \<open>a' |\<union>| b' |\<subseteq>| x\<close> \<open>a'' |\<subseteq>| a'\<close> by blast
  }

  ultimately show "x \<in> A \<otimes>\<^sub>m B"
    by (metis min_product_iff min_set_iff)
next
  fix x
  assume "x \<in> A \<otimes>\<^sub>m B"

  then have 1: "x \<in> A \<otimes> B" and "\<forall>y \<in> A \<otimes> B. y |\<subseteq>| x \<longrightarrow> y = x"
    unfolding min_product_def min_set_iff by simp+

  then have 2: "\<forall>y\<in>min_set A \<otimes> B. y |\<subseteq>| x \<longrightarrow> y = x"
    by (metis product_iff min_set_iff)

  then have "x \<in> min_set A \<otimes> B"
    by (metis 1 funion_mono min_set_obtains order_refl product_iff)

  then show "x \<in> min_set A \<otimes>\<^sub>m B"
    by (simp add: 2 min_product_def min_set_iff)
qed

lemma min_set_min_product[simp]:
  "(min_set A) \<otimes>\<^sub>m B = A \<otimes>\<^sub>m B"
  "A \<otimes>\<^sub>m (min_set B) = A \<otimes>\<^sub>m B"
  using min_product_comm min_set_min_product_helper by blast+

lemma min_set_min_union[simp]:
  "(min_set A) \<union>\<^sub>m B = A \<union>\<^sub>m B"
  "A \<union>\<^sub>m (min_set B) = A \<union>\<^sub>m B"
proof (unfold min_union_def min_set_def, safe)
  show "\<And>x xa xb. \<lbrakk>\<forall>xa\<in>{y \<in> A. \<forall>x\<in>A. x |\<subseteq>| y \<longrightarrow> x = y} \<union> B. xa |\<subseteq>| x \<longrightarrow> xa = x; x \<in> B; xa |\<subseteq>| x; xb |\<in>| x; xa \<in> A\<rbrakk> \<Longrightarrow> xb |\<in>| xa"
    by (metis (mono_tags) UnCI dual_order.trans fequalityI min_set_def min_set_obtains)
next
  show "\<And>x xa xb. \<lbrakk>\<forall>xa\<in>A \<union> {y \<in> B. \<forall>x\<in>B. x |\<subseteq>| y \<longrightarrow> x = y}. xa |\<subseteq>| x \<longrightarrow> xa = x; x \<in> A; xa |\<subseteq>| x; xb |\<in>| x; xa \<in> B\<rbrakk> \<Longrightarrow> xb |\<in>| xa"
    by (metis (mono_tags) UnCI dual_order.trans fequalityI min_set_def min_set_obtains)
qed blast+

lemma product_assoc[simp]:
  "(A \<otimes> B) \<otimes> C = A \<otimes> (B \<otimes> C)"
proof (unfold product_def, safe)
  fix a b c
  assume "a \<in> A" and "c \<in> C" and "b \<in> B"
  then have "b |\<union>| c \<in> {b |\<union>| c |b c. b \<in> B \<and> c \<in> C}"
    by blast
  then show "\<exists>a' bc. a |\<union>| b |\<union>| c = a' |\<union>| bc \<and> a' \<in> A \<and> bc \<in> {b |\<union>| c |b c. b \<in> B \<and> c \<in> C}"
    using `a \<in> A` by (metis (no_types) inf_sup_aci(5) sup_left_commute)
qed (metis (mono_tags, lifting) mem_Collect_eq sup_assoc)

lemma min_product_assoc[simp]:
  "(A \<otimes>\<^sub>m B) \<otimes>\<^sub>m C = A \<otimes>\<^sub>m (B \<otimes>\<^sub>m C)"
  unfolding min_product_def[of A B] min_product_def[of B C]
  by simp (simp add: min_product_def)

lemma min_union_assoc[simp]:
  "(A \<union>\<^sub>m B) \<union>\<^sub>m C = A \<union>\<^sub>m (B \<union>\<^sub>m C)"
  unfolding min_union_def[of A B] min_union_def[of B C]
  by simp (simp add: min_union_def sup_assoc)

lemma min_product_comp:
  "a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> \<exists>c. c |\<subseteq>| (a |\<union>| b) \<and> c \<in> A \<otimes>\<^sub>m B"
  by (metis (mono_tags, lifting) mem_Collect_eq min_product_def product_def min_set_obtains)

lemma min_union_comp:
  "a \<in> A \<Longrightarrow> \<exists>c. c |\<subseteq>| a \<and> c \<in> A \<union>\<^sub>m B"
  by (metis Un_iff min_set_obtains min_union_def)

interpretation product_set_thms: Finite_Set.comp_fun_commute product
proof unfold_locales
  have "\<And>x y z. x \<otimes> (y \<otimes> z) = y \<otimes> (x \<otimes> z)"
    by (simp only: product_assoc[symmetric]) (simp only: product_comm)

  then show "\<And>x y. (\<otimes>) y \<circ> (\<otimes>) x = (\<otimes>) x \<circ> (\<otimes>) y"
    by fastforce
qed

interpretation min_product_set_thms: Finite_Set.comp_fun_idem min_product
proof unfold_locales
  have "\<And>x y z. x \<otimes>\<^sub>m (y \<otimes>\<^sub>m z) = y \<otimes>\<^sub>m (x \<otimes>\<^sub>m z)"
    by (simp only: min_product_assoc[symmetric]) (simp only: min_product_comm)

  then show "\<And>x y. (\<otimes>\<^sub>m) y \<circ> (\<otimes>\<^sub>m) x = (\<otimes>\<^sub>m) x \<circ> (\<otimes>\<^sub>m) y"
    by fastforce
next
  have "\<And>x y. x \<otimes>\<^sub>m (x \<otimes>\<^sub>m y) = x \<otimes>\<^sub>m y"
    by (simp add: min_product_assoc[symmetric])

  then show "\<And>x. (\<otimes>\<^sub>m) x \<circ> (\<otimes>\<^sub>m) x = (\<otimes>\<^sub>m) x"
    by fastforce
qed

interpretation min_union_set_thms: Finite_Set.comp_fun_idem min_union
proof unfold_locales
  have "\<And>x y z. x \<union>\<^sub>m (y \<union>\<^sub>m z) = y \<union>\<^sub>m (x \<union>\<^sub>m z)"
    by (simp only: min_union_assoc[symmetric]) (simp only: min_union_comm)

  then show "\<And>x y. (\<union>\<^sub>m) y \<circ> (\<union>\<^sub>m) x = (\<union>\<^sub>m) x \<circ> (\<union>\<^sub>m) y"
    by fastforce
next
  have "\<And>x y. x \<union>\<^sub>m (x \<union>\<^sub>m y) = x \<union>\<^sub>m y"
    by (simp add: min_union_assoc[symmetric])

  then show "\<And>x. (\<union>\<^sub>m) x \<circ> (\<union>\<^sub>m) x = (\<union>\<^sub>m) x"
    by fastforce
qed

lemma product_set_empty[simp]:
  "\<Otimes> {} = {{||}}"
  "\<Otimes> {{}} = {}"
  "\<Otimes> {{{||}}} = {{||}}"
  by (simp_all add: product_set_def)

lemma min_product_set_empty[simp]:
  "\<Otimes>\<^sub>m {} = {{||}}"
  "\<Otimes>\<^sub>m {{}} = {}"
  "\<Otimes>\<^sub>m {{{||}}} = {{||}}"
  by (simp_all add: min_product_set_def)

lemma product_set_code[code]:
  "\<Otimes> (set xs) = fold product (remdups xs) {{||}}"
  by (simp add: product_set_def product_set_thms.fold_set_fold_remdups)

lemma min_product_set_code[code]:
  "\<Otimes>\<^sub>m (set xs) = fold min_product (remdups xs) {{||}}"
  by (simp add: min_product_set_def min_product_set_thms.fold_set_fold_remdups)

lemma product_set_insert[simp]:
  "finite X \<Longrightarrow> \<Otimes> (insert x X) = x \<otimes> (\<Otimes> (X - {x}))"
  unfolding product_set_def product_set_thms.fold_insert_remove ..

lemma min_product_set_insert[simp]:
  "finite X \<Longrightarrow> \<Otimes>\<^sub>m (insert x X) = x \<otimes>\<^sub>m (\<Otimes>\<^sub>m X)"
  unfolding min_product_set_def min_product_set_thms.fold_insert_idem ..

lemma min_product_subseteq:
  "x \<in> A \<otimes>\<^sub>m B \<Longrightarrow> \<exists>a. a |\<subseteq>| x \<and> a \<in> A"
  by (metis funion_upper1 min_product_iff)

lemma min_product_set_subseteq:
  "finite X \<Longrightarrow> x \<in> \<Otimes>\<^sub>m X \<Longrightarrow> A \<in> X \<Longrightarrow> \<exists>a \<in> A. a |\<subseteq>| x"
  apply2 (induction X rule: finite_induct) by (blast, metis finite_insert insert_absorb min_product_set_insert min_product_subseteq)

lemma min_product_min_set[simp]:
  "min_set (A \<otimes>\<^sub>m B) = A \<otimes>\<^sub>m B"
  by (simp add: min_product_def)

lemma min_union_min_set[simp]:
  "min_set (A \<union>\<^sub>m B) = A \<union>\<^sub>m B"
  by (simp add: min_union_def)

lemma min_product_set_min_set[simp]:
  "finite X \<Longrightarrow> min_set (\<Otimes>\<^sub>m X) = \<Otimes>\<^sub>m X"
  apply2 (induction X rule: finite_induct) by (auto simp add: min_product_set_def min_set_iff)

lemma min_set_min_product_set[simp]:
  "finite X \<Longrightarrow> \<Otimes>\<^sub>m (min_set ` X) = \<Otimes>\<^sub>m X"
  apply2 (induction X rule: finite_induct) by simp_all

lemma min_product_set_union[simp]:
  "finite X \<Longrightarrow> finite Y \<Longrightarrow> \<Otimes>\<^sub>m (X \<union> Y) = (\<Otimes>\<^sub>m X) \<otimes>\<^sub>m (\<Otimes>\<^sub>m Y)"
  apply2 (induction X rule: finite_induct) by simp_all

lemma product_set_finite:
  "(\<And>x. x \<in> X \<Longrightarrow> finite x) \<Longrightarrow> finite (\<Otimes> X)"
  apply (cases "finite X", rotate_tac) apply2(induction X rule: finite_induct) by (simp_all add: product_set_def, insert product_finite, blast)(*Yutaka rewrote this for evaluation. Originally it was: apply (cases "finite X", rotate_tac, induction X rule: finite_induct, simp_all add: product_set_def, insert product_finite, blast)*)

lemma min_product_set_finite:
  "(\<And>x. x \<in> X \<Longrightarrow> finite x) \<Longrightarrow> finite (\<Otimes>\<^sub>m X)"
  apply (cases "finite X", rotate_tac) apply2(induction X rule: finite_induct) by (simp_all add: min_product_set_def, insert min_product_finite, blast)(*Yutaka rewrote this for evaluation. Originally it was: by (cases "finite X", rotate_tac, induction X rule: finite_induct, simp_all add: min_product_set_def, insert min_product_finite, blast)*)

subsection \<open>Disjunctive Normal Form\<close>

fun dnf :: "'a ltln \<Rightarrow> 'a ltln fset set"
where
  "dnf true\<^sub>n = {{||}}"
| "dnf false\<^sub>n = {}"
| "dnf (\<phi> and\<^sub>n \<psi>) = (dnf \<phi>) \<otimes> (dnf \<psi>)"
| "dnf (\<phi> or\<^sub>n \<psi>) = (dnf \<phi>) \<union> (dnf \<psi>)"
| "dnf \<phi> = {{|\<phi>|}}"

fun min_dnf :: "'a ltln \<Rightarrow> 'a ltln fset set"
where
  "min_dnf true\<^sub>n = {{||}}"
| "min_dnf false\<^sub>n = {}"
| "min_dnf (\<phi> and\<^sub>n \<psi>) = (min_dnf \<phi>) \<otimes>\<^sub>m (min_dnf \<psi>)"
| "min_dnf (\<phi> or\<^sub>n \<psi>) = (min_dnf \<phi>) \<union>\<^sub>m (min_dnf \<psi>)"
| "min_dnf \<phi> = {{|\<phi>|}}"

lemma dnf_min_set:
  "min_dnf \<phi> = min_set (dnf \<phi>)"
  apply2 (induction \<phi>) by (simp_all, simp_all only: min_product_def min_union_def)

lemma dnf_finite:
  "finite (dnf \<phi>)"
  apply2 (induction \<phi>) by (auto simp: product_finite)

lemma min_dnf_finite:
  "finite (min_dnf \<phi>)"
  apply2 (induction \<phi>) by (auto simp: min_product_finite min_union_finite)

lemma dnf_Abs_fset[simp]:
  "fset (Abs_fset (dnf \<phi>)) = dnf \<phi>"
  by (simp add: dnf_finite Abs_fset_inverse)

lemma min_dnf_Abs_fset[simp]:
  "fset (Abs_fset (min_dnf \<phi>)) = min_dnf \<phi>"
  by (simp add: min_dnf_finite Abs_fset_inverse)

lemma dnf_prop_atoms:
  "\<Phi> \<in> dnf \<phi> \<Longrightarrow> fset \<Phi> \<subseteq> prop_atoms \<phi>"
  apply2 (induction \<phi> arbitrary: \<Phi>) by (auto simp: product_def, blast+)

lemma min_dnf_prop_atoms:
  "\<Phi> \<in> min_dnf \<phi> \<Longrightarrow> fset \<Phi> \<subseteq> prop_atoms \<phi>"
  using dnf_min_set dnf_prop_atoms min_set_subset by blast

lemma min_dnf_atoms_dnf:
  "\<Phi> \<in> min_dnf \<psi> \<Longrightarrow> \<phi> \<in> fset \<Phi> \<Longrightarrow> dnf \<phi> = {{|\<phi>|}}"
proof2 (induction \<phi>)
  case True_ltln
  then show ?case
    using min_dnf_prop_atoms prop_atoms_notin(1) by blast
next
  case False_ltln
  then show ?case
    using min_dnf_prop_atoms prop_atoms_notin(2) by blast
next
  case (And_ltln \<phi>1 \<phi>2)
  then show ?case
    using min_dnf_prop_atoms prop_atoms_notin(3) by force
next
  case (Or_ltln \<phi>1 \<phi>2)
  then show ?case
    using min_dnf_prop_atoms prop_atoms_notin(4) by force
qed auto

lemma min_dnf_min_set[simp]:
  "min_set (min_dnf \<phi>) = min_dnf \<phi>"
  apply2 (induction \<phi>) by (simp_all add: min_set_def min_product_def min_union_def, blast+)

lemma min_dnf_iff_prop_assignment_subset:
  "\<A> \<Turnstile>\<^sub>P \<phi> \<longleftrightarrow> (\<exists>B. fset B \<subseteq> \<A> \<and> B \<in> min_dnf \<phi>)"
proof
  assume "\<A> \<Turnstile>\<^sub>P \<phi>"

  then show "\<exists>B. fset B \<subseteq> \<A> \<and> B \<in> min_dnf \<phi>"
  proof2 (induction \<phi> arbitrary: \<A>)
    case (And_ltln \<phi>\<^sub>1 \<phi>\<^sub>2)

    then obtain B\<^sub>1 B\<^sub>2 where 1: "fset B\<^sub>1 \<subseteq> \<A> \<and> B\<^sub>1 \<in> min_dnf \<phi>\<^sub>1" and 2: "fset B\<^sub>2 \<subseteq> \<A> \<and> B\<^sub>2 \<in> min_dnf \<phi>\<^sub>2"
      by fastforce

    then obtain C where "C |\<subseteq>| B\<^sub>1 |\<union>| B\<^sub>2" and "C \<in> min_dnf \<phi>\<^sub>1 \<otimes>\<^sub>m min_dnf \<phi>\<^sub>2"
      using min_product_comp by metis

    then show ?case
      by (metis 1 2 le_sup_iff min_dnf.simps(3) sup.absorb_iff1 sup_fset.rep_eq)
  next
    case (Or_ltln \<phi>\<^sub>1 \<phi>\<^sub>2)

    {
      assume "\<A> \<Turnstile>\<^sub>P \<phi>\<^sub>1"

      then obtain B where 1: "fset B \<subseteq> \<A> \<and> B \<in> min_dnf \<phi>\<^sub>1"
        using Or_ltln by fastforce

      then obtain C where "C |\<subseteq>| B" and "C \<in> min_dnf \<phi>\<^sub>1 \<union>\<^sub>m min_dnf \<phi>\<^sub>2"
        using min_union_comp by metis

      then have ?case
        by (metis 1 dual_order.trans less_eq_fset.rep_eq min_dnf.simps(4))
    }

    moreover

    {
      assume "\<A> \<Turnstile>\<^sub>P \<phi>\<^sub>2"

      then obtain B where 2: "fset B \<subseteq> \<A> \<and> B \<in> min_dnf \<phi>\<^sub>2"
        using Or_ltln by fastforce

      then obtain C where "C |\<subseteq>| B" and "C \<in> min_dnf \<phi>\<^sub>1 \<union>\<^sub>m min_dnf \<phi>\<^sub>2"
        using min_union_comp min_union_comm by metis

      then have ?case
        by (metis 2 dual_order.trans less_eq_fset.rep_eq min_dnf.simps(4))
    }

    ultimately show ?case
      using Or_ltln.prems by auto
  qed simp_all
next
  assume "\<exists>B. fset B \<subseteq> \<A> \<and> B \<in> min_dnf \<phi>"

  then obtain B where "fset B \<subseteq> \<A>" and "B \<in> min_dnf \<phi>"
    by auto

  then have "fset B \<Turnstile>\<^sub>P \<phi>"
    apply2 (induction \<phi> arbitrary: B) by (auto simp: min_set_def min_product_def product_def min_union_def, blast+)

  then show "\<A> \<Turnstile>\<^sub>P \<phi>"
    using \<open>fset B \<subseteq> \<A>\<close> by blast
qed

lemma ltl_prop_implies_min_dnf:
  "\<phi> \<longrightarrow>\<^sub>P \<psi> = (\<forall>A \<in> min_dnf \<phi>. \<exists>B \<in> min_dnf \<psi>. B |\<subseteq>| A)"
  by (meson less_eq_fset.rep_eq ltl_prop_implies_def min_dnf_iff_prop_assignment_subset order_refl dual_order.trans)

lemma ltl_prop_equiv_min_dnf:
  "\<phi> \<sim>\<^sub>P \<psi> = (min_dnf \<phi> = min_dnf \<psi>)"
proof
  assume "\<phi> \<sim>\<^sub>P \<psi>"

  then have "\<And>x. x \<in> min_set (min_dnf \<phi>) \<longleftrightarrow> x \<in> min_set (min_dnf \<psi>)"
    unfolding ltl_prop_implies_equiv ltl_prop_implies_min_dnf min_set_iff
    by fastforce

  then show "min_dnf \<phi> = min_dnf \<psi>"
    by auto
qed (simp add: ltl_prop_equiv_def min_dnf_iff_prop_assignment_subset)

subsection \<open>Folding of \<open>and\<^sub>n\<close> and \<open>or\<^sub>n\<close> over Finite Sets\<close>

definition And\<^sub>n :: "'a ltln set \<Rightarrow> 'a ltln"
where
  "And\<^sub>n \<Phi> \<equiv> SOME \<phi>. fold_graph And_ltln True_ltln \<Phi> \<phi>"

definition Or\<^sub>n :: "'a ltln set \<Rightarrow> 'a ltln"
where
  "Or\<^sub>n \<Phi> \<equiv> SOME \<phi>. fold_graph Or_ltln False_ltln \<Phi> \<phi>"

lemma fold_graph_And\<^sub>n:
  "finite \<Phi> \<Longrightarrow> fold_graph And_ltln True_ltln \<Phi> (And\<^sub>n \<Phi>)"
  unfolding And\<^sub>n_def by (rule someI2_ex[OF finite_imp_fold_graph])

lemma fold_graph_Or\<^sub>n:
  "finite \<Phi> \<Longrightarrow> fold_graph Or_ltln False_ltln \<Phi> (Or\<^sub>n \<Phi>)"
  unfolding Or\<^sub>n_def by (rule someI2_ex[OF finite_imp_fold_graph])

lemma Or\<^sub>n_empty[simp]:
  "Or\<^sub>n {} = False_ltln"
  by (metis empty_fold_graphE finite.emptyI fold_graph_Or\<^sub>n)

lemma And\<^sub>n_empty[simp]:
  "And\<^sub>n {} = True_ltln"
  by (metis empty_fold_graphE finite.emptyI fold_graph_And\<^sub>n)

interpretation dnf_union_thms: Finite_Set.comp_fun_commute "\<lambda>\<phi>. (\<union>) (f \<phi>)"
  by unfold_locales fastforce

interpretation dnf_product_thms: Finite_Set.comp_fun_commute "\<lambda>\<phi>. (\<otimes>) (f \<phi>)"
  by unfold_locales (simp add: product_set_thms.comp_fun_commute)

\<comment> \<open>Copied from locale @{locale comp_fun_commute}\<close>

text \<open>Taking the DNF of @{const And\<^sub>n} and @{const Or\<^sub>n} is the same as folding over the individual DNFs.\<close>

lemma And\<^sub>n_dnf:
  "finite \<Phi> \<Longrightarrow> dnf (And\<^sub>n \<Phi>) = Finite_Set.fold (\<lambda>\<phi>. (\<otimes>) (dnf \<phi>)) {{||}} \<Phi>"
  apply (drule fold_graph_And\<^sub>n) proof2 (induction rule: fold_graph.induct)(*Yutaka rewrote this for evaluation. Originally, it was: proof (drule fold_graph_And\<^sub>n, induction rule: fold_graph.induct)*)
  case (insertI x A y)

  then have "finite A"
    using fold_graph_finite by fast

  then show ?case
    using insertI by auto
qed simp

lemma Or\<^sub>n_dnf:
  "finite \<Phi> \<Longrightarrow> dnf (Or\<^sub>n \<Phi>) = Finite_Set.fold (\<lambda>\<phi>. (\<union>) (dnf \<phi>)) {} \<Phi>"
  apply (drule fold_graph_Or\<^sub>n)proof2(induction rule: fold_graph.induct)(*Yutaka rewrote this for evaluation. Originally, it was: proof (drule fold_graph_Or\<^sub>n, induction rule: fold_graph.induct)*)
  case (insertI x A y)

  then have "finite A"
    using fold_graph_finite by fast

  then show ?case
    using insertI by auto
qed simp

text \<open>@{const And\<^sub>n} and @{const Or\<^sub>n} are injective on finite sets.\<close>

lemma And\<^sub>n_inj:
  "inj_on And\<^sub>n {s. finite s}"
proof (standard, simp)
  fix x y :: "'a ltln set"
  assume "finite x" and "finite y"

  then have 1: "fold_graph And_ltln True_ltln x (And\<^sub>n x)" and 2: "fold_graph And_ltln True_ltln y (And\<^sub>n y)"
    using fold_graph_And\<^sub>n by blast+

  assume "And\<^sub>n x = And\<^sub>n y"

  with 1 show "x = y"
  proof2 (induction rule: fold_graph.induct)
    case emptyI
    then show ?case
      using 2 fold_graph.cases by force
  next
    case (insertI x A y)
    with 2 show ?case
    proof2 (induction arbitrary: x A y rule: fold_graph.induct)
      case (insertI x A y)
      then show ?case
        by (metis fold_graph.cases insertI1 ltln.distinct(7) ltln.inject(3))
    qed blast
  qed
qed

lemma Or\<^sub>n_inj:
  "inj_on Or\<^sub>n {s. finite s}"
proof (standard, simp)
  fix x y :: "'a ltln set"
  assume "finite x" and "finite y"

  then have 1: "fold_graph Or_ltln False_ltln x (Or\<^sub>n x)" and 2: "fold_graph Or_ltln False_ltln y (Or\<^sub>n y)"
    using fold_graph_Or\<^sub>n by blast+

  assume "Or\<^sub>n x = Or\<^sub>n y"

  with 1 show "x = y"
  proof2 (induction rule: fold_graph.induct)
    case emptyI
    then show ?case
      using 2 fold_graph.cases by force
  next
    case (insertI x A y)
    with 2 show ?case
    proof2 (induction arbitrary: x A y rule: fold_graph.induct)
      case (insertI x A y)
      then show ?case
        by (metis fold_graph.cases insertI1 ltln.distinct(27) ltln.inject(4))
    qed blast
  qed
qed

text \<open>The semantics of @{const And\<^sub>n} and @{const Or\<^sub>n} can be expressed using quantifiers.\<close>

lemma And\<^sub>n_semantics:
  "finite \<Phi> \<Longrightarrow> w \<Turnstile>\<^sub>n And\<^sub>n \<Phi> \<longleftrightarrow> (\<forall>\<phi> \<in> \<Phi>. w \<Turnstile>\<^sub>n \<phi>)"
proof -
  assume "finite \<Phi>"
  have "\<And>\<psi>. fold_graph And_ltln True_ltln \<Phi> \<psi> \<Longrightarrow> w \<Turnstile>\<^sub>n \<psi> \<longleftrightarrow> (\<forall>\<phi> \<in> \<Phi>. w \<Turnstile>\<^sub>n \<phi>)"
    by (rule fold_graph.induct) auto
  then show ?thesis
    using fold_graph_And\<^sub>n[OF \<open>finite \<Phi>\<close>] by simp
qed

lemma Or\<^sub>n_semantics:
  "finite \<Phi> \<Longrightarrow> w \<Turnstile>\<^sub>n Or\<^sub>n \<Phi> \<longleftrightarrow> (\<exists>\<phi> \<in> \<Phi>. w \<Turnstile>\<^sub>n \<phi>)"
proof -
  assume "finite \<Phi>"
  have "\<And>\<psi>. fold_graph Or_ltln False_ltln \<Phi> \<psi> \<Longrightarrow> w \<Turnstile>\<^sub>n \<psi> \<longleftrightarrow> (\<exists>\<phi> \<in> \<Phi>. w \<Turnstile>\<^sub>n \<phi>)"
    by (rule fold_graph.induct) auto
  then show ?thesis
    using fold_graph_Or\<^sub>n[OF \<open>finite \<Phi>\<close>] by simp
qed

lemma And\<^sub>n_prop_semantics:
  "finite \<Phi> \<Longrightarrow> \<A> \<Turnstile>\<^sub>P And\<^sub>n \<Phi> \<longleftrightarrow> (\<forall>\<phi> \<in> \<Phi>. \<A> \<Turnstile>\<^sub>P \<phi>)"
proof -
  assume "finite \<Phi>"
  have "\<And>\<psi>. fold_graph And_ltln True_ltln \<Phi> \<psi> \<Longrightarrow> \<A> \<Turnstile>\<^sub>P \<psi> \<longleftrightarrow> (\<forall>\<phi> \<in> \<Phi>. \<A> \<Turnstile>\<^sub>P \<phi>)"
    by (rule fold_graph.induct) auto
  then show ?thesis
    using fold_graph_And\<^sub>n[OF \<open>finite \<Phi>\<close>] by simp
qed

lemma Or\<^sub>n_prop_semantics:
  "finite \<Phi> \<Longrightarrow> \<A> \<Turnstile>\<^sub>P Or\<^sub>n \<Phi> \<longleftrightarrow> (\<exists>\<phi> \<in> \<Phi>. \<A> \<Turnstile>\<^sub>P \<phi>)"
proof -
  assume "finite \<Phi>"
  have "\<And>\<psi>. fold_graph Or_ltln False_ltln \<Phi> \<psi> \<Longrightarrow> \<A> \<Turnstile>\<^sub>P \<psi> \<longleftrightarrow> (\<exists>\<phi> \<in> \<Phi>. \<A> \<Turnstile>\<^sub>P \<phi>)"
    by (rule fold_graph.induct) auto
  then show ?thesis
    using fold_graph_Or\<^sub>n[OF \<open>finite \<Phi>\<close>] by simp
qed

lemma Or\<^sub>n_And\<^sub>n_image_semantics:
  assumes "finite \<A>" and "\<And>\<Phi>. \<Phi> \<in> \<A> \<Longrightarrow> finite \<Phi>"
  shows "w \<Turnstile>\<^sub>n Or\<^sub>n (And\<^sub>n ` \<A>) \<longleftrightarrow> (\<exists>\<Phi> \<in> \<A>. \<forall>\<phi> \<in> \<Phi>. w \<Turnstile>\<^sub>n \<phi>)"
proof -
  have "w \<Turnstile>\<^sub>n Or\<^sub>n (And\<^sub>n ` \<A>) \<longleftrightarrow> (\<exists>\<Phi> \<in> \<A>. w \<Turnstile>\<^sub>n And\<^sub>n \<Phi>)"
    using Or\<^sub>n_semantics assms by auto
  then show ?thesis
    using And\<^sub>n_semantics assms by fast
qed

lemma Or\<^sub>n_And\<^sub>n_image_prop_semantics:
  assumes "finite \<A>" and "\<And>\<Phi>. \<Phi> \<in> \<A> \<Longrightarrow> finite \<Phi>"
  shows "\<I> \<Turnstile>\<^sub>P Or\<^sub>n (And\<^sub>n ` \<A>) \<longleftrightarrow> (\<exists>\<Phi> \<in> \<A>. \<forall>\<phi> \<in> \<Phi>. \<I> \<Turnstile>\<^sub>P \<phi>)"
proof -
  have "\<I> \<Turnstile>\<^sub>P Or\<^sub>n (And\<^sub>n ` \<A>) \<longleftrightarrow> (\<exists>\<Phi> \<in> \<A>. \<I> \<Turnstile>\<^sub>P And\<^sub>n \<Phi>)"
    using Or\<^sub>n_prop_semantics assms by blast
  then show ?thesis
    using And\<^sub>n_prop_semantics assms by metis
qed

subsection \<open>DNF to LTL conversion\<close>

definition ltln_of_dnf :: "'a ltln fset set \<Rightarrow> 'a ltln"
where
  "ltln_of_dnf \<A> = Or\<^sub>n (And\<^sub>n ` fset ` \<A>)"

lemma ltln_of_dnf_semantics:
  assumes "finite \<A>"
  shows "w \<Turnstile>\<^sub>n ltln_of_dnf \<A> \<longleftrightarrow> (\<exists>\<Phi> \<in> \<A>. \<forall>\<phi>. \<phi> |\<in>| \<Phi> \<longrightarrow> w \<Turnstile>\<^sub>n \<phi>)"
proof -
  have "finite (fset ` \<A>)"
    using assms by blast

  then have "w \<Turnstile>\<^sub>n ltln_of_dnf \<A> \<longleftrightarrow> (\<exists>\<Phi> \<in> fset ` \<A>. \<forall>\<phi> \<in> \<Phi>. w \<Turnstile>\<^sub>n \<phi>)"
    unfolding ltln_of_dnf_def using Or\<^sub>n_And\<^sub>n_image_semantics by fastforce

  then show ?thesis
    by (metis image_iff notin_fset)
qed

lemma ltln_of_dnf_prop_semantics:
  assumes "finite \<A>"
  shows "\<I> \<Turnstile>\<^sub>P ltln_of_dnf \<A> \<longleftrightarrow> (\<exists>\<Phi> \<in> \<A>. \<forall>\<phi>. \<phi> |\<in>| \<Phi> \<longrightarrow> \<I> \<Turnstile>\<^sub>P \<phi>)"
proof -
  have "finite (fset ` \<A>)"
    using assms by blast

  then have "\<I> \<Turnstile>\<^sub>P ltln_of_dnf \<A> \<longleftrightarrow> (\<exists>\<Phi> \<in> fset ` \<A>. \<forall>\<phi> \<in> \<Phi>. \<I> \<Turnstile>\<^sub>P \<phi>)"
    unfolding ltln_of_dnf_def using Or\<^sub>n_And\<^sub>n_image_prop_semantics by fastforce

  then show ?thesis
    by (metis image_iff notin_fset)
qed

lemma ltln_of_dnf_prop_equiv:
  "ltln_of_dnf (min_dnf \<phi>) \<sim>\<^sub>P \<phi>"
  unfolding ltl_prop_equiv_def
proof
  fix \<A>
  have "\<A> \<Turnstile>\<^sub>P ltln_of_dnf (min_dnf \<phi>) \<longleftrightarrow> (\<exists>\<Phi> \<in> min_dnf \<phi>. \<forall>\<phi>. \<phi> |\<in>| \<Phi> \<longrightarrow> \<A> \<Turnstile>\<^sub>P \<phi>)"
    using ltln_of_dnf_prop_semantics min_dnf_finite by metis
  also have "\<dots> \<longleftrightarrow> (\<exists>\<Phi> \<in> min_dnf \<phi>. fset \<Phi> \<subseteq> \<A>)"
    by (metis min_dnf_prop_atoms prop_atoms_entailment_iff notin_fset subset_eq)
  also have "\<dots> \<longleftrightarrow> \<A> \<Turnstile>\<^sub>P \<phi>"
    using min_dnf_iff_prop_assignment_subset by blast
  finally show "\<A> \<Turnstile>\<^sub>P ltln_of_dnf (min_dnf \<phi>) = \<A> \<Turnstile>\<^sub>P \<phi>" .
qed

lemma min_dnf_ltln_of_dnf[simp]:
  "min_dnf (ltln_of_dnf (min_dnf \<phi>)) = min_dnf \<phi>"
  using ltl_prop_equiv_min_dnf ltln_of_dnf_prop_equiv by blast

subsection \<open>Substitution in DNF formulas\<close>

definition subst_clause :: "'a ltln fset \<Rightarrow> ('a ltln \<rightharpoonup> 'a ltln) \<Rightarrow> 'a ltln fset set"
where
  "subst_clause \<Phi> m = \<Otimes>\<^sub>m {min_dnf (subst \<phi> m) | \<phi>. \<phi> \<in> fset \<Phi>}"

definition subst_dnf :: "'a ltln fset set \<Rightarrow> ('a ltln \<rightharpoonup> 'a ltln) \<Rightarrow> 'a ltln fset set"
where
  "subst_dnf \<A> m = (\<Union>\<Phi> \<in> \<A>. subst_clause \<Phi> m)"

lemma subst_clause_empty[simp]:
  "subst_clause {||} m = {{||}}"
  by (simp add: subst_clause_def)

lemma subst_dnf_empty[simp]:
  "subst_dnf {} m = {}"
  by (simp add: subst_dnf_def)

lemma subst_clause_inner_finite:
  "finite {min_dnf (subst \<phi> m) | \<phi>. \<phi> \<in> \<Phi>}" if "finite \<Phi>"
  using that by simp

lemma subst_clause_finite:
  "finite (subst_clause \<Phi> m)"
  unfolding subst_clause_def
  by (auto intro: min_dnf_finite min_product_set_finite)

lemma subst_dnf_finite:
  "finite \<A> \<Longrightarrow> finite (subst_dnf \<A> m)"
  unfolding subst_dnf_def using subst_clause_finite by blast

lemma subst_dnf_mono:
  "\<A> \<subseteq> \<B> \<Longrightarrow> subst_dnf \<A> m \<subseteq> subst_dnf \<B> m"
  unfolding subst_dnf_def by blast

lemma subst_clause_min_set[simp]:
  "min_set (subst_clause \<Phi> m) = subst_clause \<Phi> m"
  unfolding subst_clause_def by simp

lemma subst_clause_finsert[simp]:
  "subst_clause (finsert \<phi> \<Phi>) m = (min_dnf (subst \<phi> m)) \<otimes>\<^sub>m (subst_clause \<Phi> m)"
proof -
  have "{min_dnf (subst \<psi> m) | \<psi>. \<psi> \<in> fset (finsert \<phi> \<Phi>)}
    = insert (min_dnf (subst \<phi> m)) {min_dnf (subst \<psi> m) | \<psi>. \<psi> \<in> fset \<Phi>}"
    by auto

  then show ?thesis
    by (simp add: subst_clause_def)
qed

lemma subst_clause_funion[simp]:
  "subst_clause (\<Phi> |\<union>| \<Psi>) m = (subst_clause \<Phi> m) \<otimes>\<^sub>m (subst_clause \<Psi> m)"
proof2 (induction \<Psi>)
  case (insert x F)
  then show ?case
    using min_product_set_thms.fun_left_comm by fastforce
qed simp

text \<open>For the proof of correctness, we redefine the @{const product} operator on lists.\<close>

definition list_product :: "'a list set \<Rightarrow> 'a list set \<Rightarrow> 'a list set" (infixl "\<otimes>\<^sub>l" 65)
where
  "A \<otimes>\<^sub>l B = {a @ b | a b. a \<in> A \<and> b \<in> B}"

lemma list_product_fset_of_list[simp]:
  "fset_of_list ` (A \<otimes>\<^sub>l B) = (fset_of_list ` A) \<otimes> (fset_of_list ` B)"
  unfolding list_product_def product_def image_def by fastforce

lemma list_product_finite:
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite (A \<otimes>\<^sub>l B)"
  unfolding list_product_def by (simp add: finite_image_set2)

lemma list_product_iff:
  "x \<in> A \<otimes>\<^sub>l B \<longleftrightarrow> (\<exists>a b. a \<in> A \<and> b \<in> B \<and> x = a @ b)"
  unfolding list_product_def by blast

lemma list_product_assoc[simp]:
  "A \<otimes>\<^sub>l (B \<otimes>\<^sub>l C) = A \<otimes>\<^sub>l B \<otimes>\<^sub>l C"
  unfolding set_eq_iff list_product_iff by fastforce

text \<open>Furthermore, we introduct DNFs where the clauses are represented as lists.\<close>

fun list_dnf :: "'a ltln \<Rightarrow> 'a ltln list set"
where
  "list_dnf true\<^sub>n = {[]}"
| "list_dnf false\<^sub>n = {}"
| "list_dnf (\<phi> and\<^sub>n \<psi>) = (list_dnf \<phi>) \<otimes>\<^sub>l (list_dnf \<psi>)"
| "list_dnf (\<phi> or\<^sub>n \<psi>) = (list_dnf \<phi>) \<union> (list_dnf \<psi>)"
| "list_dnf \<phi> = {[\<phi>]}"

definition list_dnf_to_dnf :: "'a list set \<Rightarrow> 'a fset set"
where
  "list_dnf_to_dnf X = fset_of_list ` X"

lemma list_dnf_to_dnf_list_dnf[simp]:
  "list_dnf_to_dnf (list_dnf \<phi>) = dnf \<phi>"
  apply2 (induction \<phi>) by (simp_all add: list_dnf_to_dnf_def image_Un)

lemma list_dnf_finite:
  "finite (list_dnf \<phi>)"
  apply2 (induction \<phi>) by (simp_all add: list_product_finite)

text \<open>We use this to redefine @{const subst_clause} and @{const subst_dnf} on list DNFs.\<close>

definition subst_clause' :: "'a ltln list \<Rightarrow> ('a ltln \<rightharpoonup> 'a ltln) \<Rightarrow> 'a ltln list set"
where
  "subst_clause' \<Phi> m = fold (\<lambda>\<phi> acc. acc \<otimes>\<^sub>l list_dnf (subst \<phi> m)) \<Phi> {[]}"

definition subst_dnf' :: "'a ltln list set \<Rightarrow> ('a ltln \<rightharpoonup> 'a ltln) \<Rightarrow> 'a ltln list set"
where
  "subst_dnf' \<A> m = (\<Union>\<Phi> \<in> \<A>. subst_clause' \<Phi> m)"

lemma subst_clause'_finite:
  "finite (subst_clause' \<Phi> m)"
  apply2 (induction \<Phi> rule: rev_induct) by (simp_all add: subst_clause'_def list_dnf_finite list_product_finite)

lemma subst_clause'_nil[simp]:
  "subst_clause' [] m = {[]}"
  by (simp add: subst_clause'_def)

lemma subst_clause'_cons[simp]:
  "subst_clause' (xs @ [x]) m = subst_clause' xs m \<otimes>\<^sub>l list_dnf (subst x m)"
  by (simp add: subst_clause'_def)

lemma subst_clause'_append[simp]:
  "subst_clause' (A @ B) m = subst_clause' A m \<otimes>\<^sub>l subst_clause' B m"
proof2 (induction B rule: rev_induct)
  case (snoc x xs)
  then show ?case
    by simp (metis append_assoc subst_clause'_cons)
qed(simp add: list_product_def)

lemma subst_dnf'_iff:
  "x \<in> subst_dnf' A m \<longleftrightarrow> (\<exists>\<Phi> \<in> A. x \<in> subst_clause' \<Phi> m)"
  by (simp add: subst_dnf'_def)

lemma subst_dnf'_product:
  "subst_dnf' (A \<otimes>\<^sub>l B) m = (subst_dnf' A m) \<otimes>\<^sub>l (subst_dnf' B m)" (is "?lhs = ?rhs")
proof (unfold set_eq_iff, safe)
  fix x
  assume "x \<in> ?lhs"

  then obtain \<Phi> where "\<Phi> \<in> A \<otimes>\<^sub>l B" and "x \<in> subst_clause' \<Phi> m"
    unfolding subst_dnf'_iff by blast

  then obtain a b where "a \<in> A" and "b \<in> B" and "\<Phi> = a @ b"
    unfolding list_product_def by blast

  then have "x \<in> (subst_clause' a m) \<otimes>\<^sub>l (subst_clause' b m)"
    using \<open>x \<in> subst_clause' \<Phi> m\<close> by simp

  then obtain a' b' where "a' \<in> subst_clause' a m" and "b' \<in> subst_clause' b m" and "x = a' @ b'"
    unfolding list_product_iff by blast

  then have "a' \<in> subst_dnf' A m" and "b' \<in> subst_dnf' B m"
    unfolding subst_dnf'_iff using \<open>a \<in> A\<close> \<open>b \<in> B\<close> by auto

  then have "\<exists>a\<in>subst_dnf' A m. \<exists>b\<in>subst_dnf' B m. x = a @ b"
    using \<open>x = a' @ b'\<close> by blast

  then show "x \<in> ?rhs"
    unfolding list_product_iff by blast
next
  fix x
  assume "x \<in> ?rhs"

  then obtain a b where "a \<in> subst_dnf' A m" and "b \<in> subst_dnf' B m" and "x = a @ b"
    unfolding list_product_iff by blast

  then obtain a' b' where "a' \<in> A" and "b' \<in> B" and a: "a \<in> subst_clause' a' m" and b: "b \<in> subst_clause' b' m"
    unfolding subst_dnf'_iff by blast

  then have "x \<in> (subst_clause' a' m) \<otimes>\<^sub>l (subst_clause' b' m)"
    unfolding list_product_iff using \<open>x = a @ b\<close> by blast

  moreover

  have "a' @ b' \<in> A \<otimes>\<^sub>l B"
    unfolding list_product_iff using \<open>a' \<in> A\<close> \<open>b' \<in> B\<close> by blast

  ultimately show "x \<in> ?lhs"
    unfolding subst_dnf'_iff by force
qed

lemma subst_dnf'_list_dnf:
  "subst_dnf' (list_dnf \<phi>) m = list_dnf (subst \<phi> m)"
proof2 (induction \<phi>)
  case (And_ltln \<phi>1 \<phi>2)
  then show ?case
    by (simp add: subst_dnf'_product)
qed (simp_all add: subst_dnf'_def subst_clause'_def list_product_def)

lemma min_set_Union:
  "finite X \<Longrightarrow> min_set (\<Union> (min_set ` X)) = min_set (\<Union> X)" for X :: "'a fset set set"
  apply2 (induction X rule: finite_induct) by (force, metis Sup_insert image_insert min_set_min_union min_union_def)

lemma min_set_Union_image:
  "finite X \<Longrightarrow> min_set (\<Union>x \<in> X. min_set (f x)) = min_set (\<Union>x \<in> X. f x)" for f :: "'b \<Rightarrow> 'a fset set"
proof -
  assume "finite X"

  then have *: "finite (f ` X)" by auto

  with min_set_Union show ?thesis
    unfolding image_image by fastforce
qed

lemma subst_clause_fset_of_list:
  "subst_clause (fset_of_list \<Phi>) m = min_set (list_dnf_to_dnf (subst_clause' \<Phi> m))"
  unfolding list_dnf_to_dnf_def subst_clause'_def
proof2 (induction \<Phi> rule: rev_induct)
  case (snoc x xs)
  then show ?case
    by simp (metis (no_types, lifting) dnf_min_set list_dnf_to_dnf_def list_dnf_to_dnf_list_dnf min_product_comm min_product_def min_set_min_product(1))
qed simp

lemma min_set_list_dnf_to_dnf_subst_dnf':
  "finite X \<Longrightarrow> min_set (list_dnf_to_dnf (subst_dnf' X m)) = min_set (subst_dnf (list_dnf_to_dnf X) m)"
  by (simp add: subst_dnf'_def subst_dnf_def subst_clause_fset_of_list list_dnf_to_dnf_def min_set_Union_image image_Union)

lemma subst_dnf_dnf:
  "min_set (subst_dnf (dnf \<phi>) m) = min_dnf (subst \<phi> m)"
  unfolding dnf_min_set
  unfolding list_dnf_to_dnf_list_dnf[symmetric]
  unfolding subst_dnf'_list_dnf[symmetric]
  unfolding min_set_list_dnf_to_dnf_subst_dnf'[OF list_dnf_finite]
  by simp

text \<open>This is almost the lemma we need. However, we need to show that the same holds for @{term "min_dnf \<phi>"}, too.\<close>

lemma fold_product:
  "Finite_Set.fold (\<lambda>x. (\<otimes>) {{|x|}}) {{||}} (fset x) = {x}"
  apply2 (induction x) by (simp_all add: notin_fset, simp add: product_singleton_singleton)

lemma fold_union:
  "Finite_Set.fold (\<lambda>x. (\<union>) {x}) {} (fset x) = fset x"
  apply2 (induction x) by (simp_all add: notin_fset comp_fun_idem.fold_insert_idem comp_fun_idem_insert)

lemma fold_union_fold_product:
  assumes "finite X" and "\<And>\<Psi> \<psi>. \<Psi> \<in> X \<Longrightarrow> \<psi> \<in> fset \<Psi> \<Longrightarrow> dnf \<psi> = {{|\<psi>|}}"
  shows "Finite_Set.fold (\<lambda>x. (\<union>) (Finite_Set.fold (\<lambda>\<phi>. (\<otimes>) (dnf \<phi>)) {{||}} (fset x))) {} X = X" (is "?lhs = X")
proof -
  from assms have "?lhs = Finite_Set.fold (\<lambda>x. (\<union>) (Finite_Set.fold (\<lambda>\<phi>. (\<otimes>) {{|\<phi>|}}) {{||}} (fset x))) {} X"
  proof2 (induction X rule: finite_induct)
    case (insert \<Phi> X)

    from insert.prems have 1: "\<And>\<Psi> \<psi>. \<lbrakk>\<Psi> \<in> X; \<psi> \<in> fset \<Psi>\<rbrakk> \<Longrightarrow> dnf \<psi> = {{|\<psi>|}}"
      by force

    from insert.prems have "Finite_Set.fold (\<lambda>\<phi>. (\<otimes>) (dnf \<phi>)) {{||}} (fset \<Phi>) = Finite_Set.fold (\<lambda>\<phi>. (\<otimes>) {{|\<phi>|}}) {{||}} (fset \<Phi>)"
      apply2 (induction \<Phi>) by (force simp: notin_fset)+

    with insert 1 show ?case
      by simp
  qed simp

  with \<open>finite X\<close> show ?thesis
    unfolding fold_product by (metis fset_to_fset fold_union)
qed

lemma dnf_ltln_of_dnf_min_dnf:
  "dnf (ltln_of_dnf (min_dnf \<phi>)) = min_dnf \<phi>"
proof -
  have 1: "finite (And\<^sub>n ` fset ` min_dnf \<phi>)"
    using min_dnf_finite by blast

  have 2: "inj_on And\<^sub>n (fset ` min_dnf \<phi>)"
    by (metis (mono_tags, lifting) And\<^sub>n_inj f_inv_into_f fset inj_onI inj_on_contraD)

  have 3: "inj_on fset (min_dnf \<phi>)"
    by (meson fset_inject inj_onI)

  show ?thesis
    unfolding ltln_of_dnf_def
    unfolding Or\<^sub>n_dnf[OF 1]
    unfolding fold_image[OF 2]
    unfolding fold_image[OF 3]
    unfolding comp_def
    unfolding And\<^sub>n_dnf[OF finite_fset]
    by (metis fold_union_fold_product min_dnf_finite min_dnf_atoms_dnf)
qed

lemma min_dnf_subst:
  "min_set (subst_dnf (min_dnf \<phi>) m) = min_dnf (subst \<phi> m)" (is "?lhs = ?rhs")
proof -
  let ?\<phi>' = "ltln_of_dnf (min_dnf \<phi>)"

  have "?lhs = min_set (subst_dnf (dnf ?\<phi>') m)"
    unfolding dnf_ltln_of_dnf_min_dnf ..

  also have "\<dots> = min_dnf (subst ?\<phi>' m)"
    unfolding subst_dnf_dnf ..

  also have "\<dots> = min_dnf (subst \<phi> m)"
    using ltl_prop_equiv_min_dnf ltln_of_dnf_prop_equiv subst_respects_ltl_prop_entailment(2) by blast

  finally show ?thesis .
qed

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Complex Roots of Real Valued Polynomials\<close>

text \<open>We provide conversion functions between polynomials over the real and the complex numbers,
  and prove that the complex roots of real-valued polynomial always come in conjugate pairs.
  We further show that also the order of the complex conjugate roots is identical.

  As a consequence, we derive that every real-valued polynomial can be factored into real factors of
  degree at most 2, and we prove that every polynomial over the reals with odd degree has a real
  root.\<close>

theory Complex_Roots_Real_Poly
imports
  "HOL-Computational_Algebra.Fundamental_Theorem_Algebra"
  Polynomial_Factorization.Order_Polynomial
  Polynomial_Factorization.Explicit_Roots
  Polynomial_Interpolation.Ring_Hom_Poly
begin

interpretation of_real_poly_hom: map_poly_idom_hom complex_of_real..

lemma real_poly_real_coeff: assumes "set (coeffs p) \<subseteq> \<real>"
  shows "coeff p x \<in> \<real>"
proof -
  have "coeff p x \<in> range (coeff p)" by auto
  from this[unfolded range_coeff] assms show ?thesis by auto
qed

lemma complex_conjugate_root:
  assumes real: "set (coeffs p) \<subseteq> \<real>" and rt: "poly p c = 0"
  shows "poly p (cnj c) = 0"
proof -
  let ?c = "cnj c"
  {
    fix x
    have "coeff p x \<in> \<real>"
      by (rule real_poly_real_coeff[OF real])
    hence "cnj (coeff p x) = coeff p x" by (cases "coeff p x", auto)
  } note cnj_coeff = this
  have "poly p ?c = poly (\<Sum>x\<le>degree p. monom (coeff p x) x) ?c"
    unfolding poly_as_sum_of_monoms ..
  also have "\<dots> = (\<Sum>x\<le>degree p . coeff p x * cnj (c ^ x))"
    unfolding poly_sum poly_monom complex_cnj_power ..
  also have "\<dots> = (\<Sum>x\<le>degree p . cnj (coeff p x * c ^ x))"
    unfolding complex_cnj_mult cnj_coeff ..
  also have "\<dots> = cnj (\<Sum>x\<le>degree p . coeff p x * c ^ x)"
    unfolding cnj_sum ..
  also have "(\<Sum>x\<le>degree p . coeff p x * c ^ x) =
    poly (\<Sum>x\<le>degree p. monom (coeff p x) x) c"
    unfolding poly_sum poly_monom ..
  also have "\<dots> = 0" unfolding poly_as_sum_of_monoms rt ..
  also have "cnj 0 = 0" by simp
  finally show ?thesis .
qed

context
  fixes p :: "complex poly"
  assumes coeffs: "set (coeffs p) \<subseteq> \<real>"
begin
lemma map_poly_Re_poly: fixes x :: real
  shows "poly (map_poly Re p) x = poly p (of_real x)"
proof -
  have id: "map_poly (of_real o Re) p = p"
    by (rule map_poly_idI, insert coeffs, auto)
  show ?thesis unfolding arg_cong[OF id, of poly, symmetric]
    by (subst map_poly_map_poly[symmetric], auto)
qed

lemma map_poly_Re_coeffs:
  "coeffs (map_poly Re p) = map Re (coeffs p)"
proof (rule coeffs_map_poly)
  have "lead_coeff p \<in> range (coeff p)" by auto
  hence x: "lead_coeff p \<in> \<real>" using coeffs by (auto simp: range_coeff)
  show "(Re (lead_coeff p) = 0) = (p = 0)"
    using of_real_Re[OF x] by auto
qed

lemma map_poly_Re_0: "map_poly Re p = 0 \<Longrightarrow> p = 0"
  using map_poly_Re_coeffs by auto

end

lemma real_poly_add:
  assumes "set (coeffs p) \<subseteq> \<real>" "set (coeffs q) \<subseteq> \<real>"
  shows "set (coeffs (p + q)) \<subseteq> \<real>"
proof -
  define pp where "pp = coeffs p"
  define qq where "qq = coeffs q"
  show ?thesis using assms
  unfolding coeffs_plus_eq_plus_coeffs pp_def[symmetric] qq_def[symmetric]
    by (induct pp qq rule: plus_coeffs.induct, auto simp: cCons_def)
qed

lemma real_poly_sum:
  assumes "\<And> x. x \<in> S \<Longrightarrow> set (coeffs (f x)) \<subseteq> \<real>"
  shows "set (coeffs (sum f S)) \<subseteq> \<real>"
  using assms
proof (induct S rule: infinite_finite_induct)
  case (insert x S)
  hence id: "sum f (insert x S) = f x + sum f S" by auto
  show ?case unfolding id
    by (rule real_poly_add[OF _ insert(3)], insert insert, auto)
qed auto

lemma real_poly_smult: fixes p :: "'a :: {idom,real_algebra_1} poly"
  assumes "c \<in> \<real>" "set (coeffs p) \<subseteq> \<real>"
  shows "set (coeffs (smult c p)) \<subseteq> \<real>"
  using assms by (auto simp: coeffs_smult)

lemma real_poly_pCons:
  assumes "c \<in> \<real>" "set (coeffs p) \<subseteq> \<real>"
  shows "set (coeffs (pCons c p)) \<subseteq> \<real>"
  using assms by (auto simp: cCons_def)

lemma real_poly_mult: fixes p :: "'a :: {idom,real_algebra_1} poly"
  assumes p: "set (coeffs p) \<subseteq> \<real>" and q: "set (coeffs q) \<subseteq> \<real>"
  shows "set (coeffs (p * q)) \<subseteq> \<real>" using p
proof (induct p)
  case (pCons a p)
  show ?case unfolding mult_pCons_left
    by (intro real_poly_add real_poly_smult real_poly_pCons pCons(2) q,
    insert pCons(1,3), auto simp: cCons_def if_splits)
qed simp

lemma real_poly_power: fixes p :: "'a :: {idom,real_algebra_1} poly"
  assumes p: "set (coeffs p) \<subseteq> \<real>"
  shows "set (coeffs (p ^ n)) \<subseteq> \<real>"
proof (induct n)
  case (Suc n)
  from real_poly_mult[OF p this]
  show ?case by simp
qed simp

lemma real_poly_prod: fixes f :: "'a \<Rightarrow> 'b :: {idom,real_algebra_1} poly"
  assumes "\<And> x. x \<in> S \<Longrightarrow> set (coeffs (f x)) \<subseteq> \<real>"
  shows "set (coeffs (prod f S)) \<subseteq> \<real>"
  using assms
proof (induct S rule: infinite_finite_induct)
  case (insert x S)
  hence id: "prod f (insert x S) = f x * prod f S" by auto
  show ?case unfolding id
    by (rule real_poly_mult[OF _ insert(3)], insert insert, auto)
qed auto

lemma real_poly_uminus:
  assumes "set (coeffs p) \<subseteq> \<real>"
  shows "set (coeffs (-p)) \<subseteq> \<real>"
  using assms unfolding coeffs_uminus by auto

lemma real_poly_minus:
  assumes "set (coeffs p) \<subseteq> \<real>" "set (coeffs q) \<subseteq> \<real>"
  shows "set (coeffs (p - q)) \<subseteq> \<real>"
  using assms unfolding diff_conv_add_uminus
  by (intro real_poly_uminus real_poly_add, auto)

lemma fixes p :: "'a :: real_field poly"
  assumes p: "set (coeffs p) \<subseteq> \<real>" and *: "set (coeffs q) \<subseteq> \<real>"
  shows real_poly_div: "set (coeffs (q div p)) \<subseteq> \<real>"
    and real_poly_mod: "set (coeffs (q mod p)) \<subseteq> \<real>"
proof (atomize(full), insert *, induct q)
  case 0
  thus ?case by auto
next
  case (pCons a q)
  from pCons(1,3) have a: "a \<in> \<real>" and q: "set (coeffs q) \<subseteq> \<real>" by auto
  note res = pCons
  show ?case
  proof (cases "p = 0")
    case True
    with res pCons(3) show ?thesis by auto
  next
    case False
    from pCons have IH: "set (coeffs (q div p)) \<subseteq> \<real>" "set (coeffs (q mod p)) \<subseteq> \<real>" by auto
    define c where "c = coeff (pCons a (q mod p)) (degree p) / coeff p (degree p)"
    {
      have "coeff (pCons a (q mod p)) (degree p) \<in> \<real>"
        by (rule real_poly_real_coeff, insert IH a, intro real_poly_pCons)
      moreover have "coeff p (degree p) \<in> \<real>"
        by (rule real_poly_real_coeff[OF p])
      ultimately have "c \<in> \<real>" unfolding c_def by simp
    } note c = this
    from False
    have r: "pCons a q div p = pCons c (q div p)" and s: "pCons a q mod p = pCons a (q mod p) - smult c p"
      unfolding c_def div_pCons_eq mod_pCons_eq by simp_all
    show ?thesis unfolding r s using a p c IH by (intro conjI real_poly_pCons real_poly_minus real_poly_smult)
  qed
qed

lemma real_poly_factor: fixes p :: "'a :: real_field poly"
  assumes "set (coeffs (p * q)) \<subseteq> \<real>"
   "set (coeffs p) \<subseteq> \<real>"
  "p \<noteq> 0"
  shows "set (coeffs q) \<subseteq> \<real>"
proof -
  have "q = p * q div p" using \<open>p \<noteq> 0\<close> by simp
  hence id: "coeffs q = coeffs (p * q div p)" by simp
  show ?thesis unfolding id
    by (rule real_poly_div, insert assms, auto)
qed

lemma complex_conjugate_order: assumes real: "set (coeffs p) \<subseteq> \<real>"
  "p \<noteq> 0"
  shows "order (cnj c) p = order c p"
proof -
  define n where "n = degree p"
  have "degree p \<le> n" unfolding n_def by auto
  thus ?thesis using assms
  proof (induct n arbitrary: p)
    case (0 p)
    {
      fix x
      have "order x p \<le> degree p"
        by (rule order_degree[OF 0(3)])
      hence "order x p = 0" using 0 by auto
    }
    thus ?case by simp
  next
    case (Suc m p)
    note order = order[OF \<open>p \<noteq> 0\<close>]
    let ?c = "cnj c"
    show ?case
    proof (cases "poly p c = 0")
      case True note rt1 = this
      from complex_conjugate_root[OF Suc(3) True]
      have rt2: "poly p ?c = 0" .
      show ?thesis
      proof (cases "c \<in> \<real>")
        case True
        hence "?c = c" by (cases c, auto)
        thus ?thesis by auto
      next
        case False
        hence neq: "?c \<noteq> c" by (simp add: Reals_cnj_iff)
        let ?fac1 = "[: -c, 1 :]"
        let ?fac2 = "[: -?c, 1 :]"
        let ?fac = "?fac1 * ?fac2"
        from rt1 have "?fac1 dvd p" unfolding poly_eq_0_iff_dvd .
        from this[unfolded dvd_def] obtain q where p: "p = ?fac1 * q" by auto
        from rt2[unfolded p poly_mult] neq have "poly q ?c = 0" by auto
        hence "?fac2 dvd q" unfolding poly_eq_0_iff_dvd .
        from this[unfolded dvd_def] obtain r where q: "q = ?fac2 * r" by auto
        have p: "p = ?fac * r" unfolding p q by algebra
        from \<open>p \<noteq> 0\<close> have nz: "?fac1 \<noteq> 0" "?fac2 \<noteq> 0" "?fac \<noteq> 0" "r \<noteq> 0" unfolding p by auto
        have id: "?fac = [: ?c * c, - (?c + c), 1 :]" by simp
        have cfac: "coeffs ?fac = [ ?c * c, - (?c + c), 1 ]" unfolding id by simp
        have cfac: "set (coeffs ?fac) \<subseteq> \<real>" unfolding cfac by (cases c, auto simp: Reals_cnj_iff)
        have "degree p = degree ?fac + degree r" unfolding p
          by (rule degree_mult_eq, insert nz, auto)
        also have "degree ?fac = degree ?fac1 + degree ?fac2"
          by (rule degree_mult_eq, insert nz, auto)
        finally have "degree p = 2 + degree r" by simp
        with Suc have deg: "degree r \<le> m" by auto
        from real_poly_factor[OF Suc(3)[unfolded p] cfac] nz  have "set (coeffs r) \<subseteq> \<real>" by auto
        from Suc(1)[OF deg this \<open>r \<noteq> 0\<close>] have IH: "order ?c r = order c r" .
        {
          fix cc
          have "order cc p = order cc ?fac + order cc r" using \<open>p \<noteq> 0\<close> unfolding p
            by (rule order_mult)
          also have "order cc ?fac = order cc ?fac1 + order cc ?fac2"
            by (rule order_mult, rule nz)
          also have "order cc ?fac1 = (if cc = c then 1 else 0)"
            unfolding order_linear' by simp
          also have "order cc ?fac2 = (if cc = ?c then 1 else 0)"
            unfolding order_linear' by simp
          finally have "order cc p =
            (if cc = c then 1 else 0) + (if cc = cnj c then 1 else 0) + order cc r" .
        } note order = this
        show ?thesis unfolding order IH by auto
      qed
    next
      case False note rt1 = this
      {
        assume "poly p ?c = 0"
        from complex_conjugate_root[OF Suc(3) this] rt1
        have False by auto
      }
      hence rt2: "poly p ?c \<noteq> 0" by auto
      from rt1 rt2 show ?thesis
        unfolding order_root by simp
    qed
  qed
qed

lemma map_poly_of_real_Re: assumes "set (coeffs p) \<subseteq> \<real>"
  shows "map_poly of_real (map_poly Re p) = p"
  by (subst map_poly_map_poly, force+, rule map_poly_idI, insert assms, auto)

lemma map_poly_Re_of_real: "map_poly Re (map_poly of_real p) = p"
  by (subst map_poly_map_poly, force+, rule map_poly_idI, auto)

lemma map_poly_Re_mult: assumes p: "set (coeffs p) \<subseteq> \<real>"
  and q: "set (coeffs q) \<subseteq> \<real>" shows "map_poly Re (p * q) = map_poly Re p * map_poly Re q"
proof -
  let ?r = "map_poly Re"
  let ?c = "map_poly complex_of_real"
  have "?r (p * q) = ?r (?c (?r p) * ?c (?r q))"
    unfolding map_poly_of_real_Re[OF p] map_poly_of_real_Re[OF q] by simp
  also have "?c (?r p) * ?c (?r q) = ?c (?r p * ?r q)" by (simp add: hom_distribs)
  also have "?r \<dots> = ?r p * ?r q" unfolding map_poly_Re_of_real ..
  finally show ?thesis .
qed

lemma map_poly_Re_power: assumes p: "set (coeffs p) \<subseteq> \<real>"
 shows "map_poly Re (p^n) = (map_poly Re p)^n"
proof (induct n)
  case (Suc n)
  let ?r = "map_poly Re"
  have "?r (p^Suc n) = ?r (p * p^n)" by simp
  also have "\<dots> = ?r p * ?r (p^n)"
    by (rule map_poly_Re_mult[OF p real_poly_power[OF p]])
  also have "?r (p^n) = (?r p)^n" by (rule Suc)
  finally show ?case by simp
qed simp

lemma real_degree_2_factorization_exists_complex: fixes p :: "complex poly"
  assumes pR: "set (coeffs p) \<subseteq> \<real>"
  shows "\<exists> qs. p = prod_list qs \<and> (\<forall> q \<in> set qs. set (coeffs q) \<subseteq> \<real> \<and> degree q \<le> 2)"
proof -
  obtain n where "degree p = n" by auto
  thus ?thesis using pR
  proof (induct n arbitrary: p rule: less_induct)
    case (less n p)
    hence pR: "set (coeffs p) \<subseteq> \<real>" by auto
    show ?case
    proof (cases "n \<le> 2")
      case True
      thus ?thesis using pR
        by (intro exI[of _ "[p]"], insert less(2), auto)
    next
      case False
      hence degp: "degree p \<ge> 2" using less(2) by auto
      hence "\<not> constant (poly p)" by (simp add: constant_degree)
      from fundamental_theorem_of_algebra[OF this] obtain x where x: "poly p x = 0" by auto
      from x have dvd: "[: -x, 1 :] dvd p" using poly_eq_0_iff_dvd by blast
      have "\<exists> f. f dvd p \<and> set (coeffs f) \<subseteq> \<real> \<and> 1 \<le> degree f \<and> degree f \<le> 2"
      proof (cases "x \<in> \<real>")
        case True
        with dvd show ?thesis
          by (intro exI[of _ "[: -x, 1:]"], auto)
      next
        case False
        let ?x = "cnj x"
        let ?a = "?x * x"
        let ?b = "- ?x - x"
        from complex_conjugate_root[OF pR x]
        have xx: "poly p ?x = 0" by auto
        from False have diff: "x \<noteq> ?x" by (simp add: Reals_cnj_iff)
        from dvd obtain r where p: "p = [: -x, 1 :] * r" unfolding dvd_def by auto
        from xx[unfolded this] diff have "poly r ?x = 0" by simp
        hence "[: -?x, 1 :] dvd r" using poly_eq_0_iff_dvd by blast
        then obtain s where r: "r = [: -?x, 1 :] * s" unfolding dvd_def by auto
        have "p = ([: -x, 1:] * [: -?x, 1 :]) * s" unfolding p r by algebra
        also have "[: -x, 1:] * [: -?x, 1 :] = [: ?a, ?b, 1 :]" by simp
        finally have "[: ?a, ?b, 1 :] dvd p" unfolding dvd_def by auto
        moreover have "?a \<in> \<real>" by (simp add: Reals_cnj_iff)
        moreover have "?b \<in> \<real>" by (simp add: Reals_cnj_iff)
        ultimately show ?thesis by (intro exI[of _ "[:?a,?b,1:]"], auto)
      qed
      then obtain f where dvd: "f dvd p" and fR: "set (coeffs f) \<subseteq> \<real>" and degf: "1 \<le> degree f" "degree f \<le> 2" by auto
      from dvd obtain r where p: "p = f * r" unfolding dvd_def by auto
      from degp have p0: "p \<noteq> 0" by auto
      with p have f0: "f \<noteq> 0" and r0: "r \<noteq> 0" by auto
      from real_poly_factor[OF pR[unfolded p] fR f0] have rR: "set (coeffs r) \<subseteq> \<real>" .
      have deg: "degree p = degree f + degree r" unfolding p
        by (rule degree_mult_eq[OF f0 r0])
      with degf less(2) have degr: "degree r < n" by auto
      from less(1)[OF this refl rR] obtain qs
        where IH: "r = prod_list qs" "(\<forall>q\<in>set qs. set (coeffs q) \<subseteq> \<real> \<and> degree q \<le> 2)" by auto
      from IH(1) have p: "p = prod_list (f # qs)" unfolding p by auto
      with IH(2) fR degf show ?thesis
        by (intro exI[of _ "f # qs"], auto)
    qed
  qed
qed

lemma real_degree_2_factorization_exists: fixes p :: "real poly"
  shows "\<exists> qs. p = prod_list qs \<and> (\<forall> q \<in> set qs. degree q \<le> 2)"
proof -
  let ?cp = "map_poly complex_of_real"
  let ?rp = "map_poly Re"
  let ?p = "?cp p"
  have "set (coeffs ?p) \<subseteq> \<real>" by auto
  from real_degree_2_factorization_exists_complex[OF this]
  obtain qs where p: "?p = prod_list qs" and
    qs: "\<And> q. q \<in> set qs \<Longrightarrow> set (coeffs q) \<subseteq> \<real> \<and> degree q \<le> 2" by auto
  have p: "p = ?rp (prod_list qs)" unfolding arg_cong[OF p, of ?rp, symmetric]
    by (subst map_poly_map_poly, force, rule sym, rule map_poly_idI, auto)
  from qs have "\<exists> rs. prod_list qs = ?cp (prod_list rs) \<and> (\<forall> r \<in> set rs. degree r \<le> 2)"
  proof (induct qs)
    case Nil
    show ?case by (auto intro!: exI[of _ Nil])
  next
    case (Cons q qs)
    then obtain rs where qs: "prod_list qs = ?cp (prod_list rs)"
      and rs: "\<And> q. q\<in>set rs \<Longrightarrow> degree q \<le> 2" by force+
    from Cons(2)[of q] have q: "set (coeffs q) \<subseteq> \<real>" and dq: "degree q \<le> 2" by auto
    define r where "r = ?rp q"
    have q: "q = ?cp r" unfolding r_def
      by (subst map_poly_map_poly, force, rule sym, rule map_poly_idI, insert q, auto)
    have dr: "degree r \<le> 2" using dq unfolding q by (simp add: degree_map_poly)
    show ?case
      by (rule exI[of _ "r # rs"], unfold prod_list.Cons qs q, insert dr rs, auto simp: hom_distribs)
  qed
  then obtain rs where id: "prod_list qs = ?cp (prod_list rs)" and deg: "\<forall> r \<in> set rs. degree r \<le> 2" by auto
  show ?thesis unfolding p id
    by (intro exI, rule conjI[OF _ deg], subst map_poly_map_poly, force, rule map_poly_idI, auto)
qed

lemma odd_degree_imp_real_root: assumes "odd (degree p)"
  shows "\<exists> x. poly p x = (0 :: real)"
proof -
  from real_degree_2_factorization_exists[of p] obtain qs where
    id: "p = prod_list qs" and qs: "\<And> q. q \<in> set qs \<Longrightarrow> degree q \<le> 2" by auto
  show ?thesis using assms qs unfolding id
  proof (induct qs)
    case (Cons q qs)
    from Cons(3)[of q] have dq: "degree q \<le> 2" by auto
    show ?case
    proof (cases "degree q = 1")
      case True
      from roots1[OF this] show ?thesis by auto
    next
      case False
      with dq have deg: "degree q = 0 \<or> degree q = 2" by arith
      from Cons(2) have "q * prod_list qs \<noteq> 0" by fastforce
      hence "q \<noteq> 0" "prod_list qs \<noteq> 0" by auto
      from degree_mult_eq[OF this]
      have "degree (prod_list (q # qs)) = degree q + degree (prod_list qs)" by simp
      from Cons(2)[unfolded this] deg have "odd (degree (prod_list qs))" by auto
      from Cons(1)[OF this Cons(3)] obtain x where "poly (prod_list qs) x = 0" by auto
      thus ?thesis by auto
    qed
  qed simp
qed

end


(* Author: Tobias Nipkow *)

section \<open>Leftist Heap\<close>

theory Leftist_Heap
imports
  "HOL-Library.Pattern_Aliases"
  Tree2
  Priority_Queue_Specs
  Complex_Main
begin

fun mset_tree :: "('a*'b) tree \<Rightarrow> 'a multiset" where
"mset_tree Leaf = {#}" |
"mset_tree (Node l (a, _) r) = {#a#} + mset_tree l + mset_tree r"

type_synonym 'a lheap = "('a*nat)tree"

fun mht :: "'a lheap \<Rightarrow> nat" where
"mht Leaf = 0" |
"mht (Node _ (_, n) _) = n"

text\<open>The invariants:\<close>

fun (in linorder) heap :: "('a*'b) tree \<Rightarrow> bool" where
"heap Leaf = True" |
"heap (Node l (m, _) r) =
  ((\<forall>x \<in> set_tree l \<union> set_tree r. m \<le> x) \<and> heap l \<and> heap r)"

fun ltree :: "'a lheap \<Rightarrow> bool" where
"ltree Leaf = True" |
"ltree (Node l (a, n) r) =
 (min_height l \<ge> min_height r \<and> n = min_height r + 1 \<and> ltree l & ltree r)"

definition empty :: "'a lheap" where
"empty = Leaf"

definition node :: "'a lheap \<Rightarrow> 'a \<Rightarrow> 'a lheap \<Rightarrow> 'a lheap" where
"node l a r =
 (let mhl = mht l; mhr = mht r
  in if mhl \<ge> mhr then Node l (a,mhr+1) r else Node r (a,mhl+1) l)"

fun get_min :: "'a lheap \<Rightarrow> 'a" where
"get_min(Node l (a, n) r) = a"

text \<open>For function \<open>merge\<close>:\<close>
unbundle pattern_aliases

fun merge :: "'a::ord lheap \<Rightarrow> 'a lheap \<Rightarrow> 'a lheap" where
"merge Leaf t = t" |
"merge t Leaf = t" |
"merge (Node l1 (a1, n1) r1 =: t1) (Node l2 (a2, n2) r2 =: t2) =
   (if a1 \<le> a2 then node l1 a1 (merge r1 t2)
    else node l2 a2 (merge t1 r2))"

text \<open>Termination of @{const merge}: by sum or lexicographic product of the sizes
of the two arguments. Isabelle uses a lexicographic product.\<close>

lemma merge_code: "merge t1 t2 = (case (t1,t2) of
  (Leaf, _) \<Rightarrow> t2 |
  (_, Leaf) \<Rightarrow> t1 |
  (Node l1 (a1, n1) r1, Node l2 (a2, n2) r2) \<Rightarrow>
    if a1 \<le> a2 then node l1 a1 (merge r1 t2) else node l2 a2 (merge t1 r2))"
by(induction t1 t2 rule: merge.induct) (simp_all split: tree.split)

hide_const (open) insert

definition insert :: "'a::ord \<Rightarrow> 'a lheap \<Rightarrow> 'a lheap" where
"insert x t = merge (Node Leaf (x,1) Leaf) t"

fun del_min :: "'a::ord lheap \<Rightarrow> 'a lheap" where
"del_min Leaf = Leaf" |
"del_min (Node l _ r) = merge l r"

subsection "Lemmas"

lemma mset_tree_empty: "mset_tree t = {#} \<longleftrightarrow> t = Leaf"
by(cases t) auto

lemma mht_eq_min_height: "ltree t \<Longrightarrow> mht t = min_height t"
by(cases t) auto

lemma ltree_node: "ltree (node l a r) \<longleftrightarrow> ltree l \<and> ltree r"
by(auto simp add: node_def mht_eq_min_height)

lemma heap_node: "heap (node l a r) \<longleftrightarrow>
  heap l \<and> heap r \<and> (\<forall>x \<in> set_tree l \<union> set_tree r. a \<le> x)"
by(auto simp add: node_def)

lemma set_tree_mset: "set_tree t = set_mset(mset_tree t)"
by(induction t) auto

subsection "Functional Correctness"

lemma mset_merge: "mset_tree (merge t1 t2) = mset_tree t1 + mset_tree t2"
by (induction t1 t2 rule: merge.induct) (auto simp add: node_def ac_simps)

lemma mset_insert: "mset_tree (insert x t) = mset_tree t + {#x#}"
by (auto simp add: insert_def mset_merge)

lemma get_min: "\<lbrakk> heap t;  t \<noteq> Leaf \<rbrakk> \<Longrightarrow> get_min t = Min(set_tree t)"
by (cases t) (auto simp add: eq_Min_iff)

lemma mset_del_min: "mset_tree (del_min t) = mset_tree t - {# get_min t #}"
by (cases t) (auto simp: mset_merge)

lemma ltree_merge: "\<lbrakk> ltree l; ltree r \<rbrakk> \<Longrightarrow> ltree (merge l r)"
by(induction l r rule: merge.induct)(auto simp: ltree_node)

lemma heap_merge: "\<lbrakk> heap l; heap r \<rbrakk> \<Longrightarrow> heap (merge l r)"
proof(induction l r rule: merge.induct)
  case 3 thus ?case by(auto simp: heap_node mset_merge ball_Un set_tree_mset)
qed simp_all

lemma ltree_insert: "ltree t \<Longrightarrow> ltree(insert x t)"
by(simp add: insert_def ltree_merge del: merge.simps split: tree.split)

lemma heap_insert: "heap t \<Longrightarrow> heap(insert x t)"
by(simp add: insert_def heap_merge del: merge.simps split: tree.split)

lemma ltree_del_min: "ltree t \<Longrightarrow> ltree(del_min t)"
by(cases t)(auto simp add: ltree_merge simp del: merge.simps)

lemma heap_del_min: "heap t \<Longrightarrow> heap(del_min t)"
by(cases t)(auto simp add: heap_merge simp del: merge.simps)

text \<open>Last step of functional correctness proof: combine all the above lemmas
to show that leftist heaps satisfy the specification of priority queues with merge.\<close>

interpretation lheap: Priority_Queue_Merge
where empty = empty and is_empty = "\<lambda>t. t = Leaf"
and insert = insert and del_min = del_min
and get_min = get_min and merge = merge
and invar = "\<lambda>t. heap t \<and> ltree t" and mset = mset_tree
proof(standard, goal_cases)
  case 1 show ?case by (simp add: empty_def)
next
  case (2 q) show ?case by (cases q) auto
next
  case 3 show ?case by(rule mset_insert)
next
  case 4 show ?case by(rule mset_del_min)
next
  case 5 thus ?case by(simp add: get_min mset_tree_empty set_tree_mset)
next
  case 6 thus ?case by(simp add: empty_def)
next
  case 7 thus ?case by(simp add: heap_insert ltree_insert)
next
  case 8 thus ?case by(simp add: heap_del_min ltree_del_min)
next
  case 9 thus ?case by (simp add: mset_merge)
next
  case 10 thus ?case by (simp add: heap_merge ltree_merge)
qed

subsection "Complexity"

text\<open>Explicit termination argument: sum of sizes\<close>

fun T_merge :: "'a::ord lheap \<Rightarrow> 'a lheap \<Rightarrow> nat" where
"T_merge Leaf t = 1" |
"T_merge t Leaf = 1" |
"T_merge (Node l1 (a1, n1) r1 =: t1) (Node l2 (a2, n2) r2 =: t2) =
  (if a1 \<le> a2 then T_merge r1 t2
   else T_merge t1 r2) + 1"

definition T_insert :: "'a::ord \<Rightarrow> 'a lheap \<Rightarrow> nat" where
"T_insert x t = T_merge (Node Leaf (x, 1) Leaf) t + 1"

fun T_del_min :: "'a::ord lheap \<Rightarrow> nat" where
"T_del_min Leaf = 1" |
"T_del_min (Node l _ r) = T_merge l r + 1"

lemma T_merge_min_height: "ltree l \<Longrightarrow> ltree r \<Longrightarrow> T_merge l r \<le> min_height l + min_height r + 1"
proof(induction l r rule: merge.induct)
  case 3 thus ?case by(auto)
qed simp_all

corollary T_merge_log: assumes "ltree l" "ltree r"
  shows "T_merge l r \<le> log 2 (size1 l) + log 2 (size1 r) + 1"
using le_log2_of_power[OF min_height_size1[of l]]
  le_log2_of_power[OF min_height_size1[of r]] T_merge_min_height[of l r] assms
by linarith

corollary T_insert_log: "ltree t \<Longrightarrow> T_insert x t \<le> log 2 (size1 t) + 3"
using T_merge_log[of "Node Leaf (x, 1) Leaf" t]
by(simp add: T_insert_def split: tree.split)

(* FIXME mv ? *)
lemma ld_ld_1_less:
  assumes "x > 0" "y > 0" shows "log 2 x + log 2 y + 1 < 2 * log 2 (x+y)"
proof -
  have "2 powr (log 2 x + log 2 y + 1) = 2*x*y"
    using assms by(simp add: powr_add)
  also have "\<dots> < (x+y)^2" using assms
    by(simp add: numeral_eq_Suc algebra_simps add_pos_pos)
  also have "\<dots> = 2 powr (2 * log 2 (x+y))"
    using assms by(simp add: powr_add log_powr[symmetric])
  finally show ?thesis by simp
qed

corollary T_del_min_log: assumes "ltree t"
  shows "T_del_min t \<le> 2 * log 2 (size1 t) + 1"
proof(cases t rule: tree2_cases)
  case Leaf thus ?thesis using assms by simp
next
  case [simp]: (Node l _ _ r)
  have "T_del_min t = T_merge l r + 1" by simp
  also have "\<dots> \<le> log 2 (size1 l) + log 2 (size1 r) + 2"
    using \<open>ltree t\<close> T_merge_log[of l r] by (auto simp del: T_merge.simps)
  also have "\<dots> \<le> 2 * log 2 (size1 t) + 1"
    using ld_ld_1_less[of "size1 l" "size1 r"] by (simp)
  finally show ?thesis .
qed

end


(****************************************************************************)
chapter {* Automated Reasoning Course
          Jacques Fleuriot
          Propositional Logic in Isabelle *}
(****************************************************************************)

theory Prop
imports Main

begin

(****************************************************************************)
section {* Introduction *}

text {* This Isabelle theory file accompanies Lectures 2-4 of the
        Automated Reasoning course. By stepping through it you should become
        familiar with how to undertake propositional logic proofs in Isabelle. *}

(****************************************************************************)
section {* First theorems *}

theorem K: "A \<longrightarrow> B \<longrightarrow> A"
apply (rule impI)
apply (rule impI)
apply assumption
done

text {* The rules "impI" and "assumption" above are examples of
        Isabelle proof methods.

         After processing "done" above, the front-end will
        display a version of the theorem with the A and B replaced by
        ?A and ?B.  These are schematic or meta
        variables that can be freely instantiated if theorem K is used
        in some further proof.

        Theorems can involve assumptions from the start.  For example,
        here is the Isabelle version of the natural deduction
        derivation of A, B \<turnstile> A \<and> (B \<and> A) *}

theorem a_conj_theorem: "\<lbrakk> A ; B \<rbrakk> \<Longrightarrow> A \<and> (B \<and> A)"
apply (rule conjI)
apply assumption
apply (rule conjI)
apply assumption
apply assumption
done

text {* We can add "+" to the end of a method in order to apply it
        more than once. We can also use the keyword "by" instead
        of "apply" for the final line of the proof. This allows us
        to discard the "done".  So, the same theorem can be proved
        as follows: *}

theorem a_conj_theorem2: "\<lbrakk> A ; B \<rbrakk> \<Longrightarrow> A \<and> (B \<and> A)"
apply (rule conjI)
apply assumption
apply (rule conjI)
by assumption+

(****************************************************************************)
section {* More On Applying Rules *}

text {* A simple propositional fact is B \<or> A from the
        assumption A \<or> B. In Isabelle, this lemma can
        be proved as follows: *}

lemma "A \<or> B \<Longrightarrow> B \<or> A"
apply (erule disjE)
apply (rule disjI2)
apply assumption
apply (rule disjI1)
by assumption

text {* It is instructive to see what happens when we apply a rule
        backward such that not all of its variables can be immediately
        instantiated.  Look at what happens below after "rule
        disjE".  We get schematic variables in both subgoals that then
        are instantiated once we apply the assumption method on the
        1st subgoal.  *}

lemma "A \<or> B \<Longrightarrow> B \<or> A"
apply (rule disjE)
apply assumption
apply (rule disjI2)
apply assumption
apply (rule disjI1)
by assumption

(****************************************************************************)
section {* More Methods *}

text {* Isabelle also provides the methods "drule" and "frule" for
        forwards reasoning. These are best used with destruction rules. For
        example:
      *}

lemma "A \<and> B \<Longrightarrow> A"
apply (drule conjunct1)
by assumption

lemma "A \<and> B \<Longrightarrow> A"
apply (frule conjunct1)
by assumption

(****************************************************************************)
section {* Problems Revisited *}

text{* We can now return to the three problems first posed in Lecture
       2.  The written proof of Example 1 is shown in Lecture 3. Its
       equivalent Isabelle proof is: *}

lemma example1: "(SunnyTomorrow \<or> RainyTomorrow) \<and> \<not>SunnyTomorrow
                  \<longrightarrow> RainyTomorrow"
apply (rule impI)
apply (erule conjE)
apply (erule disjE)
apply (erule notE)
by assumption+

text{* The proofs of Examples 2 and 3 are: *}

lemma example2: "(Class \<or> Pop) \<and> (Class \<longrightarrow> Soph) \<and> \<not>Pop \<longrightarrow> Soph"
apply (rule impI)
apply (erule conjE)+
apply (erule disjE)
apply (erule impE)
apply assumption+
apply (erule notE)
by assumption

lemma example3: "(M \<or> L) \<and> (M \<or> W) \<and> \<not>(L \<and> W) \<longrightarrow> M \<or> (M \<and> L) \<or> (M \<and> W)"
apply (rule impI)
apply (erule conjE)+
apply (erule disjE)
apply (erule disjE)
apply (rule disjI1)
apply assumption
apply (rule disjI1)
apply assumption
apply (erule disjE)
apply (rule disjI1)
apply assumption
apply (erule notE)
apply (rule conjI)
by assumption+

(*****************************************************************************)
section {* Applying Rules to Correct Assumptions *}

text {* Consider the following lemma and proof: *}

lemma conj_elim1: "\<lbrakk> A \<and> B; C \<and> D \<rbrakk> \<Longrightarrow> D"
apply (erule conjE)
apply (erule conjE)
by assumption

text {* Notice that in this proof we had to apply the rule "conjE"
        twice in order to eliminate the conjunction in the second
        assumption. We could have avoided writing the extra proof step
        by using "+":
      *}

lemma conj_elim2: "\<lbrakk> A \<and> B; C \<and> D \<rbrakk> \<Longrightarrow> D"
apply (erule conjE)+
by assumption

text {* Although this new proof is shorter, we have still carried out an
       unnecessary step: we do not need to eliminate the
       conjunction in the first assumption. If we want to apply "conjE"
       to a an assumption different from the first one it matches, then
       we can rotate the ordering of our assumptions. To do this Isabelle
       provides a tactic called "rotate_tac". An alternative proof is
       thus:
     *}

lemma conj_elim3: "\<lbrakk> A \<and> B; C \<and> D \<rbrakk> \<Longrightarrow> D"
apply (rotate_tac 1)
apply (erule conjE)
by assumption

text {* If our list of assumptions is very large, we may not want to use
        "rotate_tac". A better approach is to explicitly tell Isabelle
       what instantiations the variables in a rule should take when we apply
       it. To do this we use the methods "rule_tac", "erule_tac",
       "drule_tac" and "frule_tac". Our alternative proof of
       "conj_elim" is:
    *}

lemma conj_elim4: "\<lbrakk> A \<and> B; C \<and> D \<rbrakk> \<Longrightarrow> D"
apply (erule_tac P=C and Q=D in conjE)
by assumption

text {* In the above proof it is not neccessary to tell Isabelle the variable
        Q in the rule "conjE" should be instantiated to D.
        Isabelle can automatically infer this! So our proof becomes:
      *}

lemma conj_elim5: "\<lbrakk> A \<and> B; C \<and> D \<rbrakk> \<Longrightarrow> D"
apply (erule_tac P=C in conjE)
by assumption

(*****************************************************************************)
section{* More Rules of the Game *}

text {* If you start proving a lemma but get stuck, you can always
        type the command "oops" to abandon the proof. For example:
      *}

lemma A_and_B_imp_B_or_A: "A \<and> B \<longrightarrow> B \<or> A"
oops

text {* Now imagine we want to use A \<and> B \<longrightarrow> B \<or> A to prove
        later lemmas and theorems. As it is not a rule (since it does
        not have the \<Longrightarrow>) we use it by inserting it as an
        assumption in our proof. This is done using
        a tactic called "cut_tac". Consider the following lemma and
        try uncommenting the "apply" command.
      *}

lemma "A \<and> B \<Longrightarrow> B \<or> A"
(* apply (cut_tac A_and_B_imp_B_or_A)*)
(* Isabelle complains! *)
oops

text {*  When we try to insert  A \<and> B \<longrightarrow> B \<or> A into our proof
         Isabelle complains. This is because Isabelle does not know
         the theorem. The command "oops" allowed us to abandon our
         proof, but it also told Isabelle to forget the lemma completely.

         To allow Isabelle to continue checking this theory, comment out
         again the "apply" command above.

         Instead of using "oops", we could have used the command
         "sorry":
      *}

lemma A_and_B_imp_B_or_A_take2: "A \<and> B \<longrightarrow> B \<or> A"
sorry

text {* The command "sorry" tells Isabelle to abandon the proof
        but pretend that the lemma has been proved. This allows us to use it
        in later proofs:
      *}

lemma cut_in_action: "A \<and> B \<Longrightarrow> B \<or> A"
apply (cut_tac A_and_B_imp_B_or_A_take2)
apply (erule impE)
apply assumption+
done

text {* A word of warning: "sorry" is a cheat allowing you to make
        progress. You should return to the incomplete proof and finish it
        to be completely sure the rest of your theory is valid.
      *}

(*****************************************************************************)
section {* Automation *}

text{* It may seem tedious having to type in all these commands. Isabelle does
       provide a fair amount of automation. The tactics "simp" and "auto" both
       use the classical reasoner of Isabelle and can make life a lot easier.
       Example:
     *}

lemma proved_by_simp: "A \<and> B \<Longrightarrow> B \<or> A"
by simp

lemma proved_by_auto: "A \<and> B \<Longrightarrow> B \<or> A"
by auto

end