(* Author: Tobias Nipkow and Gerwin Klein *)

section "Compiler for IMP"

theory Chapter8_2 imports "Chapter7_8/Big_Step" "~~/src/HOL/IMP/Star"
begin

subsection "List setup"

text {*
  In the following, we use the length of lists as integers
  instead of natural numbers. Instead of converting @{typ nat}
  to @{typ int} explicitly, we tell Isabelle to coerce @{typ nat}
  automatically when necessary.
*}
declare [[coercion_enabled]]
declare [[coercion "int :: nat \<Rightarrow> int"]]

text {*
  Similarly, we will want to access the ith element of a list,
  where @{term i} is an @{typ int}.
*}
fun inth :: "'a list \<Rightarrow> int \<Rightarrow> 'a" (infixl "!!" 100) where
"(x # xs) !! i = (if i = 0 then x else xs !! (i - 1))"

text {*
  The only additional lemma we need about this function
  is indexing over append:
*}
lemma inth_append [simp]:
  "0 \<le> i \<Longrightarrow>
  (xs @ ys) !! i = (if i < size xs then xs !! i else ys !! (i - size xs))"
by (induction xs arbitrary: i) (auto simp: algebra_simps)

text{* We hide coercion @{const int} applied to @{const length}: *}

abbreviation (output)
  "isize xs == int (length xs)"

notation isize ("size")

subsection "Instructions and Stack Machine"

text_raw{*\snip{instrdef}{0}{1}{% *}
datatype instr =
  LOADI int | LOAD vname | ADD | STORE vname |
  JMP int | JMPLESS int | JMPGE int
text_raw{*}%endsnip*}

type_synonym stack = "val list"
type_synonym config = "int \<times> state \<times> stack"

abbreviation "hd2 xs == hd(tl xs)"
abbreviation "tl2 xs == tl(tl xs)"

fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
"iexec instr (i,s,stk) = (case instr of
  LOADI n \<Rightarrow> (i+1,s, n#stk) |
  LOAD x \<Rightarrow> (i+1,s, s x # stk) |
  ADD \<Rightarrow> (i+1,s, (hd2 stk + hd stk) # tl2 stk) |
  STORE x \<Rightarrow> (i+1,s(x := hd stk),tl stk) |
  JMP n \<Rightarrow>  (i+1+n,s,stk) |
  JMPLESS n \<Rightarrow> (if hd2 stk < hd stk then i+1+n else i+1,s,tl2 stk) |
  JMPGE n \<Rightarrow> (if hd2 stk >= hd stk then i+1+n else i+1,s,tl2 stk))"

definition
  exec1 :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
     ("(_/ \<turnstile> (_ \<rightarrow>/ _))" [59,0,59] 60)
where
  "P \<turnstile> c \<rightarrow> c' =
  (\<exists>i s stk. c = (i,s,stk) \<and> c' = iexec(P!!i) (i,s,stk) \<and> 0 \<le> i \<and> i < size P)"

lemma exec1I [intro, code_pred_intro]:
  "c' = iexec (P!!i) (i,s,stk) \<Longrightarrow> 0 \<le> i \<Longrightarrow> i < size P
  \<Longrightarrow> P \<turnstile> (i,s,stk) \<rightarrow> c'"
by (simp add: exec1_def)

abbreviation
  exec :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool" ("(_/ \<turnstile> (_ \<rightarrow>*/ _))" 50)
where
  "exec P \<equiv> star (exec1 P)"

declare star.step[intro]

lemmas exec_induct = star.induct [of "exec1 P", split_format(complete)]

code_pred exec1 by (metis exec1_def)

values
  "{(i,map t [''x'',''y''],stk) | i t stk.
    [LOAD ''y'', STORE ''x''] \<turnstile>
    (0, <''x'' := 3, ''y'' := 4>, []) \<rightarrow>* (i,t,stk)}"

subsection{* Verification infrastructure *}

text{* Below we need to argue about the execution of code that is embedded in
larger programs. For this purpose we show that execution is preserved by
appending code to the left or right of a program. *}

lemma iexec_shift [simp]:
  "((n+i',s',stk') = iexec x (n+i,s,stk)) = ((i',s',stk') = iexec x (i,s,stk))"
by(auto split:instr.split)

lemma exec1_appendR: "P \<turnstile> c \<rightarrow> c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow> c'"
by (auto simp: exec1_def)

lemma exec_appendR: "P \<turnstile> c \<rightarrow>* c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow>* c'"
by (induction rule: star.induct) (fastforce intro: exec1_appendR)+

lemma exec1_appendL:
  fixes i i' :: int
  shows
  "P \<turnstile> (i,s,stk) \<rightarrow> (i',s',stk') \<Longrightarrow>
   P' @ P \<turnstile> (size(P')+i,s,stk) \<rightarrow> (size(P')+i',s',stk')"
  unfolding exec1_def
  by (auto simp del: iexec.simps)

lemma exec_appendL:
  fixes i i' :: int
  shows
 "P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')  \<Longrightarrow>
  P' @ P \<turnstile> (size(P')+i,s,stk) \<rightarrow>* (size(P')+i',s',stk')"
  by (induction rule: exec_induct) (blast intro!: exec1_appendL)+

text{* Now we specialise the above lemmas to enable automatic proofs of
@{prop "P \<turnstile> c \<rightarrow>* c'"} where @{text P} is a mixture of concrete instructions and
pieces of code that we already know how they execute (by induction), combined
by @{text "@"} and @{text "#"}. Backward jumps are not supported.
The details should be skipped on a first reading.

If we have just executed the first instruction of the program, drop it: *}

lemma exec_Cons_1 [intro]:
  "P \<turnstile> (0,s,stk) \<rightarrow>* (j,t,stk') \<Longrightarrow>
  instr#P \<turnstile> (1,s,stk) \<rightarrow>* (1+j,t,stk')"
by (drule exec_appendL[where P'="[instr]"]) simp

lemma exec_appendL_if[intro]:
  fixes i i' j :: int
  shows
  "size P' <= i
   \<Longrightarrow> P \<turnstile> (i - size P',s,stk) \<rightarrow>* (j,s',stk')
   \<Longrightarrow> i' = size P' + j
   \<Longrightarrow> P' @ P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')"
by (drule exec_appendL[where P'=P']) simp

text{* Split the execution of a compound program up into the excution of its
parts: *}

lemma exec_append_trans[intro]:
  fixes i' i'' j'' :: int
  shows
"P \<turnstile> (0,s,stk) \<rightarrow>* (i',s',stk') \<Longrightarrow>
 size P \<le> i' \<Longrightarrow>
 P' \<turnstile>  (i' - size P,s',stk') \<rightarrow>* (i'',s'',stk'') \<Longrightarrow>
 j'' = size P + i''
 \<Longrightarrow>
 P @ P' \<turnstile> (0,s,stk) \<rightarrow>* (j'',s'',stk'')"
by(metis star_trans[OF exec_appendR exec_appendL_if])

declare Let_def[simp]

subsection "Compilation"

fun acomp :: "aexp \<Rightarrow> instr list" where
"acomp (N n) = [LOADI n]" |
"acomp (V x) = [LOAD x]" |
"acomp (Plus a1 a2) = acomp a1 @ acomp a2 @ [ADD]"

lemma acomp_correct[intro]:
  "acomp a \<turnstile> (0,s,stk) \<rightarrow>* (size(acomp a),s,aval a s#stk)"
by (induction a arbitrary: stk) fastforce+

fun bcomp :: "bexp \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> instr list" where
"bcomp (Bc v) f n = (if v=f then [JMP n] else [])" |
"bcomp (Not b) f n = bcomp b (\<not>f) n" |
"bcomp (And b1 b2) f n =
 (let cb2 = bcomp b2 f n;
        m = if f then size cb2 else (size cb2::int)+n;
      cb1 = bcomp b1 False m
  in cb1 @ cb2)" |
"bcomp (Less a1 a2) f n =
 acomp a1 @ acomp a2 @ (if f then [JMPLESS n] else [JMPGE n])"

value
  "bcomp (And (Less (V ''x'') (V ''y'')) (Not(Less (V ''u'') (V ''v''))))
     False 3"

lemma bcomp_correct[intro]:
  fixes n :: int
  shows
  "0 \<le> n \<Longrightarrow>
  bcomp b f n \<turnstile>
 (0,s,stk)  \<rightarrow>*  (size(bcomp b f n) + (if f = bval b s then n else 0),s,stk)"
proof(induction b arbitrary: f n)
  case Not
  from Not(1)[where f="~f"] Not(2) show ?case by fastforce
next
  case (And b1 b2)
  from And(1)[of "if f then size(bcomp b2 f n) else size(bcomp b2 f n) + n"
                 "False"]
       And(2)[of n f] And(3)
  show ?case by fastforce
qed fastforce+

fun ccomp :: "com \<Rightarrow> instr list" where
"ccomp SKIP = []" |
"ccomp (x ::= a) = acomp a @ [STORE x]" |
"ccomp (c\<^sub>1;;c\<^sub>2) = ccomp c\<^sub>1 @ ccomp c\<^sub>2" |
"ccomp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) =
  (if c\<^sub>2 = SKIP then
    (let cc\<^sub>1 = ccomp c\<^sub>1; cb = bcomp b False (size cc\<^sub>1) in cb @ cc\<^sub>1)
   else (let cc\<^sub>1 = ccomp c\<^sub>1; cc\<^sub>2 = ccomp c\<^sub>2; cb = bcomp b False (size cc\<^sub>1 + 1)
   in cb @ cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2))" |
"ccomp (WHILE b DO c) =
 (let cc = ccomp c; cb = bcomp b False (size cc + 1)
  in cb @ cc @ [JMP (-(size cb + size cc + 1))])" |
"ccomp (REPEAT c UNTIL b) =
 (let cc = ccomp c; cb = bcomp b True 1 in cc @ cb @ [JMP (-(size cb + size cc + 1))])"

value "ccomp
 (IF Less (V ''u'') (N 1) THEN ''u'' ::= Plus (V ''u'') (N 1)
  ELSE ''v'' ::= V ''u'')"

value "ccomp (WHILE Less (V ''u'') (N 1) DO (''u'' ::= Plus (V ''u'') (N 1)))"

subsection "Preservation of semantics"

lemma ccomp_bigstep:
  "(c,s) \<Rightarrow> t \<Longrightarrow> ccomp c \<turnstile> (0,s,stk) \<rightarrow>* (size(ccomp c),t,stk)"
proof(induction arbitrary: stk rule: big_step_induct)
  case (Assign x a s)
  show ?case by (fastforce simp:fun_upd_def cong: if_cong)
next
  case (Seq c1 s1 s2 c2 s3)
  let ?cc1 = "ccomp c1"  let ?cc2 = "ccomp c2"
  have "?cc1 @ ?cc2 \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cc1,s2,stk)"
    using Seq.IH(1) by fastforce
  moreover
  have "?cc1 @ ?cc2 \<turnstile> (size ?cc1,s2,stk) \<rightarrow>* (size(?cc1 @ ?cc2),s3,stk)"
    using Seq.IH(2) by fastforce
  ultimately show ?case by simp (blast intro: star_trans)
next
  case (WhileTrue b s1 c s2 s3)
  let ?cc = "ccomp c"
  let ?cb = "bcomp b False (size ?cc + 1)"
  let ?cw = "ccomp(WHILE b DO c)"
  have "?cw \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cb,s1,stk)"
    using `bval b s1` by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb,s1,stk) \<rightarrow>* (size ?cb + size ?cc,s2,stk)"
    using WhileTrue.IH(1) by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb + size ?cc,s2,stk) \<rightarrow>* (0,s2,stk)"
    by fastforce
  moreover
  have "?cw \<turnstile> (0,s2,stk) \<rightarrow>* (size ?cw,s3,stk)" by(rule WhileTrue.IH(2))
  ultimately show ?case by(blast intro: star_trans)
next
  case (RepeatTrue b s2 c s1 s3 stk)
   (* ccomp (REPEAT c_ UNTIL b_) \<turnstile> (0, s\<^sub>1_, stk) \<rightarrow>* (size (ccomp (REPEAT c_ UNTIL b_)), s\<^sub>3_, stk) *)
   let ?cc = "ccomp c"
   let ?cb = "bcomp b True 1"
   let ?prog = "ccomp (REPEAT c UNTIL b)"
   have prog_def: "?prog = ?cc @ ?cb @ [JMP (-(size ?cc + size ?cb + 1))]" by auto
   from RepeatTrue.IH have "?prog \<turnstile> (0, s1, stk) \<rightarrow>* (size ?cc, s2, stk)" by fastforce
   moreover from `\<not>bval b s2` bcomp_correct[where n=1 and b=b and f=True and s=s2 and stk=stk]
     have "?cb \<turnstile> (0, s2, stk) \<rightarrow>* (size ?cb, s2, stk)"
     by auto
   moreover have "?cc @ ?cb \<turnstile> (size ?cc, s2, stk) \<rightarrow>* (size ?cc + size ?cb, s2, stk)" using exec_appendL calculation by auto
   moreover have "?prog \<turnstile> (size ?cc, s2, stk) \<rightarrow>* (size ?cc + size ?cb, s2, stk)" using exec_appendR calculation prog_def append_assoc by metis
   moreover have "?prog \<turnstile> (size ?cc + size ?cb, s2, stk) \<rightarrow> (0, s2, stk)" by auto
   moreover have "?prog \<turnstile> (0, s1, stk) \<rightarrow>* (0, s2, stk)" by (meson star_trans calculation prog_def star_step1)
   ultimately show ?case using RepeatTrue.IH star_trans by smt
   (* FIXME smt: just needs suitable instantiation of star_trans *)
qed fastforce+

end


(*  Title:    Metric_Arith.thy
    Author:   Maximilian Schäffeler (port from HOL Light)
*)

chapter \<open>Functional Analysis\<close>

section\<^marker>\<open>tag unimportant\<close> \<open>A decision procedure for metric spaces\<close>

theory Metric_Arith
  imports HOL.Real_Vector_Spaces
begin

text\<^marker>\<open>tag unimportant\<close> \<open>
A port of the decision procedure ``Formalization of metric spaces in HOL Light''
@{cite "DBLP:journals/jar/Maggesi18"} for the type class @{class metric_space},
with the \<open>Argo\<close> solver as backend.
\<close>

named_theorems metric_prenex
named_theorems metric_nnf
named_theorems metric_unfold
named_theorems metric_pre_arith

lemmas pre_arith_simps =
  max.bounded_iff max_less_iff_conj
  le_max_iff_disj less_max_iff_disj
  simp_thms HOL.eq_commute
declare pre_arith_simps [metric_pre_arith]

lemmas unfold_simps =
  Un_iff subset_iff disjoint_iff_not_equal
  Ball_def Bex_def
declare unfold_simps [metric_unfold]

declare HOL.nnf_simps(4) [metric_prenex]

lemma imp_prenex [metric_prenex]:
  "\<And>P Q. (\<exists>x. P x) \<longrightarrow> Q \<equiv> \<forall>x. (P x \<longrightarrow> Q)"
  "\<And>P Q. P \<longrightarrow> (\<exists>x. Q x) \<equiv> \<exists>x. (P \<longrightarrow> Q x)"
  "\<And>P Q. (\<forall>x. P x) \<longrightarrow> Q \<equiv> \<exists>x. (P x \<longrightarrow> Q)"
  "\<And>P Q. P \<longrightarrow> (\<forall>x. Q x) \<equiv> \<forall>x. (P \<longrightarrow> Q x)"
  by simp_all

lemma ex_prenex [metric_prenex]:
  "\<And>P Q. (\<exists>x. P x) \<and> Q \<equiv> \<exists>x. (P x \<and> Q)"
  "\<And>P Q. P \<and> (\<exists>x. Q x) \<equiv> \<exists>x. (P \<and> Q x)"
  "\<And>P Q. (\<exists>x. P x) \<or> Q \<equiv> \<exists>x. (P x \<or> Q)"
  "\<And>P Q. P \<or> (\<exists>x. Q x) \<equiv> \<exists>x. (P \<or> Q x)"
  "\<And>P. \<not>(\<exists>x. P x) \<equiv> \<forall>x. \<not>P x"
  by simp_all

lemma all_prenex [metric_prenex]:
  "\<And>P Q. (\<forall>x. P x) \<and> Q \<equiv> \<forall>x. (P x \<and> Q)"
  "\<And>P Q. P \<and> (\<forall>x. Q x) \<equiv> \<forall>x. (P \<and> Q x)"
  "\<And>P Q. (\<forall>x. P x) \<or> Q \<equiv> \<forall>x. (P x \<or> Q)"
  "\<And>P Q. P \<or> (\<forall>x. Q x) \<equiv> \<forall>x. (P \<or> Q x)"
  "\<And>P. \<not>(\<forall>x. P x) \<equiv> \<exists>x. \<not>P x"
  by simp_all

lemma nnf_thms [metric_nnf]:
  "(\<not> (P \<and> Q)) = (\<not> P \<or> \<not> Q)"
  "(\<not> (P \<or> Q)) = (\<not> P \<and> \<not> Q)"
  "(P \<longrightarrow> Q) = (\<not> P \<or> Q)"
  "(P = Q) \<longleftrightarrow> (P \<or> \<not> Q) \<and> (\<not> P \<or> Q)"
  "(\<not> (P = Q)) \<longleftrightarrow> (\<not> P \<or> \<not> Q) \<and> (P \<or> Q)"
  "(\<not> \<not> P) = P"
  by blast+

lemmas nnf_simps = nnf_thms linorder_not_less linorder_not_le
declare nnf_simps[metric_nnf]

lemma ball_insert: "(\<forall>x\<in>insert a B. P x) = (P a \<and> (\<forall>x\<in>B. P x))"
  by blast

lemma Sup_insert_insert:
  fixes a::real
  shows "Sup (insert a (insert b s)) = Sup (insert (max a b) s)"
  by (simp add: Sup_real_def)

lemma real_abs_dist: "\<bar>dist x y\<bar> = dist x y"
  by simp

lemma maxdist_thm [THEN HOL.eq_reflection]:
  assumes "finite s" "x \<in> s" "y \<in> s"
  defines "\<And>a. f a \<equiv> \<bar>dist x a - dist a y\<bar>"
  shows "dist x y = Sup (f ` s)"
proof -
  have "dist x y \<le> Sup (f ` s)"
  proof -
    have "finite (f ` s)"
      by (simp add: \<open>finite s\<close>)
    moreover have "\<bar>dist x y - dist y y\<bar> \<in> f ` s"
      by (metis \<open>y \<in> s\<close> f_def imageI)
    ultimately show ?thesis
      using le_cSup_finite by simp
  qed
  also have "Sup (f ` s) \<le> dist x y"
    using \<open>x \<in> s\<close> cSUP_least[of s f] abs_dist_diff_le
    unfolding f_def
    by blast
  finally show ?thesis .
qed

theorem metric_eq_thm [THEN HOL.eq_reflection]:
  "x \<in> s \<Longrightarrow> y \<in> s \<Longrightarrow> x = y \<longleftrightarrow> (\<forall>a\<in>s. dist x a = dist y a)"
  by auto

ML_file "metric_arith.ML"

method_setup metric = \<open>
  Scan.succeed (SIMPLE_METHOD' o MetricArith.metric_arith_tac)
\<close> "prove simple linear statements in metric spaces (\<forall>\<exists>\<^sub>p fragment)"

end


\<^marker>\<open>creator "Peter Lammich"\<close>
\<^marker>\<open>contributor "Maximilian P. L. Haslbeck"\<close>
chapter \<open>Misc Theory for Separation Algebra\<close>
theory Sep_Algebra_Add
imports "Separation_Algebra.Sep_Tactics"
begin

paragraph \<open>Summary\<close>

text \<open>Some miscellaneous theory about spearation algebras.\<close>

section \<open>Simp-Lemmas for Separation Algebra\<close>

named_theorems sep_algebra_simps \<open>Advanced simplification lemmas for separation algebra\<close>

lemmas [sep_algebra_simps] = sep_conj_exists
lemmas [simp] = sep_conj_assoc

lemmas sep_conj_c = sep_conj_commute sep_conj_left_commute

section \<open>Separation Algebra with a Unique Zero\<close>

class unique_zero_sep_algebra = sep_algebra +
  assumes unique_zero: "x##x \<Longrightarrow> x=0"
begin
  lemma unique_zero_simps[simp]:
    "a##a \<longleftrightarrow> a=0"
    "a##b \<Longrightarrow> a+b = a \<longleftrightarrow> b=0"
    "a##b \<Longrightarrow> a+b = b \<longleftrightarrow> a=0"
    "a##b \<Longrightarrow> a + b = 0 \<longleftrightarrow> a=0 \<and> b=0"
    apply -
    using local.sep_disj_zero local.unique_zero apply blast
    apply (metis local.sep_add_disjD local.sep_add_zero local.unique_zero)
    apply (metis local.sep_add_disjD local.sep_add_zero_sym local.sep_disj_commute local.unique_zero)
    by (metis local.sep_add_disjD local.sep_add_zero local.sep_disj_zero local.unique_zero)

end

section \<open>Standard Instantiations\<close>

instantiation "fun" :: (type,plus) plus
begin
  definition [simp]: "(f1 + f2) x = (f1 x + f2 x)"
  instance
    by standard
end

instantiation "fun" :: (type,sep_algebra) sep_algebra
begin
  definition "f1 ## f2 \<longleftrightarrow> (\<forall>x. f1 x ## f2 x)"
 (* definition [simp]: "(f1 + f2) x = (f1 x + f2 x)" *)
  definition [simp]: "0 x \<equiv> 0"

  instance
    apply standard
    unfolding sep_disj_fun_def plus_fun_def zero_fun_def
    apply (auto)
    subgoal
      by (simp add: sep_disj_commute)
    subgoal
      using sep_add_commute by auto
    subgoal
      by (simp add: sep_add_assoc)
    subgoal
      using sep_disj_addD1 by blast
    subgoal
      by (simp add: sep_disj_addI1)
    done

end

instance "fun" :: (type,unique_zero_sep_algebra) unique_zero_sep_algebra
  apply standard
  unfolding sep_disj_fun_def plus_fun_def zero_fun_def
  by (metis unique_zero)

lemma disj_fun_upd_iff[simp]:
  "\<lbrakk>f a = 0; g a = 0\<rbrakk> \<Longrightarrow> (f(a:=x) ## g(a:=y)) \<longleftrightarrow> (f ## g \<and> x ## y)"
  unfolding sep_disj_fun_def by force

instantiation option :: (sep_algebra) sep_algebra begin

  fun sep_disj_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> bool" where
    "sep_disj None None \<longleftrightarrow> True"
  | "sep_disj None (Some _) \<longleftrightarrow> True"
  | "sep_disj (Some _) None \<longleftrightarrow> True"
  | "sep_disj (Some x) (Some y) \<longleftrightarrow> x##y"

  lemma sep_disj_option_add_simps[simp]:
    "sep_disj None x"
    "sep_disj x None"
    by (cases x; simp)+

  fun plus_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> 'a option" where
    "plus None None = None"
  | "plus None (Some x) = Some x"
  | "plus (Some x) None = Some x"
  | "plus (Some x) (Some y) = Some (x+y)"

  lemma plus_option_add_simps[simp]: "plus None x = x" "plus x None = x"
    by (cases x; simp)+

  definition "0 = None"

  instance
    apply standard
    apply (simp_all add: zero_option_def)
    apply (case_tac x; case_tac y; simp add: sep_disj_commute)
    apply (case_tac x; case_tac y; auto simp add: sep_disj_commute sep_add_commute)
    apply (case_tac x; case_tac y; case_tac z; simp add: sep_add_assoc)
    apply (case_tac x; case_tac y; case_tac z; auto dest: sep_disj_addD1)
    apply (case_tac x; case_tac y; case_tac z; auto dest: sep_disj_addI1)
    done

end

instantiation prod :: (sep_algebra, sep_algebra) sep_algebra
begin
  definition "a##b \<longleftrightarrow> fst a ## fst b \<and> snd a ## snd b"
  definition "a+b = (fst a + fst b, snd a + snd b)"
  definition "0 = (0,0)"

  instance
    apply standard
    unfolding sep_disj_prod_def plus_prod_def zero_prod_def
    by (auto
      simp: sep_add_ac
      intro: sep_disj_commuteI sep_disj_addD1 sep_disj_addI1)
end

lemma sep_disj_prod_lower[sep_algebra_simps]: "(a,b) ## (c,d) \<longleftrightarrow> a##c \<and> b##d"
  by (simp add: sep_disj_prod_def)

lemma plus_prod_lower[sep_algebra_simps]: "(a,b) + (c,d) = (a+c,b+d)"
  by (simp add: plus_prod_def)

instance prod :: (unique_zero_sep_algebra,unique_zero_sep_algebra) unique_zero_sep_algebra
  by standard (auto simp: zero_prod_def sep_algebra_simps)

lemma prod_Z_lower[sep_algebra_simps]:
  "(a,b) = 0 \<longleftrightarrow> a=0 \<and> b=0"
  "0 = (a,b) \<longleftrightarrow> a=0 \<and> b=0"
  by (auto simp: zero_prod_def)

lemma plus_prod_eqI: "(a+b,c+d) = (a,c) + (b,d)" by (simp add: sep_algebra_simps)

datatype 'a tsa_opt = ZERO | TRIV (the_tsa: 'a)

instantiation tsa_opt :: (type) unique_zero_sep_algebra begin
  definition sep_disj_tsa_opt :: "'a tsa_opt \<Rightarrow> 'a tsa_opt \<Rightarrow> bool"
    where "a##b \<longleftrightarrow> a=ZERO \<or> b=ZERO"

  definition "a+b \<equiv> (case (a,b) of (ZERO,x) \<Rightarrow> x | (x,ZERO) \<Rightarrow> x)"
  definition "0 = ZERO"

  instance
    apply standard
    by (auto simp: zero_tsa_opt_def sep_disj_tsa_opt_def plus_tsa_opt_def split: tsa_opt.splits)

end

instance tsa_opt :: (type) cancellative_sep_algebra
  apply standard
  by (auto simp: zero_tsa_opt_def sep_disj_tsa_opt_def plus_tsa_opt_def split: tsa_opt.splits)

(* Lowering lemmas. If one side of operation breaks abstraction level,
  the other side is also lowered
*)
lemma TRIV_not_zero[simp]: "TRIV x \<noteq> 0" "0\<noteq>TRIV x" by (auto simp: zero_tsa_opt_def)
lemma TRIV_Z_lower[intro!]:
  "ZERO = 0"
  "0 = ZERO"
  by (auto simp: zero_tsa_opt_def)

lemma triv_Z_lower2[sep_algebra_simps]:
  "x + ZERO = x"
  "ZERO + x = x"
  by (auto simp: zero_tsa_opt_def plus_tsa_opt_def split: tsa_opt.splits)

lemma TRIV_disj_simps[sep_algebra_simps]:
  "TRIV a ## b \<longleftrightarrow> b=ZERO"
  "b ## TRIV a \<longleftrightarrow> b=ZERO"
  by (auto simp: sep_disj_tsa_opt_def)

section \<open>Additional Simplifier Setup\<close>

(*
  This may cause trouble on non-eta-normalized terms.
    (\<lambda>s. \<box> s) \<rightarrow> \<lambda>s. s=0
  The next lemma hopefully fixes that.
*)

lemma sep_empty_app[sep_algebra_simps]: "\<box> h \<longleftrightarrow> h=0"
  by (simp add: sep_empty_def)

lemma sep_empty_I[sep_algebra_simps]: "(\<lambda>h. h=0) = \<box>"
  by (simp add: sep_empty_def)

section \<open>Pure Assertions\<close>

text \<open>The Separation Algebra entry only defines @{term "\<langle>\<Phi>\<rangle>"}, which
  makes no constraint on the heap. We define \<open>\<up>\<Phi>\<close>, which requires an empty heap,
  and is more natural when using separation logic with deallocation.
\<close>

definition pred_lift :: "bool \<Rightarrow> 'a::sep_algebra \<Rightarrow> bool" ("\<up>_" [100] 100)
  where "(\<up>\<Phi>) s \<equiv> \<Phi> \<and> \<box> s"

text \<open>Relation between \<open>pred_lift\<close> and \<open>pred_K\<close>. Warning, do not use
  as simp-lemma, as \<open>sep_true\<close> is an abbreviation for \<open>\<langle>True\<rangle>\<close>\<close>
lemma "\<langle>\<Phi>\<rangle> = (\<up>\<Phi> ** sep_true)" by (auto simp: pred_lift_def sep_conj_def sep_algebra_simps)

lemma pred_lift_move_front_simps[sep_algebra_simps]:
  "(\<up>\<Phi> ** \<up>\<Psi>) = (\<up>(\<Phi>\<and>\<Psi>))"
  "(\<up>\<Phi> ** \<up>\<Psi> ** B) = (\<up>(\<Phi>\<and>\<Psi>) ** B)"
  "NO_MATCH (\<up>X) A \<Longrightarrow> (A ** \<up>\<Phi> ** B) = (\<up>\<Phi> ** A ** B)"
  "NO_MATCH (\<up>X) A \<Longrightarrow> (A ** \<up>\<Phi>) = (\<up>\<Phi> ** A)"
  by (auto simp: pred_lift_def sep_conj_def sep_algebra_simps)

lemma pred_lift_extract_simps:
  "(\<up>\<Phi>) h \<longleftrightarrow> \<Phi> \<and> h=0"
  "(\<up>\<Phi> ** A) h \<longleftrightarrow> \<Phi> \<and> A h"
  by (auto simp: pred_lift_def sep_conj_def sep_algebra_simps)

lemma pure_true_conv[sep_algebra_simps]: "\<up>True = \<box>" by (auto simp: sep_algebra_simps pred_lift_extract_simps)

lemma pred_lift_false_conv[simp]: "\<up>False = sep_false" by (auto simp: sep_algebra_simps pred_lift_extract_simps)

lemmas sep_conj_false_simps =
  pred_lift_false_conv
  sep_conj_false_left sep_conj_false_right

end


(*  Title:      HOL/Probability/Discrete_Topology.thy
    Author:     Fabian Immler, TU München
*)

theory Discrete_Topology
imports "HOL-Analysis.Analysis"
begin

text \<open>Copy of discrete types with discrete topology. This space is polish.\<close>

typedef 'a discrete = "UNIV::'a set"
morphisms of_discrete discrete
..

instantiation discrete :: (type) metric_space
begin

definition dist_discrete :: "'a discrete \<Rightarrow> 'a discrete \<Rightarrow> real"
  where "dist_discrete n m = (if n = m then 0 else 1)"

definition uniformity_discrete :: "('a discrete \<times> 'a discrete) filter" where
  "(uniformity::('a discrete \<times> 'a discrete) filter) = (INF e\<in>{0 <..}. principal {(x, y). dist x y < e})"

definition "open_discrete" :: "'a discrete set \<Rightarrow> bool" where
  "(open::'a discrete set \<Rightarrow> bool) U \<longleftrightarrow> (\<forall>x\<in>U. eventually (\<lambda>(x', y). x' = x \<longrightarrow> y \<in> U) uniformity)"

instance proof qed (auto simp: uniformity_discrete_def open_discrete_def dist_discrete_def intro: exI[where x=1])
end

lemma open_discrete: "open (S :: 'a discrete set)"
  unfolding open_dist dist_discrete_def by (auto intro!: exI[of _ "1 / 2"])

instance discrete :: (type) complete_space
proof
  fix X::"nat\<Rightarrow>'a discrete"
  assume "Cauchy X"
  then obtain n where "\<forall>m\<ge>n. X n = X m"
    by (force simp: dist_discrete_def Cauchy_def split: if_split_asm dest:spec[where x=1])
  thus "convergent X"
    by (intro convergentI[where L="X n"] tendstoI eventually_sequentiallyI[of n])
       (simp add: dist_discrete_def)
qed

instance discrete :: (countable) countable
proof
  have "inj (\<lambda>c::'a discrete. to_nat (of_discrete c))"
    by (simp add: inj_on_def of_discrete_inject)
  thus "\<exists>f::'a discrete \<Rightarrow> nat. inj f" by blast
qed

instance discrete :: (countable) second_countable_topology
proof
  let ?B = "range (\<lambda>n::'a discrete. {n})"
  have "\<And>S. generate_topology ?B (\<Union>x\<in>S. {x})"
    by (intro generate_topology_Union) (auto intro: generate_topology.intros)
  then have "open = generate_topology ?B"
    by (auto intro!: ext simp: open_discrete)
  moreover have "countable ?B" by simp
  ultimately show "\<exists>B::'a discrete set set. countable B \<and> open = generate_topology B" by blast
qed

instance discrete :: (countable) polish_space ..

end


theory Polygon
imports Counterclockwise_2D_Strict
begin

subsection \<open>Polygonal chains\<close>

definition "polychain xs = (\<forall>i. Suc i<length xs \<longrightarrow> snd (xs ! i) = (fst (xs ! Suc i)))"

lemma polychainI:
  assumes "\<And>i. Suc i < length xs \<Longrightarrow> snd (xs ! i) = fst (xs ! Suc i)"
  shows "polychain xs"
  by (auto intro!: assms simp: polychain_def)

lemma polychain_Nil[simp]: "polychain [] = True"
  and polychain_singleton[simp]: "polychain [x] = True"
  by (auto simp: polychain_def)

lemma polychain_Cons:
  "polychain (y # ys) = (if ys = [] then True else snd y = fst (ys ! 0) \<and> polychain ys)"
  by (auto simp: polychain_def nth_Cons split: nat.split)

lemma polychain_appendI:
  "polychain xs \<Longrightarrow> polychain ys \<Longrightarrow> (xs \<noteq> [] \<Longrightarrow> ys \<noteq> [] \<Longrightarrow> snd (last xs) = fst (hd ys)) \<Longrightarrow>
    polychain (xs @ ys)"
  by (induct xs arbitrary: ys)
    (auto simp add: polychain_Cons nth_append hd_conv_nth split: if_split_asm)

fun pairself where "pairself f (x, y) = (f x, f y)"

lemma pairself_apply: "pairself f x = (f (fst x), f (snd x))"
  by (cases x, simp)

lemma polychain_map_pairself: "polychain xs \<Longrightarrow> polychain (map (pairself f) xs)"
  by (auto simp: polychain_def pairself_apply)

definition "convex_polychain xs \<longleftrightarrow>
  (polychain xs \<and>
  (\<forall>i. Suc i < length xs \<longrightarrow> det3 (fst (xs ! i)) (snd (xs ! i)) (snd (xs ! Suc i)) > 0))"

lemma convex_polychain_Cons2[simp]:
  "convex_polychain (x#y#zs) \<longleftrightarrow>
    snd x = fst y \<and> det3 (fst x) (fst y) (snd y) > 0 \<and> convex_polychain (y#zs)"
  by (auto simp add: convex_polychain_def polychain_def nth_Cons split: nat.split)

lemma convex_polychain_ConsD:
  assumes "convex_polychain (x#xs)"
  shows "convex_polychain xs"
  using assms by (auto simp: convex_polychain_def polychain_def nth_Cons split: nat.split)

definition
  "convex_polygon xs \<longleftrightarrow> (convex_polychain xs \<and> (xs \<noteq> [] \<longrightarrow> fst (hd xs) = snd (last xs)))"

lemma convex_polychain_Nil[simp]: "convex_polychain [] = True"
  and convex_polychain_Cons[simp]: "convex_polychain [x] = True"
  by (auto simp: convex_polychain_def)

lemma convex_polygon_Cons2[simp]:
  "convex_polygon (x#y#zs) \<longleftrightarrow> fst x = snd (last (y#zs)) \<and> convex_polychain (x#y#zs)"
  by (auto simp: convex_polygon_def convex_polychain_def polychain_def nth_Cons)

lemma polychain_append_connected:
  "polychain (xs @ ys) \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> ys \<noteq> [] \<Longrightarrow> fst (hd ys) = snd (last xs)"
  by (auto simp: convex_polychain_def nth_append not_less polychain_def last_conv_nth hd_conv_nth
    dest!: spec[where x = "length xs - 1"])

lemma convex_polychain_appendI:
  assumes cxs: "convex_polychain xs"
  assumes cys: "convex_polychain ys"
  assumes pxy: "polychain (xs @ ys)"
  assumes "xs \<noteq> [] \<Longrightarrow> ys \<noteq> [] \<Longrightarrow> det3 (fst (last xs)) (snd (last xs)) (snd (hd ys)) > 0"
  shows "convex_polychain (xs @ ys)"
proof -
  {
    fix i
    assume "i < length xs" "length xs \<le> Suc i" "Suc i < length xs + length ys"
    hence "xs \<noteq> []" "ys \<noteq> []" "i = length xs - 1" by auto
  }
  thus ?thesis
    using assms
    by (auto simp: hd_conv_nth convex_polychain_def nth_append Suc_diff_le last_conv_nth )
qed

lemma convex_polychainI:
  assumes "polychain xs"
  assumes "\<And>i. Suc i < length xs \<Longrightarrow> det3 (fst (xs ! i)) (snd (xs ! i)) (snd (xs ! Suc i)) > 0"
  shows "convex_polychain xs"
  by (auto intro!: assms simp: convex_polychain_def ccw'_def)

lemma convex_polygon_skip:
  assumes "convex_polygon (x # y # z # w # ws)"
  assumes "ccw'.sortedP (fst x) (map snd (butlast (x # y # z # w # ws)))"
  shows "convex_polygon ((fst x, snd y) # z # w # ws)"
  using assms by (auto elim!: ccw'.sortedP_Cons simp: ccw'_def[symmetric])

primrec polychain_of::"'a::ab_group_add \<Rightarrow> 'a list \<Rightarrow> ('a*'a) list" where
  "polychain_of xc [] = []"
| "polychain_of xc (xm#xs) = (xc, xc + xm)#polychain_of (xc + xm) xs"

lemma in_set_polychain_ofD: "ab \<in> set (polychain_of x xs) \<Longrightarrow> (snd ab - fst ab) \<in> set xs"
  by (induct xs arbitrary: x) auto

lemma fst_polychain_of_nth_0[simp]: "xs \<noteq> [] \<Longrightarrow> fst ((polychain_of p xs) ! 0) = p"
  by (cases xs) (auto simp: Let_def)

lemma fst_hd_polychain_of: "xs \<noteq> [] \<Longrightarrow> fst (hd (polychain_of x xs)) = x"
  by (cases xs) (auto simp: )

lemma length_polychain_of_eq[simp]:
  shows "length (polychain_of p qs) = length qs"
  by (induct qs arbitrary: p) simp_all

lemma
  polychain_of_subsequent_eq:
  assumes "Suc i < length qs"
  shows "snd (polychain_of p qs ! i) = fst (polychain_of p qs ! Suc i)"
  using assms
  by (induct qs arbitrary: p i) (auto simp add: nth_Cons split: nat.split)

lemma polychain_of_eq_empty_iff[simp]: "polychain_of p xs = [] \<longleftrightarrow> xs = []"
  by (cases xs) (auto simp: Let_def)

lemma in_set_polychain_of_imp_sum_list:
  assumes "z \<in> set (polychain_of Pc Ps)"
  obtains d where "z = (Pc + sum_list (take d Ps), Pc + sum_list (take (Suc d) Ps))"
  using assms
  apply atomize_elim
proof (induction Ps arbitrary: Pc z)
  case Nil thus ?case by simp
next
  case (Cons P Ps)
  hence "z = (Pc, Pc + P) \<or> z \<in> set (polychain_of (Pc + P) Ps)"
    by auto
  thus ?case
  proof
    assume "z \<in> set ((polychain_of (Pc + P) Ps))"
    from Cons.IH[OF this]
    obtain d
    where "z = (Pc + P + sum_list (take d Ps), Pc + P + sum_list (take (Suc d) Ps))"
      by auto
    thus ?case
      by (auto intro!: exI[where x="Suc d"])
  qed (auto intro!: exI[where x=0])
qed

lemma last_polychain_of: "length xs > 0 \<Longrightarrow> snd (last (polychain_of p xs)) = p + sum_list xs"
  by (induct xs arbitrary: p) simp_all

lemma polychain_of_singleton_iff: "polychain_of p xs = [a] \<longleftrightarrow> fst a = p \<and> xs = [(snd a - p)]"
  by (induct xs) auto

lemma polychain_of_add: "polychain_of (x + y) xs = map (((+) (y, y))) (polychain_of x xs)"
  by (induct xs arbitrary: x y) (auto simp: algebra_simps)

subsection \<open>Dirvec: Inverse of Polychain\<close>

primrec dirvec where "dirvec (x, y) = (y - x)"

lemma dirvec_minus: "dirvec x = snd x - fst x"
  by (cases x) simp

lemma dirvec_nth_polychain_of: "n < length xs \<Longrightarrow> dirvec ((polychain_of p xs) ! n ) = (xs ! n)"
  by (induct xs arbitrary: p n) (auto simp: nth_Cons split: nat.split)

lemma dirvec_hd_polychain_of: "xs \<noteq> [] \<Longrightarrow> dirvec (hd (polychain_of p xs)) = (hd xs)"
  by (simp add: hd_conv_nth dirvec_nth_polychain_of)

lemma dirvec_last_polychain_of: "xs \<noteq> [] \<Longrightarrow> dirvec (last (polychain_of p xs)) = (last xs)"
  by (simp add: last_conv_nth dirvec_nth_polychain_of)

lemma map_dirvec_polychain_of[simp]: "map dirvec (polychain_of x xs) = xs"
  by (induct xs arbitrary: x) simp_all

subsection \<open>Polychain of Sorted (@{term polychain_of}, @{term ccw'.sortedP})\<close>

lemma ccw'_sortedP_translateD:
  "linorder_list0.sortedP (ccw' x0) (map ((+) x \<circ> g) xs) \<Longrightarrow>
    linorder_list0.sortedP (ccw' (x0 - x)) (map g xs)"
proof (induct xs arbitrary: x0 x)
  case Nil thus ?case by (auto simp: linorder_list0.sortedP.Nil)
next
  case (Cons a xs x0 x)
  hence "\<forall>y\<in>set xs. ccw' (x0 - x) (g a) (g y)"
    by (auto elim!: linorder_list0.sortedP_Cons simp: ccw'.translate_origin algebra_simps)
  thus ?case
    using Cons.prems(1)
    by (auto elim!: linorder_list0.sortedP_Cons intro!: linorder_list0.sortedP.Cons simp: Cons.hyps)
qed

lemma ccw'_sortedP_translateI:
  "linorder_list0.sortedP (ccw' (x0 - x)) (map g xs) \<Longrightarrow>
    linorder_list0.sortedP (ccw' x0) (map ((+) x \<circ> g) xs)"
  using ccw'_sortedP_translateD[of "x0 - x" "-x" "(+) x o g" xs]
  by (simp add: o_def)

lemma ccw'_sortedP_translate_comp[simp]:
  "linorder_list0.sortedP (ccw' x0) (map ((+) x \<circ> g) xs) \<longleftrightarrow>
    linorder_list0.sortedP (ccw' (x0 - x)) (map g xs)"
  by (metis ccw'_sortedP_translateD ccw'_sortedP_translateI)

lemma snd_plus_commute: "snd \<circ> (+) (x0, x0) = (+) x0 o snd"
  by auto

lemma ccw'_sortedP_renormalize:
  "ccw'.sortedP a (map snd (polychain_of (x0 + x) xs)) \<longleftrightarrow>
   ccw'.sortedP (a - x0) (map snd (polychain_of x xs))"
  by (simp add: polychain_of_add add.commute snd_plus_commute)

lemma ccw'_sortedP_polychain_of01:
  shows "ccw'.sortedP 0 [u] \<Longrightarrow> ccw'.sortedP x0 (map snd (polychain_of x0 [u]))"
    and "ccw'.sortedP 0 [] \<Longrightarrow> ccw'.sortedP x0 (map snd (polychain_of x0 []))"
  by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons  simp: ac_simps)

lemma ccw'_sortedP_polychain_of2:
  assumes "ccw'.sortedP 0 [u, v]"
  shows "ccw'.sortedP x0 (map snd (polychain_of x0 [u, v]))"
  using assms
  by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons
    elim!: linorder_list0.sortedP_Cons simp: ac_simps ccw'.translate_origin)

lemma ccw'_sortedP_polychain_of3:
  assumes "ccw'.sortedP 0 (u#v#w#xs)"
  shows "ccw'.sortedP x0 (map snd (polychain_of x0 (u#v#w#xs)))"
  using assms
proof (induct xs arbitrary: x0 u v w)
  case Nil
  then have *: "ccw' 0 u v" "ccw' 0 v w" "ccw' 0 u w"
    by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons
      elim!: linorder_list0.sortedP_Cons simp: ac_simps)
  moreover have "ccw' 0 (u + v) (u + (v + w))"
    by (metis add.assoc ccw'.add1 ccw'.add3_self *(2-))
  ultimately show ?case
    by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons
      elim!: linorder_list0.sortedP_Cons simp: ac_simps ccw'.translate_origin ccw'.add3)
next
  case (Cons y ys)
  have s1: "linorder_list0.sortedP (ccw' 0)  ((u + v)#w#y#ys)" using Cons.prems
    by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons
      elim!: linorder_list0.sortedP_Cons simp: ccw'.add1)
  have s2: "linorder_list0.sortedP (ccw' 0)  (u#(v + w)#y#ys)" using Cons.prems
    by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons
      elim!: linorder_list0.sortedP_Cons simp: ccw'.add3 ccw'.add1)
  have s3: "linorder_list0.sortedP (ccw' 0)  (u#v#(w + y)#ys)" using Cons.prems
    by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons
      elim!: linorder_list0.sortedP_Cons simp: ccw'.add3 ccw'.add1)
  show ?case
    using Cons.hyps[OF s1, of x0] Cons.hyps[OF s2, of x0] Cons.hyps[OF s3, of x0] Cons.prems
    by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons
      elim!: linorder_list0.sortedP_Cons simp: ac_simps)
qed

lemma ccw'_sortedP_polychain_of_snd:
  assumes "ccw'.sortedP 0 xs"
  shows "ccw'.sortedP x0 (map snd (polychain_of x0 xs))"
  using assms
  by (metis ccw'_sortedP_polychain_of01 ccw'_sortedP_polychain_of2 ccw'_sortedP_polychain_of3
    list.exhaust)

lemma ccw'_sortedP_implies_distinct:
  assumes "ccw'.sortedP x qs"
  shows "distinct qs"
  using assms
proof induct
  case Cons thus ?case by (meson ccw'_contra distinct.simps(2))
qed simp

lemma ccw'_sortedP_implies_nonaligned:
  assumes "ccw'.sortedP x qs"
  assumes "y \<in> set qs" "z \<in> set qs" "y \<noteq> z"
  shows "\<not> coll x y z"
  using assms
  by induct (force simp: ccw'_def det3_def' algebra_simps)+

lemma list_all_mp: "list_all P xs \<Longrightarrow> (\<And>x. x \<in> set xs \<Longrightarrow> P x \<Longrightarrow> Q x) \<Longrightarrow> list_all Q xs"
  by (auto simp: list_all_iff)

lemma
  ccw'_scale_origin:
  assumes "e \<in> UNIV \<rightarrow> {0<..<1}"
  assumes "x \<in> set (polychain_of Pc (P # QRRs))"
  assumes "ccw'.sortedP 0 (P # QRRs)"
  assumes "ccw' (fst x) (snd x) (P + (Pc + (\<Sum>P\<in>set QRRs. e P *\<^sub>R P)))"
  shows "ccw' (fst x) (snd x) (e P *\<^sub>R P + (Pc + (\<Sum>P\<in>set QRRs. e P *\<^sub>R P)))"
proof -
  from assms(2) have "fst x = Pc \<and> snd x = Pc + P \<or> x \<in> set (polychain_of (Pc + P) QRRs)" by auto
  thus ?thesis
  proof
    assume x: "x \<in> set (polychain_of (Pc + P) QRRs)"
    define q where "q = snd x - fst x"
    from Polygon.in_set_polychain_of_imp_sum_list[OF x]
    obtain d where d: "fst x = (Pc + P + sum_list (take d QRRs))" by (auto simp: prod_eq_iff)
    from in_set_polychain_ofD[OF x]
    have q_in: "q \<in> set QRRs" by (simp add: q_def)
    define R where "R = set QRRs - {q}"
    hence QRRs: "set QRRs = R \<union> {q}" "q \<notin> R" "finite R" using q_in by auto
    have "ccw' 0 q (-P)"
      using assms(3)
      by (auto simp: ccw'.sortedP_Cons_iff q_in)
    hence "ccw' 0 q ((1 - e P) *\<^sub>R (-P))"
      using assms(1) by (subst ccw'.scaleR2_eq) (auto simp: algebra_simps)
    moreover
    from assms(4) have "ccw' 0 q ((\<Sum>P\<in>set QRRs. e P *\<^sub>R P) - sum_list (take d QRRs))"
      by (auto simp: q_def ccw'.translate_origin d)
    ultimately
    have "ccw' 0 q ((1 - e P) *\<^sub>R (-P) + ((\<Sum>P\<in>set QRRs. e P *\<^sub>R P) - sum_list (take d QRRs)))"
      by (intro ccw'.add3) auto
    thus ?thesis
      by (auto simp: ccw'.translate_origin q_def algebra_simps d)
  qed (metis (no_types, lifting) add.left_commute assms(4) ccw'.add3_self ccw'.scale_add3
    ccw'.translate)
qed

lemma polychain_of_ccw_convex:
  assumes "e \<in> UNIV \<rightarrow> {0 <..< 1}"
  assumes sorted: "linorder_list0.sortedP (ccw' 0) (P#Q#Ps)"
  shows "list_all
    (\<lambda>(xi, xj). ccw' xi xj (Pc + (\<Sum>P \<in> set (P#Q#Ps). e P *\<^sub>R P)))
    (polychain_of Pc (P#Q#Ps))"
  using assms(1) assms(2)
proof (induct Ps arbitrary: P Q Pc)
  case Nil
  have eq: "e P *\<^sub>R P + e Q *\<^sub>R Q - P = (1 - e P) *\<^sub>R (- P) + e Q *\<^sub>R Q"
    using \<open>e \<in> _\<close>
    by (auto simp add: algebra_simps)
  from Nil ccw'_sortedP_implies_distinct[OF Nil(2)]
  have "P \<noteq> Q" "e P < 1" "0 < e Q" "ccw' 0 P Q"
    by (auto elim!: linorder_list0.sortedP_Cons)
  thus ?case
    by (auto simp: ccw'_not_coll ccw'.translate_origin eq)
next
  case (Cons R Rs)
  hence "ccw' 0 P Q" "P \<noteq> Q" using ccw'_sortedP_implies_distinct[OF Cons(3)]
    by (auto elim!: linorder_list0.sortedP_Cons)
  have "list_all (\<lambda>(xi, xj). ccw' xi xj ((Pc + P) + (\<Sum>P\<in>set (Q # R # Rs). e P *\<^sub>R P)))
    (polychain_of (Pc + P) (Q # R # Rs))"
    using Cons(2-)
    by (intro Cons(1)) (auto elim: linorder_list0.sortedP_Cons)
  also have "polychain_of (Pc + P) (Q # R # Rs) = tl (polychain_of Pc (P # Q # R # Rs))"
    by simp
  finally have "list_all (\<lambda>(xi, xj). ccw' xi xj (Pc + P + (\<Sum>P\<in>set (Q # R # Rs). e P *\<^sub>R P)))
    (tl (polychain_of Pc (P # Q # R # Rs)))" .
  moreover
  have "list_all
      (\<lambda>(xi, xj). ccw' xi xj (P + (\<Sum>P\<in>set (Q # R # Rs). e P *\<^sub>R P)))
      (polychain_of P (Q # R # Rs))"
    using Cons(2-)
    by (intro Cons(1)) (auto elim: linorder_list0.sortedP_Cons)
  have "(\<lambda>(xi, xj). ccw' xi xj (Pc + P + (\<Sum>P\<in>set (Q # R # Rs). e P *\<^sub>R P)))
    (hd (polychain_of Pc (P # Q # R # Rs)))"
    using ccw'_sortedP_implies_nonaligned[OF Cons(3), of P Q]
      ccw'_sortedP_implies_nonaligned[OF Cons(3), of Q R]
      ccw'_sortedP_implies_nonaligned[OF Cons(3), of P R]
      Cons(2,3)
    by (auto simp add: Pi_iff add.assoc simp del: scaleR_Pair intro!: ccw'.sum
        elim!: linorder_list0.sortedP_Cons)
  ultimately
  have "list_all
      (\<lambda>(xi, xj). ccw' xi xj (P + (Pc + (\<Sum>P\<in>set (Q # R # Rs). e P *\<^sub>R P))))
      (polychain_of Pc (P # Q # R # Rs))"
    by (simp add: ac_simps)
  hence "list_all
      (\<lambda>(xi, xj). ccw' xi xj (e P *\<^sub>R P + (Pc + (\<Sum>P\<in>set (Q # R # Rs). e P *\<^sub>R P))))
      (polychain_of Pc (P # Q # R # Rs))"
    unfolding split_beta'
    by (rule list_all_mp, intro ccw'_scale_origin[OF assms(1)])
      (auto intro!: ccw'_scale_origin Cons(3))
  thus ?case
    using ccw'_sortedP_implies_distinct[OF Cons(3)] Cons
    by (simp add: ac_simps)
qed

lemma polychain_of_ccw:
  assumes "e \<in> UNIV \<rightarrow> {0 <..< 1}"
  assumes sorted: "ccw'.sortedP 0 qs"
  assumes qs: "length qs \<noteq> 1"
  shows "list_all (\<lambda>(xi, xj). ccw' xi xj (Pc + (\<Sum>P \<in> set qs. e P *\<^sub>R P))) (polychain_of Pc qs)"
  using assms
proof (cases qs)
  case (Cons Q Qs)
  note CQ = this
  show ?thesis using assms
  proof (cases Qs)
    case (Cons R Rs)
    thus ?thesis using assms
      unfolding CQ Cons
      by (intro polychain_of_ccw_convex) (auto simp: CQ Cons intro!: polychain_of_ccw_convex)
  qed (auto simp: CQ)
qed simp

lemma in_polychain_of_ccw:
  assumes "e \<in> UNIV \<rightarrow> {0 <..< 1}"
  assumes "ccw'.sortedP 0 qs"
  assumes "length qs \<noteq> 1"
  assumes "seg \<in> set (polychain_of Pc qs)"
  shows "ccw' (fst seg) (snd seg) (Pc + (\<Sum>P \<in> set qs. e P *\<^sub>R P))"
  using polychain_of_ccw[OF assms(1,2,3)] assms(4)
  by (simp add: list_all_iff split_beta)

lemma distinct_butlast_ne_last: "distinct xs \<Longrightarrow> x \<in> set (butlast xs) \<Longrightarrow> x \<noteq> last xs"
  by (metis append_butlast_last_id distinct_butlast empty_iff in_set_butlastD list.set(1)
    not_distinct_conv_prefix)

lemma
  ccw'_sortedP_convex_rotate_aux:
  assumes "ccw'.sortedP 0 (zs)" "ccw'.sortedP x (map snd (polychain_of x (zs)))"
  shows "ccw'.sortedP (snd (last (polychain_of x (zs)))) (map snd (butlast (polychain_of x (zs))))"
  using assms
proof (induct zs arbitrary: x rule: list.induct)
  case (Cons z zs)
  {
    assume "zs \<noteq> []"
    have "ccw'.sortedP (snd (last (polychain_of (x + z) zs)))
      (map snd (butlast (polychain_of (x + z) zs)))"
      using Cons.prems
      by (auto elim!: ccw'.sortedP_Cons intro!: ccw'_sortedP_polychain_of_snd Cons.hyps)
    from _ this
    have "linorder_list0.sortedP (ccw' (snd (last (polychain_of (x + z) zs))))
       ((x + z) # map snd (butlast (polychain_of (x + z) zs)))"
    proof (rule ccw'.sortedP.Cons, safe)
      fix c d
      assume cd: "(c, d) \<in> set (map snd (butlast (polychain_of (x + z) zs)))"
      then obtain a b where ab: "((a, b), c, d) \<in> set (butlast (polychain_of (x + z) zs))"
        by auto
      have cd': "(c, d) \<in> set (butlast (map snd (polychain_of (x + z) zs)))" using cd
        by (auto simp: map_butlast)
      have "ccw' (x + z) (c, d) (last (map snd (polychain_of (x + z) zs)))"
      proof (rule ccw'.sortedP_right_of_last)
        show "ccw'.sortedP (x + z) (map snd (polychain_of (x + z) zs))"
           using Cons
           by (force intro!: ccw'.sortedP.Cons ccw'.sortedP.Nil ccw'_sortedP_polychain_of_snd
             elim!: ccw'.sortedP_Cons)
        show "(c, d) \<in> set (map snd (polychain_of (x + z) zs))"
          using in_set_butlastD[OF ab]
          by force
        from Cons(3) cd'
        show "(c, d) \<noteq> last (map snd (polychain_of (x + z) zs))"
          by (intro distinct_butlast_ne_last ccw'_sortedP_implies_distinct[where x=x])
            (auto elim!: ccw'.sortedP_Cons)
      qed
      thus "ccw' (snd (last (polychain_of (x + z) zs))) (x + z) (c, d)"
         by (auto simp: last_map[symmetric, where f= snd] \<open>zs \<noteq> []\<close> intro: ccw'.cyclicI)
    qed
  }
  thus ?case
    by (auto simp: ccw'.sortedP.Nil)
qed (simp add: ccw'.sortedP.Nil)

lemma ccw'_polychain_of_sorted_center_last:
  assumes set_butlast: "(c, d) \<in> set (butlast (polychain_of x0 xs))"
  assumes sorted: "ccw'.sortedP 0 xs"
  assumes ne: "xs \<noteq> []"
  shows "ccw' x0 d (snd (last (polychain_of x0 xs)))"
proof -
  from ccw'_sortedP_polychain_of_snd[OF sorted, of x0]
  have "ccw'.sortedP x0 (map snd (polychain_of x0 xs))" .
  also
  from set_butlast obtain ys zs where "butlast (polychain_of x0 xs) = ys@((c, d)#zs)"
    by (auto simp add: in_set_conv_decomp)
  hence "polychain_of x0 xs = ys @ (c, d) # zs @ [last (polychain_of x0 xs)]"
    by (metis append_Cons append_assoc append_butlast_last_id ne polychain_of_eq_empty_iff)
  finally show ?thesis by (auto elim!: ccw'.sortedP_Cons simp: ccw'.sortedP_append_iff)
qed

end


section \<open> UTP Expressions \<close>

theory utp_expr
imports
  utp_var
begin

subsection \<open> Expression type \<close>

purge_notation BNF_Def.convol ("\<langle>(_,/ _)\<rangle>")

text \<open> Before building the predicate model, we will build a model of expressions that generalise
  alphabetised predicates. Expressions are represented semantically as mapping from
  the alphabet @{typ "'\<alpha>"} to the expression's type @{typ "'a"}. This general model will allow us to unify
  all constructions under one type. The majority definitions in the file are given using
  the \emph{lifting} package~\cite{Huffman13}, which allows us to reuse much of the existing
  library of HOL functions. \<close>

typedef ('t, '\<alpha>) uexpr = "UNIV :: ('\<alpha> \<Rightarrow> 't) set" ..

setup_lifting type_definition_uexpr

notation Rep_uexpr ("\<lbrakk>_\<rbrakk>\<^sub>e")
notation Abs_uexpr ("mk\<^sub>e")

lemma uexpr_eq_iff:
  "e = f \<longleftrightarrow> (\<forall> b. \<lbrakk>e\<rbrakk>\<^sub>e b = \<lbrakk>f\<rbrakk>\<^sub>e b)"
  using Rep_uexpr_inject[of e f, THEN sym] by (auto)

text \<open> The term @{term "\<lbrakk>e\<rbrakk>\<^sub>e b"} effectively refers to the semantic interpretation of the expression
  under the state-space valuation (or variables binding) @{term b}. It can be used, in concert
  with the lifting package, to interpret UTP constructs to their HOL equivalents. We create some
  theorem sets to store such transfer theorems. \<close>

named_theorems uexpr_defs and ueval and lit_simps and lit_norm

subsection \<open> Core expression constructs \<close>

text \<open> A variable expression corresponds to the lens $get$ function associated with a variable.
  Specifically, given a lens the expression always returns that portion of the state-space
  referred to by the lens. \<close>

lift_definition var :: "('t \<Longrightarrow> '\<alpha>) \<Rightarrow> ('t, '\<alpha>) uexpr" is lens_get .

text \<open> A literal is simply a constant function expression, always returning the same value
  for any binding. \<close>

lift_definition lit :: "'t \<Rightarrow> ('t, '\<alpha>) uexpr" ("\<guillemotleft>_\<guillemotright>") is "\<lambda> v b. v" .

text \<open> We define lifting for unary, binary, ternary, and quaternary expression constructs, that
  simply take a HOL function with correct number of arguments and apply it function to all possible
  results of the expressions. \<close>

lift_definition uop :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> ('b, '\<alpha>) uexpr"
  is "\<lambda> f e b. f (e b)" .
lift_definition bop ::
  "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> ('b, '\<alpha>) uexpr \<Rightarrow> ('c, '\<alpha>) uexpr"
  is "\<lambda> f u v b. f (u b) (v b)" .
lift_definition trop ::
  "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd) \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> ('b, '\<alpha>) uexpr \<Rightarrow> ('c, '\<alpha>) uexpr \<Rightarrow> ('d, '\<alpha>) uexpr"
  is "\<lambda> f u v w b. f (u b) (v b) (w b)" .
lift_definition qtop ::
  "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> 'e) \<Rightarrow>
   ('a, '\<alpha>) uexpr \<Rightarrow> ('b, '\<alpha>) uexpr \<Rightarrow> ('c, '\<alpha>) uexpr \<Rightarrow> ('d, '\<alpha>) uexpr \<Rightarrow>
   ('e, '\<alpha>) uexpr"
  is "\<lambda> f u v w x b. f (u b) (v b) (w b) (x b)" .

text \<open> We also define a UTP expression version of function ($\lambda$) abstraction, that takes
  a function producing an expression and produces an expression producing a function. \<close>

lift_definition ulambda :: "('a \<Rightarrow> ('b, '\<alpha>) uexpr) \<Rightarrow> ('a \<Rightarrow> 'b, '\<alpha>) uexpr"
is "\<lambda> f A x. f x A" .

text \<open> We set up syntax for the conditional. This is effectively an infix version of
  if-then-else where the condition is in the middle. \<close>

definition uIf :: "bool \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where
[uexpr_defs]: "uIf = If"

abbreviation cond ::
  "('a,'\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr \<Rightarrow> ('a,'\<alpha>) uexpr \<Rightarrow> ('a,'\<alpha>) uexpr"
  ("(3_ \<triangleleft> _ \<triangleright>/ _)" [52,0,53] 52)
where "P \<triangleleft> b \<triangleright> Q \<equiv> trop uIf b P Q"

text \<open> UTP expression is equality is simply HOL equality lifted using the @{term bop} binary
  expression constructor. \<close>

definition eq_upred :: "('a, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr" (infixl "=\<^sub>u" 50)
where [uexpr_defs]: "eq_upred x y = bop HOL.eq x y"

text \<open> A literal is the expression @{term "\<guillemotleft>v\<guillemotright>"}, where @{term v} is any HOL term. Actually, the
  literal construct is very versatile and also allows us to refer to HOL variables within UTP
  expressions, and has a variety of other uses. It can therefore also be considered as a kind
  of quotation mechanism.

  We also set up syntax for UTP variable expressions. \<close>

syntax
  "_uuvar" :: "svar \<Rightarrow> logic" ("_")

translations
  "_uuvar x" == "CONST var x"

text \<open> Since we already have a parser for variables, we can directly reuse it and simply apply
  the @{term var} expression construct to lift the resulting variable to an expression. \<close>

subsection \<open> Type class instantiations \<close>

text \<open> Isabelle/HOL of course provides a large hierarchy of type classes that provide constructs
  such as numerals and the arithmetic operators. Fortunately we can directly make use of these
  for UTP expressions, and thus we now perform a long list of appropriate instantiations. We
  first lift the core arithemtic constants and operators using a mixture of literals, unary, and binary
  expression constructors. \<close>

instantiation uexpr :: (zero, type) zero
begin
  definition zero_uexpr_def [uexpr_defs]: "0 = lit 0"
instance ..
end

instantiation uexpr :: (one, type) one
begin
  definition one_uexpr_def [uexpr_defs]: "1 = lit 1"
instance ..

end

instantiation uexpr :: (plus, type) plus
begin
  definition plus_uexpr_def [uexpr_defs]: "u + v = bop (+) u v"
instance ..
end

instance uexpr :: (semigroup_add, type) semigroup_add
  by (intro_classes) (simp add: plus_uexpr_def zero_uexpr_def, transfer, simp add: add.assoc)+

text \<open> The following instantiation sets up numerals. This will allow us to have Isabelle number
  representations (i.e. 3,7,42,198 etc.) to UTP expressions directly. \<close>

instance uexpr :: (numeral, type) numeral
  by (intro_classes, simp add: plus_uexpr_def, transfer, simp add: add.assoc)

text \<open> We can also define the order relation on expressions. Now, unlike the previous group and ring
  constructs, the order relations @{term "(\<le>)"} and @{term "(\<le>)"} return a @{type bool} type.
  This order is not therefore the lifted order which allows us to compare the valuation of two
  expressions, but rather the order on expressions themselves. Notably, this instantiation will
  later allow us to talk about predicate refinements and complete lattices. \<close>

instantiation uexpr :: (ord, type) ord
begin
  lift_definition less_eq_uexpr :: "('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr \<Rightarrow> bool"
  is "\<lambda> P Q. (\<forall> A. P A \<le> Q A)" .
  definition less_uexpr :: "('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr \<Rightarrow> bool"
  where [uexpr_defs]: "less_uexpr P Q = (P \<le> Q \<and> \<not> Q \<le> P)"
instance ..
end

text \<open> UTP expressions whose return type is a partial ordered type, are also partially ordered
  as the following instantiation demonstrates. \<close>

instance uexpr :: (order, type) order
proof
  fix x y z :: "('a, 'b) uexpr"
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)" by (simp add: less_uexpr_def)
  show "x \<le> x" by (transfer, auto)
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (transfer, blast intro:order.trans)
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (transfer, rule ext, simp add: eq_iff)
qed

subsection \<open> Syntax translations \<close>

text \<open> The follows a large number of translations that lift HOL functions to UTP expressions
  using the various expression constructors defined above. Much of the time we try to keep
  the HOL syntax but add a "u" subscript. \<close>

text \<open> This operator allows us to get the characteristic set of a type. Essentially this is
  @{term "UNIV"}, but it retains the type syntactically for pretty printing. \<close>

definition set_of :: "'a itself \<Rightarrow> 'a set" where
[uexpr_defs]: "set_of t = UNIV"

text \<open> We add new non-terminals for UTP tuples and maplets. \<close>

nonterminal utuple_args and umaplet and umaplets

syntax \<comment> \<open> Core expression constructs \<close>
  "_ucoerce"    :: "logic \<Rightarrow> type \<Rightarrow> logic" (infix ":\<^sub>u" 50)
  "_ulambda"    :: "pttrn \<Rightarrow> logic \<Rightarrow> logic" ("\<lambda> _ \<bullet> _" [0, 10] 10)
  "_ulens_ovrd" :: "logic \<Rightarrow> logic \<Rightarrow> salpha \<Rightarrow> logic" ("_ \<oplus> _ on _" [85, 0, 86] 86)
  "_ulens_get"  :: "logic \<Rightarrow> svar \<Rightarrow> logic" ("_:_" [900,901] 901)
  "_umem"       :: "('a, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr" (infix "\<in>\<^sub>u" 50)

translations
  "\<lambda> x \<bullet> p" == "CONST ulambda (\<lambda> x. p)"
  "x :\<^sub>u 'a" == "x :: ('a, _) uexpr"
  "_ulens_ovrd f g a" => "CONST bop (CONST lens_override a) f g"
  "_ulens_ovrd f g a" <= "CONST bop (\<lambda>x y. CONST lens_override x1 y1 a) f g"
  "_ulens_get x y" == "CONST uop (CONST lens_get y) x"
  "x \<in>\<^sub>u A" == "CONST bop (\<in>) x A"

syntax \<comment> \<open> Tuples \<close>
  "_utuple"     :: "('a, '\<alpha>) uexpr \<Rightarrow> utuple_args \<Rightarrow> ('a * 'b, '\<alpha>) uexpr" ("(1'(_,/ _')\<^sub>u)")
  "_utuple_arg"  :: "('a, '\<alpha>) uexpr \<Rightarrow> utuple_args" ("_")
  "_utuple_args" :: "('a, '\<alpha>) uexpr => utuple_args \<Rightarrow> utuple_args"     ("_,/ _")
  "_uunit"      :: "('a, '\<alpha>) uexpr" ("'(')\<^sub>u")
  "_ufst"       :: "('a \<times> 'b, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr" ("\<pi>\<^sub>1'(_')")
  "_usnd"       :: "('a \<times> 'b, '\<alpha>) uexpr \<Rightarrow> ('b, '\<alpha>) uexpr" ("\<pi>\<^sub>2'(_')")

translations
  "()\<^sub>u"      == "\<guillemotleft>()\<guillemotright>"
  "(x, y)\<^sub>u"  == "CONST bop (CONST Pair) x y"
  "_utuple x (_utuple_args y z)" == "_utuple x (_utuple_arg (_utuple y z))"
  "\<pi>\<^sub>1(x)"    == "CONST uop CONST fst x"
  "\<pi>\<^sub>2(x)"    == "CONST uop CONST snd x"

syntax \<comment> \<open> Orders \<close>
  "_uless"      :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infix "<\<^sub>u" 50)
  "_uleq"       :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infix "\<le>\<^sub>u" 50)
  "_ugreat"     :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infix ">\<^sub>u" 50)
  "_ugeq"       :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infix "\<ge>\<^sub>u" 50)

translations
  "x <\<^sub>u y"   == "CONST bop (<) x y"
  "x \<le>\<^sub>u y"   == "CONST bop (\<le>) x y"
  "x >\<^sub>u y"   => "y <\<^sub>u x"
  "x \<ge>\<^sub>u y"   => "y \<le>\<^sub>u x"

subsection \<open> Evaluation laws for expressions \<close>

text \<open> The following laws show how to evaluate the core expressions constructs in terms of which
  the above definitions are defined. Thus, using these theorems together, we can convert any UTP
  expression into a pure HOL expression. All these theorems are marked as \emph{ueval} theorems
  which can be used for evaluation. \<close>

lemma lit_ueval [ueval]: "\<lbrakk>\<guillemotleft>x\<guillemotright>\<rbrakk>\<^sub>eb = x"
  by (transfer, simp)

lemma var_ueval [ueval]: "\<lbrakk>var x\<rbrakk>\<^sub>eb = get\<^bsub>x\<^esub> b"
  by (transfer, simp)

lemma uop_ueval [ueval]: "\<lbrakk>uop f x\<rbrakk>\<^sub>eb = f (\<lbrakk>x\<rbrakk>\<^sub>eb)"
  by (transfer, simp)

lemma bop_ueval [ueval]: "\<lbrakk>bop f x y\<rbrakk>\<^sub>eb = f (\<lbrakk>x\<rbrakk>\<^sub>eb) (\<lbrakk>y\<rbrakk>\<^sub>eb)"
  by (transfer, simp)

lemma trop_ueval [ueval]: "\<lbrakk>trop f x y z\<rbrakk>\<^sub>eb = f (\<lbrakk>x\<rbrakk>\<^sub>eb) (\<lbrakk>y\<rbrakk>\<^sub>eb) (\<lbrakk>z\<rbrakk>\<^sub>eb)"
  by (transfer, simp)

lemma qtop_ueval [ueval]: "\<lbrakk>qtop f x y z w\<rbrakk>\<^sub>eb = f (\<lbrakk>x\<rbrakk>\<^sub>eb) (\<lbrakk>y\<rbrakk>\<^sub>eb) (\<lbrakk>z\<rbrakk>\<^sub>eb) (\<lbrakk>w\<rbrakk>\<^sub>eb)"
  by (transfer, simp)

subsection \<open> Misc laws \<close>

text \<open> We also prove a few useful algebraic and expansion laws for expressions. \<close>

lemma uop_const [simp]: "uop id u = u"
  by (transfer, simp)

lemma bop_const_1 [simp]: "bop (\<lambda>x y. y) u v = v"
  by (transfer, simp)

lemma bop_const_2 [simp]: "bop (\<lambda>x y. x) u v = u"
  by (transfer, simp)

lemma uexpr_fst [simp]: "\<pi>\<^sub>1((e, f)\<^sub>u) = e"
  by (transfer, simp)

lemma uexpr_snd [simp]: "\<pi>\<^sub>2((e, f)\<^sub>u) = f"
  by (transfer, simp)

subsection \<open> Literalise tactics \<close>

text \<open> The following tactic converts literal HOL expressions to UTP expressions and vice-versa
        via a collection of simplification rules. The two tactics are called "literalise", which
        converts UTP to expressions to HOL expressions -- i.e. it pushes them into literals --
        and unliteralise that reverses this. We collect the equations in a theorem attribute
        called "lit\_simps". \<close>

lemma lit_fun_simps [lit_simps]:
  "\<guillemotleft>i x y z u\<guillemotright> = qtop i \<guillemotleft>x\<guillemotright> \<guillemotleft>y\<guillemotright> \<guillemotleft>z\<guillemotright> \<guillemotleft>u\<guillemotright>"
  "\<guillemotleft>h x y z\<guillemotright> = trop h \<guillemotleft>x\<guillemotright> \<guillemotleft>y\<guillemotright> \<guillemotleft>z\<guillemotright>"
  "\<guillemotleft>g x y\<guillemotright> = bop g \<guillemotleft>x\<guillemotright> \<guillemotleft>y\<guillemotright>"
  "\<guillemotleft>f x\<guillemotright> = uop f \<guillemotleft>x\<guillemotright>"
  by (transfer, simp)+

text \<open> The following two theorems also set up interpretation of numerals, meaning a UTP numeral
  can always be converted to a HOL numeral. \<close>

lemma numeral_uexpr_rep_eq [ueval]: "\<lbrakk>numeral x\<rbrakk>\<^sub>e b = numeral x"
  apply (induct x)
    apply (simp add: lit.rep_eq one_uexpr_def)
   apply (simp add: bop.rep_eq numeral_Bit0 plus_uexpr_def)
  apply (simp add: bop.rep_eq lit.rep_eq numeral_code(3) one_uexpr_def plus_uexpr_def)
  done

lemma numeral_uexpr_simp: "numeral x = \<guillemotleft>numeral x\<guillemotright>"
  by (simp add: uexpr_eq_iff numeral_uexpr_rep_eq lit.rep_eq)

lemma lit_zero [lit_simps]: "\<guillemotleft>0\<guillemotright> = 0" by (simp add:uexpr_defs)
lemma lit_one [lit_simps]: "\<guillemotleft>1\<guillemotright> = 1" by (simp add: uexpr_defs)
lemma lit_plus [lit_simps]: "\<guillemotleft>x + y\<guillemotright> = \<guillemotleft>x\<guillemotright> + \<guillemotleft>y\<guillemotright>" by (simp add: uexpr_defs, transfer, simp)
lemma lit_numeral [lit_simps]: "\<guillemotleft>numeral n\<guillemotright> = numeral n" by (simp add: numeral_uexpr_simp)

text \<open> In general unliteralising converts function applications to corresponding expression
  liftings. Since some operators, like + and *, have specific operators we also have to
  use @{thm uexpr_defs} in reverse to correctly interpret these. Moreover, numerals must be handled
  separately by first simplifying them and then converting them into UTP expression numerals;
  hence the following two simplification rules. \<close>

lemma lit_numeral_1: "uop numeral x = Abs_uexpr (\<lambda>b. numeral (\<lbrakk>x\<rbrakk>\<^sub>e b))"
  by (simp add: uop_def)

lemma lit_numeral_2: "Abs_uexpr (\<lambda> b. numeral v) = numeral v"
  by (metis lit.abs_eq lit_numeral)

method literalise = (unfold lit_simps[THEN sym])
method unliteralise = (unfold lit_simps uexpr_defs[THEN sym];
                     (unfold lit_numeral_1 ; (unfold uexpr_defs ueval); (unfold lit_numeral_2))?)+

text \<open> The following tactic can be used to evaluate literal expressions. It first literalises UTP
  expressions, that is pushes as many operators into literals as possible. Then it tries to simplify,
  and final unliteralises at the end. \<close>

method uexpr_simp uses simps = ((literalise)?, simp add: lit_norm simps, (unliteralise)?)

(* Example *)

lemma "(1::(int, '\<alpha>) uexpr) + \<guillemotleft>2\<guillemotright> = 4 \<longleftrightarrow> \<guillemotleft>3\<guillemotright> = 4"
  apply (literalise)
  apply (uexpr_simp) oops

end


theory Pseudo_Remainder_Sequence
  imports Sturm_Tarski
    "HOL-Computational_Algebra.Computational_Algebra"
    Poly_Conversion
    (*"Algebraic_Numbers.Algebraic_Numbers"*)
    (*"HOL-Library.Float" *)
begin

section \<open>pseudo remainder sequence\<close>

function spmods :: "'a::idom poly \<Rightarrow> 'a poly \<Rightarrow> ('a poly) list" where
  "spmods p q= (if p=0 then [] else
      let
        m=(if even(degree p+1-degree q) then -1 else -lead_coeff q)
      in
        Cons p (spmods q (smult m (pseudo_mod p q))))"
by auto
termination
 apply (relation "measure (\<lambda>(p,q).if p=0 then 0 else if q=0 then 1 else 2+degree q)")
 by (simp_all add: degree_pseudo_mod_less)

declare spmods.simps[simp del]

lemma spmods_0[simp]:
  "spmods 0 q = []"
  "spmods p 0 = (if p=0 then [] else [p])"
by (auto simp:spmods.simps)

lemma spmods_nil_eq:"spmods p q = [] \<longleftrightarrow> (p=0)"
  by (metis list.distinct(1) spmods.elims)

lemma changes_poly_at_alternative:
  "changes_poly_at ps a= changes (map (\<lambda>p. sign(poly p a)) ps)"
  "changes_poly_at ps a= changes (map (\<lambda>p. sgn(poly p a)) ps)"
  unfolding changes_poly_at_def
  subgoal by (subst changes_map_sign_eq) (auto simp add:comp_def)
  subgoal by (subst changes_map_sgn_eq) (auto simp add:comp_def)
  done

lemma smods_smult_length:
  assumes "a\<noteq>0" "b\<noteq>0"
  shows "length (smods p q) = length (smods (smult a p) (smult b q))" using assms
proof (induct "smods p q"  arbitrary:p q a b )
  case Nil
  thus ?case by (simp split:if_splits)
next
  case (Cons x xs)
  hence "p\<noteq>0" by auto
  define r where "r\<equiv>- (p mod q)"
  have "smods q r = xs" using Cons.hyps(2) `p\<noteq>0` unfolding r_def by auto
  hence "length (smods q r) = length (smods (smult b q) (smult a r))"
    using Cons.hyps(1)[of q r b a] Cons by auto
  moreover have "smult a p\<noteq>0" using `a\<noteq>0` `p\<noteq>0` by auto
  moreover have "-((smult a p) mod (smult b q)) = (smult a r)"
    using Polynomial.mod_smult_left Polynomial.mod_smult_right[OF `b\<noteq>0`]
    unfolding r_def by simp
  ultimately show ?case
    unfolding r_def by auto
qed

lemma smods_smult_nth[rule_format]:
  fixes p q::"real poly"
  assumes "a\<noteq>0" "b\<noteq>0"
  defines "xs\<equiv>smods p q" and "ys\<equiv>smods (smult a p) (smult b q)"
  shows "\<forall>n<length xs. ys!n = (if even n then smult a (xs!n)  else smult b (xs!n))" using assms
proof (induct "smods p q"  arbitrary:p q a b xs ys)
  case Nil
  thus ?case by (simp split:if_splits)
next
  case (Cons x xs)
  hence "p\<noteq>0" by auto
  define r where "r\<equiv>- (p mod q)"
  have xs:"xs=smods q r" "p#xs=smods p q" using Cons.hyps(2) `p\<noteq>0` unfolding r_def by auto
  define ys where "ys\<equiv>smods (smult b q) (smult a r)"
  have "- ((smult a p) mod (smult b q)) = smult a r"
    using mod_smult_right[OF `b\<noteq>0`, of "smult a p" q,unfolded mod_smult_left[where y=q]]
    unfolding r_def by auto
  hence ys:"smult a p # ys = smods (smult a p) (smult b q)" using `p\<noteq>0` `a\<noteq>0`
    unfolding ys_def r_def by auto
  have hyps:"\<And>n. n<length xs \<Longrightarrow> ys ! n = (if even n then smult b (xs ! n) else smult a (xs ! n))"
    using Cons.hyps(1)[of q r b a,folded xs ys_def] `a\<noteq>0` `b\<noteq>0` by auto
  thus ?case
    apply (fold xs ys)
    apply auto
    by (case_tac n,auto)+
qed

lemma smods_smult_sgn_map_eq:
  fixes x::real
  assumes "m>0"
  defines "f\<equiv>\<lambda>p. sgn(poly p x)"
  shows "map f (smods p (smult m q)) = map f (smods p q)"
        "map sgn_pos_inf (smods p (smult m q)) = map sgn_pos_inf (smods p q)"
        "map sgn_neg_inf (smods p (smult m q)) = map sgn_neg_inf (smods p q)"
proof -
  define xs ys where "xs\<equiv>smods p q" and "ys\<equiv>smods p (smult m q)"
  have "m\<noteq>0" using `m>0` by simp
  have len_eq:"length xs =length ys"
    using smods_smult_length[of 1 m] `m>0` unfolding xs_def ys_def by auto
  moreover have
    "(map f xs) ! i = (map f ys) ! i"
    "(map sgn_pos_inf xs) ! i = (map sgn_pos_inf ys) ! i"
    "(map sgn_neg_inf xs) ! i = (map sgn_neg_inf ys) ! i"
     when "i<length xs" for i
  proof -
    note nth_eq=smods_smult_nth[OF one_neq_zero `m\<noteq>0`,of _ p q,unfolded smult_1_left,
        folded xs_def ys_def,OF `i<length xs` ]
    then show "map f xs ! i = map f ys ! i"
          "(map sgn_pos_inf xs) ! i = (map sgn_pos_inf ys) ! i"
          "(map sgn_neg_inf xs) ! i = (map sgn_neg_inf ys) ! i"
      using that
      unfolding f_def using len_eq `m>0`
      by (auto simp add:sgn_mult sgn_pos_inf_def sgn_neg_inf_def lead_coeff_smult)
  qed
  ultimately show "map f (smods p (smult m q)) = map f (smods p q)"
    "map sgn_pos_inf (smods p (smult m q)) = map sgn_pos_inf (smods p q)"
    "map sgn_neg_inf (smods p (smult m q)) = map sgn_neg_inf (smods p q)"
    apply (fold xs_def ys_def)
    by (auto intro: nth_equalityI)
qed

lemma changes_poly_at_smods_smult:
  assumes "m>0"
  shows "changes_poly_at (smods p (smult m q)) x =changes_poly_at (smods p q) x "
  using smods_smult_sgn_map_eq[OF `m>0`]
unfolding changes_poly_at_alternative by auto

lemma spmods_smods_sgn_map_eq:
  fixes p q::"real poly" and x::real
  defines "f\<equiv>\<lambda>p. sgn (poly p x)"
  shows "map f (smods p q) = map f (spmods p q)"
        "map sgn_pos_inf (smods p q) = map sgn_pos_inf (spmods p q)"
        "map sgn_neg_inf (smods p q) = map sgn_neg_inf (spmods p q)"
proof (induct "spmods p q" arbitrary:p q)
  case Nil
  hence "p=0" using spmods_nil_eq by metis
  thus "map f (smods p q) = map f (spmods p q)"
       "map sgn_pos_inf (smods p q) = map sgn_pos_inf (spmods p q)"
       "map sgn_neg_inf (smods p q) = map sgn_neg_inf (spmods p q)"
    by auto
next
  case (Cons p' xs)
  hence "p\<noteq>0" by auto
  define r where "r\<equiv>- (p mod q)"
  define exp where " exp\<equiv>degree p +1 - degree q"
  define m where "m\<equiv>(if even exp then 1 else lead_coeff q)
      * (lead_coeff q ^ exp)"
  have xs1:"p#xs=spmods p q"
    by (metis (no_types) Cons.hyps(4) list.distinct(1) list.inject  spmods.simps)
  have xs2:"xs=spmods q (smult m r)" when "q\<noteq>0"
  proof -
    define m' where  "m'\<equiv>if even exp then - 1 else - lead_coeff q"
    have "smult m' (pseudo_mod p q) = smult m r"
      unfolding m_def m'_def r_def
      apply (subst pseudo_mod_mod[symmetric])
      using that exp_def by auto
    thus ?thesis using `p\<noteq>0` xs1 unfolding r_def
      by (simp add:spmods.simps[of p q,folded exp_def, folded m'_def] del:spmods.simps)
  qed
  define ys where "ys\<equiv>smods q r"
  have ys:"p#ys=smods p q" using `p\<noteq>0` unfolding ys_def r_def by auto
  have qm:"q\<noteq>0 \<Longrightarrow> m>0"
    using `p\<noteq>0` unfolding m_def
    apply auto
    subgoal by (simp add: zero_less_power_eq)
    subgoal using zero_less_power_eq by fastforce
    done
  show "map f (smods p q) = map f (spmods p q)"
  proof (cases "q\<noteq>0")
    case True
    then have "map f (spmods q (smult m r)) = map f (smods q r)"
      using smods_smult_sgn_map_eq(1)[of m x q r,folded f_def] qm
        Cons.hyps(1)[OF xs2,folded f_def]
      by simp
    thus ?thesis
      apply (fold xs1 xs2[OF True] ys ys_def)
      by auto
  next
    case False
    thus ?thesis by auto
  qed
  show "map sgn_pos_inf (smods p q) = map sgn_pos_inf (spmods p q)"
  proof (cases "q\<noteq>0")
    case True
    then have "map sgn_pos_inf (spmods q (smult m r)) = map sgn_pos_inf (smods q r)"
      using Cons.hyps(2)[OF xs2,folded f_def] qm[OF True]
        smods_smult_sgn_map_eq(2)[of m  q r,folded f_def] by auto
    thus ?thesis
      apply (fold xs1 xs2[OF True] ys ys_def)
      by (simp add:f_def)
  next
    case False
    thus ?thesis by auto
  qed
  show "map sgn_neg_inf (smods p q) = map sgn_neg_inf (spmods p q)"
  proof (cases "q\<noteq>0")
    case True
    then have "map sgn_neg_inf (spmods q (smult m r)) = map sgn_neg_inf (smods q r)"
      using Cons.hyps(3)[OF xs2,folded f_def] qm[OF True]
        smods_smult_sgn_map_eq(3)[of m  q r,folded f_def] by auto
    thus ?thesis
      apply (fold xs1 xs2[OF True] ys ys_def)
      by (simp add:f_def)
  next
    case False
    thus ?thesis by auto
  qed
qed

section \<open>Sign variations for pseudo-remainder sequences\<close>

locale order_hom =
  fixes hom :: "'a :: ord \<Rightarrow> 'b :: ord"
  assumes hom_less: "x < y \<longleftrightarrow> hom x < hom y"
   and hom_less_eq: "x \<le> y \<longleftrightarrow> hom x \<le> hom y"

locale linordered_idom_hom = order_hom hom + inj_idom_hom hom
  for hom :: "'a :: linordered_idom \<Rightarrow> 'b :: linordered_idom"
begin

lemma sgn_sign:"sgn (hom x) = sign x"
  by (simp add: sign_def hom_less sgn_if)

lemma sign_hom[simp]: "sign (hom x) = sign x"
  by (simp add: hom_less sign_def)

end

locale hom_pseudo_smods= comm_semiring_hom hom
    + r1:linordered_idom_hom R\<^sub>1 + r2:linordered_idom_hom R\<^sub>2
  for hom::"'a::linordered_idom \<Rightarrow> 'b::{comm_semiring_1,linordered_idom}"
    and R\<^sub>1::"'a \<Rightarrow> real"
    and R\<^sub>2::"'b \<Rightarrow> real" +
  assumes R_hom:"R\<^sub>1 x = R\<^sub>2 (hom x)"
begin

(*
  hom    R2

'a \<rightarrow> 'b \<rightarrow> real
      rat/float
int
p
      x
*)

lemma map_poly_R_hom_commute:
  "poly (map_poly R\<^sub>1 p) (R\<^sub>2 x) = R\<^sub>2 (poly (map_poly hom p) x)"
apply (induct p)
using r2.hom_add r2.hom_mult R_hom by auto

definition changes_hpoly_at::"'a poly list \<Rightarrow> 'b \<Rightarrow> int" where
  "changes_hpoly_at ps a= changes (map (\<lambda>p. sgn(eval_poly hom p a)) ps)"

lemma changes_hpoly_at_Nil[simp]: "changes_hpoly_at [] a = 0"
  unfolding changes_hpoly_at_def by simp

definition changes_itv_spmods:: "'b \<Rightarrow> 'b \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<Rightarrow> int" where
  "changes_itv_spmods a b p q= (let ps = spmods p q in
        changes_hpoly_at ps a - changes_hpoly_at ps b)"

definition changes_gt_spmods:: "'b \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<Rightarrow> int" where
  "changes_gt_spmods a p q= (let ps = spmods p q in
        changes_hpoly_at ps a - changes_poly_pos_inf ps)"

definition changes_le_spmods:: "'b \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<Rightarrow> int" where
  "changes_le_spmods b p q= (let ps = spmods p q in
        changes_poly_neg_inf ps - changes_hpoly_at ps b)"

definition changes_R_spmods:: "'a poly \<Rightarrow> 'a poly \<Rightarrow>  int" where
  "changes_R_spmods p q= (let ps= spmods p q in changes_poly_neg_inf ps
      - changes_poly_pos_inf ps)"

lemma changes_spmods_smods:
  shows "changes_itv_spmods a b p q
    = changes_itv_smods (R\<^sub>2 a) (R\<^sub>2 b) (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
  and "changes_R_spmods p q = changes_R_smods (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
  and "changes_gt_spmods a p q = changes_gt_smods (R\<^sub>2 a) (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
  and "changes_le_spmods b p q = changes_le_smods (R\<^sub>2 b) (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
proof -
  define pp qq where "pp = map_poly R\<^sub>1 p" and "qq = map_poly R\<^sub>1 q"

  have spmods_eq:"spmods (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q) = map (map_poly R\<^sub>1) (spmods p q)"
  proof (induct "spmods p q" arbitrary:p q )
    case Nil
    thus ?case by (metis list.simps(8) map_poly_0 spmods_nil_eq)
  next
    case (Cons p' xs)
    hence "p\<noteq>0" by auto
    define m where "m\<equiv>(if even (degree p + 1 - degree q) then - 1 else - lead_coeff q)"
    define r where "r\<equiv>smult m (pseudo_mod p q)"
    have xs1:"p#xs=spmods p q"
      by (metis (no_types) Cons.hyps(2) list.distinct(1) list.inject  spmods.simps)
    have xs2:"xs=spmods q r" using xs1 \<open>p\<noteq>0\<close> r_def
      by (auto simp add:spmods.simps[of p q,folded exp_def,folded m_def])
    define ys where "ys\<equiv>spmods (map_poly R\<^sub>1 q) (map_poly R\<^sub>1 r)"
    have ys:"(map_poly R\<^sub>1 p)#ys=spmods (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
      using \<open>p\<noteq>0\<close> unfolding ys_def r_def
      apply (subst (2) spmods.simps)
      unfolding m_def by (auto simp:r1.pseudo_mod_hom hom_distribs)
    show ?case using Cons.hyps(1)[OF xs2]
      apply (fold xs1 xs2 ys ys_def)
      by auto
  qed

  have changes_eq_at:"changes_poly_at (smods pp qq) (R\<^sub>2 x) = changes_hpoly_at (spmods p q) x"
    (is "?L=?R")
    for x
  proof -
    define ff where "ff = (\<lambda>p. sgn (poly p (R\<^sub>2 x)))"
    have "?L = changes (map ff (smods pp qq))"
      using changes_poly_at_alternative unfolding ff_def by blast
    also have "... = changes (map ff (spmods pp qq))"
      unfolding ff_def using spmods_smods_sgn_map_eq by simp
    also have "... = changes (map ff (map (map_poly R\<^sub>1) (spmods p q)))"
      unfolding pp_def qq_def using spmods_eq by simp
    also have "... = ?R"
    proof -
      have "ff \<circ> map_poly R\<^sub>1 = sign \<circ> (\<lambda>p. eval_poly hom p x)"
        unfolding ff_def comp_def
        by (simp add: map_poly_R_hom_commute poly_map_poly_eval_poly  r2.sgn_sign)
      then show ?thesis
        unfolding changes_hpoly_at_def
        apply (subst (2) changes_map_sign_eq)
        by (simp add:comp_def)
    qed
    finally show ?thesis .
  qed

  have changes_eq_neg_inf:
    "changes_poly_neg_inf (smods pp qq) = changes_poly_neg_inf (spmods p q)"
    (is "?L=?R")
  proof -
    have "?L = changes (map sgn_neg_inf (map (map_poly R\<^sub>1) (spmods p q)))"
      unfolding changes_poly_neg_inf_def spmods_smods_sgn_map_eq
      by (simp add: spmods_eq[folded pp_def qq_def])
    also have "... = changes (map (sgn_neg_inf \<circ> (map_poly R\<^sub>1)) (spmods p q))"
      using map_map by simp
    also have "... = changes (map ((sign:: _ \<Rightarrow> real) \<circ> sgn_neg_inf) (spmods p q))"
    proof -
      have "(sgn_neg_inf \<circ> (map_poly R\<^sub>1)) = sign \<circ> sgn_neg_inf"
        unfolding sgn_neg_inf_def comp_def
        by (auto simp:r1.sgn_sign)
      then show ?thesis by auto
    qed
    also have "... = changes (map sgn_neg_inf (spmods p q))"
      apply (subst (2) changes_map_sign_eq)
      by simp
    also have "... = ?R"
      unfolding changes_poly_neg_inf_def by simp
    finally show ?thesis .
  qed

  have changes_eq_pos_inf:
    "changes_poly_pos_inf (smods pp qq) = changes_poly_pos_inf (spmods p q)"
    (is "?L=?R")
  proof -
    have "?L = changes (map sgn_pos_inf (map (map_poly R\<^sub>1) (spmods p q)))"
      unfolding changes_poly_pos_inf_def spmods_smods_sgn_map_eq
      by (simp add: spmods_eq[folded pp_def qq_def])
    also have "... = changes (map (sgn_pos_inf \<circ> (map_poly R\<^sub>1)) (spmods p q))"
      using map_map by simp
    also have "... = changes (map ((sign:: _ \<Rightarrow> real) \<circ> sgn_pos_inf) (spmods p q))"
    proof -
      have "(sgn_pos_inf \<circ> (map_poly R\<^sub>1)) = sign \<circ> sgn_pos_inf"
        unfolding sgn_pos_inf_def comp_def
        by (auto simp:r1.sgn_sign)
      then show ?thesis by auto
    qed
    also have "... = changes (map sgn_pos_inf (spmods p q))"
      apply (subst (2) changes_map_sign_eq)
      by simp
    also have "... = ?R"
      unfolding changes_poly_pos_inf_def by simp
    finally show ?thesis .
  qed

  show "changes_itv_spmods a b p q
          = changes_itv_smods (R\<^sub>2 a) (R\<^sub>2 b) (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
    unfolding changes_itv_spmods_def changes_itv_smods_def
    using changes_eq_at by (simp add: Let_def pp_def qq_def)
  show "changes_R_spmods p q = changes_R_smods (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
    unfolding changes_R_spmods_def changes_R_smods_def Let_def
    using changes_eq_neg_inf changes_eq_pos_inf
    by (simp add: pp_def qq_def)
  show "changes_gt_spmods a p q = changes_gt_smods
                (R\<^sub>2 a) (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
    unfolding changes_gt_spmods_def changes_gt_smods_def Let_def
    using changes_eq_at changes_eq_pos_inf
    by (simp add: pp_def qq_def)
  show "changes_le_spmods b p q = changes_le_smods
                (R\<^sub>2 b) (map_poly R\<^sub>1 p) (map_poly R\<^sub>1 q)"
    unfolding changes_le_spmods_def changes_le_smods_def Let_def
    using changes_eq_at changes_eq_neg_inf
    by (simp add: pp_def qq_def)
qed

end

end