section \<open>Abstract syntax for Hybrid CSP.\<close>

theory HHL_SL
  imports Op_SL
begin

type_synonym now_dash = real
type_synonym 'a dform = "'a history \<Rightarrow> now \<Rightarrow> now_dash \<Rightarrow> bool"

(*
definition semd :: "'a history \<Rightarrow> now \<Rightarrow> now_dash \<Rightarrow> 'a dform \<Rightarrow> bool" ("_, [_, _] |= _" 50) where
  "h, [n, m] |= H \<equiv> H h n m"
*)

text \<open>The dform formula is only decided by the interval between now and now_dash\<close>
definition well_DC :: "'a dform \<Rightarrow> bool" where
"well_DC df == (\<forall> now now' h h'. (now \<le> now' \<and> (\<forall>t. t > now \<and> t < now' \<longrightarrow> h t = h' t)) \<longrightarrow> df h now now' = df h' now now')"

subsection \<open>Duration Calculus operators and lemmas proved\<close>
text \<open>almost P, P holds everywhere except for the rightmost point, not almost everywhere, over the interval.
The reason is that, for continuous evolution, it escapes whenever a violation is met.
A special case is that, if using almost everywhere, the differential cut rule will not hold anymore.\<close>
definition almost :: "'a fform \<Rightarrow> 'a dform"  where
"almost P \<equiv> \<lambda>h n nd. (nd-n > 0) \<and> (\<forall>t. t \<ge> n \<and> t < nd \<longrightarrow> P (h (t)))"

definition chop :: "'a dform \<Rightarrow> 'a dform \<Rightarrow> 'a dform"  (infixr "[^]" 40) where
  "H [^] M \<equiv> \<lambda>h n nd. \<exists>nm. nm \<ge> n \<and> nm \<le> nd \<and> H h n nm \<and> M h nm nd"

text \<open>The length of the interval l is equal to, greater than, less than T.\<close>
definition elE :: "real \<Rightarrow> 'a dform" where
  "elE T \<equiv> \<lambda>h n nd. (nd-n) = T"
definition elG :: "real \<Rightarrow> 'a dform" where
  "elG T \<equiv> \<lambda>h n nd. (nd-n) > T"
definition elL :: "real \<Rightarrow> 'a dform" where
  "elL T \<equiv> \<lambda>h n nd. (nd-n) < T"

definition dAnd :: "'a dform \<Rightarrow> 'a dform \<Rightarrow> 'a dform"  (infixr "[[&]]" 35) where
  "P [[&]] Q \<equiv> \<lambda>h n m. P h n m \<and> Q h n m"
definition dOr :: "'a dform \<Rightarrow> 'a dform \<Rightarrow> 'a dform"  (infixr "[[|]]" 30) where
  "P [[|]] Q \<equiv> \<lambda>h n m. P h n m \<or> Q h n m"
definition dNot :: "'a dform \<Rightarrow> 'a dform"  ("[[\<not>]]_" 40) where
  "[[\<not>]]P \<equiv> \<lambda>h n m. \<not> P h n m"
definition dImp :: "'a dform \<Rightarrow> 'a dform \<Rightarrow> 'a dform"  (infixr "[[\<longrightarrow>]]" 25) where
  "P [[\<longrightarrow>]] Q \<equiv> \<lambda>h n m. P h n m \<longrightarrow> Q h n m"

declare almost_def [simp]
declare chop_def [simp]
declare elE_def [simp]
declare elG_def [simp]
declare elL_def [simp]

text \<open>True holds almost everywhere\<close>
lemma almostf:
  "\<forall>h n nd. nd - n \<le> 0 \<or> almost fTrue h n nd"
  apply simp
  by (metis dense not_le)

text \<open>almost P \<Leftrightarrow> chop almost P almost P\<close>
lemma chopfb:
  "chop (almost P) (almost P) h n nd \<Longrightarrow> almost P h n nd"
  unfolding chop_def almost_def
  apply (rule conjI, auto)
  by (metis (poly_guards_query) less_eq_real_def less_trans not_less)

text \<open>chop (almost P \/ l = 0) (almost P \/ l = 0) ==> almost P \/ l = 0 \<close>
lemma chopfor:
  "chop (elE 0 [[|]] almost P) (elE 0 [[|]] almost P) h n nd \<Longrightarrow> (elE 0 [[|]] almost P) h n nd"
  unfolding dOr_def
  apply (rule disjCI, auto)
  by (metis less_eq_real_def less_trans not_less)

lemma chopf:
  "almost P h n nd \<Longrightarrow> chop (almost P) (almost P) h n nd"
  unfolding almost_def chop_def
  apply (rule exI[where x = "(n+nd)/2"])
  by auto

lemma chop0L: "chop (almost P) (elE 0) h n nd \<Longrightarrow> almost P h n nd"
  by auto

lemma chop0R: "almost P h n nd \<Longrightarrow> chop (almost P) (elE 0) h n nd"
  by auto

lemma chop_well_DC: "well_DC Ha \<Longrightarrow> well_DC Hb \<Longrightarrow> well_DC (Ha [^] Hb)"
  unfolding chop_def well_DC_def
  apply auto
  apply smt
  apply smt
  done

text \<open>Monotonicity: s \<Rightarrow> t \<Longrightarrow> almost s \<Rightarrow> almost t\<close>
lemma almostmono:
  "\<forall>s. P s \<longrightarrow> Q s \<Longrightarrow> \<forall>h n nd. almost P h n nd \<longrightarrow> almost Q h n nd"
  apply auto
  by (metis old.prod.exhaust)

lemma almostint:
  "now < nowf \<Longrightarrow> \<forall>t. (t\<ge>now \<and> t<nowf) \<longrightarrow> P (f t) \<Longrightarrow> almost P f now nowf"
  by auto

subsection \<open>Inference rules for Hybrid CSP: Hybrid Hoare Logic rules\<close>

text \<open>Specification\<close>
definition Valid :: "'a :: finite fform \<Rightarrow> 'a proc \<Rightarrow> 'a fform \<Rightarrow> 'a dform \<Rightarrow> bool" ("\<Turnstile> {_}_{_; _}" 80) where
  "\<Turnstile> {p} c {q; H} \<longleftrightarrow> (\<forall>now h now' h'. semB c now h now' h' \<longrightarrow> p (h now) \<longrightarrow> (q (h' now') \<and> H h' now now'))"

definition ValidP :: "'a :: finite fform \<Rightarrow> 'a fform \<Rightarrow> 'a procP \<Rightarrow> 'a fform \<Rightarrow> 'a fform \<Rightarrow> 'a dform \<Rightarrow> 'a dform \<Rightarrow> bool"
  ("\<Turnstile> {_, _}_{_, _; _, _}" 80) where
  "\<Turnstile> {pa, pb} c {qa, qb; Ha, Hb} \<longleftrightarrow> (\<forall>nowp nowq fp fq nowp' nowq' fp' fq'.
    semBP c nowp fp nowq fq nowp' fp' nowq' fq'  \<longrightarrow>
    pa (fp(nowp)) \<longrightarrow> pb (fq(nowq)) \<longrightarrow>
    qa (fp'(nowp')) \<and> qb (fq'(nowq')) \<and> (Ha fp' nowp nowp') \<and> (Hb fq' nowq nowq'))"

text \<open>Partial correctness rules\<close>
inductive HHL_partial :: "'a :: finite fform \<Rightarrow> 'a proc \<Rightarrow> 'a fform \<Rightarrow> 'a dform \<Rightarrow> bool" ("\<turnstile> {_}_{_; _}" 80) where
  skipR: "\<forall> s h now now'. (p s \<longrightarrow> q s) \<and> ((elE 0) h now now'\<longrightarrow> H h now now') \<Longrightarrow> well_DC H \<Longrightarrow>
         \<turnstile>{p} Skip {q; H}"
| assignR:"(\<forall> s. p s \<longrightarrow> (q (update_fst s x (evalE e s))))
               \<and> (\<forall> h now now'. ((elE 0) h now now'\<longrightarrow> H h now now')) \<Longrightarrow> well_DC H \<Longrightarrow>
         \<turnstile> {p} (x := e) {q; H}"
| seqR: "\<turnstile> {p} P {m; H} \<Longrightarrow> \<turnstile> {m} Q {q; G} ==> (\<forall> h m n. (H [^] G) h m n \<longrightarrow> M h m n) \<Longrightarrow> well_DC M \<Longrightarrow>
         \<turnstile> {p} P;  Q {q; M}"
| condTR: " ((\<forall> s. p s \<longrightarrow> ( b s)) \<and> \<turnstile> {p} P {q; H}) \<Longrightarrow> \<turnstile> {p} IF b P {q; H}"
| condFR: "((\<forall> s. p s \<longrightarrow> (q s \<and> (\<not>   b s))) \<and> (\<forall> h now now'. ((elE 0) h now now'\<longrightarrow> H h now now')))
            \<Longrightarrow> well_DC H ==> \<turnstile> {p} IF b P {q; H}"
| IChoiceR: "\<turnstile> {p} P {m; H} \<Longrightarrow> \<turnstile> {p} Q {q; G} ==> \<turnstile> {p} P \<sqinter> Q {m [|] q; H [[|]] G}"

| repetR: "\<forall>h n m. (H[^]H) h n m \<longrightarrow> H h n m \<Longrightarrow> \<turnstile> {I} P {I; H}  \<Longrightarrow>
           \<turnstile> {I} P*&&I {I; (H [[|]] (elE 0))} "

| consequenceR: "\<turnstile> {px} P {qx; Hx} \<Longrightarrow> (\<forall> s. p s \<longrightarrow> px s) \<Longrightarrow> (\<forall> s. qx s \<longrightarrow> q s) \<Longrightarrow>
                 (\<forall> h n m. Hx h n m \<longrightarrow> H h n m) \<Longrightarrow> well_DC H \<Longrightarrow> \<turnstile> {p} P {q; H}"

| continTR: "\<forall> s. (Inv [&][\<not>]b) s \<longrightarrow> q s \<Longrightarrow>
             \<forall> s. p s  \<longrightarrow> ODE_inv_in_dom ode s b Inv \<Longrightarrow>
             \<forall> h now now'. (almost (Inv [&]  b) [[|]] elE 0) h now now' \<longrightarrow>
               H h now now' \<Longrightarrow> well_DC H  \<Longrightarrow>
             \<turnstile> {p} <ode && Inv&b> {q; H}"

|diffCut: "\<turnstile> {p} <ode && Inv&b> {I; almost I [[|]] elE 0} \<Longrightarrow>
               \<turnstile> {p} <ode && Inv&(b[&]I)> {q; H} \<Longrightarrow>
               \<turnstile> {p} <ode && Inv&b> {q; H}"

(*
Different from Platzer's: This is not valid when b always be true.
|diffCut2: "\<turnstile> {p} <ode && Inv&b> {I; almost I [[|]] elE 0} \<Longrightarrow>
                \<turnstile> {p} <ode && Inv&b> {q; H} \<Longrightarrow>
                \<turnstile> {p} <ode && Inv&(b[&]I)> {q; H}"
*)

(*This is different from Platzer's: not b holds at the termination.*)
|diffWeak: "\<forall> h now now'. (almost b [[|]] elE 0) h now now' \<longrightarrow>
            H h now now' \<Longrightarrow> well_DC H \<Longrightarrow> \<turnstile> {p} <ode && Inv&b> {[\<not>]b; H}"

|diffE: "\<turnstile> {p} <odeone x e && Inv & b>; DAss x e {b; H} \<Longrightarrow> DE_free e \<Longrightarrow>
         \<turnstile> {p} <odeone x e && Inv & b> {b; H}"

|diffE2: "\<turnstile> {p} <odeone x e && Inv & b> {b; H} \<Longrightarrow> DE_free e \<Longrightarrow>
          \<turnstile> {p} <odeone x e && Inv & b>; DAss x e {b; H}"
(*
|diffSol: "\<forall> s. \<forall> t\<ge>0 .\<forall> u. u\<ge>0 \<and> u\<le>t \<longrightarrow> b(s) \<Longrightarrow> well
           \<turnstile> {p} <odeone x e && Inv & b> {b; H}"
*)

|diffInvGE: "\<forall> s. b s \<longrightarrow> q s \<Longrightarrow>
           \<turnstile> {p} <odeone x e && Inv & b> {(Diff f1) [\<ge>] (Diff f2); (almost ((Diff f1) [\<ge>] (Diff f2)) [[|]] elE 0)} \<Longrightarrow>
           \<forall> h now now'. (almost (f1 [\<ge>] f2) [[|]] elE 0) h now now' \<longrightarrow>
            H h now now' \<Longrightarrow> well_DC H \<Longrightarrow>
           \<turnstile> {p} <odeone x e && Inv & b> {f1 [\<ge>] f2; H}"

|diffInvG: "\<forall> s. b s \<longrightarrow> q s \<Longrightarrow>
           \<turnstile> {p} <odeone x e && Inv & b> {(Diff f1) [>] (Diff f2); (almost ((Diff f1) [>] (Diff f2)) [[|]] elE 0)} \<Longrightarrow>
           \<forall> h now now'. (almost (f1 [>] f2) [[|]] elE 0) h now now' \<longrightarrow>
            H h now now' \<Longrightarrow> well_DC H \<Longrightarrow>
           \<turnstile> {p} <odeone x e && Inv & b> {f1 [>] f2; H}"

|diffGhost: "\<forall> s. b s \<longrightarrow> q s \<Longrightarrow>
           \<turnstile> {p} <odeone x e && Inv & b> {q; (almost q [[|]] elE 0)} \<Longrightarrow>
           \<forall> h now now'. (almost q [[|]] elE 0) h now now' \<longrightarrow>
            H h now now' \<Longrightarrow> well_DC H \<Longrightarrow>
           \<turnstile> {p} <odeone x e && Inv & b> {q; H}"

|caseR: "\<turnstile> {p [&] pb} P {q; H} \<Longrightarrow> \<turnstile> {(p [&] ([\<not>]pb))} P {q; H} \<Longrightarrow>
             \<turnstile> {p} P {q; H}"

text \<open>When two independent P and Q are put in parallel, \<close>
text \<open>and when a communication follows P and Q,\<close>
text \<open>and when P and Q contain communication, and U V not.\<close>
inductive HHL_para :: "'a :: finite fform \<Rightarrow> 'a fform \<Rightarrow> 'a procP \<Rightarrow>
  'a fform \<Rightarrow> 'a fform \<Rightarrow> 'a dform \<Rightarrow> 'a dform \<Rightarrow> bool" ("\<turnstile> {_, _}_{_, _; _, _}" 70) where
  parallelR: "chanset P = {} \<and> chanset Q = {} \<Longrightarrow> \<turnstile> {pp} P {qp; Hp} \<Longrightarrow> \<turnstile> {pq} Q {qq; Hq}
                       \<Longrightarrow> \<turnstile> {pp, pq} P||Q {qp, qq; Hp, Hq}"

| commR: "\<turnstile> {px, py} (P || Q) {qx, qy; Hx, Hy} \<Longrightarrow>
         (\<forall> s. qx s \<longrightarrow> (rx (update_fst s x (evalE e s)))) \<Longrightarrow>
         (\<forall> s. qy s \<longrightarrow> ry s) \<Longrightarrow>
         (\<forall> h n m. (Hx[^](elE 0 [[|]] almost qx)) h n m \<longrightarrow> Gx h n m) \<Longrightarrow>
         (\<forall> h n m. (Hy[^](elE 0 [[|]] almost qy)) h n m \<longrightarrow> Gy h n m) \<Longrightarrow>
          well_DC Gx \<and> well_DC Gy \<Longrightarrow>
          \<turnstile> {px, py} (P; Cm (ch[?]x))||(Q; (Cm (ch[!]e))) {rx, ry; Gx, Gy}"

| parallel2R: "\<turnstile> {pp, pq} P||Q {qp, qq; Hp, Hq}  \<Longrightarrow> chanset P \<noteq> {} \<and> chanset Q \<noteq> {} \<Longrightarrow>
               \<turnstile> {qp} U {qu; Hu} \<Longrightarrow> \<turnstile> {qq} V {qv; Hv} \<Longrightarrow> chanset U = {} \<and> chanset V = {}
              \<Longrightarrow> \<turnstile> {pp, pq} P; U||Q; V {qu, qv; Hp [^] Hu, Hq [^] Hv}"

lemma hhl_well_DC : "\<turnstile> {p} P {q; H} \<Longrightarrow> well_DC H"
proof (induction rule: HHL_partial.induct)
  case (IChoiceR p P m H Q q G)
  then show ?case
    unfolding dOr_def well_DC_def
    by blast

next
  case (repetR H I P)
  then show ?case
    unfolding well_DC_def dOr_def
    by (metis (mono_tags, lifting) elE_def)

qed auto

lemma hhl_well_DC_par : "\<turnstile> {pp, pq} P||Q {qp, qq; Hp, Hq}  \<Longrightarrow> well_DC Hp \<and> well_DC Hq"
proof (induction rule: HHL_para.induct)
case (parallelR P Q pp qp Hp pq qq Hq)
  then show ?case
    using hhl_well_DC by auto
next
  case (commR px py P Q qx qy Hx Hy rx x e ry Gx Gy ch)
  then show ?case by auto
next
  case (parallel2R pp pq P Q qp qq Hp Hq U qu Hu V qv Hv)
  then have Hpq: "well_DC Hp \<and> well_DC Hq"
    and Huv: "well_DC Hu \<and> well_DC Hv" using hhl_well_DC by auto
  show ?case using Hpq Huv chop_well_DC by auto
qed

(*Sequential*)
lemma Sequential_aux :
  assumes "well_DC H" and "\<turnstile> {p} P {m; H}" and "\<turnstile> {m} Q {q; G}" and
    "\<Turnstile> {p} P {m; H}" and "\<Turnstile> {m} Q {q; G}"
  shows "\<Turnstile> {p} P;  Q {q; H [^] G}"
proof -
  have "\<forall>now h now' h'. semB (P; Q) now h now' h' \<longrightarrow> p (h now) \<longrightarrow>
    q (h' now') \<and> (\<exists>nm\<ge>now. nm \<le> now' \<and> H h' now nm \<and> G h' nm now')"
  proof -
    {
      fix now h now' h'
      assume PQ: "semB (P; Q) now h now' h'" and pre: "p (h now)"
      obtain now'a f' where sP: "semB P now h now'a f'" and sQ: "semB Q now'a f' now' h'"
        using PQ by clarsimp
      have post: "m (f' now'a) \<and> H f' now now'a \<and> q (h' now') \<and> G h' now'a now'"
        using sP sQ pre assms unfolding Valid_def by auto
      have nowa: "now \<le> now'a" using sP by (simp add: sem1)
      moreover have hf: "(now'a \<le> now' \<and> (\<forall>t. t < now'a \<or> t > now' \<longrightarrow> f' t = h' t))"
        using sQ by (simp add: sem1 sem2)
      ultimately have "now \<le> now' \<and> (\<forall>t. now < t \<and> t < now'a \<longrightarrow> f' t = h' t)" by auto
      then have "H h' now now'a" using assms(1) post nowa unfolding well_DC_def by auto
      then have "q (h' now') \<and> (\<exists>nm\<ge>now. nm \<le> now' \<and> H h' now nm \<and> G h' nm now')"
        using post hf nowa by blast
    }
    then show ?thesis by auto
  qed
  then show ?thesis  unfolding Valid_def chop_def by auto
qed

lemma repetitionN_0:
  " \<forall>h n m. (H[^]H) h n m \<longrightarrow> H h n m \<Longrightarrow>
    \<turnstile> {I}P{I; H} \<Longrightarrow>
   \<forall>now h now' h'. semB P now h now' h' \<longrightarrow> I (h now) \<longrightarrow> I (h' now') \<and> H h' now now' \<Longrightarrow>
    semB (P* NUM 0) now h now' h' \<Longrightarrow> I (h now) \<Longrightarrow> I (h' now') \<and> (H h' now now' \<or> elE 0 h' now now')"
  apply (ind_cases "semB (P* NUM 0) now h now' h'")
  unfolding elE_def
  by fastforce

lemma repetitionN_Suc:
assumes incN: "(\<And>now h now' h'.
           \<forall>h n m. (H[^]H) h n m \<longrightarrow> H h n m \<Longrightarrow>
           \<turnstile> {I}P{I; H} \<Longrightarrow>
           \<forall>now h now' h'. semB P now h now' h' \<longrightarrow> I (h now) \<longrightarrow> I (h' now') \<and> H h' now now' \<Longrightarrow>
           semB (P* NUM N) now h now' h' \<Longrightarrow> I (h now) \<Longrightarrow> I (h' now') \<and> (H h' now now' \<or> elE 0 h' now now'))"
  and chopH: "\<forall>h n m. (H[^]H) h n m \<longrightarrow> H h n m"
  and rP: "\<turnstile> {I} P {I; H}"
  and semBP: "\<forall>now h now' h'. semB P now h now' h' \<longrightarrow> I (h now) \<longrightarrow> I (h' now') \<and> H h' now now'"
(*  and semBPP: "semB (P* NUM Suc N) now h now' h'"
  and pre: "I (h now)"
shows "I (h' now') \<and> (H h' now now' \<or> elE 0 h' now now')"
*)
shows "semB (P* NUM Suc N) now h now' h' \<Longrightarrow> I (h now) \<Longrightarrow> I (h' now') \<and> (H h' now now' \<or> elE 0 h' now now')"
proof (ind_cases "semB (P* NUM Suc N) now h now' h'")
  have wellH: "well_DC H" using hhl_well_DC rP by auto
  have Pf: "\<And>now_d f_d. I (h now) \<Longrightarrow> semB P now h now_d f_d \<Longrightarrow>  I (f_d now_d) \<and> H f_d now now_d"
    using semBP by auto

   have PNf: "\<And>now_d f_d. semB (P* NUM N) now_d f_d now' h' \<Longrightarrow> I (f_d now_d) \<Longrightarrow> I (h' now') \<and> (H h' now_d now' \<or> elE 0 h' now_d now')"
     using incN[of _ _ now' h'] chopH rP semBP by metis
   have PPNf: "\<And>now_d f_d. semB P now h now_d f_d \<Longrightarrow> semB (P* NUM N) now_d f_d now' h' \<Longrightarrow> H f_d now now_d = H h' now now_d"
     using wellH unfolding well_DC_def
     by (simp add: sem1 sem2)
   have "\<And>now_d f_d. I (h now) \<Longrightarrow> semB P now h now_d f_d \<Longrightarrow> semB (P* NUM N) now_d f_d now' h'\<Longrightarrow> I (h' now') \<and> H h' now now'"
     using PNf Pf PPNf chopH unfolding elE_def chop_def
     by (metis eq_iff le_iff_diff_le_0 sem1)
   then show "\<And>now_d f_d. I (h now) \<Longrightarrow> semB P now h now_d f_d \<Longrightarrow> semB (P* NUM (Suc N - Suc 0)) now_d f_d now' h'
              \<Longrightarrow> I (h' now') \<and> (H h' now now' \<or> elE 0 h' now now')"
     by auto
 qed

lemma repetitionN_sound:
  "\<forall>h n m. (H[^]H) h n m \<longrightarrow> H h n m \<Longrightarrow>
       \<turnstile> {I}P{I; H} \<Longrightarrow>
       \<forall>now h now' h'. semB P now h now' h' \<longrightarrow> I (h now) \<longrightarrow> I (h' now') \<and> H h' now now' \<Longrightarrow>
       semB (P* NUM N) now h now' h' \<Longrightarrow> I (h now) \<Longrightarrow> I (h' now') \<and> (H [[|]] elE 0) h' now now'"
  unfolding dOr_def
  apply (induction N arbitrary: now h now' h')
  subgoal
  using repetitionN_0[of H I P] by metis
  using repetitionN_Suc[of H I P]
  by smt

lemma diffCut_aux :
  assumes I: "\<turnstile> {p}<ode&&Inv&b>{I; almost I [[|]] elE 0}"
    and vI: "\<Turnstile> {p}<ode&&Inv&b>{I; almost I [[|]] elE 0}"
    and C: "\<turnstile> {p}<ode&&Inv&(b [&] I)>{q; H}"
    and vC: "\<Turnstile> {p}<ode&&Inv&(b [&] I)>{q; H}"
  shows "\<Turnstile> {p} <ode&&Inv&b> {q; H}"
proof (simp add:Valid_def)
  have "\<forall>now h now' h'. semB (<ode&&Inv&b>) now h now' h' \<longrightarrow> p (h now)
    \<longrightarrow> I (h' now') \<and> (almost I [[|]] elE 0) h' now now'"
    using vI unfolding Valid_def by auto
  have semI: "semB (<ode&&Inv&b>) now h now' h' \<Longrightarrow> p (h now) \<Longrightarrow> semB (<ode&&Inv&(b [&] I)>) now h now' h'"
    for now h now' h'
    apply (ind_cases "semB (<ode&&Inv&b>) now h now' h'")
    subgoal for d sol
    proof -
      assume a: "p (h now)" and b: "now' = now + d"
        and c: "h' = (\<lambda>t. if t \<le> now + d \<and> now \<le> t then  execute_ODE ode (h now) (sol (t - now)) else h t)"
        and d: "0 \<le> d"
        and s: "ODE_solution ode d (h now) sol"
        and e: "(\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (execute_ODE ode (h now) (sol t)))"
        and f: "\<not> b (execute_ODE ode (h now) (sol d)) "
      show "semB (<ode&&Inv&(b [&] I)>) now h now' h'"
      proof -
        have "semB (<ode&&Inv&b>) now h (now + d) h'"
          using b c d e s f continuous by auto
        then have almostI: "I (h' now') \<and> (almost I [[|]] elE 0) h' now now'"
          using a vI b unfolding Valid_def by auto
        have "\<not> (b [&] I) (execute_ODE ode (h now) (sol d))"
          using e d c f unfolding fNot_def fAnd_def by auto
        moreover have "\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> (b [&] I) (execute_ODE ode (h now) (sol t))"
          using almostI  d b e c unfolding almost_def fAnd_def Let_def dOr_def elE_def
          by smt
        ultimately have "(\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (execute_ODE ode (h now) (sol t)) \<and>
          I (execute_ODE ode (h now) (sol t))) \<and>
          \<not> (b (execute_ODE ode (h now) (sol d)) \<and> I (execute_ODE ode (h now) (sol d)))"
          unfolding fAnd_def by auto
        then show ?thesis
          using b s c d continuous[of d ode h now sol "b[&]I" Inv]  unfolding Let_def fAnd_def
          by auto
     qed
    qed
    done

  have "semB (<ode&&Inv&b>) now h now' h' \<Longrightarrow> p (h now) \<Longrightarrow> q (h' now') \<and> H h' now now'"
    for now h now' h'
    using vC semI unfolding Valid_def by meson
  then show "\<forall>now h now' h'. semB (<ode&&Inv&b>) now h now' h' \<longrightarrow> p (h now) \<longrightarrow> q (h' now') \<and> H h' now now'"
    by auto
qed

lemma has_vderiv_on_zero_partial_constant:
  fixes f :: "real \<Rightarrow> ('a :: finite) state"
  assumes solv: "(f has_vderiv_on (\<lambda>xa. \<chi> i. if i = x then M (f xa) else 0)) {0..d}"
    and xi:  "i \<noteq> x"
    and tv: "t \<ge> 0  & t \<le> d"
  shows "f t $ i = f 0 $ i"
  sorry

lemma ODE_only_changes_not_zero_deriv:
  assumes "ODE_solution (odeone x e) d (aa, bb) sol"
    and tv: "t \<ge> 0  & t \<le> d"
  shows "sol t = fst (execute_ODE (odeone x e) (aa, bb) (sol t))"
proof -
  have "sol t = fst (concrete_sol (odeone x e) (aa, bb) (sol t))"
    using assms
    unfolding ODE_solution_def concrete_sol_def ODE_pair_state_def
    apply auto
    using vec_eq_iff[of "sol t" "(\<chi> i. (if i = x then sol t else fst (aa, bb)) $ i)"]
    apply auto
    subgoal for i
      using has_vderiv_on_zero_partial_constant[of sol x _ d i t]  by auto
    done
  then show ?thesis using execute_ODE_concrete by metis
qed

lemma diffE_lemma:
  fixes e :: "('a :: finite) exp"
    and aa bb :: "'a state"
    and sol :: "real \<Rightarrow> 'a state"
  assumes DEf: "DE_free e"
    and solx: "ODE_solution (odeone x e) d (aa, bb) sol"
    and tv: "t \<ge> 0  & t \<le> d"
  shows "evalE e (execute_ODE (odeone x e) (aa, bb) (sol t)) =
            snd (execute_ODE (odeone x e) (aa, bb) (sol t)) $ x"
proof -
  have agree: "Vagree (execute_ODE (odeone x e) (aa, bb) (sol t)) (ODE_pair_state (odeone x e) (sol t)) {x}"
    using execute_ODE_agree[of "odeone x e" "(aa, bb)" "sol t"]
    by auto
  then have "snd (execute_ODE (odeone x e) (aa, bb) (sol t)) $ x =
             ODE_sem (odeone x e) (sol t) $ x"
    unfolding Vagree_def ODE_pair_state_def by auto
  moreover have "ODE_sem (odeone x e) (sol t) $ x = evalE_df e (sol t)"
    by auto
  moreover have "evalE e (execute_ODE (odeone x e) (aa, bb) (sol t)) =
        evalE_df e (fst (execute_ODE (odeone x e) (aa, bb) (sol t)))"
    using DEf by (simp add: DE_free_evalE)
  moreover have "fst (execute_ODE (odeone x e) (aa, bb) (sol t)) = sol t"
    using ODE_only_changes_not_zero_deriv[of x e d _ _ sol t] solx tv  by auto
  ultimately show ?thesis by auto
qed

lemma diffE_aux:
  assumes "\<turnstile> {p}<odeone x e&&Inv&b>; DAss x e{b; H}"
    and "DE_free e"
    and "\<Turnstile> {p}<odeone x e&&Inv&b>; DAss x e{b; H}"
  shows "\<Turnstile> {p}<odeone x e&&Inv&b>{b; H}"
proof -
  have "DE_free e \<Longrightarrow> semB (<odeone x e&&Inv&b>) now h now' h' \<Longrightarrow>
    semB (<odeone x e&&Inv&b>; DAss x e) now h now' h'"
    for now h now' h'
  proof -
    assume semode: "semB (<odeone x e&&Inv&b>) now h now' h'" and DEe: "DE_free e"
    show "semB (<odeone x e&&Inv&b>; DAss x e) now h now' h'"
    using semode DEe apply auto
    subgoal for d sol
  proof -
    assume de: "DE_free e"
      and hi: "h' = (\<lambda>t. if t \<le> now + d \<and> now \<le> t then execute_ODE (odeone x e) (h now) (sol (t - now)) else h t)"
      and d0: "0 \<le> d" and solx: "ODE_solution (odeone x e) d (h now) sol"
      and dom: "\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (execute_ODE (odeone x e) (h now) (sol t))"
      and dom2: "\<not> b (execute_ODE (odeone x e) (h now) (sol d))" and nowd: "now' = now + d"
    show "semB (<odeone x e&&Inv&b>; DAss x e) now h (now + d) (\<lambda>t. if t \<le> now + d \<and> now \<le> t
      then execute_ODE (odeone x e) (h now) (sol (t - now)) else h t)"
    proof -
      have nowode: "now \<le> now'" using nowd d0 by auto
      have ex: "evalE e (execute_ODE (odeone x e) (h now) (sol (now' - now))) =
            snd (execute_ODE (odeone x e) (h now) (sol (now' - now))) $ x"
        using diffE_lemma[of e x d _ _ sol "now'-now"] de solx nowd nowode
        by (metis add.commute add_left_cancel d0 diff_add_cancel order_refl prod.exhaust_sel)
      from ex have "update_snd (h' now') x (evalE e (h' now')) =  h' now'"
        using nowode hi nowd
        apply auto
        by (smt eq_snd_iff fst_conv vec_lambda_unique)
      then have "h' = (\<lambda>t. if t = now' then update_snd (h' t) x (evalE e (h' t)) else h' t)"
        by auto
      then have dasem: "semB (DAss x e) now' h' now' h'"
        using DassignB[of x e now' h'] by auto
      then have "semB (<odeone x e&&Inv&b>) now h now' h' \<Longrightarrow> semB (DAss x e) now' h' now' h'"
        by auto
      then show ?thesis using sequenceB[of "<odeone x e&&Inv&b>" now h now' h' "DAss x e" now' h']
        hi nowd semode by auto
    qed
  qed
  done
  qed
  then show ?thesis using assms unfolding Valid_def
    by meson
qed

lemma diffE2_aux:
  assumes "\<turnstile> {p}<odeone x e&&Inv&b>{b; H}"
    and "DE_free e"
    and "\<Turnstile> {p}<odeone x e&&Inv&b>{b; H}"
  shows "\<Turnstile> {p}<odeone x e&&Inv&b>; DAss x e{b; H}"
proof -

  have "DE_free e \<Longrightarrow> semB (<odeone x e&&Inv&b>; DAss x e) now h now' h' \<Longrightarrow>
    semB (<odeone x e&&Inv&b>) now h now' h'"
    for now h now' h'
    apply auto
    using if_split
    sorry
  then show ?thesis sorry
qed

lemma diffInvGE_aux:
  assumes "\<forall>s. b s \<longrightarrow> q s"
    and "\<turnstile> {p}<odeone x e&&Inv&b>{Diff f1 [\<ge>] Diff f2; almost (Diff f1 [\<ge>] Diff f2) [[|]] elE 0}"
    and "\<forall>h now now'. (almost (f1 [\<ge>] f2) [[|]] elE 0) h now now' \<longrightarrow> H h now now'"
    and "well_DC H"
    and "\<Turnstile> {p}<odeone x e&&Inv&b>{Diff f1 [\<ge>] Diff f2; almost (Diff f1 [\<ge>] Diff f2) [[|]] elE 0}"
  shows "\<Turnstile> {p}<odeone x e&&Inv&b>{f1 [\<ge>] f2; H}"
  sorry

lemma diffInvG_aux:
  assumes "\<forall>s. b s \<longrightarrow> q s"
    and "\<turnstile> {p}<odeone x e&&Inv&b>{Diff f1 [>] Diff f2; almost (Diff f1 [>] Diff f2) [[|]] elE 0}"
    and "\<forall>h now now'. (almost (f1 [>] f2) [[|]] elE 0) h now now' \<longrightarrow> H h now now'"
    and "well_DC H"
    and "\<Turnstile> {p}<odeone x e&&Inv&b>{Diff f1 [>] Diff f2; almost (Diff f1 [>] Diff f2) [[|]] elE 0}"
  shows "\<Turnstile> {p}<odeone x e&&Inv&b>{f1 [>] f2; H}"
  sorry

lemma diffGhost_aux:
  assumes "\<forall>s. b s \<longrightarrow> q s"
    and "\<turnstile> {p}<odeone x e&&Inv&b>{q; almost q [[|]] elE 0}"
    and "\<forall>h now now'. (almost q [[|]] elE 0) h now now' \<longrightarrow> H h now now'"
    and "well_DC H"
    and "\<Turnstile> {p}<odeone x e&&Inv&b>{q; almost q [[|]] elE 0}"
  shows "\<Turnstile> {p}<odeone x e&&Inv&b>{q; H}"
  sorry

theorem HHL_partial_sound :
  "\<turnstile> {p} P {q; H} \<Longrightarrow> \<Turnstile> {p} P {q; H}"
proof (induction rule: HHL_partial.induct)
  case (skipR p q H)
  then show ?case
    apply (simp add:Valid_def, auto)
    by (metis surj_pair)

next
  case (assignR p q x e H)
  then show ?case
    apply (simp add:Valid_def, auto)
    by (metis (no_types, lifting) Cart_lambda_cong eq_snd_iff)

next
  case (seqR p P m H Q q G M)
   then have "\<Turnstile> {p} P;  Q {q; H [^] G} \<and> (\<forall>h m n. (H[^]G) h m n \<longrightarrow> M h m n) "
     using Sequential_aux hhl_well_DC by blast
   then show ?case unfolding Valid_def by auto

next
  case (condTR p b P q H)
  then show ?case
    unfolding Valid_def
    using condTR.IH
    apply blast
    done
  next
  case (condFR p q b H P)
  then show ?case
    unfolding Valid_def
    apply auto
    apply (simp add: condFR.hyps)+
    done

next
  case (IChoiceR p P m H Q q G)
  then show ?case
    unfolding Valid_def dOr_def fOr_def
    by auto

next
  case (repetR H I P)
  then show ?case
    unfolding Valid_def
    apply clarify
    using repetitionN_sound[of H I P]
    by metis

next
  case (consequenceR px P qx Hx p q H)
  then show ?case
    unfolding Valid_def
    apply auto
    using consequenceR.hyps(2) consequenceR.hyps(3) apply blast
    using consequenceR.hyps(2) consequenceR.hyps(3) apply blast
    done

next
  case (continTR Inv b q p ode H)
  show ?case
    unfolding Valid_def
    apply auto
    subgoal for now h d sol
    proof -
      assume d: "0 \<le> d" and s: "ODE_solution ode d (h now) sol" and
        dom: "\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow>
          b (execute_ODE ode (h now) (sol t))" and dom2: " \<not> b (execute_ODE ode (h now) (sol d))"
       and prep: "p (h now)"
      show "q (execute_ODE ode (h now) (sol d))"
      proof -
        define S where "S = (execute_ODE ode (h now) (sol d))"
        have "Inv S" using continTR.hyps(2) prep dom dom2 s d
          unfolding ODE_inv_in_dom_def Let_def
          using S_def by blast
        moreover have "([\<not>] b) S" using dom dom2
          unfolding fNot_def S_def Let_def by auto
        ultimately show ?thesis using continTR.hyps(1)
          unfolding fAnd_def S_def by blast
      qed
    qed
    subgoal for now h d sol
    proof -
      assume d: "0 \<le> d" and s: "ODE_solution ode d (h now) sol" and
        dom: "\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow>
          b (execute_ODE ode (h now) (sol t))" and dom2: "\<not> b (execute_ODE ode (h now) (sol d))"
       and prep: "p (h now)"
      show "H (\<lambda>t. if t \<le> now + d \<and> now \<le> t then execute_ODE ode (h now) (sol (t - now)) else h t) now (now + d)"
     proof -
       define P where "P = (\<lambda>t. if t \<le> now + d \<and> now \<le> t then
          execute_ODE ode (h now) (sol (t - now)) else h t)"
       have "(almost (Inv [&] b) [[|]] elE 0) P now (now + d)"
         unfolding dOr_def almost_def fAnd_def elE_def
         apply auto
         using d apply auto
         prefer 2
         using dom unfolding P_def Let_def
          apply simp
         using dom dom2 s continTR.hyps(2) prep d unfolding ODE_inv_in_dom_def Let_def
         apply auto
         using d by (smt prod.collapse)
       then show ?thesis using continTR.hyps(3) using P_def by auto
     qed
   qed
   done

next
  case (diffCut p ode Inv b I q H)
  then show ?case using diffCut_aux by auto

next
  case (diffWeak b H p ode Inv)
  then show ?case
    unfolding Valid_def
    apply auto
    unfolding fNot_def Let_def
     apply blast
    unfolding dOr_def by smt

next
  case (diffE p x e Inv b H)
  then show ?case using diffE_aux by blast
next
  case (diffE2 p x e Inv b H)
  then show ?case using diffE2_aux by blast
next
  case (diffInvGE b q p x e Inv f1 f2 H)
  then show ?case using diffInvGE_aux by blast
next
  case (diffInvG b q p x e Inv f1 f2 H)
  then show ?case using diffInvG_aux by blast
next
  case (diffGhost b q p x e Inv H)
  then show ?case using diffGhost_aux by blast

next
  case (caseR p pb P q H)
  then show ?case
    unfolding Valid_def fNot_def fAnd_def
    apply auto
    apply blast
    apply blast
    done
qed

lemma communication_aux:
  assumes PQ: "\<turnstile> {px, py}P || Q{qx, qy; Hx, Hy}"
    and postx: "\<forall>s. qx s \<longrightarrow> rx (update_fst s x (evalE e s))"
    and posty: "\<forall>s. qy s \<longrightarrow> ry s"
    and postHx: "\<forall>h n m. (Hx [^] (elE 0 [[|]] almost qx)) h n m \<longrightarrow> Gx h n m"
    and postHy: "\<forall>h n m. (Hy [^] (elE 0 [[|]] almost qy)) h n m \<longrightarrow> Gy h n m"
    and vPQ: "\<forall>nowp nowq fp fq nowp' nowq' fp' fq'.
          semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<longrightarrow> px (fp nowp) \<longrightarrow> py (fq nowq) \<longrightarrow>
           qx (fp' nowp') \<and> qy (fq' nowq') \<and> Hx fp' nowp nowp' \<and> Hy fq' nowq nowq'"
  shows "semBP (P; Cm (ch[?]x) || Q; Cm (ch[!]e)) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow>
        px (fp nowp) \<Longrightarrow> py (fq nowq) \<Longrightarrow>
        rx (fp' nowp') \<and> ry (fq' nowq') \<and> Gx fp' nowp nowp' \<and> Gy fq' nowq nowq'"
apply (ind_cases "semBP (P; Cm (ch[?]x) || Q; Cm (ch[!]e)) nowp fp nowq fq nowp' fp' nowq' fq'")
apply (simp add:chanset_def)
apply (simp add:chanset_def)
  subgoal for nowp'a fp'a nowq'a fq'a
  proof -
    assume 1: "px (fp nowp)" and 2: "py (fq nowq)" and 3: "nowp' = max nowp'a nowq'a"
      and 4: "fp' = (\<lambda>t. if nowp'a < t \<and> t < max nowp'a nowq'a then fp'a nowp'a
         else if t = max nowp'a nowq'a then update_fst (fp'a nowp'a) x (evalE e (fp'a nowp'a)) else fp'a t)"
      and 5: "nowq' = max nowp'a nowq'a"
      and 6: "fq' = (\<lambda>t. if nowq'a < t \<and> t \<le> max nowp'a nowq'a then fq'a nowq'a else fq'a t)"
      and 7: "semBP (P || Q) nowp fp nowq fq nowp'a fp'a nowq'a fq'a" and 8: "ch = ch"
    show "rx (fp' nowp') \<and> ry (fq' nowq') \<and> Gx fp' nowp nowp' \<and> Gy fq' nowq nowq'"
    proof -
      have postPQ: "qx (fp'a nowp'a) \<and> qy (fq'a nowq'a) \<and> Hx fp'a nowp nowp'a \<and> Hy fq'a nowq nowq'a"
        using 7 PQ vPQ 1 2 by auto
      then have postp: "rx (fp' nowp')" using 3 4 postx by fastforce
      have postq: "ry (fq' nowq')" using postPQ 5 6 posty
        by (simp add: posty max.strict_order_iff)
      have "Hx fp' nowp nowp'a" using postPQ semB1[of P Q nowp fp nowq fq nowp'a fp'a nowq'a fq'a]
        hhl_well_DC_par[of px py P Q qx qy Hx Hy] PQ 4 7
        unfolding well_DC_def by smt
      moreover have "(elE 0 [[|]] almost qx) fp' nowp'a nowp'"
        unfolding chop_def almost_def dOr_def elE_def 4 3
        using postPQ by auto
      ultimately have postpH: "(Hx [^] (elE 0 [[|]] almost qx)) fp' nowp nowp'"
        unfolding chop_def using 3
        by (meson "7" max.cobounded1 semB1)

      have "Hy fq' nowq nowq'a" using postPQ semB1[of P Q nowp fp nowq fq nowp'a fp'a nowq'a fq'a]
        hhl_well_DC_par[of px py P Q qx qy Hx Hy] PQ 6 7
        unfolding well_DC_def by smt
      moreover have "(elE 0 [[|]] almost qy) fq' nowq'a nowq'"
        unfolding chop_def almost_def dOr_def elE_def 5 6
        using postPQ by auto
      ultimately have postqH: "(Hy [^] (elE 0 [[|]] almost qy)) fq' nowq nowq'"
        unfolding chop_def using 5
        by (meson "7" max.cobounded2 semB1)

      from postp postq postpH postqH postHx postHy show ?thesis by auto
    qed
  qed
  done

lemma parallel_aux:
  " \<turnstile> {pp, pq}P || Q{qp, qq; Hp, Hq} \<Longrightarrow>
       \<turnstile> {qp}U{qu; Hu} \<Longrightarrow>
       \<turnstile> {qq}V{qv; Hv} \<Longrightarrow>
       \<forall>nowp nowq fp fq nowp' nowq' fp' fq'.
          semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<longrightarrow> pp (fp nowp) \<longrightarrow> pq (fq nowq) \<longrightarrow>
          qp (fp' nowp') \<and> qq (fq' nowq') \<and> Hp fp' nowp nowp' \<and> Hq fq' nowq nowq' \<Longrightarrow>
       chanset P \<noteq> {} \<Longrightarrow>
       chanset Q \<noteq> {} \<Longrightarrow>
       chanset U = {} \<Longrightarrow>
       chanset V = {} \<Longrightarrow>
       semBP (P; U || Q; V) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow>
       pp (fp nowp) \<Longrightarrow> pq (fq nowq) \<Longrightarrow>
       qu (fp' nowp') \<and> qv (fq' nowq') \<and> (Hp [^] Hu) fp' nowp nowp' \<and> (Hq [^] Hv) fq' nowq nowq'"
apply (ind_cases "semBP (P; U || Q; V) nowp fp nowq fq nowp' fp' nowq' fq'")
apply (simp add:chanset_def)
prefer 2 apply (simp add:chanset_def)
prefer 2 apply (simp add:chanset_def)
  subgoal for nowp'a fp'a nowq'a fq'a
  proof -
    assume 1: "\<turnstile> {pp, pq}P || Q{qp, qq; Hp, Hq}"
      and 2: "\<turnstile> {qp}U{qu; Hu}" and 3: "\<turnstile> {qq}V{qv; Hv}"
      and 4: "\<forall>nowp nowq fp fq nowp' nowq' fp' fq'.
           semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<longrightarrow> pp (fp nowp) \<longrightarrow> pq (fq nowq) \<longrightarrow>
            qp (fp' nowp') \<and> qq (fq' nowq') \<and> Hp fp' nowp nowp' \<and> Hq fq' nowq nowq'"
      and 5: "chanset P \<noteq> {}" and 6: "chanset Q \<noteq> {}" and 7: "chanset U = {}" and 8: "chanset V = {}"
      and 9: "pp (fp nowp)" and 10: "pq (fq nowq)"
      and 11: "semBP (P || Q) nowp fp nowq fq nowp'a fp'a nowq'a fq'a"
      and 12: "semB U nowp'a fp'a nowp' fp'" and 13: "semB V nowq'a fq'a nowq' fq'"
    and "chanset P \<noteq> {}" and "chanset Q \<noteq> {}" and "chanset U = {}" and "chanset V = {}"
     show "qu (fp' nowp') \<and> qv (fq' nowq') \<and> (Hp [^] Hu) fp' nowp nowp' \<and> (Hq [^] Hv) fq' nowq nowq'"
     proof -
       have wpq: "qp (fp'a nowp'a) \<and> qq (fq'a nowq'a) \<and> Hp fp'a nowp nowp'a \<and> Hq fq'a nowq nowq'a"
         using 4 11 9 10 by auto
       moreover have "\<Turnstile> {qp}U{qu; Hu} \<and> \<Turnstile> {qq}V{qv; Hv}"
         using 2 3 HHL_partial_sound by auto
       ultimately have wuv: "qu (fp' nowp') \<and> qv (fq' nowq') \<and> Hu fp' nowp'a nowp' \<and> Hv fq' nowq'a nowq'"
         unfolding Valid_def using 12 13 by auto

       have "Hp fp' nowp nowp'a \<and> Hq fq' nowq nowq'a"
         using wpq sem2 well_DC_def[of Hp] hhl_well_DC_par[of pp pq P Q qp qq Hp Hq] 1
           well_DC_def[of Hq] semB1 semB2
         by (smt "11" "12" "13")
       then show ?thesis unfolding chop_def using wpq wuv
         by (meson "11" "12" "13" sem1 semB1)
     qed
   qed
   done

theorem HHL_para_sound :
  "\<turnstile> {pp, pq} P||Q {qp, qq; Hp, Hq} \<Longrightarrow>  \<Turnstile> {pp, pq} P||Q {qp, qq; Hp, Hq}"
proof (induction rule: HHL_para.induct)
  case (parallelR P Q pp qp Hp pq qq Hq)
  then have chs: "chanset P = {} \<and> chanset Q = {}"
    and vP: "\<Turnstile> {pp} P {qp; Hp}" and vQ: "\<Turnstile> {pq} Q {qq; Hq}"
    using HHL_partial_sound by auto
  show ?case
    unfolding ValidP_def
    apply clarify
    subgoal for nowp nowq fp fq nowp' nowq' fp' fq'
    proof -
      assume PQ: "semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq'" and
             preP: "pp (fp nowp)" and preQ: "pq (fq nowq)"
      show "qp (fp' nowp') \<and> qq (fq' nowq') \<and> Hp fp' nowp nowp' \<and> Hq fq' nowq nowq'"
      proof -
        have "semB P nowp fp nowp' fp' \<and> semB Q nowq fq nowq' fq'"
          using PQ semB3 chs by metis
        then show ?thesis using vP vQ preP preQ unfolding Valid_def by metis
      qed
    qed
  done

next
  case (commR px py P Q qx qy Hx Hy rx x e ry Gx Gy ch)
  then show ?case
    unfolding ValidP_def
    apply clarify
    using communication_aux[of px py P Q qx qy Hx Hy rx x e ry Gx Gy ch]
    by presburger

next
  case (parallel2R pp pq P Q qp qq Hp Hq U qu Hu V qv Hv)
  then show ?case
    unfolding ValidP_def
    apply clarify
    using parallel_aux[of pp pq P Q qp qq Hp Hq U qu Hu V qv Hv]
    by presburger
qed

declare almost_def [simp del]
declare chop_def [simp del]

end


theory NFA imports AutoProj begin

(*  The non-deterministic finite automaton takes two types,
    the first one the type of states (finite),
    and the second one the type of symbols (alphabet).
*)

type_synonym ('q, 'a)nfa = "('q \<Rightarrow> 'a \<Rightarrow> 'q set) * 'q * ('q \<Rightarrow> bool)"

fun run :: "('q, 'a)nfa \<Rightarrow> 'q \<Rightarrow> 'a list \<Rightarrow> 'q set" where
"run A s Nil = {s}" |
"run A s (x # xs) = \<Union> {(run A s' xs) | s'. s'\<in> (tri_f A s x)}"

definition accept :: "('q, 'a)nfa \<Rightarrow> 'a list \<Rightarrow> bool" where
"accept A seq = (\<exists>sf. (tri_t A sf) \<and> sf \<in> (run A (tri_s A) seq))"

lemma empty_seq[simp]: "run A s Nil = {s}"
  apply auto
  done

lemma single_seq[simp]: "run A s [x] = (tri_f A s x)"
  apply auto
  done

lemma concat_seq[simp]: "run A s (xs @ ys) = \<Union> {run A s' ys | s'. s' \<in> (run A s xs)}"
proof (induct xs arbitrary: ys s)
case Nil
  then show ?case by auto
next
  case (Cons a xs)
  print_facts
  have "run A s ((a # xs) @ ys) = \<Union> {(run A s' (xs @ ys)) | s'. s' \<in> (run A s [a])}" by auto
  also have "\<dots> = \<Union> { (\<Union>{(run A s'' ys) | s''. s''\<in> (run A s' xs)}) | s'. s' \<in> (run A s [a])}"
    using Cons.hyps by auto
  also have "\<dots> = \<Union> { (run A s'' ys) | s''. s''\<in> (run A s ([a] @ xs))}" using Cons.hyps by auto
  finally have "run A s ((a # xs) @ ys) = \<Union> {run A s' ys |s'. s' \<in> run A s (a # xs)}" by auto
  then show ?case by auto
qed

end


(*  Title:      IP_Address.thy
    Authors:    Cornelius Diekmann
*)
theory IP_Address
imports Word_More
        Hs_Compat
        WordInterval
begin

section \<open>Modelling IP Adresses\<close>
  text\<open>An IP address is basically an unsigned integer.
    We model IP addresses of arbitrary lengths.

    We will write @{typ "'i::len word"} for IP addresses of length @{term "len_of TYPE('i::len)"}.
    We use the convention to write @{typ 'i} whenever we mean IP addresses instead of generic words.
    When we will later have theorems with several polymorphic types in it (e.g. arbitrarily
    extensible packets), this notation makes it easier to spot that type @{typ 'i} is for
    IP addresses.

    The files @{file "IPv4.thy"} @{file "IPv6.thy"} concrete this for IPv4 and IPv6.\<close>

  text\<open>The maximum IP address\<close>
  definition max_ip_addr :: "'i::len word" where
    "max_ip_addr \<equiv> of_nat ((2^(len_of(TYPE('i)))) - 1)"

  lemma max_ip_addr_max_word: "max_ip_addr = max_word"
    by(simp add: max_ip_addr_def max_word_def word_of_int_minus)

  lemma max_ip_addr_max: "\<forall>a. a \<le> max_ip_addr"
    by(simp add: max_ip_addr_max_word)
  lemma range_0_max_UNIV: "UNIV = {0 .. max_ip_addr}" (*not in the simp set, for a reason*)
    by(simp add: max_ip_addr_max_word) fastforce

  lemma "size (x::'i::len word) = len_of(TYPE('i))" by(simp add:word_size)

subsection\<open>Sets of IP Addresses\<close>
  (*Warning, not executable!*)
  text\<open>Specifying sets with network masks: 192.168.0.0 255.255.255.0\<close>
  definition ipset_from_netmask::"'i::len word \<Rightarrow> 'i::len word \<Rightarrow> 'i::len word set" where
    "ipset_from_netmask addr netmask \<equiv>
      let
        network_prefix = (addr AND netmask)
      in
        {network_prefix .. network_prefix OR (NOT netmask)}"

  text\<open>Example (pseudo syntax):
    @{const ipset_from_netmask} @{text "192.168.1.129  255.255.255.0"} =
        @{text "{192.168.1.0 .. 192.168.1.255}"}\<close>

  text{*A network mask of all ones (i.e. @{term "(- 1)::'i::len word"}).*}
  lemma ipset_from_netmask_minusone:
    "ipset_from_netmask ip (- 1) = {ip}" by (simp add: ipset_from_netmask_def)
  lemma ipset_from_netmask_maxword:
    "ipset_from_netmask ip max_word = {ip}" by (simp add: ipset_from_netmask_def)

  lemma ipset_from_netmask_zero:
    "ipset_from_netmask ip 0 = UNIV" by (auto simp add: ipset_from_netmask_def)

  text\<open>Specifying sets in Classless Inter-domain Routing (CIDR) notation: 192.168.0.0/24\<close>
  definition ipset_from_cidr ::"'i::len word \<Rightarrow> nat \<Rightarrow> 'i::len word set" where
    "ipset_from_cidr addr pflength \<equiv>
       ipset_from_netmask addr ((mask pflength) << (len_of(TYPE('i)) - pflength))"

  text\<open>Example (pseudo syntax):
    @{const ipset_from_cidr} @{text "192.168.1.129 24"} = @{text "{192.168.1.0 .. 192.168.1.255}"}\<close>

  (*does this simplify stuff?*)
  lemma "(case ipcidr of (base, len) \<Rightarrow> ipset_from_cidr base len) = uncurry ipset_from_cidr ipcidr"
    by(simp add: uncurry_case_stmt)

  lemma ipset_from_cidr_0: "ipset_from_cidr ip 0 = UNIV"
    by(auto simp add: ipset_from_cidr_def ipset_from_netmask_def Let_def)

  text\<open>A prefix length of word size gives back the singleton set with the IP address.
       Example: @{text "192.168.1.2/32 = {192.168.1.2}"}\<close>
  lemma ipset_from_cidr_wordlength:
    fixes ip :: "'i::len word"
    shows "ipset_from_cidr ip (len_of TYPE('i)) = {ip}"
    by(simp add: ipset_from_cidr_def ipset_from_netmask_def Let_def mask_def)

  text\<open>Alternative definition: Considering words as bit lists:\<close>
  lemma ipset_from_cidr_bl:
    fixes addr :: "'i::len word"
    shows "ipset_from_cidr addr pflength \<equiv>
            ipset_from_netmask addr (of_bl ((replicate pflength True) @
                                            (replicate ((len_of(TYPE('i))) - pflength)) False))"
    by(simp add: ipset_from_cidr_def mask_bl Word.shiftl_of_bl)

  lemma ipset_from_cidr_alt:
    fixes pre :: "'i::len word"
    shows "ipset_from_cidr pre len =
            {pre AND (mask len << len_of TYPE('i) - len)
             ..
             pre OR mask (len_of TYPE('i) - len)}"
    apply(simp add: ipset_from_cidr_def ipset_from_netmask_def Let_def)
    apply(simp add: Word.word_oa_dist)
    apply(simp add: NOT_mask_shifted_lenword)
    done

  lemma ipset_from_cidr_alt2:
    fixes base ::"'i::len word"
    shows "ipset_from_cidr base len =
           ipset_from_netmask base (NOT mask (len_of TYPE('i) - len))"
    apply(simp add: ipset_from_cidr_def)
    using NOT_mask_shifted_lenword by(metis word_not_not)

  text\<open>In CIDR notation, we cannot express the empty set.\<close>
  lemma ipset_from_cidr_not_empty: "ipset_from_cidr base len \<noteq> {}"
    by(simp add: ipset_from_cidr_alt bitmagic_zeroLast_leq_or1Last)

  text{*Though we can write 192.168.1.2/24, we say that 192.168.0.0/24 is well-formed.*}
  lemma ipset_from_cidr_base_wellforemd: fixes base:: "'i::len word"
    assumes "mask (len_of TYPE('i) - l) AND base = 0"
      shows "ipset_from_cidr base l = {base .. base OR mask (len_of TYPE('i) - l)}"
  proof -
    have maskshift_eq_not_mask_generic:
      "((mask l << len_of TYPE('i) - l) :: 'i::len word) = NOT mask (len_of TYPE('i) - l)"
      using NOT_mask_shifted_lenword by (metis word_not_not)
    have *: "base AND NOT mask (len_of TYPE('i) - l) = base"
      unfolding mask_eq_0_eq_x[symmetric] using assms word_bw_comms(1)[of base] by simp
    hence **: "base AND NOT mask (len_of TYPE('i) - l) OR mask (len_of TYPE('i) - l) =
                base OR mask (len_of TYPE('i) - l)" by simp
    have "ipset_from_netmask base (NOT mask (len_of TYPE('i) - l)) =
            {base .. base || mask (len_of TYPE('i) - l)}"
      by(simp add: ipset_from_netmask_def Let_def ** *)
    thus ?thesis by(simp add: ipset_from_cidr_def maskshift_eq_not_mask_generic)
  qed

  lemma ipset_from_cidr_large_pfxlen:
    fixes ip:: "'i::len word"
    assumes "n \<ge> len_of TYPE('i)"
    shows "ipset_from_cidr ip n = {ip}"
  proof -
    have obviously: "mask (len_of TYPE('i) - n) = 0" by (simp add: assms)
    show ?thesis
      apply(subst ipset_from_cidr_base_wellforemd)
       subgoal using assms by simp
      by (simp add: obviously)
  qed

  lemma ipset_from_netmask_base_mask_consume:
    fixes base :: "'i::len word"
    shows "ipset_from_netmask (base AND NOT mask (len_of TYPE('i) - m))
                              (NOT mask (len_of TYPE('i) - m))
            =
             ipset_from_netmask base (NOT mask (len_of TYPE('i) - m))"
    unfolding ipset_from_netmask_def by(simp)

  text\<open>Another definition of CIDR notation:
       All IP address which are equal on the first @{term "len - n"} bits\<close>
  definition ip_cidr_set :: "'i::len word \<Rightarrow> nat \<Rightarrow> 'i word set" where
    "ip_cidr_set i r \<equiv>
      {j . i AND NOT mask (len_of TYPE('i) - r) = j AND NOT mask (len_of TYPE('i) - r)}"

  text\<open>The definitions are equal\<close>
  lemma ipset_from_cidr_eq_ip_cidr_set:
    fixes base::"'i::len word"
    shows "ipset_from_cidr base len = ip_cidr_set base len"
  proof -
    have maskshift_eq_not_mask_generic:
      "((mask len << len_of TYPE('a) - len) :: 'a::len word) = NOT mask (len_of TYPE('a) - len)"
      using NOT_mask_shifted_lenword by (metis word_not_not)
    have 1: "mask (len - m) AND base AND NOT mask (len - m) = 0"
      for len m and base::"'i::len word"
      by(simp add: word_bw_lcs)
    have 2: "mask (len_of TYPE('i) - len) AND pfxm_p = 0 \<Longrightarrow>
           (a \<in> ipset_from_netmask pfxm_p (NOT mask (len_of TYPE('i) - len))) \<longleftrightarrow>
           (pfxm_p = NOT mask (len_of TYPE('i) - len) AND a)" for a::"'i::len word" and pfxm_p
    apply(subst ipset_from_cidr_alt2[symmetric])
    apply(subst zero_base_lsb_imp_set_eq_as_bit_operation)
     apply(simp; fail)
    apply(subst ipset_from_cidr_base_wellforemd)
     apply(simp; fail)
    apply(simp)
    done
    from 2[OF 1, of _ base] have
      "(x \<in> ipset_from_netmask base (~~ mask (len_of TYPE('i) - len))) \<longleftrightarrow>
       (base && ~~ mask (len_of TYPE('i) - len) = x && ~~ mask (len_of TYPE('i) - len))" for x
    apply(simp add: ipset_from_netmask_base_mask_consume)
    unfolding word_bw_comms(1)[of _ " ~~ mask (len_of TYPE('i) - len)"] by simp
    then show ?thesis
      unfolding ip_cidr_set_def ipset_from_cidr_def
      by(auto simp add:  maskshift_eq_not_mask_generic)
  qed

  lemma ip_cidr_set_change_base: "j \<in> ip_cidr_set i r \<Longrightarrow> ip_cidr_set j r = ip_cidr_set i r"
    by (auto simp: ip_cidr_set_def)

subsection\<open>IP Addresses as WordIntervals\<close>
  text\<open>The nice thing is: @{typ "'i wordinterval"}s are executable.\<close>

  definition iprange_single :: "'i::len word \<Rightarrow> 'i wordinterval" where
    "iprange_single ip \<equiv> WordInterval ip ip"

  fun iprange_interval :: "('i::len word \<times> 'i::len word) \<Rightarrow> 'i wordinterval" where
    "iprange_interval (ip_start, ip_end) = WordInterval ip_start ip_end"
  declare iprange_interval.simps[simp del]

  lemma iprange_interval_uncurry: "iprange_interval ipcidr = uncurry WordInterval ipcidr"
    by(cases ipcidr) (simp add: iprange_interval.simps)

  lemma "wordinterval_to_set (iprange_single ip) = {ip}"
    by(simp add: iprange_single_def)
  lemma "wordinterval_to_set (iprange_interval (ip1, ip2)) = {ip1 .. ip2}"
    by(simp add: iprange_interval.simps)

  text\<open>Now we can use the set operations on @{typ "'i::len wordinterval"}s\<close>
  term wordinterval_to_set
  term wordinterval_element
  term wordinterval_union
  term wordinterval_empty
  term wordinterval_setminus
  term wordinterval_UNIV
  term wordinterval_invert
  term wordinterval_intersection
  term wordinterval_subset
  term wordinterval_eq

subsection\<open>IP Addresses in CIDR Notation\<close>
  text\<open>We want to convert IP addresses in CIDR notation to intervals.
    We already have @{const ipset_from_cidr}, which gives back a non-executable set.
    We want to convert to something we can store in an @{typ "'i wordinterval"}.\<close>

  fun ipcidr_to_interval_start :: "('i::len word \<times> nat) \<Rightarrow> 'i::len word" where
    "ipcidr_to_interval_start (pre, len) = (
      let netmask = (mask len) << (len_of TYPE('i) - len);
          network_prefix = (pre AND netmask)
      in network_prefix)"
  fun ipcidr_to_interval_end :: "('i::len word \<times> nat) \<Rightarrow> 'i::len word" where
    "ipcidr_to_interval_end (pre, len) = (
      let netmask = (mask len) << (len_of TYPE('i) - len);
          network_prefix = (pre AND netmask)
      in network_prefix OR (NOT netmask))"
  definition ipcidr_to_interval :: "('i::len word \<times> nat) \<Rightarrow> ('i word \<times> 'i word)" where
    "ipcidr_to_interval cidr \<equiv> (ipcidr_to_interval_start cidr, ipcidr_to_interval_end cidr)"

  lemma ipset_from_cidr_ipcidr_to_interval:
    "ipset_from_cidr base len =
      {ipcidr_to_interval_start (base,len) .. ipcidr_to_interval_end (base,len)}"
    by(simp add: Let_def ipcidr_to_interval_def ipset_from_cidr_def ipset_from_netmask_def)
  declare ipcidr_to_interval_start.simps[simp del] ipcidr_to_interval_end.simps[simp del]

  lemma ipcidr_to_interval:
    "ipcidr_to_interval (base, len) = (s,e) \<Longrightarrow> ipset_from_cidr base len = {s .. e}"
    by (simp add: ipcidr_to_interval_def ipset_from_cidr_ipcidr_to_interval)

  definition ipcidr_tuple_to_wordinterval :: "('i::len word \<times> nat) \<Rightarrow> 'i wordinterval" where
    "ipcidr_tuple_to_wordinterval iprng \<equiv> iprange_interval (ipcidr_to_interval iprng)"

  lemma wordinterval_to_set_ipcidr_tuple_to_wordinterval:
    "wordinterval_to_set (ipcidr_tuple_to_wordinterval (b, m)) = ipset_from_cidr b m"
    unfolding ipcidr_tuple_to_wordinterval_def ipset_from_cidr_ipcidr_to_interval
              ipcidr_to_interval_def
    by(simp add: iprange_interval.simps)

  lemma wordinterval_to_set_ipcidr_tuple_to_wordinterval_uncurry:
    "wordinterval_to_set (ipcidr_tuple_to_wordinterval ipcidr) = uncurry ipset_from_cidr ipcidr"
    by(cases ipcidr, simp add: wordinterval_to_set_ipcidr_tuple_to_wordinterval)

  definition ipcidr_union_set :: "('i::len word \<times> nat) set \<Rightarrow> ('i word) set" where
    "ipcidr_union_set ips \<equiv> \<Union>(base, len) \<in> ips. ipset_from_cidr base len"

  lemma ipcidr_union_set_uncurry:
    "ipcidr_union_set ips = (\<Union> ipcidr \<in> ips. uncurry ipset_from_cidr ipcidr)"
    by(simp add: ipcidr_union_set_def uncurry_case_stmt)

subsection\<open>Clever Operations on IP Addresses in CIDR Notation\<close>
  text\<open>Intersecting two intervals may result in a new interval.
    Example: @{text "{1..10} \<inter> {5..20} = {5..10}"}

    Intersecting two IP address ranges represented as CIDR ranges results either in the empty set
    or the smaller of the two ranges. It will never create a new range.
    \<close>
  context
  begin
    (*contributed by Lars Noschinski*)
    private lemma less_and_not_mask_eq:
      fixes i :: "('a :: len) word"
      assumes "r2 \<le> r1" "i && ~~ mask r2 = x && ~~ mask r2"
      shows "i && ~~ mask r1 = x && ~~ mask r1"
    proof -
      have "i AND NOT mask r1 = (i && ~~ mask r2) && ~~ mask r1" (is "_ = ?w && _")
        using \<open>r2 \<le> r1\<close> by (simp add: and_not_mask_twice max_def)
      also have "?w = x && ~~ mask r2" by fact
      also have "\<dots> && ~~ mask r1 = x && ~~ mask r1"
        using \<open>r2 \<le> r1\<close> by (simp add: and_not_mask_twice max_def)
      finally show ?thesis .
    qed

    lemma ip_cidr_set_less:
      fixes i :: "'i::len word"
      shows "r1 \<le> r2 \<Longrightarrow> ip_cidr_set i r2 \<subseteq> ip_cidr_set i r1"
      unfolding ip_cidr_set_def
      apply auto
      apply (rule less_and_not_mask_eq[where ?r2.0="len_of TYPE('i) - r2"])
      apply auto
      done

    private lemma ip_cidr_set_intersect_subset_helper:
      fixes i1 r1 i2 r2
      assumes disj: "ip_cidr_set i1 r1 \<inter> ip_cidr_set i2 r2 \<noteq> {}" and  "r1 \<le> r2"
      shows "ip_cidr_set i2 r2 \<subseteq> ip_cidr_set i1 r1"
      proof -
      from disj obtain j where "j \<in> ip_cidr_set i1 r1" "j \<in> ip_cidr_set i2 r2" by auto
      with \<open>r1 \<le> r2\<close> have "j \<in> ip_cidr_set j r1" "j \<in> ip_cidr_set j r1"
        using ip_cidr_set_change_base ip_cidr_set_less by blast+

      show "ip_cidr_set i2 r2 \<subseteq> ip_cidr_set i1 r1"
      proof
        fix i assume "i \<in> ip_cidr_set i2 r2"
        with \<open>j \<in> ip_cidr_set i2 r2\<close> have "i \<in> ip_cidr_set j r2" using ip_cidr_set_change_base by auto
        also have "ip_cidr_set j r2 \<subseteq> ip_cidr_set j r1" using \<open>r1 \<le> r2\<close> ip_cidr_set_less by blast
        also have "\<dots> = ip_cidr_set i1 r1" using \<open>j \<in> ip_cidr_set i1 r1\<close> ip_cidr_set_change_base by blast
        finally show "i \<in> ip_cidr_set i1 r1" .
      qed
    qed

    lemma ip_cidr_set_notsubset_empty_inter:
      "\<not> ip_cidr_set i1 r1 \<subseteq> ip_cidr_set i2 r2 \<Longrightarrow>
       \<not> ip_cidr_set i2 r2 \<subseteq> ip_cidr_set i1 r1 \<Longrightarrow>
       ip_cidr_set i1 r1 \<inter> ip_cidr_set i2 r2 = {}"
      apply(cases "r1 \<le> r2")
       subgoal using ip_cidr_set_intersect_subset_helper by blast
      apply(cases "r2 \<le> r1")
       subgoal using ip_cidr_set_intersect_subset_helper by blast
      by(simp)
  end

  lemma ip_cidr_intersect:
     "\<not> ipset_from_cidr b2 m2 \<subseteq> ipset_from_cidr b1 m1 \<Longrightarrow>
      \<not> ipset_from_cidr b1 m1 \<subseteq> ipset_from_cidr b2 m2 \<Longrightarrow>
      ipset_from_cidr b1 m1 \<inter> ipset_from_cidr b2 m2 = {}"
    apply(simp add: ipset_from_cidr_eq_ip_cidr_set)
    using ip_cidr_set_notsubset_empty_inter by blast

  text\<open>Computing the intersection of two IP address ranges in CIDR notation\<close>
  fun ipcidr_conjunct :: "('i::len word \<times> nat) \<Rightarrow> ('i word \<times> nat) \<Rightarrow> ('i word \<times> nat) option" where
    "ipcidr_conjunct (base1, m1) (base2, m2) = (
       if
         ipset_from_cidr base1 m1 \<inter> ipset_from_cidr base2 m2 = {}
       then
         None
       else if
         ipset_from_cidr base1 m1 \<subseteq> ipset_from_cidr base2 m2
       then
         Some (base1, m1)
       else
         Some (base2, m2)
      )"

  text{*Intersecting with an address with prefix length zero always yields a non-empty result.*}
  lemma ipcidr_conjunct_any: "ipcidr_conjunct a (x,0) \<noteq> None" "ipcidr_conjunct (y,0) b \<noteq> None"
     apply(cases a, simp add: ipset_from_cidr_0 ipset_from_cidr_not_empty)
    by(cases b, simp add: ipset_from_cidr_0 ipset_from_cidr_not_empty)

  lemma ipcidr_conjunct_correct: "(case ipcidr_conjunct (b1, m1) (b2, m2)
                                          of Some (bx, mx) \<Rightarrow> ipset_from_cidr bx mx
                                          |  None \<Rightarrow> {}) =
                                   (ipset_from_cidr b1 m1) \<inter> (ipset_from_cidr b2 m2)"
    apply(simp split: if_split_asm)
    using ip_cidr_intersect by fast
  declare ipcidr_conjunct.simps[simp del]

subsection\<open>Code Equations\<close>
  text\<open>Executable definition using word intervals\<close>
  lemma ipcidr_conjunct_word[code_unfold]:
  "ipcidr_conjunct ips1 ips2 = (
     if
      wordinterval_empty (wordinterval_intersection
                            (ipcidr_tuple_to_wordinterval ips1) (ipcidr_tuple_to_wordinterval ips2))
     then
       None
     else if
       wordinterval_subset (ipcidr_tuple_to_wordinterval ips1) (ipcidr_tuple_to_wordinterval ips2)
     then
       Some ips1
     else
       Some ips2
     )"
  apply(simp)
  apply(cases ips1, cases ips2, rename_tac b1 m1 b2 m2, simp)
  apply(auto simp add: wordinterval_to_set_ipcidr_tuple_to_wordinterval ipcidr_conjunct.simps
             split: if_split_asm)
  done

  (*with the code_unfold lemma before, this works!*)
  lemma "ipcidr_conjunct (0::32 word,0) (8,1) = Some (8, 1)" by eval
  export_code ipcidr_conjunct checking SML

  text\<open>making element check executable\<close>
  lemma addr_in_ipset_from_netmask_code[code_unfold]:
    "addr \<in> (ipset_from_netmask base netmask) \<longleftrightarrow>
      (base AND netmask) \<le> addr \<and> addr \<le> (base AND netmask) OR (NOT netmask)"
    by(simp add: ipset_from_netmask_def Let_def)
  lemma addr_in_ipset_from_cidr_code[code_unfold]:
    "(addr::'i::len word) \<in> (ipset_from_cidr pre len) \<longleftrightarrow>
       (pre AND ((mask len) << (len_of TYPE('i) - len))) \<le> addr \<and>
        addr \<le> pre OR (mask (len_of TYPE('i) - len))"
  unfolding ipset_from_cidr_alt by simp

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>Preorders with explicit equivalence relation\<close>

theory Preorder
imports Orderings
begin

class preorder_equiv = preorder
begin

definition equiv :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  where "equiv x y \<longleftrightarrow> x \<le> y \<and> y \<le> x"

notation
  equiv ("op \<approx>") and
  equiv ("(_/ \<approx> _)"  [51, 51] 50)

lemma refl [iff]: "x \<approx> x"
  by (simp add: equiv_def)

lemma trans: "x \<approx> y \<Longrightarrow> y \<approx> z \<Longrightarrow> x \<approx> z"
  by (auto simp: equiv_def intro: order_trans)

lemma antisym: "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x \<approx> y"
  by (simp only: equiv_def)

lemma less_le: "x < y \<longleftrightarrow> x \<le> y \<and> \<not> x \<approx> y"
  by (auto simp add: equiv_def less_le_not_le)

lemma le_less: "x \<le> y \<longleftrightarrow> x < y \<or> x \<approx> y"
  by (auto simp add: equiv_def less_le)

lemma le_imp_less_or_eq: "x \<le> y \<Longrightarrow> x < y \<or> x \<approx> y"
  by (simp add: less_le)

lemma less_imp_not_eq: "x < y \<Longrightarrow> x \<approx> y \<longleftrightarrow> False"
  by (simp add: less_le)

lemma less_imp_not_eq2: "x < y \<Longrightarrow> y \<approx> x \<longleftrightarrow> False"
  by (simp add: equiv_def less_le)

lemma neq_le_trans: "\<not> a \<approx> b \<Longrightarrow> a \<le> b \<Longrightarrow> a < b"
  by (simp add: less_le)

lemma le_neq_trans: "a \<le> b \<Longrightarrow> \<not> a \<approx> b \<Longrightarrow> a < b"
  by (simp add: less_le)

lemma antisym_conv: "y \<le> x \<Longrightarrow> x \<le> y \<longleftrightarrow> x \<approx> y"
  by (simp add: equiv_def)

end

end


(*  Title:      HOL/Hoare/Arith2.thy
    Author:     Norbert Galm
    Copyright   1995 TUM

More arithmetic.  Much of this duplicates ex/Primes.
*)

theory Arith2
imports Main
begin

definition cd :: "[nat, nat, nat] => bool"
  where "cd x m n \<longleftrightarrow> x dvd m & x dvd n"

definition gcd :: "[nat, nat] => nat"
  where "gcd m n = (SOME x. cd x m n & (!y.(cd y m n) --> y<=x))"

primrec fac :: "nat => nat"
where
  "fac 0 = Suc 0"
| "fac (Suc n) = Suc n * fac n"

subsubsection \<open>cd\<close>

lemma cd_nnn: "0<n ==> cd n n n"
  apply (simp add: cd_def)
  done

lemma cd_le: "[| cd x m n; 0<m; 0<n |] ==> x<=m & x<=n"
  apply (unfold cd_def)
  apply (blast intro: dvd_imp_le)
  done

lemma cd_swap: "cd x m n = cd x n m"
  apply (unfold cd_def)
  apply blast
  done

lemma cd_diff_l: "n<=m ==> cd x m n = cd x (m-n) n"
  apply (unfold cd_def)
  apply (fastforce dest: dvd_diffD)
  done

lemma cd_diff_r: "m<=n ==> cd x m n = cd x m (n-m)"
  apply (unfold cd_def)
  apply (fastforce dest: dvd_diffD)
  done

subsubsection \<open>gcd\<close>

lemma gcd_nnn: "0<n ==> n = gcd n n"
  apply (unfold gcd_def)
  apply (frule cd_nnn)
  apply (rule some_equality [symmetric])
  apply (blast dest: cd_le)
  apply (blast intro: le_antisym dest: cd_le)
  done

lemma gcd_swap: "gcd m n = gcd n m"
  apply (simp add: gcd_def cd_swap)
  done

lemma gcd_diff_l: "n<=m ==> gcd m n = gcd (m-n) n"
  apply (unfold gcd_def)
  apply (subgoal_tac "n<=m ==> !x. cd x m n = cd x (m-n) n")
  apply simp
  apply (rule allI)
  apply (erule cd_diff_l)
  done

lemma gcd_diff_r: "m<=n ==> gcd m n = gcd m (n-m)"
  apply (unfold gcd_def)
  apply (subgoal_tac "m<=n ==> !x. cd x m n = cd x m (n-m) ")
  apply simp
  apply (rule allI)
  apply (erule cd_diff_r)
  done

subsubsection \<open>pow\<close>

lemma sq_pow_div2 [simp]:
    "m mod 2 = 0 ==> ((n::nat)*n)^(m div 2) = n^m"
  apply (simp add: power2_eq_square [symmetric] power_mult [symmetric] minus_mod_eq_mult_div [symmetric])
  done

end


theory msucc
  imports mlt
begin

context Ordinal_Model
begin

theorem mzero_mord :
  "m0 : mOrd"
  unfolding mzero_def
  using mordI[OF zero_ord] .

lemmas mzero_m =
  mord_m[OF mzero_mord]

lemma mzero_mlt :
  assumes j:"j : mOrd"
  shows "\<not> (j \<lless> m0)"
  unfolding mzero_def
proof (rule mordE[OF j], auto)
  fix j' assume "j' : Ord" "<ord, j'> \<lless> <ord, 0>"
  hence "j' < 0"
    using mltD by auto
  thus "False"
    using zero_lt[OF \<open>j' : Ord\<close>] by auto
qed

theorem mzero_ax :
  "m\<forall>b : mOrd. \<not> b \<lless> m0"
  unfolding mtall_def mall_def
  using mzero_mlt by auto

lemma msucc'_mord :
  assumes j : "j : mOrd"
  shows "msucc' j : mOrd"
  unfolding msucc'_def
  using mordI[OF succ_ord[OF mord_snd_ord[OF j]]] .

lemma msucc_mord :
  assumes j : "j : mOrd"
  shows "msucc j : mOrd"
  unfolding msucc_def
  using msucc'_mord[OF j] j by auto

lemma msucc_m :
  "msucc j : M"
  unfolding msucc_def
  using mord_m[OF msucc'_mord] Ordinal_Model_mdefault_m
  by auto

lemma msucc_eq :
  assumes j' : "j' : Ord"
  shows "msucc <ord, j'> = <ord, succ j'>"
  unfolding msucc_def msucc'_def
  using mordI[OF j'] mord_snd_eq by auto

lemma msuccI :
  assumes i : "i : mOrd" and j : "j : mOrd"
      and ij:"i \<lless> j \<or> i = j"
    shows "i \<lless> msucc j"
proof (rule mordE[OF i], rule mordE[OF j])
  fix i' j'
  assume i': "i' : Ord" "i = <ord, i'>"
     and j': "j' : Ord" "j = <ord, j'>"
  from ij have "i' < succ j'"
    unfolding i' j'
    using leqI1[OF i'(1) j'(1) mltD]
          leqI2[OF i'(1) j'(1) mord_pair_inject[OF i'(1) j'(1)]]
    by auto
 thus "i \<lless> msucc j"
  unfolding i' j' msucc_eq[OF j'(1)]
  using mltI[OF i'(1) succ_ord[OF j'(1)]]
  by auto
qed

lemma msuccD :
  assumes i : "i : mOrd" and j : "j : mOrd"
      and ij: "i \<lless> msucc j"
    shows "i \<lless> j \<or> i = j"
proof (rule mordE[OF i], rule mordE[OF j])
  fix i' j'
  assume i': "i' : Ord" "i = <ord, i'>"
     and j': "j' : Ord" "j = <ord, j'>"
  from ij have "i' < succ j'"
    unfolding i' j' msucc_eq[OF j'(1)]
    using mltD by auto
  hence "i' < j' \<or> i' = j'"
    using leqE[OF i'(1) j'(1)] by auto
  thus "i \<lless> j \<or> i = j"
    unfolding i' j'
    using mltI[OF i'(1) j'(1)] by auto
qed

theorem msucc_ax :
  "m\<forall>i : mOrd. m\<forall>j : mOrd. i \<lless> msucc j \<longleftrightarrow> (i \<lless> j \<or> i = j)"
  unfolding mtall_def mall_def
  using msuccI msuccD by blast

end
end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_regexp_Reverse
imports "../../Test_Base"
begin

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

datatype A = X | Y

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

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

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

fun reverse :: "'a list => 'a list" where
"reverse (nil2) = nil2"
| "reverse (cons2 z xs) = x (reverse xs) (cons2 z (nil2))"

fun rev :: "R => R" where
"rev y =
   (case y of
      Plus a b => Plus (rev a) (rev b)
      | Seq c b2 => Seq (rev b2) (rev c)
      | Star a2 => Star (rev a2)
      | other => y)"

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

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

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

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

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

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

theorem property0 :
  "((recognise (rev r) s) = (recognise r (reverse s)))"
  oops

end


(*  Title:      A locale for and a characterization of maximal normal subgroups
    Author:     Jakob von Raumer, Karlsruhe Institute of Technology
    Maintainer: Jakob von Raumer <jakob.raumer@student.kit.edu>
*)

theory MaximalNormalSubgroups
imports
  "SubgroupsAndNormalSubgroups"
  "SimpleGroups"
begin

section {* Facts about maximal normal subgroups *}

text {* A maximal normal subgroup of $G$ is a normal subgroup which is not contained in other any proper
  normal subgroup of $G$. *}

locale max_normal_subgroup = normal +
  assumes proper:"H \<noteq> carrier G"
  assumes max_normal:"\<And>J. J \<lhd> G \<Longrightarrow> J \<noteq> H \<Longrightarrow> J \<noteq> carrier G \<Longrightarrow> \<not> (H \<subseteq> J)"

text {* Another characterization of maximal normal subgroups: The factor group is simple. *}

theorem (in normal) max_normal_simple_quotient:
  assumes finite:"finite (carrier G)"
  shows "max_normal_subgroup H G = simple_group (G Mod H)"
proof
  assume "max_normal_subgroup H G"
  then interpret maxH: max_normal_subgroup H G.
  show "simple_group (G Mod H)" unfolding simple_group_def simple_group_axioms_def
  apply (rule conjI)
   apply (rule factorgroup_is_group)
  proof (auto del:equalityI)
    from finite factgroup_finite factorgroup_is_group group.finite_pos_order have gt0:"0 < card (rcosets H)"
      unfolding FactGroup_def order_def by force
    from maxH.proper finite have "carrier (G Mod H) \<noteq> {\<one>\<^bsub>G Mod H\<^esub>}" using fact_group_trivial_iff by auto
    hence "1 \<noteq> order (G Mod H)" using factorgroup_is_group group.order_one_triv_iff by metis
    with gt0 show "Suc 0 < order (G Mod H)" unfolding order_def FactGroup_def by auto
  next
    fix A'
    assume A'normal:"A' \<lhd> G Mod H" and A'nottriv:"A' \<noteq> {\<one>\<^bsub>G Mod H\<^esub>}"
    def A \<equiv> "\<Union>A'"
    have A2:"A \<lhd> G" using A'normal unfolding A_def by (rule factgroup_subgroup_union_normal)
    have "H \<in> A'" using A'normal normal_imp_subgroup subgroup.one_closed unfolding FactGroup_def by force
    hence "H \<subseteq> A" unfolding A_def by auto
    hence A1:"H \<lhd> (G\<lparr>carrier := A\<rparr>)" using A2 is_normal by (metis is_subgroup maxH.max_normal normal_restrict_supergroup subgroup_self)
    have A3:"A' = rcosets\<^bsub>G\<lparr>carrier := A\<rparr>\<^esub> H"
      unfolding A_def using factgroup_subgroup_union_factor A'normal normal_imp_subgroup by auto
    from A1 interpret normalHA: normal H "(G\<lparr>carrier := A\<rparr>)" by metis
    have "H \<subseteq> A" using normalHA.is_subgroup subgroup_imp_subset by force
    with A2 have "A = H \<or> A = carrier G" using maxH.max_normal by auto
    thus "A' = carrier (G Mod H)"
    proof (rule disjE)
      assume "A = H"
      hence "carrier (G\<lparr>carrier := A\<rparr> Mod H) = {\<one>\<^bsub>(G\<lparr>carrier := A\<rparr> Mod H)\<^esub>}" by (metis finite is_group normalHA.fact_group_trivial_iff normalHA.subgroup_self normalHA.subset subgroup_finite subgroup_of_restricted_group subgroup_of_subgroup subset_antisym)
      also have "... = {\<one>\<^bsub>G Mod H\<^esub>}" unfolding FactGroup_def by auto
      finally have "A' = {\<one>\<^bsub>G Mod H\<^esub>}" using A3 unfolding FactGroup_def by simp
      with A'nottriv show ?thesis..
    next
      assume "A = carrier G"
      hence "(G\<lparr>carrier := A\<rparr> Mod H) = G Mod H" by auto
      thus "A' = carrier (G Mod H)" using A3 unfolding FactGroup_def by simp
    qed
  qed
next
  assume simple:"simple_group (G Mod H)"
  show "max_normal_subgroup H G"
  proof
    from simple have "carrier (G Mod H) \<noteq> {\<one>\<^bsub>G Mod H\<^esub>}" unfolding simple_group_def simple_group_axioms_def order_def by auto
    with finite fact_group_trivial_iff show "H \<noteq> carrier G" by auto
  next
    fix A
    assume A:"A \<lhd> G" "A \<noteq> H" "A \<noteq> carrier G"
    show "\<not> H \<subseteq> A"
    proof
      assume HA:"H \<subseteq> A"
      hence "H \<lhd> (G\<lparr>carrier := A\<rparr>)" by (metis A(1) inv_op_closed2 is_subgroup normal_inv_iff normal_restrict_supergroup)
      then interpret normalHA: normal H "(G\<lparr>carrier := A\<rparr>)" by simp
      from finite have finiteA:"finite A" using A(1) normal_imp_subgroup by (metis subgroup_finite)
      have "rcosets\<^bsub>(G\<lparr>carrier := A\<rparr>)\<^esub> H \<lhd> G Mod H" using normality_factorization is_normal HA A(1) by auto
      with simple have "rcosets\<^bsub>(G\<lparr>carrier := A\<rparr>)\<^esub> H = {\<one>\<^bsub>G Mod H\<^esub>} \<or> rcosets\<^bsub>(G\<lparr>carrier := A\<rparr>)\<^esub> H = carrier (G Mod H)"
        unfolding simple_group_def simple_group_axioms_def by auto
      thus "False"
      proof
        assume "rcosets\<^bsub>G\<lparr>carrier := A\<rparr>\<^esub> H = {\<one>\<^bsub>G Mod H\<^esub>}"
        hence "rcosets\<^bsub>G\<lparr>carrier := A\<rparr>\<^esub> H = {\<one>\<^bsub>(G\<lparr>carrier := A\<rparr>) Mod H\<^esub>}" unfolding FactGroup_def by auto
        with finiteA have "H = A" using normalHA.fact_group_trivial_iff unfolding FactGroup_def by auto
        with A(2) show ?thesis by simp
      next
        assume AHGH:"rcosets\<^bsub>G\<lparr>carrier := A\<rparr>\<^esub> H = carrier (G Mod H)"
        have "A = carrier G" unfolding FactGroup_def RCOSETS_def
        proof
          show "A \<subseteq> carrier G" using A(1) normal_imp_subgroup subgroup_imp_subset by metis
        next
          show "carrier G \<subseteq> A"
          proof
            fix x
            assume x:"x \<in> carrier G"
            hence "H #> x \<in> rcosets H" unfolding RCOSETS_def by auto
            with AHGH have "H #> x \<in> rcosets\<^bsub>G\<lparr>carrier := A\<rparr>\<^esub> H" unfolding FactGroup_def by simp
            then obtain x' where x':"x' \<in> A" "H #>x = H #>\<^bsub>G\<lparr>carrier := A\<rparr>\<^esub> x'" unfolding RCOSETS_def by auto
            hence "H #> x = H #> x'" unfolding r_coset_def by auto
            hence "x \<in> H #> x'" by (metis is_subgroup rcos_self x)
            hence "x \<in> A #> x'" using HA unfolding r_coset_def by auto
            thus "x \<in> A" using x'(1) unfolding r_coset_def using subgroup.m_closed A(1) normal_imp_subgroup by force
          qed
        qed
        with A(3) show ?thesis by simp
      qed
    qed
  qed
qed

end


section{* Transformer Algebras  Based on KAD *}

theory Transformer_Algebras

imports VC_KAD

begin

no_notation inf (infixl "\<sqinter>" 70)
and sup (infixl "\<squnion>" 65)

definition bpt :: "'a :: antidomain_kleene_algebra \<Rightarrow> ('a \<Rightarrow> 'a)" ("|_\<rbrakk>") where
  "|x\<rbrakk>  = (\<lambda>p. |x] p)"

lemma bpt_box: "|x\<rbrakk>p = |x]p"
  by (simp add: bpt_def)

definition bpt_meet :: "('a :: antidomain_kleene_algebra \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<sqinter>" 70) where
  "f \<sqinter> g = (\<lambda>p. (f p) \<cdot> (g p))"

definition bpt_join :: "('a :: antidomain_kleene_algebra \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<squnion>" 65) where
  "f \<squnion> g = (\<lambda>p. (f p) + (g p))"

lemma bpt_seq: "|x \<cdot> y\<rbrakk> = |x\<rbrakk> \<circ> |y\<rbrakk>"
  by (intro ext, simp add: bpt_def)

lemma bpt_add1: "|x\<rbrakk> (d p \<cdot> d q) = |x\<rbrakk> p \<cdot> |x\<rbrakk> q"
  by (simp add: fbox_add1 bpt_def)

lemma bpt_add2: "|x + y\<rbrakk> p = |x\<rbrakk> p \<cdot> |y\<rbrakk> p"
  by (simp add: fbox_add2 bpt_def)

lemma bpt_add2_var: "|x + y\<rbrakk> = |x\<rbrakk> \<sqinter> |y\<rbrakk>"
  by (intro ext, simp add: bpt_meet_def bpt_add2)

lemma "|x\<rbrakk> \<squnion> |y\<rbrakk> = (\<lambda>p. |ad ( |x]p) \<cdot> y]p)"
  by (intro ext, metis (no_types, lifting) addual.ars_r_def addual.bbox_def fbox_export1 bpt_def bpt_join_def)

lemma bpt_one: "|1\<rbrakk> = (\<lambda>p. d p)"
  by (intro ext, simp add: bpt_def)

lemma bpt_zero: "|0\<rbrakk>  = (\<lambda>p. 1)"
  by (intro ext, simp add: bpt_def)

lemma bpt_mult_assoc: "( |x\<rbrakk> \<circ> |y\<rbrakk>) \<circ> |z\<rbrakk> = |x\<rbrakk> \<circ> ( |y\<rbrakk> \<circ> |z\<rbrakk>)"
  by (simp add: comp_assoc)

lemma bpt_mult_onel: "|1\<rbrakk> \<circ> |x\<rbrakk> = |x\<rbrakk>"
  by (metis mult.left_neutral bpt_seq)

lemma bpt_mult_oner: "|x\<rbrakk> \<circ> |1\<rbrakk> = |x\<rbrakk>"
  by (metis mult.right_neutral bpt_seq)

lemma bpt_mult_annil: "|0\<rbrakk> \<circ> |x\<rbrakk> = |0\<rbrakk>"
  by (metis ds.ddual.annir bpt_seq)

lemma bpt_mult_annir: "|x\<rbrakk> \<circ> |0\<rbrakk> = |0\<rbrakk>"
  by (metis ds.ddual.annil bpt_seq)

lemma bpt_meet_assoc: "|x\<rbrakk> \<sqinter> ( |y\<rbrakk> \<sqinter> |z\<rbrakk> ) = ( |x\<rbrakk> \<sqinter> |y\<rbrakk> ) \<sqinter> |z\<rbrakk>"
  by (intro ext, simp add: bpt_meet_def ds.ddual.mult_assoc)

lemma bpt_meet_comm: "|x\<rbrakk> \<sqinter> |y\<rbrakk> = |y\<rbrakk> \<sqinter> |x\<rbrakk>"
  by (intro ext, simp add: bpt_meet_def am2 fbox_def bpt_def)

lemma bpt_meet_idem: "|x\<rbrakk> \<sqinter> |x\<rbrakk> = |x\<rbrakk>"
  by (metis dnsz.dnso1 dnsz.dsg1 bpt_add2_var)

lemma bpt_meet_zero: "|0\<rbrakk> \<sqinter> |x\<rbrakk> = |x\<rbrakk>"
  by (metis add.left_neutral bpt_add2_var)

lemma bpt_join_assoc: "|x\<rbrakk> \<squnion> ( |y\<rbrakk> \<squnion> |z\<rbrakk> ) = ( |x\<rbrakk>\<squnion> |y\<rbrakk> ) \<squnion> |z\<rbrakk>"
  by (intro ext, simp add: bpt_join_def join.sup_assoc)

lemma bpt_join_comm: "|x\<rbrakk> \<squnion> |y\<rbrakk> = |y\<rbrakk> \<squnion> |x\<rbrakk>"
  by (intro ext, simp add: bpt_join_def join.sup.commute)

lemma bpt_meet_comp_distl: "|x\<rbrakk> \<circ> |y\<rbrakk> \<sqinter> |z\<rbrakk> = ( |x\<rbrakk> \<circ> |y\<rbrakk> ) \<sqinter> ( |x\<rbrakk> \<circ> |z\<rbrakk> )"
  apply (rule ext, simp add: bpt_meet_def bpt_def)
  by (metis ds.ddual.distrib_right' fbox_add2 fbox_mult)

lemma bpt_meet_comp_distr: "( |x\<rbrakk> \<sqinter> |y\<rbrakk> ) \<circ> |z\<rbrakk> = ( |x\<rbrakk> \<circ> |z\<rbrakk> ) \<sqinter> ( |y\<rbrakk> \<circ> |z\<rbrakk> )"
  by (intro ext, simp add: bpt_meet_def bpt_def)

lemma bpt_join_meet_dist1: "|x\<rbrakk> \<sqinter> ( |y\<rbrakk> \<squnion> |z\<rbrakk> ) = ( |x\<rbrakk> \<sqinter> |y\<rbrakk> ) \<squnion> ( |x\<rbrakk> \<sqinter> |z\<rbrakk> )"
  by (intro ext, simp add: bpt_join_def bpt_meet_def)

lemma bpt_join_meet_dist2: "|x\<rbrakk> \<squnion> ( |y\<rbrakk> \<sqinter> |z\<rbrakk> ) = ( |x\<rbrakk> \<squnion> |y\<rbrakk> ) \<sqinter> ( |x\<rbrakk> \<squnion> |z\<rbrakk> )"
  apply (intro ext, simp only: bpt_meet_def bpt_join_def bpt_box)
  by (metis (no_types, lifting) addual.bbox_def fbox_add2 fbox_export1 semiring_class.distrib_left)

text {* These facts show that (backward) predicate transformers form a dioid. Can we do that by a locale statement? *}

lemma bpt_cond: "|if p then x else y fi\<rbrakk> = |d p \<cdot> x\<rbrakk> \<sqinter> |ad p \<cdot> y\<rbrakk>"
  by (intro ext, simp only: bpt_def bpt_meet_def cond_def fbox_add2)

lemma bpt_cond_var: "|if p then x else y fi\<rbrakk> = ( |d p\<rbrakk> \<circ> |x\<rbrakk> ) \<sqinter> ( |ad p\<rbrakk> \<circ> |y\<rbrakk> )"
  by (simp add: bpt_cond bpt_seq)

lemma bpt_star_unfoldl: "|1\<rbrakk> \<sqinter> ( |x\<rbrakk> \<circ> |x\<^sup>\<star>\<rbrakk> ) = |x\<^sup>\<star>\<rbrakk>"
  by (intro ext, simp add: bpt_meet_def bpt_def)

lemma bpt_star_unfoldr: "|1\<rbrakk> \<sqinter> ( |x\<^sup>\<star>\<rbrakk> \<circ> |x\<rbrakk> ) = |x\<^sup>\<star>\<rbrakk>"
  by (intro ext, simp add: bpt_meet_def bpt_def)

lemma bpt_ord_prop: "|x\<rbrakk> \<le> |y\<rbrakk> \<longleftrightarrow> |x\<rbrakk> \<sqinter> |y\<rbrakk> = |x\<rbrakk>"
  apply (simp add: bpt_def ext bpt_meet_def fbox_def le_fun_def)
  by (meson meet_ord_def)

lemma d_fbox: "|y] (p :: 'a :: antidomain_kleene_algebra) = d ( |y] p)"
  by (metis ds.ddual.mult_oner fbox_mult fbox_one)

lemma bpt_star_inductl_aux: "|y] (p :: 'a :: antidomain_kleene_algebra) \<le> |z] p \<cdot> |x]( |y] p) \<Longrightarrow> |y] p \<le> |x\<^sup>\<star>]( |z] p)"
  by (metis d_fbox fbox_star_induct)

lemma bpt_star_intuctl: "|y\<rbrakk> \<le> |z\<rbrakk> \<sqinter> ( |x\<rbrakk> \<circ> |y\<rbrakk>) \<Longrightarrow> |y\<rbrakk> \<le> |x\<^sup>\<star>\<rbrakk> \<circ> |z\<rbrakk>"
  by (simp add: bpt_meet_def bpt_def bpt_star_inductl_aux le_fun_def)

text {* We can also define a specification statement at this level. We need to prove that this gives us the correct
 thing by a correspondence proof with the lower level. *}

definition aH :: "('a :: ord \<Rightarrow> 'a ) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "aH f g h \<longleftrightarrow> f \<le> g \<circ> h"

lemma spec_lift: "|d p\<rbrakk> \<le> |x\<rbrakk> \<circ> |d q\<rbrakk> \<Longrightarrow> ad p \<le> |x] (ad q)"
proof -
  assume "|d p\<rbrakk> \<le> |x\<rbrakk> \<circ> |d q\<rbrakk>"
  hence "\<forall>y. |d p] y \<le> |x]|d q]y"
    by (metis bpt_def bpt_seq fbox_seq le_funD)
  hence "|d p] 0 \<le> |x]|d q] 0"
    by blast
  thus "ad p \<le> |x] (ad q)"
    by (metis (no_types, lifting) addual.ars_r_def addual.bbox_def am3 apd2 dpdz.domain_invol dual_order.trans fbox_dom)
qed

lemma "rdom X \<subseteq> rdom Y \<Longrightarrow> (\<forall>Z. rdom (X ; Z) \<subseteq> rdom (Y ; Z))"
apply (simp add: rel_antidomain_kleene_algebra.ads_d_def rel_ad_def)
nitpick
oops

lemma "rel_ad p \<le> wp x (rel_ad q) \<Longrightarrow> (\<forall>y. wp (rdom p) y \<le> wp x (wp (rdom q) y))"
nitpick
oops

lemma (in antidomain_semiring) "d x \<le> d y \<Longrightarrow> (\<forall>z. d (x \<cdot> z) \<le> d (y \<cdot> z))"
nitpick

end

lemma (in antidomain_semiring)
assumes "(\<forall>p. |x]p \<le> |y]p) \<Longrightarrow> y \<le> x"
shows "ad p \<le> |x] (ad q) \<Longrightarrow> (\<forall>y. |d p]y \<le> |x] |d q]y)"

text {* If we can encode the effect of an assignment at the level of the algebra, we might get a way of doing program verification
and refinement purely symbolically, at least for straight line programs. This would require us to link assignments with substitutions. *}

text {* This shows that the transformer algebra forms a left Kleene algebra. Again: can we do a locale proof? *}

interpretation left_kleene_algebra "\<lambda>x y. (pt_meet |x\<rbrakk> |y\<rbrakk>) 1" "\<lambda>x y. ( |x\<rbrakk> \<circ> |y\<rbrakk>) 1"
apply standard
prefer 8
apply (simp add: bpt_meet_def bpt_def)
oops

interpretation left_kleene_algebra tp "op \<circ>" "op \<le>" "op <" "|1\<rbrakk>" "\<lambda>f. f"
apply standard
prefer 8
(* nitpick *)
oops

text {* We get dual results for the backward boxes. *}

end


theory tree_sort_AddDifferent
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

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

datatype 'a Tree = Node "'a Tree" "'a" "'a Tree" | Nil2

datatype Nat = Z | S "Nat"

fun le :: "Nat => Nat => bool" where
"le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun flatten :: "'a Tree => 'a list => 'a list" where
"flatten (Node q z q2) y = flatten q (Cons2 z (flatten q2 y))"
| "flatten (Nil2) y = y"

fun equal2 :: "Nat => Nat => bool" where
"equal2 (Z) (Z) = True"
| "equal2 (Z) (S z) = False"
| "equal2 (S x2) (Z) = False"
| "equal2 (S x2) (S y2) = equal2 x2 y2"

fun count :: "Nat => Nat list => Nat" where
"count x (Nil2) = Z"
| "count x (Cons2 z xs) =
     (if equal2 x z then S (count x xs) else count x xs)"

fun add :: "Nat => Nat Tree => Nat Tree" where
"add x (Node q z q2) =
   (if le x z then Node (add x q) z q2 else Node q z (add x q2))"
| "add x (Nil2) = Node (Nil2) x (Nil2)"

(*hipster le flatten equal2 count add *)

theorem x0 :
  "!! (x :: Nat) (y :: Nat) (t :: Nat Tree) .
     (~ (equal2 x y)) ==>
       ((count y (flatten (add x t) (Nil2))) =
          (count y (flatten t (Nil2))))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(*  Author:  Stefan Berghofer et al.
*)

subsection \<open>Signed division: negative results rounded towards zero rather than minus infinity.\<close>

theory Signed_Division
  imports MainRLT
begin

class signed_division =
  fixes signed_divide :: \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close> (infixl "sdiv" 70)
  and signed_modulo :: \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close> (infixl "smod" 70)

instantiation int :: signed_division
begin

definition signed_divide_int :: \<open>int \<Rightarrow> int \<Rightarrow> int\<close>
  where \<open>k sdiv l = sgn k * sgn l * (\<bar>k\<bar> div \<bar>l\<bar>)\<close> for k l :: int

definition signed_modulo_int :: \<open>int \<Rightarrow> int \<Rightarrow> int\<close>
  where \<open>k smod l = k - (k sdiv l) * l\<close> for k l :: int

instance ..

end

lemma int_sdiv_simps [simp]:
    "(a :: int) sdiv 1 = a"
    "(a :: int) sdiv 0 = 0"
    "(a :: int) sdiv -1 = -a"
  apply (auto simp: signed_divide_int_def sgn_if)
  done

lemma sgn_div_eq_sgn_mult:
    "a div b \<noteq> 0 \<Longrightarrow> sgn ((a :: int) div b) = sgn (a * b)"
  apply (clarsimp simp: sgn_if zero_le_mult_iff neg_imp_zdiv_nonneg_iff not_less)
  apply (metis less_le mult_le_0_iff neg_imp_zdiv_neg_iff not_less pos_imp_zdiv_neg_iff zdiv_eq_0_iff)
  done

lemma sgn_sdiv_eq_sgn_mult:
  "a sdiv b \<noteq> 0 \<Longrightarrow> sgn ((a :: int) sdiv b) = sgn (a * b)"
  by (auto simp: signed_divide_int_def sgn_div_eq_sgn_mult sgn_mult)

lemma int_sdiv_same_is_1 [simp]:
    "a \<noteq> 0 \<Longrightarrow> ((a :: int) sdiv b = a) = (b = 1)"
  apply (rule iffI)
   apply (clarsimp simp: signed_divide_int_def)
   apply (subgoal_tac "b > 0")
    apply (case_tac "a > 0")
     apply (clarsimp simp: sgn_if)
  apply (simp_all add: not_less algebra_split_simps sgn_if split: if_splits)
  using int_div_less_self [of a b] apply linarith
    apply (metis add.commute add.inverse_inverse group_cancel.rule0 int_div_less_self linorder_neqE_linordered_idom neg_0_le_iff_le not_less verit_comp_simplify1(1) zless_imp_add1_zle)
   apply (metis div_minus_right neg_imp_zdiv_neg_iff neg_le_0_iff_le not_less order.not_eq_order_implies_strict)
  apply (metis abs_le_zero_iff abs_of_nonneg neg_imp_zdiv_nonneg_iff order.not_eq_order_implies_strict)
  done

lemma int_sdiv_negated_is_minus1 [simp]:
    "a \<noteq> 0 \<Longrightarrow> ((a :: int) sdiv b = - a) = (b = -1)"
  apply (clarsimp simp: signed_divide_int_def)
  apply (rule iffI)
   apply (subgoal_tac "b < 0")
    apply (case_tac "a > 0")
     apply (clarsimp simp: sgn_if algebra_split_simps not_less)
     apply (case_tac "sgn (a * b) = -1")
      apply (simp_all add: not_less algebra_split_simps sgn_if split: if_splits)
     apply (metis add.inverse_inverse int_div_less_self int_one_le_iff_zero_less less_le neg_0_less_iff_less)
    apply (metis add.inverse_inverse div_minus_right int_div_less_self int_one_le_iff_zero_less less_le neg_0_less_iff_less)
   apply (metis less_le neg_less_0_iff_less not_less pos_imp_zdiv_neg_iff)
  apply (metis div_minus_right dual_order.eq_iff neg_imp_zdiv_nonneg_iff neg_less_0_iff_less)
  done

lemma sdiv_int_range:
    "(a :: int) sdiv b \<in> { - (abs a) .. (abs a) }"
  apply (unfold signed_divide_int_def)
  apply (subgoal_tac "(abs a) div (abs b) \<le> (abs a)")
   apply (auto simp add: sgn_if not_less)
      apply (metis le_less le_less_trans neg_equal_0_iff_equal neg_less_iff_less not_le pos_imp_zdiv_neg_iff)
     apply (metis add.inverse_neutral div_int_pos_iff le_less neg_le_iff_le order_trans)
    apply (metis div_minus_right le_less_trans neg_imp_zdiv_neg_iff neg_less_0_iff_less not_le)
  using div_int_pos_iff apply fastforce
  apply (auto simp add: abs_if not_less)
     apply (metis add.inverse_inverse add_0_left div_by_1 div_minus_right less_le neg_0_le_iff_le not_le not_one_le_zero zdiv_mono2 zless_imp_add1_zle)
    apply (metis div_by_1 neg_0_less_iff_less pos_imp_zdiv_pos_iff zdiv_mono2 zero_less_one)
   apply (metis add.inverse_neutral div_by_0 div_by_1 int_div_less_self int_one_le_iff_zero_less less_le less_minus_iff order_refl)
  apply (metis div_by_1 divide_int_def int_div_less_self less_le linorder_neqE_linordered_idom order_refl unique_euclidean_semiring_numeral_class.div_less)
  done

lemma sdiv_int_div_0 [simp]:
  "(x :: int) sdiv 0 = 0"
  by (clarsimp simp: signed_divide_int_def)

lemma sdiv_int_0_div [simp]:
  "0 sdiv (x :: int) = 0"
  by (clarsimp simp: signed_divide_int_def)

lemma smod_int_alt_def:
     "(a::int) smod b = sgn (a) * (abs a mod abs b)"
  apply (clarsimp simp: signed_modulo_int_def signed_divide_int_def)
  apply (clarsimp simp: minus_div_mult_eq_mod [symmetric] abs_sgn sgn_mult sgn_if algebra_split_simps)
  done

lemma smod_int_range:
  "b \<noteq> 0 \<Longrightarrow> (a::int) smod b \<in> { - abs b + 1 .. abs b - 1 }"
  apply (case_tac  "b > 0")
   apply (insert pos_mod_conj [where a=a and b=b])[1]
   apply (insert pos_mod_conj [where a="-a" and b=b])[1]
   apply (auto simp: smod_int_alt_def algebra_simps sgn_if
              abs_if not_less add1_zle_eq [simplified add.commute])[1]
    apply (metis add_nonneg_nonneg int_one_le_iff_zero_less le_less less_add_same_cancel2 not_le pos_mod_conj)
  apply (metis (full_types) add.inverse_inverse eucl_rel_int eucl_rel_int_iff le_less_trans neg_0_le_iff_le)
  apply (insert neg_mod_conj [where a=a and b="b"])[1]
  apply (insert neg_mod_conj [where a="-a" and b="b"])[1]
  apply (clarsimp simp: smod_int_alt_def algebra_simps sgn_if
            abs_if not_less add1_zle_eq [simplified add.commute])
  apply (metis neg_0_less_iff_less neg_mod_conj not_le not_less_iff_gr_or_eq order_trans pos_mod_conj)
  done

lemma smod_int_compares:
   "\<lbrakk> 0 \<le> a; 0 < b \<rbrakk> \<Longrightarrow> (a :: int) smod b < b"
   "\<lbrakk> 0 \<le> a; 0 < b \<rbrakk> \<Longrightarrow> 0 \<le> (a :: int) smod b"
   "\<lbrakk> a \<le> 0; 0 < b \<rbrakk> \<Longrightarrow> -b < (a :: int) smod b"
   "\<lbrakk> a \<le> 0; 0 < b \<rbrakk> \<Longrightarrow> (a :: int) smod b \<le> 0"
   "\<lbrakk> 0 \<le> a; b < 0 \<rbrakk> \<Longrightarrow> (a :: int) smod b < - b"
   "\<lbrakk> 0 \<le> a; b < 0 \<rbrakk> \<Longrightarrow> 0 \<le> (a :: int) smod b"
   "\<lbrakk> a \<le> 0; b < 0 \<rbrakk> \<Longrightarrow> (a :: int) smod b \<le> 0"
   "\<lbrakk> a \<le> 0; b < 0 \<rbrakk> \<Longrightarrow> b \<le> (a :: int) smod b"
  apply (insert smod_int_range [where a=a and b=b])
  apply (auto simp: add1_zle_eq smod_int_alt_def sgn_if)
  done

lemma smod_int_mod_0 [simp]:
  "x smod (0 :: int) = x"
  by (clarsimp simp: signed_modulo_int_def)

lemma smod_int_0_mod [simp]:
  "0 smod (x :: int) = 0"
  by (clarsimp simp: smod_int_alt_def)

lemma smod_mod_positive:
    "\<lbrakk> 0 \<le> (a :: int); 0 \<le> b \<rbrakk> \<Longrightarrow> a smod b = a mod b"
  by (clarsimp simp: smod_int_alt_def zsgn_def)

lemma minus_sdiv_eq [simp]:
  \<open>- k sdiv l = - (k sdiv l)\<close> for k l :: int
  by (simp add: signed_divide_int_def)

lemma sdiv_minus_eq [simp]:
  \<open>k sdiv - l = - (k sdiv l)\<close> for k l :: int
  by (simp add: signed_divide_int_def)

lemma sdiv_int_numeral_numeral [simp]:
  \<open>numeral m sdiv numeral n = numeral m div (numeral n :: int)\<close>
  by (simp add: signed_divide_int_def)

lemma minus_smod_eq [simp]:
  \<open>- k smod l = - (k smod l)\<close> for k l :: int
  by (simp add: smod_int_alt_def)

lemma smod_minus_eq [simp]:
  \<open>k smod - l = k smod l\<close> for k l :: int
  by (simp add: smod_int_alt_def)

lemma smod_int_numeral_numeral [simp]:
  \<open>numeral m smod numeral n = numeral m mod (numeral n :: int)\<close>
  by (simp add: smod_int_alt_def)

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
section \<open>Subset\<close>
theory Subset
  imports Basic
begin

lemma subsetI [intro!]: "(\<And>x. x \<in> A \<Longrightarrow> x \<in> B) \<Longrightarrow> A \<subseteq> B"
  unfolding subset_def by simp

lemma subsetD [dest, trans]: "\<lbrakk>A \<subseteq> B; a \<in> A\<rbrakk> \<Longrightarrow> a \<in> B"
  unfolding subset_def by blast

lemma subset_self [iff]: "A \<subseteq> A" by blast

lemma empty_subset [iff]: "{} \<subseteq> A" by blast

lemma subset_empty_iff [iff]: "A \<subseteq> {} \<longleftrightarrow> A = {}" by blast

lemma not_mem_if_subset_if_not_mem [trans]: "\<lbrakk>a \<notin> B; A \<subseteq> B\<rbrakk> \<Longrightarrow> a \<notin> A"
  by blast

lemma subset_if_subset_if_subset [trans]: "\<lbrakk>A \<subseteq> B; B \<subseteq> C\<rbrakk> \<Longrightarrow> A \<subseteq> C"
  by blast

lemma subsetCE [elim]:
  assumes "A \<subseteq> B"
  obtains "a \<notin> A" | "a \<in> B"
  using assms by auto

subsection \<open>Strict Subsets\<close>

definition "ssubset A B \<equiv> A \<subseteq> B \<and> A \<noteq> B"

bundle hotg_ssubset_syntax begin notation ssubset (infixl "\<subset>" 50) end
bundle no_hotg_xsubset_syntax begin no_notation ssubset (infixl "\<subset>" 50) end
unbundle hotg_ssubset_syntax

lemma ssubsetI [intro]:
  assumes "A \<subseteq> B"
  and "A \<noteq> B"
  shows "A \<subset> B"
  unfolding ssubset_def using assms by blast

lemma ssubsetE [elim]:
  assumes "A \<subset> B"
  obtains "A \<subseteq> B" "A \<noteq> B"
  using assms unfolding ssubset_def by blast

end