(*
    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


theory Powers3844

imports Main Kyber_Values

begin
section \<open>Checking Powers of Root of Unity\<close>
text \<open>In order to check, that $3844$ is indeed a root of unity, we need to calculate all powers
and show that they are not equal to one.\<close>
fun fast_exp_7681 ::" int \<Rightarrow> nat \<Rightarrow> int" where
"fast_exp_7681 x 0 = 1" |
"fast_exp_7681 x (Suc e) = (x * (fast_exp_7681 x e)) mod 7681"

lemma list_all_fast_exp_7681:
"list_all (\<lambda>l. fast_exp_7681 (3844::int) l \<noteq> 1) [1..<256]"
by (subst upt_conv_Cons, simp, subst list_all_simps(1), intro conjI, eval)+
   force

lemma fast_exp_7681_to_mod_ring:
"fast_exp_7681 x e = to_int_mod_ring ((of_int_mod_ring x :: fin7681 mod_ring)^e)"
proof (induct e arbitrary: x rule: fast_exp_7681.induct)
  case (2 x e)
  then show ?case
  by (metis Suc_inject fast_exp_7681.elims kyber7681.CARD_a kyber7681.of_int_mod_ring_mult
    nat.discI of_int_mod_ring.rep_eq of_int_mod_ring_to_int_mod_ring power_Suc
    to_int_mod_ring.rep_eq)
qed auto

lemma fast_exp_7681_less256:
assumes "0<l" "l<256"
shows "fast_exp_7681 3844 l \<noteq> 1"
using list_all_fast_exp_7681 assms
by (smt (verit, ccfv_threshold) Ball_set One_nat_def atLeastLessThan_iff
  bot_nat_0.not_eq_extremum fast_exp_7681.elims less_Suc_numeral less_nat_zero_code
  not_less numeral_One numeral_less_iff set_upt)

lemma powr_less256:
assumes "0<l" "l<256"
shows "(3844::fin7681 mod_ring)^l \<noteq> 1"
using fast_exp_7681_less256[OF assms] unfolding fast_exp_7681_to_mod_ring
by (metis of_int_numeral of_int_of_int_mod_ring to_int_mod_ring_hom.hom_one)

end


section \<open>java.lang.Long\<close>

text \<open>
Utility functions from the Java Long class that Graal occasionally makes use of.
\<close>

theory JavaLong
  imports JavaWords
          "HOL-Library.FSet"
begin

lemma negative_all_set_32:
  "n < 32 \<Longrightarrow> bit (-1::int32) n"
  apply transfer by auto

(* TODO: better handle empty *)
definition MaxOrNeg :: "nat set \<Rightarrow> int" where
  "MaxOrNeg s = (if s = {} then -1 else Max s)"

definition MinOrHighest :: "nat set \<Rightarrow> nat \<Rightarrow> nat" where
  "MinOrHighest s m = (if s = {} then m else Min s)"

lemma MaxOrNegEmpty:
  "MaxOrNeg s = -1 \<longleftrightarrow> s = {}"
  unfolding MaxOrNeg_def by auto

subsection Long.highestOneBit

(* This is a different definition to Long.highestOneBit *)
definition highestOneBit :: "('a::len) word \<Rightarrow> int" where
  "highestOneBit v = MaxOrNeg {n. bit v n}"

lemma highestOneBitInvar:
  "highestOneBit v = j \<Longrightarrow> (\<forall>i::nat. (int i > j \<longrightarrow> \<not> (bit v i)))"
  apply (induction "size v")
  apply simp
  by (smt (verit) MaxOrNeg_def Max_ge empty_iff finite_bit_word highestOneBit_def mem_Collect_eq of_nat_mono)

lemma highestOneBitNeg:
  "highestOneBit v = -1 \<longleftrightarrow> v = 0"
  unfolding highestOneBit_def MaxOrNeg_def
  by (metis Collect_empty_eq_bot bit_0_eq bit_word_eqI int_ops(2) negative_eq_positive one_neq_zero)

lemma higherBitsFalse:
  fixes v :: "'a :: len word"
  shows "i > size v \<Longrightarrow> \<not> (bit v i)"
  by (simp add: bit_word.rep_eq size_word.rep_eq)

lemma highestOneBitN:
  assumes "bit v n"
  assumes "\<forall>i::nat. (int i > n \<longrightarrow> \<not> (bit v i))"
  shows "highestOneBit v = n"
  unfolding highestOneBit_def MaxOrNeg_def
  by (metis Max_ge Max_in all_not_in_conv assms(1) assms(2) finite_bit_word mem_Collect_eq of_nat_less_iff order_less_le)

lemma highestOneBitSize:
  assumes "bit v n"
  assumes "n = size v"
  shows "highestOneBit v = n"
  by (metis assms(1) assms(2) not_bit_length wsst_TYs(3))

lemma highestOneBitMax:
  "highestOneBit v < size v"
  unfolding highestOneBit_def MaxOrNeg_def
  using higherBitsFalse
  by (simp add: bit_imp_le_length size_word.rep_eq)

lemma highestOneBitAtLeast:
  assumes "bit v n"
  shows "highestOneBit v \<ge> n"
proof (induction "size v")
  case 0
  then show ?case by simp
next
  case (Suc x)
  then have "\<forall>i. bit v i \<longrightarrow> i < Suc x"
    by (simp add: bit_imp_le_length wsst_TYs(3))
  then show ?case
    unfolding highestOneBit_def MaxOrNeg_def
    using assms by auto
qed

lemma highestOneBitElim:
  "highestOneBit v = n
     \<Longrightarrow> ((n = -1 \<and> v = 0) \<or> (n \<ge> 0 \<and> bit v n))"
  unfolding highestOneBit_def MaxOrNeg_def
  by (metis Max_in finite_bit_word le0 le_minus_one_simps(3) mem_Collect_eq of_nat_0_le_iff of_nat_eq_iff)

text \<open>A recursive implementation of highestOneBit that is suitable for code generation.\<close>

fun highestOneBitRec :: "nat \<Rightarrow> ('a::len) word \<Rightarrow> int" where
  "highestOneBitRec n v =
    (if bit v n then n
     else if n = 0 then -1
     else highestOneBitRec (n - 1) v)"

lemma highestOneBitRecTrue:
  "highestOneBitRec n v = j \<Longrightarrow> j \<ge> 0 \<Longrightarrow> bit v j"
proof (induction "n")
  case 0
  then show ?case
    by (metis diff_0 highestOneBitRec.simps leD of_nat_0_eq_iff of_nat_0_le_iff zle_diff1_eq)
next
  case (Suc n)
  then show ?case
    by (metis diff_Suc_1 highestOneBitRec.elims nat.discI nat_int)
qed

lemma highestOneBitRecN:
  assumes "bit v n"
  shows "highestOneBitRec n v = n"
  by (simp add: assms)

lemma highestOneBitRecMax:
  "highestOneBitRec n v \<le> n"
  by (induction n; simp)

lemma highestOneBitRecElim:
  assumes "highestOneBitRec n v = j"
  shows "((j = -1 \<and> v = 0) \<or> (j \<ge> 0 \<and> bit v j))"
  using assms highestOneBitRecTrue by blast

lemma highestOneBitRecZero:
  "v = 0 \<Longrightarrow> highestOneBitRec (size v) v = -1"
  by (induction rule: "highestOneBitRec.induct"; simp)

lemma highestOneBitRecLess:
  assumes "\<not> bit v n"
  shows "highestOneBitRec n v = highestOneBitRec (n - 1) v"
  using assms by force

text \<open>Some lemmas that use masks to restrict highestOneBit
  and relate it to highestOneBitRec.\<close>

lemma highestOneBitMask:
  assumes "size v = n"
  shows "highestOneBit v = highestOneBit (and v (mask n))"
  by (metis assms dual_order.refl lt2p_lem mask_eq_iff size_word.rep_eq)

lemma maskSmaller:
  fixes v :: "'a :: len word"
  assumes "\<not> bit v n"
  shows "and v (mask (Suc n)) = and v (mask n)"
  unfolding bit_eq_iff
  by (metis assms bit_and_iff bit_mask_iff less_Suc_eq)

lemma highestOneBitSmaller:
  assumes "size v = Suc n"
  assumes "\<not> bit v n"
  shows "highestOneBit v = highestOneBit (and v (mask n))"
  by (metis assms highestOneBitMask maskSmaller)

lemma highestOneBitRecMask:
  shows "highestOneBit (and v (mask (Suc n))) = highestOneBitRec n v"
proof (induction n)
  case 0
  then show ?case
    by (smt (verit, ccfv_SIG) Word.mask_Suc_0 and_mask_lt_2p and_nonnegative_int_iff bit_1_iff bit_and_iff highestOneBitN highestOneBitNeg highestOneBitRec.simps mask_eq_exp_minus_1 of_int_0 uint_1_eq uint_and word_and_def)
next
  case (Suc n)
  then show ?case
  proof (cases "bit v (Suc n)")
    case True
    have 1: "highestOneBitRec (Suc n) v = Suc n"
      by (simp add: True)
    have "\<forall>i::nat. (int i > (Suc n) \<longrightarrow> \<not> (bit (and v (mask (Suc (Suc n)))) i))"
      by (simp add: bit_and_iff bit_mask_iff)
    then have 2: "highestOneBit (and v (mask (Suc (Suc n)))) = Suc n"
      using True highestOneBitN
      by (metis bit_take_bit_iff lessI take_bit_eq_mask)
    then show ?thesis
      using 1 2 by auto
  next
    case False
    then show ?thesis
      by (simp add: Suc maskSmaller)
  qed
qed

text \<open>Finally - we can use the mask lemmas to relate highestOneBitRec to its spec.\<close>

lemma highestOneBitImpl[code]:
  "highestOneBit v = highestOneBitRec (size v) v"
  by (metis highestOneBitMask highestOneBitRecMask maskSmaller not_bit_length wsst_TYs(3))

lemma "highestOneBit (0x5 :: int8) = 2" by code_simp

subsection \<open>Long.lowestOneBit\<close>

definition lowestOneBit :: "('a::len) word \<Rightarrow> nat" where
  "lowestOneBit v = MinOrHighest {n . bit v n} (size v)"

lemma max_bit: "bit (v::('a::len) word) n \<Longrightarrow> n < size v"
  by (simp add: bit_imp_le_length size_word.rep_eq)

lemma max_set_bit: "MaxOrNeg {n . bit (v::('a::len) word) n} < Nat.size v"
  using max_bit unfolding MaxOrNeg_def
  by force

subsection \<open>Long.numberOfLeadingZeros\<close>

definition numberOfLeadingZeros :: "('a::len) word \<Rightarrow> nat" where
  "numberOfLeadingZeros v = nat (Nat.size v - highestOneBit v - 1)"

lemma MaxOrNeg_neg: "MaxOrNeg {} = -1"
  by (simp add: MaxOrNeg_def)

lemma MaxOrNeg_max: "s \<noteq> {} \<Longrightarrow> MaxOrNeg s = Max s"
  by (simp add: MaxOrNeg_def)

lemma zero_no_bits:
  "{n . bit 0 n} = {}"
  by simp

lemma "highestOneBit (0::64 word) = -1"
  by (simp add: MaxOrNeg_neg highestOneBit_def)

lemma "numberOfLeadingZeros (0::64 word) = 64"
  unfolding numberOfLeadingZeros_def using  MaxOrNeg_neg highestOneBit_def size64
  by (smt (verit) nat_int zero_no_bits)

lemma highestOneBit_top: "Max {highestOneBit (v::64 word)} < 64"
  unfolding highestOneBit_def
  by (metis Max_singleton int_eq_iff_numeral max_set_bit size64)

lemma numberOfLeadingZeros_top: "Max {numberOfLeadingZeros (v::64 word)} \<le> 64"
  unfolding numberOfLeadingZeros_def
  using size64
  by (simp add: MaxOrNeg_def highestOneBit_def nat_le_iff)

lemma numberOfLeadingZeros_range: "0 \<le> numberOfLeadingZeros a \<and> numberOfLeadingZeros a \<le> Nat.size a"
  unfolding numberOfLeadingZeros_def
  using MaxOrNeg_def highestOneBit_def nat_le_iff
  by (smt (verit) bot_nat_0.extremum int_eq_iff)

lemma leadingZerosAddHighestOne: "numberOfLeadingZeros v + highestOneBit v = Nat.size v - 1"
  unfolding numberOfLeadingZeros_def highestOneBit_def
  using MaxOrNeg_def int_nat_eq int_ops(6) max_bit order_less_irrefl by fastforce

subsection \<open>Long.numberOfTrailingZeros\<close>

definition numberOfTrailingZeros :: "('a::len) word \<Rightarrow> nat" where
  "numberOfTrailingZeros v = lowestOneBit v"

lemma lowestOneBit_bot: "lowestOneBit (0::64 word) = 64"
  unfolding lowestOneBit_def MinOrHighest_def
  by (simp add: size64)

lemma bit_zero_set_in_top: "bit (-1::'a::len word) 0"
  by auto

lemma nat_bot_set: "(0::nat) \<in> xs \<longrightarrow> (\<forall>x \<in> xs . 0 \<le> x)"
  by fastforce

lemma "numberOfTrailingZeros (0::64 word) = 64"
  unfolding numberOfTrailingZeros_def
  using lowestOneBit_bot by simp

subsection \<open>Long.bitCount\<close>

definition bitCount :: "('a::len) word \<Rightarrow> nat" where
  "bitCount v = card {n . bit v n}"

lemma "bitCount 0 = 0"
  unfolding bitCount_def
  by (metis card.empty zero_no_bits)

subsection \<open>Long.zeroCount\<close>

definition zeroCount :: "('a::len) word \<Rightarrow> nat" where
  "zeroCount v = card {n. n < Nat.size v \<and> \<not>(bit v n)}"

lemma zeroCount_finite: "finite {n. n < Nat.size v \<and> \<not>(bit v n)}"
  using finite_nat_set_iff_bounded by blast

lemma negone_set:
  "bit (-1::('a::len) word) n \<longleftrightarrow> n < LENGTH('a)"
  by simp

lemma negone_all_bits:
  "{n . bit (-1::('a::len) word) n} = {n . 0 \<le> n \<and> n < LENGTH('a)}"
  using negone_set
  by auto

lemma bitCount_finite:
  "finite {n . bit (v::('a::len) word) n}"
  by simp

lemma card_of_range:
  "x = card {n . 0 \<le> n \<and> n < x}"
  by simp

lemma range_of_nat:
  "{(n::nat) . 0 \<le> n \<and> n < x} = {n . n < x}"
  by simp

lemma finite_range:
  "finite {n::nat . n < x}"
  by simp

lemma range_eq:
  fixes x y :: nat
  shows "card {y..<x} = card {y<..x}"
  using card_atLeastLessThan card_greaterThanAtMost by presburger

lemma card_of_range_bound:
  fixes x y :: nat
  assumes "x > y"
  shows "x - y = card {n . y < n \<and> n \<le> x}"
proof -
  have finite: "finite {n . y \<le> n \<and> n < x}"
    by auto
  have nonempty: "{n . y \<le> n \<and> n < x} \<noteq> {}"
    using assms by blast
  have simprep: "{n . y < n \<and> n \<le> x} = {y<..x}"
    by auto
  have "x - y = card {y<..x}"
    by auto
  then show ?thesis
    unfolding simprep by blast
qed

lemma "bitCount (-1::('a::len) word) = LENGTH('a)"
  unfolding bitCount_def using card_of_range
  by (metis (no_types, lifting) Collect_cong negone_all_bits)

lemma bitCount_range:
  fixes n :: "('a::len) word"
  shows "0 \<le> bitCount n \<and> bitCount n \<le> Nat.size n"
  unfolding bitCount_def
  by (metis atLeastLessThan_iff bot_nat_0.extremum max_bit mem_Collect_eq subsetI subset_eq_atLeast0_lessThan_card)

lemma zerosAboveHighestOne:
  "n > highestOneBit a \<Longrightarrow> \<not>(bit a n)"
  unfolding highestOneBit_def MaxOrNeg_def
  by (metis (mono_tags, opaque_lifting) Collect_empty_eq Max_ge finite_bit_word less_le_not_le mem_Collect_eq of_nat_le_iff)

lemma zerosBelowLowestOne:
  assumes "n < lowestOneBit a"
  shows "\<not>(bit a n)"
proof (cases "{i. bit a i} = {}")
  case True
  then show ?thesis by simp
next
  case False
  have "n < Min (Collect (bit a)) \<Longrightarrow> \<not> bit a n"
    using False by auto
  then show ?thesis
    by (metis False MinOrHighest_def assms lowestOneBit_def)
qed

lemma union_bit_sets:
  fixes a :: "('a::len) word"
  shows "{n . n < Nat.size a \<and> bit a n} \<union> {n . n < Nat.size a \<and> \<not>(bit a n)} = {n . n < Nat.size a}"
  by fastforce

lemma disjoint_bit_sets:
  fixes a :: "('a::len) word"
  shows "{n . n < Nat.size a \<and> bit a n} \<inter> {n . n < Nat.size a \<and> \<not>(bit a n)} = {}"
  by blast

lemma qualified_bitCount:
  "bitCount v = card {n . n < Nat.size v \<and> bit v n}"
  by (metis (no_types, lifting) Collect_cong bitCount_def max_bit)

lemma card_eq:
  assumes "finite x \<and> finite y \<and> finite z"
  assumes "x \<union> y = z"
  assumes "y \<inter> x = {}"
  shows "card z - card y = card x"
  using assms add_diff_cancel_right' card_Un_disjoint
  by (metis inf.commute)

lemma card_add:
  assumes "finite x \<and> finite y \<and> finite z"
  assumes "x \<union> y = z"
  assumes "y \<inter> x = {}"
  shows "card x + card y = card z"
  using assms card_Un_disjoint
  by (metis inf.commute)

lemma card_add_inverses:
  assumes "finite {n. Q n \<and> \<not>(P n)} \<and> finite {n. Q n \<and> P n} \<and> finite {n. Q n}"
  shows "card {n. Q n \<and> P n} + card {n. Q n \<and> \<not>(P n)} = card {n. Q n}"
  apply (rule card_add)
  using assms apply simp
  apply auto[1]
  by auto

lemma ones_zero_sum_to_width:
  "bitCount a + zeroCount a = Nat.size a"
proof -
  have add_cards: "card {n. (\<lambda>n. n < size a) n \<and> (bit a n)} + card {n. (\<lambda>n. n < size a) n \<and> \<not>(bit a n)} = card {n. (\<lambda>n. n < size a) n}"
    apply (rule card_add_inverses) by simp
  then have "... = Nat.size a"
    by auto
 then show ?thesis
    unfolding bitCount_def zeroCount_def using max_bit
    by (metis (mono_tags, lifting) Collect_cong add_cards)
qed

lemma intersect_bitCount_helper:
  "card {n . n < Nat.size a} - bitCount a = card {n . n < Nat.size a \<and> \<not>(bit a n)}"
proof -
  have size_def: "Nat.size a = card {n . n < Nat.size a}"
    using card_of_range by simp
  have bitCount_def: "bitCount a = card {n . n < Nat.size a \<and> bit a n}"
    using qualified_bitCount by auto
  have disjoint: "{n . n < Nat.size a \<and> bit a n} \<inter> {n . n < Nat.size a \<and> \<not>(bit a n)} = {}"
    using disjoint_bit_sets by auto
  have union: "{n . n < Nat.size a \<and> bit a n} \<union> {n . n < Nat.size a \<and> \<not>(bit a n)} = {n . n < Nat.size a}"
    using union_bit_sets by auto
  show ?thesis
    unfolding bitCount_def
    apply (rule card_eq)
    using finite_range apply simp
    using union apply blast
    using disjoint by simp
qed

lemma intersect_bitCount:
  "Nat.size a - bitCount a = card {n . n < Nat.size a \<and> \<not>(bit a n)}"
  using card_of_range intersect_bitCount_helper by auto

hide_fact intersect_bitCount_helper

end


theory Karatsuba
  imports "Auto2_HOL.Auto2_Main" Berlekamp_Zassenhaus.Karatsuba_Multiplication
begin

section \<open>List version of polynomial operations\<close>

fun coeffs_smult :: "'a::comm_ring_1 \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "coeffs_smult m [] = []"
| "coeffs_smult m (x # xs) = m * x # coeffs_smult m xs"
setup \<open>fold add_rewrite_rule @{thms coeffs_smult.simps}\<close>

lemma coeffs_smult [rewrite]: "Poly (coeffs_smult m xs) = smult m (Poly xs)"
  by (induct xs, auto)

lemma coeffs_smult_length [rewrite_arg]:
  "length (coeffs_smult m xs) = length xs"
@proof @induct xs @qed

lemma coeffs_smult_nth [rewrite]:
  "i < length (coeffs_smult m xs) \<Longrightarrow> coeffs_smult m xs ! i = m * xs ! i"
@proof @induct xs arbitrary i @qed

lemma coeffs_smult_one [rewrite]:
  "coeffs_smult 1 xs = xs" by auto2

definition coeffs_plus :: "'a::comm_ring_1 list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixl "+\<^sub>l" 65) where
  "xs +\<^sub>l ys = list (\<lambda>i. nth_default 0 xs i + nth_default 0 ys i) (max (length xs) (length ys))"

lemma coeffs_plus_length [rewrite_arg]:
  "length ys \<le> length xs \<Longrightarrow> length (xs +\<^sub>l ys) = length xs"
@proof @unfold "xs +\<^sub>l ys" @qed

lemma coeffs_plus_length' [rewrite_arg]:
  "length xs \<le> length ys \<Longrightarrow> length (xs +\<^sub>l ys) = length ys"
@proof @unfold "xs +\<^sub>l ys" @qed

lemma coeffs_plus_Poly [rewrite]: "Poly (f1 +\<^sub>l f0) = Poly f1 + Poly f0"
proof (rule poly_eqI, unfold poly_of_list_def coeff_add coeff_Poly)
  fix i
  show "nth_default 0 (f1 +\<^sub>l f0) i = nth_default 0 f1 i + nth_default 0 f0 i"
    unfolding coeffs_plus_def
    by (simp add: list_length list_nth max_def nth_default_def)
qed

definition coeffs_minus :: "'a::comm_ring_1 list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixl "-\<^sub>l" 65) where
  "xs -\<^sub>l ys = list (\<lambda>i. nth_default 0 xs i - nth_default 0 ys i) (max (length xs) (length ys))"

lemma coeffs_minus_length [rewrite_arg]:
  "length ys \<le> length xs \<Longrightarrow> length (xs -\<^sub>l ys) = length xs"
@proof @unfold "xs -\<^sub>l ys" @qed

lemma coeffs_minus_Poly [rewrite]: "Poly (f1 -\<^sub>l f0) = Poly f1 - Poly f0"
proof (rule poly_eqI, unfold poly_of_list_def coeff_diff coeff_Poly)
  fix i
  show "nth_default 0 (f1 -\<^sub>l f0) i = nth_default 0 f1 i - nth_default 0 f0 i"
    unfolding coeffs_minus_def
    by (simp add: list_length list_nth max_def nth_default_def)
qed

lemma arith1 [rewrite_back]: "(a::'a::comm_ring_1) - b = a + (-1) * b" by simp
lemma mult0_right [rewrite]: "(m::('a::comm_ring_1)) * 0 = 0" by auto
setup \<open>add_rewrite_rule @{thm nth_default_def}\<close>

lemma coeffs_plus_neg_is_minus [rewrite_back]:
  "xs +\<^sub>l coeffs_smult (-1) ys = xs -\<^sub>l ys"
@proof
  @unfold "xs -\<^sub>l ys"
  @unfold "xs +\<^sub>l coeffs_smult (-1) ys"
  @have "length (xs -\<^sub>l ys) = length (xs +\<^sub>l coeffs_smult (-1) ys)"
  @have "\<forall>i<length (xs -\<^sub>l ys). (xs -\<^sub>l ys) ! i = (xs +\<^sub>l coeffs_smult (-1) ys) ! i" @with
    @let "x = nth_default 0 xs i"
    @let "y = nth_default 0 ys i"
    @have "(xs -\<^sub>l ys) ! i = x - y"
    @have "(xs +\<^sub>l coeffs_smult (-1) ys) ! i = x + (-1) * y"
  @end
@qed

definition coeffs_monom_mult :: "nat \<Rightarrow> 'a::comm_ring_1 list \<Rightarrow> 'a list" where
  "coeffs_monom_mult n xs = replicate n 0 @ xs"

lemma coeffs_mono_mult [rewrite]:
  "Poly (coeffs_monom_mult n xs) = monom_mult n (Poly xs)"
proof (cases "Poly xs = 0")
  case True
  then show ?thesis by (auto simp: coeffs_monom_mult_def monom_mult_def Poly_append)
next
  case False
  then have N: "coeffs (Poly xs) \<noteq> []" and
      N2: "xs \<noteq> []"
    by (auto simp add: coeffs_eq_iff)
  have "monom_mult n (Poly xs) = Poly (coeffs (monom_mult n (Poly xs)))"
    by simp
  also have "\<dots> = Poly (let xs = coeffs (Poly xs) in
    if xs = [] then xs else replicate n 0 @ xs)" unfolding monom_mult_code by simp
  also have "\<dots> = Poly (replicate n 0 @ coeffs (Poly xs))"
    using N by presburger
  also have "\<dots> = poly_of_list (coeffs_monom_mult n xs)"
    unfolding coeffs_monom_mult_def using N2 apply auto
    by (metis Poly_append Poly_coeffs coeffs_Poly)
  finally show ?thesis by simp
qed

lemma length_coeffs_monom_mult [rewrite_arg]:
  "length (coeffs_monom_mult n as) = n + length as"
@proof @unfold "coeffs_monom_mult n as" @qed

lemma coeffs_monom_mult_0 [rewrite]: "coeffs_monom_mult 0 xs = xs"
@proof @unfold "coeffs_monom_mult 0 xs" @qed

section \<open>General addition function\<close>

definition coeffs_shift_plus :: "nat \<Rightarrow> 'a::comm_ring_1 \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where [rewrite]:
  "coeffs_shift_plus s m xs ys = list (\<lambda>i.
     if i < s then ys ! i else if i \<ge> s + length xs then ys ! i
     else ys ! i + m * xs ! (i - s)) (length ys)"
setup \<open>register_wellform_data ("coeffs_shift_plus s m xs ys", ["s + length xs \<le> length ys"])\<close>

lemma coeffs_shift_plus_correct [rewrite]:
  "s + length xs \<le> length ys \<Longrightarrow>
   coeffs_shift_plus s m xs ys = ys +\<^sub>l coeffs_smult m (coeffs_monom_mult s xs)"
@proof
  @unfold "ys +\<^sub>l coeffs_smult m (coeffs_monom_mult s xs)"
  @unfold "coeffs_monom_mult s xs"
@qed

lemma smult_monom_mult' [rewrite]: "smult a (monom_mult n q) = monom a n * q"
  by (metis monom_mult_unfold(1) mult.right_neutral smult_monom_mult)

lemma coeffs_shift_plus_Poly [rewrite]:
  "s + length xs \<le> length ys \<Longrightarrow>
   Poly (coeffs_shift_plus s m xs ys) = Poly ys + monom m s * Poly xs" by auto2

lemma coeffs_shift_plus_1 [rewrite]:
  "s + length xs \<le> length ys \<Longrightarrow>
   coeffs_shift_plus s 1 xs ys = ys +\<^sub>l coeffs_monom_mult s xs" by auto2

lemma coeffs_shift_minus_1 [rewrite]:
  "0 + length xs \<le> length ys \<Longrightarrow>
   coeffs_shift_plus 0 (-1) xs ys = ys -\<^sub>l xs" by auto2

fun coeffs_shift_add_array :: "nat \<Rightarrow> 'a::comm_ring_1 \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> 'a list" where
  "coeffs_shift_add_array s m xs ys 0 = ys"
| "coeffs_shift_add_array s m xs ys (Suc n) =
   (let ys' = coeffs_shift_add_array s m xs ys n in
      list_update ys' (s + n) (m * xs ! n + ys' ! (s + n)))"
setup \<open>fold add_rewrite_rule @{thms coeffs_shift_add_array.simps}\<close>

lemma coeffs_shift_add_array_length [rewrite_arg]:
  "n \<le> length xs \<Longrightarrow> s + length xs \<le> length ys \<Longrightarrow>
   length (coeffs_shift_add_array s m xs ys n) = length ys"
@proof @induct n @qed

lemma coeffs_shift_add_array_ind [rewrite]:
  "n \<le> length xs \<Longrightarrow> s + length xs \<le> length ys \<Longrightarrow> i < length ys \<Longrightarrow>
   coeffs_shift_add_array s m xs ys n ! i = (if i < s + n then coeffs_shift_plus s m xs ys ! i else ys ! i)"
@proof @induct n @with
  @subgoal "n = 0" @case "i < s" @endgoal
  @subgoal "n = Suc n"
    @case "i < s + Suc n" @with
      @case "i < s + n" @case "i = s + n"
      @have "s + Suc n = Suc (s + n)"
    @end
  @endgoal @end
@qed

lemma coeffs_shift_add_array [rewrite]:
  "s + length xs \<le> length ys \<Longrightarrow>
   coeffs_shift_add_array s m xs ys (length xs) = coeffs_shift_plus s m xs ys" by auto2

section \<open>Naive multiplication procedure\<close>

setup \<open>add_rewrite_rule @{thm Poly_snoc}\<close>
setup \<open>add_rewrite_rule @{thm Poly.simps(1)}\<close>
setup \<open>add_rewrite_rule @{thm Poly_replicate_0}\<close>

lemma ring_norm1 [resolve]: "(a + b) * c = a * c + b * (c::'a::comm_ring_1 poly)"
  by (simp add: comm_semiring_class.distrib)

(* Compute product by adding terms in g one-by-one. *)
fun coeffs_prod_ind :: "'a::comm_ring_1 list \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> 'a list" where
  "coeffs_prod_ind xs ys 0 = replicate (length xs + length ys - 1) 0"
| "coeffs_prod_ind xs ys (Suc n) =
   (let zs = coeffs_prod_ind xs ys n in
      coeffs_shift_plus n (xs ! n) ys zs)"
setup \<open>fold add_rewrite_rule @{thms coeffs_prod_ind.simps}\<close>

lemma coeffs_prod_ind_length [rewrite_arg]:
  "length (coeffs_prod_ind xs ys n) = length xs + length ys - 1"
@proof @induct n @qed

lemma poly_mult_ind [rewrite]:
  "length (p::'a::comm_ring_1 list) + length q \<le> length ys \<Longrightarrow>
   Poly ys = Poly p * Poly q \<Longrightarrow>
   Poly (coeffs_shift_plus (length p) a q ys) = Poly (p @ [a]) * Poly q" by auto2

lemma coeffs_prod_correct_ind [rewrite]:
  "n \<le> length xs \<Longrightarrow>
   Poly (coeffs_prod_ind xs ys n) = Poly (take n xs) * Poly ys"
@proof @induct n @with
  @subgoal "n = Suc n"
    @have "n + length ys \<le> length xs + length ys - 1"
  @endgoal @end
@qed

definition coeffs_prod :: "'a::comm_ring_1 list \<Rightarrow> 'a list \<Rightarrow> 'a list" where [rewrite]:
  "coeffs_prod xs ys = coeffs_prod_ind xs ys (length xs)"

lemma coeffs_prod_correct [rewrite]:
  "Poly (coeffs_prod xs ys) = Poly xs * Poly ys" by auto2

section \<open>Functional version of karatsuba\<close>

fun karatsuba_main_list :: "'a::comm_ring_1 list \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> 'a list" where
  "karatsuba_main_list f g n = (
   if n \<le> karatsuba_lower_bound then
     coeffs_prod f g
   else let
     n2 = n div 2;
     f0 = take n2 f; f1 = drop n2 f;
     g0 = take n2 g; g1 = drop n2 g;
     p1 = karatsuba_main_list f1 g1 (n - n2);
     p2 = karatsuba_main_list (f1 -\<^sub>l f0) (g1 -\<^sub>l g0) (n - n2);
     p3 = karatsuba_main_list f0 g0 n2
   in
     coeffs_monom_mult (n2 + n2) p1 +\<^sub>l coeffs_monom_mult n2 (p1 -\<^sub>l p2 +\<^sub>l p3) +\<^sub>l p3)"
declare karatsuba_main_list.simps [simp del]

lemma Poly_split_at [rewrite]:
  "monom_mult n (Poly (drop n f)) + Poly (take n f) = Poly f"
  by (metis (no_types, lifting) Lists_Thms.length_take Poly_append Poly_coeffs add.commute
       append_take_drop_id coeffs_0_eq_Nil drop_eq_Nil le_less monom_mult_unfold mult_zero_left not_less)

setup \<open>add_backward_prfstep @{thm div_le_mono}\<close>

lemma karatsuba_lower_bound_div [rewrite]: "karatsuba_lower_bound div 2 = 3"
  by (simp add: karatsuba_lower_bound_def)

lemma n_div_2_compl [resolve]: "(n::nat) - n div 2 = (n + 1) div 2" by linarith

lemma karatsuba_basic [resolve]:
  "n > karatsuba_lower_bound \<Longrightarrow> n div 2 \<ge> 1"
@proof @have "karatsuba_lower_bound div 2 = 3" @qed

lemma karatsuba_basic2 [resolve]:
  "n > karatsuba_lower_bound \<Longrightarrow> n - n div 2 \<ge> 1"
@proof @have "n - n div 2 = (n + 1) div 2" @qed

lemma karatsuba_diff1 [resolve]:
  "n > karatsuba_lower_bound \<Longrightarrow> n div 2 + n div 2 \<ge> 1" by auto2

lemma karatsuba_diff2 [resolve]:
  "n > karatsuba_lower_bound \<Longrightarrow> n \<ge> n div 2" by auto

lemma karatsuba_diff2' [resolve]:
  "n > karatsuba_lower_bound \<Longrightarrow> n > n div 2" by auto

lemma karatsuba_diff3 [resolve]:
  "n > karatsuba_lower_bound \<Longrightarrow> (n - n div 2) + (n - n div 2) \<ge> 1" by auto2

lemma karatsuba_diff4 [resolve]:
  "n > karatsuba_lower_bound \<Longrightarrow> n - n div 2 < n"
@proof @have "n div 2 \<ge> 1" @qed

lemma karatsuba_diff5 [resolve]:
  "n > karatsuba_lower_bound \<Longrightarrow> n div 2 \<le> n - n div 2" by auto

setup \<open>add_rewrite_rule @{thm karatsuba_main_step}\<close>

lemma karatsuba_main_list_length [rewrite_arg]:
  "length f = n \<Longrightarrow> length g = n \<Longrightarrow>
   length (karatsuba_main_list f g n) = n + n - 1"
@proof
  @strong_induct n arbitrary f g
  @case "n \<le> karatsuba_lower_bound" @with
    @unfold "karatsuba_main_list f g n"
  @end
  @let "n2 = n div 2"
  @let "f0 = take n2 f" "f1 = drop n2 f"
  @let "g0 = take n2 g" "g1 = drop n2 g"
  @let "p1 = karatsuba_main_list f1 g1 (n - n2)"
  @let "p2 = karatsuba_main_list (f1 -\<^sub>l f0) (g1 -\<^sub>l g0) (n - n2)"
  @let "p3 = karatsuba_main_list f0 g0 n2"
  @let "res = coeffs_monom_mult (n2 + n2) p1 +\<^sub>l coeffs_monom_mult n2 (p1 -\<^sub>l p2 +\<^sub>l p3) +\<^sub>l p3"
  @have "n2 \<le> n - n2"
  @apply_induct_hyp "n - n2" f1 g1
  @apply_induct_hyp "n - n2" "f1 -\<^sub>l f0" "g1 -\<^sub>l g0"
  @apply_induct_hyp n2 f0 g0
  @have "length (coeffs_monom_mult n2 (p1 -\<^sub>l p2 +\<^sub>l p3)) = n + (n - n2) - 1" @with
    @have "n2 + n2 - 1 \<le> (n - n2) + (n - n2) - 1"
  @end
  @have "length (coeffs_monom_mult (n2 + n2) p1) = n + n - 1"
  @have "length res = n + n - 1" @with
    @have "n2 + n2 - 1 \<le> (n - n2) + (n - n2) - 1"
    @have "(n - n2) + (n - n2) - 1 \<le> n + n - 1"
    @have "n + (n - n2) - 1 \<le> n + n - 1"
  @end
  @unfold "karatsuba_main_list f g n"
@qed

lemma karatsuba_main_list_correct:
  "Poly (karatsuba_main_list f g n) = Poly f * Poly g"
@proof
  @strong_induct n arbitrary f g
  @case "n \<le> karatsuba_lower_bound" @with
    @unfold "karatsuba_main_list f g n"
  @end
  @let "n2 = n div 2"
  @let "f0 = take n2 f" "f1 = drop n2 f"
  @let "g0 = take n2 g" "g1 = drop n2 g"
  @apply_induct_hyp "n - n2" f1 g1
  @apply_induct_hyp "n - n2" "f1 -\<^sub>l f0" "g1 -\<^sub>l g0"
  @apply_induct_hyp n2 f0 g0
  @let "p1 = karatsuba_main_list f1 g1 (n - n2)"
  @let "p2 = karatsuba_main_list (f1 -\<^sub>l f0) (g1 -\<^sub>l g0) (n - n2)"
  @let "p3 = karatsuba_main_list f0 g0 n2"
  @let "res = coeffs_monom_mult (n2 + n2) p1 +\<^sub>l coeffs_monom_mult n2 (p1 -\<^sub>l p2 +\<^sub>l p3) +\<^sub>l p3"
  @have "Poly res = monom_mult (n2 + n2) (Poly p1) + monom_mult n2 (Poly p1 - Poly p2 + Poly p3) + Poly p3"
  @have "Poly res = monom_mult (n2 + n2) (Poly p1) + (monom_mult n2 (Poly p1 - Poly p2 + Poly p3) + Poly p3)"
  @unfold "karatsuba_main_list f g n"
@qed

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_65
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun t22 :: "Nat => Nat => Nat" where
  "t22 (Z) y = y"
| "t22 (S z) y = S (t22 z y)"

fun t2 :: "Nat => Nat => bool" where
  "t2 x (Z) = False"
| "t2 (Z) (S z) = True"
| "t2 (S x2) (S z) = t2 x2 z"

lemma "t2 i (S_t22_m_i) \<Longrightarrow> t2 i (S S_t22_m_i)"
  apply(induct S_t22_m_i rule:t2.induct)
  apply fastforce+
  oops

theorem property0 :
  "t2 i (S (t22 m i))"
  (*"induct m" is the natural choice as the innermost recursive function "t22" is defined
   recursively on its first argument, which is "m" in this case and
   the other recursive function "t2" is defined recursively on the second argument, which is
   "t22 m i" in this case.
 *)
  apply(induct m)
   apply clarsimp
   apply(induct_tac i)(*"i" is the only variable*)
    apply fastforce+
  apply clarsimp
    (*generalization "t22 m i" \<rightarrow> "t22_m_i".
      A stronger generalization "(S (t22_m_i))" \<rightarrow> "S_t22_m_i" would be less optimal,
      since it blocks Isabelle using pattern-matching on "S" for "t2.simps"(?) *)
  apply(subgoal_tac "\<And>t22_m_i. t2 i (S (t22_m_i)) \<Longrightarrow> t2 i (S (S (t22_m_i)))")
   apply fastforce
  apply(thin_tac "t2 i (S (t22 m i))")
  apply clarsimp
  apply(subgoal_tac "\<And>t22_m_i. t2 i (S t22_m_i) \<longrightarrow> t2 i (S (S t22_m_i))")
   apply fastforce
  apply(thin_tac "t2 i (S t22_m_i)")
  apply (induct_tac t22_m_ia i rule: t2.induct)
    apply auto
  done

end


(*
  Title:    Missing_PMF.thy
  Author:   Manuel Eberl, TU München

  Auxiliary facts about PMFs that should go in the library at some point
*)

section \<open>Auxiliary facts about PMFs\<close>

theory Missing_PMF
  imports Complex_Main "~~/src/HOL/Probability/Probability" PMF_Of_List Missing_Multiset
begin

(* TODO: Move? *)
adhoc_overloading Monad_Syntax.bind bind_pmf

lemma pmf_not_neg [simp]: "\<not>pmf p x < 0"
  by (simp add: not_less pmf_nonneg)

lemma set_pmf_eq': "set_pmf p = {x. pmf p x > 0}"
proof safe
  fix x assume "x \<in> set_pmf p"
  hence "pmf p x \<noteq> 0" by (auto simp: set_pmf_eq)
  with pmf_nonneg[of p x] show "pmf p x > 0" by simp
qed (auto simp: set_pmf_eq)

lemma setsum_pmf_eq_1:
  assumes "finite A" "set_pmf p \<subseteq> A"
  shows   "(\<Sum>x\<in>A. pmf p x) = 1"
proof -
  have "(\<Sum>x\<in>A. pmf p x) = measure_pmf.prob p A"
    by (simp add: measure_measure_pmf_finite assms)
  also from assms have "\<dots> = 1"
    by (subst measure_pmf.prob_eq_1) (auto simp: AE_measure_pmf_iff)
  finally show ?thesis .
qed

lemma map_pmf_of_set:
  assumes "finite A" "A \<noteq> {}"
  shows   "map_pmf f (pmf_of_set A) = pmf_of_multiset (image_mset f (mset_set A))"
    (is "?lhs = ?rhs")
proof (intro pmf_eqI)
  fix x
  from assms have "ereal (pmf ?lhs x) = ereal (pmf ?rhs x)"
    by (subst ereal_pmf_map)
       (simp_all add: emeasure_pmf_of_set mset_set_empty_iff count_image_mset Int_commute)
  thus "pmf ?lhs x = pmf ?rhs x" by simp
qed

lemma pmf_bind_pmf_of_set:
  assumes "A \<noteq> {}" "finite A"
  shows   "pmf (bind_pmf (pmf_of_set A) f) x =
             (\<Sum>xa\<in>A. pmf (f xa) x) / real_of_nat (card A)" (is "?lhs = ?rhs")
proof -
  from assms have "ereal ?lhs = ereal ?rhs"
    by (subst ereal_pmf_bind) (simp_all add: nn_integral_pmf_of_set max_def pmf_nonneg)
  thus ?thesis by simp
qed

text \<open>The type of lotteries (a probability mass function)\<close>
type_synonym 'alt lottery = "'alt pmf"

definition lotteries_on :: "'a set \<Rightarrow> 'a lottery set" where
  "lotteries_on A = {p. set_pmf p \<subseteq> A}"

lemma pmf_of_set_lottery:
  "A \<noteq> {} \<Longrightarrow> finite A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> pmf_of_set A \<in> lotteries_on B"
  unfolding lotteries_on_def by auto

lemma pmf_of_list_lottery:
  "pmf_of_list_wf xs \<Longrightarrow> set (map fst xs) \<subseteq> A \<Longrightarrow> pmf_of_list xs \<in> lotteries_on A"
  using set_pmf_of_list[of xs] by (auto simp: lotteries_on_def)

lemma return_pmf_in_lotteries_on [simp,intro]:
  "x \<in> A \<Longrightarrow> return_pmf x \<in> lotteries_on A"
  by (simp add: lotteries_on_def)

end


theory Ch3
  imports Main
begin

type_synonym vname = string
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"
datatype aexp = N val | V vname | Plus aexp aexp

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a1 a2) s = aval a1 s + aval a2 s"

fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (Plus a1 a2) = (case (asimp_const a1, asimp_const a2) of
  (N n1, N n2) \<Rightarrow> N (n1 + n2) |
  (a1s, a2s) \<Rightarrow> Plus a1s a2s
)" |
"asimp_const a = a"

(* Exercise 3.1. To show that asimp_const really folds all subexpressions of
the form Plus (N i ) (N j ), define a function optimal :: aexp \<Rightarrow> bool that
checks that its argument does not contain a subexpression of the form Plus
(N i ) (N j ). Then prove optimal (asimp_const a).
*)

lemma aval_asimp_const: "aval (asimp_const a) s = aval a s"
apply(induction a)
apply(auto split: aexp.split)
done

(* 3.10 *)

datatype instr = LOADI val | LOAD vname | ADD

type_synonym stack = "val list"

abbreviation hd2 where
"hd2 xs \<equiv> hd (tl xs)"

abbreviation tl2 where
"tl2 xs \<equiv> tl (tl xs)"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec1 (LOADI n) _ stk = Some (n # stk)" |
"exec1 (LOAD x) s stk = Some (s(x) # stk)" |
"exec1 ADD _ stk =
 (case stk of
  (x # y # xs) \<Rightarrow> Some ((hd2 stk + hd stk) # tl2 stk) |
  (xs) \<Rightarrow> None)"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec [] _ stk = Some stk" |
"exec (i#is) s stk =
 (case (exec1 i s stk) of
  Some res \<Rightarrow> exec is s res |
  None \<Rightarrow> None)"

fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x) = [LOAD x]" |
"comp (Plus e1 e2) = comp e1 @ comp e2 @ [ADD]"

lemma exec_append: "exec is1 s stk = Some new_stk \<Longrightarrow> exec (is1 @ is2) s stk = exec is2 s new_stk"
apply (induction is1 arbitrary:stk)
apply (auto split:option.split)
done

lemma "exec (comp a) s stk = Some (aval a s # stk)"
apply (induction a arbitrary:stk)
apply (auto simp add: exec_append)
done

end


theory prop_06
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
  | "plus (S z) y = S (plus z y)"
  fun length :: "'a list => Nat" where
  "length (Nil2) = Z"
  | "length (Cons2 y xs) = S (length xs)"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  fun rev :: "'a list => 'a list" where
  "rev (Nil2) = Nil2"
  | "rev (Cons2 y xs) = append (rev xs) (Cons2 y (Nil2))"
  (*hipster plus length append rev *)

(*hipster append rev length*)
lemma lemma_a [thy_expl]: "append x2 Nil2 = x2"
by (hipster_induct_schemes append.simps rev.simps length.simps)

lemma lemma_aa [thy_expl]: "append (append x2 y2) z2 = append x2 (append y2 z2)"
by (hipster_induct_schemes append.simps rev.simps length.simps)

lemma lemma_ab [thy_expl]: "append (rev x5) (rev y5) = rev (append y5 x5)"
by (hipster_induct_schemes append.simps rev.simps length.simps)

lemma lemma_ac [thy_expl]: "rev (rev x5) = x5"
by (hipster_induct_schemes append.simps rev.simps length.simps)

lemma unknown []: "length (append x y) = length (append y x)"
oops

lemma unknown []: "length (rev x) = length x"
oops

lemma lemma_ad [thy_expl]: "plus x2 Z = x2"
by (hipster_induct_schemes plus.simps)

lemma lemma_ae [thy_expl]: "plus (plus x2 y2) z2 = plus x2 (plus y2 z2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_af [thy_expl]: "plus x2 (S y2) = S (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ag [thy_expl]: "plus x1 (plus y1 x1) = plus y1 (plus x1 x1)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ah [thy_expl]: "plus x2 (plus y2 y2) = plus y2 (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ai [thy_expl]: "plus x2 (S y2) = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_aj [thy_expl]: "plus (S x2) y2 = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ak [thy_expl]: "plus (plus x2 y2) (plus x2 z2) = plus (plus x2 z2) (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_al [thy_expl]: "plus (plus x2 y2) (plus z2 x2) = plus (plus z2 x2) (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_am [thy_expl]: "plus x2 (plus y2 z2) = plus y2 (plus z2 x2)"
by (hipster_induct_schemes plus.simps)

(*hipster length plus append rev*)
lemma lemma_an [thy_expl]: "plus (length x2) (length y2) = length (append x2 y2)"
by (hipster_induct_schemes length.simps plus.simps append.simps rev.simps)

lemma lemma_ao [thy_expl]: "plus (length x1) (length y1) = length (append y1 x1)"
by (hipster_induct_schemes length.simps plus.simps append.simps rev.simps)

lemma lemma_ap [thy_expl]: "length (rev x3) = length x3"
by (hipster_induct_schemes length.simps plus.simps append.simps rev.simps)

  theorem x0 :
    "(length (rev (append x y))) = (plus (length x) (length y))"
    by (hipster_induct_schemes)

end


(*  Title:      HOL/ex/Abstract_NAT.thy
    Author:     Makarius
*)

section \<open>Abstract Natural Numbers primitive recursion\<close>

theory Abstract_NAT
imports Main
begin

text \<open>Axiomatic Natural Numbers (Peano) -- a monomorphic theory.\<close>

locale NAT =
  fixes zero :: 'n
    and succ :: "'n \<Rightarrow> 'n"
  assumes succ_inject [simp]: "succ m = succ n \<longleftrightarrow> m = n"
    and succ_neq_zero [simp]: "succ m \<noteq> zero"
    and induct [case_names zero succ, induct type: 'n]:
      "P zero \<Longrightarrow> (\<And>n. P n \<Longrightarrow> P (succ n)) \<Longrightarrow> P n"
begin

lemma zero_neq_succ [simp]: "zero \<noteq> succ m"
  by (rule succ_neq_zero [symmetric])

text \<open>\medskip Primitive recursion as a (functional) relation -- polymorphic!\<close>

inductive Rec :: "'a \<Rightarrow> ('n \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'n \<Rightarrow> 'a \<Rightarrow> bool"
  for e :: 'a and r :: "'n \<Rightarrow> 'a \<Rightarrow> 'a"
where
    Rec_zero: "Rec e r zero e"
  | Rec_succ: "Rec e r m n \<Longrightarrow> Rec e r (succ m) (r m n)"

lemma Rec_functional:
  fixes x :: 'n
  shows "\<exists>!y::'a. Rec e r x y"
proof -
  let ?R = "Rec e r"
  show ?thesis
  proof (induct x)
    case zero
    show "\<exists>!y. ?R zero y"
    proof
      show "?R zero e" ..
      fix y assume "?R zero y"
      then show "y = e" by cases simp_all
    qed
  next
    case (succ m)
    from \<open>\<exists>!y. ?R m y\<close>
    obtain y where y: "?R m y"
      and yy': "\<And>y'. ?R m y' \<Longrightarrow> y = y'" by blast
    show "\<exists>!z. ?R (succ m) z"
    proof
      from y show "?R (succ m) (r m y)" ..
      fix z assume "?R (succ m) z"
      then obtain u where "z = r m u" and "?R m u" by cases simp_all
      with yy' show "z = r m y" by (simp only:)
    qed
  qed
qed

text \<open>\medskip The recursion operator -- polymorphic!\<close>

definition rec :: "'a \<Rightarrow> ('n \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'n \<Rightarrow> 'a"
  where "rec e r x = (THE y. Rec e r x y)"

lemma rec_eval:
  assumes Rec: "Rec e r x y"
  shows "rec e r x = y"
  unfolding rec_def
  using Rec_functional and Rec by (rule the1_equality)

lemma rec_zero [simp]: "rec e r zero = e"
proof (rule rec_eval)
  show "Rec e r zero e" ..
qed

lemma rec_succ [simp]: "rec e r (succ m) = r m (rec e r m)"
proof (rule rec_eval)
  let ?R = "Rec e r"
  have "?R m (rec e r m)"
    unfolding rec_def using Rec_functional by (rule theI')
  then show "?R (succ m) (r m (rec e r m))" ..
qed

text \<open>\medskip Example: addition (monomorphic)\<close>

definition add :: "'n \<Rightarrow> 'n \<Rightarrow> 'n"
  where "add m n = rec n (\<lambda>_ k. succ k) m"

lemma add_zero [simp]: "add zero n = n"
  and add_succ [simp]: "add (succ m) n = succ (add m n)"
  unfolding add_def by simp_all

lemma add_zero_right: "add m zero = m"
  by (induct m) simp_all

lemma add_succ_right: "add m (succ n) = succ (add m n)"
  by (induct m) simp_all

lemma "add (succ (succ (succ zero))) (succ (succ zero)) =
    succ (succ (succ (succ (succ zero))))"
  by simp

text \<open>\medskip Example: replication (polymorphic)\<close>

definition repl :: "'n \<Rightarrow> 'a \<Rightarrow> 'a list"
  where "repl n x = rec [] (\<lambda>_ xs. x # xs) n"

lemma repl_zero [simp]: "repl zero x = []"
  and repl_succ [simp]: "repl (succ n) x = x # repl n x"
  unfolding repl_def by simp_all

lemma "repl (succ (succ (succ zero))) True = [True, True, True]"
  by simp

end

text \<open>\medskip Just see that our abstract specification makes sense \dots\<close>

interpretation NAT 0 Suc
proof (rule NAT.intro)
  fix m n
  show "Suc m = Suc n \<longleftrightarrow> m = n" by simp
  show "Suc m \<noteq> 0" by simp
  fix P
  assume zero: "P 0"
    and succ: "\<And>n. P n \<Longrightarrow> P (Suc n)"
  show "P n"
  proof (induct n)
    case 0
    show ?case by (rule zero)
  next
    case Suc
    then show ?case by (rule succ)
  qed
qed

end


(*  Title:      HOL/UNITY/Comp/PriorityAux.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
    Copyright   2001  University of Cambridge

Auxiliary definitions needed in Priority.thy
*)

theory PriorityAux
imports "../UNITY_Main"
begin

typedecl vertex

definition symcl :: "(vertex*vertex)set=>(vertex*vertex)set" where
  "symcl r == r \<union> (r\<inverse>)"
    \<comment> \<open>symmetric closure: removes the orientation of a relation\<close>

definition neighbors :: "[vertex, (vertex*vertex)set]=>vertex set" where
  "neighbors i r == ((r \<union> r\<inverse>)``{i}) - {i}"
    \<comment> \<open>Neighbors of a vertex i\<close>

definition R :: "[vertex, (vertex*vertex)set]=>vertex set" where
  "R i r == r``{i}"

definition A :: "[vertex, (vertex*vertex)set]=>vertex set" where
  "A i r == (r\<inverse>)``{i}"

definition reach :: "[vertex, (vertex*vertex)set]=> vertex set" where
  "reach i r == (r\<^sup>+)``{i}"
    \<comment> \<open>reachable and above vertices: the original notation was R* and A*\<close>

definition above :: "[vertex, (vertex*vertex)set]=> vertex set" where
  "above i r == ((r\<inverse>)\<^sup>+)``{i}"

definition reverse :: "[vertex, (vertex*vertex) set]=>(vertex*vertex)set" where
  "reverse i r == (r - {(x,y). x=i | y=i} \<inter> r) \<union> ({(x,y). x=i|y=i} \<inter> r)\<inverse>"

definition derive1 :: "[vertex, (vertex*vertex)set, (vertex*vertex)set]=>bool" where
    \<comment> \<open>The original definition\<close>
  "derive1 i r q == symcl r = symcl q &
                    (\<forall>k k'. k\<noteq>i & k'\<noteq>i -->((k,k') \<in> r) = ((k,k') \<in> q)) \<and>
                    A i r = {} & R i q = {}"

definition derive :: "[vertex, (vertex*vertex)set, (vertex*vertex)set]=>bool" where
    \<comment> \<open>Our alternative definition\<close>
  "derive i r q == A i r = {} & (q = reverse i r)"

axiomatization where
  finite_vertex_univ:  "finite (UNIV :: vertex set)"
    \<comment> \<open>we assume that the universe of vertices is finite\<close>

declare derive_def [simp] derive1_def [simp] symcl_def [simp]
        A_def [simp] R_def [simp]
        above_def [simp] reach_def [simp]
        reverse_def [simp] neighbors_def [simp]

text\<open>All vertex sets are finite\<close>
declare finite_subset [OF subset_UNIV finite_vertex_univ, iff]

text\<open>and relatons over vertex are finite too\<close>

lemmas finite_UNIV_Prod =
       finite_Prod_UNIV [OF finite_vertex_univ finite_vertex_univ]

declare finite_subset [OF subset_UNIV finite_UNIV_Prod, iff]

(* The equalities (above i r = {}) = (A i r = {})
   and (reach i r = {}) = (R i r) rely on the following theorem  *)

lemma image0_trancl_iff_image0_r: "((r\<^sup>+)``{i} = {}) = (r``{i} = {})"
apply auto
apply (erule trancl_induct, auto)
done

(* Another form usefull in some situation *)
lemma image0_r_iff_image0_trancl: "(r``{i}={}) = (\<forall>x. ((i,x) \<in> r\<^sup>+) = False)"
apply auto
apply (drule image0_trancl_iff_image0_r [THEN ssubst], auto)
done

(* In finite universe acyclic coincides with wf *)
lemma acyclic_eq_wf: "!!r::(vertex*vertex)set. acyclic r = wf r"
by (auto simp add: wf_iff_acyclic_if_finite)

(* derive and derive1 are equivalent *)
lemma derive_derive1_eq: "derive i r q = derive1 i r q"
by auto

(* Lemma 1 *)
lemma lemma1_a:
     "[| x \<in> reach i q; derive1 k r q |] ==> x\<noteq>k --> x \<in> reach i r"
apply (unfold reach_def)
apply (erule ImageE)
apply (erule trancl_induct)
 apply (cases "i=k", simp_all)
 apply (blast, blast, clarify)
apply (drule_tac x = y in spec)
apply (drule_tac x = z in spec)
apply (blast dest: r_into_trancl intro: trancl_trans)
done

lemma reach_lemma: "derive k r q ==> reach i q \<subseteq> (reach i r \<union> {k})"
apply clarify
apply (drule lemma1_a)
apply (auto simp add: derive_derive1_eq
            simp del: reach_def derive_def derive1_def)
done

(* An other possible formulation of the above theorem based on
   the equivalence x \<in> reach y r = y \<in> above x r                  *)
lemma reach_above_lemma:
      "(\<forall>i. reach i q \<subseteq> (reach i r \<union> {k})) =
       (\<forall>x. x\<noteq>k --> (\<forall>i. i \<notin> above x r --> i \<notin> above x q))"
by (auto simp add: trancl_converse)

(* Lemma 2 *)
lemma maximal_converse_image0:
     "(z, i) \<in> r\<^sup>+ \<Longrightarrow> (\<forall>y. (y, z) \<in> r \<longrightarrow> (y,i) \<notin> r\<^sup>+) = ((r\<inverse>)``{z}={})"
apply auto
apply (frule_tac r = r in trancl_into_trancl2, auto)
done

lemma above_lemma_a:
     "acyclic r ==> A i r\<noteq>{}-->(\<exists>j \<in> above i r. A j r = {})"
apply (simp add: acyclic_eq_wf wf_eq_minimal)
apply (drule_tac x = " ((r\<inverse>)\<^sup>+) ``{i}" in spec)
apply auto
apply (simp add: maximal_converse_image0 trancl_converse)
done

lemma above_lemma_b:
     "acyclic r ==> above i r\<noteq>{}-->(\<exists>j \<in> above i r. above j r = {})"
apply (drule above_lemma_a)
apply (auto simp add: image0_trancl_iff_image0_r)
done

end


(* Author: Tobias Nipkow *)

section {* Association List Update and Deletion *}

theory AList_Upd_Del
imports Sorted_Less
begin

abbreviation "sorted1 ps \<equiv> sorted(map fst ps)"

text{* Define own @{text map_of} function to avoid pulling in an unknown
amount of lemmas implicitly (via the simpset). *}

hide_const (open) map_of

fun map_of :: "('a*'b)list \<Rightarrow> 'a \<Rightarrow> 'b option" where
"map_of [] = (\<lambda>x. None)" |
"map_of ((a,b)#ps) = (\<lambda>x. if x=a then Some b else map_of ps x)"

text \<open>Updating an association list:\<close>

fun upd_list :: "'a::linorder \<Rightarrow> 'b \<Rightarrow> ('a*'b) list \<Rightarrow> ('a*'b) list" where
"upd_list x y [] = [(x,y)]" |
"upd_list x y ((a,b)#ps) =
  (if x < a then (x,y)#(a,b)#ps else
  if x = a then (x,y)#ps else (a,b) # upd_list x y ps)"

fun del_list :: "'a::linorder \<Rightarrow> ('a*'b)list \<Rightarrow> ('a*'b)list" where
"del_list x [] = []" |
"del_list x ((a,b)#ps) = (if x = a then ps else (a,b) # del_list x ps)"

subsection \<open>Lemmas for @{const map_of}\<close>

lemma map_of_ins_list: "map_of (upd_list x y ps) = (map_of ps)(x := Some y)"
by(induction ps) auto

lemma map_of_append: "map_of (ps @ qs) x =
  (case map_of ps x of None \<Rightarrow> map_of qs x | Some y \<Rightarrow> Some y)"
by(induction ps)(auto)

lemma map_of_None: "sorted (x # map fst ps) \<Longrightarrow> map_of ps x = None"
by (induction ps) (auto simp: sorted_lems sorted_Cons_iff)

lemma map_of_None2: "sorted (map fst ps @ [x]) \<Longrightarrow> map_of ps x = None"
by (induction ps) (auto simp: sorted_lems)

lemma map_of_del_list: "sorted1 ps \<Longrightarrow>
  map_of(del_list x ps) = (map_of ps)(x := None)"
by(induction ps) (auto simp: map_of_None sorted_lems fun_eq_iff)

lemma map_of_sorted_Cons: "sorted (a # map fst ps) \<Longrightarrow> x < a \<Longrightarrow>
   map_of ps x = None"
by (meson less_trans map_of_None sorted_Cons_iff)

lemma map_of_sorted_snoc: "sorted (map fst ps @ [a]) \<Longrightarrow> a \<le> x \<Longrightarrow>
  map_of ps x = None"
by (meson le_less_trans map_of_None2 not_less sorted_snoc_iff)

lemmas map_of_sorteds = map_of_sorted_Cons map_of_sorted_snoc
lemmas map_of_simps = sorted_lems map_of_append map_of_sorteds

subsection \<open>Lemmas for @{const upd_list}\<close>

lemma sorted_upd_list: "sorted1 ps \<Longrightarrow> sorted1 (upd_list x y ps)"
apply(induction ps)
 apply simp
apply(case_tac ps)
 apply auto
done

lemma upd_list_sorted: "sorted1 (ps @ [(a,b)]) \<Longrightarrow>
  upd_list x y (ps @ (a,b) # qs) =
    (if x < a then upd_list x y ps @ (a,b) # qs
    else ps @ upd_list x y ((a,b) # qs))"
by(induction ps) (auto simp: sorted_lems)

text\<open>In principle, @{thm upd_list_sorted} suffices, but the following two
corollaries speed up proofs.\<close>

corollary upd_list_sorted1: "\<lbrakk> sorted (map fst ps @ [a]); x < a \<rbrakk> \<Longrightarrow>
  upd_list x y (ps @ (a,b) # qs) =  upd_list x y ps @ (a,b) # qs"
by (auto simp: upd_list_sorted)

corollary upd_list_sorted2: "\<lbrakk> sorted (map fst ps @ [a]); a \<le> x \<rbrakk> \<Longrightarrow>
  upd_list x y (ps @ (a,b) # qs) = ps @ upd_list x y ((a,b) # qs)"
by (auto simp: upd_list_sorted)

lemmas upd_list_simps = sorted_lems upd_list_sorted1 upd_list_sorted2

text\<open>Splay trees need two additional @{const upd_list} lemmas:\<close>

lemma upd_list_Cons:
  "sorted1 ((x,y) # xs) \<Longrightarrow> upd_list x y xs = (x,y) # xs"
by (induction xs) auto

lemma upd_list_snoc:
  "sorted1 (xs @ [(x,y)]) \<Longrightarrow> upd_list x y xs = xs @ [(x,y)]"
by(induction xs) (auto simp add: sorted_mid_iff2)

subsection \<open>Lemmas for @{const del_list}\<close>

lemma sorted_del_list: "sorted1 ps \<Longrightarrow> sorted1 (del_list x ps)"
apply(induction ps)
 apply simp
apply(case_tac ps)
apply auto
by (meson order.strict_trans sorted_Cons_iff)

lemma del_list_idem: "x \<notin> set(map fst xs) \<Longrightarrow> del_list x xs = xs"
by (induct xs) auto

lemma del_list_sorted: "sorted1 (ps @ (a,b) # qs) \<Longrightarrow>
  del_list x (ps @ (a,b) # qs) =
    (if x < a then del_list x ps @ (a,b) # qs
     else ps @ del_list x ((a,b) # qs))"
by(induction ps)
  (fastforce simp: sorted_lems sorted_Cons_iff intro!: del_list_idem)+

text\<open>In principle, @{thm del_list_sorted} suffices, but the following
corollaries speed up proofs.\<close>

corollary del_list_sorted1: "sorted1 (xs @ (a,b) # ys) \<Longrightarrow> a \<le> x \<Longrightarrow>
  del_list x (xs @ (a,b) # ys) = xs @ del_list x ((a,b) # ys)"
by (auto simp: del_list_sorted)

lemma del_list_sorted2: "sorted1 (xs @ (a,b) # ys) \<Longrightarrow> x < a \<Longrightarrow>
  del_list x (xs @ (a,b) # ys) = del_list x xs @ (a,b) # ys"
by (auto simp: del_list_sorted)

lemma del_list_sorted3:
  "sorted1 (xs @ (a,a') # ys @ (b,b') # zs) \<Longrightarrow> x < b \<Longrightarrow>
  del_list x (xs @ (a,a') # ys @ (b,b') # zs) = del_list x (xs @ (a,a') # ys) @ (b,b') # zs"
by (auto simp: del_list_sorted sorted_lems)

lemma del_list_sorted4:
  "sorted1 (xs @ (a,a') # ys @ (b,b') # zs @ (c,c') # us) \<Longrightarrow> x < c \<Longrightarrow>
  del_list x (xs @ (a,a') # ys @ (b,b') # zs @ (c,c') # us) = del_list x (xs @ (a,a') # ys @ (b,b') # zs) @ (c,c') # us"
by (auto simp: del_list_sorted sorted_lems)

lemma del_list_sorted5:
  "sorted1 (xs @ (a,a') # ys @ (b,b') # zs @ (c,c') # us @ (d,d') # vs) \<Longrightarrow> x < d \<Longrightarrow>
   del_list x (xs @ (a,a') # ys @ (b,b') # zs @ (c,c') # us @ (d,d') # vs) =
   del_list x (xs @ (a,a') # ys @ (b,b') # zs @ (c,c') # us) @ (d,d') # vs"
by (auto simp: del_list_sorted sorted_lems)

lemmas del_list_simps = sorted_lems
  del_list_sorted1
  del_list_sorted2
  del_list_sorted3
  del_list_sorted4
  del_list_sorted5

text\<open>Splay trees need two additional @{const del_list} lemmas:\<close>

lemma del_list_notin_Cons: "sorted (x # map fst xs) \<Longrightarrow> del_list x xs = xs"
by(induction xs)(auto simp: sorted_Cons_iff)

lemma del_list_sorted_app:
  "sorted(map fst xs @ [x]) \<Longrightarrow> del_list x (xs @ ys) = xs @ del_list x ys"
by (induction xs) (auto simp: sorted_mid_iff2)

end