theory v4_isar_K
  imports Main "../QML"
begin

text \<open>
@{text "Compossibility\<^sub>4'"}: If a table @{term x} is originally made from matter @{term y} and it
is possible for a table to be the @{text "n\<^sup>t\<^sup>h"} table originally made from matter @{term z} according to plan @{term p},
then it is also possible for table @{term x} to be originally made from matter @{term y} and in
addition some table or other @{term x'} to be the @{text "n\<^sup>t\<^sup>h"} table originally made from matter @{term z}
according to plan @{term p}.

@{text "Origin Uniqueness\<^sub>4'"}: It is impossible that a single table @{term x} is originally made from
matter @{term y} and in addition is originally made from matter @{term z}.

@{text "Sufficiency\<^sub>4'"}: If it is possible that a table @{term x'} is the @{text "n\<^sup>t\<^sup>h"} table originally made from matter @{term z}
according to plan @{term p}, then necessarily any table that is the @{text "n\<^sup>t\<^sup>h"} table originally made from matter @{term z}
according to plan @{term p} is the very table @{term x'} and no other.
\<close>

text \<open>
@{text "Origin Essentialism\<^sub>4'"}: If a given table is originally made from certain matter, then it is necessary
that the given table is not (the @{text "n\<^sup>t\<^sup>h"} table for any @{term n}) originally made from any non-overlapping
matter according to any plan.
\<close>

consts kTable :: "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<mu> \<Rightarrow> nat \<Rightarrow> \<sigma>" ("N")
(* (N x y p k) \<equiv> x is the kth table made from y according to p *)

lemma
assumes compossibilty4: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. (N x y p k \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) \<^bold>\<rightarrow> \<^bold>\<diamond>(N x y p k \<^bold>\<and> (\<^bold>\<exists>x'. N x' z p k))\<rfloor>"
assumes origin_uniqueness4: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>(\<^bold>\<diamond>(N x y p k \<^bold>\<and> N x z p k \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz))\<rfloor>"
assumes sufficiency4: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(N x y p k) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. N x' y p k \<^bold>\<rightarrow> x'\<^bold>=\<^sup>Lx)\<rfloor>"
shows origin_essentialism4: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. (y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> N x y p k) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k'))\<rfloor>"
  text \<open>\<^item> Setting-up the worlds\<close>
(*<*)
proof (rule allI)
  fix w
  show "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. ((y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k'))) w"
  proof (rule allI)
    fix x
    show "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. ((y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k'))) w"
    proof (rule allI)
      fix y
      show "(\<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. ((y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k'))) w"
      proof (rule allI)
        fix z
        show "(\<^bold>\<forall>p. \<^bold>\<forall>k. ((y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k'))) w"
        proof (rule allI)
          fix p
          show "(\<^bold>\<forall>k. ((y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k'))) w"
          proof (rule allI)
            fix k
            show "(((y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> (N x y p k)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k. N x z p' k))) w"
(*>*)

            proof (rule impI)
              assume antecedent: "(y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> N x y p k) w"
              show "\<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k')) w"
              proof (rule notI)
                assume  "\<^bold>\<diamond>(\<^bold>\<forall>p'. \<^bold>\<forall>k'. N x z p' k') w"
                then have sufficiency4_ante: "\<^bold>\<diamond>(N x z p k) w" by auto
                then have compossibilty4_ante: "(N x y p k \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) w"
                  using antecedent by auto
                from antecedent have non_overlapping: "(y\<^bold>\<noteq>\<^sup>Lz) w" by (rule conjE)
                text\<open>\<^item> Deriving @{text "N x' z p k"} in @{term u} using @{term compossibilty4}\<close>
                from compossibilty4 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. (N x y p k \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) \<^bold>\<rightarrow> \<^bold>\<diamond>(N x y p k \<^bold>\<and> (\<^bold>\<exists>x'. N x' z p k))) w"..
(*<*)
                then have "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> (y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k)))) w" by (rule allE)
                then have "(\<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> (y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k)))) w" by (rule allE)
                then have "(\<^bold>\<forall>p. \<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> (y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k)))) w" by (rule allE)
                then have "(\<^bold>\<forall>k. ((N x y p k) \<^bold>\<and> (y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k)))) w" by (rule allE)
                then have "(((N x y p k) \<^bold>\<and> (y\<^bold>\<noteq>\<^sup>Lz) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. N t z p k)) \<^bold>\<rightarrow> \<^bold>\<diamond>((N x y p k) \<^bold>\<and> (\<^bold>\<exists>x'. (N x' z p k)))) w" by (rule allE)
(*>*)

                then have "\<^bold>\<diamond>(N x y p k \<^bold>\<and> (\<^bold>\<exists>x'. N x' z p k)) w"
                  using compossibilty4_ante by (rule mp)
                then obtain u where u: "w r u \<and> ((N x y p k \<^bold>\<and> (\<^bold>\<exists>x'. N x' z p k))  u)" by (rule exE)
                then have "(\<^bold>\<exists>x'. N x' z p k) u" by auto
                then obtain x' where x': "(N x' z p k) u" by (rule exE)
                from u have "w r u" by (rule conjE)
                text \<open>\<^item> Deriving @{text "x' \<^bold>=\<^sup>L x"} in @{term u} using @{term sufficiency4}\<close>
                from sufficiency4 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(N x y p k) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. N x' y p k \<^bold>\<rightarrow> x'\<^bold>=\<^sup>Lx)) w"..
(*<*)
                then have "(\<^bold>\<forall>y. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(N x y p k) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' y p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w" by (rule allE)
                then have "(\<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<diamond>(N x z p k) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' z p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w" by (rule allE)
                then have "(\<^bold>\<forall>k. \<^bold>\<diamond>(N x z p k) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' z p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w" by (rule allE)
                then have "(\<^bold>\<diamond>(N x z p k) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (N x' z p k) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w" by (rule allE)
(*>*)

                then have "\<^bold>\<box>(\<^bold>\<forall>x'. N x' z p k \<^bold>\<rightarrow> x'\<^bold>=\<^sup>Lx) w" using sufficiency4_ante by (rule mp)
                then have "(N x' z p k \<^bold>\<rightarrow> x'\<^bold>=\<^sup>Lx) u" using `w r u` by auto
                then have "(x'\<^bold>=\<^sup>Lx) u" using `N x' z p k u` by (rule mp)
                then have "(N x z p k) u" using `(N x' z p k) u` by auto
                text\<open>\<^item> Framing the @{term impossible_arg}\<close>
                from u have "(N x y p k) u" by simp
                then have impossible_arg: "(N x y p k \<^bold>\<and> N x z p k \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz) u"
                  using `(N x z p k) u` and non_overlapping by auto
                text\<open>\<^item> Falsifying the @{term impossible_arg} using @{term origin_uniqueness4}\<close>
                from origin_uniqueness4 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>(\<^bold>\<diamond>(N x y p k \<^bold>\<and> N x z p k \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz))) w"..
(*<*)
                then have "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>(\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> (y\<^bold>\<noteq>\<^sup>Lz)))) w" by (rule allE)
                then have "(\<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>(\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> (y\<^bold>\<noteq>\<^sup>Lz)))) w" by (rule allE)
                then have "(\<^bold>\<forall>p. \<^bold>\<forall>k. \<^bold>\<not>(\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> (y\<^bold>\<noteq>\<^sup>Lz)))) w" by (rule allE)
                then have "(\<^bold>\<forall>k. \<^bold>\<not>(\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> (y\<^bold>\<noteq>\<^sup>Lz)))) w" by (rule allE)
                then have "(\<^bold>\<not>(\<^bold>\<diamond>((N x y p k) \<^bold>\<and> (N x z p k) \<^bold>\<and> (y\<^bold>\<noteq>\<^sup>Lz)))) w" by (rule allE)
(*>*)

                then have "\<^bold>\<box>(\<^bold>\<not>(N x y p k \<^bold>\<and> N x z p k \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz)) w" by auto
                then have "\<^bold>\<not>(N x y p k \<^bold>\<and> N x z p k \<^bold>\<and> y\<^bold>\<noteq>\<^sup>Lz) u"
                  using `w r u` by auto
                then show "False" using impossible_arg by (rule notE)
(*<*)
              qed
            qed
          qed
        qed
      qed
    qed
  qed
qed
(*>*)

end


section \<open>General Domain Theory\<close>
theory RefineG_Domain
imports "../Refine_Misc"
begin

  subsection \<open>General Order Theory Tools\<close>
  lemma chain_f_apply: "Complete_Partial_Order.chain (fun_ord le) F
    \<Longrightarrow> Complete_Partial_Order.chain le {y . \<exists>f\<in>F. y = f x}"
    unfolding Complete_Partial_Order.chain_def
    by (auto simp: fun_ord_def)

  lemma ccpo_lift:
    assumes "class.ccpo lub le lt"
    shows "class.ccpo (fun_lub lub) (fun_ord le) (mk_less (fun_ord le))"
  proof -
    interpret ccpo: ccpo lub le lt by fact
    show ?thesis
      apply unfold_locales
      apply (simp_all only: mk_less_def fun_ord_def fun_lub_def)
      apply simp
      using ccpo.order_trans apply blast
      using ccpo.antisym apply blast
      using ccpo.ccpo_Sup_upper apply (blast intro: chain_f_apply)
      using ccpo.ccpo_Sup_least apply (blast intro: chain_f_apply)
      done
  qed

  (* TODO: Move *)
  lemma fun_lub_simps[simp]:
    "fun_lub lub {} = (\<lambda>x. lub {})"
    "fun_lub lub {f} = (\<lambda>x. lub {f x})"
    unfolding fun_lub_def by auto

  subsection \<open>Flat Ordering\<close>
  lemma flat_ord_chain_cases:
    assumes A: "Complete_Partial_Order.chain (flat_ord b) C"
    obtains "C={}"
    | "C={b}"
    | x where "x\<noteq>b" and "C={x}"
    | x where "x\<noteq>b" and "C={b,x}"
  proof -
    have "\<exists>m1 m2. C \<subseteq> {m1,m2} \<and> (m1 = b \<or> m2 = b)"
      apply (rule ccontr)
    proof clarsimp
      assume "\<forall>m1 m2. C \<subseteq> {m1, m2} \<longrightarrow> m1\<noteq>b \<and> m2\<noteq>b"
      then obtain m1 m2 where "m1\<in>C" "m2\<in>C"
        "m1\<noteq>m2" "m1\<noteq>b" "m2\<noteq>b"
        by blast
      with A show False
        unfolding Complete_Partial_Order.chain_def flat_ord_def
        by auto
    qed
    then obtain m where "C \<subseteq> {m,b}" by blast
    thus ?thesis
      apply (cases "m=b")
      using that
      apply blast+
      done
  qed

  lemma flat_lub_simps[simp]:
    "flat_lub b {} = b"
    "flat_lub b {x} = x"
    "flat_lub b (insert b X) = flat_lub b X"
    unfolding flat_lub_def
    by auto

  lemma flat_ord_simps[simp]:
    "flat_ord b b x"
    by (simp add: flat_ord_def)

  interpretation flat_ord: ccpo "flat_lub b" "flat_ord b" "mk_less (flat_ord b)"
    apply unfold_locales
    apply (simp_all only: mk_less_def flat_ord_def) apply auto [4]
    apply (erule flat_ord_chain_cases, auto) []
    apply (erule flat_ord_chain_cases, auto) []
    done

  interpretation flat_le_mono_setup: mono_setup_loc "flat_ord b"
    by standard auto

  subsubsection \<open>Flat function Ordering\<close>
  abbreviation "flatf_ord b == fun_ord (flat_ord b)"
  abbreviation "flatf_lub b == fun_lub (flat_lub b)"

  interpretation flatf_ord: ccpo "flatf_lub b" "flatf_ord b" "mk_less (flatf_ord b)"
    apply (rule ccpo_lift)
    apply unfold_locales
    done

  subsubsection \<open>Fixed Points in Flat Ordering\<close>
  text \<open>
    Fixed points in a flat ordering are used to express recursion.
    The bottom element is interpreted as non-termination.
\<close>

  abbreviation "flat_mono b == monotone (flat_ord b) (flat_ord b)"
  abbreviation "flatf_mono b == monotone (flatf_ord b) (flatf_ord b)"
  abbreviation "flatf_fp b \<equiv> flatf_ord.fixp b"

  lemma flatf_fp_mono[refine_mono]:
    \<comment> \<open>The fixed point combinator is monotonic\<close>
    assumes "flatf_mono b f"
      and "flatf_mono b g"
      and "\<And>Z x. flat_ord b (f Z x) (g Z x)"
    shows "flat_ord b (flatf_fp b f x) (flatf_fp b g x)"
  proof -
    have "flatf_ord b (flatf_fp b f) (flatf_fp b g)"
      apply (rule flatf_ord.fixp_mono[OF assms(1,2)])
      using assms(3) by (simp add: fun_ord_def)
    thus ?thesis unfolding fun_ord_def by blast
  qed

  lemma flatf_admissible_pointwise:
    "(\<And>x. P x b) \<Longrightarrow>
      ccpo.admissible (flatf_lub b) (flatf_ord b) (\<lambda>g. \<forall>x. P x (g x))"
    apply (intro ccpo.admissibleI allI impI)
    apply (drule_tac x=x in chain_f_apply)
    apply (erule flat_ord_chain_cases)
    apply (auto simp add: fun_lub_def) [2]
    apply (force simp add: fun_lub_def) []
    apply (auto simp add: fun_lub_def) []
    done

  text \<open>
    If a property is defined pointwise, and holds for the bottom element,
    we can use fixed-point induction for it.

    In the induction step, we can assume that the function is less or equal
    to the fixed-point.

    This rule covers refinement and transfer properties,
    such as: Refinement of fixed-point combinators and transfer of
    fixed-point combinators to different domains.
\<close>
  lemma flatf_fp_induct_pointwise:
    \<comment> \<open>Fixed-point induction for pointwise properties\<close>
    fixes a :: 'a
    assumes cond_bot: "\<And>a x. pre a x \<Longrightarrow> post a x b"
    assumes MONO: "flatf_mono b B"
    assumes PRE0: "pre a x"
    assumes STEP: "\<And>f a x.
      \<lbrakk>\<And>a' x'. pre a' x' \<Longrightarrow> post a' x' (f x'); pre a x;
        flatf_ord b f (flatf_fp b B) \<rbrakk>
      \<Longrightarrow> post a x (B f x)"
    shows "post a x (flatf_fp b B x)"
  proof -
    define ub where "ub = flatf_fp b B"

    have "(\<forall>x a. pre a x \<longrightarrow> post a x (flatf_fp b B x))
      \<and> flatf_ord b (flatf_fp b B) ub"
      apply (rule flatf_ord.fixp_induct[OF _ MONO])
      apply (rule admissible_conj)
      apply (rule flatf_admissible_pointwise)
      apply (blast intro: cond_bot)
      apply (rule ccpo.admissibleI)
      apply (blast intro: flatf_ord.ccpo_Sup_least)

      apply (auto intro: cond_bot simp: fun_ord_def flat_ord_def) []

      apply (rule conjI)
      unfolding ub_def

      apply (blast intro: STEP)

      apply (subst flatf_ord.fixp_unfold[OF MONO])
      apply (blast intro: monotoneD[OF MONO])
      done
    with PRE0 show ?thesis by blast
  qed

  text \<open>
    The next rule covers transfer between fixed points.
    It allows to lift a pointwise transfer condition
    \<open>P x y \<longrightarrow> tr (f x) (f y)\<close> to fixed points.
    Note that one of the fixed points may be an arbitrary fixed point.
\<close>
  lemma flatf_fixp_transfer:
    \<comment> \<open>Transfer rule for fixed points\<close>
    assumes TR_BOT[simp]: "\<And>x'. tr b x'"
    assumes MONO: "flatf_mono b B"
    assumes FP': "fp' = B' fp'"
    assumes R0: "P x x'"
    assumes RS: "\<And>f f' x x'.
       \<lbrakk>\<And>x x'. P x x' \<Longrightarrow> tr (f x) (f' x'); P x x'; fp' = f'\<rbrakk>
       \<Longrightarrow> tr (B f x) (B' f' x')"
    shows "tr (flatf_fp b B x) (fp' x')"
    apply (rule flatf_fp_induct_pointwise[where pre="\<lambda>x y. P y x", OF _ MONO])
    apply simp
    apply (rule R0)
    apply (subst FP')
    apply (blast intro: RS)
    done

  subsubsection \<open>Relation of Flat Ordering to Complete Lattices\<close>
  text \<open>
    In this section, we establish the relation between flat orderings
    and complete lattices. This relation is exploited to show properties
    of fixed points wrt. a refinement ordering.
\<close>

  abbreviation "flat_le \<equiv> flat_ord bot"
  abbreviation "flat_ge \<equiv> flat_ord top"
  abbreviation "flatf_le \<equiv> flatf_ord bot"
  abbreviation "flatf_ge \<equiv> flatf_ord top"

  text \<open>The flat ordering implies the lattice ordering\<close>
  lemma flat_ord_compat:
    fixes x y :: "'a :: complete_lattice"
    shows
    "flat_le x y \<Longrightarrow> x \<le> y"
    "flat_ge x y \<Longrightarrow> x \<ge> y"
    unfolding flat_ord_def by auto

  lemma flatf_ord_compat:
    fixes x y :: "'a \<Rightarrow> ('b :: complete_lattice)"
    shows
    "flatf_le x y \<Longrightarrow> x \<le> y"
    "flatf_ge x y \<Longrightarrow> x \<ge> y"
    by (auto simp: flat_ord_compat le_fun_def fun_ord_def)

  abbreviation "flat_mono_le \<equiv> flat_mono bot"
  abbreviation "flat_mono_ge \<equiv> flat_mono top"

  abbreviation "flatf_mono_le \<equiv> flatf_mono bot"
  abbreviation "flatf_mono_ge \<equiv> flatf_mono top"

  abbreviation "flatf_gfp \<equiv> flatf_ord.fixp top"
  abbreviation "flatf_lfp \<equiv> flatf_ord.fixp bot"

  text \<open>If a functor is monotonic wrt. both the flat and the
    lattice ordering, the fixed points wrt. these orderings coincide.
\<close>
  lemma lfp_eq_flatf_lfp:
    assumes FM: "flatf_mono_le B" and M: "mono B"
    shows "lfp B = flatf_lfp B"
  proof -
    from lfp_unfold[OF M, symmetric] have "B (lfp B) = lfp B" .
    hence "flatf_le (B (lfp B)) (lfp B)" by simp
    with flatf_ord.fixp_lowerbound[OF FM] have "flatf_le (flatf_lfp B) (lfp B)" .
    with flatf_ord_compat have "flatf_lfp B \<le> lfp B" by blast
    also
    from flatf_ord.fixp_unfold[OF FM, symmetric] have "B (flatf_lfp B) = flatf_lfp B" .
    hence "B (flatf_lfp B) \<le> flatf_lfp B" by simp
    with lfp_lowerbound[where A="flatf_lfp B"] have "lfp B \<le> flatf_lfp B" .
    finally show "lfp B = flatf_lfp B" ..
  qed

  lemma gfp_eq_flatf_gfp:
    assumes FM: "flatf_mono_ge B" and M: "mono B"
    shows "gfp B = flatf_gfp B"
  proof -
    from gfp_unfold[OF M, symmetric] have "B (gfp B) = gfp B" .
    hence "flatf_ge (B (gfp B)) (gfp B)" by simp
    with flatf_ord.fixp_lowerbound[OF FM] have "flatf_ge (flatf_gfp B) (gfp B)" .
    with flatf_ord_compat have "gfp B \<le> flatf_gfp B" by blast
    also
    from flatf_ord.fixp_unfold[OF FM, symmetric] have "B (flatf_gfp B) = flatf_gfp B" .
    hence "flatf_gfp B \<le> B (flatf_gfp B)" by simp
    with gfp_upperbound[where X="flatf_gfp B"] have "flatf_gfp B \<le> gfp B" .
    finally show "gfp B = flatf_gfp B" .
  qed

  (* TODO: This belongs to "General Recursion"*)
  text \<open>
    The following lemma provides a well-founded induction scheme for arbitrary
    fixed point combinators.
\<close>
  lemma wf_fixp_induct:
    \<comment> \<open>Well-Founded induction for arbitrary fixed points\<close>
    fixes a :: 'a
    assumes fixp_unfold: "fp B = B (fp B)"
    assumes WF: "wf V"
    assumes P0: "pre a x"
    assumes STEP: "\<And>f a x. \<lbrakk>
      \<And>a' x'. \<lbrakk> pre a' x'; (x',x)\<in>V \<rbrakk> \<Longrightarrow> post a' x' (f x'); fp B = f; pre a x
    \<rbrakk> \<Longrightarrow> post a x (B f x)"
    shows "post a x (fp B x)"
  proof -
    have "\<forall>a. pre a x \<longrightarrow> post a x (fp B x)"
      using WF
      apply (induct x rule: wf_induct_rule)
      apply (intro allI impI)
      apply (subst fixp_unfold)
      apply (rule STEP)
      apply (simp)
      apply (simp)
      apply (simp)
      done
    with P0 show ?thesis by blast
  qed

  lemma flatf_lfp_transfer:
    \<comment> \<open>Transfer rule for least fixed points\<close>
    fixes B::"(_ \<Rightarrow> 'a::order_bot) \<Rightarrow> _"
    assumes TR_BOT[simp]: "\<And>x. tr bot x"
    assumes MONO: "flatf_mono_le B"
    assumes MONO': "flatf_mono_le B'"
    assumes R0: "P x x'"
    assumes RS: "\<And>f f' x x'.
       \<lbrakk>\<And>x x'. P x x' \<Longrightarrow> tr (f x) (f' x'); P x x'; flatf_lfp B' = f'\<rbrakk>
       \<Longrightarrow> tr (B f x) (B' f' x')"
    shows "tr (flatf_lfp B x) (flatf_lfp B' x')"
    apply (rule flatf_fixp_transfer[where tr=tr and fp'="flatf_lfp B'" and P=P])
    apply (fact|rule flatf_ord.fixp_unfold[OF MONO'])+
    done

  lemma flatf_gfp_transfer:
    \<comment> \<open>Transfer rule for greatest fixed points\<close>
    fixes B::"(_ \<Rightarrow> 'a::order_top) \<Rightarrow> _"
    assumes TR_TOP[simp]: "\<And>x. tr x top"
    assumes MONO: "flatf_mono_ge B"
    assumes MONO': "flatf_mono_ge B'"
    assumes R0: "P x x'"
    assumes RS: "\<And>f f' x x'.
       \<lbrakk>\<And>x x'. P x x' \<Longrightarrow> tr (f x) (f' x'); P x x'; flatf_gfp B = f\<rbrakk>
       \<Longrightarrow> tr (B f x) (B' f' x')"
    shows "tr (flatf_gfp B x) (flatf_gfp B' x')"
    apply (rule flatf_fixp_transfer[where
        tr="\<lambda>x y. tr y x" and fp'="flatf_gfp B" and P="\<lambda>x y. P y x"])
    apply (fact|assumption|rule flatf_ord.fixp_unfold[OF MONO] RS)+
    done

  lemma meta_le_everything_if_top: "(m=top) \<Longrightarrow> (\<And>x. x \<le> (m::'a::order_top))"
    by auto

  lemmas flatf_lfp_refine = flatf_lfp_transfer[
    where tr = "\<lambda>a b. a \<le> cf b" for cf, OF bot_least]
  lemmas flatf_gfp_refine = flatf_gfp_transfer[
    where tr = "\<lambda>a b. a \<le> cf b" for cf, OF meta_le_everything_if_top]

  lemma flat_ge_sup_mono[refine_mono]: "\<And>a a'::'a::complete_lattice.
    flat_ge a a' \<Longrightarrow> flat_ge b b' \<Longrightarrow> flat_ge (sup a b) (sup a' b')"
    by (auto simp: flat_ord_def)

  declare sup_mono[refine_mono]

end


section \<open> Partial Function Command \<close>

theory Partial_Function_Command
  imports Function_Toolkit
  keywords "zfun" :: "thy_decl_block" and "precondition" "postcondition"
begin

definition pfun_spec :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<Zpfun> 'b" where
"pfun_spec P Q = (\<lambda> x | P x \<and> (\<exists> y. Q x y) \<bullet> SOME y. Q x y)"

lemma pfun_spec_app_eqI [intro]: "\<lbrakk> P x; \<And> y. Q x y \<longleftrightarrow> y = f x \<rbrakk> \<Longrightarrow> (pfun_spec P Q)(x)\<^sub>p = f x"
  by (simp add: pfun_spec_def, subst pabs_apply, auto)

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

ML \<open>
val _ =
  Outer_Syntax.command @{command_keyword zfun} "define Z-like partial functions"
    (Zfun_Command.zfun_parser >> (Toplevel.theory o Zfun_Command.compile_zfun));
\<close>

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_19
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun rev :: "'a list => 'a list" where
"rev (nil2) = nil2"
| "rev (cons2 z xs) = x (rev xs) (cons2 z (nil2))"

theorem property0 :
  "((x (rev (rev y)) z) = (rev (rev (x y z))))"
  oops

end


theory ITree
imports "HOLCF"
begin

domain ('a::countable) tree' = Node (lazy next' :: "'a discr \<rightarrow> 'a tree'")
type_synonym 'a tree = "'a discr \<rightarrow> 'a tree'"

default_sort countable

definition mkt :: "('a \<Rightarrow> 'a tree') \<Rightarrow> 'a tree'"
  where "mkt f = Node\<cdot>(\<Lambda> x. f (undiscr x))"
lemma mkt_cont: "cont (\<lambda> x. mkt x)"
  unfolding mkt_def
  by (intro cont2cont cont_fun)
lemmas cont_compose[OF mkt_cont, cont2cont, simp]

abbreviation tnext ::"'a tree' \<Rightarrow> 'a \<Rightarrow> 'a tree'"
 where "tnext t x \<equiv> next'\<cdot>t\<cdot>(Discr x)"

lemma mkt_not_bot[simp]: "\<not> mkt f = \<bottom>"
  by (auto simp add: mkt_def)

lemma tnext_mkt[simp]: "tnext (mkt f) x = f x"
  by (auto simp add: mkt_def)

fixrec lempty :: "'a::countable tree'"
  where "lempty = mkt (\<lambda> _. \<bottom>)"

context
  fixes x :: "'a::countable"
begin
  fixrec single :: "'a tree'"
    where "single = mkt (\<lambda> x'. if x' = x then lempty else \<bottom>)"

  fixrec many :: "'a tree'"
    where [simp del]: "many = mkt (\<lambda> x'. if x' =  x then many else \<bottom>)"
end

lemma many_not_bot[simp]: "many x \<noteq> \<bottom>"
  by (subst many.simps) simp

lemma tnext_many[simp]: "tnext (many x) x' = (if x' =  x then many x else \<bottom>)"
  by (subst many.simps) simp

fixrec lanything :: "'a::countable tree'"
  where "lanything = Node\<cdot>(\<Lambda> x'. lanything)"

inductive paths_aux :: "'a tree' \<Rightarrow> 'a list \<Rightarrow> bool"
  where "paths_aux t []"
      | "tnext t x = t' \<Longrightarrow> t' \<noteq> \<bottom> \<Longrightarrow> paths_aux t' l \<Longrightarrow> paths_aux t (x#l)"
definition paths :: "'a tree' \<Rightarrow> 'a list set"
  where "paths t = Collect (paths_aux t)"
lemma elim_paths_aux[pred_set_conv]: "paths_aux t p \<longleftrightarrow> p \<in> paths t" unfolding paths_def by simp
lemmas paths_intros[intro?] = paths_aux.intros[unfolded elim_paths_aux]
lemmas paths_induct[consumes 1, induct set: paths] = paths_aux.induct[to_set]
lemmas paths_cases[consumes 1, cases set: paths] = paths_aux.cases[to_set]
lemmas paths_simpss = paths_aux.simps[to_set]

lemma "replicate n x \<in> paths (many x)"
 by(induction n) (auto intro: paths_intros)

lemma "p \<in> paths (many x) \<Longrightarrow> (\<forall> x' \<in> set p. x' = x)"
  by (induction "many x" p arbitrary: x rule: paths_induct)
     (auto  split: if_splits)

fun op_option :: "('a::cpo \<rightarrow> 'a \<rightarrow> 'a) \<Rightarrow> 'a option \<Rightarrow> 'a option \<Rightarrow> 'a option"
  where "op_option f (Some x) (Some y) = Some (f\<cdot>x\<cdot>y)"
      | "op_option f (Some x) None     = Some x"
      | "op_option f None     (Some y) = Some y"
      | "op_option f None     None     = None"

fixrec or' :: "'a tree' \<rightarrow> 'a tree' \<rightarrow> 'a tree'"
 where "or'\<cdot>t1\<cdot>t2 = mkt (\<lambda> x. or'\<cdot>(tnext t1 x)\<cdot>(tnext t2 x))"
print_theorems

lemma or'_bot: "f \<noteq> \<bottom> \<Longrightarrow> or'\<cdot>\<bottom>\<cdot>f \<sqsubseteq> f"
  apply (induction arbitrary: f rule: or'.induct)
  apply auto
  apply (case_tac f)
  apply simp
  apply (simp add: mkt_def)
  apply (rule cfun_belowI)
  apply simp

  oops

end


(*  Title:      Separation-Logic-Formalization/Modus_Ponens.thy
    Author:     Nicolas Amat, Mnacho Echenim, Nicolas Peltier
*)

section \<open>Modus Ponens\<close>

text \<open>This section contains the Modus Ponens like for the sepration logic.\<close>

theory Modus_Ponens
imports
  Interpretation
  Formula
begin

subsection \<open>Proof\<close>

lemma modus_ponens:
  fixes I::"('var, 'addr, 'k::finite) interp"
    and P::"('var, 'k) sl_formula"
    and Q::"('var, 'k) sl_formula"
  assumes  "evaluation I (sl_conj P (sl_magic_wand P Q))"
  shows "evaluation I Q"
proof -
  have def_1: "\<exists>h1::('addr, 'k) heaps.
               \<exists>h2::('addr, 'k) heaps. (union_heaps h1 h2 = heap I)
                                     \<and> (disjoint_heaps h1 h2)
                                     \<and> (evaluation (to_interp (store I) h1) P)
                                     \<and> (evaluation (to_interp (store I) h2) (sl_magic_wand P Q))"
    using assms evaluation.simps(9) by blast
  hence def_2: "\<exists>h2::('addr, 'k) heaps.
                \<forall>h3::('addr, 'k) heaps. ((disjoint_heaps h3 h2)
                                       \<and> (evaluation (to_interp (store I) h3) P))
                                    \<longrightarrow> (evaluation (to_interp (store I) (union_heaps h2  h3)) Q)"
    by (metis evaluation.simps(10) store_on_to_interp)
  from def_1 and def_2  show "evaluation I Q"
    by (metis commutative_union_disjoint_heaps evaluation.simps(10) heap_def heap_on_to_interp
        prod.exhaust_sel store_def store_on_to_interp)
qed

end


(* Author: Tobias Nipkow *)

theory Abs_Int_den0
imports Abs_State_den
begin

subsection "Computable Abstract Interpretation"

text{* Abstract interpretation over type @{text astate} instead of
functions. *}

locale Abs_Int = Val_abs +
fixes pfp :: "('a astate \<Rightarrow> 'a astate) \<Rightarrow> 'a astate \<Rightarrow> 'a astate"
assumes pfp: "f(pfp f x0) \<sqsubseteq> pfp f x0"
assumes above: "x0 \<sqsubseteq> pfp f x0"
begin

fun aval' :: "aexp \<Rightarrow> 'a astate \<Rightarrow> 'a" where
"aval' (N n) _ = num' n" |
"aval' (V x) S = lookup S x" |
"aval' (Plus e1 e2) S = plus' (aval' e1 S) (aval' e2 S)"

abbreviation astate_in_rep (infix "<:" 50) where
"s <: S == ALL x. s x <: lookup S x"

lemma astate_in_rep_le: "(s::state) <: S \<Longrightarrow> S \<sqsubseteq> T \<Longrightarrow> s <: T"
by (metis in_mono le_astate_def le_rep lookup_def top)

lemma aval'_sound: "s <: S \<Longrightarrow> aval a s <: aval' a S"
by (induct a) (auto simp: rep_num' rep_plus')

fun AI :: "com \<Rightarrow> 'a astate \<Rightarrow> 'a astate" where
"AI SKIP S = S" |
"AI (x ::= a) S = update S x (aval' a S)" |
"AI (c1;;c2) S = AI c2 (AI c1 S)" |
"AI (IF b THEN c1 ELSE c2) S = (AI c1 S) \<squnion> (AI c2 S)" |
"AI (WHILE b DO c) S = pfp (AI c) S"

lemma AI_sound: "(c,s) \<Rightarrow> t \<Longrightarrow> s <: S0 \<Longrightarrow> t <: AI c S0"
proof(induction c arbitrary: s t S0)
  case SKIP thus ?case by fastforce
next
  case Assign thus ?case
    by (auto simp: lookup_update aval'_sound)
next
  case Seq thus ?case by auto
next
  case If thus ?case
    by (metis AI.simps(4) IfE astate_in_rep_le join_ge1 join_ge2)
next
  case (While b c)
  let ?P = "pfp (AI c) S0"
  { fix s t have "(WHILE b DO c,s) \<Rightarrow> t \<Longrightarrow> s <: ?P \<Longrightarrow> t <: ?P"
    proof(induction "WHILE b DO c" s t rule: big_step_induct)
      case WhileFalse thus ?case by simp
    next
      case WhileTrue thus ?case using While.IH pfp astate_in_rep_le by metis
    qed
  }
  with astate_in_rep_le[OF `s <: S0` above]
  show ?case by (metis While(2) AI.simps(5))
qed

end

end


theory Benchmark_Set
imports
  "HOL-Library.Word"
  "HOL-Library.Cardinality"
begin

instantiation word :: (len) card_UNIV begin
definition "finite_UNIV = Phantom('a word) True"
definition "card_UNIV = Phantom('a word) (2 ^ LENGTH('a))"
instance by(intro_classes)(simp_all add: card_UNIV_word_def card_word finite_UNIV_word_def)
end

definition word_of_integer :: "integer \<Rightarrow> 'a::len word"
where "word_of_integer = word_of_int \<circ> int_of_integer"

lemma word_of_integer_code [code]:
  "word_of_integer k =
  (if k < 0 then - word_of_integer (- k)
   else if k = 0 then 0
   else let (q, r) = divmod_integer k 2
        in if r = 0 then 2 * word_of_integer q else 2 * word_of_integer q + 1)"
  apply (unfold word_of_integer_def)
  apply transfer
  apply (auto simp add: not_less comp_def split_beta)
  apply (subst int_of_integer_code)
  apply (clarsimp simp add: divmod_integer_def)
  done

definition word_of :: "natural \<Rightarrow> 'a::len word"
where "word_of = word_of_integer o integer_of_natural"

text \<open>randomly generate a set of (up to) n elements drawn from 0 to bound\<close>

fun gen_build1 :: "natural \<Rightarrow> nat \<Rightarrow> (32 word set \<times> Random.seed) \<Rightarrow> (32 word set \<times> Random.seed)"
where
  "gen_build1 bound n (A, seed) =
  (if n = 0 then (A, seed)
   else let (x, seed') = Random.range bound seed in gen_build1 bound (n - 1) (insert (word_of x) A, seed'))"

declare gen_build1.simps[simp del]

definition build1 :: "natural \<Rightarrow> Random.seed \<Rightarrow> (32 word set \<times> Random.seed)"
where
  "build1 bound seed =
  (let (n', seed') = Random.range bound seed;
       (compl, seed'') = Random.range 2 seed;
       (x, seed''') = gen_build1 bound (Code_Numeral.nat_of_natural n') ({}, seed'')
   in (if compl = 0 then x else - x, seed'''))"

text \<open>randomly generate a set of (up to) n sets each with a random number between 0 and bound of elements between 0 and bound\<close>

fun gen_build2 :: "natural \<Rightarrow> nat \<Rightarrow> (32 word set set \<times> Random.seed) \<Rightarrow> (32 word set set \<times> Random.seed)"
where
  "gen_build2 bound n (A, seed) =
  (if n = 0 then (A, seed)
   else let (x, seed') = build1 bound seed
        in gen_build2 bound (n - 1) (insert x A, seed'))"

declare gen_build2.simps[simp del]

definition build :: "nat \<Rightarrow> nat \<Rightarrow> Random.seed \<Rightarrow> 32 word set set \<times> Random.seed"
where "build n m seed = gen_build2 (of_nat m) n ({}, seed)"

fun gen_lookup :: "32 word set set \<Rightarrow> natural \<Rightarrow> nat \<Rightarrow> (nat \<times> Random.seed) \<Rightarrow> (nat \<times> Random.seed)"
where
  "gen_lookup A bound n (hits, seed) =
  (if n = 0 then (hits, seed)
   else let (x, seed') = build1 bound seed
        in gen_lookup A bound (n - 1) (if x : A then hits + 1 else hits, seed'))"

declare gen_lookup.simps [simp del]

primrec lookup :: "nat \<Rightarrow> nat \<Rightarrow> (32 word set set \<times> Random.seed) \<Rightarrow> (nat \<times> Random.seed)"
where "lookup n m (A, seed) = gen_lookup A (of_nat m) 100 (0, seed)"

definition covered :: "32 word set set \<Rightarrow> nat"
where "covered A = card (\<Union>A)"

definition complete :: "nat \<Rightarrow> nat \<Rightarrow> Random.seed \<Rightarrow> (nat \<times> nat)"
where "complete n m seed = (let (A, seed') = build n m seed in (fst (lookup n m (A, seed)), covered A))"

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Algebraic Numbers: Addition and Multiplication\<close>

text \<open>This theory contains the remaining field operations for algebraic numbers, namely
  addition and multiplication.\<close>

theory Algebraic_Numbers
imports
  Algebraic_Numbers_Prelim
  Resultant
  Polynomial_Factorization.Polynomial_Divisibility
begin

interpretation coeff_hom: monoid_add_hom "\<lambda>p. coeff p i" by (unfold_locales, auto)
interpretation coeff_hom: comm_monoid_add_hom "\<lambda>p. coeff p i"..
interpretation coeff_hom: group_add_hom "\<lambda>p. coeff p i"..
interpretation coeff_hom: ab_group_add_hom "\<lambda>p. coeff p i"..
interpretation coeff_0_hom: monoid_mult_hom "\<lambda>p. coeff p 0" by (unfold_locales, auto simp: coeff_mult)
interpretation coeff_0_hom: semiring_hom "\<lambda>p. coeff p 0"..
interpretation coeff_0_hom: comm_monoid_mult_hom "\<lambda>p. coeff p 0"..
interpretation coeff_0_hom: comm_semiring_hom "\<lambda>p. coeff p 0"..

subsection \<open>Addition of Algebraic Numbers\<close>

definition "x_y \<equiv> [: [: 0, 1 :], -1 :]"

definition "poly_x_minus_y p = poly_lift p \<circ>\<^sub>p x_y"

text \<open>The following polynomial represents the sum of two algebraic numbers.\<close>

definition poly_add :: "'a :: comm_ring_1 poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
  "poly_add p q = resultant (poly_x_minus_y p) (poly_lift q)"

subsubsection \<open>@{term poly_add} has desired root\<close>

interpretation poly_x_minus_y_hom:
  comm_ring_hom poly_x_minus_y by (unfold_locales; simp add: poly_x_minus_y_def hom_distribs)

lemma poly2_x_y[simp]:
  fixes x :: "'a :: comm_ring_1"
  shows "poly2 x_y x y = x - y" unfolding poly2_def by (simp add: x_y_def)

lemma degree_poly_x_minus_y[simp]:
  fixes p :: "'a::idom poly"
  shows "degree (poly_x_minus_y p) = degree p" unfolding poly_x_minus_y_def x_y_def by auto

lemma poly_x_minus_y_pCons[simp]:
  "poly_x_minus_y (pCons a p) = [:[: a :]:] + poly_x_minus_y p * x_y"
  unfolding poly_x_minus_y_def x_y_def by simp

lemma poly_poly_poly_x_minus_y[simp]:
  fixes p :: "'a :: comm_ring_1 poly"
  shows "poly (poly (poly_x_minus_y p) q) x = poly p (x - poly q x)"
  by (induct p; simp add: ring_distribs x_y_def)

lemma poly2_poly_x_minus_y[simp]:
  fixes p :: "'a :: comm_ring_1 poly"
  shows "poly2 (poly_x_minus_y p) x y = poly p (x-y)" unfolding poly2_def by simp

interpretation x_y_mult_hom: zero_hom_0 "\<lambda>p :: 'a :: comm_ring_1 poly poly. x_y * p"
proof (unfold_locales)
  fix p :: "'a poly poly"
  assume "x_y * p = 0"
  then show "p = 0" apply (simp add: x_y_def)
    by (metis eq_neg_iff_add_eq_0 minus_equation_iff minus_pCons synthetic_div_unique_lemma)
qed

lemma x_y_nonzero[simp]: "x_y \<noteq> 0" by (simp add: x_y_def)

lemma degree_x_y[simp]: "degree x_y = 1" by (simp add: x_y_def)

interpretation x_y_mult_hom: inj_comm_monoid_add_hom "\<lambda>p :: 'a :: idom poly poly. x_y * p"
proof (unfold_locales)
  show "x_y * p = x_y * q \<Longrightarrow> p = q" for p q :: "'a poly poly"
  proof (induct p arbitrary:q)
    case 0
    then show ?case by simp
  next
    case p: (pCons a p)
    from p(3)[unfolded mult_pCons_right]
    have "x_y * (monom a 0 + pCons 0 1 * p) = x_y * q"
      apply (subst(asm) pCons_0_as_mult)
      apply (subst(asm) smult_prod) by (simp only: field_simps distrib_left)
    then have "monom a 0 + pCons 0 1 * p = q" by simp
    then show "pCons a p = q" using pCons_as_add by (simp add: monom_0 monom_Suc)
  qed
qed

interpretation poly_x_minus_y_hom: inj_idom_hom poly_x_minus_y
proof
  fix p :: "'a poly"
  assume 0: "poly_x_minus_y p = 0"
  then have "poly_lift p \<circ>\<^sub>p x_y = 0" by (simp add: poly_x_minus_y_def)
  then show "p = 0"
  proof (induct p)
    case 0
    then show ?case by simp
  next
    case (pCons a p)
    note p = this[unfolded poly_lift_pCons pcompose_pCons]
    show ?case
    proof (cases "a=0")
      case a0: True
      with p have "x_y * poly_lift p \<circ>\<^sub>p x_y = 0" by simp
      then have "poly_lift p \<circ>\<^sub>p x_y = 0" by simp
      then show ?thesis using p by simp
    next
      case a0: False
      with p have p0: "p \<noteq> 0" by auto
      from p have "[:[:a:]:] = - x_y * poly_lift p \<circ>\<^sub>p x_y" by (simp add: eq_neg_iff_add_eq_0)
      then have "degree [:[:a:]:] = degree (x_y * poly_lift p \<circ>\<^sub>p x_y)" by simp
      also have "... = degree (x_y::'a poly poly) + degree (poly_lift p \<circ>\<^sub>p x_y)"
        apply (subst degree_mult_eq)
          apply simp
         apply (subst pcompose_eq_0)
          apply (simp add: x_y_def)
         apply (simp add: p0)
        apply simp
       done
      finally have False by simp
      then show ?thesis..
    qed
  qed
qed

lemma poly_add:
  fixes p q :: "'a ::comm_ring_1 poly"
  assumes q0: "q \<noteq> 0" and x: "poly p x = 0" and y: "poly q y = 0"
  shows "poly (poly_add p q) (x+y) = 0"
proof (unfold poly_add_def, rule poly_resultant_zero[OF disjI2])
  have "degree q > 0" using poly_zero q0 y by auto
  thus degq: "degree (poly_lift q) > 0" by auto
qed (insert x y, simp_all)

subsubsection \<open>@{const poly_add} is nonzero\<close>

text \<open>
  We first prove that @{const poly_lift} preserves factorization. The result will be essential
  also in the next section for division of algebraic numbers.
\<close>

interpretation coeff_lift_hom:
  factor_preserving_hom "coeff_lift :: 'a :: {comm_semiring_1,semiring_no_zero_divisors} \<Rightarrow> _"
  by (unfold_locales, auto)

interpretation poly_lift_hom:
  unit_preserving_hom "poly_lift :: 'a :: {comm_semiring_1,semiring_no_zero_divisors} poly \<Rightarrow> _"
proof
  fix x :: "'a poly"
  assume "poly_lift x dvd 1"
  then have "poly_y_x (poly_lift x) dvd poly_y_x 1"
    by simp
  then show "x dvd 1"
    by (auto simp add: poly_y_x_poly_lift)
qed

interpretation poly_lift_hom:
  factor_preserving_hom "poly_lift::'a::idom poly \<Rightarrow> 'a poly poly"
proof unfold_locales
  fix p :: "'a poly"
  assume p: "irreducible p"
  show "irreducible (poly_lift p)"
  proof(rule ccontr)
    from p have p0: "p \<noteq> 0" and "\<not> p dvd 1" by (auto dest: irreducible_not_unit)
    with poly_lift_hom.hom_dvd[of p 1] have p1: "\<not> poly_lift p dvd 1" by auto
    assume "\<not> irreducible (poly_lift p)"
    from this[unfolded irreducible_altdef,simplified] p0 p1
    obtain q where "q dvd poly_lift p" and pq: "\<not> poly_lift p dvd q" and q: "\<not> q dvd 1" by auto
    then obtain r where "q * r = poly_lift p" by (elim dvdE, auto)
    then have "poly_y_x (q * r) = poly_y_x (poly_lift p)" by auto
    also have "... = [:p:]" by (auto simp: poly_y_x_poly_lift monom_0)
    also have "poly_y_x (q * r) = poly_y_x q * poly_y_x r" by (auto simp: hom_distribs)
    finally have "... = [:p:]" by auto
    then have qp: "poly_y_x q dvd [:p:]" by (metis dvdI)
    from dvd_const[OF this] p0 have "degree (poly_y_x q) = 0" by auto
    from degree_0_id[OF this,symmetric] obtain s
      where qs: "poly_y_x q = [:s:]" by auto
    have "poly_lift s = poly_y_x (poly_y_x (poly_lift s))" by auto
      also have "... = poly_y_x [:s:]" by (auto simp: poly_y_x_poly_lift monom_0)
      also have "... = q" by (auto simp: qs[symmetric])
    finally have sq: "poly_lift s = q" by auto
    from qp[unfolded qs] have sp: "s dvd p" by (auto simp: const_poly_dvd)
    from irreducibleD'[OF p this] sq q pq show False by auto
  qed
qed

text \<open>
  We now show that @{const poly_x_minus_y} is a factor-preserving homomorphism. This is
  essential for this section. This is easy since @{const poly_x_minus_y} can be represented
  as the composition of two factor-preserving homomorphisms.
\<close>

lemma poly_x_minus_y_as_comp: "poly_x_minus_y = (\<lambda>p. p \<circ>\<^sub>p x_y) \<circ> poly_lift"
  by (intro ext, unfold poly_x_minus_y_def, auto)
context idom_isom begin
  sublocale comm_semiring_isom..
end
interpretation poly_x_minus_y_hom:
  factor_preserving_hom "poly_x_minus_y :: 'a :: idom poly \<Rightarrow> 'a poly poly"
proof-
  interpret x_y_hom: bijective "\<lambda>p :: 'a poly poly. p \<circ>\<^sub>p x_y"
  proof (unfold bijective_eq_bij, rule id_imp_bij)
    fix p :: "'a poly poly" show "p \<circ>\<^sub>p x_y \<circ>\<^sub>p x_y = p"
      apply (induct p,simp)
      apply(unfold x_y_def hom_distribs pcompose_pCons) by (simp)
  qed
  interpret x_y_hom: idom_isom "\<lambda>p :: 'a poly poly. p \<circ>\<^sub>p x_y" by (unfold_locales, auto)
  show "factor_preserving_hom (poly_x_minus_y :: 'a poly \<Rightarrow> _)"
    by (unfold poly_x_minus_y_as_comp, rule factor_preserving_hom_comp, unfold_locales)
qed

text \<open>
  Now we show that results of @{const poly_x_minus_y} and @{const poly_lift} are coprime.
\<close>

lemma poly_y_x_const[simp]: "poly_y_x [:[:a:]:] = [:[:a:]:]" by (simp add: poly_y_x_def monom_0)

context begin

private abbreviation "y_x == [: [: 0, -1 :], 1 :]"

lemma poly_y_x_x_y[simp]: "poly_y_x x_y = y_x" by (simp add: x_y_def poly_y_x_def monom_Suc monom_0)

private lemma y_x[simp]: fixes x :: "'a :: comm_ring_1" shows "poly2 y_x x y = y - x"
  unfolding poly2_def by simp

private definition "poly_y_minus_x p \<equiv> poly_lift p \<circ>\<^sub>p y_x"

private lemma poly_y_minus_x_0[simp]: "poly_y_minus_x 0 = 0" by (simp add: poly_y_minus_x_def)

private lemma poly_y_minus_x_pCons[simp]:
  "poly_y_minus_x (pCons a p) = [:[: a :]:] + poly_y_minus_x p * y_x" by (simp add: poly_y_minus_x_def)

private lemma poly_y_x_poly_x_minus_y:
  fixes p :: "'a :: idom poly"
  shows "poly_y_x (poly_x_minus_y p) = poly_y_minus_x p"
  apply (induct p, simp)
  apply (unfold poly_x_minus_y_pCons hom_distribs) by simp

lemma degree_poly_y_minus_x[simp]:
  fixes p :: "'a :: idom poly"
  shows "degree (poly_y_x (poly_x_minus_y p)) = degree p"
  by (simp add: poly_y_minus_x_def poly_y_x_poly_x_minus_y)

end

lemma dvd_all_coeffs_iff:
  fixes x :: "'a :: comm_semiring_1" (* No addition needed! *)
  shows "(\<forall>pi \<in> set (coeffs p). x dvd pi) \<longleftrightarrow> (\<forall>i. x dvd coeff p i)" (is "?l = ?r")
proof-
  have "?r = (\<forall>i\<in>{..degree p} \<union> {Suc (degree p)..}. x dvd coeff p i)" by auto
  also have "... = (\<forall>i\<le>degree p. x dvd coeff p i)" by (auto simp add: ball_Un coeff_eq_0)
  also have "... = ?l" by (auto simp: coeffs_def)
  finally show ?thesis..
qed

lemma primitive_imp_no_constant_factor:
  fixes p :: "'a :: {comm_semiring_1, semiring_no_zero_divisors} poly"
  assumes pr: "primitive p" and F: "mset_factors F p" and fF: "f \<in># F"
  shows "degree f \<noteq> 0"
proof
  from F fF have irr: "irreducible f" and fp: "f dvd p" by (auto dest: mset_factors_imp_dvd)
  assume deg: "degree f = 0"
  then obtain f0 where f0: "f = [:f0:]" by (auto dest: degree0_coeffs)
  with fp have "[:f0:] dvd p" by simp
  then have "f0 dvd coeff p i" for i by (simp add: const_poly_dvd_iff)
  with primitiveD[OF pr] dvd_all_coeffs_iff have "f0 dvd 1" by (auto simp: coeffs_def)
  with f0 irr show False by auto
qed

lemma coprime_poly_x_minus_y_poly_lift:
  fixes p q :: "'a :: ufd poly"
  assumes degp: "degree p > 0" and degq: "degree q > 0"
    and pr: "primitive p"
  shows "coprime (poly_x_minus_y p) (poly_lift q)"
proof(rule ccontr)
  from degp have p: "\<not> p dvd 1" by (auto simp: dvd_const)
  from degp have p0: "p \<noteq> 0" by auto
  from mset_factors_exist[of p, OF p0 p]
  obtain F where F: "mset_factors F p" by auto
  with poly_x_minus_y_hom.hom_mset_factors
  have pF: "mset_factors (image_mset poly_x_minus_y F) (poly_x_minus_y p)" by auto

  from degq have q: "\<not> q dvd 1" by (auto simp: dvd_const)
  from degq have q0: "q \<noteq> 0" by auto
  from mset_factors_exist[OF q0 q]
  obtain G where G: "mset_factors G q" by auto
  with poly_lift_hom.hom_mset_factors
  have pG: "mset_factors (image_mset poly_lift G) (poly_lift q)" by auto

  assume "\<not> coprime (poly_x_minus_y p) (poly_lift q)"
  from this[unfolded not_coprime_iff_common_factor]
  obtain r
  where rp: "r dvd (poly_x_minus_y p)"
    and rq: "r dvd (poly_lift q)"
    and rU: "\<not> r dvd 1" by auto note poly_lift_hom.hom_dvd
  from rp p0 have r0: "r \<noteq> 0" by auto
  from mset_factors_exist[OF r0 rU]
  obtain H where H: "mset_factors H r" by auto
  then have "H \<noteq> {#}" by auto
  then obtain h where hH: "h \<in># H" by fastforce
  with H mset_factors_imp_dvd have hr: "h dvd r" and h: "irreducible h" by auto
  from irreducible_not_unit[OF h] have hU: "\<not> h dvd 1" by auto
  from hr rp have "h dvd (poly_x_minus_y p)" by (rule dvd_trans)
  from irreducible_dvd_imp_factor[OF this h pF] p0
  obtain f where f: "f \<in># F" and fh: "poly_x_minus_y f ddvd h" by auto
  from hr rq have "h dvd (poly_lift q)" by (rule dvd_trans)
  from irreducible_dvd_imp_factor[OF this h pG] q0
  obtain g where g: "g \<in># G" and gh: "poly_lift g ddvd h" by auto
  from fh gh have "poly_x_minus_y f ddvd poly_lift g" using ddvd_trans by auto
  then have "poly_y_x (poly_x_minus_y f) ddvd poly_y_x (poly_lift g)" by simp
  also have "poly_y_x (poly_lift g) = [:g:]" unfolding poly_y_x_poly_lift monom_0 by auto
  finally have ddvd: "poly_y_x (poly_x_minus_y f) ddvd [:g:]" by auto
  then have "degree (poly_y_x (poly_x_minus_y f)) = 0" by (metis degree_pCons_0 dvd_0_left_iff dvd_const)
  then have "degree f = 0" by simp
  with primitive_imp_no_constant_factor[OF pr F f] show False by auto
qed

lemma poly_add_nonzero:
  fixes p q :: "'a :: ufd poly"
  assumes p0: "p \<noteq> 0" and q0: "q \<noteq> 0" and x: "poly p x = 0" and y: "poly q y = 0"
      and pr: "primitive p"
  shows "poly_add p q \<noteq> 0"
proof
  have degp: "degree p > 0" using le_0_eq order_degree order_root p0 x by (metis gr0I)
  have degq: "degree q > 0" using le_0_eq order_degree order_root q0 y by (metis gr0I)
  assume 0: "poly_add p q = 0"
  from resultant_zero_imp_common_factor[OF _ this[unfolded poly_add_def]] degp
   and coprime_poly_x_minus_y_poly_lift[OF degp degq pr]
  show False by auto
qed

subsubsection \<open>Summary for addition\<close>

text \<open>Now we lift the results to one that uses @{const ipoly}, by showing some homomorphism lemmas.\<close>

lemma (in comm_ring_hom) map_poly_x_minus_y:
  "map_poly (map_poly hom) (poly_x_minus_y p) = poly_x_minus_y (map_poly hom p)"
proof-
  interpret mp: map_poly_comm_ring_hom hom..
  interpret mmp: map_poly_comm_ring_hom "map_poly hom"..
  show ?thesis
    apply (induct p, simp)
    apply(unfold x_y_def hom_distribs poly_x_minus_y_pCons, simp) done
qed

lemma (in comm_ring_hom) hom_poly_lift[simp]:
  "map_poly (map_poly hom) (poly_lift q) = poly_lift (map_poly hom q)"
proof -
  show ?thesis
    unfolding poly_lift_def
    unfolding map_poly_map_poly[of coeff_lift,OF coeff_lift_hom.hom_zero]
    unfolding map_poly_coeff_lift_hom by simp
qed

lemma lead_coeff_poly_x_minus_y:
  fixes p :: "'a::idom poly"
  shows "lead_coeff (poly_x_minus_y p) = [:lead_coeff p * ((- 1) ^ degree p):]" (is "?l = ?r")
proof-
  have "?l = Polynomial.smult (lead_coeff p) ((- 1) ^ degree p)"
    by (unfold poly_x_minus_y_def, subst lead_coeff_comp; simp add: x_y_def)
  also have "... = ?r" by (unfold hom_distribs, simp add: smult_as_map_poly[symmetric])
  finally show ?thesis.
qed

lemma (in idom_hom) poly_add_hom:
  assumes p0: "hom (lead_coeff p) \<noteq> 0" and q0: "hom (lead_coeff q) \<noteq> 0"
  shows "map_poly hom (poly_add p q) = poly_add (map_poly hom p) (map_poly hom q)"
proof -
  interpret mh: map_poly_idom_hom..
  show ?thesis unfolding poly_add_def
    apply (subst mh.resultant_map_poly(1)[symmetric])
       apply (subst degree_map_poly_2)
       apply (unfold lead_coeff_poly_x_minus_y, unfold hom_distribs, simp add: p0)
      apply simp
     apply (subst degree_map_poly_2)
      apply (simp_all add: q0 map_poly_x_minus_y)
    done
qed

lemma(in zero_hom) hom_lead_coeff_nonzero_imp_map_poly_hom:
  assumes "hom (lead_coeff p) \<noteq> 0"
  shows "map_poly hom p \<noteq> 0"
proof
  assume "map_poly hom p = 0"
  then have "coeff (map_poly hom p) (degree p) = 0" by simp
  with assms show False by simp
qed

lemma ipoly_poly_add:
  fixes x y :: "'a :: idom"
  assumes p0: "(of_int (lead_coeff p) :: 'a) \<noteq> 0" and q0: "(of_int (lead_coeff q) :: 'a) \<noteq> 0"
      and x: "ipoly p x = 0" and y: "ipoly q y = 0"
  shows "ipoly (poly_add p q) (x+y) = 0"
  using assms of_int_hom.hom_lead_coeff_nonzero_imp_map_poly_hom[OF q0]
  by (auto intro: poly_add simp: of_int_hom.poly_add_hom[OF p0 q0])

lemma (in comm_monoid_gcd) gcd_list_eq_0_iff[simp]: "listgcd xs = 0 \<longleftrightarrow> (\<forall>x \<in> set xs. x = 0)"
  by (induct xs, auto)

lemma primitive_field_poly[simp]: "primitive (p :: 'a :: field poly) \<longleftrightarrow> p \<noteq> 0"
  by (unfold primitive_iff_some_content_dvd_1,auto simp: dvd_field_iff coeffs_def)

lemma ipoly_poly_add_nonzero:
  fixes x y :: "'a :: field"
  assumes "p \<noteq> 0" and "q \<noteq> 0" and "ipoly p x = 0" and "ipoly q y = 0"
      and "(of_int (lead_coeff p) :: 'a) \<noteq> 0" and "(of_int (lead_coeff q) :: 'a) \<noteq> 0"
  shows "poly_add p q \<noteq> 0"
proof-
  from assms have "(of_int_poly (poly_add p q) :: 'a poly) \<noteq> 0"
    apply (subst of_int_hom.poly_add_hom,simp,simp)
    by (rule poly_add_nonzero, auto dest:of_int_hom.hom_lead_coeff_nonzero_imp_map_poly_hom)
  then show ?thesis by auto
qed

lemma represents_add:
  assumes x: "p represents x" and y: "q represents y"
  shows "(poly_add p q) represents (x + y)"
  using assms by (intro representsI ipoly_poly_add ipoly_poly_add_nonzero, auto)

subsection \<open>Division of Algebraic Numbers\<close>

definition poly_x_mult_y where
  [code del]: "poly_x_mult_y p \<equiv> (\<Sum> i \<le> degree p. monom (monom (coeff p i) i) i)"

lemma coeff_poly_x_mult_y:
  shows "coeff (poly_x_mult_y p) i = monom (coeff p i) i" (is "?l = ?r")
proof(cases "degree p < i")
  case i: False
  have "?l = sum (\<lambda>j. if j = i then (monom (coeff p j) j) else 0) {..degree p}"
   (is "_ = sum ?f ?A") by (simp add: poly_x_mult_y_def coeff_sum)
  also have "... = sum ?f {i}" using i by (intro sum.mono_neutral_right, auto)
  also have "... = ?f i" by simp
  also have "... = ?r" by auto
  finally show ?thesis.
next
  case True then show ?thesis by (auto simp: poly_x_mult_y_def coeff_eq_0 coeff_sum)
qed

lemma poly_x_mult_y_code[code]: "poly_x_mult_y p = (let cs = coeffs p
  in poly_of_list (map (\<lambda> (i, ai). monom ai i) (zip [0 ..< length cs] cs)))"
  unfolding Let_def poly_of_list_def
proof (rule poly_eqI, unfold coeff_poly_x_mult_y)
  fix n
  let ?xs = "zip [0..<length (coeffs p)] (coeffs p)"
  let ?f = "(\<lambda>(i, ai). monom ai i)"
  show "monom (coeff p n) n = coeff (Poly (map ?f ?xs)) n"
  proof (cases "n < length (coeffs p)")
    case True
    hence n: "n < length (map ?f ?xs)" and nn: "n < length ?xs"
      unfolding degree_eq_length_coeffs by auto
    show ?thesis unfolding coeff_Poly nth_default_nth[OF n] nth_map[OF nn]
      using True by (simp add: nth_coeffs_coeff)
  next
    case False
    hence id: "coeff (Poly (map ?f ?xs)) n = 0" unfolding coeff_Poly
      by (subst nth_default_beyond, auto)
    from False have "n > degree p \<or> p = 0" unfolding degree_eq_length_coeffs by (cases n, auto)
    hence "monom (coeff p n) n = 0" using coeff_eq_0[of p n] by auto
    thus ?thesis unfolding id by simp
  qed
qed

definition poly_div :: "'a :: comm_ring_1 poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
  "poly_div p q = resultant (poly_x_mult_y p) (poly_lift q)"

text \<open>@{const poly_div} has desired roots.\<close>

lemma poly2_poly_x_mult_y:
  fixes p :: "'a :: comm_ring_1 poly"
  shows "poly2 (poly_x_mult_y p) x y = poly p (x * y)"
  apply (subst(3) poly_as_sum_of_monoms[symmetric])
  apply (unfold poly_x_mult_y_def hom_distribs)
  by (auto simp: poly2_monom poly_monom power_mult_distrib ac_simps)

lemma poly_div:
  fixes p q :: "'a ::field poly"
  assumes q0: "q \<noteq> 0" and x: "poly p x = 0" and y: "poly q y = 0" and y0: "y \<noteq> 0"
  shows "poly (poly_div p q) (x/y) = 0"
proof (unfold poly_div_def, rule poly_resultant_zero[OF disjI2])
  have "degree q > 0" using poly_zero q0 y by auto
  thus degq: "degree (poly_lift q) > 0" by auto
qed (insert x y y0, simp_all add: poly2_poly_x_mult_y)

text \<open>@{const poly_div} is nonzero.\<close>

interpretation poly_x_mult_y_hom: ring_hom "poly_x_mult_y :: 'a :: {idom,ring_char_0} poly \<Rightarrow> _"
  by (unfold_locales, auto intro: poly2_ext simp: poly2_poly_x_mult_y hom_distribs)

interpretation poly_x_mult_y_hom: inj_ring_hom "poly_x_mult_y :: 'a :: {idom,ring_char_0} poly \<Rightarrow> _"
proof
  let ?h = poly_x_mult_y
  fix f :: "'a poly"
  assume "?h f = 0"
  then have "poly2 (?h f) x 1 = 0" for x by simp
  from this[unfolded poly2_poly_x_mult_y]
  show "f = 0" by auto
qed

lemma degree_poly_x_mult_y[simp]:
  fixes p :: "'a :: {idom, ring_char_0} poly"
  shows "degree (poly_x_mult_y p) = degree p" (is "?l = ?r")
proof(rule antisym)
  show "?r \<le> ?l" by (cases "p=0", auto intro: le_degree simp: coeff_poly_x_mult_y)
  show "?l \<le> ?r" unfolding poly_x_mult_y_def
    by (auto intro: degree_sum_le le_trans[OF degree_monom_le])
qed

interpretation poly_x_mult_y_hom: unit_preserving_hom "poly_x_mult_y :: 'a :: field_char_0 poly \<Rightarrow> _"
proof(unfold_locales)
  let ?h = "poly_x_mult_y :: 'a poly \<Rightarrow> _"
  fix f :: "'a poly"
  assume unit: "?h f dvd 1"
  then have "degree (?h f) = 0" and "coeff (?h f) 0 dvd 1" unfolding poly_dvd_1 by auto
  then have deg: "degree f = 0" by (auto simp add: degree_monom_eq)
  with unit show "f dvd 1" by(cases "f = 0", auto)
qed

lemmas poly_y_x_o_poly_lift = o_def[of poly_y_x poly_lift, unfolded poly_y_x_poly_lift]

lemma irreducible_dvd_degree: assumes "(f::'a::field poly) dvd g"
 "irreducible g"
 "degree f > 0"
 shows "degree f = degree g"
  using assms
 by (metis irreducible_altdef degree_0 dvd_refl is_unit_field_poly linorder_neqE_nat poly_divides_conv0)

lemma coprime_poly_x_mult_y_poly_lift:
  fixes p q :: "'a :: field_char_0 poly"
  assumes degp: "degree p > 0" and degq: "degree q > 0"
    and nz: "poly p 0 \<noteq> 0 \<or> poly q 0 \<noteq> 0"
  shows "coprime (poly_x_mult_y p) (poly_lift q)"
proof(rule ccontr)
  from degp have p: "\<not> p dvd 1" by (auto simp: dvd_const)
  from degp have p0: "p \<noteq> 0" by auto
  from mset_factors_exist[of p, OF p0 p]
  obtain F where F: "mset_factors F p" by auto
  then have pF: "prod_mset (image_mset poly_x_mult_y F) = poly_x_mult_y p"
    by (auto simp: hom_distribs)

  from degq have q: "\<not> is_unit q" by (auto simp: dvd_const)
  from degq have q0: "q \<noteq> 0" by auto
  from mset_factors_exist[OF q0 q]
  obtain G where G: "mset_factors G q" by auto
  with poly_lift_hom.hom_mset_factors
  have pG: "mset_factors (image_mset poly_lift G) (poly_lift q)" by auto
  from poly_y_x_hom.hom_mset_factors[OF this]
  have pG: "mset_factors (image_mset coeff_lift G) [:q:]"
    by (auto simp: poly_y_x_poly_lift monom_0 image_mset.compositionality poly_y_x_o_poly_lift)

  assume "\<not> coprime (poly_x_mult_y p) (poly_lift q)"
  then have "\<not> coprime (poly_y_x (poly_x_mult_y p)) (poly_y_x (poly_lift q))"
    by (simp del: coprime_iff_coprime)
  from this[unfolded not_coprime_iff_common_factor]
  obtain r
  where rp: "r dvd poly_y_x (poly_x_mult_y p)"
    and rq: "r dvd poly_y_x (poly_lift q)"
    and rU: "\<not> r dvd 1" by auto
  from rp p0 have r0: "r \<noteq> 0" by auto
  from mset_factors_exist[OF r0 rU]
  obtain H where H: "mset_factors H r" by auto
  then have "H \<noteq> {#}" by auto
  then obtain h where hH: "h \<in># H" by fastforce
  with H mset_factors_imp_dvd have hr: "h dvd r" and h: "irreducible h" by auto
  from irreducible_not_unit[OF h] have hU: "\<not> h dvd 1" by auto
  from hr rp have "h dvd poly_y_x (poly_x_mult_y p)" by (rule dvd_trans)
  note this[folded pF,unfolded poly_y_x_hom.hom_prod_mset image_mset.compositionality]
  from prime_elem_dvd_prod_mset[OF h[folded prime_elem_iff_irreducible] this]
  obtain f where f: "f \<in># F" and hf: "h dvd poly_y_x (poly_x_mult_y f)" by auto
  have irrF: "irreducible f" using f F by blast
    from dvd_trans[OF hr rq] have "h dvd [:q:]" by (simp add: poly_y_x_poly_lift monom_0)
    from irreducible_dvd_imp_factor[OF this h pG] q0
    obtain g where g: "g \<in># G" and gh: "[:g:] dvd h" by auto
    from dvd_trans[OF gh hf] have *: "[:g:] dvd poly_y_x (poly_x_mult_y f)" using dvd_trans by auto
  show False
  proof (cases "poly f 0 = 0")
    case f_0: False
    from poly_hom.hom_dvd[OF *]
    have "g dvd poly (poly_y_x (poly_x_mult_y f)) [:0:]" by simp
    also have "... = [:poly f 0:]" by (intro poly_ext, fold poly2_def, simp add: poly2_poly_x_mult_y)
    also have "... dvd 1" using f_0 by auto
    finally have "g dvd 1".
    with g G show False by (auto elim!: mset_factorsE dest!: irreducible_not_unit)
  next
    case True
    hence "[:0,1:] dvd f" by (unfold dvd_iff_poly_eq_0, simp)
    from irreducible_dvd_degree[OF this irrF]
    have "degree f = 1" by auto
    from degree1_coeffs[OF this] True obtain c where c: "c \<noteq> 0" and f: "f = [:0,c:]" by auto
    from g G have irrG: "irreducible g" by auto
    from poly_hom.hom_dvd[OF *]
    have "g dvd poly (poly_y_x (poly_x_mult_y f)) 1" by simp
    also have "\<dots> = f" by (auto simp: f poly_x_mult_y_code Let_def c poly_y_x_pCons map_poly_monom poly_monom poly_lift_def)
    also have "\<dots> dvd [:0,1:]" unfolding f dvd_def using c
      by (intro exI[of _ "[: inverse c :]"], auto)
    finally have g01: "g dvd [:0,1:]" .
    from divides_degree[OF this] irrG have "degree g = 1" by auto
    from degree1_coeffs[OF this] obtain a b where g: "g = [:b,a:]" and a: "a \<noteq> 0" by auto
    from g01[unfolded dvd_def] g obtain k where id: "[:0,1:] = g * k" by auto
    from id have 0: "g \<noteq> 0" "k \<noteq> 0" by auto
    from arg_cong[OF id, of degree] have "degree k = 0" unfolding degree_mult_eq[OF 0]
      unfolding g using a by auto
    from degree0_coeffs[OF this] obtain kk where k: "k = [:kk:]" by auto
    from id[unfolded g k] a have "b = 0" by auto
    hence "poly g 0 = 0" by (auto simp: g)
    from True this nz \<open>f \<in># F\<close> \<open>g \<in># G\<close> F G
    show False by (auto dest!:mset_factors_imp_dvd elim:dvdE)
  qed
qed

lemma poly_div_nonzero:
  fixes p q :: "'a :: field_char_0 poly"
  assumes p0: "p \<noteq> 0" and q0: "q \<noteq> 0" and x: "poly p x = 0" and y: "poly q y = 0"
      and p_0: "poly p 0 \<noteq> 0 \<or> poly q 0 \<noteq> 0"
  shows "poly_div p q \<noteq> 0"
proof
  have degp: "degree p > 0" using le_0_eq order_degree order_root p0 x by (metis gr0I)
  have degq: "degree q > 0" using le_0_eq order_degree order_root q0 y by (metis gr0I)
  assume 0: "poly_div p q = 0"
  from resultant_zero_imp_common_factor[OF _ this[unfolded poly_div_def]] degp
   and coprime_poly_x_mult_y_poly_lift[OF degp degq] p_0
  show False by auto
qed

subsubsection \<open>Summary for division\<close>

text \<open>Now we lift the results to one that uses @{const ipoly}, by showing some homomorphism lemmas.\<close>

lemma (in inj_comm_ring_hom) poly_x_mult_y_hom:
  "poly_x_mult_y (map_poly hom p) = map_poly (map_poly hom) (poly_x_mult_y p)"
proof -
  interpret mh: map_poly_inj_comm_ring_hom..
  interpret mmh: map_poly_inj_comm_ring_hom "map_poly hom"..
  show ?thesis unfolding poly_x_mult_y_def by (simp add: hom_distribs)
qed

lemma (in inj_comm_ring_hom) poly_div_hom:
  "map_poly hom (poly_div p q) = poly_div (map_poly hom p) (map_poly hom q)"
proof -
  have zero: "\<forall>x. hom x = 0 \<longrightarrow> x = 0" by simp
  interpret mh: map_poly_inj_comm_ring_hom..
  show ?thesis unfolding poly_div_def mh.resultant_hom[symmetric]
    by (simp add: poly_x_mult_y_hom)
qed

lemma ipoly_poly_div:
  fixes x y :: "'a :: field_char_0"
  assumes "q \<noteq> 0" and "ipoly p x = 0" and "ipoly q y = 0" and "y \<noteq> 0"
  shows "ipoly (poly_div p q) (x/y) = 0"
  by (unfold of_int_hom.poly_div_hom, rule poly_div, insert assms, auto)

lemma represents_div:
  fixes x y :: "'a :: field_char_0"
  assumes "p represents x" and "q represents y" and "poly q 0 \<noteq> 0"
  shows "(poly_div p q) represents (x / y)"
  using assms by (intro representsI ipoly_poly_div ipoly_poly_div_nonzero, auto)

subsection \<open>Multiplication of Algebraic Numbers\<close>

definition poly_mult where "poly_mult p q \<equiv> poly_div p (reflect_poly q)"

lemma represents_mult:
  assumes px: "p represents x" and qy: "q represents y" and q_0: "poly q 0 \<noteq> 0"
  shows "(poly_mult p q) represents (x * y)"
proof-
  from q_0 qy have y0: "y \<noteq> 0" by auto
  from represents_inverse[OF y0 qy] y0 px q_0
  have "poly_mult p q represents x / (inverse y)"
    unfolding poly_mult_def by (intro represents_div, auto)
  with y0 show ?thesis by (simp add: field_simps)
qed

subsection \<open>Summary: Closure Properties of Algebraic Numbers\<close>

lemma algebraic_representsI: "p represents x \<Longrightarrow> algebraic x"
  unfolding represents_def algebraic_altdef_ipoly by auto

lemma algebraic_uminus: "algebraic x \<Longrightarrow> algebraic (-x)"
  by (auto dest: algebraic_imp_represents_irreducible intro: algebraic_representsI represents_uminus)

lemma algebraic_inverse: "algebraic x \<Longrightarrow> algebraic (inverse x)"
  using algebraic_of_rat[of 0]
  by (cases "x = 0", auto dest: algebraic_imp_represents_irreducible intro: algebraic_representsI represents_inverse)

lemma algebraic_plus: "algebraic x \<Longrightarrow> algebraic y \<Longrightarrow> algebraic (x + y)"
  by (auto dest!: algebraic_imp_represents_irreducible_cf_pos intro!: algebraic_representsI[OF represents_add])

lemma algebraic_div:
  assumes x: "algebraic x" and y: "algebraic y" shows "algebraic (x/y)"
proof(cases "y = 0 \<or> x = 0")
  case True
  then show ?thesis using algebraic_of_rat[of 0] by auto
next
  case False
  then have x0: "x \<noteq> 0" and y0: "y \<noteq> 0" by auto
  from x y obtain p q
  where px: "p represents x" and irr: "irreducible q" and qy: "q represents y"
    by (auto dest!: algebraic_imp_represents_irreducible)
  show ?thesis
    using False px represents_irr_non_0[OF irr qy]
    by (auto intro!: algebraic_representsI[OF represents_div] qy)
qed

lemma algebraic_times: "algebraic x \<Longrightarrow> algebraic y \<Longrightarrow> algebraic (x * y)"
  using algebraic_div[OF _ algebraic_inverse, of x y] by (simp add: field_simps)

lemma algebraic_root: "algebraic x \<Longrightarrow> algebraic (root n x)"
proof -
  assume "algebraic x"
  then obtain p where p: "p represents x" by (auto dest: algebraic_imp_represents_irreducible_cf_pos)
  from
    algebraic_representsI[OF represents_nth_root_neg_real[OF _ this, of n]]
    algebraic_representsI[OF represents_nth_root_pos_real[OF _ this, of n]]
    algebraic_of_rat[of 0]
  show ?thesis by (cases "n = 0", force, cases "n > 0", force, cases "n < 0", auto)
qed

lemma algebraic_nth_root: "n \<noteq> 0 \<Longrightarrow> algebraic x \<Longrightarrow> y^n = x \<Longrightarrow> algebraic y"
  by (auto dest: algebraic_imp_represents_irreducible_cf_pos intro: algebraic_representsI represents_nth_root)

hide_const x_y

end


(* Author: Alexander Maletzky *)

section \<open>Quasi-Poly-Mapping Power-Products\<close>

theory Quasi_PM_Power_Products
  imports MPoly_Type_Class_Ordered
begin

text \<open>In this theory we introduce a subclass of @{class graded_dickson_powerprod} that approximates
  polynomial mappings even closer. We need this class for signature-based Gr\"obner basis algorithms.\<close>

definition (in monoid_add) hom_grading_fun :: "('a \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "hom_grading_fun d f \<longleftrightarrow> (\<forall>n. (\<forall>s t. f n (s + t) = f n s + f n t) \<and>
          (\<forall>t. d (f n t) \<le> n \<and> (d t \<le> n \<longrightarrow> f n t = t)))"

definition (in monoid_add) hom_grading :: "('a \<Rightarrow> nat) \<Rightarrow> bool"
  where "hom_grading d \<longleftrightarrow> (\<exists>f. hom_grading_fun d f)"

definition (in monoid_add) decr_grading :: "('a \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"
  where "decr_grading d = (SOME f. hom_grading_fun d f)"

lemma decr_grading:
  assumes "hom_grading d"
  shows "hom_grading_fun d (decr_grading d)"
proof -
  from assms obtain f where "hom_grading_fun d f" unfolding hom_grading_def ..
  thus ?thesis unfolding decr_grading_def by (metis someI)
qed

lemma decr_grading_plus:
  "hom_grading d \<Longrightarrow> decr_grading d n (s + t) = decr_grading d n s + decr_grading d n t"
  using decr_grading unfolding hom_grading_fun_def by blast

lemma decr_grading_zero:
  assumes "hom_grading d"
  shows "decr_grading d n 0 = (0::'a::cancel_comm_monoid_add)"
proof -
  have "decr_grading d n 0 = decr_grading d n (0 + 0)" by simp
  also from assms have "... = decr_grading d n 0 + decr_grading d n 0" by (rule decr_grading_plus)
  finally show ?thesis by simp
qed

lemma decr_grading_le: "hom_grading d \<Longrightarrow> d (decr_grading d n t) \<le> n"
  using decr_grading unfolding hom_grading_fun_def by blast

lemma decr_grading_idI: "hom_grading d \<Longrightarrow> d t \<le> n \<Longrightarrow> decr_grading d n t = t"
  using decr_grading unfolding hom_grading_fun_def by blast

class quasi_pm_powerprod = ulcs_powerprod +
  assumes ex_hgrad: "\<exists>d::'a \<Rightarrow> nat. dickson_grading d \<and> hom_grading d"
begin

subclass graded_dickson_powerprod
proof
  from ex_hgrad show "\<exists>d. dickson_grading d" by blast
qed

end (* quasi_pm_powerprod *)

lemma hom_grading_varnum:
  "hom_grading ((varnum X)::('x::countable \<Rightarrow>\<^sub>0 'b::add_wellorder) \<Rightarrow> nat)"
proof -
  define f where "f = (\<lambda>n t. (except t (- (X \<union> {x. elem_index x < n})))::'x \<Rightarrow>\<^sub>0 'b)"
  show ?thesis unfolding hom_grading_def hom_grading_fun_def
  proof (intro exI allI conjI impI)
    fix n s t
    show "f n (s + t) = f n s + f n t" by (simp only: f_def except_plus)
  next
    fix n t
    show "varnum X (f n t) \<le> n" by (auto simp: varnum_le_iff keys_except f_def)
  next
    fix n t
    show "varnum X t \<le> n \<Longrightarrow> f n t = t" by (auto simp: f_def except_id_iff varnum_le_iff)
  qed
qed

instance poly_mapping :: (countable, add_wellorder) quasi_pm_powerprod
  by (standard, intro exI conjI, fact dickson_grading_varnum_empty, fact hom_grading_varnum)

context term_powerprod
begin

definition decr_grading_term :: "('a \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> 't \<Rightarrow> 't"
  where "decr_grading_term d n v = term_of_pair (decr_grading d n (pp_of_term v), component_of_term v)"

definition decr_grading_p :: "('a \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> ('t \<Rightarrow>\<^sub>0 'b) \<Rightarrow> ('t \<Rightarrow>\<^sub>0 'b::comm_monoid_add)"
  where "decr_grading_p d n p = (\<Sum>v\<in>keys p. monomial (lookup p v) (decr_grading_term d n v))"

lemma decr_grading_term_splus:
  "hom_grading d \<Longrightarrow> decr_grading_term d n (t \<oplus> v) = decr_grading d n t \<oplus> decr_grading_term d n v"
  by (simp add: decr_grading_term_def term_simps decr_grading_plus splus_def)

lemma decr_grading_term_le: "hom_grading d \<Longrightarrow> d (pp_of_term (decr_grading_term d n v)) \<le> n"
  by (simp add: decr_grading_term_def term_simps decr_grading_le)

lemma decr_grading_term_idI: "hom_grading d \<Longrightarrow> d (pp_of_term v) \<le> n \<Longrightarrow> decr_grading_term d n v = v"
  by (simp add: decr_grading_term_def term_simps decr_grading_idI)

lemma punit_decr_grading_term: "punit.decr_grading_term = decr_grading"
  by (intro ext, simp add: punit.decr_grading_term_def)

lemma decr_grading_p_zero: "decr_grading_p d n 0 = 0"
  by (simp add: decr_grading_p_def)

lemma decr_grading_p_monomial: "decr_grading_p d n (monomial c v) = monomial c (decr_grading_term d n v)"
  by (simp add: decr_grading_p_def)

lemma decr_grading_p_plus:
  "decr_grading_p d n (p + q) = (decr_grading_p d n p) + (decr_grading_p d n q)"
proof -
  from finite_keys finite_keys have fin: "finite (keys p \<union> keys q)" by (rule finite_UnI)
  hence eq1: "(\<Sum>v\<in>keys p \<union> keys q. monomial (lookup p v) (decr_grading_term d n v)) =
              (\<Sum>v\<in>keys p. monomial (lookup p v) (decr_grading_term d n v))"
  proof (rule sum.mono_neutral_right)
    show "\<forall>v\<in>keys p \<union> keys q - keys p. monomial (lookup p v) (decr_grading_term d n v) = 0"
      by (simp add: in_keys_iff)
  qed simp
  from fin have eq2: "(\<Sum>v\<in>keys p \<union> keys q. monomial (lookup q v) (decr_grading_term d n v)) =
              (\<Sum>v\<in>keys q. monomial (lookup q v) (decr_grading_term d n v))"
  proof (rule sum.mono_neutral_right)
    show "\<forall>v\<in>keys p \<union> keys q - keys q. monomial (lookup q v) (decr_grading_term d n v) = 0"
      by (simp add: in_keys_iff)
  qed simp
  from fin Poly_Mapping.keys_add
  have "decr_grading_p d n (p + q) =
                (\<Sum>v\<in>keys p \<union> keys q. monomial (lookup (p + q) v) (decr_grading_term d n v))"
    unfolding decr_grading_p_def
  proof (rule sum.mono_neutral_left)
    show "\<forall>v\<in>keys p \<union> keys q - keys (p + q). monomial (lookup (p + q) v) (decr_grading_term d n v) = 0"
      by (simp add: in_keys_iff)
  qed
  also have "... = (\<Sum>v\<in>keys p \<union> keys q. monomial (lookup p v) (decr_grading_term d n v)) +
                   (\<Sum>v\<in>keys p \<union> keys q. monomial (lookup q v) (decr_grading_term d n v))"
    by (simp only: lookup_add single_add sum.distrib)
  also have "... = (decr_grading_p d n p) + (decr_grading_p d n q)"
    by (simp only: eq1 eq2 decr_grading_p_def)
  finally show ?thesis .
qed

corollary decr_grading_p_sum: "decr_grading_p d n (sum f A) = (\<Sum>a\<in>A. decr_grading_p d n (f a))"
  using decr_grading_p_zero decr_grading_p_plus by (rule fun_sum_commute)

lemma decr_grading_p_monom_mult:
  assumes "hom_grading d"
  shows "decr_grading_p d n (monom_mult c t p) = monom_mult c (decr_grading d n t) (decr_grading_p d n p)"
proof (induct p rule: poly_mapping_plus_induct)
  case 1
  show ?case by (simp add: decr_grading_p_zero)
next
  case (2 p a s)
  from assms show ?case
    by (simp add: monom_mult_dist_right decr_grading_p_plus 2(3) monom_mult_monomial
        decr_grading_p_monomial decr_grading_term_splus)
qed

lemma decr_grading_p_mult_scalar:
  assumes "hom_grading d"
  shows "decr_grading_p d n (p \<odot> q) = punit.decr_grading_p d n p \<odot> decr_grading_p d n q"
proof (induct p rule: poly_mapping_plus_induct)
  case 1
  show ?case by (simp add: punit.decr_grading_p_zero decr_grading_p_zero)
next
  case (2 p a s)
  from assms show ?case
    by (simp add: mult_scalar_distrib_right decr_grading_p_plus punit.decr_grading_p_plus 2(3)
        punit.decr_grading_p_monomial mult_scalar_monomial decr_grading_p_monom_mult punit_decr_grading_term)
qed

lemma decr_grading_p_keys_subset: "keys (decr_grading_p d n p) \<subseteq> decr_grading_term d n ` keys p"
proof
  fix v
  assume "v \<in> keys (decr_grading_p d n p)"
  also have "... \<subseteq> (\<Union>u\<in>keys p. keys (monomial (lookup p u) (decr_grading_term d n u)))"
    unfolding decr_grading_p_def by (fact keys_sum_subset)
  finally obtain u where "u \<in> keys p" and "v \<in> keys (monomial (lookup p u) (decr_grading_term d n u))" ..
  from this(2) have eq: "v = decr_grading_term d n u" by (simp split: if_split_asm)
  show "v \<in> decr_grading_term d n ` keys p" unfolding eq using \<open>u \<in> keys p\<close> by (rule imageI)
qed

lemma decr_grading_p_idI':
  assumes "hom_grading d" and "\<And>v. v \<in> keys p \<Longrightarrow> d (pp_of_term v) \<le> n"
  shows "decr_grading_p d n p = p"
proof -
  have "decr_grading_p d n p = (\<Sum>v \<in> keys p. monomial (lookup p v) v)" unfolding decr_grading_p_def
    using refl
  proof (rule sum.cong)
    fix v
    assume "v \<in> keys p"
    hence "d (pp_of_term v) \<le> n" by (rule assms(2))
    with assms(1) have "decr_grading_term d n v = v" by (rule decr_grading_term_idI)
    thus "monomial (lookup p v) (decr_grading_term d n v) = monomial (lookup p v) v" by simp
  qed
  also have "... = p" by (fact poly_mapping_sum_monomials)
  finally show ?thesis .
qed

end (* term_powerprod *)

context gd_term
begin

lemma decr_grading_p_idI:
  assumes "hom_grading d" and "p \<in> dgrad_p_set d m"
  shows "decr_grading_p d m p = p"
proof -
  from assms(2) have "\<And>v. v \<in> keys p \<Longrightarrow> d (pp_of_term v) \<le> m"
    by (auto simp: dgrad_p_set_def dgrad_set_def)
  with assms(1) show ?thesis by (rule decr_grading_p_idI')
qed

lemma decr_grading_p_dgrad_p_setI:
  assumes "hom_grading d"
  shows "decr_grading_p d m p \<in> dgrad_p_set d m"
proof (rule dgrad_p_setI)
  fix v
  assume "v \<in> keys (decr_grading_p d m p)"
  hence "v \<in> decr_grading_term d m ` keys p" using decr_grading_p_keys_subset ..
  then obtain u where "v = decr_grading_term d m u" ..
  with assms show "d (pp_of_term v) \<le> m" by (simp add: decr_grading_term_le)
qed

lemma (in gd_term) in_pmdlE_dgrad_p_set:
  assumes "hom_grading d" and "B \<subseteq> dgrad_p_set d m" and "p \<in> dgrad_p_set d m" and "p \<in> pmdl B"
  obtains A q where "finite A" and "A \<subseteq> B" and "\<And>b. q b \<in> punit.dgrad_p_set d m"
    and "p = (\<Sum>b\<in>A. q b \<odot> b)"
proof -
  from assms(4) obtain A q0 where "finite A" and "A \<subseteq> B" and p: "p = (\<Sum>b\<in>A. q0 b \<odot> b)"
    by (rule pmdl.spanE)
  define q where "q = (\<lambda>b. punit.decr_grading_p d m (q0 b))"
  from \<open>finite A\<close> \<open>A \<subseteq> B\<close> show ?thesis
  proof
    fix b
    show "q b \<in> punit.dgrad_p_set d m" unfolding q_def using assms(1) by (rule punit.decr_grading_p_dgrad_p_setI)
  next
    from assms(1, 3) have "p = decr_grading_p d m p" by (simp only: decr_grading_p_idI)
    also from assms(1) have "... = (\<Sum>b\<in>A. q b \<odot> (decr_grading_p d m b))"
      by (simp add: p q_def decr_grading_p_sum decr_grading_p_mult_scalar)
    also from refl have "... = (\<Sum>b\<in>A. q b \<odot> b)"
    proof (rule sum.cong)
      fix b
      assume "b \<in> A"
      hence "b \<in> B" using \<open>A \<subseteq> B\<close> ..
      hence "b \<in> dgrad_p_set d m" using assms(2) ..
      with assms(1) have "decr_grading_p d m b = b" by (rule decr_grading_p_idI)
      thus "q b \<odot> decr_grading_p d m b = q b \<odot> b" by simp
    qed
    finally show "p = (\<Sum>b\<in>A. q b \<odot> b)" .
  qed
qed

end (* gd_term *)

end (* theory *)


section {* \isaheader{Array-Based Maps with Natural Number Keys} *}
theory Impl_Array_Map
imports
  "../../../Automatic_Refinement/Automatic_Refinement"
  "../../Lib/Diff_Array"
  "../../Iterator/Iterator"
  "../Gen/Gen_Map"
  "../Intf/Intf_Comp"
  "../Intf/Intf_Map"
begin

type_synonym 'v iam = "'v option array"

subsection {* Definitions *}

definition iam_\<alpha> :: "'v iam \<Rightarrow> nat \<rightharpoonup> 'v" where
  "iam_\<alpha> a i \<equiv> if i < array_length a then array_get a i else None"

abbreviation iam_invar :: "'v iam \<Rightarrow> bool" where "iam_invar \<equiv> \<lambda>_. True"

definition iam_empty :: "unit \<Rightarrow> 'v iam"
  where "iam_empty \<equiv> \<lambda>_::unit. array_of_list []"

definition iam_lookup :: "nat \<Rightarrow> 'v iam \<rightharpoonup> 'v"
  where [code_unfold]: "iam_lookup k a \<equiv> iam_\<alpha> a k"

definition "iam_increment (l::nat) idx \<equiv>
  max (idx + 1 - l) (2 * l + 3)"

lemma incr_correct: "\<not> idx < l \<Longrightarrow> idx < l + iam_increment l idx"
  unfolding iam_increment_def by auto

definition iam_update :: "nat \<Rightarrow> 'v \<Rightarrow> 'v iam \<Rightarrow> 'v iam"
  where "iam_update k v a \<equiv> let
    l = array_length a;
    a = if k < l then a else array_grow a (iam_increment l k) None
  in
    array_set a k (Some v)"

lemma [code]: "iam_update k v a \<equiv> array_set_oo
  (\<lambda>_. let l=array_length a in
         array_set (array_grow a (iam_increment l k) None) k (Some v))
  a k (Some v)"
  unfolding iam_update_def array_set_oo_def
  apply (rule eq_reflection)
  by auto

definition iam_delete :: "nat \<Rightarrow> 'v iam \<Rightarrow> 'v iam"
  where "iam_delete k a \<equiv>
  if k<array_length a then array_set a k None else a"

lemma [code]: "iam_delete k a \<equiv> array_set_oo (\<lambda>_. a) a k None"
  unfolding iam_delete_def array_set_oo_def by auto

primrec iam_iteratei_aux
  :: "nat \<Rightarrow> ('v iam) \<Rightarrow> ('\<sigma>\<Rightarrow>bool) \<Rightarrow> (nat \<times> 'v\<Rightarrow>'\<sigma>\<Rightarrow>'\<sigma>) \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>"
  where
    "iam_iteratei_aux 0 a c f \<sigma> = \<sigma>"
  | "iam_iteratei_aux (Suc i) a c f \<sigma> = (
      if c \<sigma> then
        iam_iteratei_aux i a c f (
          case array_get a i of None \<Rightarrow> \<sigma> | Some x \<Rightarrow> f (i, x) \<sigma>
        )
      else \<sigma>)"

definition iam_iteratei :: "'v iam \<Rightarrow> (nat \<times> 'v,'\<sigma>) set_iterator" where
  "iam_iteratei a = iam_iteratei_aux (array_length a) a"

subsection {* Parametricity *}

definition iam_rel_def_internal:
  "iam_rel R \<equiv> \<langle>\<langle>R\<rangle> option_rel\<rangle> array_rel"
lemma iam_rel_def: "\<langle>R\<rangle> iam_rel = \<langle>\<langle>R\<rangle> option_rel\<rangle> array_rel"
    by (simp add: iam_rel_def_internal relAPP_def)

lemma iam_rel_sv[relator_props]:
  "single_valued Rv \<Longrightarrow> single_valued (\<langle>Rv\<rangle>iam_rel)"
  unfolding iam_rel_def
  by tagged_solver

lemma param_iam_\<alpha>[param]:
  "(iam_\<alpha>, iam_\<alpha>) \<in> \<langle>R\<rangle> iam_rel \<rightarrow> nat_rel \<rightarrow> \<langle>R\<rangle> option_rel"
  unfolding iam_\<alpha>_def[abs_def] iam_rel_def by parametricity

lemma param_iam_invar[param]:
  "(iam_invar, iam_invar) \<in> \<langle>R\<rangle> iam_rel \<rightarrow> bool_rel"
  unfolding iam_rel_def by parametricity

lemma param_iam_empty[param]:
  "(iam_empty, iam_empty) \<in> unit_rel \<rightarrow> \<langle>R\<rangle>iam_rel"
    unfolding iam_empty_def[abs_def] iam_rel_def by parametricity

lemma param_iam_lookup[param]:
  "(iam_lookup, iam_lookup) \<in> nat_rel \<rightarrow> \<langle>R\<rangle>iam_rel \<rightarrow> \<langle>R\<rangle>option_rel"
  unfolding iam_lookup_def[abs_def]
  by parametricity

(* TODO: why does parametricity fail here? *)
lemma param_iam_increment[param]:
  "(iam_increment, iam_increment) \<in> nat_rel \<rightarrow> nat_rel \<rightarrow> nat_rel"
  unfolding iam_increment_def[abs_def]
  by simp

(* TODO: The builtin "Let" rule for parametricity does some unpleasant things
         here, leading to an unprovable subgoal. Investigate this. *)
lemma param_iam_update[param]:
  "(iam_update, iam_update) \<in> nat_rel \<rightarrow> R \<rightarrow> \<langle>R\<rangle>iam_rel \<rightarrow> \<langle>R\<rangle>iam_rel"
unfolding iam_update_def[abs_def] iam_rel_def Let_def
apply parametricity
done

lemma param_iam_delete[param]:
  "(iam_delete, iam_delete) \<in> nat_rel \<rightarrow> \<langle>R\<rangle>iam_rel \<rightarrow> \<langle>R\<rangle>iam_rel"
  unfolding iam_delete_def[abs_def] iam_rel_def by parametricity

lemma param_iam_iteratei_aux[param]:
  assumes I: "i \<le> array_length a"
  assumes IR: "(i,i') \<in> nat_rel"
  assumes AR: "(a,a') \<in> \<langle>Ra\<rangle>iam_rel"
  assumes CR: "(c,c') \<in> Rb \<rightarrow> bool_rel"
  assumes FR: "(f,f') \<in> \<langle>nat_rel,Ra\<rangle>prod_rel \<rightarrow> Rb \<rightarrow> Rb"
  assumes \<sigma>R: "(\<sigma>,\<sigma>') \<in> Rb"
  shows "(iam_iteratei_aux i a c f \<sigma>, iam_iteratei_aux i' a' c' f' \<sigma>') \<in> Rb"
  using assms
  unfolding iam_rel_def
  apply (induct i' arbitrary: i \<sigma> \<sigma>')
  apply (simp_all only: pair_in_Id_conv iam_iteratei_aux.simps)
  apply parametricity
  apply simp_all
  done

lemma param_iam_iteratei[param]:
  "(iam_iteratei,iam_iteratei) \<in> \<langle>Ra\<rangle>iam_rel \<rightarrow> (Rb \<rightarrow> bool_rel) \<rightarrow>
      (\<langle>nat_rel,Ra\<rangle>prod_rel \<rightarrow> Rb \<rightarrow> Rb) \<rightarrow> Rb \<rightarrow> Rb"
  unfolding iam_iteratei_def[abs_def]
  by parametricity (simp_all add: iam_rel_def)

subsection {* Correctness *}

definition "iam_rel' \<equiv> br iam_\<alpha> iam_invar"

lemma iam_empty_correct:
  "(iam_empty (), Map.empty) \<in>  iam_rel'"
   by (simp add: iam_rel'_def br_def iam_\<alpha>_def[abs_def] iam_empty_def)

lemma iam_update_correct:
  "(iam_update,op_map_update) \<in> nat_rel \<rightarrow> Id \<rightarrow> iam_rel'  \<rightarrow> iam_rel'"
   by (auto simp: iam_rel'_def br_def Let_def array_get_array_set_other
                  incr_correct iam_\<alpha>_def[abs_def] iam_update_def)

lemma iam_lookup_correct:
  "(iam_lookup,op_map_lookup) \<in> Id \<rightarrow> iam_rel' \<rightarrow> \<langle>Id\<rangle>option_rel"
   by (auto simp: iam_rel'_def br_def iam_lookup_def[abs_def])

lemma array_get_set_iff: "i<array_length a \<Longrightarrow>
  array_get (array_set a i x) j = (if i=j then x else array_get a j)"
  by (auto simp: array_get_array_set_other)

lemma iam_delete_correct:
  "(iam_delete,op_map_delete) \<in> Id \<rightarrow> iam_rel' \<rightarrow> iam_rel'"
  unfolding iam_\<alpha>_def[abs_def] iam_delete_def[abs_def] iam_rel'_def br_def
  by (auto simp: Let_def array_get_set_iff)

definition iam_map_rel_def_internal:
  "iam_map_rel Rk Rv \<equiv>
    if Rk=nat_rel then \<langle>Rv\<rangle>iam_rel O iam_rel' else {}"
lemma iam_map_rel_def:
  "\<langle>nat_rel,Rv\<rangle>iam_map_rel \<equiv> \<langle>Rv\<rangle>iam_rel O iam_rel'"
  unfolding iam_map_rel_def_internal relAPP_def by simp

lemmas [autoref_rel_intf] = REL_INTFI[of "iam_map_rel" i_map]

lemma iam_map_rel_sv[relator_props]:
  "single_valued Rv \<Longrightarrow> single_valued (\<langle>nat_rel,Rv\<rangle>iam_map_rel)"
  unfolding iam_map_rel_def iam_rel'_def by tagged_solver

lemma iam_empty_impl:
    "(iam_empty (), op_map_empty) \<in> \<langle>nat_rel,R\<rangle>iam_map_rel"
  unfolding iam_map_rel_def op_map_empty_def
  apply (intro relcompI)
  apply (rule param_iam_empty[THEN fun_relD], simp)
  apply (rule iam_empty_correct)
  done

lemma iam_lookup_impl:
    "(iam_lookup, op_map_lookup)
  \<in> nat_rel \<rightarrow> \<langle>nat_rel,R\<rangle>iam_map_rel \<rightarrow> \<langle>R\<rangle>option_rel"
unfolding iam_map_rel_def
apply (intro fun_relI)
apply (elim relcompE)
apply (frule iam_lookup_correct[param_fo], assumption)
apply (frule param_iam_lookup[param_fo], assumption)
apply simp
done

lemma iam_update_impl:
   "(iam_update, op_map_update) \<in>
     nat_rel \<rightarrow> R \<rightarrow> \<langle>nat_rel,R\<rangle>iam_map_rel \<rightarrow> \<langle>nat_rel,R\<rangle>iam_map_rel"
  unfolding iam_map_rel_def
  apply (intro fun_relI, elim relcompEpair, intro relcompI)
  apply (erule (2) param_iam_update[param_fo])
  apply (rule iam_update_correct[param_fo])
  apply simp_all
  done

lemma iam_delete_impl:
    "(iam_delete, op_map_delete) \<in>
        nat_rel \<rightarrow> \<langle>nat_rel,R\<rangle>iam_map_rel \<rightarrow> \<langle>nat_rel,R\<rangle>iam_map_rel"
  unfolding iam_map_rel_def
  apply (intro fun_relI, elim relcompEpair, intro relcompI)
  apply (erule (1) param_iam_delete[param_fo])
  apply (rule iam_delete_correct[param_fo])
  by simp_all

lemmas iam_map_impl =
  iam_empty_impl
  iam_lookup_impl
  iam_update_impl
  iam_delete_impl

declare iam_map_impl[autoref_rules]

subsection {* Iterator proofs *}

abbreviation "iam_to_list a \<equiv> it_to_list iam_iteratei a"

lemma distinct_iam_to_list_aux:
  shows "\<lbrakk>distinct xs; \<forall>(i,_)\<in>set xs. i \<ge> n\<rbrakk> \<Longrightarrow>
        distinct (iam_iteratei_aux n a
            (\<lambda>_.True) (\<lambda>x y. y @ [x]) xs)"
   (is "\<lbrakk>_;_\<rbrakk> \<Longrightarrow> distinct (?iam_to_list_aux n xs)")
proof (induction n arbitrary: xs)
  case (0 xs) thus ?case by simp
next
  case (Suc i xs)
    show ?case
    proof (cases "array_get a i")
      case None
        with Suc.IH[OF Suc.prems(1)] Suc.prems(2)
            show ?thesis by force
    next
      case (Some x)
        let ?xs' = "xs @ [(i,x)]"
        from Suc.prems have "distinct ?xs'" and
            "\<forall>(i',x)\<in>set ?xs'. i' \<ge> i" by force+
        from Some and Suc.IH[OF this] show ?thesis by simp
  qed
qed

lemma distinct_iam_to_list:
  "distinct (iam_to_list a)"
unfolding it_to_list_def iam_iteratei_def
  by (force intro: distinct_iam_to_list_aux)

lemma iam_to_list_set_correct_aux:
  assumes "(a, m) \<in> iam_rel'"
  shows "\<lbrakk>n \<le> array_length a; map_to_set m - {(k,v). k < n} = set xs\<rbrakk>
         \<Longrightarrow> map_to_set m =
             set (iam_iteratei_aux n a (\<lambda>_.True) (\<lambda>x y. y @ [x]) xs)"
proof (induction n arbitrary: xs)
  case (0 xs)
    thus ?case by simp
next
  case (Suc n xs)
    with assms have [simp]: "array_get a n = m n"
        unfolding iam_rel'_def br_def iam_\<alpha>_def[abs_def] by simp
    show ?case
    proof (cases "m n")
      case None
        with Suc.prems(2) have "map_to_set m - {(k,v). k < n} = set xs"
        unfolding map_to_set_def by (fastforce simp: less_Suc_eq)
        from None and Suc.IH[OF _ this] and Suc.prems(1)
            show ?thesis by simp
    next
      case (Some x)
        let ?xs' = "xs @ [(n,x)]"
        from Some and Suc.prems(2)
            have "map_to_set m - {(k,v). k < n} = set ?xs'"
            unfolding map_to_set_def by (fastforce simp: less_Suc_eq)
        from Some and Suc.IH[OF _ this] and Suc.prems(1)
            show ?thesis by simp
    qed
qed

lemma iam_to_list_set_correct:
  assumes "(a, m) \<in> iam_rel'"
  shows "map_to_set m = set (iam_to_list a)"
proof-
  from assms
      have A: "map_to_set m - {(k, v). k < array_length a} = set []"
      unfolding map_to_set_def iam_rel'_def br_def iam_\<alpha>_def[abs_def]
      by (force split: split_if_asm)
  with iam_to_list_set_correct_aux[OF assms _ A] show ?thesis
    unfolding it_to_list_def iam_iteratei_def by simp
qed

lemma iam_iteratei_aux_append:
  "n \<le> length xs \<Longrightarrow> iam_iteratei_aux n (Array (xs @ ys)) =
             iam_iteratei_aux n (Array xs)"
apply (induction n)
apply force
apply (intro ext, auto split: option.split simp: nth_append)
done

lemma iam_iteratei_append:
  "iam_iteratei (Array (xs @ [None])) c f \<sigma> =
       iam_iteratei (Array xs) c f \<sigma>"
  "iam_iteratei (Array (xs @ [Some x])) c f \<sigma> =
       iam_iteratei (Array xs) c f
       (if c \<sigma> then (f (length xs, x) \<sigma>) else \<sigma>)"
unfolding  iam_iteratei_def
apply (cases "length xs")
apply (simp add: iam_iteratei_aux_append)
apply (force simp: nth_append iam_iteratei_aux_append) []
apply (cases "length xs")
apply (simp add: iam_iteratei_aux_append)
apply (force split: option.split
             simp: nth_append iam_iteratei_aux_append) []
done

lemma iam_iteratei_aux_Cons:
  "n < array_length a \<Longrightarrow>
      iam_iteratei_aux n a (\<lambda>_. True) (\<lambda>x l. l @ [x]) (x#xs) =
      x # iam_iteratei_aux n a (\<lambda>_. True) (\<lambda>x l. l @ [x]) xs"
    by (induction n arbitrary: xs, auto split: option.split)

lemma iam_to_list_append:
  "iam_to_list (Array (xs @ [None])) = iam_to_list (Array xs)"
  "iam_to_list (Array (xs @ [Some x])) =
       (length xs, x) # iam_to_list (Array xs)"
unfolding  it_to_list_def iam_iteratei_def
apply (simp add: iam_iteratei_aux_append)
apply (simp add: iam_iteratei_aux_Cons)
apply (simp add: iam_iteratei_aux_append)
done

lemma autoref_iam_is_iterator[autoref_ga_rules]:
  shows "is_map_to_list nat_rel Rv iam_map_rel iam_to_list"
  unfolding is_map_to_list_def is_map_to_sorted_list_def
proof (clarify)
  fix a m'
  assume "(a,m') \<in> \<langle>nat_rel,Rv\<rangle>iam_map_rel"
  then obtain a' where [param]: "(a,a')\<in>\<langle>Rv\<rangle>iam_rel"
    and "(a',m')\<in>iam_rel'" unfolding iam_map_rel_def by blast

  have "(iam_to_list a, iam_to_list a')
            \<in> \<langle>\<langle>nat_rel, Rv\<rangle>prod_rel\<rangle>list_rel" by parametricity

  moreover from distinct_iam_to_list and
                iam_to_list_set_correct[OF `(a',m')\<in>iam_rel'`]
      have "RETURN (iam_to_list a') \<le> it_to_sorted_list
               (key_rel (\<lambda>_ _. True)) (map_to_set m')"
      unfolding it_to_sorted_list_def key_rel_def[abs_def]
          by (force intro: refine_vcg)

  ultimately show "\<exists>l'. (iam_to_list a, l') \<in>
                            \<langle>\<langle>nat_rel, Rv\<rangle>prod_rel\<rangle>list_rel
                    \<and> RETURN l' \<le> it_to_sorted_list (
                        key_rel (\<lambda>_ _. True)) (map_to_set m')" by blast
qed

(* We provide a ,,sorted'' iterator to simplify derivations of the
    generic algorithm library *)
lemmas [autoref_ga_rules] =
  autoref_iam_is_iterator[unfolded is_map_to_list_def]

lemma iam_iteratei_altdef:
    "iam_iteratei a = foldli (iam_to_list a)"
     (is "?f a = ?g (iam_to_list a)")
proof-
  obtain l where "a = Array l" by (cases a)
  have "?f (Array l) = ?g (iam_to_list (Array l))"
  proof (induction "length l" arbitrary: l)
    case (0 l)
      thus ?case by (intro ext,
          simp add: iam_iteratei_def it_to_list_def)
  next
    case (Suc n l)
      hence "l \<noteq> []" and [simp]: "length l = Suc n" by force+
      with append_butlast_last_id have [simp]:
          "butlast l @ [last l] = l" by simp
      with Suc have [simp]: "length (butlast l) = n" by simp
      note IH = Suc(1)[OF this[symmetric]]
      let ?l' = "iam_to_list (Array l)"

      show ?case
      proof (cases "last l")
        case None
          have "?f (Array l) =
              ?f (Array (butlast l @ [last l]))" by simp
          also have "... = ?g (iam_to_list (Array (butlast l)))"
              by (force simp: None iam_iteratei_append IH)
          also have "iam_to_list (Array (butlast l)) =
              iam_to_list (Array (butlast l @ [last l]))"
              using None by (simp add: iam_to_list_append)
          finally show "?f (Array l) = ?g ?l'" by simp
      next
        case (Some x)
          have "?f (Array l) =
              ?f (Array (butlast l @ [last l]))" by simp
          also have "... = ?g (iam_to_list
              (Array (butlast l @ [last l])))"
              by (force simp: IH iam_iteratei_append
                      iam_to_list_append Some)
          finally show ?thesis by simp
      qed
  qed
  thus ?thesis by (simp add: `a = Array l`)
qed

lemma pi_iam[icf_proper_iteratorI]:
  "proper_it (iam_iteratei a) (iam_iteratei a)"
unfolding proper_it_def by (force simp: iam_iteratei_altdef)

lemma pi'_iam[icf_proper_iteratorI]:
  "proper_it' iam_iteratei iam_iteratei"
  by (rule proper_it'I, rule pi_iam)

end