(*  Title:       AWN.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

header "Terms of the Algebra for Wireless Networks"

theory AWN
imports Lib
begin

subsection "Sequential Processes"

type_synonym ip = nat
type_synonym data = nat

text \<open>
  Most of AWN is independent of the type of messages, but the closed layer turns
  newpkt actions into the arrival of newpkt messages. We use a type class to maintain
  some abstraction (and independence from the definition of particular protocols).
\<close>

class msg =
  fixes newpkt :: "data \<times> ip \<Rightarrow> 'a"
    and eq_newpkt :: "'a \<Rightarrow> bool"
  assumes eq_newpkt_eq [simp]: "eq_newpkt (newpkt (d, i))"

text \<open>
  Sequential process terms abstract over the types of data states (@{typ 's}),
  messages (@{typ 'm}), process names (@{typ 'p}),and labels (@{typ 'l}).
\<close>

datatype (dead 's, dead 'm, dead 'p, 'l) seqp =
    GUARD "'l" "'s \<Rightarrow> 's set" "('s, 'm, 'p, 'l) seqp"
  | ASSIGN "'l" "'s \<Rightarrow> 's" "('s, 'm, 'p, 'l) seqp"
  | CHOICE "('s, 'm, 'p, 'l) seqp" "('s, 'm, 'p, 'l) seqp"
  | UCAST "'l" "'s \<Rightarrow> ip" "'s \<Rightarrow> 'm" "('s, 'm, 'p, 'l) seqp" "('s, 'm, 'p, 'l) seqp"
  | BCAST "'l" "'s \<Rightarrow> 'm" "('s, 'm, 'p, 'l) seqp"
  | GCAST "'l" "'s \<Rightarrow> ip set" "'s \<Rightarrow> 'm" "('s, 'm, 'p, 'l) seqp"
  | SEND "'l" "'s \<Rightarrow> 'm" "('s, 'm, 'p, 'l) seqp"
  | DELIVER "'l" "'s \<Rightarrow> data" "('s, 'm, 'p, 'l) seqp"
  | RECEIVE "'l" "'m \<Rightarrow> 's \<Rightarrow> 's" "('s, 'm, 'p, 'l) seqp"
  | CALL 'p
  for map: labelmap

syntax
  "_guard"    :: "['a,  ('s, 'm, 'p, unit) seqp] \<Rightarrow>  ('s, 'm, 'p, unit) seqp"
                 ("(00\<langle>_\<rangle>)//_" [0, 60] 60)
  "_lguard"   :: "['a, 'a,  ('s, 'm, 'p, unit) seqp] \<Rightarrow>  ('s, 'm, 'p, unit) seqp"
                 ("{_}(00\<langle>_\<rangle>)//_" [0, 0, 60] 60)
  "_ifguard"  :: "[pttrn, bool,  ('s, 'm, 'p, unit) seqp] \<Rightarrow>  ('s, 'm, 'p, unit) seqp"
                 ("(00\<langle>_. _\<rangle>)//_" [0, 0, 60] 60)

  "_bassign"  :: "[pttrn, 'a,  ('s, 'm, 'p, unit) seqp] \<Rightarrow>  ('s, 'm, 'p, unit) seqp"
                 ("(00\<lbrakk>_. _\<rbrakk>)//_" [0, 0, 60] 60)
  "_lbassign" :: "['a, pttrn, 'a, ('s, 'm, 'p, 'a) seqp] \<Rightarrow> ('s, 'm, 'p, 'a) seqp"
                 ("{_}(00\<lbrakk>_. _\<rbrakk>)//_" [0, 0, 0, 60] 60)

  "_assign"  :: "['a,  ('s, 'm, 'p, unit) seqp] \<Rightarrow>  ('s, 'm, 'p, unit) seqp"
                 ("((00\<lbrakk>_\<rbrakk>))//_" [0, 60] 60)
  "_lassign" :: "['a, 'a, ('s, 'm, 'p, 'a) seqp] \<Rightarrow> ('s, 'm, 'p, 'a) seqp"
                 ("({_}(00\<lbrakk>_\<rbrakk>))//_" [0, 0, 60] 60)

  "_unicast"  :: "['a, 'a,  ('s, 'm, 'p, unit) seqp,  ('s, 'm, 'p, unit) seqp] \<Rightarrow>  ('s, 'm, 'p, unit) seqp"
                 ("(3unicast'((1(3_),/ (3_))') .//(_)/ (2\<triangleright> _))" [0, 0, 60, 60] 60)
  "_lunicast" :: "['a, 'a, 'a, ('s, 'm, 'p, 'a) seqp, ('s, 'm, 'p, 'a) seqp] \<Rightarrow> ('s, 'm, 'p, 'a) seqp"
                 ("(3{_}unicast'((1(3_),/ (3_))') .//(_)/ (2\<triangleright> _))" [0, 0, 0, 60, 60] 60)

  "_bcast"    :: "['a,  ('s, 'm, 'p, unit) seqp] \<Rightarrow>  ('s, 'm, 'p, unit) seqp"
                 ("(3broadcast'((1(_))') .)//_" [0, 60] 60)
  "_lbcast"   :: "['a, 'a, ('s, 'm, 'p, 'a) seqp] \<Rightarrow> ('s, 'm, 'p, 'a) seqp"
                 ("(3{_}broadcast'((1(_))') .)//_" [0, 0, 60] 60)

  "_gcast"    :: "['a, 'a,  ('s, 'm, 'p, unit) seqp] \<Rightarrow>  ('s, 'm, 'p, unit) seqp"
                 ("(3groupcast'((1(_),/ (_))') .)//_" [0, 0, 60] 60)
  "_lgcast"   :: "['a, 'a, 'a, ('s, 'm, 'p, 'a) seqp] \<Rightarrow> ('s, 'm, 'p, 'a) seqp"
                 ("(3{_}groupcast'((1(_),/ (_))') .)//_" [0, 0, 0, 60] 60)

  "_send"     :: "['a,  ('s, 'm, 'p, unit) seqp] \<Rightarrow>  ('s, 'm, 'p, unit) seqp"
                 ("(3send'((_)') .)//_" [0, 60] 60)
  "_lsend"    :: "['a, 'a, ('s, 'm, 'p, 'a) seqp] \<Rightarrow> ('s, 'm, 'p, 'a) seqp"
                 ("(3{_}send'((_)') .)//_" [0, 0, 60] 60)

  "_deliver"  :: "['a,  ('s, 'm, 'p, unit) seqp] \<Rightarrow>  ('s, 'm, 'p, unit) seqp"
                 ("(3deliver'((_)') .)//_" [0, 60] 60)
  "_ldeliver" :: "['a, 'a, ('s, 'm, 'p, 'a) seqp] \<Rightarrow> ('s, 'm, 'p, 'a) seqp"
                 ("(3{_}deliver'((_)') .)//_" [0, 0, 60] 60)

  "_receive"  :: "['a,  ('s, 'm, 'p, unit) seqp] \<Rightarrow>  ('s, 'm, 'p, unit) seqp"
                 ("(3receive'((_)') .)//_" [0, 60] 60)
  "_lreceive" :: "['a, 'a, ('s, 'm, 'p, 'a) seqp] \<Rightarrow> ('s, 'm, 'p, 'a) seqp"
                 ("(3{_}receive'((_)') .)//_" [0, 0, 60] 60)

translations
  "_guard f p"     \<rightleftharpoons> "CONST GUARD () f p"
  "_lguard l f p"  \<rightleftharpoons> "CONST GUARD l f p"
  "_ifguard \<xi> e p" \<rightharpoonup> "CONST GUARD () (\<lambda>\<xi>. if e then {\<xi>} else {}) p"

  "_assign f p"    \<rightleftharpoons> "CONST ASSIGN () f p"
  "_lassign l f p" \<rightleftharpoons> "CONST ASSIGN l f p"

  "_bassign \<xi> e p"    \<rightleftharpoons> "CONST ASSIGN () (\<lambda>\<xi>. e) p"
  "_lbassign l \<xi> e p" \<rightleftharpoons> "CONST ASSIGN l (\<lambda>\<xi>. e) p"

  "_unicast fip fmsg p q"    \<rightleftharpoons> "CONST UCAST () fip fmsg p q"
  "_lunicast l fip fmsg p q" \<rightleftharpoons> "CONST UCAST l fip fmsg p q"

  "_bcast fmsg p"    \<rightleftharpoons> "CONST BCAST () fmsg p"
  "_lbcast l fmsg p" \<rightleftharpoons> "CONST BCAST l fmsg p"

  "_gcast fipset fmsg p"    \<rightleftharpoons> "CONST GCAST () fipset fmsg p"
  "_lgcast l fipset fmsg p" \<rightleftharpoons> "CONST GCAST l fipset fmsg p"

  "_send fmsg p"    \<rightleftharpoons> "CONST SEND () fmsg p"
  "_lsend l fmsg p" \<rightleftharpoons> "CONST SEND l fmsg p"

  "_deliver fdata p"    \<rightleftharpoons> "CONST DELIVER () fdata p"
  "_ldeliver l fdata p" \<rightleftharpoons> "CONST DELIVER l fdata p"

  "_receive fmsg p"    \<rightleftharpoons> "CONST RECEIVE () fmsg p"
  "_lreceive l fmsg p" \<rightleftharpoons> "CONST RECEIVE l fmsg p"

notation "CHOICE" ("((_)//\<oplus>//(_))" [56, 55] 55)
     and "CALL"   ("(3call'((3_)'))" [0] 60)

definition not_call :: "('s, 'm, 'p, 'l) seqp \<Rightarrow> bool"
where "not_call p \<equiv> \<forall>pn. p \<noteq> call(pn)"

lemma not_call_simps [simp]:
  "\<And>l fg p.         not_call ({l}\<langle>fg\<rangle> p)"
  "\<And>l fa p.         not_call ({l}\<lbrakk>fa\<rbrakk> p)"
  "\<And>p1 p2.          not_call (p1 \<oplus> p2)"
  "\<And>l fip fmsg p q. not_call ({l}unicast(fip, fmsg).p \<triangleright> q)"
  "\<And>l fmsg p.       not_call ({l}broadcast(fmsg).p)"
  "\<And>l fips fmsg p.  not_call ({l}groupcast(fips, fmsg).p)"
  "\<And>l fmsg p.       not_call ({l}send(fmsg).p)"
  "\<And>l fdata p.      not_call ({l}deliver(fdata).p)"
  "\<And>l fmsg p.       not_call ({l}receive(fmsg).p)"
  "\<And>l pn.         \<not>(not_call (call(pn)))"
  unfolding not_call_def by auto

definition not_choice :: "('s, 'm, 'p, 'l) seqp \<Rightarrow> bool"
where "not_choice p \<equiv> \<forall>p1 p2. p \<noteq> p1 \<oplus> p2"

lemma not_choice_simps [simp]:
  "\<And>l fg p.         not_choice ({l}\<langle>fg\<rangle> p)"
  "\<And>l fa p.         not_choice ({l}\<lbrakk>fa\<rbrakk> p)"
  "\<And>p1 p2.        \<not>(not_choice (p1 \<oplus> p2))"
  "\<And>l fip fmsg p q. not_choice ({l}unicast(fip, fmsg).p \<triangleright> q)"
  "\<And>l fmsg p.       not_choice ({l}broadcast(fmsg).p)"
  "\<And>l fips fmsg p.  not_choice ({l}groupcast(fips, fmsg).p)"
  "\<And>l fmsg p.       not_choice ({l}send(fmsg).p)"
  "\<And>l fdata p.      not_choice ({l}deliver(fdata).p)"
  "\<And>l fmsg p.       not_choice ({l}receive(fmsg).p)"
  "\<And>l pn.           not_choice (call(pn))"
  unfolding not_choice_def by auto

lemma seqp_congs:
  "\<And>l fg p. {l}\<langle>fg\<rangle> p = {l}\<langle>fg\<rangle> p"
  "\<And>l fa p. {l}\<lbrakk>fa\<rbrakk> p = {l}\<lbrakk>fa\<rbrakk> p"
  "\<And>p1 p2. p1 \<oplus> p2 = p1 \<oplus> p2"
  "\<And>l fip fmsg p q. {l}unicast(fip, fmsg).p \<triangleright> q = {l}unicast(fip, fmsg).p \<triangleright> q"
  "\<And>l fmsg p. {l}broadcast(fmsg).p = {l}broadcast(fmsg).p"
  "\<And>l fips fmsg p. {l}groupcast(fips, fmsg).p = {l}groupcast(fips, fmsg).p"
  "\<And>l fmsg p. {l}send(fmsg).p = {l}send(fmsg).p"
  "\<And>l fdata p. {l}deliver(fdata).p = {l}deliver(fdata).p"
  "\<And>l fmsg p. {l}receive(fmsg).p = {l}receive(fmsg).p"
  "\<And>l pn. call(pn) = call(pn)"
  by auto

text \<open>Remove data expressions from process terms.\<close>

fun seqp_skeleton :: "('s, 'm, 'p, 'l) seqp \<Rightarrow> (unit, unit, 'p, 'l) seqp"
where
    "seqp_skeleton ({l}\<langle>_\<rangle> p)                 = {l}\<langle>\<lambda>_. {()}\<rangle> (seqp_skeleton p)"
  | "seqp_skeleton ({l}\<lbrakk>_\<rbrakk> p)                 = {l}\<lbrakk>\<lambda>_. ()\<rbrakk> (seqp_skeleton p)"
  | "seqp_skeleton (p \<oplus> q)                   = (seqp_skeleton p) \<oplus> (seqp_skeleton q)"
  | "seqp_skeleton ({l}unicast(_, _). p \<triangleright> q) = {l}unicast(\<lambda>_. 0, \<lambda>_. ()). (seqp_skeleton p) \<triangleright> (seqp_skeleton q)"
  | "seqp_skeleton ({l}broadcast(_). p)      = {l}broadcast(\<lambda>_. ()). (seqp_skeleton p)"
  | "seqp_skeleton ({l}groupcast(_, _). p)   = {l}groupcast(\<lambda>_. {}, \<lambda>_. ()). (seqp_skeleton p)"
  | "seqp_skeleton ({l}send(_). p)           = {l}send(\<lambda>_. ()). (seqp_skeleton p)"
  | "seqp_skeleton ({l}deliver(_). p)        = {l}deliver(\<lambda>_. 0). (seqp_skeleton p)"
  | "seqp_skeleton ({l}receive(_). p)        = {l}receive(\<lambda>_ _. ()). (seqp_skeleton p)"
  | "seqp_skeleton (call(pn))                = call(pn)"

text \<open>Calculate the subterms of a term.\<close>

fun subterms :: "('s, 'm, 'p, 'l) seqp \<Rightarrow> ('s, 'm, 'p, 'l) seqp set"
where
    "subterms ({l}\<langle>fg\<rangle> p) = {{l}\<langle>fg\<rangle> p} \<union> subterms p"
  | "subterms ({l}\<lbrakk>fa\<rbrakk> p) = {{l}\<lbrakk>fa\<rbrakk> p} \<union> subterms p"
  | "subterms (p1 \<oplus> p2) = {p1 \<oplus> p2} \<union> subterms p1 \<union> subterms p2"
  | "subterms ({l}unicast(fip, fmsg). p \<triangleright> q) =
       {{l}unicast(fip, fmsg). p \<triangleright> q} \<union> subterms p \<union> subterms q"
  | "subterms ({l}broadcast(fmsg). p) = {{l}broadcast(fmsg). p} \<union> subterms p"
  | "subterms ({l}groupcast(fips, fmsg). p) = {{l}groupcast(fips, fmsg). p} \<union> subterms p"
  | "subterms ({l}send(fmsg). p) = {{l}send(fmsg).p} \<union> subterms p"
  | "subterms ({l}deliver(fdata). p) = {{l}deliver(fdata).p} \<union> subterms p"
  | "subterms ({l}receive(fmsg). p) = {{l}receive(fmsg).p} \<union> subterms p"
  | "subterms (call(pn)) = {call(pn)}"

lemma subterms_refl [simp]: "p \<in> subterms p"
  by (cases p) simp_all

lemma subterms_trans [elim]:
  assumes "q \<in> subterms p"
      and "r \<in> subterms q"
    shows "r \<in> subterms p"
  using assms by (induction p) auto

lemma root_in_subterms [simp]:
   "\<And>\<Gamma> pn. \<exists>pn'. \<Gamma> pn \<in> subterms (\<Gamma> pn')"
  by (rule_tac x=pn in exI) simp

lemma deriv_in_subterms [elim, dest]:
  "\<And>l f p q. {l}\<langle>f\<rangle> q \<in> subterms p \<Longrightarrow> q \<in> subterms p"
  "\<And>l fa p q. {l}\<lbrakk>fa\<rbrakk> q \<in> subterms p \<Longrightarrow> q \<in> subterms p"
  "\<And>p1 p2 p. p1 \<oplus> p2 \<in> subterms p \<Longrightarrow> p1 \<in> subterms p"
  "\<And>p1 p2 p. p1 \<oplus> p2 \<in> subterms p \<Longrightarrow> p2 \<in> subterms p"
  "\<And>l fip fmsg p q r. {l}unicast(fip, fmsg). q \<triangleright> r \<in> subterms p \<Longrightarrow> q \<in> subterms p"
  "\<And>l fip fmsg p q r. {l}unicast(fip, fmsg). q \<triangleright> r \<in> subterms p \<Longrightarrow> r \<in> subterms p"
  "\<And>l fmsg p q. {l}broadcast(fmsg). q \<in> subterms p \<Longrightarrow> q \<in> subterms p"
  "\<And>l fips fmsg p q. {l}groupcast(fips, fmsg). q \<in> subterms p \<Longrightarrow> q \<in> subterms p"
  "\<And>l fmsg p q. {l}send(fmsg). q \<in> subterms p \<Longrightarrow> q \<in> subterms p"
  "\<And>l fdata p q. {l}deliver(fdata). q \<in> subterms p \<Longrightarrow> q \<in> subterms p"
  "\<And>l fmsg p q. {l}receive(fmsg). q \<in> subterms p \<Longrightarrow> q \<in> subterms p"
  by auto

subsection "Actions"

text \<open>
  There are two sorts of @{text \<tau>} actions in AWN: one at the level of individual processes
  (within nodes), and one at the network level (outside nodes). We define a class so that
  we can ignore this distinction whenever it is not critical.
\<close>

class tau =
  fixes tau :: "'a" ("\<tau>")

subsubsection "Sequential Actions (and related predicates)"

datatype 'm seq_action =
    broadcast 'm
  | groupcast "ip set" 'm
  | unicast ip 'm
  | notunicast ip           ("\<not>unicast _" [1000] 60)
  | send 'm
  | deliver data
  | receive 'm
  | seq_tau                 ("\<tau>\<^sub>s")

instantiation "seq_action" :: (type) tau
begin
definition step_seq_tau [simp]: "\<tau> \<equiv> \<tau>\<^sub>s"
instance ..
end

definition recvmsg :: "('m \<Rightarrow> bool) \<Rightarrow> 'm seq_action \<Rightarrow> bool"
where "recvmsg P a \<equiv> case a of receive m \<Rightarrow> P m
                             | _ \<Rightarrow> True"

lemma recvmsg_simps[simp]:
  "\<And>m.     recvmsg P (broadcast m)     = True"
  "\<And>ips m. recvmsg P (groupcast ips m) = True"
  "\<And>ip m.  recvmsg P (unicast ip m)    = True"
  "\<And>ip.    recvmsg P (notunicast ip)   = True"
  "\<And>m.     recvmsg P (send m)          = True"
  "\<And>d.     recvmsg P (deliver d)       = True"
  "\<And>m.     recvmsg P (receive m)       = P m"
  "        recvmsg P \<tau>\<^sub>s                 = True"
  unfolding recvmsg_def by simp_all

lemma recvmsgTT [simp]: "recvmsg TT a"
  by (cases a) simp_all

lemma recvmsgE [elim]:
  assumes "recvmsg (R \<sigma>) a"
      and "\<And>m. R \<sigma> m \<Longrightarrow> R \<sigma>' m"
    shows "recvmsg (R \<sigma>') a"
  using assms(1) by (cases a) (auto elim!: assms(2))

definition anycast :: "('m \<Rightarrow> bool) \<Rightarrow> 'm seq_action \<Rightarrow> bool"
where "anycast P a \<equiv> case a of broadcast m \<Rightarrow> P m
                             | groupcast _ m \<Rightarrow> P m
                             | unicast _ m \<Rightarrow> P m
                             | _ \<Rightarrow> True"

lemma anycast_simps [simp]:
  "\<And>m.     anycast P (broadcast m)     = P m"
  "\<And>ips m. anycast P (groupcast ips m) = P m"
  "\<And>ip m.  anycast P (unicast ip m)    = P m"
  "\<And>ip.    anycast P (notunicast ip)   = True"
  "\<And>m.     anycast P (send m)          = True"
  "\<And>d.     anycast P (deliver d)       = True"
  "\<And>m.     anycast P (receive m)       = True"
  "        anycast P \<tau>\<^sub>s                 = True"
  unfolding anycast_def by simp_all

definition orecvmsg :: "((ip \<Rightarrow> 's) \<Rightarrow> 'm \<Rightarrow> bool) \<Rightarrow> (ip \<Rightarrow> 's) \<Rightarrow> 'm seq_action \<Rightarrow> bool"
where "orecvmsg P \<sigma> a \<equiv> (case a of receive m \<Rightarrow> P \<sigma> m
                                         | _ \<Rightarrow> True)"

lemma orecvmsg_simps [simp]:
  "\<And>m.     orecvmsg P \<sigma> (broadcast m)     = True"
  "\<And>ips m. orecvmsg P \<sigma> (groupcast ips m) = True"
  "\<And>ip m.  orecvmsg P \<sigma> (unicast ip m)    = True"
  "\<And>ip.    orecvmsg P \<sigma> (notunicast ip)   = True"
  "\<And>m.     orecvmsg P \<sigma> (send m)          = True"
  "\<And>d.     orecvmsg P \<sigma> (deliver d)       = True"
  "\<And>m.     orecvmsg P \<sigma> (receive m)       = P \<sigma> m"
  "         orecvmsg P \<sigma> \<tau>\<^sub>s                = True"
  unfolding orecvmsg_def by simp_all

lemma orecvmsgEI [elim]:
  "\<lbrakk> orecvmsg P \<sigma> a; \<And>\<sigma> a. P \<sigma> a \<Longrightarrow> Q \<sigma> a \<rbrakk> \<Longrightarrow> orecvmsg Q \<sigma> a"
  by (cases a) simp_all

lemma orecvmsg_stateless_recvmsg [elim]:
  "orecvmsg (\<lambda>_. P) \<sigma> a \<Longrightarrow> recvmsg P a"
  by (cases a) simp_all

lemma orecvmsg_recv_weaken [elim]:
  "\<lbrakk> orecvmsg P \<sigma> a; \<And>\<sigma> a. P \<sigma> a \<Longrightarrow> Q a \<rbrakk> \<Longrightarrow> recvmsg Q a"
  by (cases a) simp_all

lemma orecvmsg_recvmsg [elim]:
  "orecvmsg P \<sigma> a \<Longrightarrow> recvmsg (P \<sigma>) a"
  by (cases a) simp_all

definition sendmsg :: "('m \<Rightarrow> bool) \<Rightarrow> 'm seq_action \<Rightarrow> bool"
where "sendmsg P a \<equiv> case a of send m \<Rightarrow> P m | _ \<Rightarrow> True"

lemma sendmsg_simps [simp]:
  "\<And>m.     sendmsg P (broadcast m)     = True"
  "\<And>ips m. sendmsg P (groupcast ips m) = True"
  "\<And>ip m.  sendmsg P (unicast ip m)    = True"
  "\<And>ip.    sendmsg P (notunicast ip)   = True"
  "\<And>m.     sendmsg P (send m)          = P m"
  "\<And>d.     sendmsg P (deliver d)       = True"
  "\<And>m.     sendmsg P (receive m)       = True"
  "        sendmsg P \<tau>\<^sub>s                 = True"
  unfolding sendmsg_def by simp_all

type_synonym ('s, 'm, 'p, 'l) seqp_env = "'p \<Rightarrow> ('s, 'm, 'p, 'l) seqp"

subsubsection "Node Actions (and related predicates)"

datatype 'm node_action =
    node_cast "ip set" 'm             ("_:*cast'(_')"       [200, 200] 200)
  | node_deliver ip data              ("_:deliver'(_')"     [200, 200] 200)
  | node_arrive "ip set" "ip set" 'm  ("_\<not>_:arrive'(_')"    [200, 200, 200] 200)
  | node_connect ip ip                ("connect'(_, _')"    [200, 200] 200)
  | node_disconnect ip ip             ("disconnect'(_, _')" [200, 200] 200)
  | node_newpkt ip data ip            ("_:newpkt'(_, _')"   [200, 200, 200] 200)
  | node_tau                          ("\<tau>\<^sub>n")

instantiation "node_action" :: (type) tau
begin
definition step_node_tau [simp]: "\<tau> \<equiv> \<tau>\<^sub>n"
instance ..
end

definition arrivemsg :: "ip \<Rightarrow> ('m \<Rightarrow> bool) \<Rightarrow> 'm node_action \<Rightarrow> bool"
where "arrivemsg i P a \<equiv> case a of node_arrive ii ni m \<Rightarrow> ((ii = {i} \<longrightarrow> P m))
                                  | _ \<Rightarrow> True"

lemma arrivemsg_simps[simp]:
  "\<And>R m.       arrivemsg i P (R:*cast(m))         = True"
  "\<And>d m.       arrivemsg i P (d:deliver(m))       = True"
  "\<And>i ii ni m. arrivemsg i P (ii\<not>ni:arrive(m))    = (ii = {i} \<longrightarrow> P m)"
  "\<And>i1 i2.     arrivemsg i P (connect(i1, i2))    = True"
  "\<And>i1 i2.     arrivemsg i P (disconnect(i1, i2)) = True"
  "\<And>i i' d di. arrivemsg i P (i':newpkt(d, di))   = True"
  "             arrivemsg i P \<tau>\<^sub>n                   = True"
  unfolding arrivemsg_def by simp_all

lemma arrivemsgTT [simp]: "arrivemsg i TT = TT"
  by (rule ext) (clarsimp simp: arrivemsg_def split: node_action.split)

definition oarrivemsg :: "((ip \<Rightarrow> 's) \<Rightarrow> 'm \<Rightarrow> bool) \<Rightarrow> (ip \<Rightarrow> 's) \<Rightarrow> 'm node_action \<Rightarrow> bool"
where "oarrivemsg P \<sigma> a \<equiv> case a of node_arrive ii ni m \<Rightarrow> P \<sigma> m | _ \<Rightarrow> True"

lemma oarrivemsg_simps[simp]:
  "\<And>R m.       oarrivemsg P \<sigma> (R:*cast(m))         = True"
  "\<And>d m.       oarrivemsg P \<sigma> (d:deliver(m))       = True"
  "\<And>i ii ni m. oarrivemsg P \<sigma> (ii\<not>ni:arrive(m))    = P \<sigma> m"
  "\<And>i1 i2.     oarrivemsg P \<sigma> (connect(i1, i2))    = True"
  "\<And>i1 i2.     oarrivemsg P \<sigma> (disconnect(i1, i2)) = True"
  "\<And>i i' d di. oarrivemsg P \<sigma> (i':newpkt(d, di))   = True"
  "             oarrivemsg P \<sigma> \<tau>\<^sub>n                   = True"
  unfolding oarrivemsg_def by simp_all

lemma oarrivemsg_True [simp, intro]: "oarrivemsg (\<lambda>_ _. True) \<sigma> a"
  by (cases a) auto

definition castmsg :: "('m \<Rightarrow> bool) \<Rightarrow> 'm node_action \<Rightarrow> bool"
where "castmsg P a \<equiv> case a of _:*cast(m) \<Rightarrow> P m
                              | _ \<Rightarrow> True"

lemma castmsg_simps[simp]:
  "\<And>R m.       castmsg P (R:*cast(m))         = P m"
  "\<And>d m.       castmsg P (d:deliver(m))       = True"
  "\<And>i ii ni m. castmsg P (ii\<not>ni:arrive(m))    = True"
  "\<And>i1 i2.     castmsg P (connect(i1, i2))    = True"
  "\<And>i1 i2.     castmsg P (disconnect(i1, i2)) = True"
  "\<And>i i' d di. castmsg P (i':newpkt(d, di))   = True"
  "             castmsg P \<tau>\<^sub>n                   = True"
  unfolding castmsg_def by simp_all

subsection "Networks"

datatype net_tree =
    Node ip "ip set"          ("\<langle>_; _\<rangle>")
  | Subnet net_tree net_tree  (infixl "\<parallel>" 90)

declare net_tree.induct [[induct del]]
lemmas net_tree_induct [induct type: net_tree] = net_tree.induct [rename_abs i R p1 p2]

datatype 's net_state =
    NodeS ip 's "ip set"
  | SubnetS "'s net_state" "'s net_state"

fun net_ips :: "'s net_state \<Rightarrow> ip set"
where
    "net_ips (NodeS i s R) = {i}"
  | "net_ips (SubnetS n1 n2) = net_ips n1 \<union> net_ips n2"

fun net_tree_ips :: "net_tree \<Rightarrow> ip set"
where
    "net_tree_ips (p1 \<parallel> p2) = net_tree_ips p1 \<union> net_tree_ips p2"
  | "net_tree_ips (\<langle>i; R\<rangle>) = {i}"

lemma net_tree_ips_commute:
  "net_tree_ips (p1 \<parallel> p2) = net_tree_ips (p2 \<parallel> p1)"
  by simp (rule Un_commute)

fun wf_net_tree :: "net_tree \<Rightarrow> bool"
where
   "wf_net_tree (p1 \<parallel> p2) = (net_tree_ips p1 \<inter> net_tree_ips p2 = {}
                             \<and> wf_net_tree p1 \<and> wf_net_tree p2)"
 | "wf_net_tree (\<langle>i; R\<rangle>) = True"

lemma wf_net_tree_children [elim]:
  assumes "wf_net_tree (p1 \<parallel> p2)"
  obtains "wf_net_tree p1"
      and "wf_net_tree p2"
  using assms by simp

fun netmap :: "'s net_state \<Rightarrow> ip \<Rightarrow> 's option"
where
    "netmap (NodeS i p R\<^sub>i) = [i \<mapsto> p]"
  | "netmap (SubnetS s t) = netmap s ++ netmap t"

lemma not_in_netmap [simp]:
  assumes "i \<notin> net_ips ns"
    shows "netmap ns i = None"
  using assms by (induction ns) simp_all

lemma netmap_none_not_in_net_ips:
  assumes "netmap ns i = None"
    shows "i\<notin>net_ips ns"
  using assms by (induction ns) auto

lemma net_ips_is_dom_netmap: "net_ips s = dom(netmap s)"
  proof (induction s)
    fix i R\<^sub>i and p :: 's
    show "net_ips (NodeS i p R\<^sub>i) = dom (netmap (NodeS i p R\<^sub>i))"
      by auto
  next
    fix s1 s2 :: "'s net_state"
    assume "net_ips s1 = dom (netmap s1)"
       and "net_ips s2 = dom (netmap s2)"
    thus "net_ips (SubnetS s1 s2) = dom (netmap (SubnetS s1 s2))"
      by auto
  qed

lemma in_netmap [simp]:
  assumes "i \<in> net_ips ns"
    shows "netmap ns i \<noteq> None"
  using assms by (auto simp add: net_ips_is_dom_netmap)

lemma netmap_subnets_same:
  assumes "netmap s1 i = x"
      and "netmap s2 i = x"
    shows "netmap (SubnetS s1 s2) i = x"
  using assms by simp (metis map_add_dom_app_simps(1) map_add_dom_app_simps(3))

lemma netmap_subnets_samef:
  assumes "netmap s1 = f"
      and "netmap s2 = f"
    shows "netmap (SubnetS s1 s2) = f"
  using assms by simp (metis map_add_le_mapI map_le_antisym map_le_map_add map_le_refl)

lemma netmap_add_disjoint [elim]:
  assumes "\<forall>i\<in>net_ips s1 \<union> net_ips s2. the ((netmap s1 ++ netmap s2) i) = \<sigma> i"
      and "net_ips s1 \<inter> net_ips s2 = {}"
    shows "\<forall>i\<in>net_ips s1. the (netmap s1 i) = \<sigma> i"
  proof
    fix i
    assume "i \<in> net_ips s1"
    hence "i \<in> dom(netmap s1)" by (simp add: net_ips_is_dom_netmap)
    moreover with assms(2) have "i \<notin> dom(netmap s2)" by (auto simp add: net_ips_is_dom_netmap)
    ultimately have "the (netmap s1 i) = the ((netmap s1 ++ netmap s2) i)"
      by (simp add: map_add_dom_app_simps)
    with assms(1) and \<open>i\<in>net_ips s1\<close> show "the (netmap s1 i) = \<sigma> i" by simp
  qed

lemma netmap_add_disjoint2 [elim]:
  assumes "\<forall>i\<in>net_ips s1 \<union> net_ips s2. the ((netmap s1 ++ netmap s2) i) = \<sigma> i"
    shows "\<forall>i\<in>net_ips s2. the (netmap s2 i) = \<sigma> i"
  using assms by (simp add: net_ips_is_dom_netmap)
                 (metis Un_iff map_add_dom_app_simps(1))

lemma net_ips_netmap_subnet [elim]:
  assumes "net_ips s1 \<inter> net_ips s2 = {}"
      and "\<forall>i\<in>net_ips (SubnetS s1 s2). the (netmap (SubnetS s1 s2) i) = \<sigma> i"
    shows "\<forall>i\<in>net_ips s1. the (netmap s1 i) = \<sigma> i"
      and "\<forall>i\<in>net_ips s2. the (netmap s2 i) = \<sigma> i"
  proof -
    from assms(2) have "\<forall>i\<in>net_ips s1 \<union> net_ips s2. the ((netmap s1 ++ netmap s2) i) = \<sigma> i" by auto
    with assms(1) show "\<forall>i\<in>net_ips s1. the (netmap s1 i) = \<sigma> i"
      by - (erule(1) netmap_add_disjoint)
  next
    from assms(2) have "\<forall>i\<in>net_ips s1 \<union> net_ips s2. the ((netmap s1 ++ netmap s2) i) = \<sigma> i" by auto
    thus "\<forall>i\<in>net_ips s2. the (netmap s2 i) = \<sigma> i"
      by - (erule netmap_add_disjoint2)
  qed

fun inoclosed :: "'s \<Rightarrow> 'm::msg node_action \<Rightarrow> bool"
where
    "inoclosed _ (node_arrive ii ni m) = eq_newpkt m"
  | "inoclosed _ (node_newpkt i d di)  = False"
  | "inoclosed _ _ = True"

lemma inclosed_simps [simp]:
  "\<And>\<sigma> ii ni. inoclosed \<sigma> (ii\<not>ni:arrive(m))   = eq_newpkt m"
  "\<And>\<sigma> d di.  inoclosed \<sigma> (i:newpkt(d, di))   = False"
  "\<And>\<sigma> R m.   inoclosed \<sigma> (R:*cast(m))        = True"
  "\<And>\<sigma> i d.   inoclosed \<sigma> (i:deliver(d))      = True"
  "\<And>\<sigma> i i'.  inoclosed \<sigma> (connect(i, i'))    = True"
  "\<And>\<sigma> i i'.  inoclosed \<sigma> (disconnect(i, i')) = True"
  "\<And>\<sigma>.       inoclosed \<sigma> (\<tau>)                 = True"
  by auto

definition
  netmask :: "ip set \<Rightarrow> ((ip \<Rightarrow> 's) \<times> 'l) \<Rightarrow> ((ip \<Rightarrow> 's option) \<times> 'l)"
where
  "netmask I s \<equiv> (\<lambda>i. if i\<in>I then Some (fst s i) else None, snd s)"

lemma netmask_def' [simp]:
  "netmask I (\<sigma>, \<zeta>) = (\<lambda>i. if i\<in>I then Some (\<sigma> i) else None, \<zeta>)"
  unfolding netmask_def by auto

fun netgmap :: "('s \<Rightarrow> 'g \<times> 'l) \<Rightarrow> 's net_state \<Rightarrow> (nat \<Rightarrow> 'g option) \<times> 'l net_state"
  where
    "netgmap sr (NodeS i s R) = ([i \<mapsto> fst (sr s)], NodeS i (snd (sr s)) R)"
  | "netgmap sr (SubnetS s\<^sub>1 s\<^sub>2) = (let (\<sigma>\<^sub>1, ss) = netgmap sr s\<^sub>1 in
                                   let (\<sigma>\<^sub>2, tt) = netgmap sr s\<^sub>2 in
                                   (\<sigma>\<^sub>1 ++ \<sigma>\<^sub>2, SubnetS ss tt))"

lemma dom_fst_netgmap [simp, intro]: "dom (fst (netgmap sr n)) = net_ips n"
  using assms proof (induction n)
    fix i s R
    show "dom (fst (netgmap sr (NodeS i s R))) = net_ips (NodeS i s R)"
      by simp
  next
    fix n1 n2
    assume a1: "dom (fst (netgmap sr n1)) = net_ips n1"
       and a2: "dom (fst (netgmap sr n2)) = net_ips n2"
    obtain \<sigma>\<^sub>1 \<zeta>\<^sub>1 \<sigma>\<^sub>2 \<zeta>\<^sub>2 where nm1: "netgmap sr n1 = (\<sigma>\<^sub>1, \<zeta>\<^sub>1)"
                        and nm2: "netgmap sr n2 = (\<sigma>\<^sub>2, \<zeta>\<^sub>2)"
      by (metis surj_pair)
    hence "netgmap sr (SubnetS n1 n2) = (\<sigma>\<^sub>1 ++ \<sigma>\<^sub>2, SubnetS \<zeta>\<^sub>1 \<zeta>\<^sub>2)" by simp
    hence "dom (fst (netgmap sr (SubnetS n1 n2))) = dom (\<sigma>\<^sub>1 ++ \<sigma>\<^sub>2)" by simp
    also from a1 a2 nm1 nm2 have "dom (\<sigma>\<^sub>1 ++ \<sigma>\<^sub>2) = net_ips (SubnetS n1 n2)" by auto
    finally show "dom (fst (netgmap sr (SubnetS n1 n2))) = net_ips (SubnetS n1 n2)" .
  qed

lemma netgmap_pair_dom [elim]:
  obtains \<sigma> \<zeta> where "netgmap sr n = (\<sigma>, \<zeta>)"
                and "dom \<sigma> = net_ips n"
    by (metis dom_fst_netgmap surjective_pairing)

lemma net_ips_netgmap [simp]:
  "net_ips (snd (netgmap sr s)) = net_ips s"
  proof (induction s)
    fix s1 s2
    assume "net_ips (snd (netgmap sr s1)) = net_ips s1"
       and "net_ips (snd (netgmap sr s2)) = net_ips s2"
    thus "net_ips (snd (netgmap sr (SubnetS s1 s2))) = net_ips (SubnetS s1 s2)"
      by (cases "netgmap sr s1", cases "netgmap sr s2") auto
  qed simp

lemma some_the_fst_netgmap:
  assumes "i \<in> net_ips s"
    shows "Some (the (fst (netgmap sr s) i)) = fst (netgmap sr s) i"
  using assms by (metis domIff dom_fst_netgmap option.collapse)

lemma fst_netgmap_none [simp]:
  assumes "i \<notin> net_ips s"
    shows "fst (netgmap sr s) i = None"
  using assms by (metis domIff dom_fst_netgmap)

lemma fst_netgmap_subnet [simp]:
  "fst (case netgmap sr s1 of (\<sigma>\<^sub>1, ss) \<Rightarrow>
        case netgmap sr s2 of (\<sigma>\<^sub>2, tt) \<Rightarrow>
        (\<sigma>\<^sub>1 ++ \<sigma>\<^sub>2, SubnetS ss tt)) = (fst (netgmap sr s1) ++ fst (netgmap sr s2))"
  by (metis (mono_tags) fst_conv netgmap_pair_dom split_conv)

lemma snd_netgmap_subnet [simp]:
  "snd (case netgmap sr s1 of (\<sigma>\<^sub>1, ss) \<Rightarrow>
        case netgmap sr s2 of (\<sigma>\<^sub>2, tt) \<Rightarrow>
        (\<sigma>\<^sub>1 ++ \<sigma>\<^sub>2, SubnetS ss tt)) = (SubnetS (snd (netgmap sr s1)) (snd (netgmap sr s2)))"
  by (metis (lifting, no_types) Pair_inject split_beta' surjective_pairing)

lemma fst_netgmap_not_none [simp]:
  assumes "i \<in> net_ips s"
    shows "fst (netgmap sr s) i \<noteq> None"
  using assms by (induction s) auto

lemma netgmap_netgmap_not_rhs [simp]:
  assumes "i \<notin> net_ips s2"
    shows "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i = (fst (netgmap sr s1)) i"
  proof -
    from assms(1) have "i \<notin> dom (fst (netgmap sr s2))" by simp
    thus ?thesis by (simp add: map_add_dom_app_simps)
  qed

lemma netgmap_netgmap_rhs [simp]:
  assumes "i \<in> net_ips s2"
    shows "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i = (fst (netgmap sr s2)) i"
  using assms by (simp add: map_add_dom_app_simps)

lemma netgmap_netmask_subnets [elim]:
  assumes "netgmap sr s1 = netmask (net_tree_ips n1) (\<sigma>, snd (netgmap sr s1))"
      and "netgmap sr s2 = netmask (net_tree_ips n2) (\<sigma>, snd (netgmap sr s2))"
    shows "fst (netgmap sr (SubnetS s1 s2))
            = fst (netmask (net_tree_ips (n1 \<parallel> n2)) (\<sigma>, snd (netgmap sr (SubnetS s1 s2))))"
  proof (rule ext)
    fix i
    have "i \<in> net_tree_ips n1 \<or> i \<in> net_tree_ips n2 \<or> (i\<notin>net_tree_ips n1 \<union> net_tree_ips n2)"
      by auto
    thus "fst (netgmap sr (SubnetS s1 s2)) i
            = fst (netmask (net_tree_ips (n1 \<parallel> n2)) (\<sigma>, snd (netgmap sr (SubnetS s1 s2)))) i"
    proof (elim disjE)
      assume "i \<in> net_tree_ips n1"
      with \<open>netgmap sr s1 = netmask (net_tree_ips n1) (\<sigma>, snd (netgmap sr s1))\<close>
           \<open>netgmap sr s2 = netmask (net_tree_ips n2) (\<sigma>, snd (netgmap sr s2))\<close>
        show ?thesis
          by (cases "netgmap sr s1", cases "netgmap sr s2", clarsimp)
             (metis (lifting, mono_tags) map_add_Some_iff)
    next
      assume "i \<in> net_tree_ips n2"
      with \<open>netgmap sr s2 = netmask (net_tree_ips n2) (\<sigma>, snd (netgmap sr s2))\<close>
        show ?thesis
          by simp (metis (lifting, mono_tags) fst_conv map_add_find_right)
    next
      assume "i\<notin>net_tree_ips n1 \<union> net_tree_ips n2"
      with \<open>netgmap sr s1 = netmask (net_tree_ips n1) (\<sigma>, snd (netgmap sr s1))\<close>
           \<open>netgmap sr s2 = netmask (net_tree_ips n2) (\<sigma>, snd (netgmap sr s2))\<close>
        show ?thesis
          by simp (metis (lifting, mono_tags) fst_conv)
    qed
  qed

lemma netgmap_netmask_subnets' [elim]:
  assumes "netgmap sr s1 = netmask (net_tree_ips n1) (\<sigma>, snd (netgmap sr s1))"
      and "netgmap sr s2 = netmask (net_tree_ips n2) (\<sigma>, snd (netgmap sr s2))"
      and "s = SubnetS s1 s2"
    shows "netgmap sr s = netmask (net_tree_ips (n1 \<parallel> n2)) (\<sigma>, snd (netgmap sr s))"
  by (simp only: assms(3))
     (rule prod_eqI [OF netgmap_netmask_subnets [OF assms(1-2)]], simp)

lemma netgmap_subnet_split1:
  assumes "netgmap sr (SubnetS s1 s2) = netmask (net_tree_ips (n1 \<parallel> n2)) (\<sigma>, \<zeta>)"
      and "net_tree_ips n1 \<inter> net_tree_ips n2 = {}"
      and "net_ips s1 = net_tree_ips n1"
      and "net_ips s2 = net_tree_ips n2"
    shows "netgmap sr s1 = netmask (net_tree_ips n1) (\<sigma>, snd (netgmap sr s1))"
  proof (rule prod_eqI)
    show "fst (netgmap sr s1) = fst (netmask (net_tree_ips n1) (\<sigma>, snd (netgmap sr s1)))"
    proof (rule ext, simp, intro conjI impI)
      fix i
      assume "i\<in>net_tree_ips n1"
      with \<open>net_tree_ips n1 \<inter> net_tree_ips n2 = {}\<close> have "i\<notin>net_tree_ips n2"
        by auto
      from assms(1) [simplified prod_eq_iff]
        have "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i =
                 (if i \<in> net_tree_ips n1 \<or> i \<in> net_tree_ips n2 then Some (\<sigma> i) else None)"
          by simp
      also from \<open>i\<notin>net_tree_ips n2\<close> and \<open>net_ips s2 = net_tree_ips n2\<close>
        have "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i = fst (netgmap sr s1) i"
          by (metis dom_fst_netgmap map_add_dom_app_simps(3))
      finally show "fst (netgmap sr s1) i = Some (\<sigma> i)"
        using \<open>i\<in>net_tree_ips n1\<close> by simp
    next
      fix i
      assume "i \<notin> net_tree_ips n1"
      with \<open>net_ips s1 = net_tree_ips n1\<close> have "i \<notin> net_ips s1" by simp
      thus "fst (netgmap sr s1) i = None" by simp
    qed
  qed simp

lemma netgmap_subnet_split2:
  assumes "netgmap sr (SubnetS s1 s2) = netmask (net_tree_ips (n1 \<parallel> n2)) (\<sigma>, \<zeta>)"
      and "net_ips s1 = net_tree_ips n1"
      and "net_ips s2 = net_tree_ips n2"
    shows "netgmap sr s2 = netmask (net_tree_ips n2) (\<sigma>, snd (netgmap sr s2))"
  proof (rule prod_eqI)
    show "fst (netgmap sr s2) = fst (netmask (net_tree_ips n2) (\<sigma>, snd (netgmap sr s2)))"
    proof (rule ext, simp, intro conjI impI)
      fix i
      assume "i\<in>net_tree_ips n2"
      from assms(1) [simplified prod_eq_iff]
        have "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i =
                 (if i \<in> net_tree_ips n1 \<or> i \<in> net_tree_ips n2 then Some (\<sigma> i) else None)"
          by simp
      also from \<open>i\<in>net_tree_ips n2\<close> and \<open>net_ips s2 = net_tree_ips n2\<close>
        have "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i = fst (netgmap sr s2) i"
          by (metis dom_fst_netgmap map_add_dom_app_simps(1))
      finally show "fst (netgmap sr s2) i = Some (\<sigma> i)"
        using \<open>i\<in>net_tree_ips n2\<close> by simp
    next
      fix i
      assume "i \<notin> net_tree_ips n2"
      with \<open>net_ips s2 = net_tree_ips n2\<close> have "i \<notin> net_ips s2" by simp
      thus "fst (netgmap sr s2) i = None" by simp
    qed
  qed simp

lemma netmap_fst_netgmap_rel:
  shows "(\<lambda>i. map_option (fst o sr) (netmap s i)) = fst (netgmap sr s)"
  proof (induction s)
    fix ii s R
    show "(\<lambda>i. map_option (fst \<circ> sr) (netmap (NodeS ii s R) i)) = fst (netgmap sr (NodeS ii s R))"
      by auto
  next
    fix s1 s2
    assume a1: "(\<lambda>i. map_option (fst \<circ> sr) (netmap s1 i)) = fst (netgmap sr s1)"
       and a2: "(\<lambda>i. map_option (fst \<circ> sr) (netmap s2 i)) = fst (netgmap sr s2)"
    show "(\<lambda>i. map_option (fst \<circ> sr) (netmap (SubnetS s1 s2) i)) = fst (netgmap sr (SubnetS s1 s2))"
    proof (rule ext)
      fix i
      from a1 a2 have "map_option (fst \<circ> sr) ((netmap s1 ++ netmap s2) i)
                                    = (fst (netgmap sr s1) ++ fst (netgmap sr s2)) i"
        by (metis fst_conv map_add_dom_app_simps(1) map_add_dom_app_simps(3)
                  net_ips_is_dom_netmap netgmap_pair_dom)
      thus "map_option (fst \<circ> sr) (netmap (SubnetS s1 s2) i) = fst (netgmap sr (SubnetS s1 s2)) i"
        by simp
    qed
  qed

lemma netmap_is_fst_netgmap:
  assumes "netmap s' = netmap s"
    shows "fst (netgmap sr s') = fst (netgmap sr s)"
  using assms by (metis netmap_fst_netgmap_rel)

lemma netmap_is_fst_netgmap':
  assumes "netmap s' i = netmap s i"
    shows "fst (netgmap sr s') i = fst (netgmap sr s) i"
  using assms by (metis netmap_fst_netgmap_rel)

lemma fst_netgmap_pair_fst [simp]:
  "fst (netgmap (\<lambda>(p, q). (fst p, snd p, q)) s) = fst (netgmap fst s)"
  by (induction s) auto

text \<open>Introduce streamlined alternatives to netgmap to simplify certain property
        statements and thus make them easier to understand and to present.\<close>

fun netlift :: "('s \<Rightarrow> 'g \<times> 'l) \<Rightarrow> 's net_state \<Rightarrow> (nat \<Rightarrow> 'g option)"
  where
    "netlift sr (NodeS i s R) = [i \<mapsto> fst (sr s)]"
  | "netlift sr (SubnetS s t) = (netlift sr s) ++ (netlift sr t)"

lemma fst_netgmap_netlift:
  "fst (netgmap sr s) = netlift sr s"
  by (induction s) simp_all

fun netliftl :: "('s \<Rightarrow> 'g \<times> 'l) \<Rightarrow> 's net_state \<Rightarrow> 'l net_state"
  where
    "netliftl sr (NodeS i s R) = NodeS i (snd (sr s)) R"
  | "netliftl sr (SubnetS s t) = SubnetS (netliftl sr s) (netliftl sr t)"

lemma snd_netgmap_netliftl:
  "snd (netgmap sr s) = netliftl sr s"
  by (induction s) simp_all

lemma netgmap_netlift_netliftl: "netgmap sr s = (netlift sr s, netliftl sr s)"
  by rule (simp_all add: fst_netgmap_netlift snd_netgmap_netliftl)

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2005         |
            |               Februaru 2006               |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory FNF_F_sf_hide
imports FNF_F_sf_induct FNF_F_sf_ext
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  disj_not1: (~ P | Q) = (P --> Q)                   *)

declare disj_not1 [simp del]

(*  The following simplification rules are deleted in this theory file *)
(*       P (if Q then x else y) = ((Q --> P x) & (~ Q --> P y))        *)
(* Isabelle 2017: split_if --> if_split *)

declare if_split  [split del]

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

         1. full sequentialization for Hiding (P -- X)
         2.
         3.

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

(*============================================================*
 |                                                            |
 |                     Hiding P -- X                          |
 |                                                            |
 *============================================================*)

definition
  Pfun_Hiding :: "'a set => (('p,'a) proc => ('p,'a) proc)"
  where
  Pfun_Hiding_def :
    "Pfun_Hiding X == (%P1. P1 -- X)"

definition
  SP_step_Hiding ::
   "'a set => ('a set => ('a => ('p,'a) proc) => ('p,'a) proc =>
    ('a => ('p,'a) proc) => ('p,'a) proc)"
  where
  SP_step_Hiding_def :
    "SP_step_Hiding X == (%A1 Pf1 Q1 SPf.
     (if (Q1 = STOP)
      then if (A1 Int X = {})
           then ((? :A1 -> SPf) [+] Q1)
           else (((? :(A1-X) -> SPf) [+] Q1)
                 [>seq
                (! :(A1 Int X) ..seq SPf))
      else (((? :(A1-X) -> SPf) [+] Q1) |~|seq
            (! :(A1 Int X) ..seq SPf))))"

definition
  fsfF_Hiding :: "('p,'a) proc => 'a set => ('p,'a) proc"
                          ("(1_ /--seq _)" [84,85] 84)
  where
  fsfF_Hiding_def :
    "P1 --seq X ==
       (fsfF_induct1 (Pfun_Hiding X) (SP_step_Hiding X) P1)"

(*------------------------------------------------------------*
 |                        in fsfF_proc                        |
 *------------------------------------------------------------*)

lemma fsfF_Hiding_in:
    "P1 : fsfF_proc ==> P1 --seq X : fsfF_proc"
apply (simp add: fsfF_Hiding_def)
apply (rule fsfF_induct1_in)
apply (simp_all add: SP_step_Hiding_def)
apply (simp split: if_split)
apply (intro conjI impI)
apply (simp_all add: fsfF_proc.intros)
apply (rule fsfF_Int_choice_in)
apply (simp_all add: fsfF_proc.intros)
apply (simp add: fsfF_Rep_int_choice_com_in)
apply (rule fsfF_Timeout_in)
apply (simp_all add: fsfF_proc.intros)
apply (simp add: fsfF_Rep_int_choice_com_in)
apply (rule fsfF_Int_choice_in)
apply (simp add: fsfF_proc.intros)
apply (simp add: fsfF_Rep_int_choice_com_in)
done

(*------------------------------------------------------------*
 |             syntactical transformation to fsfF             |
 *------------------------------------------------------------*)

lemma cspF_fsfF_Hiding_eqF: "P1 -- X =F P1 --seq X"
apply (simp add: fsfF_Hiding_def)
apply (rule cspF_rw_right)
apply (rule cspF_fsfF_induct1_eqF[THEN cspF_sym])
apply (simp_all add: Pfun_Hiding_def
                     SP_step_Hiding_def)

apply (case_tac "Q1 = STOP")
apply (rule cspF_rw_left)
apply (rule cspF_decompo)
apply (simp)
apply (simp)
apply (rule cspF_unit)

apply (rule cspF_rw_left)
apply (rule cspF_step)
apply (simp)

apply (simp split: if_split)
apply (intro conjI impI)
apply (rule cspF_rw_left)
apply (rule cspF_IF)
apply (rule cspF_rw_right)
apply (rule cspF_unit)
apply (rule cspF_reflex)

apply (rule cspF_rw_left)
apply (rule cspF_IF)
apply (rule cspF_rw_right)
apply (rule cspF_fsfF_Timeout_eqF[THEN cspF_sym])
apply (rule cspF_decompo)
apply (rule cspF_decompo)
apply (rule cspF_rw_right)
apply (rule cspF_unit)
apply (simp)
apply (simp)

apply (rule cspF_rw_right)
apply (rule cspF_fsfF_Rep_int_choice_com_eqF[THEN cspF_sym])
apply (simp)

(* Q1 ~= STOP *)
apply (simp)

apply (rule cspF_rw_left)
apply (rule cspF_SKIP_or_DIV)
apply (simp)

apply (rule cspF_rw_right)
apply (rule cspF_fsfF_Int_choice_eqF[THEN cspF_sym])
apply (rule cspF_decompo)
apply (rule cspF_reflex)

apply (rule cspF_rw_right)
apply (rule cspF_fsfF_Rep_int_choice_com_eqF[THEN cspF_sym])
apply (rule cspF_reflex)

(* congruence *)
apply (simp split: if_split)
apply (intro conjI impI)
apply (rule cspF_rw_left,
     (simp
     | rule cspF_fsfF_Int_choice_eqF[THEN cspF_sym]
     | rule cspF_fsfF_Rep_int_choice_eqF[THEN cspF_sym]
     | rule cspF_fsfF_Rep_int_choice_com_eqF[THEN cspF_sym]
     | rule cspF_fsfF_Timeout_eqF[THEN cspF_sym]
     | rule cspF_decompo
     | rule cspF_reflex)+ ,
       rule cspF_rw_right,
     (simp
     | rule cspF_fsfF_Int_choice_eqF[THEN cspF_sym]
     | rule cspF_fsfF_Rep_int_choice_eqF[THEN cspF_sym]
     | rule cspF_fsfF_Rep_int_choice_com_eqF[THEN cspF_sym]
     | rule cspF_fsfF_Timeout_eqF[THEN cspF_sym]
     | rule cspF_decompo
     | rule cspF_reflex)+)+
done

(****************** to add them again ******************)

declare if_split    [split]
declare disj_not1   [simp]

end


theory SM_Datastructures
imports Main
  CAVA_Base.CAVA_Base
  "../Lib/SOS_Misc_Add"
  DFS_Framework.Feedback_Arcs (* TODO: Only for oo-symbol !?*)

begin

  lemma [code_unfold]: "{(a,b). (a,b)\<in>X \<and> P a b} = Set.filter (\<lambda>(a,b). P a b) X"
    by auto

  lemma in_dom_map_code[code_unfold]:
    "x\<in>dom m = (case m x of None \<Rightarrow> False | _ \<Rightarrow> True)"
    by (auto split: option.splits)

  (* TODO: Move to gen_set. Generic algorithm for set_of_list *)
  lemma set_by_fold: "set l = fold insert l {}"
  proof -
    {
      fix s
      have "fold insert l s = s \<union> set l"
        by (induction l arbitrary: s) auto
    } from this[of "{}"] show ?thesis by simp
  qed

  context
  begin

    interpretation autoref_syn .

    lemma [autoref_itype]: "set ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set" by simp

  end

  lemma gen_set[autoref_rules_raw]:
    fixes R :: "('c\<times>'a)set" and Rs :: "('c\<times>'a) set \<Rightarrow> (_\<times>'a set) set"
    assumes [simplified,param]:
      "GEN_OP em {} (\<langle>R\<rangle>Rs)"
      "GEN_OP ins insert (R \<rightarrow> \<langle>R\<rangle>Rs \<rightarrow> \<langle>R\<rangle>Rs)"
    shows "(\<lambda>li. fold ins li em,set)\<in>\<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>Rs"
      unfolding set_by_fold[abs_def]
      by parametricity

  schematic_goal
    shows "(?c,set [1,2,3::nat])\<in>\<langle>nat_rel\<rangle>dflt_ahs_rel"
      using [[autoref_trace_failed_id]]
      by (autoref (trace, keep_goal))

  (* TODO: Possibly, we can drop the
    find_min_idx_f - stuff, and formalize our ample-set
    using the abstract LEAST, which is then implemented
    by collecti_index.
  *)

  text \<open>Find minimum index and result where function returns non-none value\<close>
  primrec find_min_idx_f :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a list \<rightharpoonup> (nat \<times> 'b)" where
    "find_min_idx_f f [] = None"
  | "find_min_idx_f f (x#xs) = (
      case f x of
        Some r \<Rightarrow> Some (0,r)
      | None \<Rightarrow> map_option (map_prod Suc id) (find_min_idx_f f xs)
    )"

  lemma find_min_idx_f_None_conv:
    "find_min_idx_f f l = None \<longleftrightarrow> (\<forall>a\<in>set l. f a = None)"
    apply (induction l)
    apply (auto split: option.splits)
    done

  lemma find_min_idx_f_SomeD:
    "find_min_idx_f f l = Some (i,r) \<Longrightarrow> f (l!i) = Some r \<and> i < length l"
    by (induction l arbitrary: i) (auto split: if_split_asm option.splits)

  lemma find_min_idx_f_SomeD_complete:
    "find_min_idx_f f l = Some (i,r)
      \<Longrightarrow> (f (l!i) = Some r \<and> i < length l \<and> (\<forall>j<i. f (l!j) = None))"
    apply (induction l arbitrary: i)
    apply (auto split: if_split_asm option.splits)
    apply (case_tac j)
    apply auto
    done

  lemma find_min_idx_f_LEAST_eq: "find_min_idx_f f l = (
    if \<exists>i<length l. f (l!i) \<noteq> None then
      let i = LEAST i. i<length l \<and> f (l!i) \<noteq> None in Some (i,the (f (l!i)))
    else
      None
  )"
  proof (cases "find_min_idx_f f l")
    case None
    show ?thesis using None by (auto simp: find_min_idx_f_None_conv)
  next
    case (Some a)
    obtain i r where 1: "a = (i, r)" by force
    have 2: "f (l ! i) = Some r" "i < length l" "\<forall> j < i. f (l ! j) = None"
      using find_min_idx_f_SomeD_complete[OF Some[unfolded 1]] by auto
    have 3: "(LEAST i. i < length l \<and> (\<exists> y. f (l ! i) = Some y)) = i"
      using 2 linorder_neqE_nat by (force intro!: Least_equality)
    show ?thesis unfolding Some 1 using 2 3 by auto
  qed

  primrec collect_indexr' :: "nat \<Rightarrow> (nat\<times>'b) set \<Rightarrow> (nat \<Rightarrow> 'a \<Rightarrow> 'b set) \<Rightarrow> 'a list \<Rightarrow> (nat\<times>'b) set" where
    "collect_indexr' i a c [] = a"
  | "collect_indexr' i a c (x#xs) = (collect_indexr' (Suc i) (a\<union>({i} \<times> c i x)) c xs)"

  abbreviation "collect_indexr \<equiv> collect_indexr' 0 {}"

  lemma collect_indexr'_collect: "collect_indexr' i0 a f l
    = a \<union> {(i0+i,x) | i x. i<length l \<and> x\<in>f (i0+i) (l!i)}"
    apply (induction l arbitrary: i0 a)
    apply simp
    apply simp
    apply auto
    apply (case_tac i, auto)
    apply (case_tac i, auto)
    done

  lemma collect_indexr_collect: "collect_indexr f l
    = {(i,x) | i x. i<length l \<and> x\<in>f i (l!i)}"
    by (simp add: collect_indexr'_collect)

  primrec collecti_index' :: "nat \<Rightarrow> (nat\<times>'b) set \<Rightarrow> (nat \<Rightarrow> 'a \<Rightarrow> (bool \<times> 'b set)) \<Rightarrow> 'a list \<Rightarrow> (nat\<times>'b) set" where
    "collecti_index' i a c [] = a"
  | "collecti_index' i a c (x#xs) = (case c i x of
      (False,s) \<Rightarrow> collecti_index' (Suc i) (a \<union> {i}\<times>s) c xs
    | (True,s) \<Rightarrow> {i}\<times>s)"

  abbreviation "collecti_index \<equiv> collecti_index' 0 {}"

  lemma collecti_index'_collect: "collecti_index' i0 a0 f l
    = (
      if \<exists>i<length l. fst (f (i0+i) (l!i)) then
        let i=LEAST i . i<length l \<and> fst (f (i0+i) (l!i)) in {i0+i} \<times> snd (f (i0+i) (l!i))
      else
        a0 \<union> {(i0+i,x) | i x. i<length l \<and> x\<in>snd (f (i0+i) (l!i))})"
  proof (cases "\<exists>i<length l. fst (f (i0+i) (l!i))")
    case False
    note False[simp]
    hence "\<forall>i<length l. \<not>fst (f (i0+i) (l!i))" by blast
    hence "collecti_index' i0 a0 f l = collect_indexr' i0 a0 (snd oo f) l"
    proof (induction l arbitrary: i0 a0)
      case (Cons x l)
      from Cons.prems have "\<not>fst (f i0 x)" by auto
      hence [simp]: "\<And>v. f i0 x \<noteq> (True,v)" by auto
      have "collecti_index' i0 a0 f (x#l) =
        collecti_index' (Suc i0) (a0 \<union> {i0} \<times> (snd (f i0 x))) f l"
        by (simp split: prod.splits bool.splits)
      also have "\<dots> = collect_indexr' (Suc i0) ((a0 \<union> {i0} \<times> (snd (f i0 x)))) (snd oo f) l"
        apply (subst Cons.IH)
        using Cons.prems
        by auto
      finally have 1: "collecti_index' i0 a0 f (x # l) =
        collect_indexr' (Suc i0) (a0 \<union> {i0} \<times> snd (f i0 x)) (snd \<circ>\<circ> f) l" .
      show ?case by (subst 1) simp
    qed simp
    also note collect_indexr'_collect
    finally show ?thesis by simp
  next
    case True
    note True[simp]
    define im where "im \<equiv> \<lambda>l (i0::nat). LEAST i . i<length l \<and> fst (f (i0+i) (l!i))"
    from LeastI_ex[OF True] have
      1: "im l i0<length l" "fst (f (i0+im l i0) (l!im l i0))"
      unfolding im_def by (auto)
    have 2: "\<forall>i<im l i0. \<not> fst (f (i0+i) (l!i))"
    proof safe
      fix i
      assume A: "i<im l i0" with 1 have "i<length l" by simp
      moreover assume "fst (f (i0+i) (l!i))"
      ultimately have "im l i0 \<le> i"
        unfolding im_def by (auto intro: Least_le)
      with A show False by simp
    qed

    from 1 2 have "collecti_index' i0 a0 f l = {i0+im l i0} \<times> snd (f (i0+im l i0) (l!im l i0))"
    proof (induction l arbitrary: i0 a0)
      case (Cons x l)
      show ?case proof (cases "fst (f i0 x)")
        case True
        hence [simp]: "\<And>y. f i0 x \<noteq> (False,y)" by auto
        note [simp] = True

        from Cons.prems(3) have [simp]: "im (x#l) i0 = 0"
          by auto

        thus ?thesis
          by (auto split: prod.splits bool.splits)
      next
        case False
        hence "im (x#l) i0 = Suc (im l (Suc i0))"
          unfolding im_def
          apply (subst Least_Suc)
          apply (rule conjI)
          apply (rule Cons.prems)+
          apply simp
          apply simp
          done
        hence ims: "im (x#l) i0 > 0" "im l (Suc i0) = im (x#l) i0 - 1"
          by simp_all

        from False have 1: "collecti_index' i0 a0 f (x # l)
          = collecti_index' (Suc i0) (a0 \<union> {i0} \<times> (snd (f i0 x))) f l"
          by (auto)

        show ?thesis
          apply (subst 1)
          apply (subst Cons.IH)
          using Cons.prems(1) ims apply (simp)
          using Cons.prems(2) ims apply simp
          using Cons.prems(3)
          apply (auto simp: ims nth_Cons less_diff_conv split: nat.splits) []
          using ims(1) apply (auto simp: ims(2))
          done
      qed
    qed simp
    thus ?thesis
      by (simp add: im_def)

  qed

  lemma collecti_index_collect: "collecti_index f l
    = (
      if \<exists>i<length l. fst (f i (l!i)) then
        let i=LEAST i . i<length l \<and> fst (f i (l!i)) in {i} \<times> snd (f i (l!i))
      else
        {(i,x) | i x. i<length l \<and> x\<in>snd (f i (l!i))})"
    using collecti_index'_collect[of 0 "{}" f l]
    by (simp cong: if_cong)

  primrec collecti_index'_list :: "nat \<Rightarrow> (nat\<times>'b) list \<Rightarrow> (nat \<Rightarrow> 'a \<Rightarrow> (bool \<times> 'b list)) \<Rightarrow> 'a list \<Rightarrow> (nat\<times>'b) list" where
    "collecti_index'_list i a c [] = a"
  | "collecti_index'_list i a c (x#xs) = (case c i x of
      (False,s) \<Rightarrow> collecti_index'_list (Suc i) (a @ map (Pair i) s) c xs
    | (True,s) \<Rightarrow> map (Pair i) s)"

  abbreviation "collecti_index_list \<equiv> collecti_index'_list 0 []"

  lemma collecti_index'_list_invar:
    assumes "\<And>i x b l. c i x = (b,l) \<Longrightarrow> distinct l"
    assumes "fst`set a \<subseteq> {0..<i0}" "distinct a"
    shows "distinct (collecti_index'_list i0 a c l)"
    using assms
    apply (induction l arbitrary: i0 a)
    apply simp
    apply (auto split: prod.splits bool.splits simp: nth_Cons' distinct_map)
    apply rprems
    apply (auto simp: distinct_map)
    done

  lemma image_Pair_eq_prod_sng[simp]: "Pair x ` s = {x}\<times>s" by auto

  lemma collecti_index'_list_\<alpha>:
    assumes "\<And>i x b l. ci i x = (b,l) \<Longrightarrow> c i x = (b,set l)"
    shows
      "set (collecti_index'_list i0 ai ci l) = collecti_index' i0 (set ai) c l"
  proof -
    from assms have A: "\<And>i x b s. c i x = (b,s) \<longleftrightarrow> (\<exists>l. ci i x = (b, l) \<and> s=set l)"
      apply auto apply (case_tac "ci i x") apply auto done

    show ?thesis
      apply (induction l arbitrary: i0 ai)
      apply simp
      apply simp
      apply (split prod.split, clarsimp)
      apply (split bool.split, clarsimp, intro allI impI conjI)
      apply (force simp add: A) []

      apply (simp split: prod.splits bool.splits add: A)
      apply safe
      apply simp_all
      apply blast
      done
  qed

  lemma collecti_index_list_refine:
    "(collecti_index_list,collecti_index)\<in>
       (nat_rel \<rightarrow> Id \<rightarrow> bool_rel \<times>\<^sub>r \<langle>Id\<rangle>list_set_rel) \<rightarrow> \<langle>Id\<rangle>list_rel
    \<rightarrow> \<langle>nat_rel\<times>\<^sub>rId\<rangle>list_set_rel"
    apply (intro fun_relI)
    apply (simp add: list_set_rel_def)
    apply (rule brI)

    apply (simp add: br_def)
    apply (rule collecti_index'_list_\<alpha>[of _ _ 0 "[]", simplified, symmetric])
    apply (drule_tac x=i and x'=i in fun_relD, simp)
    apply (drule_tac x=x and x'=x in fun_relD, simp)
    apply (auto simp: prod_rel_def) []

    apply (rule collecti_index'_list_invar)
    apply auto
    apply (drule_tac x=i and x'=i in fun_relD, simp)
    apply (drule_tac x=x and x'=x in fun_relD, simp)
    apply (auto simp: prod_rel_def br_def) []
    done

end


(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      HoareTotalDef.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

header {* Hoare Logic for Total Correctness *}

theory HoareTotalDef imports HoarePartialDef Termination begin

subsection {* Validity of Hoare Tuples: @{text  "\<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"} *}

definition
  validt :: "[('s,'p,'f) body,'f set,'s assn,('s,'p,'f) com,'s assn,'s assn] \<Rightarrow> bool"
                ("_\<Turnstile>\<^sub>t\<^bsub>'/_\<^esub>/ _ _ _,_"  [61,60,1000, 20, 1000,1000] 60)
where
 "\<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A \<equiv> \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A \<and> (\<forall>s \<in> Normal ` P. \<Gamma>\<turnstile>c\<down>s)"

definition
  cvalidt::
  "[('s,'p,'f) body,('s,'p) quadruple set,'f set,
    's assn,('s,'p,'f) com,'s assn,'s assn] \<Rightarrow> bool"
                ("_,_\<Turnstile>\<^sub>t\<^bsub>'/_\<^esub>/ _ _ _,_"  [61,60, 60,1000, 20, 1000,1000] 60)
where
 "\<Gamma>,\<Theta>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A \<equiv> (\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Call p) Q,A) \<longrightarrow> \<Gamma> \<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"

notation (ascii)
  validt  ("_|=t'/_/ _ _ _,_"  [61,60,1000, 20, 1000,1000] 60) and
  cvalidt  ("_,_|=t'/_ / _ _ _,_"  [61,60,60,1000, 20, 1000,1000] 60)

subsection {* Properties of Validity *}

lemma validtI:
 "\<lbrakk>\<And>s t. \<lbrakk>\<Gamma>\<turnstile>\<langle>c,Normal s\<rangle> \<Rightarrow> t;s \<in> P;t \<notin> Fault ` F\<rbrakk> \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A;
   \<And>s. s \<in> P \<Longrightarrow> \<Gamma>\<turnstile> c\<down>(Normal s) \<rbrakk>
  \<Longrightarrow> \<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  by (auto simp add: validt_def valid_def)

lemma cvalidtI:
 "\<lbrakk>\<And>s t. \<lbrakk>\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Call p) Q,A;\<Gamma>\<turnstile>\<langle>c,Normal s\<rangle> \<Rightarrow> t;s \<in> P;
          t \<notin> Fault ` F\<rbrakk>
          \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A;
   \<And>s. \<lbrakk>\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Call p) Q,A; s\<in>P\<rbrakk> \<Longrightarrow>  \<Gamma>\<turnstile>c\<down>(Normal s)\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  by (auto simp add: cvalidt_def validt_def valid_def)

lemma cvalidt_postD:
 "\<lbrakk>\<Gamma>,\<Theta>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A; \<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Call p) Q,A;\<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> \<Rightarrow> t;
   s \<in> P;t \<notin> Fault ` F\<rbrakk>
  \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A"
  by (simp add: cvalidt_def validt_def valid_def)

lemma cvalidt_termD:
 "\<lbrakk>\<Gamma>,\<Theta>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A; \<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Call p) Q,A;s \<in> P\<rbrakk>
  \<Longrightarrow> \<Gamma>\<turnstile>c\<down>(Normal s)"
  by (simp add: cvalidt_def validt_def valid_def)

lemma validt_augment_Faults:
  assumes valid:"\<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  assumes F': "F \<subseteq> F'"
  shows "\<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F'\<^esub> P c Q,A"
  using valid F'
  by (auto intro: valid_augment_Faults simp add: validt_def)

subsection {* The Hoare Rules: @{text "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A" } *}

inductive "hoaret"::"[('s,'p,'f) body,('s,'p) quadruple set,'f set,
                        's assn,('s,'p,'f) com,'s assn,'s assn]
                       => bool"
    ("(3_,_/\<turnstile>\<^sub>t\<^bsub>'/_\<^esub> (_/ (_)/ _,_))" [61,60,60,1000,20,1000,1000]60)
   for \<Gamma>::"('s,'p,'f) body"
where
  Skip: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> Q Skip Q,A"

| Basic: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> {s. f s \<in> Q} (Basic f) Q,A"

| Spec: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> {s. (\<forall>t. (s,t) \<in> r \<longrightarrow> t \<in> Q) \<and> (\<exists>t. (s,t) \<in> r)} (Spec r) Q,A"

| Seq: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c\<^sub>1 R,A; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> R c\<^sub>2 Q,A\<rbrakk>
        \<Longrightarrow>
        \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P Seq c\<^sub>1 c\<^sub>2 Q,A"

| Cond: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P \<inter> b) c\<^sub>1 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P \<inter> - b) c\<^sub>2 Q,A\<rbrakk>
         \<Longrightarrow>
         \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Cond b c\<^sub>1 c\<^sub>2) Q,A"

| While: "\<lbrakk>wf r; \<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<sigma>} \<inter> P \<inter> b) c ({t. (t,\<sigma>)\<in>r} \<inter> P),A\<rbrakk>
          \<Longrightarrow>
          \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (While b c) (P \<inter> - b),A"

| Guard: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (g \<inter> P) c Q,A
          \<Longrightarrow>
          \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (g \<inter> P) Guard f g c Q,A"

| Guarantee: "\<lbrakk>f \<in> F; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (g \<inter> P) c Q,A\<rbrakk>
              \<Longrightarrow>
              \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Guard f g c) Q,A"

| CallRec:
  "\<lbrakk>(P,p,Q,A) \<in> Specs;
    wf r;
    Specs_wf = (\<lambda>p \<sigma>. (\<lambda>(P,q,Q,A). (P \<inter> {s. ((s,q),(\<sigma>,p)) \<in> r},q,Q,A)) ` Specs);
    \<forall>(P,p,Q,A)\<in> Specs.
      p \<in> dom \<Gamma> \<and> (\<forall>\<sigma>. \<Gamma>,\<Theta> \<union> Specs_wf p \<sigma>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<sigma>} \<inter> P) (the (\<Gamma> p)) Q,A)
    \<rbrakk>
    \<Longrightarrow>
    \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Call p) Q,A"

| DynCom:  "\<forall>s \<in> P. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (c s) Q,A
            \<Longrightarrow>
            \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (DynCom c) Q,A"

| Throw: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> A Throw Q,A"

| Catch: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c\<^sub>1 Q,R; \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> R c\<^sub>2 Q,A\<rbrakk> \<Longrightarrow>  \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P Catch c\<^sub>1 c\<^sub>2 Q,A"

| Conseq: "\<forall>s \<in> P. \<exists>P' Q' A'. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P' c Q',A' \<and> s \<in> P' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A
           \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"

| Asm: "(P,p,Q,A) \<in> \<Theta>
        \<Longrightarrow>
        \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (Call p) Q,A"

| ExFalso: "\<lbrakk>\<Gamma>,\<Theta>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A; \<not> \<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  -- {* This is a hack rule that enables us to derive completeness for
        an arbitrary context @{text "\<Theta>"}, from completeness for an empty context.*}

text {* Does not work, because of rule ExFalso, the context @{text \<Theta>} is to blame.
 A weaker version with empty context can be derived from soundness
 later on. *}
lemma hoaret_to_hoarep:
  assumes hoaret: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P p Q,A"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P p Q,A"
using hoaret
proof (induct)
  case Skip thus ?case by (rule hoarep.intros)
next
  case Basic thus ?case by (rule hoarep.intros)
next
  case Seq thus ?case by - (rule hoarep.intros)
next
  case Cond thus ?case by - (rule hoarep.intros)
next
  case (While r \<Theta> F P b c A)
  hence "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({\<sigma>} \<inter> P \<inter> b) c ({t. (t, \<sigma>) \<in> r} \<inter> P),A"
    by iprover
  hence "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> b) c P,A"
    by (rule HoarePartialDef.conseq) blast
  then show "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P While b c (P \<inter> - b),A"
    by (rule hoarep.While)
next
  case Guard thus ?case by - (rule hoarep.intros)
(*next
  case (CallRec A F P Procs Q Z \<Theta>  p r)
  hence hyp: "\<forall>p\<in>Procs. \<forall>\<tau> Z.
           \<Gamma>,\<Theta> \<union> (\<Union>q\<in>Procs. \<Union>Z. {(P q Z \<inter> {s. ((s, q), \<tau>, p) \<in> r},
                      Call q, Q q Z,A q Z)})\<turnstile>\<^bsub>/F\<^esub>
              ({\<tau>} \<inter> P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)"
    by blast
  have "\<forall>p\<in>Procs. \<forall>Z.
           \<Gamma>,\<Theta> \<union> (\<Union>q\<in>Procs. \<Union>Z. {(P q Z,
                      Call q, Q q Z,A q Z)})\<turnstile>\<^bsub>/F\<^esub>
              (P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)"
  proof (intro ballI allI)
    fix p Z
    assume "p \<in> Procs"
    with hyp
    have hyp': "\<And> \<tau>.
           \<Gamma>,\<Theta> \<union> (\<Union>q\<in>Procs. \<Union>Z. {(P q Z \<inter> {s. ((s, q), \<tau>, p) \<in> r},
                      Call q, Q q Z, A q Z)})\<turnstile>\<^bsub>/F\<^esub>
              ({\<tau>} \<inter> P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)"
      by blast
    have "\<forall>\<tau>.
           \<Gamma>,\<Theta> \<union> (\<Union>q\<in>Procs. \<Union>Z. {(P q Z,
                      Call q, Q q Z,A q Z)})\<turnstile>\<^bsub>/F\<^esub>
              ({\<tau>} \<inter> P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)"
      (is "\<forall>\<tau>. \<Gamma>,?\<Theta>'\<turnstile>\<^bsub>/F\<^esub> ({\<tau>} \<inter> P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)")
    proof (rule allI, rule WeakenContext [OF hyp'],clarify)
      fix \<tau> P' c Q' A'
      assume "(P', c, Q', A') \<in> \<Theta> \<union>
         (\<Union>q\<in>Procs.
             \<Union>Z. {(P q Z \<inter> {s. ((s, q), \<tau>, p) \<in> r},
                  Call q, Q q Z,
                  A q Z)})" (is "(P', c, Q', A') \<in> \<Theta> \<union> ?Spec")
      then show "\<Gamma>,?\<Theta>'\<turnstile>\<^bsub>/F\<^esub> P' c Q',A'"
      proof (cases rule: UnE [consumes 1])
        assume "(P',c,Q',A') \<in> \<Theta>"
        then show ?thesis
          by (blast intro: HoarePartialDef.Asm)
      next
        assume "(P',c,Q',A') \<in> ?Spec"
        then show ?thesis
        proof (clarify)
          fix q Z
          assume q: "q \<in> Procs"
          show "\<Gamma>,?\<Theta>'\<turnstile>\<^bsub>/F\<^esub> (P q Z \<inter> {s. ((s, q), \<tau>, p) \<in> r})
                         Call  q
                        (Q q Z),(A q Z)"
          proof -
            from q
            have "\<Gamma>,?\<Theta>'\<turnstile>\<^bsub>/F\<^esub> (P q Z) Call q (Q q Z),(A q Z)"
              by - (rule HoarePartialDef.Asm,blast)
            thus ?thesis
              by (rule HoarePartialDef.conseqPre) blast
          qed
        qed
      qed
    qed
    then show "\<Gamma>,\<Theta> \<union> (\<Union>q\<in>Procs. \<Union>Z. {(P q Z, Call q, Q q Z,A q Z)})
                \<turnstile>\<^bsub>/F\<^esub> (P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)"
      by (rule HoarePartialDef.conseq) blast
  qed
  thus ?case
    by - (rule hoarep.CallRec)*)
next
  case DynCom thus ?case by (blast intro: hoarep.DynCom)
next
  case Throw thus ?case by - (rule hoarep.Throw)
next
  case Catch thus ?case by - (rule hoarep.Catch)
next
  case Conseq thus ?case by - (rule hoarep.Conseq,blast)
next
  case Asm thus ?case by (rule HoarePartialDef.Asm)
next
  case (ExFalso \<Theta> F P c Q A)
  assume "\<Gamma>,\<Theta>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  hence "\<Gamma>,\<Theta>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"
    oops

lemma hoaret_augment_context:
  assumes deriv: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P p Q,A"
  shows "\<And>\<Theta>'. \<Theta> \<subseteq> \<Theta>' \<Longrightarrow> \<Gamma>,\<Theta>'\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P p Q,A"
using deriv
proof (induct)
  case (CallRec P p Q A Specs r Specs_wf \<Theta> F \<Theta>')
  have aug: "\<Theta> \<subseteq> \<Theta>'" by fact
  then
  have h: "\<And>\<tau> p. \<Theta> \<union> Specs_wf p \<tau>
       \<subseteq> \<Theta>' \<union> Specs_wf p \<tau>"
    by blast
  have "\<forall>(P,p,Q,A)\<in>Specs. p \<in> dom \<Gamma> \<and>
     (\<forall>\<tau>. \<Gamma>,\<Theta> \<union> Specs_wf p \<tau>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<tau>} \<inter> P) (the (\<Gamma> p)) Q,A \<and>
           (\<forall>x. \<Theta> \<union> Specs_wf p \<tau>
                 \<subseteq> x \<longrightarrow>
                 \<Gamma>,x\<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<tau>} \<inter> P) (the (\<Gamma> p)) Q,A))" by fact
  hence "\<forall>(P,p,Q,A)\<in>Specs. p \<in> dom \<Gamma> \<and>
         (\<forall>\<tau>. \<Gamma>,\<Theta>'\<union> Specs_wf p \<tau> \<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<tau>} \<inter> P) (the (\<Gamma> p)) Q,A)"
    apply (clarify)
    apply (rename_tac P p Q A)
    apply (drule (1) bspec)
    apply (clarsimp)
    apply (erule_tac x=\<tau> in allE)
    apply clarify
    apply (erule_tac x="\<Theta>' \<union> Specs_wf p \<tau>" in allE)
    apply (insert aug)
    apply auto
    done
  with CallRec show ?case by - (rule hoaret.CallRec)
next
  case DynCom thus ?case by (blast intro: hoaret.DynCom)
next
  case (Conseq P \<Theta> F c Q A \<Theta>')
  from Conseq
  have "\<forall>s \<in> P. (\<exists>P' Q' A'. (\<Gamma>,\<Theta>' \<turnstile>\<^sub>t\<^bsub>/F\<^esub> P' c Q',A') \<and> s \<in> P'\<and> Q' \<subseteq> Q \<and> A' \<subseteq> A)"
    by blast
  with Conseq show ?case by - (rule hoaret.Conseq)
next
  case (ExFalso \<Theta> F P  c Q A \<Theta>')
  have "\<Gamma>,\<Theta>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A" "\<not> \<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A" "\<Theta> \<subseteq> \<Theta>'"  by fact+
  then show ?case
    by (fastforce intro: hoaret.ExFalso simp add: cvalidt_def)
qed (blast intro: hoaret.intros)+

subsection {* Some Derived Rules *}

lemma  Conseq': "\<forall>s. s \<in> P \<longrightarrow>
            (\<exists>P' Q' A'.
              (\<forall> Z. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) c (Q' Z),(A' Z)) \<and>
                    (\<exists>Z. s \<in> P' Z \<and> (Q' Z \<subseteq> Q) \<and> (A' Z \<subseteq> A)))
           \<Longrightarrow>
           \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
apply (rule Conseq)
apply (rule ballI)
apply (erule_tac x=s in allE)
apply (clarify)
apply (rule_tac x="P' Z" in exI)
apply (rule_tac x="Q' Z" in exI)
apply (rule_tac x="A' Z" in exI)
apply blast
done

lemma conseq:"\<lbrakk>\<forall>Z. \<Gamma>,\<Theta> \<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P' Z) c (Q' Z),(A' Z);
              \<forall>s. s \<in> P \<longrightarrow> (\<exists> Z. s\<in>P' Z \<and> (Q' Z \<subseteq> Q)\<and> (A' Z \<subseteq> A))\<rbrakk>
              \<Longrightarrow>
              \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  by (rule Conseq) blast

theorem conseqPrePost:
  "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P' c Q',A' \<Longrightarrow> P \<subseteq> P' \<Longrightarrow>  Q' \<subseteq> Q \<Longrightarrow> A' \<subseteq> A \<Longrightarrow>  \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  by (rule conseq [where ?P'="\<lambda>Z. P'" and ?Q'="\<lambda>Z. Q'"]) auto

lemma conseqPre: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P' c Q,A \<Longrightarrow> P \<subseteq> P' \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
by (rule conseq) auto

lemma conseqPost: "\<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q',A'\<Longrightarrow> Q' \<subseteq> Q \<Longrightarrow> A' \<subseteq> A \<Longrightarrow>   \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  by (rule conseq) auto

lemma Spec_wf_conv:
  "(\<lambda>(P, q, Q, A). (P \<inter> {s. ((s, q), \<tau>, p) \<in> r}, q, Q, A)) `
                (\<Union>p\<in>Procs. \<Union>Z. {(P p Z, p, Q p Z, A p Z)}) =
        (\<Union>q\<in>Procs. \<Union>Z. {(P q Z \<inter> {s. ((s, q), \<tau>, p) \<in> r}, q, Q q Z, A q Z)})"
apply (rule)
apply  fastforce
apply (fastforce simp add: image_def)
done

lemma CallRec':
  "\<lbrakk>p\<in>Procs; Procs \<subseteq> dom \<Gamma>;
    wf r;
   \<forall>p\<in>Procs. \<forall>\<tau> Z.
   \<Gamma>,\<Theta>\<union>(\<Union>q\<in>Procs. \<Union>Z.
    {((P q Z) \<inter> {s. ((s,q),(\<tau>,p)) \<in> r},q,Q q Z,(A q Z))})
     \<turnstile>\<^sub>t\<^bsub>/F\<^esub> ({\<tau>} \<inter> (P p Z)) (the (\<Gamma> p)) (Q p Z),(A p Z)\<rbrakk>
   \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P p Z) (Call p) (Q p Z),(A p Z)"
apply (rule CallRec [where Specs="\<Union>p\<in>Procs. \<Union>Z. {((P p Z),p,Q p Z,A p Z)}" and
         r=r])
apply    blast
apply   assumption
apply  (rule refl)
apply (clarsimp)
apply (rename_tac p')
apply (rule conjI)
apply  blast
apply (intro allI)
apply (rename_tac Z \<tau>)
apply (drule_tac x=p' in bspec, assumption)
apply (erule_tac x=\<tau> in allE)
apply (erule_tac x=Z in allE)
apply (fastforce simp add: Spec_wf_conv)
done

end


theory HC_Compl_Consistency
imports Consistency HC
begin

context begin
private lemma dt: "F \<triangleright> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H G \<Longrightarrow> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H F \<^bold>\<rightarrow> G"
  by (metis AX100 Deduction_theorem Un_insert_right sup_left_commute)
lemma sim: "\<Gamma> \<union> AX10 \<turnstile>\<^sub>H F \<Longrightarrow> F \<triangleright> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H G \<Longrightarrow> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H G"
  using MP dt by blast
lemma sim_conj: "F \<triangleright> G \<triangleright> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H H \<Longrightarrow> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H F \<Longrightarrow> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H G \<Longrightarrow> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H H"
  using MP dt by (metis Un_insert_left)
lemma sim_disj: "\<lbrakk>F \<triangleright> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H H; G \<triangleright> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H H; \<Gamma> \<union> AX10 \<turnstile>\<^sub>H F \<^bold>\<or> G\<rbrakk> \<Longrightarrow> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H H"
proof goal_cases
  case 1
  have 2: "\<Gamma> \<union> AX10 \<turnstile>\<^sub>H F \<^bold>\<rightarrow> H" by (simp add: 1 dt)
  have 3: "\<Gamma> \<union> AX10 \<turnstile>\<^sub>H G \<^bold>\<rightarrow> H" by (simp add: 1 dt)
  have 4: "\<Gamma> \<union> AX10 \<turnstile>\<^sub>H (F \<^bold>\<or> G) \<^bold>\<rightarrow> H" by (meson 2 3 HC.simps HC_intros(7) HC_mono sup_ge2)
  thus ?case  using 1(3) MP by blast
qed

private lemma someax: "\<Gamma> \<union> AX10 \<turnstile>\<^sub>H F \<^bold>\<rightarrow> \<^bold>\<not> F \<^bold>\<rightarrow> \<bottom>"
proof -
  have "F \<triangleright> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H \<^bold>\<not> F \<^bold>\<rightarrow> F \<^bold>\<rightarrow> \<bottom>"
    by (meson HC_intros(12) HC_mono subset_insertI sup_ge2)
  then have "\<^bold>\<not> F \<triangleright> F \<triangleright> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H \<bottom>"
    by (meson HC.simps HC_mono insertI1 subset_insertI)
  then show ?thesis
    by (metis (no_types) Un_insert_left dt)
qed

lemma lem: "\<Gamma> \<union> AX10 \<turnstile>\<^sub>H \<^bold>\<not> F \<^bold>\<or> F"
proof -
  thm HC_intros(7)[of F \<bottom> "Not F"]
  have "F \<triangleright> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H ( \<^bold>\<not> F \<^bold>\<or> F)"
    by (metis AX10.intros(3) Ax HC_mono MP Un_commute Un_insert_left insertI1 sup_ge1)
  hence "F \<triangleright> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H \<^bold>\<not> ( \<^bold>\<not> F \<^bold>\<or> F) \<^bold>\<rightarrow> \<bottom>" using someax by (metis HC.simps Un_insert_left)
  hence "\<^bold>\<not> ( \<^bold>\<not> F \<^bold>\<or> F) \<triangleright> F \<triangleright> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H \<bottom>" by (meson Ax HC_mono MP insertI1 subset_insertI)
  hence "\<^bold>\<not> ( \<^bold>\<not> F \<^bold>\<or> F) \<triangleright> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H F \<^bold>\<rightarrow> \<bottom>"
    by (metis Un_insert_left dt insert_commute)

  have "\<^bold>\<not>F \<triangleright> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H ( \<^bold>\<not> F \<^bold>\<or> F)"
    by (metis HC.simps HC_intros(5) HC_mono inf_sup_ord(4) insertI1 insert_is_Un)
  hence "\<^bold>\<not>F \<triangleright> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H \<^bold>\<not> ( \<^bold>\<not> F \<^bold>\<or> F) \<^bold>\<rightarrow> \<bottom>" using someax by (metis HC.simps Un_insert_left)
  hence "\<^bold>\<not> ( \<^bold>\<not> F \<^bold>\<or> F) \<triangleright> \<^bold>\<not>F \<triangleright> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H \<bottom>" by (meson Ax HC_mono MP insertI1 subset_insertI)
  hence "\<^bold>\<not> ( \<^bold>\<not> F \<^bold>\<or> F) \<triangleright> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H \<^bold>\<not>F \<^bold>\<rightarrow> \<bottom>"
    by (metis Un_insert_left dt insert_commute)

  hence "\<Gamma> \<union> AX10 \<turnstile>\<^sub>H \<^bold>\<not> ( \<^bold>\<not> F \<^bold>\<or> F) \<^bold>\<rightarrow> \<bottom>"
    by (meson HC_intros(13) HC_mono MP \<open>\<^bold>\<not> (\<^bold>\<not> F \<^bold>\<or> F) \<triangleright> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H F \<^bold>\<rightarrow> \<bottom>\<close> dt subset_insertI sup_ge2)
  thus ?thesis by (meson HC.simps HC_intros(13) HC_mono sup_ge2)
(*    apply(insert HC_mono dt HC_intros(3-)[THEN HC_mono, OF sup_ge2] sim HC.intros)
    sledgehammer[debug,max_facts=50,timeout=120]*)
qed

lemma exchg: "\<Gamma> \<union> AX10 \<turnstile>\<^sub>H F \<^bold>\<or> G \<Longrightarrow> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H G \<^bold>\<or> F"
  by (meson AX10.intros(3) HC.simps HC_intros(5) HC_intros(7) HC_mono sup_ge2)

lemma nor_sim:
assumes "\<Gamma> \<union> AX10 \<turnstile>\<^sub>H \<^bold>\<not> (F \<^bold>\<or> G)"
shows "\<Gamma> \<union> AX10 \<turnstile>\<^sub>H \<^bold>\<not> F" " \<Gamma> \<union> AX10 \<turnstile>\<^sub>H \<^bold>\<not> G"
  using HC_contrapos_nn assms by (metis HC_intros(5,6) HC_mono sup_ge2)+

lemma HC_contrapos_np:
  "\<lbrakk>\<Gamma> \<union> AX10 \<turnstile>\<^sub>H \<^bold>\<not> F; \<Gamma> \<union> AX10 \<turnstile>\<^sub>H \<^bold>\<not> G \<^bold>\<rightarrow> F\<rbrakk> \<Longrightarrow> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H G"
    by (meson HC_intros(12) HC_intros(13) HC_mono MP sup_ge2  HC_contrapos_nn[of \<Gamma> F "Not G"])

lemma not_imp: "\<Gamma> \<union> AX10 \<turnstile>\<^sub>H \<^bold>\<not> F \<^bold>\<rightarrow> F \<^bold>\<rightarrow> G"
proof goal_cases case 1
  have "\<Gamma> \<union> AX10 \<turnstile>\<^sub>H \<^bold>\<not> F \<^bold>\<rightarrow> F \<^bold>\<rightarrow> \<bottom>" by (simp add: AX10.intros(9) Ax)
  hence "\<^bold>\<not> F \<triangleright> F \<triangleright> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H \<bottom>" by (meson HC.simps HC_mono insertI1 subset_insertI)
  hence "\<^bold>\<not> F \<triangleright> F \<triangleright> \<Gamma> \<union> AX10 \<turnstile>\<^sub>H G" by (metis (no_types, hide_lams) Un_commute Un_insert_right inpcp)
  thus ?case by (metis Un_insert_left dt insert_commute)
qed

lemma HC_consistent:  "pcp {\<Gamma>| \<Gamma>. \<not>(\<Gamma> \<union> AX10 \<turnstile>\<^sub>H \<bottom>)}"
  unfolding pcp_def
  apply(intro ballI conjI; unfold mem_Collect_eq; elim exE conjE; erule contrapos_np; clarsimp)
          subgoal by (simp add: HC.Ax)
         subgoal by (meson Ax HC_intros(12) HC_mono MP Un_upper1 sup_ge2)
        subgoal using sim_conj by (metis (no_types, lifting) Ax HC_intros(8) HC_intros(9) HC_mono MP sup_ge1 sup_ge2)
       subgoal using sim_disj using Ax by blast
      subgoal by (erule (1) sim_disj) (simp add: Ax imp_sim)
     subgoal by (metis Ax HC_contrapos_nn MP Un_iff Un_insert_left dt inpcp someax)
    subgoal by(erule (1) sim_disj) (simp add: Ax nand_sim)
   subgoal by(erule  sim_conj) (meson Ax Un_iff nor_sim)+
  subgoal for \<Gamma> F G apply(erule sim_conj)
     subgoal by (meson Ax HC_Compl_Consistency.not_imp HC_contrapos_np Un_iff)
    subgoal by (metis Ax HC_contrapos_nn HC_intros(3) HC_mono sup_ge1 sup_ge2)
  done
done

end

corollary HC_complete:
  fixes F :: "'a :: countable formula"
  shows "\<Turnstile> F \<Longrightarrow> AX10 \<turnstile>\<^sub>H F"
proof(erule contrapos_pp)
  let ?W = "{\<Gamma>| \<Gamma>. \<not>((\<Gamma> :: ('a :: countable) formula set) \<union> AX10 \<turnstile>\<^sub>H \<bottom>)}"
    note [[show_types]]
  assume \<open>\<not> (AX10 \<turnstile>\<^sub>H F)\<close>
  hence "\<not> (\<^bold>\<not>F \<triangleright> AX10 \<turnstile>\<^sub>H \<bottom>)"
    by (metis AX100 Deduction_theorem HC_intros(13) MP Un_insert_right)
  hence "{\<^bold>\<not>F} \<in> ?W" by simp
  with pcp_sat HC_consistent have "sat {\<^bold>\<not> F}" .
  thus "\<not> \<Turnstile> F" by (simp add: sat_def)
qed

end


theory DP_CRelVH_Ext
imports DP_CRelVH
begin
context dp_consistency_heap begin

definition "crel_vs1 R v f \<equiv>
  \<forall>heap. P heap \<longrightarrow>
    (case execute f heap of None \<Rightarrow> False | Some (v', heap') \<Rightarrow> P heap' \<and> (state_dp_consistency.cmem heap \<longrightarrow> R v v' \<and> state_dp_consistency.cmem heap'))
"

lemma crel_vs1_execute_None:
  False if "crel_vs1 R a b" "execute b heap = None" "P heap"
  using that unfolding crel_vs1_def by auto

lemma crel_vs1_execute_Some:
  assumes "crel_vs1 R a b" "P heap"
  obtains x heap' where "execute b heap = Some (x, heap')" "P heap'"
  using assms unfolding crel_vs1_def by (cases "execute b heap") auto

lemma crel_vs1_executeD:
  assumes "crel_vs1 R a b" "P heap" "state_dp_consistency.cmem heap"
  obtains x heap' where "execute b heap = Some (x, heap')" "P heap'" "state_dp_consistency.cmem heap'" "R a x"
  using assms unfolding crel_vs1_def by (cases "execute b heap") auto

lemma rel_state_state_of:
  "rel_state (=) (state_of b) b" if "crel_vs1 R a b"
  unfolding rel_state_def state_of_def
  by (auto split: option.split elim: crel_vs1_execute_Some[OF that])

lemma crel_vs1_state_of:
  "state_dp_consistency.crel_vs R a (state_of b)" if "crel_vs1 R a b"
  unfolding state_dp_consistency.crel_vs_def state_of_def by (auto elim: crel_vs1_executeD[OF that])

lemma crel_vs1_alt_def:
  "crel_vs1 R = (state_dp_consistency.crel_vs R OO rel_state (=))"
proof (intro ext)
  fix a b
  have "(state_dp_consistency.crel_vs R OO rel_state (=)) a b" if "crel_vs1 R a b"
    using that by - (rule relcomppI; erule crel_vs1_state_of rel_state_state_of)
  moreover have "crel_vs1 R a b" if "(state_dp_consistency.crel_vs R OO rel_state (=)) a b"
    using that by (auto 4 3 elim: state_dp_consistency.crel_vs_elim rel_state_elim simp: crel_vs1_def)
  ultimately show "crel_vs1 R a b = (state_dp_consistency.crel_vs R OO rel_state (=)) a b" ..
qed

context
  includes lifting_syntax
begin

lemma transfer_return1[transfer_rule]:
  "(R ===> crel_vs1 R) Wrap return"
  unfolding crel_vs1_alt_def Wrap_def by (rule rel_fun_comp1 state_dp_consistency.return_transfer[unfolded Wrap_def] transfer_return)+ auto

lemma crel_vs_return1:
  "\<lbrakk>R x y\<rbrakk> \<Longrightarrow> crel_vs1 R (Wrap x) (return y)"
  by (rule transfer_return1[unfolded rel_fun_def, rule_format])
term 0 (**)

lemma crel_vs_rel_state:
  "(R0 ===> state_dp_consistency.crel_vs R1) x (state_of o y)" if "(R0 ===> state_dp_consistency.crel_vs R1 OO rel_state (=)) x y"
  using that
  unfolding state_of_def
  apply -
  apply (rule rel_funI)
  apply (drule rel_funD, assumption)
  apply (erule relcomppE)
  apply auto
  apply (rule state_dp_consistency.crel_vs_intro)
  apply auto
   apply (erule rel_state_elim, assumption)
    apply (erule state_dp_consistency.crel_vs_elim)
      apply assumption+
    apply simp
  subgoal premises prems for x' y' b M v' M'
  proof -
    from prems(2,3) have "crel_vs1 R1 (x x') (y y')"
      unfolding crel_vs1_alt_def by (rule relcomppI)
    with prems show ?thesis
      by (auto elim: crel_vs1_executeD)
  qed
  subgoal premises prems for x' y' b M v' M'
  proof -
    from prems(2,3) have "crel_vs1 R1 (x x') (y y')"
      unfolding crel_vs1_alt_def by (rule relcomppI)
    with prems show ?thesis
      by (auto elim: crel_vs1_executeD)
  qed
  done

lemma bind_transfer1:
  "(crel_vs1 R0 ===> (R0 ===> crel_vs1 R1) ===> crel_vs1 R1) (\<lambda>v f. f v) (\<bind>)"
  if "\<And> x. R0 x x"
  unfolding crel_vs1_alt_def
  apply (rule rel_fun_comp2')
    apply (rule state_dp_consistency.bind_transfer)
   apply (rule transfer_bind)
  apply (drule rel_fun_relcompp)
  apply (erule rel_fun_mono)
   defer
   apply assumption
  apply (intro impI relcomppI)
   apply (erule crel_vs_rel_state)
  by (auto 4 4 dest: rel_funD intro: that elim: rel_state_state_of simp: crel_vs1_alt_def[symmetric])

lemma fun_app_transfer[transfer_rule]:
  "(crel_vs1 (R0 ===> crel_vs1 R1) ===> crel_vs1 R0 ===> crel_vs1 R1) App Heap_Monad_Ext.fun_app_lifted"
  unfolding App_def Heap_Monad_Ext.fun_app_lifted_def
  oops
end (* Lifting Syntax *)

end (* Dynamic Programming Problem *)

end