header {* Deep representation of HyperCTL* -- syntax and semantics *}

(*<*)
theory Deep
imports Shallow "~~/src/HOL/Library/Infinite_Set"
begin
(*>*)

subsection{* Path variables and environments *}

datatype pvar = Pvariable (natOf : nat)

text {* Deeply embedded (syntactic) formulas *}

datatype 'aprop dfmla =
  Atom 'aprop pvar |
  Fls | Neg "'aprop dfmla" | Dis "'aprop dfmla" "'aprop dfmla" |
  Next "'aprop dfmla" | Until "'aprop dfmla" "'aprop dfmla" |
  Exi pvar "'aprop dfmla"

text{* Derived operators *}

definition "Tr \<equiv> Neg Fls"
definition "Con \<phi> \<psi> \<equiv> Neg (Dis (Neg \<phi>) (Neg \<psi>))"
definition "Imp \<phi> \<psi> \<equiv> Dis (Neg \<phi>) \<psi>"
definition "Eq \<phi> \<psi> \<equiv> Con (Imp \<phi> \<psi>) (Imp \<psi> \<phi>) "
definition "Fall p \<phi> \<equiv> Neg (Exi p (Neg \<phi>))"
definition "Ev \<phi> \<equiv> Until Tr \<phi>"
definition "Alw \<phi> \<equiv> Neg (Ev (Neg \<phi>))"
definition "Wuntil \<phi> \<psi> \<equiv> Dis (Until \<phi> \<psi>) (Alw \<phi>)"
definition "Fall2 p p' \<phi> \<equiv> Fall p (Fall p' \<phi>)"

lemmas der_Op_defs =
Tr_def Con_def Imp_def Eq_def Ev_def Alw_def Wuntil_def Fall_def Fall2_def

text{* Well-formed formulas are those that do not have a temporal operator
outside the scope of any quantifier -- indeed, in HyperCTL* such a situation does not make sense,
since the temporal operators refer to previously introduced/quantified paths. *}

primrec wff :: "'aprop dfmla \<Rightarrow> bool" where
 "wff (Atom a p) = True"
|"wff Fls = True"
|"wff (Neg \<phi>) = wff \<phi>"
|"wff (Dis \<phi> \<psi>) = (wff \<phi> \<and> wff \<psi>)"
|"wff (Next \<phi>) = False"
|"wff (Until \<phi> \<psi>) = False"
|"wff (Exi p \<phi>) = True"

text {* The ability to pick a fresh variable *}

lemma finite_fresh_pvar:
assumes "finite (P :: pvar set)"
obtains p where "p \<notin> P"
proof-
  have "finite (natOf ` P)" by (metis assms finite_imageI)
  then obtain n where "n \<notin> natOf ` P" by (metis unbounded_k_infinite)
  hence "Pvariable n \<notin> P" by (metis imageI pvar.sel)
  thus ?thesis using that by auto
qed

definition getFresh :: "pvar set \<Rightarrow> pvar" where
"getFresh P \<equiv> SOME p. p \<notin> P"

lemma getFresh:
assumes "finite P" shows "getFresh P \<notin> P"
by (metis assms exE_some finite_fresh_pvar getFresh_def)

text {* The free-variables operator *}

primrec FV :: "'aprop dfmla \<Rightarrow> pvar set" where
 "FV (Atom a p) = {p}"
|"FV Fls = {}"
|"FV (Neg \<phi>) = FV \<phi>"
|"FV (Dis \<phi> \<psi>) = FV \<phi> \<union> FV \<psi>"
|"FV (Next \<phi>) = FV \<phi>"
|"FV (Until \<phi> \<psi>) = FV \<phi> \<union> FV \<psi>"
|"FV (Exi p \<phi>) = FV \<phi> - {p}"

text{* Environments *}

type_synonym env = "pvar \<Rightarrow> nat"

definition "eqOn P env env1 \<equiv> \<forall> p. p \<in> P \<longrightarrow> env p = env1 p"

lemma eqOn_Un[simp]:
"eqOn (P \<union> Q) env env1 \<longleftrightarrow> eqOn P env env1 \<and> eqOn Q env env1"
using assms unfolding eqOn_def by auto

lemma eqOn_update[simp]:
"eqOn P (env(p := \<pi>)) (env1(p := \<pi>)) \<longleftrightarrow> eqOn (P - {p}) env env1"
unfolding eqOn_def by auto

lemma eqOn_singl[simp]:
"eqOn {p} env env1 \<longleftrightarrow> env p = env1 p"
unfolding eqOn_def by auto

context Shallow
begin

subsection {* The semantic operator *}

text{* The semantics will interpret deep (syntactic) formulas as shallow formulas.
Recall that the latter are predicates on lists of paths -- the interpretation will
be parameterized by an environment mapping each path variable to a number indicating
the index (in the list) for the path denoted by the variable.

The semantics will only
be meaningful if the indexes of a formula's free variables are smaller than the length
of the path list -- we call this property ``compatibility''. *}

primrec sem :: "'aprop dfmla \<Rightarrow> env \<Rightarrow> ('state,'aprop) sfmla" where
 "sem (Atom a p) env = atom a (env p)"
|"sem Fls env = fls"
|"sem (Neg \<phi>) env = neg (sem \<phi> env)"
|"sem (Dis \<phi> \<psi>) env = dis (sem \<phi> env) (sem \<psi> env)"
|"sem (Next \<phi>) env = next (sem \<phi> env)"
|"sem (Until \<phi> \<psi>) env = until (sem \<phi> env) (sem \<psi> env)"
|"sem (Exi p \<phi>) env = exi (\<lambda> \<pi> \<pi>l. sem \<phi> (env(p := length \<pi>l)) (\<pi>l @ [\<pi>]))"

lemma sem_Exi_explicit:
"sem (Exi p \<phi>) env \<pi>l \<longleftrightarrow>
 (\<exists> \<pi>. wfp AP' \<pi> \<and> stateOf \<pi> = (if \<pi>l \<noteq> [] then stateOf (last \<pi>l) else s0) \<and>
       sem \<phi> (env(p := length \<pi>l)) (\<pi>l @ [\<pi>]))"
unfolding sem.simps
unfolding exi_def ..

lemma sem_derived[simp]:
 "sem Tr env = tr"
 "sem (Con \<phi> \<psi>) env = con (sem \<phi> env) (sem \<psi> env)"
 "sem (Imp \<phi> \<psi>) env = imp (sem \<phi> env) (sem \<psi> env)"
 "sem (Eq \<phi> \<psi>) env = eq (sem \<phi> env) (sem \<psi> env)"
 "sem (Fall p \<phi>) env = fall (\<lambda> \<pi> \<pi>l. sem \<phi> (env(p := length \<pi>l)) (\<pi>l @ [\<pi>]))"
 "sem (Ev \<phi>) env = ev (sem \<phi> env)"
 "sem (Alw \<phi>) env = alw (sem \<phi> env)"
 "sem (Wuntil \<phi> \<psi>) env = wuntil (sem \<phi> env) (sem \<psi> env)"
unfolding der_Op_defs der_op_defs by (auto simp: neg_def[abs_def])

lemma sem_Fall2[simp]:
"sem (Fall2 p p' \<phi>) env =
 fall2 (\<lambda> \<pi>' \<pi> \<pi>l. sem \<phi> (env (p := length \<pi>l, p' := Suc(length \<pi>l))) (\<pi>l @ [\<pi>,\<pi>']))"
unfolding Fall2_def fall2_def by (auto simp add: fall_def exi_def[abs_def] neg_def[abs_def])

text{* Compatibility of a pair (environment,path list) on a set of variables means
no out-or-range references: *}

definition "cpt P env \<pi>l \<equiv> \<forall> p \<in> P. env p < length \<pi>l"

lemma cpt_Un[simp]:
"cpt (P \<union> Q) env \<pi>l \<longleftrightarrow> cpt P env \<pi>l \<and> cpt Q env \<pi>l"
using assms unfolding cpt_def by auto

lemma cpt_singl[simp]:
"cpt {p} env \<pi>l \<longleftrightarrow> env p < length \<pi>l"
unfolding cpt_def by auto

lemma cpt_map_stl[simp]:
"cpt P env \<pi>l \<Longrightarrow> cpt P env (map stl \<pi>l)"
unfolding cpt_def by auto

text {* Next we prove that the semantics of well-formed formulas only depends on the interpretation
of the free variables of a formula and on the current state of the last recorded path --
we call the latter the ``pointer'' of the path list. *}

fun pointerOf :: "('state,'aprop) path list \<Rightarrow> 'state" where
"pointerOf \<pi>l = (if \<pi>l \<noteq> [] then stateOf (last \<pi>l) else s0)"

text{* Equality of two pairs (environment,path list) on a set of variables: *}

definition eqOn ::
"pvar set \<Rightarrow> env \<Rightarrow> ('state,'aprop) path list \<Rightarrow> env \<Rightarrow> ('state,'aprop) path list \<Rightarrow> bool"
where
"eqOn P env \<pi>l env1 \<pi>l1 \<equiv> \<forall> p. p \<in> P \<longrightarrow> \<pi>l!(env p) = \<pi>l1!(env1 p)"

lemma eqOn_Un[simp]:
"eqOn (P \<union> Q) env \<pi>l env1 \<pi>l1 \<longleftrightarrow> eqOn P env \<pi>l env1 \<pi>l1 \<and> eqOn Q env \<pi>l env1 \<pi>l1"
using assms unfolding eqOn_def by auto

lemma eqOn_singl[simp]:
"eqOn {p} env \<pi>l env1 \<pi>l1 \<longleftrightarrow> \<pi>l!(env p) = \<pi>l1!(env1 p)"
unfolding eqOn_def by auto

lemma eqOn_map_stl[simp]:
"cpt P env \<pi>l \<Longrightarrow> cpt P env1 \<pi>l1 \<Longrightarrow>
 eqOn P env \<pi>l env1 \<pi>l1 \<Longrightarrow> eqOn P env (map stl \<pi>l) env1 (map stl \<pi>l1)"
unfolding eqOn_def cpt_def by auto

lemma cpt_map_sdrop[simp]:
"cpt P env \<pi>l \<Longrightarrow> cpt P env (map (sdrop i) \<pi>l)"
unfolding cpt_def by auto

lemma cpt_update[simp]:
assumes "cpt (P - {p}) env \<pi>l"
shows "cpt P (env(p := length \<pi>l)) (\<pi>l @ [\<pi>])"
using assms unfolding cpt_def by simp (metis Diff_iff less_SucI singleton_iff)

lemma eqOn_map_sdrop[simp]:
"cpt V env \<pi>l \<Longrightarrow> cpt V env1 \<pi>l1 \<Longrightarrow>
 eqOn V env \<pi>l env1 \<pi>l1 \<Longrightarrow> eqOn V env (map (sdrop i) \<pi>l) env1 (map (sdrop i) \<pi>l1)"
unfolding eqOn_def cpt_def by auto

lemma eqOn_update[simp]:
assumes "cpt (P - {p}) env \<pi>l" and "cpt (P - {p}) env1 \<pi>l1"
shows
"eqOn P (env(p := length \<pi>l)) (\<pi>l @ [\<pi>]) (env1(p := length \<pi>l1)) (\<pi>l1 @ [\<pi>])
 \<longleftrightarrow>
 eqOn (P - {p}) env \<pi>l env1 \<pi>l1"
using assms unfolding eqOn_def cpt_def by simp (metis DiffI nth_append singleton_iff)

lemma eqOn_FV_sem_NE:
assumes "cpt (FV \<phi>) env \<pi>l" and "cpt (FV \<phi>) env1 \<pi>l1" and "eqOn (FV \<phi>) env \<pi>l env1 \<pi>l1"
and "\<pi>l \<noteq> []" and "\<pi>l1 \<noteq> []" and "last \<pi>l = last \<pi>l1"
shows "sem \<phi> env \<pi>l = sem \<phi> env1 \<pi>l1"
using assms proof (induction \<phi> arbitrary: env \<pi>l env1 \<pi>l1)
  case (Until \<phi> \<psi> env \<pi>l env1 \<pi>l1)
  hence "\<And> i. sem \<phi> env (map (sdrop i) \<pi>l) = sem \<phi> env1 (map (sdrop i) \<pi>l1) \<and>
              sem \<psi> env (map (sdrop i) \<pi>l) = sem \<psi> env1 (map (sdrop i) \<pi>l1)"
  using Until by (auto simp: last_map)
  thus ?case by (auto simp: op_defs)
next
  case (Exi p \<phi> env \<pi>l env1 \<pi>l1)
  hence 1:
  "\<And> \<pi>. cpt (FV \<phi>) (env(p := length \<pi>l)) (\<pi>l @ [\<pi>]) \<and>
         cpt (FV \<phi>) (env1(p := length \<pi>l1)) (\<pi>l1 @ [\<pi>]) \<and>
         eqOn (FV \<phi>) (env(p := length \<pi>l)) (\<pi>l @ [\<pi>]) (env1(p := length \<pi>l1)) (\<pi>l1 @ [\<pi>])"
  by simp_all
  thus ?case unfolding sem.simps exi_def using Exi
  by (intro iff_exI) (metis append_is_Nil_conv last_snoc)
qed(auto simp: last_map op_defs)

text{* The next theorem states that the semantics of a formula on an environment
and a list of paths only depends on the pointer of the list of paths.
 *}

theorem eqOn_FV_sem:
assumes "wff \<phi>" and "pointerOf \<pi>l = pointerOf \<pi>l1"
and "cpt (FV \<phi>) env \<pi>l" and "cpt (FV \<phi>) env1 \<pi>l1" and "eqOn (FV \<phi>) env \<pi>l env1 \<pi>l1"
shows "sem \<phi> env \<pi>l = sem \<phi> env1 \<pi>l1"
using assms proof (induction \<phi> arbitrary: env \<pi>l env1 \<pi>l1)
  case (Until \<phi> \<psi> env \<pi>l env1 \<pi>l1)
  hence "\<And> i. sem \<phi> env (map (sdrop i) \<pi>l) = sem \<phi> env1 (map (sdrop i) \<pi>l1) \<and>
              sem \<psi> env (map (sdrop i) \<pi>l) = sem \<psi> env1 (map (sdrop i) \<pi>l1)"
  using Until by (auto simp: last_map)
  thus ?case by (auto simp: op_defs)
next
  case (Exi p \<phi> env \<pi>l env1 \<pi>l1)
  have "\<And> \<pi>. sem \<phi> (env(p := length \<pi>l)) (\<pi>l @ [\<pi>]) =
             sem \<phi> (env1(p := length \<pi>l1)) (\<pi>l1 @ [\<pi>])"
  apply(rule eqOn_FV_sem_NE) using Exi by auto
  thus ?case unfolding sem.simps exi_def using Exi by (intro iff_exI conj_cong) simp_all
qed(auto simp: last_map op_defs)

corollary FV_sem:
assumes "wff \<phi>" and "\<forall> p \<in> FV \<phi>. env p = env1 p"
and "cpt (FV \<phi>) env \<pi>l" and "cpt (FV \<phi>) env1 \<pi>l"
shows "sem \<phi> env \<pi>l = sem \<phi> env1 \<pi>l"
apply(rule eqOn_FV_sem)
using assms unfolding eqOn_def by auto

text{* As a consequence, the interpretation of a closed formula (i.e., a formula
with no free variables) will not depend on the environment and, from the
list of paths, will only depend on its pointer: *}

corollary interp_closed:
assumes "wff \<phi>" and "FV \<phi> = {}" and "pointerOf \<pi>l = pointerOf \<pi>l1"
shows "sem \<phi> env \<pi>l = sem \<phi> env1 \<pi>l1"
apply(rule eqOn_FV_sem)
using assms unfolding eqOn_def cpt_def by auto

text{* Therefore, it makes sense to define the interpretation of a closed formula
by choosing any environment and any list of paths such that its pointer is the initial state
(e.g., the empty list) -- knowing that the choices are irrelevant. *}

definition "semClosed \<phi> \<equiv> sem \<phi> (any::env) (SOME \<pi>l. pointerOf \<pi>l = s0)"

lemma semClosed:
assumes \<phi>: "wff \<phi>" "FV \<phi> = {}" and p: "pointerOf \<pi>l = s0"
shows "semClosed \<phi> = sem \<phi> env \<pi>l"
proof-
  have "pointerOf (SOME \<pi>l. pointerOf \<pi>l = s0) = s0"
  by (rule someI[of _ "[]"]) simp
  thus ?thesis unfolding semClosed_def using interp_closed[OF \<phi>] p by auto
qed

lemma semClosed_Nil:
assumes \<phi>: "wff \<phi>" "FV \<phi> = {}"
shows "semClosed \<phi> = sem \<phi> env []"
using assms semClosed by auto

subsection{* The conjunction of a finite set of formulas *}

text{* This is defined by making the set into a list (by choosing any ordering of the
elements) and iterating binary conjunction. *}

definition Scon :: "'aprop dfmla set \<Rightarrow> 'aprop dfmla" where
"Scon \<phi>s \<equiv> foldr Con (asList \<phi>s) Tr"

lemma sem_Scon[simp]:
assumes "finite \<phi>s"
shows "sem (Scon \<phi>s) env = scon ((\<lambda> \<phi>. sem \<phi> env) ` \<phi>s)"
proof-
  def \<phi>l \<equiv> "asList \<phi>s"
  have "sem (foldr Con \<phi>l Tr) env = scon ((\<lambda> \<phi>. sem \<phi> env) ` (set \<phi>l))"
  by (induct \<phi>l) (auto simp: scon_def)
  thus ?thesis unfolding \<phi>l_def Scon_def by (metis assms set_asList)
qed

lemma FV_Scon[simp]:
assumes "finite \<phi>s"
shows "FV (Scon \<phi>s) = \<Union> (FV ` \<phi>s)"
proof-
  def \<phi>l \<equiv> "asList \<phi>s"
  have "FV (foldr Con \<phi>l Tr) = \<Union> (set (map FV \<phi>l))"
  apply(induct \<phi>l) by (auto simp: der_Op_defs)
  thus ?thesis unfolding \<phi>l_def Scon_def by (metis assms set_map set_asList)
qed

(*<*)
end (* context Shallow  *)
(*>*)

text{* end-of-context Shallow  *}

(*<*)
end
(*>*)


(*<*)
theory CounterExample
imports
  HOLCF
  WorkerWrapper
begin
(*>*)

subsection\<open>Worker/wrapper fusion is partially correct\<close>

text\<open>

We now examine how Gill and Hutton apply their worker/wrapper fusion
rule in the context of the fold/unfold framework.

The key step of those left implicit in the original paper is the use
of the \textsf{fold} rule to justify replacing the worker with the
fused version. Schematically, the fold/unfold framework maintains a
history of all definitions that have appeared during transformation,
and the \textsf{fold} rule treats this as a set of rewrite rules
oriented right-to-left. (The \textsf{unfold} rule treats the current
working set of definitions as rewrite rules oriented left-to-right.)
Hence as each definition @{haskell "f = body"} yields a rule of the form
@{haskell "body\\ \\Longrightarrow\\ f"}, one can always derive @{haskell "f =\\
f"}. Clearly this has dire implications for the preservation of
termination behaviour.

\citet{Tullsen:PhDThesis} in his \S3.1.2 observes that the semantic
essence of the \textsf{fold} rule is Park induction:
\begin{center}
  @{thm[mode=Rule] "fix_least"[where F=f]} {\texttt{fix\_least}}
\end{center}
viz that @{haskell "f\\ x = x"} implies only the partially correct @{haskell "fix\\ f
\\sqsubseteq x"}, and not the totally correct @{haskell "fix\\ f = x"}. We use
this characterisation to show that if @{haskell "unwrap"} is non-strict
(i.e. @{haskell "unwrap \\bot \\neq \\bot"}) then there are programs where
worker/wrapper fusion as used by Gill and Hutton need only be
partially correct.

Consider the scenario described in Figure~\ref{fig:ww}. After applying
the worker/wrapper transformation, we attempt to apply fusion by
finding a residual expression @{term "body'"} such that the body of
the worker, i.e. the expression @{term "unwrap oo body oo wrap"}, can
be rewritten as @{term "body' oo unwrap oo wrap"}. Intuitively this is
the semantic form of workers where all self-calls are fusible. Our
goal is to justify redefining @{term "work"} to @{term "fix\<cdot>body'"},
i.e. to establish:
\begin{center}
  @{term "fix\<cdot>(unwrap oo body oo wrap) = fix\<cdot>body'"}
\end{center}
We show that worker/wrapper fusion as proposed by Gill and Hutton is
partially correct using Park induction:

\<close>

lemma fusion_partially_correct:
  assumes wrap_unwrap: "wrap oo unwrap = ID"
  assumes work: "work = fix\<cdot>(unwrap oo body oo wrap)"
  assumes body': "unwrap oo body oo wrap = body' oo unwrap oo wrap"
  shows "fix\<cdot>body' \<sqsubseteq> work"
proof(rule fix_least)
  have "work = (unwrap oo body oo wrap)\<cdot>work"
    using work by (simp add: fix_eq[symmetric])
  also have "... = (body' oo unwrap oo wrap)\<cdot>work"
    using body' by simp
  also have "... = (body' oo unwrap oo wrap)\<cdot>((unwrap oo body oo wrap)\<cdot>work)"
    using work by (simp add: fix_eq[symmetric])
  also have "... = (body' oo unwrap oo wrap oo unwrap oo body oo wrap)\<cdot>work"
    by simp
  also have "... = (body' oo unwrap oo body oo wrap)\<cdot>work"
    using wrap_unwrap by (simp add: assoc_oo)
  also have "... = body'\<cdot>work"
    using work by (simp add: fix_eq[symmetric])
  finally show "body'\<cdot>work = work" by simp
qed

text\<open>

The next section shows the converse does not obtain.

\<close>

subsection\<open>A non-strict @{term "unwrap"} may go awry\<close>

text\<open>

\label{sec:ww-counterexample}

If @{term "unwrap"} is non-strict, then it is possible that the fusion
rule proposed by Gill and Hutton does not preserve termination. To
show this we take a small artificial example. The type @{term "A"} is
not important, but we need access to a non-bottom inhabitant. The
target type @{term "B"} is the non-strict lift of @{term "A"}.

\<close>

domain A = A
domain B = B (lazy "A")

text\<open>

The functions @{term "wrap"} and @{term "unwrap"} that map between
these types are routine. Note that @{term "wrap"} is (necessarily)
strict due to the property @{thm "retraction_strict"}.

\<close>

fixrec wrap :: "B \<rightarrow> A"
where "wrap\<cdot>(B\<cdot>a) = a"

(*<*)
lemma wrap_strict[simp]: "wrap\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp
(*>*)

fixrec unwrap :: "A \<rightarrow> B"
where "unwrap = B"

text\<open>

Discharging the worker/wrapper hypothesis is similarly routine.

\<close>

lemma wrap_unwrap: "wrap oo unwrap = ID"
  by (simp add: cfun_eq_iff)

text\<open>

The candidate computation we transform can be any that uses the
recursion parameter @{term "r"} non-strictly. The following is
especially trivial.

\<close>

fixrec body :: "A \<rightarrow> A"
where "body\<cdot>r = A"

text\<open>

The wrinkle is that the transformed worker can be strict in the
recursion parameter @{term "r"}, as @{term "unwrap"} always lifts it.

\<close>

fixrec body' :: "B \<rightarrow> B"
where "body'\<cdot>(B\<cdot>a) = B\<cdot>A"
(*<*)

lemma body'_strict[simp]: "body'\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp

(*>*)
text\<open>

As explained above, we set up the fusion opportunity:

\<close>

lemma body_body': "unwrap oo body oo wrap = body' oo unwrap oo wrap"
  by (simp add: cfun_eq_iff)

text\<open>

This result depends crucially on @{term "unwrap"} being non-strict.

Our earlier result shows that the proposed transformation is partially
correct:

\<close>

lemma "fix\<cdot>body' \<sqsubseteq> fix\<cdot>(unwrap oo body oo wrap)"
  by (rule fusion_partially_correct[OF wrap_unwrap refl body_body'])

text\<open>

However it is easy to see that it is not totally correct:

\<close>

lemma "\<not> fix\<cdot>(unwrap oo body oo wrap) \<sqsubseteq> fix\<cdot>body'"
proof -
  have l: "fix\<cdot>(unwrap oo body oo wrap) = B\<cdot>A"
    by (subst fix_eq) simp
  have r: "fix\<cdot>body' = \<bottom>"
    by (simp add: fix_strict)
  from l r show ?thesis by simp
qed

text\<open>

This trick works whenever @{term "unwrap"} is not strict. In the
following section we show that requiring @{term "unwrap"} to be strict
leads to a straightforward proof of total correctness.

Note that if we have already established that @{term "wrap oo unwrap =
ID"}, then making @{term "unwrap"} strict preserves this equation:

\<close>

lemma
  assumes "wrap oo unwrap = ID"
  shows "wrap oo strictify\<cdot>unwrap = ID"
proof(rule cfun_eqI)
  fix x
  from assms
  show "(wrap oo strictify\<cdot>unwrap)\<cdot>x = ID\<cdot>x"
    by (cases "x = \<bottom>") (simp_all add: cfun_eq_iff retraction_strict)
qed

text\<open>

From this we conclude that the worker/wrapper transformation itself
cannot exploit any laziness in @{term "unwrap"} under the
context-insensitive assumptions of @{thm [source]
"worker_wrapper_id"}. This is not to say that other program
transformations may not be able to.

\<close>

(*<*)
lemma
  "\<not> strictify\<cdot>unwrap oo body oo wrap = body' oo strictify\<cdot>unwrap oo wrap"
  by (simp add: cfun_eq_iff exI[where x="\<bottom>"])
(*>*)

(*<*)
end
(*>*)


(*  Title:      HOL/ATP.thy
    Author:     Fabian Immler, TU Muenchen
    Author:     Jasmin Blanchette, TU Muenchen
*)

section \<open>Automatic Theorem Provers (ATPs)\<close>

theory ATP
  imports Meson
begin

subsection \<open>ATP problems and proofs\<close>

ML_file \<open>Tools/ATP/atp_util.ML\<close>
ML_file \<open>Tools/ATP/atp_problem.ML\<close>
ML_file \<open>Tools/ATP/atp_proof.ML\<close>
ML_file \<open>Tools/ATP/atp_proof_redirect.ML\<close>
ML_file \<open>Tools/ATP/atp_satallax.ML\<close>

subsection \<open>Higher-order reasoning helpers\<close>

definition fFalse :: bool where
"fFalse \<longleftrightarrow> False"

definition fTrue :: bool where
"fTrue \<longleftrightarrow> True"

definition fNot :: "bool \<Rightarrow> bool" where
"fNot P \<longleftrightarrow> \<not> P"

definition fComp :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" where
"fComp P = (\<lambda>x. \<not> P x)"

definition fconj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"fconj P Q \<longleftrightarrow> P \<and> Q"

definition fdisj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"fdisj P Q \<longleftrightarrow> P \<or> Q"

definition fimplies :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"fimplies P Q \<longleftrightarrow> (P \<longrightarrow> Q)"

definition fAll :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where
"fAll P \<longleftrightarrow> All P"

definition fEx :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where
"fEx P \<longleftrightarrow> Ex P"

definition fequal :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
"fequal x y \<longleftrightarrow> (x = y)"

lemma fTrue_ne_fFalse: "fFalse \<noteq> fTrue"
unfolding fFalse_def fTrue_def by simp

lemma fNot_table:
"fNot fFalse = fTrue"
"fNot fTrue = fFalse"
unfolding fFalse_def fTrue_def fNot_def by auto

lemma fconj_table:
"fconj fFalse P = fFalse"
"fconj P fFalse = fFalse"
"fconj fTrue fTrue = fTrue"
unfolding fFalse_def fTrue_def fconj_def by auto

lemma fdisj_table:
"fdisj fTrue P = fTrue"
"fdisj P fTrue = fTrue"
"fdisj fFalse fFalse = fFalse"
unfolding fFalse_def fTrue_def fdisj_def by auto

lemma fimplies_table:
"fimplies P fTrue = fTrue"
"fimplies fFalse P = fTrue"
"fimplies fTrue fFalse = fFalse"
unfolding fFalse_def fTrue_def fimplies_def by auto

lemma fAll_table:
"Ex (fComp P) \<or> fAll P = fTrue"
"All P \<or> fAll P = fFalse"
unfolding fFalse_def fTrue_def fComp_def fAll_def by auto

lemma fEx_table:
"All (fComp P) \<or> fEx P = fTrue"
"Ex P \<or> fEx P = fFalse"
unfolding fFalse_def fTrue_def fComp_def fEx_def by auto

lemma fequal_table:
"fequal x x = fTrue"
"x = y \<or> fequal x y = fFalse"
unfolding fFalse_def fTrue_def fequal_def by auto

lemma fNot_law:
"fNot P \<noteq> P"
unfolding fNot_def by auto

lemma fComp_law:
"fComp P x \<longleftrightarrow> \<not> P x"
unfolding fComp_def ..

lemma fconj_laws:
"fconj P P \<longleftrightarrow> P"
"fconj P Q \<longleftrightarrow> fconj Q P"
"fNot (fconj P Q) \<longleftrightarrow> fdisj (fNot P) (fNot Q)"
unfolding fNot_def fconj_def fdisj_def by auto

lemma fdisj_laws:
"fdisj P P \<longleftrightarrow> P"
"fdisj P Q \<longleftrightarrow> fdisj Q P"
"fNot (fdisj P Q) \<longleftrightarrow> fconj (fNot P) (fNot Q)"
unfolding fNot_def fconj_def fdisj_def by auto

lemma fimplies_laws:
"fimplies P Q \<longleftrightarrow> fdisj (\<not> P) Q"
"fNot (fimplies P Q) \<longleftrightarrow> fconj P (fNot Q)"
unfolding fNot_def fconj_def fdisj_def fimplies_def by auto

lemma fAll_law:
"fNot (fAll R) \<longleftrightarrow> fEx (fComp R)"
unfolding fNot_def fComp_def fAll_def fEx_def by auto

lemma fEx_law:
"fNot (fEx R) \<longleftrightarrow> fAll (fComp R)"
unfolding fNot_def fComp_def fAll_def fEx_def by auto

lemma fequal_laws:
"fequal x y = fequal y x"
"fequal x y = fFalse \<or> fequal y z = fFalse \<or> fequal x z = fTrue"
"fequal x y = fFalse \<or> fequal (f x) (f y) = fTrue"
unfolding fFalse_def fTrue_def fequal_def by auto

subsection \<open>Basic connection between ATPs and HOL\<close>

ML_file \<open>Tools/lambda_lifting.ML\<close>
ML_file \<open>Tools/monomorph.ML\<close>
ML_file \<open>Tools/ATP/atp_problem_generate.ML\<close>
ML_file \<open>Tools/ATP/atp_proof_reconstruct.ML\<close>

end


theory Stuttering_Extension
imports Simulation Step_Conv
begin

  definition stutter_extend_edges :: "'v set \<Rightarrow> 'v digraph \<Rightarrow> 'v digraph"
    where "stutter_extend_edges V E \<equiv> E \<union> {(v, v) |v. v \<in> V \<and> v \<notin> Domain E}"

  lemma stutter_extend_edgesI_edge:
    assumes "(u, v) \<in> E"
    shows "(u, v) \<in> stutter_extend_edges V E"
    using assms unfolding stutter_extend_edges_def by auto
  lemma stutter_extend_edgesI_stutter:
    assumes "v \<in> V" "v \<notin> Domain E"
    shows "(v, v) \<in> stutter_extend_edges V E"
    using assms unfolding stutter_extend_edges_def by auto
  lemma stutter_extend_edgesE:
    assumes "(u, v) \<in> stutter_extend_edges V E"
    obtains (edge) "(u, v) \<in> E" | (stutter) "u \<in> V" "u \<notin> Domain E" "u = v"
    using assms unfolding stutter_extend_edges_def by auto

  lemma stutter_extend_wf: "E \<subseteq> V \<times> V \<Longrightarrow> stutter_extend_edges V E \<subseteq> V \<times> V"
    unfolding stutter_extend_edges_def by auto

  lemma stutter_extend_edges_rtrancl[simp]: "(stutter_extend_edges V E)\<^sup>* = E\<^sup>*"
    unfolding stutter_extend_edges_def by (auto intro: in_rtrancl_UnI elim: rtrancl_induct)

  lemma stutter_extend_domain: "V \<subseteq> Domain (stutter_extend_edges V E)"
    unfolding stutter_extend_edges_def by auto

  definition stutter_extend :: "('v, _) graph_rec_scheme \<Rightarrow> ('v, _) graph_rec_scheme"
    where "stutter_extend G \<equiv>
    \<lparr>
      g_V = g_V G,
      g_E = stutter_extend_edges (g_V G) (g_E G),
      g_V0 = g_V0 G,
      \<dots> = graph_rec.more G
    \<rparr>"

  lemma stutter_extend_simps[simp]:
    "g_V (stutter_extend G) = g_V G"
    "g_E (stutter_extend G) = stutter_extend_edges (g_V G) (g_E G)"
    "g_V0 (stutter_extend G) = g_V0 G"
    unfolding stutter_extend_def by auto

  lemma stutter_extend_simps_sa[simp]:
    "sa_L (stutter_extend G) = sa_L G"
    unfolding stutter_extend_def
    by (metis graph_rec.select_convs(4) sa_rec.select_convs(1) sa_rec.surjective)

  lemma (in graph) stutter_extend_graph: "graph (stutter_extend G)"
    using V0_ss E_ss by (unfold_locales, auto intro!: stutter_extend_wf)
  lemma (in sa) stutter_extend_sa: "sa (stutter_extend G)"
  proof -
    interpret graph "stutter_extend G" using stutter_extend_graph by this
    show ?thesis by unfold_locales
  qed

  lemma (in bisimulation) stutter_extend: "bisimulation R (stutter_extend A) (stutter_extend B)"
  proof -
    interpret ea: graph "stutter_extend A" by (rule a.stutter_extend_graph)
    interpret eb: graph "stutter_extend B" by (rule b.stutter_extend_graph)
    show ?thesis
    proof
      fix a b
      assume "a \<in> g_V (stutter_extend A)" "(a, b) \<in> R"
      thus "b \<in> g_V (stutter_extend B)" using s1.nodes_sim by simp
    next
      fix a
      assume "a \<in> g_V0 (stutter_extend A)"
      thus "\<exists> b. b \<in> g_V0 (stutter_extend B) \<and> (a, b) \<in> R" using s1.init_sim by simp
    next
      fix a a' b
      assume "(a, a') \<in> g_E (stutter_extend A)" "(a, b) \<in> R"
      thus "\<exists> b'. (b, b') \<in> g_E (stutter_extend B) \<and> (a', b') \<in> R"
        apply simp
        using s1.nodes_sim s1.step_sim s2.stuck_sim
        by (blast
          intro: stutter_extend_edgesI_edge stutter_extend_edgesI_stutter
          elim: stutter_extend_edgesE)
    next
      fix b a
      assume "b \<in> g_V (stutter_extend B)" "(b, a) \<in> R\<inverse>"
      thus "a \<in> g_V (stutter_extend A)" using s2.nodes_sim by simp
    next
      fix b
      assume "b \<in> g_V0 (stutter_extend B)"
      thus "\<exists> a. a \<in> g_V0 (stutter_extend A) \<and> (b, a) \<in> R\<inverse>" using s2.init_sim by simp
    next
      fix b b' a
      assume "(b, b') \<in> g_E (stutter_extend B)" "(b, a) \<in> R\<inverse>"
      thus "\<exists> a'. (a, a') \<in> g_E (stutter_extend A) \<and> (b', a') \<in> R\<inverse>"
        apply simp
        using s2.nodes_sim s2.step_sim s1.stuck_sim
        by (blast
          intro: stutter_extend_edgesI_edge stutter_extend_edgesI_stutter
          elim: stutter_extend_edgesE)
    qed
  qed

  lemma (in lbisimulation) lstutter_extend: "lbisimulation R (stutter_extend A) (stutter_extend B)"
  proof -
    interpret se: bisimulation R "stutter_extend A" "stutter_extend B" by (rule stutter_extend)
    show ?thesis by (unfold_locales, auto simp: s1.labeling_consistent)
  qed

  definition stutter_extend_en :: "('s\<Rightarrow>'a set) \<Rightarrow> ('s \<Rightarrow> 'a option set)" where
    "stutter_extend_en en \<equiv> \<lambda>s. let as = en s in if as={} then {None} else Some`as"

  definition stutter_extend_ex :: "('a \<Rightarrow> 's \<Rightarrow> 's) \<Rightarrow> ('a option \<Rightarrow> 's \<Rightarrow> 's)" where
    "stutter_extend_ex ex \<equiv> \<lambda>None \<Rightarrow> id | Some a \<Rightarrow> ex a"

  abbreviation stutter_extend_enex
    :: "('s\<Rightarrow>'a set) \<times> ('a \<Rightarrow> 's \<Rightarrow> 's) \<Rightarrow> ('s \<Rightarrow> 'a option set) \<times> ('a option \<Rightarrow> 's \<Rightarrow> 's)"
  where
   "stutter_extend_enex \<equiv> map_prod stutter_extend_en stutter_extend_ex"

  lemma stutter_extend_pred_of_enex_conv:
    "stutter_extend_edges UNIV (rel_of_enex enex) = rel_of_enex (stutter_extend_enex enex)"
    unfolding rel_of_enex_def stutter_extend_edges_def
    apply (auto simp: stutter_extend_en_def stutter_extend_ex_def split: prod.splits)
    apply force
    apply blast
    done

  lemma stutter_extend_en_Some_eq[simp]:
    "Some a \<in> stutter_extend_en en gc \<longleftrightarrow> a \<in> en gc"
    "stutter_extend_ex ex (Some a) gc = ex a gc"
    unfolding stutter_extend_en_def stutter_extend_ex_def by auto

  lemma stutter_extend_ex_None_eq[simp]:
    "stutter_extend_ex ex None = id"
    unfolding stutter_extend_ex_def by auto

end


(*  Title:      HOL/Auth/Guard/List_Msg.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2001  University of Cambridge
*)

section{*Lists of Messages and Lists of Agents*}

theory List_Msg imports Extensions begin

subsection{*Implementation of Lists by Messages*}

subsubsection{*nil is represented by any message which is not a pair*}

abbreviation (input)
  cons :: "msg => msg => msg" where
  "cons x l == {|x,l|}"

subsubsection{*induction principle*}

lemma lmsg_induct: "[| !!x. not_MPair x ==> P x; !!x l. P l ==> P (cons x l) |]
==> P l"
by (induct l) auto

subsubsection{*head*}

primrec head :: "msg => msg" where
"head (cons x l) = x"

subsubsection{*tail*}

primrec tail :: "msg => msg" where
"tail (cons x l) = l"

subsubsection{*length*}

fun len :: "msg => nat" where
"len (cons x l) = Suc (len l)" |
"len other = 0"

lemma len_not_empty: "n < len l ==> EX x l'. l = cons x l'"
by (cases l) auto

subsubsection{*membership*}

fun isin :: "msg * msg => bool" where
"isin (x, cons y l) = (x=y | isin (x,l))" |
"isin (x, other) = False"

subsubsection{*delete an element*}

fun del :: "msg * msg => msg" where
"del (x, cons y l) = (if x=y then l else cons y (del (x,l)))" |
"del (x, other) = other"

lemma notin_del [simp]: "~ isin (x,l) ==> del (x,l) = l"
by (induct l) auto

lemma isin_del [rule_format]: "isin (y, del (x,l)) --> isin (y,l)"
by (induct l) auto

subsubsection{*concatenation*}

fun app :: "msg * msg => msg" where
"app (cons x l, l') = cons x (app (l,l'))" |
"app (other, l') = l'"

lemma isin_app [iff]: "isin (x, app(l,l')) = (isin (x,l) | isin (x,l'))"
by (induct l) auto

subsubsection{*replacement*}

fun repl :: "msg * nat * msg => msg" where
"repl (cons x l, Suc i, x') = cons x (repl (l,i,x'))" |
"repl (cons x l, 0, x') = cons x' l" |
"repl (other, i, M') = other"

subsubsection{*ith element*}

fun ith :: "msg * nat => msg" where
"ith (cons x l, Suc i) = ith (l,i)" |
"ith (cons x l, 0) = x" |
"ith (other, i) = other"

lemma ith_head: "0 < len l ==> ith (l,0) = head l"
by (cases l) auto

subsubsection{*insertion*}

fun ins :: "msg * nat * msg => msg" where
"ins (cons x l, Suc i, y) = cons x (ins (l,i,y))" |
"ins (l, 0, y) = cons y l"

lemma ins_head [simp]: "ins (l,0,y) = cons y l"
by (cases l) auto

subsubsection{*truncation*}

fun trunc :: "msg * nat => msg" where
"trunc (l,0) = l" |
"trunc (cons x l, Suc i) = trunc (l,i)"

lemma trunc_zero [simp]: "trunc (l,0) = l"
by (cases l) auto

subsection{*Agent Lists*}

subsubsection{*set of well-formed agent-list messages*}

abbreviation
  nil :: msg where
  "nil == Number 0"

inductive_set agl :: "msg set"
where
  Nil[intro]: "nil:agl"
| Cons[intro]: "[| A:agent; I:agl |] ==> cons (Agent A) I :agl"

subsubsection{*basic facts about agent lists*}

lemma del_in_agl [intro]: "I:agl ==> del (a,I):agl"
by (erule agl.induct, auto)

lemma app_in_agl [intro]: "[| I:agl; J:agl |] ==> app (I,J):agl"
by (erule agl.induct, auto)

lemma no_Key_in_agl: "I:agl ==> Key K ~:parts {I}"
by (erule agl.induct, auto)

lemma no_Nonce_in_agl: "I:agl ==> Nonce n ~:parts {I}"
by (erule agl.induct, auto)

lemma no_Key_in_appdel: "[| I:agl; J:agl |] ==>
Key K ~:parts {app (J, del (Agent B, I))}"
by (rule no_Key_in_agl, auto)

lemma no_Nonce_in_appdel: "[| I:agl; J:agl |] ==>
Nonce n ~:parts {app (J, del (Agent B, I))}"
by (rule no_Nonce_in_agl, auto)

lemma no_Crypt_in_agl: "I:agl ==> Crypt K X ~:parts {I}"
by (erule agl.induct, auto)

lemma no_Crypt_in_appdel: "[| I:agl; J:agl |] ==>
Crypt K X ~:parts {app (J, del (Agent B,I))}"
by (rule no_Crypt_in_agl, auto)

end


(*  Title:       variants/c_gtobcast/Aodv_Predicates.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke, Inria
    Author:      Peter Höfner, NICTA
*)

section "Invariant assumptions and properties"

theory C_Aodv_Predicates
imports C_Aodv
begin

text \<open>Definitions for expression assumptions on incoming messages and properties of
      outgoing messages.\<close>

abbreviation not_Pkt :: "msg \<Rightarrow> bool"
where "not_Pkt m \<equiv> case m of Pkt _ _ _ \<Rightarrow> False | _ \<Rightarrow> True"

definition msg_sender :: "msg \<Rightarrow> ip"
where "msg_sender m \<equiv> case m of Rreq _ _ _ _ _ _ _ ipc \<Rightarrow> ipc
                              | Rrep _ _ _ _ ipc \<Rightarrow> ipc
                              | Rerr _ ipc \<Rightarrow> ipc
                              | Pkt _ _ ipc \<Rightarrow> ipc"

lemma msg_sender_simps [simp]:
  "\<And>hops rreqid dip dsn dsk oip osn sip.
                          msg_sender (Rreq hops rreqid dip dsn dsk oip osn sip) = sip"
  "\<And>hops dip dsn oip sip. msg_sender (Rrep hops dip dsn oip sip) = sip"
  "\<And>dests sip.            msg_sender (Rerr dests sip) = sip"
  "\<And>d dip sip.            msg_sender (Pkt d dip sip) = sip"
  unfolding msg_sender_def by simp_all

definition msg_zhops :: "msg \<Rightarrow> bool"
where "msg_zhops m \<equiv> case m of
                                 Rreq hopsc _ dipc _ _ oipc _ sipc \<Rightarrow> hopsc = 0 \<longrightarrow> oipc = sipc
                               | Rrep hopsc dipc _ _ sipc \<Rightarrow> hopsc = 0 \<longrightarrow> dipc = sipc
                               | _ \<Rightarrow> True"

lemma msg_zhops_simps [simp]:
  "\<And>hops rreqid dip dsn dsk oip osn sip.
           msg_zhops (Rreq hops rreqid dip dsn dsk oip osn sip) = (hops = 0 \<longrightarrow> oip = sip)"
  "\<And>hops dip dsn oip sip. msg_zhops (Rrep hops dip dsn oip sip) = (hops = 0 \<longrightarrow> dip = sip)"
  "\<And>dests sip.            msg_zhops (Rerr dests sip)        = True"
  "\<And>d dip.                msg_zhops (Newpkt d dip)          = True"
  "\<And>d dip sip.            msg_zhops (Pkt d dip sip)         = True"
  unfolding msg_zhops_def by simp_all

definition rreq_rrep_sn :: "msg \<Rightarrow> bool"
where "rreq_rrep_sn m \<equiv> case m of Rreq _ _ _ _ _ _ osnc _ \<Rightarrow> osnc \<ge> 1
                                | Rrep _ _ dsnc _ _ \<Rightarrow> dsnc \<ge> 1
                                | _ \<Rightarrow> True"

lemma rreq_rrep_sn_simps [simp]:
  "\<And>hops rreqid dip dsn dsk oip osn sip.
           rreq_rrep_sn (Rreq hops rreqid dip dsn dsk oip osn sip) = (osn \<ge> 1)"
  "\<And>hops dip dsn oip sip. rreq_rrep_sn (Rrep hops dip dsn oip sip) = (dsn \<ge> 1)"
  "\<And>dests sip.            rreq_rrep_sn (Rerr dests sip) = True"
  "\<And>d dip.                rreq_rrep_sn (Newpkt d dip)   = True"
  "\<And>d dip sip.            rreq_rrep_sn (Pkt d dip sip)  = True"
  unfolding rreq_rrep_sn_def by simp_all

definition rreq_rrep_fresh :: "rt \<Rightarrow> msg \<Rightarrow> bool"
where "rreq_rrep_fresh crt m \<equiv> case m of Rreq hopsc _ _ _ _ oipc osnc ipcc \<Rightarrow> (ipcc \<noteq> oipc \<longrightarrow>
                                                oipc\<in>kD(crt) \<and> (sqn crt oipc > osnc
                                                                \<or> (sqn crt oipc = osnc
                                                                   \<and> the (dhops crt oipc) \<le> hopsc
                                                                   \<and> the (flag crt oipc) = val)))
                                | Rrep hopsc dipc dsnc _ ipcc \<Rightarrow> (ipcc \<noteq> dipc \<longrightarrow>
                                                                    dipc\<in>kD(crt)
                                                                  \<and> sqn crt dipc = dsnc
                                                                  \<and> the (dhops crt dipc) = hopsc
                                                                  \<and> the (flag crt dipc) = val)
                                | _ \<Rightarrow> True"

lemma rreq_rrep_fresh [simp]:
  "\<And>hops rreqid dip dsn dsk oip osn sip.
           rreq_rrep_fresh crt (Rreq hops rreqid dip dsn dsk oip osn sip) =
                               (sip \<noteq> oip \<longrightarrow> oip\<in>kD(crt)
                                            \<and> (sqn crt oip > osn
                                               \<or> (sqn crt oip = osn
                                                  \<and> the (dhops crt oip) \<le> hops
                                                  \<and> the (flag crt oip) = val)))"
  "\<And>hops dip dsn oip sip. rreq_rrep_fresh crt (Rrep hops dip dsn oip sip) =
                               (sip \<noteq> dip \<longrightarrow> dip\<in>kD(crt)
                                              \<and> sqn crt dip = dsn
                                              \<and> the (dhops crt dip) = hops
                                              \<and> the (flag crt dip) = val)"
  "\<And>dests sip.            rreq_rrep_fresh crt (Rerr dests sip) = True"
  "\<And>d dip.                rreq_rrep_fresh crt (Newpkt d dip)   = True"
  "\<And>d dip sip.            rreq_rrep_fresh crt (Pkt d dip sip)  = True"
  unfolding rreq_rrep_fresh_def by simp_all

definition rerr_invalid :: "rt \<Rightarrow> msg \<Rightarrow> bool"
where "rerr_invalid crt m \<equiv> case m of Rerr destsc _ \<Rightarrow> (\<forall>ripc\<in>dom(destsc).
                                            (ripc\<in>iD(crt) \<and> the (destsc ripc) = sqn crt ripc))
                                | _ \<Rightarrow> True"

lemma rerr_invalid [simp]:
  "\<And>hops rreqid dip dsn dsk oip osn sip.
                           rerr_invalid crt (Rreq hops rreqid dip dsn dsk oip osn sip) = True"
  "\<And>hops dip dsn oip sip. rerr_invalid crt (Rrep hops dip dsn oip sip) = True"
  "\<And>dests sip.            rerr_invalid crt (Rerr dests sip) = (\<forall>rip\<in>dom(dests).
                                                 rip\<in>iD(crt) \<and> the (dests rip) = sqn crt rip)"
  "\<And>d dip.                rerr_invalid crt (Newpkt d dip)   = True"
  "\<And>d dip sip.            rerr_invalid crt (Pkt d dip sip)  = True"
  unfolding rerr_invalid_def by simp_all

definition
  initmissing :: "(nat \<Rightarrow> state option) \<times> 'a \<Rightarrow> (nat \<Rightarrow> state) \<times> 'a"
where
  "initmissing \<sigma> = (\<lambda>i. case (fst \<sigma>) i of None \<Rightarrow> aodv_init i | Some s \<Rightarrow> s, snd \<sigma>)"

lemma not_in_net_ips_fst_init_missing [simp]:
  assumes "i \<notin> net_ips \<sigma>"
    shows "fst (initmissing (netgmap fst \<sigma>)) i = aodv_init i"
  using assms unfolding initmissing_def by simp

lemma fst_initmissing_netgmap_pair_fst [simp]:
  "fst (initmissing (netgmap (\<lambda>(p, q). (fst (id p), snd (id p), q)) s))
                                               = fst (initmissing (netgmap fst s))"
  unfolding initmissing_def by auto

text \<open>We introduce a streamlined alternative to @{term initmissing} with @{term netgmap}
        to simplify invariant statements and thus facilitate their comprehension and
        presentation.\<close>

lemma fst_initmissing_netgmap_default_aodv_init_netlift:
  "fst (initmissing (netgmap fst s)) = default aodv_init (netlift fst s)"
  unfolding initmissing_def default_def
  by (simp add: fst_netgmap_netlift del: One_nat_def)

definition
  netglobal :: "((nat \<Rightarrow> state) \<Rightarrow> bool) \<Rightarrow> ((state \<times> 'b) \<times> 'c) net_state \<Rightarrow> bool"
where
  "netglobal P \<equiv> (\<lambda>s. P (default aodv_init (netlift fst s)))"

end


theory subst_SubstFreeYes
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype Expr = Var "int" | Lam "int" "Expr" | App "Expr" "Expr"

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun newmaximum :: "int => int list => int" where
"newmaximum x (Nil2) = x"
| "newmaximum x (Cons2 z ys) =
     (if x <= z then newmaximum z ys else newmaximum x ys)"

fun new :: "int list => int" where
"new x = (newmaximum 0 x) + 1"

fun filter :: "('t => bool) => 't list => 't list" where
"filter p (Nil2) = Nil2"
| "filter p (Cons2 y z) =
     (if p y then Cons2 y (filter p z) else filter p z)"

fun elem :: "int => int list => bool" where
"elem x (Nil2) = False"
| "elem x (Cons2 z ys) = or2 (x = z) (elem x ys)"

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

fun free :: "Expr => int list" where
"free (Var y) = Cons2 y (Nil2)"
| "free (Lam z b) = filter (% (x2 :: int) => z ~= x2) (free b)"
| "free (App c b2) = append (free c) (free b2)"

fun subst :: "int => Expr => Expr => Expr" where
"subst x y (Var y2) = (if x = y2 then y else Var y2)"
| "subst x y (Lam y3 a) =
     (if x = y3 then Lam y3 a else
        (if elem y3 (free y) then
           subst
             x y
             (Lam
                (new (append (free y) (free a)))
                (subst y3 (Var (new (append (free y) (free a)))) a))
           else
           Lam y3 (subst x y a)))"
| "subst x y (App c b2) = App (subst x y c) (subst x y b2)"

(*hipster or2 newmaximum new filter elem append free subst *)

theorem x0 :
  "!! (x :: int) (e :: Expr) (a :: Expr) (y :: int) .
     (elem x (free a)) ==>
       ((elem
           y (append (filter (% (z :: int) => z ~= x) (free a)) (free e))) =
          (elem y (free (subst x e a))))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Ex035
  imports Main
begin

lemma "A \<longrightarrow> True"
proof -
  {
    assume A
    have True by (rule TrueI)
  }
  thus ?thesis by (rule impI)
qed


theory Enclosure_Operations
imports
  Autoref_Misc
  Affine_Arithmetic.Print
  Ordinary_Differential_Equations.Reachability_Analysis
begin

section \<open>interfaces\<close>

consts i_appr :: interface \<comment> \<open>reachable set\<close>

section \<open>Operations on Enclosures (Sets)\<close>

definition [refine_vcg_def]: "split_spec X = SPEC (\<lambda>(A, B). X \<subseteq> A \<union> B)"

definition [refine_vcg_def]: "split_spec_param (n::nat) X = SPEC (\<lambda>(A, B). X \<subseteq> A \<union> B)"
definition [refine_vcg_def]: "split_spec_params d n X = SPEC (\<lambda>(A, B). env_len A d \<and> env_len B d \<and> X \<subseteq> A \<union> B)"

definition [refine_vcg_def]: "split_spec_exact x = SPEC (\<lambda>(a, b). x = a \<union> b)"

definition [refine_vcg_def]: "Inf_specs d X = SPEC (\<lambda>r::real list. length r = d \<and> (\<forall>x \<in> X. list_all2 (\<le>) r x))"
definition [refine_vcg_def]: "Inf_spec X = SPEC (\<lambda>r. \<forall>x \<in> X. r \<le> x)"

definition [refine_vcg_def]: "Sup_specs d X = SPEC (\<lambda>r::real list. length r = d \<and> (\<forall>x \<in> X. list_all2 (\<le>) x r))"
definition [refine_vcg_def]: "Sup_spec X = SPEC (\<lambda>r. \<forall>x \<in> X. x \<le> r)"

definition [refine_vcg_def]: "Inf_inners X y = SPEC (\<lambda>r::real. (\<forall>x \<in> X. r \<le> inner_lv_rel x y))" \<comment> \<open>TODO: generic image of aforms, then Inf\<close>
definition [refine_vcg_def]: "Inf_inner X y = SPEC (\<lambda>r. \<forall>x \<in> X. r \<le> x \<bullet> y)" \<comment> \<open>TODO: generic image of aforms, then Inf\<close>

definition [refine_vcg_def]: "Sup_inners X y = SPEC (\<lambda>r::real. (\<forall>x \<in> X. r \<ge> inner_lv_rel x y))" \<comment> \<open>TODO: generic image of aforms, then Inf\<close>
definition [refine_vcg_def]: "Sup_inner X y = SPEC (\<lambda>r. \<forall>x \<in> X. x \<bullet> y \<le> r)" \<comment> \<open>TODO: generic image of aforms. then Sup\<close>

definition "plane_ofs sctn = {x. inner_lv_rel x (normal sctn) = pstn sctn}"
definition [refine_vcg_def]: "inter_sctn_specs d X sctn = SPEC (\<lambda>R. env_len R d \<and> X \<inter> plane_ofs sctn \<subseteq> R \<and> R \<subseteq> plane_ofs sctn)"
definition [refine_vcg_def]: "inter_sctn_spec X sctn = SPEC (\<lambda>R. X \<inter> plane_of sctn \<subseteq> R \<and> R \<subseteq> plane_of sctn)"

definition [refine_vcg_def]: "intersects_spec X sctn = SPEC (\<lambda>b. b \<or> X \<inter> plane_of sctn = {})"

definition [refine_vcg_def]: "intersects_sctns_spec X sctns = SPEC (\<lambda>b. b \<or> X \<inter> \<Union>(plane_of ` sctns) = {})"

definition [refine_vcg_def]: "reduce_spec (reach_options_o::unit) X = SPEC (\<lambda>R. X \<subseteq> R)"
definition [refine_vcg_def]: "reduce_specs d (reach_options_o::unit) X = SPEC (\<lambda>R. env_len R d \<and> X \<subseteq> R)"

definition [refine_vcg_def]: "width_spec X = SPEC (top::real\<Rightarrow>_)"

definition [refine_vcg_def]: "ivl_rep_of_set X = SPEC (\<lambda>(i, s). i \<le> s \<and> X \<subseteq> {i .. s})"

definition "strongest_direction T =
  (let
    b = fold (\<lambda>b' b. if abs (T \<bullet> b') \<ge> abs (T \<bullet> b) then b' else b) (Basis_list::'a::executable_euclidean_space list) 0
  in
    (sgn (T \<bullet> b) *\<^sub>R b, abs (T \<bullet> b)))"

subsection \<open>subset approximation\<close>

definition[refine_vcg_def]:  "subset_spec X Y = SPEC (\<lambda>b. b \<longrightarrow> X \<subseteq> Y)"

definition [refine_vcg_def]: "above_sctn X sctn = SPEC (\<lambda>b. b \<longrightarrow> (X \<subseteq> sabove_halfspace sctn))"

lemma above_sctn_nres: "do { ii \<leftarrow> Inf_inner X (normal sctn); RETURN (ii > pstn sctn)} \<le> above_sctn X sctn"
  by (auto simp: above_sctn_def Inf_inner_def sabove_halfspace_def gt_halfspace_def intro!: refine_vcg)

definition [refine_vcg_def]: "below_sctn X sctn = SPEC (\<lambda>b. b \<longrightarrow> (X \<subseteq> below_halfspace sctn))"

lemma below_sctn_nres:
  "do { si \<leftarrow> Sup_inner X (normal sctn); RETURN (si \<le> pstn sctn)} \<le> below_sctn X sctn"
  by (auto simp: below_sctn_def Sup_inner_def below_halfspace_def le_halfspace_def intro!: refine_vcg)

definition [refine_vcg_def]: "sbelow_sctn X sctn = SPEC (\<lambda>b. b \<longrightarrow> (X \<subseteq> sbelow_halfspace sctn))"

lemma sbelow_sctn_nres:
  "do { si \<leftarrow> Sup_inner X (normal sctn); RETURN (si < pstn sctn)} \<le> sbelow_sctn X sctn"
  by (auto simp: sbelow_sctn_def Sup_inner_def sbelow_halfspace_def lt_halfspace_def intro!: refine_vcg)

definition [refine_vcg_def]: "sbelow_sctns X sctn = SPEC (\<lambda>b. b \<longrightarrow> (X \<subseteq> sbelow_halfspaces sctn))"

lemma sbelow_sctns_nres:
  assumes "finite sctns"
  shows "FOREACH\<^bsup>(\<lambda>it b. b \<longrightarrow> (\<forall>sctn \<in> sctns - it. X \<subseteq> sbelow_halfspace sctn))\<^esup> sctns  (\<lambda>sctn b.
    do {
      b' \<leftarrow> sbelow_sctn X sctn;
      RETURN (b' \<and> b)}) True \<le> sbelow_sctns X sctns"
  unfolding sbelow_sctns_def
  by (refine_vcg assms) (auto simp: sbelow_halfspaces_def)

definition [refine_vcg_def]: "disjoint_sets X Y = SPEC (\<lambda>b. b \<longrightarrow> X \<inter> Y = {})"

section \<open>Dependencies (Set of vectors)\<close>

subsection \<open>singleton projection\<close>

definition [refine_vcg_def]: "nth_image_precond X n \<longleftrightarrow> X \<noteq> {} \<and> (\<forall>xs\<in>X. n < length xs \<and> env_len X (length xs))"

definition [refine_vcg_def]: "nth_image X n = SPEC (\<lambda>R. nth_image_precond X n \<and> (R = (\<lambda>x. x ! n) ` X))"

subsection \<open>projection\<close>

definition "project_env_precond env is \<equiv> (\<forall>i \<in> set is. \<forall>xs\<in>env. i < length xs \<and> env_len env (length xs))"

definition project_env where [refine_vcg_def]:
  "project_env env is = SPEC (\<lambda>R. project_env_precond env is \<and> env_len R (length is) \<and> (\<lambda>xs. map (\<lambda>i. xs ! i) is) ` env \<subseteq> R)"

subsection \<open>expressions\<close>

definition approx_slp_spec::"floatarith list \<Rightarrow> nat \<Rightarrow> slp \<Rightarrow> real list set \<Rightarrow> real list set option nres"
  where [refine_vcg_def]: "approx_slp_spec fas l slp env =
    (ASSERT (slp_of_fas fas = slp \<and> length fas = l)) \<bind>
    (\<lambda>_. SPEC (\<lambda>R. case R of Some R \<Rightarrow> \<exists>e. env_len env e \<and> env_len R l \<and>
        (\<forall>e\<in>env. interpret_floatariths fas e \<in> R) | None \<Rightarrow> True))"

definition approx_form_spec::"form \<Rightarrow> real list set \<Rightarrow> bool nres"
where "approx_form_spec ea E = SPEC (\<lambda>r. r \<longrightarrow> (\<forall>e\<in>E. interpret_form ea e))"

definition isFDERIV_spec
  :: "nat \<Rightarrow> nat list \<Rightarrow> floatarith list \<Rightarrow> real list set \<Rightarrow> bool nres"
  where "isFDERIV_spec N xs fas VS = SPEC (\<lambda>r. r \<longrightarrow> (\<forall>vs \<in> VS. isFDERIV N xs fas vs))"

subsection \<open>singleton environment\<close>

definition sings_spec where [refine_vcg_def]:
  "sings_spec X = SPEC (\<lambda>env. env_len env 1 \<and> X \<noteq> {} \<and> (env = (\<lambda>x. [x]) ` X))"

definition [refine_vcg_def]: "project_set X b y = SPEC (\<lambda>ivl. X \<inter> {x. x \<bullet> b = y} \<subseteq> ivl \<and> ivl \<subseteq> {x. x \<bullet> b = y})"

definition [refine_vcg_def]: "sets_of_coll X = SPEC (\<lambda>XS. X = \<Union>XS)"

definition [simp]: "is_empty \<equiv> \<lambda>x. x = {}"
lemma [autoref_itype]: "is_empty ::\<^sub>i A \<rightarrow>\<^sub>i i_bool"
  by simp

definition [refine_vcg_def]: "project_sets X b y = SPEC (\<lambda>ivl. X \<inter> {x. x \<bullet> b = y} \<subseteq> ivl \<and> ivl \<subseteq> {x. x \<bullet> b = y})"

definition [refine_vcg_def]: "restrict_to_halfspaces sctns X = SPEC (\<lambda>R. R = X \<inter> below_halfspaces sctns)"

end


(* Author: Manuel Eberl <manuel@pruvisto.org> *)
theory Misc_Polynomial
imports "HOL-Computational_Algebra.Polynomial" "HOL-Computational_Algebra.Polynomial_Factorial" "Pure-ex.Guess"
begin

subsection \<open>Analysis\<close>

lemma fun_eq_in_ivl:
  assumes "a \<le> b" "\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> eventually (\<lambda>\<xi>. f \<xi> = f x) (at x)"
  shows "f a = f b"
proof (rule connected_local_const)
  show "connected {a..b}" "a \<in> {a..b}" "b \<in> {a..b}" using \<open>a \<le> b\<close> by (auto intro: connected_Icc)
  show "\<forall>aa\<in>{a..b}. eventually (\<lambda>b. f aa = f b) (at aa within {a..b})"
  proof
    fix x assume "x \<in> {a..b}"
    with assms(2)[rule_format, of x]
    show "eventually (\<lambda>b. f x = f b) (at x within {a..b})"
      by (auto simp: eventually_at_filter elim: eventually_mono)
  qed
qed

subsection \<open>Polynomials\<close>

subsubsection \<open>General simplification lemmas\<close>

lemma pderiv_div:
  assumes [simp]: "q dvd p" "q \<noteq> 0"
  shows "pderiv (p div q) = (q * pderiv p - p * pderiv q) div (q * q)"
        "q*q dvd (q * pderiv p - p * pderiv q)"
proof-
  from assms obtain r where "p = q * r" unfolding dvd_def by blast
  hence "q * pderiv p - p * pderiv q = (q * q) * pderiv r"
      by (simp add: algebra_simps pderiv_mult)
  thus "q*q dvd (q * pderiv p - p * pderiv q)" by simp
  note 0 = pderiv_mult[of q "p div q"]
  have 1: "q * (p div q) = p"
    by (metis assms(1) assms(2) dvd_def nonzero_mult_div_cancel_left)
  have f1: "pderiv (p div q) * (q * q) div (q * q) = pderiv (p div q)"
    by simp
  have f2: "pderiv p = q * pderiv (p div q) + p div q * pderiv q"
    by (metis 0 1)
  have "p * pderiv q = pderiv q * (q * (p div q))"
    by (metis 1 mult.commute)
  then have "p * pderiv q = q * (p div q * pderiv q)"
    by fastforce
  then have "q * pderiv p - p * pderiv q = q * (q * pderiv (p div q))"
    using f2 by (metis add_diff_cancel_right' distrib_left)
  then show "pderiv (p div q) = (q * pderiv p - p * pderiv q) div (q * q)"
    using f1 by (metis mult.commute mult.left_commute)
qed

subsubsection \<open>Divisibility of polynomials\<close>

text \<open>
  Two polynomials that are coprime have no common roots.
\<close>
lemma coprime_imp_no_common_roots:
  "\<not> (poly p x = 0 \<and> poly q x = 0)" if "coprime p q"
     for x :: "'a :: field"
proof clarify
  assume "poly p x = 0" "poly q x = 0"
  then have "[:-x, 1:] dvd p" "[:-x, 1:] dvd q"
    by (simp_all add: poly_eq_0_iff_dvd)
  with that have "is_unit [:-x, 1:]"
    by (rule coprime_common_divisor)
  then show False
    by (auto simp add: is_unit_pCons_iff)
qed

lemma poly_div:
  assumes "poly q x \<noteq> 0" and "(q::'a :: field poly) dvd p"
  shows "poly (p div q) x = poly p x / poly q x"
proof-
  from assms have [simp]: "q \<noteq> 0" by force
  have "poly q x * poly (p div q) x = poly (q * (p div q)) x" by simp
  also have "q * (p div q) = p"
      using assms by (simp add: div_mult_swap)
  finally show "poly (p div q) x = poly p x / poly q x"
      using assms by (simp add: field_simps)
qed

(* TODO: make this less ugly *)
lemma poly_div_gcd_squarefree_aux:
  assumes "pderiv (p::('a::{field_char_0,field_gcd}) poly) \<noteq> 0"
  defines "d \<equiv> gcd p (pderiv p)"
  shows "coprime (p div d) (pderiv (p div d))" and
        "\<And>x. poly (p div d) x = 0 \<longleftrightarrow> poly p x = 0"
proof -
  obtain r s where "bezout_coefficients p (pderiv p) = (r, s)"
    by (auto simp add: prod_eq_iff)
  then have "r * p + s * pderiv p = gcd p (pderiv p)"
    by (rule bezout_coefficients)
  then have rs: "d = r * p + s * pderiv p"
    by (simp add: d_def)
  define t where "t = p div d"
  define p' where [simp]: "p' = pderiv p"
  define d' where [simp]: "d' = pderiv d"
  define u where "u = p' div d"
  have A: "p = t * d" and B: "p' = u * d"
    by (simp_all add: t_def u_def d_def algebra_simps)
  from poly_squarefree_decomp[OF assms(1) A B[unfolded p'_def] rs]
    show "\<And>x. poly (p div d) x = 0 \<longleftrightarrow> poly p x = 0" by (auto simp: t_def)

  from rs have C: "s*t*d' = d * (1 - r*t - s*pderiv t)"
      by (simp add: A B algebra_simps pderiv_mult)
  from assms have [simp]: "p \<noteq> 0" "d \<noteq> 0" "t \<noteq> 0"
      by (force, force, subst (asm) A, force)

  have "\<And>x. \<lbrakk>x dvd t; x dvd (pderiv t)\<rbrakk> \<Longrightarrow> x dvd 1"
  proof -
    fix x assume "x dvd t" "x dvd (pderiv t)"
    then obtain v w where vw:
        "t = x*v" "pderiv t = x*w" unfolding dvd_def by blast
    define x' v' where [simp]: "x' = pderiv x" and [simp]: "v' = pderiv v"
    from vw have "x*v' + v*x' = x*w" by (simp add: pderiv_mult)
    hence "v*x' = x*(w - v')" by (simp add: algebra_simps)
    hence "x dvd v*pderiv x" by simp
    then obtain y where y: "v*x' = x*y" unfolding dvd_def by force
    from \<open>t \<noteq> 0\<close> and vw have "x \<noteq> 0" by simp

    have x_pow_n_dvd_d: "\<And>n. x^n dvd d"
    proof-
      fix n show "x ^ n dvd d"
      proof (induction n, simp, rename_tac n, case_tac n)
        fix n assume "n = (0::nat)"
        from vw and C have "d = x*(d*r*v + d*s*w + s*v*d')"
            by (simp add: algebra_simps)
        with \<open>n = 0\<close> show "x^Suc n dvd d" by (force intro: dvdI)
      next
        fix n n' assume IH: "x^n dvd d" and "n = Suc n'"
        hence [simp]: "Suc n' = n" "x * x^n' = x^n" by simp_all
        define c :: "'a poly" where "c = [:of_nat n:]"
        from pderiv_power_Suc[of x n']
            have [simp]: "pderiv (x^n) = c*x^n' * x'" unfolding c_def
            by simp

        from IH obtain z where d: "d = x^n * z" unfolding dvd_def by blast
        define z' where [simp]: "z' = pderiv z"
        from d \<open>d \<noteq> 0\<close> have "x^n \<noteq> 0" "z \<noteq> 0" by force+
        from C d have "x^n*z = z*r*v*x^Suc n + z*s*c*x^n*(v*x') +
                          s*v*z'*x^Suc n + s*z*(v*x')*x^n + s*z*v'*x^Suc n"
            by (simp add: algebra_simps vw pderiv_mult)
        also have "... = x^n*x * (z*r*v + z*s*c*y + s*v*z' + s*z*y + s*z*v')"
            by (simp only: y, simp add: algebra_simps)
        finally have "z = x*(z*r*v+z*s*c*y+s*v*z'+s*z*y+s*z*v')"
             using \<open>x^n \<noteq> 0\<close> by force
        hence "x dvd z" by (metis dvd_triv_left)
        with d show "x^Suc n dvd d" by simp
     qed
   qed

   have "degree x = 0"
   proof (cases "degree x", simp)
     case (Suc n)
       hence "x \<noteq> 0" by auto
       with Suc have "degree (x ^ (Suc (degree d))) > degree d"
           by (subst degree_power_eq, simp_all)
       moreover from x_pow_n_dvd_d[of "Suc (degree d)"] and \<open>d \<noteq> 0\<close>
           have "degree (x^Suc (degree d)) \<le> degree d"
                by (simp add: dvd_imp_degree_le)
       ultimately show ?thesis by simp
    qed
    then obtain c where [simp]: "x = [:c:]" by (cases x, simp split: if_split_asm)
    moreover from \<open>x \<noteq> 0\<close> have "c \<noteq> 0" by simp
    ultimately show "x dvd 1" using dvdI[of 1 x "[:inverse c:]"]
      by simp
  qed

  then show "coprime t (pderiv t)"
    by (rule coprimeI)
qed

lemma normalize_field:
  "normalize (x :: 'a :: {field,normalization_semidom}) = (if x = 0 then 0 else 1)"
  by (auto simp: is_unit_normalize dvd_field_iff)

lemma normalize_field_eq_1 [simp]:
  "x \<noteq> 0 \<Longrightarrow> normalize (x :: 'a :: {field,normalization_semidom}) = 1"
  by (simp add: normalize_field)

lemma unit_factor_field [simp]:
  "unit_factor (x :: 'a :: {field,normalization_semidom}) = x"
  by (cases "x = 0") (auto simp: is_unit_unit_factor dvd_field_iff)

text \<open>
  Dividing a polynomial by its gcd with its derivative yields
  a squarefree polynomial with the same roots.
\<close>
lemma poly_div_gcd_squarefree:
  assumes "(p :: ('a::{field_char_0,field_gcd}) poly) \<noteq> 0"
  defines "d \<equiv> gcd p (pderiv p)"
  shows "coprime (p div d) (pderiv (p div d))" (is ?A) and
        "\<And>x. poly (p div d) x = 0 \<longleftrightarrow> poly p x = 0" (is "\<And>x. ?B x")
proof-
  have "?A \<and> (\<forall>x. ?B x)"
  proof (cases "pderiv p = 0")
    case False
      from poly_div_gcd_squarefree_aux[OF this] show ?thesis
          unfolding d_def by auto
  next
    case True
      then obtain c where [simp]: "p = [:c:]" using pderiv_iszero by blast
      from assms(1) have "c \<noteq> 0" by simp
      from True have "d = smult (inverse c) p"
        by (simp add: d_def normalize_poly_def map_poly_pCons field_simps)
      with \<open>p \<noteq> 0\<close> \<open>c \<noteq> 0\<close> have "p div d = [:c:]"
        by (simp add: pCons_one)
      with \<open>c \<noteq> 0\<close> show ?thesis
        by (simp add: normalize_const_poly is_unit_triv)
  qed
  thus ?A and "\<And>x. ?B x" by simp_all
qed

subsubsection \<open>Sign changes of a polynomial\<close>

text \<open>
  If a polynomial has different signs at two points, it has a root inbetween.
\<close>
lemma poly_different_sign_imp_root:
  assumes "a < b" and "sgn (poly p a) \<noteq> sgn (poly p (b::real))"
  shows "\<exists>x. a \<le> x \<and> x \<le> b \<and> poly p x = 0"
proof (cases "poly p a = 0 \<or> poly p b = 0")
  case True
    thus ?thesis using assms(1)
        by (elim disjE, rule_tac exI[of _ a], simp,
                        rule_tac exI[of _ b], simp)
next
  case False
    hence [simp]: "poly p a \<noteq> 0" "poly p b \<noteq> 0" by simp_all
    show ?thesis
    proof (cases "poly p a < 0")
      case True
        hence "sgn (poly p a) = -1" by simp
        with assms True have "poly p b > 0"
            by (auto simp: sgn_real_def split: if_split_asm)
        from poly_IVT_pos[OF \<open>a < b\<close> True this] guess x ..
        thus ?thesis by (intro exI[of _ x], simp)
    next
      case False
        hence "poly p a > 0" by (simp add: not_less less_eq_real_def)
        hence "sgn (poly p a) = 1"  by simp
        with assms False have "poly p b < 0"
            by (auto simp: sgn_real_def not_less
                           less_eq_real_def split: if_split_asm)
        from poly_IVT_neg[OF \<open>a < b\<close> \<open>poly p a > 0\<close> this] guess x ..
        thus ?thesis by (intro exI[of _ x], simp)
    qed
qed

lemma poly_different_sign_imp_root':
  assumes "sgn (poly p a) \<noteq> sgn (poly p (b::real))"
  shows "\<exists>x. poly p x = 0"
using assms by (cases "a < b", auto dest!: poly_different_sign_imp_root
                                    simp: less_eq_real_def not_less)

lemma no_roots_inbetween_imp_same_sign:
  assumes "a < b" "\<forall>x. a \<le> x \<and> x \<le> b \<longrightarrow> poly p x \<noteq> (0::real)"
  shows "sgn (poly p a) = sgn (poly p b)"
  using poly_different_sign_imp_root assms by auto

subsubsection \<open>Limits of polynomials\<close>

lemma poly_neighbourhood_without_roots:
  assumes "(p :: real poly) \<noteq> 0"
  shows "eventually (\<lambda>x. poly p x \<noteq> 0) (at x\<^sub>0)"
proof-
  {
    fix \<epsilon> :: real assume "\<epsilon> > 0"
    have fin: "finite {x. \<bar>x-x\<^sub>0\<bar> < \<epsilon> \<and> x \<noteq> x\<^sub>0 \<and> poly p x = 0}"
        using poly_roots_finite[OF assms] by simp
    with \<open>\<epsilon> > 0\<close>have "\<exists>\<delta>>0. \<delta>\<le>\<epsilon> \<and> (\<forall>x. \<bar>x-x\<^sub>0\<bar> < \<delta> \<and> x \<noteq> x\<^sub>0 \<longrightarrow> poly p x \<noteq> 0)"
    proof (induction "card {x. \<bar>x-x\<^sub>0\<bar> < \<epsilon> \<and> x \<noteq> x\<^sub>0 \<and> poly p x = 0}"
           arbitrary: \<epsilon> rule: less_induct)
    case (less \<epsilon>)
    let ?A = "{x. \<bar>x - x\<^sub>0\<bar> < \<epsilon> \<and> x \<noteq> x\<^sub>0 \<and> poly p x = 0}"
    show ?case
      proof (cases "card ?A")
      case 0
        hence "?A = {}" using less by auto
        thus ?thesis using less(2) by (rule_tac exI[of _ \<epsilon>], auto)
      next
      case (Suc _)
        with less(3) have "{x. \<bar>x - x\<^sub>0\<bar> < \<epsilon> \<and> x \<noteq> x\<^sub>0 \<and> poly p x = 0} \<noteq> {}" by force
        then obtain x where x_props: "\<bar>x - x\<^sub>0\<bar> < \<epsilon>" "x \<noteq> x\<^sub>0" "poly p x = 0" by blast
        define \<epsilon>' where "\<epsilon>' = \<bar>x - x\<^sub>0\<bar> / 2"
        have "\<epsilon>' > 0" "\<epsilon>' < \<epsilon>" unfolding \<epsilon>'_def using x_props by simp_all
        from x_props(1,2) and \<open>\<epsilon> > 0\<close>
            have "x \<notin> {x'. \<bar>x' - x\<^sub>0\<bar> < \<epsilon>' \<and> x' \<noteq> x\<^sub>0 \<and> poly p x' = 0}" (is "_ \<notin> ?B")
            by (auto simp: \<epsilon>'_def)
        moreover from x_props
            have "x \<in> {x. \<bar>x - x\<^sub>0\<bar> < \<epsilon> \<and> x \<noteq> x\<^sub>0 \<and> poly p x = 0}" by blast
        ultimately have "?B \<subset> ?A" by auto
        hence "card ?B < card ?A" "finite ?B"
            by (rule psubset_card_mono[OF less(3)],
                blast intro: finite_subset[OF _ less(3)])
        from less(1)[OF this(1) \<open>\<epsilon>' > 0\<close> this(2)]
            show ?thesis using \<open>\<epsilon>' < \<epsilon>\<close> by force
      qed
    qed
  }
  from this[of "1"]
    show ?thesis by (auto simp: eventually_at dist_real_def)
qed

lemma poly_neighbourhood_same_sign:
  assumes "poly p (x\<^sub>0 :: real) \<noteq> 0"
  shows "eventually (\<lambda>x. sgn (poly p x) = sgn (poly p x\<^sub>0)) (at x\<^sub>0)"
proof -
  have cont: "isCont (\<lambda>x. sgn (poly p x)) x\<^sub>0"
      by (rule isCont_sgn, rule poly_isCont, rule assms)
  then have "eventually (\<lambda>x. \<bar>sgn (poly p x) - sgn (poly p x\<^sub>0)\<bar> < 1) (at x\<^sub>0)"
      by (auto simp: isCont_def tendsto_iff dist_real_def)
  then show ?thesis
    by (rule eventually_mono) (simp add: sgn_real_def split: if_split_asm)
qed

lemma poly_lhopital:
  assumes "poly p (x::real) = 0" "poly q x = 0" "q \<noteq> 0"
  assumes "(\<lambda>x. poly (pderiv p) x / poly (pderiv q) x) \<midarrow>x\<rightarrow> y"
  shows "(\<lambda>x. poly p x / poly q x) \<midarrow>x\<rightarrow> y"
using assms
proof (rule_tac lhopital)
  have "isCont (poly p) x" "isCont (poly q) x" by simp_all
  with assms(1,2) show "poly p \<midarrow>x\<rightarrow> 0" "poly q \<midarrow>x\<rightarrow> 0"
       by (simp_all add: isCont_def)
  from \<open>q \<noteq> 0\<close> and \<open>poly q x = 0\<close> have "pderiv q \<noteq> 0"
      by (auto dest: pderiv_iszero)
  from poly_neighbourhood_without_roots[OF this]
      show "eventually (\<lambda>x. poly (pderiv q) x \<noteq> 0) (at x)" .
qed (auto intro: poly_DERIV poly_neighbourhood_without_roots)

lemma poly_roots_bounds:
  assumes "p \<noteq> 0"
  obtains l u
  where "l \<le> (u :: real)"
    and "poly p l \<noteq> 0"
    and "poly p u \<noteq> 0"
    and "{x. x > l \<and> x \<le> u \<and> poly p x = 0 } = {x. poly p x = 0}"
    and "\<And>x. x \<le> l \<Longrightarrow> sgn (poly p x) = sgn (poly p l)"
    and "\<And>x. x \<ge> u \<Longrightarrow> sgn (poly p x) = sgn (poly p u)"
proof
  from assms have "finite {x. poly p x = 0}" (is "finite ?roots")
      using poly_roots_finite by fast
  let ?roots' = "insert 0 ?roots"

  define l where "l = Min ?roots' - 1"
  define u where "u = Max ?roots' + 1"

  from \<open>finite ?roots\<close> have A: "finite ?roots'"  by auto
  from Min_le[OF this, of 0] and Max_ge[OF this, of 0]
      show "l \<le>  u" by (simp add: l_def u_def)
  from Min_le[OF A] have l_props: "\<And>x. x\<le>l \<Longrightarrow> poly p x \<noteq> 0"
      by (fastforce simp: l_def)
  from Max_ge[OF A] have u_props: "\<And>x. x\<ge>u \<Longrightarrow> poly p x \<noteq> 0"
      by (fastforce simp: u_def)
  from l_props u_props show [simp]: "poly p l \<noteq> 0" "poly p u \<noteq> 0" by auto

  from l_props have "\<And>x. poly p x = 0 \<Longrightarrow> x > l" by (metis not_le)
  moreover from u_props have "\<And>x. poly p x = 0 \<Longrightarrow> x \<le> u" by (metis linear)
  ultimately show "{x. x > l \<and> x \<le> u \<and> poly p x = 0} = ?roots" by auto

  {
    fix x assume A: "x < l" "sgn (poly p x) \<noteq> sgn (poly p l)"
    with poly_IVT_pos[OF A(1), of p] poly_IVT_neg[OF A(1), of p] A(2)
        have False by (auto split: if_split_asm
                         simp: sgn_real_def l_props not_less less_eq_real_def)
  }
  thus "\<And>x. x \<le> l \<Longrightarrow> sgn (poly p x) = sgn (poly p l)"
      by (case_tac "x = l", auto simp: less_eq_real_def)

  {
    fix x assume A: "x > u" "sgn (poly p x) \<noteq> sgn (poly p u)"
    with u_props poly_IVT_neg[OF A(1), of p] poly_IVT_pos[OF A(1), of p] A(2)
        have False by (auto split: if_split_asm
                         simp: sgn_real_def l_props not_less less_eq_real_def)
  }
  thus "\<And>x. x \<ge> u \<Longrightarrow> sgn (poly p x) = sgn (poly p u)"
      by (case_tac "x = u", auto simp: less_eq_real_def)
qed

definition poly_inf :: "('a::real_normed_vector) poly \<Rightarrow> 'a" where
  "poly_inf p \<equiv> sgn (coeff p (degree p))"
definition poly_neg_inf :: "('a::real_normed_vector) poly \<Rightarrow> 'a" where
  "poly_neg_inf p \<equiv> if even (degree p) then sgn (coeff p (degree p))
                                       else -sgn (coeff p (degree p))"
lemma poly_inf_0_iff[simp]:
    "poly_inf p = 0 \<longleftrightarrow> p = 0" "poly_neg_inf p = 0 \<longleftrightarrow> p = 0"
    by (auto simp: poly_inf_def poly_neg_inf_def sgn_zero_iff)

lemma poly_inf_mult[simp]:
  fixes p :: "('a::real_normed_field) poly"
  shows "poly_inf (p*q) = poly_inf p * poly_inf q"
        "poly_neg_inf (p*q) = poly_neg_inf p * poly_neg_inf q"
unfolding poly_inf_def poly_neg_inf_def
by ((cases "p = 0 \<or> q = 0",auto simp: sgn_zero_iff
         degree_mult_eq[of p q] coeff_mult_degree_sum Real_Vector_Spaces.sgn_mult)[])+

lemma poly_neq_0_at_infinity:
  assumes "(p :: real poly) \<noteq> 0"
  shows "eventually (\<lambda>x. poly p x \<noteq> 0) at_infinity"
proof-
  from poly_roots_bounds[OF assms] guess l u .
  note lu_props = this
  define b where "b = max (-l) u"
  show ?thesis
  proof (subst eventually_at_infinity, rule exI[of _ b], clarsimp)
    fix x assume A: "\<bar>x\<bar> \<ge> b" and B: "poly p x = 0"
    show False
    proof (cases "x \<ge> 0")
      case True
        with A have "x \<ge> u" unfolding b_def by simp
        with lu_props(3, 6) show False by (metis sgn_zero_iff B)
    next
      case False
        with A have "x \<le> l" unfolding b_def by simp
        with lu_props(2, 5) show False by (metis sgn_zero_iff B)
    qed
  qed
qed

lemma poly_limit_aux:
  fixes p :: "real poly"
  defines "n \<equiv> degree p"
  shows "((\<lambda>x. poly p x / x ^ n) \<longlongrightarrow> coeff p n) at_infinity"
proof (subst filterlim_cong, rule refl, rule refl)
  show "eventually (\<lambda>x. poly p x / x^n = (\<Sum>i\<le>n. coeff p i / x^(n-i)))
            at_infinity"
  proof (rule eventually_mono)
    show "eventually (\<lambda>x::real. x \<noteq> 0) at_infinity"
        by (simp add: eventually_at_infinity, rule exI[of _ 1], auto)
    fix x :: real assume [simp]: "x \<noteq> 0"
    show "poly p x / x ^ n = (\<Sum>i\<le>n. coeff p i / x ^ (n - i))"
        by (simp add: n_def sum_divide_distrib power_diff poly_altdef)
  qed

  let ?a = "\<lambda>i. if i = n then coeff p n else 0"
  have "\<forall>i\<in>{..n}. ((\<lambda>x. coeff p i / x ^ (n - i)) \<longlongrightarrow> ?a i) at_infinity"
  proof
    fix i assume "i \<in> {..n}"
    hence "i \<le> n" by simp
    show "((\<lambda>x. coeff p i / x ^ (n - i)) \<longlongrightarrow> ?a i) at_infinity"
    proof (cases "i = n")
      case True
        thus ?thesis by (intro tendstoI, subst eventually_at_infinity,
                         intro exI[of _ 1], simp add: dist_real_def)
    next
      case False
        hence "n - i > 0" using \<open>i \<le> n\<close> by simp
        from tendsto_inverse_0 and divide_real_def[of 1]
            have "((\<lambda>x. 1 / x :: real) \<longlongrightarrow> 0) at_infinity" by simp
        from tendsto_power[OF this, of "n - i"]
            have "((\<lambda>x::real. 1 / x ^ (n - i)) \<longlongrightarrow> 0) at_infinity"
                using \<open>n - i > 0\<close> by (simp add: power_0_left power_one_over)
        from tendsto_mult_right_zero[OF this, of "coeff p i"]
            have "((\<lambda>x. coeff p i / x ^ (n - i)) \<longlongrightarrow> 0) at_infinity"
                by (simp add: field_simps)
        thus ?thesis using False by simp
    qed
  qed
  hence "((\<lambda>x. \<Sum>i\<le>n. coeff p i / x^(n-i)) \<longlongrightarrow> (\<Sum>i\<le>n. ?a i)) at_infinity"
    by (force intro!: tendsto_sum)
  also have "(\<Sum>i\<le>n. ?a i) = coeff p n" by (subst sum.delta, simp_all)
  finally show "((\<lambda>x. \<Sum>i\<le>n. coeff p i / x^(n-i)) \<longlongrightarrow> coeff p n) at_infinity" .
qed

lemma poly_at_top_at_top:
  fixes p :: "real poly"
  assumes "degree p \<ge> 1" "coeff p (degree p) > 0"
  shows "LIM x at_top. poly p x :> at_top"
proof-
  let ?n = "degree p"
  define f g where "f x = poly p x / x^?n" and "g x = x ^ ?n" for x :: real

  from poly_limit_aux have "(f \<longlongrightarrow> coeff p (degree p)) at_top"
      using tendsto_mono at_top_le_at_infinity unfolding f_def by blast
  moreover from assms
      have "LIM x at_top. g x :> at_top"
        by (auto simp add: g_def intro!: filterlim_pow_at_top filterlim_ident)
  ultimately have "LIM x at_top. f x * g x :> at_top"
      using filterlim_tendsto_pos_mult_at_top assms by simp
  also have "eventually (\<lambda>x. f x * g x = poly p x) at_top"
      unfolding f_def g_def
      by (subst eventually_at_top_linorder, rule exI[of _ 1],
          simp add: poly_altdef field_simps sum_distrib_left power_diff)
  note filterlim_cong[OF refl refl this]
  finally show ?thesis .
qed

lemma poly_at_bot_at_top:
  fixes p :: "real poly"
  assumes "degree p \<ge> 1" "coeff p (degree p) < 0"
  shows "LIM x at_top. poly p x :> at_bot"
proof-
  from poly_at_top_at_top[of "-p"] and assms
      have "LIM x at_top. -poly p x :> at_top" by simp
  thus ?thesis by (simp add: filterlim_uminus_at_bot)
qed

lemma poly_lim_inf:
  "eventually (\<lambda>x::real. sgn (poly p x) = poly_inf p) at_top"
proof (cases "degree p \<ge> 1")
  case False
    hence "degree p = 0" by simp
    then obtain c where "p = [:c:]" by (cases p, auto split: if_split_asm)
    thus ?thesis
        by (simp add: eventually_at_top_linorder poly_inf_def)
next
  case True
    note deg = this
    let ?lc = "coeff p (degree p)"
    from True have "?lc \<noteq> 0" by force
    show ?thesis
    proof (cases "?lc > 0")
      case True
        from poly_at_top_at_top[OF deg this]
          obtain x\<^sub>0 where "\<And>x. x \<ge> x\<^sub>0 \<Longrightarrow> poly p x \<ge> 1"
              by (fastforce simp: filterlim_at_top
                      eventually_at_top_linorder less_eq_real_def)
        hence "\<And>x. x \<ge> x\<^sub>0 \<Longrightarrow> sgn (poly p x) = 1" by force
        thus ?thesis by (simp only: eventually_at_top_linorder poly_inf_def,
                             intro exI[of _ x\<^sub>0], simp add: True)
    next
      case False
        hence "?lc < 0" using \<open>?lc \<noteq> 0\<close> by linarith
        from poly_at_bot_at_top[OF deg this]
          obtain x\<^sub>0 where "\<And>x. x \<ge> x\<^sub>0 \<Longrightarrow> poly p x \<le> -1"
              by (fastforce simp: filterlim_at_bot
                      eventually_at_top_linorder less_eq_real_def)
        hence "\<And>x. x \<ge> x\<^sub>0 \<Longrightarrow> sgn (poly p x) = -1" by force
        thus ?thesis by (simp only: eventually_at_top_linorder poly_inf_def,
                             intro exI[of _ x\<^sub>0], simp add: \<open>?lc < 0\<close>)
    qed
qed

lemma poly_at_top_or_bot_at_bot:
  fixes p :: "real poly"
  assumes "degree p \<ge> 1" "coeff p (degree p) > 0"
  shows "LIM x at_bot. poly p x :> (if even (degree p) then at_top else at_bot)"
proof-
  let ?n = "degree p"
  define f g where "f x = poly p x / x ^ ?n" and "g x = x ^ ?n" for x :: real

  from poly_limit_aux have "(f \<longlongrightarrow> coeff p (degree p)) at_bot"
      using tendsto_mono at_bot_le_at_infinity by (force simp: f_def [abs_def])
  moreover from assms
      have "LIM x at_bot. g x :> (if even (degree p) then at_top else at_bot)"
        by (auto simp add: g_def split: if_split_asm intro: filterlim_pow_at_bot_even filterlim_pow_at_bot_odd filterlim_ident)
  ultimately have "LIM x at_bot. f x * g x :>
                      (if even ?n then at_top else at_bot)"
      by (auto simp: assms intro: filterlim_tendsto_pos_mult_at_top
                                  filterlim_tendsto_pos_mult_at_bot)
  also have "eventually (\<lambda>x. f x * g x = poly p x) at_bot"
      unfolding f_def g_def
      by (subst eventually_at_bot_linorder, rule exI[of _ "-1"],
          simp add: poly_altdef field_simps sum_distrib_left power_diff)
  note filterlim_cong[OF refl refl this]
  finally show ?thesis .
qed

lemma poly_at_bot_or_top_at_bot:
  fixes p :: "real poly"
  assumes "degree p \<ge> 1" "coeff p (degree p) < 0"
  shows "LIM x at_bot. poly p x :> (if even (degree p) then at_bot else at_top)"
proof-
  from poly_at_top_or_bot_at_bot[of "-p"] and assms
      have "LIM x at_bot. -poly p x :>
                (if even (degree p) then at_top else at_bot)" by simp
  thus ?thesis by (auto simp: filterlim_uminus_at_bot)
qed

lemma poly_lim_neg_inf:
  "eventually (\<lambda>x::real. sgn (poly p x) = poly_neg_inf p) at_bot"
proof (cases "degree p \<ge> 1")
  case False
    hence "degree p = 0" by simp
    then obtain c where "p = [:c:]" by (cases p, auto split: if_split_asm)
    thus ?thesis
        by (simp add: eventually_at_bot_linorder poly_neg_inf_def)
next
  case True
    note deg = this
    let ?lc = "coeff p (degree p)"
    from True have "?lc \<noteq> 0" by force
    show ?thesis
    proof (cases "?lc > 0")
      case True
        note lc_pos = this
        show ?thesis
        proof (cases "even (degree p)")
          case True
            from poly_at_top_or_bot_at_bot[OF deg lc_pos] and True
              obtain x\<^sub>0 where "\<And>x. x \<le> x\<^sub>0 \<Longrightarrow> poly p x \<ge> 1"
                by (fastforce simp add: filterlim_at_top filterlim_at_bot
                        eventually_at_bot_linorder less_eq_real_def)
                hence "\<And>x. x \<le> x\<^sub>0 \<Longrightarrow> sgn (poly p x) = 1" by force
              thus ?thesis
                by (simp add: True eventually_at_bot_linorder poly_neg_inf_def,
                    intro exI[of _ x\<^sub>0], simp add: lc_pos)
       next
          case False
            from poly_at_top_or_bot_at_bot[OF deg lc_pos] and False
              obtain x\<^sub>0 where "\<And>x. x \<le> x\<^sub>0 \<Longrightarrow> poly p x \<le> -1"
                by (fastforce simp add: filterlim_at_bot
                        eventually_at_bot_linorder less_eq_real_def)
                hence "\<And>x. x \<le> x\<^sub>0 \<Longrightarrow> sgn (poly p x) = -1" by force
              thus ?thesis
                by (simp add: False eventually_at_bot_linorder poly_neg_inf_def,
                              intro exI[of _ x\<^sub>0], simp add: lc_pos)
      qed
    next
      case False
        hence lc_neg: "?lc < 0" using \<open>?lc \<noteq> 0\<close> by linarith
        show ?thesis
        proof (cases "even (degree p)")
          case True
            with poly_at_bot_or_top_at_bot[OF deg lc_neg]
              obtain x\<^sub>0 where "\<And>x. x \<le> x\<^sub>0 \<Longrightarrow> poly p x \<le> -1"
                  by (fastforce simp: filterlim_at_bot
                          eventually_at_bot_linorder less_eq_real_def)
              hence "\<And>x. x \<le> x\<^sub>0 \<Longrightarrow> sgn (poly p x) = -1" by force
              thus ?thesis
                by (simp only: True eventually_at_bot_linorder poly_neg_inf_def,
                               intro exI[of _ x\<^sub>0], simp add: lc_neg)
        next
          case False
            with poly_at_bot_or_top_at_bot[OF deg lc_neg]
              obtain x\<^sub>0 where "\<And>x. x \<le> x\<^sub>0 \<Longrightarrow> poly p x \<ge> 1"
                  by (fastforce simp: filterlim_at_top
                          eventually_at_bot_linorder less_eq_real_def)
              hence "\<And>x. x \<le> x\<^sub>0 \<Longrightarrow> sgn (poly p x) = 1" by force
              thus ?thesis
                by (simp only: False eventually_at_bot_linorder poly_neg_inf_def,
                               intro exI[of _ x\<^sub>0], simp add: lc_neg)
        qed
    qed
qed

subsubsection \<open>Signs of polynomials for sufficiently large values\<close>

lemma polys_inf_sign_thresholds:
  assumes "finite (ps :: real poly set)"
  obtains l u
  where "l \<le> u"
    and "\<And>p. \<lbrakk>p \<in> ps; p \<noteq> 0\<rbrakk> \<Longrightarrow>
              {x. l < x \<and> x \<le> u \<and> poly p x = 0} = {x. poly p x = 0}"
    and "\<And>p x. \<lbrakk>p \<in> ps; x \<ge> u\<rbrakk> \<Longrightarrow> sgn (poly p x) = poly_inf p"
    and "\<And>p x. \<lbrakk>p \<in> ps; x \<le> l\<rbrakk> \<Longrightarrow> sgn (poly p x) = poly_neg_inf p"
proof goal_cases
  case prems: 1
  have "\<exists>l u. l \<le> u \<and> (\<forall>p x. p \<in> ps \<and> x \<ge> u \<longrightarrow> sgn (poly p x) = poly_inf p) \<and>
              (\<forall>p x. p \<in> ps \<and> x \<le> l \<longrightarrow> sgn (poly p x) = poly_neg_inf p)"
      (is "\<exists>l u. ?P ps l u")
  proof (induction rule: finite_subset_induct[OF assms(1), where A = UNIV])
    case 1
      show ?case by simp
  next
    case 2
      show ?case by (intro exI[of _ 42], simp)
  next
    case prems: (3 p ps)
      from prems(4) obtain l u where lu_props: "?P ps l u" by blast
      from poly_lim_inf obtain u'
          where u'_props: "\<forall>x\<ge>u'. sgn (poly p x) = poly_inf p"
          by (force simp add: eventually_at_top_linorder)
      from poly_lim_neg_inf obtain l'
          where l'_props: "\<forall>x\<le>l'. sgn (poly p x) = poly_neg_inf p"
          by (force simp add: eventually_at_bot_linorder)
      show ?case
          by (rule exI[of _ "min l l'"], rule exI[of _ "max u u'"],
              insert lu_props l'_props u'_props, auto)
  qed
  then obtain l u where lu_props: "l \<le> u"
        "\<And>p x. p \<in> ps \<Longrightarrow> u \<le> x \<Longrightarrow> sgn (poly p x) = poly_inf p"
        "\<And>p x. p \<in> ps \<Longrightarrow> x \<le> l \<Longrightarrow> sgn (poly p x) = poly_neg_inf p" by blast
  moreover {
    fix p x assume A: "p \<in> ps" "p \<noteq> 0" "poly p x = 0"
    from A have "l < x" "x < u"
        by (auto simp: not_le[symmetric] dest: lu_props(2,3))
  }
  note A = this
  have "\<And>p. p \<in> ps \<Longrightarrow> p \<noteq> 0 \<Longrightarrow>
                 {x. l < x \<and> x \<le> u \<and> poly p x = 0} = {x. poly p x = 0}"
      by (auto dest: A)

  from prems[OF lu_props(1) this lu_props(2,3)] show thesis .
qed

subsubsection \<open>Positivity of polynomials\<close>

lemma poly_pos:
  "(\<forall>x::real. poly p x > 0) \<longleftrightarrow> poly_inf p = 1 \<and> (\<forall>x. poly p x \<noteq> 0)"
proof (intro iffI conjI)
  assume A: "\<forall>x::real. poly p x > 0"
  have "\<And>x. poly p (x::real) > 0 \<Longrightarrow> poly p x \<noteq> 0" by simp
  with A show "\<forall>x::real. poly p x \<noteq> 0" by simp

  from poly_lim_inf obtain x where "sgn (poly p x) = poly_inf p"
      by (auto simp: eventually_at_top_linorder)
  with A show "poly_inf p = 1"
      by (simp add: sgn_real_def split: if_split_asm)
next
  assume "poly_inf p = 1 \<and> (\<forall>x. poly p x \<noteq> 0)"
  hence A: "poly_inf p = 1" and B: "(\<forall>x. poly p x \<noteq> 0)" by simp_all
  from poly_lim_inf obtain x where C: "sgn (poly p x) = poly_inf p"
      by (auto simp: eventually_at_top_linorder)
  show "\<forall>x. poly p x > 0"
  proof (rule ccontr)
    assume "\<not>(\<forall>x. poly p x > 0)"
    then obtain x' where "poly p x' \<le> 0" by (auto simp: not_less)
    with A and C have "sgn (poly p x') \<noteq> sgn (poly p x)"
        by (auto simp: sgn_real_def split: if_split_asm)
    from poly_different_sign_imp_root'[OF this] and B
        show False by blast
  qed
qed

lemma poly_pos_greater:
  "(\<forall>x::real. x > a \<longrightarrow> poly p x > 0) \<longleftrightarrow>
    poly_inf p = 1 \<and> (\<forall>x. x > a \<longrightarrow> poly p x \<noteq> 0)"
proof (intro iffI conjI)
  assume A: "\<forall>x::real. x > a \<longrightarrow> poly p x > 0"
  have "\<And>x. poly p (x::real) > 0 \<Longrightarrow> poly p x \<noteq> 0" by simp
  with A show "\<forall>x::real. x > a \<longrightarrow> poly p x \<noteq> 0" by auto

  from poly_lim_inf obtain x\<^sub>0 where
      "\<forall>x\<ge>x\<^sub>0. sgn (poly p x) = poly_inf p"
      by (auto simp: eventually_at_top_linorder)
  hence "poly_inf p = sgn (poly p (max x\<^sub>0 (a + 1)))" by simp
  also from A have "... = 1" by force
  finally show "poly_inf p = 1" .
next
  assume "poly_inf p = 1 \<and> (\<forall>x. x > a \<longrightarrow> poly p x \<noteq> 0)"
  hence A: "poly_inf p = 1" and
        B: "(\<forall>x. x > a \<longrightarrow> poly p x \<noteq> 0)" by simp_all
  from poly_lim_inf obtain x\<^sub>0 where
      C: "\<forall>x\<ge>x\<^sub>0. sgn (poly p x) = poly_inf p"
      by (auto simp: eventually_at_top_linorder)
  hence "sgn (poly p (max x\<^sub>0 (a+1))) = poly_inf p" by simp
  with A have D: "sgn (poly p (max x\<^sub>0 (a+1))) = 1" by simp
  show "\<forall>x. x > a \<longrightarrow> poly p x > 0"
  proof (rule ccontr)
    assume "\<not>(\<forall>x. x > a \<longrightarrow> poly p x > 0)"
    then obtain x' where "x' > a" "poly p x' \<le> 0" by (auto simp: not_less)
    with A and D have E: "sgn (poly p x') \<noteq> sgn (poly p (max x\<^sub>0(a+1)))"
        by (auto simp: sgn_real_def split: if_split_asm)
    show False
        apply (cases x' "max x\<^sub>0 (a+1)" rule: linorder_cases)
        using B E \<open>x' > a\<close>
            apply (force dest!: poly_different_sign_imp_root[of _ _ p])+
        done
  qed
qed

lemma poly_pos_geq:
  "(\<forall>x::real. x \<ge> a \<longrightarrow> poly p x > 0) \<longleftrightarrow>
    poly_inf p = 1 \<and> (\<forall>x. x \<ge> a \<longrightarrow> poly p x \<noteq> 0)"
proof (intro iffI conjI)
  assume A: "\<forall>x::real. x \<ge> a \<longrightarrow> poly p x > 0"
  hence "\<forall>x::real. x > a \<longrightarrow> poly p x > 0" by simp
  also note poly_pos_greater
  finally have "poly_inf p = 1" "(\<forall>x>a. poly p x \<noteq> 0)" by simp_all
  moreover from A have "poly p a > 0" by simp
  ultimately show "poly_inf p = 1" "\<forall>x\<ge>a. poly p x \<noteq> 0"
      by (auto simp: less_eq_real_def)
next
  assume "poly_inf p = 1 \<and> (\<forall>x. x \<ge> a \<longrightarrow> poly p x \<noteq> 0)"
  hence A: "poly_inf p = 1" and
        B: "poly p a \<noteq> 0" and C: "\<forall>x>a. poly p x \<noteq> 0" by simp_all
  from A and C and poly_pos_greater have "\<forall>x>a. poly p x > 0" by simp
  moreover with B C poly_IVT_pos[of a "a+1" p] have "poly p a > 0" by force
  ultimately show "\<forall>x\<ge>a. poly p x > 0" by (auto simp: less_eq_real_def)
qed

lemma poly_pos_less:
  "(\<forall>x::real. x < a \<longrightarrow> poly p x > 0) \<longleftrightarrow>
    poly_neg_inf p = 1 \<and> (\<forall>x. x < a \<longrightarrow> poly p x \<noteq> 0)"
proof (intro iffI conjI)
  assume A: "\<forall>x::real. x < a \<longrightarrow> poly p x > 0"
  have "\<And>x. poly p (x::real) > 0 \<Longrightarrow> poly p x \<noteq> 0" by simp
  with A show "\<forall>x::real. x < a \<longrightarrow> poly p x \<noteq> 0" by auto

  from poly_lim_neg_inf obtain x\<^sub>0 where
      "\<forall>x\<le>x\<^sub>0. sgn (poly p x) = poly_neg_inf p"
      by (auto simp: eventually_at_bot_linorder)
  hence "poly_neg_inf p = sgn (poly p (min x\<^sub>0 (a - 1)))" by simp
  also from A have "... = 1" by force
  finally show "poly_neg_inf p = 1" .
next
  assume "poly_neg_inf p = 1 \<and> (\<forall>x. x < a \<longrightarrow> poly p x \<noteq> 0)"
  hence A: "poly_neg_inf p = 1" and
        B: "(\<forall>x. x < a \<longrightarrow> poly p x \<noteq> 0)" by simp_all
  from poly_lim_neg_inf obtain x\<^sub>0 where
      C: "\<forall>x\<le>x\<^sub>0. sgn (poly p x) = poly_neg_inf p"
      by (auto simp: eventually_at_bot_linorder)
  hence "sgn (poly p (min x\<^sub>0 (a - 1))) = poly_neg_inf p" by simp
  with A have D: "sgn (poly p (min x\<^sub>0 (a - 1))) = 1" by simp
  show "\<forall>x. x < a \<longrightarrow> poly p x > 0"
  proof (rule ccontr)
    assume "\<not>(\<forall>x. x < a \<longrightarrow> poly p x > 0)"
    then obtain x' where "x' < a" "poly p x' \<le> 0" by (auto simp: not_less)
    with A and D have E: "sgn (poly p x') \<noteq> sgn (poly p (min x\<^sub>0 (a - 1)))"
        by (auto simp: sgn_real_def split: if_split_asm)
    show False
        apply (cases x' "min x\<^sub>0 (a - 1)" rule: linorder_cases)
        using B E \<open>x' < a\<close>
            apply (auto dest!: poly_different_sign_imp_root[of _ _ p])+
        done
  qed
qed

lemma poly_pos_leq:
  "(\<forall>x::real. x \<le> a \<longrightarrow> poly p x > 0) \<longleftrightarrow>
    poly_neg_inf p = 1 \<and> (\<forall>x. x \<le> a \<longrightarrow> poly p x \<noteq> 0)"
proof (intro iffI conjI)
  assume A: "\<forall>x::real. x \<le> a \<longrightarrow> poly p x > 0"
  hence "\<forall>x::real. x < a \<longrightarrow> poly p x > 0" by simp
  also note poly_pos_less
  finally have "poly_neg_inf p = 1" "(\<forall>x<a. poly p x \<noteq> 0)" by simp_all
  moreover from A have "poly p a > 0" by simp
  ultimately show "poly_neg_inf p = 1" "\<forall>x\<le>a. poly p x \<noteq> 0"
      by (auto simp: less_eq_real_def)
next
  assume "poly_neg_inf p = 1 \<and> (\<forall>x. x \<le> a \<longrightarrow> poly p x \<noteq> 0)"
  hence A: "poly_neg_inf p = 1" and
        B: "poly p a \<noteq> 0" and C: "\<forall>x<a. poly p x \<noteq> 0" by simp_all
  from A and C and poly_pos_less have "\<forall>x<a. poly p x > 0" by simp
  moreover with B C poly_IVT_neg[of "a - 1" a p] have "poly p a > 0" by force
  ultimately show "\<forall>x\<le>a. poly p x > 0" by (auto simp: less_eq_real_def)
qed

lemma poly_pos_between_less_less:
  "(\<forall>x::real. a < x \<and> x < b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
    (a \<ge> b \<or> poly p ((a+b)/2) > 0) \<and> (\<forall>x. a < x \<and> x < b \<longrightarrow> poly p x \<noteq> 0)"
proof (intro iffI conjI)
  assume A: "\<forall>x. a < x \<and> x < b \<longrightarrow> poly p x > 0"
  have "\<And>x. poly p (x::real) > 0 \<Longrightarrow> poly p x \<noteq> 0" by simp
  with A show "\<forall>x::real. a < x \<and> x < b \<longrightarrow> poly p x \<noteq> 0" by auto
  from A show "a \<ge> b \<or> poly p ((a+b)/2) > 0" by (cases "a < b", auto)
next
  assume "(b \<le> a \<or> 0 < poly p ((a+b)/2)) \<and> (\<forall>x. a<x \<and> x<b \<longrightarrow> poly p x \<noteq> 0)"
  hence A: "b \<le> a \<or> 0 < poly p ((a+b)/2)" and
        B: "\<forall>x. a<x \<and> x<b \<longrightarrow> poly p x \<noteq> 0" by simp_all
  show "\<forall>x. a < x \<and> x < b \<longrightarrow> poly p x > 0"
  proof (cases "a \<ge> b", simp, clarify, rule_tac ccontr,
         simp only: not_le not_less)
    fix x assume "a < b" "a < x" "x < b" "poly p x \<le> 0"
    with B have "poly p x < 0" by (simp add: less_eq_real_def)
    moreover from A and \<open>a < b\<close> have "poly p ((a+b)/2) > 0" by simp
    ultimately have "sgn (poly p x) \<noteq> sgn (poly p ((a+b)/2))" by simp
    thus False using B
       apply (cases x "(a+b)/2" rule: linorder_cases)
       apply (drule poly_different_sign_imp_root[of _ _ p], assumption,
              insert \<open>a < b\<close> \<open>a < x\<close> \<open>x < b\<close> , force) []
       apply simp
       apply (drule poly_different_sign_imp_root[of _ _ p], simp,
              insert \<open>a < b\<close> \<open>a < x\<close> \<open>x < b\<close> , force)
       done
  qed
qed

lemma poly_pos_between_less_leq:
  "(\<forall>x::real. a < x \<and> x \<le> b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
    (a \<ge> b \<or> poly p b > 0) \<and> (\<forall>x. a < x \<and> x \<le> b \<longrightarrow> poly p x \<noteq> 0)"
proof (intro iffI conjI)
  assume A: "\<forall>x. a < x \<and> x \<le> b \<longrightarrow> poly p x > 0"
  have "\<And>x. poly p (x::real) > 0 \<Longrightarrow> poly p x \<noteq> 0" by simp
  with A show "\<forall>x::real. a < x \<and> x \<le> b \<longrightarrow> poly p x \<noteq> 0" by auto
  from A show "a \<ge> b \<or> poly p b > 0" by (cases "a < b", auto)
next
  assume "(b \<le> a \<or> 0 < poly p b) \<and> (\<forall>x. a<x \<and> x\<le>b \<longrightarrow> poly p x \<noteq> 0)"
  hence A: "b \<le> a \<or> 0 < poly p b" and B: "\<forall>x. a<x \<and> x\<le>b \<longrightarrow> poly p x \<noteq> 0"
      by simp_all
  show "\<forall>x. a < x \<and> x \<le> b \<longrightarrow> poly p x > 0"
  proof (cases "a \<ge> b", simp, clarify, rule_tac ccontr,
         simp only: not_le not_less)
    fix x assume "a < b" "a < x" "x \<le> b" "poly p x \<le> 0"
    with B have "poly p x < 0" by (simp add: less_eq_real_def)
    moreover from A and \<open>a < b\<close> have "poly p b > 0" by simp
    ultimately have "x < b" using \<open>x \<le> b\<close> by (auto simp: less_eq_real_def)
    from \<open>poly p x < 0\<close> and \<open>poly p b > 0\<close>
        have "sgn (poly p x) \<noteq> sgn (poly p b)" by simp
    from poly_different_sign_imp_root[OF \<open>x < b\<close> this] and B and \<open>x > a\<close>
        show False by auto
  qed
qed

lemma poly_pos_between_leq_less:
  "(\<forall>x::real. a \<le> x \<and> x < b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
    (a \<ge> b \<or> poly p a > 0) \<and> (\<forall>x. a \<le> x \<and> x < b \<longrightarrow> poly p x \<noteq> 0)"
proof (intro iffI conjI)
  assume A: "\<forall>x. a \<le> x \<and> x < b \<longrightarrow> poly p x > 0"
  have "\<And>x. poly p (x::real) > 0 \<Longrightarrow> poly p x \<noteq> 0" by simp
  with A show "\<forall>x::real. a \<le> x \<and> x < b \<longrightarrow> poly p x \<noteq> 0" by auto
  from A show "a \<ge> b \<or> poly p a > 0" by (cases "a < b", auto)
next
  assume "(b \<le> a \<or> 0 < poly p a) \<and> (\<forall>x. a\<le>x \<and> x<b \<longrightarrow> poly p x \<noteq> 0)"
  hence A: "b \<le> a \<or> 0 < poly p a" and B: "\<forall>x. a\<le>x \<and> x<b \<longrightarrow> poly p x \<noteq> 0"
      by simp_all
  show "\<forall>x. a \<le> x \<and> x < b \<longrightarrow> poly p x > 0"
  proof (cases "a \<ge> b", simp, clarify, rule_tac ccontr,
         simp only: not_le not_less)
    fix x assume "a < b" "a \<le> x" "x < b" "poly p x \<le> 0"
    with B have "poly p x < 0" by (simp add: less_eq_real_def)
    moreover from A and \<open>a < b\<close> have "poly p a > 0" by simp
    ultimately have "x > a" using \<open>x \<ge> a\<close> by (auto simp: less_eq_real_def)
    from \<open>poly p x < 0\<close> and \<open>poly p a > 0\<close>
        have "sgn (poly p a) \<noteq> sgn (poly p x)" by simp
    from poly_different_sign_imp_root[OF \<open>x > a\<close> this] and B and \<open>x < b\<close>
        show False by auto
  qed
qed

lemma poly_pos_between_leq_leq:
  "(\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
    (a > b \<or> poly p a > 0) \<and> (\<forall>x. a \<le> x \<and> x \<le> b \<longrightarrow> poly p x \<noteq> 0)"
proof (intro iffI conjI)
  assume A: "\<forall>x. a \<le> x \<and> x \<le> b \<longrightarrow> poly p x > 0"
  have "\<And>x. poly p (x::real) > 0 \<Longrightarrow> poly p x \<noteq> 0" by simp
  with A show "\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> poly p x \<noteq> 0" by auto
  from A show "a > b \<or> poly p a > 0" by (cases "a \<le> b", auto)
next
  assume "(b < a \<or> 0 < poly p a) \<and> (\<forall>x. a\<le>x \<and> x\<le>b \<longrightarrow> poly p x \<noteq> 0)"
  hence A: "b < a \<or> 0 < poly p a" and B: "\<forall>x. a\<le>x \<and> x\<le>b \<longrightarrow> poly p x \<noteq> 0"
      by simp_all
  show "\<forall>x. a \<le> x \<and> x \<le> b \<longrightarrow> poly p x > 0"
  proof (cases "a > b", simp, clarify, rule_tac ccontr,
         simp only: not_le not_less)
    fix x assume "a \<le> b" "a \<le> x" "x \<le> b" "poly p x \<le> 0"
    with B have "poly p x < 0" by (simp add: less_eq_real_def)
    moreover from A and \<open>a \<le> b\<close> have "poly p a > 0" by simp
    ultimately have "x > a" using \<open>x \<ge> a\<close> by (auto simp: less_eq_real_def)
    from \<open>poly p x < 0\<close> and \<open>poly p a > 0\<close>
        have "sgn (poly p a) \<noteq> sgn (poly p x)" by simp
    from poly_different_sign_imp_root[OF \<open>x > a\<close> this] and B and \<open>x \<le> b\<close>
        show False by auto
  qed
qed

end