section \<open> Implementation of the Ouroboros BFT protocol \<close>

theory Ouroboros_BFT_Implementation
  imports Chi_Calculus.Typed_Basic_Transition_System "HOL-Library.BNF_Corec"
begin

subsection \<open> Cryptographic Primitives \<close>

subsubsection \<open> Hashing \<close>

text \<open>
  We will simply assume that we can compute the hash value of any value
\<close>

\<comment> \<open> Hash values \<close>
typedecl hash
axiomatization where hash_finite: "OFCLASS(hash, finite_class)"
instance hash :: finite by (rule hash_finite)

\<comment> \<open> A `perfect' hash function \<close>
consts hash :: "'a \<Rightarrow> hash"

text \<open>
  with no way of recovering @{typ 'a} from @{type hash}.
\<close>

subsubsection \<open> Public-Key infrastructure \<close>

text \<open>
  Public-key infrastructure depends on a pair of a public key and a private key:
\<close>

typedecl public_key

typedecl private_key

text \<open>
  We can sign a value using a private key:
\<close>

\<comment> \<open> Signatures \<close>
typedecl signature
axiomatization where signature_finite: "OFCLASS(signature, finite_class)"
instance signature :: finite by (rule signature_finite)

\<comment> \<open> Signing function \<close>
consts sign :: "private_key \<Rightarrow> 'a \<Rightarrow> signature"

text \<open>
  and verify signatures using a public key:
\<close>

\<comment> \<open> Signature verification function \<close>
consts verify :: "public_key \<Rightarrow> 'a \<Rightarrow> signature \<Rightarrow> bool"

subsection \<open> Environment Variables \<close>

text \<open>
  We bundle the environment variables used by the servers running the protocol in a record type:
\<close>

type_synonym u_param = nat

record server_env =
  se_u :: u_param \<comment> \<open> The `time-to-live' of a transaction in the mempool \<close>
  se_n :: nat \<comment> \<open> The number of servers running the protocol \<close>

subsection \<open> Data Types \<close>

subsubsection \<open> Slots \<close>

text \<open>
  We define the concept of slot:
\<close>

type_synonym slot = nat

text \<open>
  As defined in the paper, slot numbers begin at 1:
\<close>

abbreviation first_slot :: slot where
  "first_slot \<equiv> 1"

subsubsection \<open> Transactions \<close>

text \<open>
  We define the concept of transaction. As stated in the paper, this concept is an abstract one,
  therefore we model transactions as merely sequences of bits (following the tradition of
  Ouroboros papers):
\<close>
type_synonym transaction = string

subsubsection \<open> Genesis block \<close>

text \<open>
  As defined in the paper, we have a genesis block at the very start of a blockchain:
\<close>

record genesis =
  vks :: "public_key list" \<comment> \<open> list of servers' public keys \<close>

subsubsection \<open> Block \<close>

text \<open>
  We distinguish between an \<open>unsigned block\<close> (a block without a signature, a concept not explicitly
  present in the paper) and a signed block. Since the latter corresponds to the concept of a block
  in the paper, we refer to a signed block as simply a \<open>block\<close>:
\<close>

type_synonym unsigned_block = "
  hash option \<times> \<comment> \<open> Previous block hash. If first block then no previous block hash \<close>
  transaction list \<times> \<comment> \<open> Transaction data \<close>
  slot \<times> \<comment> \<open> Slot when the block was created \<close>
  signature" \<comment> \<open> Slot signature \<close>

type_synonym block = "unsigned_block \<times> signature"

subsubsection \<open> Blockchain \<close>

text \<open>
  A blockchain is simply a list of blocks:
\<close>

type_synonym blockchain = "block list"

text \<open>
  We do not record the genesis block explicitly and instead assume the genesis block is known to all
  servers.

  We define a function to prune the last \<open>k\<close> blocks in a blockchain:
\<close>

abbreviation prune_chain :: "blockchain \<Rightarrow> nat \<Rightarrow> blockchain" (infixl \<open>\<lceil>\<close> 999) where
  "\<C> \<lceil>k \<equiv> take (length \<C> - k) \<C>"

subsubsection \<open> Mempool \<close>

text \<open>
  Mempool entries consist of a transaction and the slot in which the transaction was created:
\<close>

type_synonym mempool = "(transaction \<times> slot) list"

subsection \<open> Leader Election \<close>

text \<open>
  Servers can compute the slot leader for any given slot number, being \<open>n\<close> the number of servers
  running the protocol:
\<close>

type_synonym server_index = nat \<comment> \<open> server indices begin at 1 \<close>

abbreviation slot_leader :: "slot \<Rightarrow> nat \<Rightarrow> server_index" where
  "slot_leader sl n \<equiv> (sl - 1) mod n + 1"

text \<open>
  Also, servers can ask if a given server is the slot leader for a given slot number:
\<close>

abbreviation is_slot_leader :: "slot \<Rightarrow> server_index \<Rightarrow> nat \<Rightarrow> bool" where
  "is_slot_leader sl i n \<equiv> i = slot_leader sl n"

subsection \<open> Verification \<close>

text \<open>
  A key component of verification is verifying that a transaction is consistent with a given current
  blockchain. However, the paper does not define what this notion of consistency means, so we leave
  this as an abstract concept:
\<close>

axiomatization
  is_consistent_tx_chain :: "transaction \<Rightarrow> blockchain \<Rightarrow> bool"
where
  empty_chain_tx_consistency: "is_consistent_tx_chain tx []"

text \<open>
  Based on this abstract definition, we can now verify that the transaction data in a block, i.e.
  the list of transactions in the block, is consistent with a given current blockchain:
\<close>

abbreviation is_consistent_tx_data_chain :: "transaction list \<Rightarrow> blockchain \<Rightarrow> bool" where
  "is_consistent_tx_data_chain d \<C> \<equiv> foldr (\<lambda>tx res. is_consistent_tx_chain tx \<C> \<and> res) d True"

text \<open>
  Another key component of verification is verifying that the signatures in a block are valid:
\<close>

fun verify_block_signatures :: "block \<Rightarrow> public_key \<Rightarrow> bool" where
  "verify_block_signatures ((h, d, sl, \<sigma>\<^sub>s\<^sub>l), \<sigma>\<^sub>b\<^sub>l\<^sub>o\<^sub>c\<^sub>k) vk =
    (verify vk sl \<sigma>\<^sub>s\<^sub>l \<and> verify vk (h, d, sl, \<sigma>\<^sub>s\<^sub>l) \<sigma>\<^sub>b\<^sub>l\<^sub>o\<^sub>c\<^sub>k)"

text \<open>
  In order to verify a block, we need some context: the hash of the previous block (if any),
  the public key of the block's slot leader, and the prefix of the current blockchain comprised by
  all the blocks preceding the block to be verified:
\<close>

abbreviation verify_block :: "block \<Rightarrow> hash option \<Rightarrow> public_key \<Rightarrow> blockchain \<Rightarrow> bool" where
  "verify_block B oh\<^sub>p\<^sub>r\<^sub>e\<^sub>v vk \<C>\<^sub>p\<^sub>r\<^sub>e\<^sub>v \<equiv> (
    let
      ((h, d, _, _), _) = B
    in (
      if \<not> verify_block_signatures B vk then
        False
      else (
        if \<not> is_consistent_tx_data_chain d \<C>\<^sub>p\<^sub>r\<^sub>e\<^sub>v then
          False
        else (
          case oh\<^sub>p\<^sub>r\<^sub>e\<^sub>v of
            None \<Rightarrow> True
          | Some h\<^sub>p\<^sub>r\<^sub>e\<^sub>v \<Rightarrow>
              the h = h\<^sub>p\<^sub>r\<^sub>e\<^sub>v)))) \<comment> \<open> if \<open>oh\<^sub>p\<^sub>r\<^sub>e\<^sub>v\<close> is not \<open>None\<close> then \<open>h\<close> is not \<open>None\<close> either \<close>"

text \<open>
  Finally, we define a function to verify a blockchain:
\<close>

abbreviation verify_chain :: "blockchain \<Rightarrow> genesis \<Rightarrow> nat \<Rightarrow> bool" where
  "verify_chain \<C> G n \<equiv>
    fold (
      \<lambda>k res. res \<and> (
        let
          B = \<C> ! k; \<comment> \<open> current block \<close>
          ((_, _, sl, _), _) = B;
          oh\<^sub>p\<^sub>r\<^sub>e\<^sub>v = (if k = 0 then None else fst (fst (\<C> ! (k - 1)))); \<comment> \<open> previous block hash \<close>
          i = slot_leader sl n; \<comment> \<open> index of slot leader for \<open>B\<close> \<close>
          vk\<^sub>i = vks G ! (i - 1); \<comment> \<open> public key of slot leader \<close>
          \<C>\<^sub>p\<^sub>r\<^sub>e\<^sub>v = take k \<C> \<comment> \<open> sub-chain of \<open>\<C>\<close> previous to \<open>B\<close> \<close>
        in
          verify_block B oh\<^sub>p\<^sub>r\<^sub>e\<^sub>v vk\<^sub>i \<C>\<^sub>p\<^sub>r\<^sub>e\<^sub>v))
      [0..<length \<C>]
      True"

subsection \<open> Protocol Implementation \<close>

subsubsection \<open> Server state \<close>

text \<open>
  Each server has access to its own state. We bundle the items comprising the server state in a
  record type:
\<close>

record server_state =
  ss_idx :: server_index \<comment> \<open> index of the server in the set of servers \<open>S\<^sub>1, ..., S\<^sub>n\<close> \<close>
  ss_G :: genesis \<comment> \<open> genesis block \<close>
  ss_\<C> :: blockchain \<comment> \<open> current blockchain \<close>
  ss_mempool :: mempool \<comment> \<open> current mempool \<close>
  ss_sk :: private_key \<comment> \<open> private key \<close>

text \<open>
  We can specify what the initial state for each server should be:
\<close>

abbreviation init_server_state :: "server_index \<Rightarrow> genesis \<Rightarrow> private_key \<Rightarrow> server_state" where
  "init_server_state i G sk \<equiv> \<lparr>ss_idx = i, ss_G = G, ss_\<C> = [], ss_mempool = [], ss_sk = sk\<rparr>"

subsubsection \<open> Mempool update \<close>

text \<open>
  A key component of mempool update is verifying that a transaction is consistent with a given
  current mempool. However, the paper does not define what this notion of consistency means, so we
  leave this as an abstract concept:
\<close>

axiomatization
  is_consistent_tx_mempool :: "transaction \<Rightarrow> mempool \<Rightarrow> bool"
where
  empty_mempool_tx_consistency: "is_consistent_tx_mempool tx []"

text \<open>
  Now, a transaction is consistent with a server state whenever is consistent with both the server
  state's mempool and blockchain:
\<close>

abbreviation is_consistent_tx :: "transaction \<Rightarrow> server_state \<Rightarrow> bool" where
  "is_consistent_tx tx ss \<equiv>
    is_consistent_tx_mempool tx (ss_mempool ss) \<and> is_consistent_tx_chain tx (ss_\<C> ss)"

text \<open>
  Finally, we can add a transaction to the server's mempool as long as it is consistent with the
  server state:
\<close>

abbreviation update_mempool :: "server_state \<Rightarrow> transaction \<Rightarrow> slot \<Rightarrow> server_state" where
  "update_mempool ss tx sl \<equiv> (
    if is_consistent_tx tx ss then
      ss\<lparr>ss_mempool := (tx, sl) # ss_mempool ss\<rparr>
    else
      ss)"

subsubsection \<open> Blockchain update \<close>

text \<open>
  We can replace the server's current blockchain with a new one provided it is longer and valid:
\<close>

fun update_chain :: "server_state \<Rightarrow> nat \<Rightarrow> blockchain \<Rightarrow> server_state" where
  "update_chain ss n \<C> = (
    if length \<C> > length (ss_\<C> ss) \<and> verify_chain \<C> (ss_G ss) n then
      ss\<lparr>ss_\<C> := \<C>\<rparr>
    else
      ss)"

subsubsection \<open> Blockchain extension \<close>

text \<open>
  We need a function that removes the `old' transactions from the server's mempool, i.e. the
  transactions that have been maintained for \<open>u\<close> rounds:
\<close>

abbreviation prune_mempool :: "server_state \<Rightarrow> slot \<Rightarrow> u_param \<Rightarrow> server_state" where
  "prune_mempool ss sl u \<equiv> ss\<lparr>ss_mempool := filter (\<lambda>(_, sl'). sl - sl' + 1 < u) (ss_mempool ss)\<rparr>"

text \<open>
  We define a function that builds a new block containing the transactions in the server's
  current mempool. A pre-condition for using this function is that @{const prune_mempool} must be
  called beforehand so that the mempool already contains only the valid transactions:
\<close>
abbreviation make_block :: "server_state \<Rightarrow> slot \<Rightarrow> block" where
  "make_block ss sl \<equiv> (
    let
      h = (if ss_\<C> ss = [] then None else Some (hash (last (ss_\<C> ss))));
      d = map fst (ss_mempool ss);
      \<sigma>sl = sign (ss_sk ss) sl;
      uB = (h, d, sl, \<sigma>sl)
    in
      (uB, sign (ss_sk ss) uB))"

text \<open>
  We can extend a server's current blockchain simply by appending a newly constructed block to it:
\<close>

abbreviation extend_chain where
  "extend_chain ss B\<^sub>n\<^sub>e\<^sub>w \<equiv> ss\<lparr>ss_\<C> := ss_\<C> ss @ [B\<^sub>n\<^sub>e\<^sub>w]\<rparr>"

text \<open>
  Finally, we need a function to empty the server's mempool in preparation for the next round:
\<close>

abbreviation clear_mempool :: "server_state \<Rightarrow> server_state" where
  "clear_mempool ss \<equiv> ss\<lparr>ss_mempool := []\<rparr>"

subsubsection \<open> Broadcast messages \<close>

text \<open>
  In addition to broadcasting transactions and blockchains, we also assume that there is a `clock
  process' broadcasting the next slot at the end of each current slot:
\<close>

datatype broadcast_msg =
    BroadcastTx (bm_tx: transaction)
  | BroadcastChain (bm_\<C>: blockchain)
  | BroadcastEndSlot (bm_sl: slot)

instance broadcast_msg :: countable
  by countable_datatype

type_synonym receive_channel = "broadcast_msg channel"

type_synonym send_channel = "broadcast_msg channel"

subsubsection \<open> The server process \<close>

text \<open>
  Now we are ready to define the process representing a server running the protocol:
\<close>

corec main_loop :: "send_channel \<Rightarrow> receive_channel \<Rightarrow> server_env \<Rightarrow> server_state \<Rightarrow> slot \<Rightarrow> process"
where
  "main_loop s r \<Gamma> ss sl =
    r \<triangleright>\<degree> msg. (
      case msg of
        BroadcastTx tx \<Rightarrow> (
          let
            ss' = update_mempool ss tx sl
          in
            main_loop s r \<Gamma> ss' sl)
      | BroadcastChain \<C> \<Rightarrow> (
          let
            ss' = update_chain ss (se_n \<Gamma>) \<C>
          in
            main_loop s r \<Gamma> ss' sl)
      | BroadcastEndSlot sl\<^sub>n\<^sub>e\<^sub>x\<^sub>t \<Rightarrow> (
          let
            ss' = prune_mempool ss sl (se_u \<Gamma>)
          in (
            if is_slot_leader sl (ss_idx ss) (se_n \<Gamma>) then (
              let
                B\<^sub>n\<^sub>e\<^sub>w = make_block ss' sl;
                ss'' = extend_chain ss' B\<^sub>n\<^sub>e\<^sub>w;
                ss''' = clear_mempool ss''
              in
                s \<triangleleft>\<degree> BroadcastChain (ss_\<C> ss''') \<parallel> main_loop s r \<Gamma> ss''' sl\<^sub>n\<^sub>e\<^sub>x\<^sub>t)
            else
              main_loop s r \<Gamma> ss' sl\<^sub>n\<^sub>e\<^sub>x\<^sub>t)))"

abbreviation server ::
  "send_channel \<Rightarrow> receive_channel \<Rightarrow> genesis \<Rightarrow> server_env \<Rightarrow> server_index \<Rightarrow> private_key \<Rightarrow> process"
where
  "server s r G \<Gamma> i sk \<equiv> (
    let
      ss\<^sub>i\<^sub>n\<^sub>i\<^sub>t = init_server_state i G sk
    in
      main_loop s r \<Gamma> ss\<^sub>i\<^sub>n\<^sub>i\<^sub>t first_slot)"

subsection \<open> Proofs \<close>

text \<open>
  This section contains lemmas for proving the correctness of the functions defined in previous
  sections, some of them according to specific scenarios, i.e. using specific data sets.
\<close>

subsubsection \<open> Proofs for @{const is_consistent_tx_data_chain}\<close>

lemma empty_chain_tx_data_consistency: "is_consistent_tx_data_chain d []"
  by (induction d) (auto simp add: empty_chain_tx_consistency)

lemma tx_data_chain_consistency:
  assumes "\<forall>i \<in> {0..<length d}. is_consistent_tx_chain (d ! i) \<C>"
  shows "is_consistent_tx_data_chain d \<C>"
  using assms
  by (induction d) (auto dest: bspec, force)

lemma tx_data_chain_inconsistency:
  assumes "\<exists>i \<in> {0..<length d}. \<not> is_consistent_tx_chain (d ! i) \<C>"
  shows "\<not> is_consistent_tx_data_chain d \<C>"
  using assms by (induction d) (simp, force simp add: less_Suc_eq_0_disj)

subsubsection \<open> Proofs for @{const update_mempool}\<close>

lemma update_mempool_consistency:
  assumes "is_consistent_tx tx ss"
  shows "update_mempool ss tx sl = ss\<lparr>ss_mempool := (tx, sl) # ss_mempool ss\<rparr>"
  using assms by simp

lemma update_mempool_inconsistency:
  assumes "\<not> is_consistent_tx tx ss"
  shows "update_mempool ss tx sl = ss"
  using assms by simp

subsubsection \<open> Proofs for @{const verify_block}\<close>

lemma signatures_block_invalidity:
  assumes "\<not> verify_block_signatures B vk"
  shows "\<not> verify_block B oB\<^sub>p\<^sub>r\<^sub>e\<^sub>v vk \<C>\<^sub>p\<^sub>r\<^sub>e\<^sub>v"
  using assms by auto

lemma tx_data_chain_block_invalidity:
  assumes "\<not> is_consistent_tx_data_chain d \<C>\<^sub>p\<^sub>r\<^sub>e\<^sub>v"
  shows "\<not> verify_block ((h, d, sl, \<sigma>\<^sub>s\<^sub>l), \<sigma>\<^sub>b\<^sub>l\<^sub>o\<^sub>c\<^sub>k) oB\<^sub>p\<^sub>r\<^sub>e\<^sub>v vk \<C>\<^sub>p\<^sub>r\<^sub>e\<^sub>v"
  using assms by simp

lemma first_block_validity:
  assumes "B = ((h, d, sl, \<sigma>\<^sub>s\<^sub>l), \<sigma>\<^sub>b\<^sub>l\<^sub>o\<^sub>c\<^sub>k)"
  and "verify_block_signatures B vk"
  and "is_consistent_tx_data_chain d \<C>\<^sub>p\<^sub>r\<^sub>e\<^sub>v"
  and "oh\<^sub>p\<^sub>r\<^sub>e\<^sub>v = None"
  shows "verify_block B oh\<^sub>p\<^sub>r\<^sub>e\<^sub>v vk \<C>\<^sub>p\<^sub>r\<^sub>e\<^sub>v"
  using assms by simp

lemma intermediate_block_validity:
  assumes "B = ((h, d, sl, \<sigma>\<^sub>s\<^sub>l), \<sigma>\<^sub>b\<^sub>l\<^sub>o\<^sub>c\<^sub>k)"
  and "verify_block_signatures B vk"
  and "is_consistent_tx_data_chain d \<C>\<^sub>p\<^sub>r\<^sub>e\<^sub>v"
  and "oh\<^sub>p\<^sub>r\<^sub>e\<^sub>v = Some h\<^sub>p\<^sub>r\<^sub>e\<^sub>v"
  shows "verify_block B oh\<^sub>p\<^sub>r\<^sub>e\<^sub>v vk \<C>\<^sub>p\<^sub>r\<^sub>e\<^sub>v = (the h = h\<^sub>p\<^sub>r\<^sub>e\<^sub>v)"
  using assms by simp

subsubsection \<open> Proofs for @{const slot_leader}\<close>

lemma two_server_network_odd_slot_leadership:
  assumes "n = 2"
  and "odd sl"
  shows "slot_leader sl n = 1"
  using assms by simp

lemma two_server_network_even_slot_leadership:
  assumes "n = 2"
  and "sl > 0" \<comment> \<open> slots begin at 1, so \<open>sl > 0\<close> always holds \<close>
  and "even sl"
  shows "slot_leader sl n = 2"
  using assms by (simp add: mod2_eq_if)

subsubsection \<open> Proofs for @{const verify_chain}\<close>

lemma block_signatures_chain_validity:
  assumes "G = \<lparr>vks = [vk\<^sub>1, vk\<^sub>2]\<rparr>"
  and "n = 2"
  and "sl\<^sub>1 = 1"
  and "B\<^sub>1 = ((None, [tx\<^sub>1], sl\<^sub>1, \<sigma>sl\<^sub>1), \<sigma>B\<^sub>1)"
  and "\<C> = [B\<^sub>1]"
  and "verify_block_signatures B\<^sub>1 vk\<^sub>1"
  shows "verify_chain \<C> G n"
proof -
  from assms(1,3-5) have "verify_chain \<C> G n = verify_block B\<^sub>1 None vk\<^sub>1 []"
    by simp
  moreover from assms(6) have "verify_block B\<^sub>1 None vk\<^sub>1 []"
    by (auto simp add: empty_chain_tx_data_consistency)
  ultimately show ?thesis
    by simp
qed

lemma block_signatures_chain_invalidity:
  assumes "G = \<lparr>vks = [vk\<^sub>1, vk\<^sub>2]\<rparr>"
  and "n = 2"
  and "sl\<^sub>1 = 1"
  and "B\<^sub>1 = ((None, [tx\<^sub>1], sl\<^sub>1, \<sigma>sl\<^sub>1), \<sigma>B\<^sub>1)"
  and "\<C> = [B\<^sub>1]"
  and "\<not> verify_block_signatures B\<^sub>1 vk\<^sub>1"
  shows "\<not> verify_chain \<C> G n"
proof -
  from assms(1,3-5) have "verify_chain \<C> G n = verify_block B\<^sub>1 None vk\<^sub>1 []"
    by simp
  moreover from assms(6) have "\<not> verify_block B\<^sub>1 None vk\<^sub>1 []"
    using empty_chain_tx_data_consistency by auto
  ultimately show ?thesis
    by simp
qed

lemma verify_chain_split:
  assumes "G = \<lparr>vks = [vk\<^sub>1, vk\<^sub>2]\<rparr>"
  and "n = 2"
  and "sl\<^sub>1 = 1"
  and "uB\<^sub>1 = (None, [tx\<^sub>1], sl\<^sub>1, \<sigma>sl\<^sub>1)"
  and "B\<^sub>1 = (uB\<^sub>1, \<sigma>B\<^sub>1)"
  and "sl\<^sub>2 = 2"
  and "oh\<^sub>1 = Some (hash uB\<^sub>1)"
  and "B\<^sub>2 = ((oh\<^sub>1, [tx\<^sub>2, tx\<^sub>3], sl\<^sub>2, \<sigma>sl\<^sub>2), \<sigma>B\<^sub>2)"
  and "\<C> = [B\<^sub>1, B\<^sub>2]"
  shows "verify_chain \<C> G n = (verify_block B\<^sub>1 None vk\<^sub>1 [] \<and> verify_block B\<^sub>2 oh\<^sub>1 vk\<^sub>2 [B\<^sub>1])"
proof -
  let ?f = "
    \<lambda>k res. res \<and> (
      let
        B = \<C> ! k;
        ((_, _, sl, _), _) = B;
        oh\<^sub>p\<^sub>r\<^sub>e\<^sub>v = (if k = 0 then None else fst (fst (\<C> ! (k - 1))));
        i = slot_leader sl n;
        vk\<^sub>i = vks G ! (i - 1);
        \<C>\<^sub>p\<^sub>r\<^sub>e\<^sub>v = take k \<C>
      in
        verify_block B oh\<^sub>p\<^sub>r\<^sub>e\<^sub>v vk\<^sub>i \<C>\<^sub>p\<^sub>r\<^sub>e\<^sub>v)"
  from assms(9) have "verify_chain \<C> G n = fold ?f [0, 1] True"
    by simp
  also have "\<dots> = ?f 1 (?f 0 True)"
    unfolding Let_def and One_nat_def by simp
  also from assms(1-5,9) have "\<dots> = ?f 1 (verify_block B\<^sub>1 None vk\<^sub>1 [])"
    by simp
  also from assms(1,2,4-9) have "\<dots> = (verify_block B\<^sub>1 None vk\<^sub>1 [] \<and> verify_block B\<^sub>2 oh\<^sub>1 vk\<^sub>2 [B\<^sub>1])"
    by simp
  finally show ?thesis .
qed

lemma non_singleton_chain_validity:
  assumes "G = \<lparr>vks = [vk\<^sub>1, vk\<^sub>2]\<rparr>"
  and "n = 2"
  and "sl\<^sub>1 = 1"
  and "uB\<^sub>1 = (None, [tx\<^sub>1], sl\<^sub>1, \<sigma>sl\<^sub>1)"
  and "B\<^sub>1 = (uB\<^sub>1, \<sigma>B\<^sub>1)"
  and "sl\<^sub>2 = 2"
  and "oh\<^sub>1 = Some (hash uB\<^sub>1)"
  and "B\<^sub>2 = ((oh\<^sub>1, [tx\<^sub>2, tx\<^sub>3], sl\<^sub>2, \<sigma>sl\<^sub>2), \<sigma>B\<^sub>2)"
  and "\<C> = [B\<^sub>1, B\<^sub>2]"
  and "verify_block_signatures B\<^sub>1 vk\<^sub>1"
  and "verify_block_signatures B\<^sub>2 vk\<^sub>2"
  and "is_consistent_tx_data_chain [tx\<^sub>2, tx\<^sub>3] [B\<^sub>1]"
  shows "verify_chain \<C> G n"
proof -
  from assms(10) have "verify_block B\<^sub>1 None vk\<^sub>1 []"
    using empty_chain_tx_data_consistency by (simp add: case_prod_beta')
  moreover from assms(2,4,6,7,8,11,12) have "verify_block B\<^sub>2 oh\<^sub>1 vk\<^sub>2 [B\<^sub>1]"
    by simp
  ultimately have "verify_block B\<^sub>1 None vk\<^sub>1 [] \<and> verify_block B\<^sub>2 oh\<^sub>1 vk\<^sub>2 [B\<^sub>1]"
    by simp
  moreover from assms(1-9) have "
    (verify_block B\<^sub>1 None vk\<^sub>1 [] \<and> verify_block B\<^sub>2 oh\<^sub>1 vk\<^sub>2 [B\<^sub>1]) = verify_chain \<C> G n"
    by (simp add: verify_chain_split)
  ultimately show ?thesis
    by simp
qed

subsubsection \<open> Proofs for @{const update_chain}\<close>

lemma not_longer_chain_update:
  assumes "length \<C> \<le> length (ss_\<C> ss)"
  shows "update_chain ss n \<C> = ss"
  using assms by simp

lemma invalid_chain_update:
  assumes "\<not> verify_chain \<C> (ss_G ss) n"
  shows "update_chain ss n \<C> = ss"
  using assms by simp

lemma longer_and_valid_chain_update:
  assumes "length \<C> > length (ss_\<C> ss)"
  and "verify_chain \<C> (ss_G ss) n"
  shows "update_chain ss n \<C> = ss\<lparr>ss_\<C> := \<C>\<rparr>"
  using assms by simp

subsubsection \<open> Proofs for @{const prune_mempool}\<close>

text \<open>
  The lemma in this section uses the following timeline of arrival of transactions:

  \begin{tabular}{|c|c|c|c|}
  \hline
  slot & $tx_1$   & $tx_2$   & $tx_3$   \\ \hline
  1    & $\times$ &          &          \\ \hline
  2    & $\times$ &          &          \\ \hline
  3    & $\times$ & $\times$ &          \\ \hline
  4    & $\times$ & $\times$ & $\times$ \\ \hline
  \end{tabular}
\<close>

lemma mempool_prunning:
  assumes "ss_mempool ss = [(tx\<^sub>1, 1), (tx\<^sub>2, 3), (tx\<^sub>3, 4)]"
  and "sl = 4"
  and "u = 4"
  shows "ss_mempool (prune_mempool ss sl u) = [(tx\<^sub>2, 3), (tx\<^sub>3, 4)]"
  using assms by simp

subsubsection \<open> Proofs for @{const make_block}\<close>

lemma first_block_creation:
  assumes "ss_mempool ss = [(tx\<^sub>2, 3), (tx\<^sub>3, 4)]"
  and "sl = 4"
  and "ss_\<C> ss = []"
  and "uB\<^sub>1 = (None, [tx\<^sub>2, tx\<^sub>3], sl, sign (ss_sk ss) sl)"
  and "B\<^sub>1 = (uB\<^sub>1, sign (ss_sk ss) uB\<^sub>1)"
  shows "make_block ss sl = B\<^sub>1"
  using assms by (simp, metis)

lemma second_block_creation:
  assumes "ss_mempool ss = [(tx\<^sub>2, 3), (tx\<^sub>3, 4)]"
  and "sl = 10"
  and "B\<^sub>1 = ((None, [tx\<^sub>0], sl\<^sub>1, \<sigma>sl\<^sub>1), \<sigma>B\<^sub>1)"
  and "ss_\<C> ss = [B\<^sub>1]"
  and "uB\<^sub>2 = (Some (hash B\<^sub>1), [tx\<^sub>2, tx\<^sub>3], sl, sign (ss_sk ss) sl)"
  and "B\<^sub>2 = (uB\<^sub>2, sign (ss_sk ss) uB\<^sub>2)"
  shows "make_block ss sl = B\<^sub>2"
  using assms by (simp, metis)

subsubsection \<open> Proofs for @{const main_loop}\<close>

lemma main_loop_end_slot_no_mining:
  assumes "msg = BroadcastEndSlot sl\<^sub>n\<^sub>e\<^sub>x\<^sub>t"
  and "\<Gamma> = \<lparr>se_u = 4, se_n = 2\<rparr>"
  and "ss = \<lparr>
    ss_idx = 1,
    ss_G = \<lparr>vks = [vk\<^sub>1, vk\<^sub>2]\<rparr>,
    ss_\<C> = [B\<^sub>1],
    ss_mempool = [(tx\<^sub>1, 1), (tx\<^sub>2, 3), (tx\<^sub>3, 4)],
    ss_sk = sk\<^sub>1\<rparr>"
  and "sl = 4"
  and "ss' = ss\<lparr>ss_mempool := [(tx\<^sub>2, 3), (tx\<^sub>3, 4)]\<rparr>"
  shows "main_loop s r \<Gamma> ss sl \<rightarrow>\<^sub>\<flat>\<lbrace>r \<triangleright>\<degree> msg\<rbrace> main_loop s r \<Gamma> ss' sl\<^sub>n\<^sub>e\<^sub>x\<^sub>t"
proof -
  from assms(1) have "main_loop s r \<Gamma> ss sl \<rightarrow>\<^sub>\<flat>\<lbrace>r \<triangleright>\<degree> msg\<rbrace> (
    let
      ss'' = prune_mempool ss sl (se_u \<Gamma>)
    in (
      if is_slot_leader sl (ss_idx ss) (se_n \<Gamma>) then (
        let
          B\<^sub>n\<^sub>e\<^sub>w = make_block ss'' sl;
          ss''' = extend_chain ss'' B\<^sub>n\<^sub>e\<^sub>w;
          ss'''' = clear_mempool ss'''
        in
          s \<triangleleft>\<degree> BroadcastChain (ss_\<C> ss'''') \<parallel> main_loop s r \<Gamma> ss'''' sl\<^sub>n\<^sub>e\<^sub>x\<^sub>t)
      else
        main_loop s r \<Gamma> ss'' sl\<^sub>n\<^sub>e\<^sub>x\<^sub>t))"
    using broadcast_msg.simps(12) and main_loop.code and receiving and typed_untyped_value
    by (metis (no_types, lifting))
  with assms(2-5) show ?thesis
    by auto
qed

lemma main_loop_end_slot_mining:
  assumes "msg = BroadcastEndSlot sl\<^sub>n\<^sub>e\<^sub>x\<^sub>t"
  and "\<Gamma> = \<lparr>se_u = 4, se_n = 2\<rparr>"
  and "B\<^sub>1 = ((None, [tx\<^sub>0], sl\<^sub>1, \<sigma>sl\<^sub>1), \<sigma>B\<^sub>1)"
  and "ss = \<lparr>
    ss_idx = 2,
    ss_G = \<lparr>vks = [vk\<^sub>1, vk\<^sub>2]\<rparr>,
    ss_\<C> = [B\<^sub>1],
    ss_mempool = [(tx\<^sub>1, 1), (tx\<^sub>2, 3), (tx\<^sub>3, 4)],
    ss_sk = sk\<^sub>1\<rparr>"
  and "sl = 4"
  and "uB\<^sub>2 = (Some (hash B\<^sub>1), [tx\<^sub>2, tx\<^sub>3], sl, sign (ss_sk ss) sl)"
  and "B\<^sub>2 = (uB\<^sub>2, sign (ss_sk ss) uB\<^sub>2)"
  and "\<C>\<^sub>n\<^sub>e\<^sub>w = [B\<^sub>1, B\<^sub>2]"
  and "ss' = ss\<lparr>ss_\<C> := \<C>\<^sub>n\<^sub>e\<^sub>w, ss_mempool := []\<rparr>"
  shows "main_loop s r \<Gamma> ss sl \<rightarrow>\<^sub>\<flat>\<lbrace>r \<triangleright>\<degree> msg\<rbrace> s \<triangleleft>\<degree> BroadcastChain \<C>\<^sub>n\<^sub>e\<^sub>w \<parallel> main_loop s r \<Gamma> ss' sl\<^sub>n\<^sub>e\<^sub>x\<^sub>t"
proof -
  let ?ss'' = "ss\<lparr>ss_mempool := [(tx\<^sub>2, 3), (tx\<^sub>3, 4)]\<rparr>"
  let ?ss''' = "?ss''\<lparr>ss_\<C> := \<C>\<^sub>n\<^sub>e\<^sub>w\<rparr>"
  from assms(2,4,5) have "is_slot_leader sl (ss_idx ss) (se_n \<Gamma>)"
    by simp
  moreover have f1: "prune_mempool ss sl (se_u \<Gamma>) = ?ss''"
    using assms(2,4,5) and mempool_prunning by simp
  with assms(4,6,7) have f2: "make_block ?ss'' sl = B\<^sub>2"
    by (auto, metis)
  with assms(4,8) have f3: "extend_chain ?ss'' B\<^sub>2 = ?ss'''"
    by simp
  with assms(4,9) have f4: "clear_mempool ?ss''' = ss'"
    by simp
  moreover from assms(1) have "main_loop s r \<Gamma> ss sl \<rightarrow>\<^sub>\<flat>\<lbrace>r \<triangleright>\<degree> msg\<rbrace> (
    let
      ss'' = prune_mempool ss sl (se_u \<Gamma>)
    in (
      if is_slot_leader sl (ss_idx ss) (se_n \<Gamma>) then (
        let
          B\<^sub>n\<^sub>e\<^sub>w = make_block ss'' sl;
          ss''' = extend_chain ss'' B\<^sub>n\<^sub>e\<^sub>w;
          ss'''' = clear_mempool ss'''
        in
          s \<triangleleft>\<degree> BroadcastChain (ss_\<C> ss'''') \<parallel> main_loop s r \<Gamma> ss'''' sl\<^sub>n\<^sub>e\<^sub>x\<^sub>t)
      else
        main_loop s r \<Gamma> ss'' sl\<^sub>n\<^sub>e\<^sub>x\<^sub>t))"
    using broadcast_msg.simps(12) and main_loop.code and receiving and typed_untyped_value
    by (metis (no_types, lifting))
  ultimately show ?thesis
    using f1 and f2 and f3 and f4 and assms(4)
    by (smt server_state.select_convs(2,3) server_state.update_convs(2-4))
qed

lemma main_loop_consistent_tx_reception:
  assumes "msg = BroadcastTx tx"
  and "is_consistent_tx tx ss"
  and "ss' = ss\<lparr>ss_mempool := (tx, sl) # ss_mempool ss\<rparr>"
  shows "main_loop s r \<Gamma> ss sl \<rightarrow>\<^sub>\<flat>\<lbrace>r \<triangleright>\<degree> msg\<rbrace> main_loop s r \<Gamma> ss' sl"
proof -
  from assms(1) have "
    main_loop s r \<Gamma> ss sl \<rightarrow>\<^sub>\<flat>\<lbrace>r \<triangleright>\<degree> msg\<rbrace> main_loop s r \<Gamma> (update_mempool ss tx sl) sl"
    using broadcast_msg.simps(10) and main_loop.code and receiving and typed_untyped_value
    by (metis (no_types, lifting))
  with assms(2,3) show ?thesis
    by simp
qed

lemma main_loop_inconsistent_tx_reception:
  assumes "msg = BroadcastTx tx"
  and "\<not> is_consistent_tx tx ss"
  shows "main_loop s r \<Gamma> ss sl \<rightarrow>\<^sub>\<flat>\<lbrace>r \<triangleright>\<degree> msg\<rbrace> main_loop s r \<Gamma> ss sl"
proof -
  from assms(1) have "
    main_loop s r \<Gamma> ss sl \<rightarrow>\<^sub>\<flat>\<lbrace>r \<triangleright>\<degree> msg\<rbrace> main_loop s r \<Gamma> (update_mempool ss tx sl) sl"
    using broadcast_msg.simps(10) and main_loop.code and receiving and typed_untyped_value
    by (metis (no_types, lifting))
  moreover from assms(2) have "update_mempool ss tx sl = ss"
    by simp
  ultimately show ?thesis
    by simp
qed

lemma main_loop_not_longer_chain_reception:
  assumes "length \<C> \<le> length (ss_\<C> ss)"
  and "msg = BroadcastChain \<C>"
  shows "main_loop s r \<Gamma> ss sl \<rightarrow>\<^sub>\<flat>\<lbrace>r \<triangleright>\<degree> msg\<rbrace> main_loop s r \<Gamma> ss sl"
proof -
  from assms(2) have "
    main_loop s r \<Gamma> ss sl \<rightarrow>\<^sub>\<flat>\<lbrace>r \<triangleright>\<degree> msg\<rbrace> main_loop s r \<Gamma> (update_chain ss (se_n \<Gamma>) \<C>) sl"
    using broadcast_msg.simps(11) and main_loop.code and receiving and typed_untyped_value
    by (metis (no_types, lifting))
  moreover from assms(1) have "update_chain ss (se_n \<Gamma>) \<C> = ss"
    using not_longer_chain_update by simp
  ultimately show ?thesis
    by simp
qed

lemma main_loop_longer_and_valid_chain_reception:
  assumes "length \<C> > length (ss_\<C> ss)"
  and "verify_chain \<C> (ss_G ss) (se_n \<Gamma>)"
  and "msg = BroadcastChain \<C>"
  and "ss' = ss\<lparr>ss_\<C> := \<C>\<rparr>"
  shows "main_loop s r \<Gamma> ss sl \<rightarrow>\<^sub>\<flat>\<lbrace>r \<triangleright>\<degree> msg\<rbrace> main_loop s r \<Gamma> ss' sl"
proof -
  from assms(3) have "
    main_loop s r \<Gamma> ss sl \<rightarrow>\<^sub>\<flat>\<lbrace>r \<triangleright>\<degree> msg\<rbrace> main_loop s r \<Gamma> (update_chain ss (se_n \<Gamma>) \<C>) sl"
    using broadcast_msg.simps(11) and main_loop.code and receiving and typed_untyped_value
    by (metis (no_types, lifting))
  moreover from assms(1,2) have "update_chain ss (se_n \<Gamma>) \<C> = ss\<lparr>ss_\<C> := \<C>\<rparr>"
    using longer_and_valid_chain_update by simp
  ultimately show ?thesis
    using assms(4) by simp
qed

end


(*  Title:      Sequents/Modal0.thy
    Author:     Martin Coen
    Copyright   1991  University of Cambridge
*)

theory Modal0
imports LK0
begin

ML_file "modal.ML"

consts
  box           :: "o=>o"       ("[]_" [50] 50)
  dia           :: "o=>o"       ("<>_" [50] 50)
  strimp        :: "[o,o]=>o"   (infixr "--<" 25)
  streqv        :: "[o,o]=>o"   (infixr ">-<" 25)
  Lstar         :: "two_seqi"
  Rstar         :: "two_seqi"

syntax
  "_Lstar"      :: "two_seqe"   ("(_)|L>(_)" [6,6] 5)
  "_Rstar"      :: "two_seqe"   ("(_)|R>(_)" [6,6] 5)

ML {*
  fun star_tr c [s1, s2] = Const(c, dummyT) $ seq_tr s1 $ seq_tr s2;
  fun star_tr' c [s1, s2] = Const(c, dummyT) $ seq_tr' s1 $ seq_tr' s2;
*}

parse_translation {*
 [(@{syntax_const "_Lstar"}, K (star_tr @{const_syntax Lstar})),
  (@{syntax_const "_Rstar"}, K (star_tr @{const_syntax Rstar}))]
*}

print_translation {*
 [(@{const_syntax Lstar}, K (star_tr' @{syntax_const "_Lstar"})),
  (@{const_syntax Rstar}, K (star_tr' @{syntax_const "_Rstar"}))]
*}

defs
  strimp_def:    "P --< Q == [](P --> Q)"
  streqv_def:    "P >-< Q == (P --< Q) & (Q --< P)"

lemmas rewrite_rls = strimp_def streqv_def

lemma iffR:
    "[| $H,P |- $E,Q,$F;  $H,Q |- $E,P,$F |] ==> $H |- $E, P <-> Q, $F"
  apply (unfold iff_def)
  apply (assumption | rule conjR impR)+
  done

lemma iffL:
    "[| $H,$G |- $E,P,Q;  $H,Q,P,$G |- $E |] ==> $H, P <-> Q, $G |- $E"
  apply (unfold iff_def)
  apply (assumption | rule conjL impL basic)+
  done

lemmas safe_rls = basic conjL conjR disjL disjR impL impR notL notR iffL iffR
  and unsafe_rls = allR exL
  and bound_rls = allL exR

end


header {* Generic Algorithm to Generate Sets from Lists *}
theory From_List_GA
imports Imp_Set_Spec Imp_List_Spec Hash_Set_Impl Array_Set_Impl
begin

term fold

  primrec from_list_ga_aux where
    "from_list_ga_aux ins [] s = return s"
  | "from_list_ga_aux ins (x#l) s
     = do { s \<leftarrow> ins x s; from_list_ga_aux ins l s }"

  lemma from_list_ga_aux_rule:
    assumes "imp_set_ins is_set ins"
    shows
    "< is_set s p > from_list_ga_aux ins l p <\<lambda>r. is_set (set l \<union> s) r >\<^sub>t"
  proof -
    interpret imp_set_ins is_set ins by fact
    show ?thesis
    proof (induction l arbitrary: s p)
      case Nil thus ?case by sep_auto
    next
      case (Cons x l)
      show ?case by (sep_auto heap: Cons.IH)
    qed
  qed

  definition "from_list_ga e i l = do { s\<leftarrow>e; from_list_ga_aux i l s}"

  lemma from_list_ga_rule:
    fixes empty
    assumes "imp_set_empty is_set empty"
    assumes I: "imp_set_ins is_set ins"
    shows "<emp> from_list_ga empty ins l <\<lambda>r. is_set (set l) r>\<^sub>t"
  proof -
    interpret imp_set_empty is_set empty by fact
    note [sep_heap_rules] = from_list_ga_aux_rule[OF I]
    show ?thesis unfolding from_list_ga_def by sep_auto
  qed

  definition "hs_from_list \<equiv> from_list_ga hs_new hs_ins"
  lemmas hs_from_list_rule[sep_heap_rules]
    = from_list_ga_rule[OF hs_new_impl hs_ins_impl, folded hs_from_list_def]

  definition "ias_from_list \<equiv> from_list_ga ias_new ias_ins"
  lemmas ias_from_list_rule[sep_heap_rules]
    = from_list_ga_rule[OF ias_empty_impl ias_ins_impl,
        folded ias_from_list_def]

end


(*  Title:      HOL/Nitpick_Examples/Pattern_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2011

Examples featuring Nitpick's "destroy_constrs" optimization.
*)

section \<open>Examples Featuring Nitpick's \textit{destroy\_constrs} Optimization\<close>

theory Pattern_Nits
imports Main
begin

nitpick_params [verbose, card = 8, max_potential = 0, sat_solver = MiniSat,
                max_threads = 1, timeout = 240]

lemma "x = (case u of () \<Rightarrow> y)"
nitpick [expect = genuine]
oops

lemma "x = (case b of True \<Rightarrow> x | False \<Rightarrow> y)"
nitpick [expect = genuine]
oops

lemma "x = (case p of (x, y) \<Rightarrow> y)"
nitpick [expect = genuine]
oops

lemma "x = (case n of 0 \<Rightarrow> x | Suc n \<Rightarrow> n)"
nitpick [expect = genuine]
oops

lemma "x = (case opt of None \<Rightarrow> x | Some y \<Rightarrow> y)"
nitpick [expect = genuine]
oops

lemma "x = (case xs of [] \<Rightarrow> x | y # ys \<Rightarrow> y)"
nitpick [expect = genuine]
oops

lemma "x = (case xs of
              [] \<Rightarrow> x
            | y # ys \<Rightarrow>
              (case ys of
                 [] \<Rightarrow> x
               | z # zs \<Rightarrow>
                 (case z of
                    None \<Rightarrow> x
                  | Some p \<Rightarrow>
                    (case p of
                       (a, b) \<Rightarrow> b))))"
nitpick [expect = genuine]
oops

fun f1 where
"f1 x () = x"

lemma "x = f1 y u"
nitpick [expect = genuine]
oops

fun f2 where
"f2 x _ True = x" |
"f2 _ y False = y"

lemma "x = f2 x y b"
nitpick [expect = genuine]
oops

fun f3 where
"f3 (_, y) = y"

lemma "x = f3 p"
nitpick [expect = genuine]
oops

fun f4 where
"f4 x 0 = x" |
"f4 _ (Suc n) = n"

lemma "x = f4 x n"
nitpick [expect = genuine]
oops

fun f5 where
"f5 x None = x" |
"f5 _ (Some y) = y"

lemma "x = f5 x opt"
nitpick [expect = genuine]
oops

fun f6 where
"f6 x [] = x" |
"f6 _ (y # ys) = y"

lemma "x = f6 x xs"
nitpick [expect = genuine]
oops

fun f7 where
"f7 _ (y # Some (a, b) # zs) = b" |
"f7 x (y # None # zs) = x" |
"f7 x [y] = x" |
"f7 x [] = x"

lemma "x = f7 x xs"
nitpick [expect = genuine]
oops

lemma "u = ()"
nitpick [expect = none]
sorry

lemma "\<exists>y. (b::bool) = y"
nitpick [expect = none]
sorry

lemma "\<exists>x y. p = (x, y)"
nitpick [expect = none]
sorry

lemma "\<exists>x. n = Suc x"
nitpick [expect = genuine]
oops

lemma "\<exists>y. x = Some y"
nitpick [expect = genuine]
oops

lemma "\<exists>y ys. xs = y # ys"
nitpick [expect = genuine]
oops

lemma "\<exists>y a b zs. x = y # Some (a, b) # zs"
nitpick [expect = genuine]
oops

end


theory FactoredSystemLib
  imports Main "HOL-Library.Finite_Map"
begin

section \<open>Factored Systems Library\<close>

text \<open>This section contains definitions used in the factored system theory (FactoredSystem.thy) and in
other theories. \<close>

subsection \<open>Semantics of Map Addition\<close>

text \<open> Most importantly, we are redefining the map addition operator (`++`) to reflect HOL4
semantics which are left to right (ltr), rather than right-to-left as in Isabelle/HOL.

This means that given a finite map (`M = M1 ++ M2`) and a variable `v` which is in the domain of
both `M1` and `M2`, the lookup `M v` will yield `M1 v` in HOL4 but `M2 v` in Isabelle/HOL.
This behavior can be confirmed  by looking at the definition of `fmap\_add` (`++f`,
Finite\_Map.thy:460)---which is lifted from `map\_add` (Map.thy:24)

  @{const map_add}  (infixl "++" 100) where
    @{term "m1 ++ m2 = (\<lambda>x. case m2 x of None \<Rightarrow> m1 x | Some y \<Rightarrow> Some y)"}

to finite sets---and the HOL4 definition of "FUNION` (finite\_mapScript.sml:770) which recurs
on `union\_lemma` (finite\_mapScript.sml:756)

  !\^fmap g.
     ?union.
       (FDOM union = FDOM f Union (g ` FDOM)) /\
       (!x. FAPPLY union x = if x IN FDOM f then FAPPLY f x else FAPPLY g x)

The ltr semantics are also reflected in [Abdulaziz et al., Definition 2, p.9].
\<close>

\<comment> \<open>NOTE hide `Map.map\_add` to free the operator symbol `++` and redefine it to reflect HOL4 map
addition semantics.\<close>
hide_const (open) Map.map_add
no_notation Map.map_add (infixl "++" 100)
definition fmap_add_ltr :: "('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap" (infixl "++" 100) where
  "m1 ++ m2 \<equiv> m2 ++\<^sub>f m1"

subsection \<open>States, Actions and Problems.\<close>

text \<open> Planning problems are typically formalized by considering possible states and the effect
of actions upon these states.

In this case we consider a world model in propositional logic: i.e. states are finite maps of
variables (with arbitrary type 'a) to boolean values and actions are pairs of states where the first
component specifies preconditions and the second component specifies effects (postconditions) of
applying the action to a given state. [Abdulaziz et al., Definition 2, p.9] \<close>

type_synonym ('a) state = "('a, bool) fmap"
type_synonym ('a) action = "('a state \<times> 'a state)"
type_synonym ('a) problem = "('a state \<times> 'a state) set"

text \<open> For a given action @{term "\<pi> = (p, e)"} the action domain @{term "\<D>(\<pi>)"} is the set of variables `v` where
a value is assigned to `v` in either `p` or `e`, i.e. `p v` or `e v` are defined. [Abdulaziz et al.,
Definition 2, p.9] \<close>
definition action_dom where
  "action_dom s1 s2 \<equiv> (fmdom' s1 \<union> fmdom' s2)"

\<comment> \<open>NOTE lemma `action\_dom\_pair`

  action\_dom a = FDOM (FST a) Union ((SND a) ` FDOM)

was removed because the curried definition of `action\_dom` in the translation makes it redundant.\<close>

text \<open> Now, for a given problem (i.e. action set) @{term "\<delta>"}, the problem domain @{term "\<D>(\<delta>)"} is given by the
union of the action domains of all actions in @{term "\<delta>"}. [Abdulaziz et al., Definition 3, p.9]

Moreover, the set of valid states @{term "U(\<delta>)"} is given by the union over all states whose domain is equal
to the problem domain and the set of valid action sequences (or, valid plans) is given by the
Kleene closure of @{term "\<delta>"}, i.e. @{term "\<delta>_star = {\<pi>. set(\<pi>) \<subseteq> \<delta>}"}. [Abdulaziz et al., Definition 3, p.9]

Ultimately, the effect of executing an action `a` on a state `s` is given by calculating the
succeding state. In general, the succeding state is either the preceding state---if the action does
not apply to the state, i.e. if the preconditions are not met---; or, the union of the effects of
the action application and the state. [Abdulaziz et al., Definition 3, p.9]
\<close>

\<comment> \<open>NOTE name shortened to 'prob\_dom'.\<close>
\<comment> \<open>NOTE lambda added to convert problem pairs to arguments of 'action\_dom'.\<close>
definition prob_dom where
  "prob_dom prob \<equiv> \<Union> ((\<lambda> (s1, s2). action_dom s1 s2) ` prob)"

definition valid_states where
  "valid_states prob \<equiv> {s. fmdom' s = prob_dom prob}"

definition valid_plans  where
  "valid_plans prob \<equiv> {as. set as \<subseteq> prob}"

definition state_succ where
  "state_succ s a \<equiv> (if fst a \<subseteq>\<^sub>f s then (snd a ++ s) else s)"

end


theory TopoS_Stateful_Policy
imports TopoS_Composition_Theory
begin

section{*Stateful Policy*}

text{*Details described in \cite{diekmann2014esss}. *}

text{* Algorithm *}
term TopoS_Composition_Theory.generate_valid_topology
text{* generates a valid high-level topology. Now we discuss how to turn this into
       a stateful policy. *}

text{*
Example:
  SensorNode produces data and has no security level.
  SensorSink has high security level
  SensorNode -> SensorSink, but not the other way round.
  Implementation: UDP in one direction

  Alice is in internal protected subnet. Google can not arbitrarily access Alice.
  Alice sends requests to google.
  It is desirable that Alice gets the response back
  Implementation: TCP and stateful packet filter that allows, once Alice establishes a connection, to get a response back via this connection.

Result:
  IFS violations undesirable.
  ACS violations may be okay under certain conditions.
*}

term all_security_requirements_fulfilled

text{* @{term "G = (V, E\<^sub>f\<^sub>i\<^sub>x, E\<^sub>s\<^sub>t\<^sub>a\<^sub>t\<^sub>e)"} *}
record 'v stateful_policy =
    hosts :: "'v set" --"nodes, vertices"
    flows_fix :: "('v \<times>'v) set" --"edges in high-level policy"
    flows_state :: "('v \<times>'v) set" --"edges that can have stateful flows, i.e. backflows"

text{* All the possible ways packets can travel in a @{typ "'v stateful_policy"}.
        They can either choose the fixed links;
        Or use a stateful link, i.e. establish state.
        Once state is established, packets can flow back via the established link.*}
definition all_flows :: "'v stateful_policy \<Rightarrow> ('v \<times> 'v) set" where
  "all_flows \<T> \<equiv> flows_fix \<T> \<union> flows_state \<T> \<union> backflows (flows_state \<T>)"

definition stateful_policy_to_network_graph :: "'v stateful_policy \<Rightarrow> 'v graph" where
  "stateful_policy_to_network_graph \<T> = \<lparr> nodes = hosts \<T>, edges = all_flows \<T> \<rparr>"

text{* @{typ "'v stateful_policy"} syntactically well-formed *}
locale wf_stateful_policy =
  fixes \<T> :: "'v stateful_policy"
  assumes E_wf: "fst ` (flows_fix \<T>) \<subseteq> (hosts \<T>)"
                   "snd ` (flows_fix \<T>) \<subseteq> (hosts \<T>)"
  and E_state_fix: "flows_state \<T> \<subseteq> flows_fix \<T>"
  and finite_Hosts: "finite (hosts \<T>)"
begin

  lemma finite_fix: "finite (flows_fix \<T>)"
  proof -
    from finite_subset[OF E_wf(1) finite_Hosts] have 1: "finite (fst ` flows_fix \<T>)" .
    from finite_subset[OF E_wf(2) finite_Hosts] have 2: "finite (snd ` flows_fix \<T>)" .
    have s: "flows_fix \<T> \<subseteq> (fst ` flows_fix \<T> \<times> snd ` flows_fix \<T>)" by force
    from finite_cartesian_product[OF 1 2] have "finite (fst ` flows_fix \<T> \<times> snd ` flows_fix \<T>)" .
    from finite_subset[OF s this] show ?thesis .
  qed

  lemma finite_state: "finite (flows_state \<T>)"
    using finite_subset[OF E_state_fix finite_fix] by assumption

  lemma finite_backflows_state: "finite (backflows (flows_state \<T>))"
    using [[simproc add: finite_Collect]] by(simp add: backflows_def finite_state)

  lemma E_state_backflows_wf: "fst ` backflows (flows_state \<T>) \<subseteq> (hosts \<T>)"
                         "snd ` backflows (flows_state \<T>) \<subseteq> (hosts \<T>)"
    by(auto simp add: backflows_def E_state_valid E_state_validD)

end

text{*Minimizing stateful flows such that only newly added backflows remain*}
  definition filternew_flows_state :: "'v stateful_policy \<Rightarrow> ('v \<times> 'v) set" where
    "filternew_flows_state \<T> \<equiv> {(s, r) \<in> flows_state \<T>. (r, s) \<notin> flows_fix \<T>}"

  lemma filternew_subseteq_flows_state: "filternew_flows_state \<T> \<subseteq> flows_state \<T>"
    by(auto simp add: filternew_flows_state_def)

  --"alternative definitions, all are equal"
  lemma filternew_flows_state_alt: "filternew_flows_state \<T>  = flows_state \<T> - (backflows (flows_fix \<T>))"
    apply(simp add: backflows_def filternew_flows_state_def)
    apply(rule)
     apply blast+
    done

  lemma stateful_policy_to_network_graph_filternew: "\<lbrakk> wf_stateful_policy \<T> \<rbrakk> \<Longrightarrow>
    stateful_policy_to_network_graph \<T> =
    stateful_policy_to_network_graph \<lparr>hosts = hosts \<T>, flows_fix = flows_fix \<T>, flows_state = filternew_flows_state \<T> \<rparr>"
    apply(drule wf_stateful_policy.E_state_fix)
    apply(simp add: stateful_policy_to_network_graph_def all_flows_def)
    apply(rule Set.equalityI)
     apply(simp add: filternew_flows_state_def backflows_def)
     apply(rule, blast)+
    apply(simp add: filternew_flows_state_def backflows_def)
    apply fastforce
    done

  lemma backflows_filternew_disjunct_flows_fix:
    "\<forall> b \<in> (backflows (filternew_flows_state \<T>)). b \<notin> flows_fix \<T>"
    by(simp add: filternew_flows_state_def backflows_def)

text{* Given a high-level policy, we can construct a pretty large syntactically valid low level policy. However, the stateful policy will
       almost certainly violate security requirements! *}
  lemma "wf_graph G \<Longrightarrow> wf_stateful_policy \<lparr> hosts = nodes G, flows_fix = nodes G \<times> nodes G, flows_state = nodes G \<times> nodes G \<rparr>"
    by(simp add: wf_stateful_policy_def wf_graph_def)

text{* @{const wf_stateful_policy} implies @{term wf_graph} *}
  lemma wf_stateful_policy_is_wf_graph: "wf_stateful_policy \<T> \<Longrightarrow> wf_graph \<lparr>nodes = hosts \<T>, edges = all_flows \<T>\<rparr>"
    apply(frule wf_stateful_policy.E_state_backflows_wf)
    apply(frule wf_stateful_policy.E_state_backflows_wf(2))
    apply(frule wf_stateful_policy.E_state_valid)
    apply(frule wf_stateful_policy.E_state_valid(2))
    apply(frule wf_stateful_policy.E_wf)
    apply(frule wf_stateful_policy.E_wf(2))
    apply(simp add: all_flows_def wf_graph_def wf_stateful_policy_def
          wf_stateful_policy.finite_fix wf_stateful_policy.finite_state wf_stateful_policy.finite_backflows_state)
    apply(rule conjI)
     apply (metis image_Un sup.bounded_iff)+
    done

(*we use the second way of writing it in the paper*)
lemma "(\<forall>F \<in> get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<T> ). F \<subseteq> backflows (filternew_flows_state \<T>)) \<longleftrightarrow>
    \<Union> get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<T> ) \<subseteq> (backflows (flows_state \<T>)) - (flows_fix \<T>)"
    by(simp add: filternew_flows_state_alt backflows_minus_backflows, blast)

text{* When is a stateful policy @{term "\<T>"} compliant with a high-level policy @{term "G"} and the security requirements @{term "M"}? *}
locale stateful_policy_compliance =
  fixes \<T> :: "('v::vertex) stateful_policy"
  fixes G :: "'v graph"
  fixes M :: "('v) SecurityInvariant_configured list"
  assumes
    -- "the graph must be syntactically valid"
    wfG: "wf_graph G"
    and
    -- "security requirements must be valid"
    validReqs: "valid_reqs M"
    and
    -- "the high-level policy must be valid"
    high_level_policy_valid: "all_security_requirements_fulfilled M G"
    and
    -- "the stateful policy must be syntactically valid"
    stateful_policy_wf:
    "wf_stateful_policy \<T>"
    and
    -- "the stateful policy must talk about the same nodes as the high-level policy"
    hosts_nodes:
    "hosts \<T> = nodes G"
    and
    -- "only flows that are allowed in the high-level policy are allowed in the stateful policy"
    flows_edges:
    "flows_fix \<T> \<subseteq> edges G"
    and
    -- "the low level policy must comply with the high-level policy"
      -- "all information flow strategy requirements must be fulfilled, i.e. no leaks!"
      compliant_stateful_IFS:
        "all_security_requirements_fulfilled (get_IFS M) (stateful_policy_to_network_graph \<T>)"
      and
      -- "No Access Control side effects must occur"
      compliant_stateful_ACS:
        "\<forall>F \<in> get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<T> ). F \<subseteq> backflows (filternew_flows_state \<T>)"

  begin
    lemma compliant_stateful_ACS_no_side_effects_filternew_helper:
      "\<forall> E \<subseteq> backflows (filternew_flows_state \<T>). \<forall> F \<in> get_offending_flows (get_ACS M) \<lparr> nodes = hosts \<T>, edges = flows_fix \<T> \<union> E \<rparr>. F \<subseteq> E"
    proof(rule, rule)
      fix E
      assume a1: "E \<subseteq> backflows (filternew_flows_state \<T>)"
      from validReqs have valid_ReqsACS: "valid_reqs (get_ACS M)" by(simp add: get_ACS_def valid_reqs_def)

      from compliant_stateful_ACS stateful_policy_to_network_graph_filternew[OF stateful_policy_wf] have compliant_stateful_ACS_only_state_violations_filternew:
      "\<forall>F \<in> get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<lparr>hosts = hosts \<T>, flows_fix = flows_fix \<T>, flows_state = filternew_flows_state \<T> \<rparr>). F \<subseteq> backflows (filternew_flows_state \<T>)" by simp

      from wf_stateful_policy_is_wf_graph[OF stateful_policy_wf] have wfGfilternew:
        "wf_graph \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> filternew_flows_state \<T> \<union> backflows (filternew_flows_state \<T>)\<rparr>"
        apply(simp add: all_flows_def filternew_flows_state_alt backflows_minus_backflows)
        by(auto simp add: wf_graph_def)

      from wf_stateful_policy.E_state_fix[OF stateful_policy_wf] filternew_subseteq_flows_state have flows_fix_un_filternew_simp: "flows_fix \<T> \<union> filternew_flows_state \<T> = flows_fix \<T>" by blast

      from compliant_stateful_ACS_only_state_violations_filternew have
        "\<And>m. m \<in> set (get_ACS M) \<Longrightarrow>
        \<Union>(c_offending_flows m \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> filternew_flows_state \<T> \<union> backflows (filternew_flows_state \<T>)\<rparr>) \<subseteq> backflows (filternew_flows_state \<T>)"
        by(simp add: stateful_policy_to_network_graph_def all_flows_def get_offending_flows_def, blast)

      --{*idea: use @{thm compliant_stateful_ACS} with the @{thm configured_SecurityInvariant.Un_set_offending_flows_bound_minus_subseteq}
        lemma and substract @{term "backflows (filternew_flows_state \<T>) - E"}, on the right hand side @{term E} remains, as Graph's edges @{term "flows_fix \<T>  \<union> E"} remains*}

      from configured_SecurityInvariant.Un_set_offending_flows_bound_minus_subseteq[where X="backflows (filternew_flows_state \<T>)", OF _ wfGfilternew this]
        `valid_reqs (get_ACS M)`
        have
        "\<And> m E. m \<in> set (get_ACS M) \<Longrightarrow>
        \<forall>F\<in>c_offending_flows m \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> filternew_flows_state \<T> \<union> backflows (filternew_flows_state \<T>) - E\<rparr>. F \<subseteq> backflows (filternew_flows_state \<T>) - E"
        by(auto simp add: all_flows_def valid_reqs_def)
      from this flows_fix_un_filternew_simp have rule:
        "\<And> m E. m \<in> set (get_ACS M) \<Longrightarrow>
        \<forall>F\<in>c_offending_flows m \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> backflows (filternew_flows_state \<T>) - E\<rparr>. F \<subseteq> backflows (filternew_flows_state \<T>) - E"
        by simp

      from  backflows_finite rev_finite_subset[OF wf_stateful_policy.finite_state[OF stateful_policy_wf] filternew_subseteq_flows_state] have
        "finite (backflows (filternew_flows_state \<T>))" by blast
      from a1 this have "finite E" by (metis rev_finite_subset)

      from a1 obtain E' where E'_prop1: "backflows (filternew_flows_state \<T>) - E' = E" and E'_prop2: "E' = backflows (filternew_flows_state \<T>) - E" by blast
      from E'_prop2 `finite (backflows (filternew_flows_state \<T>))` `finite E` have "finite E'" by blast

      from Set.double_diff[where B="backflows (filternew_flows_state \<T>)" and C="backflows (filternew_flows_state \<T>)" and A="E", OF a1, simplified] have Ebackflowssimp:
        "backflows (filternew_flows_state \<T>) - (backflows (filternew_flows_state \<T>) - E) = E" .

      have "flows_fix \<T> \<union> backflows (filternew_flows_state \<T>) - (backflows (filternew_flows_state \<T>) - E) =
          (flows_fix \<T> - (backflows (filternew_flows_state \<T>))) \<union> E"
          apply(simp add: Set.Un_Diff)
          apply(simp add: Ebackflowssimp)
          by blast
      also have "(flows_fix \<T> - (backflows (filternew_flows_state \<T>))) \<union> E = flows_fix \<T>  \<union> E" using backflows_filternew_disjunct_flows_fix by blast
      finally have flows_E_simp: "flows_fix \<T> \<union> backflows (filternew_flows_state \<T>) - (backflows (filternew_flows_state \<T>) - E) = flows_fix \<T>  \<union> E" .

      from rule[simplified E'_prop1 E'_prop2] have
      "\<And>m. m \<in> set (get_ACS M) \<Longrightarrow>
      \<forall>F\<in>c_offending_flows m \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> backflows (filternew_flows_state \<T>) - (backflows (filternew_flows_state \<T>) - E)\<rparr>.
       F \<subseteq> backflows (filternew_flows_state \<T>) - (backflows (filternew_flows_state \<T>) - E)"
       by(simp)
      from this Ebackflowssimp flows_E_simp have
      "\<And>m. m \<in> set (get_ACS M) \<Longrightarrow>
        \<forall>F\<in>c_offending_flows m \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> E\<rparr>. F \<subseteq> E"
       by simp
      thus  "\<forall>F\<in>get_offending_flows (get_ACS M) \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> E\<rparr>. F \<subseteq> E"
        by(simp add: get_offending_flows_def)
      qed

    theorem compliant_stateful_ACS_no_side_effects:
      "\<forall> E \<subseteq> backflows (flows_state \<T>). \<forall> F \<in> get_offending_flows(get_ACS M) \<lparr> nodes = hosts \<T>, edges = flows_fix \<T> \<union> E \<rparr>. F \<subseteq> E"
    proof -
      from compliant_stateful_ACS stateful_policy_to_network_graph_filternew[OF stateful_policy_wf] have a1:
      "\<forall>F \<in> get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<lparr>hosts = hosts \<T>, flows_fix = flows_fix \<T>, flows_state = filternew_flows_state \<T> \<rparr>). F \<subseteq> backflows (filternew_flows_state \<T>)" by simp

      have backflows_split: "backflows (filternew_flows_state \<T>) \<union> (backflows (flows_state \<T>) - backflows (filternew_flows_state \<T>)) = backflows (flows_state \<T>)"
        by (metis Diff_subset Un_Diff_cancel Un_absorb1 backflows_minus_backflows filternew_flows_state_alt)

      have
        "\<forall>E\<subseteq>backflows (filternew_flows_state \<T>) \<union> (backflows (flows_state \<T>) - backflows (filternew_flows_state \<T>)).
             \<forall>F\<in>get_offending_flows (get_ACS M) \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> E\<rparr>. F \<subseteq> E"
        proof(rule allI, rule impI)
          fix E
          assume h1: "E \<subseteq> backflows (filternew_flows_state \<T>) \<union> (backflows (flows_state \<T>) - backflows (filternew_flows_state \<T>))"

          have "\<exists> E1 E2. E1 \<subseteq> backflows (filternew_flows_state \<T>) \<and> E2 \<subseteq> (backflows (flows_state \<T>) - backflows (filternew_flows_state \<T>)) \<and> E1 \<union> E2 = E \<and> E1 \<inter> E2 = {}"
            apply(rule_tac x="{e \<in> E. e \<in> backflows (filternew_flows_state \<T>)}" in exI)
            apply(rule_tac x="{e \<in> E. e \<in>(backflows (flows_state \<T>) - backflows (filternew_flows_state \<T>))}" in exI)
            apply(simp)
            apply(rule)
             apply blast
            apply(rule)
             apply blast
            apply(rule)
             using h1 apply blast
            using backflows_filternew_disjunct_flows_fix by blast

          from this obtain E1 E2 where E1_prop: "E1 \<subseteq> backflows (filternew_flows_state \<T>)" and E2_prop: "E2 \<subseteq> (backflows (flows_state \<T>) - backflows (filternew_flows_state \<T>))" and "E = E1 \<union> E2" and "E1 \<inter> E2 = {}" by blast

          --{*the stateful flows are @{text "\<subseteq>"} fix flows. If substracting the new stateful flows, onyly the existing fix flows remain*}
          from E2_prop filternew_flows_state_alt have "E2 \<subseteq> flows_fix \<T>" by (metis (hide_lams, no_types) Diff_subset_conv Un_Diff_cancel2 backflows_minus_backflows inf_sup_ord(3) order.trans)
          --"hence, E2 disappears"
          from Set.Un_absorb1[OF this] have E2_absorb: "flows_fix \<T> \<union> E2 = flows_fix \<T>" by blast

          from `E = E1 \<union> E2` have E2E1eq: "E2 \<union> E1 = E" by blast

          from `E = E1 \<union> E2` `E1 \<inter> E2 = {}` have "E1 \<subseteq> E" by simp

          from compliant_stateful_ACS_no_side_effects_filternew_helper E1_prop have "\<forall>F\<in>get_offending_flows (get_ACS M) \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> E1 \<rparr>. F \<subseteq> E1" by simp
          hence "\<forall>F\<in>get_offending_flows (get_ACS M) \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> E2 \<union> E1 \<rparr>. F \<subseteq> E1" using E2_absorb[symmetric] by simp
          hence "\<forall>F\<in>get_offending_flows (get_ACS M) \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> E \<rparr>. F \<subseteq> E1" using E2E1eq by (metis Un_assoc)

          from this `E1 \<subseteq> E` show "\<forall>F\<in>get_offending_flows (get_ACS M) \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> E\<rparr>. F \<subseteq> E" by blast
        qed

      from this backflows_split show ?thesis by presburger
    qed

    corollary compliant_stateful_ACS_no_side_effects': "\<forall> E \<subseteq> backflows (flows_state \<T>). \<forall> F \<in> get_offending_flows(get_ACS M) \<lparr> nodes = hosts \<T>, edges = flows_fix \<T> \<union> flows_state \<T> \<union> E \<rparr>. F \<subseteq> E"
      using compliant_stateful_ACS_no_side_effects wf_stateful_policy.E_state_fix[OF stateful_policy_wf] by (metis Un_absorb2)

    text{* The high level graph generated from the low level policy is a valid graph*}
    lemma valid_stateful_policy: "wf_graph \<lparr>nodes = hosts \<T>, edges = all_flows \<T>\<rparr>"
      by(rule wf_stateful_policy_is_wf_graph,fact stateful_policy_wf)

    text{* The security requirements are definitely fulfilled if we consider only the fixed flows and the
           normal direction of the stateful flows (i.e. no backflows).
           I.e. considering no states, everything must be fulfilled *}
    lemma compliant_stateful_ACS_static_valid: "all_security_requirements_fulfilled (get_ACS M) \<lparr> nodes = hosts \<T>, edges = flows_fix \<T>  \<rparr>"
    proof -
      from validReqs have valid_ReqsACS: "valid_reqs (get_ACS M)" by(simp add: get_ACS_def valid_reqs_def)
      from wfG hosts_nodes[symmetric] have wfG': "wf_graph \<lparr> nodes = hosts \<T>, edges = edges G  \<rparr>" by(case_tac G, simp)
      from high_level_policy_valid have "all_security_requirements_fulfilled (get_ACS M) G"
        by(simp add: get_ACS_def all_security_requirements_fulfilled_def)
      from this hosts_nodes[symmetric] have "all_security_requirements_fulfilled (get_ACS M) \<lparr> nodes = hosts \<T>, edges = edges G  \<rparr>"
        by(case_tac G, simp)
      from all_security_requirements_fulfilled_mono[OF valid_ReqsACS flows_edges wfG' this] show ?thesis .
    qed
    theorem compliant_stateful_ACS_static_valid':
      "all_security_requirements_fulfilled M \<lparr> nodes = hosts \<T>, edges = flows_fix \<T> \<union> flows_state \<T>  \<rparr>"
      proof -
        from validReqs have valid_ReqsIFS: "valid_reqs (get_IFS M)" by(simp add: get_IFS_def valid_reqs_def)

        --"show that it holds for IFS, by monotonicity as it holds for more in IFS"
        from all_security_requirements_fulfilled_mono[OF valid_ReqsIFS _ valid_stateful_policy compliant_stateful_IFS[unfolded stateful_policy_to_network_graph_def]] have
          goalIFS: "all_security_requirements_fulfilled (get_IFS M) \<lparr> nodes = hosts \<T>, edges = flows_fix \<T> \<union> flows_state \<T>  \<rparr>" by(simp add: all_flows_def)

        from wf_stateful_policy.E_state_fix[OF stateful_policy_wf] have "flows_fix \<T> \<union> flows_state \<T> =  flows_fix \<T>" by blast
        from this compliant_stateful_ACS_static_valid have goalACS:
          "all_security_requirements_fulfilled (get_ACS M) \<lparr> nodes = hosts \<T>, edges = flows_fix \<T> \<union> flows_state \<T>  \<rparr>" by simp

        --"ACS and IFS together form M, we know it holds for ACS"
        from goalACS goalIFS show ?thesis
          apply(simp add: all_security_requirements_fulfilled_def get_IFS_def get_ACS_def)
          by fastforce
    qed

    text{* The flows with state are a subset of the flows allowed by the policy *}
    theorem flows_state_edges: "flows_state \<T> \<subseteq> edges G"
      using wf_stateful_policy.E_state_fix[OF stateful_policy_wf] flows_edges by simp

    text{* All offending flows are subsets of the reveres stateful flows *}
    lemma compliant_stateful_ACS_only_state_violations:
      "\<forall>F \<in> get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<T>). F \<subseteq> backflows (flows_state \<T>)"
      proof -
        have "backflows (filternew_flows_state \<T>) \<subseteq> backflows (flows_state \<T>)" by (metis Diff_subset backflows_minus_backflows filternew_flows_state_alt)
        from compliant_stateful_ACS this have
          "\<forall> F \<in> get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<T>). F \<subseteq> backflows (flows_state \<T>)"
          by (metis subset_trans)
        thus ?thesis .
      qed
    theorem compliant_stateful_ACS_only_state_violations': "\<forall>F \<in> get_offending_flows M (stateful_policy_to_network_graph \<T>). F \<subseteq> backflows (flows_state \<T>)"
      proof -
        from validReqs have valid_ReqsIFS: "valid_reqs (get_IFS M)" by(simp add: get_IFS_def valid_reqs_def)
        have offending_split: "\<And>G. get_offending_flows M G = (get_offending_flows (get_IFS M) G \<union> get_offending_flows (get_ACS M) G)"
          apply(simp add: get_offending_flows_def get_IFS_def get_ACS_def) by blast
       show ?thesis
        apply(subst offending_split)
        using compliant_stateful_ACS_only_state_violations
              all_security_requirements_fulfilled_imp_get_offending_empty[OF valid_ReqsIFS compliant_stateful_IFS]
        by auto
      qed

    text {* All violations are backflows of valid flows *}
    corollary compliant_stateful_ACS_only_state_violations_union: "\<Union> get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<T>) \<subseteq> backflows (flows_state \<T>)"
    using compliant_stateful_ACS_only_state_violations by fastforce

    corollary compliant_stateful_ACS_only_state_violations_union': "\<Union> get_offending_flows M (stateful_policy_to_network_graph \<T>) \<subseteq> backflows (flows_state \<T>)"
    using compliant_stateful_ACS_only_state_violations' by fastforce

    text{* All individual flows cause no side effects, i.e. each backflow causes at most itself as violation, no other
           side-effect violations are induced. *}
    lemma  compliant_stateful_ACS_no_state_singleflow_side_effect:
      "\<forall> (v\<^sub>1, v\<^sub>2) \<in> backflows (flows_state \<T>).
       (\<Union> get_offending_flows(get_ACS M) \<lparr> nodes = hosts \<T>, edges = flows_fix \<T> \<union> flows_state \<T> \<union> {(v\<^sub>1, v\<^sub>2)} \<rparr>) \<subseteq> {(v\<^sub>1, v\<^sub>2)}"
    using compliant_stateful_ACS_no_side_effects' by blast
  end

subsection{* Summarizing the important theorems *}

  text{* No information flow security requirements are violated (including all added stateful flows)*}
  thm stateful_policy_compliance.compliant_stateful_IFS

  text{* There are not access control side effects when allowing stateful backflows.
          I.e. for all possible subsets of the to-allow backflows, the violations they cause are only these backflows themselves*}
  thm stateful_policy_compliance.compliant_stateful_ACS_no_side_effects'

    text{* Also, considering all backflows individually, they cause no side effect, i.e. the only violation added is the backflow itself *}
    thm stateful_policy_compliance.compliant_stateful_ACS_no_state_singleflow_side_effect

    text{* In particular, all introduced offending flows for access control strategies are at most the stateful backflows *}
    thm stateful_policy_compliance.compliant_stateful_ACS_only_state_violations_union
    text{* Which implies: all introduced offending flows are at most the stateful backflows *}
    thm stateful_policy_compliance.compliant_stateful_ACS_only_state_violations_union'

  text{* Disregarding the backflows of stateful flows, all security requirements are fulfilled. *}
  thm stateful_policy_compliance.compliant_stateful_ACS_static_valid'

end


theory Ports
imports String
  "~~/src/HOL/Word/Word"
  "../Common/WordInterval_Lists"
  L4_Protocol_Flags
begin

section\<open>Ports (layer 4)\<close>
text\<open>E.g. source and destination ports for TCP/UDP\<close>

text\<open>list of (start, end) port ranges\<close>
type_synonym raw_ports = "(16 word \<times> 16 word) list"

fun ports_to_set :: "raw_ports \<Rightarrow> (16 word) set" where
  "ports_to_set [] = {}" |
  "ports_to_set ((s,e)#ps) = {s..e} \<union> ports_to_set ps"

lemma ports_to_set: "ports_to_set pts = \<Union> {{s..e} | s e . (s,e) \<in> set pts}"
  proof(induction pts)
  case Nil thus ?case by simp
  next
  case (Cons p pts) thus ?case by(cases p, simp, blast)
  qed

text\<open>We can reuse the wordinterval theory to reason about ports\<close>
lemma ports_to_set_wordinterval: "ports_to_set ps = wordinterval_to_set (l2wi ps)"
  by(induction ps rule: l2wi.induct) (auto)

text\<open>inverting a raw listing of ports\<close>
definition "raw_ports_invert" :: "raw_ports \<Rightarrow> raw_ports" where
  "raw_ports_invert ps = wi2l (wordinterval_invert (l2wi ps))"

lemma raw_ports_invert: "ports_to_set (raw_ports_invert ps) = - ports_to_set ps"
  by(auto simp add: raw_ports_invert_def l2wi_wi2l ports_to_set_wordinterval)

text\<open>A port always belongs to a protocol! We must not lose this information.
 You should never use @{typ raw_ports} directly\<close>
datatype ipt_l4_ports = L4Ports primitive_protocol raw_ports

end


section \<open>
  Equivalence of a Diamond-Shaped Forwarding Praos Network and a Cross-Shaped Broadcasting Praos
  Network
\<close>

theory Ouroboros_Praos_Forwarding_Broadcasting_Equivalence
  imports
    "Chi_Calculus_Examples.Network_Equivalences-Forwarding_Broadcasting"
    Ouroboros_Praos_Implementation
begin

theorem praos_diamond_cross_equivalence:
  assumes "
    (s\<^sub>1, s\<^sub>2, s\<^sub>3, s\<^sub>4) =
      (untyped_channel ts\<^sub>1, untyped_channel ts\<^sub>2, untyped_channel ts\<^sub>3, untyped_channel ts\<^sub>4)"
  and "
    (r\<^sub>1, r\<^sub>2, r\<^sub>3, r\<^sub>4) =
      (untyped_channel tr\<^sub>1, untyped_channel tr\<^sub>2, untyped_channel tr\<^sub>3, untyped_channel tr\<^sub>4)"
  and "
    args = [
      (U\<^sub>1, sk\<^sub>1\<^sub>_\<^sub>v\<^sub>r\<^sub>f, sk\<^sub>1\<^sub>_\<^sub>k\<^sub>e\<^sub>s, sk\<^sub>1\<^sub>_\<^sub>d\<^sub>s\<^sub>i\<^sub>g, ts\<^sub>1, tr\<^sub>1), (U\<^sub>2, sk\<^sub>2\<^sub>_\<^sub>v\<^sub>r\<^sub>f, sk\<^sub>2\<^sub>_\<^sub>k\<^sub>e\<^sub>s, sk\<^sub>2\<^sub>_\<^sub>d\<^sub>s\<^sub>i\<^sub>g, ts\<^sub>2, tr\<^sub>2),
      (U\<^sub>3, sk\<^sub>3\<^sub>_\<^sub>v\<^sub>r\<^sub>f, sk\<^sub>3\<^sub>_\<^sub>k\<^sub>e\<^sub>s, sk\<^sub>3\<^sub>_\<^sub>d\<^sub>s\<^sub>i\<^sub>g, ts\<^sub>3, tr\<^sub>3), (U\<^sub>4, sk\<^sub>4\<^sub>_\<^sub>v\<^sub>r\<^sub>f, sk\<^sub>4\<^sub>_\<^sub>k\<^sub>e\<^sub>s, sk\<^sub>4\<^sub>_\<^sub>d\<^sub>s\<^sub>i\<^sub>g, ts\<^sub>4, tr\<^sub>4)]"
  and "
    shs =
      \<Prod>(U\<^sub>i, sk\<^sub>i\<^sub>_\<^sub>v\<^sub>r\<^sub>f, sk\<^sub>i\<^sub>_\<^sub>k\<^sub>e\<^sub>s, sk\<^sub>i\<^sub>_\<^sub>d\<^sub>s\<^sub>i\<^sub>g, ts\<^sub>i, tr\<^sub>i)\<leftarrow>args. stakeholder U\<^sub>i G sk\<^sub>i\<^sub>_\<^sub>v\<^sub>r\<^sub>f sk\<^sub>i\<^sub>_\<^sub>k\<^sub>e\<^sub>s sk\<^sub>i\<^sub>_\<^sub>d\<^sub>s\<^sub>i\<^sub>g (ts\<^sub>i, tr\<^sub>i)"
  shows "
    shs \<parallel>
    \<currency>\<^sup>?r\<^sub>0 \<parallel> \<currency>\<^sup>?r\<^sub>1 \<parallel> \<currency>\<^sup>?r\<^sub>2 \<parallel> \<currency>\<^sup>?r\<^sub>3 \<parallel>
    diamond s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3
    \<approx>\<^sub>\<sharp>
    shs \<parallel>
    \<currency>\<^sup>?r\<^sub>0 \<parallel> \<currency>\<^sup>?r\<^sub>1 \<parallel> \<currency>\<^sup>?r\<^sub>2 \<parallel> \<currency>\<^sup>?r\<^sub>3 \<parallel>
    cross s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3"
  using diamond_cross_equivalence by equivalence

end


theory Proofs4
  imports Requirements VCTheoryLemmas
begin

definition inv4 where "inv4 s \<equiv> R4 s \<and> extraInv s"

definition pred4 where "pred4 s1 s2 s s5 \<equiv>
substate s1 s2 \<and> substate s2 s5 \<and> substate s5 s \<and> toEnvP s1 \<and> toEnvP s2 \<and> toEnvNum s1 s2 = 1 \<and> toEnvNum s2 s = 100 \<and>
\<not> getVarBool s1 open' \<and> getVarBool s2 open' \<and>
(\<forall> s3. toEnvP s3 \<and> substate s2 s3 \<and> substate s3 s5 \<and> s3 \<noteq> s5 \<longrightarrow> getVarBool s3 open') \<longrightarrow>
(\<exists> s4. toEnvP s4 \<and> substate s5 s4 \<and> substate s4 s \<and> toEnvNum s2 s4 \<le> 100 \<and> \<not> getVarBool s4 open' \<and>
(\<forall> s3. toEnvP s3 \<and> substate s5 s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow> getVarBool s3 open'))"

lemma minimalOpened_open: "toEnvP s1 \<and> toEnvP s2 \<and> toEnvP s0 \<and> substate s1 s2 \<and> substate s2 s0 \<and> substate s0 s\<and> toEnvNum s1 s2 = 1 \<and>
10 \<le> toEnvNum s2 s0 \<and> toEnvNum s2 s0 \<le> 99 \<and> \<not> getVarBool s1 open' \<and> getVarBool s2 open' \<and>
 getPstate s0 Controller' = Controller'minimalOpened' \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> getPstate s1 Init'init' = Controller'minimalOpened' \<longrightarrow> ltime s1 Init'init' \<le> 10) \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> getPstate s1 Init'init' = Controller'minimalOpened' \<longrightarrow>
      (\<exists>s2 s3.
          toEnvP s2 \<and>
          toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s1 \<and>
          toEnvNum s2 s3 = 1 \<and>
          toEnvNum s2 s1 = ltime s1 Init'init' \<and> getPstate s2 Init'init' = Controller'isClosed' \<and> getVarBool s3 Init'init')) \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> (getPstate s1 Init'init' = Controller'isClosed' \<or> getPstate s1 Init'init' = STOP) \<longrightarrow>
      \<not> getVarBool s1 Controller'minimalOpened')
\<longrightarrow>
(\<exists> s3. toEnvP s3 \<and> substate s2 s3 \<and> substate s3 s0 \<and> \<not> getVarBool s3 open')"
  apply(rule impI)
  apply(rule exE[of " (\<lambda> s2. \<exists> s3.
          toEnvP s2 \<and>
          toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s0 \<and>
          toEnvNum s2 s3 = 1 \<and>
          toEnvNum s2 s0 = ltime s0 Init'init' \<and> getPstate s2 Init'init' = Controller'isClosed' \<and> getVarBool s3 Init'init') "])
   apply blast
  apply(drule exE)
   prefer 2
   apply assumption
  subgoal for s3 s4
    apply(rule exI[of _ s3])
    apply(rule cut_rl[of "substate s2 s3"])
    using substate_trans
     apply meson
    using toEnvNum_substate2 substate_trans
    by (smt (verit) le_antisym le_trans substate_linear toEnvNum_eq_imp_eq2)
  done

lemma isOpened_open: "toEnvP s1 \<and> toEnvP s2 \<and> toEnvP s0 \<and> substate s1 s2 \<and> substate s2 s0 \<and> substate s0 s\<and> toEnvNum s1 s2 = 1 \<and>
 toEnvNum s2 s0 = 99 \<and> \<not> getVarBool s1 open' \<and> getVarBool s2 open' \<and>
 getPstate s0 Controller' = Controller'isOpened' \<and> ltime s0 Controller' < 90 \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> getPstate s1 Init'init' = Controller'minimalOpened' \<longrightarrow> ltime s1 Init'init' \<le> 10) \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> getPstate s1 Init'init' = Controller'minimalOpened' \<longrightarrow>
      (\<exists>s2 s3.
          toEnvP s2 \<and>
          toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s1 \<and>
          toEnvNum s2 s3 = 1 \<and>
          toEnvNum s2 s1 = ltime s1 Init'init' \<and> getPstate s2 Init'init' = Controller'isClosed' \<and> getVarBool s3 Init'init')) \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> (getPstate s1 Init'init' = Controller'isClosed' \<or> getPstate s1 Init'init' = STOP) \<longrightarrow>
      \<not> getVarBool s1 Controller'minimalOpened') \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> getPstate s1 Init'init' = Controller'isOpened' \<longrightarrow> ltime s1 Init'init' \<le> 90) \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> getPstate s1 Init'init' = Controller'isOpened' \<longrightarrow>
      (\<exists>s2 s3.
          toEnvP s2 \<and>
          toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s1 \<and>
          toEnvNum s2 s3 = 1 \<and>
          toEnvNum s2 s1 = ltime s1 Init'init' \<and>
          getPstate s2 Init'init' = Controller'minimalOpened' \<and> \<not> getVarBool s3 EntranceController'isOpened'))
\<longrightarrow>
(\<exists> s3. toEnvP s3 \<and> substate s2 s3 \<and> substate s3 s0 \<and> \<not> getVarBool s3 open')"
  apply(rule impI)
  apply(rule exE[of "(\<lambda> s2.\<exists> s3.
              toEnvP s2 \<and>
              toEnvP s3 \<and>
              substate s2 s3 \<and>
              substate s3 s0 \<and>
              toEnvNum s2 s3 = 1 \<and>
              toEnvNum s2 s0 = ltime s0 Init'init' \<and>
              getPstate s2 Init'init' = Controller'minimalOpened' \<and> \<not> getVarBool s3 EntranceController'isOpened')"])
  apply blast
  apply(drule exE)
   prefer 2
   apply assumption
  subgoal for s3 s4
 apply(rule cut_rl[of " substate s3 s0 "])
    apply(rule impE[OF minimalOpened_open[of s1 s2 s3 s]])
    subgoal
      apply((drule conjE[of _ _ ?thesis])+)
                          defer
                          apply assumption+
    using substate_trans apply -[1]
    apply(rule cut_rl[of "substate s2 s3"])
apply(rule conjI)
      apply blast
    apply(rule conjI)
      apply blast
    apply(rule conjI)
      apply blast
    apply(rule conjI)
      apply blast
    apply(rule conjI)
       apply blast
     apply(rule conjI)
       apply meson
    apply(rule conjI)
      apply blast
     apply(rule conjI)
    using toEnvNum3[of s2 s3 s0] apply arith
     apply(rule conjI)
    using toEnvNum3[of s2 s3 s0] apply arith
     apply blast
     apply(rule cut_rl[of "\<not>substate s3 s2 \<or> s2=s3"])
    using substate_linear substate_refl
      apply meson
     apply(rule cut_rl[of "toEnvNum s3 s0 \<le> toEnvNum s2 s0"])
    using toEnvNum_substate2 toEnvNum_eq_imp_eq2
      apply (meson le_antisym)
    by arith
   apply(drule exE)
    prefer 2
    apply assumption
  subgoal for s5
    apply(rule exI[of _ s5])
    using substate_trans[of s5 s3 s0]
    by blast
  using substate_trans[of s3 s4 s0] by blast
  done

theorem proof_4_1: "VC1 inv4 s0"
  apply(simp only: VC1_def inv4_def R4_def extraInv_def)
  by auto

theorem proof_4_346: "VC346 inv4 env s0 PdOut_value paid_value opened_value"
  apply(simp only: VC346_def)
  by auto

theorem proof_4_348: "VC348 inv4 env s0 PdOut_value paid_value opened_value"
  apply(simp only: VC348_def)
  by auto

end