(*****************************************************************************
 * Featherweight-OCL --- A Formal Semantics for UML-OCL Version OCL 2.5
 *                       for the OMG Standard.
 *                       http://www.brucker.ch/projects/hol-testgen/
 *
 * UML_Real.thy --- Library definitions.
 * This file is part of HOL-TestGen.
 *
 * Copyright (c) 2012-2015 Université Paris-Saclay, Univ. Paris-Sud, France
 *               2013-2015 IRT SystemX, France
 *
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are
 * met:
 *
 *     * Redistributions of source code must retain the above copyright
 *       notice, this list of conditions and the following disclaimer.
 *
 *     * Redistributions in binary form must reproduce the above
 *       copyright notice, this list of conditions and the following
 *       disclaimer in the documentation and/or other materials provided
 *       with the distribution.
 *
 *     * Neither the name of the copyright holders nor the names of its
 *       contributors may be used to endorse or promote products derived
 *       from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ******************************************************************************)

theory  UML_Real
imports "../UML_PropertyProfiles"
begin

section\<open>Basic Type Real: Operations\<close>

subsection\<open>Fundamental Predicates on Reals: Strict Equality \label{sec:real-strict-eq}\<close>

text\<open>The last basic operation belonging to the fundamental infrastructure
of a value-type in OCL is the weak equality, which is defined similar
to the @{typ "('\<AA>)Boolean"}-case as strict extension of the strong equality:\<close>
overloading StrictRefEq \<equiv> "StrictRefEq :: [('\<AA>)Real,('\<AA>)Real] \<Rightarrow> ('\<AA>)Boolean"
begin
  definition StrictRefEq\<^sub>R\<^sub>e\<^sub>a\<^sub>l [code_unfold] :
    "(x::('\<AA>)Real) \<doteq> y \<equiv> \<lambda> \<tau>. if (\<upsilon> x) \<tau> = true \<tau> \<and> (\<upsilon> y) \<tau> = true \<tau>
                                  then (x \<triangleq> y) \<tau>
                                  else invalid \<tau>"
end

text\<open>Property proof in terms of @{term "profile_bin\<^sub>S\<^sub>t\<^sub>r\<^sub>o\<^sub>n\<^sub>g\<^sub>E\<^sub>q_\<^sub>v_\<^sub>v"}\<close>
interpretation StrictRefEq\<^sub>R\<^sub>e\<^sub>a\<^sub>l : profile_bin\<^sub>S\<^sub>t\<^sub>r\<^sub>o\<^sub>n\<^sub>g\<^sub>E\<^sub>q_\<^sub>v_\<^sub>v "\<lambda> x y. (x::('\<AA>)Real) \<doteq> y"
         by unfold_locales (auto simp: StrictRefEq\<^sub>R\<^sub>e\<^sub>a\<^sub>l)

subsection\<open>Basic Real Constants\<close>

text\<open>Although the remaining part of this library reasons about
reals abstractly, we provide here as example some convenient shortcuts.\<close>

definition OclReal0 ::"('\<AA>)Real" ("\<zero>.\<zero>")   where      "\<zero>.\<zero> =  (\<lambda> _ . \<lfloor>\<lfloor>0::real\<rfloor>\<rfloor>)"
definition OclReal1 ::"('\<AA>)Real" ("\<one>.\<zero>")   where      "\<one>.\<zero> = (\<lambda> _ . \<lfloor>\<lfloor>1::real\<rfloor>\<rfloor>)"
definition OclReal2 ::"('\<AA>)Real" ("\<two>.\<zero>")   where      "\<two>.\<zero> = (\<lambda> _ . \<lfloor>\<lfloor>2::real\<rfloor>\<rfloor>)"
text\<open>Etc.\<close>
text_raw\<open>\isatagafp\<close>
definition OclReal3 ::"('\<AA>)Real" ("\<three>.\<zero>")   where      "\<three>.\<zero> = (\<lambda> _ . \<lfloor>\<lfloor>3::real\<rfloor>\<rfloor>)"
definition OclReal4 ::"('\<AA>)Real" ("\<four>.\<zero>")   where      "\<four>.\<zero> = (\<lambda> _ . \<lfloor>\<lfloor>4::real\<rfloor>\<rfloor>)"
definition OclReal5 ::"('\<AA>)Real" ("\<five>.\<zero>")   where      "\<five>.\<zero> = (\<lambda> _ . \<lfloor>\<lfloor>5::real\<rfloor>\<rfloor>)"
definition OclReal6 ::"('\<AA>)Real" ("\<six>.\<zero>")   where      "\<six>.\<zero> = (\<lambda> _ . \<lfloor>\<lfloor>6::real\<rfloor>\<rfloor>)"
definition OclReal7 ::"('\<AA>)Real" ("\<seven>.\<zero>")   where      "\<seven>.\<zero> = (\<lambda> _ . \<lfloor>\<lfloor>7::real\<rfloor>\<rfloor>)"
definition OclReal8 ::"('\<AA>)Real" ("\<eight>.\<zero>")   where      "\<eight>.\<zero> = (\<lambda> _ . \<lfloor>\<lfloor>8::real\<rfloor>\<rfloor>)"
definition OclReal9 ::"('\<AA>)Real" ("\<nine>.\<zero>")   where      "\<nine>.\<zero> = (\<lambda> _ . \<lfloor>\<lfloor>9::real\<rfloor>\<rfloor>)"
definition OclReal10 ::"('\<AA>)Real" ("\<one>\<zero>.\<zero>") where      "\<one>\<zero>.\<zero> = (\<lambda> _ . \<lfloor>\<lfloor>10::real\<rfloor>\<rfloor>)"
definition OclRealpi ::"('\<AA>)Real" ("\<pi>")    where      "\<pi> = (\<lambda> _ . \<lfloor>\<lfloor>pi\<rfloor>\<rfloor>)"

subsection\<open>Validity and Definedness Properties\<close>

lemma  "\<delta>(null::('\<AA>)Real) = false" by simp
lemma  "\<upsilon>(null::('\<AA>)Real) = true"  by simp

lemma [simp,code_unfold]: "\<upsilon> (\<lambda>_. \<lfloor>\<lfloor>n\<rfloor>\<rfloor>) = true"
by(simp add:valid_def true_def
               bot_fun_def bot_option_def)

(* ecclectic proofs to make examples executable *)
lemma [simp,code_unfold]: "\<delta> \<zero>.\<zero> = true" by(simp add:OclReal0_def)
lemma [simp,code_unfold]: "\<upsilon> \<zero>.\<zero> = true" by(simp add:OclReal0_def)
lemma [simp,code_unfold]: "\<delta> \<one>.\<zero> = true" by(simp add:OclReal1_def)
lemma [simp,code_unfold]: "\<upsilon> \<one>.\<zero> = true" by(simp add:OclReal1_def)
lemma [simp,code_unfold]: "\<delta> \<two>.\<zero> = true" by(simp add:OclReal2_def)
lemma [simp,code_unfold]: "\<upsilon> \<two>.\<zero> = true" by(simp add:OclReal2_def)
lemma [simp,code_unfold]: "\<delta> \<six>.\<zero> = true" by(simp add:OclReal6_def)
lemma [simp,code_unfold]: "\<upsilon> \<six>.\<zero> = true" by(simp add:OclReal6_def)
lemma [simp,code_unfold]: "\<delta> \<eight>.\<zero> = true" by(simp add:OclReal8_def)
lemma [simp,code_unfold]: "\<upsilon> \<eight>.\<zero> = true" by(simp add:OclReal8_def)
lemma [simp,code_unfold]: "\<delta> \<nine>.\<zero> = true" by(simp add:OclReal9_def)
lemma [simp,code_unfold]: "\<upsilon> \<nine>.\<zero> = true" by(simp add:OclReal9_def)
text_raw\<open>\endisatagafp\<close>

subsection\<open>Arithmetical Operations\<close>

subsubsection\<open>Definition\<close>
text\<open>Here is a common case of a built-in operation on built-in types.
Note that the arguments must be both defined (non-null, non-bot).\<close>
text\<open>Note that we can not follow the lexis of the OCL Standard for Isabelle
technical reasons; these operators are heavily overloaded in the HOL library
that a further overloading would lead to heavy technical buzz in this
document.
\<close>
definition OclAdd\<^sub>R\<^sub>e\<^sub>a\<^sub>l ::"('\<AA>)Real \<Rightarrow> ('\<AA>)Real \<Rightarrow> ('\<AA>)Real" (infix "+\<^sub>r\<^sub>e\<^sub>a\<^sub>l" 40)
where "x +\<^sub>r\<^sub>e\<^sub>a\<^sub>l y \<equiv> \<lambda> \<tau>. if (\<delta> x) \<tau> = true \<tau> \<and> (\<delta> y) \<tau> = true \<tau>
                       then \<lfloor>\<lfloor>\<lceil>\<lceil>x \<tau>\<rceil>\<rceil> + \<lceil>\<lceil>y \<tau>\<rceil>\<rceil>\<rfloor>\<rfloor>
                       else invalid \<tau> "
interpretation OclAdd\<^sub>R\<^sub>e\<^sub>a\<^sub>l : profile_bin\<^sub>d_\<^sub>d "(+\<^sub>r\<^sub>e\<^sub>a\<^sub>l)" "\<lambda> x y. \<lfloor>\<lfloor>\<lceil>\<lceil>x\<rceil>\<rceil> + \<lceil>\<lceil>y\<rceil>\<rceil>\<rfloor>\<rfloor>"
         by unfold_locales (auto simp:OclAdd\<^sub>R\<^sub>e\<^sub>a\<^sub>l_def bot_option_def null_option_def)

definition OclMinus\<^sub>R\<^sub>e\<^sub>a\<^sub>l ::"('\<AA>)Real \<Rightarrow> ('\<AA>)Real \<Rightarrow> ('\<AA>)Real" (infix "-\<^sub>r\<^sub>e\<^sub>a\<^sub>l" 41)
where "x -\<^sub>r\<^sub>e\<^sub>a\<^sub>l y \<equiv> \<lambda> \<tau>. if (\<delta> x) \<tau> = true \<tau> \<and> (\<delta> y) \<tau> = true \<tau>
                       then \<lfloor>\<lfloor>\<lceil>\<lceil>x \<tau>\<rceil>\<rceil> - \<lceil>\<lceil>y \<tau>\<rceil>\<rceil>\<rfloor>\<rfloor>
                       else invalid \<tau> "
interpretation OclMinus\<^sub>R\<^sub>e\<^sub>a\<^sub>l : profile_bin\<^sub>d_\<^sub>d "(-\<^sub>r\<^sub>e\<^sub>a\<^sub>l)" "\<lambda> x y. \<lfloor>\<lfloor>\<lceil>\<lceil>x\<rceil>\<rceil> - \<lceil>\<lceil>y\<rceil>\<rceil>\<rfloor>\<rfloor>"
         by   unfold_locales  (auto simp:OclMinus\<^sub>R\<^sub>e\<^sub>a\<^sub>l_def bot_option_def null_option_def)

definition OclMult\<^sub>R\<^sub>e\<^sub>a\<^sub>l ::"('\<AA>)Real \<Rightarrow> ('\<AA>)Real \<Rightarrow> ('\<AA>)Real" (infix "*\<^sub>r\<^sub>e\<^sub>a\<^sub>l" 45)
where "x *\<^sub>r\<^sub>e\<^sub>a\<^sub>l y \<equiv> \<lambda> \<tau>. if (\<delta> x) \<tau> = true \<tau> \<and> (\<delta> y) \<tau> = true \<tau>
                       then \<lfloor>\<lfloor>\<lceil>\<lceil>x \<tau>\<rceil>\<rceil> * \<lceil>\<lceil>y \<tau>\<rceil>\<rceil>\<rfloor>\<rfloor>
                       else invalid \<tau>"
interpretation OclMult\<^sub>R\<^sub>e\<^sub>a\<^sub>l : profile_bin\<^sub>d_\<^sub>d "OclMult\<^sub>R\<^sub>e\<^sub>a\<^sub>l" "\<lambda> x y. \<lfloor>\<lfloor>\<lceil>\<lceil>x\<rceil>\<rceil> * \<lceil>\<lceil>y\<rceil>\<rceil>\<rfloor>\<rfloor>"
         by   unfold_locales  (auto simp:OclMult\<^sub>R\<^sub>e\<^sub>a\<^sub>l_def bot_option_def null_option_def)

text\<open>Here is the special case of division, which is defined as invalid for division
by zero.\<close>
definition OclDivision\<^sub>R\<^sub>e\<^sub>a\<^sub>l ::"('\<AA>)Real \<Rightarrow> ('\<AA>)Real \<Rightarrow> ('\<AA>)Real" (infix "div\<^sub>r\<^sub>e\<^sub>a\<^sub>l" 45)
where "x div\<^sub>r\<^sub>e\<^sub>a\<^sub>l y \<equiv> \<lambda> \<tau>. if (\<delta> x) \<tau> = true \<tau> \<and> (\<delta> y) \<tau> = true \<tau>
                       then if y \<tau> \<noteq> OclReal0 \<tau> then \<lfloor>\<lfloor>\<lceil>\<lceil>x \<tau>\<rceil>\<rceil> / \<lceil>\<lceil>y \<tau>\<rceil>\<rceil>\<rfloor>\<rfloor> else invalid \<tau>
                       else invalid \<tau> "
(* TODO: special locale setup.*)

definition "mod_float a b = a - real_of_int (floor (a / b)) * b"
definition OclModulus\<^sub>R\<^sub>e\<^sub>a\<^sub>l ::"('\<AA>)Real \<Rightarrow> ('\<AA>)Real \<Rightarrow> ('\<AA>)Real" (infix "mod\<^sub>r\<^sub>e\<^sub>a\<^sub>l" 45)
where "x mod\<^sub>r\<^sub>e\<^sub>a\<^sub>l y \<equiv> \<lambda> \<tau>. if (\<delta> x) \<tau> = true \<tau> \<and> (\<delta> y) \<tau> = true \<tau>
                       then if y \<tau> \<noteq> OclReal0 \<tau> then \<lfloor>\<lfloor>mod_float \<lceil>\<lceil>x \<tau>\<rceil>\<rceil> \<lceil>\<lceil>y \<tau>\<rceil>\<rceil>\<rfloor>\<rfloor> else invalid \<tau>
                       else invalid \<tau> "
(* TODO: special locale setup.*)

definition OclLess\<^sub>R\<^sub>e\<^sub>a\<^sub>l ::"('\<AA>)Real \<Rightarrow> ('\<AA>)Real \<Rightarrow> ('\<AA>)Boolean" (infix "<\<^sub>r\<^sub>e\<^sub>a\<^sub>l" 35)
where "x <\<^sub>r\<^sub>e\<^sub>a\<^sub>l y \<equiv> \<lambda> \<tau>. if (\<delta> x) \<tau> = true \<tau> \<and> (\<delta> y) \<tau> = true \<tau>
                       then \<lfloor>\<lfloor>\<lceil>\<lceil>x \<tau>\<rceil>\<rceil> < \<lceil>\<lceil>y \<tau>\<rceil>\<rceil>\<rfloor>\<rfloor>
                       else invalid \<tau> "
interpretation OclLess\<^sub>R\<^sub>e\<^sub>a\<^sub>l : profile_bin\<^sub>d_\<^sub>d "(<\<^sub>r\<^sub>e\<^sub>a\<^sub>l)" "\<lambda> x y. \<lfloor>\<lfloor>\<lceil>\<lceil>x\<rceil>\<rceil> < \<lceil>\<lceil>y\<rceil>\<rceil>\<rfloor>\<rfloor>"
         by   unfold_locales  (auto simp:OclLess\<^sub>R\<^sub>e\<^sub>a\<^sub>l_def bot_option_def null_option_def)

definition OclLe\<^sub>R\<^sub>e\<^sub>a\<^sub>l ::"('\<AA>)Real \<Rightarrow> ('\<AA>)Real \<Rightarrow> ('\<AA>)Boolean" (infix "\<le>\<^sub>r\<^sub>e\<^sub>a\<^sub>l" 35)
where "x \<le>\<^sub>r\<^sub>e\<^sub>a\<^sub>l y \<equiv> \<lambda> \<tau>. if (\<delta> x) \<tau> = true \<tau> \<and> (\<delta> y) \<tau> = true \<tau>
                       then \<lfloor>\<lfloor>\<lceil>\<lceil>x \<tau>\<rceil>\<rceil> \<le> \<lceil>\<lceil>y \<tau>\<rceil>\<rceil>\<rfloor>\<rfloor>
                       else invalid \<tau> "
interpretation OclLe\<^sub>R\<^sub>e\<^sub>a\<^sub>l : profile_bin\<^sub>d_\<^sub>d "(\<le>\<^sub>r\<^sub>e\<^sub>a\<^sub>l)" "\<lambda> x y. \<lfloor>\<lfloor>\<lceil>\<lceil>x\<rceil>\<rceil> \<le> \<lceil>\<lceil>y\<rceil>\<rceil>\<rfloor>\<rfloor>"
         by   unfold_locales  (auto simp:OclLe\<^sub>R\<^sub>e\<^sub>a\<^sub>l_def bot_option_def null_option_def)

subsubsection\<open>Basic Properties\<close>

lemma OclAdd\<^sub>R\<^sub>e\<^sub>a\<^sub>l_commute: "(X +\<^sub>r\<^sub>e\<^sub>a\<^sub>l Y) = (Y +\<^sub>r\<^sub>e\<^sub>a\<^sub>l X)"
  by(rule ext,auto simp:true_def false_def OclAdd\<^sub>R\<^sub>e\<^sub>a\<^sub>l_def invalid_def
                   split: option.split option.split_asm
                          bool.split bool.split_asm)

subsubsection\<open>Execution with Invalid or Null or Zero as Argument\<close>

lemma OclAdd\<^sub>R\<^sub>e\<^sub>a\<^sub>l_zero1[simp,code_unfold] :
"(x +\<^sub>r\<^sub>e\<^sub>a\<^sub>l \<zero>.\<zero>) = (if \<upsilon> x and not (\<delta> x) then invalid else x endif)"
 proof (rule ext, rename_tac \<tau>, case_tac "(\<upsilon> x and not (\<delta> x)) \<tau> = true \<tau>")
  fix \<tau> show "(\<upsilon> x and not (\<delta> x)) \<tau> = true \<tau> \<Longrightarrow>
              (x +\<^sub>r\<^sub>e\<^sub>a\<^sub>l \<zero>.\<zero>) \<tau> = (if \<upsilon> x and not (\<delta> x) then invalid else x endif) \<tau>"
   apply(subst OclIf_true', simp add: OclValid_def)
  by (metis OclAdd\<^sub>R\<^sub>e\<^sub>a\<^sub>l_def OclNot_defargs OclValid_def foundation5 foundation9)
 next fix \<tau>
  have A: "\<And>\<tau>. (\<tau> \<Turnstile> not (\<upsilon> x and not (\<delta> x))) = (x \<tau> = invalid \<tau> \<or> \<tau> \<Turnstile> \<delta> x)"
  by (metis OclNot_not OclOr_def defined5 defined6 defined_not_I foundation11 foundation18'
            foundation6 foundation7 foundation9 invalid_def)
  have B: "\<tau> \<Turnstile> \<delta> x \<Longrightarrow> \<lfloor>\<lfloor>\<lceil>\<lceil>x \<tau>\<rceil>\<rceil>\<rfloor>\<rfloor> = x \<tau>"
   apply(cases "x \<tau>", metis bot_option_def foundation16)
   apply(rename_tac x', case_tac x', metis bot_option_def foundation16 null_option_def)
  by(simp)
  show "(x +\<^sub>r\<^sub>e\<^sub>a\<^sub>l \<zero>.\<zero>) \<tau> = (if \<upsilon> x and not (\<delta> x) then invalid else x endif) \<tau>"
    when "\<tau> \<Turnstile> not (\<upsilon> x and not (\<delta> x))"
   apply(insert that, subst OclIf_false', simp, simp add: A, auto simp: OclAdd\<^sub>R\<^sub>e\<^sub>a\<^sub>l_def OclReal0_def)
     (* *)
     apply(simp add: foundation16'[simplified OclValid_def])
    apply(simp add: B)
  by(simp add: OclValid_def)
qed(metis OclValid_def defined5 defined6 defined_and_I defined_not_I foundation9)

lemma OclAdd\<^sub>R\<^sub>e\<^sub>a\<^sub>l_zero2[simp,code_unfold] :
"(\<zero>.\<zero> +\<^sub>r\<^sub>e\<^sub>a\<^sub>l x) = (if \<upsilon> x and not (\<delta> x) then invalid else x endif)"
by(subst OclAdd\<^sub>R\<^sub>e\<^sub>a\<^sub>l_commute, simp)

(* TODO Basic proproperties for multiplication, division, modulus. *)

subsection\<open>Test Statements\<close>
text\<open>Here follows a list of code-examples, that explain the meanings
of the above definitions by compilation to code and execution to @{term "True"}.\<close>

Assert "\<tau> \<Turnstile> ( \<nine>.\<zero> \<le>\<^sub>r\<^sub>e\<^sub>a\<^sub>l \<one>\<zero>.\<zero> )"
Assert "\<tau> \<Turnstile> (( \<four>.\<zero> +\<^sub>r\<^sub>e\<^sub>a\<^sub>l \<four>.\<zero> ) \<le>\<^sub>r\<^sub>e\<^sub>a\<^sub>l \<one>\<zero>.\<zero> )"
Assert "\<tau> |\<noteq> (( \<four>.\<zero> +\<^sub>r\<^sub>e\<^sub>a\<^sub>l ( \<four>.\<zero> +\<^sub>r\<^sub>e\<^sub>a\<^sub>l \<four>.\<zero> )) <\<^sub>r\<^sub>e\<^sub>a\<^sub>l \<one>\<zero>.\<zero> )"
Assert "\<tau> \<Turnstile> not (\<upsilon> (null +\<^sub>r\<^sub>e\<^sub>a\<^sub>l \<one>.\<zero>)) "
Assert "\<tau> \<Turnstile> (((\<nine>.\<zero> *\<^sub>r\<^sub>e\<^sub>a\<^sub>l \<four>.\<zero>) div\<^sub>r\<^sub>e\<^sub>a\<^sub>l \<one>\<zero>.\<zero>) \<le>\<^sub>r\<^sub>e\<^sub>a\<^sub>l  \<four>.\<zero>) "
Assert "\<tau> \<Turnstile> not (\<delta> (\<one>.\<zero> div\<^sub>r\<^sub>e\<^sub>a\<^sub>l \<zero>.\<zero>)) "
Assert "\<tau> \<Turnstile> not (\<upsilon> (\<one>.\<zero> div\<^sub>r\<^sub>e\<^sub>a\<^sub>l \<zero>.\<zero>)) "

lemma real_non_null [simp]: "((\<lambda>_. \<lfloor>\<lfloor>n\<rfloor>\<rfloor>) \<doteq> (null::('\<AA>)Real)) = false"
by(rule ext,auto simp: StrictRefEq\<^sub>R\<^sub>e\<^sub>a\<^sub>l valid_def
                         bot_fun_def bot_option_def null_fun_def null_option_def StrongEq_def)

lemma null_non_real [simp]: "((null::('\<AA>)Real) \<doteq> (\<lambda>_. \<lfloor>\<lfloor>n\<rfloor>\<rfloor>)) = false"
by(rule ext,auto simp: StrictRefEq\<^sub>R\<^sub>e\<^sub>a\<^sub>l valid_def
                         bot_fun_def bot_option_def null_fun_def null_option_def StrongEq_def)

lemma OclReal0_non_null [simp,code_unfold]: "(\<zero>.\<zero> \<doteq> null) = false" by(simp add: OclReal0_def)
lemma null_non_OclReal0 [simp,code_unfold]: "(null \<doteq> \<zero>.\<zero>) = false" by(simp add: OclReal0_def)
lemma OclReal1_non_null [simp,code_unfold]: "(\<one>.\<zero> \<doteq> null) = false" by(simp add: OclReal1_def)
lemma null_non_OclReal1 [simp,code_unfold]: "(null \<doteq> \<one>.\<zero>) = false" by(simp add: OclReal1_def)
lemma OclReal2_non_null [simp,code_unfold]: "(\<two>.\<zero> \<doteq> null) = false" by(simp add: OclReal2_def)
lemma null_non_OclReal2 [simp,code_unfold]: "(null \<doteq> \<two>.\<zero>) = false" by(simp add: OclReal2_def)
lemma OclReal6_non_null [simp,code_unfold]: "(\<six>.\<zero> \<doteq> null) = false" by(simp add: OclReal6_def)
lemma null_non_OclReal6 [simp,code_unfold]: "(null \<doteq> \<six>.\<zero>) = false" by(simp add: OclReal6_def)
lemma OclReal8_non_null [simp,code_unfold]: "(\<eight>.\<zero> \<doteq> null) = false" by(simp add: OclReal8_def)
lemma null_non_OclReal8 [simp,code_unfold]: "(null \<doteq> \<eight>.\<zero>) = false" by(simp add: OclReal8_def)
lemma OclReal9_non_null [simp,code_unfold]: "(\<nine>.\<zero> \<doteq> null) = false" by(simp add: OclReal9_def)
lemma null_non_OclReal9 [simp,code_unfold]: "(null \<doteq> \<nine>.\<zero>) = false" by(simp add: OclReal9_def)

text\<open>Here follows a list of code-examples, that explain the meanings
of the above definitions by compilation to code and execution to @{term "True"}.\<close>

text\<open>Elementary computations on Real\<close>

Assert "\<tau> \<Turnstile> \<one>.\<zero> <> \<two>.\<zero>"
Assert "\<tau> \<Turnstile> \<two>.\<zero> <> \<one>.\<zero>"
Assert "\<tau> \<Turnstile> \<two>.\<zero> \<doteq> \<two>.\<zero>"

Assert "\<tau> \<Turnstile> \<upsilon> \<four>.\<zero>"
Assert "\<tau> \<Turnstile> \<delta> \<four>.\<zero>"
Assert "\<tau> \<Turnstile> \<upsilon> (null::('\<AA>)Real)"
Assert "\<tau> \<Turnstile> (invalid \<triangleq> invalid)"
Assert "\<tau> \<Turnstile> (null \<triangleq> null)"
Assert "\<tau> \<Turnstile> (\<four>.\<zero> \<triangleq> \<four>.\<zero>)"
Assert "\<tau> |\<noteq> (\<nine>.\<zero> \<triangleq> \<one>\<zero>.\<zero>)"
Assert "\<tau> |\<noteq> (invalid \<triangleq> \<one>\<zero>.\<zero>)"
Assert "\<tau> |\<noteq> (null \<triangleq> \<one>\<zero>.\<zero>)"
Assert "\<tau> |\<noteq> (invalid \<doteq> (invalid::('\<AA>)Real))" (* Without typeconstraint not executable.*)
Assert "\<tau> |\<noteq> \<upsilon> (invalid \<doteq> (invalid::('\<AA>)Real))" (* Without typeconstraint not executable.*)
Assert "\<tau> |\<noteq> (invalid <> (invalid::('\<AA>)Real))" (* Without typeconstraint not executable.*)
Assert "\<tau> |\<noteq> \<upsilon> (invalid <> (invalid::('\<AA>)Real))" (* Without typeconstraint not executable.*)
Assert "\<tau> \<Turnstile> (null \<doteq> (null::('\<AA>)Real) )" (* Without typeconstraint not executable.*)
Assert "\<tau> \<Turnstile> (null \<doteq> (null::('\<AA>)Real) )" (* Without typeconstraint not executable.*)
Assert "\<tau> \<Turnstile> (\<four>.\<zero> \<doteq> \<four>.\<zero>)"
Assert "\<tau> |\<noteq> (\<four>.\<zero> <> \<four>.\<zero>)"
Assert "\<tau> |\<noteq> (\<four>.\<zero> \<doteq> \<one>\<zero>.\<zero>)"
Assert "\<tau> \<Turnstile> (\<four>.\<zero> <> \<one>\<zero>.\<zero>)"
Assert "\<tau> |\<noteq> (\<zero>.\<zero> <\<^sub>r\<^sub>e\<^sub>a\<^sub>l null)"
Assert "\<tau> |\<noteq> (\<delta> (\<zero>.\<zero> <\<^sub>r\<^sub>e\<^sub>a\<^sub>l null))"

end


theory CValue
imports C
begin

domain CValue
  = CFn (lazy "(C \<rightarrow> CValue) \<rightarrow> (C \<rightarrow> CValue)")
  | CB (lazy "bool discr")

fixrec CFn_project :: "CValue \<rightarrow> (C \<rightarrow> CValue) \<rightarrow> (C \<rightarrow> CValue)"
 where "CFn_project\<cdot>(CFn\<cdot>f)\<cdot>v = f \<cdot> v"

abbreviation CFn_project_abbr (infix "\<down>CFn" 55)
  where "f \<down>CFn v \<equiv> CFn_project\<cdot>f\<cdot>v"

lemma CFn_project_strict[simp]:
  "\<bottom> \<down>CFn v = \<bottom>"
  "CB\<cdot>b \<down>CFn v = \<bottom>"
  by (fixrec_simp)+

lemma CB_below[simp]: "CB\<cdot>b \<sqsubseteq> v \<longleftrightarrow> v = CB\<cdot>b"
  by (cases v) auto

fixrec CB_project :: "CValue \<rightarrow> CValue \<rightarrow> CValue \<rightarrow> CValue" where
  "CB_project\<cdot>(CB\<cdot>db)\<cdot>v\<^sub>1\<cdot>v\<^sub>2 = (if undiscr db then v\<^sub>1 else v\<^sub>2)"

lemma CB_project_not_bot:
  "CB_project\<cdot>scrut\<cdot>v\<^sub>1\<cdot>v\<^sub>2 \<noteq> \<bottom> \<longleftrightarrow> (\<exists> b. scrut = CB\<cdot>(Discr b) \<and> (if b then v\<^sub>1 else v\<^sub>2) \<noteq> \<bottom>)"
  apply (cases scrut)
  apply simp
  apply simp
  by (metis (poly_guards_query) CB_project.simps CValue.injects(2) discr.exhaust undiscr_Discr)

text \<open>HOLCF provides us @{const CValue_take}\<open>::\<close>@{typeof CValue_take};
we want a similar function for @{typ "C \<rightarrow> CValue"}.\<close>

abbreviation C_to_CValue_take :: "nat \<Rightarrow> (C \<rightarrow> CValue) \<rightarrow> (C \<rightarrow> CValue)"
   where "C_to_CValue_take n \<equiv> cfun_map\<cdot>ID\<cdot>(CValue_take n)"

lemma C_to_CValue_chain_take: "chain C_to_CValue_take"
  by (auto intro: chainI cfun_belowI chainE[OF CValue.chain_take] monofun_cfun_fun)

lemma C_to_CValue_reach: "(\<Squnion> n. C_to_CValue_take n\<cdot>x) = x"
  by (auto intro:  cfun_eqI simp add: contlub_cfun_fun[OF ch2ch_Rep_cfunL[OF C_to_CValue_chain_take]]  CValue.reach)

end


section \<open>Proof of the theorem of three circles\<close>

theory Three_Circles
  imports "Bernstein" "Normal_Poly"
begin

text \<open>
The theorem of three circles is a result in real algebraic geometry about the number of real roots
in an interval. It says if the number of roots in certain circles in the complex plane are zero or
one then the number of roots in the circles is equal to the sign changes of the Bernstein
coefficients on that interval for which the circles intersect the real line. This can then be used
to determine if an interval has a real root in the bisection procedure, which is more efficient than
Descartes' rule of signs.

The proof here follows Theorem 10.50 in
  Basu, S., Pollack, R., Roy, M.-F.: Algorithms in Real Algebraic Geometry.
  Springer Berlin Heidelberg, Berlin, Heidelberg (2016).

This theorem has also been fomalised in Coq \<^cite>\<open>"zsido2014theorem"\<close>. The relationship
between this theorem and root isolation has been elaborated in Eigenwillig's PhD
thesis \<^cite>\<open>"eigenwillig2008real"\<close>.
\<close>

subsection \<open>No sign changes case\<close>

declare degree_pcompose[simp del]

corollary descartes_sign_zero:
  fixes p::"real poly"
  assumes "\<And>x::complex. poly (map_poly of_real p) x = 0 \<Longrightarrow> Re x \<le> 0"
    and "lead_coeff p = 1"
  shows "coeff p i \<ge> 0"
  using assms
proof (induction p arbitrary: i rule: real_poly_roots_induct)
  case (1 p x)
  interpret map_poly_idom_hom complex_of_real ..
  have h: "\<And> i. 0 \<le> coeff p i"
    apply (rule 1(1))
    using 1(2) apply (metis lambda_zero of_real_poly_map_mult poly_mult)
    using 1(3) apply (metis lead_coeff_1 lead_coeff_mult lead_coeff_pCons(1)
                      mult_cancel_right2 pCons_one zero_neq_one)
    done
  have "x \<le> 0"
    apply (subst Re_complex_of_real[symmetric])
    apply (rule 1(2))
    apply (subst hom_mult)
    by (auto)
  thus ?case
    apply (cases i)
    subgoal using h[of i] h[of "i-1"]
      by (fastforce simp: coeff_pCons mult_nonneg_nonpos2)
    subgoal using h[of i] h[of "i-1"] mult_left_mono_neg
      by (fastforce simp: coeff_pCons)
    done
next
  case (2 p a b)
  interpret map_poly_idom_hom complex_of_real ..
  have h: "\<And> i. 0 \<le> coeff p i"
    apply (rule 2(2))
    using 2(3) apply (metis lambda_zero of_real_poly_map_mult poly_mult)
    using 2(4) apply (metis lead_coeff_1 lead_coeff_mult lead_coeff_pCons(1)
                      mult_cancel_right2 pCons_one zero_neq_one)
    done
  have "Re (a + b * \<i>) \<le> 0"
    apply (rule 2(3))
    apply (subst hom_mult)
    by (auto simp: algebra_simps)
  hence 1: "0 \<le> - 2 * a" by fastforce
  have 2: "0 \<le> a * a + b * b" by fastforce
  have "\<And> x. 0 \<le> coeff [:a * a + b * b, - 2 * a, 1:] x"
  proof -
    fix x
    show "0 \<le> coeff [:a * a + b * b, - 2 * a, 1:] x"
      using 2 apply (cases "x = 0", fastforce)
      using 1 apply (cases "x = 1", fastforce)
      apply (cases "x = 2", fastforce simp: coeff_pCons)
      by (auto simp: coeff_eq_0)
  qed
  thus ?case
    apply (subst mult.commute, subst coeff_mult)
    apply (rule sum_nonneg, rule mult_nonneg_nonneg[OF _ h])
    by auto
next
  case (3 a)
  then show ?case
    by (smt (z3) bot_nat_0.extremum_uniqueI degree_1 le_degree
        lead_coeff_pCons(2) pCons_one)
qed

definition circle_01_diam :: "complex set" where
"circle_01_diam =
 {x. cmod (x - (of_nat 1 :: complex)/(of_nat 2)) < (real 1)/(real 2)}"

lemma pos_real_map:
  "{x::complex. 1 / x \<in> (\<lambda>x. x + 1) ` {x. 0 < Re x}} = circle_01_diam"
proof
  show "{x. 1 / x \<in> (\<lambda>x. x + 1) ` {x. 0 < Re x}} \<subseteq> circle_01_diam"
  proof
    fix x assume "x \<in> {x. 1 / x \<in> (\<lambda>x. x + 1) ` {x. 0 < Re x}}"
    then obtain y where h: "1 / x = y + 1" and hy: "0 < Re y" by blast
    hence hy': "y = 1 / x - 1" by fastforce
    hence hy'': "y + 1 \<noteq> 0" using h hy by fastforce
    hence "x = 1 / (y + 1)" using h
      by (metis div_by_1 divide_divide_eq_right mult.left_neutral)
    have "\<bar>Re y - 1\<bar> < \<bar>Re y + 1\<bar>" using hy by simp
    hence "cmod (y - 1) < cmod (y + 1)"
      by (smt (z3) cmod_Re_le_iff minus_complex.simps(1) minus_complex.simps(2)
          one_complex.simps plus_complex.simps(1) plus_complex.simps(2))
    hence "cmod ((y - 1)/(y + 1)) < 1"
      by (smt (verit) divide_less_eq_1_pos nonzero_norm_divide zero_less_norm_iff)
    thus "x \<in> circle_01_diam" using hy' hy''
      by (auto simp: field_simps norm_minus_commute circle_01_diam_def)
  qed
  show "circle_01_diam \<subseteq> {x. 1 / x \<in> (\<lambda>x. x + 1) ` {x. 0 < Re x}}"
  proof
    fix x assume "x \<in> circle_01_diam"
    hence "cmod (x - 1 / 2) * 2 < 1" by (auto simp: circle_01_diam_def)
    hence h: "x \<noteq> 0" and "cmod (x - 1 / 2) * cmod 2 < 1" by auto
    hence "cmod (2*x - 1) < 1"
      by (smt (verit) dbl_simps(3) dbl_simps(5) div_self times_divide_eq_left
          left_diff_distrib_numeral mult.commute mult_numeral_1
          norm_eq_zero norm_mult norm_numeral norm_one numeral_One)
    hence "cmod (((1/x - 1) -  1)/((1/x - 1) + 1)) < 1"
      by (auto simp: divide_simps norm_minus_commute)
    hence "cmod (((1/x - 1) -  1)/ cmod ((1/x - 1) + 1)) < 1"
      by (metis (no_types, lifting) abs_norm_cancel norm_divide norm_of_real)
    hence "cmod ((1/x - 1) - 1) < cmod ((1/x - 1) + 1)" using h
      by (smt (verit) diff_add_cancel divide_eq_0_iff divide_less_eq_1_pos
          norm_divide norm_of_real zero_less_norm_iff zero_neq_one)
    hence "\<bar>Re (1/x - 1) - 1\<bar> < \<bar>Re (1/x - 1) + 1\<bar>"
      by (smt (z3) cmod_Re_le_iff minus_complex.simps(1) minus_complex.simps(2)
          one_complex.simps plus_complex.simps(1) plus_complex.simps(2))
    hence "0 < Re (1/x - 1)" by linarith
    moreover have "1 / x = (1/x - 1) + 1" by simp
    ultimately have "0 < Re (1/x - 1) \<and> 1 / x = (1/x - 1) + 1" by blast
    hence "\<exists>xa. 0 < Re xa \<and> 1 / x = xa + 1" by blast
    thus "x \<in> {x. 1 / x \<in> (\<lambda>x. x + 1) ` {x. 0 < Re x}}" by blast
  qed
qed

lemma one_circle_01: fixes P::"real poly" assumes hP: "degree P \<le> p" and "P \<noteq> 0"
  and "proots_count (map_poly of_real P) circle_01_diam = 0"
shows "Bernstein_changes_01 p P = 0"
proof -
  let ?Q = "(reciprocal_poly p P) \<circ>\<^sub>p [:1, 1:]"
  have hQ: "?Q \<noteq> 0"
    using assms
    by (simp add: Missing_Polynomial.pcompose_eq_0 reciprocal_0_iff)

  hence 1: "changes (coeffs ?Q) \<ge> proots_count ?Q {x. 0 < x} \<and>
        even (changes (coeffs ?Q) - proots_count ?Q {x. 0 < x})"
    by (rule descartes_sign)

  have hdeg: "degree (map_poly complex_of_real P) \<le> p"
    by (rule le_trans, rule degree_map_poly_le, auto simp: assms)
  have hx: "\<And>x. 1 + x = 0 \<Longrightarrow> 0 < Re x \<Longrightarrow> False"
  proof -
    fix x::complex assume "1 + x = 0"
    hence "x = -1" by algebra
    thus "0 < Re x \<Longrightarrow> False" by auto
  qed

  have 2: "proots_count (map_poly of_real P) circle_01_diam =
           proots_count (map_poly of_real ?Q) {x. 0 < Re x}"
    apply (subst pos_real_map[symmetric])
    apply (subst of_real_hom.map_poly_pcompose)
    apply (subst map_poly_reciprocal) using assms apply auto[2]
    apply (subst proots_pcompose)
    using assms apply (auto simp: reciprocal_0_iff degree_map_poly)[2]
    apply (subst proots_count_reciprocal)
    using assms apply (auto simp: degree_map_poly inverse_eq_divide)[2]
    using hx apply fastforce
    by (auto simp: inverse_eq_divide algebra_simps)

  hence 3:"proots_count (map_poly of_real ?Q) {x. 0 < Re x} = 0"
    using assms(3) by presburger

  hence "\<And>x::complex.
         poly (map_poly of_real (smult (inverse (lead_coeff ?Q)) ?Q)) x = 0 \<Longrightarrow>
         Re x \<le> 0"
  proof cases
    fix x::complex show "Re x \<le> 0 \<Longrightarrow> Re x \<le> 0" by fast
    assume "\<not>Re x \<le> 0" hence h:"0 < Re x" by simp
    assume "poly (map_poly of_real (smult (inverse (lead_coeff ?Q)) ?Q)) x = 0"
    hence h2:"poly (map_poly of_real ?Q) x = 0" by fastforce
    hence "order x (map_poly complex_of_real (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:])) > 0"
      using assms by (fastforce simp: order_root pcompose_eq_0 reciprocal_0_iff)
    hence "proots_count (map_poly of_real ?Q) {x. 0 < Re x} \<noteq> 0"
    proof -
      have h3: "finite {x. poly (map_poly complex_of_real
                (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:])) x = 0}"
        apply (rule poly_roots_finite)
        using assms by (fastforce simp: order_root pcompose_eq_0 reciprocal_0_iff)
      have "0 < order x (map_poly complex_of_real (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]))"
        using h2 assms by (fastforce simp: order_root pcompose_eq_0 reciprocal_0_iff)
      also have "... \<le> (\<Sum>r\<in>{x. 0 < Re x \<and>
                  poly (map_poly complex_of_real (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:])) x =
                  0}.
           order r (map_poly complex_of_real (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:])))"
        apply (rule member_le_sum) using h h2 h3 by auto
      finally have
        "0 < (\<Sum>r\<in>{x. 0 < Re x \<and>
         poly (map_poly complex_of_real (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:])) x = 0}.
         order r (map_poly complex_of_real (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:])))" .
      thus
        "0 < order x (map_poly complex_of_real (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:])) \<Longrightarrow>
         proots_count (map_poly complex_of_real (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]))
         {x. 0 < Re x} \<noteq> 0 "
        by (auto simp: proots_count_def proots_within_def)
    qed
    thus "Re x \<le> 0" using 3 by blast
  qed
  hence "\<And>i. coeff (smult (inverse (lead_coeff ?Q)) ?Q) i \<ge> 0"
    apply (frule descartes_sign_zero)
    using assms by (fastforce simp: pcompose_eq_0 reciprocal_0_iff)
  hence "changes (coeffs (smult (inverse (lead_coeff ?Q)) ?Q)) = 0"
    by (subst changes_all_nonneg, auto simp: nth_default_coeffs_eq)
  hence "changes (coeffs ?Q) = 0"
    using hQ by (auto simp: coeffs_smult changes_scale_const)

  thus ?thesis
    apply (subst Bernstein_changes_01_eq_changes["OF" hP])
    by blast
qed

definition circle_diam :: "real \<Rightarrow> real \<Rightarrow> complex set" where
"circle_diam l r = {x. cmod ((x - l) - (r - l)/2) < (r - l)/2}"

lemma circle_diam_rescale: assumes "l < r"
  shows "circle_diam l r = (\<lambda> x . (x*(r - l) + l)) ` circle_01_diam"
proof
  show "circle_diam l r \<subseteq> (\<lambda>x. x * (complex_of_real r - complex_of_real l) +
        complex_of_real l) ` circle_01_diam"
  proof
    fix x assume "x \<in> circle_diam l r"
    hence "cmod ((x - l) - (r - l)/2) < (r - l)/2" by (auto simp: circle_diam_def)
    hence "cmod ((r - l) * ((x - l)/(r - l) - 1/2)) < (r - l)/2" using assms
      by (subst right_diff_distrib, fastforce)
    hence "(r - l) * cmod ((x - l)/(r - l) - 1/2) < (r - l) * 1/2"
      apply (subst(2) abs_of_pos[symmetric])
      subgoal using assms by argo
      subgoal
        apply (subst norm_scaleR[symmetric])
        by (simp add: scaleR_conv_of_real)
      done
    hence "cmod ((x - l)/(r - l) - 1/2) < 1/2"
      apply (subst mult_less_cancel_left_pos[of "r-l",symmetric])
      using assms by auto
    hence
      "cmod ((x-l)/(r-l) - 1 / 2) * 2 < 1 \<and>
       x = (x-l)/(r-l) * (complex_of_real r - complex_of_real l) + complex_of_real l"
      by force
    thus "x \<in> (\<lambda>x. x * (complex_of_real r - complex_of_real l) + complex_of_real l) `
          circle_01_diam"
      by (force simp: circle_01_diam_def)
  qed
  show "(\<lambda>x. x * (complex_of_real r - complex_of_real l) + complex_of_real l) `
        circle_01_diam \<subseteq> circle_diam l r"
  proof
    fix x::complex
    assume
      "x \<in> (\<lambda>x. x * (complex_of_real r - complex_of_real l) + complex_of_real l) `
       circle_01_diam"
    then obtain y::complex where "x = y * (r - l) + l" "cmod (y - 1/2) < 1/2"
      by (fastforce simp: circle_01_diam_def)
    moreover hence "y = (x - l) / (r - l)" using assms by force
    ultimately have "cmod ((x - l) / (r - l) - 1/2) < 1/2" by presburger
    hence "(r - l) * (cmod ((x - l) / (r - l) - 1/2)) < (r - l) * (1/2)"
      apply (subst mult_less_cancel_left_pos)
      using assms by auto
    hence "cmod ((x - l) - (r - l)/2) < (r - l)/2"
      apply (subst(asm) (2) abs_of_pos[symmetric])
      using assms apply argo
      apply (subst(asm) norm_scaleR[symmetric])
      by (smt (verit, del_insts)
          \<open>x = y * complex_of_real (r - l) + complex_of_real l\<close>
          \<open>y = (x - complex_of_real l) / complex_of_real (r - l)\<close>
          add_diff_cancel divide_divide_eq_right divide_numeral_1 mult.commute
          of_real_1 of_real_add of_real_divide one_add_one scaleR_conv_of_real
          scale_right_diff_distrib times_divide_eq_right)
    thus "x \<in> circle_diam l r"
      by (force simp: circle_diam_def)
  qed
qed

lemma one_circle: fixes P::"real poly" assumes "l < r"
  and "proots_count (map_poly of_real P) (circle_diam l r) = 0"
  and "P \<noteq> 0"
  and "degree P \<le> p"
shows "Bernstein_changes p l r P = 0"
proof (subst Bernstein_changes_eq_rescale)
  show "l \<noteq> r" using assms(1) by force
  show "degree P \<le> p" using assms(4) by blast
  show "Bernstein_changes_01 p (P \<circ>\<^sub>p [:l, 1:] \<circ>\<^sub>p [:0, r - l:]) = 0"
  proof (rule one_circle_01)
    show "degree (P \<circ>\<^sub>p [:l, 1:] \<circ>\<^sub>p [:0, r - l:]) \<le> p"
      using assms(4) by (force simp: degree_pcompose)
    show "P \<circ>\<^sub>p [:l, 1:] \<circ>\<^sub>p [:0, r - l:] \<noteq> 0"
      using assms by (smt (z3) degree_0_iff gr_zeroI pCons_eq_0_iff pCons_eq_iff
                      pcompose_eq_0)

    have "proots_count (map_poly of_real P) (circle_diam l r) =
          proots_count (map_poly complex_of_real (P \<circ>\<^sub>p [:l, 1:] \<circ>\<^sub>p [:0, r - l:]))
          circle_01_diam"
      apply (subst of_real_hom.map_poly_pcompose)
      apply (subst proots_pcompose)
        apply (metis assms(3) degree_eq_zeroE of_real_poly_eq_0_iff
          pCons_eq_iff pCons_one pcompose_eq_0 zero_neq_one)
      using assms(1) apply fastforce
      apply (subst of_real_hom.map_poly_pcompose)
      apply (subst proots_pcompose)
        apply (auto simp: assms(3))[2]
      apply (subst circle_diam_rescale[OF assms(1)])
      apply (rule arg_cong[of _ _ "proots_count (map_poly complex_of_real P)"])
      by fastforce

    thus "proots_count (map_poly complex_of_real (P \<circ>\<^sub>p [:l, 1:] \<circ>\<^sub>p [:0, r - l:]))
          circle_01_diam = 0"
      using assms(2) by presburger
  qed
qed

subsection \<open>One sign change case\<close>

definition upper_circle_01 :: "complex set" where
"upper_circle_01 = {x. cmod (x - (1/2 + sqrt(3)/6 * \<i>)) < sqrt 3 / 3}"

lemma upper_circle_map:
  "{x::complex. 1 / x \<in> (\<lambda>x. x + 1) ` {x. Im x < sqrt 3 * Re x}} = upper_circle_01"
proof
  show "{x::complex. 1 / x \<in> (\<lambda>x. x + 1) ` {x. Im x < sqrt 3 * Re x}} \<subseteq> upper_circle_01"
  proof
    fix x
    assume "x \<in> {x. 1 / x \<in> (\<lambda>x. x + 1) ` {x. Im x < sqrt 3 * Re x}}"
    then obtain y where "1 / x = y + 1" and h: "Im y < sqrt 3 * Re y" by fastforce
    hence hy: "y = 1/x - 1" by simp
    hence hx: "x = 1/(y+1)" by auto
    from h have hy1: "y \<noteq> -1" by fastforce
    hence hx0: "x \<noteq> 0" using hy by fastforce
    from h have "0 < Re ((\<i> + sqrt 3) * y)" by fastforce
    hence "cmod ((\<i> + sqrt 3) * y - 1) < cmod ((\<i> + sqrt 3) * y + 1)"
      by (auto simp: cmod_def power2_eq_square algebra_simps)
    hence 1: "cmod (((\<i> + sqrt 3) * y - 1)/((\<i> + sqrt 3) * y + 1)) < 1"
      by (auto simp: norm_divide divide_simps)
    also have "cmod (((\<i> + sqrt 3) * y - 1)/((\<i> + sqrt 3) * y + 1)) =
               cmod (((\<i> + sqrt 3) * y * x - x)/((\<i> + sqrt 3) * y * x + x))"
      apply (subst mult_divide_mult_cancel_right[symmetric, OF hx0])
      apply (subst ring_distribs(2)[of _ _ x])
      apply (subst left_diff_distrib[of _ _ x])
      by simp
    also have "... = cmod
       (((-1 - complex_of_real (sqrt 3) - \<i>) * x + (complex_of_real (sqrt 3) + \<i>)) /
       (( 1 - complex_of_real (sqrt 3) - \<i>) * x + (complex_of_real (sqrt 3) + \<i>)))"
      by (auto simp: hy algebra_simps hx0)

    also have
      "... = cmod ((-1 - complex_of_real (sqrt 3) - \<i>) * x +
                   (complex_of_real (sqrt 3) + \<i>)) /
             cmod (( 1 - complex_of_real (sqrt 3) - \<i>) * x +
                   (complex_of_real (sqrt 3) + \<i>))"
      by (auto simp: norm_divide)

    finally have
      "cmod ((-1 - complex_of_real (sqrt 3) - \<i>) * x + (complex_of_real (sqrt 3) + \<i>))
       < cmod ((1 - complex_of_real (sqrt 3) - \<i>) * x + (complex_of_real (sqrt 3) + \<i>))"
    proof (subst divide_less_eq_1_pos[symmetric], subst zero_less_norm_iff)
      show "(1 - complex_of_real (sqrt 3) - \<i>) * x + (complex_of_real (sqrt 3) + \<i>) \<noteq> 0"
      proof
        have "-\<i> + 1 \<noteq> complex_of_real (sqrt 3)" by (auto simp: complex_eq_iff)
        moreover assume
          "(1 - complex_of_real (sqrt 3) - \<i>) * x + (complex_of_real (sqrt 3) + \<i>) = 0"
        ultimately have
          "x = (-complex_of_real (sqrt 3) - \<i>)/(1 - complex_of_real (sqrt 3) - \<i>)"
          by (auto simp: divide_simps algebra_simps)
        thus False
          using h by (auto simp: hy field_simps Im_divide Re_divide)
      qed
    qed

    hence "cmod (x - (1/2 + sqrt(3)/6 * \<i>)) < sqrt 3 / 3"
      apply (subst(3) abs_of_pos[symmetric, of 3]) apply auto[1]
      apply (subst real_sqrt_abs2[symmetric], subst real_sqrt_divide[symmetric])
      apply (subst cmod_def, subst real_sqrt_less_iff)
      apply (rule mult_right_less_imp_less[of _ "sqrt 3 /3"])
      by (auto simp: cmod_def power2_eq_square algebra_simps)

    thus "x \<in> upper_circle_01"
      by (auto simp: upper_circle_01_def)
  qed

  show "upper_circle_01 \<subseteq> {x. 1 / x \<in> (\<lambda>x. x + 1) ` {x. sqrt 3 * Re x > Im x}}"
  proof
    fix x assume "x \<in> upper_circle_01"
    hence "cmod (x - (1/2 + sqrt(3)/6 * \<i>)) < sqrt 3 / 3"
      by (force simp: upper_circle_01_def)
    hence "sqrt ((Re x - 1/2)^2 + (Im x - sqrt(3)/6)^2) < sqrt (1/3)"
      by (auto simp: cmod_def sqrt_divide_self_eq real_sqrt_inverse[symmetric])
    hence 1: "- Im x * sqrt 3 + (Im x * (Im x * 3) + Re x * (Re x * 3)) < Re x * 3"
      by (auto simp: power2_eq_square algebra_simps)
    have 2: "- Im x + (Im x * (Im x * sqrt 3) + Re x * (Re x * sqrt 3)) < Re x * sqrt 3"
      apply (rule mult_right_less_imp_less[of _ "sqrt 3"])
       apply (subst mult.assoc[of _ "sqrt 3"], subst real_sqrt_mult_self)
      using 1 by (auto simp: algebra_simps)
    have "sqrt 3 + (-Im x) / (Im x * Im x + Re x * Re x) <
          Re x * sqrt 3 / (Im x * Im x + Re x * Re x)"
      apply (rule mult_right_less_imp_less[of _ "(Im x * Im x + Re x * Re x)"])
       apply (rule subst, rule arg_cong2[of _ _ _ _ "(<)"])
         prefer 3 apply (rule 2)
        apply (subst distrib_right)
      using 2 apply auto
      by (auto simp: algebra_simps)

    hence "0 < - Im (1/x-1) + sqrt 3 * Re (1/x-1)"
      by (auto simp: power2_eq_square algebra_simps Re_divide Im_divide)
    hence "sqrt 3 * Re (1/x-1) > Im (1/x-1)"
      by argo
    hence "(1/x-1) \<in> {x. sqrt 3 * Re x > Im x}" by fast
    moreover have "1/x = (1/x-1) + 1" by simp
    ultimately show "x \<in> {x. 1 / x \<in> (\<lambda>x. x + 1) ` {x. sqrt 3 * Re x > Im x}}"
      by blast
  qed
qed

definition lower_circle_01 :: "complex set" where
"lower_circle_01 = {x. cmod (x - (1/2 - sqrt(3)/6 * \<i>)) < sqrt 3 / 3}"

lemma cnj_upper_circle_01: "cnj ` upper_circle_01 = lower_circle_01"
proof
  show "cnj ` upper_circle_01 \<subseteq> lower_circle_01"
  proof
    fix x assume "x \<in> cnj ` upper_circle_01"
    then obtain y where "y \<in> upper_circle_01" and "x = cnj y" by blast
    thus "x \<in> lower_circle_01"
      apply (subst lower_circle_01_def, subst complex_mod_cnj[symmetric])
      by (auto simp add: upper_circle_01_def del: complex_mod_cnj)
  qed
  show "lower_circle_01 \<subseteq> cnj ` upper_circle_01"
  proof
    fix x assume "x \<in> lower_circle_01"
    hence "cnj x \<in> upper_circle_01" and "x = cnj (cnj x)"
      apply (subst upper_circle_01_def, subst complex_mod_cnj[symmetric])
      by (auto simp add: lower_circle_01_def del: complex_mod_cnj)
    thus "x \<in> cnj ` upper_circle_01"
      by blast
  qed
qed

lemma lower_circle_map:
  "{x::complex. 1 / x \<in> (\<lambda>x. x + 1) ` {x. Im x > - sqrt 3 * Re x}} = lower_circle_01"
proof (subst cnj_upper_circle_01[symmetric], subst upper_circle_map[symmetric])
  have "{x. 1 / x \<in> (\<lambda>x. x + 1) ` {x. - sqrt 3 * Re x < Im x}} =
        {x. 1 / x \<in> (\<lambda>x. x + 1) ` {x. sqrt 3 * Re (cnj x) > Im (cnj x)}}"
    by auto
  also have "... = {x. 1 / x \<in> (\<lambda>x. x + 1) ` cnj ` {x. sqrt 3 * Re x > Im x}}"
    apply (subst(2) bij_image_Collect_eq)
     apply (metis bijI' complex_cnj_cnj)
    by (auto simp: inj_def inj_imp_inv_eq[of _ cnj])
  also have "... = {x. 1 / x \<in> cnj ` (\<lambda>x. x + 1) ` {x. sqrt 3 * Re x > Im x}}"
    by (auto simp: image_image)
  also have "... = {x. cnj (1 / x) \<in> (\<lambda>x. x + 1) ` {x. sqrt 3 * Re x > Im x}}"
    by (metis (no_types, lifting) complex_cnj_cnj image_iff)
  also have "... = cnj ` {x. 1 / x \<in> (\<lambda>x. x + 1) ` {x. sqrt 3 * Re x > Im x}}"
    apply (subst(2) bij_image_Collect_eq)
     apply (metis bijI' complex_cnj_cnj)
    by (auto simp: inj_def inj_imp_inv_eq[of _ cnj])
  finally show "{x. 1 / x \<in> (\<lambda>x. x + 1) ` {x. - sqrt 3 * Re x < Im x}} =
          cnj ` {x. 1 / x \<in> (\<lambda>x. x + 1) ` {x. Im x < sqrt 3 * Re x}}" .
qed

lemma two_circles_01:
  fixes P::"real poly"
  assumes hP: "degree P \<le> p" and hP0: "P \<noteq> 0" and hp0: "p \<noteq> 0"
  and h: "proots_count (map_poly of_real P)
          (upper_circle_01 \<union> lower_circle_01) = 1"
shows "Bernstein_changes_01 p P = 1"
proof (subst Bernstein_changes_01_eq_changes[OF hP])
  let ?Q = "reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]"
  have hQ0: "?Q \<noteq> 0" using hP0
    by (simp add: pcompose_eq_0 hP reciprocal_0_iff)

  from h obtain x' where hroot': "poly (map_poly of_real P) x' = 0"
    and hx':"x' \<in> upper_circle_01 \<union> lower_circle_01"
    using proots_count_pos by (metis less_numeral_extra(1))

  obtain x where hxx': "x' = complex_of_real x"
  proof (cases "Im x' = 0")
    assume "Im x' = 0" and h: "\<And>x. x' = complex_of_real x \<Longrightarrow> thesis"
    then show thesis using h[of "Re x'"] by (simp add: complex_is_Real_iff)
  next
    assume hx'': "Im x' \<noteq> 0"
    have 1: "card {x', cnj x'} = 2"
    proof (subst card_2_iff)
      from hx'' have "x' \<noteq> cnj x'" and "{x', cnj x'} = {x', cnj x'}"
        by (metis cnj.simps(2) neg_equal_zero, argo)
      thus "\<exists>x y. {x', cnj x'} = {x, y} \<and> x \<noteq> y" by blast
    qed
    moreover have "{x', cnj x'} \<subseteq> upper_circle_01 \<union> lower_circle_01" using hx'
      apply (rule UnE)
      by (auto simp: cnj_upper_circle_01[symmetric])
    moreover have "\<And>x. x \<in> {x', cnj x'} \<Longrightarrow> poly (map_poly of_real P) x = 0"
      using hroot' poly_map_poly_of_real_cnj by auto
    ultimately have
      "proots_count (map_poly of_real P) (upper_circle_01 \<union> lower_circle_01) \<ge> 2"
      apply (subst 1[symmetric])
      apply (rule proots_count_of_root_set)
      using assms(2) of_real_poly_eq_0_iff by (blast, blast, blast)
    thus thesis using assms(4) by linarith
  qed
  hence hroot: "poly P x = 0"
    using hroot' by (metis of_real_0 of_real_eq_iff of_real_poly_map_poly)
  have that: "3 * sqrt (x * x + 1 / 3 - x) < sqrt 3" using hx'
    apply (rule UnE)
    by (auto simp: cmod_def power2_eq_square algebra_simps upper_circle_01_def
        lower_circle_01_def hxx')
  have hx: "0 < x \<and> x < 1"
  proof -
    have "3 * sqrt (x * x + 1 / 3 - x) = sqrt (9 * (x * x + 1 / 3 - x))"
      by (subst real_sqrt_mult, simp)
    hence "9 * (x * x + 1 / 3 - x) < 3" using that real_sqrt_less_iff by metis
    hence "x*x - x < 0" by auto
    thus "0 < x \<and> x < 1"
      using mult_eq_0_iff mult_less_cancel_right_disj by fastforce
  qed

  let ?y = "1/x - 1"
  from hroot hx assms have "poly ?Q ?y = 0"
    by (auto simp: poly_pcompose poly_reciprocal)
  hence "[:-?y, 1:] dvd ?Q" using poly_eq_0_iff_dvd by blast
  then obtain R where hR: "?Q = R * [:-?y, 1:]" by auto
  hence hR0: "R \<noteq> 0" using hQ0 by force
  interpret map_poly_idom_hom complex_of_real ..

  have "normal_poly (smult (inverse (lead_coeff (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]))) R)"
  proof (rule normal_poly_of_roots)
    show "\<And>z. poly (map_poly complex_of_real
          (smult (inverse (lead_coeff (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]))) R)) z = 0 \<Longrightarrow>
          Re z \<le> 0 \<and> (cmod z)\<^sup>2 \<le> 4 * (Re z)\<^sup>2"
    proof -
      fix z
      assume
        "poly (map_poly complex_of_real
         (smult (inverse (lead_coeff (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]))) R)) z = 0"
      hence hroot2: "poly (map_poly complex_of_real R) z = 0"
        by (auto simp: map_poly_smult hQ0)
      show "Re z \<le> 0 \<and> (cmod z)\<^sup>2 \<le> 4 * (Re z)\<^sup>2"
      proof (rule ccontr)
        assume "\<not> (Re z \<le> 0 \<and> (cmod z)\<^sup>2 \<le> 4 * (Re z)\<^sup>2)"
        hence 1: "0 < Re z \<or> 4 * (Re z)\<^sup>2 < (cmod z)\<^sup>2" by linarith
        hence hz: "z \<noteq> -1" by force
        have "Im z > - sqrt 3 * Re z \<or> sqrt 3 * Re z > Im z"
        proof (cases "Im z \<ge> sqrt 3 * Re z", cases "- sqrt 3 * Re z \<ge> Im z")
          assume 2: "sqrt 3 * Re z \<le> Im z" "Im z \<le> - sqrt 3 * Re z"
          hence "sqrt 3 * Re z \<le> sqrt 3 * - Re z" by force
          hence "Re z \<le> - Re z"
            apply (rule mult_left_le_imp_le)
            by fastforce
          hence "Re z \<le> 0" by simp
          moreover have "(Im z)^2 \<le> (-sqrt 3 * Re z)^2"
            apply (subst power2_eq_square, subst power2_eq_square)
            apply (rule square_bounded_le)
            using 2 by auto
          ultimately have False using 1
            by (auto simp: power2_eq_square cmod_def algebra_simps)
          thus ?thesis by fast
        qed auto

        hence "z \<in> {z. - sqrt 3 * Re z < Im z} \<union> {z. Im z < sqrt 3 * Re z}"
          by blast

        hence 1: "inverse (1 + z) \<in> upper_circle_01 \<union> lower_circle_01"
          by (force simp: inverse_eq_divide upper_circle_map[symmetric]
              lower_circle_map[symmetric])

        have hRdeg': "degree R < p"
          apply (rule less_le_trans[of "degree R" "degree ?Q"])
           apply (subst hR, subst degree_mult_eq[OF hR0], fastforce, fastforce)
          by (auto simp: degree_pcompose degree_reciprocal hP)
        hence hRdeg: "degree R \<le> p" by fastforce
        have 2: "map_poly complex_of_real (reciprocal_poly p (R \<circ>\<^sub>p [:-1, 1:])) \<noteq> 0"
          apply (subst of_real_poly_eq_0_iff, subst reciprocal_0_iff)
           apply (force simp: hRdeg degree_pcompose)
          using hR0 pcompose_eq_0
          by (metis degree_eq_zeroE gr_zeroI pCons_eq_iff pCons_one zero_neq_one)
        have 3:
          "poly (map_poly complex_of_real (reciprocal_poly p (R \<circ>\<^sub>p [:-1, 1:])))
                 (inverse (1 + z)) = 0"
          apply (subst map_poly_reciprocal)
          using hRdeg apply (force simp: degree_pcompose)
           apply auto[1]
          apply (subst poly_reciprocal)
          using hRdeg apply (force simp: degree_map_poly degree_pcompose)
          using hz apply (metis inverse_nonzero_iff_nonzero neg_eq_iff_add_eq_0)
          by (auto simp: of_real_hom.map_poly_pcompose poly_pcompose hroot2)

        have "proots_count (map_poly of_real (reciprocal_poly p (R \<circ>\<^sub>p [:-1, 1:])))
               (upper_circle_01 \<union> lower_circle_01) > 0"
          by (rule proots_count_of_root[OF 2 1 3])
        moreover have "proots_count
                     (map_poly complex_of_real
                     (reciprocal_poly p ([:1 - 1 / x, 1:] \<circ>\<^sub>p [:- 1, 1:])))
                     (upper_circle_01 \<union> lower_circle_01) > 0"
          apply (subst map_poly_reciprocal)
            using hp0 less_eq_Suc_le apply (simp add: degree_pcompose)
           apply simp
            apply (subst proots_count_reciprocal)
            using hp0 less_eq_Suc_le
               apply (simp add: degree_pcompose degree_map_poly)
              apply (auto simp: pcompose_pCons)[1]
             apply (auto simp: cmod_def power2_eq_square real_sqrt_divide
                    real_div_sqrt upper_circle_01_def lower_circle_01_def)[1]
            apply (subst of_real_hom.map_poly_pcompose)
            apply (subst proots_pcompose, fastforce, force)
            apply (subst lower_circle_map[symmetric])
            apply (subst upper_circle_map[symmetric])
            apply (rule proots_count_of_root[of _ "of_real (1/x - 1)"])
              apply simp
             apply (auto simp: bij_image_Collect_eq bij_def inj_def image_iff
                    inverse_eq_divide inj_imp_inv_eq[of _ "\<lambda> x. x+1"] hx simp del: surj_plus_right)[1]
            by force

          ultimately have "proots_count
                 (map_poly complex_of_real (reciprocal_poly p (R \<circ>\<^sub>p [:- 1, 1:])))
                 (upper_circle_01 \<union> lower_circle_01) +
            proots_count
             (map_poly complex_of_real
               (reciprocal_poly p ([:1 - 1 / x, 1:] \<circ>\<^sub>p [:- 1, 1:])))
             (upper_circle_01 \<union> lower_circle_01) > 1"
          by fastforce
        also have "... = proots_count (map_poly complex_of_real
                   (monom 1 p * reciprocal_poly p (?Q \<circ>\<^sub>p [:- 1, 1:])))
           (upper_circle_01 \<union> lower_circle_01)"
          apply (subst eq_commute, subst hR, subst pcompose_mult)
          apply (subst reciprocal_mult, subst degree_mult_eq)
          using hR0 apply (fastforce simp: pcompose_eq_0)
              apply (fastforce simp: pcompose_pCons)
          using hRdeg' apply (simp add: degree_pcompose)
          using hRdeg apply (simp add: degree_pcompose)
          using hp0 apply (auto simp: degree_pcompose)[1]
          apply (subst hom_mult)
          apply (subst proots_count_times)
          using hp0 hRdeg' hR0
          apply (fastforce simp: reciprocal_0_iff degree_pcompose pcompose_eq_0
                 pcompose_pCons)
          by simp
        also have "... = proots_count
           (map_poly complex_of_real
             (reciprocal_poly p (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:] \<circ>\<^sub>p [:- 1, 1:])))
           (upper_circle_01 \<union> lower_circle_01)"
          apply (subst hom_mult)
          apply (subst proots_count_times)
          using hp0 hP hP0
           apply (auto simp: map_poly_reciprocal degree_pcompose
                  degree_reciprocal of_real_hom.map_poly_pcompose
                  reciprocal_0_iff degree_map_poly pcompose_eq_0)[1]
          apply (subst map_poly_monom, fastforce)
          apply (subst of_real_1, subst proots_count_monom)
           apply (auto simp: cmod_def power2_eq_square real_sqrt_divide
                  real_div_sqrt upper_circle_01_def lower_circle_01_def)[1]
          by presburger
        also have "... = 1"
          by (auto simp: pcompose_assoc["symmetric"] pcompose_pCons
              reciprocal_reciprocal hP h)
        finally show False by blast
      qed
    qed
   show "lead_coeff
         (smult (inverse (lead_coeff (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]))) R) = 1"
      by (auto simp: hR degree_add_eq_right hR0 coeff_eq_0)
  qed

  hence "changes (coeffs (smult (inverse (lead_coeff ?Q)) ?Q)) = 1"
    apply (subst hR, subst mult_smult_left[symmetric], rule normal_changes)
    by (auto simp: hx)

  moreover have "changes (coeffs (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:])) =
      changes (coeffs (smult (inverse (lead_coeff (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:])))
        (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:])))"
    by (auto simp: pcompose_eq_0 reciprocal_0_iff hP hP0 coeffs_smult
        changes_scale_const[symmetric])

  ultimately show "changes (coeffs (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:])) = 1" by argo
qed

definition upper_circle :: "real \<Rightarrow> real \<Rightarrow> complex set" where
"upper_circle l r = {x::complex.
  cmod ((x-of_real l)/(of_real (r-l)) - (1/2 + of_real (sqrt(3))/6 * \<i>)) < sqrt 3 / 3}"

lemma upper_circle_rescale: assumes "l < r"
  shows "upper_circle l r = (\<lambda> x . (x*(r - l) + l)) ` upper_circle_01"
proof
  show "upper_circle l r \<subseteq>
        (\<lambda>x. x * (of_real r - of_real l) + of_real l) ` upper_circle_01"
    apply (rule subsetI)
    apply (rule image_eqI[of _ _ "(_ - of_real l)/(of_real r - of_real l)"])
    using assms apply (auto simp: divide_simps)[1]
    by (auto simp: upper_circle_01_def upper_circle_def)
  show "(\<lambda>x. x * (of_real r - of_real l) + of_real l) ` upper_circle_01 \<subseteq>
        upper_circle l r"
    apply (rule subsetI, subst(asm) image_iff)
    using assms by (auto simp: upper_circle_01_def upper_circle_def)
qed

definition lower_circle :: "real \<Rightarrow> real \<Rightarrow> complex set" where
"lower_circle l r = {x::complex.
 cmod ((x-of_real l)/(of_real (r-l)) - (1/2 - of_real (sqrt(3))/6 * \<i>)) < sqrt 3 / 3}"

lemma lower_circle_rescale:
  assumes "l < r"
  shows "lower_circle l r = (\<lambda> x . (x*(r - l) + l)) ` lower_circle_01"
proof
  show "lower_circle l r \<subseteq> (\<lambda>x. x * (of_real r - of_real l) + of_real l) `
        lower_circle_01"
    apply (rule subsetI)
    apply (rule image_eqI[of _ _ "(_ - of_real l)/(of_real r - of_real l)"])
    using assms apply (auto simp: divide_simps)[1]
    by (auto simp: lower_circle_01_def lower_circle_def)
  show "(\<lambda>x. x * (of_real r - of_real l) + of_real l) ` lower_circle_01 \<subseteq>
        lower_circle l r"
    apply (rule subsetI, subst(asm) image_iff)
    using assms by (auto simp: lower_circle_01_def lower_circle_def)
qed

lemma two_circles:
  fixes P::"real poly" and l r::real
  assumes hlr: "l < r"
  and hP: "degree P \<le> p"
  and hP0: "P \<noteq> 0"
  and hp0: "p \<noteq> 0"
  and h: "proots_count (map_poly of_real P)
       (upper_circle l r \<union> lower_circle l r) = 1"
shows "Bernstein_changes p l r P = 1"
proof -
  have 1: "Bernstein_changes p l r P =
           Bernstein_changes_01 p (P \<circ>\<^sub>p [:l, 1:] \<circ>\<^sub>p [:0, r - l:])"
    using assms by (force simp: Bernstein_changes_eq_rescale)
  have "proots_count (map_poly complex_of_real (P \<circ>\<^sub>p [:l, 1:] \<circ>\<^sub>p [:0, r - l:]))
     (upper_circle_01 \<union> lower_circle_01) = 1"
    using assms
    by (auto simp: upper_circle_rescale lower_circle_rescale proots_pcompose image_Un
        of_real_hom.map_poly_pcompose pcompose_eq_0 image_image algebra_simps)
  thus ?thesis
    apply (subst 1)
    apply (rule two_circles_01)
    using hP apply (force simp: degree_pcompose)
    using hP0 hlr apply (fastforce simp: pcompose_eq_0)
    using hp0 apply blast
    by blast
qed

subsection \<open>The theorem of three circles\<close>

theorem three_circles:
  fixes P::"real poly" and l r::real
  assumes "l < r"
  and hP: "degree P \<le> p"
  and hP0: "P \<noteq> 0"
  and hp0: "p \<noteq> 0"
shows "proots_count (map_poly of_real P) (circle_diam l r) = 0 \<Longrightarrow>
       Bernstein_changes p l r P = 0"
  and "proots_count (map_poly of_real P)
       (upper_circle l r \<union> lower_circle l r) = 1 \<Longrightarrow>
       Bernstein_changes p l r P = 1"
  apply (rule one_circle)
  using assms apply auto[4]
  apply (rule two_circles)
  using assms by auto

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               February 2005               |
            |                   June 2005  (modified)   |
            |                 August 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  March 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_T_law_ufp
imports CSP_T_continuous CSP_T_contraction CSP_T_mono CSP_T_law_decompo
begin

(*****************************************************************

         1. cms fixed point theory in CSP-Prover
         2.
         3.
         4.

 *****************************************************************)

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)
(*
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)
declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]

(*=======================================================*
 |                                                       |
 |                        CMS                            |
 |                                                       |
 *=======================================================*)

(*-------------*
 |  existency  |
 *-------------*)

lemma semT_hasUFP_cms:
 "[| Pf = PNfun ; guardedfun (Pf) |]
  ==> [[Pf]]Tfun hasUFP"
apply (rule Banach_thm_EX)
apply (rule contraction_semTfun)
apply (simp)
done

lemma semT_UFP_cms:
  "[| Pf = PNfun ;
      guardedfun (Pf) ;
      FPmode = CMSmode |]
  ==> [[$p]]T = UFP [[Pf]]Tfun p"
apply (simp add: semT_def semTf_def)
apply (simp add: traces_iff)
apply (simp add: MT_def)
apply (simp add: semTfix_def)
done

lemma semT_UFP_fun_cms:
  "[| Pf = PNfun ;
      guardedfun (Pf) ;
      FPmode = CMSmode |]
  ==> (%p. [[$p]]T) = UFP [[Pf]]Tfun"
apply (simp (no_asm) add: fun_eq_iff)
apply (simp add: semT_UFP_cms)
done

(*---------*
 |    MT   |
 *---------*)

lemma MT_fixed_point_cms:
      "[| (Pf::'p=>('p,'a) proc) = PNfun; guardedfun Pf ; FPmode = CMSmode|]
        ==> [[Pf]]Tfun (MT::'p => 'a domT) = (MT::'p => 'a domT)"
apply (simp add: MT_def)
apply (simp add: semTfix_def)
apply (rule UFP_fp)
apply (simp add: semT_hasUFP_cms)
done

(*---------*
 |  unique |
 *---------*)

lemma ALL_cspT_unique_cms:
  "[| Pf = PNfun ; guardedfun Pf ;
       FPmode = CMSmode ;
       ALL p. (Pf p) << f =T f p |] ==> ALL p. f p =T $p"
apply (simp add: cspT_semantics)
apply (simp add: fun_eq_iff[THEN sym])
apply (rule hasUFP_unique_solution[of "[[PNfun]]Tfun"])
apply (simp add: semT_hasUFP_cms)

apply (simp add: traces_subst)
apply (simp add: semTfun_def semTf_def)

apply (fold semTf_def semT_def)
apply (simp add: semT_UFP_fun_cms)
apply (simp add: UFP_fp semT_hasUFP_cms)
done

lemma cspT_unique_cms:
  "[| Pf = PNfun ; guardedfun Pf ;
       FPmode = CMSmode ;
       ALL p. (Pf p) << f =T f p |] ==> f p =T $p"
by (simp add: ALL_cspT_unique_cms)

(*-------------------------------------------------------*
 |                                                       |
 |           Fixpoint unwind (CSP-Prover rule)           |
 |                                                       |
 *-------------------------------------------------------*)

lemma ALL_cspT_unwind_cms:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode |]
     ==> ALL p. ($p =T Pf p)"
apply (simp add: cspT_semantics)
apply (simp add: traces_iff)
apply (simp add: MT_def)
apply (simp add: semTfix_def)
apply (simp add: fun_eq_iff[THEN sym])
apply (simp add: traces_semTfun)
apply (simp add: UFP_fp semT_hasUFP_cms)
done

(*  csp law  *)

lemma cspT_unwind_cms:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode |]
     ==> $p =T Pf p"
by (simp add: ALL_cspT_unwind_cms)

(*-------------------------------------------------------*
 |                                                       |
 |    fixed point inducntion (CSP-Prover intro rule)     |
 |                                                       |
 *-------------------------------------------------------*)

(*----------- refinement -----------*)

(*** left ***)

lemma cspT_fp_induct_cms_ref_left_ALL:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode ;
       f p <=T Q ;
       ALL p. (Pf p)<<f <=T f p |]
    ==> $p <=T Q"
apply (simp add: refT_semT)
apply (insert cms_fixpoint_induction_ref
       [of "[[Pf]]Tfun" "(%p. [[f p]]T)" "UFP [[Pf]]Tfun"])
apply (simp add: UFP_fp semT_hasUFP_cms)
apply (simp add: fold_order_prod_def)
apply (simp add: semT_subst_semTfun)
apply (simp add: mono_semTfun)

apply (simp add: contra_alpha_to_contst contraction_alpha_semTfun)
apply (simp add: to_distance_rs)
apply (simp add: order_prod_def)
apply (drule_tac x="p" in spec)+
apply (simp add: semT_UFP_cms)
done

(*  csp law  *)

lemma cspT_fp_induct_cms_ref_left:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode ;
       f p <=T Q;
       !! p. (Pf p)<<f <=T f p |]
    ==> $p <=T Q"
by (simp add: cspT_fp_induct_cms_ref_left_ALL)

(*** right ***)

lemma cspT_fp_induct_cms_ref_right_ALL:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode ;
       Q <=T f p;
       ALL p. f p <=T (Pf p)<<f |]
    ==> Q <=T $p"
apply (simp add: refT_semT)
apply (insert cms_fixpoint_induction_rev
       [of "[[Pf]]Tfun" "(%p. [[f p]]T)" "UFP [[Pf]]Tfun"])
apply (simp add: UFP_fp semT_hasUFP_cms)
apply (simp add: fold_order_prod_def)
apply (simp add: semT_subst_semTfun)
apply (simp add: mono_semTfun)

apply (simp add: contra_alpha_to_contst contraction_alpha_semTfun)
apply (simp add: to_distance_rs)
apply (simp add: order_prod_def)
apply (drule_tac x="p" in spec)+

apply (simp add: semT_UFP_cms)
done

(*  csp law  *)

lemma cspT_fp_induct_cms_ref_right:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode ;
       Q <=T f p;
       !! p. f p <=T (Pf p)<<f |]
    ==> Q <=T $p"
by (simp add: cspT_fp_induct_cms_ref_right_ALL)

(*----------- equality -----------*)

(*** left ***)

lemma cspT_fp_induct_cms_eq_left_ALL:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode ;
       f p =T Q ;
       ALL p. (Pf p)<<f =T f p |]
    ==> $p =T Q"
apply (simp add: eqT_semT)
apply (simp add: fun_eq_iff[THEN sym])
apply (simp add: semT_subst_semTfun)
apply (insert semT_UFP_fun_cms[of Pf])
apply (simp)
apply (subgoal_tac "(%p. [[$p]]T) = (%p. [[f p]]T)")
apply (simp add: fun_eq_iff)

apply (rule hasUFP_unique_solution[of "[[Pf]]Tfun"])
apply (simp_all add: semT_hasUFP_cms)
apply (simp add: UFP_fp semT_hasUFP_cms)
done

(*  csp law  *)

lemma cspT_fp_induct_cms_eq_left:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode ;
       f p =T Q ;
       !! p. (Pf p)<<f =T f p |]
    ==> $p =T Q"
by (simp add: cspT_fp_induct_cms_eq_left_ALL)

lemma cspT_fp_induct_cms_eq_right:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode ;
       Q =T f p;
       !! p. f p =T (Pf p)<<f |]
    ==> Q =T $p"
apply (rule cspT_sym)
apply (rule cspT_fp_induct_cms_eq_left[of Pf f p Q])
apply (simp_all)
apply (rule cspT_sym)
apply (simp)
apply (rule cspT_sym)
apply (simp)
done

lemmas cspT_fp_induct_cms_left
     = cspT_fp_induct_cms_ref_left cspT_fp_induct_cms_eq_left

lemmas cspT_fp_induct_cms_right
     = cspT_fp_induct_cms_ref_right cspT_fp_induct_cms_eq_right

(****************** to add them again ******************)
(*
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)

declare Sup_image_eq [simp]
declare Inf_image_eq [simp]

end