(*  Title:       CoreC++
    Author:      Daniel Wasserrab
    Maintainer:  Daniel Wasserrab <wasserra at fmi.uni-passau.de>

   Based on the Jinja theory Common/Objects.thy by Tobias Nipkow
*)

section \<open>Objects and the Heap\<close>

theory Objects imports SubObj begin

subsection\<open>Objects\<close>

type_synonym
  subo = "(path \<times> (vname \<rightharpoonup> val))"     \<comment> \<open>subobjects realized on the heap\<close>
type_synonym
  obj  = "cname \<times> subo set"            \<comment> \<open>mdc and subobject\<close>

definition init_class_fieldmap :: "prog \<Rightarrow> cname \<Rightarrow> (vname \<rightharpoonup> val)" where
  "init_class_fieldmap P C \<equiv>
     map_of (map (\<lambda>(F,T).(F,default_val T)) (fst(snd(the(class P C)))) )"

inductive
  init_obj :: "prog \<Rightarrow> cname \<Rightarrow> (path \<times> (vname \<rightharpoonup> val)) \<Rightarrow> bool"
  for P :: prog and C :: cname
where
  "Subobjs P C Cs \<Longrightarrow> init_obj P C (Cs,init_class_fieldmap P (last Cs))"

lemma init_obj_nonempty: "init_obj P C (Cs,fs) \<Longrightarrow> Cs \<noteq> []"
by (fastforce elim:init_obj.cases dest:Subobjs_nonempty)

lemma init_obj_no_Ref:
"\<lbrakk>init_obj P C (Cs,fs);  fs F = Some(Ref(a',Cs'))\<rbrakk> \<Longrightarrow> False"
by (fastforce elim:init_obj.cases default_val_no_Ref
                  simp:init_class_fieldmap_def map_of_map)

lemma SubobjsSet_init_objSet:
  "{Cs. Subobjs P C Cs} = {Cs. \<exists>vmap. init_obj P C (Cs,vmap)}"
by ( fastforce intro:init_obj.intros elim:init_obj.cases)

definition obj_ty :: "obj \<Rightarrow> ty" where
  "obj_ty obj  \<equiv>  Class (fst obj)"

 \<comment> \<open>a new, blank object with default values in all fields:\<close>
definition blank :: "prog \<Rightarrow> cname \<Rightarrow> obj" where
  "blank P C  \<equiv> (C, Collect (init_obj P C))"

subsection\<open>Heap\<close>

type_synonym heap  = "addr \<rightharpoonup> obj"

abbreviation
  cname_of :: "heap \<Rightarrow> addr \<Rightarrow> cname" where
  "cname_of hp a == fst (the (hp a))"

definition new_Addr :: "heap \<Rightarrow> addr option" where
  "new_Addr h  \<equiv>  if \<exists>a. h a = None then Some(SOME a. h a = None) else None"

lemma new_Addr_SomeD:
  "new_Addr h = Some a \<Longrightarrow> h a = None"
 by(fastforce simp add:new_Addr_def split:if_splits intro:someI)

end


header {* \subsection{Separation kernel model}\label{sect:separation_kernel_model} *}

theory Separation_kernel_model
  imports "../../step/Step"
          "../../step/Step_invariants"
          "../../step/Step_vpeq"
          "../../step/Step_vpeq_locally_respects"
          "../../step/Step_vpeq_weakly_step_consistent"
          "CISK"
begin

text {*
 First (Section~\ref{sect:initial_state}) we instantiate the CISK generic model.
 Functions that instantiate a generic function of the CISK model are prefixed with an `r',
 `r' standing for ``Rushby';, as CISK is derived originally from a model
  by Rushby~\cite{Verbeek2013}.
 For example, `rifp' is the instantiation of the generic `ifp'.

 Later (Section~\ref{sect:discharging}) all CISK proof obligations are discharged, e.g.,
 weak step consistency, output consistency, etc. These will be used in
 Section~\ref{sect:link_to_CISK}.
*}

subsubsection {* Initial state of separation kernel model\label{sect:initial_state} *}

text {* We assume that the initial state of threads and memory is given.
  The initial state of threads is arbitrary, but the threads are not
  executing the system call. The purpose of the following definitions
  is to obtain the initial state without potentially dangerous axioms.
  The only axioms we admit without proof are formulated using the
  ``consts'' syntax and thus safe. *}

consts
  initial_current :: "thread_id_t"
  initial_obj :: "obj_id_t \<Rightarrow> obj_t"

definition s0 :: state_t where
  "s0 \<equiv> \<lparr> sp_impl_subj_subj = Policy.sp_spec_subj_subj,
          sp_impl_subj_obj = Policy.sp_spec_subj_obj,
          current = initial_current,
          obj = initial_obj,
          thread = \<lambda> _ . (| ev_counter = 0 |)
          \<rparr>"

lemma initial_invariant:
  shows "atomic_step_invariant s0"
proof -
  have "sp_subset s0"
    unfolding sp_subset_def s0_def by auto
  thus ?thesis
    unfolding atomic_step_invariant_def by auto
qed

subsubsection {* Types for instantiation of the generic model *}

text {* To simplify formulations, we include the state invariant
 @{term "atomic_step_invariant"} in the state data type. The
 initial state @{term s0} serves at witness that @{term rstate_t}
 is non-empty. *}

typedef rstate_t = "{ s . atomic_step_invariant s }"
  using initial_invariant by auto

definition abs :: "state_t \<Rightarrow> rstate_t" ("\<up> _") where "abs = Abs_rstate_t"
definition rep :: "rstate_t \<Rightarrow> state_t" ("\<down> _") where "rep = Rep_rstate_t"

lemma rstate_invariant:
  shows "atomic_step_invariant (\<down>s)"
  unfolding rep_def by (metis Rep_rstate_t mem_Collect_eq)

lemma rstate_down_up[simp]:
  shows "(\<up>\<down>s) = s"
  unfolding rep_def abs_def using Rep_rstate_t_inverse by auto

lemma rstate_up_down[simp]:
  assumes "atomic_step_invariant s"
  shows "(\<down>\<up>s) = s"
  using assms Abs_rstate_t_inverse unfolding rep_def abs_def by auto

text {* A CISK action is identified with an interrupt point. *}

type_synonym raction_t = int_point_t

definition rcurrent :: "rstate_t \<Rightarrow> thread_id_t" where
  "rcurrent s = current \<down>s"

definition rstep :: "rstate_t \<Rightarrow> raction_t \<Rightarrow> rstate_t" where
  "rstep s a \<equiv> \<up>(atomic_step (\<down>s) a)"

text {* Each CISK domain is identified with a thread id. *}

type_synonym rdom_t = "thread_id_t"

text {* The output function returns the contents of all memory accessible
  to the subject. The action argument of the output function is ignored. *}

datatype visible_obj_t = VALUE obj_t | EXCEPTION
type_synonym routput_t = "page_t \<Rightarrow> visible_obj_t"

definition routput_f :: "rstate_t \<Rightarrow> raction_t \<Rightarrow> routput_t" where
  "routput_f s a p \<equiv>
    if sp_impl_subj_obj (\<down>s) (partition (rcurrent s)) (PAGE p) READ then
      VALUE (obj (\<down>s) (PAGE p))
    else
      EXCEPTION"

text {* The precondition for the generic model. Note that @{term atomic_step_invariant}
  is already part of the state. *}

definition rprecondition :: "rstate_t \<Rightarrow> rdom_t \<Rightarrow> raction_t \<Rightarrow> bool" where
  "rprecondition s d a \<equiv> atomic_step_precondition (\<down>s) d a"
abbreviation rinvariant
where "rinvariant s \<equiv> True" --"The invariant is already in the state type."

text {* Translate view-partitioning and interaction-allowed relations. *}

definition rvpeq :: "rdom_t \<Rightarrow> rstate_t \<Rightarrow> rstate_t \<Rightarrow> bool" where
  "rvpeq u s1 s2 \<equiv> vpeq (partition u) (\<down>s1) (\<down>s2)"

definition rifp :: "rdom_t \<Rightarrow> rdom_t \<Rightarrow> bool" where
  "rifp u v = Policy.ifp (partition u) (partition v)"

text {* Context Switches *}
definition rcswitch :: "nat \<Rightarrow> rstate_t \<Rightarrow> rstate_t" where
  "rcswitch n s \<equiv> \<up>((\<down>s) \<lparr> current := (SOME t . True) \<rparr>)"

subsubsection  {* Possible action sequences *}

text {*
An @{term SK_IPC} consists of three atomic actions @{term PREP}, @{term WAIT} and @{term BUF} with the same parameters.
*}
definition is_SK_IPC :: "raction_t list \<Rightarrow> bool"
where "is_SK_IPC aseq \<equiv> \<exists> dir partner page .
                    aseq = [SK_IPC dir PREP partner page,SK_IPC dir WAIT partner page,SK_IPC dir (BUF (SOME page' . True)) partner page]"
text {*
An @{term SK_EV_WAIT} consists of three atomic actions, one for each of the stages @{term EV_PREP}, @{term EV_WAIT} and @{term EV_FINISH}
with the same parameters.
*}
definition is_SK_EV_WAIT :: "raction_t list \<Rightarrow> bool"
where "is_SK_EV_WAIT aseq \<equiv> \<exists> consume .
                     aseq = [SK_EV_WAIT EV_PREP consume ,
                             SK_EV_WAIT EV_WAIT consume ,
                             SK_EV_WAIT EV_FINISH consume ]"

text {*
An @{term SK_EV_SIGNAL} consists of two atomic actions, one for each of the stages @{term EV_SIGNAL_PREP} and
@{term EV_SIGNAL_FINISH} with the same parameters.
*}
definition is_SK_EV_SIGNAL :: "raction_t list \<Rightarrow> bool"
where "is_SK_EV_SIGNAL aseq \<equiv> \<exists> partner .
                     aseq = [SK_EV_SIGNAL EV_SIGNAL_PREP partner,
                             SK_EV_SIGNAL EV_SIGNAL_FINISH partner]"

text {*
  The complete attack surface consists of IPC calls, events, and noops.
*}
definition rAS_set :: "raction_t list set"
  where "rAS_set \<equiv> { aseq . is_SK_IPC aseq \<or> is_SK_EV_WAIT aseq \<or> is_SK_EV_SIGNAL aseq } \<union> {[]}"

subsubsection {* Control *}
text {*
  When are actions aborting, and when are actions waiting.
  We do not currently use the @{term set_error_code} function yet.
*}
abbreviation raborting
  where "raborting s \<equiv> aborting (\<down>s)"
abbreviation rwaiting
  where "rwaiting s \<equiv> waiting (\<down>s)"
definition rset_error_code :: "rstate_t \<Rightarrow> raction_t \<Rightarrow> rstate_t"
  where "rset_error_code s a \<equiv> s"
text {*
  Returns the set of threads that are involved in a certain action.
  For example, for an IPC call, the @{term WAIT} stage synchronizes with the partner.
  This partner is involved in that action.
*}
definition rkinvolved :: "int_point_t \<Rightarrow> rdom_t set"
  where "rkinvolved a \<equiv>
  case a of SK_IPC dir WAIT partner page \<Rightarrow> {partner}
   | SK_EV_SIGNAL EV_SIGNAL_FINISH partner => {partner}
   | _ \<Rightarrow> {}"
abbreviation rinvolved :: "int_point_t option \<Rightarrow> rdom_t set"
  where "rinvolved \<equiv> Kernel.involved rkinvolved"

subsubsection {* Discharging the proof obligations\label{sect:discharging} *}

lemma inst_vpeq_rel:
  shows rvpeq_refl: "rvpeq u s s"
    and rvpeq_sym: "rvpeq u s1 s2 \<Longrightarrow> rvpeq u s2 s1"
    and rvpeq_trans: "\<lbrakk> rvpeq u s1 s2; rvpeq u s2 s3 \<rbrakk> \<Longrightarrow> rvpeq u s1 s3"
    unfolding rvpeq_def using vpeq_rel by metis+

lemma inst_ifp_refl:
  shows "\<forall> u . rifp u u"
unfolding rifp_def using Policy_properties.ifp_reflexive by fast

(* Original definition
  definition step_atomicity::bool where "step_atomicity
  \<equiv> \<forall> s a . current (step s a) = current s"
*)
lemma inst_step_atomicity [simp]:
  shows "\<forall> s a . rcurrent (rstep s a) = rcurrent s"
unfolding rstep_def rcurrent_def
using atomic_step_does_not_change_current_thread rstate_up_down rstate_invariant atomic_step_preserves_invariants
    by auto

(* Original definition
definition weakly_step_consistent::bool where "weakly_step_consistent
  \<equiv> \<forall> s t u a.
    vpeq u s t \<and> vpeq (current s) s t
  \<and> current s = current t
  \<and> precondition s a \<and> precondition t a
  \<longrightarrow>
  vpeq u (step s a) (step t a)"
*)

lemma inst_weakly_step_consistent:
  assumes "rvpeq u s t"
      and "rvpeq (rcurrent s) s t"
      and "rcurrent s = rcurrent t"
      and "rprecondition s (rcurrent s) a"
      and "rprecondition t (rcurrent t) a"
    shows "rvpeq u (rstep s a) (rstep t a)"
using assms atomic_step_weakly_step_consistent rstate_invariant atomic_step_preserves_invariants
unfolding rcurrent_def rstep_def rvpeq_def rprecondition_def
by auto

(* Original definition

definition locally_respects::bool where "locally_respects
  \<equiv> \<forall> a s u.
    \<not>ifp (current s) u
  \<and> precondition s a
  \<longrightarrow>
  vpeq u s (step s a)"
*)

lemma inst_local_respect:
  assumes not_ifp: "\<not>rifp (rcurrent s) u"
      and prec: "rprecondition s (rcurrent s) a"
    shows "rvpeq u s (rstep s a)"
using assms atomic_step_respects_policy rstate_invariant atomic_step_preserves_invariants
unfolding rifp_def rprecondition_def rvpeq_def rstep_def rcurrent_def
by auto

(*

definition output_consistent::bool where "output_consistent
  \<equiv> \<forall> a s t.
   vpeq (current s) s t
 \<and> current s = current t
 \<longrightarrow>
 (output_f s a) = (output_f t a)"
*)

lemma inst_output_consistency:
  assumes rvpeq: "rvpeq (rcurrent s) s t"
  and     current_eq: "rcurrent s = rcurrent t"
  shows   "routput_f s a = routput_f t a"
proof-
  have "\<forall> a s t. rvpeq (rcurrent s) s t \<and> rcurrent s = rcurrent t \<longrightarrow> routput_f s a = routput_f t a"
    proof-
      { fix a :: raction_t
        fix s t :: rstate_t
        fix p :: page_t
        assume 1: "rvpeq (rcurrent s) s t"
           and 2: "rcurrent s = rcurrent t"
        let ?part = "partition (rcurrent s)"
        have "routput_f s a p = routput_f t a p"
          proof (cases "Policy.sp_spec_subj_obj ?part (PAGE p) READ"
                 rule: case_split [case_names Allowed Denied])
            case Allowed
              have 5: "obj (\<down>s) (PAGE p) = obj (\<down>t) (PAGE p)"
                using 1 Allowed unfolding rvpeq_def vpeq_def vpeq_obj_def  by auto
              have 6: "sp_impl_subj_obj (\<down>s) ?part (PAGE p) READ = sp_impl_subj_obj (\<down>t) ?part (PAGE p) READ"
                using 1 2 Allowed unfolding rvpeq_def vpeq_def vpeq_subj_obj_def by auto
              show "routput_f s a p = routput_f t a p"
                unfolding routput_f_def using 2 5 6 by auto
            next case Denied
              hence "sp_impl_subj_obj (\<down>s) ?part (PAGE p) READ = False"
                and "sp_impl_subj_obj (\<down>t) ?part (PAGE p) READ = False"
                using rstate_invariant unfolding atomic_step_invariant_def sp_subset_def
                by auto
              thus "routput_f s a p = routput_f t a p"
                using 2 unfolding routput_f_def by simp
          qed }
        thus "\<forall> a s t. rvpeq (rcurrent s) s t \<and> rcurrent s = rcurrent t \<longrightarrow> routput_f s a = routput_f t a"
          by auto
    qed
  thus ?thesis using assms by auto
qed

(*
definition cswitch_independent_of_state::bool where "cswitch_independent_of_state
  \<equiv> \<forall> n s t . current s = current t \<longrightarrow> current (cswitch n s) = current (cswitch n t)"
*)
lemma inst_cswitch_independent_of_state:
  assumes "rcurrent s = rcurrent t"
  shows "rcurrent (rcswitch n s) = rcurrent (rcswitch n t)"
using rstate_invariant cswitch_preserves_invariants unfolding rcurrent_def rcswitch_def by simp

(*
definition cswitch_consistency::bool where "cswitch_consistency
  \<equiv> \<forall> u s t n . vpeq u s t \<longrightarrow> vpeq u (cswitch n s) (cswitch n t)"
  *)
lemma inst_cswitch_consistency:
  assumes "rvpeq u s t"
  shows "rvpeq u (rcswitch n s) (rcswitch n t)"
proof-
  have 1: "vpeq (partition u) (\<down>s) \<down>(rcswitch n s)"
  using rstate_invariant cswitch_consistency_and_respect cswitch_preserves_invariants
  unfolding rcswitch_def
    by auto
  have 2: "vpeq (partition u) (\<down>t) \<down>(rcswitch n t)"
  using rstate_invariant cswitch_consistency_and_respect cswitch_preserves_invariants
  unfolding rcswitch_def
    by auto
  from 1 2 assms show ?thesis unfolding rvpeq_def using vpeq_rel by metis
qed

text {*
For the @{term PREP} stage (the first stage of the IPC action sequence) the precondition is True.
*}
lemma prec_first_IPC_action:
assumes "is_SK_IPC aseq"
  shows "rprecondition s d (hd aseq)"
using assms
unfolding is_SK_IPC_def rprecondition_def atomic_step_precondition_def
by auto

text {*
For the the first stage of the @{term EV_WAIT} action sequence the precondition is True.
*}
lemma prec_first_EV_WAIT_action:
assumes "is_SK_EV_WAIT aseq"
  shows "rprecondition s d (hd aseq)"
using assms
unfolding is_SK_EV_WAIT_def rprecondition_def atomic_step_precondition_def
by auto

text {*
For the first stage of the @{term EV_SIGNAL} action sequence the precondition is True.
*}
lemma prec_first_EV_SIGNAL_action:
assumes "is_SK_EV_SIGNAL aseq"
  shows "rprecondition s d (hd aseq)"
using assms
unfolding is_SK_EV_SIGNAL_def rprecondition_def atomic_step_precondition_def
          ev_signal_precondition_def
  by auto

text {*
When not waiting or aborting, the precondition is ``1-step inductive'', that is at all times
the precondition holds initially (for the first step of an action sequence) and after doing
one step.
*}
lemma prec_after_IPC_step:
assumes prec: "rprecondition s (rcurrent s) (aseq ! n)"
    and n_bound: "Suc n < length aseq"
    and IPC: "is_SK_IPC aseq"
    and not_aborting: "\<not>raborting s (rcurrent s) (aseq ! n)"
    and not_waiting: "\<not>rwaiting s (rcurrent s) (aseq ! n)"
shows "rprecondition (rstep s (aseq ! n)) (rcurrent s) (aseq ! Suc n)"
proof-
{
  fix dir partner page
  let ?page' = "(SOME page' . True)"
  assume IPC: "aseq = [SK_IPC dir PREP partner page,SK_IPC dir WAIT partner page,SK_IPC dir (BUF ?page') partner page]"
  {
    assume 0: "n=0"
    from 0 IPC prec not_aborting
      have ?thesis
      unfolding rprecondition_def atomic_step_precondition_def rstep_def rcurrent_def atomic_step_def atomic_step_ipc_def aborting_def
      by(auto)
  }
  moreover
  {
    assume 1: "n=1"
    from 1 IPC prec not_waiting
      have ?thesis
      unfolding rprecondition_def atomic_step_precondition_def rstep_def rcurrent_def atomic_step_def atomic_step_ipc_def waiting_def
      by(auto)
  }
  moreover
  from IPC
    have "length aseq = 3"
    by auto
  ultimately
    have ?thesis
    using n_bound
    by arith
}
thus ?thesis
  using IPC
  unfolding is_SK_IPC_def
  by(auto)
qed

text {*
When not waiting or aborting, the precondition is 1-step inductive.
*}
lemma prec_after_EV_WAIT_step:
assumes prec: "rprecondition s (rcurrent s) (aseq ! n)"
    and n_bound: "Suc n < length aseq"
    and IPC: "is_SK_EV_WAIT aseq"
    and not_aborting: "\<not>raborting s (rcurrent s) (aseq ! n)"
    and not_waiting: "\<not>rwaiting s (rcurrent s) (aseq ! n)"
shows "rprecondition (rstep s (aseq ! n)) (rcurrent s) (aseq ! Suc n)"
proof-
{
  fix consume

  assume WAIT: "aseq = [SK_EV_WAIT EV_PREP consume,
                        SK_EV_WAIT EV_WAIT consume,
                        SK_EV_WAIT EV_FINISH consume]"
  {
    assume 0: "n=0"
    from 0 WAIT prec not_aborting
      have ?thesis
      unfolding rprecondition_def atomic_step_precondition_def
      by(auto)
  }
  moreover
  {
    assume 1: "n=1"
    from 1 WAIT prec not_waiting
      have ?thesis
      unfolding rprecondition_def atomic_step_precondition_def
      by(auto)
  }
  moreover
  from WAIT
    have "length aseq = 3"
    by auto
  ultimately
    have ?thesis
    using n_bound
    by arith
}
thus ?thesis
  using assms
  unfolding is_SK_EV_WAIT_def
  by auto
qed

text {*
When not waiting or aborting, the precondition is 1-step inductive.
*}
lemma prec_after_EV_SIGNAL_step:
assumes prec: "rprecondition s (rcurrent s) (aseq ! n)"
    and n_bound: "Suc n < length aseq"
    and SIGNAL: "is_SK_EV_SIGNAL aseq"
    and not_aborting: "\<not>raborting s (rcurrent s) (aseq ! n)"
    and not_waiting: "\<not>rwaiting s (rcurrent s) (aseq ! n)"
shows "rprecondition (rstep s (aseq ! n)) (rcurrent s) (aseq ! Suc n)"
proof-
{   fix partner
    assume SIGNAL1: "aseq = [SK_EV_SIGNAL EV_SIGNAL_PREP partner,
                            SK_EV_SIGNAL EV_SIGNAL_FINISH partner]"
  {
    assume 0: "n=0"
    from 0 SIGNAL1 prec not_aborting
      have ?thesis
      unfolding rprecondition_def atomic_step_precondition_def ev_signal_precondition_def
                aborting_def rstep_def atomic_step_def
      by auto
  }
  moreover
  from SIGNAL1
    have "length aseq = 2"
    by auto
  ultimately
    have ?thesis
    using n_bound
    by arith
}
thus ?thesis
  using assms
  unfolding is_SK_EV_SIGNAL_def
  by auto
qed

lemma on_set_object_value:
  shows "sp_impl_subj_subj (set_object_value ob val s) = sp_impl_subj_subj s"
    and "sp_impl_subj_obj (set_object_value ob val s) = sp_impl_subj_obj s"
  unfolding set_object_value_def apply simp+ done

lemma prec_IPC_dom_independent:
assumes "current s \<noteq> d"
    and "atomic_step_invariant s"
    and "atomic_step_precondition s d a"
shows "atomic_step_precondition (atomic_step_ipc (current s) dir stage partner page s) d a"
using assms on_set_object_value
unfolding atomic_step_precondition_def atomic_step_ipc_def ipc_precondition_def
          ev_signal_precondition_def set_object_value_def
          by (auto split add: int_point_t.splits ipc_stage_t.splits ipc_direction_t.splits
                   ev_consume_t.splits ev_wait_stage_t.splits ev_signal_stage_t.splits)

lemma prec_ev_signal_dom_independent:
assumes "current s \<noteq> d"
    and "atomic_step_invariant s"
    and "atomic_step_precondition s d a"
shows "atomic_step_precondition (atomic_step_ev_signal (current s) partner s) d a"
using assms on_set_object_value
unfolding atomic_step_precondition_def atomic_step_ev_signal_def ipc_precondition_def
          ev_signal_precondition_def set_object_value_def
          by (auto split add: int_point_t.splits ipc_stage_t.splits ipc_direction_t.splits
                   ev_consume_t.splits ev_wait_stage_t.splits ev_signal_stage_t.splits)

lemma prec_ev_wait_one_dom_independent:
assumes "current s \<noteq> d"
    and "atomic_step_invariant s"
    and "atomic_step_precondition s d a"
shows "atomic_step_precondition (atomic_step_ev_wait_one (current s) s) d a"
using assms on_set_object_value
unfolding atomic_step_precondition_def atomic_step_ev_wait_one_def ipc_precondition_def
          ev_signal_precondition_def set_object_value_def
          by (auto split add: int_point_t.splits ipc_stage_t.splits ipc_direction_t.splits
                   ev_consume_t.splits ev_wait_stage_t.splits ev_signal_stage_t.splits)

lemma prec_ev_wait_all_dom_independent:
assumes "current s \<noteq> d"
    and "atomic_step_invariant s"
    and "atomic_step_precondition s d a"
shows "atomic_step_precondition (atomic_step_ev_wait_all (current s) s) d a"
using assms on_set_object_value
unfolding atomic_step_precondition_def atomic_step_ev_wait_all_def ipc_precondition_def
          ev_signal_precondition_def set_object_value_def
          by (auto split add: int_point_t.splits ipc_stage_t.splits ipc_direction_t.splits
                   ev_consume_t.splits ev_wait_stage_t.splits ev_signal_stage_t.splits)

lemma prec_dom_independent:
shows "\<forall> s d a a' . rcurrent s \<noteq> d \<and> rprecondition s d a \<longrightarrow> rprecondition (rstep s a') d a"
using atomic_step_preserves_invariants
rstate_invariant prec_IPC_dom_independent prec_ev_signal_dom_independent
prec_ev_wait_all_dom_independent prec_ev_wait_one_dom_independent
unfolding rcurrent_def rprecondition_def rstep_def atomic_step_def
by(auto split add: int_point_t.splits  ev_consume_t.splits ev_wait_stage_t.splits ev_signal_stage_t.splits)

lemma ipc_precondition_after_cswitch[simp]:
shows "ipc_precondition d dir partner page ((\<down> s)\<lparr>current := new_current\<rparr>)
          = ipc_precondition d dir partner page (\<down> s)"
using assms
unfolding ipc_precondition_def
by(auto split add: ipc_direction_t.splits)

lemma precondition_after_cswitch:
shows "\<forall>s d n a. rprecondition s d a \<longrightarrow> rprecondition (rcswitch n s) d a"
using cswitch_preserves_invariants rstate_invariant
unfolding rprecondition_def rcswitch_def atomic_step_precondition_def
          ev_signal_precondition_def
by (auto split add: int_point_t.splits ipc_stage_t.splits  ev_signal_stage_t.splits)

lemma aborting_switch_independent:
shows "\<forall>n s. raborting (rcswitch n s) = raborting s"
proof-
{
  fix n s
  {
    fix tid a
    have "raborting (rcswitch n s) tid a = raborting s tid a"
      using rstate_invariant cswitch_preserves_invariants ev_signal_precondition_weakly_step_consistent
            cswitch_consistency_and_respect
      unfolding aborting_def rcswitch_def
      apply (auto split add: int_point_t.splits ipc_stage_t.splits
                         ev_wait_stage_t.splits ev_signal_stage_t.splits)
      apply (metis (full_types))
      by blast
  }
  hence "raborting (rcswitch n s) = raborting s" by auto
}
thus ?thesis by auto
qed
lemma waiting_switch_independent:
shows "\<forall>n s. rwaiting (rcswitch n s) = rwaiting s"
proof-
{
  fix n s
  {
    fix tid a
    have "rwaiting (rcswitch n s) tid a = rwaiting s tid a"
      using rstate_invariant cswitch_preserves_invariants
      unfolding waiting_def rcswitch_def
      by(auto split add: int_point_t.splits ipc_stage_t.splits ev_wait_stage_t.splits)
  }
  hence "rwaiting (rcswitch n s) = rwaiting s" by auto
}
thus ?thesis by auto
qed

lemma aborting_after_IPC_step:
assumes "d1 \<noteq> d2"
shows "aborting (atomic_step_ipc d1 dir stage partner page s) d2 a = aborting s d2 a"
unfolding atomic_step_ipc_def aborting_def set_object_value_def ipc_precondition_def
          ev_signal_precondition_def
by(auto split add: int_point_t.splits ipc_stage_t.splits ipc_direction_t.splits
                   ev_signal_stage_t.splits)

lemma waiting_after_IPC_step:
assumes "d1 \<noteq> d2"
shows "waiting (atomic_step_ipc d1 dir stage partner page s) d2 a = waiting s d2 a"
unfolding atomic_step_ipc_def waiting_def set_object_value_def ipc_precondition_def
by(auto split add: int_point_t.splits ipc_stage_t.splits ipc_direction_t.splits
                   ev_wait_stage_t.splits)
(*
lemma raborting_after_step:
shows "\<forall>s a d. rcurrent s \<noteq> d \<longrightarrow> raborting (rstep s a) d = raborting s d"
proof-
{
  fix s a d
  assume not_curr: "rcurrent s \<noteq> d"
  {
    fix a
    have "raborting (rstep s a) d = raborting s d"
      using not_curr aborting_after_IPC_step
            rstate_invariant atomic_ipc_preserves_invariants
      unfolding rcurrent_def  rstep_def atomic_step_def
      by(auto split add: int_point_t.splits)
  }
  hence "raborting (rstep s a) d = raborting s d" by auto
}
thus ?thesis by auto
qed
*)
(*
lemma rwaiting_after_step:
shows "\<forall>s a d. rcurrent s \<noteq> d \<longrightarrow> rwaiting (rstep s a) d = rwaiting s d"
proof-
{
  fix s a d
  assume not_curr: "rcurrent s \<noteq> d"
  {
    fix a
    have "rwaiting (rstep s a) d = rwaiting s d"
      using not_curr waiting_after_IPC_step
            rstate_invariant atomic_ipc_preserves_invariants
      unfolding rcurrent_def  rstep_def atomic_step_def
      by(auto split add: int_point_t.splits)
  }
  hence "rwaiting (rstep s a) d = rwaiting s d" by auto
}
thus ?thesis by auto
qed
*)

lemma raborting_consistent:
shows "\<forall>s t u. rvpeq u s t \<longrightarrow> raborting s u = raborting t u"
proof-
{
  fix s t u
  assume vpeq: "rvpeq u s t"
  {
    fix a
    from vpeq ipc_precondition_weakly_step_consistent rstate_invariant
      have "\<And> tid dir partner page . ipc_precondition u dir partner page (\<down>s)
                                    = ipc_precondition u dir partner page (\<down>t)"
      unfolding rvpeq_def
      by auto
    with vpeq rstate_invariant have "raborting s u a = raborting t u a"
      unfolding aborting_def rvpeq_def vpeq_def vpeq_local_def ev_signal_precondition_def
               vpeq_subj_subj_def atomic_step_invariant_def sp_subset_def rep_def
      apply (auto split add: int_point_t.splits ipc_stage_t.splits ev_signal_stage_t.splits)
      by blast
  }
  hence "raborting s u = raborting t u" by auto
}
thus ?thesis by auto
qed

lemma aborting_dom_independent:
  assumes "rcurrent s \<noteq> d"
    shows "raborting (rstep s a) d a' = raborting s d a'"
proof -
  have "\<And> tid dir partner page s . ipc_precondition tid dir partner page s = ipc_precondition tid dir partner page (atomic_step s a)
                                   \<and> ev_signal_precondition tid partner  s = ev_signal_precondition tid partner (atomic_step s a)
       "
    proof -
    fix tid dir partner page s
    let ?s = "atomic_step s a"
    have "(\<forall> p q . sp_impl_subj_subj s p q = sp_impl_subj_subj ?s p q)
       \<and> (\<forall> p x m . sp_impl_subj_obj s p x m = sp_impl_subj_obj ?s p x m)"
      unfolding atomic_step_def atomic_step_ipc_def
               atomic_step_ev_wait_all_def atomic_step_ev_wait_one_def
               atomic_step_ev_signal_def set_object_value_def
      by (auto split add: int_point_t.splits ipc_stage_t.splits ipc_direction_t.splits
          ev_wait_stage_t.splits ev_consume_t.splits  ev_signal_stage_t.splits)
    thus "ipc_precondition tid dir partner page s = ipc_precondition tid dir partner page (atomic_step s a)
         \<and> ev_signal_precondition tid partner  s = ev_signal_precondition tid partner (atomic_step s a)"
      unfolding ipc_precondition_def ev_signal_precondition_def by simp
    qed
  moreover have "\<And> b . (\<down>(\<up>(atomic_step (\<down>s) b))) = atomic_step (\<down>s) b"
    using rstate_invariant atomic_step_preserves_invariants rstate_up_down by auto
  ultimately show ?thesis
    unfolding aborting_def rstep_def ev_signal_precondition_def

    by (simp split add: int_point_t.splits ipc_stage_t.splits ev_wait_stage_t.splits
                        ev_signal_stage_t.splits)
qed

lemma ipc_precondition_of_partner_consistent:
assumes vpeq: "\<forall> d \<in> rkinvolved (SK_IPC dir WAIT partner page) . rvpeq d s t"
shows "ipc_precondition partner dir' u page' (\<down> s) =  ipc_precondition partner dir' u page' \<down> t"
proof-
  from assms ipc_precondition_weakly_step_consistent rstate_invariant
    show ?thesis
    unfolding rvpeq_def rkinvolved_def
    by auto
qed

lemma ev_signal_precondition_of_partner_consistent:
assumes vpeq: "\<forall> d \<in> rkinvolved (SK_EV_SIGNAL EV_SIGNAL_FINISH partner) . rvpeq d s t"
shows "ev_signal_precondition partner u (\<down> s) =  ev_signal_precondition partner u (\<down> t)"
proof-
  from assms ev_signal_precondition_weakly_step_consistent rstate_invariant
    show ?thesis
    unfolding rvpeq_def rkinvolved_def
    by auto
qed

lemma waiting_consistent:
shows "\<forall>s t u a . rvpeq (rcurrent s) s t \<and> (\<forall> d \<in> rkinvolved a . rvpeq d s t)
        \<and> rvpeq u s t
        \<longrightarrow> rwaiting s u a = rwaiting t u a"
proof-
{
  fix s t u a
  assume vpeq: "rvpeq (rcurrent s) s t"
  assume vpeq_involved: "\<forall> d \<in> rkinvolved a . rvpeq d s t"
  assume vpeq_u: "rvpeq u s t"
  have "rwaiting s u a = rwaiting t u a" proof (cases a)
    case SK_IPC
      thus "rwaiting s u a = rwaiting t u a"
      using ipc_precondition_of_partner_consistent vpeq_involved
      unfolding waiting_def by (auto split add: ipc_stage_t.splits)
    next case SK_EV_WAIT
      thus "rwaiting s u a = rwaiting t u a"
        using ev_signal_precondition_of_partner_consistent
        vpeq_involved vpeq vpeq_u
        unfolding waiting_def rkinvolved_def ev_signal_precondition_def
                  rvpeq_def vpeq_def vpeq_local_def
        by (auto split         add: ipc_stage_t.splits ev_wait_stage_t.splits ev_consume_t.splits)
    qed (simp add: waiting_def, simp add: waiting_def)
}
thus ?thesis by auto
qed

lemma ipc_precondition_ensures_ifp:
assumes "ipc_precondition (current s) dir partner page s"
    and "atomic_step_invariant s"
shows "rifp partner (current s)"
proof -
  let ?sp = "\<lambda> t1 t2 . Policy.sp_spec_subj_subj (partition t1) (partition t2)"
  have "?sp (current s) partner \<or> ?sp partner (current s)"
    using assms unfolding ipc_precondition_def atomic_step_invariant_def sp_subset_def
    by (cases dir, auto)
  thus ?thesis
    unfolding rifp_def using Policy_properties.ifp_compatible_with_sp_spec by auto
qed

lemma ev_signal_precondition_ensures_ifp:
assumes "ev_signal_precondition (current s) partner s"
    and "atomic_step_invariant s"
shows "rifp partner (current s)"
proof -
  let ?sp = "\<lambda> t1 t2 . Policy.sp_spec_subj_subj (partition t1) (partition t2)"
  have "?sp (current s) partner \<or> ?sp partner (current s)"
    using assms unfolding ev_signal_precondition_def atomic_step_invariant_def sp_subset_def
    by (auto)
  thus ?thesis
    unfolding rifp_def using Policy_properties.ifp_compatible_with_sp_spec by auto
qed

lemma involved_ifp:
shows "\<forall> s a . \<forall> d \<in> rkinvolved a . rprecondition s (rcurrent s) a \<longrightarrow> rifp d (rcurrent s)"
proof-
{
  fix s a d
  assume d_involved: "d \<in> rkinvolved a"
  assume prec: "rprecondition s (rcurrent s) a"
  from d_involved prec have "rifp d (rcurrent s)"
    using ipc_precondition_ensures_ifp ev_signal_precondition_ensures_ifp rstate_invariant
    unfolding rkinvolved_def rprecondition_def atomic_step_precondition_def rcurrent_def Kernel.involved_def
    by(cases a,simp,auto split add: int_point_t.splits ipc_stage_t.splits ev_signal_stage_t.splits)
}
thus ?thesis by auto
qed

lemma spec_of_waiting_ev:
shows "\<forall>s a. rwaiting s (rcurrent s) (SK_EV_WAIT EV_FINISH EV_CONSUME_ALL)
               \<longrightarrow> rstep s a = s"
 unfolding waiting_def
 by auto

lemma spec_of_waiting_ev_w:
shows "\<forall>s a. rwaiting s (rcurrent s) (SK_EV_WAIT EV_WAIT EV_CONSUME_ALL)
               \<longrightarrow> rstep s (SK_EV_WAIT EV_WAIT EV_CONSUME_ALL) = s"
 unfolding rstep_def atomic_step_def
 by (auto split  add: int_point_t.splits ipc_stage_t.splits ev_wait_stage_t.splits)

lemma spec_of_waiting:
shows "\<forall>s a. rwaiting s (rcurrent s) a \<longrightarrow> rstep s a = s"
unfolding waiting_def rstep_def atomic_step_def atomic_step_ipc_def
          atomic_step_ev_signal_def atomic_step_ev_wait_all_def
          atomic_step_ev_wait_one_def
  by(auto split add: int_point_t.splits ipc_stage_t.splits ev_wait_stage_t.splits)
end


header {* Abstract syntax for Hybrid CSP. *}

theory HHL
  imports  HCSP_Com
begin

consts
spec :: "fform => proc => fform => fform => prop"   ("{_}_{_;_}" 80)
specP2 :: "fform => fform => proc => fform => fform => fform  => fform => prop"   ("{_, _}_{_, _ ; _, _}" 80)
specP3 :: "fform => fform => fform => proc => fform => fform => fform => fform => fform => fform => prop"("{_,_,_}_{_,_,_; _,_,_}" 80)
specP4 :: "fform => fform => fform => fform => proc => fform => fform => fform => fform => fform  => fform => fform  => fform => prop"   ("{_,_,_,_}_{_,_,_,_ ; _,_,_,_}" 80)
specP5 :: "fform => fform => fform => fform => fform => proc => fform => fform => fform => fform => fform => fform  => fform => fform  => fform => fform  => prop"   ("{_,_,_,_,_}_{_,_,_,_,_ ; _,_,_,_,_}" 80)
specP6 :: "fform => fform => fform => fform => fform => fform => proc => fform => fform => fform => fform => fform => fform => fform  => fform => fform => fform => fform => fform  => prop"   ("{_,_,_,_,_,_}_{_,_,_,_,_,_ ; _,_,_,_,_,_}" 80)

(*Skip rule*)
axiomatization where
Skip : "|- ((l [=] (Real 0)) [-->] G) ==> {p} Skip {p; G}"

(*Assignment rule*)
axiomatization where
Assign  :" [| ~inPairForm ([(e, f)], q); |-(p [-->] (substF ([(e, f)]) (q)))
        [&]   ((l [=] (Real 0)) [-->] G)|] ==>
       {p} (e := f) {q; G}"

(*Example*)
lemma "{WTrue} (RVar ''x'') := (Real 2) {((RVar ''x'') [=] (Real 2)); (l [=] (Real 0))}"
apply (cut_tac p = "WTrue" and e = "(RVar ''x'')" and f = "(Real 2)" and
                q = "((RVar ''x'') [=] (Real 2))" and G = "(l [=] (Real 0))" in Assign, auto)
apply (rule Trans,auto)
done

(*Continuous rule*)
axiomatization where
Continue : "|- (Init [-->] FF)
           [&] ((p [&] close(FF) [&] close([~]b)) [-->] q)
           [&] ((((l [=] Real 0) [|] (high (close(FF) [&] p [&] close(b)))) [&] Rg) [-->] G)
           ==> {Init [&] p} <FF&&b> : Rg {q; G}" and
ContinueT : "|- (Init[&]p [-->]FF[&]b)
           [&] ((p [&] close(FF) [&] close(b) [&] close([~]b)) [-->] q)
           [&] ((((l [=] Real 0) [|] (high (close(FF) [&] p [&] close(b)))) [&] Rg) [-->] G)
           ==> {Init [&] p} <FF&&(b)> : Rg {q; G}" and
ContinueF : "|- (p[-->][~]b) [&] (p[-->]q) [&] ((l[=](Real 0))[-->]G)
           ==> {p} <FF&&b> : Rg {q; G}"

(*Continuous rule 2*)
(*The pb in the domain refers to the discrete variables.*)
axiomatization where
Continue2 : "|- (Init [-->] FF)
           [&] ((p [&] pb [&] close(FF) [&] close([~]b)) [-->] q)
           [&] ((((l [=] Real 0) [|] (high (close(FF) [&] p [&] pb [&] close(b)))) [&] Rg) [-->] G)
[&] (exeFlow (D,b,F1) [-->]FF)
           ==> {Init [&] p} <D&&FF&&(pb[&]b)> : Rg {q; G}"  and
Continue2T : "|- (Init[&]p [-->] FF[&]b)
           [&] ((p [&] pb [&] close(FF) [&] close(b) [&] close([~]b)) [-->] q)
           [&] ((((l [=] Real 0) [|] (high (close(FF) [&] p [&] pb [&] close(b)))) [&] Rg) [-->] G)
[&](exeFlow (D,b,FF) [-->]FF)
           ==> {Init [&] p} <D&&FF&&(pb[&]b)> : Rg {q; G}" and
Continue2F : "|- (p[&] pb[-->][~]b) [&] (p[&] pb[-->]q) [&] ((l[=](Real 0))[-->]G)
           ==> {p} <D&&FF&&(pb[&]b)> : Rg {q; G}"

(*Sequential rule*)
axiomatization where
Sequence : "[| {p} P {m; H}; {m} Q {q; G} |] ==>
             {p} P; (m, H); Q {q; H [^] G}"
(*The following rule for the case that the annotation M is discarded in the proof.*)
axiomatization where
Sequence1 : "[| {p} P {m; H}; {m} Q {q; G} |] ==>
             {p} P; M; Q {q; H [^] G}"

(*Case rule*)
axiomatization where
Case : "[| {p [&] b} P {q; G}; {p [&] ([~]b)} P {q; G}|]
             ==> {p} P {q; G}"

(*Conditional rule*)
axiomatization where
ConditionF : " [| |-(p [-->] [~] b); |- (p [-->] q); |- ((l [=] Real 0) [-->] G) |]
             ==> {p} IF b P {q; G}"
and
ConditionT :  "[| |-(p [-->] b); {p} P {q; G} |]
             ==> {p} IF b P {q; G}"
and
Condition : "[| {p [&] b} IF b P {q; G}; {p [&] ([~]b)} IF b P {q; G}|]
             ==> {p} IF b P {q; G}"

(*Nondeterministic rule*)
axiomatization where
Nondeterministic :
"{p [&] b} P {q;G}
  ==> {p} NON i x : b P {q; G}"

(*Communication rule*)
(*H in the rule denotes the common interval range.*)
axiomatization where
Communication : "[| ~inPairForm ([(x, e)], ry);
                    {px, py} (Px || Py) {qx, qy; Hx, Hy};
                    |- (qx [-->] rx) [&] (qy [-->] (substF ([(x, e)]) (ry)));
                    |- ((Hx [^] (high (qx))) [-->] Gx) [&] ((Hy [^] (high (qy))) [-->] Gy);
                    |- ((((Hx [^] (high (qx))) [&] Hy) [|]((Hy [^] (high (qy))) [&] Hx)) [-->] H)
                 |]
              ==>   {px, py} ((Px; (qx, Hx); ch !! e) || (Py; (qy, Hy); ch ?? x)) {rx, ry;
                    Gx [&] H, Gy [&] H}"

(*Communication interrupt rule*)
primrec contain :: "proc => proc => bool" where
"contain (Skip,p) = False" |
"contain (Stop,p) = False" |
"contain (x:=e,p) = False" |
"contain ((Ch!!e),p) = ((Ch!!e)=p)" |
"contain ((Ch??x),p) = ((Ch??x)=p)" |
"contain ((q;m;r),p) = False" |
"contain ((IF b q),p) = False" |
"contain ((NON i x : b q),p) = False" |
"contain ((q [[ r),p) = (if contain(q,p) then True else contain(r,p))" |
"contain ((q << r),p) = False" |
"contain ((q || r),p) = False" |
"contain ((q*),p) = False" |
"contain ((q**n),p) = False" |
"contain ((<F1 && b> : g),p) = False" |
"contain ((<D &&F1 && b> : g),p) = False" |
"contain ((q |> b r),p) = False" |
"contain ((q [[> r),p) = False"

(**)
axiomatization where
CommunicationI1 : "[| ~inPairForm ([(x, e)], ry);
                    |- Hy [-->] H;
                    |- rg [-->] H[^]WTrue;
                    {px, py} (Px || Py) {qx, qy; Hx, Hy};
                    |- Init [&] pre [<->] qx;
                    |- pre [&] Init [&] b [-->] F1;
                    |- (pre [&] close(F1) [&] close(b)) [-->] rx;
                    |- (qy [&] pre [&] close(F1) [&] close(b)) [-->] (substF ([(x, e)]) (ry));
                    |- (Hx [^] ((((l [=] Real 0) [|] (high (close(F1) [&] pre [&] close(b)))) [&] H)) [-->] Gx);
                    |- Hy [-->] Gy;
                    |- Hx [-->] Hxm;
                    |- Hy [-->] Hym;
                    contain(P,(ch !! e))
                 |]
              ==>   {px, py} (( Px; (qx, Hxm); (<F1 && b> :rg) [[> P) || (Py; (qy, Hym); ch ?? x))
                    {rx, ry; Gx, Gy}"
axiomatization where
CommunicationI2 : "[| ~inPairForm ([(x, e)], ry);
                    |- Hy [-->] H;
                    |- rg [-->] H[^]WTrue;
                    {px, py} (Px || Py) {qx, qy; Hx, Hy};
                    |- Init [&] pre [<->] qx;
                    |- pre [&] Init [&] b [-->] F1;
                    |- (qy [&] pre [&] close(F1) [&] close(b)) [-->] (substF ([(x, e)]) (rx));
                    |- qy [-->] ry;
                    |- Hx [^] ((((l [=] Real 0) [|] (high (close(F1) [&] pre [&] close(b)))) [&] H)) [-->] Gx;
                    |- Hy [-->] Gy;
                    |- Hx [-->] Hxm;
                    |- Hy [-->] Hym;
                    contain(P,(ch ?? x))
                 |]
              ==>   {px, py} (( Px; (qx, Hxm); (<F1 && b> :rg) [[> P) || (Py; (qy, Hym); ch !! e))
                    {rx, ry; Gx, Gy}"

(*Parallel rule*)
(*It is valid only when there are not communications occurring in P3 and P4.*)
axiomatization where
Parallel1: "[| {px, py} (Px || Py) {qx, qy; Hx, Hy}; {qx} Qx {rx; Gx}; {qy} Qy {ry; Gy} |]
           ==>  {px, py} ((Px; (qx, Hx); Qx) || (Py; (qy, Hy); Qy)) {rx, ry; Hx [^] Gx, Hy [^] Gy}"

(*It is valid only when there are no communications occurring in P1 and P2.*)
axiomatization where
Parallel2: "[| {px} Px {qx; Hx}; {py} Py {qy; Hy}|]
           ==> {px, py} (Px || Py) {qx, qy; Hx, Hy}"
(*It is valid in any case*)
axiomatization where
Parallel3: "[| {px, py} (Px || Py) {qx, qy; Hx[&](l[=](Real m)), Hy[&](l[=](Real m))};
               {qx, qy} (Qx || Qy) {rx, ry; Mx, My};
               |- (Hx[&](l[=](Real m))) [-->] HL;
               |- (Hy[&](l[=](Real m))) [-->] HR;
               |- ((Hx[&](l[=](Real m))) [^] Mx) [-->] Gx;
               |- ((Hy[&](l[=](Real m))) [^] My) [-->] Gy
            |]
           ==> {px, py} (Px;(qx,HL);Qx) || (Py;(qy,HR);Qy) {rx, ry; Gx, Gy}"

(*Repetition rule*)
axiomatization where
Rep : "[| {px} (Px) {px; Hx}; |- Hx [^] Hx [-->] Hx|]
           ==>  {px} (Px*) {px; Hx} "
axiomatization where
Repetition : "[| {px, py} (Px || Py) {px, py; Hx, Hy};
                 |- Hx [^] Hx [-->] Hx; |- Hy [^] Hy [-->] Hy|]
           ==>  {px, py} ((Px*) || (Py*)) {px, py; Hx, Hy} "

(*Consequence rule*)
axiomatization where
ConsequenceS : "[| {px} P {qx; Hx}; |- ((p [-->] px) [&] (qx [-->] q) [&] (Hx [-->] H))|]
            ==> {p} P {q; H}"
and
ConsequenceP : "[| {px, py} (Px || Py) {qx, qy; Hx, Hy};
                   |- ((p [-->] px) [&] (r [-->] py) [&] (qx [-->] q) [&] (qy [-->] s)
                       [&] (Hx [-->] H) [&] (Hy [-->] G))|]
            ==> {p, r} (Px || Py) {q, s; H, G}"

end


section \<open>Constructs for Describing Communication\<close>

theory "Network_Equivalences-Communication"
  imports "Thorn_Calculus.Thorn_Calculus-Core_Bisimilarities"
begin

subsection \<open>Distributors\<close>

definition distributor :: "chan family \<Rightarrow> chan family list \<Rightarrow> process family" (infix \<open>\<Rightarrow>\<close> 52) where
  [simp]: "A \<Rightarrow> Bs = A \<triangleright>\<^sup>\<infinity> x. \<Prod>B \<leftarrow> Bs. B \<triangleleft> \<box> x"

lemma adapted_after_distributor:
  shows "(A \<Rightarrow> Bs) \<guillemotleft> \<E> = A \<guillemotleft> \<E> \<Rightarrow> map (\<lambda>B. B \<guillemotleft> \<E>) Bs"
  sorry

lemma distributor_idempotency [thorn_simps]:
  shows "A \<Rightarrow> Bs \<parallel> A \<Rightarrow> Bs \<sim>\<^sub>s A \<Rightarrow> Bs"
  unfolding distributor_def
  using repeated_receive_idempotency .

lemma distributor_nested_idempotency [thorn_simps]:
  shows "A \<Rightarrow> Bs \<parallel> (A \<Rightarrow> Bs \<parallel> P) \<sim>\<^sub>s A \<Rightarrow> Bs \<parallel> P"
  unfolding distributor_def
  using repeated_receive_nested_idempotency .

(*FIXME: Check whether we should add this lemma to \<^theory_text>\<open>thorn_simps\<close>. *)
lemma inner_distributor_redundancy:
  shows "A \<Rightarrow> Bs \<parallel> C \<triangleright>\<^sup>\<infinity> x. (A \<Rightarrow> Bs \<parallel> \<P> x) \<sim>\<^sub>s A \<Rightarrow> Bs \<parallel> C \<triangleright>\<^sup>\<infinity> x. \<P> x"
  unfolding distributor_def
  using inner_repeated_receive_redundancy .

subsection \<open>Loss Servers\<close>

definition loss :: "chan family \<Rightarrow> process family" (\<open>\<currency>\<^sup>?\<close>) where
  [simp]: "\<currency>\<^sup>? A = A \<Rightarrow> []"

lemma adapted_after_loss:
  shows "\<currency>\<^sup>? A \<guillemotleft> \<E> = \<currency>\<^sup>? (A \<guillemotleft> \<E>)"
  by (simp del: distributor_def add: adapted_after_distributor)

lemma loss_idempotency [thorn_simps]:
  shows "\<currency>\<^sup>? A \<parallel> \<currency>\<^sup>? A \<sim>\<^sub>s \<currency>\<^sup>? A"
  unfolding loss_def
  using distributor_idempotency .

lemma loss_nested_idempotency [thorn_simps]:
  shows "\<currency>\<^sup>? A \<parallel> (\<currency>\<^sup>? A \<parallel> P) \<sim>\<^sub>s \<currency>\<^sup>? A \<parallel> P"
  unfolding loss_def
  using distributor_nested_idempotency .

lemma inner_loss_redundancy:
  shows "\<currency>\<^sup>? A \<parallel> B \<triangleright>\<^sup>\<infinity> x. (\<currency>\<^sup>? A \<parallel> \<P> x) \<sim>\<^sub>s \<currency>\<^sup>? A \<parallel> B \<triangleright>\<^sup>\<infinity> x. \<P> x"
  unfolding loss_def
  using inner_distributor_redundancy .

subsection \<open>Duplication Servers\<close>

definition duplication :: "chan family \<Rightarrow> process family" (\<open>\<currency>\<^sup>+\<close>) where
  [simp]: "\<currency>\<^sup>+ A = A \<Rightarrow> [A, A]"

lemma adapted_after_duplication:
  shows "\<currency>\<^sup>+ A \<guillemotleft> \<E> = \<currency>\<^sup>+ (A \<guillemotleft> \<E>)"
  by (simp del: distributor_def add: adapted_after_distributor)

lemma duplication_idempotency [thorn_simps]:
  shows "\<currency>\<^sup>+ A \<parallel> \<currency>\<^sup>+ A \<sim>\<^sub>s \<currency>\<^sup>+ A"
  unfolding duplication_def
  using distributor_idempotency .

lemma duplication_nested_idempotency [thorn_simps]:
  shows "\<currency>\<^sup>+ A \<parallel> (\<currency>\<^sup>+ A \<parallel> P) \<sim>\<^sub>s \<currency>\<^sup>+ A \<parallel> P"
  unfolding duplication_def
  using distributor_nested_idempotency .

lemma inner_duplication_redundancy:
  shows "\<currency>\<^sup>+ A \<parallel> B \<triangleright>\<^sup>\<infinity> x. (\<currency>\<^sup>+ A \<parallel> \<P> x) \<sim>\<^sub>s \<currency>\<^sup>+ A \<parallel> B \<triangleright>\<^sup>\<infinity> x. \<P> x"
  unfolding duplication_def
  using inner_distributor_redundancy .

lemma repeated_receive_split:
  assumes "\<And>x. \<P> x \<rightarrow>\<^sub>s\<lparr>\<tau>\<rparr> \<zero>" and "\<And>x. \<Q> x \<rightarrow>\<^sub>s\<lparr>\<tau>\<rparr> \<zero>"
  shows "\<currency>\<^sup>+ A \<parallel> A \<triangleright>\<^sup>\<infinity> x. (\<P> x \<parallel> \<Q> x) \<approx>\<^sub>s \<currency>\<^sup>+ A \<parallel> A \<triangleright>\<^sup>\<infinity> x. \<P> x \<parallel> A \<triangleright>\<^sup>\<infinity> x. \<Q> x"
  sorry

subsection \<open>Duploss Servers\<close>

definition duploss :: "chan family \<Rightarrow> process family" (\<open>\<currency>\<^sup>*\<close>) where
  [simp]: "\<currency>\<^sup>* A = \<currency>\<^sup>? A \<parallel> \<currency>\<^sup>+ A"

lemma adapted_after_duploss:
  shows "\<currency>\<^sup>* A \<guillemotleft> \<E> = \<currency>\<^sup>* (A \<guillemotleft> \<E>)"
  by (simp only: duploss_def adapted_after_parallel adapted_after_loss adapted_after_duplication)

lemma duploss_idempotency [thorn_simps]:
  shows "\<currency>\<^sup>* A \<parallel> \<currency>\<^sup>* A \<sim>\<^sub>s \<currency>\<^sup>* A"
  unfolding duploss_def
  using thorn_simps
  by equivalence

lemma duploss_nested_idempotency [thorn_simps]:
  shows "\<currency>\<^sup>* A \<parallel> (\<currency>\<^sup>* A \<parallel> P) \<sim>\<^sub>s \<currency>\<^sup>* A \<parallel> P"
  unfolding duploss_def
  using thorn_simps
  by equivalence

(*FIXME:
  Simplify the proof of the following lemma once #231 is resolved.

  In particular, do the following:

    \<^item> Turn the detailed proofs that involve
      \<^theory_text>\<open>repeated_receive_is_quasi_compatible_with_synchronous_bisimilarity\<close> into single-step proofs
      that use the \<^theory_text>\<open>bisimilarity\<close> proof method.

    \<^item> Merge the resulting proofs with adjacent proofs if \<^theory_text>\<open>bisimilarity\<close> can solve the whole step.

    \<^item> Merge applications of \<^theory_text>\<open>parallel_commutativity\<close> and \<^theory_text>\<open>parallel_associativity\<close> when possible.

    \<^item> Get rid of applications of compatibility rules whenever \<^theory_text>\<open>bisimilarity\<close> can be used instead.
*)
lemma inner_duploss_redundancy:
  shows "\<currency>\<^sup>* A \<parallel> B \<triangleright>\<^sup>\<infinity> x. (\<currency>\<^sup>* A \<parallel> \<P> x) \<sim>\<^sub>s \<currency>\<^sup>* A \<parallel> B \<triangleright>\<^sup>\<infinity> x. \<P> x"
proof -
  have "
    post_receive n X (\<lambda>x. (\<currency>\<^sup>? A \<parallel> \<currency>\<^sup>+ A) \<parallel> \<P> x)
    \<sim>\<^sub>s
    post_receive n X (\<lambda>x. \<currency>\<^sup>? A \<parallel> (\<currency>\<^sup>+ A \<parallel> \<P> x))"
    for n and X
  proof -
    have "
      (\<lambda>e. (((\<currency>\<^sup>? A \<parallel> \<currency>\<^sup>+ A) \<parallel> \<P> (X e)) \<guillemotleft> suffix n) e)
      =
      (\<lambda>e. ((\<currency>\<^sup>? A \<guillemotleft> suffix n \<parallel> \<currency>\<^sup>+ A \<guillemotleft> suffix n) \<parallel> \<P> (X e) \<guillemotleft> suffix n) e)"
      by (simp only: adapted_after_parallel)
    also have "\<dots> = (\<currency>\<^sup>? A \<guillemotleft> suffix n \<parallel> \<currency>\<^sup>+ A \<guillemotleft> suffix n) \<parallel> (\<lambda>e. (\<P> (X e) \<guillemotleft> suffix n) e)"
      by (subst environment_dependent_parallel) (fact refl)
    also have "\<dots> \<sim>\<^sub>s \<currency>\<^sup>? A \<guillemotleft> suffix n \<parallel> (\<currency>\<^sup>+ A \<guillemotleft> suffix n \<parallel> (\<lambda>e. (\<P> (X e) \<guillemotleft> suffix n) e))"
      using parallel_associativity .
    also have "\<dots> = (\<lambda>e. (\<currency>\<^sup>? A \<guillemotleft> suffix n \<parallel> (\<currency>\<^sup>+ A \<guillemotleft> suffix n \<parallel> \<P> (X e) \<guillemotleft> suffix n)) e)"
      by
        (subst (3) environment_dependent_parallel, subst (4) environment_dependent_parallel)
        (fact refl)
    also have "\<dots> = (\<lambda>e. ((\<currency>\<^sup>? A \<parallel> (\<currency>\<^sup>+ A \<parallel> \<P> (X e))) \<guillemotleft> suffix n) e)"
      by (simp only: adapted_after_parallel)
    finally show ?thesis
      unfolding post_receive_def .
  qed
  then have "
    (\<currency>\<^sup>? A \<parallel> \<currency>\<^sup>+ A) \<parallel> B \<triangleright>\<^sup>\<infinity> x. ((\<currency>\<^sup>? A \<parallel> \<currency>\<^sup>+ A) \<parallel> \<P> x)
    \<sim>\<^sub>s
    (\<currency>\<^sup>? A \<parallel> \<currency>\<^sup>+ A) \<parallel> B \<triangleright>\<^sup>\<infinity> x. (\<currency>\<^sup>? A \<parallel> (\<currency>\<^sup>+ A \<parallel> \<P> x))"
    by
      (intro
        synchronous.parallel_is_right_compatible_with_bisimilarity
        synchronous.repeated_receive_is_quasi_compatible_with_bisimilarity
      )
      simp
  also have "\<dots> \<sim>\<^sub>s \<currency>\<^sup>+ A \<parallel> (\<currency>\<^sup>? A \<parallel> B \<triangleright>\<^sup>\<infinity> x. (\<currency>\<^sup>? A \<parallel> (\<currency>\<^sup>+ A \<parallel> \<P> x)))"
    using thorn_simps
    by equivalence
  also have "\<dots> \<sim>\<^sub>s \<currency>\<^sup>+ A \<parallel> (\<currency>\<^sup>? A \<parallel> B \<triangleright>\<^sup>\<infinity> x. (\<currency>\<^sup>+ A \<parallel> \<P> x))"
    using inner_loss_redundancy
    by (rule synchronous.parallel_is_right_compatible_with_bisimilarity)
  also have "\<dots> \<sim>\<^sub>s \<currency>\<^sup>? A \<parallel> (\<currency>\<^sup>+ A \<parallel> B \<triangleright>\<^sup>\<infinity> x. (\<currency>\<^sup>+ A \<parallel> \<P> x))"
    using parallel_left_commutativity .
  also have "\<dots> \<sim>\<^sub>s \<currency>\<^sup>? A \<parallel> (\<currency>\<^sup>+ A \<parallel> B \<triangleright>\<^sup>\<infinity> x. \<P> x)"
    using inner_duplication_redundancy
    by (rule synchronous.parallel_is_right_compatible_with_bisimilarity)
  also have "\<dots> \<sim>\<^sub>s (\<currency>\<^sup>? A \<parallel> \<currency>\<^sup>+ A) \<parallel> B \<triangleright>\<^sup>\<infinity> x. \<P> x"
    using parallel_associativity
    by equivalence
  finally show ?thesis
  unfolding duploss_def .
qed

lemma send_idempotency_under_duploss:
  shows "\<currency>\<^sup>* A \<parallel> A \<triangleleft> X \<parallel> A \<triangleleft> X \<approx>\<^sub>s \<currency>\<^sup>* A \<parallel> A \<triangleleft> X"
  sorry

subsection \<open>Unidirectional Bridges\<close>

definition
  unidirectional_bridge :: "chan family \<Rightarrow> chan family \<Rightarrow> process family"
  (infix \<open>\<rightarrow>\<close> 52)
where
  [simp]: "A \<rightarrow> B = A \<Rightarrow> [B]"

lemma adapted_after_unidirectional_bridge:
  shows "(A \<rightarrow> B) \<guillemotleft> \<E> = A \<guillemotleft> \<E> \<rightarrow> B \<guillemotleft> \<E>"
  by (simp del: distributor_def add: adapted_after_distributor)

lemma unidirectional_bridge_idempotency [thorn_simps]:
  shows "A \<rightarrow> B \<parallel> A \<rightarrow> B \<sim>\<^sub>s A \<rightarrow> B"
  unfolding unidirectional_bridge_def
  using distributor_idempotency .

lemma unidirectional_bridge_nested_idempotency [thorn_simps]:
  shows "A \<rightarrow> B \<parallel> (A \<rightarrow> B \<parallel> P) \<sim>\<^sub>s A \<rightarrow> B \<parallel> P"
  unfolding unidirectional_bridge_def
  using distributor_nested_idempotency .

lemma inner_unidirectional_bridge_redundancy:
  shows "A \<rightarrow> B \<parallel> C \<triangleright>\<^sup>\<infinity> x. (A \<rightarrow> B \<parallel> \<P> x) \<sim>\<^sub>s A \<rightarrow> B \<parallel> C \<triangleright>\<^sup>\<infinity> x. \<P> x"
  unfolding unidirectional_bridge_def
  using inner_distributor_redundancy .

lemma repeated_receive_shortcut_redundancy:
  shows "A \<rightarrow> B \<parallel> B \<triangleright>\<^sup>\<infinity> x. \<P> x \<parallel> A \<triangleright>\<^sup>\<infinity> x. \<P> x \<approx>\<^sub>s A \<rightarrow> B \<parallel> B \<triangleright>\<^sup>\<infinity> x. \<P> x"
  sorry

lemma distributor_shortcut_redundancy:
  shows "A \<rightarrow> B \<parallel> B \<Rightarrow> Cs \<parallel> A \<Rightarrow> Cs \<approx>\<^sub>s A \<rightarrow> B \<parallel> B \<Rightarrow> Cs"
  unfolding distributor_def
  using repeated_receive_shortcut_redundancy .

lemma unidirectional_bridge_shortcut_redundancy:
  shows "A \<rightarrow> B \<parallel> B \<rightarrow> C \<parallel> A \<rightarrow> C \<approx>\<^sub>s A \<rightarrow> B \<parallel> B \<rightarrow> C"
  using distributor_shortcut_redundancy
  unfolding unidirectional_bridge_def .

lemma loop_redundancy_under_duploss:
  shows "\<currency>\<^sup>* A \<parallel> A \<rightarrow> A \<approx>\<^sub>s \<currency>\<^sup>* A"
  sorry

lemma sidetrack_redundancy:
  shows "\<Prod>B \<leftarrow> Bs. \<currency>\<^sup>? B \<parallel> A \<Rightarrow> (B\<^sub>0 # Bs) \<parallel> A \<rightarrow> B\<^sub>0 \<approx>\<^sub>s \<Prod>B \<leftarrow> Bs. \<currency>\<^sup>? B \<parallel> A \<Rightarrow> (B\<^sub>0 # Bs)"
  sorry

lemma distributor_split:
  shows "\<currency>\<^sup>+ A \<parallel> \<Prod>B \<leftarrow> Bs. \<currency>\<^sup>? B \<parallel> A \<Rightarrow> Bs \<approx>\<^sub>s \<currency>\<^sup>+ A \<parallel> \<Prod>B \<leftarrow> Bs. \<currency>\<^sup>? B \<parallel> \<Prod>B \<leftarrow> Bs. A \<rightarrow> B"
  sorry

subsection \<open>Bidirectional Bridges\<close>

definition
  bidirectional_bridge :: "chan family \<Rightarrow> chan family \<Rightarrow> process family"
  (infix \<open>\<leftrightarrow>\<close> 52)
where
  [simp]: "A \<leftrightarrow> B = A \<rightarrow> B \<parallel> B \<rightarrow> A"

lemma adapted_after_bidirectional_bridge:
  shows "(A \<leftrightarrow> B) \<guillemotleft> \<E> = A \<guillemotleft> \<E> \<leftrightarrow> B \<guillemotleft> \<E>"
  by (simp only: bidirectional_bridge_def adapted_after_parallel adapted_after_unidirectional_bridge)

lemma bidirectional_bridge_idempotency [thorn_simps]:
  shows "A \<leftrightarrow> B \<parallel> A \<leftrightarrow> B \<sim>\<^sub>s A \<leftrightarrow> B"
  unfolding bidirectional_bridge_def
  using thorn_simps
  by equivalence

lemma bidirectional_bridge_nested_idempotency [thorn_simps]:
  shows "A \<leftrightarrow> B \<parallel> (A \<leftrightarrow> B \<parallel> P) \<sim>\<^sub>s A \<leftrightarrow> B \<parallel> P"
  unfolding bidirectional_bridge_def
  using thorn_simps
  by equivalence

lemma inner_bidirectional_bridge_redundancy:
  shows "A \<leftrightarrow> B \<parallel> C \<triangleright>\<^sup>\<infinity> x. (A \<leftrightarrow> B \<parallel> \<P> x) \<sim>\<^sub>s A \<leftrightarrow> B \<parallel> C \<triangleright>\<^sup>\<infinity> x. \<P> x"
proof -
  have "
    post_receive n X (\<lambda>x. (A \<rightarrow> B \<parallel> B \<rightarrow> A) \<parallel> \<P> x)
    \<sim>\<^sub>s
    post_receive n X (\<lambda>x. A \<rightarrow> B \<parallel> (B \<rightarrow> A \<parallel> \<P> x))"
    for n and X
  proof -
    have "
      (\<lambda>e. (((A \<rightarrow> B \<parallel> B \<rightarrow> A) \<parallel> \<P> (X e)) \<guillemotleft> suffix n) e)
      =
      (\<lambda>e. (((A \<rightarrow> B) \<guillemotleft> suffix n \<parallel> (B \<rightarrow> A) \<guillemotleft> suffix n) \<parallel> \<P> (X e) \<guillemotleft> suffix n) e)"
      by (simp only: adapted_after_parallel)
    also have "\<dots> = ((A \<rightarrow> B) \<guillemotleft> suffix n \<parallel> (B \<rightarrow> A) \<guillemotleft> suffix n) \<parallel> (\<lambda>e. (\<P> (X e) \<guillemotleft> suffix n) e)"
      by (subst environment_dependent_parallel) (fact refl)
    also have "\<dots> \<sim>\<^sub>s (A \<rightarrow> B) \<guillemotleft> suffix n \<parallel> ((B \<rightarrow> A) \<guillemotleft> suffix n \<parallel> (\<lambda>e. (\<P> (X e) \<guillemotleft> suffix n) e))"
      using parallel_associativity .
    also have "\<dots> = (\<lambda>e. ((A \<rightarrow> B) \<guillemotleft> suffix n \<parallel> ((B \<rightarrow> A) \<guillemotleft> suffix n \<parallel> \<P> (X e) \<guillemotleft> suffix n)) e)"
      by
        (subst (3) environment_dependent_parallel, subst (4) environment_dependent_parallel)
        (fact refl)
    also have "\<dots> = (\<lambda>e. ((A \<rightarrow> B \<parallel> (B \<rightarrow> A \<parallel> \<P> (X e))) \<guillemotleft> suffix n) e)"
      by (simp only: adapted_after_parallel)
    finally show ?thesis
      unfolding post_receive_def .
  qed
  then have "
    (A \<rightarrow> B \<parallel> B \<rightarrow> A) \<parallel> C \<triangleright>\<^sup>\<infinity> x. ((A \<rightarrow> B \<parallel> B \<rightarrow> A) \<parallel> \<P> x)
    \<sim>\<^sub>s
    (A \<rightarrow> B \<parallel> B \<rightarrow> A) \<parallel> C \<triangleright>\<^sup>\<infinity> x. (A \<rightarrow> B \<parallel> (B \<rightarrow> A \<parallel> \<P> x))"
    by
      (intro
        synchronous.parallel_is_right_compatible_with_bisimilarity
        synchronous.repeated_receive_is_quasi_compatible_with_bisimilarity
      )
      simp
  also have "\<dots> \<sim>\<^sub>s B \<rightarrow> A \<parallel> (A \<rightarrow> B \<parallel> C \<triangleright>\<^sup>\<infinity> x. (A \<rightarrow> B \<parallel> (B \<rightarrow> A \<parallel> \<P> x)))"
    using thorn_simps
    by equivalence
  also have "\<dots> \<sim>\<^sub>s B \<rightarrow> A \<parallel> (A \<rightarrow> B \<parallel> C \<triangleright>\<^sup>\<infinity> x. (B \<rightarrow> A \<parallel> \<P> x))"
    using inner_unidirectional_bridge_redundancy
    by (rule synchronous.parallel_is_right_compatible_with_bisimilarity)
  also have "\<dots> \<sim>\<^sub>s A \<rightarrow> B \<parallel> (B \<rightarrow> A \<parallel> C \<triangleright>\<^sup>\<infinity> x. (B \<rightarrow> A \<parallel> \<P> x))"
    using parallel_left_commutativity .
  also have "\<dots> \<sim>\<^sub>s A \<rightarrow> B \<parallel> (B \<rightarrow> A \<parallel> C \<triangleright>\<^sup>\<infinity> x. \<P> x)"
    using inner_unidirectional_bridge_redundancy
    by (rule synchronous.parallel_is_right_compatible_with_bisimilarity)
  also have "\<dots> \<sim>\<^sub>s (A \<rightarrow> B \<parallel> B \<rightarrow> A) \<parallel> C \<triangleright>\<^sup>\<infinity> x. \<P> x"
    using thorn_simps
    by equivalence
  finally show ?thesis
    unfolding bidirectional_bridge_def .
qed

lemma bidirectional_bridge_commutativity [thorn_simps]:
  shows "A \<leftrightarrow> B \<sim>\<^sub>s B \<leftrightarrow> A"
  unfolding bidirectional_bridge_def
  using parallel_commutativity .

lemma forward_bridge_absorption:
  shows "A \<leftrightarrow> B \<parallel> A \<rightarrow> B \<sim>\<^sub>s A \<leftrightarrow> B"
  unfolding bidirectional_bridge_def
  using thorn_simps
  by equivalence

lemma backward_bridge_absorption:
  shows "A \<leftrightarrow> B \<parallel> B \<rightarrow> A \<sim>\<^sub>s A \<leftrightarrow> B"
  unfolding bidirectional_bridge_def
  using thorn_simps
  by equivalence

lemma send_channel_switch:
  shows "A \<leftrightarrow> B \<parallel> A \<triangleleft> X \<approx>\<^sub>s A \<leftrightarrow> B \<parallel> B \<triangleleft> X"
  sorry

lemma receive_channel_switch:
  shows "A \<leftrightarrow> B \<parallel> A \<triangleright> x. \<P> x \<approx>\<^sub>s A \<leftrightarrow> B \<parallel> B \<triangleright> x. \<P> x"
  sorry

lemma general_parallel_channel_switch:
  assumes "\<And>x. fst x \<leftrightarrow> snd x \<parallel> \<P> (fst x) \<approx>\<^sub>s fst x \<leftrightarrow> snd x \<parallel> \<P> (snd x)"
  shows "\<Prod>v \<leftarrow> vs. fst v \<leftrightarrow> snd v \<parallel> \<Prod>v \<leftarrow> vs. \<P> (fst v) \<approx>\<^sub>s \<Prod>v \<leftarrow> vs. fst v \<leftrightarrow> snd v \<parallel> \<Prod>v \<leftarrow> vs. \<P> (snd v)"
proof (induction vs)
  case Nil
  show ?case
    unfolding general_parallel.simps(1)
    by equivalence
next
  case (Cons v vs)
  have "
    (fst v \<leftrightarrow> snd v \<parallel> \<Prod>v \<leftarrow> vs. fst v \<leftrightarrow> snd v) \<parallel> \<P> (fst v) \<parallel> \<Prod>x \<leftarrow> vs. \<P> (fst x)
    \<approx>\<^sub>s
    (fst v \<leftrightarrow> snd v \<parallel> \<P> (fst v)) \<parallel> (\<Prod>x \<leftarrow> vs. fst x \<leftrightarrow> snd x \<parallel> \<Prod>x \<leftarrow> vs. \<P> (fst x))"
    using thorn_simps
    by equivalence
  also have "\<dots> \<approx>\<^sub>s (fst v \<leftrightarrow> snd v \<parallel> \<P> (snd v)) \<parallel> (\<Prod>v \<leftarrow> vs. fst v \<leftrightarrow> snd v \<parallel> \<Prod>v \<leftarrow> vs. \<P> (snd v))"
    using assms and Cons.IH
    by (rule synchronous.weak.parallel_is_compatible_with_bisimilarity)
  also have "\<dots> \<approx>\<^sub>s (fst v \<leftrightarrow> snd v \<parallel> \<Prod>v \<leftarrow> vs. fst v \<leftrightarrow> snd v) \<parallel> (\<P> (snd v) \<parallel> \<Prod>v \<leftarrow> vs. \<P> (snd v))"
    using thorn_simps
    by equivalence
  finally show ?case
    unfolding general_parallel.simps(2) .
qed

lemma repeated_receive_channel_switch:
  shows "A \<leftrightarrow> B \<parallel> A \<triangleright>\<^sup>\<infinity> x. \<P> x \<approx>\<^sub>s A \<leftrightarrow> B \<parallel> B \<triangleright>\<^sup>\<infinity> x. \<P> x"
  sorry

lemma distributor_source_switch:
  shows "A \<leftrightarrow> B \<parallel> A \<Rightarrow> Cs \<approx>\<^sub>s A \<leftrightarrow> B \<parallel> B \<Rightarrow> Cs"
  unfolding distributor_def
  using repeated_receive_channel_switch .

(*FIXME:
  Simplify the proof of the following lemma once #231 is resolved.

  In particular, do the following:

    \<^item> Turn the detailed proofs that involve
      \<^theory_text>\<open>repeated_receive_is_quasi_compatible_with_synchronous_bisimilarity\<close> into single-step proofs
      that use the \<^theory_text>\<open>bisimilarity\<close> proof method.

    \<^item> Merge the resulting proofs with adjacent proofs if \<^theory_text>\<open>bisimilarity\<close> can solve the whole step.

    \<^item> Merge applications of \<^theory_text>\<open>parallel_commutativity\<close> and \<^theory_text>\<open>parallel_associativity\<close> when possible.

    \<^item> Get rid of applications of compatibility rules whenever \<^theory_text>\<open>bisimilarity\<close> can be used instead.
*)
(*FIXME:
  The following proof uses \<^theory_text>\<open>general_parallel_conversion_deferral\<close> twice. Check whether this is
  unnecessary and, if yes, whether it should be avoided.
*)
lemma distributor_target_switch:
  shows
    "\<Prod>v \<leftarrow> vs. fst v \<leftrightarrow> snd v \<parallel> A \<Rightarrow> map fst vs \<approx>\<^sub>s \<Prod>v \<leftarrow> vs. fst v \<leftrightarrow> snd v \<parallel> A \<Rightarrow> map snd vs"
    (is "?\<P> vs \<parallel> _ \<approx>\<^sub>s ?\<P> vs \<parallel> _")
proof -
  \<comment> \<open>Specializations of lemmas:\<close>
  have inner_target_bridges_redundancy:
    "?\<P> vs \<parallel> A \<triangleright>\<^sup>\<infinity> y. (?\<P> vs \<parallel> \<Q> y) \<sim>\<^sub>s ?\<P> vs \<parallel> A \<triangleright>\<^sup>\<infinity> y. \<Q> y" for \<Q>
    using inner_bidirectional_bridge_redundancy
    by (rule inner_general_parallel_redundancy)
  have targets_switch:
    "?\<P> ws \<parallel> \<Prod>w \<leftarrow> ws. fst w \<triangleleft> Y \<approx>\<^sub>s ?\<P> ws \<parallel> \<Prod>w \<leftarrow> ws. snd w \<triangleleft> Y" for ws and Y
    using send_channel_switch
    by (rule general_parallel_channel_switch)
  have post_receive_targets_switch: "
    post_receive n X (\<lambda>x. ?\<P> vs \<parallel> \<Prod>v \<leftarrow> vs. fst v \<triangleleft> \<box> x)
    \<approx>\<^sub>s
    post_receive n X (\<lambda>x. ?\<P> vs \<parallel> \<Prod>v \<leftarrow> vs. snd v \<triangleleft> \<box> x)"
    for n and X
  proof -
    let ?ws = "map (\<lambda>v. (fst v \<guillemotleft> suffix n, snd v \<guillemotleft> suffix n)) vs"
    have "
      (\<lambda>e. ((?\<P> vs \<parallel> \<Prod>v \<leftarrow> vs. fst v \<triangleleft> \<box> (X e)) \<guillemotleft> suffix n) e)
      =
      (\<lambda>e. (\<Prod>v \<leftarrow> vs. fst v \<guillemotleft> suffix n \<leftrightarrow> snd v \<guillemotleft> suffix n \<parallel> \<Prod>v \<leftarrow> vs. fst v \<guillemotleft> suffix n \<triangleleft> \<box> (X e) \<guillemotleft> suffix n) e)"
      by
        (simp only:
          adapted_after_parallel
          adapted_after_general_parallel
          adapted_after_bidirectional_bridge
          adapted_after_send
        )
    also have "\<dots> = \<Prod>v \<leftarrow> vs. fst v \<guillemotleft> suffix n \<leftrightarrow> snd v \<guillemotleft> suffix n \<parallel> \<Prod>v \<leftarrow> vs. fst v \<guillemotleft> suffix n \<triangleleft> X"
      by
        (
          subst environment_dependent_parallel,
          subst (2) environment_dependent_general_parallel,
          subst environment_dependent_send,
          transfer,
          simp only: comp_def constant_family_def
        )
    also have "\<dots> = \<Prod>w \<leftarrow> ?ws. fst w \<leftrightarrow> snd w \<parallel> \<Prod>w \<leftarrow> ?ws. fst w \<triangleleft> X"
      by (simp only: general_parallel_conversion_deferral fst_conv snd_conv)
    also have "\<dots> \<approx>\<^sub>s \<Prod>w \<leftarrow> ?ws. fst w \<leftrightarrow> snd w \<parallel> \<Prod>w \<leftarrow> ?ws. snd w \<triangleleft> X"
      using general_parallel_channel_switch [OF send_channel_switch] .
    also have "\<dots> = \<Prod>v \<leftarrow> vs. fst v \<guillemotleft> suffix n \<leftrightarrow> snd v \<guillemotleft> suffix n \<parallel> \<Prod>v \<leftarrow> vs. snd v \<guillemotleft> suffix n \<triangleleft> X"
      by (simp only: general_parallel_conversion_deferral fst_conv snd_conv)
    also have "\<dots> = (\<lambda>e. (\<Prod>v \<leftarrow> vs. fst v \<guillemotleft> suffix n \<leftrightarrow> snd v \<guillemotleft> suffix n \<parallel> \<Prod>v \<leftarrow> vs. snd v \<guillemotleft> suffix n \<triangleleft> \<box> (X e) \<guillemotleft> suffix n) e)"
      by
        (
          subst (2) environment_dependent_parallel,
          subst (4) environment_dependent_general_parallel,
          subst (2) environment_dependent_send,
          transfer,
          simp only: comp_def constant_family_def
        )
    also have "\<dots> = (\<lambda>e. ((?\<P> vs \<parallel> \<Prod>v \<leftarrow> vs. snd v \<triangleleft> \<box> (X e)) \<guillemotleft> suffix n) e)"
      by
        (simp only:
          adapted_after_parallel
          adapted_after_general_parallel
          adapted_after_bidirectional_bridge
          adapted_after_send
        )
    finally show ?thesis
      unfolding post_receive_def .
  qed
  \<comment> \<open>The actual proof:\<close>
  have "?\<P> vs \<parallel> A \<triangleright>\<^sup>\<infinity> y. \<Prod>v \<leftarrow> vs. fst v \<triangleleft> \<box> y \<approx>\<^sub>s ?\<P> vs \<parallel> A \<triangleright>\<^sup>\<infinity> y. (?\<P> vs \<parallel> \<Prod>v \<leftarrow> vs. fst v \<triangleleft> \<box> y)"
    by
      (
        rule synchronous.bisimilarity_in_weak_bisimilarity [THEN predicate2D],
        rule synchronous.bisimilarity_symmetry_rule
      )
      (fact inner_target_bridges_redundancy)
  also have "\<dots> \<approx>\<^sub>s ?\<P> vs \<parallel> A \<triangleright>\<^sup>\<infinity> y. (?\<P> vs \<parallel> \<Prod>v \<leftarrow> vs. snd v \<triangleleft> \<box> y)"
    using post_receive_targets_switch
    by
      (intro
        synchronous.weak.parallel_is_right_compatible_with_bisimilarity
        synchronous.weak.repeated_receive_is_quasi_compatible_with_bisimilarity
      )
      simp
  also have "\<dots> \<approx>\<^sub>s ?\<P> vs \<parallel> A \<triangleright>\<^sup>\<infinity> y. \<Prod>v \<leftarrow> vs. snd v \<triangleleft> \<box> y"
    by
      (rule synchronous.bisimilarity_in_weak_bisimilarity [THEN predicate2D])
      (fact inner_target_bridges_redundancy)
  finally show ?thesis
    unfolding distributor_def and general_parallel_conversion_deferral .
qed

lemma loss_channel_switch:
  shows "A \<leftrightarrow> B \<parallel> \<currency>\<^sup>? A \<approx>\<^sub>s A \<leftrightarrow> B \<parallel> \<currency>\<^sup>? B"
  unfolding loss_def using distributor_source_switch .

lemma duplication_channel_switch:
  shows "A \<leftrightarrow> B \<parallel> \<currency>\<^sup>+ A \<approx>\<^sub>s A \<leftrightarrow> B \<parallel> \<currency>\<^sup>+ B"
proof -
  have "A \<leftrightarrow> B \<parallel> A \<Rightarrow> [A, A] \<approx>\<^sub>s A \<leftrightarrow> B \<parallel> B \<Rightarrow> [A, A]"
    using distributor_source_switch .
  also have "\<dots> \<approx>\<^sub>s (A \<leftrightarrow> B \<parallel> A \<leftrightarrow> B \<parallel> \<zero>) \<parallel> B \<Rightarrow> [A, A]"
    using thorn_simps
    by equivalence
  also have "\<dots> \<approx>\<^sub>s \<Prod>v \<leftarrow> [(A, B), (A, B)]. fst v \<leftrightarrow> snd v \<parallel> B \<Rightarrow> map fst [(A, B), (A, B)]"
    by simp
  also have "\<dots> \<approx>\<^sub>s \<Prod>v \<leftarrow> [(A, B), (A, B)]. fst v \<leftrightarrow> snd v \<parallel> B \<Rightarrow> map snd [(A, B), (A, B)]"
    using distributor_target_switch .
  also have "\<dots> \<approx>\<^sub>s (A \<leftrightarrow> B \<parallel> A \<leftrightarrow> B \<parallel> \<zero>) \<parallel> B \<Rightarrow> [B, B]"
    by simp
  also have "\<dots> \<approx>\<^sub>s A \<leftrightarrow> B \<parallel> B \<Rightarrow> [B, B]"
    using thorn_simps
    by equivalence
  finally show ?thesis
    unfolding duplication_def .
qed

lemma duploss_channel_switch:
  shows "A \<leftrightarrow> B \<parallel> \<currency>\<^sup>* A \<approx>\<^sub>s A \<leftrightarrow> B \<parallel> \<currency>\<^sup>* B"
proof -
  have "A \<leftrightarrow> B \<parallel> (\<currency>\<^sup>? A \<parallel> \<currency>\<^sup>+ A) \<approx>\<^sub>s (A \<leftrightarrow> B \<parallel> \<currency>\<^sup>? A) \<parallel> \<currency>\<^sup>+ A"
    using thorn_simps
    by equivalence
  also have "\<dots> \<approx>\<^sub>s (A \<leftrightarrow> B \<parallel> \<currency>\<^sup>? B) \<parallel> \<currency>\<^sup>+ A"
    using loss_channel_switch
    by (rule synchronous.weak.parallel_is_left_compatible_with_bisimilarity)
  also have "\<dots> \<approx>\<^sub>s \<currency>\<^sup>? B \<parallel> (A \<leftrightarrow> B \<parallel> \<currency>\<^sup>+ A)"
    using thorn_simps
    by equivalence
  also have "\<dots> \<approx>\<^sub>s \<currency>\<^sup>? B \<parallel> (A \<leftrightarrow> B \<parallel> \<currency>\<^sup>+ B)"
    using duplication_channel_switch
    by (rule synchronous.weak.parallel_is_right_compatible_with_bisimilarity)
  also have "\<dots> \<approx>\<^sub>s A \<leftrightarrow> B \<parallel> (\<currency>\<^sup>? B \<parallel> \<currency>\<^sup>+ B)"
    using thorn_simps
    by equivalence
  finally show ?thesis
    unfolding duploss_def .
qed

lemma unidirectional_bridge_source_switch:
  shows "A \<leftrightarrow> B \<parallel> A \<rightarrow> C \<approx>\<^sub>s A \<leftrightarrow> B \<parallel> B \<rightarrow> C"
  unfolding unidirectional_bridge_def
  using distributor_source_switch .

lemma unidirectional_bridge_target_switch:
  shows "A \<leftrightarrow> B \<parallel> C \<rightarrow> A \<approx>\<^sub>s A \<leftrightarrow> B \<parallel> C \<rightarrow> B"
proof -
  have "A \<leftrightarrow> B \<parallel> C \<Rightarrow> [A] \<approx>\<^sub>s (A \<leftrightarrow> B \<parallel> \<zero>) \<parallel> C \<Rightarrow> [A]"
    using thorn_simps
    by equivalence
  also have "\<dots> \<approx>\<^sub>s \<Prod>v \<leftarrow> [(A, B)]. fst v \<leftrightarrow> snd v \<parallel> C \<Rightarrow> map fst [(A, B)]"
    by simp
  also have "\<dots> \<approx>\<^sub>s \<Prod>v \<leftarrow>[(A, B)]. fst v \<leftrightarrow> snd v \<parallel> C \<Rightarrow> map snd [(A, B)]"
    using distributor_target_switch .
  also have "\<dots> \<approx>\<^sub>s (A \<leftrightarrow> B \<parallel> \<zero>) \<parallel> C \<Rightarrow> [B]"
    by simp
  also have "\<dots> \<approx>\<^sub>s A \<leftrightarrow> B \<parallel> C \<Rightarrow> [B]"
    using thorn_simps
    by equivalence
  finally show ?thesis
    unfolding unidirectional_bridge_def .
qed

lemma bidirectional_bridge_source_switch:
  shows "A \<leftrightarrow> B \<parallel> A \<leftrightarrow> C \<approx>\<^sub>s A \<leftrightarrow> B \<parallel> B \<leftrightarrow> C"
proof -
  have "A \<leftrightarrow> B \<parallel> (A \<rightarrow> C \<parallel> C \<rightarrow> A) \<approx>\<^sub>s (A \<leftrightarrow> B \<parallel> A \<rightarrow> C) \<parallel> C \<rightarrow> A"
    using thorn_simps
    by equivalence
  also have "\<dots> \<approx>\<^sub>s (A \<leftrightarrow> B \<parallel> B \<rightarrow> C) \<parallel> C \<rightarrow> A"
    using unidirectional_bridge_source_switch
    by (rule synchronous.weak.parallel_is_left_compatible_with_bisimilarity)
  also have "\<dots> \<approx>\<^sub>s B \<rightarrow> C \<parallel> (A \<leftrightarrow> B \<parallel> C \<rightarrow> A)"
    using thorn_simps
    by equivalence
  also have "\<dots> \<approx>\<^sub>s B \<rightarrow> C \<parallel> (A \<leftrightarrow> B \<parallel> C \<rightarrow> B)"
    using unidirectional_bridge_target_switch
    by (rule synchronous.weak.parallel_is_right_compatible_with_bisimilarity)
  also have "\<dots> \<approx>\<^sub>s A \<leftrightarrow> B \<parallel> (B \<rightarrow> C \<parallel> C \<rightarrow> B)"
    using thorn_simps
    by equivalence
  finally show ?thesis
    unfolding bidirectional_bridge_def .
qed

lemma bidirectional_bridge_target_switch:
  shows "A \<leftrightarrow> B \<parallel> C \<leftrightarrow> A \<approx>\<^sub>s A \<leftrightarrow> B \<parallel> C \<leftrightarrow> B"
proof -
  have "A \<leftrightarrow> B \<parallel> C \<leftrightarrow> A \<approx>\<^sub>s A \<leftrightarrow> B \<parallel> A \<leftrightarrow> C"
    using bidirectional_bridge_commutativity
    by equivalence
  also have "\<dots> \<approx>\<^sub>s A \<leftrightarrow> B \<parallel> B \<leftrightarrow> C"
    using bidirectional_bridge_source_switch .
  also have "\<dots> \<approx>\<^sub>s A \<leftrightarrow> B \<parallel> C \<leftrightarrow> B"
    using bidirectional_bridge_commutativity
    by equivalence
  finally show ?thesis .
qed

lemma detour_squashing:
  shows "\<nu> b. (A \<leftrightarrow> \<box> b) \<approx>\<^sub>s A \<rightarrow> A"
  sorry

(*FIXME:
  Use \<^theory_text>\<open>equivalence\<close> and possible similar proof methods in the following proof once this is possible
  with higher operators like \<open>\<leftrightarrow>\<close>.
*)
lemma duploss_detour_collapse:
  shows "\<nu> b. (\<currency>\<^sup>* (\<box> b) \<parallel> A \<leftrightarrow> \<box> b) \<approx>\<^sub>s \<currency>\<^sup>* A"
proof -
  have "\<nu> b. (\<currency>\<^sup>* (\<box> b) \<parallel> A \<leftrightarrow> \<box> b) \<approx>\<^sub>s \<nu> b. (\<box> b \<leftrightarrow> A \<parallel> \<currency>\<^sup>* (\<box> b))"
    using thorn_simps
    sorry
  also have "\<dots> \<approx>\<^sub>s \<nu> b. (\<box> b \<leftrightarrow> A \<parallel> \<currency>\<^sup>* A)"
    using duploss_channel_switch
    sorry
  also have "\<dots> \<approx>\<^sub>s \<currency>\<^sup>* A \<parallel> \<nu> b. (A \<leftrightarrow> \<box> b)"
    using thorn_simps
    sorry
  also have "\<dots> \<approx>\<^sub>s \<currency>\<^sup>* A \<parallel> A \<rightarrow> A"
    using detour_squashing
    sorry
  also have "\<dots> \<approx>\<^sub>s \<currency>\<^sup>* A"
    using loop_redundancy_under_duploss
    by equivalence
  finally show ?thesis .
qed

end


(*

Copyright (c) 2017, ETH Zurich
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

1. Redistributions of source code must retain the above copyright notice, this
   list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation
   and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

(*<*)
theory ConcreteOps
  imports AbstractOps Syntax
begin
(*>*)

subsection {* Transformations on Abstract Syntax *}
text_raw {* \label{sec:isasplitC} *}

(*<*)
subsubsection {* Node Splitting *}
(*>*)

text {* These are the equivalents, in abstract syntax, of the abstract acceptor
        and translator nodes.  Somewhat confusingly, we will now refer to the
        \emph{abstract} syntax as the \emph{concrete} model (relative to the
        abstract directed graph model).  *}
primrec remap_all :: "nodeid \<Rightarrow> block_spec list \<Rightarrow> map_spec list"
  where "remap_all _ [] = []" |
        "remap_all nd (b#bs) = direct_map b nd # remap_all nd bs"

definition redirector_node_C :: "nodeid \<Rightarrow> node_spec \<Rightarrow> node_spec"
  where "redirector_node_C nd' ns =
          empty_spec \<lparr> map_blocks := remap_all nd' (acc_blocks ns) @ map_blocks ns,
                       overlay := overlay ns \<rparr>"

definition acceptor_node_C :: "node_spec \<Rightarrow> node_spec"
  where "acceptor_node_C ns = empty_spec \<lparr> acc_blocks := acc_blocks ns \<rparr>"

(*<*)
lemma translate_nomap:
  "a \<notin> accept (add_blocks ps bs empty_node) \<Longrightarrow>
   translate (add_maps ps (remap_all nd' bs) node) a = translate node a"
  by(simp add:add_maps_recursive[symmetric], induct bs, simp_all add:mk_map_def direct_map_def)

lemma translate_map:
  "a \<in> accept (add_blocks ps bs empty_node) \<Longrightarrow>
   translate (add_maps ps (remap_all nd' bs) node) a = insert (nd', a) (translate node a)"
proof(induct bs, simp add:accept_empty_node)
  fix b bs
  assume IH: "a \<in> accept (add_blocks ps bs empty_node) \<Longrightarrow>
              translate (add_maps ps (remap_all nd' bs) node) a = insert (nd', a) (translate node a)"

  assume "a \<in> accept (add_blocks ps (b # bs) empty_node)"
  hence either: "a \<in> mk_block ps b \<or> a \<in> accept (add_blocks ps bs empty_node)" by(simp)

  show "translate (add_maps ps (remap_all nd' (b # bs)) node) a = insert (nd', a) (translate node a)"
  proof(cases)
    assume "a \<in> accept (add_blocks ps bs empty_node)"
    thus ?thesis
      apply(simp add:add_maps_recursive[symmetric])
      apply(simp add: IH mk_map_def direct_map_def mk_block_def add_maps_recursive)
      apply(auto)
      done
  next
    assume notin: "a \<notin> accept (add_blocks ps bs empty_node)"
    with either have "a \<in> mk_block ps b" by(blast)
    thus ?thesis
      apply(simp add:add_maps_recursive[symmetric])
      apply(simp add:translate_nomap notin mk_map_def direct_map_def mk_block_def add_maps_recursive)
      apply(auto)
      done
  qed
qed

lemma translate_redirect:
  "a \<in> accept (mk_node ps ns) \<Longrightarrow>
   translate (mk_node ps (redirector_node_C nd' ns)) a = {(nd',a)} \<union> translate (mk_node ps ns) a"
  by(simp add:translate_mk_node redirector_node_C_def add_maps_append accept_mk_node translate_map)

lemma translate_noredirect:
  "a \<notin> accept (mk_node ps ns) \<Longrightarrow> translate (mk_node ps (redirector_node_C nd' ns)) a =
                               translate (mk_node ps ns) a"
  by(simp add:translate_mk_node redirector_node_C_def accept_mk_node add_maps_append translate_nomap)
(*>*)
text {* The concrete redirector node refines the abstract: *}
lemma redirector_rel:
  "mk_node ps (redirector_node_C nd' ns) = redirector_node nd' (mk_node ps ns)"
(*<*)
  (is "?X = ?Y")
proof -
  have "accept ?X = accept ?Y"
    by(simp add:mk_node_def redirector_node_def redirector_node_C_def acc_blocks_empty
                accept_add_maps accept_mk_overlay)
  moreover have "translate ?X = translate ?Y"
  proof(rule ext)
    fix a
    show "translate ?X a = translate ?Y a"
      by(cases "a \<in> accept (mk_node ps ns)",
         simp_all add:redirector_node_def translate_redirect translate_noredirect)
  qed
  ultimately show ?thesis by(simp)
qed
(*>*)
text {* The concrete acceptor node refines the abstract: *}
lemma acceptor_rel:
  "mk_node ps (acceptor_node_C ns) = acceptor_node (mk_node ps ns)"
(*<*)
proof -
  have "translate (mk_node ps (acceptor_node_C ns)) = translate (acceptor_node (mk_node ps ns))"
    by(simp add:acceptor_node_C_def acceptor_node_def translate_mk_node empty_spec_def
                mk_overlay_def add_maps_recursive[symmetric])
  moreover have "accept (mk_node ps (acceptor_node_C ns)) = accept (acceptor_node (mk_node ps ns))"
    by(simp add:acceptor_node_C_def acceptor_node_def accept_mk_node)
  ultimately show ?thesis by(simp)
qed
(*>*)
primrec split_all_C :: "nodeid \<Rightarrow> net_spec \<Rightarrow> net_spec"
  where "split_all_C _ [] = []" |
        "split_all_C off (s#ss) =
          [(off + fst s, acceptor_node_C (snd s)),
           (fst s, redirector_node_C (off + fst s) (snd s))] @ split_all_C off ss"

text {* Thus (by induction), splitting all nodes in the concrete spec is equivalent to doing so
  in the abstract (\autoref{eq:splitrefine}): *}
lemma split_all_rel:
  assumes "distinct (map fst ss)"
      and  "\<And>nd. nd \<in> set (map fst ss) \<Longrightarrow> nd < off"
    shows "mk_net (split_all_C off ss) = split_all (map fst ss) (op + off) (mk_net ss)"
(*<*)
      (is "?X ss = ?Y ss")
  using assms
proof(induct ss, simp)
  fix s ss
  assume distinct: "distinct (map fst (s # ss))"
     and bound: "\<And>nd. nd \<in> set (map fst (s # ss)) \<Longrightarrow> nd < off"
     and IH: "distinct (map fst ss) \<Longrightarrow>
             (\<And>nd. nd \<in> set (map fst ss) \<Longrightarrow> nd < off) \<Longrightarrow>
             ?X ss = ?Y ss"

  have "mk_net (split_all_C off (s # ss)) =
        (mk_net (split_all_C off ss))
          (fst s := redirector_node (off + fst s) (mk_node ALLPROPERTIES (snd s)),
           off + fst s := acceptor_node (mk_node ALLPROPERTIES (snd s)))"
    by(simp add:redirector_rel acceptor_rel)
  also from distinct bound IH
  have "... =
        (?Y ss)
          (fst s := redirector_node (off + fst s) (mk_node ALLPROPERTIES (snd s)),
           off + fst s := acceptor_node (mk_node ALLPROPERTIES (snd s)))"
    by(simp)
  also have "... = split_node (fst s) (off + fst s) ((?Y ss)(fst s := mk_node ALLPROPERTIES (snd s)))"
    by(simp add:split_node_def)
  also {
    let ?prev = "..."
    from distinct bound have "fst s \<notin> set (map fst ss)" "\<And>nd'. off + nd' \<noteq> fst s" by(auto)
    hence "?prev =
      split_node (fst s) (off + fst s) (split_all (map fst ss) (op + off) (mk_net (s#ss)))"
      by(simp add:split_all_upd_comm)
  }
  also have "split_node (fst s) (off + fst s) (split_all (map fst ss) (op + off) (mk_net (s#ss))) =
             split_all (map fst (s # ss)) (op + off) (mk_net (s # ss))"
    by(simp)
  finally show "mk_net (split_all_C off (s # ss)) =
                split_all (map fst (s # ss)) (op + off) (mk_net (s # ss))" .
qed
(*>*)

text {* Finally, we have refinement between the concrete and abstract split operations on whole
  nets (\autoref{eq:fulleq}): *}
definition split_net_C :: "net_spec \<Rightarrow> net_spec"
  where "split_net_C s = split_all_C (ff_net s) s"

lemma split_net_equiv:
  assumes distinct: "distinct (map fst s)"
  shows "view_eq_on {0..<ff_net s} (rename_list (op + (ff_net s)) (map fst s), mk_net s) (id, mk_net (split_net_C s))"
proof -
  text {* The abstract split preserves view equivalence for any node that was defined in the
    original spec: *}
  have "view_eq_on {0..<ff_net s} (rename_list (op + (ff_net s)) (map fst s), mk_net s)
                                  (id, split_all (map fst s) (op + (ff_net s)) (mk_net s))"
    using ff_net_idbound distinct wf_mk_net
    by(intro view_eq_split_all, auto intro:ff_net_fresh view_eq_split_all)

  text {* The concrete split refines the abstract split: *}
  moreover have "mk_net (split_all_C (ff_net s) s) = split_all (map fst s) (op + (ff_net s)) (mk_net s)"
    by(auto intro:split_all_rel distinct ff_net_idbound)

  text {* Thus we have view equivalence for the concrete operation, too. *}
  ultimately show ?thesis by(simp add:split_net_C_def)
qed

(*<*)
end
(*>*)


(*  Title:      HOL/Auth/n_german_lemma_on_inv__4.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_german Protocol Case Study*}

theory n_german_lemma_on_inv__4 imports n_german_base
begin
section{*All lemmas on causal relation between inv__4 and some rule r*}
lemma n_SendInvEVsinv__4:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInvE  i)" and
a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__4  p__Inv3 p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInvE  i" apply fastforce done
from a2 obtain p__Inv3 p__Inv4 where a2:"p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__4  p__Inv3 p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i=p__Inv3)\<or>(i~=p__Inv3\<and>i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv3)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv3\<and>i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInvSVsinv__4:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInvS  i)" and
a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__4  p__Inv3 p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInvS  i" apply fastforce done
from a2 obtain p__Inv3 p__Inv4 where a2:"p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__4  p__Inv3 p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i=p__Inv3)\<or>(i~=p__Inv3\<and>i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv3)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv3\<and>i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInvAckVsinv__4:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)" and
a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__4  p__Inv3 p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInvAck  i" apply fastforce done
from a2 obtain p__Inv3 p__Inv4 where a2:"p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__4  p__Inv3 p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i=p__Inv3)\<or>(i~=p__Inv3\<and>i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv3)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv3\<and>i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntSVsinv__4:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)" and
a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__4  p__Inv3 p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntS  i" apply fastforce done
from a2 obtain p__Inv3 p__Inv4 where a2:"p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__4  p__Inv3 p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i=p__Inv3)\<or>(i~=p__Inv3\<and>i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv3)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv3\<and>i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntEVsinv__4:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)" and
a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__4  p__Inv3 p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntE N i" apply fastforce done
from a2 obtain p__Inv3 p__Inv4 where a2:"p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__4  p__Inv3 p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i=p__Inv3)\<or>(i~=p__Inv3\<and>i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv3)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Ident ''ExGntd'')) (Const false)) (eqn (IVar (Field (Para (Ident ''Cache'') p__Inv4) ''State'')) (Const E))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv3\<and>i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvGntSVsinv__4:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)" and
a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__4  p__Inv3 p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvGntS  i" apply fastforce done
from a2 obtain p__Inv3 p__Inv4 where a2:"p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__4  p__Inv3 p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i=p__Inv3)\<or>(i~=p__Inv3\<and>i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv3)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv3\<and>i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvGntEVsinv__4:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)" and
a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__4  p__Inv3 p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvGntE  i" apply fastforce done
from a2 obtain p__Inv3 p__Inv4 where a2:"p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__4  p__Inv3 p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i=p__Inv3)\<or>(i~=p__Inv3\<and>i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv3) ''Cmd'')) (Const GntE)) (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv4) ''Cmd'')) (Const GntE))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv3)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv3\<and>i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_StoreVsinv__4:
  assumes a1: "\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d" and
  a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__4  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendReqESVsinv__4:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendReqES  i" and
  a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__4  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvInvAckVsinv__4:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i" and
  a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__4  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvReqVsinv__4:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvReq N i" and
  a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__4  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendReqSVsinv__4:
  assumes a1: "\<exists> j. j\<le>N\<and>r=n_SendReqS  j" and
  a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__4  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendReqEIVsinv__4:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendReqEI  i" and
  a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__4  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

end