theory NetworkAnalysis
imports DisjunctIPs StanfordHelpers "../topoS/interface_abstraction/Network_ex"
begin

definition "valid_network_formers ifaces iface_links forwarding_map \<equiv>
  wellformed_network (network_of ifaces iface_links forwarding_map) \<and>
  (\<forall>tbl \<in> snd ` set forwarding_map. correct_routing tbl) \<and>
  entity ` ifaces \<subseteq> fst ` set forwarding_map \<and>
  single_valued (set forwarding_map)
"

lemma valid_network_formers_code[code_unfold]: "valid_network_formers = (\<lambda> i l t.
  wellformed_network (network_of i l t) \<and>
  foldr (op \<and>) (map (correct_routing \<circ> snd) t) True \<and>
  entity ` i \<subseteq> set (map fst t) \<and>
  single_valued (set t))"
  unfolding fun_eq_iff
  unfolding valid_network_formers_def
  unfolding set_map
  unfolding foldr_map
  unfolding comp_def
  unfolding foldr_True_set
  by simp

lemma valid_formers_valid_prefixes: "valid_network_formers i il fm \<Longrightarrow> all_valid_prefixes (map snd fm)"
  unfolding
    all_valid_prefixes_def
    valid_network_formers_def
    correct_routing_def
proof -
  case goal1
  have "\<forall>tbl\<in>set fm. valid_prefixes (snd tbl)" using goal1 by simp
  then show ?case by(induction fm) simp_all
qed

lemma view_hdr_infold:
  "view network header = view \<lparr> interfaces = interfaces network,
    forwarding = (\<lambda> entity port hdr. (forwarding network) entity port header), links = links network \<rparr> header"
unfolding view_def traverse_def succ_def by(simp only: network.simps)

lemma fst_e_imp_snd_e: "e \<in> set (map fst tbls) \<Longrightarrow> (the \<circ> map_of tbls) e \<in> set (map snd tbls)"
  by(induction tbls) auto

lemma network_of_src_inv: "view (network_of i l tbls) (srca, dst) = view (network_of i l tbls) (srcb, dst)"
  unfolding network_of_def block_reoutput_def
  unfolding packet_routing_table_semantics_def
  unfolding dst_addr_def extract_addr_def snd_def
  unfolding view_def traverse_def succ_def
  unfolding network.simps
  by simp

lemma network_of_Host_eq_NB[simp]: "view (network_of i l tbls) (src, NetworkBox dst) = view (network_of i l tbls) (src, Host dst)"
  unfolding network_of_def block_reoutput_def
  unfolding packet_routing_table_semantics_def
  unfolding dst_addr_def extract_addr_def snd_def
  unfolding view_def traverse_def succ_def
  unfolding network.simps
  by simp

definition "all_views ifs ifls tbls \<equiv> (map (\<lambda>cdst. view (network_of ifs ifls tbls) (Host 0, Host cdst)) (covering_iplist (map snd tbls)))"

theorem all_views_complete:
  assumes "valid_network_formers i l tbls"
  shows "view (network_of i l tbls) pkg
    \<in> set (all_views i l tbls)"
proof -
  obtain src wdst where pkg_split: "pkg = (src, wdst)" by force
  obtain dst where dst_split: "Host dst = wdst \<or> NetworkBox dst = wdst" by(metis entity.exhaust)
  let ?csrc = "Host 0" (* Arbitrary source in all_views *)
  note conjunct31 = conjunct1[OF conjunct2[OF conjunct2]]
  case goal1
  note covering_iplists_ex_representative_set[OF valid_formers_valid_prefixes[OF assms], of dst]
    then guess reprS .. note lS = this
  let ?repr = "the (ipv4rq_lowest_element reprS)"
  have "\<not>ipv4rq_empty reprS" using lS(2) unfolding ipv4rq_empty_set_eq ipv4rq_element_set_eq by blast
  from ipv4rq_lowest_in[OF this, unfolded ipv4rq_element_set_eq] have representant_replacement:
    "\<And>entity. entity \<in> set (map fst tbls) \<Longrightarrow> routing_table_semantics ((the \<circ> map_of tbls) entity) dst
    = routing_table_semantics ((the \<circ> map_of tbls) entity) ?repr"
    using fst_e_imp_snd_e conjunct2[OF lS(2)] by fast
  have "view (network_of i l tbls) (src, Host dst) = view (network_of i l tbls) (src, Host ?repr)"
    using conjunct31[OF assms[unfolded valid_network_formers_def]] representant_replacement[simplified]
    by (subst view_hdr_infold)
       (subst view_hdr_infold[of _ "(src, Host ?repr)"],
        unfold network_of_def block_reoutput_def packet_routing_table_semantics_def, simp only: network.simps,
        unfold view_def traverse_def succ_def dst_addr_f[where f = Host, simplified], simp, fast)
  moreover have "view (network_of i l tbls) (src, Host ?repr)
    \<in> set (map (\<lambda>cdst. view (network_of i l tbls) (?csrc, Host cdst)) (covering_iplist (map snd tbls)))"
    unfolding covering_iplist_def
    unfolding comp_def map_map set_map
    unfolding network_of_src_inv[where srca = ?csrc and srcb = src]
    using imageI[OF lS(1)]
    .
  from this[unfolded calculation[symmetric]]
  show ?case unfolding all_views_def unfolding pkg_split using dst_split network_of_Host_eq_NB by auto
qed

definition "all_views_code ifs ifls tbls \<equiv> (map (\<lambda>cdst. view_code (network_of ifs ifls tbls) (Host 0, Host cdst)) (covering_iplist (map snd tbls)))"

lemma all_views_code_correct:
  assumes "wellformed_network (network_of ifs ifls tbls)"
  shows "all_views ifs ifls tbls = all_views_code ifs ifls tbls"
  unfolding all_views_def all_views_code_def
  unfolding view_code_correct[OF assms]
  ..

corollary all_network_analysis:
  assumes "valid_network_formers i l tbls"
  shows "(\<forall>x \<in> set (all_views i l tbls). analysis_fun x) \<Longrightarrow>
    \<not>(\<exists>y. \<not>analysis_fun (view (network_of i l tbls) y))"
using all_views_complete[OF assms] by simp

end


(*  Title:      RSAPSS/EMSAPSS.thy
    Author:     Christina Lindenberg, Kai Wirt, Technische Universität Darmstadt
    Copyright:  2005 - Technische Universität Darmstadt
*)

header "EMSA-PSS encoding and decoding operation"

theory EMSAPSS
imports SHA1 Wordarith
begin

text {* We define the encoding and decoding operations for the probabilistic
 signature scheme. Finally we show, that encoded messages always can be
 verified *}

definition show_rightmost_bits:: "bv \<Rightarrow> nat \<Rightarrow> bv" (* extract n rightmost bits of a bit string*)
  where "show_rightmost_bits bvec n = rev (take n (rev bvec))"

definition BC:: "bv" (* 0xbc *)
  where "BC = [One, Zero, One, One, One, One, Zero, Zero]"

definition salt:: "bv"
  where "salt = []"

definition sLen:: "nat" (* length of salt *)
  where "sLen = length salt"

definition generate_M':: "bv \<Rightarrow> bv \<Rightarrow> bv" (* generate_M' outputs "M'" a bit string of length "64 + length(sha1 _ ) + sLen" with 64 initial zero bits *)
  where "generate_M' mHash salt_new = bv_prepend 64 \<zero> [] @ mHash @ salt_new"

definition generate_PS:: "nat \<Rightarrow> nat \<Rightarrow> bv" (* generate_PS outputs "PS" a bit string consisting of "nat (roundup emBits 8) * 8 - sLen - length (sha1 _ ) - 16" zero bits *)
  where "generate_PS emBits hLen = bv_prepend ((roundup emBits 8)*8 - sLen - hLen - 16) \<zero> []"

definition generate_DB:: "bv \<Rightarrow> bv" (* generate_DB outputs the bit string DB="PS#(0x01)#salt" of length "nat (roundup emBits 8) * 8 - length (sha1 _ ) - 8" *)
  where "generate_DB PS = PS @ [Zero, Zero, Zero, Zero, Zero, Zero, Zero, One] @ salt"

definition maskedDB_zero:: "bv \<Rightarrow> nat \<Rightarrow> bv" (* sets "roundup emBits 8 * 8 - emBits" bits of maskedDB to zero *)
  where "maskedDB_zero maskedDB emBits = bv_prepend ((roundup emBits 8) * 8 - emBits)  \<zero> (drop ((roundup emBits 8)*8 - emBits) maskedDB)"

definition generate_H:: "bv \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bv" (* generate_H returns a bit string of length (sha1 _) *)
  where "generate_H EM emBits hLen = take hLen (drop ((roundup emBits 8)*8 - hLen - 8) EM)"

definition generate_maskedDB:: "bv \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bv " (* outputs a bit string of length "nat (roundup emBits 8) * 8 - length (sha1 _) - 8" *)
  where "generate_maskedDB EM emBits hLen = take ((roundup emBits 8)*8 - hLen - 8) EM"

definition generate_salt:: "bv \<Rightarrow> bv" (* outputs a bit string of length sLen *)
  where "generate_salt DB_zero = show_rightmost_bits DB_zero sLen"

primrec MGF2:: "bv \<Rightarrow> nat \<Rightarrow> bv" (* help function for MGF1 *)
where
  "MGF2 Z 0 = sha1 (Z@(nat_to_bv_length 0 32))"
| "MGF2 Z (Suc n) = (MGF2 Z n)@(sha1 (Z@(nat_to_bv_length (Suc n) 32)))"

definition MGF1:: "bv \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bv" (* help function for MGF *)
  where "MGF1 Z n l = take l (MGF2 Z n)"

definition MGF:: "bv \<Rightarrow> nat \<Rightarrow> bv" (* mask generation function *)
where
  "MGF Z l = (if l = 0 \<or> 2^32*(length (sha1 Z)) < l
              then []
              else MGF1 Z ( roundup l (length (sha1 Z))  - 1 ) l)"

definition emsapss_encode_help8:: "bv \<Rightarrow> bv \<Rightarrow> bv"
  where "emsapss_encode_help8 DBzero H = DBzero @ H @ BC"

definition emsapss_encode_help7:: "bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bv"
  where "emsapss_encode_help7 maskedDB H emBits =
    emsapss_encode_help8 (maskedDB_zero maskedDB emBits) H"

definition emsapss_encode_help6:: "bv \<Rightarrow> bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bv"
  where "emsapss_encode_help6 DB dbMask H emBits =
    (if dbMask = []
     then []
     else emsapss_encode_help7 (bvxor DB dbMask) H emBits)"

definition emsapss_encode_help5:: "bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bv"
  where "emsapss_encode_help5 DB H emBits =
    emsapss_encode_help6 DB (MGF H (length DB)) H emBits"

definition emsapss_encode_help4:: "bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bv"
  where "emsapss_encode_help4 PS H emBits =
    emsapss_encode_help5 (generate_DB PS) H emBits"

definition emsapss_encode_help3:: "bv \<Rightarrow> nat \<Rightarrow> bv"
  where "emsapss_encode_help3 H emBits =
    emsapss_encode_help4 (generate_PS emBits (length H)) H emBits"

definition emsapss_encode_help2:: "bv \<Rightarrow> nat \<Rightarrow> bv"
  where "emsapss_encode_help2 M' emBits = emsapss_encode_help3 (sha1 M') emBits"

definition emsapss_encode_help1:: "bv \<Rightarrow> nat \<Rightarrow> bv"
  where "emsapss_encode_help1 mHash emBits =
    (if emBits  < length (mHash) + sLen + 16
     then []
     else emsapss_encode_help2 (generate_M' mHash salt) emBits)"

definition emsapss_encode:: "bv \<Rightarrow> nat \<Rightarrow> bv" (* outputs the encoded message of length emBits *)
  where "emsapss_encode M emBits =
    (if (2^64 \<le> length M \<or> 2^32 * 160 < emBits)
     then []
     else emsapss_encode_help1 (sha1 M) emBits)"

definition emsapss_decode_help11:: "bv \<Rightarrow> bv \<Rightarrow> bool"
  where "emsapss_decode_help11 H' H = (if H' \<noteq> H then False else True)"

definition emsapss_decode_help10:: "bv \<Rightarrow> bv \<Rightarrow> bool"
  where "emsapss_decode_help10 M' H = emsapss_decode_help11 (sha1 M') H"

definition emsapss_decode_help9:: "bv \<Rightarrow> bv \<Rightarrow> bv \<Rightarrow> bool"
  where "emsapss_decode_help9 mHash salt_new H =
    emsapss_decode_help10 (generate_M' mHash salt_new) H"

definition emsapss_decode_help8:: "bv \<Rightarrow> bv \<Rightarrow> bv \<Rightarrow> bool"
  where "emsapss_decode_help8 mHash DB_zero H =
    emsapss_decode_help9 mHash (generate_salt DB_zero) H"

definition emsapss_decode_help7:: "bv \<Rightarrow> bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bool"
  where "emsapss_decode_help7 mHash DB_zero H emBits =
   (if (take ( (roundup emBits 8)*8 - (length mHash) - sLen - 16) DB_zero \<noteq> bv_prepend ( (roundup emBits 8)*8 - (length mHash) - sLen - 16) \<zero> []) \<or> (take 8 ( drop ((roundup emBits 8)*8 - (length mHash) - sLen - 16 ) DB_zero ) \<noteq> [Zero, Zero, Zero, Zero, Zero, Zero, Zero, One])
    then False
    else emsapss_decode_help8 mHash DB_zero H)"

definition emsapss_decode_help6:: "bv \<Rightarrow> bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bool"
  where "emsapss_decode_help6 mHash DB H emBits =
    emsapss_decode_help7 mHash (maskedDB_zero DB emBits) H emBits"

definition emsapss_decode_help5:: "bv \<Rightarrow> bv \<Rightarrow> bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bool"
  where "emsapss_decode_help5 mHash maskedDB dbMask H emBits =
    emsapss_decode_help6 mHash (bvxor maskedDB dbMask) H emBits"

definition emsapss_decode_help4:: "bv \<Rightarrow> bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bool"
  where "emsapss_decode_help4 mHash maskedDB H emBits =
   (if take ((roundup emBits 8)*8 - emBits) maskedDB \<noteq> bv_prepend ((roundup emBits 8)*8 - emBits) \<zero> []
    then False
    else emsapss_decode_help5 mHash maskedDB (MGF H ((roundup emBits 8)*8 - (length mHash) - 8)) H emBits)"

definition emsapss_decode_help3:: "bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bool"
  where "emsapss_decode_help3 mHash EM emBits =
    emsapss_decode_help4 mHash (generate_maskedDB EM emBits (length mHash)) (generate_H EM emBits (length mHash)) emBits"

definition emsapss_decode_help2:: "bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bool"
  where "emsapss_decode_help2 mHash EM emBits =
   (if show_rightmost_bits EM 8 \<noteq> BC
    then False
    else emsapss_decode_help3 mHash EM emBits)"

definition emsapss_decode_help1:: "bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bool"
  where "emsapss_decode_help1 mHash EM emBits =
    (if emBits < length (mHash) + sLen + 16
     then False
     else emsapss_decode_help2 mHash EM emBits)"

definition emsapss_decode:: "bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bool" (* outputs "true" if EM is encoding of M *)
  where "emsapss_decode M EM emBits =
    (if (2^64 \<le> length M \<or> 2^32*160<emBits)
     then False
     else emsapss_decode_help1 (sha1 M) EM emBits)"

lemma roundup_positiv: "0 < emBits \<Longrightarrow> 0 < (roundup emBits 160)"
  by (simp add: roundup, safe, simp)

lemma roundup_ge_emBits:" 0 < emBits \<Longrightarrow> 0 < x \<Longrightarrow> emBits \<le> (roundup emBits x) * x"
  apply (simp add: roundup mult.commute)
  apply (safe)
  apply (simp)
  apply (simp add: add.commute [of x "x*(emBits div x)" ])
  apply (insert mod_div_equality2 [of x emBits])
  apply (subgoal_tac "emBits mod x < x")
  apply (arith)
  apply (simp only: mod_less_divisor)
  done

lemma roundup_ge_0: "0 < emBits \<Longrightarrow> 0 < x \<Longrightarrow> 0 \<le> roundup emBits x * x - emBits"
  by (simp add: roundup)

lemma roundup_le_7: "0 < emBits \<Longrightarrow> roundup emBits 8 * 8 - emBits \<le>  7"
  apply (simp add: roundup)
  apply (insert  div_mod_equality [of emBits 8 1])
  apply arith
  done

lemma roundup_nat_ge_8_help:
  "length (sha1 M) + sLen + 16 \<le> emBits \<Longrightarrow> 8 \<le> roundup emBits 8 * 8 - (length (sha1 M) + 8)"
  apply (insert roundup_ge_emBits [of emBits 8])
  apply (simp add: roundup sha1len sLen_def)
  done

lemma roundup_nat_ge_8:
  "length (sha1 M) + sLen + 16 \<le> emBits \<Longrightarrow> 8 \<le> roundup emBits 8 * 8 - (length (sha1 M) + 8)"
  apply (insert roundup_nat_ge_8_help [of M emBits])
  apply arith
  done

lemma roundup_le_ub:
  "\<lbrakk> 176 + sLen \<le> emBits; emBits \<le> 2^32 * 160\<rbrakk> \<Longrightarrow> (roundup emBits 8) * 8 - 168 \<le> 2^32 * 160"
  apply (simp add: roundup)
  apply (safe)
  apply (simp)
  apply (arith)+
  done

lemma modify_roundup_ge1: "\<lbrakk>8 \<le> roundup emBits 8 * 8 - 168\<rbrakk> \<Longrightarrow> 176 \<le>  roundup emBits 8 * 8"
  by arith

lemma modify_roundup_ge2: "\<lbrakk> 176 \<le> roundup emBits 8 * 8\<rbrakk> \<Longrightarrow> 21 < roundup emBits 8"
  by simp

lemma roundup_help1: "\<lbrakk> 0 < roundup l 160\<rbrakk> \<Longrightarrow> (roundup l 160 - 1) + 1 = (roundup l 160)"
  by arith

lemma roundup_help1_new: "\<lbrakk> 0 < l\<rbrakk> \<Longrightarrow> (roundup l 160 - 1) + 1 = (roundup l 160)"
  apply (drule roundup_positiv [of l])
  apply arith
  done

lemma roundup_help2: "\<lbrakk>176 + sLen \<le> emBits\<rbrakk> \<Longrightarrow> roundup emBits 8 * 8 - emBits <=  roundup emBits 8 * 8 - 160 - sLen - 16"
  by (simp add: sLen_def)

lemma bv_prepend_equal: "bv_prepend (Suc n) b l = b#bv_prepend n b l"
  by (simp add: bv_prepend)

lemma length_bv_prepend: "length (bv_prepend n b l) = n+length l"
  by (induct n) (simp_all add: bv_prepend)

lemma length_bv_prepend_drop: "a <= length xs \<longrightarrow> length (bv_prepend a b (drop a xs)) = length xs"
  by (simp add:length_bv_prepend)

lemma take_bv_prepend: "take n (bv_prepend n b x) = bv_prepend n b []"
  by (induct n) (simp add: bv_prepend)+

lemma take_bv_prepend2: "take n (bv_prepend n b xs@ys@zs) = bv_prepend n b []"
  by (induct n) (simp add: bv_prepend)+

lemma bv_prepend_append: "bv_prepend a b x = bv_prepend a b [] @ x"
  by (induct a) (simp add: bv_prepend, simp add: bv_prepend_equal)

lemma bv_prepend_append2:
  "x < y \<Longrightarrow> bv_prepend y b xs = (bv_prepend x b [])@(bv_prepend (y-x) b [])@xs"
  by (simp add: bv_prepend replicate_add [symmetric])

lemma drop_bv_prepend_help2: "\<lbrakk>x < y\<rbrakk> \<Longrightarrow> drop x (bv_prepend y b []) = bv_prepend (y-x) b []"
  apply (insert bv_prepend_append2 [of "x" "y" b "[]"])
  by (simp add: length_bv_prepend)

lemma drop_bv_prepend_help3: "\<lbrakk>x = y\<rbrakk> \<Longrightarrow> drop x (bv_prepend y b []) = bv_prepend (y-x) b []"
  apply (insert length_bv_prepend [of y b "[]"])
  by (simp add: bv_prepend)

lemma bv_prepend_add: "bv_prepend x b [] @ bv_prepend y b [] = bv_prepend (x + y) b []"
  by (induct x) (simp add: bv_prepend)+

lemma bv_prepend_drop: "x \<le> y \<longrightarrow> bv_prepend x b (drop x (bv_prepend y b [])) = bv_prepend y b []"
  apply (simp add: drop_bv_prepend_help4 [of x y b])
  by (simp add: bv_prepend_append [of "x" b "(bv_prepend (y - x) b [])"] bv_prepend_add)

lemma bv_prepend_split: "bv_prepend x b (left @ right) = bv_prepend x b left @ right"
  by (induct x) (simp add: bv_prepend)+

lemma length_generate_DB: "length (generate_DB PS) = length PS + 8 + sLen"
  by (simp add: generate_DB_def sLen_def)

lemma length_generate_PS: "length (generate_PS emBits 160) = (roundup emBits 8)*8 - sLen - 160 - 16"
  by (simp add: generate_PS_def length_bv_prepend)

lemma length_bvxor: "length a = length b \<Longrightarrow> length (bvxor a b) = length a"
  by (simp add: bvxor)

lemma length_MGF2: "length (MGF2 Z m) = Suc m * length (sha1 (Z @ nat_to_bv_length m 32))"
  by (induct m) (simp+, simp add: sha1len)

lemma length_MGF1: "l \<le> (Suc n) * 160 \<Longrightarrow> length (MGF1 Z n l) = l"
  by (simp add: MGF1_def length_MGF2 sha1len)

lemma length_MGF: "0 < l \<Longrightarrow> l \<le>  2^32 * length (sha1 x) \<Longrightarrow> length (MGF x l) = l"
  apply (simp add: MGF_def sha1len)
  apply (insert roundup_help1_new [of l])
  apply (rule length_MGF1)
  apply (simp)
  apply (insert roundup_ge_emBits [of l 160])
  apply (arith)
  done

lemma solve_length_generate_DB:
  "\<lbrakk> 0 < emBits; length (sha1 M) + sLen + 16 \<le> emBits\<rbrakk>
  \<Longrightarrow> length (generate_DB (generate_PS emBits (length (sha1 x)) )) = (roundup emBits 8) * 8 - 168"
  apply (insert roundup_ge_emBits [of emBits 8])
  apply (simp add: length_generate_DB length_generate_PS sha1len)
  done

lemma length_maskedDB_zero:
  "\<lbrakk> roundup emBits 8 * 8 - emBits \<le> length maskedDB\<rbrakk>
  \<Longrightarrow> length (maskedDB_zero maskedDB emBits) = length maskedDB"
  by (simp add: maskedDB_zero_def length_bv_prepend)

lemma take_equal_bv_prepend:
  "\<lbrakk> 176 + sLen \<le> emBits; roundup emBits 8 * 8 - emBits \<le> 7\<rbrakk>
  \<Longrightarrow> take (roundup emBits 8 * 8 - length (sha1 M) - sLen - 16) (maskedDB_zero (generate_DB (generate_PS emBits 160)) emBits) =
    bv_prepend (roundup emBits 8 * 8 - length (sha1 M) - sLen - 16) \<zero> []"
  apply (insert roundup_help2 [of emBits] length_generate_PS [of emBits])
  apply (simp add: sha1len maskedDB_zero_def generate_DB_def generate_PS_def
    bv_prepend_split bv_prepend_drop)
  done

lemma lastbits_BC: "BC = show_rightmost_bits (xs @ ys @ BC) 8"
  by (simp add: show_rightmost_bits_def BC_def)

lemma equal_zero:
  "176 + sLen \<le> emBits \<Longrightarrow> roundup emBits 8 * 8 - emBits \<le> roundup emBits 8 * 8 - (176 + sLen)
  \<Longrightarrow> 0 = roundup emBits 8 * 8 - emBits - (roundup emBits 8 * 8 - (176 + sLen))"
  by arith

lemma get_salt: "\<lbrakk> 176 + sLen \<le> emBits; roundup emBits 8 * 8 - emBits \<le> 7\<rbrakk> \<Longrightarrow> (generate_salt (maskedDB_zero (generate_DB (generate_PS emBits 160)) emBits)) = salt"
  apply (insert roundup_help2 [of emBits] length_generate_PS [of emBits] equal_zero [of emBits])
  apply (simp add: generate_DB_def generate_PS_def maskedDB_zero_def)
  apply (simp add: bv_prepend_split bv_prepend_drop generate_salt_def
    show_rightmost_bits_def sLen_def)
  done

lemma generate_maskedDB_elim: "\<lbrakk>roundup emBits 8 * 8 - emBits \<le> length x; ( roundup emBits 8) * 8 - (length (sha1 M)) - 8 = length (maskedDB_zero x emBits)\<rbrakk> \<Longrightarrow> generate_maskedDB (maskedDB_zero x emBits @ y @ z) emBits (length(sha1 M)) = maskedDB_zero x emBits"
  apply (simp add: maskedDB_zero_def)
  apply (insert length_bv_prepend_drop [of "(roundup emBits 8 * 8 - emBits)" "x"])
  apply (simp add: generate_maskedDB_def)
  done

lemma generate_H_elim: "\<lbrakk> roundup emBits 8 * 8 - emBits \<le> length x; length (maskedDB_zero x emBits) =  (roundup emBits 8) * 8 - 168; length y = 160\<rbrakk> \<Longrightarrow> generate_H (maskedDB_zero x emBits @ y @ z) emBits 160 = y"
  apply (simp add: maskedDB_zero_def)
  apply (insert length_bv_prepend_drop [of "roundup emBits 8 * 8 - emBits" "x"])
  apply (simp add: generate_H_def)
  done

lemma length_bv_prepend_drop_special: "[|roundup emBits 8 * 8 - emBits <= roundup emBits 8 * 8 - (176 + sLen); length (generate_PS emBits 160) = roundup emBits 8 * 8 - (176 + sLen)|] ==> length ( bv_prepend (roundup emBits 8 * 8 - emBits) \<zero> (drop (roundup emBits 8 * 8 - emBits) (generate_PS emBits 160))) = length (generate_PS emBits 160)"
  by (simp add: length_bv_prepend_drop)

lemma x01_elim: "\<lbrakk>176 + sLen \<le> emBits; roundup emBits 8 * 8 - emBits \<le> 7\<rbrakk> \<Longrightarrow> take 8 (drop (roundup emBits 8 * 8 - (length (sha1 M) + sLen + 16))(maskedDB_zero (generate_DB (generate_PS emBits 160)) emBits)) = [\<zero>, \<zero>, \<zero>, \<zero>, \<zero>, \<zero>, \<zero>, \<one>]"
  apply (insert roundup_help2 [of emBits] length_generate_PS [of emBits] equal_zero [of emBits])
  apply (simp add: sha1len maskedDB_zero_def generate_DB_def generate_PS_def
    bv_prepend_split bv_prepend_drop)
  done

lemma bvxorxor_elim_help:
  assumes "x <= length a" and "length a = length b"
  shows "bv_prepend x \<zero> (drop x (bvxor (bv_prepend x \<zero> (drop x (bvxor a b))) b)) =
    bv_prepend x \<zero> (drop x a)"
proof -
  have "drop x (bvxor (bv_prepend x \<zero> (drop x (bvxor a b))) b) = drop x a"
    apply (unfold bvxor bv_prepend)
    apply (cut_tac assms)
    apply (insert length_replicate [of x \<zero> ])
    apply (insert length_drop [of x a])
    apply (insert length_drop [of x b])
    apply (insert length_bvxor [of "drop x a" "drop x b"])
    apply (subgoal_tac "length (replicate x \<zero> @ drop x (bv_mapzip op \<oplus>\<^sub>b a b)) = length b")
    apply (subgoal_tac "b = (take x b)@(drop x b)")
    apply (insert drop_bv_mapzip [of x "(replicate x \<zero> @ drop x (bv_mapzip op \<oplus>\<^sub>b a b))" b "op \<oplus>\<^sub>b"])
    apply (simp)
    apply (insert drop_bv_mapzip [of x a b "op \<oplus>\<^sub>b"])
    apply (simp)
    apply (fold bvxor)
    apply (simp_all)
    done
  with assms show ?thesis by simp
qed

lemma bvxorxor_elim: "\<lbrakk> roundup emBits 8 * 8 - emBits \<le> length a; length a = length b\<rbrakk> \<Longrightarrow> (maskedDB_zero (bvxor (maskedDB_zero (bvxor a b) emBits)b) emBits) = bv_prepend (roundup emBits 8 * 8 - emBits) \<zero> (drop (roundup emBits 8 * 8 - emBits) a)"
  by (simp add: maskedDB_zero_def bvxorxor_elim_help)

lemma verify: "\<lbrakk>(emsapss_encode M emBits) \<noteq> []; EM=(emsapss_encode M emBits)\<rbrakk> \<Longrightarrow> emsapss_decode M EM emBits = True"
  apply (simp add: emsapss_decode_def emsapss_encode_def)
  apply (safe, simp+)
  apply (simp add: emsapss_decode_help1_def emsapss_encode_help1_def)
  apply (safe, simp+)
  apply (simp add: emsapss_decode_help2_def emsapss_encode_help2_def)
  apply (safe)
  apply (simp add: emsapss_encode_help3_def emsapss_encode_help4_def
    emsapss_encode_help5_def emsapss_encode_help6_def)
  apply (safe)
  apply (simp add: emsapss_encode_help7_def emsapss_encode_help8_def lastbits_BC [symmetric])+
  apply (simp add: emsapss_decode_help3_def emsapss_encode_help3_def
    emsapss_decode_help4_def emsapss_encode_help4_def)
  apply (safe)
  apply (insert roundup_le_7 [of emBits] roundup_ge_0 [of emBits 8] roundup_nat_ge_8 [of M emBits])
  apply (simp add: generate_maskedDB_def emsapss_encode_help5_def emsapss_encode_help6_def)
  apply (safe)
  apply (simp)
  apply (simp add: emsapss_encode_help7_def)
  apply (simp only: emsapss_encode_help8_def)
  apply (simp only: maskedDB_zero_def)
  apply (simp only: take_bv_prepend2 min.absorb1)
  apply (simp)
  apply (simp add: emsapss_encode_help5_def emsapss_encode_help6_def)
  apply (safe)
  apply (simp)+
  apply (insert solve_length_generate_DB [of emBits M "generate_M' (sha1 M) salt"] roundup_le_ub [of emBits])
  apply (insert length_MGF [of "(roundup emBits 8) * 8 - 168" "(sha1 (generate_M' (sha1 M) salt))"])
  apply (insert modify_roundup_ge1 [of emBits] modify_roundup_ge2 [of emBits])
  apply (simp add: sha1len emsapss_encode_help7_def emsapss_encode_help8_def)
  apply (insert length_bvxor [of "(generate_DB (generate_PS emBits 160))" "(MGF (sha1 (generate_M' (sha1 M) salt)) ((roundup emBits 8) * 8 - 168))"])
  apply (insert generate_maskedDB_elim [of emBits "(bvxor (generate_DB (generate_PS emBits 160))(MGF (sha1 (generate_M' (sha1 M) salt)) ((roundup emBits 8) * 8 - 168)))" M "sha1 (generate_M' (sha1 M) salt)" BC])
  apply (insert length_maskedDB_zero [of emBits "(bvxor (generate_DB (generate_PS emBits 160))(MGF (sha1 (generate_M' (sha1 M) salt)) ((roundup emBits 8) * 8 - 168)))"])
  apply (insert generate_H_elim [of emBits "(bvxor (generate_DB (generate_PS emBits 160))(MGF (sha1 (generate_M' (sha1 M) salt)) (roundup emBits 8 * 8 - 168)))" "sha1 (generate_M' (sha1 M) salt)" BC])
  apply (simp add: sha1len emsapss_decode_help5_def)
  apply (simp only: emsapss_decode_help6_def emsapss_decode_help7_def)
  apply (insert bvxorxor_elim [of emBits "(generate_DB (generate_PS emBits 160))" "(MGF (sha1 (generate_M' (sha1 M) salt)) ((roundup emBits 8) * 8 - 168))"])
  apply (fold maskedDB_zero_def)
  apply (insert take_equal_bv_prepend [of emBits M] x01_elim [of emBits M] get_salt [of emBits])
  apply (simp add: emsapss_decode_help8_def emsapss_decode_help9_def emsapss_decode_help10_def emsapss_decode_help11_def)
  done

end


section {* UTP variables *}

theory utp_var
  imports
  Deriv
  "~~/src/HOL/Library/Prefix_Order"
  "~~/src/HOL/Library/Char_ord"
  "~~/src/Tools/Adhoc_Overloading"
  "~~/src/HOL/Library/Monad_Syntax"
  "~~/src/HOL/Library/Countable"
  "~~/src/HOL/Library/Order_Continuity"
  "~~/src/HOL/Eisbach/Eisbach"
  "../contrib/Complete_Lattice"
  "../contrib/Galois_Connection"
  "../optics/Lenses"
  "../utils/Profiling"
  "../utils/TotalRecall"
  "../utils/Pfun"
  "../utils/Ffun"
  "../utils/List_lexord_alt"
  "../utils/Monoid_extra"
  utp_parser_utils
  "../../../Front-End/Syntax_Translation"
  "../../../Front-End/Syntax_Adhoc_Overloading"
begin

text \<open> In this first UTP theory we set up variable, which are are built on lenses. A large part
  of this theory is setting up the parser for UTP variable syntax. \<close>

subsection \<open> Initial syntax setup \<close>

text \<open> We will overload the square order relation with refinement and also the lattice operators so
  we will turn off these notations. \<close>

purge_notation
  Order.le (infixl "\<sqsubseteq>\<index>" 50) and
  Lattice.sup ("\<Squnion>\<index>_" [90] 90) and
  Lattice.inf ("\<Sqinter>\<index>_" [90] 90) and
  Lattice.join (infixl "\<squnion>\<index>" 65) and
  Lattice.meet (infixl "\<sqinter>\<index>" 70) and
  LFP ("\<mu>\<index>") and
  GFP ("\<nu>\<index>") and
  Set.member ("op :") and
  Set.member ("(_/ : _)" [51, 51] 50) and
  disj  (infixr "|" 30)

text \<open> We hide HOL's built-in relation type since we will replace it with our own \<close>

hide_type rel
type_synonym 'a relation = "('a \<times> 'a) set"

declare fst_vwb_lens [simp]
declare snd_vwb_lens [simp]
declare comp_vwb_lens [simp]
declare lens_indep_left_ext [simp]
declare lens_indep_right_ext [simp]

subsection \<open> Variable foundations \<close>

text \<open> This theory describes the foundational structure of UTP variables, upon which the rest
  of our model rests. We start by defining alphabets, which following~\cite{Feliachi2010,Feliachi2012}
  in this shallow model are simply represented as types @{typ "'\<alpha>"}, though by convention usually a record
  type where each field corresponds to a variable. UTP variables in this frame are simply modelled
  as lenses @{typ "'a \<Longrightarrow> '\<alpha>"}, where the view type @{typ "'a"} is the variable type, and the
  source type @{text "'\<alpha>"} is the alphabet or state-space type.

  We define some lifting functions for variables to create input and output variables.
  These simply lift the alphabet to a tuple type since relations will ultimately be defined
  by a tuple alphabet.
\<close>

definition in_var :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> ('a \<Longrightarrow> '\<alpha> \<times> '\<beta>)" where
[lens_defs]: "in_var x = x ;\<^sub>L fst\<^sub>L"

definition out_var :: "('a \<Longrightarrow> '\<beta>) \<Rightarrow> ('a \<Longrightarrow> '\<alpha> \<times> '\<beta>)" where
[lens_defs]: "out_var x = x ;\<^sub>L snd\<^sub>L"

text \<open> Variables can also be used to effectively define sets of variables. Here we define the
  the universal alphabet ($\Sigma$) to be the bijective lens @{term "1\<^sub>L"}. This characterises
  the whole of the source type, and thus is effectively the set of all alphabet variables. \<close>

abbreviation (input) univ_alpha :: "('\<alpha> \<Longrightarrow> '\<alpha>)" ("\<Sigma>") where
"univ_alpha \<equiv> 1\<^sub>L"

text \<open> The next construct is vacuous and simply exists to help the parser distinguish predicate
  variables from input and output variables. \<close>

definition pr_var :: "('a \<Longrightarrow> '\<beta>) \<Rightarrow> ('a \<Longrightarrow> '\<beta>)" where
[lens_defs]: "pr_var x = x"

subsection \<open> Variable lens properties \<close>

text \<open> We can now easily show that our UTP variable construction are various classes of
  well-behaved lens .\<close>

lemma in_var_semi_uvar [simp]:
  "mwb_lens x \<Longrightarrow> mwb_lens (in_var x)"
  by (simp add: comp_mwb_lens in_var_def)

lemma pr_var_mwb_lens [simp]:
  "mwb_lens x \<Longrightarrow> mwb_lens (pr_var x)"
  by (simp add: pr_var_def)

lemma pr_var_vwb_lens [simp]:
  "vwb_lens x \<Longrightarrow> vwb_lens (pr_var x)"
  by (simp add: pr_var_def)

lemma in_var_uvar [simp]:
  "vwb_lens x \<Longrightarrow> vwb_lens (in_var x)"
  by (simp add: in_var_def)

lemma out_var_semi_uvar [simp]:
  "mwb_lens x \<Longrightarrow> mwb_lens (out_var x)"
  by (simp add: comp_mwb_lens out_var_def)

lemma out_var_uvar [simp]:
  "vwb_lens x \<Longrightarrow> vwb_lens (out_var x)"
  by (simp add: out_var_def)

text \<open> Moreover, we can show that input and output variables are independent, since they refer
  to different sections of the alphabet. \<close>

lemma out_in_indep [simp]:
  "out_var x \<bowtie> in_var y"
  by (simp add: lens_indep_def in_var_def out_var_def fst_lens_def snd_lens_def lens_comp_def)

lemma in_var_indep [simp]:
  "x \<bowtie> y \<Longrightarrow> in_var x \<bowtie> in_var y"
  by (simp add: in_var_def out_var_def)

lemma out_var_indep [simp]:
  "x \<bowtie> y \<Longrightarrow> out_var x \<bowtie> out_var y"
  by (simp add: out_var_def)

lemma pr_var_indeps [simp]:
  "x \<bowtie> y \<Longrightarrow> pr_var x \<bowtie> y"
  "x \<bowtie> y \<Longrightarrow> x \<bowtie> pr_var y"
  by (simp_all add: pr_var_def)

lemma prod_lens_indep_in_var [simp]:
  "a \<bowtie> x \<Longrightarrow> a \<times>\<^sub>L b \<bowtie> in_var x"
  by (metis in_var_def in_var_indep out_in_indep out_var_def plus_pres_lens_indep prod_as_plus)

lemma prod_lens_indep_out_var [simp]:
  "b \<bowtie> x \<Longrightarrow> a \<times>\<^sub>L b \<bowtie> out_var x"
  by (metis in_out_indep in_var_def out_var_def out_var_indep plus_pres_lens_indep prod_as_plus)

lemma in_var_pr_var [simp]:
  "in_var (pr_var x) = in_var x"
  by (simp add: pr_var_def)

lemma out_var_pr_var [simp]:
  "out_var (pr_var x) = out_var x"
  by (simp add: pr_var_def)

text \<open> Similar properties follow for sublens \<close>

lemma in_var_sublens [simp]:
  "y \<subseteq>\<^sub>L x \<Longrightarrow> in_var y \<subseteq>\<^sub>L in_var x"
  by (metis (no_types, hide_lams) in_var_def lens_comp_assoc sublens_def)

lemma out_var_sublens [simp]:
  "y \<subseteq>\<^sub>L x \<Longrightarrow> out_var y \<subseteq>\<^sub>L out_var x"
  by (metis (no_types, hide_lams) out_var_def lens_comp_assoc sublens_def)

lemma pr_var_sublens [simp]:
  "y \<subseteq>\<^sub>L x \<Longrightarrow> pr_var y \<subseteq>\<^sub>L pr_var x"
  by (simp add: pr_var_def)

subsection \<open> Lens simplifications \<close>

text \<open> We also define some lookup abstraction simplifications. \<close>

lemma var_lookup_in [simp]: "lens_get (in_var x) (A, A') = lens_get x A"
  by (simp add: in_var_def fst_lens_def lens_comp_def)

lemma var_lookup_out [simp]: "lens_get (out_var x) (A, A') = lens_get x A'"
  by (simp add: out_var_def snd_lens_def lens_comp_def)

lemma var_update_in [simp]: "lens_put (in_var x) (A, A') v = (lens_put x A v, A')"
  by (simp add: in_var_def fst_lens_def lens_comp_def)

lemma var_update_out [simp]: "lens_put (out_var x) (A, A') v = (A, lens_put x A' v)"
  by (simp add: out_var_def snd_lens_def lens_comp_def)

subsection \<open> Syntax translations \<close>

text \<open> In order to support nice syntax for variables, we here set up some translations. The first
  step is to introduce a collection of non-terminals. \<close>

nonterminal svid and svids and svar and svars and salpha

text \<open> These non-terminals correspond to the following syntactic entities. Non-terminal
  @{typ "svid"} is an atomic variable identifier, and @{typ "svids"} is a list of identifier.
  @{typ "svar"} is a decorated variable, such as an input or output variable, and @{typ "svars"} is
  a list of decorated variables. @{typ "salpha"} is an alphabet or set of variables. Such sets can
  be constructed only through lens composition due to typing restrictions. Next we introduce some
  syntax constructors. \<close>

syntax -- \<open> Identifiers \<close>
  "_svid"        :: "id \<Rightarrow> svid" ("_" [999] 999)
  "_svid_unit"   :: "svid \<Rightarrow> svids" ("_")
  "_svid_list"   :: "svid \<Rightarrow> svids \<Rightarrow> svids" ("_,/ _")
  "_svid_alpha"  :: "svid" ("\<Sigma>")
  "_svid_empty"  :: "svid" ("\<emptyset>")
  "_svid_dot"    :: "svid \<Rightarrow> svid \<Rightarrow> svid" ("_:_" [999,998] 999)

text \<open> A variable identifier can either be a HOL identifier, the complete set of variables in the
  alphabet $\Sigma$, the empty set $\emptyset$, or a composite identifier separated by colons, which
  corresponds to a sort of qualification. The final option is effectively a lens composition. \<close>

syntax -- \<open> Decorations \<close>
  "_spvar"       :: "svid \<Rightarrow> svar" ("&_" [998] 998)
  "_sinvar"      :: "svid \<Rightarrow> svar" ("$_" [998] 998)
  "_soutvar"     :: "svid \<Rightarrow> svar" ("$_\<acute>" [998] 998)

text \<open> A variable can be decorated with an ampersand, to indicate it is a predicate variable, with
  a dollar to indicate its an unprimed relational variable, or a dollar and ``acute'' symbol to
  indicate its a primed relational variable. Isabelle's parser is extensible so additional
  decorations can be and are added later. \<close>

syntax -- \<open> Variable sets \<close>
  "_salphaid"    :: "id \<Rightarrow> salpha" ("_" [998] 998)
  "_salphavar"   :: "svar \<Rightarrow> salpha" ("_" [998] 998)
  "_salphaparen" :: "salpha \<Rightarrow> salpha" ("'(_')")
  "_salphacomp"  :: "salpha \<Rightarrow> salpha \<Rightarrow> salpha" (infixr ";" 75)
  "_salphaprod"  :: "salpha \<Rightarrow> salpha \<Rightarrow> salpha" (infixr "\<times>" 85)
  "_svar_nil"    :: "svar \<Rightarrow> svars" ("_")
  "_svar_cons"   :: "svar \<Rightarrow> svars \<Rightarrow> svars" ("_,/ _")
  "_salphaset"   :: "svars \<Rightarrow> salpha" ("{_}")
  "_salphamk"    :: "logic \<Rightarrow> salpha"

text \<open> The terminals of an alphabet are either HOL identifiers or UTP variable identifiers.
  We support two ways of constructing alphabets; by composition of smaller alphabets using
  a semi-colon or by a set-style construction $\{a,b,c\}$ with a list of UTP variables. \<close>

syntax -- \<open> Quotations \<close>
  "_ualpha_set"  :: "svars \<Rightarrow> logic" ("{_}\<^sub>\<alpha>")
  "_svar"        :: "svar \<Rightarrow> logic" ("'(_')\<^sub>v")

text \<open> For various reasons, the syntax constructors above all yield specific grammar categories and
  will not parser at the HOL top level (basically this is to do with us wanting to reuse the syntax
  for expressions). As a result we provide some quotation constructors above.

  Next we need to construct the syntax translations rules. First we need a few polymorphic constants. \<close>

consts
  svar :: "'v \<Rightarrow> 'e"
  ivar :: "'v \<Rightarrow> 'e"
  ovar :: "'v \<Rightarrow> 'e"

adhoc_overloading
  svar pr_var and ivar in_var and ovar out_var

text \<open> The functions above turn a representation of a variable (type @{typ "'v"}), including
  its name and type, into some lens type @{typ "'e"}. @{term "svar"} constructs a predicate variable,
  @{term "ivar"} and input variables, and @{term "ovar"} and output variable. The functions bridge
  between the model and encoding of the variable and its interpretation as a lens in order to integrate it
  into the general lens-based framework. Overriding these functions is then all we need to make
  use of any kind of variables in terms of interfacing it with the system. Although in core UTP
  variables are always modelled using record field, we can overload these constants to allow other
  kinds of variables, such as deep variables with explicit syntax and type information.

  Finally, we set up the translations rules. \<close>
translations_params[no_print,equal_as_parse]
translations
  -- \<open> Identifiers \<close>
  "_svid x" \<rightharpoonup> "x"
  "_svid_alpha" \<rightleftharpoons> "\<Sigma>"
  "_svid_empty" \<rightleftharpoons> "0\<^sub>L"
  "_svid_dot x y" \<rightharpoonup> "y ;\<^sub>L x"

  -- \<open> Decorations \<close>
  "_spvar \<Sigma>"  \<leftharpoondown>  "CONST svar CONST id_lens"
  "_sinvar \<Sigma>"  \<leftharpoondown> "CONST ivar 1\<^sub>L"
  "_soutvar \<Sigma>" \<leftharpoondown> "CONST ovar 1\<^sub>L"
  "_spvar (_svid_dot x y)" \<leftharpoondown> "CONST svar (CONST lens_comp y x)"
  "_sinvar (_svid_dot x y)" \<leftharpoondown> "CONST ivar (CONST lens_comp y x)"
  "_soutvar (_svid_dot x y)" \<leftharpoondown> "CONST ovar (CONST lens_comp y x)"
  "_spvar x" \<rightleftharpoons> "CONST svar x"
  "_sinvar x" \<rightleftharpoons> "CONST ivar x"
  "_soutvar x" \<rightleftharpoons> "CONST ovar x"

  -- \<open> Alphabets \<close>
  "_salphaparen a" \<rightharpoonup> "a"
  "_salphaid x" \<rightharpoonup> "x"
  "_salphacomp x y" \<rightharpoonup> "x +\<^sub>L y"
  "_salphaprod a b" \<rightleftharpoons> "a \<times>\<^sub>L b"
  "_salphavar x" \<rightharpoonup> "x"
  "_svar_nil x" \<rightharpoonup> "x"
  "_svar_cons x xs" \<rightharpoonup> "x +\<^sub>L xs"
  "_salphaset A" \<rightharpoonup> "A"
  "(_svar_cons x (_salphamk y))" \<leftharpoondown> "_salphamk (x +\<^sub>L y)"
  "x" \<leftharpoondown> "_salphamk x"

  -- \<open> Quotations \<close>
  "_ualpha_set A" \<rightharpoonup> "A"
  "_svar x" \<rightharpoonup> "x"

text \<open> The translation rules mainly convert syntax into lens constructions, using a mixture
  of lens operators and the bespoke variable definitions. Notably, a colon variable identifier
  qualification becomes a lens composition, and variable sets are constructed using len sum.
  The translation rules are carefully crafted to ensure both parsing and pretty printing.

  Finally we create the following useful utility translation function that allows us to construct a
  UTP variable (lens) type given a return and alphabet type. \<close>

syntax
  "_uvar_ty"      :: "type \<Rightarrow> type \<Rightarrow> type"

parse_translation \<open>
let
  fun uvar_ty_tr [ty] = Syntax.const @{type_syntax lens} $ ty $ Syntax.const @{type_syntax dummy}
    | uvar_ty_tr ts = raise TERM ("uvar_ty_tr", ts);
in [(@{syntax_const "_uvar_ty"}, K uvar_ty_tr)] end
\<close>
end


theory Normalized_Matches
imports Fixed_Action
begin

section\<open>Normalized (DNF) matches\<close>

text\<open>simplify a match expression. The output is a list of match exprissions, the semantics is \<open>\<or>\<close> of the list elements.\<close>
fun normalize_match :: "'a match_expr \<Rightarrow> 'a match_expr list" where
  "normalize_match (MatchAny) = [MatchAny]" |
  "normalize_match (Match m) = [Match m]" |
  "normalize_match (MatchAnd m1 m2) = [MatchAnd x y. x <- normalize_match m1, y <- normalize_match m2]" |
  "normalize_match (MatchNot (MatchAnd m1 m2)) = normalize_match (MatchNot m1) @ normalize_match (MatchNot m2)" | (*DeMorgan*)
  "normalize_match (MatchNot (MatchNot m)) = normalize_match m" | (*idem*)
  "normalize_match (MatchNot (MatchAny)) = []" | (*false*)
  "normalize_match (MatchNot (Match m)) = [MatchNot (Match m)]"

lemma normalize_match_not_matcheq_matchNone: "\<forall>m' \<in> set (normalize_match m). \<not> matcheq_matchNone m'"
  proof(induction m rule: normalize_match.induct)
  case 4 thus ?case by (simp) blast
  qed(simp_all)

lemma normalize_match_empty_iff_matcheq_matchNone: "normalize_match m = [] \<longleftrightarrow> matcheq_matchNone m "
  proof(induction m rule: normalize_match.induct)
  case 3 thus ?case  by (simp) fastforce
  qed(simp_all)

lemma match_list_normalize_match: "match_list \<gamma> [m] a p \<longleftrightarrow> match_list \<gamma> (normalize_match m) a p"
  proof(induction m rule:normalize_match.induct)
  case 1 thus ?case by(simp add: match_list_singleton)
  next
  case 2 thus ?case by(simp add: match_list_singleton)
  next
  case (3 m1 m2) thus ?case
    apply(simp_all add: match_list_singleton del: match_list.simps(2))
    apply(case_tac "matches \<gamma> m1 a p")
     apply(rule matches_list_And_concat)
      apply(simp)
     apply(case_tac "(normalize_match m1)")
      apply simp
     apply (auto)[1]
    apply(simp add: bunch_of_lemmata_about_matches match_list_helper)
    done
  next
  case 4 thus ?case
    apply(simp_all add: match_list_singleton del: match_list.simps(2))
    apply(simp add: match_list_append)
    apply(safe)
        apply(simp_all add: matches_DeMorgan)
    done
  next
  case 5 thus ?case
    by(simp add: match_list_singleton bunch_of_lemmata_about_matches)
  next
  case 6 thus ?case
    by(simp add: match_list_singleton bunch_of_lemmata_about_matches)
  next
  case 7 thus ?case by(simp add: match_list_singleton)
qed

thm match_list_normalize_match[simplified match_list_singleton]

theorem normalize_match_correct: "approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m a) (normalize_match m)) s = approximating_bigstep_fun \<gamma> p [Rule m a] s"
apply(rule match_list_semantics[of _ _ _ _ "[m]", simplified])
using match_list_normalize_match by fastforce

lemma matches_to_match_list_normalize: "matches \<gamma> m a p = match_list \<gamma> (normalize_match m) a p"
  using match_list_normalize_match[simplified match_list_singleton] .

lemma wf_ruleset_normalize_match: "wf_ruleset \<gamma> p [(Rule m a)] \<Longrightarrow> wf_ruleset \<gamma> p (map (\<lambda>m. Rule m a) (normalize_match m))"
proof(induction m rule: normalize_match.induct)
  case 1 thus ?case by simp
  next
  case 2 thus ?case by simp
  next
  case 3 thus ?case by(simp add: fixedaction_wf_ruleset wf_ruleset_singleton matches_to_match_list_normalize)
  next
  case 4 thus ?case
    apply(simp add: wf_ruleset_append)
    apply(simp add: fixedaction_wf_ruleset)
    apply(unfold wf_ruleset_singleton)
    apply(safe) (*there is a simpler way but the simplifier takes for ever if we just apply it here, ...*)
           apply(simp_all add: matches_to_match_list_normalize)
         apply(simp_all add: match_list_append)
    done
  next
  case 5 thus ?case by(simp add: wf_ruleset_singleton matches_to_match_list_normalize)
  next
  case 6 thus ?case by(simp add: wf_ruleset_def)
  next
  case 7 thus ?case by(simp_all add: wf_ruleset_append)
  qed

lemma normalize_match_wf_ruleset: "wf_ruleset \<gamma> p (map (\<lambda>m. Rule m a) (normalize_match m)) \<Longrightarrow> wf_ruleset \<gamma> p [Rule m a]"
proof(induction m rule: normalize_match.induct)
  case 1 thus ?case by simp
  next
  case 2 thus ?case by simp
  next
  case 3 thus ?case by(simp add: fixedaction_wf_ruleset wf_ruleset_singleton matches_to_match_list_normalize)
  next
  case 4 thus ?case
    apply(simp add: wf_ruleset_append)
    apply(simp add: fixedaction_wf_ruleset)
    apply(unfold wf_ruleset_singleton)
    apply(safe)
         apply(simp_all add: matches_to_match_list_normalize)
         apply(simp_all add: match_list_append)
    done
  next
  case 5 thus ?case
    unfolding wf_ruleset_singleton by(simp add: matches_to_match_list_normalize)
  next
  case 6 thus ?case unfolding wf_ruleset_singleton by(simp add: bunch_of_lemmata_about_matches)
  next
  case 7 thus ?case by(simp add: wf_ruleset_append)
  qed

lemma good_ruleset_normalize_match: "good_ruleset [(Rule m a)] \<Longrightarrow> good_ruleset (map (\<lambda>m. Rule m a) (normalize_match m))"
by(simp add: good_ruleset_def)

section\<open>Normalizing rules instead of only match expressions\<close>
  fun normalize_rules :: "('a match_expr \<Rightarrow> 'a match_expr list) \<Rightarrow> 'a rule list \<Rightarrow> 'a rule list" where
    "normalize_rules _ [] = []" |
    "normalize_rules f ((Rule m a)#rs) = (map (\<lambda>m. Rule m a) (f m))@(normalize_rules f rs)"

  lemma normalize_rules_singleton: "normalize_rules f [Rule m a] = map (\<lambda>m. Rule m a) (f m)" by(simp)

  lemma normalize_rules_concat_map:
    "normalize_rules f rs = concat (map (\<lambda>r. map (\<lambda>m. Rule m (get_action r)) (f (get_match r))) rs)"
    apply(induction rs)
     apply(simp_all)
    apply(rename_tac r rs, case_tac r)
    apply(simp)
    done

  lemma good_ruleset_normalize_rules: "good_ruleset rs \<Longrightarrow> good_ruleset (normalize_rules f rs)"
    proof(induction rs)
    case Nil thus ?case by (simp)
    next
    case(Cons r rs)
      from Cons have IH: "good_ruleset (normalize_rules f rs)" using good_ruleset_tail by blast
      from Cons.prems have "good_ruleset [r]" using good_ruleset_fst by fast
      hence "good_ruleset (normalize_rules f [r])" by(cases r) (simp add: good_ruleset_alt)
      with IH good_ruleset_append have "good_ruleset (normalize_rules f [r] @ normalize_rules f rs)" by blast
      thus ?case using normalize_rules_fst by metis
    qed

  lemma simple_ruleset_normalize_rules: "simple_ruleset rs \<Longrightarrow> simple_ruleset (normalize_rules f rs)"
    proof(induction rs)
    case Nil thus ?case by (simp)
    next
    case(Cons r rs)
      from Cons have IH: "simple_ruleset (normalize_rules f rs)" using simple_ruleset_tail by blast
      from Cons.prems have "simple_ruleset [r]" using simple_ruleset_append by fastforce
      hence "simple_ruleset (normalize_rules f [r])" by(cases r) (simp add: simple_ruleset_def)
      with IH simple_ruleset_append have  "simple_ruleset (normalize_rules f [r] @ normalize_rules f rs)" by blast
      thus ?case using normalize_rules_fst by metis
    qed

  (*tuned version of the next lemma for usage with normalize_primitive_extract where P=normalized_nnf_match*)
  lemma normalize_rules_match_list_semantics_3:
    assumes "\<forall>m a. P m \<longrightarrow> match_list \<gamma> (f m) a p = matches \<gamma> m a p"
    and "simple_ruleset rs"
    and P: "\<forall> r \<in> set rs. P (get_match r)"
    shows "approximating_bigstep_fun \<gamma> p (normalize_rules f rs) s = approximating_bigstep_fun \<gamma> p rs s"
    proof -
      have assm_1: "\<forall>r\<in>set rs. match_list \<gamma> (f (get_match r)) (get_action r) p = matches \<gamma> (get_match r) (get_action r) p" using P assms(1) by blast
      { fix r s
        assume "r \<in> set rs"
        with assm_1 have "match_list \<gamma> (f (get_match r)) (get_action r) p \<longleftrightarrow> match_list \<gamma> [(get_match r)] (get_action r) p" by simp
        with match_list_semantics[of \<gamma> "f (get_match r)" "(get_action r)" p "[(get_match r)]"] have
          "approximating_bigstep_fun \<gamma> p (map (\<lambda>m. Rule m (get_action r)) (f (get_match r))) s =
           approximating_bigstep_fun \<gamma> p [Rule (get_match r) (get_action r)] s" by simp
        hence "(approximating_bigstep_fun \<gamma> p (normalize_rules f [r]) s) = approximating_bigstep_fun \<gamma> p [r] s"
          by(cases r) (simp)
      }

    with assms show ?thesis
      proof(induction rs arbitrary: s)
        case Nil thus ?case by (simp)
      next
        case (Cons r rs)
        from Cons.prems have "simple_ruleset [r]" by(simp add: simple_ruleset_def)
        with simple_imp_good_ruleset good_imp_wf_ruleset have wf_r: "wf_ruleset \<gamma> p [r]" by fast

        from \<open>simple_ruleset [r]\<close> simple_imp_good_ruleset good_imp_wf_ruleset have wf_r:
          "wf_ruleset \<gamma> p [r]" by fast
        from simple_ruleset_normalize_rules[OF \<open>simple_ruleset [r]\<close>] have "simple_ruleset (normalize_rules f [r])"
          by(simp)
        with simple_imp_good_ruleset good_imp_wf_ruleset have wf_nr: "wf_ruleset \<gamma> p (normalize_rules f [r])" by fast

        from Cons have IH: "\<And>s. approximating_bigstep_fun \<gamma> p (normalize_rules f rs) s = approximating_bigstep_fun \<gamma> p rs s"
          using simple_ruleset_tail by force

        from Cons have a: "\<And>s. approximating_bigstep_fun \<gamma> p (normalize_rules f [r]) s = approximating_bigstep_fun \<gamma> p [r] s" by simp

        show ?case
          apply(subst normalize_rules_fst)
          apply(simp add: approximating_bigstep_fun_seq_wf[OF wf_nr])
          apply(subst approximating_bigstep_fun_seq_wf[OF wf_r, simplified])
          apply(simp add: a)
          apply(simp add: IH)
          done
      qed
    qed

 corollary normalize_rules_match_list_semantics:
  "(\<forall>m a. match_list \<gamma> (f m) a p = matches \<gamma> m a p) \<Longrightarrow> simple_ruleset rs \<Longrightarrow>
   approximating_bigstep_fun \<gamma> p (normalize_rules f rs) s = approximating_bigstep_fun \<gamma> p rs s"
  by(rule normalize_rules_match_list_semantics_3[where P="\<lambda>_. True"]) simp_all

lemma in_normalized_matches: "ls \<in> set (normalize_match m) \<and> matches \<gamma> ls a p \<Longrightarrow> matches \<gamma> m a p"
  by (meson match_list_matches matches_to_match_list_normalize)

 text\<open>applying a function (with a prerequisite \<open>Q\<close>) to all rules\<close>
 lemma normalize_rules_property:
 assumes "\<forall> r \<in> set rs. P (get_match r)"
     and "\<forall>m. P m \<longrightarrow> (\<forall>m' \<in> set (f m). Q m')"
  shows "\<forall>r \<in> set (normalize_rules f rs). Q (get_match r)"
  proof
    fix r' assume a: "r' \<in> set (normalize_rules f rs)"
    from a assms show "Q (get_match r')"
    proof(induction rs)
    case Nil thus ?case by simp
    next
    case (Cons r rs)
      {
        assume "r' \<in> set (normalize_rules f rs)"
        from Cons.IH this have "Q (get_match r')" using Cons.prems(2) Cons.prems(3) by fastforce
      } note 1=this
      {
        assume "r' \<in> set (normalize_rules f [r])"
        hence a: "(get_match r') \<in> set (f (get_match r))" by(cases r) (auto)
        with Cons.prems(2) Cons.prems(3) have "\<forall>m'\<in>set (f (get_match r)). Q m'" by auto
        with a have "Q (get_match r')" by blast
      } note 2=this
      from Cons.prems(1) have "r' \<in> set (normalize_rules f [r]) \<or> r' \<in> set (normalize_rules f rs)"
        by(subst(asm) normalize_rules_fst) auto
      with 1 2 show ?case
        by(elim disjE)(simp)
    qed
 qed

 text\<open>If a function \<open>f\<close> preserves some property of the match expressions, then this property is preserved when applying @{const normalize_rules}\<close>

 lemma normalize_rules_preserves: assumes "\<forall> r \<in> set rs. P (get_match r)"
     and "\<forall>m. P m \<longrightarrow> (\<forall>m' \<in> set (f m). P m')"
  shows "\<forall>r \<in> set (normalize_rules f rs). P (get_match r)"
  using normalize_rules_property[OF assms(1) assms(2)] by simp

fun normalize_rules_dnf :: "'a rule list \<Rightarrow> 'a rule list" where
  "normalize_rules_dnf [] = []" |
  "normalize_rules_dnf ((Rule m a)#rs) = (map (\<lambda>m. Rule m a) (normalize_match m))@(normalize_rules_dnf rs)"

lemma normalize_rules_dnf_append: "normalize_rules_dnf (rs1@rs2) = normalize_rules_dnf rs1 @ normalize_rules_dnf rs2"
  proof(induction rs1 rule: normalize_rules_dnf.induct)
  qed(simp_all)

lemma normalize_rules_dnf_def2: "normalize_rules_dnf = normalize_rules normalize_match"
  proof(simp add: fun_eq_iff, intro allI)
    fix x::"'a rule list" show "normalize_rules_dnf x = normalize_rules normalize_match x"
    proof(induction x)
    case (Cons r rs) thus ?case by (cases r) simp
    qed(simp)
  qed

lemma wf_ruleset_normalize_rules_dnf: "wf_ruleset \<gamma> p rs \<Longrightarrow> wf_ruleset \<gamma> p (normalize_rules_dnf rs)"
  proof(induction rs)
  case Nil thus ?case by simp
  next
  case(Cons r rs)
    from Cons have IH: "wf_ruleset \<gamma> p (normalize_rules_dnf rs)" by(auto dest: wf_rulesetD)
    from Cons.prems have "wf_ruleset \<gamma> p [r]" by(auto dest: wf_rulesetD)
    hence "wf_ruleset \<gamma> p (normalize_rules_dnf [r])" using wf_ruleset_normalize_match by(cases r) simp
    with IH wf_ruleset_append have "wf_ruleset \<gamma> p (normalize_rules_dnf [r] @ normalize_rules_dnf rs)" by fast
    thus ?case using normalize_rules_dnf_def2 normalize_rules_fst by metis
  qed

lemma good_ruleset_normalize_rules_dnf: "good_ruleset rs \<Longrightarrow> good_ruleset (normalize_rules_dnf rs)"
  using normalize_rules_dnf_def2 good_ruleset_normalize_rules by metis

lemma simple_ruleset_normalize_rules_dnf: "simple_ruleset rs \<Longrightarrow> simple_ruleset (normalize_rules_dnf rs)"
  using normalize_rules_dnf_def2 simple_ruleset_normalize_rules by metis

(*This is the simple correctness proof, using the generalized version.
  below, we have a more complex correctness proof with a slighter generic assumption.
  Probably, we can delete the complex proof when we only focus on simple rulesets
  *)
lemma "simple_ruleset rs \<Longrightarrow>
  approximating_bigstep_fun \<gamma> p (normalize_rules_dnf rs) s = approximating_bigstep_fun \<gamma> p rs s"
  unfolding normalize_rules_dnf_def2
  apply(rule normalize_rules_match_list_semantics)
   apply (metis matches_to_match_list_normalize)
  by simp

lemma normalize_rules_dnf_correct: "wf_ruleset \<gamma> p rs \<Longrightarrow>
  approximating_bigstep_fun \<gamma> p (normalize_rules_dnf rs) s = approximating_bigstep_fun \<gamma> p rs s"
  proof(induction rs)
  case Nil thus ?case by simp
  next
  case (Cons r rs)
    show ?case
    proof(induction s rule: just_show_all_approximating_bigstep_fun_equalities_with_start_Undecided)
    case Undecided
    from Cons wf_rulesetD(2) have IH: "approximating_bigstep_fun \<gamma> p (normalize_rules_dnf rs) s = approximating_bigstep_fun \<gamma> p rs s" by fast
    from Cons.prems have "wf_ruleset \<gamma> p [r]" and "wf_ruleset \<gamma> p (normalize_rules_dnf [r])"
      by(auto dest: wf_rulesetD simp: wf_ruleset_normalize_rules_dnf)
    with IH Undecided have
      "approximating_bigstep_fun \<gamma> p (normalize_rules_dnf rs) (approximating_bigstep_fun \<gamma> p (normalize_rules_dnf [r]) Undecided) = approximating_bigstep_fun \<gamma> p (r # rs) Undecided"
      apply(cases r, rename_tac m a)
      apply(simp)
      apply(case_tac a)
              apply(simp_all add: normalize_match_correct Decision_approximating_bigstep_fun wf_ruleset_singleton)
      done
    hence "approximating_bigstep_fun \<gamma> p (normalize_rules_dnf [r] @ normalize_rules_dnf rs) s = approximating_bigstep_fun \<gamma> p (r # rs) s"
      using Undecided \<open>wf_ruleset \<gamma> p [r]\<close> \<open>wf_ruleset \<gamma> p (normalize_rules_dnf [r])\<close>
      by(simp add: approximating_bigstep_fun_seq_wf)
    thus ?thesis using normalize_rules_fst normalize_rules_dnf_def2 by metis
    qed
  qed

fun normalized_nnf_match :: "'a match_expr \<Rightarrow> bool" where
  "normalized_nnf_match MatchAny = True" |
  "normalized_nnf_match (Match _ ) = True" |
  "normalized_nnf_match (MatchNot (Match _)) = True" |
  "normalized_nnf_match (MatchAnd m1 m2) = ((normalized_nnf_match m1) \<and> (normalized_nnf_match m2))" |
  "normalized_nnf_match _ = False"

text\<open>Essentially, @{term normalized_nnf_match} checks for a negation normal form: Only AND is at toplevel, negation only occurs in front of literals.
 Since @{typ "'a match_expr"} does not support OR, the result is in conjunction normal form.
 Applying @{const normalize_match}, the reuslt is a list. Essentially, this is the disjunctive normal form.\<close>

lemma normalize_match_already_normalized: "normalized_nnf_match m \<Longrightarrow> normalize_match m = [m]"
  by(induction m rule: normalize_match.induct) (simp)+

lemma normalized_nnf_match_normalize_match: "\<forall> m' \<in> set (normalize_match m). normalized_nnf_match m'"
  proof(induction m arbitrary: rule: normalize_match.induct)
  case 4 thus ?case by fastforce
  qed (simp_all)

lemma normalized_nnf_match_MatchNot_D: "normalized_nnf_match (MatchNot m) \<Longrightarrow> normalized_nnf_match m"
  by(induction m) (simp_all)

text\<open>Example\<close>
lemma "normalize_match (MatchNot (MatchAnd (Match ip_src) (Match tcp))) = [MatchNot (Match ip_src), MatchNot (Match tcp)]" by simp

subsection\<open>Functions which preserve @{const normalized_nnf_match}\<close>

lemma optimize_matches_option_normalized_nnf_match: "(\<And> r. r \<in> set rs \<Longrightarrow> normalized_nnf_match (get_match r)) \<Longrightarrow>
     (\<And>m m'. normalized_nnf_match m \<Longrightarrow> f m = Some m' \<Longrightarrow> normalized_nnf_match m') \<Longrightarrow>
      \<forall> r \<in> set (optimize_matches_option f rs). normalized_nnf_match (get_match r)"
    proof(induction rs)
      case Nil thus ?case by simp
    next
      case (Cons r rs)
      from Cons.IH Cons.prems have IH: "\<forall>r\<in>set (optimize_matches_option f rs). normalized_nnf_match (get_match r)" by simp
      from Cons.prems have "\<forall>r\<in>set (optimize_matches_option f [r]). normalized_nnf_match (get_match r)"
        apply(cases r)
        apply(simp split: option.split)
        by force (*1s*)
      with IH show ?case by(cases r, simp split: option.split_asm)
    qed

lemma optimize_matches_normalized_nnf_match: "\<lbrakk>\<forall> r \<in> set rs. normalized_nnf_match (get_match r); \<forall>m. normalized_nnf_match m \<longrightarrow> normalized_nnf_match (f m) \<rbrakk> \<Longrightarrow>
      \<forall> r \<in> set (optimize_matches f rs). normalized_nnf_match (get_match r)"
  unfolding optimize_matches_def
  apply(rule optimize_matches_option_normalized_nnf_match)
   apply(simp; fail)
  apply(simp split: if_split_asm)
  by blast

lemma normalize_rules_dnf_normalized_nnf_match: "\<forall>x \<in> set (normalize_rules_dnf rs). normalized_nnf_match (get_match x)"
  proof(induction rs)
  case Nil thus ?case by simp
  next
  case (Cons r rs) thus ?case using normalized_nnf_match_normalize_match by(cases r) fastforce
  qed

end


header {* CSP processes *}

theory CSP_Processes
imports Reactive_Processes
begin

text {* A CSP process is a UTP reactive process that satisfies two additional
healthiness conditions called $CSP1$ and $CSP2$. A reactive process that satisfies
$CSP1$ and $CSP2$ is said to be CSP healthy.*}

subsection {* Definitions *}

text {* We introduce here the definitions of the CSP healthiness conditions.*}

definition CSP1::"(('\<theta>,'\<sigma>) alphabet_rp) Healthiness_condition"
where "CSP1 (P)  \<equiv>  P \<or> (\<lambda>(A, A'). \<not>ok A \<and> tr A \<le> tr A')"

definition J_csp
where "J_csp  \<equiv>  \<lambda>(A, A'). (ok A \<longrightarrow> ok A') \<and> tr A = tr A' \<and> wait A = wait A'
                                                     \<and> ref A = ref A' \<and> more A = more A'"

definition CSP2::"(('\<theta>,'\<sigma>) alphabet_rp) Healthiness_condition"
where "CSP2 (P)  \<equiv>  P ;; J_csp"

definition is_CSP_process::"('\<theta>,'\<sigma>) relation_rp \<Rightarrow> bool" where
"is_CSP_process P \<equiv> P is CSP1 healthy \<and> P is CSP2 healthy \<and> P is R healthy"

lemmas csp_defs = CSP1_def J_csp_def CSP2_def is_CSP_process_def

lemma is_CSP_processE1 [elim?]:
  assumes "is_CSP_process P"
  obtains "P is CSP1 healthy" "P is CSP2 healthy" "P is R healthy"
  using assms unfolding is_CSP_process_def by simp

lemma is_CSP_processE2 [elim?]:
  assumes "is_CSP_process P"
  obtains "CSP1 P = P" "CSP2 P = P" "R P = P"
  using assms unfolding is_CSP_process_def by (simp add: Healthy_def')

subsection {* Proofs *}

text {* Theorems and lemmas relative to CSP processes are introduced here.*}

lemma CSP1_CSP2_commute: "CSP1 o CSP2 = CSP2 o CSP1"
by (auto simp: csp_defs fun_eq_iff)

lemma CSP2_is_H2: "H2 = CSP2"
apply (clarsimp simp add: csp_defs design_defs rp_defs fun_eq_iff)
apply (rule iffI)
apply (erule_tac [!] comp_elim)
apply (rule_tac [!] b=ba in comp_intro)
apply (auto elim!: alpha_d_more_eqE intro!: alpha_d_more_eqI)
done

lemma H2_CSP1_commute: "H2 o CSP1 = CSP1 o H2"
apply (subst CSP2_is_H2[simplified Healthy_def])+
apply (rule CSP1_CSP2_commute[symmetric])
done

lemma H2_CSP1_commute2: "H2 (CSP1 P) = CSP1 (H2 P)"
by (simp add: H2_CSP1_commute[simplified Fun.comp_def fun_eq_iff, rule_format] fun_eq_iff)

lemma CSP2_R_commute:
  "CSP2 (R P) = R (CSP2 P)"
apply (subst CSP2_is_H2[symmetric])+
apply (rule R_H2_commute2[symmetric])
done

lemma CSP1_idem: "CSP1 = CSP1 o CSP1"
by (auto simp: csp_defs fun_eq_iff)

lemma CSP2_idem: "CSP2 = CSP2 o CSP2"
by (auto simp: csp_defs fun_eq_iff)

lemma CSP_is_CSP1:
  assumes A: "is_CSP_process P"
  shows "P is CSP1 healthy"
using A by (auto simp: is_CSP_process_def design_defs)

lemma CSP_is_CSP2:
  assumes A: "is_CSP_process P"
  shows "P is CSP2 healthy"
using A by (simp add: design_defs prefixeq_def is_CSP_process_def)

lemma CSP_is_R:
  assumes A: "is_CSP_process P"
  shows "P is R healthy"
using A by (simp add: design_defs prefixeq_def is_CSP_process_def)

lemma CSP2_ok_a:
"(CSP2 P)(a, b\<lparr>ok:=True\<rparr>) \<Longrightarrow> (P(a, b\<lparr>ok:=True\<rparr>) \<or> P(a, b\<lparr>ok:=False\<rparr>))"
apply (clarsimp simp: csp_defs design_defs rp_defs split: cond_splits elim: prefixE)
apply (case_tac "ok ba")
apply (rule_tac t="b\<lparr>ok := True\<rparr>" and s="ba" in ssubst, simp_all)
apply (drule_tac b="b\<lparr>ok := False\<rparr>" and a="ba" in back_subst)
apply (auto intro: alpha_rp.equality)
done

lemma CSP2_ok_b:
"(P(a, b\<lparr>ok:=True\<rparr>) \<or> P(a, b\<lparr>ok:=False\<rparr>)) \<Longrightarrow> (CSP2 P)(a, b\<lparr>ok:=True\<rparr>)"
by (auto simp: csp_defs design_defs rp_defs)

lemma CSP2_ok:
"(CSP2 P)(a, b\<lparr>ok:=True\<rparr>) = (P(a, b\<lparr>ok:=True\<rparr>) \<or> P(a, b\<lparr>ok:=False\<rparr>))"
apply (rule iffI)
apply (simp add: CSP2_ok_a)
by (simp add: CSP2_ok_b)

lemma CSP2_notok_a: "(CSP2 P)(a, b\<lparr>ok:=False\<rparr>) \<Longrightarrow> P(a, b\<lparr>ok:=False\<rparr>)"
apply (clarsimp simp: csp_defs design_defs rp_defs)
apply (case_tac "ok ba")
apply (rule_tac t="b\<lparr>ok := True\<rparr>" and s="ba" in ssubst, simp_all)
apply (drule_tac b="b\<lparr>ok := False\<rparr>" and a="ba" in back_subst)
apply (auto intro: alpha_rp.equality)
done

lemma CSP2_notok_b: "P(a, b\<lparr>ok:=False\<rparr>) \<Longrightarrow> (CSP2 P)(a, b\<lparr>ok:=False\<rparr>)"
by (auto simp: csp_defs design_defs rp_defs)

lemma CSP2_notok: "(CSP2 P)(a, b\<lparr>ok:=False\<rparr>) = P(a, b\<lparr>ok:=False\<rparr>)"
apply (rule iffI)
apply (simp add: CSP2_notok_a)
by (simp add: CSP2_notok_b)

lemma CSP2_t_f:
  assumes A:"(CSP2 (R (r \<turnstile> p)))(a, b)"
  and B: "((CSP2 (R (r \<turnstile> p)))(a, b\<lparr>ok:=False\<rparr>)) \<or>
          ((CSP2 (R (r \<turnstile> p)))(a, b\<lparr>ok:=True\<rparr>)) \<Longrightarrow> Q"
  shows "Q"
apply (rule B)
apply (rule disjI2)
apply (insert A)
apply (auto simp add: csp_defs design_defs rp_defs)
done

lemma disj_CSP1:
  assumes "P is CSP1 healthy"
    and "Q is CSP1 healthy"
  shows "(P \<or> Q) is CSP1 healthy"
using assms by (auto simp: csp_defs design_defs rp_defs fun_eq_iff)

lemma disj_CSP2:
  "P is CSP2 healthy ==> Q is CSP2 healthy ==> (P \<or> Q) is CSP2 healthy"
  by (simp add: CSP2_is_H2[symmetric] Healthy_def' design_defs comp_ndet_l_distr)

lemma disj_CSP:
  assumes A: "is_CSP_process P"
  assumes B: "is_CSP_process Q"
  shows "is_CSP_process (P \<or> Q)"
apply (simp add: is_CSP_process_def Healthy_def)
apply (subst disj_CSP2[simplified Healthy_def, symmetric])
apply (rule A[THEN CSP_is_CSP2, simplified Healthy_def])
apply (rule B[THEN CSP_is_CSP2, simplified Healthy_def], simp)
apply (subst disj_CSP1[simplified Healthy_def, symmetric])
apply (rule A[THEN CSP_is_CSP1, simplified Healthy_def])
apply (rule B[THEN CSP_is_CSP1, simplified Healthy_def], simp)
apply (subst R_disj[simplified Healthy_def])
apply (rule A[THEN CSP_is_R, simplified Healthy_def])
apply (rule B[THEN CSP_is_R, simplified Healthy_def], simp)
done

lemma seq_CSP1:
  assumes A: "P is CSP1 healthy"
  assumes B: "Q is CSP1 healthy"
  shows "(P ;; Q) is CSP1 healthy"
using A B by (auto simp: csp_defs design_defs rp_defs fun_eq_iff)

lemma seq_CSP2:
  assumes A: "Q is CSP2 healthy"
  shows "(P ;; Q) is CSP2 healthy"
using A
by (auto simp: CSP2_is_H2[symmetric] H2_J[symmetric])

lemma seq_R:
  assumes "P is R healthy"
  and "Q is R healthy"
  shows "(P ;; Q) is R healthy"
proof -
  have "R P = P" and "R Q = Q"
    using assms by (simp_all only: Healthy_def)
  moreover
  have "(R P ;; R Q) is R healthy"
    apply (auto simp add: design_defs rp_defs prefixeq_def fun_eq_iff split: cond_splits)
    apply (erule_tac x="zs @ zsa" in allE, auto split: cond_splits)+
    apply (rule_tac b=a in comp_intro, auto split: cond_splits)
    apply (rule_tac x="zs" in exI, auto split: cond_splits)
    apply (rule_tac b="ba\<lparr>tr := tr a @ tr ba\<rparr>" in comp_intro, auto split: cond_splits)+
    done
  ultimately show ?thesis by simp
qed

lemma seq_CSP:
  assumes A: "P is CSP1 healthy"
  and B: "P is R healthy"
  and C: "is_CSP_process Q"
  shows "is_CSP_process (P ;; Q)"
apply (auto simp add: is_CSP_process_def)
apply (subst seq_CSP1[simplified Healthy_def])
apply (rule A[simplified Healthy_def])
apply (rule CSP_is_CSP1[OF C, simplified Healthy_def])
apply (simp add: Healthy_def, subst CSP1_idem, auto)
apply (subst seq_CSP2[simplified Healthy_def])
apply (rule CSP_is_CSP2[OF C, simplified Healthy_def])
apply (simp add: Healthy_def, subst CSP2_idem, auto)
apply (subst seq_R[simplified Healthy_def])
apply (rule B[simplified Healthy_def])
apply (rule CSP_is_R[OF C, simplified Healthy_def])
apply (simp add: Healthy_def, subst R_idem2, auto)
done

lemma rd_ind_wait: "(R(\<not>(P \<^isup>f\<^isub>f) \<turnstile> (P \<^isup>t\<^isub>f)))
                        = (R((\<not>(\<lambda> (A, A'). P (A, A'\<lparr>ok := False\<rparr>)))
                                  \<turnstile> (\<lambda> (A, A'). P (A, A'\<lparr>ok := True\<rparr>))))"
apply (auto simp: design_defs rp_defs fun_eq_iff split: cond_splits)
apply (subgoal_tac "a\<lparr>tr := [], wait := False\<rparr> = a\<lparr>tr := []\<rparr>", auto)
apply (subgoal_tac "a\<lparr>tr := [], wait := False\<rparr> = a\<lparr>tr := []\<rparr>", auto)
apply (subgoal_tac "a\<lparr>tr := [], wait := False\<rparr> = a\<lparr>tr := []\<rparr>", auto)
apply (subgoal_tac "a\<lparr>tr := [], wait := False\<rparr> = a\<lparr>tr := []\<rparr>", auto)
apply (subgoal_tac "a\<lparr>tr := [], wait := False\<rparr> = a\<lparr>tr := []\<rparr>", auto)
apply (rule_tac t="a\<lparr>tr := [], wait := False\<rparr>" and s="a\<lparr>tr := []\<rparr>" in subst, simp_all)
done

lemma rd_H1: "(R((\<not>(\<lambda> (A, A'). P (A, A'\<lparr>ok := False\<rparr>)))
                              \<turnstile> (\<lambda> (A, A'). P (A, A'\<lparr>ok := True\<rparr>)))) =
                      (R ((\<not> H1 (\<lambda> (A, A'). P (A, A'\<lparr>ok := False\<rparr>)))
                              \<turnstile> H1 (\<lambda> (A, A'). P (A, A'\<lparr>ok := True\<rparr>))))"
by (auto simp: design_defs rp_defs fun_eq_iff split: cond_splits)

lemma rd_H1_H2: "(R((\<not> H1 (\<lambda> (A, A'). P (A, A'\<lparr>ok := False\<rparr>)))
                                  \<turnstile> H1 (\<lambda> (A, A'). P (A, A'\<lparr>ok := True\<rparr>)))) =
                        (R((\<not>(H1 o H2) (\<lambda> (A, A'). P (A, A'\<lparr>ok := False\<rparr>)))
                                  \<turnstile> (H1 o H2) (\<lambda> (A, A'). P (A, A'\<lparr>ok := True\<rparr>))))"
apply (auto simp: design_defs rp_defs prefixeq_def fun_eq_iff split: cond_splits elim: alpha_d_more_eqE)
apply (subgoal_tac "b\<lparr>tr := zs, ok := False\<rparr> = ba\<lparr>ok := False\<rparr>", auto intro: alpha_d.equality)
apply (subgoal_tac "b\<lparr>tr := zs, ok := False\<rparr> = ba\<lparr>ok := False\<rparr>", auto intro: alpha_d.equality)
apply (subgoal_tac "b\<lparr>tr := zs, ok := False\<rparr> = ba\<lparr>ok := False\<rparr>", auto intro: alpha_d.equality)
apply (subgoal_tac "b\<lparr>tr := zs, ok := True\<rparr> = ba\<lparr>ok := True\<rparr>", auto intro: alpha_d.equality)
apply (subgoal_tac "b\<lparr>tr := zs, ok := True\<rparr> = ba\<lparr>ok := True\<rparr>", auto intro: alpha_d.equality)
done

lemma rd_H1_H2_R_H1_H2:
   "(R ((\<not> (H1 o H2) (\<lambda> (A, A'). P (A, A'\<lparr>ok := False\<rparr>)))
            \<turnstile> (H1 o H2) (\<lambda> (A, A'). P (A, A'\<lparr>ok := True\<rparr>)))) =
    (R o H1 o H2) P"
apply (auto simp: design_defs rp_defs fun_eq_iff split: cond_splits)
apply (erule notE) back back
apply (rule_tac b="ba" in comp_intro, auto)
apply (rule_tac t="ba\<lparr>ok := False\<rparr>" and s=ba in subst, auto intro: alpha_d.equality)
apply (erule notE) back back
apply (rule_tac b="ba" in comp_intro, auto)
apply (rule_tac t="ba\<lparr>ok := False\<rparr>" and s=ba in subst, auto intro: alpha_d.equality)
apply (case_tac "ok ba")
apply (rule_tac b="ba" in comp_intro, auto)
apply (rule_tac t="ba\<lparr>ok := True\<rparr>" and s=ba in subst, auto)
apply (erule notE) back
apply (rule_tac b="ba" in comp_intro, auto)
apply (rule_tac t="ba\<lparr>ok := False\<rparr>" and s=ba in subst, auto intro: alpha_d.equality)
done

lemma CSP1_is_R1_H1:
  assumes "P is R1 healthy"
  shows "CSP1 P = R1 (H1 P)"
using assms
by (auto simp: csp_defs design_defs rp_defs fun_eq_iff split: cond_splits)

lemma CSP1_is_R1_H1_2: "CSP1 (R1 P) = R1 (H1 P)"
by (auto simp: csp_defs design_defs rp_defs fun_eq_iff split: cond_splits)

lemma CSP1_R1_commute: "CSP1 o R1 = R1 o CSP1"
by (auto simp: csp_defs design_defs rp_defs fun_eq_iff split: cond_splits)

lemma CSP1_R1_commute2: "CSP1 (R1 P) = R1 (CSP1 P)"
by (auto simp: csp_defs design_defs rp_defs fun_eq_iff split: cond_splits)

lemma CSP1_join:
  assumes A: "x is CSP1 healthy"
  and B: "y is CSP1 healthy"
  shows "(x \<sqinter> y) is CSP1 healthy"
  using A B
  by (simp add: Healthy_def CSP1_def fun_eq_iff utp_defs)

lemma CSP2_join:
  assumes A: "x is CSP2 healthy"
  and B: "y is CSP2 healthy"
  shows "(x \<sqinter> y) is CSP2 healthy"
  using A B
  apply (simp add: design_defs csp_defs fun_eq_iff)
  apply (rule allI)
  apply (rule allI)
  apply (erule_tac x="a" in allE)
  apply (erule_tac x="a" in allE)
  apply (erule_tac x="b" in allE)+
  by (auto)

lemma CSP1_meet:
  assumes A: "x is CSP1 healthy"
  and B: "y is CSP1 healthy"
  shows "(x \<squnion> y) is CSP1 healthy"
  using A B
  apply (simp add: Healthy_def CSP1_def fun_eq_iff utp_defs)
  apply (rule allI)
  apply (rule allI)
  apply (erule_tac x="a" in allE)
  apply (erule_tac x="a" in allE)
  apply (erule_tac x="b" in allE)+
  by (auto)

lemma CSP2_meet:
  assumes A: "x is CSP2 healthy"
  and B: "y is CSP2 healthy"
  shows "(x \<squnion> y) is CSP2 healthy"
  using A B
  apply (simp add: Healthy_def CSP2_def fun_eq_iff)
  apply (rule allI)+
  apply (erule_tac x="a" in allE)
  apply (erule_tac x="a" in allE)
  apply (erule_tac x="b" in allE)+
  apply (auto)
  apply (rule_tac b="ca" in comp_intro)
  apply (auto simp: J_csp_def)
done

lemma CSP_join:
  assumes A: "is_CSP_process x"
  and B: "is_CSP_process y"
  shows "is_CSP_process (x \<sqinter> y)"
  using A B
by (simp add: is_CSP_process_def CSP1_join CSP2_join R_join)

lemma CSP_meet:
  assumes A: "is_CSP_process x"
  and B: "is_CSP_process y"
  shows "is_CSP_process (x \<squnion> y)"
  using A B
by (simp add: is_CSP_process_def CSP1_meet CSP2_meet R_meet)

subsection {* CSP processes and reactive designs *}

text {* In this section, we prove the relation between CSP processes and reactive designs. *}

lemma rd_is_CSP1: "(R (r \<turnstile> p)) is CSP1 healthy"
by (auto simp: csp_defs design_defs rp_defs fun_eq_iff split: cond_splits elim: prefixE)

lemma rd_is_CSP2:
  assumes A: "\<forall> a b. r (a, b\<lparr>ok := True\<rparr>) \<longrightarrow> r (a, b\<lparr>ok := False\<rparr>)"
  shows "(R (r \<turnstile> p)) is CSP2 healthy"
apply (subst CSP2_is_H2[symmetric])
apply (simp add: Healthy_def)
apply (subst R_H2_commute2[symmetric])
apply (subst design_H2[simplified Healthy_def], auto simp: A)
done

lemma rd_is_CSP:
  assumes A: "\<forall> a b. r (a, b\<lparr>ok := True\<rparr>) \<longrightarrow> r (a, b\<lparr>ok := False\<rparr>)"
  shows "is_CSP_process (R (r \<turnstile> p))"
apply (simp add: is_CSP_process_def Healthy_def fun_eq_iff)
apply (subst R_idem2)
apply (subst rd_is_CSP2[simplified Healthy_def, symmetric], rule A)
apply (subst rd_is_CSP1[simplified Healthy_def, symmetric], simp)
done

lemma CSP_is_rd:
  assumes A: "is_CSP_process P"
  shows "P = (R (\<not>(P \<^isup>f\<^isub>f) \<turnstile> (P \<^isup>t\<^isub>f)))"
  apply (subst rd_ind_wait)
  apply (subst rd_H1)
  apply (subst rd_H1_H2)
  apply (subst rd_H1_H2_R_H1_H2)
  apply (subst R_abs_R1[symmetric])
  apply (subst CSP1_is_R1_H1_b)
  apply (subst CSP2_is_H2)
  apply (simp)
  apply (subst CSP_is_CSP2[OF A, simplified Healthy_def, symmetric])
  apply (subst CSP_is_CSP1[OF A, simplified Healthy_def, symmetric])
  apply (subst CSP_is_R[OF A, simplified Healthy_def, symmetric], simp)
done

end


theory SINVAR_TaintingTrusted
imports "../TopoS_Helper"
begin

subsection \<open>SecurityInvariant Tainting with Untainting-Feature for IFS\<close>

context
begin
  qualified datatype taints_raw = TaintsUntaints_Raw (taints_raw: "string set") (untaints_raw: "string set")

  text\<open>The @{const untaints_raw} set must be a subset of @{const taints_raw}.
        Otherwise, there can be entries in the untaints set, which do not affect anything.
        This is certainly undesirable.
        In addition, a unique default parameter cannot exist if we allow such dead entries.\<close>
  qualified typedef taints = "{ts::taints_raw. untaints_raw ts \<subseteq> taints_raw ts}"
    morphisms raw_of_taints Abs_taints
  proof
    show "TaintsUntaints_Raw {} {} \<in> {ts. untaints_raw ts \<subseteq> taints_raw ts}" by simp
  qed

  setup_lifting type_definition_taints

  lemma taints_eq_iff:
    "tsx = tsy \<longleftrightarrow> raw_of_taints tsx = raw_of_taints tsy"
    by (simp add: raw_of_taints_inject)

  definition taints :: "taints \<Rightarrow> string set" where
    "taints ts \<equiv> taints_raw (raw_of_taints ts)"
  definition untaints :: "taints \<Rightarrow> string set" where
    "untaints ts \<equiv> untaints_raw (raw_of_taints ts)"

  lemma taints_wellformedness: "untaints ts \<subseteq> taints ts"
    using raw_of_taints taints_def untaints_def by auto

  text \<open>Constructor for @{typ "taints"}:\<close>

  definition TaintsUntaints :: "string set \<Rightarrow> string set \<Rightarrow> taints" where
    "TaintsUntaints ts uts = Abs_taints (TaintsUntaints_Raw (ts \<union> uts) uts)"

  lemma raw_of_taints_TaintsUntaints:
    "raw_of_taints (TaintsUntaints ts uts) = (TaintsUntaints_Raw (ts \<union> uts) uts)"
    by (simp add: TaintsUntaints_def Abs_taints_inverse)

  lemma taints_TaintsUntaints[code]: "taints (TaintsUntaints ts uts) = ts \<union> uts"
    by(simp add: taints_def raw_of_taints_TaintsUntaints)
  lemma untaints_TaintsUntaints[code]: "untaints (TaintsUntaints ts uts) = uts"
    by(simp add: untaints_def raw_of_taints_TaintsUntaints)

  text\<open>The things in the first set are tainted, those in the second set are untainted.
    For example, a machine produces @{term "''foo''"}:
      @{term "TaintsUntaints {''foo''} {}"}

    For example, a machine consumes @{term "''foo''"} and @{term "''bar''"}, combines them in a
    way that they are no longer critical and outputs @{term "''baz''"}:
      @{term "TaintsUntaints {''foo'', ''bar'', ''baz''} {''foo'', ''bar''}"}
      abbreviated: @{term "TaintsUntaints {''baz''} {''foo'', ''bar''}"}
\<close>
  lemma "TaintsUntaints {''foo'', ''bar'', ''baz''} {''foo'', ''bar''} =
         TaintsUntaints {''baz''} {''foo'', ''bar''}"
    apply(simp add: taints_eq_iff raw_of_taints_TaintsUntaints)
    by blast

  qualified definition default_node_properties :: "taints"
    where  "default_node_properties \<equiv> TaintsUntaints {} {}"

  qualified definition sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> taints) \<Rightarrow> bool" where
    "sinvar G nP \<equiv> \<forall> (v1,v2) \<in> edges G.
        taints (nP v1) - untaints (nP v1) \<subseteq> taints (nP v2)"

  text\<open>Information Flow Security\<close>
  qualified definition receiver_violation :: "bool" where "receiver_violation \<equiv> True"

  private

end

code_datatype TaintsUntaints

value[code] "TaintsUntaints {''foo''} {''bar''}"

value[code] "taints (TaintsUntaints {''foo''} {''bar''})"

end