(*<*)
(*
 * The worker/wrapper transformation, following Gill and Hutton.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com, commenced December 2007.
 * License: BSD
 *)

theory WorkerWrapper
imports
  HOLCF
  FixedPointTheorems
begin

(*>*)
section\<open>The transformation according to Gill and Hutton\<close>

text\<open>

\begin{figure}[tb]
 \begin{center}
  \fbox{\parbox{0.96\textwidth}{For a recursive definition @{haskell "comp =
      \\mathsf{fix}\\ body"} for some @{haskell "body :: A \\to A"} and a pair of
      functions @{haskell "wrap :: B \\to A"} and @{haskell "unwrap :: A \\to B"} where
      @{haskell "wrap \\circ unwrap = id_A"}, we have:

      \parbox{0.35\textwidth}{\begin{haskell}
        comp = wrap\ work\\
        \quad work :: B\\
        \quad work = \mathsf{fix}\ (unwrap \circ body \circ wrap)
      \end{haskell}}\hfill \textsf{(the worker/wrapper transformation)}

      Also:

      \parbox{0.35\textwidth}{\begin{haskell}
        (unwrap \circ wrap)\ work = work
      \end{haskell}}\hfill \textsf{(worker/wrapper fusion)}}}%
 \end{center}%
 \caption{The worker/wrapper transformation and fusion rule of \<^citet>\<open>"GillHutton:2009"\<close>.}\label{fig:ww}
\end{figure}

The worker/wrapper transformation and associated fusion rule as
formalised by \citet*{GillHutton:2009} are reproduced in
Figure~\ref{fig:ww}, and the reader is referred to the original paper
for further motivation and background.

Armed with the rolling rule we can show that Gill and Hutton's
justification of the worker/wrapper transformation is sound. There is
a battery of these transformations with varying strengths of
hypothesis.

The first requires @{term "wrap oo unwrap"} to be the identity for all
values.

\<close>

lemma worker_wrapper_id:
  fixes wrap :: "'b::pcpo \<rightarrow> 'a::pcpo"
  fixes unwrap :: "'a \<rightarrow> 'b"
  assumes wrap_unwrap: "wrap oo unwrap = ID"
  assumes comp_body: "computation = fix\<cdot>body"
  shows "computation = wrap\<cdot>(fix\<cdot>(unwrap oo body oo wrap))"
proof -
  from comp_body have "computation = fix\<cdot>(ID oo body)"
    by simp
  also from wrap_unwrap have "\<dots> = fix\<cdot>(wrap oo unwrap oo body)"
    by (simp add: assoc_oo)
  also have "... = wrap\<cdot>(fix\<cdot>(unwrap oo body oo wrap))"
    using rolling_rule[where f="unwrap oo body" and g="wrap"]
    by (simp add: assoc_oo)
  finally show ?thesis .
qed

text\<open>

The second weakens this assumption by requiring that @{term "wrap oo
wrap"} only act as the identity on values in the image of @{term
"body"}.

\<close>

lemma worker_wrapper_body:
  fixes wrap :: "'b::pcpo \<rightarrow> 'a::pcpo"
  fixes unwrap :: "'a \<rightarrow> 'b"
  assumes wrap_unwrap: "wrap oo unwrap oo body = body"
  assumes comp_body: "computation = fix\<cdot>body"
  shows "computation = wrap\<cdot>(fix\<cdot>(unwrap oo body oo wrap))"
proof -
  from comp_body have "computation = fix\<cdot>(wrap oo unwrap oo body)"
    using wrap_unwrap by (simp add: assoc_oo wrap_unwrap)
  also have "... = wrap\<cdot>(fix\<cdot>(unwrap oo body oo wrap))"
    using rolling_rule[where f="unwrap oo body" and g="wrap"]
    by (simp add: assoc_oo)
  finally show ?thesis .
qed

text\<open>

This is particularly useful when the computation being transformed is
strict in its argument.

Finally we can allow the identity to take the full recursive context
into account. This rule was described by Gill and Hutton but not used.

\<close>

lemma worker_wrapper_fix:
  fixes wrap :: "'b::pcpo \<rightarrow> 'a::pcpo"
  fixes unwrap :: "'a \<rightarrow> 'b"
  assumes wrap_unwrap: "fix\<cdot>(wrap oo unwrap oo body) = fix\<cdot>body"
  assumes comp_body: "computation = fix\<cdot>body"
  shows "computation = wrap\<cdot>(fix\<cdot>(unwrap oo body oo wrap))"
proof -
  from comp_body have "computation = fix\<cdot>(wrap oo unwrap oo body)"
    using wrap_unwrap by (simp add: assoc_oo wrap_unwrap)
  also have "... = wrap\<cdot>(fix\<cdot>(unwrap oo body oo wrap))"
    using rolling_rule[where f="unwrap oo body" and g="wrap"]
    by (simp add: assoc_oo)
  finally show ?thesis .
qed

text\<open>

Gill and Hutton's \<open>worker_wrapper_fusion\<close> rule is intended to
allow the transformation of @{term "(unwrap oo wrap)\<cdot>R"} to @{term
"R"} in recursive contexts, where @{term "R"} is meant to be a
self-call. Note that it assumes that the first worker/wrapper
hypothesis can be established.

\<close>

lemma worker_wrapper_fusion:
  fixes wrap :: "'b::pcpo \<rightarrow> 'a::pcpo"
  fixes unwrap :: "'a \<rightarrow> 'b"
  assumes wrap_unwrap: "wrap oo unwrap = ID"
  assumes work: "work = fix\<cdot>(unwrap oo body oo wrap)"
  shows "(unwrap oo wrap)\<cdot>work = work"
proof -
  have "(unwrap oo wrap)\<cdot>work = (unwrap oo wrap)\<cdot>(fix\<cdot>(unwrap oo body oo wrap))"
    using work by simp
  also have "\<dots> = (unwrap oo wrap)\<cdot>(fix\<cdot>(unwrap oo body oo wrap oo unwrap oo wrap))"
    using wrap_unwrap by (simp add: assoc_oo)
  also have "\<dots> = fix\<cdot>(unwrap oo wrap oo unwrap oo body oo wrap)"
    using rolling_rule[where f="unwrap oo body oo wrap" and g="unwrap oo wrap"]
    by (simp add: assoc_oo)
  also have "\<dots> = fix\<cdot>(unwrap oo body oo wrap)"
    using wrap_unwrap by (simp add: assoc_oo)
  finally show ?thesis using work by simp
qed

text\<open>

The following sections show that this rule only preserves partial
correctness. This is because Gill and Hutton apply it in the context
of the fold/unfold program transformation framework of
\citet*{BurstallDarlington:1977}, which need not preserve termination.
We show that the fusion rule does in fact require extra conditions to
be totally correct and propose one such sufficient condition.

\<close>
(*<*)

end
(*>*)


(*
  File:     Power_Sum_Polynomials_Library.thy
  Author:   Manuel Eberl, TU München
*)
section \<open>Auxiliary material\<close>
theory Power_Sum_Polynomials_Library
imports
  "Polynomial_Factorization.Fundamental_Theorem_Algebra_Factorized"
  "Symmetric_Polynomials.Symmetric_Polynomials"
  "HOL-Computational_Algebra.Computational_Algebra"
begin

unbundle multiset.lifting

subsection \<open>Miscellaneous\<close>

lemma atLeastAtMost_nat_numeral:
  "atLeastAtMost m (numeral k :: nat) =
     (if m \<le> numeral k then insert (numeral k) (atLeastAtMost m (pred_numeral k))
                 else {})"
  by (simp add: numeral_eq_Suc atLeastAtMostSuc_conv)

lemma sum_in_Rats [intro]: "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> \<rat>) \<Longrightarrow> sum f A \<in> \<rat>"
  by (induction A rule: infinite_finite_induct) auto

(* TODO Move *)
lemma (in monoid_mult) prod_list_distinct_conv_prod_set:
  "distinct xs \<Longrightarrow> prod_list (map f xs) = prod f (set xs)"
  by (induct xs) simp_all

lemma (in monoid_mult) interv_prod_list_conv_prod_set_nat:
  "prod_list (map f [m..<n]) = prod f (set [m..<n])"
  by (simp add: prod_list_distinct_conv_prod_set)

lemma (in monoid_mult) prod_list_prod_nth:
  "prod_list xs = (\<Prod>i = 0..< length xs. xs ! i)"
  using interv_prod_list_conv_prod_set_nat [of "(!) xs" 0 "length xs"] by (simp add: map_nth)

lemma gcd_poly_code_aux_reduce:
  "gcd_poly_code_aux p 0 = normalize p"
  "q \<noteq> 0 \<Longrightarrow> gcd_poly_code_aux p q = gcd_poly_code_aux q (primitive_part (pseudo_mod p q))"
  by (subst gcd_poly_code_aux.simps; simp)+

lemma coprime_pderiv_imp_squarefree:
  assumes "coprime p (pderiv p)"
  shows   "squarefree p"
proof (rule squarefreeI)
  fix d assume d: "d ^ 2 dvd p"
  then obtain q where q: "p = d ^ 2 * q"
    by (elim dvdE)
  hence "d dvd p" "d dvd pderiv p"
    by (auto simp: pderiv_mult pderiv_power_Suc numeral_2_eq_2)
  with assms show "is_unit d"
    using not_coprimeI by blast
qed

lemma squarefree_field_poly_iff:
  fixes p :: "'a :: {field_char_0,euclidean_ring_gcd,semiring_gcd_mult_normalize} poly"
  assumes [simp]: "p \<noteq> 0"
  shows "squarefree p \<longleftrightarrow> coprime p (pderiv p)"
proof
  assume "squarefree p"
  show "coprime p (pderiv p)"
  proof (rule coprimeI_primes)
    fix d assume d: "d dvd p" "d dvd pderiv p" "prime d"
    from d(1) obtain q where q: "p = d * q"
      by (elim dvdE)
    from d(2) and q have "d dvd q * pderiv d"
      by (simp add: pderiv_mult dvd_add_right_iff)
    with \<open>prime d\<close> have "d dvd q \<or> d dvd pderiv d"
      using prime_dvd_mult_iff by blast
    thus False
    proof
      assume "d dvd q"
      hence "d ^ 2 dvd p"
        by (auto simp: q power2_eq_square)
      with \<open>squarefree p\<close> show False
        using d(3) not_prime_unit squarefreeD by blast
    next
      assume "d dvd pderiv d"
      hence "Polynomial.degree d = 0" by simp
      moreover have "d \<noteq> 0" using d by auto
      ultimately show False
        using d(3) is_unit_iff_degree not_prime_unit by blast
    qed
  qed auto
qed (use coprime_pderiv_imp_squarefree[of p] in auto)

lemma coprime_pderiv_imp_rsquarefree:
  assumes "coprime (p :: 'a :: field_char_0 poly) (pderiv p)"
  shows   "rsquarefree p"
  unfolding rsquarefree_roots
proof safe
  fix x assume "poly p x = 0" "poly (pderiv p) x = 0"
  hence "[:-x, 1:] dvd p" "[:-x, 1:] dvd pderiv p"
    by (auto simp: poly_eq_0_iff_dvd)
  with assms have "is_unit [:-x, 1:]"
    using not_coprimeI by blast
  thus False by auto
qed

lemma poly_of_nat [simp]: "poly (of_nat n) x = of_nat n"
  by (induction n) auto

lemma poly_of_int [simp]: "poly (of_int n) x = of_int n"
  by (cases n) auto

lemma order_eq_0_iff: "p \<noteq> 0 \<Longrightarrow> order x p = 0 \<longleftrightarrow> poly p x \<noteq> 0"
  by (auto simp: order_root)

lemma order_pos_iff: "p \<noteq> 0 \<Longrightarrow> order x p > 0 \<longleftrightarrow> poly p x = 0"
  by (auto simp: order_root)

lemma order_prod:
  assumes "\<And>x. x \<in> A \<Longrightarrow> f x \<noteq> 0"
  shows   "order x (\<Prod>y\<in>A. f y) = (\<Sum>y\<in>A. order x (f y))"
  using assms by (induction A rule: infinite_finite_induct) (auto simp: order_mult)

lemma order_prod_mset:
  assumes "0 \<notin># A"
  shows   "order x (prod_mset A) = sum_mset (image_mset (order x) A)"
  using assms by (induction A) (auto simp: order_mult)

lemma order_prod_list:
  assumes "0 \<notin> set xs"
  shows   "order x (prod_list xs) = sum_list (map (order x) xs)"
  using assms by (induction xs) (auto simp: order_mult)

lemma order_power: "p \<noteq> 0 \<Longrightarrow> order x (p ^ n) = n * order x p"
  by (induction n) (auto simp: order_mult)

lemma smult_0_right [simp]: "MPoly_Type.smult p 0 = 0"
  by (transfer, transfer) auto

lemma mult_smult_right [simp]:
  fixes c :: "'a :: comm_semiring_0"
  shows "p * MPoly_Type.smult c q = MPoly_Type.smult c (p * q)"
  by (simp add: smult_conv_mult mult_ac)

lemma mapping_single_eq_iff [simp]:
  "Poly_Mapping.single a b = Poly_Mapping.single c d \<longleftrightarrow> b = 0 \<and> d = 0 \<or> a = c \<and> b = d"
  by transfer (unfold fun_eq_iff when_def, metis)

lemma monom_of_set_plus_monom_of_set:
  assumes "A \<inter> B = {}" "finite A" "finite B"
  shows   "monom_of_set A + monom_of_set B = monom_of_set (A \<union> B)"
  using assms by transfer (auto simp: fun_eq_iff)

lemma mpoly_monom_0_eq_Const: "monom 0 c = Const c"
  by (intro mpoly_eqI) (auto simp: coeff_monom when_def mpoly_coeff_Const)

lemma mpoly_Const_0 [simp]: "Const 0 = 0"
  by (intro mpoly_eqI) (auto simp: mpoly_coeff_Const mpoly_coeff_0)

lemma mpoly_Const_1 [simp]: "Const 1 = 1"
  by (intro mpoly_eqI) (auto simp: mpoly_coeff_Const mpoly_coeff_1)

lemma mpoly_Const_uminus: "Const (-a) = -Const a"
  by (intro mpoly_eqI) (auto simp: mpoly_coeff_Const)

lemma mpoly_Const_add: "Const (a + b) = Const a + Const b"
  by (intro mpoly_eqI) (auto simp: mpoly_coeff_Const)

lemma mpoly_Const_mult: "Const (a * b) = Const a * Const b"
  unfolding mpoly_monom_0_eq_Const [symmetric] mult_monom by simp

lemma mpoly_Const_power: "Const (a ^ n) = Const a ^ n"
  by (induction n) (auto simp: mpoly_Const_mult)

lemma of_nat_mpoly_eq: "of_nat n = Const (of_nat n)"
proof (induction n)
  case 0
  have "0 = (Const 0 :: 'a mpoly)"
    by (intro mpoly_eqI) (auto simp: mpoly_coeff_Const)
  thus ?case
    by simp
next
  case (Suc n)
  have "1 + Const (of_nat n) = Const (1 + of_nat n)"
    by (intro mpoly_eqI) (auto simp: mpoly_coeff_Const mpoly_coeff_1)
  thus ?case
    using Suc by auto
qed

lemma insertion_of_nat [simp]: "insertion f (of_nat n) = of_nat n"
  by (simp add: of_nat_mpoly_eq)

lemma insertion_monom_of_set [simp]:
  "insertion f (monom (monom_of_set X) c) = c * (\<Prod>i\<in>X. f i)"
proof (cases "finite X")
  case [simp]: True
  have "insertion f (monom (monom_of_set X) c) = c * (\<Prod>a. f a ^ (if a \<in> X then 1 else 0))"
    by (auto simp: lookup_monom_of_set)
  also have "(\<Prod>a. f a ^ (if a \<in> X then 1 else 0)) = (\<Prod>i\<in>X. f i ^ (if i \<in> X then 1 else 0))"
    by (intro Prod_any.expand_superset) auto
  also have "\<dots> = (\<Prod>i\<in>X. f i)"
    by (intro prod.cong) auto
  finally show ?thesis .
qed (auto simp: lookup_monom_of_set)

(* TODO: Move! Version in AFP is too weak! *)
lemma symmetric_mpoly_symmetric_sum:
  assumes "\<And>\<pi>. \<pi> permutes A \<Longrightarrow> g \<pi> permutes X"
  assumes "\<And>x \<pi>. x \<in> X \<Longrightarrow> \<pi> permutes A \<Longrightarrow> mpoly_map_vars \<pi> (f x) = f (g \<pi> x)"
  shows "symmetric_mpoly A (\<Sum>x\<in>X. f x)"
  unfolding symmetric_mpoly_def
proof safe
  fix \<pi> assume \<pi>: "\<pi> permutes A"
  have "mpoly_map_vars \<pi> (sum f X) = (\<Sum>x\<in>X. mpoly_map_vars \<pi> (f x))"
    by simp
  also have "\<dots> = (\<Sum>x\<in>X. f (g \<pi> x))"
    by (intro sum.cong assms \<pi> refl)
  also have "\<dots> = (\<Sum>x\<in>g \<pi>`X. f x)"
    using assms(1)[OF \<pi>] by (subst sum.reindex) (auto simp: permutes_inj_on)
  also have "g \<pi> ` X = X"
    using assms(1)[OF \<pi>] by (simp add: permutes_image)
  finally show "mpoly_map_vars \<pi> (sum f X) = sum f X" .
qed

lemma sym_mpoly_0 [simp]:
  assumes "finite A"
  shows   "sym_mpoly A 0 = 1"
  using assms by (transfer, transfer) (auto simp: fun_eq_iff when_def)

lemma sym_mpoly_eq_0 [simp]:
  assumes "k > card A"
  shows   "sym_mpoly A k = 0"
proof (transfer fixing: A k, transfer fixing: A k, intro ext)
  fix mon
  have "\<not>(finite A \<and> (\<exists>Y\<subseteq>A. card Y = k \<and> mon = monom_of_set Y))"
  proof safe
    fix Y assume Y: "finite A" "Y \<subseteq> A" "k = card Y" "mon = monom_of_set Y"
    hence "card Y \<le> card A" by (intro card_mono) auto
    with Y and assms show False by simp
  qed
  thus "(if finite A \<and> (\<exists>Y\<subseteq>A. card Y = k \<and> mon = monom_of_set Y) then 1 else 0) = 0"
    by auto
qed

lemma coeff_sym_mpoly_monom_of_set_eq_0:
  assumes "finite X" "Y \<subseteq> X" "card Y \<noteq> k"
  shows   "MPoly_Type.coeff (sym_mpoly X k) (monom_of_set Y) = 0"
  using assms finite_subset[of _ X] by (auto simp: coeff_sym_mpoly)

lemma coeff_sym_mpoly_monom_of_set_eq_0':
  assumes "finite X" "\<not>Y \<subseteq> X" "finite Y"
  shows   "MPoly_Type.coeff (sym_mpoly X k) (monom_of_set Y) = 0"
  using assms finite_subset[of _ X] by (auto simp: coeff_sym_mpoly)

subsection \<open>The set of roots of a univariate polynomial\<close>

lift_definition poly_roots :: "'a :: idom poly \<Rightarrow> 'a multiset" is
  "\<lambda>p x. if p = 0 then 0 else order x p"
proof -
  fix p :: "'a poly"
  show "finite {x. 0 < (if p = 0 then 0 else order x p)}"
    by (cases "p = 0") (auto simp: order_pos_iff poly_roots_finite)
qed

lemma poly_roots_0 [simp]: "poly_roots 0 = {#}"
  by transfer auto

lemma poly_roots_1 [simp]: "poly_roots 1 = {#}"
  by transfer auto

lemma count_poly_roots [simp]:
  assumes "p \<noteq> 0"
  shows   "count (poly_roots p) x = order x p"
  using assms by transfer auto

lemma in_poly_roots_iff [simp]: "p \<noteq> 0 \<Longrightarrow> x \<in># poly_roots p \<longleftrightarrow> poly p x = 0"
  by (subst count_greater_zero_iff [symmetric], subst count_poly_roots) (auto simp: order_pos_iff)

lemma set_mset_poly_roots: "p \<noteq> 0 \<Longrightarrow> set_mset (poly_roots p) = {x. poly p x = 0}"
  using in_poly_roots_iff[of p] by blast

lemma count_poly_roots': "count (poly_roots p) x = (if p = 0 then 0 else order x p)"
  by transfer' auto

lemma poly_roots_const [simp]: "poly_roots [:c:] = {#}"
  by (intro multiset_eqI) (auto simp: count_poly_roots' order_eq_0_iff)

lemma poly_roots_linear [simp]: "poly_roots [:-x, 1:] = {#x#}"
  by (intro multiset_eqI) (auto simp: count_poly_roots' order_eq_0_iff)

lemma poly_roots_monom [simp]: "c \<noteq> 0 \<Longrightarrow> poly_roots (Polynomial.monom c n) = replicate_mset n 0"
  by (intro multiset_eqI) (auto simp: count_poly_roots' order_eq_0_iff poly_monom)

lemma poly_roots_smult [simp]: "c \<noteq> 0 \<Longrightarrow> poly_roots (Polynomial.smult c p) = poly_roots p"
  by (intro multiset_eqI) (auto simp: count_poly_roots' order_smult)

lemma poly_roots_mult: "p \<noteq> 0 \<Longrightarrow> q \<noteq> 0 \<Longrightarrow> poly_roots (p * q) = poly_roots p + poly_roots q"
  by (intro multiset_eqI) (auto simp: count_poly_roots' order_mult)

lemma poly_roots_prod:
  assumes "\<And>x. x \<in> A \<Longrightarrow> f x \<noteq> 0"
  shows   "poly_roots (prod f A) = (\<Sum>x\<in>A. poly_roots (f x))"
  using assms by (induction A rule: infinite_finite_induct) (auto simp: poly_roots_mult)

lemma poly_roots_prod_mset:
  assumes "0 \<notin># A"
  shows   "poly_roots (prod_mset A) = sum_mset (image_mset poly_roots A)"
  using assms by (induction A) (auto simp: poly_roots_mult)

lemma poly_roots_prod_list:
  assumes "0 \<notin> set xs"
  shows   "poly_roots (prod_list xs) = sum_list (map poly_roots xs)"
  using assms by (induction xs) (auto simp: poly_roots_mult)

lemma poly_roots_power: "p \<noteq> 0 \<Longrightarrow> poly_roots (p ^ n) = repeat_mset n (poly_roots p)"
  by (induction n) (auto simp: poly_roots_mult)

lemma rsquarefree_poly_roots_eq:
  assumes "rsquarefree p"
  shows   "poly_roots p = mset_set {x. poly p x = 0}"
proof (rule multiset_eqI)
  fix x :: 'a
  from assms show "count (poly_roots p) x = count (mset_set {x. poly p x = 0}) x"
    by (cases "poly p x = 0") (auto simp: poly_roots_finite order_eq_0_iff rsquarefree_def)
qed

lemma rsquarefree_imp_distinct_roots:
  assumes "rsquarefree p" and "mset xs = poly_roots p"
  shows   "distinct xs"
proof (cases "p = 0")
  case [simp]: False
  have *: "mset xs = mset_set {x. poly p x = 0}"
    using assms by (simp add: rsquarefree_poly_roots_eq)
  hence "set_mset (mset xs) = set_mset (mset_set {x. poly p x = 0})"
    by (simp only: )
  hence [simp]: "set xs = {x. poly p x = 0}"
    by (simp add: poly_roots_finite)
  from * show ?thesis
    by (subst distinct_count_atmost_1) (auto simp: poly_roots_finite)
qed (use assms in auto)

lemma poly_roots_factorization:
  fixes p c A
  assumes [simp]: "c \<noteq> 0"
  defines "p \<equiv> Polynomial.smult c (prod_mset (image_mset (\<lambda>x. [:-x, 1:]) A))"
  shows   "poly_roots p = A"
proof -
  have "poly_roots p = poly_roots (\<Prod>x\<in>#A. [:-x, 1:])"
    by (auto simp: p_def)
  also have "\<dots> = A"
    by (subst poly_roots_prod_mset) (auto simp: image_mset.compositionality o_def)
  finally show ?thesis .
qed

lemma fundamental_theorem_algebra_factorized':
  fixes p :: "complex poly"
  shows "p = Polynomial.smult (Polynomial.lead_coeff p)
               (prod_mset (image_mset (\<lambda>x. [:-x, 1:]) (poly_roots p)))"
proof (cases "p = 0")
  case [simp]: False
  obtain xs where
    xs: "Polynomial.smult (Polynomial.lead_coeff p) (\<Prod>x\<leftarrow>xs. [:-x, 1:]) = p"
        "length xs = Polynomial.degree p"
    using fundamental_theorem_algebra_factorized[of p] by auto
  define A where "A = mset xs"

  note xs(1)
  also have "(\<Prod>x\<leftarrow>xs. [:-x, 1:]) = prod_mset (image_mset (\<lambda>x. [:-x, 1:]) A)"
    unfolding A_def by (induction xs) auto
  finally have *: "Polynomial.smult (Polynomial.lead_coeff p) (\<Prod>x\<in>#A. [:- x, 1:]) = p" .
  also have "A = poly_roots p"
    using poly_roots_factorization[of "Polynomial.lead_coeff p" A]
    by (subst * [symmetric]) auto
  finally show ?thesis ..
qed auto

lemma poly_roots_eq_imp_eq:
  fixes p q :: "complex poly"
  assumes "Polynomial.lead_coeff p = Polynomial.lead_coeff q"
  assumes "poly_roots p = poly_roots q"
  shows   "p = q"
proof (cases "p = 0 \<or> q = 0")
  case False
  hence [simp]: "p \<noteq> 0" "q \<noteq> 0"
    by auto
  have "p = Polynomial.smult (Polynomial.lead_coeff p)
               (prod_mset (image_mset (\<lambda>x. [:-x, 1:]) (poly_roots p)))"
    by (rule fundamental_theorem_algebra_factorized')
  also have "\<dots> = Polynomial.smult (Polynomial.lead_coeff q)
                   (prod_mset (image_mset (\<lambda>x. [:-x, 1:]) (poly_roots q)))"
    by (simp add: assms)
  also have "\<dots> = q"
    by (rule fundamental_theorem_algebra_factorized' [symmetric])
  finally show ?thesis .
qed (use assms in auto)

lemma Sum_any_zeroI': "(\<And>x. P x \<Longrightarrow> f x = 0) \<Longrightarrow> Sum_any (\<lambda>x. f x when P x) = 0"
  by (auto simp: Sum_any.expand_set)

(* TODO: This was not really needed here, but it is important nonetheless.
   It should go in the Symmetric_Polynomials entry. *)
lemma sym_mpoly_insert:
  assumes "finite X" "x \<notin> X"
  shows   "(sym_mpoly (insert x X) (Suc k) :: 'a :: semiring_1 mpoly) =
             monom (monom_of_set {x}) 1 * sym_mpoly X k + sym_mpoly X (Suc k)" (is "?lhs = ?A + ?B")
proof (rule mpoly_eqI)
  fix mon
  show "coeff ?lhs mon = coeff (?A + ?B) mon"
  proof (cases "\<forall>i. lookup mon i \<le> 1 \<and> (i \<notin> insert x X \<longrightarrow> lookup mon i = 0)")
    case False
    then obtain i where i: "lookup mon i > 1 \<or> i \<notin> insert x X \<and> lookup mon i > 0"
      by (auto simp: not_le)

    have "coeff ?A mon = prod_fun (coeff (monom (monom_of_set {x}) 1))
                                  (coeff (sym_mpoly X k)) mon"
      by (simp add: coeff_mpoly_times)
    also have "\<dots> = (\<Sum>l. \<Sum>q. coeff (monom (monom_of_set {x}) 1) l * coeff (sym_mpoly X k) q
                         when mon = l + q)"
        unfolding prod_fun_def
        by (intro Sum_any.cong, subst Sum_any_right_distrib, force)
           (auto simp: Sum_any_right_distrib when_def intro!: Sum_any.cong)
    also have "\<dots> = 0"
    proof (rule Sum_any_zeroI, rule Sum_any_zeroI')
      fix ma mb assume *: "mon = ma + mb"
      show "coeff (monom (monom_of_set {x}) (1::'a)) ma * coeff (sym_mpoly X k) mb = 0"
      proof (cases "i = x")
        case [simp]: True
        show ?thesis
        proof (cases "lookup mb i > 0")
          case True
          hence "coeff (sym_mpoly X k) mb = 0" using \<open>x \<notin> X\<close>
            by (auto simp: coeff_sym_mpoly lookup_monom_of_set split: if_splits)
          thus ?thesis
            using mult_not_zero by blast
        next
          case False
          hence "coeff (monom (monom_of_set {x}) 1) ma = 0"
            using i by (auto simp: coeff_monom when_def * lookup_add)
          thus ?thesis
            using mult_not_zero by blast
        qed
      next
        case [simp]: False
        show ?thesis
        proof (cases "lookup ma i > 0")
          case False
          hence "lookup mb i = lookup mon i"
            using * by (auto simp: lookup_add)
          hence "coeff (sym_mpoly X k) mb = 0" using i
            by (auto simp: coeff_sym_mpoly lookup_monom_of_set split: if_splits)
          thus ?thesis
            using mult_not_zero by blast
        next
          case True
          hence "coeff (monom (monom_of_set {x}) 1) ma = 0"
            using i by (auto simp: coeff_monom when_def * lookup_add)
          thus ?thesis
            using mult_not_zero by blast
        qed
      qed
    qed
    finally have "coeff ?A mon = 0" .
    moreover from False have "coeff ?lhs mon = 0"
      by (subst coeff_sym_mpoly) (auto simp: lookup_monom_of_set split: if_splits)
    moreover from False have "coeff (sym_mpoly X (Suc k)) mon = 0"
      by (subst coeff_sym_mpoly) (auto simp: lookup_monom_of_set split: if_splits)
    ultimately show ?thesis
      by auto
  next
    case True
    define A where "A = keys mon"
    have A: "A \<subseteq> insert x X"
      using True by (auto simp: A_def)
    have [simp]: "mon = monom_of_set A"
      unfolding A_def using True by transfer (force simp: fun_eq_iff le_Suc_eq)
    have "finite A"
      using finite_subset A assms by blast
    show ?thesis
    proof (cases "x \<in> A")
      case False
      have "coeff ?A mon = prod_fun (coeff (monom (monom_of_set {x}) 1))
                                    (coeff (sym_mpoly X k)) (monom_of_set A)"
        by (simp add: coeff_mpoly_times)
      also have "\<dots> = (\<Sum>l. \<Sum>q. coeff (monom (monom_of_set {x}) 1) l * coeff (sym_mpoly X k) q
                         when monom_of_set A = l + q)"
        unfolding prod_fun_def
        by (intro Sum_any.cong, subst Sum_any_right_distrib, force)
           (auto simp: Sum_any_right_distrib when_def intro!: Sum_any.cong)
      also have "\<dots> = 0"
      proof (rule Sum_any_zeroI, rule Sum_any_zeroI')
        fix ma mb assume *: "monom_of_set A = ma + mb"
        hence "keys ma \<subseteq> A"
          using \<open>finite A\<close> by transfer (auto simp: fun_eq_iff split: if_splits)
        thus "coeff (monom (monom_of_set {x}) (1::'a)) ma * coeff (sym_mpoly X k) mb = 0"
          using \<open>x \<notin> A\<close> by (auto simp: coeff_monom when_def)
      qed
      finally show ?thesis
        using False A assms finite_subset[of _ "insert x X"] finite_subset[of _ X]
        by (auto simp: coeff_sym_mpoly)
    next
      case True
      have "mon = monom_of_set {x} + monom_of_set (A - {x})"
        using \<open>x \<in> A\<close> \<open>finite A\<close> by (auto simp: monom_of_set_plus_monom_of_set)
      also have "coeff ?A \<dots> = coeff (sym_mpoly X k) (monom_of_set (A - {x}))"
        by (subst coeff_monom_mult) auto
      also have "\<dots> = (if card A = Suc k then 1 else 0)"
      proof (cases "card A = Suc k")
        case True
        thus ?thesis
          using assms \<open>finite A\<close> \<open>x \<in> A\<close> A
          by (subst coeff_sym_mpoly_monom_of_set) auto
      next
        case False
        thus ?thesis
          using assms \<open>x \<in> A\<close> A \<open>finite A\<close> card_Suc_Diff1[of A x]
          by (subst coeff_sym_mpoly_monom_of_set_eq_0) auto
      qed
      moreover have "coeff ?B (monom_of_set A) = 0"
        using assms \<open>x \<in> A\<close> \<open>finite A\<close>
        by (subst coeff_sym_mpoly_monom_of_set_eq_0') auto
      moreover have "coeff ?lhs (monom_of_set A) = (if card A = Suc k then 1 else 0)"
        using assms A \<open>finite A\<close> finite_subset[of _ "insert x X"] by (auto simp: coeff_sym_mpoly)
      ultimately show ?thesis by simp
    qed
  qed
qed

lifting_update multiset.lifting
lifting_forget multiset.lifting

end


subsection \<open>Existential quantification is Diophantine\<close>

theory Existential_Quantifier
  imports Diophantine_Relations
begin

lemma exist_list_dioph[dioph]:
  fixes D
  assumes "is_dioph_rel D"
  shows "is_dioph_rel ([\<exists>n] D)"
proof (induction n)
  case 0
  then show ?case
    using assms unfolding is_dioph_rel_def by (auto simp: push_list_empty)
next
  case (Suc n)

  have h: "(\<lambda>i. if i = 0 then v 0 else v i) = v" for v::assignment
    by auto

  have "eval ([\<exists>Suc n] D) a = (\<exists>k::nat. eval ([\<exists>n] D) (push a k))" for a
    apply (simp add: push_list2)
    by (smt (z3) Zero_not_Suc add_Suc_right append_Nil2 length_Cons
                 length_append list.size(3) nat.inject rev_exhaust)
  moreover from Suc is_dioph_rel_def obtain P\<^sub>1 P\<^sub>2 where
    "\<forall>a. eval ([\<exists>n] D) a = (\<exists>v. ppeval P\<^sub>1 a v = ppeval P\<^sub>2 a v)"
    by auto
  ultimately have t1: "eval ([\<exists>Suc n] D) a = (\<exists>k::nat. (\<exists>v. ppeval P\<^sub>1 (push a k) v
                                                            = ppeval P\<^sub>2 (push a k) v))" for a
    by simp

  define f :: "ppolynomial \<Rightarrow> ppolynomial" where
    "f \<equiv> \<lambda>P. pull_param (push_var P 1) (Var 0)"
  have "ppeval P (push a k) v = ppeval (f P) a (push v k)" for P a k v
    apply (induction P, auto simp: push_def f_def)
    by (metis (no_types, lifting) Suc_pred ppeval.simps(2) pull_param.simps(2))
  then have t2: "eval ([\<exists>Suc n] D) a = (\<exists>k::nat. (\<exists>v. ppeval (f P\<^sub>1) a (push v k)
                                                      = ppeval (f P\<^sub>2) a (push v k)))" for a
    using t1 by auto
  moreover have "(\<exists>k::nat. \<exists>v. ppeval P a (push v k) = ppeval Q a (push v k))
                  \<longleftrightarrow> (\<exists>v. ppeval P a v = ppeval Q a v)" for P Q a
    unfolding push_def
    apply auto
    subgoal for v
      apply (rule exI[of _ "v 0"])
      apply (rule exI[of _ "\<lambda>i. v (i + 1)"])
      by (auto simp: h cong: if_cong)
    done
  ultimately have "eval ([\<exists>Suc n] D) a = (\<exists>v. ppeval (f P\<^sub>1) a v = ppeval (f P\<^sub>2) a v)" for a
    by auto

  thus ?case
    unfolding is_dioph_rel_def by auto
qed

lemma exist_dioph[dioph]:
  fixes D
  assumes "is_dioph_rel D"
  shows "is_dioph_rel ([\<exists>] D)"
  unfolding EXIST_def using assms by (auto simp: exist_list_dioph)

lemma exist_eval[defs]:
  shows "eval ([\<exists>] D) a = (\<exists>k. eval D (push a k))"
  unfolding EXIST_def apply (simp add: push_list_def)
  by (metis length_Suc_conv list.exhaust list.size(3) nat.simps(3) push_list_singleton)

end


theory "Correctness-Counterexample"
imports "Denotational" Launchbury
begin

text {* In this theory we show that Theorem 2 in Launchbury's original paper \cite{launchbury} does not hold if one
takes @{text "\<squnion>"} to mean the least upper bound, by giving a counter example. *}

(* TODO: State using HSem, not USemUpd *)

theorem counterexample:
  assumes correct: "
    \<And> \<Gamma> e L \<Delta> z \<rho>.
    \<lbrakk> \<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z;
     distinctVars \<Gamma>;
     fdom \<rho> - heapVars \<Gamma> \<subseteq> set L
    \<rbrakk> \<Longrightarrow>
    \<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub> = \<lbrakk>z\<rbrakk>\<^bsub>\<lbrace>\<Delta>\<rbrace>\<rho>\<^esub>"
  shows False
proof-
  txt {* We need several variables; for two of them we require that they are different from each other. *}
  obtain x :: var where True by metis
  obtain a :: var where True by metis
  obtain b :: var where "atom b \<sharp> a" by (rule obtain_fresh)
    hence [simp]:"b \<noteq> a" by (simp add: fresh_at_base)

  txt {* Two distinct, but compatible elements of type @{typ Value}. *}
  def id \<equiv> "Fn\<cdot>(\<Lambda> x. x)"
  def const \<equiv> "\<lambda> y. Fn\<cdot>(\<Lambda> x. y)"
  have "const id \<down>Fn id \<noteq> const \<bottom> \<down>Fn id"
    by (simp only: const_def id_def Fn_project.simps beta_cfun cont2cont Value.con_rews not_False_eq_True)
  hence "const id \<noteq> const \<bottom>" by auto
  have [simp]:"compatible (const id) (const \<bottom>)"
    by (auto intro: compatibleI[where z = "const id"] simp add: const_def id_def)

  txt {* This is how we instantiate the theorem. *}
  def e \<equiv> "Var x"
  def z \<equiv> "Lam [a]. let b be Var b in Var b"
  def \<Gamma> \<equiv> "[(x, z)]"
  def \<Delta> \<equiv> "[(x, z)]"
  def \<rho> \<equiv> "fempty( x f\<mapsto> const id )"

  txt {* Establish the denotation of our terms (this involves picking fresh variables). *}
  have [simp]: "\<And> \<rho>. \<lbrakk>let b be Var b in Var b\<rbrakk>\<^bsub>\<rho>\<^esub> = \<bottom>"
  proof-
    fix \<rho> :: Env

    obtain b' :: var where fresh: "atom b' \<sharp> (b,\<rho>)" by (rule obtain_fresh)
    hence "b' \<noteq> b" "atom b' \<sharp> \<rho>" and [simp]: "b' \<notin> fdom \<rho>"
      by (auto simp add: fresh_Pair fresh_at_base fresh_fmap_pure)

    have "let b be Var b in Var b = let b' be Var b' in Var b'"
      apply simp
      apply (subst Abs_swap2[where a = "atom b" and b = "atom b'"])
      apply (auto simp add: exp_assn.bn_defs exp_assn.supp supp_Pair supp_at_base)
      done
    also
    have "\<lbrakk>\<dots>\<rbrakk>\<^bsub>\<rho>\<^esub> = \<lbrakk>Var b'\<rbrakk>\<^bsub>\<lbrace>[(b', Var b')]\<rbrace>\<rho>\<^esub>"
      using `atom b' \<sharp> \<rho>`
      by (auto simp add: fresh_star_def exp_assn.bn_defs)
    also have "\<dots> = \<lbrace>[(b', Var b')]\<rbrace>\<rho> f!\<^sub>\<bottom> b'" by simp
    also have "\<dots> = \<bottom>"
      apply (rule HSem_ind)
        apply (rule adm_is_adm_on)
        apply auto[1]
      apply (simp add: to_bot_fmap_def)
      apply (subst fmap_lookup_bot_join[OF rho_F_compat_fjc], assumption)
      apply simp_all
      done
    finally
    show "\<lbrakk>let b be Var b in Var b\<rbrakk>\<^bsub>\<rho>\<^esub> = \<bottom>".
  qed

  have [simp]: "\<And> \<rho>.  \<lbrakk>z\<rbrakk>\<^bsub>\<rho>\<^esub> = const \<bottom>"
  proof-
    fix \<rho> :: Env
    obtain a' :: var where fresh: "atom a' \<sharp> (b,\<rho>)" by (rule obtain_fresh)
    hence [simp]:"b \<noteq> a'" "atom a' \<sharp> \<rho>"
      by (auto simp add: fresh_Pair fresh_at_base sharp_Env)

    have "z = Lam [a]. let b be Var b in Var b" unfolding z_def..
    also have "\<dots> = Lam [a']. let b be Var b in Var b"
      apply (simp add: fresh_Pair)
      by (metis `b \<noteq> a'` `b \<noteq> a` flip_at_base_simps(3) not_self_fresh)
    also have "\<lbrakk>\<dots>\<rbrakk>\<^bsub>\<rho>\<^esub> = const \<bottom>"
      by (simp add: const_def)
    finally show "\<lbrakk>z\<rbrakk>\<^bsub>\<rho>\<^esub> = const \<bottom>".
  qed

  txt {* Establish that all joins occuring in the proof are well-defined. *}
  have cond: "HSem_cond'' \<Gamma> \<rho>"
    apply (intro fix_join_condI cont_compose[OF fmap_expand_cont cont2cont_heapToEnv] ESem_cont)
    apply (rule compatible_fmapI)
    apply (auto simp add: \<rho>_def \<Gamma>_def)
    done

  txt {* On the one hand, we have an equality according to theorem 2. *}
  have "\<Gamma> : e \<Down>\<^bsub>[]\<^esub> \<Delta> : z"
    unfolding \<Gamma>_def \<Delta>_def e_def z_def
    by (auto intro!: reds.intros)
  moreover
  have "distinctVars \<Gamma>" by (simp add: \<Gamma>_def)
  moreover
  have "fdom \<rho> - heapVars \<Gamma> \<subseteq> set []" by (simp add: \<rho>_def \<Gamma>_def)
  ultimately
  have "\<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub> = \<lbrakk>z\<rbrakk>\<^bsub>\<lbrace>\<Delta>\<rbrace>\<rho>\<^esub>"
    by (rule correct)
  moreover

  txt {* On the other hand, we have an inequality between the same terms. *}
  {
  have "\<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub> = \<lbrace>\<Gamma>\<rbrace>\<rho> f!\<^sub>\<bottom> x"
    by (simp add: e_def)
  also have "\<dots> = (\<rho> f! x) \<squnion> (\<lbrakk>z\<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>)"
    by (simp add: \<Gamma>_def \<rho>_def the_lookup_HSem_both[OF cond, unfolded \<Gamma>_def \<rho>_def])
  also have "\<dots> = const id \<squnion> const \<bottom>"
    by (simp add: \<rho>_def)
  also have "\<dots> = const id"
    by (auto intro: larger_is_join1 simp add: const_def)
  also have "\<dots> \<noteq> const \<bottom>"
    by fact
  also have "const \<bottom> = \<lbrakk>z\<rbrakk>\<^bsub>\<lbrace>\<Delta>\<rbrace>\<rho>\<^esub>" by simp
  finally
  have "\<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub> \<noteq> \<lbrakk>z\<rbrakk>\<^bsub>\<lbrace>\<Delta>\<rbrace>\<rho>\<^esub>".
  }
  ultimately

  txt {* So clearly, this is a contradiction. *}
  show False by metis
qed
oops

end


(*
  File:         PAC_Checker_Synthesis.thy
  Author:       Mathias Fleury, Daniela Kaufmann, JKU
  Maintainer:   Mathias Fleury, JKU
*)
theory PAC_Checker_Synthesis
  imports PAC_Checker WB_Sort PAC_Checker_Relation
    PAC_Checker_Init More_Loops PAC_Version
begin

section \<open>Code Synthesis of the Complete Checker\<close>

text \<open>We here combine refine the full checker, using the initialisation provided in another file and
adding more efficient data structures (mostly replacing the set of variables by a more efficient
hash map).\<close>

abbreviation vars_assn where
  \<open>vars_assn \<equiv> hs.assn string_assn\<close>

fun vars_of_monom_in where
  \<open>vars_of_monom_in [] _ = True\<close> |
  \<open>vars_of_monom_in (x # xs) \<V> \<longleftrightarrow> x \<in> \<V> \<and> vars_of_monom_in xs \<V>\<close>

fun vars_of_poly_in where
  \<open>vars_of_poly_in [] _ = True\<close> |
  \<open>vars_of_poly_in ((x, _) # xs) \<V> \<longleftrightarrow> vars_of_monom_in x \<V> \<and> vars_of_poly_in xs \<V>\<close>

lemma vars_of_monom_in_alt_def:
  \<open>vars_of_monom_in xs \<V> \<longleftrightarrow> set xs \<subseteq> \<V>\<close>
  by (induction xs)
   auto

lemma vars_llist_alt_def:
  \<open>vars_llist xs \<subseteq> \<V> \<longleftrightarrow> vars_of_poly_in xs \<V>\<close>
  by (induction xs)
   (auto simp: vars_llist_def vars_of_monom_in_alt_def)

lemma vars_of_monom_in_alt_def2:
  \<open>vars_of_monom_in xs \<V> \<longleftrightarrow> fold (\<lambda>x b. b \<and> x \<in> \<V>) xs True\<close>
  apply (subst foldr_fold[symmetric])
  subgoal by auto
  subgoal by (induction xs) auto
  done

sepref_definition vars_of_monom_in_impl
  is \<open>uncurry (RETURN oo vars_of_monom_in)\<close>
  :: \<open>(list_assn string_assn)\<^sup>k *\<^sub>a vars_assn\<^sup>k \<rightarrow>\<^sub>a bool_assn\<close>
  unfolding vars_of_monom_in_alt_def2
  by sepref

declare vars_of_monom_in_impl.refine[sepref_fr_rules]

lemma vars_of_poly_in_alt_def2:
  \<open>vars_of_poly_in xs \<V> \<longleftrightarrow> fold (\<lambda>(x, _) b. b \<and> vars_of_monom_in x \<V>) xs True\<close>
  apply (subst foldr_fold[symmetric])
  subgoal by auto
  subgoal by (induction xs) auto
  done

sepref_definition vars_of_poly_in_impl
  is \<open>uncurry (RETURN oo vars_of_poly_in)\<close>
  :: \<open>(poly_assn)\<^sup>k *\<^sub>a vars_assn\<^sup>k \<rightarrow>\<^sub>a bool_assn\<close>
  unfolding vars_of_poly_in_alt_def2
  by sepref

declare vars_of_poly_in_impl.refine[sepref_fr_rules]

definition union_vars_monom :: \<open>string list \<Rightarrow> string set \<Rightarrow> string set\<close> where
\<open>union_vars_monom xs \<V> = fold insert xs \<V>\<close>

definition union_vars_poly :: \<open>llist_polynomial \<Rightarrow> string set \<Rightarrow> string set\<close> where
\<open>union_vars_poly xs \<V> = fold (\<lambda>(xs, _) \<V>. union_vars_monom xs \<V>) xs \<V>\<close>

lemma union_vars_monom_alt_def:
  \<open>union_vars_monom xs \<V> = \<V> \<union> set xs\<close>
  unfolding union_vars_monom_def
  apply (subst foldr_fold[symmetric])
  subgoal for x y
    by (cases x; cases y) auto
  subgoal
    by (induction xs) auto
  done

lemma union_vars_poly_alt_def:
  \<open>union_vars_poly xs \<V> = \<V> \<union> vars_llist xs\<close>
  unfolding union_vars_poly_def
  apply (subst foldr_fold[symmetric])
  subgoal for x y
    by (cases x; cases y)
      (auto simp: union_vars_monom_alt_def)
  subgoal
    by (induction xs)
     (auto simp: vars_llist_def union_vars_monom_alt_def)
   done

sepref_definition union_vars_monom_impl
  is \<open>uncurry (RETURN oo union_vars_monom)\<close>
  :: \<open>monom_assn\<^sup>k *\<^sub>a vars_assn\<^sup>d \<rightarrow>\<^sub>a vars_assn\<close>
  unfolding union_vars_monom_def
  by sepref

declare union_vars_monom_impl.refine[sepref_fr_rules]

sepref_definition union_vars_poly_impl
  is \<open>uncurry (RETURN oo union_vars_poly)\<close>
  :: \<open>poly_assn\<^sup>k *\<^sub>a vars_assn\<^sup>d \<rightarrow>\<^sub>a vars_assn\<close>
  unfolding union_vars_poly_def
  by sepref

declare union_vars_poly_impl.refine[sepref_fr_rules]

hide_const (open) Autoref_Fix_Rel.CONSTRAINT

fun status_assn where
  \<open>status_assn _ CSUCCESS CSUCCESS = emp\<close> |
  \<open>status_assn _ CFOUND CFOUND = emp\<close> |
  \<open>status_assn R (CFAILED a) (CFAILED b) = R a b\<close> |
  \<open>status_assn _ _ _ = false\<close>

lemma SUCCESS_hnr[sepref_fr_rules]:
  \<open>(uncurry0 (return CSUCCESS), uncurry0 (RETURN CSUCCESS)) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a status_assn R\<close>
  by (sepref_to_hoare)
    sep_auto

lemma FOUND_hnr[sepref_fr_rules]:
  \<open>(uncurry0 (return CFOUND), uncurry0 (RETURN CFOUND)) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a status_assn R\<close>
  by (sepref_to_hoare)
    sep_auto

lemma is_success_hnr[sepref_fr_rules]:
  \<open>CONSTRAINT is_pure R \<Longrightarrow>
  ((return o is_cfound), (RETURN o is_cfound)) \<in> (status_assn R)\<^sup>k \<rightarrow>\<^sub>a bool_assn\<close>
  apply (sepref_to_hoare)
  apply (rename_tac xi x; case_tac xi; case_tac x)
  apply sep_auto+
  done

lemma is_cfailed_hnr[sepref_fr_rules]:
  \<open>CONSTRAINT is_pure R \<Longrightarrow>
  ((return o is_cfailed), (RETURN o is_cfailed)) \<in> (status_assn R)\<^sup>k \<rightarrow>\<^sub>a bool_assn\<close>
  apply (sepref_to_hoare)
  apply (rename_tac xi x; case_tac xi; case_tac x)
  apply  sep_auto+
  done

lemma merge_cstatus_hnr[sepref_fr_rules]:
  \<open>CONSTRAINT is_pure R \<Longrightarrow>
  (uncurry (return oo merge_cstatus), uncurry (RETURN oo merge_cstatus)) \<in>
    (status_assn R)\<^sup>k *\<^sub>a  (status_assn R)\<^sup>k \<rightarrow>\<^sub>a status_assn R\<close>
  apply (sepref_to_hoare)
  by (case_tac b; case_tac bi; case_tac a; case_tac ai; sep_auto simp: is_pure_conv pure_app_eq)

sepref_definition add_poly_impl
  is \<open>add_poly_l\<close>
  :: \<open>(poly_assn \<times>\<^sub>a poly_assn)\<^sup>k \<rightarrow>\<^sub>a poly_assn\<close>
  supply [[goals_limit=1]]
  unfolding add_poly_l_def
    HOL_list.fold_custom_empty
    term_order_rel'_def[symmetric]
    term_order_rel'_alt_def
  by sepref

declare add_poly_impl.refine[sepref_fr_rules]

sepref_register mult_monomials
lemma mult_monoms_alt_def:
  \<open>(RETURN oo mult_monoms) x y = REC\<^sub>T
    (\<lambda>f (p, q).
      case (p, q) of
        ([], _) \<Rightarrow> RETURN q
       | (_, []) \<Rightarrow> RETURN p
       | (x # p, y # q) \<Rightarrow>
        (if x = y then do {
          pq \<leftarrow> f (p, q);
           RETURN (x # pq)}
        else if (x, y) \<in> var_order_rel
        then do {
          pq \<leftarrow> f (p, y # q);
          RETURN (x # pq)}
        else do {
          pq \<leftarrow>  f (x # p, q);
          RETURN (y # pq)}))
     (x, y)\<close>
  apply (subst eq_commute)
  apply (induction x y rule: mult_monoms.induct)
  subgoal for p
    by (subst RECT_unfold, refine_mono) (auto split: list.splits)
  subgoal for p
    by (subst RECT_unfold, refine_mono) (auto split: list.splits)
  subgoal for x p y q
    by (subst RECT_unfold, refine_mono) (auto split: list.splits simp: let_to_bind_conv)
  done

sepref_definition mult_monoms_impl
  is \<open>uncurry (RETURN oo mult_monoms)\<close>
  :: \<open>(monom_assn)\<^sup>k *\<^sub>a (monom_assn)\<^sup>k \<rightarrow>\<^sub>a (monom_assn)\<close>
  supply [[goals_limit=1]]
  unfolding mult_poly_raw_def
    HOL_list.fold_custom_empty
    var_order'_def[symmetric]
    term_order_rel'_alt_def
    mult_monoms_alt_def
    var_order_rel_var_order
  by sepref

declare mult_monoms_impl.refine[sepref_fr_rules]

sepref_definition mult_monomials_impl
  is \<open>uncurry (RETURN oo mult_monomials)\<close>
  :: \<open>(monomial_assn)\<^sup>k *\<^sub>a (monomial_assn)\<^sup>k \<rightarrow>\<^sub>a (monomial_assn)\<close>
  supply [[goals_limit=1]]
  unfolding mult_monomials_def
    HOL_list.fold_custom_empty
    term_order_rel'_def[symmetric]
    term_order_rel'_alt_def
  by sepref

lemma map_append_alt_def2:
  \<open>(RETURN o (map_append f b)) xs = REC\<^sub>T
    (\<lambda>g xs. case xs of [] \<Rightarrow> RETURN b
      | x # xs \<Rightarrow> do {
           y \<leftarrow> g xs;
           RETURN (f x # y)
     }) xs\<close>
   apply (subst eq_commute)
  apply (induction f b xs rule: map_append.induct)
  subgoal by (subst RECT_unfold, refine_mono) auto
  subgoal by (subst RECT_unfold, refine_mono) auto
  done

definition map_append_poly_mult where
  \<open>map_append_poly_mult x = map_append (mult_monomials x)\<close>

declare mult_monomials_impl.refine[sepref_fr_rules]

sepref_definition map_append_poly_mult_impl
  is \<open>uncurry2 (RETURN ooo map_append_poly_mult)\<close>
  :: \<open>monomial_assn\<^sup>k *\<^sub>a poly_assn\<^sup>k *\<^sub>a poly_assn\<^sup>k \<rightarrow>\<^sub>a poly_assn\<close>
  unfolding map_append_poly_mult_def
    map_append_alt_def2
  by sepref

declare map_append_poly_mult_impl.refine[sepref_fr_rules]

text \<open>TODO @{thm map_by_foldl} is the worst possible implementation of map!\<close>
sepref_definition mult_poly_raw_impl
  is \<open>uncurry (RETURN oo mult_poly_raw)\<close>
  :: \<open>poly_assn\<^sup>k *\<^sub>a poly_assn\<^sup>k \<rightarrow>\<^sub>a poly_assn\<close>
  supply [[goals_limit=1]]
  supply [[eta_contract = false, show_abbrevs=false]]
  unfolding mult_poly_raw_def
    HOL_list.fold_custom_empty
    term_order_rel'_def[symmetric]
    term_order_rel'_alt_def
    foldl_conv_fold
    fold_eq_nfoldli
    map_append_poly_mult_def[symmetric]
    map_append_alt_def[symmetric]
  by sepref

declare mult_poly_raw_impl.refine[sepref_fr_rules]

sepref_definition mult_poly_impl
  is \<open>uncurry mult_poly_full\<close>
  :: \<open>poly_assn\<^sup>k *\<^sub>a poly_assn\<^sup>k \<rightarrow>\<^sub>a poly_assn\<close>
  supply [[goals_limit=1]]
  unfolding mult_poly_full_def
    HOL_list.fold_custom_empty
    term_order_rel'_def[symmetric]
    term_order_rel'_alt_def
  by sepref

declare mult_poly_impl.refine[sepref_fr_rules]

lemma inverse_monomial:
  \<open>monom_rel\<inverse> \<times>\<^sub>r int_rel = (monom_rel \<times>\<^sub>r int_rel)\<inverse>\<close>
  by (auto)

lemma eq_poly_rel_eq[sepref_import_param]:
  \<open>((=), (=)) \<in> poly_rel \<rightarrow> poly_rel \<rightarrow> bool_rel\<close>
  using list_rel_sv[of \<open>monomial_rel\<close>, OF single_valued_monomial_rel]
  using list_rel_sv[OF single_valued_monomial_rel'[unfolded IS_LEFT_UNIQUE_def inv_list_rel_eq]]
  unfolding inv_list_rel_eq[symmetric]
  by (auto intro!: frefI simp:
      rel2p_def single_valued_def p2rel_def
    simp del: inv_list_rel_eq)

sepref_definition weak_equality_l_impl
  is \<open>uncurry weak_equality_l\<close>
  :: \<open>poly_assn\<^sup>k *\<^sub>a poly_assn\<^sup>k \<rightarrow>\<^sub>a bool_assn\<close>
  supply [[goals_limit=1]]
  unfolding weak_equality_l_def
  by sepref

declare weak_equality_l_impl.refine[sepref_fr_rules]
sepref_register add_poly_l mult_poly_full

abbreviation raw_string_assn :: \<open>string \<Rightarrow> string \<Rightarrow> assn\<close> where
  \<open>raw_string_assn \<equiv> list_assn id_assn\<close>

definition show_nat :: \<open>nat \<Rightarrow> string\<close> where
  \<open>show_nat i = show i\<close>

lemma [sepref_import_param]:
  \<open>(show_nat, show_nat) \<in> nat_rel \<rightarrow> \<langle>Id\<rangle>list_rel\<close>
  by (auto intro: fun_relI)

lemma status_assn_pure_conv:
  \<open>status_assn (id_assn) a b = id_assn a b\<close>
  by (cases a; cases b)
    (auto simp: pure_def)

lemma [sepref_fr_rules]:
  \<open>(uncurry3 (\<lambda>x y. return oo (error_msg_not_equal_dom x y)), uncurry3 check_not_equal_dom_err) \<in>
  poly_assn\<^sup>k *\<^sub>a poly_assn\<^sup>k *\<^sub>a poly_assn\<^sup>k *\<^sub>a poly_assn\<^sup>k \<rightarrow>\<^sub>a raw_string_assn\<close>
  unfolding show_nat_def[symmetric] list_assn_pure_conv
    prod_assn_pure_conv check_not_equal_dom_err_def
  by (sepref_to_hoare; sep_auto simp: error_msg_not_equal_dom_def)

lemma [sepref_fr_rules]:
  \<open>(return o (error_msg_notin_dom o nat_of_uint64), RETURN o error_msg_notin_dom)
   \<in> uint64_nat_assn\<^sup>k \<rightarrow>\<^sub>a raw_string_assn\<close>
  \<open>(return o (error_msg_reused_dom o nat_of_uint64), RETURN o error_msg_reused_dom)
    \<in> uint64_nat_assn\<^sup>k \<rightarrow>\<^sub>a raw_string_assn\<close>
  \<open>(uncurry (return oo (\<lambda>i. error_msg (nat_of_uint64 i))), uncurry (RETURN oo error_msg))
    \<in> uint64_nat_assn\<^sup>k *\<^sub>a raw_string_assn\<^sup>k  \<rightarrow>\<^sub>a status_assn raw_string_assn\<close>
  \<open>(uncurry (return oo  error_msg), uncurry (RETURN oo error_msg))
   \<in> nat_assn\<^sup>k *\<^sub>a raw_string_assn\<^sup>k  \<rightarrow>\<^sub>a status_assn raw_string_assn\<close>
  unfolding error_msg_notin_dom_def list_assn_pure_conv list_rel_id_simp
  unfolding status_assn_pure_conv
  unfolding show_nat_def[symmetric]
  by (sepref_to_hoare; sep_auto simp: uint64_nat_rel_def br_def; fail)+

sepref_definition check_addition_l_impl
  is \<open>uncurry6 check_addition_l\<close>
  :: \<open>poly_assn\<^sup>k *\<^sub>a polys_assn\<^sup>k *\<^sub>a vars_assn\<^sup>k *\<^sub>a uint64_nat_assn\<^sup>k *\<^sub>a uint64_nat_assn\<^sup>k *\<^sub>a
        uint64_nat_assn\<^sup>k *\<^sub>a poly_assn\<^sup>k  \<rightarrow>\<^sub>a status_assn raw_string_assn\<close>
  supply [[goals_limit=1]]
  unfolding mult_poly_full_def
    HOL_list.fold_custom_empty
    term_order_rel'_def[symmetric]
    term_order_rel'_alt_def
    check_addition_l_def
    in_dom_m_lookup_iff
    fmlookup'_def[symmetric]
    vars_llist_alt_def
  by sepref

declare check_addition_l_impl.refine[sepref_fr_rules]

sepref_register check_mult_l_dom_err

definition check_mult_l_dom_err_impl where
  \<open>check_mult_l_dom_err_impl pd p ia i =
    (if pd then ''The polynomial with id '' @ show (nat_of_uint64 p) @ '' was not found'' else '''') @
    (if ia then ''The id of the resulting id '' @ show (nat_of_uint64 i) @ '' was already given'' else '''')\<close>

definition check_mult_l_mult_err_impl where
  \<open>check_mult_l_mult_err_impl p q pq r =
    ''Multiplying '' @ show p @ '' by '' @ show q @ '' gives '' @ show pq @ '' and not '' @ show r\<close>

lemma [sepref_fr_rules]:
  \<open>(uncurry3 ((\<lambda>x y. return oo (check_mult_l_dom_err_impl x y))),
   uncurry3 (check_mult_l_dom_err)) \<in> bool_assn\<^sup>k *\<^sub>a uint64_nat_assn\<^sup>k *\<^sub>a bool_assn\<^sup>k *\<^sub>a uint64_nat_assn\<^sup>k \<rightarrow>\<^sub>a raw_string_assn\<close>
   unfolding check_mult_l_dom_err_def check_mult_l_dom_err_impl_def list_assn_pure_conv
   apply sepref_to_hoare
   apply sep_auto
   done

lemma [sepref_fr_rules]:
  \<open>(uncurry3 ((\<lambda>x y. return oo (check_mult_l_mult_err_impl x y))),
   uncurry3 (check_mult_l_mult_err)) \<in> poly_assn\<^sup>k *\<^sub>a poly_assn\<^sup>k *\<^sub>a poly_assn\<^sup>k *\<^sub>a poly_assn\<^sup>k \<rightarrow>\<^sub>a raw_string_assn\<close>
   unfolding check_mult_l_mult_err_def check_mult_l_mult_err_impl_def list_assn_pure_conv
   apply sepref_to_hoare
   apply sep_auto
   done

sepref_definition check_mult_l_impl
  is \<open>uncurry6 check_mult_l\<close>
  :: \<open>poly_assn\<^sup>k *\<^sub>a polys_assn\<^sup>k *\<^sub>a vars_assn\<^sup>k *\<^sub>a uint64_nat_assn\<^sup>k *\<^sub>a poly_assn\<^sup>k *\<^sub>a uint64_nat_assn\<^sup>k *\<^sub>a poly_assn\<^sup>k  \<rightarrow>\<^sub>a status_assn raw_string_assn\<close>
  supply [[goals_limit=1]]
  unfolding check_mult_l_def
    HOL_list.fold_custom_empty
    term_order_rel'_def[symmetric]
    term_order_rel'_alt_def
    in_dom_m_lookup_iff
    fmlookup'_def[symmetric]
    vars_llist_alt_def
  by sepref

declare check_mult_l_impl.refine[sepref_fr_rules]

definition check_ext_l_dom_err_impl :: \<open>uint64 \<Rightarrow> _\<close>  where
  \<open>check_ext_l_dom_err_impl p =
    ''There is already a polynomial with index '' @ show (nat_of_uint64 p)\<close>

lemma [sepref_fr_rules]:
  \<open>(((return o (check_ext_l_dom_err_impl))),
    (check_extension_l_dom_err)) \<in> uint64_nat_assn\<^sup>k \<rightarrow>\<^sub>a raw_string_assn\<close>
   unfolding check_extension_l_dom_err_def check_ext_l_dom_err_impl_def list_assn_pure_conv
   apply sepref_to_hoare
   apply sep_auto
   done

definition check_extension_l_no_new_var_err_impl :: \<open>_ \<Rightarrow> _\<close>  where
  \<open>check_extension_l_no_new_var_err_impl p =
    ''No new variable could be found in polynomial '' @ show p\<close>

lemma [sepref_fr_rules]:
  \<open>(((return o (check_extension_l_no_new_var_err_impl))),
    (check_extension_l_no_new_var_err)) \<in> poly_assn\<^sup>k \<rightarrow>\<^sub>a raw_string_assn\<close>
   unfolding check_extension_l_no_new_var_err_impl_def check_extension_l_no_new_var_err_def
     list_assn_pure_conv
   apply sepref_to_hoare
   apply sep_auto
   done

definition check_extension_l_side_cond_err_impl :: \<open>_ \<Rightarrow> _\<close>  where
  \<open>check_extension_l_side_cond_err_impl v p r s =
    ''Error while checking side conditions of extensions polynow, var is '' @ show v @
    '' polynomial is '' @ show p @ ''side condition p*p - p = '' @ show s @ '' and should be 0''\<close>

lemma [sepref_fr_rules]:
  \<open>((uncurry3 (\<lambda>x y. return oo (check_extension_l_side_cond_err_impl x y))),
    uncurry3 (check_extension_l_side_cond_err)) \<in> string_assn\<^sup>k *\<^sub>a poly_assn\<^sup>k *\<^sub>a poly_assn\<^sup>k *\<^sub>a poly_assn\<^sup>k \<rightarrow>\<^sub>a raw_string_assn\<close>
   unfolding check_extension_l_side_cond_err_impl_def check_extension_l_side_cond_err_def
     list_assn_pure_conv
   apply sepref_to_hoare
   apply sep_auto
   done

definition check_extension_l_new_var_multiple_err_impl :: \<open>_ \<Rightarrow> _\<close>  where
  \<open>check_extension_l_new_var_multiple_err_impl v p =
    ''Error while checking side conditions of extensions polynow, var is '' @ show v @
    '' but it either appears at least once in the polynomial or another new variable is created '' @
    show p @ '' but should not.''\<close>

lemma [sepref_fr_rules]:
  \<open>((uncurry (return oo (check_extension_l_new_var_multiple_err_impl))),
    uncurry (check_extension_l_new_var_multiple_err)) \<in> string_assn\<^sup>k *\<^sub>a poly_assn\<^sup>k \<rightarrow>\<^sub>a raw_string_assn\<close>
   unfolding check_extension_l_new_var_multiple_err_impl_def
     check_extension_l_new_var_multiple_err_def
     list_assn_pure_conv
   apply sepref_to_hoare
   apply sep_auto
   done

sepref_register check_extension_l_dom_err fmlookup'
  check_extension_l_side_cond_err check_extension_l_no_new_var_err
  check_extension_l_new_var_multiple_err

definition uminus_poly :: \<open>llist_polynomial \<Rightarrow> llist_polynomial\<close> where
  \<open>uminus_poly p' = map (\<lambda>(a, b). (a, - b)) p'\<close>

sepref_register uminus_poly
lemma [sepref_import_param]:
  \<open>(map (\<lambda>(a, b). (a, - b)), uminus_poly) \<in> poly_rel \<rightarrow> poly_rel\<close>
  unfolding uminus_poly_def
  apply (intro fun_relI)
  subgoal for p p'
    by (induction p p' rule: list_rel_induct)
     auto
  done

sepref_register vars_of_poly_in
  weak_equality_l

lemma [safe_constraint_rules]:
  \<open>Sepref_Constraints.CONSTRAINT single_valued (the_pure monomial_assn)\<close> and
  single_valued_the_monomial_assn:
    \<open>single_valued (the_pure monomial_assn)\<close>
    \<open>single_valued ((the_pure monomial_assn)\<inverse>)\<close>
  unfolding IS_LEFT_UNIQUE_def[symmetric]
  by (auto simp: step_rewrite_pure single_valued_monomial_rel single_valued_monomial_rel' Sepref_Constraints.CONSTRAINT_def)

sepref_definition check_extension_l_impl
  is \<open>uncurry5 check_extension_l\<close>
  :: \<open>poly_assn\<^sup>k *\<^sub>a polys_assn\<^sup>k *\<^sub>a vars_assn\<^sup>k *\<^sub>a uint64_nat_assn\<^sup>k *\<^sub>a string_assn\<^sup>k *\<^sub>a poly_assn\<^sup>k \<rightarrow>\<^sub>a
     status_assn raw_string_assn\<close>
  supply option.splits[split] single_valued_the_monomial_assn[simp]
  supply [[goals_limit=1]]
  unfolding
    HOL_list.fold_custom_empty
    term_order_rel'_def[symmetric]
    term_order_rel'_alt_def
    in_dom_m_lookup_iff
    fmlookup'_def[symmetric]
    vars_llist_alt_def
    check_extension_l_def
    not_not
    option.case_eq_if
    uminus_poly_def[symmetric]
    HOL_list.fold_custom_empty
  by sepref

declare check_extension_l_impl.refine[sepref_fr_rules]

sepref_definition check_del_l_impl
  is \<open>uncurry2 check_del_l\<close>
  :: \<open>poly_assn\<^sup>k *\<^sub>a polys_assn\<^sup>k *\<^sub>a uint64_nat_assn\<^sup>k \<rightarrow>\<^sub>a status_assn raw_string_assn\<close>
  supply [[goals_limit=1]]
  unfolding check_del_l_def
    in_dom_m_lookup_iff
    fmlookup'_def[symmetric]
  by sepref

lemmas [sepref_fr_rules] = check_del_l_impl.refine

abbreviation pac_step_rel where
  \<open>pac_step_rel \<equiv> p2rel (\<langle>Id, \<langle>monomial_rel\<rangle>list_rel, Id\<rangle> pac_step_rel_raw)\<close>

sepref_register PAC_Polynomials_Operations.normalize_poly
  pac_src1 pac_src2 new_id pac_mult case_pac_step check_mult_l
  check_addition_l check_del_l check_extension_l

lemma pac_step_rel_assn_alt_def2:
  \<open>hn_ctxt (pac_step_rel_assn nat_assn poly_assn id_assn) b bi =
       hn_val
        (p2rel
          (\<langle>nat_rel, poly_rel, Id :: (string \<times> _) set\<rangle>pac_step_rel_raw)) b bi\<close>
  unfolding poly_assn_list hn_ctxt_def
  by (induction nat_assn poly_assn \<open>id_assn :: string \<Rightarrow> _\<close> b bi rule: pac_step_rel_assn.induct)
   (auto simp: p2rel_def hn_val_unfold pac_step_rel_raw.simps relAPP_def
    pure_app_eq)

lemma is_AddD_import[sepref_fr_rules]:
  assumes \<open>CONSTRAINT is_pure K\<close>  \<open>CONSTRAINT is_pure V\<close>
  shows
    \<open>(return o pac_res, RETURN o pac_res) \<in> [\<lambda>x. is_Add x \<or> is_Mult x \<or> is_Extension x]\<^sub>a
       (pac_step_rel_assn K V R)\<^sup>k \<rightarrow> V\<close>
    \<open>(return o pac_src1, RETURN o pac_src1) \<in> [\<lambda>x. is_Add x \<or> is_Mult x \<or> is_Del x]\<^sub>a (pac_step_rel_assn K V R)\<^sup>k \<rightarrow> K\<close>
    \<open>(return o new_id, RETURN o new_id) \<in> [\<lambda>x. is_Add x \<or> is_Mult x \<or> is_Extension x]\<^sub>a (pac_step_rel_assn K V R)\<^sup>k \<rightarrow> K\<close>
    \<open>(return o is_Add, RETURN o is_Add) \<in>  (pac_step_rel_assn K V R)\<^sup>k \<rightarrow>\<^sub>a bool_assn\<close>
    \<open>(return o is_Mult, RETURN o is_Mult) \<in> (pac_step_rel_assn K V R)\<^sup>k \<rightarrow>\<^sub>a bool_assn\<close>
    \<open>(return o is_Del, RETURN o is_Del) \<in> (pac_step_rel_assn K V R)\<^sup>k \<rightarrow>\<^sub>a bool_assn\<close>
    \<open>(return o is_Extension, RETURN o is_Extension) \<in> (pac_step_rel_assn K V R)\<^sup>k \<rightarrow>\<^sub>a bool_assn\<close>
  using assms
  by (sepref_to_hoare; sep_auto simp: pac_step_rel_assn_alt_def is_pure_conv ent_true_drop pure_app_eq
      split: pac_step.splits; fail)+

lemma [sepref_fr_rules]:
  \<open>CONSTRAINT is_pure K \<Longrightarrow>
  (return o pac_src2, RETURN o pac_src2) \<in> [\<lambda>x. is_Add x]\<^sub>a (pac_step_rel_assn K V R)\<^sup>k \<rightarrow> K\<close>
  \<open>CONSTRAINT is_pure V \<Longrightarrow>
  (return o pac_mult, RETURN o pac_mult) \<in> [\<lambda>x. is_Mult x]\<^sub>a (pac_step_rel_assn K V R)\<^sup>k \<rightarrow> V\<close>
  \<open>CONSTRAINT is_pure R \<Longrightarrow>
  (return o new_var, RETURN o new_var) \<in> [\<lambda>x. is_Extension x]\<^sub>a (pac_step_rel_assn K V R)\<^sup>k \<rightarrow> R\<close>
  by (sepref_to_hoare; sep_auto simp: pac_step_rel_assn_alt_def is_pure_conv ent_true_drop pure_app_eq
      split: pac_step.splits; fail)+

lemma is_Mult_lastI:
  \<open>\<not> is_Add b \<Longrightarrow> \<not>is_Mult b \<Longrightarrow> \<not>is_Extension b \<Longrightarrow> is_Del b\<close>
  by (cases b) auto

sepref_register is_cfailed is_Del

definition PAC_checker_l_step' ::  _ where
  \<open>PAC_checker_l_step' a b c d = PAC_checker_l_step a (b, c, d)\<close>

lemma PAC_checker_l_step_alt_def:
  \<open>PAC_checker_l_step a bcd e = (let (b,c,d) = bcd in PAC_checker_l_step' a b c d e)\<close>
  unfolding PAC_checker_l_step'_def by auto

sepref_decl_intf ('k) acode_status is "('k) code_status"
sepref_decl_intf ('k, 'b, 'lbl) apac_step is "('k, 'b, 'lbl) pac_step"

sepref_register merge_cstatus full_normalize_poly new_var is_Add

lemma poly_rel_the_pure:
  \<open>poly_rel = the_pure poly_assn\<close> and
  nat_rel_the_pure:
  \<open>nat_rel = the_pure nat_assn\<close> and
 WTF_RF: \<open>pure (the_pure nat_assn) = nat_assn\<close>
  unfolding poly_assn_list
  by auto

lemma [safe_constraint_rules]:
    \<open>CONSTRAINT IS_LEFT_UNIQUE uint64_nat_rel\<close> and
  single_valued_uint64_nat_rel[safe_constraint_rules]:
    \<open>CONSTRAINT single_valued uint64_nat_rel\<close>
  by (auto simp: IS_LEFT_UNIQUE_def single_valued_def uint64_nat_rel_def br_def)

sepref_definition check_step_impl
  is \<open>uncurry4 PAC_checker_l_step'\<close>
  :: \<open>poly_assn\<^sup>k *\<^sub>a (status_assn raw_string_assn)\<^sup>d *\<^sub>a vars_assn\<^sup>d *\<^sub>a polys_assn\<^sup>d *\<^sub>a (pac_step_rel_assn (uint64_nat_assn) poly_assn (string_assn :: string \<Rightarrow> _))\<^sup>d \<rightarrow>\<^sub>a
    status_assn raw_string_assn \<times>\<^sub>a vars_assn \<times>\<^sub>a polys_assn\<close>
  supply [[goals_limit=1]] is_Mult_lastI[intro] single_valued_uint64_nat_rel[simp]
  unfolding PAC_checker_l_step_def PAC_checker_l_step'_def
    pac_step.case_eq_if Let_def
     is_success_alt_def[symmetric]
    uminus_poly_def[symmetric]
    HOL_list.fold_custom_empty
  by sepref

declare check_step_impl.refine[sepref_fr_rules]

sepref_register PAC_checker_l_step PAC_checker_l_step' fully_normalize_poly_impl

definition PAC_checker_l' where
  \<open>PAC_checker_l' p \<V> A status steps = PAC_checker_l p (\<V>, A) status steps\<close>

lemma PAC_checker_l_alt_def:
  \<open>PAC_checker_l p \<V>A status steps =
    (let (\<V>, A) = \<V>A in PAC_checker_l' p \<V> A status steps)\<close>
  unfolding PAC_checker_l'_def by auto

sepref_definition PAC_checker_l_impl
  is \<open>uncurry4 PAC_checker_l'\<close>
  :: \<open>poly_assn\<^sup>k *\<^sub>a vars_assn\<^sup>d *\<^sub>a polys_assn\<^sup>d *\<^sub>a (status_assn raw_string_assn)\<^sup>d *\<^sub>a
       (list_assn (pac_step_rel_assn (uint64_nat_assn) poly_assn string_assn))\<^sup>k \<rightarrow>\<^sub>a
     status_assn raw_string_assn \<times>\<^sub>a vars_assn \<times>\<^sub>a polys_assn\<close>
  supply [[goals_limit=1]] is_Mult_lastI[intro]
  unfolding PAC_checker_l_def is_success_alt_def[symmetric] PAC_checker_l_step_alt_def
    nres_bind_let_law[symmetric] PAC_checker_l'_def
  apply (subst nres_bind_let_law)
  by sepref

declare PAC_checker_l_impl.refine[sepref_fr_rules]

abbreviation polys_assn_input where
  \<open>polys_assn_input \<equiv> iam_fmap_assn nat_assn poly_assn\<close>

definition remap_polys_l_dom_err_impl :: \<open>_\<close>  where
  \<open>remap_polys_l_dom_err_impl =
    ''Error during initialisation. Too many polynomials where provided. If this happens,'' @
    ''please report the example to the authors, because something went wrong during '' @
    ''code generation (code generation to arrays is likely to be broken).''\<close>

lemma [sepref_fr_rules]:
  \<open>((uncurry0 (return (remap_polys_l_dom_err_impl))),
    uncurry0 (remap_polys_l_dom_err)) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a raw_string_assn\<close>
   unfolding remap_polys_l_dom_err_def
     remap_polys_l_dom_err_def
     list_assn_pure_conv
   by sepref_to_hoare sep_auto

text \<open>MLton is not able to optimise the calls to pow.\<close>
lemma pow_2_64: \<open>(2::nat) ^ 64 = 18446744073709551616\<close>
  by auto

sepref_register upper_bound_on_dom op_fmap_empty

sepref_definition remap_polys_l_impl
  is \<open>uncurry2 remap_polys_l2\<close>
  :: \<open>poly_assn\<^sup>k *\<^sub>a vars_assn\<^sup>d *\<^sub>a polys_assn_input\<^sup>d \<rightarrow>\<^sub>a
    status_assn raw_string_assn \<times>\<^sub>a vars_assn \<times>\<^sub>a polys_assn\<close>
  supply [[goals_limit=1]] is_Mult_lastI[intro] indom_mI[dest]
  unfolding remap_polys_l2_def op_fmap_empty_def[symmetric] while_eq_nfoldli[symmetric]
    while_upt_while_direct pow_2_64
    in_dom_m_lookup_iff
    fmlookup'_def[symmetric]
    union_vars_poly_alt_def[symmetric]
  apply (rewrite at \<open>fmupd \<hole>\<close> uint64_of_nat_conv_def[symmetric])
  apply (subst while_upt_while_direct)
  apply simp
  apply (rewrite at \<open>op_fmap_empty\<close> annotate_assn[where A=\<open>polys_assn\<close>])
  by sepref

lemma remap_polys_l2_remap_polys_l:
  \<open>(uncurry2 remap_polys_l2, uncurry2 remap_polys_l) \<in> (Id \<times>\<^sub>r \<langle>Id\<rangle>set_rel) \<times>\<^sub>r Id \<rightarrow>\<^sub>f \<langle>Id\<rangle>nres_rel\<close>
  apply (intro frefI fun_relI nres_relI)
  using remap_polys_l2_remap_polys_l by auto

lemma [sepref_fr_rules]:
   \<open>(uncurry2 remap_polys_l_impl,
     uncurry2 remap_polys_l) \<in> poly_assn\<^sup>k *\<^sub>a vars_assn\<^sup>d *\<^sub>a polys_assn_input\<^sup>d \<rightarrow>\<^sub>a
       status_assn raw_string_assn \<times>\<^sub>a vars_assn \<times>\<^sub>a polys_assn\<close>
   using hfcomp_tcomp_pre[OF remap_polys_l2_remap_polys_l remap_polys_l_impl.refine]
   by (auto simp: hrp_comp_def hfprod_def)

sepref_register remap_polys_l

sepref_definition full_checker_l_impl
  is \<open>uncurry2 full_checker_l\<close>
  :: \<open>poly_assn\<^sup>k *\<^sub>a polys_assn_input\<^sup>d *\<^sub>a (list_assn (pac_step_rel_assn (uint64_nat_assn) poly_assn string_assn))\<^sup>k \<rightarrow>\<^sub>a
    status_assn raw_string_assn \<times>\<^sub>a vars_assn \<times>\<^sub>a polys_assn\<close>
  supply [[goals_limit=1]] is_Mult_lastI[intro]
  unfolding full_checker_l_def hs.fold_custom_empty
    union_vars_poly_alt_def[symmetric]
    PAC_checker_l_alt_def
  by sepref

sepref_definition PAC_update_impl
  is \<open>uncurry2 (RETURN ooo fmupd)\<close>
  :: \<open>nat_assn\<^sup>k *\<^sub>a poly_assn\<^sup>k *\<^sub>a (polys_assn_input)\<^sup>d \<rightarrow>\<^sub>a polys_assn_input\<close>
  unfolding comp_def
  by sepref

sepref_definition PAC_empty_impl
  is \<open>uncurry0 (RETURN fmempty)\<close>
  :: \<open>unit_assn\<^sup>k \<rightarrow>\<^sub>a polys_assn_input\<close>
  unfolding op_iam_fmap_empty_def[symmetric] pat_fmap_empty
  by sepref

sepref_definition empty_vars_impl
  is \<open>uncurry0 (RETURN {})\<close>
  :: \<open>unit_assn\<^sup>k \<rightarrow>\<^sub>a vars_assn\<close>
  unfolding hs.fold_custom_empty
  by sepref

text \<open>This is a hack for performance. There is no need to recheck that that a char is valid when
  working on chars coming from strings... It is not that important in most cases, but in our case
  the preformance difference is really large.\<close>

definition unsafe_asciis_of_literal :: \<open>_\<close> where
  \<open>unsafe_asciis_of_literal xs = String.asciis_of_literal xs\<close>

definition unsafe_asciis_of_literal' :: \<open>_\<close> where
  [simp, symmetric, code]: \<open>unsafe_asciis_of_literal' = unsafe_asciis_of_literal\<close>

code_printing
  constant unsafe_asciis_of_literal' \<rightharpoonup>
    (SML) "!(List.map (fn c => let val k = Char.ord c in IntInf.fromInt k end) /o String.explode)"

text \<open>
  Now comes the big and ugly and unsafe hack.

  Basically, we try to avoid the conversion to IntInf when calculating the hash. The performance
  gain is roughly 40\%, which is a LOT and definitively something we need to do. We are aware that the
  SML semantic encourages compilers to optimise conversions, but this does not happen here,
  corroborating our early observation on the verified SAT solver IsaSAT.x
\<close>
definition raw_explode where
  [simp]: \<open>raw_explode = String.explode\<close>
code_printing
  constant raw_explode \<rightharpoonup>
    (SML) "String.explode"

definition \<open>hashcode_literal' s \<equiv>
    foldl (\<lambda>h x. h * 33 + uint32_of_int (of_char x)) 5381
     (raw_explode s)\<close>

lemmas [code] =
  hashcode_literal_def[unfolded String.explode_code
    unsafe_asciis_of_literal_def[symmetric]]

definition uint32_of_char where
  [symmetric, code_unfold]: \<open>uint32_of_char x = uint32_of_int (int_of_char x)\<close>

code_printing
  constant uint32_of_char \<rightharpoonup>
    (SML) "!(Word32.fromInt /o (Char.ord))"

text \<open>We compile Pastèque in \<^file>\<open>PAC_Checker_MLton.thy\<close>.\<close>
export_code PAC_checker_l_impl PAC_update_impl PAC_empty_impl the_error is_cfailed is_cfound
  int_of_integer Del Add Mult nat_of_integer String.implode remap_polys_l_impl
  fully_normalize_poly_impl union_vars_poly_impl empty_vars_impl
  full_checker_l_impl check_step_impl CSUCCESS
  Extension hashcode_literal' version
  in SML_imp module_name PAC_Checker

section \<open>Correctness theorem\<close>

context poly_embed
begin

definition full_poly_assn where
  \<open>full_poly_assn = hr_comp poly_assn (fully_unsorted_poly_rel O mset_poly_rel)\<close>

definition full_poly_input_assn where
  \<open>full_poly_input_assn = hr_comp
        (hr_comp polys_assn_input
          (\<langle>nat_rel, fully_unsorted_poly_rel O mset_poly_rel\<rangle>fmap_rel))
        polys_rel\<close>

definition fully_pac_assn where
  \<open>fully_pac_assn = (list_assn
        (hr_comp (pac_step_rel_assn uint64_nat_assn poly_assn string_assn)
          (p2rel
            (\<langle>nat_rel,
             fully_unsorted_poly_rel O
             mset_poly_rel, var_rel\<rangle>pac_step_rel_raw))))\<close>

definition code_status_assn where
  \<open>code_status_assn = hr_comp (status_assn raw_string_assn)
                            code_status_status_rel\<close>

definition full_vars_assn where
  \<open>full_vars_assn = hr_comp (hs.assn string_assn)
                              (\<langle>var_rel\<rangle>set_rel)\<close>

lemma polys_rel_full_polys_rel:
  \<open>polys_rel_full = Id \<times>\<^sub>r polys_rel\<close>
  by (auto simp: polys_rel_full_def)

definition full_polys_assn :: \<open>_\<close> where
\<open>full_polys_assn = hr_comp (hr_comp polys_assn
                              (\<langle>nat_rel,
                               sorted_poly_rel O mset_poly_rel\<rangle>fmap_rel))
                            polys_rel\<close>

text \<open>

Below is the full correctness theorems. It basically states that:

  \<^enum> assuming that the input polynomials have no duplicate variables

Then:

\<^enum> if the checker returns \<^term>\<open>CFOUND\<close>, the spec is in the ideal
  and the PAC file is correct

\<^enum> if the checker returns \<^term>\<open>CSUCCESS\<close>, the PAC file is correct (but
there is no information on the spec, aka checking failed)

\<^enum> if the checker return \<^term>\<open>CFAILED err\<close>, then checking failed (and
\<^term>\<open>err\<close> \<^emph>\<open>might\<close> give you an indication of the error, but the correctness
theorem does not say anything about that).

The input parameters are:

\<^enum> the specification polynomial represented as a list

\<^enum> the input polynomials as hash map (as an array of option polynomial)

\<^enum> a represention of the PAC proofs.

\<close>

lemma PAC_full_correctness: (* \htmllink{PAC-full-correctness} *)
  \<open>(uncurry2 full_checker_l_impl,
     uncurry2 (\<lambda>spec A _. PAC_checker_specification spec A))
    \<in> (full_poly_assn)\<^sup>k *\<^sub>a (full_poly_input_assn)\<^sup>d *\<^sub>a (fully_pac_assn)\<^sup>k \<rightarrow>\<^sub>a hr_comp
      (code_status_assn \<times>\<^sub>a full_vars_assn \<times>\<^sub>a hr_comp polys_assn
                              (\<langle>nat_rel, sorted_poly_rel O mset_poly_rel\<rangle>fmap_rel))
                            {((st, G), st', G').
                             st = st' \<and> (st \<noteq> FAILED \<longrightarrow> (G, G') \<in> Id \<times>\<^sub>r polys_rel)}\<close>
  using
    full_checker_l_impl.refine[FCOMP full_checker_l_full_checker',
      FCOMP full_checker_spec',
      unfolded full_poly_assn_def[symmetric]
        full_poly_input_assn_def[symmetric]
        fully_pac_assn_def[symmetric]
        code_status_assn_def[symmetric]
        full_vars_assn_def[symmetric]
        polys_rel_full_polys_rel
        hr_comp_prod_conv
        full_polys_assn_def[symmetric]]
      hr_comp_Id2
   by auto

text \<open>

It would be more efficient to move the parsing to Isabelle, as this
would be more memory efficient (and also reduce the TCB). But now
comes the fun part: It cannot work. A stream (of a file) is consumed
by side effects. Assume that this would work. The code could look like:

\<^term>\<open>
  let next_token = read_file file
  in f (next_token)
\<close>

This code is equal to (in the HOL sense of equality):
\<^term>\<open>
  let _ = read_file file;
      next_token = read_file file
  in f (next_token)
\<close>

However, as an hypothetical \<^term>\<open>read_file\<close> changes the underlying stream, we would get the next
token. Remark that this is already a weird point of ML compilers. Anyway, I see currently two
solutions to this problem:

\<^enum> The meta-argument: use it only in the Refinement Framework in a setup where copies are
disallowed. Basically, this works because we can express the non-duplication constraints on the type
level. However, we cannot forbid people from expressing things directly at the HOL level.

\<^enum> On the target language side, model the stream as the stream and the position. Reading takes two
arguments. First, the position to read. Second, the stream (and the current position) to read. If
the position to read does not match the current position, return an error. This would fit the
correctness theorem of the code generation (roughly ``if it terminates without exception, the answer
is the same''), but it is still unsatisfactory.
\<close>

end

definition \<phi> :: \<open>string \<Rightarrow> nat\<close> where
  \<open>\<phi> = (SOME \<phi>. bij \<phi>)\<close>

lemma bij_\<phi>: \<open>bij \<phi>\<close>
  using someI[of \<open>\<lambda>\<phi> :: string \<Rightarrow> nat. bij \<phi>\<close>]
  unfolding \<phi>_def[symmetric]
  using poly_embed_EX
  by auto

global_interpretation PAC: poly_embed where
  \<phi> = \<phi>
  apply standard
  apply (use bij_\<phi> in \<open>auto simp: bij_def\<close>)
  done

text \<open>The full correctness theorem is @{thm PAC.PAC_full_correctness}.\<close>

end


section \<open>Miscellaneous Lemmas\<close>
theory Chloe_Misc
imports Main
begin
  (* TODO: Move to Misc/Isabelle Library*)

  definition "ID_TAG \<equiv> \<lambda>x. x"
  lemma ID_TAGI: "P \<Longrightarrow> ID_TAG P" by (simp add: ID_TAG_def)

  subsection \<open>Maps\<close>
  lemma map_leD[intro?, elim]: "m \<subseteq>\<^sub>m m' \<Longrightarrow> m x = Some v \<Longrightarrow> m' x = Some v"
    by (auto simp: map_le_def dom_def)

  declare map_le_refl[intro!]

  subsection \<open>Lists\<close>
  fun split_common_prefix :: "'a list \<Rightarrow> 'a list \<Rightarrow> ('a list \<times> 'a list \<times> 'a list)"
    -- \<open>Find longest common prefix of two lists\<close>
  where
    "split_common_prefix [] l2 = ([],[],l2)"
  | "split_common_prefix l1 [] = ([],l1,[])"
  | "split_common_prefix (a#l1) (b#l2) = (
      if a=b then
        let (prf,ra,rb) = split_common_prefix l1 l2 in (b#prf,ra,rb)
      else
        ([],a#l1,b#l2)
    )"

  lemma split_common_prefix_correct:
    assumes "split_common_prefix l1 l2 = (prf,r1,r2)"
    shows "l1=prf@r1" "l2=prf@r2" "r1\<noteq>[] \<and> r2\<noteq>[] \<longrightarrow> hd r1\<noteq>hd r2"
    using assms
    apply (induction l1 l2 arbitrary: "prf" r1 r2 rule: split_common_prefix.induct)
    apply (auto split: split_if_asm prod.splits)
    done

end


section\<open>Some demonstrations\<close>

theory Demonstrations
  imports
    Definitions_Main
begin

text\<open>The following theory is only intended to explore some details of the
formalization and to show the appearance of relevant internalized formulas.
It is \<^bold>\<open>not\<close> intended as the entry point of the session. For that purpose,
consult \<^theory>\<open>Independence_CH.Definitions_Main\<close>\<close>

text\<open>The snippet (by M. Pagano) commented out below outputs a directed
graph picturing the locale structure.\<close>
\<comment> \<open>
ML\<open>Locale.pretty_locale_deps @{theory} |>
map (fn n => let val nom = #name n
    in  map (writeln o (fn p => "\"" ^ p ^ "\" -> \"" ^ nom ^ "\";")) (#parents n)
end)
\<close>
\<close>

locale Demo = M_trivial + M_AC +
  fixes t\<^sub>1 t\<^sub>2
  assumes
    ts_in_nat[simp]: "t\<^sub>1\<in>\<omega>" "t\<^sub>2\<in>\<omega>"
    and
    power_infty: "power_ax(M)" "M(\<omega>)"
begin

text\<open>The next fake lemma is intended to explore the instances of the axiom
schemes that are needed to build our forcing models. They are categorized as
plain replacements (using \<^term>\<open>strong_replacement\<close>), “lambda-replacements”
using a higher order function, replacements  to perform
transfinite and general well-founded recursion (using \<^term>\<open>transrec_replacement\<close> and
\<^term>\<open>wfrec_replacement\<close> respectively) and for the construction of fixpoints
(using \<^term>\<open>iterates_replacement\<close>). Lastly, separations instances.\<close>

lemma
  assumes
    sorried_replacements:
    "\<And>P. strong_replacement(M,P)"
    "\<And>F. lam_replacement(M,F)"
    "\<And>Q S. iterates_replacement(M,Q,S)"
    "\<And>Q S. wfrec_replacement(M,Q,S)"
    "\<And>Q S. transrec_replacement(M,Q,S)"
    and
    sorried_separations: "\<And>Q. separation(M,Q)"
  shows
    "M_master(M)"
  apply unfold_locales
                      apply
    (simp_all add:
      sorried_replacements(1-2)
      sorried_separations
      power_infty)
  oops

\<comment> \<open>NOTE: Only for pretty-printing purposes, overrides previous
  fundamental notations\<close>
no_notation mem (infixl \<open>\<in>\<close> 50)
no_notation conj  (infixr \<open>\<and>\<close> 35)
no_notation disj (infixr \<open>\<or>\<close> 30)
no_notation iff (infixr \<open>\<longleftrightarrow>\<close> 25)
no_notation imp (infixr \<open>\<longrightarrow>\<close> 25)
no_notation not (\<open>\<not> _\<close> [40] 40)
no_notation All (\<open>'(\<forall>_')\<close>)
no_notation Ex (\<open>'(\<exists>_')\<close>)

no_notation Member (\<open>\<cdot>_ \<in>/ _\<cdot>\<close>)
no_notation Equal (\<open>\<cdot>_ =/ _\<cdot>\<close>)
no_notation Nand (\<open>\<cdot>\<not>'(_ \<and>/ _')\<cdot>\<close>)
no_notation And (\<open>\<cdot>_ \<and>/ _\<cdot>\<close>)
no_notation Or (\<open>\<cdot>_ \<or>/ _\<cdot>\<close>)
no_notation Iff (\<open>\<cdot>_ \<leftrightarrow>/ _\<cdot>\<close>)
no_notation Implies (\<open>\<cdot>_ \<rightarrow>/ _\<cdot>\<close>)
no_notation Neg (\<open>\<cdot>\<not>_\<cdot>\<close>)
no_notation Forall (\<open>'(\<cdot>\<forall>(/_)\<cdot>')\<close>)
no_notation Exists (\<open>'(\<cdot>\<exists>(/_)\<cdot>')\<close>)

notation Member (infixl \<open>\<in>\<close> 50)
notation Equal (infixl \<open>\<equiv>\<close> 50)
notation Nand (\<open>\<not>'(_ \<and>/ _')\<close>)
notation And  (infixr \<open>\<and>\<close> 35)
notation Or (infixr \<open>\<or>\<close> 30)
notation Iff (infixr \<open>\<longleftrightarrow>\<close> 25)
notation Implies (infixr \<open>\<longrightarrow>\<close> 25)
notation Neg (\<open>\<not> _\<close> [40] 40)
notation Forall (\<open>'(\<forall>_')\<close>)
notation Exists (\<open>'(\<exists>_')\<close>)

lemma "forces(t\<^sub>1\<in>t\<^sub>2) = (0 \<in> 1 \<and> forces_mem_fm(1, 2, 0, t\<^sub>1+\<^sub>\<omega>4, t\<^sub>2+\<^sub>\<omega>4))"
  unfolding forces_def by simp

(*
\<comment> \<open>Prefix abbreviated notation\<close>
notation Member (\<open>M\<close>)
notation Equal (\<open>Eq\<close>)
notation Nand (\<open>Na\<close>)
notation And  (\<open>A\<close>)
notation Or (\<open>O\<close>)
notation Iff (\<open>If\<close>)
notation Implies (\<open>Im\<close>)
notation Neg (\<open>Ne\<close>)
notation Forall (\<open>Fo\<close>)
notation Exists (\<open>Ex\<close>)
*)

(* forces_mem_fm(1, 2, 0, t\<^sub>1+\<^sub>\<omega>4, t\<^sub>1+\<^sub>\<omega>4)
   = forces_mem_fm(1, 2, 0, succ(succ(succ(succ(t\<^sub>1)))), succ(succ(succ(succ(t\<^sub>2)))))
   = \<dots> *)

definition forces_0_mem_1 where "forces_0_mem_1\<equiv>forces_mem_fm(1,2,0,t\<^sub>1+\<^sub>\<omega>4,t\<^sub>2+\<^sub>\<omega>4)"
thm forces_0_mem_1_def[
    unfolded frc_at_fm_def ftype_fm_def
    name1_fm_def name2_fm_def snd_snd_fm_def hcomp_fm_def
    ecloseN_fm_def eclose_n1_fm_def eclose_n2_fm_def
    is_eclose_fm_def mem_eclose_fm_def eclose_n_fm_def
    is_If_fm_def least_fm_def Replace_fm_def Collect_fm_def
    fm_definitions,simplified]
  (* NOTE: in view of the above, @{thm [source] fm_definitions} might be incomplete *)

named_theorems incr_bv_new_simps

schematic_goal incr_bv_Neg(* [incr_bv_new_simps] *):
  "mem(n,\<omega>) \<Longrightarrow> mem(\<phi>,formula) \<Longrightarrow> incr_bv(Neg(\<phi>))`n = ?x"
  unfolding Neg_def by simp

schematic_goal incr_bv_Exists [incr_bv_new_simps]:
  "mem(n,\<omega>) \<Longrightarrow> mem(\<phi>,formula) \<Longrightarrow> incr_bv(Exists(\<phi>))`n = ?x"
  unfolding Exists_def by (simp add: incr_bv_Neg)
(*
schematic_goal incr_bv_And [incr_bv_new_simps]:
  "mem(n,\<omega>) \<Longrightarrow> mem(\<phi>,formula) \<Longrightarrow>mem(\<psi>,formula)\<Longrightarrow> incr_bv(And(\<phi>,\<psi>))`n = ?x"
  unfolding And_def by (simp add: incr_bv_Neg)

schematic_goal incr_bv_Or [incr_bv_new_simps]:
  "mem(n,\<omega>) \<Longrightarrow> mem(\<phi>,formula) \<Longrightarrow>mem(\<psi>,formula)\<Longrightarrow> incr_bv(Or(\<phi>,\<psi>))`n = ?x"
  unfolding Or_def by (simp add: incr_bv_Neg)

schematic_goal incr_bv_Implies [incr_bv_new_simps]:
  "mem(n,\<omega>) \<Longrightarrow> mem(\<phi>,formula) \<Longrightarrow>mem(\<psi>,formula)\<Longrightarrow> incr_bv(Implies(\<phi>,\<psi>))`n = ?x"
  unfolding Implies_def by (simp add: incr_bv_Neg)
*)

\<comment> \<open>The two renamings involved in the definition of \<^term>\<open>forces\<close> depend on
the recursive function \<^term>\<open>incr_bv\<close>. Here we have an apparently
exponential bottleneck, since all the propositional connectives (even \<^term>\<open>Neg\<close>)
duplicate the appearances of \<^term>\<open>incr_bv\<close>.

Not even the double negation of an atomic formula can be managed by the
system (in version 2021-1).\<close>
(*

schematic_goal "forces(\<not>\<not>0\<in>1) = ?x"
  unfolding forces_def Neg_def
   by (simp add:ren_forces_nand_def ren_forces_forall_def
      frc_at_fm_def ftype_fm_def
      name1_fm_def name2_fm_def snd_snd_fm_def hcomp_fm_def
      ecloseN_fm_def eclose_n1_fm_def eclose_n2_fm_def
      is_eclose_fm_def mem_eclose_fm_def eclose_n_fm_def
      is_If_fm_def least_fm_def Collect_fm_def
      fm_definitions incr_bv_Neg incr_bv_Exists)
(* exception Size raised (line 183 of "./basis/LibrarySupport.sml") *)

*)

(*
declare is_ContHyp_fm_def[fm_definitions del]

thm is_ContHyp_fm_def[unfolded is_eclose_fm_def mem_eclose_fm_def eclose_n_fm_def
   is_If_fm_def least_fm_def Replace_fm_def Collect_fm_def
   fm_definitions, simplified] *)

end \<comment> \<open>\<^locale>\<open>Demo\<close>\<close>

end


subsection\<open>Compactness\<close>

theory Compactness
imports Sema
begin

lemma fin_sat_extend: "fin_sat S \<Longrightarrow> fin_sat (insert F S) \<or> fin_sat (insert (\<^bold>\<not>F) S)"
proof (rule ccontr)
  assume fs: "fin_sat S"
  assume nfs: "\<not> (fin_sat (insert F S) \<or> fin_sat (insert (\<^bold>\<not> F) S))"
  from nfs obtain s1 where s1: "s1 \<subseteq> insert F S"       "finite s1" "\<not>sat s1" unfolding fin_sat_def by blast
  from nfs obtain s2 where s2: "s2 \<subseteq> insert (Not F) S" "finite s2" "\<not>sat s2" unfolding fin_sat_def by blast
  let ?u = "(s1 - {F}) \<union> (s2 - {Not F})"
  have "?u \<subseteq> S" "finite ?u" using s1 s2 by auto
  hence "sat ?u" using fs unfolding fin_sat_def by blast
  then obtain A where A: "\<forall>F \<in> ?u. A \<Turnstile> F" unfolding sat_def by blast
  have "A \<Turnstile> F \<or> A \<Turnstile> \<^bold>\<not>F" by simp
  hence "sat s1 \<or> sat s2" using A unfolding sat_def by(fastforce intro!: exI[where x=A])
  thus False using s1(3) s2(3) by simp
qed

context
begin

lemma fin_sat_antimono: "fin_sat F \<Longrightarrow> G \<subseteq> F \<Longrightarrow> fin_sat G" unfolding fin_sat_def by simp
lemmas fin_sat_insert = fin_sat_antimono[OF _ subset_insertI]

primrec extender :: "nat \<Rightarrow> ('a :: countable) formula set \<Rightarrow> 'a formula set" where
"extender 0 S = S" |
"extender (Suc n) S = (
  let r = extender n S;
  rt = insert (from_nat n) r;
  rf = insert (\<^bold>\<not>(from_nat n)) r
  in if fin_sat rf then rf else rt
)"

private lemma extender_fin_sat: "fin_sat S \<Longrightarrow> fin_sat (extender n S)"
proof(induction n arbitrary: S)
  case (Suc n)
  note mIH = Suc.IH[OF Suc.prems]
  show ?case proof(cases "fin_sat (insert (Not (from_nat n)) (extender n S))")
    case True thus ?thesis by simp
  next
    case False
    hence "fin_sat (insert ((from_nat n)) (extender n S))" using mIH fin_sat_extend by auto
    thus ?thesis by(simp add: Let_def)
  qed
qed simp

definition "extended S = \<Union>{extender n S|n. True}"

lemma extended_max: "F \<in> extended S \<or> Not F \<in> extended S"
proof -
  obtain n where [simp]: "F = from_nat n" by (metis from_nat_to_nat)
  have "F \<in> extender (Suc n) S \<or> Not F \<in> extender (Suc n) S" by(simp add: Let_def)
  thus ?thesis unfolding extended_def by blast
qed

private lemma extender_Sucset: "extender k S \<subseteq> extender (Suc k) S" by(force simp add: Let_def)
private lemma extender_deeper: "F \<in> extender k S \<Longrightarrow> k \<le> l \<Longrightarrow> F \<in> extender l S" using extender_Sucset le_Suc_eq
  by(induction l) (auto simp del: extender.simps)
private lemma extender_subset: "S \<subseteq> extender k S"
proof -
  from extender_deeper[OF _ le0] have "F \<in> extender 0 Sa \<Longrightarrow> F \<in> extender l Sa" for Sa l F .
  thus ?thesis by auto
qed

lemma extended_fin_sat:
  assumes "fin_sat S"
  shows  "fin_sat (extended S)"
proof -
  have assm: "\<lbrakk>s \<subseteq> extender n S; finite s\<rbrakk> \<Longrightarrow> sat s" for s n
    using extender_fin_sat[OF assms] unfolding fin_sat_def by presburger
  hence "sat s" if su: "s \<subseteq> \<Union>{extender n S |n. True}" and fin: "finite s" for s proof -
    { fix x assume e: "x \<in> s"
      with su have "x \<in> \<Union>{extender n S |n. True}" by blast
      hence "\<exists>n. x \<in> extender n S" unfolding Union_eq by blast }
    hence "\<forall>x \<in> s. \<exists>n. x \<in> extender n S" by blast
    from finite_set_choice[OF fin this] obtain f where cf: "\<forall>x\<in>s. x \<in> extender (f x) S" ..
    have "\<exists>k. s \<subseteq> \<Union>{extender n S |n. n \<le> k}" proof(intro exI subsetI)
      fix x assume e: "x \<in> s"
      with cf have "x \<in> extender (f x) S" ..
      hence "x \<in> extender (Max (f ` s)) S" by(elim extender_deeper; simp add: e fin)
      thus "x \<in> \<Union>{extender n S |n. n \<le> Max (f ` s)}" by blast
    qed
    moreover have "\<Union>{extender n S |n. n \<le> k} = extender k S" for k proof(induction k)
      case (Suc k)
      moreover have "\<Union>{extender n S |n. n \<le> Suc k} = \<Union>{extender n S |n. n \<le> k} \<union> extender (Suc k) S"
        unfolding Union_eq le_Suc_eq
        using le_Suc_eq by(auto simp del: extender.simps)
      ultimately show ?case using extender_Sucset by(force simp del: extender.simps)
    qed simp
    ultimately show "sat s" using assm fin by auto
  qed
  thus ?thesis unfolding extended_def fin_sat_def by presburger
qed

lemma extended_superset: "S \<subseteq> extended S" unfolding extended_def using extender.simps(1) by blast

lemma extended_complem:
  assumes fs: "fin_sat S"
  shows "(F \<in> extended S) \<noteq> (Not F \<in> extended S)"
proof -
  note fs = fs[THEN extended_fin_sat]
  show ?thesis proof(cases "F \<in> extended S")
    case False with extended_max show ?thesis by blast
  next
    case True have "Not F \<notin> extended S" proof
      assume False: "Not F \<in> extended S"
      with True have "{F, Not F} \<subseteq> extended S" by blast
      moreover have "finite {F, Not F}" by simp
      ultimately have "sat {F, Not F}" using fs unfolding fin_sat_def by blast
      thus False unfolding sat_def by simp
    qed
    with True show ?thesis by blast
  qed
qed

lemma not_fin_sat_extended_UNIV: fixes S :: "'a :: countable formula set" assumes "\<not>fin_sat S" shows "extended S = UNIV"
text\<open>Note that this crucially depends on the fact that we check \emph{first} whether adding @{term "\<^bold>\<not>F"} makes the set not satisfiable,
  and add @{term F} otherwise \emph{without any further checks}.
  The proof of compactness does (to the best of my knowledge) depend on neither of these two facts.\<close>
proof -
  from assms[unfolded fin_sat_def, simplified] obtain s :: "'a :: countable formula set"
    where "finite s" "\<not> sat s" by clarify
  from this(2)[unfolded sat_def, simplified] have "\<exists>x\<in>s. \<not> A \<Turnstile> x" for A ..
  have nfs: "\<not>fin_sat (insert x (extender n S))" for n x
    apply(rule notI)
    apply(drule fin_sat_insert)
    apply(drule fin_sat_antimono)
     apply(rule extender_subset)
    apply(erule notE[rotated])
    apply(fact assms)
  done
  have "x \<in> \<Union>{extender n S |n. True}" for x proof cases
    assume "x \<in> S" thus ?thesis by (metis extended_def extended_superset insert_absorb insert_subset)
  next
    assume "x \<notin> S"
    have "x \<in> extender (Suc (to_nat x)) S"
      unfolding extender.simps Let_def
      unfolding if_not_P[OF nfs] by simp
    thus ?thesis by blast
  qed
  thus ?thesis unfolding extended_def by auto
qed

lemma extended_tran: "S \<subseteq> T \<Longrightarrow> extended S \<subseteq> extended T"
text\<open>This lemma doesn't hold: think of making S empty and inserting a formula into T s.t. it can never be satisfied simultaneously with the first
non-tautological formula in the extension S. Showing that this is possible is not worth the effort, since we can't influence the ordering of formulae.
But we showed it anyway.\<close>
oops
lemma extended_not_increasing: "\<exists>S T. fin_sat S \<and> fin_sat T \<and> \<not> (S \<subseteq> T \<longrightarrow> extended S \<subseteq> extended (T :: 'a :: countable formula set))"
proof -
  have ex_then_min: "\<exists>x :: nat. P x \<Longrightarrow> P (LEAST x. P x)" for P using LeastI2_wellorder by auto
  define P where "P x = (let F = (from_nat x :: 'a formula) in (\<exists>A. \<not> A \<Turnstile> F) \<and> (\<exists> A. A \<Turnstile> F))" for x
  define x where "x = (LEAST n. P n)"
  hence "\<exists>n. P n" unfolding P_def Let_def by(auto intro!: exI[where x="to_nat (Atom undefined :: 'a formula)"])
  from ex_then_min[OF this] have Px: "P x" unfolding x_def .
  have lessx: "n < x \<Longrightarrow> \<not> P n" for n unfolding x_def using not_less_Least by blast
  let ?S = "{} :: 'a formula set" let ?T = "{from_nat x :: 'a formula}"
  have s: "fin_sat ?S" "fin_sat ?T" using Px unfolding P_def fin_sat_def sat_def Let_def by fastforce+
  have reject: "Q A \<Longrightarrow> \<forall>A. \<not> Q A \<Longrightarrow> False" for A Q by simp
  have "y \<le> x \<Longrightarrow> F \<in> extender y ?S \<Longrightarrow> \<Turnstile> F" for F y
  proof(induction y arbitrary: F)
    case (Suc y)
    have *: "F \<in> extender y {} \<Longrightarrow> \<Turnstile> F" for F :: "'a formula" using Suc.IH Suc.prems(1) by auto
    let ?Y = "from_nat y :: 'a formula"
    have ex: "(\<forall>A. \<not> A \<Turnstile> ?Y) \<or> \<Turnstile> ?Y" unfolding formula_semantics.simps by (meson P_def Suc.prems(1) Suc_le_lessD lessx)
    have 1: "\<forall>A. \<not> A \<Turnstile> ?Y" if "fin_sat (Not ?Y \<triangleright> extender y ?S)"
    proof -
      note[[show_types]]
      from that have "\<exists>A. A \<Turnstile> Not ?Y" unfolding fin_sat_def sat_def  by(elim allE[where x="{Not ?Y}"]) simp
      hence "\<not>\<Turnstile> ?Y" by simp
      hence "\<forall>A. \<not> A \<Turnstile> ?Y" using ex by argo
      thus ?thesis by simp
    qed
    have 2: "\<not> fin_sat (Not ?Y \<triangleright> extender y ?S) \<Longrightarrow> \<Turnstile> ?Y"
    proof(erule contrapos_np)
      assume "\<not> \<Turnstile> ?Y"
      hence "\<forall>A. \<not> A \<Turnstile> ?Y" using ex by argo
      hence "\<Turnstile> \<^bold>\<not> ?Y" by simp
      thus "fin_sat (\<^bold>\<not> ?Y \<triangleright> extender y ?S)" unfolding fin_sat_def sat_def
        by(auto intro!: exI[where x="\<lambda>_ :: 'a. False"] dest!: rev_subsetD[rotated] *)
    qed
    show ?case using Suc.prems(2) by(simp add: Let_def split: if_splits; elim disjE; simp add: * 1 2)
  qed simp
  hence "fin_sat (\<^bold>\<not> (from_nat x) \<triangleright> extender x ?S)" using Px unfolding P_def Let_def
    by (clarsimp simp: fin_sat_def sat_def) (insert formula_semantics.simps(3), blast)
  hence "Not (from_nat x) \<in> extender (Suc x) ?S" by(simp)
  hence "Not (from_nat x) \<in> extended ?S" unfolding extended_def by blast
  moreover have "Not (from_nat x) \<notin> extended ?T" using extended_complem extended_superset s(2) by blast
  ultimately show ?thesis using s by blast
qed

private lemma not_in_extended_FE: "fin_sat S \<Longrightarrow> (\<not>sat (insert (Not F) G)) \<Longrightarrow> F \<notin> extended S \<Longrightarrow> G \<subseteq> extended S \<Longrightarrow> finite G \<Longrightarrow> False"
proof(goal_cases)
  case 1
  hence "Not F \<in> extended S" using extended_max by blast
  thus False using 1 extended_fin_sat fin_sat_def
    by (metis Diff_eq_empty_iff finite.insertI insert_Diff_if)
qed

lemma extended_id: "extended (extended S) = extended S"
  using extended_complem extended_fin_sat extended_max extended_superset not_fin_sat_extended_UNIV
  by(intro equalityI[rotated] extended_superset) blast

(* This would be nicer, though\<dots>
inductive_set extended_set :: "form set \<Rightarrow> form set" for S where
"F \<in> S \<Longrightarrow> F \<in> extended_set S" |
"fin_sat (insert F (extended_set S)) \<or> F \<in> extended_set S \<Longrightarrow> F \<in> extended_set S"
but it can't work, as extended is not increasing (?) *)

lemma ext_model:
  assumes r: "fin_sat S"
  shows "(\<lambda>k. Atom k \<in> extended S) \<Turnstile> F \<longleftrightarrow> F \<in> extended S"
proof -
  note fs = r[THEN extended_fin_sat]
  have Elim: "F \<in> S \<and> G \<in> S \<Longrightarrow> {F,G} \<subseteq> S" "F \<in> S \<Longrightarrow> {F} \<subseteq> S" for F G S by simp+
  show ?thesis
  proof(induction F)
    case Atom thus ?case by(simp)
  next
    case Bot
    have False if "\<bottom> \<in> extended S" proof -
      have "finite {\<bottom>}" by simp
      moreover from that have "{\<bottom>} \<subseteq> extended S" by simp
      ultimately have "\<exists>A. A \<Turnstile> \<bottom>" using fs unfolding fin_sat_def sat_def
        by(elim allE[of _ "{\<bottom>}"]) simp
      thus False by simp
    qed
    thus ?case by auto
  next
    case (Not F)
    moreover have "A \<Turnstile> F \<noteq> A \<Turnstile> \<^bold>\<not>F" for A F by simp
    ultimately show ?case using extended_complem[OF r] by blast
  next
    case (And F G)
    have "(F \<in> extended S \<and> G \<in> extended S) = (F \<^bold>\<and> G \<in> extended S)" proof -
      have *: "\<not>sat {\<^bold>\<not> (F \<^bold>\<and> G), F, G}" "\<not>sat {\<^bold>\<not> F, (F \<^bold>\<and> G)}" "\<not>sat {\<^bold>\<not> G, (F \<^bold>\<and> G)}" unfolding sat_def by auto
      show ?thesis by(intro iffI; rule ccontr) (auto intro: *[THEN not_in_extended_FE[OF r]])
    qed
    thus ?case by(simp add: And)
  next
    case (Or F G)
    have "(F \<in> extended S \<or> G \<in> extended S) = (F \<^bold>\<or> G \<in> extended S)" proof -
      have "\<not>sat {\<^bold>\<not>(F \<^bold>\<or> G), F}" "\<not>sat {\<^bold>\<not>(F \<^bold>\<or> G), G}" unfolding sat_def by auto
      from this[THEN not_in_extended_FE[OF r]] have 1: "\<lbrakk>F \<in> extended S \<or> G \<in> extended S; F \<^bold>\<or> G \<notin> extended S\<rbrakk> \<Longrightarrow> False" by auto
      have "\<not>sat {\<^bold>\<not>F, \<^bold>\<not>G, F \<^bold>\<or> G}" unfolding sat_def by auto
      hence 2: "\<lbrakk>F \<^bold>\<or> G \<in> extended S; F \<notin> extended S; G \<notin> extended S\<rbrakk> \<Longrightarrow> False" using extended_max not_in_extended_FE[OF r] by fastforce
      show ?thesis by(intro iffI; rule ccontr) (auto intro: 1 2)
    qed
    thus ?case by(simp add: Or)
  next
    case (Imp F G)
    have "(F \<in> extended S \<longrightarrow> G \<in> extended S) = (F \<^bold>\<rightarrow> G \<in> extended S)" proof -
      have "\<not>sat {\<^bold>\<not>G, F, F \<^bold>\<rightarrow> G}" unfolding sat_def by auto
      hence 1: "\<lbrakk>F \<^bold>\<rightarrow> G \<in> extended S; F \<in> extended S; G \<notin> extended S\<rbrakk> \<Longrightarrow> False" using extended_max not_in_extended_FE[OF r] by blast
      have "\<not>sat {\<^bold>\<not>F,\<^bold>\<not>(F \<^bold>\<rightarrow> G)}" unfolding sat_def by auto
      hence 2: "\<lbrakk>F \<^bold>\<rightarrow> G \<notin> extended S; F \<notin> extended S\<rbrakk> \<Longrightarrow> False" using extended_max not_in_extended_FE[OF r] by blast
      have "\<not>sat {\<^bold>\<not>(F \<^bold>\<rightarrow> G),G}" unfolding sat_def by auto
      hence 3: "\<lbrakk>F \<^bold>\<rightarrow> G \<notin> extended S; G \<in> extended S\<rbrakk> \<Longrightarrow> False" using extended_max not_in_extended_FE[OF r] by blast
      show ?thesis by(intro iffI; rule ccontr) (auto intro: 1 2 3)
    qed
    thus ?case by(simp add: Imp)
  qed
qed

theorem compactness:
  fixes S :: "'a :: countable formula set"
  shows "sat S \<longleftrightarrow> fin_sat S" (is "?l = ?r")
proof
  assume ?l thus ?r unfolding sat_def fin_sat_def by blast
next
  assume r: ?r
  note ext_model[OF r, THEN iffD2]
  hence "\<forall>F\<in>S. (\<lambda>k. Atom k \<in> extended S) \<Turnstile> F" using extended_superset by blast
  thus ?l unfolding sat_def by blast
qed

corollary compact_entailment:
  fixes F :: "'a :: countable formula"
  assumes fent: "\<Gamma> \<TTurnstile> F"
  shows "\<exists>\<Gamma>'. finite \<Gamma>' \<and> \<Gamma>' \<subseteq> \<Gamma> \<and> \<Gamma>' \<TTurnstile> F"
proof -
  have ND_sem:  "\<Gamma> \<TTurnstile> F \<longleftrightarrow> \<not>sat (insert (\<^bold>\<not>F) \<Gamma>)"
    for \<Gamma> F unfolding sat_def entailment_def by auto
  obtain \<Gamma>' where 0: "finite \<Gamma>'" "\<Gamma>' \<TTurnstile> F" "\<Gamma>' \<subseteq> \<Gamma>" proof(goal_cases)
    from fent[unfolded ND_sem compactness] have "\<not> fin_sat (insert (\<^bold>\<not> F) \<Gamma>)" .
    from this[unfolded fin_sat_def] obtain s where s: "s \<subseteq> insert(\<^bold>\<not>F) \<Gamma>" "finite s" "\<not>sat s" by blast
    have 2: "finite (s - {\<^bold>\<not> F})" using s by simp
    have 3: "s - {\<^bold>\<not> F} \<TTurnstile> F" unfolding ND_sem using s(3) unfolding sat_def by blast
    have 4: "s - {\<^bold>\<not> F} \<subseteq> \<Gamma>" using s by blast
    case 1 from 2 3 4 show ?case by(intro 1[of "s - {Not F}"])
  qed
  thus ?thesis by blast
qed

corollary compact_to_formula:
  fixes F :: "'a :: countable formula"
  assumes fent: "\<Gamma> \<TTurnstile> F"
  obtains \<Gamma>' where "set \<Gamma>' \<subseteq> \<Gamma>" "\<Turnstile> (\<^bold>\<And>\<Gamma>') \<^bold>\<rightarrow> F"
proof goal_cases
  case 1
  note compact_entailment[OF assms]
  then guess \<Gamma>' ..
  moreover then obtain \<Gamma>'' where "\<Gamma>' = set \<Gamma>''" using finite_list by auto
  ultimately show thesis by(intro 1)  (blast, simp add: entailment_def)
qed

end

end