# Theory AWN

```(*  Title:       AWN.thy
Author:      Timothy Bourke
*)

section "Terms of the Algebra for Wireless Networks"

theory AWN
imports Lib
begin

subsection "Sequential Processes"

type_synonym ip = nat
type_synonym data = nat

text ‹
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).
›

class msg =
fixes newpkt :: "data × ip ⇒ 'a"
and eq_newpkt :: "'a ⇒ bool"
assumes eq_newpkt_eq [simp]: "eq_newpkt (newpkt (d, i))"

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

GUARD "'l" "'s ⇒ 's set" "('s, 'm, 'p, 'l) seqp"
| ASSIGN "'l" "'s ⇒ 's" "('s, 'm, 'p, 'l) seqp"
| CHOICE "('s, 'm, 'p, 'l) seqp" "('s, 'm, 'p, 'l) seqp"
| UCAST "'l" "'s ⇒ ip" "'s ⇒ 'm" "('s, 'm, 'p, 'l) seqp" "('s, 'm, 'p, 'l) seqp"
| BCAST "'l" "'s ⇒ 'm" "('s, 'm, 'p, 'l) seqp"
| GCAST "'l" "'s ⇒ ip set" "'s ⇒ 'm" "('s, 'm, 'p, 'l) seqp"
| SEND "'l" "'s ⇒ 'm" "('s, 'm, 'p, 'l) seqp"
| DELIVER "'l" "'s ⇒ data" "('s, 'm, 'p, 'l) seqp"
| RECEIVE "'l" "'m ⇒ 's ⇒ 's" "('s, 'm, 'p, 'l) seqp"
| CALL 'p
for map: labelmap

syntax
"_guard"    :: "['a,  ('s, 'm, 'p, unit) seqp] ⇒  ('s, 'm, 'p, unit) seqp"
("(‹unbreakable›⟨_⟩)//_" [0, 60] 60)
"_lguard"   :: "['a, 'a,  ('s, 'm, 'p, unit) seqp] ⇒  ('s, 'm, 'p, unit) seqp"
("{_}(‹unbreakable›⟨_⟩)//_" [0, 0, 60] 60)
"_ifguard"  :: "[pttrn, bool,  ('s, 'm, 'p, unit) seqp] ⇒  ('s, 'm, 'p, unit) seqp"
("(‹unbreakable›⟨_. _⟩)//_" [0, 0, 60] 60)

"_bassign"  :: "[pttrn, 'a,  ('s, 'm, 'p, unit) seqp] ⇒  ('s, 'm, 'p, unit) seqp"
("(‹unbreakable›⟦_. _⟧)//_" [0, 0, 60] 60)
"_lbassign" :: "['a, pttrn, 'a, ('s, 'm, 'p, 'a) seqp] ⇒ ('s, 'm, 'p, 'a) seqp"
("{_}(‹unbreakable›⟦_. _⟧)//_" [0, 0, 0, 60] 60)

"_assign"  :: "['a,  ('s, 'm, 'p, unit) seqp] ⇒  ('s, 'm, 'p, unit) seqp"
("((‹unbreakable›⟦_⟧))//_" [0, 60] 60)
"_lassign" :: "['a, 'a, ('s, 'm, 'p, 'a) seqp] ⇒ ('s, 'm, 'p, 'a) seqp"
("({_}(‹unbreakable›⟦_⟧))//_" [0, 0, 60] 60)

"_unicast"  :: "['a, 'a,  ('s, 'm, 'p, unit) seqp,  ('s, 'm, 'p, unit) seqp] ⇒  ('s, 'm, 'p, unit) seqp"
("(3unicast'((1(3_),/ (3_))') .//(_)/ (2▹ _))" [0, 0, 60, 60] 60)
"_lunicast" :: "['a, 'a, 'a, ('s, 'm, 'p, 'a) seqp, ('s, 'm, 'p, 'a) seqp] ⇒ ('s, 'm, 'p, 'a) seqp"
("(3{_}unicast'((1(3_),/ (3_))') .//(_)/ (2▹ _))" [0, 0, 0, 60, 60] 60)

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

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

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

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

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

translations
"_guard f p"     ⇌ "CONST GUARD () f p"
"_lguard l f p"  ⇌ "CONST GUARD l f p"
"_ifguard ξ e p" ⇀ "CONST GUARD () (λξ. if e then {ξ} else {}) p"

"_assign f p"    ⇌ "CONST ASSIGN () f p"
"_lassign l f p" ⇌ "CONST ASSIGN l f p"

"_bassign ξ e p"    ⇌ "CONST ASSIGN () (λξ. e) p"
"_lbassign l ξ e p" ⇌ "CONST ASSIGN l (λξ. e) p"

"_unicast fip fmsg p q"    ⇌ "CONST UCAST () fip fmsg p q"
"_lunicast l fip fmsg p q" ⇌ "CONST UCAST l fip fmsg p q"

"_bcast fmsg p"    ⇌ "CONST BCAST () fmsg p"
"_lbcast l fmsg p" ⇌ "CONST BCAST l fmsg p"

"_gcast fipset fmsg p"    ⇌ "CONST GCAST () fipset fmsg p"
"_lgcast l fipset fmsg p" ⇌ "CONST GCAST l fipset fmsg p"

"_send fmsg p"    ⇌ "CONST SEND () fmsg p"
"_lsend l fmsg p" ⇌ "CONST SEND l fmsg p"

"_deliver fdata p"    ⇌ "CONST DELIVER () fdata p"
"_ldeliver l fdata p" ⇌ "CONST DELIVER l fdata p"

notation "CHOICE" ("((_)//⊕//(_))" [56, 55] 55)
and "CALL"   ("(3call'((3_)'))" [0] 60)

definition not_call :: "('s, 'm, 'p, 'l) seqp ⇒ bool"
where "not_call p ≡ ∀pn. p ≠ call(pn)"

lemma not_call_simps [simp]:
"⋀l fg p.         not_call ({l}⟨fg⟩ p)"
"⋀l fa p.         not_call ({l}⟦fa⟧ p)"
"⋀p1 p2.          not_call (p1 ⊕ p2)"
"⋀l fip fmsg p q. not_call ({l}unicast(fip, fmsg).p ▹ q)"
"⋀l fips fmsg p.  not_call ({l}groupcast(fips, fmsg).p)"
"⋀l fmsg p.       not_call ({l}send(fmsg).p)"
"⋀l fdata p.      not_call ({l}deliver(fdata).p)"
"⋀l pn.         ¬(not_call (call(pn)))"
unfolding not_call_def by auto

definition not_choice :: "('s, 'm, 'p, 'l) seqp ⇒ bool"
where "not_choice p ≡ ∀p1 p2. p ≠ p1 ⊕ p2"

lemma not_choice_simps [simp]:
"⋀l fg p.         not_choice ({l}⟨fg⟩ p)"
"⋀l fa p.         not_choice ({l}⟦fa⟧ p)"
"⋀p1 p2.        ¬(not_choice (p1 ⊕ p2))"
"⋀l fip fmsg p q. not_choice ({l}unicast(fip, fmsg).p ▹ q)"
"⋀l fips fmsg p.  not_choice ({l}groupcast(fips, fmsg).p)"
"⋀l fmsg p.       not_choice ({l}send(fmsg).p)"
"⋀l fdata p.      not_choice ({l}deliver(fdata).p)"
"⋀l pn.           not_choice (call(pn))"
unfolding not_choice_def by auto

lemma seqp_congs:
"⋀l fg p. {l}⟨fg⟩ p = {l}⟨fg⟩ p"
"⋀l fa p. {l}⟦fa⟧ p = {l}⟦fa⟧ p"
"⋀p1 p2. p1 ⊕ p2 = p1 ⊕ p2"
"⋀l fip fmsg p q. {l}unicast(fip, fmsg).p ▹ q = {l}unicast(fip, fmsg).p ▹ q"
"⋀l fips fmsg p. {l}groupcast(fips, fmsg).p = {l}groupcast(fips, fmsg).p"
"⋀l fmsg p. {l}send(fmsg).p = {l}send(fmsg).p"
"⋀l fdata p. {l}deliver(fdata).p = {l}deliver(fdata).p"
"⋀l pn. call(pn) = call(pn)"
by auto

text ‹Remove data expressions from process terms.›

fun seqp_skeleton :: "('s, 'm, 'p, 'l) seqp ⇒ (unit, unit, 'p, 'l) seqp"
where
"seqp_skeleton ({l}⟨_⟩ p)                 = {l}⟨λ_. {()}⟩ (seqp_skeleton p)"
| "seqp_skeleton ({l}⟦_⟧ p)                 = {l}⟦λ_. ()⟧ (seqp_skeleton p)"
| "seqp_skeleton (p ⊕ q)                   = (seqp_skeleton p) ⊕ (seqp_skeleton q)"
| "seqp_skeleton ({l}unicast(_, _). p ▹ q) = {l}unicast(λ_. 0, λ_. ()). (seqp_skeleton p) ▹ (seqp_skeleton q)"
| "seqp_skeleton ({l}groupcast(_, _). p)   = {l}groupcast(λ_. {}, λ_. ()). (seqp_skeleton p)"
| "seqp_skeleton ({l}send(_). p)           = {l}send(λ_. ()). (seqp_skeleton p)"
| "seqp_skeleton ({l}deliver(_). p)        = {l}deliver(λ_. 0). (seqp_skeleton p)"
| "seqp_skeleton (call(pn))                = call(pn)"

text ‹Calculate the subterms of a term.›

fun subterms :: "('s, 'm, 'p, 'l) seqp ⇒ ('s, 'm, 'p, 'l) seqp set"
where
"subterms ({l}⟨fg⟩ p) = {{l}⟨fg⟩ p} ∪ subterms p"
| "subterms ({l}⟦fa⟧ p) = {{l}⟦fa⟧ p} ∪ subterms p"
| "subterms (p1 ⊕ p2) = {p1 ⊕ p2} ∪ subterms p1 ∪ subterms p2"
| "subterms ({l}unicast(fip, fmsg). p ▹ q) =
{{l}unicast(fip, fmsg). p ▹ q} ∪ subterms p ∪ subterms q"
| "subterms ({l}groupcast(fips, fmsg). p) = {{l}groupcast(fips, fmsg). p} ∪ subterms p"
| "subterms ({l}send(fmsg). p) = {{l}send(fmsg).p} ∪ subterms p"
| "subterms ({l}deliver(fdata). p) = {{l}deliver(fdata).p} ∪ subterms p"
| "subterms (call(pn)) = {call(pn)}"

lemma subterms_refl [simp]: "p ∈ subterms p"
by (cases p) simp_all

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

lemma root_in_subterms [simp]:
"⋀Γ pn. ∃pn'. Γ pn ∈ subterms (Γ pn')"
by (rule_tac x=pn in exI) simp

lemma deriv_in_subterms [elim, dest]:
"⋀l f p q. {l}⟨f⟩ q ∈ subterms p ⟹ q ∈ subterms p"
"⋀l fa p q. {l}⟦fa⟧ q ∈ subterms p ⟹ q ∈ subterms p"
"⋀p1 p2 p. p1 ⊕ p2 ∈ subterms p ⟹ p1 ∈ subterms p"
"⋀p1 p2 p. p1 ⊕ p2 ∈ subterms p ⟹ p2 ∈ subterms p"
"⋀l fip fmsg p q r. {l}unicast(fip, fmsg). q ▹ r ∈ subterms p ⟹ q ∈ subterms p"
"⋀l fip fmsg p q r. {l}unicast(fip, fmsg). q ▹ r ∈ subterms p ⟹ r ∈ subterms p"
"⋀l fmsg p q. {l}broadcast(fmsg). q ∈ subterms p ⟹ q ∈ subterms p"
"⋀l fips fmsg p q. {l}groupcast(fips, fmsg). q ∈ subterms p ⟹ q ∈ subterms p"
"⋀l fmsg p q. {l}send(fmsg). q ∈ subterms p ⟹ q ∈ subterms p"
"⋀l fdata p q. {l}deliver(fdata). q ∈ subterms p ⟹ q ∈ subterms p"
"⋀l fmsg p q. {l}receive(fmsg). q ∈ subterms p ⟹ q ∈ subterms p"
by auto

subsection "Actions"

text ‹
There are two sorts of ‹τ› 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.
›

class tau =
fixes tau :: "'a" ("τ")

subsubsection "Sequential Actions (and related predicates)"

datatype 'm seq_action =
| groupcast "ip set" 'm
| unicast ip 'm
| notunicast ip           ("¬unicast _" [1000] 60)
| send 'm
| deliver data
| seq_tau                 ("τ⇩s")

instantiation "seq_action" :: (type) tau
begin
definition step_seq_tau [simp]: "τ ≡ τ⇩s"
instance ..
end

definition recvmsg :: "('m ⇒ bool) ⇒ 'm seq_action ⇒ bool"
where "recvmsg P a ≡ case a of receive m ⇒ P m
| _ ⇒ True"

lemma recvmsg_simps[simp]:
"⋀m.     recvmsg P (broadcast m)     = True"
"⋀ips m. recvmsg P (groupcast ips m) = True"
"⋀ip m.  recvmsg P (unicast ip m)    = True"
"⋀ip.    recvmsg P (notunicast ip)   = True"
"⋀m.     recvmsg P (send m)          = True"
"⋀d.     recvmsg P (deliver d)       = True"
"⋀m.     recvmsg P (receive m)       = P m"
"        recvmsg P τ⇩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 σ) a"
and "⋀m. R σ m ⟹ R σ' m"
shows "recvmsg (R σ') a"
using assms(1) by (cases a) (auto elim!: assms(2))

definition anycast :: "('m ⇒ bool) ⇒ 'm seq_action ⇒ bool"
where "anycast P a ≡ case a of broadcast m ⇒ P m
| groupcast _ m ⇒ P m
| unicast _ m ⇒ P m
| _ ⇒ True"

lemma anycast_simps [simp]:
"⋀m.     anycast P (broadcast m)     = P m"
"⋀ips m. anycast P (groupcast ips m) = P m"
"⋀ip m.  anycast P (unicast ip m)    = P m"
"⋀ip.    anycast P (notunicast ip)   = True"
"⋀m.     anycast P (send m)          = True"
"⋀d.     anycast P (deliver d)       = True"
"⋀m.     anycast P (receive m)       = True"
"        anycast P τ⇩s                 = True"
unfolding anycast_def by simp_all

definition orecvmsg :: "((ip ⇒ 's) ⇒ 'm ⇒ bool) ⇒ (ip ⇒ 's) ⇒ 'm seq_action ⇒ bool"
where "orecvmsg P σ a ≡ (case a of receive m ⇒ P σ m
| _ ⇒ True)"

lemma orecvmsg_simps [simp]:
"⋀m.     orecvmsg P σ (broadcast m)     = True"
"⋀ips m. orecvmsg P σ (groupcast ips m) = True"
"⋀ip m.  orecvmsg P σ (unicast ip m)    = True"
"⋀ip.    orecvmsg P σ (notunicast ip)   = True"
"⋀m.     orecvmsg P σ (send m)          = True"
"⋀d.     orecvmsg P σ (deliver d)       = True"
"⋀m.     orecvmsg P σ (receive m)       = P σ m"
"         orecvmsg P σ τ⇩s                = True"
unfolding orecvmsg_def by simp_all

lemma orecvmsgEI [elim]:
"⟦ orecvmsg P σ a; ⋀σ a. P σ a ⟹ Q σ a ⟧ ⟹ orecvmsg Q σ a"
by (cases a) simp_all

lemma orecvmsg_stateless_recvmsg [elim]:
"orecvmsg (λ_. P) σ a ⟹ recvmsg P a"
by (cases a) simp_all

lemma orecvmsg_recv_weaken [elim]:
"⟦ orecvmsg P σ a; ⋀σ a. P σ a ⟹ Q a ⟧ ⟹ recvmsg Q a"
by (cases a) simp_all

lemma orecvmsg_recvmsg [elim]:
"orecvmsg P σ a ⟹ recvmsg (P σ) a"
by (cases a) simp_all

definition sendmsg :: "('m ⇒ bool) ⇒ 'm seq_action ⇒ bool"
where "sendmsg P a ≡ case a of send m ⇒ P m | _ ⇒ True"

lemma sendmsg_simps [simp]:
"⋀m.     sendmsg P (broadcast m)     = True"
"⋀ips m. sendmsg P (groupcast ips m) = True"
"⋀ip m.  sendmsg P (unicast ip m)    = True"
"⋀ip.    sendmsg P (notunicast ip)   = True"
"⋀m.     sendmsg P (send m)          = P m"
"⋀d.     sendmsg P (deliver d)       = True"
"⋀m.     sendmsg P (receive m)       = True"
"        sendmsg P τ⇩s                 = True"
unfolding sendmsg_def by simp_all

type_synonym ('s, 'm, 'p, 'l) seqp_env = "'p ⇒ ('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  ("_¬_: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                          ("τ⇩n")

instantiation "node_action" :: (type) tau
begin
definition step_node_tau [simp]: "τ ≡ τ⇩n"
instance ..
end

definition arrivemsg :: "ip ⇒ ('m ⇒ bool) ⇒ 'm node_action ⇒ bool"
where "arrivemsg i P a ≡ case a of node_arrive ii ni m ⇒ ((ii = {i} ⟶ P m))
| _ ⇒ True"

lemma arrivemsg_simps[simp]:
"⋀R m.       arrivemsg i P (R:*cast(m))         = True"
"⋀d m.       arrivemsg i P (d:deliver(m))       = True"
"⋀i ii ni m. arrivemsg i P (ii¬ni:arrive(m))    = (ii = {i} ⟶ P m)"
"⋀i1 i2.     arrivemsg i P (connect(i1, i2))    = True"
"⋀i1 i2.     arrivemsg i P (disconnect(i1, i2)) = True"
"⋀i i' d di. arrivemsg i P (i':newpkt(d, di))   = True"
"             arrivemsg i P τ⇩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 ⇒ 's) ⇒ 'm ⇒ bool) ⇒ (ip ⇒ 's) ⇒ 'm node_action ⇒ bool"
where "oarrivemsg P σ a ≡ case a of node_arrive ii ni m ⇒ P σ m | _ ⇒ True"

lemma oarrivemsg_simps[simp]:
"⋀R m.       oarrivemsg P σ (R:*cast(m))         = True"
"⋀d m.       oarrivemsg P σ (d:deliver(m))       = True"
"⋀i ii ni m. oarrivemsg P σ (ii¬ni:arrive(m))    = P σ m"
"⋀i1 i2.     oarrivemsg P σ (connect(i1, i2))    = True"
"⋀i1 i2.     oarrivemsg P σ (disconnect(i1, i2)) = True"
"⋀i i' d di. oarrivemsg P σ (i':newpkt(d, di))   = True"
"             oarrivemsg P σ τ⇩n                   = True"
unfolding oarrivemsg_def by simp_all

lemma oarrivemsg_True [simp, intro]: "oarrivemsg (λ_ _. True) σ a"
by (cases a) auto

definition castmsg :: "('m ⇒ bool) ⇒ 'm node_action ⇒ bool"
where "castmsg P a ≡ case a of _:*cast(m) ⇒ P m
| _ ⇒ True"

lemma castmsg_simps[simp]:
"⋀R m.       castmsg P (R:*cast(m))         = P m"
"⋀d m.       castmsg P (d:deliver(m))       = True"
"⋀i ii ni m. castmsg P (ii¬ni:arrive(m))    = True"
"⋀i1 i2.     castmsg P (connect(i1, i2))    = True"
"⋀i1 i2.     castmsg P (disconnect(i1, i2)) = True"
"⋀i i' d di. castmsg P (i':newpkt(d, di))   = True"
"             castmsg P τ⇩n                   = True"
unfolding castmsg_def by simp_all

subsection "Networks"

datatype net_tree =
Node ip "ip set"          ("⟨_; _⟩")
| Subnet net_tree net_tree  (infixl "∥" 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 ⇒ ip set"
where
"net_ips (NodeS i s R) = {i}"
| "net_ips (SubnetS n1 n2) = net_ips n1 ∪ net_ips n2"

fun net_tree_ips :: "net_tree ⇒ ip set"
where
"net_tree_ips (p1 ∥ p2) = net_tree_ips p1 ∪ net_tree_ips p2"
| "net_tree_ips (⟨i; R⟩) = {i}"

lemma net_tree_ips_commute:
"net_tree_ips (p1 ∥ p2) = net_tree_ips (p2 ∥ p1)"
by simp (rule Un_commute)

fun wf_net_tree :: "net_tree ⇒ bool"
where
"wf_net_tree (p1 ∥ p2) = (net_tree_ips p1 ∩ net_tree_ips p2 = {}
∧ wf_net_tree p1 ∧ wf_net_tree p2)"
| "wf_net_tree (⟨i; R⟩) = True"

lemma wf_net_tree_children [elim]:
assumes "wf_net_tree (p1 ∥ p2)"
obtains "wf_net_tree p1"
and "wf_net_tree p2"
using assms by simp

fun netmap :: "'s net_state ⇒ ip ⇒ 's option"
where
"netmap (NodeS i p R⇩i) = [i ↦ p]"
| "netmap (SubnetS s t) = netmap s ++ netmap t"

lemma not_in_netmap [simp]:
assumes "i ∉ 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∉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⇩i and p :: 's
show "net_ips (NodeS i p R⇩i) = dom (netmap (NodeS i p R⇩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 ∈ net_ips ns"
shows "netmap ns i ≠ 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"

lemma netmap_subnets_samef:
assumes "netmap s1 = f"
and "netmap s2 = f"
shows "netmap (SubnetS s1 s2) = f"

assumes "∀i∈net_ips s1 ∪ net_ips s2. the ((netmap s1 ++ netmap s2) i) = σ i"
and "net_ips s1 ∩ net_ips s2 = {}"
shows "∀i∈net_ips s1. the (netmap s1 i) = σ i"
proof
fix i
assume "i ∈ net_ips s1"
hence "i ∈ dom(netmap s1)" by (simp add: net_ips_is_dom_netmap)
moreover with assms(2) have "i ∉ dom(netmap s2)" by (auto simp add: net_ips_is_dom_netmap)
ultimately have "the (netmap s1 i) = the ((netmap s1 ++ netmap s2) i)"
with assms(1) and ‹i∈net_ips s1› show "the (netmap s1 i) = σ i" by simp
qed

assumes "∀i∈net_ips s1 ∪ net_ips s2. the ((netmap s1 ++ netmap s2) i) = σ i"
shows "∀i∈net_ips s2. the (netmap s2 i) = σ i"
using assms by (simp add: net_ips_is_dom_netmap)

lemma net_ips_netmap_subnet [elim]:
assumes "net_ips s1 ∩ net_ips s2 = {}"
and "∀i∈net_ips (SubnetS s1 s2). the (netmap (SubnetS s1 s2) i) = σ i"
shows "∀i∈net_ips s1. the (netmap s1 i) = σ i"
and "∀i∈net_ips s2. the (netmap s2 i) = σ i"
proof -
from assms(2) have "∀i∈net_ips s1 ∪ net_ips s2. the ((netmap s1 ++ netmap s2) i) = σ i" by auto
with assms(1) show "∀i∈net_ips s1. the (netmap s1 i) = σ i"
next
from assms(2) have "∀i∈net_ips s1 ∪ net_ips s2. the ((netmap s1 ++ netmap s2) i) = σ i" by auto
thus "∀i∈net_ips s2. the (netmap s2 i) = σ i"
qed

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

lemma inclosed_simps [simp]:
"⋀σ ii ni. inoclosed σ (ii¬ni:arrive(m))   = eq_newpkt m"
"⋀σ d di.  inoclosed σ (i:newpkt(d, di))   = False"
"⋀σ R m.   inoclosed σ (R:*cast(m))        = True"
"⋀σ i d.   inoclosed σ (i:deliver(d))      = True"
"⋀σ i i'.  inoclosed σ (connect(i, i'))    = True"
"⋀σ i i'.  inoclosed σ (disconnect(i, i')) = True"
"⋀σ.       inoclosed σ (τ)                 = True"
by auto

definition
netmask :: "ip set ⇒ ((ip ⇒ 's) × 'l) ⇒ ((ip ⇒ 's option) × 'l)"
where
"netmask I s ≡ (λi. if i∈I then Some (fst s i) else None, snd s)"

"netmask I (σ, ζ) = (λi. if i∈I then Some (σ i) else None, ζ)"

fun netgmap :: "('s ⇒ 'g × 'l) ⇒ 's net_state ⇒ (nat ⇒ 'g option) × 'l net_state"
where
"netgmap sr (NodeS i s R) = ([i ↦ fst (sr s)], NodeS i (snd (sr s)) R)"
| "netgmap sr (SubnetS s⇩1 s⇩2) = (let (σ⇩1, ss) = netgmap sr s⇩1 in
let (σ⇩2, tt) = netgmap sr s⇩2 in
(σ⇩1 ++ σ⇩2, SubnetS ss tt))"

lemma dom_fst_netgmap [simp, intro]: "dom (fst (netgmap sr n)) = net_ips n"
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 σ⇩1 ζ⇩1 σ⇩2 ζ⇩2 where nm1: "netgmap sr n1 = (σ⇩1, ζ⇩1)"
and nm2: "netgmap sr n2 = (σ⇩2, ζ⇩2)"
by (metis surj_pair)
hence "netgmap sr (SubnetS n1 n2) = (σ⇩1 ++ σ⇩2, SubnetS ζ⇩1 ζ⇩2)" by simp
hence "dom (fst (netgmap sr (SubnetS n1 n2))) = dom (σ⇩1 ++ σ⇩2)" by simp
also from a1 a2 nm1 nm2 have "dom (σ⇩1 ++ σ⇩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 σ ζ where "netgmap sr n = (σ, ζ)"
and "dom σ = 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 ∈ 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 ∉ 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 (σ⇩1, ss) ⇒
case netgmap sr s2 of (σ⇩2, tt) ⇒
(σ⇩1 ++ σ⇩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 (σ⇩1, ss) ⇒
case netgmap sr s2 of (σ⇩2, tt) ⇒
(σ⇩1 ++ σ⇩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 ∈ net_ips s"
shows "fst (netgmap sr s) i ≠ None"
using assms by (induction s) auto

lemma netgmap_netgmap_not_rhs [simp]:
assumes "i ∉ net_ips s2"
shows "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i = (fst (netgmap sr s1)) i"
proof -
from assms(1) have "i ∉ dom (fst (netgmap sr s2))" by simp
qed

lemma netgmap_netgmap_rhs [simp]:
assumes "i ∈ net_ips s2"
shows "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i = (fst (netgmap sr s2)) i"

assumes "netgmap sr s1 = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1))"
and "netgmap sr s2 = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2))"
shows "fst (netgmap sr (SubnetS s1 s2))
= fst (netmask (net_tree_ips (n1 ∥ n2)) (σ, snd (netgmap sr (SubnetS s1 s2))))"
proof (rule ext)
fix i
have "i ∈ net_tree_ips n1 ∨ i ∈ net_tree_ips n2 ∨ (i∉net_tree_ips n1 ∪ net_tree_ips n2)"
by auto
thus "fst (netgmap sr (SubnetS s1 s2)) i
= fst (netmask (net_tree_ips (n1 ∥ n2)) (σ, snd (netgmap sr (SubnetS s1 s2)))) i"
proof (elim disjE)
assume "i ∈ net_tree_ips n1"
with ‹netgmap sr s1 = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1))›
‹netgmap sr s2 = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2))›
show ?thesis
by (cases "netgmap sr s1", cases "netgmap sr s2", clarsimp)
next
assume "i ∈ net_tree_ips n2"
with ‹netgmap sr s2 = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2))›
show ?thesis
by simp (metis (lifting, mono_tags) fst_conv map_add_find_right)
next
assume "i∉net_tree_ips n1 ∪ net_tree_ips n2"
with ‹netgmap sr s1 = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1))›
‹netgmap sr s2 = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2))›
show ?thesis
by simp (metis (lifting, mono_tags) fst_conv)
qed
qed

assumes "netgmap sr s1 = netmask (net_tree_ips n1) (σ, snd (netgmap sr s1))"
and "netgmap sr s2 = netmask (net_tree_ips n2) (σ, snd (netgmap sr s2))"
and "s = SubnetS s1 s2"
shows "netgmap sr s = netmask (net_tree_ips (n1 ∥ n2)) (σ, 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 ∥ n2)) (σ, ζ)"
and "net_tree_ips n1 ∩ 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) (σ, snd (netgmap sr s1))"
proof (rule prod_eqI)
show "fst (netgmap sr s1) = fst (netmask (net_tree_ips n1) (σ, snd (netgmap sr s1)))"
proof (rule ext, simp, intro conjI impI)
fix i
assume "i∈net_tree_ips n1"
with ‹net_tree_ips n1 ∩ net_tree_ips n2 = {}› have "i∉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 ∈ net_tree_ips n1 ∨ i ∈ net_tree_ips n2 then Some (σ i) else None)"
by simp
also from ‹i∉net_tree_ips n2› and ‹net_ips s2 = net_tree_ips n2›
have "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i = fst (netgmap sr s1) i"
finally show "fst (netgmap sr s1) i = Some (σ i)"
using ‹i∈net_tree_ips n1› by simp
next
fix i
assume "i ∉ net_tree_ips n1"
with ‹net_ips s1 = net_tree_ips n1› have "i ∉ 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 ∥ n2)) (σ, ζ)"
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) (σ, snd (netgmap sr s2))"
proof (rule prod_eqI)
show "fst (netgmap sr s2) = fst (netmask (net_tree_ips n2) (σ, snd (netgmap sr s2)))"
proof (rule ext, simp, intro conjI impI)
fix i
assume "i∈net_tree_ips n2"
from assms(1) [simplified prod_eq_iff]
have "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i =
(if i ∈ net_tree_ips n1 ∨ i ∈ net_tree_ips n2 then Some (σ i) else None)"
by simp
also from ‹i∈net_tree_ips n2› and ‹net_ips s2 = net_tree_ips n2›
have "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i = fst (netgmap sr s2) i"
finally show "fst (netgmap sr s2) i = Some (σ i)"
using ‹i∈net_tree_ips n2› by simp
next
fix i
assume "i ∉ net_tree_ips n2"
with ‹net_ips s2 = net_tree_ips n2› have "i ∉ net_ips s2" by simp
thus "fst (netgmap sr s2) i = None" by simp
qed
qed simp

lemma netmap_fst_netgmap_rel:
shows "(λi. map_option (fst o sr) (netmap s i)) = fst (netgmap sr s)"
proof (induction s)
fix ii s R
show "(λi. map_option (fst ∘ sr) (netmap (NodeS ii s R) i)) = fst (netgmap sr (NodeS ii s R))"
by auto
next
fix s1 s2
assume a1: "(λi. map_option (fst ∘ sr) (netmap s1 i)) = fst (netgmap sr s1)"
and a2: "(λi. map_option (fst ∘ sr) (netmap s2 i)) = fst (netgmap sr s2)"
show "(λi. map_option (fst ∘ sr) (netmap (SubnetS s1 s2) i)) = fst (netgmap sr (SubnetS s1 s2))"
proof (rule ext)
fix i
from a1 a2 have "map_option (fst ∘ sr) ((netmap s1 ++ netmap s2) i)
= (fst (netgmap sr s1) ++ fst (netgmap sr s2)) i"
net_ips_is_dom_netmap netgmap_pair_dom)
thus "map_option (fst ∘ 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' i = netmap s i"
shows "fst (netgmap sr s') i = fst (netgmap sr s) i"
using assms by (metis netmap_fst_netgmap_rel)

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

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

text ‹Introduce streamlined alternatives to netgmap to simplify certain property
statements and thus make them easier to understand and to present.›

fun netlift :: "('s ⇒ 'g × 'l) ⇒ 's net_state ⇒ (nat ⇒ 'g option)"
where
"netlift sr (NodeS i s R) = [i ↦ 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 ⇒ 'g × 'l) ⇒ 's net_state ⇒ '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
```