(* Victor B. F. Gomes, University of Cambridge
   Martin Kleppmann, University of Cambridge
   Dominic P. Mulligan, University of Cambridge
   Alastair R. Beresford, University of Cambridge
*)

section\<open>Axiomatic network models\<close>

text\<open>In this section we develop a formal definition of an \emph{asynchronous unreliable causal broadcast network}.
     We choose this model because it satisfies the causal delivery requirements of many operation-based
     CRDTs~\<^cite>\<open>"Almeida:2015fc" and "Baquero:2014ed"\<close>. Moreover, it is suitable for use in decentralised settings,
     as motivated in the introduction, since it does not require waiting for communication with
     a central server or a quorum of nodes.\<close>

theory
  Network
imports
  Convergence
begin

subsection\<open>Node histories\<close>

text\<open>We model a distributed system as an unbounded number of communicating nodes.
     We assume nothing about the communication pattern of nodes---we assume only that each node is
     uniquely identified by a natural number, and that the flow of execution at each node consists
     of a finite, totally ordered sequence of execution steps (events).
     We call that sequence of events at node $i$ the \emph{history} of that node.
     For convenience, we assume that every event or execution step is unique within a node's history.\<close>

locale node_histories =
  fixes history :: "nat \<Rightarrow> 'evt list"
  assumes histories_distinct [intro!, simp]: "distinct (history i)"

lemma (in node_histories) history_finite:
  shows "finite (set (history i))"
by auto

definition (in node_histories) history_order :: "'evt \<Rightarrow> nat \<Rightarrow> 'evt \<Rightarrow> bool" ("_/ \<sqsubset>\<^sup>_/ _" [50,1000,50]50) where
  "x \<sqsubset>\<^sup>i z \<equiv> \<exists>xs ys zs. xs@x#ys@z#zs = history i"

lemma (in node_histories) node_total_order_trans:
  assumes "e1 \<sqsubset>\<^sup>i e2"
      and "e2 \<sqsubset>\<^sup>i e3"
    shows "e1 \<sqsubset>\<^sup>i e3"
proof -
  obtain xs1 xs2 ys1 ys2 zs1 zs2 where *: "xs1 @ e1 # ys1 @ e2 # zs1 = history i"
      "xs2 @ e2 # ys2 @ e3 # zs2 = history i"
    using history_order_def assms by auto
  hence "xs1 @ e1 # ys1 = xs2 \<and> zs1 = ys2 @ e3 # zs2"
    by(rule_tac xs="history i" and ys="[e2]" in pre_suf_eq_distinct_list) auto
  thus ?thesis
    by(clarsimp simp: history_order_def) (metis "*"(2) append.assoc append_Cons)
qed

lemma (in node_histories) local_order_carrier_closed:
  assumes "e1 \<sqsubset>\<^sup>i e2"
    shows "{e1,e2} \<subseteq> set (history i)"
  using assms by (clarsimp simp add: history_order_def)
    (metis in_set_conv_decomp Un_iff Un_subset_iff insert_subset list.simps(15)
        set_append set_subset_Cons)+

lemma (in node_histories) node_total_order_irrefl:
  shows "\<not> (e \<sqsubset>\<^sup>i e)"
  by(clarsimp simp add: history_order_def)
    (metis Un_iff histories_distinct distinct_append distinct_set_notin
        list.set_intros(1) set_append)

lemma (in node_histories) node_total_order_antisym:
  assumes "e1 \<sqsubset>\<^sup>i e2"
      and "e2 \<sqsubset>\<^sup>i e1"
    shows "False"
  using assms node_total_order_irrefl node_total_order_trans by blast

lemma (in node_histories) node_order_is_total:
  assumes "e1 \<in> set (history i)"
      and "e2 \<in> set (history i)"
      and "e1 \<noteq> e2"
    shows "e1 \<sqsubset>\<^sup>i e2 \<or> e2 \<sqsubset>\<^sup>i e1"
  using assms unfolding history_order_def by(metis list_split_two_elems histories_distinct)

definition (in node_histories) prefix_of_node_history :: "'evt list \<Rightarrow> nat \<Rightarrow> bool" (infix "prefix of" 50) where
  "xs prefix of i \<equiv> \<exists>ys. xs@ys = history i"

lemma (in node_histories) carriers_head_lt:
  assumes "y#ys = history i"
  shows   "\<not>(x \<sqsubset>\<^sup>i y)"
using assms
  apply(clarsimp simp add: history_order_def)
  apply(rename_tac xs1 ys1 zs1)
   apply (subgoal_tac "xs1 @ x # ys1 = [] \<and> zs1 = ys")
  apply clarsimp
  apply (rule_tac xs="history i" and ys="[y]" in pre_suf_eq_distinct_list)
   apply auto
  done

lemma (in node_histories) prefix_of_ConsD [dest]:
  assumes "x # xs prefix of i"
    shows "[x] prefix of i"
  using assms by(auto simp: prefix_of_node_history_def)

lemma (in node_histories) prefix_of_appendD [dest]:
  assumes "xs @ ys prefix of i"
    shows "xs prefix of i"
  using assms by(auto simp: prefix_of_node_history_def)

lemma (in node_histories) prefix_distinct:
  assumes "xs prefix of i"
    shows "distinct xs"
  using assms by(clarsimp simp: prefix_of_node_history_def) (metis histories_distinct distinct_append)

lemma (in node_histories) prefix_to_carriers [intro]:
  assumes "xs prefix of i"
    shows "set xs \<subseteq> set (history i)"
  using assms by(clarsimp simp: prefix_of_node_history_def) (metis Un_iff set_append)

lemma (in node_histories) prefix_elem_to_carriers:
  assumes "xs prefix of i"
      and "x \<in> set xs"
    shows "x \<in> set (history i)"
  using assms by(clarsimp simp: prefix_of_node_history_def) (metis Un_iff set_append)

lemma (in node_histories) local_order_prefix_closed:
  assumes "x \<sqsubset>\<^sup>i y"
      and "xs prefix of i"
      and "y \<in> set xs"
    shows "x \<in> set xs"
proof -
  obtain ys where "xs @ ys = history i"
    using assms prefix_of_node_history_def by blast
  moreover obtain as bs cs where "as @ x # bs @ y # cs = history i"
    using assms history_order_def by blast
  moreover obtain pre suf where *: "xs = pre @ y # suf"
    using assms split_list by fastforce
  ultimately have "pre = as @ x # bs \<and> suf @ ys = cs"
    by (rule_tac xs="history i" and ys="[y]" in pre_suf_eq_distinct_list) auto
  thus ?thesis
    using assms * by clarsimp
qed

lemma (in node_histories) local_order_prefix_closed_last:
  assumes "x \<sqsubset>\<^sup>i y"
      and "xs@[y] prefix of i"
    shows "x \<in> set xs"
proof -
  have "x \<in> set (xs @ [y])"
    using assms by (force dest: local_order_prefix_closed)
  thus ?thesis
    using assms by(force simp add: node_total_order_irrefl prefix_to_carriers)
qed

lemma (in node_histories) events_before_exist:
  assumes "x \<in> set (history i)"
  shows "\<exists>pre. pre @ [x] prefix of i"
proof -
  have "\<exists>idx. idx < length (history i) \<and> (history i) ! idx = x"
    using assms by(simp add: set_elem_nth)
  thus ?thesis
    by(metis append_take_drop_id take_Suc_conv_app_nth prefix_of_node_history_def)
qed

lemma (in node_histories) events_in_local_order:
  assumes "pre @ [e2] prefix of i"
  and "e1 \<in> set pre"
  shows "e1 \<sqsubset>\<^sup>i e2"
  using assms split_list unfolding history_order_def prefix_of_node_history_def by fastforce

subsection\<open>Asynchronous broadcast networks\<close>

text\<open>We define a new locale $\isa{network}$ containing three axioms that define how broadcast
     and deliver events may interact, with these axioms defining the properties of our network model.\<close>

datatype 'msg event
  = Broadcast 'msg
  | Deliver 'msg

locale network = node_histories history for history :: "nat \<Rightarrow> 'msg event list" +
  fixes msg_id :: "'msg \<Rightarrow> 'msgid"
  (* Broadcast/Deliver interaction *)
  assumes delivery_has_a_cause: "\<lbrakk> Deliver m \<in> set (history i) \<rbrakk> \<Longrightarrow>
                                    \<exists>j. Broadcast m \<in> set (history j)"
      and deliver_locally: "\<lbrakk> Broadcast m \<in> set (history i) \<rbrakk> \<Longrightarrow>
                                    Broadcast m \<sqsubset>\<^sup>i Deliver m"
      and msg_id_unique: "\<lbrakk> Broadcast m1 \<in> set (history i);
                            Broadcast m2 \<in> set (history j);
                            msg_id m1 = msg_id m2 \<rbrakk> \<Longrightarrow> i = j \<and> m1 = m2"

text\<open>
The axioms can be understood as follows:
\begin{description}
    \item[delivery-has-a-cause:] If some message $\isa{m}$ was delivered at some node, then there exists some node on which $\isa{m}$ was broadcast.
        With this axiom, we assert that messages are not created ``out of thin air'' by the network itself, and that the only source of messages are the nodes.
    \item[deliver-locally:] If a node broadcasts some message $\isa{m}$, then the same node must subsequently also deliver $\isa{m}$ to itself.
        Since $\isa{m}$ does not actually travel over the network, this local delivery is always possible, even if the network is interrupted.
        Local delivery may seem redundant, since the effect of the delivery could also be implemented by the broadcast event itself; however, it is standard practice in the description of broadcast protocols that the sender of a message also sends it to itself, since this property simplifies the definition of algorithms built on top of the broadcast abstraction \<^cite>\<open>"Cachin:2011wt"\<close>.
    \item[msg-id-unique:] We do not assume that the message type $\isacharprime\isa{msg}$ has any particular structure; we only assume the existence of a function $\isa{msg-id} \mathbin{\isacharcolon\isacharcolon} \isacharprime\isa{msg} \mathbin{\isasymRightarrow} \isacharprime\isa{msgid}$ that maps every message to some globally unique identifier of type $\isacharprime\isa{msgid}$.
        We assert this uniqueness by stating that if $\isa{m1}$ and $\isa{m2}$ are any two messages broadcast by any two nodes, and their $\isa{msg-id}$s are the same, then they were in fact broadcast by the same node and the two messages are identical.
        In practice, these globally unique IDs can by implemented using unique node identifiers, sequence numbers or timestamps.
\end{description}
\<close>

lemma (in network) broadcast_before_delivery:
  assumes "Deliver m \<in> set (history i)"
  shows "\<exists>j. Broadcast m \<sqsubset>\<^sup>j Deliver m"
  using assms deliver_locally delivery_has_a_cause by blast

lemma (in network) broadcasts_unique:
  assumes "i \<noteq> j"
    and "Broadcast m \<in> set (history i)"
  shows "Broadcast m \<notin> set (history j)"
  using assms msg_id_unique by blast

text\<open>Based on the well-known definition by \<^cite>\<open>"Lamport:1978jq"\<close>, we say that
    $\isa{m1}\prec\isa{m2}$ if any of the following is true:
    \begin{enumerate}
      \item $\isa{m1}$ and $\isa{m2}$ were broadcast by the same node, and $\isa{m1}$ was broadcast before $\isa{m2}$.
      \item The node that broadcast $\isa{m2}$ had delivered $\isa{m1}$ before it broadcast $\isa{m2}$.
      \item There exists some operation $\isa{m3}$ such that $\isa{m1} \prec \isa{m3}$ and $\isa{m3} \prec \isa{m2}$.
    \end{enumerate}\<close>

inductive (in network) hb :: "'msg \<Rightarrow> 'msg \<Rightarrow> bool" where
  hb_broadcast: "\<lbrakk> Broadcast m1 \<sqsubset>\<^sup>i Broadcast m2 \<rbrakk> \<Longrightarrow> hb m1 m2" |
  hb_deliver:   "\<lbrakk> Deliver m1 \<sqsubset>\<^sup>i Broadcast m2 \<rbrakk> \<Longrightarrow> hb m1 m2" |
  hb_trans:     "\<lbrakk> hb m1 m2; hb m2 m3 \<rbrakk> \<Longrightarrow> hb m1 m3"

inductive_cases (in network) hb_elim: "hb x y"

definition (in network) weak_hb :: "'msg \<Rightarrow> 'msg \<Rightarrow> bool" where
  "weak_hb m1 m2 \<equiv> hb m1 m2 \<or> m1 = m2"

locale causal_network = network +
  assumes causal_delivery: "Deliver m2 \<in> set (history j) \<Longrightarrow> hb m1 m2 \<Longrightarrow> Deliver m1 \<sqsubset>\<^sup>j Deliver m2"

lemma (in causal_network) causal_broadcast:
  assumes "Deliver m2 \<in> set (history j)"
      and "Deliver m1 \<sqsubset>\<^sup>i Broadcast m2"
    shows "Deliver m1 \<sqsubset>\<^sup>j Deliver m2"
  using assms causal_delivery hb.intros(2) by blast

lemma (in network) hb_broadcast_exists1:
  assumes "hb m1 m2"
  shows "\<exists>i. Broadcast m1 \<in> set (history i)"
  using assms
  apply(induction rule: hb.induct)
    apply(meson insert_subset node_histories.local_order_carrier_closed node_histories_axioms)
   apply(meson delivery_has_a_cause insert_subset local_order_carrier_closed)
  apply simp
  done

lemma (in network) hb_broadcast_exists2:
  assumes "hb m1 m2"
  shows "\<exists>i. Broadcast m2 \<in> set (history i)"
  using assms
  apply(induction rule: hb.induct)
    apply(meson insert_subset node_histories.local_order_carrier_closed node_histories_axioms)
   apply(meson delivery_has_a_cause insert_subset local_order_carrier_closed)
  apply simp
  done

subsection\<open>Causal networks\<close>

lemma (in causal_network) hb_has_a_reason:
  assumes "hb m1 m2"
    and "Broadcast m2 \<in> set (history i)"
  shows "Deliver m1 \<in> set (history i) \<or> Broadcast m1 \<in> set (history i)"
  using assms apply (induction rule: hb.induct)
    apply(metis insert_subset local_order_carrier_closed network.broadcasts_unique network_axioms)
   apply(metis insert_subset local_order_carrier_closed network.broadcasts_unique network_axioms)
  using hb_trans causal_delivery local_order_carrier_closed apply blast
  done

lemma (in causal_network) hb_cross_node_delivery:
  assumes "hb m1 m2"
    and "Broadcast m1 \<in> set (history i)"
    and "Broadcast m2 \<in> set (history j)"
    and "i \<noteq> j"
  shows "Deliver m1 \<in> set (history j)"
  using assms
  apply(induction rule: hb.induct)
    apply(metis broadcasts_unique insert_subset local_order_carrier_closed)
   apply(metis insert_subset local_order_carrier_closed network.broadcasts_unique network_axioms)
  using broadcasts_unique hb.intros(3) hb_has_a_reason apply blast
  done

lemma (in causal_network) hb_irrefl:
  assumes "hb m1 m2"
  shows "m1 \<noteq> m2"
using assms proof(induction rule: hb.induct)
  case (hb_broadcast m1 i m2) thus ?case
    using node_total_order_antisym by blast
next
  case (hb_deliver m1 i m2) thus ?case
    by(meson causal_broadcast insert_subset local_order_carrier_closed node_total_order_irrefl)
next
  case (hb_trans m1 m2 m3)
  then obtain i j where "Broadcast m3 \<in> set (history i)" "Broadcast m2 \<in> set (history j)"
    using hb_broadcast_exists2 by blast
  then show ?case
    using assms hb_trans by (meson causal_network.causal_delivery causal_network_axioms
        deliver_locally insert_subset network.hb.intros(3) network_axioms
        node_histories.local_order_carrier_closed assms hb_trans
        node_histories_axioms node_total_order_irrefl)
qed

lemma (in causal_network) hb_broadcast_broadcast_order:
  assumes "hb m1 m2"
    and "Broadcast m1 \<in> set (history i)"
    and "Broadcast m2 \<in> set (history i)"
  shows "Broadcast m1 \<sqsubset>\<^sup>i Broadcast m2"
using assms proof(induction rule: hb.induct)
  case (hb_broadcast m1 i m2) thus ?case
    by(metis insertI1 local_order_carrier_closed network.broadcasts_unique network_axioms subsetCE)
next
  case (hb_deliver m1 i m2) thus ?case
    by(metis broadcasts_unique insert_subset local_order_carrier_closed
          network.broadcast_before_delivery network_axioms node_total_order_trans)
next
  case (hb_trans m1 m2 m3)
  then show ?case
  proof (cases "Broadcast m2 \<in> set (history i)")
    case True thus ?thesis
      using hb_trans node_total_order_trans by blast
  next
    case False hence "Deliver m2 \<in> set (history i)" "m1 \<noteq> m2" "m2 \<noteq> m3"
      using hb_has_a_reason hb_trans by auto
    thus ?thesis
      by(metis hb_trans event.inject(1) hb.intros(1) hb_irrefl network.hb.intros(3) network_axioms node_order_is_total hb_irrefl)
  qed
qed

lemma (in causal_network) hb_antisym:
  assumes "hb x y"
      and "hb y x"
  shows   "False"
using assms proof(induction rule: hb.induct)
  fix m1 i m2
  assume "hb m2 m1" and "Broadcast m1 \<sqsubset>\<^sup>i Broadcast m2"
  thus False
    apply - proof(erule hb_elim)
    show "\<And>ia. Broadcast m1 \<sqsubset>\<^sup>i Broadcast m2 \<Longrightarrow> Broadcast m2 \<sqsubset>\<^sup>ia Broadcast m1 \<Longrightarrow> False"
      by(metis broadcasts_unique insert_subset local_order_carrier_closed node_total_order_irrefl node_total_order_trans)
  next
    show "\<And>ia. Broadcast m1 \<sqsubset>\<^sup>i Broadcast m2 \<Longrightarrow> Deliver m2 \<sqsubset>\<^sup>ia Broadcast m1 \<Longrightarrow> False"
      by(metis broadcast_before_delivery broadcasts_unique insert_subset local_order_carrier_closed node_total_order_irrefl node_total_order_trans)
  next
    show "\<And>m2a. Broadcast m1 \<sqsubset>\<^sup>i Broadcast m2 \<Longrightarrow> hb m2 m2a \<Longrightarrow> hb m2a m1 \<Longrightarrow> False"
      using assms(1) assms(2) hb.intros(3) hb_irrefl by blast
  qed
next
  fix m1 i m2
  assume "hb m2 m1"
     and "Deliver m1 \<sqsubset>\<^sup>i Broadcast m2"
  thus "False"
    apply - proof(erule hb_elim)
    show "\<And>ia. Deliver m1 \<sqsubset>\<^sup>i Broadcast m2 \<Longrightarrow> Broadcast m2 \<sqsubset>\<^sup>ia Broadcast m1 \<Longrightarrow> False"
      by (metis broadcast_before_delivery broadcasts_unique insert_subset local_order_carrier_closed node_total_order_irrefl node_total_order_trans)
  next
    show "\<And>ia. Deliver m1 \<sqsubset>\<^sup>i Broadcast m2 \<Longrightarrow> Deliver m2 \<sqsubset>\<^sup>ia Broadcast m1 \<Longrightarrow> False"
      by (meson causal_network.causal_delivery causal_network_axioms hb.intros(2) hb.intros(3) insert_subset local_order_carrier_closed node_total_order_irrefl)
  next
    show "\<And>m2a. Deliver m1 \<sqsubset>\<^sup>i Broadcast m2 \<Longrightarrow> hb m2 m2a \<Longrightarrow> hb m2a m1 \<Longrightarrow> False"
      by (meson causal_delivery hb.intros(2) insert_subset local_order_carrier_closed network.hb.intros(3) network_axioms node_total_order_irrefl)
  qed
next
  fix m1 m2 m3
  assume "hb m1 m2" "hb m2 m3" "hb m3 m1"
     and "(hb m2 m1 \<Longrightarrow> False)" "(hb m3 m2 \<Longrightarrow> False)"
  thus "False"
    using hb.intros(3) by blast
qed

definition (in network) node_deliver_messages :: "'msg event list \<Rightarrow> 'msg list" where
  "node_deliver_messages cs \<equiv> List.map_filter (\<lambda>e. case e of Deliver m \<Rightarrow> Some m | _ \<Rightarrow> None) cs"

lemma (in network) node_deliver_messages_empty [simp]:
  shows "node_deliver_messages [] = []"
  by(auto simp add: node_deliver_messages_def List.map_filter_simps)

lemma (in network) node_deliver_messages_Cons:
  shows "node_deliver_messages (x#xs) = (node_deliver_messages [x])@(node_deliver_messages xs)"
  by(auto simp add: node_deliver_messages_def map_filter_def)

lemma (in network) node_deliver_messages_append:
  shows "node_deliver_messages (xs@ys) = (node_deliver_messages xs)@(node_deliver_messages ys)"
  by(auto simp add: node_deliver_messages_def map_filter_def)

lemma (in network) node_deliver_messages_Broadcast [simp]:
  shows "node_deliver_messages [Broadcast m] = []"
  by(clarsimp simp: node_deliver_messages_def map_filter_def)

lemma (in network) node_deliver_messages_Deliver [simp]:
  shows "node_deliver_messages [Deliver m] = [m]"
  by(clarsimp simp: node_deliver_messages_def map_filter_def)

lemma (in network) prefix_msg_in_history:
  assumes "es prefix of i"
      and "m \<in> set (node_deliver_messages es)"
    shows "Deliver m \<in> set (history i)"
using assms prefix_to_carriers by(fastforce simp: node_deliver_messages_def map_filter_def split: event.split_asm)

lemma (in network) prefix_contains_msg:
  assumes "es prefix of i"
      and "m \<in> set (node_deliver_messages es)"
    shows "Deliver m \<in> set es"
  using assms by(auto simp: node_deliver_messages_def map_filter_def split: event.split_asm)

lemma (in network) node_deliver_messages_distinct:
  assumes "xs prefix of i"
  shows "distinct (node_deliver_messages xs)"
using assms proof(induction xs rule: rev_induct)
  case Nil thus ?case by simp
next
  case (snoc x xs)
  { fix y assume *: "y \<in> set (node_deliver_messages xs)" "y \<in> set (node_deliver_messages [x])"
    moreover have "distinct (xs @ [x])"
      using assms snoc prefix_distinct by blast
    ultimately have "False"
      using assms apply(case_tac x; clarsimp simp add: map_filter_def node_deliver_messages_def)
      using * prefix_contains_msg snoc.prems by blast
  } thus ?case
    using snoc by(fastforce simp add: node_deliver_messages_append node_deliver_messages_def map_filter_def)
qed

lemma (in network) drop_last_message:
  assumes "evts prefix of i"
  and "node_deliver_messages evts = msgs @ [last_msg]"
  shows "\<exists>pre. pre prefix of i \<and> node_deliver_messages pre = msgs"
proof -
  have "Deliver last_msg \<in> set evts"
    using assms network.prefix_contains_msg network_axioms by force
  then obtain idx where *: "idx < length evts" "evts ! idx = Deliver last_msg"
    by (meson set_elem_nth)
  then obtain pre suf where "evts = pre @ (evts ! idx) # suf"
    using id_take_nth_drop by blast
  hence **: "evts = pre @ (Deliver last_msg) # suf"
    using assms * by auto
  moreover hence "distinct (node_deliver_messages ([Deliver last_msg] @ suf))"
    by (metis assms(1) assms(2) distinct_singleton node_deliver_messages_Cons node_deliver_messages_Deliver
        node_deliver_messages_append node_deliver_messages_distinct not_Cons_self2 pre_suf_eq_distinct_list)
  ultimately have "node_deliver_messages ([Deliver last_msg] @ suf) = [last_msg] @ []"
    by (metis append_self_conv assms(1) assms(2) node_deliver_messages_Cons node_deliver_messages_Deliver
        node_deliver_messages_append node_deliver_messages_distinct not_Cons_self2 pre_suf_eq_distinct_list)
  thus ?thesis
    using assms * ** by (metis append1_eq_conv append_Cons append_Nil node_deliver_messages_append prefix_of_appendD)
qed

locale network_with_ops = causal_network history fst
  for history :: "nat \<Rightarrow> ('msgid \<times> 'op) event list" +
  fixes interp :: "'op \<Rightarrow> 'state \<rightharpoonup> 'state"
  and initial_state :: "'state"

context network_with_ops begin

definition interp_msg :: "'msgid \<times> 'op \<Rightarrow> 'state \<rightharpoonup> 'state" where
  "interp_msg msg state \<equiv> interp (snd msg) state"

sublocale hb: happens_before weak_hb hb interp_msg
proof
  fix x y :: "'msgid \<times> 'op"
  show "hb x y = (weak_hb x y \<and> \<not> weak_hb y x)"
    unfolding weak_hb_def using hb_antisym by blast
next
  fix x
  show "weak_hb x x"
    using weak_hb_def by blast
next
  fix x y z
  assume "weak_hb x y" "weak_hb y z"
  thus "weak_hb x z"
    using weak_hb_def by (metis network.hb.intros(3) network_axioms)
qed

end

definition (in network_with_ops) apply_operations :: "('msgid \<times> 'op) event list \<rightharpoonup> 'state" where
  "apply_operations es \<equiv> hb.apply_operations (node_deliver_messages es) initial_state"

definition (in network_with_ops) node_deliver_ops :: "('msgid \<times> 'op) event list \<Rightarrow> 'op list" where
  "node_deliver_ops cs \<equiv> map snd (node_deliver_messages cs)"

lemma (in network_with_ops) apply_operations_empty [simp]:
  shows "apply_operations [] = Some initial_state"
  by(auto simp add: apply_operations_def)

lemma (in network_with_ops) apply_operations_Broadcast [simp]:
  shows "apply_operations (xs @ [Broadcast m]) = apply_operations xs"
  by(auto simp add: apply_operations_def node_deliver_messages_def map_filter_def)

lemma (in network_with_ops) apply_operations_Deliver [simp]:
  shows "apply_operations (xs @ [Deliver m]) = (apply_operations xs \<bind> interp_msg m)"
  by(auto simp add: apply_operations_def node_deliver_messages_def map_filter_def kleisli_def)

lemma (in network_with_ops) hb_consistent_technical:
  assumes "\<And>m n. m < length cs \<Longrightarrow> n < m \<Longrightarrow> cs ! n \<sqsubset>\<^sup>i cs ! m"
  shows   "hb.hb_consistent (node_deliver_messages cs)"
using assms proof (induction cs rule: rev_induct)
  case Nil thus ?case
   by(simp add: node_deliver_messages_def hb.hb_consistent.intros(1) map_filter_simps(2))
next
  case (snoc x xs)
  hence *: "(\<And>m n. m < length xs \<Longrightarrow> n < m \<Longrightarrow> xs ! n \<sqsubset>\<^sup>i xs ! m)"
    by(-, erule_tac x=m in meta_allE, erule_tac x=n in meta_allE, clarsimp simp add: nth_append)
  then show ?case
  proof (cases x)
    case (Broadcast x1) thus ?thesis
      using snoc * by (simp add: node_deliver_messages_append)
  next
    case (Deliver x2) thus ?thesis
      using snoc * [[simproc del: defined_all]]
      apply (clarsimp simp add: node_deliver_messages_def map_filter_def map_filter_append)
      apply (rename_tac m m1 m2)
      apply (case_tac m; clarsimp)
      apply (drule set_elem_nth, erule exE, erule conjE)
      apply (erule_tac x="length xs" in meta_allE)
      apply (clarsimp simp add: nth_append)
      apply (metis causal_delivery insert_subset local_order_carrier_closed
        node_total_order_antisym)
      done
 qed
qed

corollary (in network_with_ops)
  shows "hb.hb_consistent (node_deliver_messages (history i))"
  by (metis hb_consistent_technical history_order_def less_one linorder_neqE_nat list_nth_split zero_order(3))

lemma (in network_with_ops) hb_consistent_prefix:
  assumes "xs prefix of i"
  shows "hb.hb_consistent (node_deliver_messages xs)"
using assms proof (clarsimp simp: prefix_of_node_history_def, rule_tac i=i in hb_consistent_technical)
  fix m n ys assume *: "xs @ ys = history i" "m < length xs" "n < m"
  consider (a) "xs = []" | (b) "\<exists>c. xs = [c]" | (c) "Suc 0 < length (xs)"
    by (metis Suc_pred length_Suc_conv length_greater_0_conv zero_less_diff)
  thus "xs ! n \<sqsubset>\<^sup>i xs ! m"
  proof (cases)
    case a thus ?thesis
      using * by clarsimp
  next
    case b thus ?thesis
      using assms * by clarsimp
  next
    case c thus ?thesis
      using assms * apply clarsimp
      apply(drule list_nth_split, assumption, clarsimp simp: c)
      apply (metis append.assoc append.simps(2) history_order_def)
      done
  qed
qed

locale network_with_constrained_ops = network_with_ops +
  fixes valid_msg :: "'c \<Rightarrow> ('a \<times> 'b) \<Rightarrow> bool"
  assumes broadcast_only_valid_msgs: "pre @ [Broadcast m] prefix of i \<Longrightarrow>
             \<exists>state. apply_operations pre = Some state \<and> valid_msg state m"

lemma (in network_with_constrained_ops) broadcast_is_valid:
  assumes "Broadcast m \<in> set (history i)"
  shows "\<exists>state. valid_msg state m"
  using assms broadcast_only_valid_msgs events_before_exist by blast

lemma (in network_with_constrained_ops) deliver_is_valid:
  assumes "Deliver m \<in> set (history i)"
  shows "\<exists>j pre state. pre @ [Broadcast m] prefix of j \<and> apply_operations pre = Some state \<and> valid_msg state m"
  using assms apply (clarsimp dest!: delivery_has_a_cause)
  using broadcast_only_valid_msgs events_before_exist apply blast
  done

lemma (in network_with_constrained_ops) deliver_in_prefix_is_valid:
  assumes "xs prefix of i"
      and "Deliver m \<in> set xs"
    shows "\<exists>state. valid_msg state m"
  by (meson assms network_with_constrained_ops.deliver_is_valid network_with_constrained_ops_axioms prefix_elem_to_carriers)

subsection\<open>Dummy network models\<close>

interpretation trivial_node_histories: node_histories "\<lambda>m. []"
  by standard auto

interpretation trivial_network: network "\<lambda>m. []" id
  by standard auto

interpretation trivial_causal_network: causal_network "\<lambda>m. []" id
  by standard auto

interpretation trivial_network_with_ops: network_with_ops "\<lambda>m. []" "(\<lambda>x y. Some y)" 0
  by standard auto

interpretation trivial_network_with_constrained_ops: network_with_constrained_ops "\<lambda>m. []" "(\<lambda>x y. Some y)" 0 "\<lambda>x y. True"
  by standard (simp add: trivial_node_histories.prefix_of_node_history_def)

end


(*  Title:      HOL/SPARK/Examples/RIPEMD-160/RMD_Lemmas.thy
    Author:     Fabian Immler, TU Muenchen

Verification of the RIPEMD-160 hash function
*)

theory RMD_Lemmas
imports Main
begin

definition "fun_of_list i xs g j =
  (if j < i \<or> i + int (length xs) \<le> j then g j else xs ! nat (j - i))"

lemma fun_of_list_Nil [simp]: "fun_of_list i [] g = g"
  by (auto simp add: fun_eq_iff fun_of_list_def)

lemma fun_of_list_Cons [simp]:
  "fun_of_list i (x # xs) g = fun_of_list (i + 1) xs (g(i:=x))"
  by (auto simp add: fun_eq_iff fun_of_list_def nth_Cons'
    nat_diff_distrib [of "int (Suc 0)", simplified, symmetric]
    diff_diff_eq)

lemma nth_fun_of_list_eq:
  "0 \<le> i \<Longrightarrow> i < int (length xs) \<Longrightarrow> xs ! nat i = fun_of_list 0 xs g i"
  by (simp add: fun_of_list_def)

end


(*  Title:      Containers/RBT_Mapping2.thy
    Author:     Andreas Lochbihler, KIT *)

theory RBT_Mapping2
imports
  Collection_Order
  RBT_ext
begin

section {* Mappings implemented by red-black trees *}

lemma distinct_map_filterI: "distinct (map f xs) \<Longrightarrow> distinct (map f (filter P xs))"
by(induct xs) auto

lemma map_of_filter_apply:
  "distinct (map fst xs)
  \<Longrightarrow> map_of (filter P xs) k =
  (case map_of xs k of None \<Rightarrow> None | Some v \<Rightarrow> if P (k, v) then Some v else None)"
by(induct xs)(auto simp add: map_of_eq_None_iff split: option.split)

subsection {* Type definition *}

typedef ('a, 'b) mapping_rbt
  = "{t :: ('a :: corder, 'b) RBT_Impl.rbt. ord.is_rbt cless t \<or> ID CORDER('a) = None}"
  morphisms impl_of Mapping_RBT'
proof
  show "RBT_Impl.Empty \<in> ?mapping_rbt" by(simp add: ord.Empty_is_rbt)
qed

definition Mapping_RBT :: "('a :: corder, 'b) rbt \<Rightarrow> ('a, 'b) mapping_rbt"
where
  "Mapping_RBT t = Mapping_RBT'
  (if ord.is_rbt cless t \<or> ID CORDER('a) = None then t
   else RBT_Impl.fold (ord.rbt_insert cless) t rbt.Empty)"

lemma Mapping_RBT_inverse:
  fixes y :: "('a :: corder, 'b) rbt"
  assumes "y \<in> {t. ord.is_rbt cless t \<or> ID CORDER('a) = None}"
  shows "impl_of (Mapping_RBT y) = y"
using assms by(auto simp add: Mapping_RBT_def Mapping_RBT'_inverse)

lemma impl_of_inverse: "Mapping_RBT (impl_of t) = t"
by(cases t)(auto simp add: Mapping_RBT'_inverse Mapping_RBT_def)

lemma type_definition_mapping_rbt':
  "type_definition impl_of Mapping_RBT
    {t :: ('a, 'b) rbt. ord.is_rbt cless t \<or> ID CORDER('a :: corder) = None}"
by unfold_locales(rule mapping_rbt.impl_of impl_of_inverse Mapping_RBT_inverse)+

lemmas Mapping_RBT_cases[cases type: mapping_rbt] =
  type_definition.Abs_cases[OF type_definition_mapping_rbt']
  and Mapping_RBT_induct[induct type: mapping_rbt] =
  type_definition.Abs_induct[OF type_definition_mapping_rbt'] and
  Mapping_RBT_inject = type_definition.Abs_inject[OF type_definition_mapping_rbt']

lemma rbt_eq_iff:
  "t1 = t2 \<longleftrightarrow> impl_of t1 = impl_of t2"
  by (simp add: impl_of_inject)

lemma rbt_eqI:
  "impl_of t1 = impl_of t2 \<Longrightarrow> t1 = t2"
  by (simp add: rbt_eq_iff)

lemma Mapping_RBT_impl_of [simp]:
  "Mapping_RBT (impl_of t) = t"
  by (simp add: impl_of_inverse)

subsection {* Operations *}

setup_lifting type_definition_mapping_rbt'

context fixes dummy :: "'a :: corder" begin

lift_definition lookup :: "('a, 'b) mapping_rbt \<Rightarrow> 'a \<rightharpoonup> 'b" is "ord.rbt_lookup cless" .

lift_definition empty :: "('a, 'b) mapping_rbt" is "RBT_Impl.Empty"
by(simp add: ord.Empty_is_rbt)

lift_definition insert :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> ('a, 'b) mapping_rbt" is
  "ord.rbt_insert cless"
by(auto 4 3 intro: linorder.rbt_insert_is_rbt ID_corder)

lift_definition delete :: "'a \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> ('a, 'b) mapping_rbt" is
  "ord.rbt_delete cless"
by(auto 4 3 intro: linorder.rbt_delete_is_rbt ID_corder)

lift_definition bulkload :: "('a \<times> 'b) list \<Rightarrow> ('a, 'b) mapping_rbt" is
  "ord.rbt_bulkload cless"
by(auto 4 3 intro: linorder.rbt_bulkload_is_rbt ID_corder)

lift_definition map_entry :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> ('a, 'b) mapping_rbt" is
  "ord.rbt_map_entry cless"
by(simp add: ord.rbt_map_entry_is_rbt)

lift_definition map :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> ('a, 'c) mapping_rbt" is "RBT_Impl.map"
by(simp add: ord.map_is_rbt)

lift_definition entries :: "('a, 'b) mapping_rbt \<Rightarrow> ('a \<times> 'b) list" is "RBT_Impl.entries" .

lift_definition keys :: "('a, 'b) mapping_rbt \<Rightarrow> 'a set" is "set \<circ> RBT_Impl.keys" .

lift_definition fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> 'c \<Rightarrow> 'c" is "RBT_Impl.fold" .

lift_definition is_empty :: "('a, 'b) mapping_rbt \<Rightarrow> bool" is "case_rbt True (\<lambda>_ _ _ _ _. False)" .

lift_definition filter :: "('a \<times> 'b \<Rightarrow> bool) \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> ('a, 'b) mapping_rbt" is
  "\<lambda>P t. rbtreeify (List.filter P (RBT_Impl.entries t))"
by(auto intro!: linorder.is_rbt_rbtreeify ID_corder linorder.sorted_filter linorder.rbt_sorted_entries ord.is_rbt_rbt_sorted linorder.distinct_entries distinct_map_filterI simp add: filter_map[symmetric])

lift_definition join ::
  "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> ('a, 'b) mapping_rbt"
is "ord.rbt_union_with_key cless"
by(auto 4 3 intro: linorder.is_rbt_rbt_unionwk ID_corder)

lift_definition meet ::
  "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> ('a, 'b) mapping_rbt"
is "ord.rbt_inter_with_key cless"
by(auto 4 3 intro: linorder.rbt_interwk_is_rbt ID_corder ord.is_rbt_rbt_sorted)

lift_definition all :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> bool"
is "RBT_Impl_rbt_all" .

lift_definition ex :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> bool"
is "RBT_Impl_rbt_ex" .

lift_definition product ::
  "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> 'e) \<Rightarrow> ('a, 'b) mapping_rbt
  \<Rightarrow> ('c :: corder, 'd) mapping_rbt \<Rightarrow> ('a \<times> 'c, 'e) mapping_rbt"
is "rbt_product"
by(fastforce intro: is_rbt_rbt_product ID_corder simp add: corder_prod_def ID_Some ID_None split: option.split_asm)

lift_definition diag ::
  "('a, 'b) mapping_rbt \<Rightarrow> ('a \<times> 'a, 'b) mapping_rbt"
is "RBT_Impl_diag"
by(auto simp add: corder_prod_def ID_Some ID_None is_rbt_RBT_Impl_diag split: option.split_asm)

lift_definition init :: "('a, 'b) mapping_rbt \<Rightarrow> ('a, 'b, 'c) rbt_generator_state"
is "rbt_init" .

end

subsection {* Properties *}

lemma unfoldr_rbt_entries_generator:
  "list.unfoldr rbt_entries_generator (init t) = entries t"
  by transfer(simp add: unfoldr_rbt_entries_generator)

lemma lookup_RBT:
  "ord.is_rbt cless t \<Longrightarrow>
  lookup (Mapping_RBT t) = ord.rbt_lookup cless t"
by(simp add: lookup_def Mapping_RBT_inverse)

lemma lookup_impl_of:
  "ord.rbt_lookup cless (impl_of t) = lookup t"
by(transfer) simp

lemma entries_impl_of:
  "RBT_Impl.entries (impl_of t) = entries t"
by transfer simp

lemma keys_impl_of:
  "set (RBT_Impl.keys (impl_of t)) = keys t"
  by (simp add: keys_def)

lemma lookup_empty [simp]:
  "lookup empty = Map.empty"
by transfer (simp add: fun_eq_iff ord.rbt_lookup.simps)

lemma fold_conv_fold:
  "fold f t = List.fold (case_prod f) (entries t)"
by transfer(simp add: RBT_Impl.fold_def)

lemma is_empty_empty [simp]:
  "is_empty t \<longleftrightarrow> t = empty"
by transfer (simp split: rbt.split)

context assumes ID_corder_neq_None: "ID CORDER('a :: corder) \<noteq> None"
begin

lemma mapping_linorder: "class.linorder (cless_eq :: 'a \<Rightarrow> 'a \<Rightarrow> bool) cless"
using ID_corder_neq_None by(clarsimp)(rule ID_corder)

lemma lookup_insert [simp]:
  "lookup (insert (k :: 'a) v t) = (lookup t)(k \<mapsto> v)"
by transfer(simp add: ID_corder_neq_None linorder.rbt_lookup_rbt_insert[OF mapping_linorder])

lemma lookup_delete [simp]:
  "lookup (delete (k :: 'a) t) = (lookup t)(k := None)"
by transfer(simp add: ID_corder_neq_None linorder.rbt_lookup_rbt_delete[OF mapping_linorder] restrict_complement_singleton_eq)

lemma map_of_entries [simp]:
  "map_of (entries (t :: ('a, 'b) mapping_rbt)) = lookup t"
by transfer(simp add: ID_corder_neq_None linorder.map_of_entries[OF mapping_linorder] ord.is_rbt_rbt_sorted)

lemma entries_lookup:
  "entries (t1 :: ('a, 'b) mapping_rbt) = entries t2 \<longleftrightarrow> lookup t1 = lookup t2"
by transfer(simp add: ID_corder_neq_None linorder.entries_rbt_lookup[OF mapping_linorder] ord.is_rbt_rbt_sorted)

lemma lookup_bulkload [simp]:
  "lookup (bulkload xs) = map_of (xs :: ('a \<times> 'b) list)"
by transfer(simp add: linorder.rbt_lookup_rbt_bulkload[OF mapping_linorder])

lemma lookup_map_entry [simp]:
  "lookup (map_entry (k :: 'a) f t) = (lookup t)(k := map_option f (lookup t k))"
by transfer(simp add: ID_corder_neq_None linorder.rbt_lookup_rbt_map_entry[OF mapping_linorder])

lemma lookup_map [simp]:
  "lookup (map f t) (k :: 'a) = map_option (f k) (lookup t k)"
by transfer(simp add: linorder.rbt_lookup_map[OF mapping_linorder])

lemma RBT_lookup_empty [simp]:
  "ord.rbt_lookup cless (t :: ('a, 'b) RBT_Impl.rbt) = Map.empty \<longleftrightarrow> t = RBT_Impl.Empty"
proof -
  interpret linorder "cless_eq :: 'a \<Rightarrow> 'a \<Rightarrow> bool" cless by(rule mapping_linorder)
  show ?thesis by(cases t)(auto simp add: fun_eq_iff)
qed

lemma lookup_empty_empty [simp]:
  "lookup t = Map.empty \<longleftrightarrow> (t :: ('a, 'b) mapping_rbt) = empty"
by transfer simp

lemma finite_dom_lookup [simp]: "finite (dom (lookup (t :: ('a, 'b) mapping_rbt)))"
by transfer(auto simp add: linorder.finite_dom_rbt_lookup[OF mapping_linorder])

lemma card_com_lookup [unfolded length_map, simp]:
  "card (dom (lookup (t :: ('a, 'b) mapping_rbt))) = length (List.map fst (entries t))"
by transfer(auto simp add: linorder.rbt_lookup_keys[OF mapping_linorder] linorder.distinct_entries[OF mapping_linorder] RBT_Impl.keys_def ord.is_rbt_rbt_sorted ID_corder_neq_None List.card_set simp del: set_map length_map)

lemma lookup_join:
  "lookup (join f (t1 :: ('a, 'b) mapping_rbt) t2) =
  (\<lambda>k. case lookup t1 k of None \<Rightarrow> lookup t2 k | Some v1 \<Rightarrow> Some (case lookup t2 k of None \<Rightarrow> v1 | Some v2 \<Rightarrow> f k v1 v2))"
by transfer(auto simp add: fun_eq_iff linorder.rbt_lookup_rbt_unionwk[OF mapping_linorder] ord.is_rbt_rbt_sorted ID_corder_neq_None split: option.splits)

lemma lookup_meet:
  "lookup (meet f (t1 :: ('a, 'b) mapping_rbt) t2) =
  (\<lambda>k. case lookup t1 k of None \<Rightarrow> None | Some v1 \<Rightarrow> case lookup t2 k of None \<Rightarrow> None | Some v2 \<Rightarrow> Some (f k v1 v2))"
by transfer(auto simp add: fun_eq_iff linorder.rbt_lookup_rbt_interwk[OF mapping_linorder] ord.is_rbt_rbt_sorted ID_corder_neq_None split: option.splits)

lemma lookup_filter [simp]:
  "lookup (filter P (t :: ('a, 'b) mapping_rbt)) k =
  (case lookup t k of None \<Rightarrow> None | Some v \<Rightarrow> if P (k, v) then Some v else None)"
by transfer(simp split: option.split add: ID_corder_neq_None linorder.rbt_lookup_rbtreeify[OF mapping_linorder] linorder.sorted_filter[OF mapping_linorder] ord.is_rbt_rbt_sorted linorder.rbt_sorted_entries[OF mapping_linorder] distinct_map_filterI linorder.distinct_entries[OF mapping_linorder] map_of_filter_apply linorder.map_of_entries[OF mapping_linorder])

lemma all_conv_all_lookup:
  "all P t \<longleftrightarrow> (\<forall>(k :: 'a) v. lookup t k = Some v \<longrightarrow> P k v)"
by transfer(auto simp add: ID_corder_neq_None linorder.rbt_lookup_keys[OF mapping_linorder] ord.is_rbt_rbt_sorted RBT_Impl.keys_def RBT_Impl_rbt_all_def linorder.map_of_entries[OF mapping_linorder, symmetric] linorder.distinct_entries[OF mapping_linorder] dest: map_of_is_SomeD intro: map_of_is_SomeI)

lemma ex_conv_ex_lookup:
  "ex P t \<longleftrightarrow> (\<exists>(k :: 'a) v. lookup t k = Some v \<and> P k v)"
by transfer(auto simp add: ID_corder_neq_None linorder.rbt_lookup_keys[OF mapping_linorder] ord.is_rbt_rbt_sorted RBT_Impl.keys_def RBT_Impl_rbt_ex_def linorder.map_of_entries[OF mapping_linorder, symmetric] linorder.distinct_entries[OF mapping_linorder] intro: map_of_is_SomeI)

lemma diag_lookup:
  "lookup (diag t) = (\<lambda>(k :: 'a, k'). if k = k' then lookup t k else None)"
using linorder.rbt_lookup_RBT_Impl_diag[where ?'b='b, OF mapping_linorder]
by transfer(clarsimp simp add: ID_corder_neq_None corder_prod_def ID_Some split: option.split)

context assumes ID_corder_neq_None': "ID CORDER('b :: corder) \<noteq> None"
begin

lemma mapping_linorder': "class.linorder (cless_eq :: 'b \<Rightarrow> 'b \<Rightarrow> bool) cless"
using ID_corder_neq_None' by(clarsimp)(rule ID_corder)

lemma cless_prod_eq_less_prod:
  "cless = (less_prod cless_eq cless cless :: 'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool)"
by(simp add: corder_prod_def ID_corder_neq_None ID_corder_neq_None' ID_Some split: option.splits)

lemma lookup_product:
  "lookup (product f rbt1 rbt2) (a :: 'a, b :: 'b) =
  (case lookup rbt1 a of None \<Rightarrow> None
   | Some c \<Rightarrow> map_option (f a c b) (lookup rbt2 b))"
using mapping_linorder mapping_linorder'
by transfer(simp add: cless_prod_eq_less_prod ID_corder_neq_None ID_corder_neq_None' rbt_lookup_rbt_product)

end

end

hide_const (open) impl_of lookup empty insert delete
  entries keys bulkload map_entry map fold join meet filter all ex product diag init

end


(*<*)
theory TAO_98_ArtificialTheorems
imports TAO_7_Axioms
begin
(*>*)

section\<open>Artificial Theorems\<close>
text\<open>\label{TAO_ArtificialTheorems}\<close>

text\<open>
\begin{remark}
  Some examples of theorems that can be derived from the model structure, but which
  are not derivable from the deductive system PLM itself.
\end{remark}
\<close>

locale ArtificialTheorems
begin

  lemma lambda_enc_1:
    "[\<lparr>\<^bold>\<lambda>x . \<lbrace>x\<^sup>P, F\<rbrace> \<^bold>\<equiv> \<lbrace>x\<^sup>P, F\<rbrace>, y\<^sup>P\<rparr> in v]"
    by (auto simp: meta_defs meta_aux conn_defs forall_\<Pi>\<^sub>1_def)

  lemma lambda_enc_2:
    "[\<lparr>\<^bold>\<lambda> x . \<lbrace>y\<^sup>P, G\<rbrace>, x\<^sup>P\<rparr> \<^bold>\<equiv> \<lbrace>y\<^sup>P, G\<rbrace> in v]"
    by (auto simp: meta_defs meta_aux conn_defs forall_\<Pi>\<^sub>1_def)

text\<open>
\begin{remark}
  The following is \emph{not} a theorem and nitpick can
  find a countermodel. This is expected and important.
  If this were a theorem, the theory would become inconsistent.
\end{remark}
\<close>

  lemma lambda_enc_3:
    "[(\<lparr>\<^bold>\<lambda> x . \<lbrace>x\<^sup>P, F\<rbrace>, x\<^sup>P\<rparr> \<^bold>\<rightarrow> \<lbrace>x\<^sup>P, F\<rbrace>) in v]"
    apply (simp add: meta_defs meta_aux conn_defs forall_\<Pi>\<^sub>1_def)
    nitpick[user_axioms, expect=genuine]
    oops \<comment> \<open>countermodel by nitpick\<close>

text\<open>
\begin{remark}
  Instead the following two statements hold.
\end{remark}
\<close>

  lemma lambda_enc_4:
    "[\<lparr>(\<^bold>\<lambda> x . \<lbrace>x\<^sup>P, F\<rbrace>), x\<^sup>P\<rparr> in v] = (\<exists> y . \<nu>\<upsilon> y = \<nu>\<upsilon> x \<and> [\<lbrace>y\<^sup>P, F\<rbrace> in v])"
    by (simp add: meta_defs meta_aux)

  lemma lambda_ex:
    "[\<lparr>(\<^bold>\<lambda> x . \<phi> (x\<^sup>P)), x\<^sup>P\<rparr> in v] = (\<exists> y . \<nu>\<upsilon> y = \<nu>\<upsilon> x \<and> [\<phi> (y\<^sup>P) in v])"
    by (simp add: meta_defs meta_aux)

text\<open>
\begin{remark}
  These statements can be translated to statements in the embedded logic.
\end{remark}
\<close>

  lemma lambda_ex_emb:
    "[\<lparr>(\<^bold>\<lambda> x . \<phi> (x\<^sup>P)), x\<^sup>P\<rparr> \<^bold>\<equiv> (\<^bold>\<exists> y . (\<^bold>\<forall> F . \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr>) \<^bold>& \<phi> (y\<^sup>P)) in v]"
    proof(rule MetaSolver.EquivI)
      interpret MetaSolver .
      {
        assume "[\<lparr>(\<^bold>\<lambda> x . \<phi> (x\<^sup>P)), x\<^sup>P\<rparr> in v]"
        then obtain y where "\<nu>\<upsilon> y = \<nu>\<upsilon> x \<and> [\<phi> (y\<^sup>P) in v]"
          using lambda_ex by blast
        moreover hence "[(\<^bold>\<forall> F . \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr>) in v]"
          apply - apply meta_solver
          by (simp add: Semantics.d\<^sub>\<kappa>_proper Semantics.ex1_def)
        ultimately have "[\<^bold>\<exists> y . (\<^bold>\<forall> F . \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr>) \<^bold>& \<phi> (y\<^sup>P) in v]"
          using ExIRule ConjI by fast
      }
      moreover {
        assume "[\<^bold>\<exists> y . (\<^bold>\<forall> F . \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr>) \<^bold>& \<phi> (y\<^sup>P) in v]"
        then obtain y where y_def: "[(\<^bold>\<forall> F . \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr>) \<^bold>& \<phi> (y\<^sup>P) in v]"
          by (rule ExERule)
        hence "\<And> F . [\<lparr>F,x\<^sup>P\<rparr> in v] = [\<lparr>F,y\<^sup>P\<rparr> in v]"
          apply - apply (drule ConjE) apply (drule conjunct1)
          apply (drule AllE) apply (drule EquivE) by simp
        hence "[\<lparr>make\<Pi>\<^sub>1 (\<lambda> u s w . \<nu>\<upsilon> y = u),x\<^sup>P\<rparr> in v]
             = [\<lparr>make\<Pi>\<^sub>1 (\<lambda> u s w . \<nu>\<upsilon> y = u),y\<^sup>P\<rparr> in v]" by auto
        hence "\<nu>\<upsilon> y = \<nu>\<upsilon> x" by (simp add: meta_defs meta_aux)
        moreover have "[\<phi> (y\<^sup>P) in v]" using y_def ConjE by blast
        ultimately have "[\<lparr>(\<^bold>\<lambda> x . \<phi> (x\<^sup>P)), x\<^sup>P\<rparr> in v]"
          using lambda_ex by blast
      }
      ultimately show "[\<lparr>\<^bold>\<lambda>x. \<phi> (x\<^sup>P),x\<^sup>P\<rparr> in v]
          = [\<^bold>\<exists>y. (\<^bold>\<forall>F. \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr>) \<^bold>& \<phi> (y\<^sup>P) in v]"
        by auto
    qed

  lemma lambda_enc_emb:
    "[\<lparr>(\<^bold>\<lambda> x . \<lbrace>x\<^sup>P, F\<rbrace>), x\<^sup>P\<rparr> \<^bold>\<equiv> (\<^bold>\<exists> y . (\<^bold>\<forall> F . \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr>) \<^bold>& \<lbrace>y\<^sup>P, F\<rbrace>) in v]"
    using lambda_ex_emb by fast

text\<open>
\begin{remark}
  In the case of proper maps, the generalized \<open>\<beta>\<close>-conversion reduces to
  classical \<open>\<beta>\<close>-conversion.
\end{remark}
\<close>

  lemma proper_beta:
    assumes "IsProperInX \<phi>"
    shows "[(\<^bold>\<exists> y . (\<^bold>\<forall> F . \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr>) \<^bold>& \<phi> (y\<^sup>P)) \<^bold>\<equiv> \<phi> (x\<^sup>P) in v]"
  proof (rule MetaSolver.EquivI; rule)
    interpret MetaSolver .
    assume "[\<^bold>\<exists>y. (\<^bold>\<forall>F. \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr>) \<^bold>& \<phi> (y\<^sup>P) in v]"
    then obtain y where y_def: "[(\<^bold>\<forall>F. \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr>) \<^bold>& \<phi> (y\<^sup>P) in v]" by (rule ExERule)
    hence "[\<lparr>make\<Pi>\<^sub>1 (\<lambda> u s w . \<nu>\<upsilon> y = u), x\<^sup>P\<rparr> in v] = [\<lparr>make\<Pi>\<^sub>1 (\<lambda> u s w . \<nu>\<upsilon> y = u), y\<^sup>P\<rparr> in v]"
      using EquivS AllE ConjE by blast
    hence "\<nu>\<upsilon> y = \<nu>\<upsilon> x" by (simp add: meta_defs meta_aux)
    thus "[\<phi> (x\<^sup>P) in v]"
      using y_def[THEN ConjE[THEN conjunct2]]
            assms IsProperInX.rep_eq valid_in.rep_eq
      by blast
  next
    interpret MetaSolver .
    assume "[\<phi> (x\<^sup>P) in v]"
    moreover have "[\<^bold>\<forall>F. \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,x\<^sup>P\<rparr> in v]" apply meta_solver by blast
    ultimately show "[\<^bold>\<exists>y. (\<^bold>\<forall>F. \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr>) \<^bold>& \<phi> (y\<^sup>P) in v]"
      by (meson ConjI ExI)
  qed

text\<open>
\begin{remark}
  The following theorem is a consequence of the constructed Aczel-model, but not
  part of PLM. Separate research on possible modifications of the embedding suggest
  that this artificial theorem can be avoided by introducing a dependency on states
  for the mapping from abstract objects to special urelements.
\end{remark}
\<close>

  lemma lambda_rel_extensional:
    assumes "[\<^bold>\<forall>F . \<lparr>F,a\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,b\<^sup>P\<rparr> in v]"
    shows "(\<^bold>\<lambda>x. \<lparr>R,x\<^sup>P,a\<^sup>P\<rparr>) = (\<^bold>\<lambda>x . \<lparr>R,x\<^sup>P, b\<^sup>P\<rparr>)"
  proof -
    interpret MetaSolver .
    obtain F where F_def: "F = make\<Pi>\<^sub>1 (\<lambda> u s w . u = \<nu>\<upsilon> a)" by auto
    have "[\<lparr>F, a\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F, b\<^sup>P\<rparr> in v]" using assms by (rule AllE)
    moreover have "[\<lparr>F, a\<^sup>P\<rparr> in v]"
      unfolding F_def by (simp add: meta_defs meta_aux)
    ultimately have "[\<lparr>F, b\<^sup>P\<rparr> in v]" using EquivE by auto
    hence "\<nu>\<upsilon> a = \<nu>\<upsilon> b" using F_def by (simp add: meta_defs meta_aux)
    thus ?thesis by (simp add: meta_defs meta_aux)
  qed

end

(*<*)
end
(*>*)


theory TopoS_Interface
imports Main "Lib/FiniteGraph" TopoS_Vertices "Lib/TopoS_Util"
begin

section {* Security Invariants *}
  text{*
    A good documentation of this formalization is available in \cite{diekmann2014forte}.
  *}

  text{*
    We define security invariants over a graph.
    The graph corresponds to the network's access control structure.
  *}

  -- {*@{typ "'v"} is the type of the nodes in the graph (hosts in the network).
     @{typ "'a"} is the type of the host attributes.
     @{typ "'b"} is the type of some additional global attributes (not very important) *}
  record ('v::vertex, 'a, 'b) TopoS_Params =
    node_properties :: "'v::vertex \<Rightarrow> 'a option"
    model_global_properties :: "'b"

text{*
A Security Invariant is defined as locale.

We successively define more and more locales with more and more assumptions.
This clearly depicts which assumptions are necessary to use certain features of a Security Invariant.
In addition, it makes instance proofs of Security Invariants easier, since the lemmata obtained by an (easy, few assumptions) instance proof
can be used for the complicated (more assumptions) instance proofs.

A security Invariant consists of two functions. A function @{text "sinvar"} and a function @{text "verify_globals"}.
@{text "sinvar"} is the most important function.
Essentially, it is a predicate over the policy (depiced as graph @{text "G"} and a host attribute mapping (@{text "nP"})).

The second function @{text "verify_globals"} is less important. It can for example be used to check so properties if the global attributes.
It is barely used.
*}

text {* A Security Invariant where the offending flows (flows that invalidate the policy) can be defined and calculated.
No assumptions are necessary for this step.
*}
  locale SecurityInvariant_withOffendingFlows =
    fixes sinvar::"('v::vertex) graph \<Rightarrow> ('v::vertex \<Rightarrow> 'a) \<Rightarrow> bool" --{* policy @{text "\<Rightarrow>"} host attribute mapping @{text "\<Rightarrow>"} bool*}
    fixes verify_globals::"('v::vertex) graph \<Rightarrow> ('v::vertex \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> bool" (*Network Graph (V,E) => V to node_properties => model_global_properties => bool*)
   begin
    -- "Offending Flows definitions:"
    definition is_offending_flows::"('v \<times> 'v) set \<Rightarrow> 'v graph \<Rightarrow> ('v \<Rightarrow> 'a) \<Rightarrow> bool" where
      "is_offending_flows f G nP \<equiv> \<not> sinvar G nP \<and> sinvar (delete_edges G f) nP"

    -- "Above definition is not minimal: "
    definition is_offending_flows_min_set::"('v \<times> 'v) set \<Rightarrow> 'v graph \<Rightarrow> ('v \<Rightarrow> 'a) \<Rightarrow> bool" where
      "is_offending_flows_min_set f G nP \<equiv> is_offending_flows f G nP \<and>
        (\<forall> (e1, e2) \<in> f. \<not> sinvar (add_edge e1 e2 (delete_edges G f)) nP)"

    -- "The set of all offending flows."
    definition set_offending_flows::"'v graph \<Rightarrow> ('v \<Rightarrow> 'a) \<Rightarrow> ('v \<times> 'v) set set" where
      "set_offending_flows G  nP = {F. F \<subseteq> (edges G) \<and> is_offending_flows_min_set F G nP}"

    text {*Some of the @{const set_offending_flows} definition*}
    lemma offending_not_empty: "\<lbrakk> F \<in> set_offending_flows G nP \<rbrakk> \<Longrightarrow> F \<noteq> {}"
     by(auto simp add: set_offending_flows_def is_offending_flows_def is_offending_flows_min_set_def)
    lemma empty_offending_contra:
       "\<lbrakk> F \<in> set_offending_flows G nP; F = {}\<rbrakk> \<Longrightarrow> False"
     by(simp add: set_offending_flows_def is_offending_flows_def is_offending_flows_min_set_def)
    lemma offending_notevalD: "F \<in> set_offending_flows G nP \<Longrightarrow> \<not> sinvar G nP"
     by(simp add: set_offending_flows_def is_offending_flows_def is_offending_flows_min_set_def)
    lemma sinvar_no_offending: "sinvar G nP \<Longrightarrow> set_offending_flows G nP = {}"
      by(simp add: set_offending_flows_def is_offending_flows_def is_offending_flows_min_set_def)
    theorem removing_offending_flows_makes_invariant_hold:
      "\<forall>F \<in> set_offending_flows G nP. sinvar (delete_edges G F) nP"
      proof(cases "sinvar G nP")
       case True
        hence no_offending: "set_offending_flows G nP = {}" using sinvar_no_offending by simp
        thus "\<forall>F\<in>set_offending_flows G nP. sinvar (delete_edges G F) nP" using empty_iff by simp
       next
       case False thus "\<forall>F\<in>set_offending_flows G nP. sinvar (delete_edges G F) nP"
        by(simp add: set_offending_flows_def is_offending_flows_def is_offending_flows_min_set_def graph_ops)
      qed
  corollary valid_without_offending_flows:
  "\<lbrakk> F \<in> set_offending_flows G nP \<rbrakk> \<Longrightarrow> sinvar (delete_edges G F) nP"
    by(simp add: removing_offending_flows_makes_invariant_hold)

  lemma set_offending_flows_simp:
    "\<lbrakk> valid_graph G \<rbrakk> \<Longrightarrow>
      set_offending_flows G nP = {F. F \<subseteq> edges G \<and>
        (\<not> sinvar G nP \<and> sinvar \<lparr>nodes = nodes G, edges = edges G - F\<rparr> nP) \<and>
        (\<forall>(e1, e2)\<in>F. \<not> sinvar \<lparr>nodes = nodes G, edges = {(e1, e2)} \<union> (edges G - F)\<rparr> nP)}"
    apply(simp only: set_offending_flows_def is_offending_flows_min_set_def
      is_offending_flows_def delete_edges_simp2 add_edge_def graph.select_convs)
    apply(subgoal_tac "\<And>F e1 e2. F \<subseteq> edges G \<Longrightarrow> (e1, e2) \<in> F \<Longrightarrow> nodes G \<union> {e1, e2} = nodes G")
     apply fastforce
    apply(simp add: valid_graph_def)
    by (metis fst_conv imageI in_mono insert_absorb snd_conv)

   end

print_locale! SecurityInvariant_withOffendingFlows

text{*
The locale @{text SecurityInvariant_withOffendingFlows} has no assumptions about the security invariant @{text sinvar}.
Undesirable things may happen:
The offending flows can be empty, even for a violated invariant.

We provide an example, the security invariant @{term "(\<lambda>_ _. False)"}.
As host attributes, we simply use the identity function @{const id}.
*}
lemma "SecurityInvariant_withOffendingFlows.set_offending_flows (\<lambda>_ _. False) \<lparr> nodes = {V ''v1''}, edges={} \<rparr> id = {}"
by %invisible (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
  SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def SecurityInvariant_withOffendingFlows.is_offending_flows_def)
lemma "SecurityInvariant_withOffendingFlows.set_offending_flows (\<lambda>_ _. False)
  \<lparr> nodes = {V ''v1'', V ''v2''}, edges = {(V ''v1'', V ''v2'')} \<rparr> id = {}"
by %invisible (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
  SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def SecurityInvariant_withOffendingFlows.is_offending_flows_def)

text {*In general, there exists a @{term sinvar} such that the invariant does not hold and no offending flows exits.*}
  lemma "\<exists>sinvar. \<not> sinvar G nP \<and> SecurityInvariant_withOffendingFlows.set_offending_flows sinvar G nP = {}"
  apply(simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
    SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply(rule_tac x="(\<lambda>_ _. False)" in exI)
  apply(simp)
  done

text{*Thus, we introduce usefulness properties that prohibits such useless invariants.*}
text{*We summarize them in an invariant.
It requires the following:
\begin{enumerate}
  \item The offending flows are always defined.
  \item The invariant is monotonic, i.e. prohibiting more is more secure.
  \item And, the (non-minimal) offending flows are monotonic, i.e. prohibiting more solves more security issues.
\end{enumerate}

Later, we will show that is suffices to show that the invariant is monotonic. The other two properties can be derived.
*}

  locale SecurityInvariant_preliminaries = SecurityInvariant_withOffendingFlows sinvar verify_globals
    for sinvar
    and verify_globals
    +
    assumes
      defined_offending:
      "\<lbrakk> valid_graph G; \<not> sinvar G nP \<rbrakk> \<Longrightarrow> set_offending_flows G nP \<noteq> {}"
    and
      mono_sinvar:
      "\<lbrakk> valid_graph \<lparr> nodes = N, edges = E \<rparr>; E' \<subseteq> E; sinvar \<lparr> nodes = N, edges = E \<rparr> nP \<rbrakk> \<Longrightarrow>
        sinvar \<lparr> nodes = N, edges = E' \<rparr> nP"
    and mono_offending:
      "\<lbrakk> valid_graph G; is_offending_flows ff G nP \<rbrakk> \<Longrightarrow> is_offending_flows (ff \<union> f') G nP"
  begin

  text {*
    \begin{small}
    To instantiate a @{const SecurityInvariant_preliminaries}, here are some hints:
    Have a look at the @{text "TopoS_withOffendingFlows.thy"} file.
    There is a definition of @{prop sinvar_mono}. It impplies @{prop mono_sinvar} and @{prop mono_offending}
    @{text "apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_sinvar_mono[OF sinvar_mono])
    apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_is_offending_flows_mono[OF sinvar_mono])"}

    In addition, @{text "SecurityInvariant_withOffendingFlows.mono_imp_set_offending_flows_not_empty[OF sinvar_mono]"} gives a nice proof rule for
    @{prop defined_offending}

    Basically, @{text "sinvar_mono."} implies almost all assumptions here and is equal to @{prop mono_sinvar}.
    \end{small}
  *}
  (*

  *)
  end

subsection{*Security Invariants with secure auto-completion of host attribute mappings*}

text{*
We will now add a new artifact to the Security Invariant.
It is a secure default host attribute, we will use the symbol @{text "\<bottom>"}.

The newly introduced Boolean @{text "receiver_violation"} tells whether a security violation happens at the sender's or the receiver's side.

The details can be looked up in \cite{diekmann2014forte}.
*}

  -- {* Some notes about the notation:
          @{term "fst ` F"} means to apply the function @{const "fst"} to the set @{term "F"} element-wise.
          Example: If @{term "F"} is a set of directed edges,
          @{term "F \<subseteq> edges G"}, then @{term "fst ` F"}
          is the set of senders and @{term "snd ` f"} the set of receivers.*}

  locale SecurityInvariant = SecurityInvariant_preliminaries sinvar verify_globals
    for sinvar::"('v::vertex) graph \<Rightarrow> ('v::vertex \<Rightarrow> 'a) \<Rightarrow> bool"
    and verify_globals::"('v::vertex) graph \<Rightarrow> ('v::vertex \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> bool"
    +
    fixes default_node_properties :: "'a" ("\<bottom>")
    and receiver_violation :: "bool"
    assumes
      -- "default value can never fix a security violation."
      -- {*Idea: Assume there is a violation, then there is some offending flow.
        @{text receiver_violation} defines whether the violation happens at the sender's or the receiver's side.
        We call the place of the violation the \emph{offending host}.
        We replace the host attribute of the offending host with the default attribute.
        Giving an offending host, a \emph{secure} default attribute does not change whether the invariant holds.
        I.e.\ this reconfiguration does not remove information, thus preserves all security critical information.
        Thought experiment preliminaries: Can a default configuration ever solve an existing security violation? NO!
        Thought experiment 1: admin forgot to configure host, hence it is handled by default configuration value ...
        Thought experiment 2: new node (attacker) is added to the network. What is its default configuration value ...*}
      default_secure:
      "\<lbrakk> valid_graph G; \<not> sinvar G nP; F \<in> set_offending_flows G nP \<rbrakk> \<Longrightarrow>
        (\<not> receiver_violation \<longrightarrow> i \<in> fst ` F \<longrightarrow> \<not> sinvar G (nP(i := \<bottom>))) \<and>
        (receiver_violation \<longrightarrow> i \<in> snd ` F \<longrightarrow> \<not> sinvar G (nP(i := \<bottom>)))"
      and
      default_unique:
      "otherbot \<noteq> \<bottom> \<Longrightarrow>
        \<exists> (G::('v::vertex) graph) nP i F. valid_graph G \<and> \<not> sinvar G nP \<and> F \<in> set_offending_flows G nP \<and>
         sinvar (delete_edges G F) nP \<and>
         (\<not> receiver_violation \<longrightarrow> i \<in> fst ` F \<and> sinvar G (nP(i := otherbot))) \<and>
         (receiver_violation \<longrightarrow> i \<in> snd ` F \<and> sinvar G (nP(i := otherbot))) "
      (*and
      --{*verify_globals does not depend on graph topology, i.e. semantics is in sinvar*}
      verify_globals_sound:
      "verify_globals G nP gP \<Longrightarrow>
        (\<forall> v. verify_globals (add_node v G) nP gP) \<and>
        (\<forall> v \<in> nodes G. verify_globals (delete_node v G) nP gP) \<and>
        (\<forall> v\<^sub>1 v\<^sub>2. verify_globals (add_edge v\<^sub>1 v\<^sub>2 G) nP gP) \<and>
        (\<forall> (v\<^sub>1, v\<^sub>2) \<in> edges G. verify_globals (delete_edge v\<^sub>1 v\<^sub>2 G) nP gP)"*)
   begin
    -- "Removes option type, replaces with default host attribute"
    fun node_props :: "('v, 'a, 'b) TopoS_Params \<Rightarrow> ('v \<Rightarrow> 'a)" where
    "node_props P = (\<lambda> i. (case (node_properties P) i of Some property \<Rightarrow> property | None \<Rightarrow> \<bottom>))"

    definition node_props_formaldef :: "('v, 'a, 'b) TopoS_Params \<Rightarrow> ('v \<Rightarrow> 'a)" where
    "node_props_formaldef P \<equiv>
    (\<lambda> i. (if i \<in> dom (node_properties P) then the (node_properties P i) else \<bottom>))"

    lemma node_props_eq_node_props_formaldef: "node_props_formaldef = node_props"
     apply(simp add: fun_eq_iff node_props_formaldef_def)
     apply(rule allI)+
     apply(simp add: option.case_eq_if domIff)
     done

    text{*
      Checking whether a security invariant holds.
      \begin{enumerate}
        \item check that the policy @{term G} is syntactically valid
        \item check that some optional properties hold, specified by @{term verify_globals}
        \item check the security invariant @{term sinvar}
      \end{enumerate}
    *}
    definition eval::"'v graph \<Rightarrow> ('v, 'a, 'b)TopoS_Params \<Rightarrow> bool" where
    "eval G P \<equiv> valid_graph G \<and> verify_globals G (node_props P) (model_global_properties P) \<and>
          sinvar G (node_props P)"

    lemma unique_common_math_notation:
    assumes "\<forall>G nP i F. valid_graph (G::('v::vertex) graph) \<and> \<not> sinvar G nP \<and> F \<in> set_offending_flows G nP \<and>
         sinvar (delete_edges G F) nP \<and>
         (\<not> receiver_violation \<longrightarrow> i \<in> fst ` F \<longrightarrow> \<not> sinvar G (nP(i := otherbot))) \<and>
         (receiver_violation \<longrightarrow> i \<in> snd ` F \<longrightarrow> \<not> sinvar G (nP(i := otherbot)))"
    shows "otherbot = \<bottom>"
    apply(rule ccontr)
    apply(drule default_unique)
    using assms by blast
   end

print_locale! SecurityInvariant

subsection{*Information Flow Security and Access Control*}
text{*

@{term receiver_violation} defines the offending host. Thus, it defines when the violation happens.

We found that this coincides with the invariant's security strategy.

\begin{description}
\item[ACS] If the violation happens at the sender, we have an access control strategy (\emph{ACS}).
I.e.\ the sender does not have the appropriate rights to initiate the connection.

\item[IFS] If the violation happens at the receiver, we have an information flow security strategy (\emph{IFS})
I.e.\ the receiver lacks the appropriate security clearance to retrieve the (confidential) information.
The violations happens only when the receiver reads the data.
\end{description}

We refine our @{term SecurityInvariant} locale.
*}

subsection {*Information Flow Security Strategy (IFS)*}
  locale SecurityInvariant_IFS = SecurityInvariant_preliminaries sinvar verify_globals
      for sinvar::"('v::vertex) graph \<Rightarrow> ('v::vertex \<Rightarrow> 'a) \<Rightarrow> bool"
      and verify_globals::"('v::vertex) graph \<Rightarrow> ('v::vertex \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> bool"
      +
      fixes default_node_properties :: "'a" ("\<bottom>")
      assumes  default_secure_IFS:
        "\<lbrakk> valid_graph G; f \<in> set_offending_flows G nP \<rbrakk> \<Longrightarrow>
          \<forall>i \<in> snd` f. \<not> sinvar G (nP(i := \<bottom>))"
      and
      --{* If some otherbot fulfills @{text default_secure}, it must be @{term "\<bottom>"}
             Hence, @{term "\<bottom>"} is uniquely defined *}
      default_unique_IFS:
      "(\<forall>G f nP i. valid_graph G \<and> f \<in> set_offending_flows G nP \<and> i \<in> snd` f
                \<longrightarrow> \<not> sinvar G (nP(i := otherbot))) \<Longrightarrow> otherbot = \<bottom>"
      begin
        lemma default_unique_EX_notation: "otherbot \<noteq> \<bottom> \<Longrightarrow>
          \<exists> G nP i f. valid_graph G \<and> \<not> sinvar G nP \<and> f \<in> set_offending_flows G nP \<and>
           sinvar (delete_edges G f) nP \<and>
           (i \<in> snd` f \<and> sinvar G (nP(i := otherbot)))"
          apply(erule contrapos_pp)
          apply(simp)
          using default_unique_IFS SecurityInvariant_withOffendingFlows.valid_without_offending_flows offending_notevalD
          by metis
      end

  sublocale SecurityInvariant_IFS \<subseteq> SecurityInvariant where receiver_violation=True
  apply(unfold_locales)
   apply(simp add: default_secure_IFS)
  apply(simp only: HOL.simp_thms)
  apply(drule default_unique_EX_notation)
  apply(assumption)
  done

  (*other direction*)
  locale SecurityInvariant_IFS_otherDirectrion = SecurityInvariant where receiver_violation=True
  sublocale SecurityInvariant_IFS_otherDirectrion \<subseteq> SecurityInvariant_IFS
  apply(unfold_locales)
   apply (metis default_secure offending_notevalD)
  apply(erule contrapos_pp)
  apply(simp)
  apply(drule default_unique)
  apply(simp)
  apply(blast)
  done

lemma default_uniqueness_by_counterexample_IFS:
  assumes "(\<forall>G F nP i. valid_graph G \<and> F \<in> SecurityInvariant_withOffendingFlows.set_offending_flows sinvar G nP \<and> i \<in> snd` F
                \<longrightarrow> \<not> sinvar G (nP(i := otherbot)))"
  and "otherbot \<noteq> default_value \<Longrightarrow>
    \<exists>G nP i F. valid_graph G \<and> \<not> sinvar G nP \<and> F \<in> (SecurityInvariant_withOffendingFlows.set_offending_flows sinvar G nP) \<and>
       sinvar (delete_edges G F) nP \<and>
        i \<in> snd ` F \<and> sinvar G (nP(i := otherbot)) "
   shows "otherbot = default_value"
   using assms by blast

subsection {*Access Control Strategy (ACS)*}
  locale SecurityInvariant_ACS = SecurityInvariant_preliminaries sinvar verify_globals
      for sinvar::"('v::vertex) graph \<Rightarrow> ('v::vertex \<Rightarrow> 'a) \<Rightarrow> bool"
      and verify_globals::"('v::vertex) graph \<Rightarrow> ('v::vertex \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> bool"
      +
      fixes default_node_properties :: "'a" ("\<bottom>")
      assumes  default_secure_ACS:
        "\<lbrakk> valid_graph G; f \<in> set_offending_flows G nP \<rbrakk> \<Longrightarrow>
          \<forall>i \<in> fst` f. \<not> sinvar G (nP(i := \<bottom>))"
      and
      default_unique_ACS:
      "(\<forall>G f nP i. valid_graph G \<and> f \<in> set_offending_flows G nP \<and> i \<in> fst` f
                \<longrightarrow> \<not> sinvar G (nP(i := otherbot))) \<Longrightarrow> otherbot = \<bottom>"
      begin
        lemma default_unique_EX_notation: "otherbot \<noteq> \<bottom> \<Longrightarrow>
          \<exists> G nP i f. valid_graph G \<and> \<not> sinvar G nP \<and> f \<in> set_offending_flows G nP \<and>
           sinvar (delete_edges G f) nP \<and>
           (i \<in> fst` f \<and> sinvar G (nP(i := otherbot)))"
          apply(erule contrapos_pp)
          apply(simp)
          using default_unique_ACS SecurityInvariant_withOffendingFlows.valid_without_offending_flows offending_notevalD
          by metis
      end

  sublocale SecurityInvariant_ACS \<subseteq> SecurityInvariant where receiver_violation=False
  apply(unfold_locales)
   apply(simp add: default_secure_ACS)
  apply(simp only: HOL.simp_thms)
  apply(drule default_unique_EX_notation)
  apply(assumption)
  done

  (*other direction*)
  locale SecurityInvariant_ACS_otherDirectrion = SecurityInvariant where receiver_violation=False
  sublocale SecurityInvariant_ACS_otherDirectrion \<subseteq> SecurityInvariant_ACS
  apply(unfold_locales)
   apply (metis default_secure offending_notevalD)
  apply(erule contrapos_pp)
  apply(simp)
  apply(drule default_unique)
  apply(simp)
  apply(blast)
  done

lemma default_uniqueness_by_counterexample_ACS:
  assumes "(\<forall>G F nP i. valid_graph G \<and> F \<in> SecurityInvariant_withOffendingFlows.set_offending_flows sinvar G nP \<and> i \<in> fst ` F
                \<longrightarrow> \<not> sinvar G (nP(i := otherbot)))"
  and "otherbot \<noteq> default_value \<Longrightarrow>
    \<exists>G nP i F. valid_graph G \<and> \<not> sinvar G nP \<and> F \<in> (SecurityInvariant_withOffendingFlows.set_offending_flows sinvar G nP) \<and>
       sinvar (delete_edges G F) nP \<and>
        i \<in> fst ` F \<and> sinvar G (nP(i := otherbot))"
  shows "otherbot = default_value"
  using assms by blast

text{* The sublocale relationships tell that the simplified @{const SecurityInvariant_ACS} and @{const SecurityInvariant_IFS}
  assumptions suffice to do tho generic SecurityInvariant assumptions. *}

end


(* Author: Dmitriy Traytel *)

header {* $\Pi$-Extended Dual Regular Expressions *}

(*<*)
theory Pi_Regular_Exp_Dual
imports Pi_Derivatives "~~/src/HOL/Library/List_lexord" "~~/src/HOL/Library/Code_Target_Nat"
begin
(*>*)
subsection {* Syntax of regular expressions *}

datatype 'a rexp_dual =
  CoZero (co: bool) |
  CoOne (co: bool) |
  CoAtom (co: bool) 'a |
  CoPlus (co: bool) "'a rexp_dual" "'a rexp_dual" |
  CoTimes (co: bool) "'a rexp_dual" "'a rexp_dual" |
  CoStar (co: bool) "'a rexp_dual" |
  CoPr (co: bool) "'a rexp_dual"
derive linorder rexp_dual

abbreviation "CoPLUS_dual b \<equiv> rexp_of_list (CoPlus b) (CoZero b)"
abbreviation "bool_unop_dual b \<equiv> (if b then id else HOL.Not)"
abbreviation "bool_binop_dual b \<equiv> (if b then op \<or> else op \<and>)"
abbreviation "set_binop_dual b \<equiv> (if b then op \<union> else op \<inter>)"

primrec final_dual :: "'a rexp_dual \<Rightarrow> bool"
where
  "final_dual (CoZero b) = (\<not> b)"
| "final_dual (CoOne b) = b"
| "final_dual (CoAtom b _) = (\<not> b)"
| "final_dual (CoPlus b r s) = bool_binop_dual b (final_dual r) (final_dual s)"
| "final_dual (CoTimes b r s) = bool_binop_dual (\<not> b) (final_dual r) (final_dual s)"
| "final_dual (CoStar b _) = b"
| "final_dual (CoPr _ r) = final_dual r"

context alphabet
begin

primrec wf_dual :: "nat \<Rightarrow> 'b rexp_dual \<Rightarrow> bool"
where
"wf_dual n (CoZero _) = True" |
"wf_dual n (CoOne _) = True" |
"wf_dual n (CoAtom _ a) = (wf_atom n a)" |
"wf_dual n (CoPlus _ r s) = (wf_dual n r \<and> wf_dual n s)" |
"wf_dual n (CoTimes _ r s) = (wf_dual n r \<and> wf_dual n s)" |
"wf_dual n (CoStar _ r) = wf_dual n r" |
"wf_dual n (CoPr _ r) = wf_dual (n + 1) r"

lemma wf_dual_PLUS_dual[simp]:
  "wf_dual n (CoPLUS_dual b xs) = (\<forall>r \<in> set xs. wf_dual n r)"
  by (induct xs rule: list_singleton_induct) auto

abbreviation "set_unop_dual n b A \<equiv> if b then A else lists (\<Sigma> n) - A"

end

context project
begin

primrec lang_dual :: "nat \<Rightarrow> 'b rexp_dual => 'a lang" where
"lang_dual n (CoZero b) = set_unop_dual n b {}" |
"lang_dual n (CoOne b) = set_unop_dual n b {[]}" |
"lang_dual n (CoAtom b a) = set_unop_dual n b {[x] | x. lookup a x \<and> x \<in> \<Sigma> n}" |
"lang_dual n (CoPlus b r s) = set_binop_dual b (lang_dual n r) (lang_dual n s)" |
"lang_dual n (CoTimes b r s) = set_unop_dual n b
   (set_unop_dual n b (lang_dual n r) @@ set_unop_dual n b (lang_dual n s))" |
"lang_dual n (CoStar b r) = set_unop_dual n b (star (set_unop_dual n b (lang_dual n r)))" |
"lang_dual n (CoPr b r) = set_unop_dual n b (map project ` (set_unop_dual (n + 1) b (lang_dual (n + 1) r)))"

lemma wf_dual_lang_dual_wf_word: "wf_dual n r \<Longrightarrow> \<forall>w \<in> lang_dual n r. wf_word n w"
  by (induct r arbitrary: n) (auto elim: set_rev_mp[OF _ conc_mono] star_induct
    intro: iffD2[OF wf_word] wf_word_map_project)

lemma lang_dual_subset_lists: "wf_dual n r \<Longrightarrow> lang_dual n r \<subseteq> lists (\<Sigma> n)"
proof (induct r arbitrary: n)
  case (CoPr b r) thus ?case by (cases b) (fastforce intro!: project)+
qed (auto simp: conc_subset_lists star_subset_lists)

lemma lang_dual_final_dual: "final_dual r = ([] \<in> lang_dual n r)"
  by (induct r arbitrary: n) (auto intro: concI[of "[]" _ "[]", simplified])

lemma lang_dual_PLUS_dual[simp]:
  "lang_dual n (CoPLUS_dual True xs) = (\<Union>r \<in> set xs. lang_dual n r)"
  by (induct xs rule: list_singleton_induct) auto

lemma lang_dual_CoPLUS_dual[simp]:
  "lang_dual n (CoPLUS_dual False xs) = (if xs = [] then lists (\<Sigma> n) else \<Inter>r \<in> set xs. lang_dual n r)"
  by (induct xs rule: list_singleton_induct) auto

end

context embed
begin

primrec lderiv_dual :: "'a \<Rightarrow> 'b rexp_dual \<Rightarrow> 'b rexp_dual" where
  "lderiv_dual _ (CoZero b) = (CoZero b)"
| "lderiv_dual _ (CoOne b) = (CoZero b)"
| "lderiv_dual a (CoAtom b c) = (if lookup c a then CoOne b else CoZero b)"
| "lderiv_dual a (CoPlus b r s) = CoPlus b (lderiv_dual a r) (lderiv_dual a s)"
| "lderiv_dual a (CoTimes b r s) =
    (let r's = CoTimes b (lderiv_dual a r) s
     in if bool_unop_dual b (final_dual r) then CoPlus b r's (lderiv_dual a s) else r's)"
| "lderiv_dual a (CoStar b r) = CoTimes b (lderiv_dual a r) (CoStar b r)"
| "lderiv_dual a (CoPr b r) = CoPr b (CoPLUS_dual b (map (\<lambda>a'. lderiv_dual a' r) (embed a)))"

primrec lderivs_dual where
  "lderivs_dual [] r = r"
| "lderivs_dual (w#ws) r = lderivs_dual ws (lderiv_dual w r)"

lemma wf_dual_lderiv_dual[simp]: "wf_dual n r \<Longrightarrow> wf_dual n (lderiv_dual w r)"
  by (induct r arbitrary: n w) (auto simp add: Let_def)

lemma wf_dual_lderivs_dual[simp]: "wf_dual n r \<Longrightarrow> wf_dual n (lderivs_dual ws r)"
  by (induct ws arbitrary: r) (auto intro: wf_dual_lderiv_dual)

lemma lang_dual_lderiv_dual: "\<lbrakk>wf_dual n r; w \<in> \<Sigma> n\<rbrakk> \<Longrightarrow>
  lang_dual n (lderiv_dual w r) = lQuot w (lang_dual n r)"
proof (induct r arbitrary: n w)
  case (CoPr b r)
  hence *: "wf_dual (Suc n) r" "\<And>w'. w' \<in> set (embed w) \<Longrightarrow>  w' \<in> \<Sigma> (Suc n)" by (auto simp: embed)
  then show ?case using lQuot_map_project[OF CoPr(3) lang_dual_subset_lists[OF *(1)]]
    lQuot_map_project[OF CoPr(3) Diff_subset, of "lang_dual (n + 1) r"]
    by (simp_all add: CoPr(1,3))
qed (auto 0 3 simp: Let_def lang_dual_final_dual[symmetric])

lemma lang_dual_lderivs_dual: "\<lbrakk>wf_dual n r; wf_word n ws\<rbrakk> \<Longrightarrow>
  lang_dual n (lderivs_dual ws r) = lQuots ws (lang_dual n r)"
  by (induct ws arbitrary: r) (auto simp: lang_dual_lderiv_dual)

corollary lderivs_dual_final_dual:
  assumes "wf_dual n r" "wf_word n ws"
  shows "final_dual (lderivs_dual ws r) \<longleftrightarrow> ws \<in> lang_dual n r"
  using lang_dual_lderivs_dual[OF assms] lang_dual_final_dual[of "lderivs_dual ws r" n] by auto

end

fun pnCoPlus :: "bool \<Rightarrow> 'a::linorder rexp_dual \<Rightarrow> 'a rexp_dual \<Rightarrow> 'a rexp_dual" where
  "pnCoPlus b1 (CoZero b2) r = (if b1 = b2 then r else CoZero b2)"
| "pnCoPlus b1 r (CoZero b2) = (if b1 = b2 then r else CoZero b2)"
| "pnCoPlus b1 (CoPlus b2 r s) t =
    (if b1 = b2 then pnCoPlus b2 r (pnCoPlus b2 s t) else CoPlus b1 (CoPlus b2 r s) t)"
| "pnCoPlus b1 r (CoPlus b2 s t) =
     (if b1 = b2 then
       (if r = s then (CoPlus b2 s t)
       else if r \<le> s then CoPlus b2 r (CoPlus b2 s t)
       else CoPlus b2 s (pnCoPlus b2 r t))
     else CoPlus b1 r (CoPlus b2 s t))"
| "pnCoPlus b r s =
     (if r = s then r
      else if r \<le> s then CoPlus b r s
      else CoPlus b s r)"

lemma (in alphabet) wf_dual_pnCoPlus[simp]: "\<lbrakk>wf_dual n r; wf_dual n s\<rbrakk> \<Longrightarrow> wf_dual n (pnCoPlus b r s)"
  by (induct b r s rule: pnCoPlus.induct) auto

lemma (in project) lang_dual_pnCoPlus[simp]: "\<lbrakk>wf_dual n r; wf_dual n s\<rbrakk> \<Longrightarrow>
  lang_dual n (pnCoPlus b r s) = lang_dual n (CoPlus b r s)"
proof (induct b r s rule: pnCoPlus.induct)
  case 1 thus ?case by (auto dest: lang_dual_subset_lists)
next
  case "2_1" thus ?case by auto
next
  case "2_2" thus ?case by auto
next
  case "2_3" thus ?case by (auto dest: lang_dual_subset_lists)
next
  case "2_4" thus ?case by (auto dest!: lang_dual_subset_lists dest:
    subsetD[OF conc_subset_lists, unfolded in_lists_conv_set, rotated -1])
next
  case "2_5" thus ?case by (auto dest!: lang_dual_subset_lists dest:
    subsetD[OF star_subset_lists, unfolded in_lists_conv_set, rotated -1])
next
  case "2_6" thus ?case by (auto 4 4 dest!: lang_dual_subset_lists intro: project)
next
  case "3_1" thus ?case by auto
next
  case "3_2" thus ?case by auto
next
  case "3_3" thus ?case by auto
next
  case "3_4" thus ?case by auto
next
  case "3_5" thus ?case by auto
next
  case "3_6" thus ?case by auto
next
  case "4_1" thus ?case by auto
next
  case "4_2" thus ?case by auto
next
  case "4_3" thus ?case by auto
next
  case "4_4" thus ?case by auto
next
  case "4_5" thus ?case by auto
next
  case "5_1" thus ?case by auto
next
  case "5_2" thus ?case by auto
next
  case "5_3" thus ?case by auto
next
  case "5_4" thus ?case by auto
next
  case "5_5" thus ?case by auto
next
  case "5_6" thus ?case by auto
next
  case "5_7" thus ?case by auto
next
  case "5_8" thus ?case by auto
next
  case "5_9" thus ?case by auto
next
  case "5_10" thus ?case
    by auto (metis (no_types, hide_lams) Cons_in_lists_iff Diff_iff imageI list.simps(8) list.simps(9) lists.Nil)+
next
  case "5_11" thus ?case by auto
next
  case "5_12" thus ?case by auto
next
  case "5_13" thus ?case by auto
next
  case "5_14" thus ?case by auto
next
  case "5_15" thus ?case by auto
next
  case "5_16" thus ?case by auto
next
  case "5_17" thus ?case by auto
next
  case "5_18" thus ?case by auto
next
  case "5_19" thus ?case by (auto dest!: lang_dual_subset_lists dest:
    subsetD[OF star_subset_lists, unfolded in_lists_conv_set, rotated -1])
next
  case "5_20" thus ?case by auto
next
  case "5_21" thus ?case by auto
next
  case "5_22" thus ?case
    by auto (metis (no_types, hide_lams) Cons_in_lists_iff Diff_iff imageI list.simps(8) list.simps(9) lists.Nil)+
next
  case "5_23" thus ?case by auto
next
  case "5_24" thus ?case by auto
next
  case "5_25" thus ?case by auto
qed

fun pnCoTimes :: "bool \<Rightarrow> 'a::linorder rexp_dual \<Rightarrow> 'a rexp_dual \<Rightarrow> 'a rexp_dual" where
  "pnCoTimes b1 (CoZero b2) r = (if b1 = b2 then CoZero b1 else CoTimes b1 (CoZero b2) r)"
| "pnCoTimes b1 (CoOne b2) r = (if b1 = b2 then r else CoTimes b1 (CoOne b2) r)"
| "pnCoTimes b1 (CoPlus b2 r s) t = (if b1 = b2 then pnCoPlus b2 (pnCoTimes b2 r t) (pnCoTimes b2 s t)
   else CoTimes b1 (CoPlus b2 r s) t)"
| "pnCoTimes b r s = CoTimes b r s"

lemma (in alphabet) wf_dual_pnCoTimes[simp]: "\<lbrakk>wf_dual n r; wf_dual n s\<rbrakk> \<Longrightarrow> wf_dual n (pnCoTimes b r s)"
  by (induct b r s rule: pnCoTimes.induct) auto

lemma (in project) lang_dual_pnCoTimes[simp]: "\<lbrakk>wf_dual n r; wf_dual n s\<rbrakk> \<Longrightarrow> lang_dual n (pnCoTimes b r s) = lang_dual n (CoTimes b r s)"
  apply (induct b r s rule: pnCoTimes.induct)
  apply (auto, auto dest!: lang_dual_subset_lists dest: project
      subsetD[OF star_subset_lists, unfolded in_lists_conv_set, rotated -1]
      subsetD[OF conc_subset_lists, unfolded in_lists_conv_set, rotated -1])
  by (metis (full_types) Diff_iff conc_epsilon(1) double_diff empty_subsetI in_listsI insert_subset lists.Nil subset_refl)

fun pnCoPr :: "bool \<Rightarrow> 'a::linorder rexp_dual \<Rightarrow> 'a rexp_dual" where
  "pnCoPr b1 (CoZero b2) = (if b1 = b2 then CoZero b2 else CoPr b1 (CoZero b2))"
| "pnCoPr b1 (CoOne b2) = (if b1 = b2 then CoOne b2 else CoPr b1 (CoOne b2))"
| "pnCoPr b1 (CoPlus b2 r s) = (if b1 = b2 then pnCoPlus b2 (pnCoPr b2 r) (pnCoPr b2 s)
    else CoPr b1 (CoPlus b2 r s))"
| "pnCoPr b r = CoPr b r"

lemma (in alphabet) wf_dual_pnCoPr[simp]: "wf_dual (Suc n) r \<Longrightarrow> wf_dual n (pnCoPr b r)"
  by (induct b r rule: pnCoPr.induct) auto

lemma (in project) lang_dual_pnCoPr[simp]: "wf_dual (Suc n) r \<Longrightarrow> lang_dual n (pnCoPr b r) = lang_dual n (CoPr b r)"
  by (induct b r rule: pnCoPr.induct) auto

primrec pnorm_dual :: "'a::linorder rexp_dual \<Rightarrow> 'a rexp_dual" where
  "pnorm_dual (CoZero b) = (CoZero b)"
| "pnorm_dual (CoOne b) = (CoOne b)"
| "pnorm_dual (CoAtom b a) = (CoAtom b a)"
| "pnorm_dual (CoPlus b r s) = pnCoPlus b (pnorm_dual r) (pnorm_dual s)"
| "pnorm_dual (CoTimes b r s) = pnCoTimes b (pnorm_dual r) s"
| "pnorm_dual (CoStar b r) = CoStar b r"
| "pnorm_dual (CoPr b r) = pnCoPr b (pnorm_dual r)"

lemma (in alphabet) wf_dual_pnorm_dual[simp]: "wf_dual n r \<Longrightarrow> wf_dual n (pnorm_dual r)"
  by (induct r arbitrary: n) auto

lemma (in project) lang_dual_pnorm_dual[simp]: "wf_dual n r \<Longrightarrow> lang_dual n (pnorm_dual r) = lang_dual n r"
  by (induct r arbitrary: n) auto

primrec CoNot where
  "CoNot (CoZero b) = CoZero (\<not> b)"
| "CoNot (CoOne b) = CoOne (\<not> b)"
| "CoNot (CoAtom b a) = CoAtom (\<not> b) a"
| "CoNot (CoPlus b r s) = CoPlus (\<not> b) (CoNot r) (CoNot s)"
| "CoNot (CoTimes b r s) = CoTimes (\<not> b) (CoNot r) (CoNot s)"
| "CoNot (CoStar b r) = CoStar (\<not> b) (CoNot r)"
| "CoNot (CoPr b r) = CoPr (\<not> b) (CoNot r)"

primrec rexp_dual_of where
  "rexp_dual_of Zero = CoZero True"
| "rexp_dual_of Full = CoZero False"
| "rexp_dual_of One = CoOne True"
| "rexp_dual_of (Atom a) = CoAtom True a"
| "rexp_dual_of (Plus r s) = CoPlus True (rexp_dual_of r) (rexp_dual_of s)"
| "rexp_dual_of (Times r s) = CoTimes True (rexp_dual_of r) (rexp_dual_of s)"
| "rexp_dual_of (Star r) = CoStar True (rexp_dual_of r)"
| "rexp_dual_of (Not r) = CoNot (rexp_dual_of r)"
| "rexp_dual_of (Inter r s) = CoPlus False (rexp_dual_of r) (rexp_dual_of s)"
| "rexp_dual_of (Pr r) = CoPr True (rexp_dual_of r)"

lemma (in alphabet) wf_dual_CoNot[simp]: "wf_dual n r \<Longrightarrow> wf_dual n (CoNot r)"
  by (induct r arbitrary: n) auto

lemma (in project) lang_dual_CoNot[simp]: "wf_dual n r \<Longrightarrow> lang_dual n (CoNot r) = lists (\<Sigma> n) - lang_dual n r"
  apply (induct r arbitrary: n)
  apply (auto dest!: lang_dual_subset_lists simp: double_diff intro!: project)
  apply force
  apply (metis (full_types) Diff_subset contra_subsetD in_listsD star_subset_lists)
  done

lemma (in alphabet) wf_dual_rexp_dual_of[simp]: "wf n r \<Longrightarrow> wf_dual n (rexp_dual_of r)"
  by (induct r arbitrary: n) auto

lemma (in project) lang_dual_rexp_dual_of[simp]: "wf n r \<Longrightarrow> lang_dual n (rexp_dual_of r) = lang n r"
  by (induct r arbitrary: n) auto

end


theory NatStream = Main:

use tactics

method_setup circular_coinduction = "build_tactic (circular_coinduction_fun)" "all"
method_setup coinduction = "build_tactic (coinduction_fun)" "rule_tac R=?Rzero in ga_cogenerated, instantiate_tac Rzero %s1.?R,step"
method_setup init = "build_tactic (init_fun)" "(simp|(solve,blast))?,init2_fun?"
method_setup breakup = "build_tactic (breakup_fun)" "simp,((exE|conjE)+)?,disjE"
method_setup solve= "build_tactic (solve_fun 1)" "((exE|conjE|conjI)+)?,(simp)?,((exE|conjE|conjI)+)?,(simp)?"
method_setup step = "build_tactic (step_fun)" "((disjI2)+)?,inst r (rcs union (trans r))"
method_setup close= "build_tactic (close_fun)" "((disjI1|disjI2)+)?,((exE|conjE)+)?,force_solve|solve,disji1+,blast"
method_setup close_or_step= "build_tactic (close_or_step_fun)" "close|(solve,(close|(step,solve?,disjI2?,solve?,xy_exi?,solve,close?),((disjI1+)?,blast,close)?))"
method_setup force_finish = "build_tactic (force_finish_fun)" "inst r false,solve1"

typedecl "NatStream"
datatype Nat = zero | succ "Nat"
consts

"zero" :: "Nat"
"succ" :: "Nat => Nat"
"cons" :: "Nat => NatStream => NatStream"
"even" :: "NatStream => NatStream"
"hd" :: "NatStream => Nat"
"merge" :: "NatStream => NatStream => NatStream"
"odd" :: "NatStream => NatStream"
"tl" :: "NatStream => NatStream"
"add" :: "Nat => Nat => Nat"
"stradd" :: "NatStream => NatStream => NatStream"
"map" :: "(Nat => Nat) => NatStream => NatStream"
"double" :: "Nat => Nat"
"const" :: "Nat => NatStream"
"swap" :: "Nat => Nat => NatStream"

consts
  BinRelImage :: "('a => 'b) => ('a => 'a => bool) => ('b => 'b => bool)"
  Trans_NatStream :: "('a => 'a => bool) => ('b => 'b => bool)"
  union :: "('a => 'a => bool)  => ('a => 'a => bool) => ('a => 'a => bool)" (infixl 20)
defs
  BinRelImage_def [simp] : "BinRelImage f R == %x y . EX u v . R u v & x = f u & y = f v"
  Trans_NatStream_def [simp] : "Trans_NatStream R == (BinRelImage tl R)"
  union_def [simp] : "R union S == % x y . R x y | S x y"

axioms
ga_generated_Nat: "True"

Nat1 [simp] : "!! n1 :: Nat . add zero n1 = n1"
Nat2 [simp]: "!! n1 :: Nat . !! n2 :: Nat . add (succ n1) n2 = (succ (add n1 n2))"
NatCom [simp]: "!! n1 :: Nat . !! n2 :: Nat . add n1 n2 = add n2 n1"
double1 [simp] : "double zero = zero"
double2 [simp] : "!! n1 :: Nat . double (succ n1) = (add (succ n1) (succ n1))"
AddDouble [simp]: "!! n1 :: Nat . (add n1 n1) = (double n1) "

const_hd [simp] : "!! n1 :: Nat . (hd (const n1)) = n1"
const_tl [simp] : "!! n1 :: Nat . (tl (const n1)) = const n1"
swap_hd [simp] : "!! n1 :: Nat . !! n2 :: Nat . (hd (swap n1 n2)) = n1"
swap_tl [simp] : "!! n1 :: Nat . !! n2 :: Nat . (tl (swap n1 n2)) = (swap n2 n1)"
odd_hd [simp]: "!! s :: NatStream . (hd (odd s)) = (hd s)"
odd_tl [simp]: "!! s :: NatStream . (tl (odd s)) = odd (tl (tl s))"
even_hd [simp]: "!! s :: NatStream . (hd (even s)) = (hd (tl s))"
even_tl [simp]: "!! s :: NatStream . (tl (even s)) = even (tl (tl s))"
merge_hd [simp]: "!! s1 :: NatStream . !! s2 :: NatStream . (hd (merge s1 s2)) = (hd s1)"
merge_tl [simp]: "!! s1 :: NatStream . !! s2 :: NatStream . (tl (merge s1 s2)) = merge s2 (tl s1)"
stradd_hd [simp]: "!! s1 :: NatStream . !! s2 :: NatStream . (hd (stradd s1 s2)) = (add (hd s1) (hd s2)) "
stradd_tl [simp]: "!! s1 :: NatStream . !! s2 :: NatStream . (tl (stradd s1 s2)) = (stradd (tl s1) (tl s2))"
map_hd [simp]: "!! f :: Nat => Nat . !! s :: NatStream . (hd (map f s)) = (f (hd s))"
map_tl [simp]: "!! f :: Nat => Nat . !! s :: NatStream . (tl (map f s)) = (map f (tl s))"

ga_cogenerated_NatStream: "!! R :: NatStream => NatStream => bool . !! u :: NatStream . !! v :: NatStream . ! x :: NatStream . ! y :: NatStream . ((R x) y) --> ((hd x) = (hd y) & ((R (tl x)) (tl y)))  ==> ((R u) v) ==> u = v"
ga_selector_hd: "!! X1 :: Nat . !! X2 :: NatStream . (hd (cons X1 X2)) = X1"
ga_selector_tl: "!! X1 :: Nat . !! X2 :: NatStream . (tl (cons X1 X2)) = X2"

theorem Stream_Const_Swap: "!! a :: Nat . !! b :: Nat . (merge (const a) (const b)) = (swap a b)"
apply(circular_coinduction)
(*
apply(coinduction)
apply(init)
(*
apply(rule_tac R="?Rs" in ga_cogenerated_NatStream)
apply(tactic "instantiate_tac [(\"Rs\" , \"% s1 s2. Rcs union (Trans ?R)\" )]")
defer
apply(solve)
apply(blast)
apply(init2)
*)
apply(breakup)

apply(close_or_step)

apply(finish)

(*apply(rule disjI1)
apply(blast)
apply(close)

(*
apply(solve1)
apply(step)
apply(solve1)
apply(xy_exI)
apply(solve1)
apply(rule disjI1)
apply(blast)
apply(simp)
*)

apply(breakup)

apply(solve)
apply(rule disjI1)
apply(blast)

apply(finish)
*)*)
done

theorem NatStream_Map_Double: "!! l :: NatStream . (stradd l l) = (map double l)"
apply(circular_coinduction)
(*
apply(coinduction4)
apply(init)

(*
apply(rule_tac R="?Rs" in ga_cogenerated_NatStream)
apply(tactic "instantiate_tac [(\"Rs\" , \"% s. Rd union (Trans ?R)\" )]")
defer
apply(solve)
apply(rule disjI1)
apply(blast)
apply(init2)
*)

apply(breakup)

apply(solve)
apply(simp add: AddDouble)
apply(close_or_step4)

apply(finish)
*)
done

theorem Stream_StrAdd: "!! s1 :: NatStream . !! s2 :: NatStream . (stradd s1 s2) = (stradd s2 s1)"
apply(circular_coinduction)
(*
apply(coinduction2)
apply(init)

(*
apply(rule_tac R="?Rs" in ga_cogenerated_NatStream)
apply(tactic "instantiate_tac [(\"Rs\" , \"% s t. Rsa union (Trans ?R)\" )]")
defer
apply(solve)
apply(rule disjI1)
apply(blast)
apply(init2)
*)

apply(breakup)

apply(solve)
apply(simp add: NatCom)
apply(close_or_step2)

(*
apply(rule disjI1)
apply(rule_tac x="tl s1" in exI)
apply(rule_tac x="tl s2" in exI)
apply(close)
*)

apply(finish)
*)
done

theorem NatStream_Merge: "!! s :: NatStream . merge (odd s) (even s) = s"
apply(circular_coinduction)
(*
apply(coinduction3)
apply(init)
(*
apply(rule_tac R="?Rzero" in ga_cogenerated_NatStream)
apply(tactic "instantiate_tac [(\"Rzero\" , \"% s.  Rm union (Trans ?R)\" )]")
defer
apply(init)
*)

apply(breakup)

apply(close_or_step3)

(*
apply(solve1)
apply(step3)
apply(solve1)
apply(xy_exI)
apply(solve1)
apply(simp)
*)

apply(breakup)

apply(close_or_step3)

apply(finish)
*)
done

end


(*  Title:      HOL/Library/DAList.thy
    Author:     Lukas Bulwahn, TU Muenchen
*)

section \<open>Abstract type of association lists with unique keys\<close>

theory DAList
imports AList
begin

text \<open>This was based on some existing fragments in the AFP-Collection framework.\<close>

subsection \<open>Preliminaries\<close>

lemma distinct_map_fst_filter:
  "distinct (map fst xs) \<Longrightarrow> distinct (map fst (List.filter P xs))"
  by (induct xs) auto

subsection \<open>Type @{text "('key, 'value) alist" }\<close>

typedef ('key, 'value) alist = "{xs :: ('key \<times> 'value) list. (distinct \<circ> map fst) xs}"
  morphisms impl_of Alist
proof
  show "[] \<in> {xs. (distinct o map fst) xs}"
    by simp
qed

setup_lifting type_definition_alist

lemma alist_ext: "impl_of xs = impl_of ys \<Longrightarrow> xs = ys"
  by (simp add: impl_of_inject)

lemma alist_eq_iff: "xs = ys \<longleftrightarrow> impl_of xs = impl_of ys"
  by (simp add: impl_of_inject)

lemma impl_of_distinct [simp, intro]: "distinct (map fst (impl_of xs))"
  using impl_of[of xs] by simp

lemma Alist_impl_of [code abstype]: "Alist (impl_of xs) = xs"
  by (rule impl_of_inverse)

subsection \<open>Primitive operations\<close>

lift_definition lookup :: "('key, 'value) alist \<Rightarrow> 'key \<Rightarrow> 'value option" is map_of  .

lift_definition empty :: "('key, 'value) alist" is "[]"
  by simp

lift_definition update :: "'key \<Rightarrow> 'value \<Rightarrow> ('key, 'value) alist \<Rightarrow> ('key, 'value) alist"
  is AList.update
  by (simp add: distinct_update)

(* FIXME: we use an unoptimised delete operation. *)
lift_definition delete :: "'key \<Rightarrow> ('key, 'value) alist \<Rightarrow> ('key, 'value) alist"
  is AList.delete
  by (simp add: distinct_delete)

lift_definition map_entry ::
    "'key \<Rightarrow> ('value \<Rightarrow> 'value) \<Rightarrow> ('key, 'value) alist \<Rightarrow> ('key, 'value) alist"
  is AList.map_entry
  by (simp add: distinct_map_entry)

lift_definition filter :: "('key \<times> 'value \<Rightarrow> bool) \<Rightarrow> ('key, 'value) alist \<Rightarrow> ('key, 'value) alist"
  is List.filter
  by (simp add: distinct_map_fst_filter)

lift_definition map_default ::
    "'key \<Rightarrow> 'value \<Rightarrow> ('value \<Rightarrow> 'value) \<Rightarrow> ('key, 'value) alist \<Rightarrow> ('key, 'value) alist"
  is AList.map_default
  by (simp add: distinct_map_default)

subsection \<open>Abstract operation properties\<close>

(* FIXME: to be completed *)

lemma lookup_empty [simp]: "lookup empty k = None"
  by (simp add: empty_def lookup_def Alist_inverse)

lemma lookup_delete [simp]: "lookup (delete k al) = (lookup al)(k := None)"
  by (simp add: lookup_def delete_def Alist_inverse distinct_delete delete_conv')

subsection \<open>Further operations\<close>

subsubsection \<open>Equality\<close>

instantiation alist :: (equal, equal) equal
begin

definition "HOL.equal (xs :: ('a, 'b) alist) ys == impl_of xs = impl_of ys"

instance
  by default (simp add: equal_alist_def impl_of_inject)

end

subsubsection \<open>Size\<close>

instantiation alist :: (type, type) size
begin

definition "size (al :: ('a, 'b) alist) = length (impl_of al)"

instance ..

end

subsection \<open>Quickcheck generators\<close>

notation fcomp (infixl "\<circ>>" 60)
notation scomp (infixl "\<circ>\<rightarrow>" 60)

definition (in term_syntax)
  valterm_empty :: "('key :: typerep, 'value :: typerep) alist \<times> (unit \<Rightarrow> Code_Evaluation.term)"
  where "valterm_empty = Code_Evaluation.valtermify empty"

definition (in term_syntax)
  valterm_update :: "'key :: typerep \<times> (unit \<Rightarrow> Code_Evaluation.term) \<Rightarrow>
  'value :: typerep \<times> (unit \<Rightarrow> Code_Evaluation.term) \<Rightarrow>
  ('key, 'value) alist \<times> (unit \<Rightarrow> Code_Evaluation.term) \<Rightarrow>
  ('key, 'value) alist \<times> (unit \<Rightarrow> Code_Evaluation.term)" where
  [code_unfold]: "valterm_update k v a = Code_Evaluation.valtermify update {\<cdot>} k {\<cdot>} v {\<cdot>}a"

fun (in term_syntax) random_aux_alist
where
  "random_aux_alist i j =
    (if i = 0 then Pair valterm_empty
     else Quickcheck_Random.collapse
       (Random.select_weight
         [(i, Quickcheck_Random.random j \<circ>\<rightarrow> (\<lambda>k. Quickcheck_Random.random j \<circ>\<rightarrow>
           (\<lambda>v. random_aux_alist (i - 1) j \<circ>\<rightarrow> (\<lambda>a. Pair (valterm_update k v a))))),
          (1, Pair valterm_empty)]))"

instantiation alist :: (random, random) random
begin

definition random_alist
where
  "random_alist i = random_aux_alist i i"

instance ..

end

no_notation fcomp (infixl "\<circ>>" 60)
no_notation scomp (infixl "\<circ>\<rightarrow>" 60)

instantiation alist :: (exhaustive, exhaustive) exhaustive
begin

fun exhaustive_alist ::
  "(('a, 'b) alist \<Rightarrow> (bool \<times> term list) option) \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
where
  "exhaustive_alist f i =
    (if i = 0 then None
     else
      case f empty of
        Some ts \<Rightarrow> Some ts
      | None \<Rightarrow>
          exhaustive_alist
            (\<lambda>a. Quickcheck_Exhaustive.exhaustive
              (\<lambda>k. Quickcheck_Exhaustive.exhaustive (\<lambda>v. f (update k v a)) (i - 1)) (i - 1))
            (i - 1))"

instance ..

end

instantiation alist :: (full_exhaustive, full_exhaustive) full_exhaustive
begin

fun full_exhaustive_alist ::
  "(('a, 'b) alist \<times> (unit \<Rightarrow> term) \<Rightarrow> (bool \<times> term list) option) \<Rightarrow> natural \<Rightarrow>
    (bool \<times> term list) option"
where
  "full_exhaustive_alist f i =
    (if i = 0 then None
     else
      case f valterm_empty of
        Some ts \<Rightarrow> Some ts
      | None \<Rightarrow>
          full_exhaustive_alist
            (\<lambda>a.
              Quickcheck_Exhaustive.full_exhaustive
                (\<lambda>k. Quickcheck_Exhaustive.full_exhaustive (\<lambda>v. f (valterm_update k v a)) (i - 1))
              (i - 1))
            (i - 1))"

instance ..

end

hide_const valterm_empty valterm_update random_aux_alist

hide_fact (open) lookup_def empty_def update_def delete_def map_entry_def filter_def map_default_def
hide_const (open) impl_of lookup empty update delete map_entry filter map_default

end