(*<*)
theory LoweOntologicalArgument_5
imports QML
begin

nitpick_params[box=false, user_axioms=true, show_all, expect=genuine, format = 3,  atoms e = a b c d]
sledgehammer_params[verbose=true]
(*>*)

subsection \<open>Arriving at a Non-Modal Argument\<close>

text\<open>\noindent{A new simplified emendation of Lowe's argument is obtained after abandoning the concept of existence
and redefining necessariness and contingency accordingly. As we will see, this variant
is actually non-modal and can be easily formalized in first-order predicate logic.}\<close>

text\<open>\noindent{A more literal reading of Lowe's article has suggested a simplified formalization, in which necessariness
and contingency are taken as complementary predicates. According to this, our domain of discourse becomes
divided in four main categories, as exemplified in the table below:\footnote{
As Lowe explains in the article, "there is no logical restriction on combinations of the properties
involved in the concrete/abstract and the necessary/contingent distinctions.
In principle, then, we can have contingent concrete beings, contingent abstract beings,
necessary concrete beings, and necessary abstract beings."}
}\<close>
text\<open>\noindent{
\begin{center}
  \begin{tabular}{ l | c | r | }
     & Abstract & Concrete \\ \hline
    Necessary & Numbers & God \\ \hline
    Contingent & Fiction & Stuff \\
    \hline
  \end{tabular}
\end{center}
}\<close>
consts Necessary::"e\<Rightarrow>wo"
abbreviation Contingent::"e\<Rightarrow>wo" where "Contingent x \<equiv> \<^bold>\<not>(Necessary x)"

consts Concrete::"e\<Rightarrow>wo"
abbreviation Abstract::"e\<Rightarrow>wo" where "Abstract x \<equiv>  \<^bold>\<not>(Concrete x)"

abbreviation Godlike::"e\<Rightarrow>w\<Rightarrow>bool" where "Godlike x\<equiv> Necessary x \<^bold>\<and> Concrete x"

consts dependence::"e\<Rightarrow>e\<Rightarrow>wo" (infix "dependsOn"(*<*)100(*>*))
abbreviation explanation::"(e\<Rightarrow>e\<Rightarrow>wo)" (infix "explains"(*<*)100(*>*))
  where "y explains x \<equiv> x dependsOn y"

text\<open>\noindent{As shown below, we can even define the "dependent" predicate as \emph{primitive},
i.e. bearing no relation to ontological dependence, and still be able to validate the argument.
Being "independent" is defined as the negation of being "dependent", as before.}\<close>
consts Dependent::"e\<Rightarrow>wo"
abbreviation Independent::"e\<Rightarrow>wo" where "Independent x  \<equiv> \<^bold>\<not>(Dependent x)"

text\<open>\noindent{By taking, once again, metaphysical explanation as the inverse relation of ontological dependence
and by assuming premises P2 to P5 we can prove conclusion C10.}\<close>

axiomatization where
P2: "\<lfloor>\<^bold>\<exists>x. Necessary x \<^bold>\<and> Abstract x\<rfloor>" and
P3: "\<lfloor>\<^bold>\<forall>x. Abstract x \<^bold>\<rightarrow> Dependent x\<rfloor>" and
P4: "\<lfloor>\<^bold>\<forall>x. Dependent x \<^bold>\<rightarrow> (\<^bold>\<exists>y. Independent y \<^bold>\<and> x dependsOn y)\<rfloor>" and
P5: "\<lfloor>\<^bold>\<not>(\<^bold>\<exists>x. \<^bold>\<exists>y. Contingent y \<^bold>\<and> Necessary x \<^bold>\<and> y explains x)\<rfloor>"

theorem C10: "\<lfloor>\<^bold>\<exists>x. Godlike x\<rfloor>" using  P2 P3 P4 P5 by blast

text\<open>\noindent{Note that, in the axioms above, all actualist quantifiers have been changed into non-guarded quantifiers,
following the elimination of the concept of existence from our argument: Our quantifiers range over \emph{all}
beings, because all beings exist. Also note that all modal operators have disappeared;
thus, this new variant is directly formalizable in classical first-order logic.}\<close>

(*<*)
(* We carry out our `sanity checks' as usual.*)
lemma True nitpick[satisfy, user_axioms] oops (* model found: axioms are consistent *)
lemma "\<lfloor>Necessary x\<rfloor>" nitpick[user_axioms] oops (* counter-model found: axioms do not trivialize argument *)
lemma "\<lfloor>\<phi> \<^bold>\<rightarrow> \<^bold>\<box>\<phi>\<rfloor>" nitpick[user_axioms] oops (* counter-model found: modal collapse is not valid *)

end
(*>*)


\<^marker>\<open>creator Bilel Ghorbel\<close>
chapter \<open>defining reductions using IMP- programs\<close>
paragraph \<open>Summary\<close>
text \<open>
Reductions could be informally seen as transitions from a decision problem to another.

Although some existing theory makes a general definition of reductions using functions,
we do restrict our definition to computable reductions AND hence use IMP- programs instead
of functions
\<close>
theory "IMP-_Reductions"
  imports Abstractions Bounds
begin

subsection \<open>Definition\<close>
paragraph \<open>Defining computable reductions using IMP-\<close>
text \<open>A reduction is a program that always computes a result based uniquely on the input.
Hence computing a total function.
for a reduction c from D to D',  an input x AND a result r we have: x \<in> D iff r \<in>D'.

As a convention, the reduction should conserve the certificate.
This convention is necessary while working on verifiers.\<close>

definition is_reduction :: "com \<Rightarrow> lang \<Rightarrow> lang \<Rightarrow> bool" where
  "is_reduction c D D' \<equiv> cons_certif c \<and>( \<forall>x. \<exists>r. comp' c x r \<and>( x \<in> D \<longleftrightarrow> r \<in> D'))"

lemma is_reductionI:
  assumes "cons_certif c"
    and "\<And>x. \<exists>r. comp' c x r \<and>( x \<in> D \<longleftrightarrow> r \<in> D')"
  shows "is_reduction c D D'"
  using assms unfolding is_reduction_def by auto

subsection \<open>Reductions composed with deciders/verifiers/other reductions\<close>

lemma reduction_decision_correct:
  assumes "is_reduction f D D'" "decides g D'"
  shows "decides (f;;g) D "
proof (auto simp add: is_reduction_def decides_def)
  fix x
  obtain y where f_part:"comp' f x y" " x \<in> D \<longleftrightarrow> y \<in> D'" using assms(1) is_reduction_def by metis
  obtain z where g_part:"comp' g y z" "y \<in> D' \<longleftrightarrow> z = 0" using assms(2) decides_def by meson
  have "comp' (f;;g) x z" using comp'_comp' f_part(1)_g_part(1) by auto
  moreover have "x \<in>D \<longleftrightarrow> 0 = z" using f_part(2) g_part(2) by blast
  ultimately show "\<exists>r. comp' (f;; g) x r \<and> (x \<in> D) = (r = 0)" by blast
qed

lemma reduction_verification_correct:
  assumes "is_reduction f D D'" "is_verif g D'"
  shows "is_verif (f;;g) D"
proof (intro is_verifI)
  fix x  z
  from assms(1) obtain y where  "comp' f x y " using is_reduction_def by meson
  moreover have "cons_certif f" using assms(1) is_reduction_def  by simp
  ultimately have
    "comp f [(''input'',x),(''certificate'',z)] [(''input'',y),(''certificate'',z)]"
    using  cons_certif_effect by(auto simp add: comp'_def)
  moreover from assms(2) obtain r where  "verif g y z r" using is_verif_def by meson
  ultimately show "\<exists>r. verif (f;;g) x z r" using comp_comp cons_certif_def verif_def
    by meson
next
  fix x
  from assms(1) obtain y where y_def:  "comp' f x y " " (x\<in>D) = (y\<in>D')"
    using is_reduction_def by meson
  moreover have "cons_certif f" using assms(1) is_reduction_def  by simp
  ultimately have
    as1: "\<forall>z. comp f [(''input'',x),(''certificate'',z)] [(''input'',y),(''certificate'',z)]"
    using  cons_certif_effect by(auto simp add:comp'_def)
  from assms(2) have "(y\<in>D')  = (\<exists>z. verif g y z 0)"
    using is_verif_def by simp
  hence  as2:"(x \<in> D) = (\<exists>z. verif g y z 0) " using y_def(2) by simp
  show "(x \<in> D) = (\<exists>z. verif (f;; g) x z 0)"
  proof safe
    assume "x \<in> D"
    then obtain z where "verif g y z 0" using as2 by blast
    moreover have "comp f [(''input'',x),(''certificate'',z)] [(''input'',y),(''certificate'',z)]"
      using as1 by simp
    ultimately have" verif (f;; g) x z 0" using as1 comp_comp verif_def by blast
    thus "\<exists>z. verif (f;; g) x z 0" by auto
  next
    fix z
    assume asm: "verif (f;; g) x z 0"
    from as1
    have " comp f [(''input'',x),(''certificate'',z)] [(''input'',y),(''certificate'',z)]"
      by auto
    moreover from assms(2) obtain r where r_def:  "verif g y z r" using is_verif_def by meson
    ultimately have "verif (f;; g) x z r" using verif_def comp_comp by meson
    hence "r=0" using asm verif_def comp_det
      by (smt fst_conv
          iszero_primfun_list.simps(1) iszero_primfun_list.simps(2) list.simps(9) pair_list_eqI)
    hence "verif g y z 0" using r_def by auto
    thus "x \<in> D" using as2 by blast
  qed
qed

lemma is_reduction_compose:
  assumes "is_reduction f D D'" "is_reduction g D' D''"
  shows "is_reduction (f;;g) D D''"
  unfolding is_reduction_def
  apply safe
  subgoal using assms apply(simp add: cons_certif_def is_reduction_def) by fastforce
proof -
  fix x
   obtain y where y_def: "comp' f x y" "(x\<in>D) =(y\<in>D')"
     using assms(1) by (auto simp add:is_reduction_def)
   obtain z where z_def: "comp' g y z" "(y\<in>D') =(z\<in>D'')"
     using assms(2) by (auto simp add:is_reduction_def)
   have  "comp' (f;; g) x z  \<and> (x \<in> D) = (z \<in> D'')"
     using y_def z_def comp_comp comp'_def by simp
   thus  "\<exists>r. comp' (f;; g) x r \<and> (x \<in> D) = (r \<in> D'')" by blast
 qed

subsection \<open>Polynomial reductions\<close>
paragraph \<open>Definition\<close>
text \<open>
A polyreduction is a reduction that is also polynomially bounded in time (in most literature)

A necessary condition also for polyreduction is to be polynomially result-bounded
(otherwise polyreduction would not be transitive)
Yet, this condition is generally omitted in most literature, as TM is the commonly used model
of computation, where the limitation in time implies a limitation in space.
As it is not the case in our model, we choose to add explicitly this condition.

It is yet worth the mention, that given that program is a reduction hence
depends on only one register. the time bound would imply a result bound.
This yet would involve a bit of digging into the semantics to be proven.
This could be done as a future step in the project.
\<close>

definition is_polyreduction :: "com \<Rightarrow> lang \<Rightarrow> lang  \<Rightarrow> bool" where
"is_polyreduction c D D' \<equiv> poly_time_bounded c [''input'']
                               \<and> is_reduction c D D'
                               \<and> poly_result_bounded c [''input''] [''input''] "

paragraph \<open>poly-reductions as a binary relation over languages\<close>

definition poly_reduces :: "lang \<Rightarrow> lang \<Rightarrow> bool" where
"poly_reduces D D' \<equiv> \<exists>c. is_polyreduction c D D'"

paragraph \<open>Properties of the polyreduction relation\<close>

text \<open>Reflexivity\<close>

lemma "poly_reduces D D"
  apply(simp add: poly_reduces_def is_polyreduction_def)
proof
  let ?c=SKIP
  show "poly_time_bounded ?c [''input''] \<and> is_reduction ?c D D
              \<and> poly_result_bounded ?c [''input''] [''input'']"
    apply (auto)
    apply(auto simp add:poly_time_bounded_def)
    subgoal
    proof
      let ?p = "(\<lambda>x. 1)"
      have "poly ?p" by simp
      moreover have "time_bounded SKIP [''input''] ?p "
        using time_bounded_def by auto
      ultimately show "poly ?p \<and> time_bounded SKIP [''input''] ?p" by simp
    qed
     apply (auto simp add: is_reduction_def cons_certif_def comp_def poly_result_bounded_def)
    subgoal for x
    proof -
      have "(\<forall>s. s ''input'' = x \<longrightarrow> (\<exists>t s'. (SKIP, s) \<Rightarrow>\<^bsup> t \<^esup> s' \<and> s' ''input'' = x)) \<and> (x \<in> D) = (x \<in> D)"
        by auto
      thus ?thesis by (auto simp add:comp'_def comp_def)
    qed
  proof
    let ?p= "(\<lambda>a .a)"
    show "poly ?p \<and> result_bounded SKIP [''input''] [''input''] ?p"
      apply(auto simp add:poly_linear result_bounded_def)
      subgoal for x
      proof -
        assume "length x = Suc 0"
        then have "length x = Suc 0 \<and> comp SKIP (zip [''input''] x) (zip [''input''] x) \<and> bit_size x \<le> bit_size x "
          by (auto simp add: comp'_def comp_def)
        thus  ?thesis by auto
      qed
      done
  qed
qed

text \<open>Transitivity\<close>

lemma "poly_reduces_trans":
  assumes "poly_reduces D D'"  "poly_reduces D' D''"
  shows "poly_reduces D D''"
proof -
  from assms obtain f g where fg_def: "is_polyreduction f D D'" "is_polyreduction g D' D''"
    by (auto simp add:poly_reduces_def)
  let ?c= "f;;g"
  have  "is_polyreduction ?c D D''"
    apply (auto simp add:is_polyreduction_def  reduction_poly)
    using fg_def apply (simp add: is_polyreduction_def reduction_poly)
    using reduction_poly apply blast
    using fg_def is_reduction_compose apply (simp add: is_polyreduction_def) apply blast
    using fg_def apply (auto simp add:is_polyreduction_def reduction_poly)
    using poly_result_compose apply blast
    done
  thus "poly_reduces D D''" by (auto simp add:poly_reduces_def)
qed

end


(*  Title:      HOL/ex/Tree23.thy
    Author:     Tobias Nipkow, TU Muenchen
*)

section \<open>2-3 Trees\<close>

theory Tree23
imports Main
begin

text\<open>This is a very direct translation of some of the functions in table.ML
in the Isabelle source code. That source is due to Makarius Wenzel and Stefan
Berghofer.

So far this file contains only data types and functions, but no proofs. Feel
free to have a go at the latter!

Note that because of complicated patterns and mutual recursion, these
function definitions take a few minutes and can also be seen as stress tests
for the function definition facility.\<close>

type_synonym key = int \<comment> \<open>for simplicity, should be a type class\<close>

datatype ord = LESS | EQUAL | GREATER

definition "ord i j = (if i<j then LESS else if i=j then EQUAL else GREATER)"

datatype 'a tree23 =
  Empty |
  Branch2 "'a tree23" "key * 'a" "'a tree23" |
  Branch3 "'a tree23" "key * 'a" "'a tree23" "key * 'a" "'a tree23"

datatype 'a growth =
  Stay "'a tree23" |
  Sprout "'a tree23" "key * 'a" "'a tree23"

fun add :: "key \<Rightarrow> 'a \<Rightarrow> 'a tree23 \<Rightarrow> 'a growth" where
"add key y Empty = Sprout Empty (key,y) Empty" |
"add key y (Branch2 left (k,x) right) =
   (case ord key k of
      LESS =>
        (case add key y left of
           Stay left' => Stay (Branch2 left' (k,x) right)
         | Sprout left1 q left2
           => Stay (Branch3 left1 q left2 (k,x) right))
    | EQUAL => Stay (Branch2 left (k,y) right)
    | GREATER =>
        (case add key y right of
           Stay right' => Stay (Branch2 left (k,x) right')
         | Sprout right1 q right2
           => Stay (Branch3 left (k,x) right1 q right2)))" |
"add key y (Branch3 left (k1,x1) mid (k2,x2) right) =
   (case ord key k1 of
      LESS =>
        (case add key y left of
           Stay left' => Stay (Branch3 left' (k1,x1) mid (k2,x2) right)
         | Sprout left1 q left2
           => Sprout (Branch2 left1 q left2) (k1,x1) (Branch2 mid (k2,x2) right))
    | EQUAL => Stay (Branch3 left (k1,y) mid (k2,x2) right)
    | GREATER =>
        (case ord key k2 of
           LESS =>
             (case add key y mid of
                Stay mid' => Stay (Branch3 left (k1,x1) mid' (k2,x2) right)
              | Sprout mid1 q mid2
                => Sprout (Branch2 left (k1,x1) mid1) q (Branch2 mid2 (k2,x2) right))
         | EQUAL => Stay (Branch3 left (k1,x1) mid (k2,y) right)
         | GREATER =>
             (case add key y right of
                Stay right' => Stay (Branch3 left (k1,x1) mid (k2,x2) right')
              | Sprout right1 q right2
                => Sprout (Branch2 left (k1,x1) mid) (k2,x2) (Branch2 right1 q right2))))"

definition add0 :: "key \<Rightarrow> 'a \<Rightarrow> 'a tree23 \<Rightarrow> 'a tree23" where
"add0 k y t =
  (case add k y t of Stay t' => t' | Sprout l p r => Branch2 l p r)"

value "add0 5 e (add0 4 d (add0 3 c (add0 2 b (add0 1 a Empty))))"

fun compare where
"compare None (k2, _) = LESS" |
"compare (Some k1) (k2, _) = ord k1 k2"

fun if_eq where
"if_eq EQUAL x y = x" |
"if_eq _ x y = y"

fun del :: "key option \<Rightarrow> 'a tree23 \<Rightarrow> ((key * 'a) * bool * 'a tree23)option"
where
"del (Some k) Empty = None" |
"del None (Branch2 Empty p Empty) = Some(p, (True, Empty))" |
"del None (Branch3 Empty p Empty q Empty) = Some(p, (False, Branch2 Empty q Empty))" |
"del k (Branch2 Empty p Empty) = (case compare k p of
      EQUAL => Some(p, (True, Empty)) | _ => None)" |
"del k (Branch3 Empty p Empty q Empty) = (case compare k p of
      EQUAL => Some(p, (False, Branch2 Empty q Empty))
    | _ => (case compare k q of
        EQUAL => Some(q, (False, Branch2 Empty p Empty))
      | _ => None))" |
"del k (Branch2 l p r) = (case compare k p of
      LESS => (case del k l of None \<Rightarrow> None |
        Some(p', (False, l')) => Some(p', (False, Branch2 l' p r))
      | Some(p', (True, l')) => Some(p', case r of
          Branch2 rl rp rr => (True, Branch3 l' p rl rp rr)
        | Branch3 rl rp rm rq rr => (False, Branch2
            (Branch2 l' p rl) rp (Branch2 rm rq rr))))
    | or => (case del (if_eq or None k) r of None \<Rightarrow> None |
        Some(p', (False, r')) => Some(p', (False, Branch2 l (if_eq or p' p) r'))
      | Some(p', (True, r')) => Some(p', case l of
          Branch2 ll lp lr => (True, Branch3 ll lp lr (if_eq or p' p) r')
        | Branch3 ll lp lm lq lr => (False, Branch2
            (Branch2 ll lp lm) lq (Branch2 lr (if_eq or p' p) r')))))" |
"del k (Branch3 l p m q r) = (case compare k q of
      LESS => (case compare k p of
        LESS => (case del k l of None \<Rightarrow> None |
          Some(p', (False, l')) => Some(p', (False, Branch3 l' p m q r))
        | Some(p', (True, l')) => Some(p', (False, case (m, r) of
            (Branch2 ml mp mr, Branch2 _ _ _) => Branch2 (Branch3 l' p ml mp mr) q r
          | (Branch3 ml mp mm mq mr, _) => Branch3 (Branch2 l' p ml) mp (Branch2 mm mq mr) q r
          | (Branch2 ml mp mr, Branch3 rl rp rm rq rr) =>
              Branch3 (Branch2 l' p ml) mp (Branch2 mr q rl) rp (Branch2 rm rq rr))))
      | or => (case del (if_eq or None k) m of None \<Rightarrow> None |
          Some(p', (False, m')) => Some(p', (False, Branch3 l (if_eq or p' p) m' q r))
        | Some(p', (True, m')) => Some(p', (False, case (l, r) of
            (Branch2 ll lp lr, Branch2 _ _ _) => Branch2 (Branch3 ll lp lr (if_eq or p' p) m') q r
          | (Branch3 ll lp lm lq lr, _) => Branch3 (Branch2 ll lp lm) lq (Branch2 lr (if_eq or p' p) m') q r
          | (_, Branch3 rl rp rm rq rr) => Branch3 l (if_eq or p' p) (Branch2 m' q rl) rp (Branch2 rm rq rr)))))
    | or => (case del (if_eq or None k) r of None \<Rightarrow> None |
        Some(q', (False, r')) => Some(q', (False, Branch3 l p m (if_eq or q' q) r'))
      | Some(q', (True, r')) => Some(q', (False, case (l, m) of
          (Branch2 _ _ _, Branch2 ml mp mr) => Branch2 l p (Branch3 ml mp mr (if_eq or q' q) r')
        | (_, Branch3 ml mp mm mq mr) => Branch3 l p (Branch2 ml mp mm) mq (Branch2 mr (if_eq or q' q) r')
        | (Branch3 ll lp lm lq lr, Branch2 ml mp mr) =>
            Branch3 (Branch2 ll lp lm) lq (Branch2 lr p ml) mp (Branch2 mr (if_eq or q' q) r')))))"

definition del0 :: "key \<Rightarrow> 'a tree23 \<Rightarrow> 'a tree23" where
"del0 k t = (case del (Some k) t of None \<Rightarrow> t | Some(_,(_,t')) \<Rightarrow> t')"

text \<open>Ordered trees\<close>

definition opt_less :: "key option \<Rightarrow> key option \<Rightarrow> bool" where
  "opt_less x y = (case x of None \<Rightarrow> True | Some a \<Rightarrow> (case y of None \<Rightarrow> True | Some b \<Rightarrow> a < b))"

lemma opt_less_simps [simp]:
  "opt_less None y = True"
  "opt_less x None = True"
  "opt_less (Some a) (Some b) = (a < b)"
unfolding opt_less_def by (auto simp add: ord_def split: option.split)

primrec ord' :: "key option \<Rightarrow> 'a tree23 \<Rightarrow> key option \<Rightarrow> bool" where
"ord' x Empty y = opt_less x y" |
"ord' x (Branch2 l p r) y = (ord' x l (Some (fst p)) & ord' (Some (fst p)) r y)" |
"ord' x (Branch3 l p m q r) y = (ord' x l (Some (fst p)) & ord' (Some (fst p)) m (Some (fst q)) & ord' (Some (fst q)) r y)"

definition ord0 :: "'a tree23 \<Rightarrow> bool" where
  "ord0 t = ord' None t None"

text \<open>Balanced trees\<close>

inductive full :: "nat \<Rightarrow> 'a tree23 \<Rightarrow> bool" where
"full 0 Empty" |
"\<lbrakk>full n l; full n r\<rbrakk> \<Longrightarrow> full (Suc n) (Branch2 l p r)" |
"\<lbrakk>full n l; full n m; full n r\<rbrakk> \<Longrightarrow> full (Suc n) (Branch3 l p m q r)"

inductive_cases full_elims:
  "full n Empty"
  "full n (Branch2 l p r)"
  "full n (Branch3 l p m q r)"

inductive_cases full_0_elim: "full 0 t"
inductive_cases full_Suc_elim: "full (Suc n) t"

lemma full_0_iff [simp]: "full 0 t \<longleftrightarrow> t = Empty"
  by (auto elim: full_0_elim intro: full.intros)

lemma full_Empty_iff [simp]: "full n Empty \<longleftrightarrow> n = 0"
  by (auto elim: full_elims intro: full.intros)

lemma full_Suc_Branch2_iff [simp]:
  "full (Suc n) (Branch2 l p r) \<longleftrightarrow> full n l \<and> full n r"
  by (auto elim: full_elims intro: full.intros)

lemma full_Suc_Branch3_iff [simp]:
  "full (Suc n) (Branch3 l p m q r) \<longleftrightarrow> full n l \<and> full n m \<and> full n r"
  by (auto elim: full_elims intro: full.intros)

fun height :: "'a tree23 \<Rightarrow> nat" where
"height Empty = 0" |
"height (Branch2 l _ r) = Suc(max (height l) (height r))" |
"height (Branch3 l _ m _ r) = Suc(max (height l) (max (height m) (height r)))"

text\<open>Is a tree balanced?\<close>
fun bal :: "'a tree23 \<Rightarrow> bool" where
"bal Empty = True" |
"bal (Branch2 l _ r) = (bal l & bal r & height l = height r)" |
"bal (Branch3 l _ m _ r) = (bal l & bal m & bal r & height l = height m & height m = height r)"

lemma full_imp_height: "full n t \<Longrightarrow> height t = n"
  by (induct set: full, simp_all)

lemma full_imp_bal: "full n t \<Longrightarrow> bal t"
  by (induct set: full, auto dest: full_imp_height)

lemma bal_imp_full: "bal t \<Longrightarrow> full (height t) t"
  by (induct t, simp_all)

lemma bal_iff_full: "bal t \<longleftrightarrow> (\<exists>n. full n t)"
  by (auto elim!: bal_imp_full full_imp_bal)

text \<open>The @{term "add0"} function either preserves the height of the
tree, or increases it by one. The constructor returned by the @{term
"add"} function determines which: A return value of the form @{term
"Stay t"} indicates that the height will be the same. A value of the
form @{term "Sprout l p r"} indicates an increase in height.\<close>

primrec gfull :: "nat \<Rightarrow> 'a growth \<Rightarrow> bool" where
"gfull n (Stay t) \<longleftrightarrow> full n t" |
"gfull n (Sprout l p r) \<longleftrightarrow> full n l \<and> full n r"

lemma gfull_add: "full n t \<Longrightarrow> gfull n (add k y t)"
by (induct set: full, auto split: ord.split growth.split)

text \<open>The @{term "add0"} operation preserves balance.\<close>

lemma bal_add0: "bal t \<Longrightarrow> bal (add0 k y t)"
unfolding bal_iff_full add0_def
apply (erule exE)
apply (drule gfull_add [of _ _ k y])
apply (cases "add k y t")
apply (auto intro: full.intros)
done

text \<open>The @{term "add0"} operation preserves order.\<close>

lemma ord_cases:
  fixes a b :: int obtains
  "ord a b = LESS" and "a < b" |
  "ord a b = EQUAL" and "a = b" |
  "ord a b = GREATER" and "a > b"
unfolding ord_def by (rule linorder_cases [of a b]) auto

definition gtree :: "'a growth \<Rightarrow> 'a tree23" where
  "gtree g = (case g of Stay t \<Rightarrow> t | Sprout l p r \<Rightarrow> Branch2 l p r)"

lemma gtree_simps [simp]:
  "gtree (Stay t) = t"
  "gtree (Sprout l p r) = Branch2 l p r"
unfolding gtree_def by simp_all

lemma add0: "add0 k y t = gtree (add k y t)"
  unfolding add0_def by (simp split: growth.split)

lemma ord'_add0:
  "\<lbrakk>ord' k1 t k2; opt_less k1 (Some k); opt_less (Some k) k2\<rbrakk> \<Longrightarrow> ord' k1 (add0 k y t) k2"
unfolding add0
 apply (induct t arbitrary: k1 k2)
   apply simp
  apply clarsimp
  apply (rule_tac a=k and b=a in ord_cases)
    apply simp
    apply (case_tac "add k y t1", simp, simp)
   apply simp
  apply simp
  apply (case_tac "add k y t2", simp, simp)
 apply clarsimp
 apply (rule_tac a=k and b=a in ord_cases)
   apply simp
   apply (case_tac "add k y t1", simp, simp)
  apply simp
 apply simp
 apply (rule_tac a=k and b=aa in ord_cases)
   apply simp
   apply (case_tac "add k y t2", simp, simp)
  apply simp
 apply simp
 apply (case_tac "add k y t3", simp, simp)
done

lemma ord0_add0: "ord0 t \<Longrightarrow> ord0 (add0 k y t)"
  by (simp add: ord0_def ord'_add0)

text \<open>The @{term "del"} function preserves balance.\<close>

lemma del_extra_simps:
"l \<noteq> Empty \<or> r \<noteq> Empty \<Longrightarrow>
 del k (Branch2 l p r) = (case compare k p of
      LESS => (case del k l of None \<Rightarrow> None |
        Some(p', (False, l')) => Some(p', (False, Branch2 l' p r))
      | Some(p', (True, l')) => Some(p', case r of
          Branch2 rl rp rr => (True, Branch3 l' p rl rp rr)
        | Branch3 rl rp rm rq rr => (False, Branch2
            (Branch2 l' p rl) rp (Branch2 rm rq rr))))
    | or => (case del (if_eq or None k) r of None \<Rightarrow> None |
        Some(p', (False, r')) => Some(p', (False, Branch2 l (if_eq or p' p) r'))
      | Some(p', (True, r')) => Some(p', case l of
          Branch2 ll lp lr => (True, Branch3 ll lp lr (if_eq or p' p) r')
        | Branch3 ll lp lm lq lr => (False, Branch2
            (Branch2 ll lp lm) lq (Branch2 lr (if_eq or p' p) r')))))"
"l \<noteq> Empty \<or> m \<noteq> Empty \<or> r \<noteq> Empty \<Longrightarrow>
 del k (Branch3 l p m q r) = (case compare k q of
      LESS => (case compare k p of
        LESS => (case del k l of None \<Rightarrow> None |
          Some(p', (False, l')) => Some(p', (False, Branch3 l' p m q r))
        | Some(p', (True, l')) => Some(p', (False, case (m, r) of
            (Branch2 ml mp mr, Branch2 _ _ _) => Branch2 (Branch3 l' p ml mp mr) q r
          | (Branch3 ml mp mm mq mr, _) => Branch3 (Branch2 l' p ml) mp (Branch2 mm mq mr) q r
          | (Branch2 ml mp mr, Branch3 rl rp rm rq rr) =>
              Branch3 (Branch2 l' p ml) mp (Branch2 mr q rl) rp (Branch2 rm rq rr))))
      | or => (case del (if_eq or None k) m of None \<Rightarrow> None |
          Some(p', (False, m')) => Some(p', (False, Branch3 l (if_eq or p' p) m' q r))
        | Some(p', (True, m')) => Some(p', (False, case (l, r) of
            (Branch2 ll lp lr, Branch2 _ _ _) => Branch2 (Branch3 ll lp lr (if_eq or p' p) m') q r
          | (Branch3 ll lp lm lq lr, _) => Branch3 (Branch2 ll lp lm) lq (Branch2 lr (if_eq or p' p) m') q r
          | (_, Branch3 rl rp rm rq rr) => Branch3 l (if_eq or p' p) (Branch2 m' q rl) rp (Branch2 rm rq rr)))))
    | or => (case del (if_eq or None k) r of None \<Rightarrow> None |
        Some(q', (False, r')) => Some(q', (False, Branch3 l p m (if_eq or q' q) r'))
      | Some(q', (True, r')) => Some(q', (False, case (l, m) of
          (Branch2 _ _ _, Branch2 ml mp mr) => Branch2 l p (Branch3 ml mp mr (if_eq or q' q) r')
        | (_, Branch3 ml mp mm mq mr) => Branch3 l p (Branch2 ml mp mm) mq (Branch2 mr (if_eq or q' q) r')
        | (Branch3 ll lp lm lq lr, Branch2 ml mp mr) =>
            Branch3 (Branch2 ll lp lm) lq (Branch2 lr p ml) mp (Branch2 mr (if_eq or q' q) r')))))"
apply -
apply (cases l, cases r, simp_all only: del.simps, simp)
apply (cases l, cases m, cases r, simp_all only: del.simps, simp)
done

fun dfull where
"dfull n None \<longleftrightarrow> True" |
"dfull n (Some (p, (True, t'))) \<longleftrightarrow> full n t'" |
"dfull n (Some (p, (False, t'))) \<longleftrightarrow> full (Suc n) t'"

lemmas dfull_case_intros =
  ord.exhaust [of y "dfull a (case_ord b c d y)"]
  option.exhaust [of y "dfull a (case_option b c y)"]
  prod.exhaust [of y "dfull a (case_prod b y)"]
  bool.exhaust [of y "dfull a (case_bool b c y)"]
  tree23.exhaust [of y "dfull a (Some (b, case_tree23 c d e y))"]
  tree23.exhaust [of y "full a (case_tree23 b c d y)"]
  for a b c d e y

lemma dfull_del: "full (Suc n) t \<Longrightarrow> dfull n (del k t)"
proof -
  { fix n :: "nat" and p :: "key \<times> 'a" and l r :: "'a tree23" and k
    assume "\<And>n. \<lbrakk>compare k p = LESS; full (Suc n) l\<rbrakk> \<Longrightarrow> dfull n (del k l)"
    and "\<And>n. \<lbrakk>compare k p = EQUAL; full (Suc n) r\<rbrakk> \<Longrightarrow> dfull n (del (if_eq EQUAL None k) r)"
    and "\<And>n. \<lbrakk>compare k p = GREATER; full (Suc n) r\<rbrakk> \<Longrightarrow> dfull n (del (if_eq GREATER None k) r)"
    and "full (Suc n) (Branch2 l p r)"
    hence "dfull n (del k (Branch2 l p r))"
     apply clarsimp
     apply (cases n)
      apply (cases k)
       apply simp
      apply (simp split: ord.split)
     apply simp
     apply (subst del_extra_simps, force)
     (* This should work, but it is way too slow!
     apply (force split: ord.split option.split bool.split tree23.split) *)
     apply (simp | rule dfull_case_intros)+
     done
  } note A = this
  { fix n :: "nat" and p q :: "key \<times> 'a" and l m r :: "'a tree23" and k
    assume "\<And>n. \<lbrakk>compare k q = LESS; compare k p = LESS; full (Suc n) l\<rbrakk> \<Longrightarrow> dfull n (del k l)"
    and "\<And>n. \<lbrakk>compare k q = LESS; compare k p = EQUAL; full (Suc n) m\<rbrakk> \<Longrightarrow> dfull n (del (if_eq EQUAL None k) m)"
    and "\<And>n. \<lbrakk>compare k q = LESS; compare k p = GREATER; full (Suc n) m\<rbrakk> \<Longrightarrow> dfull n (del (if_eq GREATER None k) m)"
    and "\<And>n. \<lbrakk>compare k q = EQUAL; full (Suc n) r\<rbrakk> \<Longrightarrow> dfull n (del (if_eq EQUAL None k) r)"
    and "\<And>n. \<lbrakk>compare k q = GREATER; full (Suc n) r\<rbrakk> \<Longrightarrow> dfull n (del (if_eq GREATER None k) r)"
    and "full (Suc n) (Branch3 l p m q r)"
    hence "dfull n (del k (Branch3 l p m q r))"
     apply clarsimp
     apply (cases n)
      apply (cases k)
       apply simp
      apply (simp split: ord.split)
     apply simp
     apply (subst del_extra_simps, force)
     apply (simp | rule dfull_case_intros)+
     done
  } note B = this
  show "full (Suc n) t \<Longrightarrow> dfull n (del k t)"
  proof (induct k t arbitrary: n rule: del.induct, goal_cases)
    case (1 k n)
    thus "dfull n (del (Some k) Empty)" by simp
  next
    case (2 p n)
    thus "dfull n (del None (Branch2 Empty p Empty))" by simp
  next
    case (3 p q n)
    thus "dfull n (del None (Branch3 Empty p Empty q Empty))" by simp
  next
    case (4 v p n)
    thus "dfull n (del (Some v) (Branch2 Empty p Empty))"
      by (simp split: ord.split)
  next
    case (5 v p q n)
    thus "dfull n (del (Some v) (Branch3 Empty p Empty q Empty))"
      by (simp split: ord.split)
  next
    case (26 n)
    thus ?case by simp
  qed (fact A | fact B)+
qed

lemma bal_del0: "bal t \<Longrightarrow> bal (del0 k t)"
unfolding bal_iff_full del0_def
apply (erule exE)
apply (case_tac n, simp, simp)
apply (frule dfull_del [where k="Some k"])
apply (cases "del (Some k) t", force)
apply (rename_tac a, case_tac "a", rename_tac b t', case_tac "b", auto)
done

text\<open>This is a little test harness and should be commented out once the
above functions have been proved correct.\<close>

datatype 'a act = Add int 'a | Del int

fun exec where
"exec [] t = t" |
"exec (Add k x # as) t = exec as (add0 k x t)" |
"exec (Del k # as) t = exec as (del0 k t)"

text\<open>Some quick checks:\<close>

lemma bal_exec: "bal t \<Longrightarrow> bal (exec as t)"
  by (induct as t arbitrary: t rule: exec.induct,
    simp_all add: bal_add0 bal_del0)

lemma "bal(exec as Empty)"
  by (simp add: bal_exec)

lemma "ord0(exec as Empty)"
quickcheck
oops

end


(* Title: Quantale Modules and Semidirect Products
   Author: Georg Struth
   Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Quantale Modules and Semidirect Products\<close>

theory Quantale_Modules
  imports Quantale_Star

begin

subsection \<open>Quantale Modules\<close>

text \<open>Quantale modules are extensions of semigroup actions in that a quantale acts on a complete lattice.
These have been investigated by Abramsky and Vickers~\cite{AbramskyV93} and others, predominantly in the context
of pointfree topology.\<close>

locale unital_quantale_module =
  fixes act :: "'a::unital_quantale \<Rightarrow> 'b::complete_lattice_with_dual \<Rightarrow> 'b" ("\<alpha>")
  assumes act1: "\<alpha> (x \<cdot> y) p = \<alpha> x (\<alpha> y p)"
    and act2 [simp]: "\<alpha> 1 p = p"
    and act3: "\<alpha> (\<Squnion>X) p = (\<Squnion>x \<in> X. \<alpha> x p)"
    and act4: "\<alpha> x (\<Squnion>P) = (\<Squnion>p \<in> P. \<alpha> x p)"

context unital_quantale_module
begin

text \<open>Actions are morphisms. The curried notation is particularly convenient for this.\<close>

lemma act_morph1: "\<alpha> (x \<cdot> y) = (\<alpha> x) \<circ> (\<alpha> y)"
  by (simp add: fun_eq_iff act1)

lemma act_morph2 [simp]: "\<alpha> 1 = id"
  by (simp add: fun_eq_iff)

lemma emp_act [simp]: "\<alpha> (\<Squnion>{}) p = \<bottom>"
  by (simp only: act3, force)

lemma emp_act_var [simp]: "\<alpha> \<bottom> p = \<bottom>"
  using emp_act by auto

lemma act_emp [simp]: "\<alpha> x (\<Squnion>{}) = \<bottom>"
  by (simp only: act4, force)

lemma act_emp_var [simp]: "\<alpha> x \<bottom> = \<bottom>"
  using act_emp by auto

lemma act_sup_distl: "\<alpha> x (p \<squnion> q) = (\<alpha> x p) \<squnion> (\<alpha> x q)"
  by (metis (mono_tags, lifting) act4 image_insert image_is_empty sup_Sup)

lemma act_sup_distr: "\<alpha> (x \<squnion> y) p = (\<alpha> x p) \<squnion> (\<alpha> y p)"
  by (metis (no_types, lifting) SUP_insert Sup_empty Sup_insert act3 sup_bot_right)

lemma act_sup_distr_var: "\<alpha> (x \<squnion> y) = (\<alpha> x) \<squnion> (\<alpha> y)"
  by (simp add: fun_eq_iff act_sup_distr)

subsection \<open>Semidirect Products and Weak Quantales\<close>

text \<open>Next, the semidirect product of a  unital quantale and a complete lattice is defined. \<close>

definition "sd_prod x y = (fst x \<cdot> fst y, snd x \<squnion> \<alpha> (fst x) (snd y))"

lemma sd_distr: "sd_prod (Sup_prod X) y = Sup_prod {sd_prod x y |x. x \<in> X}"
proof -
  have "sd_prod (Sup_prod X) y = sd_prod ((\<Squnion>x \<in> X. fst x), (\<Squnion>x \<in> X. snd x)) y"
    by (simp add: Sup_prod_def)
  also have "... = ((\<Squnion>x \<in> X. fst x) \<cdot> fst y, (\<Squnion>x \<in> X. snd x) \<squnion> (\<alpha> (\<Squnion>x \<in> X. fst x) (snd y)))"
    by (simp add: sd_prod_def)
  also have "... = ((\<Squnion>x \<in> X. (fst x \<cdot> fst y)), (\<Squnion>x \<in> X. snd x) \<squnion> (\<alpha> (\<Squnion>x \<in> X. fst x) (snd y)))"
    by (simp add: Sup_distr image_comp)
  also have "... = ((\<Squnion>x \<in> X. (fst x \<cdot> fst y)), (\<Squnion>x \<in> X. snd x) \<squnion> (\<Squnion>x \<in> X. (\<alpha> (fst x) (snd y))))"
    by (simp add: act3 image_comp)
  also have "... = ((\<Squnion>x \<in> X. (fst x \<cdot> fst y)), (\<Squnion>x \<in> X. (snd x \<squnion> (\<alpha> (fst x) (snd y)))))"
    using complete_lattice_class.SUP_sup_distrib by fastforce
  also have "... = Sup_prod {(fst x \<cdot> fst y, snd x \<squnion> (\<alpha> (fst x) (snd y))) |x. x \<in> X}"
    apply (unfold Sup_prod_def, safe)
    by ( simp add: SUP_Sup_eq, rule_tac f=Sup in arg_cong, force)+
  finally show ?thesis
    by (simp add: sd_prod_def)
qed

lemma sd_distl_aux: "Y \<noteq> {} \<Longrightarrow> p \<squnion> (\<Squnion>y \<in> Y. \<alpha> x (snd y)) = (\<Squnion>y \<in> Y. p \<squnion> \<alpha> x (snd y))"
  apply (rule antisym)
   apply (rule sup_least, metis SUP_bot_conv(2) SUP_const SUP_upper2 sup_ge1)
   apply (rule Sup_least, force simp: SUP_upper2 image_iff)
  by (rule Sup_least, safe, metis Sup_upper image_iff sup.idem sup.mono sup_ge2)

lemma sd_distl: "Y \<noteq> {} \<Longrightarrow> sd_prod x (Sup_prod Y) = Sup_prod {sd_prod x y |y. y \<in> Y}"
proof -
  assume a: "Y \<noteq> {}"
  have "sd_prod x (Sup_prod Y) = sd_prod x ((\<Squnion>y \<in> Y. fst y), (\<Squnion>y \<in> Y. snd y))"
    by (simp add: Sup_prod_def)
  also have "... = ((fst x) \<cdot> (\<Squnion>y \<in> Y. fst y), (snd x \<squnion> (\<alpha> (fst x) (\<Squnion>y \<in> Y. snd y))))"
    by (simp add: sd_prod_def)
  also have "... = ((\<Squnion>y \<in> Y. fst x \<cdot> fst y), (snd x \<squnion> (\<alpha> (fst x) (\<Squnion>y \<in> Y. snd y))))"
    by (simp add: Sup_distl image_comp)
  also have "... = ((\<Squnion>y \<in> Y. fst x \<cdot> fst y), (snd x \<squnion> (\<Squnion>y \<in> Y. \<alpha> (fst x) (snd y))))"
    by (simp add: act4 image_comp)
  also have "... = ((\<Squnion>y \<in> Y. fst x \<cdot> fst y), (\<Squnion>y \<in> Y. snd x \<squnion> (\<alpha> (fst x) (snd y))))"
    using a sd_distl_aux by blast
  also have "... = Sup_prod {(fst x \<cdot> fst y, snd x \<squnion> (\<alpha> (fst x) (snd y))) |y. y \<in> Y}"
    apply (unfold Sup_prod_def, safe)
    by ( simp add: SUP_Sup_eq, rule_tac f=Sup in arg_cong, force)+
  finally show ?thesis
    by (simp add: sd_prod_def)
qed

definition "sd_unit = (1,\<bottom>)"

lemma sd_unitl [simp]: "sd_prod sd_unit x = x"
  by (simp add: sd_prod_def sd_unit_def)

lemma sd_unitr [simp]: "sd_prod x sd_unit = x"
  by (simp add: sd_prod_def sd_unit_def)

text \<open>The following counterexamples rule out that semidirect products of quantales and complete lattices form quantales.
The reason is that the right annihilation law fails.\<close>

lemma "sd_prod x (Sup_prod Y) = Sup_prod {sd_prod x y |y. y \<in> Y}" (*nitpick[show_all,expect=genuine]*)
  oops

lemma "sd_prod x bot_prod = bot_prod" (*nitpick[show_all,expect=genuine]*)
  oops

  text \<open>However one can show that semidirect products of (unital) quantales with complete lattices form weak (unital) quantales.
This provides an example of how weak quantales arise quite naturally.\<close>

sublocale dp_quantale: weak_quantale sd_prod Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod top_prod
  apply unfold_locales
    apply (simp add: act1 act_sup_distl mult.assoc sd_prod_def sup_assoc)
   apply (metis Setcompr_eq_image sd_distr)
  by (metis Setcompr_eq_image sd_distl)

sublocale dpu_quantale: unital_weak_quantale sd_unit sd_prod Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod top_prod
  by unfold_locales simp_all

subsection \<open>The Star in Semidirect Products\<close>

text \<open>I define the star operation for a semidirect product of a quantale and a complete lattice,
and prove a characteristic property.\<close>

abbreviation "sd_power \<equiv> dpu_quantale.power"

abbreviation "sd_star \<equiv> dpu_quantale.qstar"

lemma sd_power_zero [simp]: "sd_power x 0 = (1,\<bottom>)"
  using sd_unit_def by simp

lemma sd_power_prop_aux: "\<alpha> (x ^ 0) y \<squnion> (\<Squnion>{\<alpha> (x ^ k) y |k.  0 < k \<and> k \<le> Suc i}) = \<Squnion>{\<alpha> (x ^ k) y |k. k \<le> Suc i}"
  apply (rule antisym)
  apply (rule sup_least, intro Sup_upper, blast, intro Sup_mono, blast)
  apply (rule Sup_least, safe)
  by (metis (mono_tags, lifting) Sup_insert Sup_upper insert_iff le_0_eq linorder_not_le mem_Collect_eq)

lemma sd_power_prop1 [simp]: "sd_power (x,y) (Suc i) = (x ^ (Suc i), \<Squnion>{\<alpha> (x ^ k) y|k. k \<le> i})"
proof (induct i)
  case 0 thus ?case
    by auto
next
  case (Suc i) thus ?case
  proof-
    assume "sd_power (x,y) (Suc i) = (x ^ Suc i, \<Squnion>{\<alpha> (x ^ k) y |k. k \<le> i})"
    hence "sd_power (x,y) (Suc (Suc i)) = (x ^ Suc (Suc i), \<alpha> (x ^ 0) y \<squnion> (\<Squnion>{\<alpha> (x ^ (Suc k)) y |k. k \<le> i}))"
      apply (simp add: sd_prod_def act1 act4)
      apply safe
      by (metis act4 image_Collect image_image)
    also have "... = (x ^ Suc (Suc i), \<alpha> (x ^ 0) y \<squnion> (\<Squnion>{\<alpha> (x ^ k) y |k.  0 < k \<and> k \<le> Suc i}))"
      by (metis (no_types, hide_lams) Suc_le_eq Suc_le_mono le_0_eq not0_implies_Suc zero_less_Suc)
    finally show ?thesis
      using sd_power_prop_aux by simp
  qed
qed

lemma sd_power_prop2 [simp]: "sd_power (x,y) i = (x ^ i, \<Squnion>{\<alpha> (x ^ k) y|k. k < i})"
  apply (case_tac i)
  using sd_unit_def apply force
  using le_simps(2) unital_quantale_module.sd_power_prop1 unital_quantale_module_axioms by fastforce

lemma sdstar_prop: "sd_star (x,y) = (qstar x, \<alpha> (qstar x) y)"
proof -
  have "sd_star (x,y) = sup_prod (1,\<bottom>) (Sup_prod {sd_power (x,y) (Suc i) |i. True})"
    by (metis dpu_quantale.Sup_iter_unfold dpu_quantale.qstar_def full_SetCompr_eq sd_power_zero)
  also have "... = sup_prod (1,\<bottom>) (Sup_prod {(x^(Suc i), \<Squnion>{\<alpha> (x ^ k) y|k. k \<le> i}) |i. True})"
    using sd_power_prop1 by auto
  also have "... = (1 \<squnion>( \<Squnion>i. x ^ (Suc i)), (\<Squnion>i. \<Squnion>{\<alpha> (x ^ k) y|k. k \<le> i}))"
    apply (unfold sup_prod_def Sup_prod_def, safe)
     apply (simp, rule_tac f="\<lambda>x. 1 \<squnion> x" in arg_cong)
    by (simp add: SUP_Sup_eq, rule_tac f=Sup in arg_cong, force)+
  also have "... = (qstar x, (\<Squnion>i. \<Squnion>{\<alpha> (x ^ k) y|k. k \<le> i}))"
    by (safe, metis (no_types) fSup_unfold power_0 qstar_def)
  also have "... = (qstar x, (\<Squnion>i. \<alpha> (x ^ i) y))"
    apply safe
    apply (rule antisym)
     apply (safe intro!: Sup_least, simp add: Sup_upper)
    by (metis (mono_tags, lifting) SUP_upper2 Sup_upper mem_Collect_eq order_refl)
  finally show ?thesis
    by (simp add: qstar_def act3 image_comp)
qed

end

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               November 2004               |
            |                   June 2005  (modified)   |
            |                   July 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                    May 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory Infra_exp
imports Infra_order
begin

(*****************************
         powr --> pow
 *****************************)

lemma nat_powr_pow:
  "(0::real) < r ==> r powr (real n) = r ^ n"
apply (induct_tac n)
apply (simp)
(* for Isabelle 2013
apply (simp add: real_of_nat_Suc) *)
(* apply (simp add: of_nat_Suc) *)
apply (simp add: powr_add)
done

(*****************************************************
              Exponentail convergence
 *****************************************************)

lemma powr_less_mono_inv:
  "[| (1::real) < a ; (x::real) < y |]
     ==> (inverse a) powr y < (inverse a) powr x"
apply (simp add: powr_def)
apply (auto simp add: ln_inverse)
done

lemma powr_less_mono_conv:
  "[| (0::real) < a ; a < (1::real) ; (x::real) < y |]
    ==> a powr y < a powr x"
apply (insert powr_less_mono_inv[of "inverse a" x y])
apply (simp)
apply (subgoal_tac "1 < inverse a")
apply (simp)
apply (rule inverse_less_imp_less)
apply (simp_all)
done

lemma powr_convergence:
  "[| (0::real) < alpha ; alpha < (1::real) ; (0::real) < x |]
      ==> (EX n::nat. alpha powr (real n) < x)"
apply (insert powr_log_cancel[of "alpha" x])
apply (insert reals_Archimedean2[of "log alpha x"])
apply (erule exE)
apply (subgoal_tac "alpha powr real n < alpha powr log alpha x")
apply (rule_tac x="n" in exI)
apply (simp)
apply (insert powr_less_mono_conv[of "alpha" "log alpha x"])
by (simp)

lemma pow_convergence:
  "[| (0::real) <= alpha ; alpha < (1::real) ; (0::real) < x |]
   ==> (EX n::nat. alpha^n < x)"

apply (case_tac "alpha=0")
 apply (rule_tac x="1" in exI)
 apply (simp)

apply (case_tac "0 < alpha")
 apply (insert powr_convergence[of "alpha" x])
 apply (simp)
 apply (erule exE)
 apply (rule_tac x="n" in exI)
 apply (simp add: nat_powr_pow)

apply (simp add: less_le)
done

(*** if 0 <=alpha < 1 then alpha^n ----> 0 ***)

lemma zero_isGLB_pow:
  "[| (0::real) <= alpha ; alpha < 1 |]
   ==> (0 isGLB {r. EX n. r = alpha ^ n})"
apply (simp add: isGLB_def isLB_def)
apply (rule conjI)

(* lb *)

apply (intro allI impI)
apply (erule exE)
apply (simp)
(*
apply (simp add: zero_le_power) was necessary in Isabelle 2005
*)

(* glb *)

apply (intro allI impI)
apply (case_tac "y <=0")
apply (simp)

 (* 0 < y *)
 apply (subgoal_tac "EX n. alpha ^ n < y")
 apply (simp)
 apply (erule exE)
 apply (drule_tac x="alpha ^ n" in spec)
 apply (simp)
 apply (drule_tac x="n" in spec)
 apply (simp)

 apply (simp add: pow_convergence)
done

(*** GLB ***)

lemma zero_GLB_pow:
  "[| (0::real) <= alpha ; alpha < 1 |]
   ==> GLB {r. EX n. r = alpha ^ n} = 0"
apply (subgoal_tac "{r. EX n. r = alpha ^ n} hasGLB")
apply (simp add: GLB_iff zero_isGLB_pow)
apply (insert zero_isGLB_pow[of alpha])
apply (simp add: hasGLB_def)
apply (rule_tac x="0" in exI)
by (simp)

end


section \<open>Sequential composition for conjunctive models \label{S:conjunctive-sequential}\<close>

theory Conjunctive_Sequential
imports Sequential
begin

text \<open>
  Sequential left-distributivity is only supported by conjunctive models
  but does not apply in general. The relational model is one such example.
\<close>

locale seq_finite_conjunctive = seq_distrib_right +
  assumes seq_inf_distrib: "c;(d\<^sub>0 \<sqinter> d\<^sub>1) = c;d\<^sub>0 \<sqinter> c;d\<^sub>1"
begin

sublocale seq_distrib_left
    by (simp add: seq_distrib_left.intro seq_distrib_left_axioms.intro
        seq_inf_distrib sequential_axioms)
end

locale seq_infinite_conjunctive = seq_distrib_right +
  assumes seq_Inf_distrib: "D \<noteq> {} \<Longrightarrow> c ; \<Sqinter>D = (\<Sqinter>d\<in>D. c ; d)"
begin

sublocale seq_distrib
proof unfold_locales
  fix c::'a and d\<^sub>0::'a and d\<^sub>1::'a
  have "{d\<^sub>0, d\<^sub>1} \<noteq> {}" by simp
  then have "c ; \<Sqinter>{d\<^sub>0, d\<^sub>1} = \<Sqinter>{c ; d |d. d \<in> {d\<^sub>0, d\<^sub>1}}" using seq_Inf_distrib
  proof -
    have "\<Sqinter> ((;) c ` {d\<^sub>0, d\<^sub>1}) = \<Sqinter>{c ; a |a. a \<in> {d\<^sub>0, d\<^sub>1}}"
      using INF_Inf by blast
    then show ?thesis
      using \<open>\<And>(c::'a::refinement_lattice) D::'a::refinement_lattice set. D \<noteq> {} \<Longrightarrow> c ; \<Sqinter>D = (\<Sqinter>d::'a::refinement_lattice\<in>D. c ; d)\<close> \<open>{d\<^sub>0::'a::refinement_lattice, d\<^sub>1::'a::refinement_lattice} \<noteq> {}\<close> by presburger
  qed
  also have "... = c ; d\<^sub>0 \<sqinter> c ; d\<^sub>1" by (simp only: Inf2_inf)
  finally show "c ; (d\<^sub>0 \<sqinter> d\<^sub>1) \<sqsubseteq> c ; d\<^sub>0 \<sqinter> c ; d\<^sub>1" by simp
qed

lemma seq_INF_distrib: "X \<noteq> {} \<Longrightarrow> c ; (\<Sqinter>x\<in>X. d x) = (\<Sqinter>x\<in>X. c ; d x)"
proof -
  assume xne: "X \<noteq> {}"
  have a: "c ; (\<Sqinter>x\<in>X. d x) = c ; \<Sqinter>(d ` X)" by auto
  also have b: "... = (\<Sqinter>d\<in>(d ` X). c ; d)" by (meson image_is_empty seq_Inf_distrib xne)
  also have c: "... = (\<Sqinter>x\<in>X. c ; d x)" by (simp add: image_comp)
  finally show ?thesis by (simp add: b image_comp)
qed

lemma seq_INF_distrib_UNIV: "c ; (\<Sqinter>x. d x) = (\<Sqinter>x. c ; d x)"
  by (simp add: seq_INF_distrib)

lemma INF_INF_seq_distrib: "Y \<noteq> {} \<Longrightarrow> (\<Sqinter>x\<in>X. c x) ; (\<Sqinter>y\<in>Y. d y) = (\<Sqinter>x\<in>X. \<Sqinter>y\<in>Y. c x ; d y)"
  by (simp add: INF_seq_distrib seq_INF_distrib)

lemma INF_INF_seq_distrib_UNIV: "(\<Sqinter>x. c x) ; (\<Sqinter>y. d y) = (\<Sqinter>x. \<Sqinter>y. c x ; d y)"
  by (simp add: INF_INF_seq_distrib)

end

end


(*  Title:      HOL/Induct/Common_Patterns.thy
    Author:     Makarius
*)

section \<open>Common patterns of induction\<close>

theory Common_Patterns
imports Main
begin

text \<open>
  The subsequent Isar proof schemes illustrate common proof patterns
  supported by the generic \<open>induct\<close> method.

  To demonstrate variations on statement (goal) structure we refer to
  the induction rule of Peano natural numbers: @{thm nat.induct
  [no_vars]}, which is the simplest case of datatype induction.  We
  shall also see more complex (mutual) datatype inductions involving
  several rules.  Working with inductive predicates is similar, but
  involves explicit facts about membership, instead of implicit
  syntactic typing.
\<close>

subsection \<open>Variations on statement structure\<close>

subsubsection \<open>Local facts and parameters\<close>

text \<open>
  Augmenting a problem by additional facts and locally fixed variables
  is a bread-and-butter method in many applications.  This is where
  unwieldy object-level \<open>\<forall>\<close> and \<open>\<longrightarrow>\<close> used to occur in
  the past.  The \<open>induct\<close> method works with primary means of
  the proof language instead.
\<close>

lemma
  fixes n :: nat
    and x :: 'a
  assumes "A n x"
  shows "P n x" using \<open>A n x\<close>
proof (induct n arbitrary: x)
  case 0
  note prem = \<open>A 0 x\<close>
  show "P 0 x" \<proof>
next
  case (Suc n)
  note hyp = \<open>\<And>x. A n x \<Longrightarrow> P n x\<close>
    and prem = \<open>A (Suc n) x\<close>
  show "P (Suc n) x" \<proof>
qed

subsubsection \<open>Local definitions\<close>

text \<open>
  Here the idea is to turn sub-expressions of the problem into a
  defined induction variable.  This is often accompanied with fixing
  of auxiliary parameters in the original expression, otherwise the
  induction step would refer invariably to particular entities.  This
  combination essentially expresses a partially abstracted
  representation of inductive expressions.
\<close>

lemma
  fixes a :: "'a \<Rightarrow> nat"
  assumes "A (a x)"
  shows "P (a x)" using \<open>A (a x)\<close>
proof (induct n \<equiv> "a x" arbitrary: x)
  case 0
  note prem = \<open>A (a x)\<close>
    and defn = \<open>0 = a x\<close>
  show "P (a x)" \<proof>
next
  case (Suc n)
  note hyp = \<open>\<And>x. n = a x \<Longrightarrow> A (a x) \<Longrightarrow> P (a x)\<close>
    and prem = \<open>A (a x)\<close>
    and defn = \<open>Suc n = a x\<close>
  show "P (a x)" \<proof>
qed

text \<open>
  Observe how the local definition \<open>n = a x\<close> recurs in the
  inductive cases as \<open>0 = a x\<close> and \<open>Suc n = a x\<close>,
  according to underlying induction rule.
\<close>

subsubsection \<open>Simple simultaneous goals\<close>

text \<open>
  The most basic simultaneous induction operates on several goals
  one-by-one, where each case refers to induction hypotheses that are
  duplicated according to the number of conclusions.
\<close>

lemma
  fixes n :: nat
  shows "P n" and "Q n"
proof (induct n)
  case 0 case 1
  show "P 0" \<proof>
next
  case 0 case 2
  show "Q 0" \<proof>
next
  case (Suc n) case 1
  note hyps = \<open>P n\<close> \<open>Q n\<close>
  show "P (Suc n)" \<proof>
next
  case (Suc n) case 2
  note hyps = \<open>P n\<close> \<open>Q n\<close>
  show "Q (Suc n)" \<proof>
qed

text \<open>
  The split into subcases may be deferred as follows -- this is
  particularly relevant for goal statements with local premises.
\<close>

lemma
  fixes n :: nat
  shows "A n \<Longrightarrow> P n"
    and "B n \<Longrightarrow> Q n"
proof (induct n)
  case 0
  {
    case 1
    note \<open>A 0\<close>
    show "P 0" \<proof>
  next
    case 2
    note \<open>B 0\<close>
    show "Q 0" \<proof>
  }
next
  case (Suc n)
  note \<open>A n \<Longrightarrow> P n\<close>
    and \<open>B n \<Longrightarrow> Q n\<close>
  {
    case 1
    note \<open>A (Suc n)\<close>
    show "P (Suc n)" \<proof>
  next
    case 2
    note \<open>B (Suc n)\<close>
    show "Q (Suc n)" \<proof>
  }
qed

subsubsection \<open>Compound simultaneous goals\<close>

text \<open>
  The following pattern illustrates the slightly more complex
  situation of simultaneous goals with individual local assumptions.
  In compound simultaneous statements like this, local assumptions
  need to be included into each goal, using \<open>\<Longrightarrow>\<close> of the Pure
  framework.  In contrast, local parameters do not require separate
  \<open>\<And>\<close> prefixes here, but may be moved into the common context
  of the whole statement.
\<close>

lemma
  fixes n :: nat
    and x :: 'a
    and y :: 'b
  shows "A n x \<Longrightarrow> P n x"
    and "B n y \<Longrightarrow> Q n y"
proof (induct n arbitrary: x y)
  case 0
  {
    case 1
    note prem = \<open>A 0 x\<close>
    show "P 0 x" \<proof>
  }
  {
    case 2
    note prem = \<open>B 0 y\<close>
    show "Q 0 y" \<proof>
  }
next
  case (Suc n)
  note hyps = \<open>\<And>x. A n x \<Longrightarrow> P n x\<close> \<open>\<And>y. B n y \<Longrightarrow> Q n y\<close>
  then have some_intermediate_result \<proof>
  {
    case 1
    note prem = \<open>A (Suc n) x\<close>
    show "P (Suc n) x" \<proof>
  }
  {
    case 2
    note prem = \<open>B (Suc n) y\<close>
    show "Q (Suc n) y" \<proof>
  }
qed

text \<open>
  Here \<open>induct\<close> provides again nested cases with numbered
  sub-cases, which allows to share common parts of the body context.
  In typical applications, there could be a long intermediate proof of
  general consequences of the induction hypotheses, before finishing
  each conclusion separately.
\<close>

subsection \<open>Multiple rules\<close>

text \<open>
  Multiple induction rules emerge from mutual definitions of
  datatypes, inductive predicates, functions etc.  The \<open>induct\<close> method accepts replicated arguments (with \<open>and\<close>
  separator), corresponding to each projection of the induction
  principle.

  The goal statement essentially follows the same arrangement,
  although it might be subdivided into simultaneous sub-problems as
  before!
\<close>

datatype foo = Foo1 nat | Foo2 bar
  and bar = Bar1 bool | Bar2 bazar
  and bazar = Bazar foo

text \<open>
  The pack of induction rules for this datatype is: @{thm [display]
  foo.induct [no_vars] bar.induct [no_vars] bazar.induct [no_vars]}

  This corresponds to the following basic proof pattern:
\<close>

lemma
  fixes foo :: foo
    and bar :: bar
    and bazar :: bazar
  shows "P foo"
    and "Q bar"
    and "R bazar"
proof (induct foo and bar and bazar)
  case (Foo1 n)
  show "P (Foo1 n)" \<proof>
next
  case (Foo2 bar)
  note \<open>Q bar\<close>
  show "P (Foo2 bar)" \<proof>
next
  case (Bar1 b)
  show "Q (Bar1 b)" \<proof>
next
  case (Bar2 bazar)
  note \<open>R bazar\<close>
  show "Q (Bar2 bazar)" \<proof>
next
  case (Bazar foo)
  note \<open>P foo\<close>
  show "R (Bazar foo)" \<proof>
qed

text \<open>
  This can be combined with the previous techniques for compound
  statements, e.g.\ like this.
\<close>

lemma
  fixes x :: 'a and y :: 'b and z :: 'c
    and foo :: foo
    and bar :: bar
    and bazar :: bazar
  shows
    "A x foo \<Longrightarrow> P x foo"
  and
    "B1 y bar \<Longrightarrow> Q1 y bar"
    "B2 y bar \<Longrightarrow> Q2 y bar"
  and
    "C1 z bazar \<Longrightarrow> R1 z bazar"
    "C2 z bazar \<Longrightarrow> R2 z bazar"
    "C3 z bazar \<Longrightarrow> R3 z bazar"
proof (induct foo and bar and bazar arbitrary: x and y and z)
  oops

subsection \<open>Inductive predicates\<close>

text \<open>
  The most basic form of induction involving predicates (or sets)
  essentially eliminates a given membership fact.
\<close>

inductive Even :: "nat \<Rightarrow> bool" where
  zero: "Even 0"
| double: "Even (2 * n)" if "Even n" for n

lemma
  assumes "Even n"
  shows "P n"
  using assms
proof induct
  case zero
  show "P 0" \<proof>
next
  case (double n)
  note \<open>Even n\<close> and \<open>P n\<close>
  show "P (2 * n)" \<proof>
qed

text \<open>
  Alternatively, an initial rule statement may be proven as follows,
  performing ``in-situ'' elimination with explicit rule specification.
\<close>

lemma "Even n \<Longrightarrow> P n"
proof (induct rule: Even.induct)
  oops

text \<open>
  Simultaneous goals do not introduce anything new.
\<close>

lemma
  assumes "Even n"
  shows "P1 n" and "P2 n"
  using assms
proof induct
  case zero
  {
    case 1
    show "P1 0" \<proof>
  next
    case 2
    show "P2 0" \<proof>
  }
next
  case (double n)
  note \<open>Even n\<close> and \<open>P1 n\<close> and \<open>P2 n\<close>
  {
    case 1
    show "P1 (2 * n)" \<proof>
  next
    case 2
    show "P2 (2 * n)" \<proof>
  }
qed

text \<open>
  Working with mutual rules requires special care in composing the
  statement as a two-level conjunction, using lists of propositions
  separated by \<open>and\<close>.  For example:
\<close>

inductive Evn :: "nat \<Rightarrow> bool" and Odd :: "nat \<Rightarrow> bool"
where
  zero: "Evn 0"
| succ_Evn: "Odd (Suc n)" if "Evn n" for n
| succ_Odd: "Evn (Suc n)" if "Odd n" for n

lemma
    "Evn n \<Longrightarrow> P1 n"
    "Evn n \<Longrightarrow> P2 n"
    "Evn n \<Longrightarrow> P3 n"
  and
    "Odd n \<Longrightarrow> Q1 n"
    "Odd n \<Longrightarrow> Q2 n"
proof (induct rule: Evn_Odd.inducts)
  case zero
  { case 1 show "P1 0" \<proof> }
  { case 2 show "P2 0" \<proof> }
  { case 3 show "P3 0" \<proof> }
next
  case (succ_Evn n)
  note \<open>Evn n\<close> and \<open>P1 n\<close> \<open>P2 n\<close> \<open>P3 n\<close>
  { case 1 show "Q1 (Suc n)" \<proof> }
  { case 2 show "Q2 (Suc n)" \<proof> }
next
  case (succ_Odd n)
  note \<open>Odd n\<close> and \<open>Q1 n\<close> \<open>Q2 n\<close>
  { case 1 show "P1 (Suc n)" \<proof> }
  { case 2 show "P2 (Suc n)" \<proof> }
  { case 3 show "P3 (Suc n)" \<proof> }
qed

text \<open>
  Cases and hypotheses in each case can be named explicitly.
\<close>

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r
where
  refl: "star r x x" for x
| step: "star r x z" if "r x y" and "star r y z" for x y z

text \<open>Underscores are replaced by the default name hyps:\<close>

lemmas star_induct = star.induct [case_names base step[r _ IH]]

lemma "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
proof (induct rule: star_induct) print_cases
  case base
  then show ?case .
next
  case (step a b c) print_facts
  from step.prems have "star r b z" by (rule step.IH)
  with step.r show ?case by (rule star.step)
qed

end


theory Signature
  imports Embedded_Algebras Polynomials Generated_Fields "HOL-Library.Multiset" Finite_Extensions

begin

(*
[Polynomial_Divisibility]
definition (in ring) pdivides ::"'a list \<Rightarrow>'a list \<Rightarrow> bool" (infixl "pdivides" 50)
  where "p pdivides q \<equiv> (\<exists> r. r \<noteq> [] \<and> polynomial R r \<and> p = poly_mult q r)"
*)

(*
[Polynomial_Divisibility]
definition (in ring) pirreductible :: "'a set \<Rightarrow> 'a list \<Rightarrow> bool"
  where "pirreductible K p \<equiv> polynomial R p \<and> p \<noteq> []"
*)

(*
[Polynomial_Divisibility]
lemma (in ring) pirreductibleE :
  assumes "pirreductible K p"
  shows "p \<noteq> []" "polynomial R p" "degree p \<ge> 1" "set p \<subseteq> K" "lead_coeff p = \<one>"
        "\<And> q r. \<lbrakk>polynomial R q ; set q \<subseteq> K; polynomial R r ; set r \<subseteq> K ; p = poly_mult q r\<rbrakk> \<Longrightarrow>
                 q \<in> Units(univ_poly (R\<lparr>carrier := K\<rparr>)) \<or> r \<in> Units (univ_poly (R\<lparr>carrier := K\<rparr>))"
  sorry
*)

lemma (in ring) Irr_exists:
  assumes "subfield K R"
    and "(algebraic over K) x"
    and "x \<in> carrier R"
  shows "\<exists>!p \<in> carrier (K[X]). lead_coeff p = \<one> \<and> pirreducible K p \<and> eval p x = \<zero>"
  sorry

lemma (in ring) algebraic_self:
  assumes "subring k R"
    and "x \<in> k"
  shows "(algebraic over k) x"
  sorry

(*
definition (in ring) Irr :: "'a set => 'a => 'a list"
  where "Irr K x \<equiv> THE p. (pirreducible K p \<and> eval p x = \<zero>)"
*)

lemma (in ring) Irr_self:
  assumes "subfield K R"
    and "x \<in> K"
  shows "Irr K x = [ \<one>, \<ominus> x]"
  sorry

lemma (in ring) IrrE:
  assumes "subfield K R"
    and "(algebraic over K) x"
    and "x \<in> carrier R"
  shows "pirreducible K (Irr K x)" "eval (Irr K x) x = \<zero>"
  sorry
(*
  using theI'[OF Irr_exists[OF assms]] unfolding Irr_def
  by blast+
*)

lemma (in ring) IrrE' :
  assumes "subfield K R"
    and "(algebraic over K) x"
    and "x \<in> carrier R"
  shows "(Irr K x) \<noteq> []" "polynomial K (Irr K x)" "1 \<le> degree (Irr K x)"
        "set (Irr K x) \<subseteq> K" "lead_coeff (Irr K x) = \<one>"
  sorry
(* using pirreductibleE[OF IrrE(1)[OF assms]] by auto *)

definition (in ring) multiplicity :: "'a set \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow>'a list \<Rightarrow> bool"
  where "multiplicity K x n p \<equiv> ([ \<one>, \<ominus> x ][^]\<^bsub>K[X]\<^esub> n) divides\<^bsub>(univ_poly R K)\<^esub> p
                            \<and>\<not>(([ \<one>, \<ominus> x ][^]\<^bsub>K[X]\<^esub> (Suc n)) divides\<^bsub>(univ_poly R K)\<^esub> p)"

definition (in ring) roots :: "'a set \<Rightarrow> 'a list \<Rightarrow> 'a multiset"
  where "roots K p \<equiv> Abs_multiset (\<lambda>x \<in> K. (THE n. multiplicity K x n p))"

lemma (in field) roots_well_defined :
  assumes "subfield K R"
    and "polynomial K p"
    and "p \<noteq> []"
  shows "\<And>x. x \<in> K \<Longrightarrow> \<exists>! n. multiplicity K x n p""(\<lambda>y \<in> K. (THE n. multiplicity K y n p)) \<in> multiset"
  sorry

lemma (in ring) multiplicity_consistent :
  assumes "subring k R"
    and "set p \<subseteq> k"
    and "polynomial k p"
  shows "multiplicity k x n p = ring.multiplicity (R\<lparr>carrier := k\<rparr>) k x n p"
  sorry

lemma (in ring) roots_number_inf_degree :
  assumes "subfield K R"
    and "polynomial K p" "p \<noteq> []"
  shows "size (roots K p) \<le> degree p"
  sorry

definition (in ring) split :: "'a set \<Rightarrow> 'a list \<Rightarrow> bool"
  where "split K p \<equiv> polynomial K p \<and> (size (roots K p)) = degree p"

lemma (in field) simple_extension_field :
  assumes "subfield k R"
    and "x \<in> carrier R" and "(algebraic over K) x"
  shows "subfield (simple_extension k x) R"
  sorry

lemma (in field) simple_extension_incl :
  assumes "subfield k R"
    and "x \<in> carrier R"
  shows "k \<subseteq> simple_extension k x"
proof
  fix y assume hyp : "y \<in> k"
  thus "y \<in>simple_extension k x"
    using lin[OF zero hyp,of x]l_null subfieldE(3) assms
    by fastforce
qed

lemma (in field) finite_extension_field :
  assumes "subfield k R"
    and "set xs \<subseteq> carrier R" "\<And>x. x \<in> set xs \<Longrightarrow> (algebraic over K) x"
  shows "subfield (finite_extension k xs) R" using assms(2-3)
proof (induction xs)
  case Nil
  hence "k = (finite_extension k [])" by auto
  then show ?case using assms by auto
next
  case (Cons a xs)
  hence "subfield (finite_extension k xs) R" by simp
  moreover have "finite_extension k (a # xs) = simple_extension (finite_extension k xs) a"
    by simp
  ultimately show ?case
    using simple_extension_field Cons by auto
qed

lemma (in field) algebraic_simple_extension :
  assumes "subfield k R"
    and "(algebraic over k) x"
    and "x \<in> carrier R"
  shows "\<And> y. y \<in> (simple_extension k x) \<Longrightarrow> (algebraic over k) y"
  sorry

lemma (in field) algebraic_finite_extension :
  assumes "subfield k R"
    and "\<And> x. x \<in> set xs \<Longrightarrow> (algebraic over k) x \<and> x \<in> carrier R"
  shows "\<And> y. y \<in> (finite_extension k xs) \<Longrightarrow> (algebraic over k) y"
  sorry

lemma (in field) algebraic_simple_extension_backward :
  assumes "subfield k R"
    and "(algebraic over k) x"
    and "x \<in> carrier R"
    and "y \<in> carrier R"
    and "(algebraic over simple_extension k x) y"
  shows "(algebraic over k) y"
    sorry

lemma (in field) algebraic_finite_extension_backward :
  assumes "subfield k R"
    and "\<And> x. x \<in> set xs \<Longrightarrow> (algebraic over k) x \<and> x \<in> carrier R"
    and "y \<in> carrier R"
    and "(algebraic over finite_extension k xs) y"
  shows "(algebraic over k) y"
  sorry

lemma (in field) algebraic_simple_extension_trans :
  assumes "subfield k R"
    and "x \<in> carrier R"
    and "y \<in> carrier R"
    and "(algebraic over k) y"
  shows "(algebraic over simple_extension k x) y"
  sorry

lemma (in field) algebraic_finite_extension_trans :
  assumes "subfield k R"
    and "set xs \<subseteq> carrier R"
    and "y \<in> carrier R"
    and "(algebraic over k) y"
  shows "(algebraic over finite_extension k xs) y"
  sorry

lemma (in field) split_add_trans :
  assumes "subfield k R"
    and "x \<in> carrier R"
    and "y \<in> k"
    and "split k (Irr k x)"
  shows "split k (Irr k (x \<oplus> y)) "
  sorry

lemma (in field) split_mult_trans :
  assumes "subfield k R"
    and "x \<in> carrier R"
    and "y \<in> k"
    and "split k (Irr k x)"
  shows "split k (Irr k (y \<otimes> x)) "
  sorry

lemma (in field) split_Irr_incl_trans :
  assumes "subfield K R"
    and "x \<in> carrier R"
    and "(algebraic over k) x"
    and "k \<subseteq> K"
  shows "split K (Irr K x)  \<longleftrightarrow> split K (Irr k x)"
  sorry

lemma (in field) roots_incl :
  assumes "k \<subseteq> K" "K \<subseteq> carrier R"
    and "polynomial k p"
  shows "roots k p \<subseteq># roots K p"
  sorry

lemma (in field) roots_Irr_incl :
  assumes "k \<subseteq> K" "K \<subseteq> carrier R"
    and "x \<in> carrier R"
    and "(algebraic over k) x"
  shows "roots (carrier R) (Irr K x) \<subseteq># roots (carrier R) (Irr k x)"
  sorry

lemma (in field) roots_incl_imp_split :
  assumes "polynomial (carrier R) p"
    and "split (carrier R) p"
    and "subfield K R"
    and "roots (carrier R) p \<subseteq># roots K p"
  shows "split K p"
  sorry

end


section {* Timed Reactive Designs *}

theory utp_timed_rea_designs
  imports utp_rea_designs
begin

subsection {* Traces with time constraints *}

text {* Timed traces extend the trace algebra with a constant \emph{dur} that gives the duration
  of a trace. *}

class time_trace = trace +
  fixes dur :: "'a \<Rightarrow> real"
  and idle :: "'a \<Rightarrow> bool"
  assumes dur_non_zero [simp]: "dur(t) \<ge> 0"
  and dur_empty [simp]: "dur(0) = 0"
  and dur_concat [simp]: "dur(x + y) = dur(x) + dur(y)"
  and idle_empty [simp]: "idle(0)"
  and idle_concat: "idle(x + y) \<longleftrightarrow> (idle(x) \<and> idle(y))"
begin

  lemma dur_mono: "x \<le> y \<Longrightarrow> dur(x) \<le> dur(y)"
    using local.le_iff_add by auto

  lemma dur_minus [simp]: "y \<le> x \<Longrightarrow> dur(x - y) = dur(x) - dur(y)"
    by (metis add.commute add_diff_cancel_right' diff_add_cancel_left' dur_concat)

end

class dtime_trace = time_trace +
  assumes dur_discrete: "dur(t) \<in> \<nat>"
begin

  definition ddur :: "'a \<Rightarrow> nat" where
  "ddur(x) = nat(floor(dur(x)))"

  lemma dur_via_ddur: "dur(x) = real(ddur(x))"
    by (metis Nats_cases ddur_def floor_of_nat local.dur_discrete nat_int)

  lemma ddur_empty [simp]: "ddur(0) = 0"
    by (simp add: ddur_def)

  lemma ddur_concat [simp]: "ddur(x + y) = ddur(x) + ddur(y)"
    by (metis dur_via_ddur local.dur_concat of_nat_add of_nat_eq_iff)

  lemma ddur_mono: "x \<le> y \<Longrightarrow> ddur(x) \<le> ddur(y)"
    using dur_via_ddur local.dur_mono by auto

  lemma ddur_minus [simp]: "y \<le> x \<Longrightarrow> ddur(x - y) = ddur(x) - ddur(y)"
    by (metis cancel_ab_semigroup_add_class.add_diff_cancel_left' ddur_concat local.diff_add_cancel_left')

end

subsection {* Time expressions *}

syntax
  "_dur"         :: "logic \<Rightarrow> logic" ("dur\<^sub>u'(_')")
  "_time_length" :: "logic" ("\<^bold>l")
  "_idle"        :: "logic" ("is-idle")

translations
  "dur\<^sub>u(t)" == "CONST uop CONST dur t"
  "\<^bold>l"       == "dur\<^sub>u(tt)"
  "is-idle" == "CONST uop CONST idle tt"

subsection {* Signature *}

definition Wait :: "(real, '\<sigma>) uexpr \<Rightarrow> ('\<sigma>,'t::time_trace,'\<alpha>) hrel_rsp" where
[upred_defs]: "Wait n = \<^bold>R\<^sub>s(true \<turnstile> (\<^bold>l <\<^sub>u \<lceil>n\<rceil>\<^sub>S\<^sub>< \<and> is-idle) \<diamondop> (\<^bold>l =\<^sub>u \<lceil>n\<rceil>\<^sub>S\<^sub>< \<and> is-idle \<and> $st\<acute> =\<^sub>u $st))"

definition Interrupt :: "('\<sigma>,'t::time_trace,'\<alpha>) hrel_rsp \<Rightarrow> (real, '\<sigma>) uexpr \<Rightarrow> ('\<sigma>,'t,'\<alpha>) hrel_rsp \<Rightarrow> ('\<sigma>,'t,'\<alpha>) hrel_rsp" (infixl "\<triangle>'(_')" 85) where
"P \<triangle>(n) Q = \<^bold>R\<^sub>s(((\<^bold>l \<le>\<^sub>u \<lceil>n\<rceil>\<^sub>S\<^sub>< \<Rightarrow> pre\<^sub>R(P)) \<and> (\<^bold>l =\<^sub>u \<lceil>n\<rceil>\<^sub>S\<^sub>< \<Rightarrow> post\<^sub>R(P) wp\<^sub>R pre\<^sub>R(Q)))
               \<turnstile> ((peri\<^sub>R(P) \<and> \<^bold>l \<le>\<^sub>u \<lceil>n\<rceil>\<^sub>S\<^sub><) \<or> ((peri\<^sub>R(P) \<and> \<^bold>l =\<^sub>u \<lceil>n\<rceil>\<^sub>S\<^sub><) ;; peri\<^sub>R(Q)))
               \<diamondop> ((post\<^sub>R(P) \<and> \<^bold>l \<le>\<^sub>u \<lceil>n\<rceil>\<^sub>S\<^sub><) \<or> ((peri\<^sub>R(P) \<and> \<^bold>l =\<^sub>u \<lceil>n\<rceil>\<^sub>S\<^sub><) ;; post\<^sub>R(Q))))"

definition Deadline :: "('\<sigma>,'t::time_trace,'\<alpha>) hrel_rsp \<Rightarrow> (real, '\<sigma>) uexpr \<Rightarrow> ('\<sigma>,'t,'\<alpha>) hrel_rsp" ("_ endsby'(_')" [90,0] 91) where
"P endsby(n) = P \<triangle>(n) Miracle"

end