section\<open>Contrived Example\<close>
theory Contrived_Example
imports
  "../../Primitive_Matchers/Parser"
begin

(*
  internal network: 131.159.21.0/24
  DMZ: 131.159.15.240/28
  DMZ must not connect to internal
*)

parse_iptables_save example_fw="iptables-save"

thm example_fw_def
thm example_fw_FORWARD_default_policy_def

lemma "map common_primitive_rule_toString
                  (upper_closure (packet_assume_new
                    (unfold_ruleset_FORWARD example_fw_FORWARD_default_policy
                      (map_of_string_ipv4 example_fw)))) =
[''-i lo -j ACCEPT'',
 ''! -i lo -s 127.0.0.0/8 -j DROP'',
 ''-i inteneral -s 131.159.21.0/24 -j ACCEPT'',
 ''-d 131.159.21.0/24 -s 131.159.15.240/28 -j DROP'',
 ''-p tcp -d 131.159.15.240/28 -j ACCEPT'',
 ''-i dmz -p tcp -s 131.159.15.240/28 -j ACCEPT'',
 '' -j DROP'']" by eval

lemma "map simple_rule_ipv4_toString
              (to_simple_firewall (upper_closure
                (optimize_matches abstract_for_simple_firewall
                  (upper_closure (packet_assume_new
                    (unfold_ruleset_FORWARD example_fw_FORWARD_default_policy
                      (map_of_string_ipv4 example_fw))))))) =
[''ACCEPT     all  --  0.0.0.0/0            0.0.0.0/0 in: lo   '',
  ''ACCEPT     all  --  131.159.21.0/24            0.0.0.0/0 in: inteneral   '',
  ''DROP     all  --  131.159.15.240/28            131.159.21.0/24    '',
  ''ACCEPT     tcp  --  0.0.0.0/0            131.159.15.240/28    '',
  ''ACCEPT     tcp  --  131.159.15.240/28            0.0.0.0/0 in: dmz   '',
  ''DROP     all  --  0.0.0.0/0            0.0.0.0/0    '']" by eval

lemma "map simple_rule_ipv4_toString
              (to_simple_firewall_without_interfaces ipassmt_generic_ipv4 None (upper_closure
                (optimize_matches abstract_for_simple_firewall
                  (upper_closure (packet_assume_new
                    (unfold_ruleset_FORWARD example_fw_FORWARD_default_policy
                      (map_of_string_ipv4 example_fw))))))) =
[''ACCEPT     all  --  127.0.0.0/8            0.0.0.0/0    '',
  ''ACCEPT     all  --  131.159.21.0/24            0.0.0.0/0    '',
  ''DROP     all  --  131.159.15.240/28            131.159.21.0/24    '',
  ''ACCEPT     tcp  --  0.0.0.0/0            131.159.15.240/28    '',
  ''ACCEPT     tcp  --  131.159.15.240/28            0.0.0.0/0    '',
  ''DROP     all  --  0.0.0.0/0            0.0.0.0/0    '']" by eval

lemma "access_matrix_pretty_ipv4 parts_connection_ssh
              (to_simple_firewall_without_interfaces ipassmt_generic_ipv4 None (upper_closure
                (optimize_matches abstract_for_simple_firewall
                  (upper_closure (packet_assume_new
                    (unfold_ruleset_FORWARD example_fw_FORWARD_default_policy
                      (map_of_string_ipv4 example_fw))))))) =
([(''131.159.21.0'', ''{131.159.21.0 .. 131.159.21.255}''),
   (''131.159.15.240'', ''{131.159.15.240 .. 131.159.15.255}''),
   (''127.0.0.0'', ''{127.0.0.0 .. 127.255.255.255}''),
   (''0.0.0.0'', ''{0.0.0.0 .. 126.255.255.255} u {128.0.0.0 .. 131.159.15.239} u {131.159.16.0 .. 131.159.20.255} u {131.159.22.0 .. 255.255.255.255}'')],

  [(''131.159.21.0'', ''131.159.21.0''), (''131.159.21.0'', ''131.159.15.240''),
   (''131.159.21.0'', ''127.0.0.0''), (''131.159.21.0'', ''0.0.0.0''),
   (''131.159.15.240'', ''131.159.15.240''), (''131.159.15.240'', ''127.0.0.0''),
   (''131.159.15.240'', ''0.0.0.0''), (''127.0.0.0'', ''131.159.21.0''), (''127.0.0.0'', ''131.159.15.240''),
   (''127.0.0.0'', ''127.0.0.0''), (''127.0.0.0'', ''0.0.0.0''), (''0.0.0.0'', ''131.159.15.240'')])"
by eval

(*
a |-> {131.159.21.0 .. 131.159.21.255}
b |-> {131.159.15.240 .. 131.159.15.255}
c |-> {127.0.0.0 .. 127.255.255.255}
d |-> {0.0.0.0 .. 126.255.255.255} \<union> {128.0.0.0 .. 131.159.15.239} \<union> {131.159.16.0 .. 131.159.20.255} \<union> {131.159.22.0 .. 255.255.255.255}

(a,a)
(a,b)
(a,c)
(a,d)
(b,b)
(b,c)
(b,d)
(c,a)
(c,b)
(c,c)
(c,d)
(d,b)

*)

end


theory Benchmark_Set_LC
imports
  Benchmark_Set
  "../Set_Impl"
  "~~/src/HOL/Library/Code_Target_Nat"
begin

lemma [code_unfold del]: "card \<equiv> Cardinality.card'" by(simp)

instantiation word :: (len0) ceq begin
definition "CEQ('a word) = Some op ="
instance by(intro_classes)(simp add: ceq_word_def)
end

instantiation word :: (len0) corder begin
definition "CORDER('a word) = Some (op \<le>, op <)"
instance by(intro_classes)(simp add: corder_word_def, unfold_locales)
end

instantiation word :: (len0) set_impl begin
definition "SET_IMPL('a word) = Phantom('a word) set_RBT"
instance ..
end

instantiation word :: (len) proper_interval begin
fun proper_interval_word :: "'a word option \<Rightarrow> 'a word option \<Rightarrow> bool"
where
  "proper_interval_word None None = True"
| "proper_interval_word None (Some y) = (y \<noteq> 0)"
| "proper_interval_word (Some x) None = (x \<noteq> max_word)"
| "proper_interval_word (Some x) (Some y) = (x < y \<and> x \<noteq> y - 1)"
instance
proof(intro_classes)
  let ?pi = "proper_interval :: 'a word proper_interval"
  show "?pi None None = True" by simp
  fix y
  show "?pi None (Some y) = (\<exists>z. z < y)"
    by simp (metis word_gt_0 word_not_simps(1))
  fix x
  show "?pi (Some x) None = (\<exists>z. x < z)"
    by simp (metis eq_iff max_word_max not_le)

  have "(x < y \<and> x \<noteq> y - 1) = (\<exists>z>x. z < y)" (is "?lhs \<longleftrightarrow> ?rhs")
  proof
    assume ?lhs
    then obtain "x < y" "x \<noteq> y - 1" ..
    have "0 \<le> uint x" by simp
    also have "\<dots> < uint y" using `x < y` by(simp add: word_less_def)
    finally have y: "y - 1 < y" by(simp add: word_less_def uint_sub_if' not_le)
    moreover from `0 < uint y` `x < y` `x \<noteq> y - 1`
    have "x < y - 1" by(simp add: word_less_def uint_sub_if' uint_arith_simps(3))
    ultimately show ?rhs by blast
  next
    assume ?rhs
    then obtain z where z: "x < z" "z < y" by blast
    have "0 \<le> uint z" by simp
    also have "\<dots> < uint y" using `z < y` by(simp add: word_less_def)
    finally show ?lhs using z by(auto simp add: word_less_def uint_sub_if')
  qed
  thus "?pi (Some x) (Some y) = (\<exists>z>x. z < y)" by simp
qed
end

instantiation word :: (len) cproper_interval begin
definition "cproper_interval = (proper_interval :: 'a word proper_interval)"
instance by intro_classes (simp add: cproper_interval_word_def corder_word_def ID_Some proper_interval_class.axioms)
end

instantiation word :: (len0) cenum begin
definition "CENUM('a word) = None"
instance by(intro_classes)(simp_all add: cEnum_word_def)
end

notepad begin
  have "complete 30 40 (12345, 67899) = (32, 4294967296)" by eval
end

end


(*  Title:      HOL/Auth/Guard/Proto.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2002  University of Cambridge
*)

section\<open>Other Protocol-Independent Results\<close>

theory Proto imports Guard_Public begin

subsection\<open>protocols\<close>

type_synonym rule = "event set * event"

abbreviation
  msg' :: "rule => msg" where
  "msg' R == msg (snd R)"

type_synonym proto = "rule set"

definition wdef :: "proto => bool" where
"wdef p \<equiv> \<forall>R k. R \<in> p \<longrightarrow> Number k \<in> parts {msg' R}
\<longrightarrow> Number k \<in> parts (msg`(fst R))"

subsection\<open>substitutions\<close>

record subs =
  agent   :: "agent => agent"
  nonce :: "nat => nat"
  nb    :: "nat => msg"
  key   :: "key => key"

primrec apm :: "subs => msg => msg" where
  "apm s (Agent A) = Agent (agent s A)"
| "apm s (Nonce n) = Nonce (nonce s n)"
| "apm s (Number n) = nb s n"
| "apm s (Key K) = Key (key s K)"
| "apm s (Hash X) = Hash (apm s X)"
| "apm s (Crypt K X) = (
if (\<exists>A. K = pubK A) then Crypt (pubK (agent s (agt K))) (apm s X)
else if (\<exists>A. K = priK A) then Crypt (priK (agent s (agt K))) (apm s X)
else Crypt (key s K) (apm s X))"
| "apm s \<lbrace>X,Y\<rbrace> = \<lbrace>apm s X, apm s Y\<rbrace>"

lemma apm_parts: "X \<in> parts {Y} \<Longrightarrow> apm s X \<in> parts {apm s Y}"
apply (erule parts.induct, simp_all, blast)
apply (erule parts.Fst)
apply (erule parts.Snd)
by (erule parts.Body)+

lemma Nonce_apm [rule_format]: "Nonce n \<in> parts {apm s X} \<Longrightarrow>
(\<forall>k. Number k \<in> parts {X} \<longrightarrow> Nonce n \<notin> parts {nb s k}) \<longrightarrow>
(\<exists>k. Nonce k \<in> parts {X} \<and> nonce s k = n)"
by (induct X, simp_all, blast)

lemma wdef_Nonce: "\<lbrakk>Nonce n \<in> parts {apm s X}; R \<in> p; msg' R = X; wdef p;
Nonce n \<notin> parts (apm s `(msg `(fst R)))\<rbrakk> \<Longrightarrow>
(\<exists>k. Nonce k \<in> parts {X} \<and> nonce s k = n)"
apply (erule Nonce_apm, unfold wdef_def)
apply (drule_tac x=R in spec, drule_tac x=k in spec, clarsimp)
apply (drule_tac x=x in bspec, simp)
apply (drule_tac Y="msg x" and s=s in apm_parts, simp)
by (blast dest: parts_parts)

primrec ap :: "subs \<Rightarrow> event \<Rightarrow> event" where
  "ap s (Says A B X) = Says (agent s A) (agent s B) (apm s X)"
| "ap s (Gets A X) = Gets (agent s A) (apm s X)"
| "ap s (Notes A X) = Notes (agent s A) (apm s X)"

abbreviation
  ap' :: "subs \<Rightarrow> rule \<Rightarrow> event" where
  "ap' s R \<equiv> ap s (snd R)"

abbreviation
  apm' :: "subs \<Rightarrow> rule \<Rightarrow> msg" where
  "apm' s R \<equiv> apm s (msg' R)"

abbreviation
  priK' :: "subs \<Rightarrow> agent \<Rightarrow> key" where
  "priK' s A \<equiv> priK (agent s A)"

abbreviation
  pubK' :: "subs \<Rightarrow> agent \<Rightarrow> key" where
  "pubK' s A \<equiv> pubK (agent s A)"

subsection\<open>nonces generated by a rule\<close>

definition newn :: "rule \<Rightarrow> nat set" where
"newn R \<equiv> {n. Nonce n \<in> parts {msg (snd R)} \<and> Nonce n \<notin> parts (msg`(fst R))}"

lemma newn_parts: "n \<in> newn R \<Longrightarrow> Nonce (nonce s n) \<in> parts {apm' s R}"
by (auto simp: newn_def dest: apm_parts)

subsection\<open>traces generated by a protocol\<close>

definition ok :: "event list \<Rightarrow> rule \<Rightarrow> subs \<Rightarrow> bool" where
"ok evs R s \<equiv> ((\<forall>x. x \<in> fst R \<longrightarrow> ap s x \<in> set evs)
\<and> (\<forall>n. n \<in> newn R \<longrightarrow> Nonce (nonce s n) \<notin> used evs))"

inductive_set
  tr :: "proto => event list set"
  for p :: proto
where

  Nil [intro]: "[] \<in> tr p"

| Fake [intro]: "\<lbrakk>evsf \<in> tr p; X \<in> synth (analz (spies evsf))\<rbrakk>
  \<Longrightarrow> Says Spy B X # evsf \<in> tr p"

| Proto [intro]: "\<lbrakk>evs \<in> tr p; R \<in> p; ok evs R s\<rbrakk> \<Longrightarrow> ap' s R # evs \<in> tr p"

subsection\<open>general properties\<close>

lemma one_step_tr [iff]: "one_step (tr p)"
apply (unfold one_step_def, clarify)
by (ind_cases "ev # evs \<in> tr p" for ev evs, auto)

definition has_only_Says' :: "proto => bool" where
"has_only_Says' p \<equiv> \<forall>R. R \<in> p \<longrightarrow> is_Says (snd R)"

lemma has_only_Says'D: "\<lbrakk>R \<in> p; has_only_Says' p\<rbrakk>
\<Longrightarrow> (\<exists>A B X. snd R = Says A B X)"
by (unfold has_only_Says'_def is_Says_def, blast)

lemma has_only_Says_tr [simp]: "has_only_Says' p \<Longrightarrow> has_only_Says (tr p)"
unfolding has_only_Says_def
apply (rule allI, rule allI, rule impI)
apply (erule tr.induct)
apply (auto simp: has_only_Says'_def ok_def)
by (drule_tac x=a in spec, auto simp: is_Says_def)

lemma has_only_Says'_in_trD: "\<lbrakk>has_only_Says' p; list @ ev # evs1 \<in> tr p\<rbrakk>
\<Longrightarrow> (\<exists>A B X. ev = Says A B X)"
by (drule has_only_Says_tr, auto)

lemma ok_not_used: "\<lbrakk>Nonce n \<notin> used evs; ok evs R s;
\<forall>x. x \<in> fst R \<longrightarrow> is_Says x\<rbrakk> \<Longrightarrow> Nonce n \<notin> parts (apm s `(msg `(fst R)))"
apply (unfold ok_def, clarsimp)
apply (drule_tac x=x in spec, drule_tac x=x in spec)
by (auto simp: is_Says_def dest: Says_imp_spies not_used_not_spied parts_parts)

lemma ok_is_Says: "\<lbrakk>evs' @ ev # evs \<in> tr p; ok evs R s; has_only_Says' p;
R \<in> p; x \<in> fst R\<rbrakk> \<Longrightarrow> is_Says x"
apply (unfold ok_def is_Says_def, clarify)
apply (drule_tac x=x in spec, simp)
apply (subgoal_tac "one_step (tr p)")
apply (drule trunc, simp, drule one_step_Cons, simp)
apply (drule has_only_SaysD, simp+)
by (clarify, case_tac x, auto)

subsection\<open>types\<close>

type_synonym keyfun = "rule \<Rightarrow> subs \<Rightarrow> nat \<Rightarrow> event list \<Rightarrow> key set"

type_synonym secfun = "rule \<Rightarrow> nat \<Rightarrow> subs \<Rightarrow> key set \<Rightarrow> msg"

subsection\<open>introduction of a fresh guarded nonce\<close>

definition fresh :: "proto \<Rightarrow> rule \<Rightarrow> subs \<Rightarrow> nat \<Rightarrow> key set \<Rightarrow> event list
\<Rightarrow> bool" where
"fresh p R s n Ks evs \<equiv> (\<exists>evs1 evs2. evs = evs2 @ ap' s R # evs1
\<and> Nonce n \<notin> used evs1 \<and> R \<in> p \<and> ok evs1 R s \<and> Nonce n \<in> parts {apm' s R}
\<and> apm' s R \<in> guard n Ks)"

lemma freshD: "fresh p R s n Ks evs \<Longrightarrow> (\<exists>evs1 evs2.
evs = evs2 @ ap' s R # evs1 \<and> Nonce n \<notin> used evs1 \<and> R \<in> p \<and> ok evs1 R s
\<and> Nonce n \<in> parts {apm' s R} \<and> apm' s R \<in> guard n Ks)"
  unfolding fresh_def by blast

lemma freshI [intro]: "\<lbrakk>Nonce n \<notin> used evs1; R \<in> p; Nonce n \<in> parts {apm' s R};
ok evs1 R s; apm' s R \<in> guard n Ks\<rbrakk>
\<Longrightarrow> fresh p R s n Ks (list @ ap' s R # evs1)"
  unfolding fresh_def by blast

lemma freshI': "\<lbrakk>Nonce n \<notin> used evs1; (l,r) \<in> p;
Nonce n \<in> parts {apm s (msg r)}; ok evs1 (l,r) s; apm s (msg r) \<in> guard n Ks\<rbrakk>
\<Longrightarrow> fresh p (l,r) s n Ks (evs2 @ ap s r # evs1)"
by (drule freshI, simp+)

lemma fresh_used: "\<lbrakk>fresh p R' s' n Ks evs; has_only_Says' p\<rbrakk>
\<Longrightarrow> Nonce n \<in> used evs"
apply (unfold fresh_def, clarify)
apply (drule has_only_Says'D)
by (auto intro: parts_used_app)

lemma fresh_newn: "\<lbrakk>evs' @ ap' s R # evs \<in> tr p; wdef p; has_only_Says' p;
Nonce n \<notin> used evs; R \<in> p; ok evs R s; Nonce n \<in> parts {apm' s R}\<rbrakk>
\<Longrightarrow> \<exists>k. k \<in> newn R \<and> nonce s k = n"
apply (drule wdef_Nonce, simp+)
apply (frule ok_not_used, simp+)
apply (clarify, erule ok_is_Says, simp+)
apply (clarify, rule_tac x=k in exI, simp add: newn_def)
apply (clarify, drule_tac Y="msg x" and s=s in apm_parts)
apply (drule ok_not_used, simp+)
by (clarify, erule ok_is_Says, simp_all)

lemma fresh_rule: "\<lbrakk>evs' @ ev # evs \<in> tr p; wdef p; Nonce n \<notin> used evs;
Nonce n \<in> parts {msg ev}\<rbrakk> \<Longrightarrow> \<exists>R s. R \<in> p \<and> ap' s R = ev"
apply (drule trunc, simp, ind_cases "ev # evs \<in> tr p", simp)
by (drule_tac x=X in in_sub, drule parts_sub, simp, simp, blast+)

lemma fresh_ruleD: "\<lbrakk>fresh p R' s' n Ks evs; keys R' s' n evs \<subseteq> Ks; wdef p;
has_only_Says' p; evs \<in> tr p; \<forall>R k s. nonce s k = n \<longrightarrow> Nonce n \<in> used evs \<longrightarrow>
R \<in> p \<longrightarrow> k \<in> newn R \<longrightarrow> Nonce n \<in> parts {apm' s R} \<longrightarrow> apm' s R \<in> guard n Ks \<longrightarrow>
apm' s R \<in> parts (spies evs) \<longrightarrow> keys R s n evs \<subseteq> Ks \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
apply (frule fresh_used, simp)
apply (unfold fresh_def, clarify)
apply (drule_tac x=R' in spec)
apply (drule fresh_newn, simp+, clarify)
apply (drule_tac x=k in spec)
apply (drule_tac x=s' in spec)
apply (subgoal_tac "apm' s' R' \<in> parts (spies (evs2 @ ap' s' R' # evs1))")
apply (case_tac R', drule has_only_Says'D, simp, clarsimp)
apply (case_tac R', drule has_only_Says'D, simp, clarsimp)
apply (rule_tac Y="apm s' X" in parts_parts, blast)
by (rule parts.Inj, rule Says_imp_spies, simp, blast)

subsection\<open>safe keys\<close>

definition safe :: "key set \<Rightarrow> msg set \<Rightarrow> bool" where
"safe Ks G \<equiv> \<forall>K. K \<in> Ks \<longrightarrow> Key K \<notin> analz G"

lemma safeD [dest]: "\<lbrakk>safe Ks G; K \<in> Ks\<rbrakk> \<Longrightarrow> Key K \<notin> analz G"
  unfolding safe_def by blast

lemma safe_insert: "safe Ks (insert X G) \<Longrightarrow> safe Ks G"
  unfolding safe_def by blast

lemma Guard_safe: "\<lbrakk>Guard n Ks G; safe Ks G\<rbrakk> \<Longrightarrow> Nonce n \<notin> analz G"
by (blast dest: Guard_invKey)

subsection\<open>guardedness preservation\<close>

definition preserv :: "proto \<Rightarrow> keyfun \<Rightarrow> nat \<Rightarrow> key set \<Rightarrow> bool" where
"preserv p keys n Ks \<equiv> (\<forall>evs R' s' R s. evs \<in> tr p \<longrightarrow>
Guard n Ks (spies evs) \<longrightarrow> safe Ks (spies evs) \<longrightarrow> fresh p R' s' n Ks evs \<longrightarrow>
keys R' s' n evs \<subseteq> Ks \<longrightarrow> R \<in> p \<longrightarrow> ok evs R s \<longrightarrow> apm' s R \<in> guard n Ks)"

lemma preservD: "\<lbrakk>preserv p keys n Ks; evs \<in> tr p; Guard n Ks (spies evs);
safe Ks (spies evs); fresh p R' s' n Ks evs; R \<in> p; ok evs R s;
keys R' s' n evs \<subseteq> Ks\<rbrakk> \<Longrightarrow> apm' s R \<in> guard n Ks"
  unfolding preserv_def by blast

lemma preservD': "\<lbrakk>preserv p keys n Ks; evs \<in> tr p; Guard n Ks (spies evs);
safe Ks (spies evs); fresh p R' s' n Ks evs; (l,Says A B X) \<in> p;
ok evs (l,Says A B X) s; keys R' s' n evs \<subseteq> Ks\<rbrakk> \<Longrightarrow> apm s X \<in> guard n Ks"
by (drule preservD, simp+)

subsection\<open>monotonic keyfun\<close>

definition monoton :: "proto => keyfun => bool" where
"monoton p keys \<equiv> \<forall>R' s' n ev evs. ev # evs \<in> tr p \<longrightarrow>
keys R' s' n evs \<subseteq> keys R' s' n (ev # evs)"

lemma monotonD [dest]: "\<lbrakk>keys R' s' n (ev # evs) \<subseteq> Ks; monoton p keys;
ev # evs \<in> tr p\<rbrakk> \<Longrightarrow> keys R' s' n evs \<subseteq> Ks"
  unfolding monoton_def by blast

subsection\<open>guardedness theorem\<close>

lemma Guard_tr [rule_format]: "\<lbrakk>evs \<in> tr p; has_only_Says' p;
preserv p keys n Ks; monoton p keys; Guard n Ks (initState Spy)\<rbrakk> \<Longrightarrow>
safe Ks (spies evs) \<longrightarrow> fresh p R' s' n Ks evs \<longrightarrow> keys R' s' n evs \<subseteq> Ks \<longrightarrow>
Guard n Ks (spies evs)"
apply (erule tr.induct)
(* Nil *)
apply simp
(* Fake *)
apply (clarify, drule freshD, clarsimp)
apply (case_tac evs2)
(* evs2 = [] *)
apply (frule has_only_Says'D, simp)
apply (clarsimp, blast)
(* evs2 = aa # list *)
apply (clarsimp, rule conjI)
apply (blast dest: safe_insert)
(* X:guard n Ks *)
apply (rule in_synth_Guard, simp, rule Guard_analz)
apply (blast dest: safe_insert)
apply (drule safe_insert, simp add: safe_def)
(* Proto *)
apply (clarify, drule freshD, clarify)
apply (case_tac evs2)
(* evs2 = [] *)
apply (frule has_only_Says'D, simp)
apply (frule_tac R=R' in has_only_Says'D, simp)
apply (case_tac R', clarsimp, blast)
(* evs2 = ab # list *)
apply (frule has_only_Says'D, simp)
apply (clarsimp, rule conjI)
apply (drule Proto, simp+, blast dest: safe_insert)
(* apm s X:guard n Ks *)
apply (frule Proto, simp+)
apply (erule preservD', simp+)
apply (blast dest: safe_insert)
apply (blast dest: safe_insert)
by (blast, simp, simp, blast)

subsection\<open>useful properties for guardedness\<close>

lemma newn_neq_used: "\<lbrakk>Nonce n \<in> used evs; ok evs R s; k \<in> newn R\<rbrakk>
\<Longrightarrow> n \<noteq> nonce s k"
by (auto simp: ok_def)

lemma ok_Guard: "\<lbrakk>ok evs R s; Guard n Ks (spies evs); x \<in> fst R; is_Says x\<rbrakk>
\<Longrightarrow> apm s (msg x) \<in> parts (spies evs) \<and> apm s (msg x) \<in> guard n Ks"
apply (unfold ok_def is_Says_def, clarify)
apply (drule_tac x="Says A B X" in spec, simp)
by (drule Says_imp_spies, auto intro: parts_parts)

lemma ok_parts_not_new: "\<lbrakk>Y \<in> parts (spies evs); Nonce (nonce s n) \<in> parts {Y};
ok evs R s\<rbrakk> \<Longrightarrow> n \<notin> newn R"
by (auto simp: ok_def dest: not_used_not_spied parts_parts)

subsection\<open>unicity\<close>

definition uniq :: "proto \<Rightarrow> secfun \<Rightarrow> bool" where
"uniq p secret \<equiv> \<forall>evs R R' n n' Ks s s'. R \<in> p \<longrightarrow> R' \<in> p \<longrightarrow>
n \<in> newn R \<longrightarrow> n' \<in> newn R' \<longrightarrow> nonce s n = nonce s' n' \<longrightarrow>
Nonce (nonce s n) \<in> parts {apm' s R} \<longrightarrow> Nonce (nonce s n) \<in> parts {apm' s' R'} \<longrightarrow>
apm' s R \<in> guard (nonce s n) Ks \<longrightarrow> apm' s' R' \<in> guard (nonce s n) Ks \<longrightarrow>
evs \<in> tr p \<longrightarrow> Nonce (nonce s n) \<notin> analz (spies evs) \<longrightarrow>
secret R n s Ks \<in> parts (spies evs) \<longrightarrow> secret R' n' s' Ks \<in> parts (spies evs) \<longrightarrow>
secret R n s Ks = secret R' n' s' Ks"

lemma uniqD: "\<lbrakk>uniq p secret; evs \<in> tr p; R \<in> p; R' \<in> p; n \<in> newn R; n' \<in> newn R';
nonce s n = nonce s' n'; Nonce (nonce s n) \<notin> analz (spies evs);
Nonce (nonce s n) \<in> parts {apm' s R}; Nonce (nonce s n) \<in> parts {apm' s' R'};
secret R n s Ks \<in> parts (spies evs); secret R' n' s' Ks \<in> parts (spies evs);
apm' s R \<in> guard (nonce s n) Ks; apm' s' R' \<in> guard (nonce s n) Ks\<rbrakk> \<Longrightarrow>
secret R n s Ks = secret R' n' s' Ks"
  unfolding uniq_def by blast

definition ord :: "proto \<Rightarrow> (rule \<Rightarrow> rule \<Rightarrow> bool) \<Rightarrow> bool" where
"ord p inff \<equiv> \<forall>R R'. R \<in> p \<longrightarrow> R' \<in> p \<longrightarrow> \<not> inff R R' \<longrightarrow> inff R' R"

lemma ordD: "\<lbrakk>ord p inff; \<not> inff R R'; R \<in> p; R' \<in> p\<rbrakk> \<Longrightarrow> inff R' R"
  unfolding ord_def by blast

definition uniq' :: "proto \<Rightarrow> (rule \<Rightarrow> rule \<Rightarrow> bool) \<Rightarrow> secfun \<Rightarrow> bool" where
"uniq' p inff secret \<equiv> \<forall>evs R R' n n' Ks s s'. R \<in> p \<longrightarrow> R' \<in> p \<longrightarrow>
inff R R' \<longrightarrow> n \<in> newn R \<longrightarrow> n' \<in> newn R' \<longrightarrow> nonce s n = nonce s' n' \<longrightarrow>
Nonce (nonce s n) \<in> parts {apm' s R} \<longrightarrow> Nonce (nonce s n) \<in> parts {apm' s' R'} \<longrightarrow>
apm' s R \<in> guard (nonce s n) Ks \<longrightarrow> apm' s' R' \<in> guard (nonce s n) Ks \<longrightarrow>
evs \<in> tr p \<longrightarrow> Nonce (nonce s n) \<notin> analz (spies evs) \<longrightarrow>
secret R n s Ks \<in> parts (spies evs) \<longrightarrow> secret R' n' s' Ks \<in> parts (spies evs) \<longrightarrow>
secret R n s Ks = secret R' n' s' Ks"

lemma uniq'D: "\<lbrakk>uniq' p inff secret; evs \<in> tr p; inff R R'; R \<in> p; R' \<in> p; n \<in> newn R;
n' \<in> newn R'; nonce s n = nonce s' n'; Nonce (nonce s n) \<notin> analz (spies evs);
Nonce (nonce s n) \<in> parts {apm' s R}; Nonce (nonce s n) \<in> parts {apm' s' R'};
secret R n s Ks \<in> parts (spies evs); secret R' n' s' Ks \<in> parts (spies evs);
apm' s R \<in> guard (nonce s n) Ks; apm' s' R' \<in> guard (nonce s n) Ks\<rbrakk> \<Longrightarrow>
secret R n s Ks = secret R' n' s' Ks"
by (unfold uniq'_def, blast)

lemma uniq'_imp_uniq: "\<lbrakk>uniq' p inff secret; ord p inff\<rbrakk> \<Longrightarrow> uniq p secret"
unfolding uniq_def
apply (rule allI)+
apply (case_tac "inff R R'")
apply (blast dest: uniq'D)
by (auto dest: ordD uniq'D intro: sym)

subsection\<open>Needham-Schroeder-Lowe\<close>

definition a :: agent where "a == Friend 0"
definition b :: agent where "b == Friend 1"
definition a' :: agent where "a' == Friend 2"
definition b' :: agent where "b' == Friend 3"
definition Na :: nat where "Na == 0"
definition Nb :: nat where "Nb == 1"

abbreviation
  ns1 :: rule where
  "ns1 == ({}, Says a b (Crypt (pubK b) \<lbrace>Nonce Na, Agent a\<rbrace>))"

abbreviation
  ns2 :: rule where
  "ns2 == ({Says a' b (Crypt (pubK b) \<lbrace>Nonce Na, Agent a\<rbrace>)},
    Says b a (Crypt (pubK a) \<lbrace>Nonce Na, Nonce Nb, Agent b\<rbrace>))"

abbreviation
  ns3 :: rule where
  "ns3 == ({Says a b (Crypt (pubK b) \<lbrace>Nonce Na, Agent a\<rbrace>),
    Says b' a (Crypt (pubK a) \<lbrace>Nonce Na, Nonce Nb, Agent b\<rbrace>)},
    Says a b (Crypt (pubK b) (Nonce Nb)))"

inductive_set ns :: proto where
  [iff]: "ns1 \<in> ns"
| [iff]: "ns2 \<in> ns"
| [iff]: "ns3 \<in> ns"

abbreviation (input)
  ns3a :: event where
  "ns3a == Says a b (Crypt (pubK b) \<lbrace>Nonce Na, Agent a\<rbrace>)"

abbreviation (input)
  ns3b :: event where
  "ns3b == Says b' a (Crypt (pubK a) \<lbrace>Nonce Na, Nonce Nb, Agent b\<rbrace>)"

definition keys :: "keyfun" where
"keys R' s' n evs == {priK' s' a, priK' s' b}"

lemma "monoton ns keys"
by (simp add: keys_def monoton_def)

definition secret :: "secfun" where
"secret R n s Ks ==
(if R=ns1 then apm s (Crypt (pubK b) \<lbrace>Nonce Na, Agent a\<rbrace>)
else if R=ns2 then apm s (Crypt (pubK a) \<lbrace>Nonce Na, Nonce Nb, Agent b\<rbrace>)
else Number 0)"

definition inf :: "rule => rule => bool" where
"inf R R' == (R=ns1 | (R=ns2 & R'~=ns1) | (R=ns3 & R'=ns3))"

lemma inf_is_ord [iff]: "ord ns inf"
apply (unfold ord_def inf_def)
apply (rule allI)+
apply (rule impI)
apply (simp add: split_paired_all)
by (rule impI, erule ns.cases, simp_all)+

subsection\<open>general properties\<close>

lemma ns_has_only_Says' [iff]: "has_only_Says' ns"
apply (unfold has_only_Says'_def)
apply (rule allI, rule impI)
apply (simp add: split_paired_all)
by (erule ns.cases, auto)

lemma newn_ns1 [iff]: "newn ns1 = {Na}"
by (simp add: newn_def)

lemma newn_ns2 [iff]: "newn ns2 = {Nb}"
by (auto simp: newn_def Na_def Nb_def)

lemma newn_ns3 [iff]: "newn ns3 = {}"
by (auto simp: newn_def)

lemma ns_wdef [iff]: "wdef ns"
by (auto simp: wdef_def elim: ns.cases)

subsection\<open>guardedness for NSL\<close>

lemma "uniq ns secret \<Longrightarrow> preserv ns keys n Ks"
unfolding preserv_def
apply (rule allI)+
apply (rule impI, rule impI, rule impI, rule impI, rule impI)
apply (erule fresh_ruleD, simp, simp, simp, simp)
apply (rule allI)+
apply (rule impI, rule impI, rule impI)
apply (simp add: split_paired_all)
apply (erule ns.cases)
(* fresh with NS1 *)
apply (rule impI, rule impI, rule impI, rule impI, rule impI, rule impI)
apply (erule ns.cases)
(* NS1 *)
apply clarsimp
apply (frule newn_neq_used, simp, simp)
apply (rule No_Nonce, simp)
(* NS2 *)
apply clarsimp
apply (frule newn_neq_used, simp, simp)
apply (case_tac "nonce sa Na = nonce s Na")
apply (frule Guard_safe, simp)
apply (frule Crypt_guard_invKey, simp)
apply (frule ok_Guard, simp, simp, simp, clarsimp)
apply (frule_tac K="pubK' s b" in Crypt_guard_invKey, simp)
apply (frule_tac R=ns1 and R'=ns1 and Ks=Ks and s=sa and s'=s in uniqD, simp+)
apply (simp add: secret_def, simp add: secret_def, force, force)
apply (simp add: secret_def keys_def, blast)
apply (rule No_Nonce, simp)
(* NS3 *)
apply clarsimp
apply (case_tac "nonce sa Na = nonce s Nb")
apply (frule Guard_safe, simp)
apply (frule Crypt_guard_invKey, simp)
apply (frule_tac x=ns3b in ok_Guard, simp, simp, simp, clarsimp)
apply (frule_tac K="pubK' s a" in Crypt_guard_invKey, simp)
apply (frule_tac R=ns1 and R'=ns2 and Ks=Ks and s=sa and s'=s in uniqD, simp+)
apply (simp add: secret_def, simp add: secret_def, force, force)
apply (simp add: secret_def, rule No_Nonce, simp)
(* fresh with NS2 *)
apply (rule impI, rule impI, rule impI, rule impI, rule impI, rule impI)
apply (erule ns.cases)
(* NS1 *)
apply clarsimp
apply (frule newn_neq_used, simp, simp)
apply (rule No_Nonce, simp)
(* NS2 *)
apply clarsimp
apply (frule newn_neq_used, simp, simp)
apply (case_tac "nonce sa Nb = nonce s Na")
apply (frule Guard_safe, simp)
apply (frule Crypt_guard_invKey, simp)
apply (frule ok_Guard, simp, simp, simp, clarsimp)
apply (frule_tac K="pubK' s b" in Crypt_guard_invKey, simp)
apply (frule_tac R=ns2 and R'=ns1 and Ks=Ks and s=sa and s'=s in uniqD, simp+)
apply (simp add: secret_def, simp add: secret_def, force, force)
apply (simp add: secret_def, rule No_Nonce, simp)
(* NS3 *)
apply clarsimp
apply (case_tac "nonce sa Nb = nonce s Nb")
apply (frule Guard_safe, simp)
apply (frule Crypt_guard_invKey, simp)
apply (frule_tac x=ns3b in ok_Guard, simp, simp, simp, clarsimp)
apply (frule_tac K="pubK' s a" in Crypt_guard_invKey, simp)
apply (frule_tac R=ns2 and R'=ns2 and Ks=Ks and s=sa and s'=s in uniqD, simp+)
apply (simp add: secret_def, simp add: secret_def, force, force)
apply (simp add: secret_def keys_def, blast)
apply (rule No_Nonce, simp)
(* fresh with NS3 *)
by simp

subsection\<open>unicity for NSL\<close>

lemma "uniq' ns inf secret"
apply (unfold uniq'_def)
apply (rule allI)+
apply (simp add: split_paired_all)
apply (rule impI, erule ns.cases)
(* R = ns1 *)
apply (rule impI, erule ns.cases)
(* R' = ns1 *)
apply (rule impI, rule impI, rule impI, rule impI)
apply (rule impI, rule impI, rule impI, rule impI)
apply (rule impI, erule tr.induct)
(* Nil *)
apply (simp add: secret_def)
(* Fake *)
apply (clarify, simp add: secret_def)
apply (drule notin_analz_insert)
apply (drule Crypt_insert_synth, simp, simp, simp)
apply (drule Crypt_insert_synth, simp, simp, simp, simp)
(* Proto *)
apply (erule_tac P="ok evsa R sa" in rev_mp)
apply (simp add: split_paired_all)
apply (erule ns.cases)
(* ns1 *)
apply (clarify, simp add: secret_def)
apply (erule disjE, erule disjE, clarsimp)
apply (drule ok_parts_not_new, simp, simp, simp)
apply (clarify, drule ok_parts_not_new, simp, simp, simp)
(* ns2 *)
apply (simp add: secret_def)
(* ns3 *)
apply (simp add: secret_def)
(* R' = ns2 *)
apply (rule impI, rule impI, rule impI, rule impI)
apply (rule impI, rule impI, rule impI, rule impI)
apply (rule impI, erule tr.induct)
(* Nil *)
apply (simp add: secret_def)
(* Fake *)
apply (clarify, simp add: secret_def)
apply (drule notin_analz_insert)
apply (drule Crypt_insert_synth, simp, simp, simp)
apply (drule_tac n="nonce s' Nb" in Crypt_insert_synth, simp, simp, simp, simp)
(* Proto *)
apply (erule_tac P="ok evsa R sa" in rev_mp)
apply (simp add: split_paired_all)
apply (erule ns.cases)
(* ns1 *)
apply (clarify, simp add: secret_def)
apply (drule_tac s=sa and n=Na in ok_parts_not_new, simp, simp, simp)
(* ns2 *)
apply (clarify, simp add: secret_def)
apply (drule_tac s=sa and n=Nb in ok_parts_not_new, simp, simp, simp)
(* ns3 *)
apply (simp add: secret_def)
(* R' = ns3 *)
apply simp
(* R = ns2 *)
apply (rule impI, erule ns.cases)
(* R' = ns1 *)
apply (simp only: inf_def, blast)
(* R' = ns2 *)
apply (rule impI, rule impI, rule impI, rule impI)
apply (rule impI, rule impI, rule impI, rule impI)
apply (rule impI, erule tr.induct)
(* Nil *)
apply (simp add: secret_def)
(* Fake *)
apply (clarify, simp add: secret_def)
apply (drule notin_analz_insert)
apply (drule_tac n="nonce s' Nb" in Crypt_insert_synth, simp, simp, simp)
apply (drule_tac n="nonce s' Nb" in Crypt_insert_synth, simp, simp, simp, simp)
(* Proto *)
apply (erule_tac P="ok evsa R sa" in rev_mp)
apply (simp add: split_paired_all)
apply (erule ns.cases)
(* ns1 *)
apply (simp add: secret_def)
(* ns2 *)
apply (clarify, simp add: secret_def)
apply (erule disjE, erule disjE, clarsimp, clarsimp)
apply (drule_tac s=sa and n=Nb in ok_parts_not_new, simp, simp, simp)
apply (erule disjE, clarsimp)
apply (drule_tac s=sa and n=Nb in ok_parts_not_new, simp, simp, simp)
by (simp_all add: secret_def)

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory L2Opt
imports L2Defs L2Peephole
begin

ML {*
structure L2FlowThms =
  Named_Thms (
    val name = Binding.name "L2flow"
    val description = "Flow-sensitive optimisations carried out after L2 monadic conversion."
    )
*}

attribute_setup L2flow = {*
  Attrib.add_del
    (Thm.declaration_attribute L2FlowThms.add_thm)
    (Thm.declaration_attribute L2FlowThms.del_thm) *}
  "Peephole optimisations carried out after L2 monadic conversion."

(*
 * The monads "A" and "B" are equivalent under precondition "P".
 * Additionally, under this precondition, they always leave the
 * postcondition "Q" (normally) or "E" (if an exception occurs).
 *)
definition
  "monad_equiv P A B Q E \<equiv> (\<forall>s. P s \<longrightarrow> A s = B s) \<and> \<lbrace> P \<rbrace> A \<lbrace> Q \<rbrace>, \<lbrace> E \<rbrace>"

lemma monad_equivI [intro]:
  "\<lbrakk> \<And>s. P s \<Longrightarrow> A s = B s; \<lbrace> P \<rbrace> A \<lbrace> Q \<rbrace>, \<lbrace> E \<rbrace> \<rbrakk> \<Longrightarrow> monad_equiv P A B Q E"
  apply (clarsimp simp: monad_equiv_def)
  done

lemma monad_equiv_eqI [intro]:
  "\<lbrakk> \<lbrace> P \<rbrace> A \<lbrace> Q \<rbrace>, \<lbrace> E \<rbrace> \<rbrakk> \<Longrightarrow> monad_equiv P A A Q E"
  apply (clarsimp simp: monad_equiv_def)
  done

lemma monad_equiv_eq:
    "monad_equiv (\<lambda>_. True) A B X Y \<Longrightarrow> A = B"
  apply (rule ext)
  apply (clarsimp simp: monad_equiv_def)
  done

lemma monad_equiv_triv [L2flow]:
    "monad_equiv P A A (\<lambda>_ _. \<exists>s. P s) (\<lambda>_ _. \<exists>s. P s)"
  apply rule
  apply wp
  apply force
  done

lemma monad_equiv_symmetric:
  "monad_equiv P A B X Y = monad_equiv P B A X Y"
  apply (clarsimp simp: monad_equiv_def validE_def2 Ball_def split: sum.splits)
  apply force
  done

lemma monad_equivD: "\<lbrakk> monad_equiv P A B R E; P s \<rbrakk> \<Longrightarrow> A s = B s"
  apply (clarsimp simp: monad_equiv_def)
  done

(*
 * Show that under condition "P", the values "A" and "B" are equal.
 *
 * We use this to simplify expressions inside our monads in a (somewhat)
 * controlled fashion.
 *)
definition "simp_expr P A B \<equiv> P \<longrightarrow> A = B"

lemma simp_expr_triv: "simp_expr P A A"
  apply (clarsimp simp: simp_expr_def)
  done

lemma simp_expr_P_cong:
  "\<lbrakk> P = P' \<rbrakk> \<Longrightarrow> simp_expr P A B = simp_expr P' A B"
  apply (clarsimp simp: simp_expr_def)
  done

lemma simp_expr_rhs_cong [cong]:
  "\<lbrakk> P = P'; P' \<Longrightarrow> B = B' \<rbrakk> \<Longrightarrow> simp_expr P A B = simp_expr P' A B'"
  apply (clarsimp simp: simp_expr_def simp_implies_def)
  done

lemma simp_expr_weaken:
  "\<lbrakk> simp_expr P A B; Q \<Longrightarrow> P \<rbrakk> \<Longrightarrow> simp_expr Q A B"
  apply (clarsimp simp: simp_expr_def)
  done

(*
 * Monad simplification rules.
 *)

lemma monad_equiv_gets [L2flow]:
    "simp_expr True v v' \<Longrightarrow> monad_equiv P (L2_gets (\<lambda>s. v s) n) (L2_gets (\<lambda>s. v' s) n)
        (\<lambda>r s. P s \<and> r = v' s) (\<lambda>_ _. False)"
  apply rule
   apply (clarsimp simp: L2_defs simp_expr_def)+
  done

lemma monad_equiv_throw [L2flow]:
    "simp_expr True v v' \<Longrightarrow>
       monad_equiv P (L2_throw v n) (L2_throw v' n) (\<lambda>_ _. False) (\<lambda>r s. P s \<and> r = v')"
  apply (clarsimp simp: monad_equiv_def L2_defs simp_expr_def)
  apply wp
  apply force
  done

lemma monad_equiv_guard:
    "\<lbrakk> \<And>s. simp_expr (P s) (G s) (G' s) \<rbrakk> \<Longrightarrow>
        monad_equiv P (L2_guard (\<lambda>s. G s)) (L2_guard (\<lambda>s. G' s)) (\<lambda>r s. P s \<and> G' s \<and> r = ()) (\<lambda>_ _. False)"
  apply (clarsimp simp: monad_equiv_def L2_defs simp_expr_def)
  apply rule
   apply (clarsimp simp: liftE_def guard_def bind_def in_return snd_return)
  apply wp
  apply force
  done

(* We use this weaker form of guard simplification to prevent bound
 * variables being expanded inside of guard statements. *)
lemma monad_equiv_guard' [L2flow]:
    "\<lbrakk> \<And>s. simp_expr True (G s) (G' s) \<rbrakk> \<Longrightarrow>
        monad_equiv P (L2_guard G) (L2_guard G') (\<lambda>r s. P s \<and> G' s \<and> r = ()) (\<lambda>_ _. False)"
  apply (rule monad_equiv_guard)
  apply (rule simp_expr_weaken)
   apply assumption
  apply simp
  done

lemma monad_equiv_guard_False [L2flow]:
    "\<lbrakk> \<And>s. simp_expr (P s) False (G s) \<rbrakk>
          \<Longrightarrow> monad_equiv P (L2_guard G) (L2_fail) (\<lambda>_ _. False) (\<lambda>_ _. False)"
  apply (monad_eq simp: L2_defs monad_equiv_def simp_expr_def validE_def2)
  done

lemma monad_equiv_guard_True [L2flow]:
    "\<lbrakk> \<And>s. simp_expr (P s) True (G s) \<rbrakk>
          \<Longrightarrow> monad_equiv P (L2_guard G) L2_skip (\<lambda>r s. P s \<and> r = ()) (\<lambda>_ _. False)"
  apply (auto simp: L2_defs simp_expr_def guard_def liftE_def return_def returnOk_def bind_def validE_def valid_def)
  done

lemma monad_equiv_guard_conj [L2flow]:
    "\<lbrakk> monad_equiv P (L2_guard G1) G1' R1 E1;
       monad_equiv (\<lambda>s. R1 () s) (L2_guard G2) G2' R2 E2 \<rbrakk> \<Longrightarrow>
        monad_equiv P (L2_guard (\<lambda>s. G1 s \<and> G2 s)) (L2_seq G1' (\<lambda>_. G2')) (\<lambda>r s. R2 () s) (\<lambda>_ _. False)"
  apply (subst (asm) (1 2) monad_equiv_symmetric)
  apply (subst monad_equiv_symmetric)
  apply rule
   apply (monad_eq simp: L2_defs monad_equiv_def validE_def2 Bex_def Ball_def split: sum.splits)
   apply fast
  apply (monad_eq simp: monad_equiv_def L2_defs validE_def2 Ball_def split: sum.splits)
  apply fast
  done

lemma monad_equiv_unknown [L2flow]:
    "monad_equiv P (L2_unknown name) (L2_unknown name) (\<lambda>r s. P s) (\<lambda>_ _. False)"
  apply (clarsimp simp: monad_equiv_def L2_defs)
  apply (wp select_wp)
  apply force
  done

lemma monad_equiv_modify [L2flow]:
    "\<lbrakk> \<And>s. simp_expr True (m s) (m' s) \<rbrakk> \<Longrightarrow>
        monad_equiv P (L2_modify (\<lambda>s. m s)) (L2_modify (\<lambda>s. m' s)) (\<lambda>r s'. \<exists>s. P s \<and> m' s = s' \<and> r = ()) (\<lambda>_ _. False)"
  apply rule
   apply (clarsimp simp: L2_defs simp_expr_def liftE_def modify_def put_def get_def bind_def)
  apply (clarsimp simp: L2_defs simp_expr_def)
  apply force
  done

lemma monad_equiv_spec [L2flow]:
    "\<lbrakk> \<And>s s'. simp_expr True ((s, s') \<in> S) (S' s s') \<rbrakk> \<Longrightarrow>
        monad_equiv P (L2_spec S) (L2_spec ({(s, s'). S' s s'})) (\<lambda>r s. \<exists>s. P s) (\<lambda>_ _. False)"
  apply rule
   apply (clarsimp simp: L2_defs simp_expr_def liftE_def spec_def bind_def)
  apply (clarsimp simp: L2_defs)
  apply wp
  apply force
  done

lemma monad_equiv_fail [L2flow]:
    "monad_equiv P L2_fail L2_fail (\<lambda>_ _. False) (\<lambda>_ _. False)"
  apply (clarsimp simp: monad_equiv_def L2_defs)
  done

lemma monad_equiv_condition [L2flow]:
  "\<lbrakk> \<And>s. simp_expr True (C s) (C' s);
     monad_equiv (\<lambda>s. P s \<and> C' s) L L' QL EL;
     monad_equiv (\<lambda>s. P s \<and> \<not> C' s) R R' QR ER \<rbrakk> \<Longrightarrow>
   monad_equiv P (L2_condition (\<lambda>s. C s) L R) (L2_condition (\<lambda>s. C' s) L' R')
      (\<lambda>r s. \<exists>s. P s) (* Deliberately weak to avoid exponential growth. *)
      (\<lambda>r s. \<exists>s. P s)"
  apply rule
   apply (monad_eq simp: L2_defs monad_equiv_def simp_expr_def split: condition_splits)
  apply (monad_eq simp: L2_defs monad_equiv_def validE_def2 split: condition_splits sum.splits)
  apply force
  done

lemma monad_equiv_condition_True [L2flow]:
  "\<lbrakk> \<And>s. simp_expr (P s) (C s) True;
     monad_equiv P L L' QL EL \<rbrakk> \<Longrightarrow>
     monad_equiv P (L2_condition C L R) L' QL EL"
  unfolding L2_defs condition_def
  apply (monad_eq simp: simp_expr_def monad_equiv_def validE_def2 Ball_def split: sum.splits)
  done

lemma monad_equiv_condition_False [L2flow]:
  "\<lbrakk> \<And>s. simp_expr (P s) (C s) False;
     monad_equiv P R R' QR ER \<rbrakk> \<Longrightarrow>
     monad_equiv P (L2_condition C L R) R' QR ER"
  unfolding L2_defs condition_def
  apply (monad_eq simp: simp_expr_def monad_equiv_def validE_def2 Ball_def split: sum.splits)
  done

(* C-parser sometimes generates boolean expressions like
     if P then (if P then 1 else 0) else Q
   This simplifies the branches. *)
lemma monad_equiv_gets_if [L2flow]:
   "\<lbrakk> \<And>s. simp_expr (P s) True (b s) \<rbrakk> \<Longrightarrow>
       monad_equiv P (L2_gets (\<lambda>s. if (b s) then L else R) f)
                     (L2_gets (\<lambda>s. L) f) (%r s. P s) (\<lambda>r s. False)"
   "\<lbrakk> \<And>s. simp_expr (P s) False (b s) \<rbrakk> \<Longrightarrow>
       monad_equiv P (L2_gets (\<lambda>s. if (b s) then L else R) f)
                     (L2_gets (\<lambda>s. R) f) (%r s. P s) (\<lambda>r s. False)"
  apply (monad_eq simp: L2_defs simp_expr_def monad_equiv_def
         validE_def valid_def split: sum.splits)+
  done

lemma monad_equiv_seq [L2flow]:
  "\<lbrakk> monad_equiv P A A' Q E;
     \<And>x. monad_equiv (Q x) (B x) (B' x) (R x) (E2 x) \<rbrakk> \<Longrightarrow>
   monad_equiv P (L2_seq A (\<lambda>x. B x)) (L2_seq A' (\<lambda>x. B' x)) (\<lambda>r s. \<exists>r'. R r' r s) (\<lambda>r s. \<exists>s. P s)"
  apply rule
   apply (clarsimp simp: monad_equiv_def L2_defs simp_expr_def)
   apply (rule bindE_apply_cong)
    apply simp
   apply (clarsimp simp: validE_def valid_def)
   apply force
  apply (clarsimp simp: monad_equiv_def L2_defs
               validE_def valid_def in_bindE simp_expr_def split: sum.splits)
  apply (erule allE, erule (1) impE)+
  apply fastforce
  done

lemma monad_equiv_catch [L2flow]:
  "\<lbrakk> monad_equiv P A A' Q E;
    \<And>x. monad_equiv (E x) (B x) (B' x) (Q' x) (E2 x) \<rbrakk> \<Longrightarrow>
   monad_equiv P (L2_catch A (\<lambda>x. B x)) (L2_catch A' (\<lambda>x. B' x)) (\<lambda>r s. \<exists>s. P s) (\<lambda>r s. \<exists>r'. E2 r' r s)"
  apply rule
   apply atomize
   apply (clarsimp simp: simp_expr_def L2_defs monad_equiv_def)
   apply (erule allE, erule impE, assumption)
   apply (clarsimp simp: validE_def2 split: sum.splits)
   apply (erule allE, erule impE, assumption)
   apply (rule monad_state_eqI)
     apply (clarsimp simp: in_handleE')
     apply force
    apply (clarsimp simp: in_handleE')
    apply force
   apply (fastforce simp: snd_handleE')
  apply (clarsimp simp: monad_equiv_def L2_defs
      validE_def valid_def simp_expr_def in_handleE' split: sum.splits)
  apply (erule allE, erule (1) impE)+
  apply fastforce
  done

lemma monad_equiv_cong:
  "\<lbrakk> \<And>s. P s = P' s;
     \<And>s. P s \<Longrightarrow> A s = A' s;
     \<And>s. P s \<Longrightarrow> B s = B' s;
     \<And>s s' r. P s \<Longrightarrow> Q r s' = Q' r s';
     \<And>s s' r. P s \<Longrightarrow> R r s' = R' r s' \<rbrakk> \<Longrightarrow>
   monad_equiv P A B Q R = monad_equiv P' A' B' Q' R'"
  apply atomize
  apply (clarsimp simp: monad_equiv_def validE_def valid_def split: sum.splits)
  apply (rule iffI)
   apply clarsimp
   apply fastforce
  apply clarsimp
  apply fastforce
  done

lemma monad_equiv_while [L2flow]:
  assumes cond_simp: "\<And>s r. simp_expr True (c r s) (c' r s)"
  assumes body_equiv: "\<And>r. monad_equiv (\<lambda>s. (\<exists>s'. P s') \<and> c' r s) (B r) (B' r) (Q r) (E r)"
  assumes init_simp: "\<And>s r. simp_expr True x x'"
  shows "monad_equiv P (L2_while (\<lambda>r s. c r s) B x n) (L2_while (\<lambda>r s. c' r s) B' x' n) (\<lambda>r s. \<not> c' r s \<and> (\<exists>x. P x)) (\<lambda>r s. \<exists>x. E x r s)"
  apply (insert cond_simp [unfolded simp_expr_def] init_simp [unfolded simp_expr_def])
  apply rule
   apply (clarsimp simp: L2_while_def)
   apply (rule whileLoopE_cong [THEN fun_cong, THEN fun_cong])
     apply force
    apply (cut_tac r=r in body_equiv)
    apply (clarsimp simp: monad_equiv_def)
    apply (erule allE, erule impE, auto)[1]
   apply simp
  apply (clarsimp simp: L2_while_def)
  apply (rule validE_whileLoopE [where I="\<lambda>r s. \<exists>s. P s"])
    apply force
   apply (cut_tac r=r in body_equiv)
   apply (clarsimp simp: validE_def valid_def monad_equiv_def split: sum.splits)
   apply blast
  apply simp
  done

lemma monad_equiv_recguard [L2flow]:
  "\<lbrakk> monad_equiv P B B' Q E \<rbrakk> \<Longrightarrow>
    monad_equiv P (L2_recguard a B) (L2_recguard a B') Q E"
  apply rule
   apply (clarsimp simp: L2_recguard_def monad_equiv_def valid_def validE_def
        split: sum.splits condition_splits)
  apply (clarsimp simp: L2_recguard_def monad_equiv_def valid_def validE_def in_fail
       split: sum.splits condition_splits)
  done

lemma monad_equiv_unreachable' [L2flow]:
  "monad_equiv (\<lambda>_. False) L (L2_gets (\<lambda>_. undefined) [''L2Opt_internal_var'']) Q R"
  apply (monad_eq simp: monad_equiv_def L2_defs simp_expr_def valid_def validE_def)
  done

lemma monad_equiv_split [L2flow]:
  "\<lbrakk> \<And>a b. monad_equiv (P (a, b)) (X a b) (Y a b) (Q a b) (E a b) \<rbrakk> \<Longrightarrow>
    monad_equiv (P x) (case x of (a, b) \<Rightarrow> X a b) (case x of (a, b) \<Rightarrow> Y a b)
          (case x of (a, b) \<Rightarrow> Q a b) (case x of (a, b) \<Rightarrow> E a b)"
  apply (clarsimp simp: monad_equiv_def validE_def valid_def split_def)
  done

lemma simp_expr_solve_constant: "\<lbrakk> A \<Longrightarrow> B = C \<rbrakk> \<Longrightarrow> simp_expr A B C"
  by (clarsimp simp: simp_expr_def)

lemma monad_equiv_weaken_pre':
  "\<lbrakk> \<And>s. P' s \<Longrightarrow> P s; monad_equiv P L R Q E \<rbrakk> \<Longrightarrow> monad_equiv P' L R Q E"
  by (fastforce simp: monad_equiv_def validE_def valid_def)

lemma monad_equiv_weaken_pre'':
  "\<lbrakk> P' \<equiv> P; monad_equiv P L R Q E \<rbrakk> \<Longrightarrow> monad_equiv P' L R Q E"
  by (fastforce simp: monad_equiv_def validE_def valid_def)

end


section "Algebraic laws for abrupt designs"
theory algebraic_laws_abrupt
imports algebraic_laws_abrupt_aux

begin
(*TODO: add laws for assigns when composed with try catch...*)
subsection"Simpset configuration"

declare urel_comp [uabr_comp]
declare urel_cond [uabr_cond]

subsection"Throw"

lemma throw_cpa_left_zero_true_abr[uabr_comp]:
  "(THROW\<^sub>A\<^sub>B\<^sub>R ;; true) = (true)"
  by rel_auto

lemma throw_cpa_left_zero_true_lift_abr[uabr_comp]:
  "(THROW\<^sub>A\<^sub>B\<^sub>R ;; \<lceil>true\<rceil>\<^sub>A\<^sub>B\<^sub>R) = (\<lceil>true\<rceil>\<^sub>A\<^sub>B\<^sub>R)"
  by rel_auto

lemma throw_cpa_left_zero_false_lift_abr[uabr_comp]:
  "(THROW\<^sub>A\<^sub>B\<^sub>R ;; \<lceil>false\<rceil>\<^sub>A\<^sub>B\<^sub>R) = (\<lceil>false\<rceil>\<^sub>A\<^sub>B\<^sub>R)"
  by rel_auto

lemma throw_cpa_left_zero_skip_abr[uabr_comp]:
  "(THROW\<^sub>A\<^sub>B\<^sub>R ;; SKIP\<^sub>A\<^sub>B\<^sub>R) = (THROW\<^sub>A\<^sub>B\<^sub>R)"
  by rel_auto

lemma throw_cpa_left_zero_assigns_abr[uabr_comp]:
  "(THROW\<^sub>A\<^sub>B\<^sub>R ;; \<langle>\<sigma>\<rangle>\<^sub>A\<^sub>B\<^sub>R) = (THROW\<^sub>A\<^sub>B\<^sub>R)"
  by rel_auto

(*lemma throw_cpa_left_zero_top_abr[uabr_comp]:
  "(THROW\<^sub>A\<^sub>B\<^sub>R ;; \<top>\<^sub>A\<^sub>B\<^sub>R) = (\<top>\<^sub>A\<^sub>B\<^sub>R)"
  by rel_auto*)

lemma not_abrupt_left_zero_throw_abr[uabr_comp]:
  "(($x) ;; THROW\<^sub>A\<^sub>B\<^sub>R) = ($x)"
  by rel_auto

lemma abrupt_left_zero_throw_abr[uabr_comp]:
  "($aburpt ;; THROW\<^sub>A\<^sub>B\<^sub>R) = $aburpt"
  by rel_auto

lemma bot_left_zero_throw_abr[uabr_comp]:
  "(\<top>\<^sub>A\<^sub>B\<^sub>R ;; THROW\<^sub>A\<^sub>B\<^sub>R) = (\<top>\<^sub>A\<^sub>B\<^sub>R)"
  by rel_auto

(*lemma throw_abr_idem [uabr_comp]:
  "(THROW\<^sub>A\<^sub>B\<^sub>R ;; THROW\<^sub>A\<^sub>B\<^sub>R) = THROW\<^sub>A\<^sub>B\<^sub>R"
  by rel_auto*)

lemma throw_abr_right_zero_skip_abr[uabr_comp]:
  "(SKIP\<^sub>A\<^sub>B\<^sub>R ;; THROW\<^sub>A\<^sub>B\<^sub>R) = THROW\<^sub>A\<^sub>B\<^sub>R"
  by rel_auto

(*lemma assigns_abr_throw_abr_right[uabr_comp]:
  "\<langle>\<sigma>\<rangle>\<^sub>A\<^sub>B\<^sub>R;; THROW\<^sub>A\<^sub>B\<^sub>R = (C3_abr(\<lceil>true\<rceil>\<^sub>A\<^sub>B\<^sub>R \<turnstile> ($abrupt\<acute> \<and> \<lceil>\<langle>\<sigma>\<rangle>\<^sub>a\<rceil>\<^sub>A\<^sub>B\<^sub>R)))"
  by rel_auto

lemma assigns_abr_throw_abr_right[uabr_comp]:
  "\<langle>\<sigma>\<rangle>\<^sub>A\<^sub>B\<^sub>R;; THROW\<^sub>A\<^sub>B\<^sub>R = (C3_abr(\<lceil>\<sigma>\<rceil>\<^sub>s\<^sub>A\<^sub>B\<^sub>R \<dagger> (\<lceil>true\<rceil>\<^sub>A\<^sub>B\<^sub>R \<turnstile> ($abrupt\<acute> \<and> \<lceil>II\<rceil>\<^sub>A\<^sub>B\<^sub>R))))"
  by rel_auto*)

subsection"Skip"

text{*In this section we introduce the algebraic laws of programming related to the SKIP
      statement.*}

lemma true_left_zero_skip_cpa_abr[uabr_comp]:
  "(SKIP\<^sub>A\<^sub>B\<^sub>R ;; true) = (true)"
  by rel_auto

lemma true_lift_abr_left_zero_skip_abr[uabr_comp]:
  "(SKIP\<^sub>A\<^sub>B\<^sub>R ;; \<lceil>true\<rceil>\<^sub>A\<^sub>B\<^sub>R) = (\<lceil>true\<rceil>\<^sub>A\<^sub>B\<^sub>R)"
  by rel_auto

lemma false_lift_abr_left_zero_skip_abr[uabr_comp]:
  "(SKIP\<^sub>A\<^sub>B\<^sub>R ;; \<lceil>false\<rceil>\<^sub>A\<^sub>B\<^sub>R) = (\<lceil>false\<rceil>\<^sub>A\<^sub>B\<^sub>R)"
  by rel_auto

lemma skip_abr_left_unit_assigns_abr[uabr_comp]:
  "(SKIP\<^sub>A\<^sub>B\<^sub>R ;; \<langle>\<sigma>\<rangle>\<^sub>A\<^sub>B\<^sub>R) = (\<langle>\<sigma>\<rangle>\<^sub>A\<^sub>B\<^sub>R)"
  by rel_auto

lemma skip_abr_top_abr_left_zero[uabr_comp]:
  "(SKIP\<^sub>A\<^sub>B\<^sub>R ;; \<top>\<^sub>A\<^sub>B\<^sub>R) = (\<top>\<^sub>A\<^sub>B\<^sub>R)"
  by rel_auto

lemma skip_abr_abrupt_left_zero[uabr_comp]:
  "($x ;; SKIP\<^sub>A\<^sub>B\<^sub>R) = $x"
  by rel_auto

lemma skip_abr_bot_left_zero[uabr_comp]:
  "(\<top>\<^sub>A\<^sub>B\<^sub>R ;; SKIP\<^sub>A\<^sub>B\<^sub>R) = (\<top>\<^sub>A\<^sub>B\<^sub>R)"
  by rel_auto

lemma skip_abr_idem [uabr_comp]:
  "(SKIP\<^sub>A\<^sub>B\<^sub>R ;; SKIP\<^sub>A\<^sub>B\<^sub>R) = SKIP\<^sub>A\<^sub>B\<^sub>R"
  by rel_auto

lemma skip_abr_alpha_eq:
  "SKIP\<^sub>A\<^sub>B\<^sub>R = Simpl\<^sub>A\<^sub>B\<^sub>R (\<not>$abrupt\<acute> \<and> ($\<Sigma>\<^sub>A\<^sub>B\<^sub>R\<acute> =\<^sub>u $\<Sigma>\<^sub>A\<^sub>B\<^sub>R))"
  by (simp add: skip_lift_cpa_def skip_abr_def)

lemma simpl_pre_skip_abr_post:
  "(Simpl\<^sub>A\<^sub>B\<^sub>R \<lceil>b\<rceil>\<^sub>A\<^sub>B\<^sub>R\<^sub>< \<and> SKIP\<^sub>A\<^sub>B\<^sub>R) = (SKIP\<^sub>A\<^sub>B\<^sub>R \<and> Simpl\<^sub>A\<^sub>B\<^sub>R \<lceil>b\<rceil>\<^sub>A\<^sub>B\<^sub>R\<^sub>>)"
  by rel_auto

lemma simpl_pre_skip_abr_var:
  fixes x :: "(bool,  ('b) cpa) uvar"
  shows "(Simpl\<^sub>A\<^sub>B\<^sub>R $x \<and> SKIP\<^sub>A\<^sub>B\<^sub>R) = (SKIP\<^sub>A\<^sub>B\<^sub>R \<and> Simpl\<^sub>A\<^sub>B\<^sub>R $x\<acute>)"
  by rel_auto

lemma  skip_abr_post_left_unit[uabr_comp]:
  "(S \<turnstile> (SKIP\<^sub>A\<^sub>B\<^sub>R;; Q)) = (S \<turnstile> Q)"
  apply pred_simp
  apply rel_simp
  apply fastforce
done

lemma  simpl_post_left_unit[uabr_comp]:
  "(S \<turnstile> (Simpl\<^sub>A\<^sub>B\<^sub>R (\<not>$abrupt\<acute> \<and> \<lceil>II\<rceil>\<^sub>A\<^sub>B\<^sub>R);; Q)) = (S \<turnstile> Q)"
  apply pred_simp
  apply rel_simp
  apply transfer
  apply auto
done

subsection {*Assignment Laws*}
text{*In this section we introduce the algebraic laws of programming related to the assignment
      statement.*}

lemma [urel_cond]:
  "S \<turnstile> (\<lceil>true\<rceil>\<^sub>A\<^sub>B\<^sub>R \<turnstile> (\<lceil>R\<rceil>\<^sub>A\<^sub>B\<^sub>R \<and> $abrupt\<acute>) ;; P \<triangleleft> \<not> $abrupt \<triangleright> Q) =
   S \<turnstile> (\<lceil>true\<rceil>\<^sub>A\<^sub>B\<^sub>R \<turnstile> (\<lceil>R\<rceil>\<^sub>A\<^sub>B\<^sub>R \<and> $abrupt\<acute>);; Q)"
  apply pred_simp
  apply fastforce
done

lemma [urel_cond]:
  "S \<turnstile> (\<lceil>true\<rceil>\<^sub>A\<^sub>B\<^sub>R \<turnstile> (\<lceil>R\<rceil>\<^sub>A\<^sub>B\<^sub>R \<and>  $abrupt\<acute>) ;; P \<triangleleft> $abrupt \<triangleright> Q) =
   S \<turnstile> (\<lceil>true\<rceil>\<^sub>A\<^sub>B\<^sub>R \<turnstile> (\<lceil>R\<rceil>\<^sub>A\<^sub>B\<^sub>R \<and>  $abrupt\<acute>);; P)"
  apply pred_simp
  apply fastforce
done

lemma not_abrupt_assigns_abr_L6_left_des[urel_cond]:
  "((S \<turnstile> (\<langle>a\<rangle>\<^sub>A\<^sub>B\<^sub>R;; (P \<triangleleft> $abrupt \<triangleright> Q))) \<triangleleft> \<not> $abrupt \<triangleright> R) =
   ((S \<turnstile> (\<langle>a\<rangle>\<^sub>A\<^sub>B\<^sub>R;; Q)) \<triangleleft> \<not> $abrupt \<triangleright> R)"
  unfolding assigns_abr_def
  apply pred_simp
  apply fastforce
done

lemma abrupt_assigns_abr_L6_left_des[urel_cond]:
  "((S \<turnstile> (\<langle>a\<rangle>\<^sub>A\<^sub>B\<^sub>R;; (P \<triangleleft> \<not> $abrupt \<triangleright> Q))) \<triangleleft> $abrupt \<triangleright> R) =
   ((S \<turnstile> (\<langle>a\<rangle>\<^sub>A\<^sub>B\<^sub>R;; Q)) \<triangleleft> $abrupt \<triangleright> R)"
  unfolding assigns_abr_def
  apply pred_simp
  apply rel_simp
  apply fastforce
done

lemma not_abrupt_assigns_abr_L6_right_des[urel_cond]:
  "(R \<triangleleft> \<not> $abrupt \<triangleright> (S \<turnstile> (\<langle>a\<rangle>\<^sub>A\<^sub>B\<^sub>R;; (P \<triangleleft> $abrupt \<triangleright> Q))) ) =
   ( R \<triangleleft> \<not> $abrupt \<triangleright> (S \<turnstile> (\<langle>a\<rangle>\<^sub>A\<^sub>B\<^sub>R;; P)))"
  unfolding assigns_abr_def
  apply pred_simp
  apply rel_simp
  apply fastforce
done

lemma abrupt_assigns_abr_L6_right_des[urel_cond]:
 "( R \<triangleleft> $abrupt \<triangleright> (S \<turnstile> (\<langle>a\<rangle>\<^sub>A\<^sub>B\<^sub>R;; (P \<triangleleft> \<not> $abrupt \<triangleright> Q))) ) =
  ( R \<triangleleft> $abrupt \<triangleright> (S \<turnstile> (\<langle>a\<rangle>\<^sub>A\<^sub>B\<^sub>R;; P)) )"
  apply pred_simp
  apply rel_simp
  apply fastforce
done

lemma not_abrupt_left_assigns_abr_post_des[urel_cond]:
  "R \<triangleleft> \<not> $abrupt \<triangleright> (S \<turnstile> (\<langle>a\<rangle>\<^sub>A\<^sub>B\<^sub>R;; P))  =
   R \<triangleleft> \<not> $abrupt \<triangleright> (S \<turnstile> (\<lceil>true\<rceil>\<^sub>A\<^sub>B\<^sub>R \<turnstile> (\<lceil>II\<rceil>\<^sub>A\<^sub>B\<^sub>R \<and> $abrupt\<acute>) ;; P))"
  unfolding assigns_abr_def
  apply pred_simp
  apply rel_simp
done

lemma  not_abrupt_left_throw_abr_post_des[urel_cond]:
  "R \<triangleleft> \<not> $abrupt \<triangleright> (S \<turnstile> (THROW\<^sub>A\<^sub>B\<^sub>R;; P))  =
   R \<triangleleft> \<not> $abrupt \<triangleright> (S \<turnstile> ((\<not>$abrupt) \<turnstile> (\<lceil>II\<rceil>\<^sub>A\<^sub>B\<^sub>R \<and> $abrupt\<acute>) ;; P))"
  unfolding assigns_abr_def
  apply pred_simp
  apply rel_simp
done

lemma usubst_abr_cancel [usubst]:
  assumes 1:"weak_lens v"
  shows "($v)\<lbrakk>\<lceil>expr\<rceil>\<^sub>A\<^sub>B\<^sub>R\<^sub></$v\<rbrakk>= \<lceil>expr\<rceil>\<^sub>A\<^sub>B\<^sub>R\<^sub><"
  using 1
  by  rel_auto

lemma usubst_abr_lift_cancel[usubst]:
  assumes 1:"weak_lens v"
  shows "\<lceil>($v)\<lbrakk>\<lceil>expr\<rceil>\<^sub></$v\<rbrakk>\<rceil>\<^sub>A\<^sub>B\<^sub>R= \<lceil>expr\<rceil>\<^sub>A\<^sub>B\<^sub>R\<^sub><"
  using 1
  by  rel_auto

lemma assigns_abr_id [uabr_simpl]: "SKIP\<^sub>A\<^sub>B\<^sub>R = \<langle>id\<rangle>\<^sub>A\<^sub>B\<^sub>R"
  unfolding skip_abr_def assigns_abr_def
  by (rel_auto)

lemma assign_test[uabr_comp]:
  assumes 1:"mwb_lens x"
  shows     "(x \<Midarrow> \<guillemotleft>u\<guillemotright> ;; x \<Midarrow> \<guillemotleft>v\<guillemotright>) = (x \<Midarrow> \<guillemotleft>v\<guillemotright>)"
  using 1
  by (simp add: usubst uabr_comp )

lemma assign_abr_left_comp_subst[uabr_comp]:
  "(x \<Midarrow> u ;; Simpl\<^sub>A\<^sub>B\<^sub>R(\<lceil>P\<rceil>\<^sub>A\<^sub>B\<^sub>R \<turnstile> \<lceil>Q\<rceil>\<^sub>A\<^sub>B\<^sub>R)) = Simpl\<^sub>A\<^sub>B\<^sub>R(\<lceil>P\<lbrakk>\<lceil>u\<rceil>\<^sub></$x\<rbrakk>\<rceil>\<^sub>A\<^sub>B\<^sub>R \<turnstile> \<lceil>Q\<lbrakk>\<lceil>u\<rceil>\<^sub></$x\<rbrakk>\<rceil>\<^sub>A\<^sub>B\<^sub>R)"
  by (simp add: uabr_comp usubst)

lemma assign_abr_twice[uabr_comp]:
  assumes "mwb_lens x" and  "x \<sharp> f"
  shows "(x \<Midarrow> e ;; x \<Midarrow> f) = (x \<Midarrow> f)"
  using assms
  by (simp add: uabr_comp usubst)

lemma assign_abr_commute:
  assumes "x \<bowtie> y" "x \<sharp> f" "y \<sharp> e"
  shows "(x \<Midarrow> e ;; y \<Midarrow> f) = (y \<Midarrow> f ;; x \<Midarrow> e)"
  using assms
  by (simp add: uabr_comp usubst usubst_upd_comm)

lemma assign_abr_cond_abr[uabr_comp]: (*needs more laws to be automatic*)
  fixes x :: "('a, '\<alpha>) uvar"
  shows "(x \<Midarrow> e ;; (bif b then Simpl\<^sub>A\<^sub>B\<^sub>R P else Simpl\<^sub>A\<^sub>B\<^sub>R Q eif)) =
         (bif (b\<lbrakk>e/x\<rbrakk>) then (x \<Midarrow> e ;; Simpl\<^sub>A\<^sub>B\<^sub>R P)  else (x \<Midarrow> e ;; Simpl\<^sub>A\<^sub>B\<^sub>R Q) eif)"
  apply (simp add: usubst uabr_comp)
  apply rel_auto
done

lemma assign_c_uop1[uabr_comp]:
  assumes 1: "mwb_lens v"
  shows "(v \<Midarrow> e1 ;; v \<Midarrow> (uop F (&v))) = (v \<Midarrow> (uop F e1))"
  by (simp add: usubst  uabr_comp assms)

lemma assign_c_bop1[uabr_comp]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2"
  shows "(v \<Midarrow> e1 ;; v \<Midarrow>(bop bp (&v) e2)) = (v \<Midarrow> (bop bp e1 e2))"
  by (simp add: usubst uabr_comp assms)

lemma assign_c_bop2[uabr_comp]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2"
  shows "(v \<Midarrow> e1 ;; v \<Midarrow> (bop bp e2 (&v))) = (v \<Midarrow> (bop bp e2 e1))"
  by (simp add: usubst uabr_comp assms)

lemma assign_c_trop1[uabr_comp]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3"
  shows "(v \<Midarrow> e1 ;; v \<Midarrow> (trop tp (&v) e2 e3)) =
         (v \<Midarrow> (trop tp e1 e2 e3))"
  by (simp add: usubst uabr_comp assms)

lemma assign_c_trop2[uabr_comp]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3"
  shows "(v \<Midarrow> e1 ;; v \<Midarrow> (trop tp e2 (&v) e3)) =
         (v \<Midarrow> (trop tp e2 e1 e3))"
  by (simp add: usubst uabr_comp assms)

lemma assign_c_trop3[uabr_comp]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3"
  shows "(v \<Midarrow> e1 ;; v \<Midarrow> (trop tp e2 e3 (&v))) =
         (v \<Midarrow> (trop tp e2 e3 e1))"
  by (simp add: usubst uabr_comp assms)

lemma assign_c_qtop1[uabr_comp]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3" and 4:"v \<sharp> e4"
  shows "(v \<Midarrow> e1 ;; v \<Midarrow> (qtop tp (&v) e2 e3 e4)) =
         (v \<Midarrow> (qtop tp e1 e2 e3 e4))"
  by (simp add: usubst uabr_comp assms)

lemma assign_c_qtop2[uabr_comp]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3" and 4:"v \<sharp> e4"
  shows "(v \<Midarrow> e1 ;; v \<Midarrow> (qtop tp e2 (&v) e3 e4)) =
         (v \<Midarrow> (qtop tp e2 e1 e3 e4))"
  by (simp add: usubst uabr_comp assms)

lemma assign_c_qtop3[uabr_comp]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3" and 4:"v \<sharp> e4"
  shows "(v \<Midarrow> e1 ;; v \<Midarrow> (qtop tp e2 e3 (&v) e4)) =
         (v \<Midarrow> (qtop tp e2 e3 e1 e4))"
  by (simp add: usubst uabr_comp assms)

lemma assign_c_qtop4[uabr_comp]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3" and 4:"v \<sharp> e4"
  shows "(v \<Midarrow> e1 ;; v \<Midarrow> (qtop tp e2 e3 e4 (&v))) =
         (v \<Midarrow> (qtop tp e2 e3 e4 e1))"
  by (simp add: usubst uabr_comp assms)

text {*In the sequel we define assignment laws proposed by Hoare*}

lemma assign_abr_vwb_skip_abr[uabr_comp]:
  assumes 1: "vwb_lens v"
  shows "(v \<Midarrow> &v) = SKIP\<^sub>A\<^sub>B\<^sub>R"
  by (simp add: assms usubst uabr_simpl)

lemma assign_c_simultaneous:
  assumes  1: "vwb_lens var2"
  and      2: "var1 \<bowtie> var2"
  shows "var1, var2 \<Midarrow> exp, &var2 = var1 \<Midarrow> exp"
  by (simp add: assms usubst_upd_comm usubst)

lemma assign_c_seq[uabr_comp]:
  assumes  1: "vwb_lens var2"
  shows"(var1 \<Midarrow> exp);; (var2 \<Midarrow> &var2) = (var1 \<Midarrow> exp)"
  by (simp add: assms usubst uabr_comp)

lemma assign_c_cond_c_uop[uabr_comp]: (*needs more laws to be automatic*)
  assumes 1: "weak_lens v"
  shows "bif uop F exp then (v \<Midarrow> exp ;; Simpl\<^sub>A\<^sub>B\<^sub>R C1) else (v \<Midarrow> exp ;; Simpl\<^sub>A\<^sub>B\<^sub>R C2) eif =
          v \<Midarrow> exp ;; bif uop F (&v) then Simpl\<^sub>A\<^sub>B\<^sub>R C1 else  Simpl\<^sub>A\<^sub>B\<^sub>R C2 eif"
  apply (simp add: assms usubst uabr_comp uabr_simpl )
  apply pred_simp
  apply rel_simp
  apply auto
  apply (metis assms weak_lens.put_get)+
done

lemma assign_c_cond_bop1[uabr_comp]: (*needs more laws to be automatic*)
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2"
  shows "bif bop bp exp exp2 then (v \<Midarrow> exp ;; Simpl\<^sub>A\<^sub>B\<^sub>R C1) else (v \<Midarrow> exp ;; Simpl\<^sub>A\<^sub>B\<^sub>R C2) eif =
          v \<Midarrow> exp ;; bif bop bp (&v) exp2 then Simpl\<^sub>A\<^sub>B\<^sub>R C1 else Simpl\<^sub>A\<^sub>B\<^sub>R C2 eif"
  apply (simp add: assms usubst uabr_comp uabr_simpl )
  apply pred_simp
  apply rel_simp
  apply auto
  apply (metis assms unrest_upred.rep_eq weak_lens.put_get)+
done

lemma assign_c_cond_bop2[uabr_comp]: (*needs more laws to be automatic*)
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2"
  shows "bif bop bp exp2 exp then (v \<Midarrow> exp ;; Simpl\<^sub>A\<^sub>B\<^sub>R C1) else (v \<Midarrow> exp ;; Simpl\<^sub>A\<^sub>B\<^sub>R C2) eif =
          v \<Midarrow> exp ;; bif bop bp  exp2 (&v) then Simpl\<^sub>A\<^sub>B\<^sub>R C1 else Simpl\<^sub>A\<^sub>B\<^sub>R C2 eif"
  apply (simp add: assms usubst uabr_comp uabr_simpl )
  apply pred_simp
  apply rel_simp
  apply auto
  apply (metis assms unrest_upred.rep_eq weak_lens.put_get)+
done

lemma assign_cond_trop1[uabr_comp]: (*needs more laws to be automatic*)
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3"
  shows "bif trop bp exp exp2 exp3 then (v \<Midarrow> exp ;; Simpl\<^sub>A\<^sub>B\<^sub>R C1) else (v \<Midarrow> exp ;; Simpl\<^sub>A\<^sub>B\<^sub>R C2) eif =
         v \<Midarrow> exp ;; bif trop bp (&v) exp2 exp3 then Simpl\<^sub>A\<^sub>B\<^sub>R C1 else Simpl\<^sub>A\<^sub>B\<^sub>R C2 eif"
  apply (simp add: assms usubst uabr_comp uabr_simpl )
  apply pred_simp
  apply rel_simp
  apply auto
  apply (metis assms unrest_upred.rep_eq weak_lens.put_get)+
done

lemma assign_cond_trop2[uabr_comp]: (*needs more laws to be automatic*)
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3"
  shows "bif trop bp exp2 exp  exp3 then (v \<Midarrow> exp ;; Simpl\<^sub>A\<^sub>B\<^sub>R C1) else (v \<Midarrow> exp ;; Simpl\<^sub>A\<^sub>B\<^sub>R C2) eif =
         v \<Midarrow> exp ;; bif trop bp  exp2 (&v) exp3 then Simpl\<^sub>A\<^sub>B\<^sub>R C1 else Simpl\<^sub>A\<^sub>B\<^sub>R C2 eif"
  apply (simp add: assms usubst uabr_comp uabr_simpl )
  apply pred_simp
  apply rel_simp
  apply auto
  apply (metis assms unrest_upred.rep_eq weak_lens.put_get)+
done

lemma assign_cond_trop3[uabr_comp]: (*needs more laws to be automatic*)
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3"
  shows "bif trop bp exp2 exp3 exp then (v \<Midarrow> exp ;; Simpl\<^sub>A\<^sub>B\<^sub>R C1) else (v \<Midarrow> exp ;;Simpl\<^sub>A\<^sub>B\<^sub>R C2) eif =
         v \<Midarrow> exp ;; bif trop bp exp2 exp3 (&v)  then Simpl\<^sub>A\<^sub>B\<^sub>R C1 else Simpl\<^sub>A\<^sub>B\<^sub>R C2 eif"
  apply (simp add: assms usubst uabr_comp uabr_simpl )
  apply pred_simp
  apply rel_simp
  apply auto
  apply (metis assms unrest_upred.rep_eq weak_lens.put_get)+
done

lemma assign_cond_qtop1[uabr_comp]: (*needs more laws to be automatic*)
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3" and 4: "v \<sharp> exp4"
  shows "bif qtop bp exp exp2 exp3 exp4 then (v \<Midarrow> exp ;; Simpl\<^sub>A\<^sub>B\<^sub>R C1) else (v \<Midarrow> exp ;; Simpl\<^sub>A\<^sub>B\<^sub>R C2) eif =
         v \<Midarrow> exp ;; bif qtop bp (&v) exp2 exp3 exp4 then Simpl\<^sub>A\<^sub>B\<^sub>R C1 else Simpl\<^sub>A\<^sub>B\<^sub>R C2 eif"
  apply (simp add: assms usubst uabr_comp uabr_simpl )
  apply pred_simp
  apply rel_simp
  apply auto
  apply (metis assms unrest_upred.rep_eq weak_lens.put_get)+
done

lemma assign_c_cond_qtop2[uabr_comp]: (*needs more laws to be automatic*)
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3" and 4:"v \<sharp> exp4"
  shows "bif qtop bp exp2 exp  exp3 exp4 then (v \<Midarrow> exp ;; Simpl\<^sub>A\<^sub>B\<^sub>R C1) else (v \<Midarrow> exp ;; Simpl\<^sub>A\<^sub>B\<^sub>R C2) eif =
         v \<Midarrow> exp ;; bif qtop bp exp2 (&v) exp3 exp4 then Simpl\<^sub>A\<^sub>B\<^sub>R C1 else Simpl\<^sub>A\<^sub>B\<^sub>R C2 eif"
  apply (simp add: assms usubst uabr_comp uabr_simpl )
  apply pred_simp
  apply rel_simp
  apply auto
  apply (metis assms unrest_upred.rep_eq weak_lens.put_get)+
done

lemma assign_c_cond_qtop3[uabr_comp]: (*needs more laws to be automatic*)
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3" and 4: "v \<sharp> exp4"
  shows "bif qtop bp exp2 exp3 exp exp4 then (v \<Midarrow> exp ;; Simpl\<^sub>A\<^sub>B\<^sub>R C1) else (v \<Midarrow> exp ;; Simpl\<^sub>A\<^sub>B\<^sub>R C2) eif =
         v \<Midarrow> exp ;; bif qtop bp exp2  exp3 (&v) exp4 then Simpl\<^sub>A\<^sub>B\<^sub>R C1 else Simpl\<^sub>A\<^sub>B\<^sub>R C2 eif"
  apply (simp add: assms usubst uabr_comp uabr_simpl )
  apply pred_simp
  apply rel_simp
  apply auto
  apply (metis assms unrest_upred.rep_eq weak_lens.put_get)+
done

lemma assign_c_cond_qtop4[uabr_comp]: (*needs more laws to be automatic*)
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3" and 4: "v \<sharp> exp4"
  shows "bif qtop bp exp2 exp3 exp4 exp then (v \<Midarrow> exp ;; Simpl\<^sub>A\<^sub>B\<^sub>R C1) else (v \<Midarrow> exp ;; Simpl\<^sub>A\<^sub>B\<^sub>R C2) eif =
         v \<Midarrow> exp ;; bif qtop bp exp2  exp3 exp4 (&v)  then Simpl\<^sub>A\<^sub>B\<^sub>R C1 else Simpl\<^sub>A\<^sub>B\<^sub>R C2 eif"
  apply (simp add: assms usubst uabr_comp uabr_simpl)
  apply pred_simp
  apply rel_simp
  apply auto
  apply (metis assms unrest_upred.rep_eq weak_lens.put_get)+
done

lemma assign_c_cond_If [uabr_cond]:
  "(bif bexp then (v \<Midarrow> exp1) else (v \<Midarrow> exp2) eif) =
   (v \<Midarrow> (exp1 \<triangleleft> bexp \<triangleright> exp2))"
  by rel_auto

subsection {*While laws*}
text{*In this section we introduce the algebraic laws of programming related to the while
      statement.*}

theorem while_unfold:
  "while b do P od = (bif b then (P ;; while b do P od) else SKIP\<^sub>A\<^sub>B\<^sub>R eif)"
proof -
  have m:"mono (\<lambda>X. bif b then (P ;; X) else SKIP\<^sub>A\<^sub>B\<^sub>R eif)"
    by (auto intro: monoI seqr_mono if_mono)
  have "(while b do P od) = (\<nu> X \<bullet> bif b then (P ;; X) else SKIP\<^sub>A\<^sub>B\<^sub>R eif)"
    by (simp add: While_def)
  also have "... = (bif b then (P ;; (\<nu> X \<bullet> bif b then (P ;; X) else SKIP\<^sub>A\<^sub>B\<^sub>R eif)) else SKIP\<^sub>A\<^sub>B\<^sub>R eif)"
    by (subst lfp_unfold,simp_all add:m )
  also have "... = (bif b then (P ;; while b do P od) else SKIP\<^sub>A\<^sub>B\<^sub>R eif)"
    by (simp add: While_def)
  finally show ?thesis .
qed

(*lemma while_true:
  shows "(while true do P od) = \<top>\<^sub>A\<^sub>B\<^sub>R"
  apply (simp add: While_def alpha)
  apply (rule antisym)
  apply (simp_all)
  apply (rule conjI)
  apply (rule lfp_lowerbound)
  apply (simp add: C3_abr_def design_def cond_def)
  apply rel_auto
  apply (frule cond_mono)
done*)

lemma while_false:
  shows "(while false do P od) = SKIP\<^sub>A\<^sub>B\<^sub>R"
proof -
  have "(while false do P od) = bif false then (P ;; while false do P od) else SKIP\<^sub>A\<^sub>B\<^sub>R eif"
    using while_unfold[of _ P] by simp
  also have "... = SKIP\<^sub>A\<^sub>B\<^sub>R" by rel_blast
  finally show ?thesis .
qed

lemma while_inv_unfold:
  "while b invr p do P od = (bif b then (P ;; while b invr p do P od) else SKIP\<^sub>A\<^sub>B\<^sub>R eif)"
  unfolding While_inv_def using while_unfold
  by auto

theorem while_bot_unfold:
  "while\<^sub>\<bottom> b do P od = (bif b then (P ;; while\<^sub>\<bottom> b do P od) else SKIP\<^sub>A\<^sub>B\<^sub>R eif)"
proof -
  have m:"mono (\<lambda>X. bif b then (P ;; X) else SKIP\<^sub>A\<^sub>B\<^sub>R eif)"
    by (auto intro: monoI seqr_mono if_mono)
  have "(while\<^sub>\<bottom> b do P od) = (\<mu> X \<bullet> bif b then (P ;; X) else SKIP\<^sub>A\<^sub>B\<^sub>R eif)"
    by (simp add: While_bot_def)
  also have "... = (bif b then (P ;; (\<mu> X \<bullet> bif b then (P ;; X) else SKIP\<^sub>A\<^sub>B\<^sub>R eif)) else SKIP\<^sub>A\<^sub>B\<^sub>R eif)"
    by (subst gfp_unfold, simp_all add: m)
  also have "... = (bif b then (P ;; while\<^sub>\<bottom> b do P od) else SKIP\<^sub>A\<^sub>B\<^sub>R eif)"
    by (simp add: While_bot_def)
  finally show ?thesis .
qed

term "while\<^sub>\<bottom> b do P od"

theorem while_bot_false: "while\<^sub>\<bottom> false do P od = SKIP\<^sub>A\<^sub>B\<^sub>R"
  by (simp add: While_bot_def mu_const alpha)

theorem while_bot_true: "while\<^sub>\<bottom> true do P od = (\<mu> X \<bullet> (P ;; X))"
  by (simp add: While_bot_def alpha)

subsection {*assume laws*}

lemma assume_twice[uabr_comp]: "(b\<^sup>\<top>\<^sup>C ;; c\<^sup>\<top>\<^sup>C) = (b \<and> c)\<^sup>\<top>\<^sup>C"
  apply pred_simp
  apply auto
  apply (rel_simp)+
  apply blast
  apply (rel_simp)+
  apply (metis (full_types))
done

lemma assert_twice[uabr_comp]: "(b\<^sub>\<bottom>\<^sub>C ;; c\<^sub>\<bottom>\<^sub>C) = (b \<and> c)\<^sub>\<bottom>\<^sub>C"
  apply pred_simp
  apply auto
  apply (rel_simp)+
  apply blast
  apply (rel_simp)+
  apply (metis (full_types))
done

subsection {*Try Catch laws*}
(*see utp_hoare_helper*)

end