section \<open>Interpretation of syntax in semantic domains\<close>

theory Semantic_Domains imports Iteration
begin

text \<open>In this section, we employ our iteration principle
to obtain interpretation of syntax in semantic domains via valuations.
A bonus from our Horn-theoretic approach is the built-in
commutation of the interpretation with substitution versus valuation update,
a property known in the literature as the ``substitution lemma".\<close>

subsection \<open>Semantic domains and valuations\<close>

text\<open>
Semantic domains are for binding signatures
what algebras are for standard algebraic signatures. They fix carrier sets for each sort,
and interpret each operation symbol as an operation on these sets
%
\footnote{
To match the Isabelle type system, we model (as usual) the family of carrier sets as a
``well-sortedness" predicate taking sorts and semantic items from a given
(initially unsorted) universe into booleans,
and require the operations, considered on the unsorted universe, to preserve well-sortedness.
}
%
of corresponding arity, where:
%
\\- non-binding arguments
are treated as usual (first-order) arguments;
%
\\- binding arguments are treated as second-order (functional) arguments.
%
\footnote{
In other words, syntactic bindings are captured semantically as functional bindings.}
%

In particular, for the untyped and simply-typed $\lambda$-calculi,
the semantic domains become the well-known (set-theoretic) Henkin models.

We use terminology and notation according to our general methodology employed so far:
the inhabitants of semantic domains are referred to as ``semantic items";
we prefix the reference to semantic items with an ``s": sX, sA, etc.
This convention also applies to the operations on semantic domains: ``sAbs", ``sOp", etc.

We eventually show that the function spaces consisting of maps
from valuations to semantic items form models;
in other words,
these maps can be viewed as ``generalized items"; we use for them
term-like notations ``X", ``A", etc.
(as we did in the theory that dealt with iteration).
\<close>

subsubsection \<open>Definitions:\<close>

datatype ('varSort,'sTerm)sAbs = sAbs 'varSort "'sTerm \<Rightarrow> 'sTerm"

record ('index,'bindex,'varSort,'sort,'opSym,'sTerm)semDom =
  sWls :: "'sort \<Rightarrow> 'sTerm \<Rightarrow> bool"
  sDummy :: "'sort \<Rightarrow> 'sTerm"
  sOp :: "'opSym \<Rightarrow> ('index,'sTerm)input \<Rightarrow> ('bindex,('varSort,'sTerm)sAbs)input \<Rightarrow>'sTerm"

text\<open>The type of valuations:\<close>

type_synonym ('varSort,'var,'sTerm)val = "'varSort \<Rightarrow> 'var \<Rightarrow> 'sTerm"

(* *************************************************** *)
context FixSyn
begin

(* A new type variable, corresponding to 'sTerm, is introduced in the context by
the following definitions and facts. *)

fun sWlsAbs where
"sWlsAbs SEM (xs,s) (sAbs xs' sF) =
 (isInBar (xs,s) \<and> xs = xs' \<and>
  (\<forall> sX. if sWls SEM (asSort xs) sX
           then sWls SEM s (sF sX)
           else sF sX = sDummy SEM s))"

definition sWlsInp where
"sWlsInp SEM delta sinp \<equiv>
 wlsOpS delta \<and> sameDom (arOf delta) sinp \<and> liftAll2 (sWls SEM) (arOf delta) sinp"

definition sWlsBinp where
"sWlsBinp SEM delta sbinp \<equiv>
 wlsOpS delta \<and> sameDom (barOf delta) sbinp \<and> liftAll2 (sWlsAbs SEM) (barOf delta) sbinp"

definition sWlsNE where
"sWlsNE SEM \<equiv>
 \<forall> s. \<exists> sX. sWls SEM s sX"

definition sWlsDisj where
"sWlsDisj SEM \<equiv>
 \<forall> s s' sX. sWls SEM s sX \<and> sWls SEM s' sX \<longrightarrow> s = s'"

definition sOpPrSWls where
"sOpPrSWls SEM \<equiv>
 \<forall> delta sinp sbinp.
   sWlsInp SEM delta sinp \<and> sWlsBinp SEM delta sbinp
   \<longrightarrow> sWls SEM (stOf delta) (sOp SEM delta sinp sbinp)"

text\<open>The notion of a ``well-sorted" (better read as ``well-structured")
semantic domain:
%
\footnote{
As usual in Isabelle, we first define the ``raw" version,
and then ``fix" it with a well-structuredness predicate.
}
%
\<close>
definition wlsSEM where
"wlsSEM SEM \<equiv>
 sWlsNE SEM \<and> sWlsDisj SEM \<and> sOpPrSWls SEM"

text\<open>The preperties described  in the next 4 definitions turn out to be
consequences of the well-structuredness of the semantic domain:\<close>

definition sWlsAbsNE where
"sWlsAbsNE SEM \<equiv>
 \<forall> us s. isInBar (us,s) \<longrightarrow> (\<exists> sA. sWlsAbs SEM (us,s) sA)"

definition sWlsAbsDisj where
"sWlsAbsDisj SEM \<equiv>
 \<forall> us s us' s' sA.
   isInBar (us,s) \<and> isInBar (us',s') \<and> sWlsAbs SEM (us,s) sA \<and> sWlsAbs SEM (us',s') sA
   \<longrightarrow> us = us' \<and> s = s'"

text\<open>The notion of two valuations being equal everywhere but on a given variable:\<close>

definition eqBut where
"eqBut val val' xs x \<equiv>
 \<forall> ys y. (ys = xs \<and> y = x) \<or> val ys y = val' ys y"

definition updVal ::
"('varSort,'var,'sTerm)val \<Rightarrow>
 'var \<Rightarrow> 'sTerm \<Rightarrow> 'varSort \<Rightarrow>
 ('varSort,'var,'sTerm)val" ("_ '(_ := _')'__" 200)
where
"(val (x := sX)_xs) \<equiv>
 \<lambda> ys y. (if ys = xs \<and> y = x then sX else val ys y)"

definition swapVal ::
"'varSort \<Rightarrow> 'var \<Rightarrow> 'var \<Rightarrow> ('varSort,'var,'sTerm)val \<Rightarrow>
 ('varSort,'var,'sTerm)val"
where
"swapVal zs z1 z2 val \<equiv> \<lambda>xs x. val xs (x @xs[z1 \<and> z2]_zs) "

abbreviation swapVal_abbrev ("_ ^[_ \<and> _]'__" 200) where
"val ^[z1 \<and> z2]_zs \<equiv> swapVal zs z1 z2 val"

definition sWlsVal where
"sWlsVal SEM val \<equiv>
 \<forall> ys y. sWls SEM (asSort ys) (val ys y)"

(* The last argument is a dummy argument identifying the type 'var --
it may be regarded as a type argument:  *)

definition sWlsValNE ::
"('index,'bindex,'varSort,'sort,'opSym,'sTerm)semDom \<Rightarrow> 'var \<Rightarrow> bool"
where
"sWlsValNE SEM x \<equiv> \<exists> (val :: ('varSort,'var,'sTerm)val). sWlsVal SEM val"

subsubsection \<open>Basic facts\<close>

lemma sWlsNE_imp_sWlsAbsNE:
assumes "sWlsNE SEM"
shows "sWlsAbsNE SEM"
unfolding sWlsAbsNE_def proof clarify
  fix xs s
  obtain sY where "sWls SEM s sY"
  using assms unfolding sWlsNE_def by auto
  moreover assume "isInBar (xs,s)"
  ultimately
  have "sWlsAbs SEM (xs,s) (sAbs xs (\<lambda>sX. if sWls SEM (asSort xs) sX
                                           then sY
                                           else sDummy SEM s))" by simp
  thus "\<exists>sA. sWlsAbs SEM (xs,s) sA" by blast
qed

lemma sWlsDisj_imp_sWlsAbsDisj:
"sWlsDisj SEM \<Longrightarrow> sWlsNE SEM \<Longrightarrow> sWlsAbsDisj SEM"
by (simp add: sWlsAbsDisj_def sWlsNE_def sWlsDisj_def)
   (smt prod.inject sAbs.inject sWlsAbs.elims(2))

lemma sWlsNE_imp_sWlsValNE:
"sWlsNE SEM \<Longrightarrow> sWlsValNE SEM x"
by (auto simp: sWlsNE_def  sWlsValNE_def sWlsVal_def
 intro!: exI someI_ex[of "(\<lambda> sY. sWls SEM (asSort _) sY)"])

theorem updVal_simp[simp]:
"(val (x := sX)_xs) ys y = (if ys = xs \<and> y = x then sX else val ys y)"
unfolding updVal_def by simp

theorem updVal_over[simp]:
"((val (x := sX)_xs) (x := sX')_xs) = (val (x := sX')_xs)"
unfolding updVal_def by fastforce

theorem updVal_commute:
assumes "xs \<noteq> ys \<or> x \<noteq> y"
shows "((val (x := sX)_xs) (y := sY)_ys) = ((val (y := sY)_ys) (x := sX)_xs)"
using assms unfolding updVal_def by fastforce

theorem updVal_preserves_sWls[simp]:
assumes "sWls SEM (asSort xs) sX" and "sWlsVal SEM val"
shows "sWlsVal SEM (val (x := sX)_xs)"
using assms unfolding sWlsVal_def by auto

lemmas updVal_simps = updVal_simp updVal_over updVal_preserves_sWls

theorem swapVal_ident[simp]: "(val ^[x \<and> x]_xs) = val"
unfolding swapVal_def by auto

theorem swapVal_compose:
"((val ^[x \<and> y]_zs) ^[x' \<and> y']_zs') =
 ((val ^[x' @zs'[x \<and> y]_zs \<and> y' @zs'[x \<and> y]_zs]_zs') ^[x \<and> y]_zs)"
unfolding swapVal_def by (metis sw_compose)

theorem swapVal_commute:
"zs \<noteq> zs' \<or> {x,y} \<inter> {x',y'} = {} \<Longrightarrow>
 ((val ^[x \<and> y]_zs) ^[x' \<and> y']_zs') = ((val ^[x' \<and> y']_zs') ^[x \<and> y]_zs)"
using swapVal_compose[of zs' x' y' zs x y val] by(simp add: sw_def)

lemma swapVal_involutive[simp]: "((val ^[x \<and> y]_zs) ^[x \<and> y]_zs) = val"
unfolding swapVal_def by auto

lemma swapVal_sym: "(val ^[x \<and> y]_zs) = (val ^[y \<and> x]_zs)"
unfolding swapVal_def by(auto simp add: sw_sym)

lemma swapVal_preserves_sWls1:
assumes "sWlsVal SEM val"
shows "sWlsVal SEM (val ^[z1 \<and> z2]_zs)"
using assms unfolding sWlsVal_def swapVal_def by simp

theorem swapVal_preserves_sWls[simp]:
"sWlsVal SEM (val ^[z1 \<and> z2]_zs) = sWlsVal SEM val"
using swapVal_preserves_sWls1[of _ _ zs z1 z2] by fastforce

lemmas swapVal_simps = swapVal_ident swapVal_involutive swapVal_preserves_sWls

lemma updVal_swapVal:
"((val (x := sX)_xs) ^[y1 \<and> y2]_ys) =
 ((val ^[y1 \<and> y2]_ys) ((x @xs[y1 \<and> y2]_ys) := sX)_xs)"
unfolding swapVal_def by fastforce

lemma updVal_eqBut_eq:
assumes "eqBut val val' ys y"
shows "(val (y := sY)_ys) = (val' (y := sY)_ys)"
using assms unfolding eqBut_def by fastforce

lemma swapVal_preserves_eqBut:
assumes "eqBut val val' xs x"
shows "eqBut (val ^[z1 \<and> z2]_zs) (val' ^[z1 \<and> z2]_zs) xs (x @xs[z1 \<and> z2]_zs)"
using assms unfolding eqBut_def swapVal_def by force

subsection \<open>Interpretation maps\<close>

text\<open>An interpretation map, of syntax in a semantic domain,
is the usual one w.r.t. valuations.  Here we state its compostionality conditions
(including the ``substitution lemma"), and later we prove the existence of a map
satisfying these conditions.\<close>

subsubsection \<open>Definitions\<close>

text \<open>Below, prefix ``pr" means ``preserves".\<close>

definition prWls where
"prWls g SEM \<equiv> \<forall> s X val.
    wls s X \<and> sWlsVal SEM val
    \<longrightarrow> sWls SEM s (g X val)"

definition prWlsAbs where
"prWlsAbs gA SEM \<equiv> \<forall> us s A val.
    wlsAbs (us,s) A \<and> sWlsVal SEM val
    \<longrightarrow> sWlsAbs SEM (us,s) (gA A val)"

definition prWlsAll where
"prWlsAll g gA SEM \<equiv> prWls g SEM \<and> prWlsAbs gA SEM"

definition prVar where
"prVar g SEM \<equiv> \<forall> xs x val.
    sWlsVal SEM val \<longrightarrow> g (Var xs x) val = val xs x"

definition prAbs where
"prAbs g gA SEM \<equiv> \<forall> xs s x X val.
    isInBar (xs,s) \<and> wls s X \<and> sWlsVal SEM val
    \<longrightarrow>
    gA (Abs xs x X) val =
    sAbs xs (\<lambda>sX. if sWls SEM (asSort xs) sX then g X (val (x := sX)_xs)
                                             else sDummy SEM s)"

definition prOp where
"prOp g gA SEM \<equiv> \<forall> delta inp binp val.
    wlsInp delta inp \<and> wlsBinp delta binp \<and> sWlsVal SEM val
    \<longrightarrow>
    g (Op delta inp binp) val =
    sOp SEM delta (lift (\<lambda>X. g X val) inp)
                  (lift (\<lambda>A. gA A val) binp)"

definition prCons where
"prCons g gA SEM \<equiv> prVar g SEM \<and> prAbs g gA SEM \<and> prOp g gA SEM"

definition prFresh where
"prFresh g SEM \<equiv> \<forall> ys y s X val val'.
   wls s X \<and> fresh ys y X \<and>
   sWlsVal SEM val \<and> sWlsVal SEM val' \<and> eqBut val val' ys y
   \<longrightarrow> g X val = g X val'"

definition prFreshAbs where
"prFreshAbs gA SEM \<equiv> \<forall> ys y us s A val val'.
   wlsAbs (us,s) A \<and> freshAbs ys y A \<and>
   sWlsVal SEM val \<and> sWlsVal SEM val' \<and> eqBut val val' ys y
   \<longrightarrow> gA A val = gA A val'"

definition prFreshAll where
"prFreshAll g gA SEM \<equiv> prFresh g SEM \<and> prFreshAbs gA SEM"

definition prSwap where
"prSwap g SEM \<equiv> \<forall> zs z1 z2 s X val.
   wls s X \<and> sWlsVal SEM val
   \<longrightarrow>
   g (X #[z1 \<and> z2]_zs) val =
   g X (val ^[z1 \<and> z2]_zs)"

definition prSwapAbs where
"prSwapAbs gA SEM \<equiv> \<forall> zs z1 z2 us s A val.
   wlsAbs (us,s) A \<and> sWlsVal SEM val
   \<longrightarrow>
   gA (A $[z1 \<and> z2]_zs) val =
   gA A (val ^[z1 \<and> z2]_zs)"

definition prSwapAll where
"prSwapAll g gA SEM \<equiv> prSwap g SEM \<and> prSwapAbs gA SEM"

definition prSubst where
"prSubst g SEM \<equiv> \<forall> ys Y y s X val.
    wls (asSort ys) Y \<and> wls s X
    \<and> sWlsVal SEM val
    \<longrightarrow>
    g (X #[Y / y]_ys) val =
    g X (val (y := g Y val)_ys)"

definition prSubstAbs where
"prSubstAbs g gA SEM \<equiv> \<forall> ys Y y us s A val.
    wls (asSort ys) Y \<and> wlsAbs (us,s) A
    \<and> sWlsVal SEM val
    \<longrightarrow>
    gA (A $[Y / y]_ys) val =
    gA A (val (y := g Y val)_ys)"

definition prSubstAll where
"prSubstAll g gA SEM \<equiv> prSubst g SEM \<and> prSubstAbs g gA SEM"

definition compInt where
"compInt g gA SEM \<equiv> prWlsAll g gA SEM \<and> prCons g gA SEM \<and>
 prFreshAll g gA SEM \<and> prSwapAll g gA SEM \<and> prSubstAll g gA SEM"

subsubsection \<open>Extension of domain preservation to inputs\<close>

lemma prWls_wlsInp:
assumes "wlsInp delta inp" and "prWls g SEM" and "sWlsVal SEM val"
shows "sWlsInp SEM delta (lift (\<lambda> X. g X val) inp)"
using assms unfolding sWlsInp_def wlsInp_iff liftAll2_def lift_def prWls_def
by (auto simp add: option.case_eq_if sameDom_def)

lemma prWlsAbs_wlsBinp:
assumes "wlsBinp delta binp" and "prWlsAbs gA SEM" and "sWlsVal SEM val"
shows "sWlsBinp SEM delta (lift (\<lambda> A. gA A val) binp)"
using assms unfolding sWlsBinp_def wlsBinp_iff liftAll2_def lift_def prWlsAbs_def
by (auto simp add: option.case_eq_if sameDom_def)

end (* context FixSyn *)
(***************************************)

subsection \<open>The iterative model associated to a semantic domain\<close>

text\<open>
``asIMOD SEM" stands for ``SEM (regarded) as a model".
%
\footnote{
We use the word ``model" as introduced in the theory ``Models-and-Recursion".
}
%
The associated model is built essentially as follows:
%
\\- Its carrier sets consist of functions from valuations to semantic items.
%
\\- The construct operations (i.e., those corresponding to the syntactic constructs
indicated in the given binding signature) are lifted componentwise from those of the semantic domain
``SEM" (also taking into account the higher-order nature of of the semantic counterparts of abstractions).
%
\\- For a map from valuations to items (terms or abstractions), freshness of a variable ``x"
is defined as being oblivious what the argument valuation returns for ``x".
%
\\- Swapping is defined componentwise, by two iterations of the notion of swapping the
returned value of a function.
%
\\- Substitution of a semantic term ``Y" for a variable ``y" is a semantic term ``X"
is defined to map each valuation ``val" to the application of ``X" to
[``val" updated at ``y" with whatever ``Y" returns for ``val"].

Note that:
%
\\- The construct operations definitions are determined by the desired clauses of the standard
notion of interpreting syntax in a semantic domains.
%
\\- Substitution and freshness are defined having in mind the (again standard) facts of
the interpretation commuting with substitution versus valuation update and the interpretation
being oblivious to the valuation of fresh variables.
\<close>

subsubsection \<open>Definition and basic facts\<close>

text\<open>
The next two types of ``generalized items" are used to build models from semantic domains:
%
\footnote{
Recall that ``generalized items" inhabit models.
}
%
\<close>

type_synonym ('varSort,'var,'sTerm) gTerm = "('varSort,'var,'sTerm)val \<Rightarrow> 'sTerm"

type_synonym ('varSort,'var,'sTerm) gAbs = "('varSort,'var,'sTerm)val \<Rightarrow> ('varSort,'sTerm)sAbs"

(* *************************************************** *)
context FixSyn
begin

definition asIMOD ::
"('index,'bindex,'varSort,'sort,'opSym,'sTerm)semDom \<Rightarrow>
 ('index,'bindex,'varSort,'sort,'opSym,'var,
  ('varSort,'var,'sTerm)gTerm,
  ('varSort,'var,'sTerm)gAbs)model"
where
"asIMOD SEM \<equiv>
 \<lparr>igWls = \<lambda>s X. \<forall> val. (sWlsVal SEM val \<or> X val = undefined) \<and>
                      (sWlsVal SEM val \<longrightarrow> sWls SEM s (X val)),
  igWlsAbs = \<lambda>(xs,s) A. \<forall> val. (sWlsVal SEM val \<or> A val = undefined) \<and>
                              (sWlsVal SEM val \<longrightarrow> sWlsAbs SEM (xs,s) (A val)),
  igVar = \<lambda>ys y. \<lambda>val. if sWlsVal SEM val then val ys y else undefined,
  igAbs =
  \<lambda>xs x X. \<lambda>val. if sWlsVal SEM val
                   then sAbs xs (\<lambda>sX. if sWls SEM (asSort xs) sX
                                         then X (val (x := sX)_xs)
                                         else sDummy SEM (SOME s. sWls SEM s (X val)))
                   else undefined,
  igOp = \<lambda>delta inp binp. \<lambda>val.
          if sWlsVal SEM val then sOp SEM delta (lift (\<lambda>X. X val) inp)
                                                (lift (\<lambda>A. A val) binp)
                             else undefined,
  igFresh =
  \<lambda>ys y X. \<forall> val val'. sWlsVal SEM val \<and> sWlsVal SEM val' \<and> eqBut val val' ys y
                       \<longrightarrow> X val = X val',
  igFreshAbs =
  \<lambda>ys y A. \<forall> val val'. sWlsVal SEM val \<and> sWlsVal SEM val' \<and> eqBut val val' ys y
                       \<longrightarrow> A val = A val',
  igSwap = \<lambda>zs z1 z2 X. \<lambda>val. if sWlsVal SEM val then X (val ^[z1 \<and> z2]_zs)
                                                else undefined,
  igSwapAbs = \<lambda>zs z1 z2 A. \<lambda>val. if sWlsVal SEM val then A (val ^[z1 \<and> z2]_zs)
                                                   else undefined,
  igSubst = \<lambda>ys Y y X. \<lambda>val. if sWlsVal SEM val then X (val (y := Y val)_ys)
                                                else undefined,
  igSubstAbs = \<lambda>ys Y y A. \<lambda>val. if sWlsVal SEM val then A (val (y := Y val)_ys)
                                                   else undefined\<rparr>"

text\<open>Next we state, as usual, the direct definitions of the operators and relations
of associated model, freeing ourselves from
having to go through the ``asIMOD" definition each time we reason about them.\<close>

lemma asIMOD_igWls:
"igWls (asIMOD SEM) s X \<longleftrightarrow>
 (\<forall> val. (sWlsVal SEM val \<or> X val = undefined) \<and>
         (sWlsVal SEM val \<longrightarrow> sWls SEM s (X val)))"
unfolding asIMOD_def by simp

lemma asIMOD_igWlsAbs:
"igWlsAbs (asIMOD SEM) (us,s) A \<longleftrightarrow>
 (\<forall> val. (sWlsVal SEM val \<or> A val = undefined) \<and>
         (sWlsVal SEM val \<longrightarrow> sWlsAbs SEM (us,s) (A val)))"
unfolding asIMOD_def by simp

lemma asIMOD_igOp:
"igOp (asIMOD SEM) delta inp binp =
(\<lambda>val. if sWlsVal SEM val then sOp SEM delta (lift (\<lambda>X. X val) inp)
                                             (lift (\<lambda>A. A val) binp)
                          else undefined)"
unfolding asIMOD_def by simp

lemma asIMOD_igVar:
"igVar (asIMOD SEM) ys y = (\<lambda>val. if sWlsVal SEM val then val ys y else undefined)"
unfolding asIMOD_def by simp

lemma asIMOD_igAbs:
"igAbs (asIMOD SEM) xs x X =
(\<lambda>val. if sWlsVal SEM val then sAbs xs (\<lambda>sX. if sWls SEM (asSort xs) sX
                                                then X (val (x := sX)_xs)
                                                else sDummy SEM (SOME s. sWls SEM s (X val)))
                          else undefined)"
unfolding asIMOD_def by simp

lemma asIMOD_igAbs2:
fixes SEM :: "('index,'bindex,'varSort,'sort,'opSym,'sTerm)semDom"
assumes *: "sWlsDisj SEM" and **: "igWls (asIMOD SEM) s X"
shows "igAbs (asIMOD SEM) xs x X =
(\<lambda>val. if sWlsVal SEM val then sAbs xs (\<lambda>sX. if sWls SEM (asSort xs) sX
                                                then X (val (x := sX)_xs)
                                                else sDummy SEM s)
                          else undefined)"
proof-
  {fix val :: "('varSort,'var,'sTerm)val" assume val: "sWlsVal SEM val"
   hence Xval: "sWls SEM s (X val)"
   using ** unfolding asIMOD_igWls by simp
   hence "(SOME s. sWls SEM s (X val)) = s"
   using Xval * unfolding sWlsDisj_def by auto
  }
  thus ?thesis unfolding asIMOD_igAbs by fastforce
qed

lemma asIMOD_igFresh:
"igFresh (asIMOD SEM) ys y X =
(\<forall> val val'. sWlsVal SEM val \<and> sWlsVal SEM val' \<and> eqBut val val' ys y
             \<longrightarrow> X val = X val')"
unfolding asIMOD_def by simp

lemma asIMOD_igFreshAbs:
"igFreshAbs (asIMOD SEM) ys y A =
(\<forall> val val'. sWlsVal SEM val \<and> sWlsVal SEM val' \<and> eqBut val val' ys y
             \<longrightarrow> A val = A val')"
unfolding asIMOD_def by simp

lemma asIMOD_igSwap:
"igSwap (asIMOD SEM) zs z1 z2 X =
(\<lambda>val. if sWlsVal SEM val then X (val ^[z1 \<and> z2]_zs) else undefined)"
unfolding asIMOD_def by simp

lemma asIMOD_igSwapAbs:
"igSwapAbs (asIMOD SEM) zs z1 z2 A =
(\<lambda>val. if sWlsVal SEM val then A (val ^[z1 \<and> z2]_zs) else undefined)"
unfolding asIMOD_def by simp

lemma asIMOD_igSubst:
"igSubst (asIMOD SEM) ys Y y X =
(\<lambda>val. if sWlsVal SEM val then X (val (y := Y val)_ys) else undefined)"
unfolding asIMOD_def by simp

lemma asIMOD_igSubstAbs:
"igSubstAbs (asIMOD SEM) ys Y y A =
(\<lambda>val. if sWlsVal SEM val then A (val (y := Y val)_ys) else undefined)"
unfolding asIMOD_def by simp

lemma asIMOD_igWlsInp:
assumes "sWlsNE SEM"
shows
"igWlsInp (asIMOD SEM) delta inp \<longleftrightarrow>
 ((\<forall> val. liftAll (\<lambda>X. sWlsVal SEM val \<or> X val = undefined) inp) \<and>
  (\<forall> val. sWlsVal SEM val \<longrightarrow> sWlsInp SEM delta (lift (\<lambda>X. X val) inp)))"
using assms apply safe
 subgoal by (simp add: asIMOD_igWls liftAll_def liftAll2_def igWlsInp_def
  sameDom_def split: option.splits) (metis option.distinct(1) option.exhaust)
 subgoal by (simp add: igWlsInp_def asIMOD_igWls liftAll_def liftAll2_def
  lift_def sWlsInp_def sameDom_def split: option.splits)
 subgoal by (simp add:igWlsInp_def asIMOD_igWls liftAll_def liftAll2_def
  lift_def sWlsInp_def sameDom_def split: option.splits)
  (metis (no_types) option.distinct(1) sWlsNE_imp_sWlsValNE sWlsValNE_def) .

lemma asIMOD_igSwapInp:
"sWlsVal SEM val \<Longrightarrow>
 lift (\<lambda>X. X val) (igSwapInp (asIMOD SEM) zs z1 z2 inp) =
 lift (\<lambda>X. X (swapVal zs z1 z2 val)) inp"
by (auto simp: igSwapInp_def asIMOD_igSwap lift_def split: option.splits)

lemma asIMOD_igSubstInp:
"sWlsVal SEM val \<Longrightarrow>
 lift (\<lambda>X. X val) (igSubstInp (asIMOD SEM) ys Y y inp) =
 lift (\<lambda>X. X (val (y := Y val)_ys)) inp"
by (auto simp: igSubstInp_def asIMOD_igSubst lift_def split: option.splits)

lemma asIMOD_igWlsBinp:
assumes "sWlsNE SEM"
shows
"igWlsBinp (asIMOD SEM) delta binp =
 ((\<forall> val. liftAll (\<lambda>X. sWlsVal SEM val \<or> X val = undefined) binp) \<and>
  (\<forall> val. sWlsVal SEM val \<longrightarrow> sWlsBinp SEM delta (lift (\<lambda>X. X val) binp)))"
using assms apply safe
 subgoal by (simp add: asIMOD_igWlsAbs liftAll_def liftAll2_def igWlsBinp_def
  sameDom_def split: option.splits)
 (metis option.distinct(1) option.exhaust surj_pair)
 subgoal by (simp add: igWlsBinp_def asIMOD_igWlsAbs liftAll_def liftAll2_def
  lift_def sWlsBinp_def sameDom_def split: option.splits)
 subgoal by (simp add:igWlsBinp_def asIMOD_igWlsAbs liftAll_def liftAll2_def
  lift_def sWlsBinp_def sameDom_def split: option.splits)
  (metis (no_types) old.prod.exhaust option.distinct(1) option.exhaust
   sWlsNE_imp_sWlsValNE sWlsValNE_def) .

lemma asIMOD_igSwapBinp:
"sWlsVal SEM val \<Longrightarrow>
 lift (\<lambda>A. A val) (igSwapBinp (asIMOD SEM) zs z1 z2 binp) =
 lift (\<lambda>A. A (swapVal zs z1 z2 val)) binp"
by (auto simp: igSwapBinp_def asIMOD_igSwapAbs lift_def split: option.splits)

lemma asIMOD_igSubstBinp:
"sWlsVal SEM val \<Longrightarrow>
 lift (\<lambda>A. A val) (igSubstBinp (asIMOD SEM) ys Y y binp) =
 lift (\<lambda>A. A (val (y := Y val)_ys)) binp"
by (auto simp: igSubstBinp_def asIMOD_igSubstAbs lift_def split: option.splits)

subsubsection \<open>The associated model is well-structured\<close>

text\<open>That is to say: it is a fresh-swap-subst
and fresh-subst-swap model (hence of course also a fresh-swap and fresh-subst) model.\<close>

text\<open>Domain disjointness:\<close>

lemma asIMOD_igWlsDisj:
"sWlsNE SEM \<Longrightarrow> sWlsDisj SEM \<Longrightarrow> igWlsDisj (asIMOD SEM)"
using sWlsNE_imp_sWlsValNE
by (fastforce simp: igWlsDisj_def asIMOD_igWls sWlsValNE_def sWlsDisj_def)

lemma asIMOD_igWlsAbsDisj:
"sWlsNE SEM \<Longrightarrow> sWlsDisj SEM \<Longrightarrow> igWlsAbsDisj (asIMOD SEM)"
using sWlsNE_imp_sWlsValNE sWlsDisj_imp_sWlsAbsDisj
by (fastforce simp: igWlsAbsDisj_def asIMOD_igWlsAbs sWlsAbsDisj_def sWlsValNE_def)

lemma asIMOD_igWlsAllDisj:
"sWlsNE SEM \<Longrightarrow> sWlsDisj SEM \<Longrightarrow> igWlsAllDisj (asIMOD SEM)"
unfolding igWlsAllDisj_def using asIMOD_igWlsDisj asIMOD_igWlsAbsDisj by auto

text \<open>Only ``bound arit" abstraction domains are inhabited:\<close>

lemma asIMOD_igWlsAbsIsInBar:
"sWlsNE SEM \<Longrightarrow> igWlsAbsIsInBar (asIMOD SEM)"
using sWlsNE_imp_sWlsValNE
by (auto simp: sWlsValNE_def igWlsAbsIsInBar_def asIMOD_igWlsAbs
         split: option.splits elim: sWlsAbs.elims(2))

text\<open>Domain preservation by the operators\<close>

text\<open>The constructs preserve the domains:\<close>

lemma asIMOD_igVarIPresIGWls: "igVarIPresIGWls (asIMOD SEM)"
unfolding igVarIPresIGWls_def asIMOD_igWls asIMOD_igVar sWlsVal_def by simp

lemma asIMOD_igAbsIPresIGWls:
"sWlsDisj SEM \<Longrightarrow> igAbsIPresIGWls (asIMOD SEM)"
unfolding igAbsIPresIGWls_def asIMOD_igWlsAbs apply clarify
subgoal for _ _ _ _ val
unfolding asIMOD_igAbs2 by (cases "sWlsVal SEM val") (auto simp: asIMOD_igWls) .

lemma asIMOD_igOpIPresIGWls:
"sOpPrSWls SEM \<Longrightarrow> sWlsNE SEM \<Longrightarrow> igOpIPresIGWls (asIMOD SEM)"
using asIMOD_igWlsInp asIMOD_igWlsBinp
by (fastforce simp: igOpIPresIGWls_def asIMOD_igWls asIMOD_igOp sOpPrSWls_def)

lemma asIMOD_igConsIPresIGWls:
"wlsSEM SEM \<Longrightarrow> igConsIPresIGWls (asIMOD SEM)"
unfolding igConsIPresIGWls_def wlsSEM_def
using asIMOD_igVarIPresIGWls asIMOD_igAbsIPresIGWls asIMOD_igOpIPresIGWls by auto

text\<open>Swap preserves the domains:\<close>

lemma asIMOD_igSwapIPresIGWls: "igSwapIPresIGWls (asIMOD SEM)"
unfolding igSwapIPresIGWls_def asIMOD_igSwap asIMOD_igWls by auto

lemma asIMOD_igSwapAbsIPresIGWlsAbs: "igSwapAbsIPresIGWlsAbs (asIMOD SEM)"
unfolding igSwapAbsIPresIGWlsAbs_def asIMOD_igSwapAbs asIMOD_igWlsAbs by auto

lemma asIMOD_igSwapAllIPresIGWlsAll: "igSwapAllIPresIGWlsAll (asIMOD SEM)"
unfolding igSwapAllIPresIGWlsAll_def
using asIMOD_igSwapIPresIGWls asIMOD_igSwapAbsIPresIGWlsAbs by auto

text \<open>Subst preserves the domains:\<close>

lemma asIMOD_igSubstIPresIGWls: "igSubstIPresIGWls (asIMOD SEM)"
unfolding igSubstIPresIGWls_def asIMOD_igSubst asIMOD_igWls by simp

lemma asIMOD_igSubstAbsIPresIGWlsAbs: "igSubstAbsIPresIGWlsAbs (asIMOD SEM)"
unfolding igSubstAbsIPresIGWlsAbs_def asIMOD_igSubstAbs asIMOD_igWls asIMOD_igWlsAbs by simp

lemma asIMOD_igSubstAllIPresIGWlsAll: "igSubstAllIPresIGWlsAll (asIMOD SEM)"
unfolding igSubstAllIPresIGWlsAll_def
using asIMOD_igSubstIPresIGWls asIMOD_igSubstAbsIPresIGWlsAbs by auto

text \<open>The clauses for fresh hold:\<close>

lemma asIMOD_igFreshIGVar: "igFreshIGVar (asIMOD SEM)"
unfolding igFreshIGVar_def asIMOD_igFresh asIMOD_igVar eqBut_def by force

lemma asIMOD_igFreshIGAbs1:
"sWlsDisj SEM \<Longrightarrow> igFreshIGAbs1 (asIMOD SEM)"
by(fastforce simp: igFreshIGAbs1_def asIMOD_igFresh asIMOD_igFreshAbs asIMOD_igAbs2 updVal_eqBut_eq)

lemma asIMOD_igFreshIGAbs2:
"sWlsDisj SEM \<Longrightarrow> igFreshIGAbs2 (asIMOD SEM)"
by(fastforce simp: igFreshIGAbs2_def asIMOD_igFresh asIMOD_igFreshAbs asIMOD_igAbs2  updVal_preserves_eqBut)

lemma asIMOD_igFreshIGOp:
fixes SEM :: "('index,'bindex,'varSort,'sort,'opSym,'sTerm)semDom"
shows "igFreshIGOp (asIMOD SEM)"
unfolding igFreshIGOp_def proof clarify
  fix ys y delta and inp :: "('index, ('varSort,'var,'sTerm)gTerm)input"
  and binp :: "('bindex, ('varSort,'var,'sTerm)gAbs)input"
  assume inp_fresh: "igFreshInp (asIMOD SEM) ys y inp"
                    "igFreshBinp (asIMOD SEM) ys y binp"
  show "igFresh (asIMOD SEM) ys y (igOp (asIMOD SEM) delta inp binp)"
  unfolding asIMOD_igFresh asIMOD_igOp proof safe
    fix val val'
    let ?sinp = "lift (\<lambda>X. X val) inp" let ?sinp' = "lift (\<lambda>X. X val') inp"
    let ?sbinp = "lift (\<lambda>A. A val) binp" let ?sbinp' = "lift (\<lambda>A. A val') binp"
    assume wls: "sWlsVal SEM val" "sWlsVal SEM val'" and "eqBut val val' ys y"
    hence "?sinp = ?sinp' \<and> ?sbinp = ?sbinp'"
    using inp_fresh
    by (auto simp: lift_def igFreshInp_def igFreshBinp_def errMOD_def liftAll_def
    asIMOD_igFresh asIMOD_igFreshAbs split: option.splits)
    then show "(if sWlsVal SEM val then sOp SEM delta (lift (\<lambda>X. X val) inp) (lift (\<lambda>A. A val) binp)
           else undefined) =
          (if sWlsVal SEM val' then sOp SEM delta (lift (\<lambda>X. X val') inp) (lift (\<lambda>A. A val') binp)
           else undefined)" using wls by auto
  qed
qed

lemma asIMOD_igFreshCls:
assumes "sWlsDisj SEM"
shows "igFreshCls (asIMOD SEM)"
using assms unfolding igFreshCls_def
using asIMOD_igFreshIGVar asIMOD_igFreshIGAbs1 asIMOD_igFreshIGAbs2 asIMOD_igFreshIGOp by auto

text \<open>The clauses for swap hold:\<close>

lemma asIMOD_igSwapIGVar: "igSwapIGVar (asIMOD SEM)"
unfolding igSwapIGVar_def apply clarsimp apply(rule ext)
unfolding asIMOD_igSwap asIMOD_igVar apply clarsimp
unfolding swapVal_def by simp

lemma asIMOD_igSwapIGAbs: "igSwapIGAbs (asIMOD SEM)"
by (fastforce simp: igSwapIGAbs_def asIMOD_igSwap asIMOD_igSwapAbs asIMOD_igAbs updVal_swapVal)

lemma asIMOD_igSwapIGOp: "igSwapIGOp (asIMOD SEM)"
by (auto simp: igSwapIGOp_def asIMOD_igSwap asIMOD_igOp asIMOD_igSwapInp asIMOD_igSwapBinp)

lemma asIMOD_igSwapCls: "igSwapCls (asIMOD SEM)"
unfolding igSwapCls_def using asIMOD_igSwapIGVar asIMOD_igSwapIGAbs asIMOD_igSwapIGOp by auto

text\<open>The clauses for subst hold:\<close>

lemma asIMOD_igSubstIGVar1: "igSubstIGVar1 (asIMOD SEM)"
by (auto simp: igSubstIGVar1_def asIMOD_igSubst asIMOD_igVar asIMOD_igWls)

lemma asIMOD_igSubstIGVar2: "igSubstIGVar2 (asIMOD SEM)"
by (fastforce simp: igSubstIGVar2_def asIMOD_igSubst asIMOD_igVar asIMOD_igWls)

lemma asIMOD_igSubstIGAbs: "igSubstIGAbs (asIMOD SEM)"
unfolding igSubstIGAbs_def proof(clarify, rule ext)
  fix ys y Y xs x s X val
  assume Y: "igWls (asIMOD SEM) (asSort ys) Y"
  and X: "igWls (asIMOD SEM) s X" and x_diff_y: "xs \<noteq> ys \<or> x \<noteq> y"
  and x_fresh_Y: "igFresh (asIMOD SEM) xs x Y"
  show "igSubstAbs (asIMOD SEM) ys Y y (igAbs (asIMOD SEM) xs x X) val =
        igAbs (asIMOD SEM) xs x (igSubst (asIMOD SEM) ys Y y X) val"
  proof(cases "sWlsVal SEM val")
    case False
    thus ?thesis unfolding asIMOD_igSubst asIMOD_igSubstAbs asIMOD_igAbs by simp
  next
    case True
    hence Yval: "sWls SEM (asSort ys) (Y val)"
    using Y unfolding asIMOD_igWls by simp
    {fix sX assume sX: "sWls SEM (asSort xs) sX"
     let ?val_x = "val (x := sX)_xs"
     have "sWlsVal SEM ?val_x" using True sX by simp
     moreover have "eqBut ?val_x val xs x"
     unfolding eqBut_def updVal_def by simp
     ultimately have 1: "Y ?val_x = Y val"
     using True x_fresh_Y unfolding asIMOD_igFresh by simp
     let ?Left = "X ((val (y := Y val)_ys) (x := sX)_xs)"
     let ?Riight = "X (?val_x (y := Y ?val_x)_ys)"
     have "?Left = X (?val_x (y := Y val)_ys)"
     using x_diff_y by(auto simp add: updVal_commute)
     also have "\<dots> = ?Riight" using 1 by simp
     finally have "?Left = ?Riight" .
    }
    thus ?thesis using True Yval by(auto simp: asIMOD_igSubst asIMOD_igSubstAbs asIMOD_igAbs)
  qed
qed

lemma asIMOD_igSubstIGOp: "igSubstIGOp (asIMOD SEM)"
unfolding igSubstIGOp_def proof(clarify,rule ext)
  fix ys y Y delta inp binp val
  assume Y: "igWls (asIMOD SEM) (asSort ys) Y"
  and inp: "igWlsInp (asIMOD SEM) delta inp"
  and binp: "igWlsBinp (asIMOD SEM) delta binp"
  define inpsb binpsb where
  inpsb_def: "inpsb \<equiv> igSubstInp (asIMOD SEM) ys Y y inp"
             "binpsb \<equiv> igSubstBinp (asIMOD SEM) ys Y y binp"
  note inpsb_rev = inpsb_def[symmetric]
  let ?sinpsb = "lift (\<lambda>X. X (val (y := Y val)_ys)) inp"
  let ?sbinpsb = "lift (\<lambda>A. A (val (y := Y val)_ys)) binp"
  show "igSubst (asIMOD SEM) ys Y y (igOp (asIMOD SEM) delta inp binp) val =
        igOp (asIMOD SEM) delta (igSubstInp (asIMOD SEM) ys Y y inp)
                              (igSubstBinp (asIMOD SEM) ys Y y binp) val"
  unfolding inpsb_rev unfolding asIMOD_igSubst asIMOD_igOp unfolding inpsb_def
  apply(simp add: asIMOD_igSubstInp asIMOD_igSubstBinp)
  using Y unfolding asIMOD_def by auto
qed

lemma asIMOD_igSubstCls: "igSubstCls (asIMOD SEM)"
unfolding igSubstCls_def
using asIMOD_igSubstIGVar1 asIMOD_igSubstIGVar2 asIMOD_igSubstIGAbs asIMOD_igSubstIGOp by auto

text \<open>The fresh-swap-based congruence clause holds:\<close>

lemma updVal_swapVal_eqBut: "eqBut (val (x := sX)_xs) ((val (y := sX)_xs) ^[y \<and> x]_xs) xs y"
by (simp add: updVal_def swapVal_def eqBut_def sw_def)

lemma asIMOD_igAbsCongS: "sWlsDisj SEM \<Longrightarrow> igAbsCongS (asIMOD SEM)"
unfolding igAbsCongS_def asIMOD_igFresh asIMOD_igSwap asIMOD_igAbs2
apply safe apply (simp add: asIMOD_igAbs2)
by (rule ext) (metis (opaque_lifting) updVal_swapVal_eqBut swapVal_preserves_sWls updVal_preserves_sWls)

text \<open>The abstraction-renaming clause holds:\<close>

lemma asIMOD_igAbs3:
assumes "sWlsDisj SEM" and "igWls (asIMOD SEM) s X"
shows
"igAbs (asIMOD SEM) xs y (igSubst (asIMOD SEM) xs (igVar (asIMOD SEM) xs y) x X) =
 (\<lambda>val. if sWlsVal SEM val
            then sAbs xs (\<lambda>sX. if sWls SEM (asSort xs) sX
                                 then (igSubst (asIMOD SEM) xs (igVar (asIMOD SEM) xs y) x X) (val (y := sX)_xs)
                                 else sDummy SEM s)
            else undefined)"
using assms asIMOD_igVarIPresIGWls asIMOD_igSubstIPresIGWls
unfolding igVarIPresIGWls_def igSubstIPresIGWls_def
by (fastforce intro!: asIMOD_igAbs2)

lemma asIMOD_igAbsRen:
"sWlsDisj SEM \<Longrightarrow> igAbsRen (asIMOD SEM)"
unfolding igAbsRen_def asIMOD_igFresh asIMOD_igSwap apply safe
by (simp add: asIMOD_igAbs2 asIMOD_igAbs3)
   (auto intro!: ext simp: asIMOD_igAbs2 asIMOD_igAbs3 eqBut_def asIMOD_igSubst asIMOD_igVar)

text \<open>The associated model forms well-structured models of all 4 kinds:\<close>

lemma asIMOD_wlsFSw:
assumes "wlsSEM SEM"
shows "iwlsFSw (asIMOD SEM)"
using assms unfolding wlsSEM_def iwlsFSw_def
using assms asIMOD_igWlsAllDisj asIMOD_igWlsAbsIsInBar
asIMOD_igConsIPresIGWls asIMOD_igSwapAllIPresIGWlsAll
asIMOD_igFreshCls asIMOD_igSwapCls asIMOD_igAbsCongS
by auto

lemma asIMOD_wlsFSb:
assumes "wlsSEM SEM"
shows "iwlsFSb (asIMOD SEM)"
using assms unfolding wlsSEM_def iwlsFSb_def
using assms asIMOD_igWlsAllDisj asIMOD_igWlsAbsIsInBar
asIMOD_igConsIPresIGWls[of SEM] asIMOD_igSubstAllIPresIGWlsAll
asIMOD_igFreshCls  asIMOD_igSubstCls asIMOD_igAbsRen
by auto

lemma asIMOD_wlsFSwSb: "wlsSEM SEM \<Longrightarrow> iwlsFSwSb (asIMOD SEM)"
unfolding iwlsFSwSb_def
using asIMOD_wlsFSw asIMOD_igSubstAllIPresIGWlsAll asIMOD_igSubstCls by auto

lemma asIMOD_wlsFSbSw: "wlsSEM SEM \<Longrightarrow> iwlsFSbSw (asIMOD SEM)"
unfolding iwlsFSbSw_def
using asIMOD_wlsFSb asIMOD_igSwapAllIPresIGWlsAll asIMOD_igSwapCls by auto

subsection \<open>The semantic interpretation\<close>

text\<open>The well-definedness of the semantic interpretation, as well
as its associated substitution lemma and non-dependence of fresh variables,
are the end products of this theory.

Note that in order to establish these results either fresh-subst-swap or
fresh-swap-subst aligebras would do the job, and, moreover, if we did not care
about swapping, fresh-subst aligebras would do the job.  Therefore, our
exhaustive study of the model from previous section had a deigree of redundancy w.r.t. to our main
igoal -- we pursued it however in order to better illustrate the rich structure laying under
the apparent paucity of the notion of a semantic domain.  Next, we choose to employ
fresh-subst-swap aligebras to establish the required results. (Recall however that either aligebraic route
we take, the initial morphism turns out to be the same function.)\<close>

definition semInt where "semInt SEM \<equiv> iter (asIMOD SEM)"

definition semIntAbs where "semIntAbs SEM \<equiv> iterAbs (asIMOD SEM)"

lemma semInt_prWls:
"wlsSEM SEM \<Longrightarrow> prWls (semInt SEM) SEM"
unfolding prWls_def using semIntAll_termFSwSbImorph
unfolding termFSwSbImorph_def termFSwImorph_def ipresWlsAll_def ipresWls_def asIMOD_igWls by auto

lemma semIntAbs_prWlsAbs:
"wlsSEM SEM \<Longrightarrow> prWlsAbs (semIntAbs SEM) SEM"
unfolding prWlsAbs_def using semIntAll_termFSwSbImorph
unfolding termFSwSbImorph_def termFSwImorph_def ipresWlsAll_def ipresWlsAbs_def asIMOD_igWlsAbs by blast

lemma semIntAll_prWlsAll:
"wlsSEM SEM \<Longrightarrow> prWlsAll (semInt SEM) (semIntAbs SEM) SEM"
unfolding prWlsAll_def by(simp add: semInt_prWls semIntAbs_prWlsAbs)

lemma semInt_prVar:
"wlsSEM SEM \<Longrightarrow> prVar (semInt SEM) SEM"
using semIntAll_termFSwSbImorph
unfolding prVar_def termFSwSbImorph_def termFSwImorph_def ipresCons_def ipresVar_def asIMOD_igVar
by fastforce

lemma semIntAll_prAbs:
fixes SEM :: "('index,'bindex,'varSort,'sort,'opSym,'sTerm)semDom"
assumes "wlsSEM SEM"
shows "prAbs (semInt SEM) (semIntAbs SEM) SEM"
proof-
  {fix xs s x X and val :: "('varSort,'var,'sTerm)val"
   assume xs_s: "isInBar (xs,s)" and X: "wls s X"
   and val: "sWlsVal SEM val"
   let ?L = "semIntAbs SEM (Abs xs x X)"
   let ?R = "\<lambda> val. sAbs xs (\<lambda>sX. if sWls SEM (asSort xs) sX
                              then semInt SEM X (val (x := sX)_xs)
                              else sDummy SEM s)"
   have "?L = igAbs (asIMOD SEM) xs x (semInt SEM X)"
   using xs_s X assms semIntAll_termFSwSbImorph[of SEM]
   unfolding termFSwSbImorph_def termFSwImorph_def ipresCons_def ipresAbs_def by auto
   moreover
   {have "prWls (semInt SEM) SEM" using assms semInt_prWls by auto
    hence 1: "sWls SEM s (semInt SEM X val)"
    using val X unfolding prWls_def by simp
    hence "(SOME s. sWls SEM s (semInt SEM X val)) = s"
    using 1 assms unfolding wlsSEM_def sWlsDisj_def by auto
    hence "igAbs (asIMOD SEM) xs x (semInt SEM X) val = ?R val"
    unfolding asIMOD_igAbs using val by fastforce
   }
   ultimately have "?L val = ?R val" by simp
  }
  thus ?thesis unfolding prAbs_def by auto
qed

lemma semIntAll_prOp:
assumes "wlsSEM SEM"
shows "prOp (semInt SEM) (semIntAbs SEM) SEM"
using assms semIntAll_termFSwSbImorph
unfolding prOp_def termFSwSbImorph_def termFSwImorph_def ipresCons_def ipresOp_def
asIMOD_igOp lift_comp comp_def by fastforce

lemma semIntAll_prCons:
assumes "wlsSEM SEM"
shows "prCons (semInt SEM) (semIntAbs SEM) SEM"
using assms unfolding prCons_def by(simp add: semInt_prVar semIntAll_prAbs semIntAll_prOp)

lemma semInt_prFresh:
assumes "wlsSEM SEM"
shows "prFresh (semInt SEM) SEM"
using assms semIntAll_termFSwSbImorph
unfolding prFresh_def termFSwSbImorph_def termFSwImorph_def ipresFreshAll_def ipresFresh_def
asIMOD_igFresh by fastforce

lemma semIntAbs_prFreshAbs:
assumes "wlsSEM SEM"
shows "prFreshAbs (semIntAbs SEM) SEM"
using assms semIntAll_termFSwSbImorph
unfolding prFreshAbs_def termFSwSbImorph_def termFSwImorph_def ipresFreshAll_def ipresFreshAbs_def
asIMOD_igFreshAbs by fastforce

lemma semIntAll_prFreshAll:
assumes "wlsSEM SEM"
shows "prFreshAll (semInt SEM) (semIntAbs SEM) SEM"
using assms unfolding prFreshAll_def by(simp add: semInt_prFresh semIntAbs_prFreshAbs)

lemma semInt_prSwap:
assumes "wlsSEM SEM"
shows "prSwap (semInt SEM) SEM"
using assms semIntAll_termFSwSbImorph
unfolding prSwap_def termFSwSbImorph_def termFSwImorph_def ipresSwapAll_def ipresSwap_def
asIMOD_igSwap by fastforce

lemma semIntAbs_prSwapAbs:
assumes "wlsSEM SEM"
shows "prSwapAbs (semIntAbs SEM) SEM"
using assms semIntAll_termFSwSbImorph
unfolding prSwapAbs_def termFSwSbImorph_def termFSwImorph_def ipresSwapAll_def ipresSwapAbs_def
asIMOD_igSwapAbs by fastforce

lemma semIntAll_prSwapAll:
assumes "wlsSEM SEM"
shows "prSwapAll (semInt SEM) (semIntAbs SEM) SEM"
using assms unfolding prSwapAll_def by(simp add: semInt_prSwap semIntAbs_prSwapAbs)

lemma semInt_prSubst:
assumes "wlsSEM SEM"
shows "prSubst (semInt SEM) SEM"
using assms semIntAll_termFSwSbImorph
unfolding prSubst_def termFSwSbImorph_def termFSwImorph_def ipresSubstAll_def ipresSubst_def
asIMOD_igSubst by fastforce

lemma semIntAbs_prSubstAbs:
assumes "wlsSEM SEM"
shows "prSubstAbs (semInt SEM) (semIntAbs SEM) SEM"
using assms semIntAll_termFSwSbImorph
unfolding prSubstAbs_def termFSwSbImorph_def termFSwImorph_def ipresSubstAll_def ipresSubstAbs_def
asIMOD_igSubstAbs by fastforce

lemma semIntAll_prSubstAll:
assumes "wlsSEM SEM"
shows "prSubstAll (semInt SEM) (semIntAbs SEM) SEM"
using assms unfolding prSubstAll_def by(simp add: semInt_prSubst semIntAbs_prSubstAbs)

theorem semIntAll_compInt:
assumes "wlsSEM SEM"
shows "compInt (semInt SEM) (semIntAbs SEM) SEM"
using assms unfolding compInt_def
by(simp add: semIntAll_prWlsAll semIntAll_prCons
semIntAll_prFreshAll semIntAll_prSwapAll semIntAll_prSubstAll)

lemmas semDom_simps = updVal_simps swapVal_simps

end (* context FixSyn *)

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
paragraph \<open>Surjective\<close>
theory Functions_Surjective
  imports
    HOL_Syntax_Bundles_Lattices
begin

consts surjective_at :: "'a \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow> bool"

overloading
  surjective_at_pred \<equiv> "surjective_at :: ('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> bool"
begin
  definition "surjective_at_pred P f \<equiv> \<forall>y. P y \<longrightarrow> (\<exists>x. y = f x)"
end

lemma surjective_atI [intro]:
  assumes "\<And>y. P y \<Longrightarrow> \<exists>x. y = f x"
  shows "surjective_at P f"
  unfolding surjective_at_pred_def using assms by blast

lemma surjective_atE [elim]:
  assumes "surjective_at P f"
  and "P y"
  obtains x where "y = f x"
  using assms unfolding surjective_at_pred_def by blast

definition "surjective (f :: _ \<Rightarrow> 'a) \<equiv> surjective_at (\<top> :: 'a \<Rightarrow> bool) f"

lemma surjective_eq_surjective_at:
  "surjective (f :: _ \<Rightarrow> 'a) = surjective_at (\<top> :: 'a \<Rightarrow> bool) f"
  unfolding surjective_def ..

lemma surjectiveI [intro]:
  assumes "\<And>y. \<exists>x. y = f x"
  shows "surjective f"
  unfolding surjective_eq_surjective_at using assms by (intro surjective_atI)

lemma surjectiveE:
  assumes "surjective f"
  obtains x where "y = f x"
  using assms unfolding surjective_eq_surjective_at by (blast intro: top1I)

lemma surjective_at_if_surjective:
  fixes P :: "'a \<Rightarrow> bool" and f :: "_ \<Rightarrow> 'a"
  assumes "surjective f"
  shows "surjective_at P f"
  using assms by (intro surjective_atI) (blast elim: surjectiveE)

end


(*  Title:      HOL/Algebra/IntRing.thy
    Author:     Stephan Hohe, TU Muenchen
    Author:     Clemens Ballarin
*)

theory IntRing
imports "~~/src/HOL/Number_Theory/Primes" QuotRing Lattice Int
begin

section \<open>The Ring of Integers\<close>

subsection \<open>Some properties of @{typ int}\<close>

lemma dvds_eq_abseq:
  fixes k :: int
  shows "l dvd k \<and> k dvd l \<longleftrightarrow> \<bar>l\<bar> = \<bar>k\<bar>"
apply rule
 apply (simp add: zdvd_antisym_abs)
apply (simp add: dvd_if_abs_eq)
done

subsection \<open>\<open>\<Z>\<close>: The Set of Integers as Algebraic Structure\<close>

abbreviation int_ring :: "int ring" ("\<Z>")
  where "int_ring \<equiv> \<lparr>carrier = UNIV, mult = op *, one = 1, zero = 0, add = op +\<rparr>"

lemma int_Zcarr [intro!, simp]: "k \<in> carrier \<Z>"
  by simp

lemma int_is_cring: "cring \<Z>"
apply (rule cringI)
  apply (rule abelian_groupI, simp_all)
  defer 1
  apply (rule comm_monoidI, simp_all)
 apply (rule distrib_right)
apply (fast intro: left_minus)
done

(*
lemma int_is_domain:
  "domain \<Z>"
apply (intro domain.intro domain_axioms.intro)
  apply (rule int_is_cring)
 apply (unfold int_ring_def, simp+)
done
*)

subsection \<open>Interpretations\<close>

text \<open>Since definitions of derived operations are global, their
  interpretation needs to be done as early as possible --- that is,
  with as few assumptions as possible.\<close>

interpretation int: monoid \<Z>
  rewrites "carrier \<Z> = UNIV"
    and "mult \<Z> x y = x * y"
    and "one \<Z> = 1"
    and "pow \<Z> x n = x^n"
proof -
  \<comment> "Specification"
  show "monoid \<Z>" by standard auto
  then interpret int: monoid \<Z> .

  \<comment> "Carrier"
  show "carrier \<Z> = UNIV" by simp

  \<comment> "Operations"
  { fix x y show "mult \<Z> x y = x * y" by simp }
  show "one \<Z> = 1" by simp
  show "pow \<Z> x n = x^n" by (induct n) simp_all
qed

interpretation int: comm_monoid \<Z>
  rewrites "finprod \<Z> f A = prod f A"
proof -
  \<comment> "Specification"
  show "comm_monoid \<Z>" by standard auto
  then interpret int: comm_monoid \<Z> .

  \<comment> "Operations"
  { fix x y have "mult \<Z> x y = x * y" by simp }
  note mult = this
  have one: "one \<Z> = 1" by simp
  show "finprod \<Z> f A = prod f A"
    by (induct A rule: infinite_finite_induct, auto)
qed

interpretation int: abelian_monoid \<Z>
  rewrites int_carrier_eq: "carrier \<Z> = UNIV"
    and int_zero_eq: "zero \<Z> = 0"
    and int_add_eq: "add \<Z> x y = x + y"
    and int_finsum_eq: "finsum \<Z> f A = sum f A"
proof -
  \<comment> "Specification"
  show "abelian_monoid \<Z>" by standard auto
  then interpret int: abelian_monoid \<Z> .

  \<comment> "Carrier"
  show "carrier \<Z> = UNIV" by simp

  \<comment> "Operations"
  { fix x y show "add \<Z> x y = x + y" by simp }
  note add = this
  show zero: "zero \<Z> = 0"
    by simp
  show "finsum \<Z> f A = sum f A"
    by (induct A rule: infinite_finite_induct, auto)
qed

interpretation int: abelian_group \<Z>
  (* The equations from the interpretation of abelian_monoid need to be repeated.
     Since the morphisms through which the abelian structures are interpreted are
     not the identity, the equations of these interpretations are not inherited. *)
  (* FIXME *)
  rewrites "carrier \<Z> = UNIV"
    and "zero \<Z> = 0"
    and "add \<Z> x y = x + y"
    and "finsum \<Z> f A = sum f A"
    and int_a_inv_eq: "a_inv \<Z> x = - x"
    and int_a_minus_eq: "a_minus \<Z> x y = x - y"
proof -
  \<comment> "Specification"
  show "abelian_group \<Z>"
  proof (rule abelian_groupI)
    fix x
    assume "x \<in> carrier \<Z>"
    then show "\<exists>y \<in> carrier \<Z>. y \<oplus>\<^bsub>\<Z>\<^esub> x = \<zero>\<^bsub>\<Z>\<^esub>"
      by simp arith
  qed auto
  then interpret int: abelian_group \<Z> .
  \<comment> "Operations"
  { fix x y have "add \<Z> x y = x + y" by simp }
  note add = this
  have zero: "zero \<Z> = 0" by simp
  {
    fix x
    have "add \<Z> (- x) x = zero \<Z>"
      by (simp add: add zero)
    then show "a_inv \<Z> x = - x"
      by (simp add: int.minus_equality)
  }
  note a_inv = this
  show "a_minus \<Z> x y = x - y"
    by (simp add: int.minus_eq add a_inv)
qed (simp add: int_carrier_eq int_zero_eq int_add_eq int_finsum_eq)+

interpretation int: "domain" \<Z>
  rewrites "carrier \<Z> = UNIV"
    and "zero \<Z> = 0"
    and "add \<Z> x y = x + y"
    and "finsum \<Z> f A = sum f A"
    and "a_inv \<Z> x = - x"
    and "a_minus \<Z> x y = x - y"
proof -
  show "domain \<Z>"
    by unfold_locales (auto simp: distrib_right distrib_left)
qed (simp add: int_carrier_eq int_zero_eq int_add_eq int_finsum_eq int_a_inv_eq int_a_minus_eq)+

text \<open>Removal of occurrences of @{term UNIV} in interpretation result
  --- experimental.\<close>

lemma UNIV:
  "x \<in> UNIV \<longleftrightarrow> True"
  "A \<subseteq> UNIV \<longleftrightarrow> True"
  "(\<forall>x \<in> UNIV. P x) \<longleftrightarrow> (\<forall>x. P x)"
  "(EX x : UNIV. P x) \<longleftrightarrow> (EX x. P x)"
  "(True \<longrightarrow> Q) \<longleftrightarrow> Q"
  "(True \<Longrightarrow> PROP R) \<equiv> PROP R"
  by simp_all

interpretation int (* FIXME [unfolded UNIV] *) :
  partial_order "\<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr>"
  rewrites "carrier \<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr> = UNIV"
    and "le \<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr> x y = (x \<le> y)"
    and "lless \<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr> x y = (x < y)"
proof -
  show "partial_order \<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr>"
    by standard simp_all
  show "carrier \<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr> = UNIV"
    by simp
  show "le \<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr> x y = (x \<le> y)"
    by simp
  show "lless \<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr> x y = (x < y)"
    by (simp add: lless_def) auto
qed

interpretation int (* FIXME [unfolded UNIV] *) :
  lattice "\<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr>"
  rewrites "join \<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr> x y = max x y"
    and "meet \<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr> x y = min x y"
proof -
  let ?Z = "\<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr>"
  show "lattice ?Z"
    apply unfold_locales
    apply (simp add: least_def Upper_def)
    apply arith
    apply (simp add: greatest_def Lower_def)
    apply arith
    done
  then interpret int: lattice "?Z" .
  show "join ?Z x y = max x y"
    apply (rule int.joinI)
    apply (simp_all add: least_def Upper_def)
    apply arith
    done
  show "meet ?Z x y = min x y"
    apply (rule int.meetI)
    apply (simp_all add: greatest_def Lower_def)
    apply arith
    done
qed

interpretation int (* [unfolded UNIV] *) :
  total_order "\<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr>"
  by standard clarsimp

subsection \<open>Generated Ideals of \<open>\<Z>\<close>\<close>

lemma int_Idl: "Idl\<^bsub>\<Z>\<^esub> {a} = {x * a | x. True}"
  apply (subst int.cgenideal_eq_genideal[symmetric]) apply simp
  apply (simp add: cgenideal_def)
  done

lemma multiples_principalideal: "principalideal {x * a | x. True } \<Z>"
  by (metis UNIV_I int.cgenideal_eq_genideal int.cgenideal_is_principalideal int_Idl)

lemma prime_primeideal:
  assumes prime: "prime p"
  shows "primeideal (Idl\<^bsub>\<Z>\<^esub> {p}) \<Z>"
apply (rule primeidealI)
   apply (rule int.genideal_ideal, simp)
  apply (rule int_is_cring)
 apply (simp add: int.cgenideal_eq_genideal[symmetric] cgenideal_def)
 apply clarsimp defer 1
 apply (simp add: int.cgenideal_eq_genideal[symmetric] cgenideal_def)
 apply (elim exE)
proof -
  fix a b x
  assume "a * b = x * p"
  then have "p dvd a * b" by simp
  then have "p dvd a \<or> p dvd b"
    by (metis prime prime_dvd_mult_eq_int)
  then show "(\<exists>x. a = x * p) \<or> (\<exists>x. b = x * p)"
    by (metis dvd_def mult.commute)
next
  assume "UNIV = {uu. EX x. uu = x * p}"
  then obtain x where "1 = x * p" by best
  then have "\<bar>p * x\<bar> = 1" by (simp add: mult.commute)
  then show False using prime
    by (auto dest!: abs_zmult_eq_1 simp: prime_def)
qed

subsection \<open>Ideals and Divisibility\<close>

lemma int_Idl_subset_ideal: "Idl\<^bsub>\<Z>\<^esub> {k} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {l} = (k \<in> Idl\<^bsub>\<Z>\<^esub> {l})"
  by (rule int.Idl_subset_ideal') simp_all

lemma Idl_subset_eq_dvd: "Idl\<^bsub>\<Z>\<^esub> {k} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {l} \<longleftrightarrow> l dvd k"
  apply (subst int_Idl_subset_ideal, subst int_Idl, simp)
  apply (rule, clarify)
  apply (simp add: dvd_def)
  apply (simp add: dvd_def ac_simps)
  done

lemma dvds_eq_Idl: "l dvd k \<and> k dvd l \<longleftrightarrow> Idl\<^bsub>\<Z>\<^esub> {k} = Idl\<^bsub>\<Z>\<^esub> {l}"
proof -
  have a: "l dvd k \<longleftrightarrow> (Idl\<^bsub>\<Z>\<^esub> {k} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {l})"
    by (rule Idl_subset_eq_dvd[symmetric])
  have b: "k dvd l \<longleftrightarrow> (Idl\<^bsub>\<Z>\<^esub> {l} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {k})"
    by (rule Idl_subset_eq_dvd[symmetric])

  have "l dvd k \<and> k dvd l \<longleftrightarrow> Idl\<^bsub>\<Z>\<^esub> {k} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {l} \<and> Idl\<^bsub>\<Z>\<^esub> {l} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {k}"
    by (subst a, subst b, simp)
  also have "Idl\<^bsub>\<Z>\<^esub> {k} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {l} \<and> Idl\<^bsub>\<Z>\<^esub> {l} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {k} \<longleftrightarrow> Idl\<^bsub>\<Z>\<^esub> {k} = Idl\<^bsub>\<Z>\<^esub> {l}"
    by blast
  finally show ?thesis .
qed

lemma Idl_eq_abs: "Idl\<^bsub>\<Z>\<^esub> {k} = Idl\<^bsub>\<Z>\<^esub> {l} \<longleftrightarrow> \<bar>l\<bar> = \<bar>k\<bar>"
  apply (subst dvds_eq_abseq[symmetric])
  apply (rule dvds_eq_Idl[symmetric])
  done

subsection \<open>Ideals and the Modulus\<close>

definition ZMod :: "int \<Rightarrow> int \<Rightarrow> int set"
  where "ZMod k r = (Idl\<^bsub>\<Z>\<^esub> {k}) +>\<^bsub>\<Z>\<^esub> r"

lemmas ZMod_defs =
  ZMod_def genideal_def

lemma rcos_zfact:
  assumes kIl: "k \<in> ZMod l r"
  shows "\<exists>x. k = x * l + r"
proof -
  from kIl[unfolded ZMod_def] have "\<exists>xl\<in>Idl\<^bsub>\<Z>\<^esub> {l}. k = xl + r"
    by (simp add: a_r_coset_defs)
  then obtain xl where xl: "xl \<in> Idl\<^bsub>\<Z>\<^esub> {l}" and k: "k = xl + r"
    by auto
  from xl obtain x where "xl = x * l"
    by (auto simp: int_Idl)
  with k have "k = x * l + r"
    by simp
  then show "\<exists>x. k = x * l + r" ..
qed

lemma ZMod_imp_zmod:
  assumes zmods: "ZMod m a = ZMod m b"
  shows "a mod m = b mod m"
proof -
  interpret ideal "Idl\<^bsub>\<Z>\<^esub> {m}" \<Z>
    by (rule int.genideal_ideal) fast
  from zmods have "b \<in> ZMod m a"
    unfolding ZMod_def by (simp add: a_repr_independenceD)
  then have "\<exists>x. b = x * m + a"
    by (rule rcos_zfact)
  then obtain x where "b = x * m + a"
    by fast
  then have "b mod m = (x * m + a) mod m"
    by simp
  also have "\<dots> = ((x * m) mod m) + (a mod m)"
    by (simp add: mod_add_eq)
  also have "\<dots> = a mod m"
    by simp
  finally have "b mod m = a mod m" .
  then show "a mod m = b mod m" ..
qed

lemma ZMod_mod: "ZMod m a = ZMod m (a mod m)"
proof -
  interpret ideal "Idl\<^bsub>\<Z>\<^esub> {m}" \<Z>
    by (rule int.genideal_ideal) fast
  show ?thesis
    unfolding ZMod_def
    apply (rule a_repr_independence'[symmetric])
    apply (simp add: int_Idl a_r_coset_defs)
  proof -
    have "a = m * (a div m) + (a mod m)"
      by (simp add: mult_div_mod_eq [symmetric])
    then have "a = (a div m) * m + (a mod m)"
      by simp
    then show "\<exists>h. (\<exists>x. h = x * m) \<and> a = h + a mod m"
      by fast
  qed simp
qed

lemma zmod_imp_ZMod:
  assumes modeq: "a mod m = b mod m"
  shows "ZMod m a = ZMod m b"
proof -
  have "ZMod m a = ZMod m (a mod m)"
    by (rule ZMod_mod)
  also have "\<dots> = ZMod m (b mod m)"
    by (simp add: modeq[symmetric])
  also have "\<dots> = ZMod m b"
    by (rule ZMod_mod[symmetric])
  finally show ?thesis .
qed

corollary ZMod_eq_mod: "ZMod m a = ZMod m b \<longleftrightarrow> a mod m = b mod m"
  apply (rule iffI)
  apply (erule ZMod_imp_zmod)
  apply (erule zmod_imp_ZMod)
  done

subsection \<open>Factorization\<close>

definition ZFact :: "int \<Rightarrow> int set ring"
  where "ZFact k = \<Z> Quot (Idl\<^bsub>\<Z>\<^esub> {k})"

lemmas ZFact_defs = ZFact_def FactRing_def

lemma ZFact_is_cring: "cring (ZFact k)"
  apply (unfold ZFact_def)
  apply (rule ideal.quotient_is_cring)
   apply (intro ring.genideal_ideal)
    apply (simp add: cring.axioms[OF int_is_cring] ring.intro)
   apply simp
  apply (rule int_is_cring)
  done

lemma ZFact_zero: "carrier (ZFact 0) = (\<Union>a. {{a}})"
  apply (insert int.genideal_zero)
  apply (simp add: ZFact_defs A_RCOSETS_defs r_coset_def)
  done

lemma ZFact_one: "carrier (ZFact 1) = {UNIV}"
  apply (simp only: ZFact_defs A_RCOSETS_defs r_coset_def ring_record_simps)
  apply (subst int.genideal_one)
  apply (rule, rule, clarsimp)
   apply (rule, rule, clarsimp)
   apply (rule, clarsimp, arith)
  apply (rule, clarsimp)
  apply (rule exI[of _ "0"], clarsimp)
  done

lemma ZFact_prime_is_domain:
  assumes pprime: "prime p"
  shows "domain (ZFact p)"
  apply (unfold ZFact_def)
  apply (rule primeideal.quotient_is_domain)
  apply (rule prime_primeideal[OF pprime])
  done

end


(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
theory Square_Free_Factorization_Int
imports
  Square_Free_Int_To_Square_Free_GFp
  Suitable_Prime
  Code_Abort_Gcd
  Gcd_Finite_Field_Impl
begin

definition yun_wrel :: "int poly \<Rightarrow> rat \<Rightarrow> rat poly \<Rightarrow> bool" where
  "yun_wrel F c f = (map_poly rat_of_int F = smult c f)"

definition yun_rel :: "int poly \<Rightarrow> rat \<Rightarrow> rat poly \<Rightarrow> bool" where
  "yun_rel F c f = (yun_wrel F c f
    \<and> content F = 1 \<and> lead_coeff F > 0 \<and> monic f)"

definition yun_erel :: "int poly \<Rightarrow> rat poly \<Rightarrow> bool" where
  "yun_erel F f = (\<exists> c. yun_rel F c f)"

lemma yun_wrelD: assumes "yun_wrel F c f"
  shows "map_poly rat_of_int F = smult c f"
  using assms unfolding yun_wrel_def by auto

lemma yun_relD: assumes "yun_rel F c f"
  shows "yun_wrel F c f" "map_poly rat_of_int F = smult c f"
    "degree F = degree f" "F \<noteq> 0" "lead_coeff F > 0" "monic f"
    "f = 1 \<longleftrightarrow> F = 1" "content F = 1"
proof -
  note * = assms[unfolded yun_rel_def yun_wrel_def, simplified]
  then have "degree (map_poly rat_of_int F) = degree f" by auto
  then show deg: "degree F = degree f" by simp
  show "F \<noteq> 0" "lead_coeff F > 0" "monic f" "content F = 1"
    "map_poly rat_of_int F = smult c f"
    "yun_wrel F c f" using * by (auto simp: yun_wrel_def)
  {
    assume "f = 1"
    with deg have "degree F = 0" by auto
    from degree0_coeffs[OF this] obtain c where F: "F = [:c:]" and c: "c = lead_coeff F" by auto
    from c * have c0: "c > 0" by auto
    hence cF: "content F = c" unfolding F content_def by auto
    with * have "c = 1" by auto
    with F have "F = 1" by simp
  }
  moreover
  {
    assume "F = 1"
    with deg have "degree f = 0" by auto
    with \<open>monic f\<close> have "f = 1"
      using monic_degree_0 by blast
  }
  ultimately show "(f = 1) \<longleftrightarrow> (F = 1)" by auto
qed

lemma yun_erel_1_eq: assumes "yun_erel F f"
  shows "(F = 1) \<longleftrightarrow> (f = 1)"
proof -
  from assms[unfolded yun_erel_def] obtain c where "yun_rel F c f" by auto
  from yun_relD[OF this] show ?thesis by simp
qed

lemma yun_rel_1[simp]: "yun_rel 1 1 1"
  by (auto simp: yun_rel_def yun_wrel_def content_def)

lemma yun_erel_1[simp]: "yun_erel 1 1" unfolding yun_erel_def using yun_rel_1 by blast

lemma yun_rel_mult: "yun_rel F c f \<Longrightarrow> yun_rel G d g \<Longrightarrow> yun_rel (F * G) (c * d) (f * g)"
  unfolding yun_rel_def yun_wrel_def content_mult lead_coeff_mult
  by (auto simp: monic_mult hom_distribs)

lemma yun_erel_mult: "yun_erel F f \<Longrightarrow> yun_erel G g \<Longrightarrow> yun_erel (F * G) (f * g)"
  unfolding yun_erel_def using yun_rel_mult[of F _ f G _ g] by blast

lemma yun_rel_pow: assumes "yun_rel F c f"
  shows "yun_rel (F^n) (c^n) (f^n)"
  by (induct n, insert assms yun_rel_mult, auto)

lemma yun_erel_pow: "yun_erel F f \<Longrightarrow> yun_erel (F^n) (f^n)"
  using yun_rel_pow unfolding yun_erel_def by blast

lemma yun_wrel_pderiv: assumes "yun_wrel F c f"
  shows "yun_wrel (pderiv F) c (pderiv f)"
  by (unfold yun_wrel_def, simp add: yun_wrelD[OF assms] pderiv_smult hom_distribs)

lemma yun_wrel_minus: assumes "yun_wrel F c f" "yun_wrel G c g"
  shows "yun_wrel (F - G) c (f - g)"
  using assms unfolding yun_wrel_def by (auto simp: smult_diff_right hom_distribs)

lemma gcd_smult_left: assumes "c \<noteq> 0"
  shows "gcd (smult c f) g = gcd f (g :: 'b :: {field_gcd} poly)"
proof -
  from assms have "normalize c = 1"
    by (meson dvd_field_iff is_unit_normalize)
  then show ?thesis
    by (metis (no_types) Polynomial.normalize_smult gcd.commute gcd.left_commute gcd_left_idem gcd_self smult_1_left)
qed

lemma gcd_smult_right: "c \<noteq> 0 \<Longrightarrow> gcd f (smult c g) = gcd f (g :: 'b :: {field_gcd} poly)"
  using gcd_smult_left[of c g f] by (simp add: gcd.commute)

lemma yun_wrel_div: assumes f: "yun_wrel F c f" and g: "yun_wrel G d g"
  and dvd: "G dvd F" "g dvd f"
  and G0: "G \<noteq> 0"
  shows "yun_wrel (F div G) (c / d) (f div g)"
proof -
  let ?r = "rat_of_int"
  let ?rp = "map_poly ?r"
  from dvd obtain H h where fgh: "F = G * H" "f = g * h" unfolding dvd_def by auto
  from G0 yun_wrelD[OF g] have g0: "g \<noteq> 0" and d0: "d \<noteq> 0" by auto
  from arg_cong[OF fgh(1), of "\<lambda> x. x div G"] have H: "H = F div G" using G0 by simp
  from arg_cong[OF fgh(1), of ?rp] have "?rp F = ?rp G * ?rp H" by (auto simp: hom_distribs)
  from arg_cong[OF this, of "\<lambda> x. x div ?rp G"] G0 have id: "?rp H = ?rp F div ?rp G" by auto
  have "?rp (F div G) = ?rp F div ?rp G" unfolding H[symmetric] id by simp
  also have "\<dots> = smult c f div smult d g" using f g unfolding yun_wrel_def by auto
  also have "\<dots> = smult (c / d) (f div g)" unfolding div_smult_right[OF d0] div_smult_left
    by (simp add: field_simps)
  finally show ?thesis unfolding yun_wrel_def by simp
qed

lemma yun_rel_div: assumes f: "yun_rel F c f" and g: "yun_rel G d g"
  and dvd: "G dvd F" "g dvd f"
shows "yun_rel (F div G) (c / d) (f div g)"
proof -
  note ff = yun_relD[OF f]
  note gg = yun_relD[OF g]
  show ?thesis unfolding yun_rel_def
  proof (intro conjI)
    from yun_wrel_div[OF ff(1) gg(1) dvd gg(4)]
    show "yun_wrel (F div G) (c / d) (f div g)" by auto
    from dvd have fg: "f = g * (f div g)" by auto
    from arg_cong[OF fg, of monic] ff(6) gg(6)
    show "monic (f div g)" using monic_factor by blast
    from dvd have FG: "F = G * (F div G)" by auto
    from arg_cong[OF FG, of content, unfolded content_mult] ff(8) gg(8)
    show "content (F div G) = 1" by simp
    from arg_cong[OF FG, of lead_coeff, unfolded lead_coeff_mult] ff(5) gg(5)
    show "lead_coeff (F div G) > 0" by (simp add: zero_less_mult_iff)
  qed
qed

lemma yun_wrel_gcd: assumes "yun_wrel F c' f" "yun_wrel G c g" and c: "c' \<noteq> 0" "c \<noteq> 0"
  and d: "d = rat_of_int (lead_coeff (gcd F G))" "d \<noteq> 0"
  shows "yun_wrel (gcd F G) d (gcd f g)"
proof -
  let ?r = "rat_of_int"
  let ?rp = "map_poly ?r"
  have "smult d (gcd f g) = smult d (gcd (smult c' f) (smult c g))"
    by (simp add: c gcd_smult_left gcd_smult_right)
  also have "\<dots> = smult d (gcd (?rp F) (?rp G))" using assms(1-2)[unfolded yun_wrel_def] by simp
  also have "\<dots> = smult (d * inverse d) (?rp (gcd F G))"
    unfolding gcd_rat_to_gcd_int d by simp
  also have "d * inverse d = 1" using d by auto
  finally show ?thesis  unfolding yun_wrel_def by simp
qed

lemma yun_rel_gcd: assumes f: "yun_rel F c f" and g: "yun_wrel G c' g"  and c': "c' \<noteq> 0"
  and d: "d = rat_of_int (lead_coeff (gcd F G))"
shows "yun_rel (gcd F G) d (gcd f g)"
  unfolding yun_rel_def
proof (intro conjI)
  note ff = yun_relD[OF f]
  from ff have c0: "c \<noteq> 0" by auto
  from ff d have d0: "d \<noteq> 0" by auto
  from yun_wrel_gcd[OF ff(1) g c0 c' d d0]
  show "yun_wrel (gcd F G) d (gcd f g)" by auto
  from ff have "gcd f g \<noteq> 0" by auto
  thus "monic (gcd f g)" by (simp add: poly_gcd_monic)
  obtain H where H: "gcd F G = H" by auto
  obtain lc where lc: "coeff H (degree H) = lc" by auto
  from ff have "gcd F G \<noteq> 0" by auto
  hence "H \<noteq> 0" "lc \<noteq> 0" unfolding H[symmetric] lc[symmetric] by auto
  thus "0 < lead_coeff (gcd F G)" unfolding
    arg_cong[OF normalize_gcd[of F G], of lead_coeff, symmetric]
    unfolding normalize_poly_eq_map_poly H
    by (auto, subst Polynomial.coeff_map_poly, auto,
    subst Polynomial.degree_map_poly, auto simp: sgn_if)
  have "H dvd F" unfolding H[symmetric] by auto
  then obtain K where F: "F = H * K" unfolding dvd_def by auto
  from arg_cong[OF this, of content, unfolded content_mult ff(8)]
    content_ge_0_int[of H] have "content H = 1"
    by (auto simp add: zmult_eq_1_iff)
  thus "content (gcd F G) = 1" unfolding H .
qed

lemma yun_factorization_main_int: assumes f: "f = p div gcd p (pderiv p)"
    and "g = pderiv p div gcd p (pderiv p)" "monic p"
    and "yun_gcd.yun_factorization_main gcd f g i hs = res"
    and "yun_gcd.yun_factorization_main gcd F G i Hs = Res"
    and "yun_rel F c f" "yun_wrel G c g" "list_all2 (rel_prod yun_erel (=)) Hs hs"
  shows "list_all2 (rel_prod yun_erel (=)) Res res"
proof -
  let ?P = "\<lambda> f g. \<forall> i hs res F G Hs Res c.
    yun_gcd.yun_factorization_main gcd f g i hs = res
    \<longrightarrow> yun_gcd.yun_factorization_main gcd F G i Hs = Res
    \<longrightarrow> yun_rel F c f \<longrightarrow> yun_wrel G c g \<longrightarrow> list_all2 (rel_prod yun_erel (=)) Hs hs
    \<longrightarrow> list_all2 (rel_prod yun_erel (=)) Res res"
  note simps = yun_gcd.yun_factorization_main.simps
  note rel = yun_relD
  let ?rel = "\<lambda> F f. map_poly rat_of_int F = smult (rat_of_int (lead_coeff F)) f"
  show ?thesis
  proof (induct rule: yun_factorization_induct[of ?P, rule_format, OF _ _ assms])
    case (1 f g i hs res F G Hs Res c)
    from rel[OF 1(4)] 1(1) have "f = 1" "F = 1" by auto
    from 1(2-3)[unfolded simps[of _ 1] this] have "res = hs" "Res = Hs" by auto
    with 1(6) show ?case by simp
  next
    case (2 f g i hs res F G Hs Res c)
    define d where "d = g - pderiv f"
    define a where "a = gcd f d"
    define D where "D = G - pderiv F"
    define A where "A = gcd F D"
    note f = 2(5)
    note g = 2(6)
    note hs = 2(7)
    note f1 = 2(1)
    from f1 rel[OF f] have *: "(f = 1) = False" "(F = 1) = False" and c: "c \<noteq> 0" by auto
    note res = 2(3)[unfolded simps[of _ f] * if_False Let_def, folded d_def a_def]
    note Res = 2(4)[unfolded simps[of _ F] * if_False Let_def, folded D_def A_def]
    note IH = 2(2)[folded d_def a_def, OF res Res]
    obtain c' where c': "c' = rat_of_int (lead_coeff (gcd F D))" by auto
    show ?case
    proof (rule IH)
      from yun_wrel_minus[OF g yun_wrel_pderiv[OF rel(1)[OF f]]]
      have d: "yun_wrel D c d" unfolding D_def d_def .
      have a: "yun_rel A c' a" unfolding A_def a_def
        by (rule yun_rel_gcd[OF f d c c'])
      hence "yun_erel A a" unfolding yun_erel_def by auto
      thus "list_all2 (rel_prod yun_erel (=)) ((A, i) # Hs) ((a, i) # hs)"
        using hs by auto
      have A0: "A \<noteq> 0" by (rule rel(4)[OF a])
      have "A dvd D" "a dvd d" unfolding A_def a_def by auto
      from yun_wrel_div[OF d rel(1)[OF a] this A0]
      show "yun_wrel (D div A) (c / c') (d div a)" .
      have "A dvd F" "a dvd f" unfolding A_def a_def by auto
      from yun_rel_div[OF f a this]
      show "yun_rel (F div A) (c / c') (f div a)" .
    qed
  qed
qed

lemma yun_monic_factorization_int_yun_rel: assumes
    res: "yun_gcd.yun_monic_factorization gcd f = res"
    and Res: "yun_gcd.yun_monic_factorization gcd F = Res"
    and f: "yun_rel F c f"
  shows "list_all2 (rel_prod yun_erel (=)) Res res"
proof -
  note ff = yun_relD[OF f]
  let ?g = "gcd f (pderiv f)"
  let ?yf = "yun_gcd.yun_factorization_main gcd (f div ?g) (pderiv f div ?g) 0 []"
  let ?G = "gcd F (pderiv F)"
  let ?yF = "yun_gcd.yun_factorization_main gcd (F div ?G) (pderiv F div ?G) 0 []"
  obtain r R where r: "?yf = r" and R: "?yF = R" by blast
  from res[unfolded yun_gcd.yun_monic_factorization_def Let_def r]
  have res: "res = [(a, i)\<leftarrow>r . a \<noteq> 1]" by simp
  from Res[unfolded yun_gcd.yun_monic_factorization_def Let_def R]
  have Res: "Res = [(A, i)\<leftarrow>R . A \<noteq> 1]" by simp
  from yun_wrel_pderiv[OF ff(1)] have f': "yun_wrel (pderiv F) c (pderiv f)" .
  from ff have c: "c \<noteq> 0" by auto
  from yun_rel_gcd[OF f f' c refl] obtain d where g: "yun_rel ?G d ?g" ..
  from yun_rel_div[OF f g] have 1: "yun_rel (F div ?G) (c / d) (f div ?g)" by auto
  from yun_wrel_div[OF f' yun_relD(1)[OF g] _ _ yun_relD(4)[OF g]]
  have 2: "yun_wrel (pderiv F div ?G) (c / d) (pderiv f div ?g)" by auto
  from yun_factorization_main_int[OF refl refl ff(6) r R 1 2]
  have "list_all2 (rel_prod yun_erel (=)) R r" by simp
  thus ?thesis unfolding res Res
    by (induct R r rule: list_all2_induct, auto dest: yun_erel_1_eq)
qed

lemma yun_rel_same_right: assumes "yun_rel f c G" "yun_rel g d G"
  shows "f = g"
proof -
  note f = yun_relD[OF assms(1)]
  note g = yun_relD[OF assms(2)]
  let ?r = "rat_of_int"
  let ?rp = "map_poly ?r"
  from g have d: "d \<noteq> 0" by auto
  obtain a b where quot: "quotient_of (c / d) = (a,b)" by force
  from quotient_of_nonzero[of "c/d", unfolded quot] have b: "b \<noteq> 0" by simp
  note f(2)
  also have "smult c G = smult (c / d) (smult d G)" using d by (auto simp: field_simps)
  also have "smult d G = ?rp g" using g(2) by simp
  also have cd: "c / d = (?r a / ?r b)" using quotient_of_div[OF quot] .
  finally have fg: "?rp f = smult (?r a / ?r b) (?rp g)" by simp
  from f have "c \<noteq> 0" by auto
  with cd d have a: "a \<noteq> 0" by auto
  from arg_cong[OF fg, of "\<lambda> x. smult (?r b) x"]
  have "smult (?r b) (?rp f) = smult (?r a) (?rp g)" using b by auto
  hence "?rp (smult b f) = ?rp (smult a g)" by (auto simp: hom_distribs)
  then have fg: "[:b:] * f = [:a:] * g" by auto
  from arg_cong[OF this, of content, unfolded content_mult f(8) g(8)]
  have "content [: b :] = content [: a :]" by simp
  hence abs: "abs a = abs b" unfolding content_def using b a by auto
  from arg_cong[OF fg, of "\<lambda> x. lead_coeff x > 0", unfolded lead_coeff_mult] f(5) g(5) a b
  have "(a > 0) = (b > 0)" by (simp add: zero_less_mult_iff)
  with a b abs have "a = b" by auto
  with arg_cong[OF fg, of "\<lambda> x. x div [:b:]"] b show ?thesis
    by (metis nonzero_mult_div_cancel_left pCons_eq_0_iff)
qed

definition square_free_factorization_int_main :: "int poly \<Rightarrow> (int poly \<times> nat) list" where
  "square_free_factorization_int_main f = (case square_free_heuristic f of None \<Rightarrow>
    yun_gcd.yun_monic_factorization gcd f | Some p \<Rightarrow> [(f,0)])"

lemma square_free_factorization_int_main: assumes res: "square_free_factorization_int_main f = fs"
  and ct: "content f = 1" and lc: "lead_coeff f > 0"
  and deg: "degree f \<noteq> 0"
shows "square_free_factorization f (1,fs) \<and> (\<forall> fi i. (fi, i) \<in> set fs \<longrightarrow> content fi = 1 \<and> lead_coeff fi > 0) \<and>
  distinct (map snd fs)"
proof (cases "square_free_heuristic f")
  case None
  from lc have f0: "f \<noteq> 0" by auto
  from res None have fs: "yun_gcd.yun_monic_factorization gcd f = fs"
    unfolding square_free_factorization_int_main_def by auto
  let ?r = "rat_of_int"
  let ?rp = "map_poly ?r"
  define G where "G = smult (inverse (lead_coeff (?rp f))) (?rp f)"
  have "?rp f \<noteq> 0" using f0 by auto
  hence mon: "monic G" unfolding G_def coeff_smult by simp
  obtain Fs where Fs: "yun_gcd.yun_monic_factorization gcd G = Fs" by blast
  from lc have lg: "lead_coeff (?rp f) \<noteq> 0" by auto
  let ?c = "lead_coeff (?rp f)"
  define c where "c = ?c"
  have rp: "?rp f = smult c G" unfolding G_def c_def by (simp add: field_simps)
  have in_rel: "yun_rel f c G" unfolding yun_rel_def yun_wrel_def
    using rp mon lc ct by auto
  from yun_monic_factorization_int_yun_rel[OF Fs fs in_rel]
  have out_rel: "list_all2 (rel_prod yun_erel (=)) fs Fs" by auto
  from yun_monic_factorization[OF Fs mon]
  have "square_free_factorization G (1, Fs)" and dist: "distinct (map snd Fs)" by auto
  note sff = square_free_factorizationD[OF this(1)]
  from out_rel have "map snd fs = map snd Fs" by (induct fs Fs rule: list_all2_induct, auto)
  with dist have dist': "distinct (map snd fs)" by auto
  have main: "square_free_factorization f (1, fs) \<and> (\<forall> fi i. (fi, i) \<in> set fs \<longrightarrow> content fi = 1 \<and> lead_coeff fi > 0)"
    unfolding square_free_factorization_def split
  proof (intro conjI allI impI)
    from ct have "f \<noteq> 0" by auto
    thus "f = 0 \<Longrightarrow> 1 = 0" "f = 0 \<Longrightarrow> fs = []" by auto
    from dist' show "distinct fs" by (simp add: distinct_map)
    {
      fix a i
      assume a: "(a,i) \<in> set fs"
      with out_rel obtain bj where "bj \<in> set Fs" and "rel_prod yun_erel (=) (a,i) bj"
        unfolding list_all2_conv_all_nth set_conv_nth by fastforce
      then obtain b where b: "(b,i) \<in> set Fs" and ab: "yun_erel a b" by (cases bj, auto simp: rel_prod.simps)
      from sff(2)[OF b] have b': "square_free b" "degree b \<noteq> 0" by auto
      from ab obtain c where rel: "yun_rel a c b" unfolding yun_erel_def by auto
      note aa = yun_relD[OF this]
      from aa have c0: "c \<noteq> 0" by auto
      from b' aa(3) show "degree a > 0" by simp
      from square_free_smult[OF c0 b'(1), folded aa(2)]
      show "square_free a" unfolding square_free_def by (force simp: dvd_def hom_distribs)
      show cnt: "content a = 1" and lc: "lead_coeff a > 0" using aa by auto
      fix A I
      assume A: "(A,I) \<in> set fs" and diff: "(a,i) \<noteq> (A,I)"
      from a[unfolded set_conv_nth] obtain k where k: "fs ! k = (a,i)" "k < length fs" by auto
      from A[unfolded set_conv_nth] obtain K where K: "fs ! K = (A,I)" "K < length fs" by auto
      from diff k K have kK: "k \<noteq> K" by auto
      from dist'[unfolded distinct_conv_nth length_map, rule_format, OF k(2) K(2) kK]
      have iI: "i \<noteq> I" using k K by simp
      from A out_rel obtain Bj where "Bj \<in> set Fs" and "rel_prod yun_erel (=) (A,I) Bj"
        unfolding list_all2_conv_all_nth set_conv_nth by fastforce
      then obtain B where B: "(B,I) \<in> set Fs" and AB: "yun_erel A B" by (cases Bj, auto simp: rel_prod.simps)
      then obtain C where Rel: "yun_rel A C B" unfolding yun_erel_def by auto
      note AA = yun_relD[OF this]
      from iI have "(b,i) \<noteq> (B,I)" by auto
      from sff(3)[OF b B this] have cop: "coprime b B" by simp
      from AA have C: "C \<noteq> 0" by auto
      from yun_rel_gcd[OF rel AA(1) C refl] obtain c where "yun_rel (gcd a A) c (gcd b B)" by auto
      note rel = yun_relD[OF this]
      from rel(2) cop have "?rp (gcd a A) = [: c :]" by simp
      from arg_cong[OF this, of degree] have "degree (gcd a A) = 0" by simp
      from degree0_coeffs[OF this] obtain c where gcd: "gcd a A = [: c :]" by auto
      from rel(8) rel(5) show "Rings.coprime a A"
        by (auto intro!: gcd_eq_1_imp_coprime simp add: gcd)
    }
    let ?prod = "\<lambda> fs. (\<Prod>(a, i)\<in>set fs. a ^ Suc i)"
    let ?pr = "\<lambda> fs. (\<Prod>(a, i)\<leftarrow>fs. a ^ Suc i)"
    define pr where "pr = ?prod fs"
    from \<open>distinct fs\<close> have pfs: "?prod fs = ?pr fs" by (rule prod.distinct_set_conv_list)
    from \<open>distinct Fs\<close> have pFs: "?prod Fs = ?pr Fs" by (rule prod.distinct_set_conv_list)
    from out_rel have "yun_erel (?prod fs) (?prod Fs)" unfolding pfs pFs
    proof (induct fs Fs rule: list_all2_induct)
      case (Cons ai fs Ai Fs)
      obtain a i where ai: "ai = (a,i)" by force
      from Cons(1) ai obtain A where Ai: "Ai = (A,i)"
        and rel: "yun_erel a A" by (cases Ai, auto simp: rel_prod.simps)
      show ?case unfolding ai Ai using yun_erel_mult[OF yun_erel_pow[OF rel, of "Suc i"] Cons(3)]
        by auto
    qed simp
    also have "?prod Fs = G" using sff(1) by simp
    finally obtain d where rel: "yun_rel pr d G" unfolding yun_erel_def pr_def by auto
    with in_rel have "f = pr" by (rule yun_rel_same_right)
    thus "f = smult 1 (?prod fs)" unfolding pr_def by simp
  qed
  from main dist' show ?thesis by auto
next
  case (Some p)
  from res[unfolded square_free_factorization_int_main_def Some] have fs: "fs = [(f,0)]" by auto
  from lc have f0: "f \<noteq> 0" by auto
  from square_free_heuristic[OF Some] poly_mod_prime.separable_impl(1)[of p f] square_free_mod_imp_square_free[of p f] deg
  show ?thesis unfolding fs
    by (auto simp: ct lc square_free_factorization_def f0 poly_mod_prime_def)
qed

definition square_free_factorization_int' :: "int poly \<Rightarrow> int \<times> (int poly \<times> nat)list" where
  "square_free_factorization_int' f = (if degree f = 0
    then (lead_coeff f,[]) else (let \<comment> \<open>content factorization\<close>
      c = content f;
      d = (sgn (lead_coeff f) * c);
      g = sdiv_poly f d
      \<comment> \<open>and \<open>square_free\<close> factorization\<close>
    in (d, square_free_factorization_int_main g)))"

lemma square_free_factorization_int': assumes res: "square_free_factorization_int' f = (d, fs)"
  shows "square_free_factorization f (d,fs)"
    "(fi, i) \<in> set fs \<Longrightarrow> content fi = 1 \<and> lead_coeff fi > 0"
    "distinct (map snd fs)"
proof -
  note res = res[unfolded square_free_factorization_int'_def Let_def]
  have "square_free_factorization f (d,fs)
    \<and> ((fi, i) \<in> set fs \<longrightarrow> content fi = 1 \<and> lead_coeff fi > 0)
    \<and> distinct (map snd fs)"
  proof (cases "degree f = 0")
    case True
    from degree0_coeffs[OF True] obtain c where f: "f = [: c :]" by auto
    thus ?thesis using res by (simp add: square_free_factorization_def)
  next
    case False
    let ?s = "sgn (lead_coeff f)"
    have s: "?s \<in> {-1,1}" using False unfolding sgn_if by auto
    define g where "g = smult ?s f"
    let ?d = "?s * content f"
    have "content g = content ([:?s:] * f)" unfolding g_def by simp
    also have "\<dots> = content [:?s:] * content f" unfolding content_mult by simp
    also have "content [:?s:] = 1" using s by (auto simp: content_def)
    finally have cg: "content g = content f" by simp
    from False res
    have d: "d = ?d" and fs: "fs = square_free_factorization_int_main (sdiv_poly f ?d)" by auto
    let ?g = "primitive_part g"
    define ng where "ng = primitive_part g"
    note fs
    also have "sdiv_poly f ?d = sdiv_poly g (content g)" unfolding cg unfolding g_def
      by (rule poly_eqI, unfold coeff_sdiv_poly coeff_smult, insert s, auto simp: div_minus_right)
    finally have fs: "square_free_factorization_int_main ng = fs"
      unfolding primitive_part_alt_def ng_def by simp
    have "lead_coeff f \<noteq> 0" using False by auto
    hence lg: "lead_coeff g > 0" unfolding g_def lead_coeff_smult
      by (meson linorder_neqE_linordered_idom sgn_greater sgn_less zero_less_mult_iff)
    hence g0: "g \<noteq> 0" by auto
    from g0 have "content g \<noteq> 0" by simp
    from arg_cong[OF content_times_primitive_part[of g], of lead_coeff, unfolded lead_coeff_smult]
      lg content_ge_0_int[of g] have lg': "lead_coeff ng > 0" unfolding ng_def
      by (metis \<open>content g \<noteq> 0\<close> dual_order.antisym dual_order.strict_implies_order zero_less_mult_iff)
    from content_primitive_part[OF g0] have c_ng: "content ng = 1" unfolding ng_def .
    have "degree ng = degree f" using \<open>content [:sgn (lead_coeff f):] = 1\<close> g_def ng_def
      by (auto simp add: sgn_eq_0_iff)
    with False have "degree ng \<noteq> 0" by auto
    note main = square_free_factorization_int_main[OF fs c_ng lg' this]
    show ?thesis
    proof (intro conjI impI)
      {
        assume "(fi, i) \<in> set fs"
        with main show "content fi = 1" "0 < lead_coeff fi" by auto
      }
      have d0: "d \<noteq> 0" using \<open>content [:?s:] = 1\<close> d by (auto simp:sgn_eq_0_iff)
      have "smult d ng = smult ?s (smult (content g) (primitive_part g))"
        unfolding ng_def d cg by simp
      also have "smult (content g) (primitive_part g) = g" using content_times_primitive_part .
      also have "smult ?s g = f" unfolding g_def using s by auto
      finally have id: "smult d ng = f" .
      from main have "square_free_factorization ng (1, fs)" by auto
      from square_free_factorization_smult[OF d0 this]
      show "square_free_factorization f (d,fs)" unfolding id by simp
      show "distinct (map snd fs)" using main by auto
    qed
  qed
  thus  "square_free_factorization f (d,fs)"
    "(fi, i) \<in> set fs \<Longrightarrow> content fi = 1 \<and> lead_coeff fi > 0" "distinct (map snd fs)" by auto
qed

definition x_split :: "'a :: semiring_0 poly \<Rightarrow> nat \<times> 'a poly" where
  "x_split f = (let fs = coeffs f; zs = takeWhile ((=) 0) fs
     in case zs of [] \<Rightarrow> (0,f) | _ \<Rightarrow> (length zs, poly_of_list (dropWhile ((=) 0) fs)))"

lemma x_split: assumes "x_split f = (n, g)"
  shows "f = monom 1 n * g" "n \<noteq> 0 \<or> f \<noteq> 0 \<Longrightarrow> \<not> monom 1 1 dvd g"
proof -
  define zs where "zs = takeWhile ((=) 0) (coeffs f)"
  note res = assms[unfolded zs_def[symmetric] x_split_def Let_def]
  have "f = monom 1 n * g \<and> ((n \<noteq> 0 \<or> f \<noteq> 0) \<longrightarrow> \<not> (monom 1 1 dvd g))" (is "_ \<and> (_ \<longrightarrow> \<not> (?x dvd _))")
  proof (cases "f = 0")
    case True
    with res have "n = 0" "g = 0" unfolding zs_def by auto
    thus ?thesis using True by auto
  next
    case False note f = this
    show ?thesis
    proof (cases "zs = []")
      case True
      hence choice: "coeff f 0 \<noteq> 0" using f unfolding zs_def coeff_f_0_code poly_compare_0_code
        by (cases "coeffs f", auto)
      have dvd: "?x dvd h \<longleftrightarrow> coeff h 0 = 0" for h by (simp add: monom_1_dvd_iff')
      from True choice res f show ?thesis unfolding dvd by auto
    next
      case False
      define ys where "ys = dropWhile ((=) 0) (coeffs f)"
      have dvd: "?x dvd h \<longleftrightarrow> coeff h 0 = 0" for h by (simp add: monom_1_dvd_iff')
      from res False have n: "n = length zs" and g: "g = poly_of_list ys" unfolding ys_def
        by (cases zs, auto)+
      obtain xx where xx: "coeffs f = xx" by auto
      have "coeffs f = zs @ ys" unfolding zs_def ys_def by auto
      also have "zs = replicate n 0" unfolding zs_def n xx by (induct xx, auto)
      finally have ff: "coeffs f = replicate n 0 @ ys" by auto
      from f have "lead_coeff f \<noteq> 0" by auto
      then have nz: "coeffs f \<noteq> []" "last (coeffs f) \<noteq> 0"
        by (simp_all add: last_coeffs_eq_coeff_degree)
      have ys: "ys \<noteq> []" using nz[unfolded ff] by auto
      with ys_def have hd: "hd ys \<noteq> 0" by (metis (full_types) hd_dropWhile)
      hence "coeff (poly_of_list ys) 0 \<noteq> 0" unfolding poly_of_list_def coeff_Poly using ys by (cases ys, auto)
      moreover have "coeffs (Poly ys) = ys"
        by (simp add: ys_def strip_while_dropWhile_commute)
      then have "coeffs (monom_mult n (Poly ys)) = replicate n 0 @ ys"
        by (simp add: coeffs_eq_iff monom_mult_def [symmetric] ff ys monom_mult_code)
      ultimately show ?thesis unfolding dvd g
        by (auto simp add: coeffs_eq_iff monom_mult_def [symmetric] ff)
    qed
  qed
  thus "f = monom 1 n * g" "n \<noteq> 0 \<or> f \<noteq> 0 \<Longrightarrow> \<not> monom 1 1 dvd g" by auto
qed

definition square_free_factorization_int :: "int poly \<Rightarrow> int \<times> (int poly \<times> nat)list" where
  "square_free_factorization_int f = (case x_split f of (n,g) \<comment> \<open>extract \<open>x^n\<close>\<close>
    \<Rightarrow> case square_free_factorization_int' g of (d,fs)
    \<Rightarrow> if n = 0 then (d,fs) else (d, (monom 1 1, n - 1) # fs))"

lemma square_free_factorization_int: assumes res: "square_free_factorization_int f = (d, fs)"
  shows "square_free_factorization f (d,fs)"
    "(fi, i) \<in> set fs \<Longrightarrow> primitive fi \<and> lead_coeff fi > 0"
proof -
  obtain n g where xs: "x_split f = (n,g)" by force
  obtain c hs where sf: "square_free_factorization_int' g = (c,hs)" by force
  from res[unfolded square_free_factorization_int_def xs sf split]
  have d: "d = c" and fs: "fs = (if n = 0 then hs else (monom 1 1, n - 1) # hs)" by (cases n, auto)
  note sff = square_free_factorization_int'(1-2)[OF sf]
  note xs = x_split[OF xs]
  let ?x = "monom 1 1 :: int poly"
  have x: "primitive ?x \<and> lead_coeff ?x = 1 \<and> degree ?x = 1"
    by (auto simp add: degree_monom_eq content_def monom_Suc)
  thus "(fi, i) \<in> set fs \<Longrightarrow> primitive fi \<and> lead_coeff fi > 0" using sff(2) unfolding fs
    by (cases n, auto)
  show "square_free_factorization f (d,fs)"
  proof (cases n)
    case 0
    with d fs sff xs show ?thesis by auto
  next
    case (Suc m)
    with xs have fg: "f = monom 1 (Suc m) * g" and dvd: "\<not> ?x dvd g" by auto
    from Suc have fs: "fs = (?x,m) # hs" unfolding fs by auto
    have degx: "degree ?x = 1" by code_simp
    from irreducible\<^sub>d_square_free[OF linear_irreducible\<^sub>d[OF this]] have sfx: "square_free ?x" by auto
    have fg: "f = ?x ^ n * g" unfolding fg Suc by (metis x_pow_n)
    have eq0: "?x ^ n * g = 0 \<longleftrightarrow> g = 0" by simp
    note sf = square_free_factorizationD[OF sff(1)]
    {
      fix a i
      assume ai: "(a,i) \<in> set hs"
      with sf(4) have g0: "g \<noteq> 0" by auto
      from split_list[OF ai] obtain ys zs where hs: "hs = ys @ (a,i) # zs" by auto
      have "a dvd g" unfolding square_free_factorization_prod_list[OF sff(1)] hs
        by (rule dvd_smult, simp add: ac_simps)
      moreover have "\<not> ?x dvd g" using xs[unfolded Suc] by auto
      ultimately have dvd: "\<not> ?x dvd a" using dvd_trans by blast
      from sf(2)[OF ai] have "a \<noteq> 0" by auto
      have "1 = gcd ?x a"
      proof (rule gcdI)
        fix d
        assume d: "d dvd ?x" "d dvd a"
        from content_dvd_contentI[OF d(1)] x have cnt: "is_unit (content d)" by auto
        show "is_unit d"
        proof (cases "degree d = 1")
          case False
          with divides_degree[OF d(1), unfolded degx] have "degree d = 0" by auto
          from degree0_coeffs[OF this] obtain c where dc: "d = [:c:]" by auto
          from cnt[unfolded dc] have "is_unit c" by (auto simp: content_def, cases "c = 0", auto)
          hence "d * d = 1" unfolding dc by (cases "c = -1"; cases "c = 1", auto)
          thus "is_unit d" by (metis dvd_triv_right)
        next
          case True
          from d(1) obtain e where xde: "?x = d * e" unfolding dvd_def by auto
          from arg_cong[OF this, of degree] degx have "degree d + degree e = 1"
            by (metis True add.right_neutral degree_0 degree_mult_eq one_neq_zero)
          with True have "degree e = 0" by auto
          from degree0_coeffs[OF this] xde obtain e where xde: "?x = [:e:] * d" by auto
          from arg_cong[OF this, of content, unfolded content_mult] x
          have "content [:e:] * content d = 1" by auto
          also have "content [:e :] = abs e" by (auto simp: content_def, cases "e = 0", auto)
          finally have "\<bar>e\<bar> * content d = 1" .
          from pos_zmult_eq_1_iff_lemma[OF this] have "e * e = 1" by (cases "e = 1"; cases "e = -1", auto)
          with arg_cong[OF xde, of "smult e"] have "d = ?x * [:e:]" by auto
          hence "?x dvd d" unfolding dvd_def by blast
          with d(2) have "?x dvd a" by (metis dvd_trans)
          with dvd show ?thesis by auto
        qed
      qed auto
      hence "coprime ?x a"
        by (simp add: gcd_eq_1_imp_coprime)
      note this dvd
    } note hs_dvd_x = this
    from hs_dvd_x[of ?x m]
    have nmem: "(?x,m) \<notin> set hs" by auto
    hence eq: "?x ^ n * g = smult c (\<Prod>(a, i)\<in>set fs. a ^ Suc i)"
      unfolding sf(1) unfolding fs Suc by simp
    show ?thesis unfolding fg d unfolding square_free_factorization_def split eq0 unfolding eq
    proof (intro conjI allI impI, rule refl)
      fix a i
      assume ai: "(a,i) \<in> set fs"
      thus "square_free a" "degree a > 0" using sf(2) sfx degx unfolding fs by auto
      fix b j
      assume bj: "(b,j) \<in> set fs" and diff: "(a,i) \<noteq> (b,j)"
      consider (hs_hs) "(a,i) \<in> set hs" "(b,j) \<in> set hs"
        | (hs_x) "(a,i) \<in> set hs" "b = ?x"
        | (x_hs) "(b,j) \<in> set hs" "a = ?x"
        using ai bj diff unfolding fs by auto
      then show "Rings.coprime a b"
      proof cases
        case hs_hs
        from sf(3)[OF this diff] show ?thesis .
      next
        case hs_x
        from hs_dvd_x(1)[OF hs_x(1)] show ?thesis unfolding hs_x(2) by (simp add: ac_simps)
      next
        case x_hs
        from hs_dvd_x(1)[OF x_hs(1)] show ?thesis unfolding x_hs(2) by simp
      qed
    next
      show "g = 0 \<Longrightarrow> c = 0" using sf(4) by auto
      show "g = 0 \<Longrightarrow> fs = []" using sf(4) xs Suc by auto
      show "distinct fs" using sf(5) nmem unfolding fs by auto
    qed
  qed
qed

end


(* 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_regexp_RecAtom
imports "../../Test_Base"
begin

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

datatype A = X | Y

datatype R
         = Nil | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   (case x of
      Nil => Nil
      | other =>
          (case y of
             Nil => Nil
             | other =>
                 (case x of
                    Eps => y
                    | other =>
                        (case y of
                           Eps => x
                           | other => Seq x y))))"

fun plus :: "R => R => R" where
"plus x y =
   (case x of
      Nil => y
      | other =>
          (case y of
             Nil => x
             | other => Plus x y))"

fun eqA :: "A => A => bool" where
"eqA (X) (X) = True"
| "eqA (X) (Y) = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun eqList :: "A list => A list => bool" where
"eqList (nil2) (nil2) = True"
| "eqList (nil2) (cons2 z x2) = False"
| "eqList (cons2 x3 xs) (nil2) = False"
| "eqList (cons2 x3 xs) (cons2 y2 ys) =
     ((eqA x3 y2) & (eqList xs ys))"

fun eps :: "R => bool" where
"eps x =
   (case x of
      Eps => True
      | Plus p q => ((eps p) | (eps q))
      | Seq r q2 => ((eps r) & (eps q2))
      | Star y => True
      | other => False)"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil)"

fun step :: "R => A => R" where
"step x y =
   (case x of
      Atom a => (if eqA a y then Eps else Nil)
      | Plus p q => plus (step p y) (step q y)
      | Seq r q2 => plus (seq (step r y) q2) (seq (epsR r) (step q2 y))
      | Star p2 => seq (step p2 y) x
      | other => Nil)"

fun recognise :: "R => A list => bool" where
"recognise x (nil2) = eps x"
| "recognise x (cons2 z xs) = recognise (step x z) xs"

theorem property0 :
  "((recognise (Atom a) s) = (eqList s (cons2 a (nil2))))"
  oops

end


theory Exercise_2_7
imports Main
begin
datatype 'a tree2 = Tip 'a | Node "'a tree2" "'a tree2"

fun mirror :: "'a tree2 \<Rightarrow> 'a tree2" where
  "mirror (Tip x) = Tip x" |
  "mirror (Node l r) = Node (mirror r) (mirror l)"

fun pre_order :: "'a tree2 \<Rightarrow> 'a list" where
  "pre_order (Tip x) = [x]" |
  "pre_order (Node l r) = (pre_order l) @ (pre_order r)"

fun post_order :: "'a tree2 \<Rightarrow> 'a list" where
  "post_order (Tip x) = [x]" |
  "post_order (Node l r) = (post_order r) @ (post_order l)"

value "pre_order (Node (Tip (Suc 0)) (Tip 0))"

value "post_order (Node (Tip (Suc 0)) (Tip 0))"

lemma "pre_order(mirror t) = post_order t"
  apply(induction t)
  apply(auto)
  done

lemma "pre_order(mirror t) = rev(pre_order t)"
  apply(induction t)
  apply(auto)
  done

lemma "post_order(mirror t) = pre_order t"
  apply(induction t)
  apply(auto)
  done

lemma "post_order(mirror t) = rev(post_order t)"
  apply(induction t)
  apply(auto)
  done