(*  Title:      Monad_Normalisation.thy
    Author:     Manuel Eberl, TU München
    Author:     Joshua Schneider, ETH Zurich
    Author:     Andreas Lochbihler, ETH Zurich

Normalisation of monadic expressions.
*)

section \<open>Normalisation of monadic expressions\<close>

theory Monad_Normalisation
imports "HOL-Probability.Probability"
keywords "print_monad_rules" :: diag
begin

text \<open>
  The standard monad laws
  \begin{gather}
    \label{eq:return:bind}
    \<open>return a \<bind> f = f a\<close>
    \\
    \label{eq:bind:return}
    \<open>x \<bind> return = x\<close>
    \\
    \label{eq:bind:assoc}
    \<open>(x \<bind> f) \<bind> g = x \<bind> (\<lambda>a. f a \<bind> g)\<close>
  \end{gather}
  yield a confluent and terminating rewrite system.
  Thus, when these equations are added to the simpset, the simplifier can normalise monadic
  expressions and decide the equivalence of monadic programs (in the free monad).

  However, many monads satisfy additional laws.
  In some monads, it is possible to discard unused effects
  \begin{gather}
    \label{eq:discard}
    \<open>x \<bind> (\<lambda>_. y) = y\<close>
  \end{gather}
  or duplicate effects
  \begin{gather}
    \label{eq:duplicate}
    \<open>x \<bind> (\<lambda>a. x \<bind> f a) = x \<bind> (\<lambda>a. f a a)\<close>
  \end{gather}
  or commute independent computations
  \begin{gather}
    \label{eq:commute}
    \<open>x \<bind> (\<lambda>a. y \<bind> f a) = y \<bind> (\<lambda>b. x \<bind> (\<lambda>a. f a b))\<close>.
  \end{gather}
  For example, @{typ "_ option"} satisfies \eqref{eq:duplicate} and \eqref{eq:commute},
  @{typ "_ set"} validates \eqref{eq:commute}, and
  @{typ "_ pmf"} satisfies \eqref{eq:discard} and \eqref{eq:commute}.
  Equations \eqref{eq:discard} and \eqref{eq:duplicate} can be directly used as rewrite rules.%
  \footnote{%
    If they both hold, then \eqref{eq:commute} holds, too \<^cite>\<open>"LochbihlerSchneider2016ITP"\<close>.
  }
  However, the simplifier does not handle \eqref{eq:commute} well because \eqref{eq:commute} is a
  higher-order permutative rewrite rule and ordered rewriting in the simplifier can only handle
  first-order permutative rewrite rules.
  Consequently, when \eqref{eq:commute} is added to the simpset, the simplifier will loop.

  This AFP entry implements a simproc for the simplifier to simplify HOL expressions over commutative
  monads based on ordered rewriting.  This yields a decision procedure for equality of monadic
  expressions in any (free) monad satisfying any of the laws (\ref{eq:discard}--\ref{eq:commute}).
  If further commutative operators show up in the HOL term, then the ordered rewrite system need not
  be confluent and the simproc only performs a best effort.  We do not know whether this general case
  can be solved by ordered rewriting as a complete solution would have to solve the graph isomorphism
  problem by term rewriting \<^cite>\<open>"Basin1994IPL"\<close>.
\<close>

ML_file \<open>monad_rules.ML\<close>

subsection \<open>Usage\<close>

text \<open>
  The monad laws \eqref{eq:return:bind}, \eqref{eq:bind:return}, \eqref{eq:bind:assoc}, \eqref{eq:commute}
  must be registered with the attribute @{attribute monad_rule}.
  The simproc does not need \eqref{eq:discard} and \eqref{eq:duplicate}, so these properties need not
  be registered, but can simply be added to the simpset if needed.
  The simproc is activated by including the bundle \<open>monad_normalisation\<close>.

  Additionally, distributivity laws for control operators like @{const If} and @{const case_nat}
  specialised to \<open>\<bind>\<close> can be declared with the attribute @{attribute monad_distrib}.
  Then, the simproc will also commute computations over these control operators.

  The set of registered monad laws can be inspected with the command @{command print_monad_rules}.
\<close>

subsection \<open>Registration of the monads from the Isabelle/HOL library\<close>

lemmas [monad_rule] = Set.bind_bind

lemma set_bind_commute [monad_rule]:
  fixes A :: "'a set" and B :: "'b set"
  shows "A \<bind> (\<lambda>x. B \<bind> C x) = B \<bind> (\<lambda>y. A \<bind> (\<lambda>x. C x y))"
  unfolding Set.bind_def by auto

lemma set_return_bind [monad_rule]:
  fixes A :: "'a \<Rightarrow> 'b set"
  shows "{x} \<bind> A = A x"
  unfolding Set.bind_def by auto

lemma set_bind_return [monad_rule]:
  fixes A :: "'a set"
  shows "A \<bind> (\<lambda>x. {x}) = A"
  unfolding Set.bind_def by auto

lemmas [monad_rule] = Predicate.bind_bind Predicate.bind_single Predicate.single_bind

lemma predicate_bind_commute [monad_rule]:
  fixes A :: "'a Predicate.pred" and B :: "'b Predicate.pred"
  shows "A \<bind> (\<lambda>x. B \<bind> C x) = B \<bind> (\<lambda>y. A \<bind> (\<lambda>x. C x y))"
  by (intro pred_eqI) auto

lemmas [monad_rule] = Option.bind_assoc Option.bind_lunit Option.bind_runit

lemma option_bind_commute [monad_rule]:
  fixes A :: "'a option" and B :: "'b option"
  shows "A \<bind> (\<lambda>x. B \<bind> C x) = B \<bind> (\<lambda>y. A \<bind> (\<lambda>x. C x y))"
  by (cases A) auto

lemmas [monad_rule] =
  bind_assoc_pmf
  bind_commute_pmf
  bind_return_pmf
  bind_return_pmf'

lemmas [monad_rule] =
  bind_spmf_assoc
  bind_commute_spmf
  bind_return_spmf
  return_bind_spmf

subsection \<open>Distributive operators\<close>

lemma bind_if [monad_distrib]:
  "f A (\<lambda>x. if P then B x else C x) = (if P then f A B else f A C)"
by simp

lemma bind_case_prod [monad_distrib]:
  "f A (\<lambda>x. case y of (a,b) \<Rightarrow> B a b x) = (case y of (a,b) \<Rightarrow> f A (B a b))"
by (simp split: prod.split)

lemma bind_case_sum [monad_distrib]:
  "f A (\<lambda>x. case y of Inl a \<Rightarrow> B a x | Inr a \<Rightarrow> C a x) =
    (case y of Inl a \<Rightarrow> f A (B a) | Inr a \<Rightarrow> f A (C a))"
by (simp split: sum.split)

lemma bind_case_option [monad_distrib]:
  "f A (\<lambda>x. case y of Some a \<Rightarrow> B a x | None \<Rightarrow> C x) =
    (case y of Some a \<Rightarrow> f A (B a) | None \<Rightarrow> f A C)"
by (simp split: option.split)

lemma bind_case_list [monad_distrib]:
  "f A (\<lambda>x. case y of [] \<Rightarrow> B x | y # ys \<Rightarrow> C y ys x) = (case y of [] \<Rightarrow> f A B | y # ys \<Rightarrow> f A (C y ys))"
by (simp split: list.split)

lemma bind_case_nat [monad_distrib]:
  "f A (\<lambda>x. case y of 0 \<Rightarrow> B x | Suc n \<Rightarrow> C n x) = (case y of 0 \<Rightarrow> f A B | Suc n \<Rightarrow> f A (C n))"
by (simp split: nat.split)

subsection \<open>Setup of the normalisation simproc\<close>

ML_file \<open>monad_normalisation.ML\<close>

simproc_setup monad_normalisation ("f x y") = \<open>K Monad_Normalisation.normalise_step\<close>
declare [[simproc del: monad_normalisation]]

text \<open>
  The following bundle enables normalisation of monadic expressions by the simplifier.
  We use @{attribute monad_rule_internal} instead of \<open>monad_rule[simp]\<close> such that
  the theorems in @{thm [source] monad_rule} get dynamically added to the simpset instead of
  only those that are in there when the bundle is declared.
\<close>

bundle monad_normalisation = [[simproc add: monad_normalisation, monad_rule_internal]]

end


section \<open>Miscellanneous Lemmas and Tools\<close>
theory Refine_Misc
imports
  Automatic_Refinement.Automatic_Refinement
  Refine_Mono_Prover
begin

text \<open>Basic configuration for monotonicity prover:\<close>
lemmas [refine_mono] = monoI monotoneI[of "(\<le>)" "(\<le>)"]
lemmas [refine_mono] = TrueI le_funI order_refl

lemma case_prod_mono[refine_mono]:
  "\<lbrakk>\<And>a b. p=(a,b) \<Longrightarrow> f a b \<le> f' a b\<rbrakk> \<Longrightarrow> case_prod f p \<le> case_prod f' p"
  by (auto split: prod.split)

lemma case_option_mono[refine_mono]:
  assumes "fn \<le> fn'"
  assumes "\<And>v. x=Some v \<Longrightarrow> fs v \<le> fs' v"
  shows "case_option fn fs x \<le> case_option fn' fs' x"
  using assms by (auto split: option.split)

lemma case_list_mono[refine_mono]:
  assumes "fn \<le> fn'"
  assumes "\<And>x xs. l=x#xs \<Longrightarrow> fc x xs \<le> fc' x xs"
  shows "case_list fn fc l \<le> case_list fn' fc' l"
  using assms by (auto split: list.split)

lemma if_mono[refine_mono]:
  assumes "b \<Longrightarrow> m1 \<le> m1'"
  assumes "\<not>b \<Longrightarrow> m2 \<le> m2'"
  shows "(if b then m1 else m2) \<le> (if b then m1' else m2')"
  using assms by auto

lemma let_mono[refine_mono]:
  "f x \<le> f' x' \<Longrightarrow> Let x f \<le> Let x' f'" by auto

subsection \<open>Uncategorized Lemmas\<close>
lemma all_nat_split_at: "\<forall>i::'a::linorder<k. P i \<Longrightarrow> P k \<Longrightarrow> \<forall>i>k. P i
  \<Longrightarrow> \<forall>i. P i"
  by (metis linorder_neq_iff)

subsection \<open>Well-Foundedness\<close>

lemma wf_no_infinite_down_chainI:
  assumes "\<And>f. \<lbrakk>\<And>i. (f (Suc i), f i)\<in>r\<rbrakk> \<Longrightarrow> False"
  shows "wf r"
  by (metis assms wf_iff_no_infinite_down_chain)

text \<open>This lemma transfers well-foundedness over a simulation relation.\<close>
lemma sim_wf:
  assumes WF: "wf (S'\<inverse>)"
  assumes STARTR: "(x0,x0')\<in>R"
  assumes SIM: "\<And>s s' t. \<lbrakk> (s,s')\<in>R; (s,t)\<in>S; (x0',s')\<in>S'\<^sup>* \<rbrakk>
    \<Longrightarrow> \<exists>t'. (s',t')\<in>S' \<and> (t,t')\<in>R"
  assumes CLOSED: "Domain S  \<subseteq> S\<^sup>*``{x0}"
  shows "wf (S\<inverse>)"
proof (rule wf_no_infinite_down_chainI, simp)
  txt \<open>
    Informal proof:
    Assume there is an infinite chain in \<open>S\<close>.
    Due to the closedness property of \<open>S\<close>, it can be extended to
    start at \<open>x0\<close>.
    Now, we inductively construct an infinite chain in \<open>S'\<close>, such that
    each element of the new chain is in relation with the corresponding
    element of the original chain:
      The first element is \<open>x0'\<close>.
      For any element \<open>i+1\<close>, the simulation property yields the next
      element.
    This chain contradicts well-foundedness of \<open>S'\<close>.
\<close>

  fix f
  assume CHAIN: "\<And>i. (f i, f (Suc i))\<in>S"
  txt \<open>Extend to start with \<open>x0\<close>\<close>
  obtain f' where CHAIN': "\<And>i. (f' i, f' (Suc i))\<in>S" and [simp]: "f' 0 = x0"
  proof -
    {
      fix x
      assume S: "x = f 0"
      from CHAIN have "f 0 \<in> Domain S" by auto
      with CLOSED have "(x0,x)\<in>S\<^sup>*" by (auto simp: S)
      then obtain g k where G0: "g 0 = x0" and X: "x = g k"
        and CH: "(\<forall>i<k. (g i, g (Suc i))\<in>S)"
      proof induct
        case base thus ?case by force
      next
        case (step y z) show ?case proof (rule step.hyps(3))
          fix g k
          assume "g 0 = x0" and "y = g k"
            and "\<forall>i<k. (g i, g (Suc i))\<in>S"
          thus ?case using \<open>(y,z)\<in>S\<close>
            by (rule_tac step.prems[where g="g(Suc k := z)" and k="Suc k"])
              auto
        qed
      qed
      define f' where "f' i = (if i<k then g i else f (i-k))" for i
      have "\<exists>f'. f' 0 = x0 \<and> (\<forall>i. (f' i, f' (Suc i))\<in>S)"
        apply (rule_tac x=f' in exI)
        apply (unfold f'_def)
        apply (rule conjI)
        using S X G0 apply (auto) []
        apply (rule_tac k=k in all_nat_split_at)
        apply (auto)
        apply (simp add: CH)
        apply (subgoal_tac "k = Suc i")
        apply (simp add: S[symmetric] CH X)
        apply simp
        apply (simp add: CHAIN)
        apply (subgoal_tac "Suc i - k = Suc (i-k)")
        using CHAIN apply simp
        apply simp
        done
    }
    then obtain f' where "\<forall>i. (f' i,f' (Suc i))\<in>S" and "f' 0 = x0" by blast
    thus ?thesis by (blast intro!: that)
  qed

  txt \<open>Construct chain in \<open>S'\<close>\<close>
  define g' where "g' = rec_nat x0' (\<lambda>i x. SOME x'.
          (x,x')\<in>S' \<and> (f' (Suc i),x')\<in>R \<and> (x0', x')\<in>S'\<^sup>* )"
  {
    fix i
    note [simp] = g'_def
    have "(g' i, g' (Suc i))\<in>S' \<and> (f' (Suc i),g' (Suc i))\<in>R
      \<and> (x0',g' (Suc i))\<in>S'\<^sup>*"
    proof (induct i)
      case 0
      from SIM[OF STARTR] CHAIN'[of 0] obtain t' where
        "(x0',t')\<in>S'" and "(f' (Suc 0),t')\<in>R" by auto
      moreover hence "(x0',t')\<in>S'\<^sup>*" by auto
      ultimately show ?case
        by (auto intro: someI2 simp: STARTR)
    next
      case (Suc i)
      with SIM[OF _ CHAIN'[of "Suc i"]]
      obtain t' where LS: "(g' (Suc i),t')\<in>S'" and "(f' (Suc (Suc i)),t')\<in>R"
        by auto
      moreover from LS Suc have "(x0', t')\<in>S'\<^sup>*" by auto
      ultimately show ?case
        apply simp
        apply (rule_tac a="t'" in someI2)
        apply auto
        done
    qed
  } hence S'CHAIN: "\<forall>i. (g' i, g'(Suc i))\<in>S'" by simp
  txt \<open>This contradicts well-foundedness\<close>
  with WF show False
    by (erule_tac wf_no_infinite_down_chainE[where f=g']) simp
qed

text \<open>Well-founded relation that approximates a finite set from below.\<close>
definition "finite_psupset S \<equiv> { (Q',Q). Q\<subset>Q' \<and> Q' \<subseteq> S }"
lemma finite_psupset_wf[simp, intro]: "finite S \<Longrightarrow> wf (finite_psupset S)"
  unfolding finite_psupset_def by (blast intro: wf_bounded_supset)

definition "less_than_bool \<equiv> {(a,b). a<(b::bool)}"
lemma wf_less_than_bool[simp, intro!]: "wf (less_than_bool)"
  unfolding less_than_bool_def
  by (auto simp: wf_def)
lemma less_than_bool_iff[simp]:
  "(x,y)\<in>less_than_bool \<longleftrightarrow> x=False \<and> y=True"
  by (auto simp: less_than_bool_def)

definition "greater_bounded N \<equiv> inv_image less_than (\<lambda>x. N-x)"
lemma wf_greater_bounded[simp, intro!]: "wf (greater_bounded N)" by (auto simp: greater_bounded_def)

lemma greater_bounded_Suc_iff[simp]: "(Suc x,x)\<in>greater_bounded N \<longleftrightarrow> Suc x \<le> N"
  by (auto simp: greater_bounded_def)

subsection \<open>Monotonicity and Orderings\<close>

lemma mono_const[simp, intro!]: "mono (\<lambda>_. c)" by (auto intro: monoI)
lemma mono_if: "\<lbrakk>mono S1; mono S2\<rbrakk> \<Longrightarrow>
  mono (\<lambda>F s. if b s then S1 F s else S2 F s)"
  apply rule
  apply (rule le_funI)
  apply (auto dest: monoD[THEN le_funD])
  done

lemma mono_infI: "mono f \<Longrightarrow> mono g \<Longrightarrow> mono (inf f g)"
  unfolding inf_fun_def
  apply (rule monoI)
  apply (metis inf_mono monoD)
  done

lemma mono_infI':
  "mono f \<Longrightarrow> mono g \<Longrightarrow> mono (\<lambda>x. inf (f x) (g x) :: 'b::lattice)"
  by (rule mono_infI[unfolded inf_fun_def])

lemma mono_infArg:
  fixes f :: "'a::lattice \<Rightarrow> 'b::order"
  shows "mono f \<Longrightarrow> mono (\<lambda>x. f (inf x X))"
  apply (rule monoI)
  apply (erule monoD)
  apply (metis inf_mono order_refl)
  done

lemma mono_Sup:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "mono f \<Longrightarrow> Sup (f`S) \<le> f (Sup S)"
  apply (rule Sup_least)
  apply (erule imageE)
  apply simp
  apply (erule monoD)
  apply (erule Sup_upper)
  done

lemma mono_SupI:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  assumes "mono f"
  assumes "S'\<subseteq>f`S"
  shows "Sup S' \<le> f (Sup S)"
  by (metis Sup_subset_mono assms mono_Sup order_trans)

lemma mono_Inf:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "mono f \<Longrightarrow> f (Inf S) \<le> Inf (f`S)"
  apply (rule Inf_greatest)
  apply (erule imageE)
  apply simp
  apply (erule monoD)
  apply (erule Inf_lower)
  done

lemma mono_funpow: "mono (f::'a::order \<Rightarrow> 'a) \<Longrightarrow> mono (f^^i)"
  apply (induct i)
  apply (auto intro!: monoI)
  apply (auto dest: monoD)
  done

lemma mono_id[simp, intro!]:
  "mono id"
  "mono (\<lambda>x. x)"
  by (auto intro: monoI)

declare SUP_insert[simp]

lemma (in semilattice_inf) le_infD1:
  "a \<le> inf b c \<Longrightarrow> a \<le> b" by (rule le_infE)
lemma (in semilattice_inf) le_infD2:
  "a \<le> inf b c \<Longrightarrow> a \<le> c" by (rule le_infE)
lemma (in semilattice_inf) inf_leI:
  "\<lbrakk> \<And>x. \<lbrakk> x\<le>a; x\<le>b \<rbrakk> \<Longrightarrow> x\<le>c \<rbrakk> \<Longrightarrow> inf a b \<le> c"
  by (metis inf_le1 inf_le2)

lemma top_Sup: "(top::'a::complete_lattice)\<in>A \<Longrightarrow> Sup A = top"
  by (metis Sup_upper top_le)
lemma bot_Inf: "(bot::'a::complete_lattice)\<in>A \<Longrightarrow> Inf A = bot"
  by (metis Inf_lower le_bot)

lemma mono_compD: "mono f \<Longrightarrow> x\<le>y \<Longrightarrow> f o x \<le> f o y"
  apply (rule le_funI)
  apply (auto dest: monoD le_funD)
  done

subsubsection \<open>Galois Connections\<close>
locale galois_connection =
  fixes \<alpha>::"'a::complete_lattice \<Rightarrow> 'b::complete_lattice" and \<gamma>
  assumes galois: "c \<le> \<gamma>(a) \<longleftrightarrow> \<alpha>(c) \<le> a"
begin
  lemma \<alpha>\<gamma>_defl: "\<alpha>(\<gamma>(x)) \<le> x"
  proof -
    have "\<gamma> x \<le> \<gamma> x" by simp
    with galois show "\<alpha>(\<gamma>(x)) \<le> x" by blast
  qed
  lemma \<gamma>\<alpha>_infl: "x \<le> \<gamma>(\<alpha>(x))"
  proof -
    have "\<alpha> x \<le> \<alpha> x" by simp
    with galois show "x \<le> \<gamma>(\<alpha>(x))" by blast
  qed

  lemma \<gamma>_mono: "mono \<gamma>"
    by rule (metis \<alpha>\<gamma>_defl galois inf_absorb1 le_infE)

  lemma dist_\<gamma>[simp]:
    "\<gamma> (inf a b) = inf (\<gamma> a) (\<gamma> b)"
    apply (rule order_antisym)
    apply (rule mono_inf[OF \<gamma>_mono])
    apply (simp add: galois)
    apply (simp add: galois[symmetric])
    done

  lemma dist_\<alpha>[simp]:
    "\<alpha> (sup a b) = sup (\<alpha> a) (\<alpha> b)"
    by (metis (no_types) \<alpha>_mono galois mono_sup order_antisym
      sup_ge1 sup_ge2 sup_least)

end

subsubsection \<open>Fixed Points\<close>
lemma mono_lfp_eqI:
  assumes MONO: "mono f"
  assumes FIXP: "f a \<le> a"
  assumes LEAST: "\<And>x. f x = x \<Longrightarrow> a\<le>x"
  shows "lfp f = a"
  apply (rule antisym)
  apply (rule lfp_lowerbound)
  apply (rule FIXP)
  by (metis LEAST MONO lfp_unfold)

lemma mono_gfp_eqI:
  assumes MONO: "mono f"
  assumes FIXP: "a \<le> f a"
  assumes GREATEST: "\<And>x. f x = x \<Longrightarrow> x\<le>a"
  shows "gfp f = a"
  apply (rule antisym)
  apply (metis GREATEST MONO gfp_unfold)
  apply (rule gfp_upperbound)
  apply (rule FIXP)
  done

lemma lfp_le_gfp': "mono f \<Longrightarrow> lfp f x \<le> gfp f x"
  by (rule le_funD[OF lfp_le_gfp])

(* Just a reformulation of lfp_induct *)
lemma lfp_induct':
  assumes M: "mono f"
  assumes IS: "\<And>m. \<lbrakk> m \<le> lfp f; m \<le> P \<rbrakk> \<Longrightarrow> f m \<le> P"
  shows "lfp f \<le> P"
  apply (rule lfp_induct[OF M])
  apply (rule IS)
  by simp_all

lemma lfp_gen_induct:
  \<comment> \<open>Induction lemma for generalized lfps\<close>
  assumes M: "mono f"
  notes MONO'[refine_mono] = monoD[OF M]
  assumes I0: "m0 \<le> P"
  assumes IS: "\<And>m. \<lbrakk>
      m \<le> lfp (\<lambda>s. sup m0 (f s));  \<comment> \<open>Assume already established invariants\<close>
      m \<le> P;                       \<comment> \<open>Assume invariant\<close>
      f m \<le> lfp (\<lambda>s. sup m0 (f s)) \<comment> \<open>Assume that step preserved est. invars\<close>
    \<rbrakk> \<Longrightarrow> f m \<le> P"                 \<comment> \<open>Show that step preserves invariant\<close>
  shows "lfp (\<lambda>s. sup m0 (f s)) \<le> P"
  apply (rule lfp_induct')
  apply (meson MONO' monoI order_mono_setup.refl sup_mono)
  apply (rule sup_least)
  apply (rule I0)
  apply (rule IS, assumption+)
  apply (subst lfp_unfold)
  apply (meson MONO' monoI order_mono_setup.refl sup_mono)
  apply (rule le_supI2)
  apply (rule monoD[OF M])
  .

subsubsection \<open>Connecting Complete Lattices and
  Chain-Complete Partial Orders\<close>
(* Note: Also connected by subclass now. However, we need both directions
  of embedding*)
lemma (in complete_lattice) is_ccpo: "class.ccpo Sup (\<le>) (<)"
  apply unfold_locales
  apply (erule Sup_upper)
  apply (erule Sup_least)
  done

lemma (in complete_lattice) is_dual_ccpo: "class.ccpo Inf (\<ge>) (>)"
  apply unfold_locales
  apply (rule less_le_not_le)
  apply (rule order_refl)
  apply (erule (1) order_trans)
  apply (erule (1) antisym)
  apply (erule Inf_lower)
  apply (erule Inf_greatest)
  done

lemma ccpo_mono_simp: "monotone (\<le>) (\<le>) f \<longleftrightarrow> mono f"
  unfolding monotone_def mono_def by simp
lemma ccpo_monoI: "mono f \<Longrightarrow> monotone (\<le>) (\<le>) f"
  by (simp add: ccpo_mono_simp)
lemma ccpo_monoD: "monotone (\<le>) (\<le>) f \<Longrightarrow> mono f"
  by (simp add: ccpo_mono_simp)

lemma dual_ccpo_mono_simp: "monotone (\<ge>) (\<ge>) f \<longleftrightarrow> mono f"
  unfolding monotone_def mono_def by auto
lemma dual_ccpo_monoI: "mono f \<Longrightarrow> monotone (\<ge>) (\<ge>) f"
  by (simp add: dual_ccpo_mono_simp)
lemma dual_ccpo_monoD: "monotone (\<ge>) (\<ge>) f \<Longrightarrow> mono f"
  by (simp add: dual_ccpo_mono_simp)

lemma ccpo_lfp_simp: "\<And>f. mono f \<Longrightarrow> ccpo.fixp Sup (\<le>) f = lfp f"
  apply (rule antisym)
  defer
  apply (rule lfp_lowerbound)
  apply (drule ccpo.fixp_unfold[OF is_ccpo ccpo_monoI, symmetric])
  apply simp

  apply (rule ccpo.fixp_lowerbound[OF is_ccpo ccpo_monoI], assumption)
  apply (simp add: lfp_unfold[symmetric])
  done

lemma ccpo_gfp_simp: "\<And>f. mono f \<Longrightarrow> ccpo.fixp Inf (\<ge>) f = gfp f"
  apply (rule antisym)
  apply (rule gfp_upperbound)
  apply (drule ccpo.fixp_unfold[OF is_dual_ccpo dual_ccpo_monoI, symmetric])
  apply simp

  apply (rule ccpo.fixp_lowerbound[OF is_dual_ccpo dual_ccpo_monoI], assumption)
  apply (simp add: gfp_unfold[symmetric])
  done

abbreviation "chain_admissible P \<equiv> ccpo.admissible Sup (\<le>) P"
abbreviation "is_chain \<equiv> Complete_Partial_Order.chain (\<le>)"
lemmas chain_admissibleI[intro?] = ccpo.admissibleI[where lub=Sup and ord="(\<le>)"]

abbreviation "dual_chain_admissible P \<equiv> ccpo.admissible Inf (\<lambda>x y. y\<le>x) P"
abbreviation "is_dual_chain \<equiv> Complete_Partial_Order.chain (\<lambda>x y. y\<le>x)"
lemmas dual_chain_admissibleI[intro?] =
  ccpo.admissibleI[where lub=Inf and ord="(\<lambda>x y. y\<le>x)"]

lemma dual_chain_iff[simp]: "is_dual_chain C = is_chain C"
  unfolding chain_def
  apply auto
  done

lemmas chain_dualI = iffD1[OF dual_chain_iff]
lemmas dual_chainI = iffD2[OF dual_chain_iff]

lemma is_chain_empty[simp, intro!]: "is_chain {}"
  by (rule chainI) auto
lemma is_dual_chain_empty[simp, intro!]: "is_dual_chain {}"
  by (rule dual_chainI) auto

lemma point_chainI: "is_chain M \<Longrightarrow> is_chain ((\<lambda>f. f x)`M)"
  by (auto intro: chainI le_funI dest: chainD le_funD)

text \<open>We transfer the admissible induction lemmas to complete
  lattices.\<close>
lemma lfp_cadm_induct:
  "\<lbrakk>chain_admissible P; P (Sup {}); mono f; \<And>x. P x \<Longrightarrow> P (f x)\<rbrakk> \<Longrightarrow> P (lfp f)"
  by (simp only: ccpo_mono_simp[symmetric] ccpo_lfp_simp[symmetric])
     (rule ccpo.fixp_induct[OF is_ccpo])

lemma gfp_cadm_induct:
  "\<lbrakk>dual_chain_admissible P; P (Inf {}); mono f; \<And>x. P x \<Longrightarrow> P (f x)\<rbrakk> \<Longrightarrow> P (gfp f)"
  by (simp only: dual_ccpo_mono_simp[symmetric] ccpo_gfp_simp[symmetric])
     (rule ccpo.fixp_induct[OF is_dual_ccpo])

subsubsection \<open>Continuity and Kleene Fixed Point Theorem\<close>
definition "cont f \<equiv> \<forall>C. C\<noteq>{} \<longrightarrow> f (Sup C) = Sup (f`C)"
definition "strict f \<equiv> f bot = bot"
definition "inf_distrib f \<equiv> strict f \<and> cont f"

lemma contI[intro?]: "\<lbrakk>\<And>C. C\<noteq>{} \<Longrightarrow> f (Sup C) = Sup (f`C)\<rbrakk> \<Longrightarrow> cont f"
  unfolding cont_def by auto
lemma contD: "cont f \<Longrightarrow> C\<noteq>{} \<Longrightarrow> f (Sup C) = Sup (f ` C)"
  unfolding cont_def by auto
lemma contD': "cont f \<Longrightarrow> C\<noteq>{} \<Longrightarrow> f (Sup C) = Sup (f ` C)"
  by (fact contD)

lemma strictD[dest]: "strict f \<Longrightarrow> f bot = bot"
  unfolding strict_def by auto
\<comment> \<open>We only add this lemma to the simpset for functions on the same type.
    Otherwise, the simplifier tries it much too often.\<close>
lemma strictD_simp[simp]: "strict f \<Longrightarrow> f (bot::'a::bot) = (bot::'a)"
  unfolding strict_def by auto

lemma strictI[intro?]: "f bot = bot \<Longrightarrow> strict f"
  unfolding strict_def by auto

lemma inf_distribD[simp]:
  "inf_distrib f \<Longrightarrow> strict f"
  "inf_distrib f \<Longrightarrow> cont f"
  unfolding inf_distrib_def by auto

lemma inf_distribI[intro?]: "\<lbrakk>strict f; cont f\<rbrakk> \<Longrightarrow> inf_distrib f"
  unfolding inf_distrib_def by auto

lemma inf_distribD'[simp]:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "inf_distrib f \<Longrightarrow> f (Sup C) = Sup (f`C)"
  apply (cases "C={}")
  apply (auto dest: inf_distribD contD')
  done

lemma inf_distrib_is_mono[simp]:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "inf_distrib f \<Longrightarrow> mono f"
  by simp

text \<open>Only proven for complete lattices here. Also holds for CCPOs.\<close>

theorem gen_kleene_lfp:
  fixes f:: "'a::complete_lattice \<Rightarrow> 'a"
  assumes CONT: "cont f"
  shows "lfp (\<lambda>x. sup m (f x)) = (SUP i. (f^^i) m)"
proof (rule antisym)
  let ?f = "(\<lambda>x. sup m (f x))"
  let ?K="{ (f^^i) m | i . True}"
  note MONO=cont_is_mono[OF CONT]
  note MONO'[refine_mono] = monoD[OF MONO]
  {
    fix i
    have "(f^^i) m \<le> lfp ?f"
      apply (induct i)
      apply simp
      apply (subst lfp_unfold)
      apply (meson MONO' monoI order_mono_setup.refl sup_mono)
      apply simp

      apply (subst lfp_unfold)
      apply (meson MONO' monoI order_mono_setup.refl sup_mono)
      apply simp
      by (metis MONO' le_supI2)
  } thus "(SUP i. (f^^i) m) \<le> lfp ?f" by (blast intro: SUP_least)
next
  let ?f = "(\<lambda>x. sup m (f x))"
  show "lfp ?f \<le> (SUP i. (f^^i) m)"
    apply (rule lfp_lowerbound)
    apply (rule sup_least)
    apply (rule order_trans[OF _ SUP_upper[where i=0]], simp_all) []
    apply (simp add: contD [OF CONT])
    apply (rule Sup_subset_mono)
    apply (auto)
    apply (rule_tac x="Suc i" in range_eqI)
    apply simp
    done
qed

theorem kleene_lfp:
  fixes f:: "'a::complete_lattice \<Rightarrow> 'a"
  assumes CONT: "cont f"
  shows "lfp f = (SUP i. (f^^i) bot)"
  using gen_kleene_lfp[OF CONT,where m=bot] by simp

theorem (* Detailed proof *)
  fixes f:: "'a::complete_lattice \<Rightarrow> 'a"
  assumes CONT: "cont f"
  shows "lfp f = (SUP i. (f^^i) bot)"
proof (rule antisym)
  let ?K="{ (f^^i) bot | i . True}"
  note MONO=cont_is_mono[OF CONT]
  {
    fix i
    have "(f^^i) bot \<le> lfp f"
      apply (induct i)
      apply simp
      apply simp
      by (metis MONO lfp_unfold monoD)
  } thus "(SUP i. (f^^i) bot) \<le> lfp f" by (blast intro: SUP_least)
next
  show "lfp f \<le> (SUP i. (f^^i) bot)"
    apply (rule lfp_lowerbound)
    apply (simp add: contD [OF CONT])
    apply (rule Sup_subset_mono)
    apply auto
    apply (rule_tac x="Suc i" in range_eqI)
    apply auto
    done
qed

(* Alternative proof of gen_kleene_lfp that re-uses standard Kleene, but is more tedious *)
lemma SUP_funpow_contracting:
  fixes f :: "'a \<Rightarrow> ('a::complete_lattice)"
  assumes C: "cont f"
  shows "f (SUP i. (f^^i) m) \<le> (SUP i. (f^^i) m)"
proof -
  have 1: "\<And>i x. f ((f^^i) x) = (f^^(Suc i)) x"
    by simp

  have "f (SUP i. (f^^i) m) = (SUP i. f ((f ^^ i) m))"
    by (subst contD[OF C]) (simp_all add: image_comp)
  also have "\<dots> \<le> (SUP i. (f^^i) m)"
    apply (rule SUP_least)
    apply (simp, subst 1)
    apply (rule SUP_upper)
    ..
  finally show ?thesis .
qed

lemma gen_kleene_chain_conv:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes C: "cont f"
  shows "(SUP i. (f^^i) m) = (SUP i. ((\<lambda>x. sup m (f x))^^i) bot)"
proof -
  let ?f' = "\<lambda>x. sup m (f x)"
  show ?thesis
  proof (intro antisym SUP_least)
    from C have C': "cont ?f'"
      unfolding cont_def
      by (simp add: SUP_sup_distrib[symmetric])

    fix i
    show "(f ^^ i) m \<le> (SUP i. (?f' ^^ i) bot)"
    proof (induction i)
      case 0 show ?case
        by (rule order_trans[OF _ SUP_upper[where i=1]]) auto
    next
      case (Suc i)
      from cont_is_mono[OF C, THEN monoD, OF Suc]
      have "(f ^^ (Suc i)) m \<le> f (SUP i. ((\<lambda>x. sup m (f x)) ^^ i) bot)"
        by simp
      also have "\<dots> \<le> sup m \<dots>" by simp
      also note SUP_funpow_contracting[OF C']
      finally show ?case .
    qed
  next
    fix i
    show "(?f'^^i) bot \<le> (SUP i. (f^^i) m)"
    proof (induction i)
      case 0 thus ?case by simp
    next
      case (Suc i)
      from monoD[OF cont_is_mono[OF C] Suc]
      have "(?f'^^Suc i) bot \<le> sup m (f (SUP i. (f ^^ i) m))"
        by (simp add: le_supI2)
      also have "\<dots> \<le> (SUP i. (f ^^ i) m)"
        apply (rule sup_least)
        apply (rule order_trans[OF _ SUP_upper[where i=0]], simp_all) []
        apply (rule SUP_funpow_contracting[OF C])
        done
      finally show ?case .
    qed
  qed
qed

theorem
  assumes C: "cont f"
  shows "lfp (\<lambda>x. sup m (f x)) = (SUP i. (f^^i) m)"
  apply (subst gen_kleene_chain_conv[OF C])
  apply (rule kleene_lfp)
    using C
    unfolding cont_def
    apply (simp add: SUP_sup_distrib[symmetric])
  done

lemma (in galois_connection) dual_inf_dist_\<gamma>: "\<gamma> (Inf C) = Inf (\<gamma>`C)"
  apply (rule antisym)
  apply (rule Inf_greatest)
  apply clarify
  apply (rule monoD[OF \<gamma>_mono])
  apply (rule Inf_lower)
  apply simp

  apply (subst galois)
  apply (rule Inf_greatest)
  apply (subst galois[symmetric])
  apply (rule Inf_lower)
  apply simp
  done

lemma (in galois_connection) inf_dist_\<alpha>: "inf_distrib \<alpha>"
  apply (rule inf_distribI')
  apply (rule antisym)

  apply (subst galois[symmetric])
  apply (rule Sup_least)
  apply (subst galois)
  apply (rule Sup_upper)
  apply simp

  apply (rule Sup_least)
  apply clarify
  apply (rule monoD[OF \<alpha>_mono])
  apply (rule Sup_upper)
  apply simp
  done

subsection \<open>Maps\<close>
subsubsection \<open>Key-Value Set\<close>

  lemma map_to_set_simps[simp]:
    "map_to_set Map.empty = {}"
    "map_to_set [a\<mapsto>b] = {(a,b)}"
    "map_to_set (m|`K) = map_to_set m \<inter> K\<times>UNIV"
    "map_to_set (m(x:=None)) = map_to_set m - {x}\<times>UNIV"
    "map_to_set (m(x\<mapsto>v)) = map_to_set m - {x}\<times>UNIV \<union> {(x,v)}"
    "map_to_set m \<inter> dom m\<times>UNIV = map_to_set m"
    "m k = Some v \<Longrightarrow> (k,v)\<in>map_to_set m"
    "single_valued (map_to_set m)"
    apply (simp_all)
    by (auto simp: map_to_set_def restrict_map_def split: if_split_asm
      intro: single_valuedI)

  lemma map_to_set_inj:
    "(k,v)\<in>map_to_set m \<Longrightarrow> (k,v')\<in>map_to_set m \<Longrightarrow> v = v'"
    by (auto simp: map_to_set_def)

end


theory Sep_Generic_Wp
imports
  "../lib/Sep_Algebra_Add"
  "../lib/Frame_Infer"
  "../lib/Monad"
begin

section \<open>General VCG Setup for Separation Logic\<close>

(* TODO: Move to Library *)

locale generic_wp_defs =
  fixes wp :: "'c \<Rightarrow> ('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool"
begin
  definition "htripleF \<alpha> F P c Q \<equiv> (\<forall>s. (P**F) (\<alpha> s) \<longrightarrow>
      wp c (\<lambda>r s'. (Q r ** F) (\<alpha> s')) s)"

  definition "htriple \<alpha> P c Q \<equiv> (\<forall>F s. (P**F) (\<alpha> s) \<longrightarrow>
      wp c (\<lambda>r s'. (Q r ** F) (\<alpha> s')) s)"

  lemma htriple_as_F_eq: "htriple \<alpha> P c Q = (\<forall>F. htripleF \<alpha> F P c Q)"
    unfolding htriple_def htripleF_def by blast

end

locale generic_wp = generic_wp_defs wp
  for wp :: "'c \<Rightarrow> ('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool" +
  assumes wp_mono: "Q\<le>Q' \<Longrightarrow> wp c Q \<le> wp c Q'"
begin

  lemma wp_monoI:
    assumes "wp c Q s"
    assumes "\<And>r x. Q r x \<Longrightarrow> Q' r x"
    shows "wp c Q' s"
    using assms wp_mono[of Q Q' c] by auto

  lemma htripleI:
    assumes "\<And>F s. (P**F) (\<alpha> s) \<Longrightarrow> wp c (\<lambda>r s'. (Q r ** F) (\<alpha> s')) s"
    shows "htriple \<alpha> P c Q"
    using assms by (auto simp: htriple_def)

  lemma htripleFI:
    assumes "\<And>s. (P**F) (\<alpha> s) \<Longrightarrow> wp c (\<lambda>r s'. (Q r ** F) (\<alpha> s')) s"
    shows "htripleF \<alpha> F P c Q"
    using assms by (auto simp: htripleF_def)

  lemma htripleD:
    assumes "htriple \<alpha> P c Q"
    assumes "(P**F) (\<alpha> s)"
    shows "wp c (\<lambda>r s'. (Q r ** F) (\<alpha> s')) s"
    using assms by (auto simp: htriple_def)

  lemma htriple_triv[simp, intro!]: "htriple \<alpha> sep_false c Q"
    by (auto simp: htriple_def)

  lemma frame_rule: "htriple \<alpha> P c Q \<Longrightarrow> htriple \<alpha> (P ** F) c (\<lambda>r. Q r ** F)"
    unfolding htriple_def
    by (fastforce)

  lemma cons_rule:
    assumes "htriple \<alpha> P c Q"
    assumes "\<And>s. P' s \<Longrightarrow> P s"
    assumes "\<And>r s. Q r s \<Longrightarrow> Q' r s"
    shows "htriple \<alpha> P' c Q'"
    unfolding htriple_def
  proof clarsimp
    fix F s
    assume "(P' \<and>* F) (\<alpha> s)"
    with assms(2) have "(P \<and>* F) (\<alpha> s)"
      using sep_conj_impl1 by blast
    with assms(1) have "wp c (\<lambda>r s'. (Q r \<and>* F) (\<alpha> s')) s"
      unfolding htriple_def by auto
    thus "wp c (\<lambda>r s'. (Q' r \<and>* F) (\<alpha> s')) s"
      apply (rule wp_monoI)
      using assms(3)
      using sep_conj_impl1 by blast
  qed

  lemma cons_post_rule:
    assumes "htriple \<alpha> P c Q"
    assumes "\<And>r s. Q r s \<Longrightarrow> Q' r s"
    shows "htriple \<alpha> P c Q'"
    using cons_rule assms by blast

  lemma htriple_alt:
    "htriple \<alpha> P c Q
      = (\<forall>p s f. p##f \<and> \<alpha> s = p + f \<and> P p \<longrightarrow> wp c (\<lambda>r s'. \<exists>p'. p'##f \<and> \<alpha> s'=p'+f \<and> Q r p') s)"
  proof (rule iffI, goal_cases)
    case 1
    show ?case
      using htripleD[OF 1, where F="EXACT x" for x]
        by (auto simp: sep_conj_def)

  next
    case 2
    show ?case proof (rule htripleI)
      fix F s
      assume "(P \<and>* F) (\<alpha> s)"
      then obtain p f where "p##f" "P p" "F f" "\<alpha> s = p+f"
        by (blast elim: sep_conjE)
      with 2 have "wp c (\<lambda>r s'. \<exists>p'. p' ## f \<and> \<alpha> s' = p' + f \<and> Q r p') s" by blast
      then show "wp c (\<lambda>r s'. (Q r \<and>* F) (\<alpha> s')) s"
        apply (rule wp_monoI)
        using \<open>F f\<close> by (auto intro: sep_conjI)
    qed
  qed

  lemma htripleI':
    assumes "\<And>p s f. \<lbrakk> p##f; \<alpha> s = p + f; P p\<rbrakk> \<Longrightarrow> wp c (\<lambda>r s'. \<exists>p'. p'##f \<and> \<alpha> s'=p'+f \<and> Q r p') s"
    shows "htriple \<alpha> P c Q"
    using assms by (auto simp: htriple_alt)

  lemma htripleD':
    assumes "htriple \<alpha> P c Q"
    assumes "p##f" "\<alpha> s = p + f" "P p"
    shows "wp c (\<lambda>r s'. \<exists>p'. p'##f \<and> \<alpha> s'=p'+f \<and> Q r p') s"
    using assms by (auto simp: htriple_alt)

  lemma htriple_extract_pre_pure:
    "htriple \<alpha> (\<up>\<Phi>**P) c Q \<longleftrightarrow> \<Phi> \<longrightarrow> htriple \<alpha> P c Q"
    by (cases \<Phi>) (auto simp: sep_algebra_simps)

  (*
  lemma htriple_extract_pre_EXS:
    assumes "\<And>x s. \<Phi> x \<Longrightarrow> P s \<Longrightarrow> f x ## s"
    shows "htriple \<alpha> (EXS x. \<up>\<Phi> x ** EXACT (f x) ** P) c Q \<longleftrightarrow> (\<exists>x. \<Phi> x \<and> htriple \<alpha> (EXACT (f x) ** P) c Q)"
    apply rule
  *)

  thm htripleD

  thm option.simps

  lemma sv_htripleD:
    assumes "htriple \<alpha> P c Q"
    assumes "(P**F) (\<alpha> s)"
    assumes "\<And>r s. (Q r ** F) (\<alpha> s) \<Longrightarrow> Q' r s"
    shows "wp c Q' s"
    using assms
    by (force simp: htriple_def intro: wp_monoI)

  lemma sv_htripleFD:
    assumes "htripleF \<alpha> F P c Q"
    assumes "(P**F) (\<alpha> s)"
    assumes "\<And>r s. (Q r ** F) (\<alpha> s) \<Longrightarrow> Q' r s"
    shows "wp c Q' s"
    using assms
    by (force simp: htripleF_def intro: wp_monoI)

end

definition STATE :: "('s \<Rightarrow> 'a::sep_algebra) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool"
  where "STATE \<alpha> P s \<equiv> P (\<alpha> s)"

lemma STATE_assn_cong[fri_extract_congs]: "P\<equiv>P' \<Longrightarrow> STATE \<alpha> P s \<equiv> STATE \<alpha> P' s" by simp

lemma STATE_extract[vcg_normalize_simps]:
  "STATE \<alpha> (\<up>\<Phi>) h \<longleftrightarrow> \<Phi> \<and> STATE \<alpha> \<box> h"
  "STATE \<alpha> (\<up>\<Phi> ** P) h \<longleftrightarrow> \<Phi> \<and> STATE \<alpha> P h"
  "STATE \<alpha> (EXS x. Q x) h \<longleftrightarrow> (\<exists>x. STATE \<alpha> (Q x) h)"
  "STATE \<alpha> (\<lambda>_. False) h \<longleftrightarrow> False"
  "STATE \<alpha> ((\<lambda>_. False) ** P) h \<longleftrightarrow> False"
  by (auto simp: STATE_def sep_algebra_simps pred_lift_extract_simps)

definition POSTCOND :: "('s \<Rightarrow> 'a::sep_algebra) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool"
  where [vcg_tag_defs]: "POSTCOND \<alpha> \<equiv> STATE \<alpha>"

lemma POSTCONDI:
  "STATE \<alpha> A h \<Longrightarrow> POSTCOND \<alpha> A h"
  by (auto simp add: POSTCOND_def)
lemma POSTCOND_cong[vcg_normalize_congs]: "POSTCOND \<alpha> A = POSTCOND \<alpha> A" ..

lemma POSTCOND_triv_simps[vcg_normalize_simps]:
  "POSTCOND \<alpha> sep_true h"
  "\<not>POSTCOND \<alpha> sep_false h"
  unfolding POSTCOND_def STATE_def by auto

lemma start_entailsE:
  assumes "STATE \<alpha> P h"
  assumes "ENTAILS P P'"
  shows "STATE \<alpha> P' h"
  using assms unfolding STATE_def ENTAILS_def entails_def
  by auto

declaration \<open>
  K (Basic_VCG.add_xformer (@{thms POSTCONDI},@{binding postcond_xformer},
    fn ctxt => eresolve_tac ctxt @{thms start_entailsE}
  ))
\<close>

named_theorems htriple_vcg_intros
named_theorems htriple_vcg_intro_congs
definition [vcg_tag_defs]: "DECOMP_HTRIPLE \<phi> \<equiv> \<phi>"
lemma DECOMP_HTRIPLEI: "\<phi> \<Longrightarrow> DECOMP_HTRIPLE \<phi>" unfolding vcg_tag_defs by simp

context generic_wp begin
  thm frame_rule
  thm cons_rule

  lemma htriple_vcg_frame_erule[vcg_frame_erules]:
    assumes S: "STATE \<alpha> P' s"
    assumes F: "PRECOND (FRAME P' P F)"
    assumes HT: "htriple \<alpha> P c Q"
    assumes P: "\<And>r s. STATE \<alpha> (Q r ** F) s \<Longrightarrow> PRECOND (EXTRACT (Q' r s))"
    shows "wp c Q' s"
  proof -
    from S F have "(P \<and>* F) (\<alpha> s)"
      unfolding vcg_tag_defs
      by (metis (no_types) FRAME_def entails_def STATE_def)
    with P show ?thesis
      unfolding vcg_tag_defs
      by (metis (no_types) STATE_def sv_htripleD[OF HT])

  qed

  lemma htripleF_vcg_frame_erule[vcg_frame_erules]:
    assumes S: "STATE \<alpha> P' s"
    assumes F: "PRECOND (FRAME P' P F)"
    assumes HT: "htripleF \<alpha> F P c Q"
    assumes P: "\<And>r s. STATE \<alpha> (Q r ** F) s \<Longrightarrow> PRECOND (EXTRACT (Q' r s))"
    shows "wp c Q' s"
  proof -
    from S F have "(P \<and>* F) (\<alpha> s)"
      unfolding vcg_tag_defs
      by (metis (no_types) FRAME_def entails_def STATE_def)
    with P show ?thesis
      unfolding vcg_tag_defs
      by (metis (no_types) STATE_def sv_htripleFD[OF HT])

  qed

  lemma htriple_vcgI':
    assumes "\<And>F s. STATE \<alpha> (P**F) s \<Longrightarrow> wp c (\<lambda>r. POSTCOND \<alpha> (Q r ** F)) s"
    shows "htriple \<alpha> P c Q"
    apply (rule htripleI)
    using assms unfolding vcg_tag_defs STATE_def .

  lemma htriple_vcgI[htriple_vcg_intros]:
    assumes "\<And>F s. STATE \<alpha> (P**F) s \<Longrightarrow> EXTRACT (wp c (\<lambda>r. POSTCOND \<alpha> (Q r ** F)) s)"
    shows "htriple \<alpha> P c Q"
    apply (rule htripleI)
    using assms unfolding vcg_tag_defs STATE_def .

  lemma htripleF_vcgI[htriple_vcg_intros]:
    assumes "\<And>s. STATE \<alpha> (P**F) s \<Longrightarrow> EXTRACT (wp c (\<lambda>r. POSTCOND \<alpha> (Q r ** F)) s)"
    shows "htripleF \<alpha> F P c Q"
    apply (rule htripleFI)
    using assms unfolding vcg_tag_defs STATE_def .

  lemma htriple_decompI[vcg_decomp_rules]:
    "DECOMP_HTRIPLE (htriple \<alpha> P c Q) \<Longrightarrow> htriple \<alpha> P c Q"
    "DECOMP_HTRIPLE (htripleF \<alpha> F P c Q) \<Longrightarrow> htripleF \<alpha> F P c Q"
    unfolding vcg_tag_defs by auto

  lemma htriple_assn_cong[htriple_vcg_intro_congs]:
    "P\<equiv>P' \<Longrightarrow> Q\<equiv>Q' \<Longrightarrow>  htriple \<alpha> P c Q \<equiv> htriple \<alpha> P' c Q'" by simp

  lemma htripleF_assn_cong[htriple_vcg_intro_congs]:
    "P\<equiv>P' \<Longrightarrow> Q\<equiv>Q' \<Longrightarrow>  htripleF \<alpha> F P c Q \<equiv> htripleF \<alpha> F P' c Q'" by simp

  lemma htriple_ent_pre:
    "P\<turnstile>P' \<Longrightarrow> htriple \<alpha> P' c Q \<Longrightarrow> htriple \<alpha> P c Q"
    unfolding entails_def
    apply (erule cons_rule) by blast+

  lemma htriple_ent_post:
    "\<lbrakk>\<And>r. Q r \<turnstile> Q' r\<rbrakk> \<Longrightarrow> htriple \<alpha> P c Q \<Longrightarrow> htriple \<alpha> P c Q'"
    unfolding entails_def
    apply (erule cons_rule) by blast+

  lemma htriple_pure_preI: "\<lbrakk>pure_part P \<Longrightarrow> htriple \<alpha> P c Q\<rbrakk> \<Longrightarrow> htriple \<alpha> P c Q"
    by (meson htriple_def pure_partI sep_conjE)

end

declaration \<open>
  K (Basic_VCG.add_xformer (@{thms DECOMP_HTRIPLEI},@{binding decomp_htriple_xformer},
    fn ctxt =>
      (full_simp_tac (put_simpset HOL_basic_ss ctxt
        addsimps (Named_Theorems.get ctxt @{named_theorems vcg_tag_defs})
        |> fold Simplifier.add_cong (Named_Theorems.get ctxt @{named_theorems htriple_vcg_intro_congs})
      ))
      THEN' resolve_tac ctxt (Named_Theorems.get ctxt @{named_theorems htriple_vcg_intros})
  ))
\<close>

section \<open>Setup for mres-Monad\<close>

  definition "wp c Q s \<equiv> mwp (run c s) bot bot bot Q"
  definition "wlp c Q s \<equiv> mwp (run c s) top top top Q"

  (* Definition for presentation in paper *)
  lemma "wp c Q s = (\<exists>r s'. run c s = SUCC r s' \<and> Q r s')"
    unfolding wp_def mwp_def by (auto split: mres.splits)

  lemma wlp_true[simp, intro!]:
    "wlp c (\<lambda>_ _. True) s"
    "wlp c top s"
    by (auto simp: wlp_def mwp_def split: mres.splits)

  interpretation generic_wp wp
    by unfold_locales (auto simp: wp_def elim!: mwp_cons)

  lemma wp_return[vcg_normalize_simps]: "wp (return x) Q s \<longleftrightarrow> Q x s"
    by (auto simp: wp_def run_simps)

  lemma wp_fail[vcg_normalize_simps]: "\<not> wp (fail x) Q s"
    by (auto simp: wp_def run_simps)

  lemma wp_fcheck[vcg_normalize_simps]: "wp (fcheck e \<Phi>) Q s \<longleftrightarrow> \<Phi> \<and> Q () s"
    by (auto simp: wp_def run_simps)

  lemma wp_bind[vcg_normalize_simps]: "wp (m\<bind>f) Q s = wp m (\<lambda>x. wp (f x) Q) s"
    by (auto simp: wp_def run_simps)

  thm vcg_normalize_simps

end


(*  Title:      HOL/UNITY/Follows.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge
*)

section\<open>The Follows Relation of Charpentier and Sivilotte\<close>

theory Follows
imports SubstAx ListOrder "HOL-Library.Multiset"
begin

definition Follows :: "['a => 'b::{order}, 'a => 'b::{order}] => 'a program set" (infixl "Fols" 65) where
   "f Fols g == Increasing g \<inter> Increasing f Int
                Always {s. f s \<le> g s} Int
                (\<Inter>k. {s. k \<le> g s} LeadsTo {s. k \<le> f s})"

(*Does this hold for "invariant"?*)
lemma mono_Always_o:
     "mono h ==> Always {s. f s \<le> g s} \<subseteq> Always {s. h (f s) \<le> h (g s)}"
apply (simp add: Always_eq_includes_reachable)
apply (blast intro: monoD)
done

lemma mono_LeadsTo_o:
     "mono (h::'a::order => 'b::order)
      ==> (\<Inter>j. {s. j \<le> g s} LeadsTo {s. j \<le> f s}) \<subseteq>
          (\<Inter>k. {s. k \<le> h (g s)} LeadsTo {s. k \<le> h (f s)})"
apply auto
apply (rule single_LeadsTo_I)
apply (drule_tac x = "g s" in spec)
apply (erule LeadsTo_weaken)
apply (blast intro: monoD order_trans)+
done

lemma Follows_constant [iff]: "F \<in> (%s. c) Fols (%s. c)"
by (simp add: Follows_def)

lemma mono_Follows_o:
  assumes "mono h"
  shows "f Fols g \<subseteq> (h o f) Fols (h o g)"
proof
  fix x
  assume "x \<in> f Fols g"
  with assms show "x \<in> (h \<circ> f) Fols (h \<circ> g)"
  by (auto simp add: Follows_def mono_Increasing_o [THEN [2] rev_subsetD]
    mono_Always_o [THEN [2] rev_subsetD]
    mono_LeadsTo_o [THEN [2] rev_subsetD, THEN INT_D])
qed

lemma mono_Follows_apply:
     "mono h ==> f Fols g \<subseteq> (%x. h (f x)) Fols (%x. h (g x))"
apply (drule mono_Follows_o)
apply (force simp add: o_def)
done

lemma Follows_trans:
     "[| F \<in> f Fols g;  F \<in> g Fols h |] ==> F \<in> f Fols h"
apply (simp add: Follows_def)
apply (simp add: Always_eq_includes_reachable)
apply (blast intro: order_trans LeadsTo_Trans)
done

subsection\<open>Destruction rules\<close>

lemma Follows_Increasing1: "F \<in> f Fols g ==> F \<in> Increasing f"
by (simp add: Follows_def)

lemma Follows_Increasing2: "F \<in> f Fols g ==> F \<in> Increasing g"
by (simp add: Follows_def)

lemma Follows_Bounded: "F \<in> f Fols g ==> F \<in> Always {s. f s \<le> g s}"
by (simp add: Follows_def)

lemma Follows_LeadsTo:
     "F \<in> f Fols g ==> F \<in> {s. k \<le> g s} LeadsTo {s. k \<le> f s}"
by (simp add: Follows_def)

lemma Follows_LeadsTo_pfixLe:
     "F \<in> f Fols g ==> F \<in> {s. k pfixLe g s} LeadsTo {s. k pfixLe f s}"
apply (rule single_LeadsTo_I, clarify)
apply (drule_tac k="g s" in Follows_LeadsTo)
apply (erule LeadsTo_weaken)
 apply blast
apply (blast intro: pfixLe_trans prefix_imp_pfixLe)
done

lemma Follows_LeadsTo_pfixGe:
     "F \<in> f Fols g ==> F \<in> {s. k pfixGe g s} LeadsTo {s. k pfixGe f s}"
apply (rule single_LeadsTo_I, clarify)
apply (drule_tac k="g s" in Follows_LeadsTo)
apply (erule LeadsTo_weaken)
 apply blast
apply (blast intro: pfixGe_trans prefix_imp_pfixGe)
done

lemma Always_Follows1:
     "[| F \<in> Always {s. f s = f' s}; F \<in> f Fols g |] ==> F \<in> f' Fols g"

apply (simp add: Follows_def Increasing_def Stable_def, auto)
apply (erule_tac [3] Always_LeadsTo_weaken)
apply (erule_tac A = "{s. x \<le> f s}" and A' = "{s. x \<le> f s}"
       in Always_Constrains_weaken, auto)
apply (drule Always_Int_I, assumption)
apply (force intro: Always_weaken)
done

lemma Always_Follows2:
     "[| F \<in> Always {s. g s = g' s}; F \<in> f Fols g |] ==> F \<in> f Fols g'"
apply (simp add: Follows_def Increasing_def Stable_def, auto)
apply (erule_tac [3] Always_LeadsTo_weaken)
apply (erule_tac A = "{s. x \<le> g s}" and A' = "{s. x \<le> g s}"
       in Always_Constrains_weaken, auto)
apply (drule Always_Int_I, assumption)
apply (force intro: Always_weaken)
done

subsection\<open>Union properties (with the subset ordering)\<close>

(*Can replace "Un" by any sup.  But existing max only works for linorders.*)

lemma increasing_Un:
    "[| F \<in> increasing f;  F \<in> increasing g |]
     ==> F \<in> increasing (%s. (f s) \<union> (g s))"
apply (simp add: increasing_def stable_def constrains_def, auto)
apply (drule_tac x = "f xb" in spec)
apply (drule_tac x = "g xb" in spec)
apply (blast dest!: bspec)
done

lemma Increasing_Un:
    "[| F \<in> Increasing f;  F \<in> Increasing g |]
     ==> F \<in> Increasing (%s. (f s) \<union> (g s))"
apply (auto simp add: Increasing_def Stable_def Constrains_def
                      stable_def constrains_def)
apply (drule_tac x = "f xb" in spec)
apply (drule_tac x = "g xb" in spec)
apply (blast dest!: bspec)
done

lemma Always_Un:
     "[| F \<in> Always {s. f' s \<le> f s}; F \<in> Always {s. g' s \<le> g s} |]
      ==> F \<in> Always {s. f' s \<union> g' s \<le> f s \<union> g s}"
by (simp add: Always_eq_includes_reachable, blast)

(*Lemma to re-use the argument that one variable increases (progress)
  while the other variable doesn't decrease (safety)*)
lemma Follows_Un_lemma:
     "[| F \<in> Increasing f; F \<in> Increasing g;
         F \<in> Increasing g'; F \<in> Always {s. f' s \<le> f s};
         \<forall>k. F \<in> {s. k \<le> f s} LeadsTo {s. k \<le> f' s} |]
      ==> F \<in> {s. k \<le> f s \<union> g s} LeadsTo {s. k \<le> f' s \<union> g s}"
apply (rule single_LeadsTo_I)
apply (drule_tac x = "f s" in IncreasingD)
apply (drule_tac x = "g s" in IncreasingD)
apply (rule LeadsTo_weaken)
apply (rule PSP_Stable)
apply (erule_tac x = "f s" in spec)
apply (erule Stable_Int, assumption, blast+)
done

lemma Follows_Un:
    "[| F \<in> f' Fols f;  F \<in> g' Fols g |]
     ==> F \<in> (%s. (f' s) \<union> (g' s)) Fols (%s. (f s) \<union> (g s))"
apply (simp add: Follows_def Increasing_Un Always_Un del: Un_subset_iff sup.bounded_iff, auto)
apply (rule LeadsTo_Trans)
apply (blast intro: Follows_Un_lemma)
(*Weakening is used to exchange Un's arguments*)
apply (blast intro: Follows_Un_lemma [THEN LeadsTo_weaken])
done

subsection\<open>Multiset union properties (with the multiset ordering)\<close>

lemma increasing_union:
    "[| F \<in> increasing f;  F \<in> increasing g |]
     ==> F \<in> increasing (%s. (f s) + (g s :: ('a::order) multiset))"
apply (simp add: increasing_def stable_def constrains_def, auto)
apply (drule_tac x = "f xb" in spec)
apply (drule_tac x = "g xb" in spec)
apply (drule bspec, assumption)
apply (blast intro: add_mono order_trans)
done

lemma Increasing_union:
    "[| F \<in> Increasing f;  F \<in> Increasing g |]
     ==> F \<in> Increasing (%s. (f s) + (g s :: ('a::order) multiset))"
apply (auto simp add: Increasing_def Stable_def Constrains_def
                      stable_def constrains_def)
apply (drule_tac x = "f xb" in spec)
apply (drule_tac x = "g xb" in spec)
apply (drule bspec, assumption)
apply (blast intro: add_mono order_trans)
done

lemma Always_union:
     "[| F \<in> Always {s. f' s \<le> f s}; F \<in> Always {s. g' s \<le> g s} |]
      ==> F \<in> Always {s. f' s + g' s \<le> f s + (g s :: ('a::order) multiset)}"
apply (simp add: Always_eq_includes_reachable)
apply (blast intro: add_mono)
done

(*Except the last line, IDENTICAL to the proof script for Follows_Un_lemma*)
lemma Follows_union_lemma:
     "[| F \<in> Increasing f; F \<in> Increasing g;
         F \<in> Increasing g'; F \<in> Always {s. f' s \<le> f s};
         \<forall>k::('a::order) multiset.
           F \<in> {s. k \<le> f s} LeadsTo {s. k \<le> f' s} |]
      ==> F \<in> {s. k \<le> f s + g s} LeadsTo {s. k \<le> f' s + g s}"
apply (rule single_LeadsTo_I)
apply (drule_tac x = "f s" in IncreasingD)
apply (drule_tac x = "g s" in IncreasingD)
apply (rule LeadsTo_weaken)
apply (rule PSP_Stable)
apply (erule_tac x = "f s" in spec)
apply (erule Stable_Int, assumption, blast)
apply (blast intro: add_mono order_trans)
done

(*The !! is there to influence to effect of permutative rewriting at the end*)
lemma Follows_union:
     "!!g g' ::'b => ('a::order) multiset.
        [| F \<in> f' Fols f;  F \<in> g' Fols g |]
        ==> F \<in> (%s. (f' s) + (g' s)) Fols (%s. (f s) + (g s))"
apply (simp add: Follows_def)
apply (simp add: Increasing_union Always_union, auto)
apply (rule LeadsTo_Trans)
apply (blast intro: Follows_union_lemma)
(*now exchange union's arguments*)
apply (simp add: union_commute)
apply (blast intro: Follows_union_lemma)
done

lemma Follows_sum:
     "!!f ::['c,'b] => ('a::order) multiset.
        [| \<forall>i \<in> I. F \<in> f' i Fols f i;  finite I |]
        ==> F \<in> (%s. \<Sum>i \<in> I. f' i s) Fols (%s. \<Sum>i \<in> I. f i s)"
apply (erule rev_mp)
apply (erule finite_induct, simp)
apply (simp add: Follows_union)
done

(*Currently UNUSED, but possibly of interest*)
lemma Increasing_imp_Stable_pfixGe:
     "F \<in> Increasing func ==> F \<in> Stable {s. h pfixGe (func s)}"
apply (simp add: Increasing_def Stable_def Constrains_def constrains_def)
apply (blast intro: trans_Ge [THEN trans_genPrefix, THEN transD]
                    prefix_imp_pfixGe)
done

(*Currently UNUSED, but possibly of interest*)
lemma LeadsTo_le_imp_pfixGe:
     "\<forall>z. F \<in> {s. z \<le> f s} LeadsTo {s. z \<le> g s}
      ==> F \<in> {s. z pfixGe f s} LeadsTo {s. z pfixGe g s}"
apply (rule single_LeadsTo_I)
apply (drule_tac x = "f s" in spec)
apply (erule LeadsTo_weaken)
 prefer 2
 apply (blast intro: trans_Ge [THEN trans_genPrefix, THEN transD]
                     prefix_imp_pfixGe, blast)
done

end


theory computations
imports Kauffman_Matrix
begin

lemma unlink_computation:
 "rat_poly_plus (rat_poly_times (rat_poly_times A A) (rat_poly_times A A))
     (rat_poly_plus
       (rat_poly_times 2 (rat_poly_times A (rat_poly_times A (rat_poly_times B B))))
       (rat_poly_times (rat_poly_times B B) (rat_poly_times B B))) =
             ((A^4)+(B^4)+2)"
  proof-
  have "(rat_poly_times (rat_poly_times A A) (rat_poly_times A A)) = A^4"
             by (metis comm_semiring_1_class.normalizing_semiring_rules(18) comm_semiring_1_class.normalizing_semiring_rules(31) numeral_times_numeral power2_eq_square semiring_norm(12) semiring_norm(13))
  moreover have "(rat_poly_times (rat_poly_times B B) (rat_poly_times B B))
             = B^4"
             by (metis comm_semiring_1_class.normalizing_semiring_rules(18) comm_semiring_1_class.normalizing_semiring_rules(31) numeral_times_numeral power2_eq_square semiring_norm(12) semiring_norm(13))
  moreover have "(rat_poly_times 2 (rat_poly_times A (rat_poly_times A (rat_poly_times B B))))
               = 2"
       using inverse1  by (metis mult_2_right one_add_one rat_poly.assoc rat_poly.comm)
   ultimately show ?thesis by auto
qed

lemma computation_swingpos:
" rat_poly_plus (rat_poly_times B (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B) B))
     (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B)
       (rat_poly_times A (A - rat_poly_times (rat_poly_times B B) B))) =
    rat_poly_times A (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B) A)" (is "?l = ?r")
   proof-
     have 1:"(A - rat_poly_times (rat_poly_times B B) B)
               = A - (B^3)"
             by (metis power3_eq_cube)
     then have 2:"(rat_poly_times (A - rat_poly_times (rat_poly_times B B) B) B)
                 = A*B - (B^3)*B"
              by (metis minus_right_distributivity)
    then have "... = 1 - (B^4)"
              using inverse1 by (metis (hide_lams, no_types) Suc_numeral comm_semiring_1_class.normalizing_semiring_rules(12) comm_semiring_1_class.normalizing_semiring_rules(18) comm_semiring_1_class.normalizing_semiring_rules(30) comm_semiring_1_class.normalizing_semiring_rules(31) comm_semiring_1_class.normalizing_semiring_rules(7) mult_Suc_right numeral_One numeral_plus_numeral power2_eq_square power3_eq_cube semiring_norm(2) semiring_norm(6))
    then have "(rat_poly_times B (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B) B))
                      = B - (B^4)*B"
             using 2  by (metis comm_semiring_1_class.normalizing_semiring_rules(12) comm_semiring_1_class.normalizing_semiring_rules(7) minus_left_distributivity)
   then have 3:"(rat_poly_times B (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B) B))
                  = B - (B^5)"
                 by (metis Suc_numeral add_One_commute comm_semiring_1_class.normalizing_semiring_rules(28) semiring_norm(3))
    have "(rat_poly_times (A - rat_poly_times (rat_poly_times B B) B)
       (rat_poly_times A (A - rat_poly_times (rat_poly_times B B) B)))
                 =  (A - (B^3))*(A*( A - (B^3)))"
             using 1 by auto
    moreover then have "... =  (A - (B^3))*(A*A - (A*(B^3)))"
                    by (metis minus_left_distributivity)
    moreover then have "... = (A - (B^3))*(A*A - (B^2))"
                   using inverse1 by (metis (hide_lams, no_types) comm_semiring_1_class.normalizing_semiring_rules(12) comm_semiring_1_class.normalizing_semiring_rules(19) power2_eq_square power3_eq_cube)
    moreover then have "... = A*(A*A - (B^2)) - (B^3)*(A*A - (B^2))"
                  by (metis minus_right_distributivity)
    moreover then have "... = ((A^3) - B) - B + (B^5)"
         proof-
         have "A*(A*A - (B^2)) = (A*A*A - A*(B^2))"
                   by (metis (hide_lams, no_types) comm_semiring_1_class.normalizing_semiring_rules(18) comm_semiring_1_class.normalizing_semiring_rules(34) diff_0_right diff_minus_eq_add minus_diff_eq minus_mult_right)
         moreover have "... = (A*A*A - A*(B*B))"
                   by (metis power2_eq_square)
         moreover have "...  = ((A^3) - ((A::rat_poly)*B)*B)"
                   by (metis comm_semiring_1_class.normalizing_semiring_rules(17) power3_eq_cube)
         moreover have "... = ((A^3) - ((1::rat_poly)*B))"
                  by (metis inverse1)
         moreover have "... = (A^3) - B"
                  by (metis comm_semiring_1_class.normalizing_semiring_rules(11))
         ultimately have s1:"(A::rat_poly)*(A*A - (B^2)) = (A^3) - (B::rat_poly)"
                 by metis
         have "((B::rat_poly)^3)*(A*A - (B^2)) = (B^3)*(A*A) - (B^(3::nat))*(B^2)"
                    by (metis minus_left_distributivity power3_eq_cube)
         moreover then have "... = (((B::rat_poly)^3)*(A*A) - (B^5))"
                    using power_add by (metis (hide_lams, no_types) comm_semiring_1_class.normalizing_semiring_rules(7) numeral_plus_numeral semiring_norm(2) semiring_norm(7))
         moreover then have "... =  ((((B::rat_poly)*B*B)*(A*A)) - (B^5))"
                     by (metis power3_eq_cube)
         moreover then have "... = ((((B::rat_poly)*(B*(B*A)*A))) - (B^5))"
                     by auto
         moreover then have "... = ((((B::rat_poly)*(B*(1)*A))) - (B^5))"
                     using inverse2 by auto
         moreover then have "... =  ((((B::rat_poly)*(B*A))) - (B^5))"
                     by auto
         moreover then have "... = ((((B::rat_poly))) - (B^5))"
                      using inverse2 by (metis comm_semiring_1_class.normalizing_semiring_rules(12))
         ultimately have "((B::rat_poly)^3)*(A*A - (B^2)) = ((B::rat_poly) - (B^5))"
                      by auto
         then have "A*(A*A - (B^2)) - (B^3)*(A*A - (B^2))
                       = (A^3) - (B::rat_poly) - ((B::rat_poly) - (B^5))"
                    using s1 by auto
         then show ?thesis by auto
         qed
 ultimately have "(rat_poly_times (A - rat_poly_times (rat_poly_times B B) B)
       (rat_poly_times A (A - rat_poly_times (rat_poly_times B B) B)))
             = ((A^3) - B) - B + (B^5)"
          by auto
 then have "?l =  B - (B^5) +  ((A^3) - B) - B + (B^5)"
               using 3 by auto
 then have 4:"?l = (A^3) - B"
              by auto
  have "?r =  A*((A - rat_poly_times (rat_poly_times B B) B)*A)"
             by auto
  moreover then have "... = A*(A - (B^3))*A"
              using 1 by auto
  moreover have "... = A*(A*A - (B^3)*A)"
              by (metis comm_semiring_1_class.normalizing_semiring_rules(7) minus_left_distributivity)
 moreover have "... = A*(A*A - (B*B*B)*A)"
              by (metis power3_eq_cube)
  moreover have "... = A*(A*A - (B*B*(B*A)))"
               by auto
  moreover have "... = A*(A*A - B*B)"
              by (metis comm_monoid_mult_class.mult.right_neutral inverse2)
  moreover have "... = A*A*A - A*(B*B)"
              by (metis minus_left_distributivity rat_poly.comm)
  moreover have "... = A^3 - (A*B)*B"
              by (metis ab_semigroup_mult_class.mult_ac(1) power3_eq_cube)
  moreover have "... = A^3 - B"
             using inverse1 by (metis monoid_mult_class.mult.left_neutral)
  ultimately have "?r =  A^3 - B"
               by auto
  then show ?thesis using 4 by auto
qed

lemma computation2:
" rat_poly_plus (rat_poly_times A (rat_poly_times (B - rat_poly_times (rat_poly_times A A) A) A))
     (rat_poly_times (B - rat_poly_times (rat_poly_times A A) A)
       (rat_poly_times B (B - rat_poly_times (rat_poly_times A A) A))) =
    rat_poly_times B (rat_poly_times (B - rat_poly_times (rat_poly_times A A) A) B)" (is "?l = ?r")
   proof-
     have 1:"(B - rat_poly_times (rat_poly_times A A) A)
               = B - (A^3)"
             by (metis power3_eq_cube)
     then have 2:"(rat_poly_times (B - rat_poly_times (rat_poly_times A A) A) A)
                 = B*A - (A^3)*A"
              by (metis minus_right_distributivity)
    then have "... = 1 - (A^4)"
              using inverse2 by (metis (hide_lams, no_types) Suc_numeral comm_semiring_1_class.normalizing_semiring_rules(12) comm_semiring_1_class.normalizing_semiring_rules(18) comm_semiring_1_class.normalizing_semiring_rules(30) comm_semiring_1_class.normalizing_semiring_rules(31) comm_semiring_1_class.normalizing_semiring_rules(7) mult_Suc_right numeral_One numeral_plus_numeral power2_eq_square power3_eq_cube semiring_norm(2) semiring_norm(6))
    then have "(rat_poly_times A (rat_poly_times (B - rat_poly_times (rat_poly_times A A) A) A))
                      = A - (A^4)*A"
             using 2  by (metis comm_semiring_1_class.normalizing_semiring_rules(12) comm_semiring_1_class.normalizing_semiring_rules(7) minus_left_distributivity)
   then have 3:"(rat_poly_times A (rat_poly_times (B - rat_poly_times (rat_poly_times A A) A) A))
                  = A - (A^5)"
                 by (metis Suc_numeral add_One_commute comm_semiring_1_class.normalizing_semiring_rules(28) semiring_norm(3))
    have "(rat_poly_times (B - rat_poly_times (rat_poly_times A A) A)
       (rat_poly_times B (B - rat_poly_times (rat_poly_times A A) A)))
                 =  (B - (A^3))*(B*( B - (A^3)))"
             using 1 by auto
    moreover then have "... =  (B - (A^3))*(B*B - (B*(A^3)))"
                    by (metis minus_left_distributivity)
    moreover then have "... = (B - (A^3))*(B*B - (A^2))"
                   using inverse2 by (metis (hide_lams, no_types) comm_semiring_1_class.normalizing_semiring_rules(12) comm_semiring_1_class.normalizing_semiring_rules(19) power2_eq_square power3_eq_cube)
    moreover then have "... = B*(B*B - (A^2)) - (A^3)*(B*B - (A^2))"
                  by (metis minus_right_distributivity)
    moreover then have "... = ((B^3) - A) - A + (A^5)"
         proof-
         have "B*(B*B - (A^2)) = (B*B*B - B*(A^2))"
                   by (metis (hide_lams, no_types) comm_semiring_1_class.normalizing_semiring_rules(18) comm_semiring_1_class.normalizing_semiring_rules(34) diff_0_right diff_minus_eq_add minus_diff_eq minus_mult_right)
         moreover have "... = (B*B*B - B*(A*A))"
                   by (metis power2_eq_square)
         moreover have "...  = ((B^3) - ((B::rat_poly)*A)*A)"
                   by (metis comm_semiring_1_class.normalizing_semiring_rules(17) power3_eq_cube)
         moreover have "... = ((B^3) - ((1::rat_poly)*A))"
                  by (metis inverse2)
         moreover have "... = (B^3) - A"
                  by (metis comm_semiring_1_class.normalizing_semiring_rules(11))
         ultimately have s1:"(B::rat_poly)*(B*B - (A^2)) = (B^3) - (A::rat_poly)"
                 by metis
         have "((A::rat_poly)^3)*(B*B - (A^2)) = (A^3)*(B*B) - (A^(3::nat))*(A^2)"
                    by (metis minus_left_distributivity power3_eq_cube)
         moreover then have "... = (((A::rat_poly)^3)*(B*B) - (A^5))"
                    using power_add by (metis (hide_lams, no_types) comm_semiring_1_class.normalizing_semiring_rules(7) numeral_plus_numeral semiring_norm(2) semiring_norm(7))
         moreover then have "... =  ((((A::rat_poly)*A*A)*(B*B)) - (A^5))"
                     by (metis power3_eq_cube)
         moreover then have "... = ((((A::rat_poly)*(A*(A*B)*B))) - (A^5))"
                     by auto
         moreover then have "... = ((((A::rat_poly)*(A*(1)*B))) - (A^5))"
                     using inverse1 by auto
         moreover then have "... =  ((((A::rat_poly)*(A*B))) - (A^5))"
                     by auto
         moreover then have "... = ((((A::rat_poly))) - (A^5))"
                      using inverse1 by (metis comm_semiring_1_class.normalizing_semiring_rules(12))
         ultimately have "((A::rat_poly)^3)*(B*B - (A^2)) = ((A::rat_poly) - (A^5))"
                      by auto
         then have "B*(B*B - (A^2)) - (A^3)*(B*B - (A^2))
                       = (B^3) - (A::rat_poly) - ((A::rat_poly) - (A^5))"
                    using s1 by auto
         then show ?thesis by auto
         qed
 ultimately have "(rat_poly_times (B - rat_poly_times (rat_poly_times A A) A)
       (rat_poly_times B (B - rat_poly_times (rat_poly_times A A) A)))
             = ((B^3) - A) - A + (A^5)"
          by auto
 then have "?l =  A - (A^5) +  ((B^3) - A) - A + (A^5)"
               using 3 by auto
 then have 4:"?l = (B^3) - A"
              by auto
  have "?r =  B*((B - rat_poly_times (rat_poly_times A A) A)*B)"
             by auto
  moreover then have "... = B*(B - (A^3))*B"
              using 1 by auto
  moreover have "... = B*(B*B - (A^3)*B)"
              by (metis comm_semiring_1_class.normalizing_semiring_rules(7) minus_left_distributivity)
 moreover have "... = B*(B*B - (A*A*A)*B)"
              by (metis power3_eq_cube)
  moreover have "... = B*(B*B - (A*A*(A*B)))"
               by auto
  moreover have "... = B*(B*B - A*A)"
              by (metis comm_monoid_mult_class.mult.right_neutral inverse1)
  moreover have "... = B*B*B - B*(A*A)"
              by (metis minus_left_distributivity rat_poly.comm)
  moreover have "... = B^3 - (B*A)*A"
              by (metis ab_semigroup_mult_class.mult_ac(1) power3_eq_cube)
  moreover have "... = B^3 - A"
             using inverse2 by (metis monoid_mult_class.mult.left_neutral)
  ultimately have "?r =  B^3 - A"
               by auto
  then show ?thesis using 4 by auto
qed

lemma computation_swingneg:"rat_poly_times B (rat_poly_times (B - rat_poly_times (rat_poly_times A A) A) B) =
    rat_poly_plus
     (rat_poly_times (B - rat_poly_times (rat_poly_times A A) A)
       (rat_poly_times B (B - rat_poly_times (rat_poly_times A A) A)))
     (rat_poly_times A (rat_poly_times (B - rat_poly_times (rat_poly_times A A) A) A))"
        using computation2 by auto
lemma computation_toppos:"rat_poly_inv (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B) A) =
    rat_poly_times (B - rat_poly_times (rat_poly_times A A) A) B"(is "?l = ?r")
   proof-
   have "(rat_poly_times (A - rat_poly_times (rat_poly_times B B) B) A)
                = ((A - ((B*B)*B))*A)"
                   by auto
   moreover then have "... = (A*A) - ((B*B)*B)*A"
                  by (metis minus_left_distributivity rat_poly.comm)
   moreover then have "... = (A*A) - (B*B)*(B*A)"
                  by auto
   moreover then have "... = (A*A) - (B*B)"
                  by (metis comm_semiring_1_class.normalizing_semiring_rules(12) inverse2)
  ultimately have "?l = rat_poly_inv ((A*A) - (B*B))"
                  by auto
  then have 1:"?l = (B*B) - (A*A)"
                by auto
  have "?r =(B - ((A*A) *A))*B"
           by auto
  moreover have "... = B*B - ((A*A)*A)*B"
           by (metis minus_left_distributivity rat_poly.comm)
  moreover have "... = (B*B) - ((A*A)*(A*B))"
          by auto
  moreover have "... = ((B::rat_poly)*B) - (A*A)"
       using inverse1   by (metis (hide_lams, no_types) comm_monoid_mult_class.mult.right_neutral)
  ultimately have "?r = (B*B) - (A*A)"
          by auto
  then show ?thesis using 1 by auto
qed

(*rat_poly_times A (A - rat_poly_times (rat_poly_times B B) B) =
    rat_poly_inv (rat_poly_times B (B - rat_poly_times (rat_poly_times A A) A))*)

lemma computation_downpos_prelim:
"rat_poly_inv (rat_poly_times (B - rat_poly_times (rat_poly_times A A) A) B) =
    rat_poly_times (A - rat_poly_times (rat_poly_times B B) B) A"(is "?l = ?r")
   proof-
   have "(rat_poly_times (B - rat_poly_times (rat_poly_times A A) A) B)
                = ((B - ((A*A)*A))*B)"
                   by auto
   moreover then have "... = (B*B) - ((A*A)*A)*B"
                  by (metis minus_left_distributivity rat_poly.comm)
   moreover then have "... = (B*B) - (A*A)*(A*B)"
                  by auto
   moreover then have "... = (B*B) - (A*A)"
                  by (metis comm_semiring_1_class.normalizing_semiring_rules(12) inverse1)
  ultimately have "?l = rat_poly_inv ((B*B) - (A*A))"
                  by auto
  then have 1:"?l = (A*A) - (B*B)"
                by auto
  have "?r =(A - ((B*B) *B))*A"
           by auto
  moreover have "... = A*A - ((B*B)*B)*A"
           by (metis minus_left_distributivity rat_poly.comm)
  moreover have "... = (A*A) - ((B*B)*(B*A))"
          by auto
  moreover have "... = ((A::rat_poly)*A) - (B*B)"
       using inverse2   by (metis (hide_lams, no_types) comm_monoid_mult_class.mult.right_neutral)
  ultimately have "?r = (A*A) - (B*B)"
          by auto
  then show ?thesis using 1 by auto
qed

lemma computation_downpos:"rat_poly_times A (A - rat_poly_times (rat_poly_times B B) B) =
    rat_poly_inv (rat_poly_times B (B - rat_poly_times (rat_poly_times A A) A))"
       using computation_downpos_prelim by (metis rat_poly.comm)

lemma computatition_positive_flip:"rat_poly_plus
     (rat_poly_inv (rat_poly_times A (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B) A)))
     (rat_poly_inv (rat_poly_times B (rat_poly_times A B))) =
    rat_poly_inv (rat_poly_times A (rat_poly_times A A))" (is "?l = ?r")
 proof-
 have "(rat_poly_inv (rat_poly_times B (rat_poly_times A B)))
                 = (rat_poly_inv (rat_poly_times B 1))"
          using inverse1 by auto
 moreover have "... = - B"
        by auto
 ultimately have 1:"(rat_poly_inv (rat_poly_times B (rat_poly_times A B))) = - B"
       by auto
 have " (rat_poly_times A (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B) A))
         = A*((A - ((B*B)*B))*A)"
          by auto
 moreover then have "... = A*((A*A) - ((B*B)*B*A))"
          by (metis minus_left_distributivity rat_poly.comm)
 moreover then have "... = A*((A*A) - ((B*B)*1))"
         using inverse2 by auto
 moreover then have "... = A*((A*A) - (B*B))"
          by auto
 moreover then have "... = A*(A*A) - (A*(B*B))"
         by (metis minus_left_distributivity)
 moreover then have "... = (A*(A*A)) - (1*B)"
         using inverse1 by auto
 moreover then have "... =  (A*(A*A)) - B"
         by auto
 ultimately have "(rat_poly_times A (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B) A))
                     = (A*(A*A)) - B"
            by auto
 then have "rat_poly_inv (rat_poly_times A (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B) A))
                  = B - (A*A*A)"
           by auto
 then have 3:"?l = - (A*A*A)"
           using 1 by auto
 moreover have "?r = - (A*A*A)"
            by auto
 ultimately show ?thesis by auto
qed

lemma computation_negative_flip:"rat_poly_plus
     (rat_poly_inv (rat_poly_times B (rat_poly_times (B - rat_poly_times (rat_poly_times A A) A) B)))
     (rat_poly_inv (rat_poly_times A (rat_poly_times B A))) =
    rat_poly_inv (rat_poly_times B (rat_poly_times B B))" (is "?l = ?r")
 proof-
 have "(rat_poly_inv (rat_poly_times A (rat_poly_times B A)))
                 = (rat_poly_inv (rat_poly_times A 1))"
          using inverse2 by auto
 moreover have "... = - A"
        by auto
 ultimately have 1:"(rat_poly_inv (rat_poly_times A (rat_poly_times B A))) = - A"
       by auto
 have " (rat_poly_times B (rat_poly_times (B - rat_poly_times (rat_poly_times A A) A) B))
         = B*((B - ((A*A)*A))*B)"
          by auto
 moreover then have "... = B*((B*B) - ((A*A)*A*B))"
          by (metis minus_left_distributivity rat_poly.comm)
 moreover then have "... = B*((B*B) - ((A*A)*1))"
         using inverse1 by auto
 moreover then have "... = B*((B*B) - (A*A))"
          by auto
 moreover then have "... = B*(B*B) - (B*(A*A))"
         by (metis minus_left_distributivity)
 moreover then have "... = (B*(B*B)) - (1*A)"
         using inverse2 by auto
 moreover then have "... =  (B*(B*B)) - A"
         by auto
 ultimately have "(rat_poly_times B (rat_poly_times (B - rat_poly_times (rat_poly_times A A) A) B))
                     = (B*(B*B)) - A"
            by auto
 then have "rat_poly_inv (rat_poly_times B (rat_poly_times (B - rat_poly_times (rat_poly_times A A) A) B))
                  = A - (B*B*B)"
           by auto
 then have 3:"?l = - (B*B*B)"
           using 1 by auto
 moreover have "?r = - (B*B*B)"
            by auto
 ultimately show ?thesis by auto
qed

lemma computation_pull_pos_neg:
"rat_poly_plus (rat_poly_times B (B - rat_poly_times (rat_poly_times A A) A))
     (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B) A) = 0"
      proof-
      have " rat_poly_times (rat_poly_times A A) A
                       = ((A*A)*A)"
                  by auto
     then have "rat_poly_times B (B - rat_poly_times (rat_poly_times A A) A)
                     = B*B - B*((A*A)*A)"
             using minus_left_distributivity by auto
      moreover have "... = B*B - (B*(A*(A*A)))"
                      by auto
      moreover have "... = B*B - ((B*A)*(A*A))"
                      by auto
      moreover have "... = B*B - A*A"
                      using inverse2 by auto
      ultimately have 1:"rat_poly_times B (B - rat_poly_times (rat_poly_times A A) A)
                               =  B*B - A*A"
                by auto
      have "rat_poly_times (rat_poly_times B B) B = (B*B)*B"
                by auto
      then have "(rat_poly_times (A - rat_poly_times (rat_poly_times B B) B) A)
                  = (A*A) - ((B*B)*B)*A"
              using minus_right_distributivity by auto
      moreover have "... = (A*A) - ((B*B)*(B*A))"
                     by auto
      moreover have "... = (A*A) - (B*B)"
                    using inverse2 by auto
      ultimately have 2:"(rat_poly_times (A - rat_poly_times (rat_poly_times B B) B) A)
                  = (A*A) - (B*B)"
                    by auto
      have "B*B - A*A + (A*A) - (B*B) = 0"
                  by auto
      with 1 2 show ?thesis by auto
  qed

lemma aux1:"(A - rat_poly_times (rat_poly_times B B) B)
         = A - (B^3)"
  using power3_eq_cube by (metis)

lemma square_subtract:"(((p::rat_poly) - (q::rat_poly))^2)
         = (p^2) - (2*p*q) + (q^2)"
   proof-
   have 1:"(((p::rat_poly) - (q::rat_poly))^2)
             = (p- q)*(p - q)"
             by (metis power2_eq_square)
   then have "(p - q)*(p - q) = (p - q)*p - (p - q)*q"
             by (metis minus_right_distributivity rat_poly.comm)
   moreover have "(p - q)*p = p*p - q*p"
                 by (metis minus_left_distributivity rat_poly.comm)
   moreover have "(p - q)*q = p*q - q*q"
                 by (metis minus_left_distributivity rat_poly.comm)
   ultimately have "(p - q)*(p - q) = p*p - q*p - (p*q - q*q)"
                by auto
   moreover have "... = (p*p) - q*p - p*q + q*q"
               by auto
   moreover have "... = (p^2) -p*q - p*q + (q^2)"
               by (metis comm_semiring_1_class.normalizing_semiring_rules(7) power2_eq_square)
   ultimately show ?thesis using 1 by auto
qed

lemma cube_minus:"\<forall>p q.((((p::rat_poly) - (q::rat_poly))^3)
                = (p^3) - 3*(p^2)*(q) + 3*(p)*(q^2) - (q^3))"
 apply(rule allI)
 apply(rule allI)
 proof-
 fix p q
 have 1:"(((p::rat_poly) - (q::rat_poly))^3) = (p - q)*(p-q)^2"
        by (metis comm_semiring_1_class.normalizing_semiring_rules(7) power2_eq_square power3_eq_cube)
 then have "(p-q)^2 = (p^2) - (2*p*q) + (q^2)"
            using square_subtract by auto
 then have 2:"(p - q)*(p-q)^2 = (p - q)*((p^2) - (2*p*q) + (q^2))"
                    by auto
 moreover have 3:"(p - q)*((p^2) - (2*p*q) + (q^2))
                   = p*((p^2) - (2*p*q) + (q^2))
               - (q*((p^2) - (2*p*q) + (q^2)))"
            by (metis minus_right_distributivity)
 moreover have "p*((p^2) - (2*p*q) + (q^2))
                   = p*(p^2) - p*(2*p*q) + (p*(q^2))"
               by (metis comm_semiring_1_class.normalizing_semiring_rules(34) minus_left_distributivity)
 moreover have "p*(p^2) = p^3"
                by (metis comm_semiring_1_class.normalizing_semiring_rules(7) power2_eq_square power3_eq_cube)
 moreover have "p*(2*p*q) = 2*(p^2)*q"
                by (metis (hide_lams, no_types) comm_semiring_1_class.normalizing_semiring_rules(19) comm_semiring_1_class.normalizing_semiring_rules(7) power2_eq_square)
 ultimately have 4:"p*((p^2) - (2*p*q) + (q^2))
                   = (p^3) - (2*(p^2)*q) + (p*(q^2))"
                by auto
 have "q*((p^2) - (2*p*q) + (q^2))
                   = q*(p^2) - q*(2*p*q) + (q*(q^2))"
               by (metis comm_semiring_1_class.normalizing_semiring_rules(34) minus_left_distributivity)
 moreover have "q*(p^2) = (p^2)*q"
                by (metis comm_semiring_1_class.normalizing_semiring_rules(7) power2_eq_square power3_eq_cube)
 moreover have "q*(2*p*q) = 2*p*(q^2)"
                by (metis (hide_lams, no_types) comm_semiring_1_class.normalizing_semiring_rules(19) comm_semiring_1_class.normalizing_semiring_rules(7) power2_eq_square)
 ultimately have 5:"q*((p^2) - (2*p*q) + (q^2))
                   = (p^2)*q - 2*p*(q^2) + (q^3)"
                by (metis comm_semiring_1_class.normalizing_semiring_rules(7) power2_eq_square power3_eq_cube)
 with 1 2 3 4 have "(p - q)^3
                      = (p^3) - (2*(p^2)*q) + (p*(q^2))
                          - ((p^2)*q - 2*p*(q^2) + (q^3))"
               by auto
 moreover have "... = (p^3) - (2*(p^2)*q) + (p*(q^2))
                     - (p^2)*q + 2*p*(q^2) - (q^3)"
                by auto
 moreover have "... = (p^3) - 3*(p^2)*(q) + 3*(p)*(q^2) - (q^3)"
                by auto
 ultimately show " (p - q) ^ 3 =
          rat_poly_plus (p ^ 3 - rat_poly_times (rat_poly_times 3 (p\<twosuperior>)) q)
           (rat_poly_times (rat_poly_times 3 p) (q\<twosuperior>)) -
          q ^ 3" by auto
qed

lemma power_mult: "((p::rat_poly)^m)^n= (p)^(m*(n::nat))"
       by (metis power_mult)

lemma cube_minus2:
fixes p q
shows "(((p::rat_poly) - (q::rat_poly))^3)
                = (p^3) - 3*(p^2)*(q) + 3*(p)*(q^2) - (q^3)"
        using cube_minus by auto

lemma subst_poly:assumes "a = b" shows "(p::rat_poly)*a = p*b"
           using assms by auto

lemma sub1: assumes "p*q = 1"
       shows "r*(p*q) = r*1"
         using assms by metis

lemma n_distrib:"(A^(n::nat))*(B^n) = (A*B)^n"
       apply(induct_tac n)
       apply(auto)
       done

lemma rat_poly_id_pow:"(1::rat_poly)^n = 1"
     apply(induct_tac n)
     apply(auto)
      done

lemma power_prod:"(A^(n::nat))*(B^n) = (1::rat_poly)"
        apply(simp add:n_distrib)
        apply(simp add:inverse1)
        done
lemma "(pCons 0 1) \<noteq> 0"
          by (metis non_zero var_def)
(*
lemma "(B^3)*(A^2) = B"
     proof-
      have "(B^3) = B*B*B"
           by (metis power3_eq_cube)
      moreover have "(A^2) = A*A"
           by (metis power2_eq_square)
      ultimately have "(B^3)*(A^2) = (B*B*B)*(A*A)"
                by metis
       moreover have "... = (B*B)*(B*A)*A"
                by auto
       moreover have "... = (B*B)*(1::rat_poly)*A"
                by (metis inverse2)
       moreover have "... = (B*B)*A"
                by auto
       moreover have "... = (B*(B*A))"
                by auto
        moreover have "... = (B*(1::rat_poly))"
                using inverse2 by auto
        moreover have "... = B"
                 by auto
        ultimately show ?thesis sledgehammer

lemma "(rat_poly_times (rat_poly_times A A)
       (rat_poly_plus
         (rat_poly_times B
           (rat_poly_times B
             (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B)
               (rat_poly_times A A))))
         (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B)
           (rat_poly_plus
             (rat_poly_times B (rat_poly_times B (rat_poly_times A A)))
             (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B)
               (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B)
                 (rat_poly_times A A)))))))
= (A^7 + A^4 - 2*(A^3) + 2*B - B^5)"
proof-
have "(rat_poly_times B
           (rat_poly_times B
             (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B)
               (rat_poly_times A A))))
         = (B*B)*(A - (B^3))*(A*A)"
         using aux1 by auto
then have 1:"(rat_poly_times B
           (rat_poly_times B
             (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B)
               (rat_poly_times A A)))) = (A - (B^3))"
          by (metis (hide_lams, no_types) aux1 comm_semiring_1_class.normalizing_semiring_rules(11) comm_semiring_1_class.normalizing_semiring_rules(17) comm_semiring_1_class.normalizing_semiring_rules(19) comm_semiring_1_class.normalizing_semiring_rules(7) diff_0 inverse1 minus_diff_eq minus_minus minus_mult_left minus_mult_minus minus_mult_right semiring_norm(3))
then have 2:"(rat_poly_plus
             (rat_poly_times B (rat_poly_times B (rat_poly_times A A)))
             (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B)
               (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B)
                 (rat_poly_times A A))))= (1 + ((A - (B^3))^2)*(A^2))"
     proof-
     have "(rat_poly_times B (rat_poly_times B (rat_poly_times A A)))
                 = 1"
               by (metis comm_semiring_1_class.normalizing_semiring_rules(19) inverse1 rat_poly.right_id)
     moreover have "(rat_poly_times (A - rat_poly_times (rat_poly_times B B) B)
               (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B)
                 (rat_poly_times A A)))
                              = ((A - (B^3))^2)*(A^2)"
                      using aux1 power2_eq_square by (metis (hide_lams, no_types) comm_semiring_1_class.normalizing_semiring_rules(19) comm_semiring_1_class.normalizing_semiring_rules(7))
    ultimately show ?thesis by auto
   qed
 then have 3:" (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B)
           (rat_poly_plus
             (rat_poly_times B (rat_poly_times B (rat_poly_times A A)))
             (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B)
               (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B)
                 (rat_poly_times A A)))))
                  = (A -(B^3))*(1 + ((A - (B^3))^2)*(A^2))"
        using aux1 by auto
 have "... = (A -(B^3))*(1 + ((A - (B^3))*((A - (B^3))*(A^2))))"
             by (metis (hide_lams, no_types) comm_semiring_1_class.normalizing_semiring_rules(19) comm_semiring_1_class.normalizing_semiring_rules(7) power2_eq_square)
 then have "... = (A -(B^3))*(1 + ((A - (B^3))*((A*(A^2) - (B^3)*(A^2)))))"
             by (metis (hide_lams, mono_tags) comm_semiring_1_class.normalizing_semiring_rules(18) comm_semiring_1_class.normalizing_semiring_rules(7) minus_left_distributivity power2_eq_square)
 then have "...
 have "  (rat_poly_times (A - rat_poly_times (rat_poly_times B B) B)
                 (rat_poly_times A A))
                = (rat_poly_times A (rat_poly_times A A)) -
                    (rat_poly_times (rat_poly_times (rat_poly_times B B) B)
                        (rat_poly_times A A))"
                 by (metis minus_left_distributivity rat_poly.comm)
 have "(A -(B^3))*(1 + ((A - (B^3))^2)*(A^2))
            = (A^5) - (B^7) - (2*A) + (2*(B^3)) - (B^7)" (is "?l = ?r")
     proof-
     have "?l = (A -(B^3))*1 + (A -(B^3))*((A - (B^3))^2)*(A^2)"
           by (metis (hide_lams, no_types) comm_semiring_1_class.normalizing_semiring_rules(18) comm_semiring_1_class.normalizing_semiring_rules(34))
     then have "... = (A -(B^3)) + ((A - (B^3))^3)*(A^2)"
            by (metis comm_monoid_mult_class.mult.right_neutral comm_semiring_1_class.normalizing_semiring_rules(7) power2_eq_square power3_eq_cube)
     have "((A - (B^3))^3) = (A^3)-(3*(A^2)*(B^3))
               + (3*A*((B^3)^2))-(B^3)^3"
            using cube_minus2 sorry
     moreover have "(A^2)*(B^3)  = B"
               proof-
               have 0:"A \<noteq> (0::rat_poly)"
                    using A_non_zero by auto
               have 1:"((A^2)*(B^3)) = (A^2)*(B^2)*B"
                  by (metis comm_semiring_1_class.normalizing_semiring_rules(18) power2_eq_square power3_eq_cube)
               moreover have "(A^2)*(B^2) = (1::rat_poly)"
                  using power_prod by auto
               then have 2:"(A^2)*(B^2)*B = (1::rat_poly)*B"
                         by auto
               moreover then have 3:"... = B"
                        by auto
               ultimately show ?thesis using 0 1 B_non_zero by auto
               qed    *)
end