\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Order Equivalence\<close>
theory Transport_Natural_Functors_Order_Equivalence
  imports
    Transport_Natural_Functors_Base
begin

lemma inflationary_on_in_dom_FrelI:
  assumes "inflationary_on (in_dom R1) R1 f1"
  and "inflationary_on (in_dom R2) R2 f2"
  and "inflationary_on (in_dom R3) R3 f3"
  defines "R \<equiv> Frel R1 R2 R3"
  shows "inflationary_on (in_dom R) R (Fmap f1 f2 f3)"
  apply (unfold R_def)
  apply (rule inflationary_onI)
  apply (subst (asm) in_dom_Frel_eq_Fpred_in_dom)
  apply (erule FpredE)
  apply (subst Frel_Fmap_eq2)
  apply (rule Frel_refl_strong)
    apply (rule inflationary_onD[where ?R=R1] inflationary_onD[where ?R=R2]
        inflationary_onD[where ?R=R3],
      rule assms,
      assumption+)+
  done

lemma inflationary_on_in_codom_FrelI:
  assumes "inflationary_on (in_codom R1) R1 f1"
  and "inflationary_on (in_codom R2) R2 f2"
  and "inflationary_on (in_codom R3) R3 f3"
  defines "R \<equiv> Frel R1 R2 R3"
  shows "inflationary_on (in_codom R) R (Fmap f1 f2 f3)"
  apply (unfold R_def)
  apply (rule inflationary_onI)
  apply (subst (asm) in_codom_Frel_eq_Fpred_in_codom)
  apply (erule FpredE)
  apply (subst Frel_Fmap_eq2)
  apply (rule Frel_refl_strong)
    apply (rule inflationary_onD[where ?R=R1] inflationary_onD[where ?R=R2]
        inflationary_onD[where ?R=R3],
      rule assms,
      assumption+)+
  done

lemma inflationary_on_in_field_FrelI:
  assumes "inflationary_on (in_field R1) R1 f1"
  and "inflationary_on (in_field R2) R2 f2"
  and "inflationary_on (in_field R3) R3 f3"
  defines "R \<equiv> Frel R1 R2 R3"
  shows "inflationary_on (in_field R) R (Fmap f1 f2 f3)"
  apply (unfold R_def)
  apply (subst in_field_eq_in_dom_sup_in_codom)
  apply (subst inflationary_on_sup_eq)
  apply (unfold inf_apply)
  apply (subst inf_bool_def)
  apply (rule conjI;
    rule inflationary_on_in_dom_FrelI inflationary_on_in_codom_FrelI;
    rule inflationary_on_if_le_pred_if_inflationary_on,
    rule assms,
    rule le_predI,
    rule in_field_if_in_dom in_field_if_in_codom,
    assumption)
  done

lemma deflationary_on_in_dom_FrelI:
  assumes "deflationary_on (in_dom R1) R1 f1"
  and "deflationary_on (in_dom R2) R2 f2"
  and "deflationary_on (in_dom R3) R3 f3"
  defines "R \<equiv> Frel R1 R2 R3"
  shows "deflationary_on (in_dom R) R (Fmap f1 f2 f3)"
  apply (unfold R_def)
  apply (subst deflationary_on_eq_inflationary_on_rel_inv)
  apply (subst in_codom_rel_inv_eq_in_dom[symmetric])
  apply (unfold Frel_rel_inv_eq_rel_inv_Frel[symmetric])
  apply (rule inflationary_on_in_codom_FrelI;
    subst deflationary_on_eq_inflationary_on_rel_inv[symmetric],
    subst in_codom_rel_inv_eq_in_dom,
    rule assms)
  done

lemma deflationary_on_in_codom_FrelI:
  assumes "deflationary_on (in_codom R1) R1 f1"
  and "deflationary_on (in_codom R2) R2 f2"
  and "deflationary_on (in_codom R3) R3 f3"
  defines "R \<equiv> Frel R1 R2 R3"
  shows "deflationary_on (in_codom R) R (Fmap f1 f2 f3)"
  apply (unfold R_def)
  apply (subst deflationary_on_eq_inflationary_on_rel_inv)
  apply (subst in_dom_rel_inv_eq_in_codom[symmetric])
  apply (unfold Frel_rel_inv_eq_rel_inv_Frel[symmetric])
  apply (rule inflationary_on_in_dom_FrelI;
    subst deflationary_on_eq_inflationary_on_rel_inv[symmetric],
    subst in_dom_rel_inv_eq_in_codom,
    rule assms)
  done

lemma deflationary_on_in_field_FrelI:
  assumes "deflationary_on (in_field R1) R1 f1"
  and "deflationary_on (in_field R2) R2 f2"
  and "deflationary_on (in_field R3) R3 f3"
  defines "R \<equiv> Frel R1 R2 R3"
  shows "deflationary_on (in_field R) R (Fmap f1 f2 f3)"
  apply (unfold R_def)
  apply (subst deflationary_on_eq_inflationary_on_rel_inv)
  apply (subst in_field_rel_inv_eq[symmetric])
  apply (unfold Frel_rel_inv_eq_rel_inv_Frel[symmetric])
  apply (rule inflationary_on_in_field_FrelI;
    subst deflationary_on_eq_inflationary_on_rel_inv[symmetric],
    subst in_field_rel_inv_eq,
    rule assms)
  done

lemma rel_equivalence_on_in_field_FrelI:
  assumes "rel_equivalence_on (in_field R1) R1 f1"
  and "rel_equivalence_on (in_field R2) R2 f2"
  and "rel_equivalence_on (in_field R3) R3 f3"
  defines "R \<equiv> Frel R1 R2 R3"
  shows "rel_equivalence_on (in_field R) R (Fmap f1 f2 f3)"
  apply (unfold R_def)
  apply (subst rel_equivalence_on_eq)
  apply (unfold inf_apply)
  apply (subst inf_bool_def)
  apply (insert assms)
  apply (elim rel_equivalence_onE)
  apply (rule conjI;
    rule inflationary_on_in_field_FrelI deflationary_on_in_field_FrelI;
    assumption)
  done

context transport_natural_functor
begin

lemmas inflationary_on_in_field_unitI = inflationary_on_in_field_FrelI
  [of L1 "\<eta>\<^sub>1" L2 "\<eta>\<^sub>2" L3 "\<eta>\<^sub>3", folded transport_defs unit_eq_Fmap]

lemmas deflationary_on_in_field_unitI = deflationary_on_in_field_FrelI
  [of L1 "\<eta>\<^sub>1" L2 "\<eta>\<^sub>2" L3 "\<eta>\<^sub>3", folded transport_defs unit_eq_Fmap]

lemmas rel_equivalence_on_in_field_unitI = rel_equivalence_on_in_field_FrelI
  [of L1 "\<eta>\<^sub>1" L2 "\<eta>\<^sub>2" L3 "\<eta>\<^sub>3", folded transport_defs unit_eq_Fmap]

interpretation flip :
  transport_natural_functor R1 L1 r1 l1 R2 L2 r2 l2 R3 L3 r3 l3
  rewrites "flip.unit \<equiv> \<epsilon>" and "flip.t1.unit \<equiv> \<epsilon>\<^sub>1"
  and "flip.t2.unit \<equiv> \<epsilon>\<^sub>2" and "flip.t3.unit \<equiv> \<epsilon>\<^sub>3"
  by (simp_all only: order_functors.flip_counit_eq_unit)

lemma order_equivalenceI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "((\<le>\<^bsub>L2\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "((\<le>\<^bsub>L3\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R3\<^esub>)) l3 r3"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R\<^esub>)) l r"
  apply (insert assms)
  apply (elim order_functors.order_equivalenceE)
  apply (rule order_equivalenceI;
    rule mono_wrt_rel_leftI
      flip.mono_wrt_rel_leftI
      rel_equivalence_on_in_field_unitI
      flip.rel_equivalence_on_in_field_unitI;
    assumption)
  done

end

end


(* @LICENSE(NICTA_CORE) *)

(*  Author:     Rafal Kolanski, NICTA & UNSW

    Definition of the mem_type class (types which we can store on the heap as
    a sequence of bytes).
*)

theory MemTypes
imports MachineARM
begin

(*XXX: someone removed this in the main repo, where should it go now?*)
type_synonym byte = "8 word"

type_synonym type_tag = string
(*TODO: when working on structure types, this should be moved to where all the other stuff is defined (atomic/structure types etc) (XXX or removed when dropping the tagged heap *)

text \<open>
  The @{text "mem_type"} class represents a C-like values storable in memory.
  They:
   * must be convertable to a series of bytes, reversibly
   * the number of bytes used must be constant for the type, irrespective
     of value, so if we append its encoding to a byte stream, we know how
     many bytes to take off again to decode, thus knowing where the ``rest''
     of the stream is (e.g. encoding as part of a larger structure)
   * must have a nonzero size in bytes that is smaller than both the physical
     and virtual address spaces
   * may require an alignment that divides the both the physical and virtual
     address space sizes
\<close>
class mem_type =
  (* "size of value in bytes" *)
  fixes size_of :: "'a itself \<Rightarrow> nat"
  assumes some_size: "0 < size_of (TYPE('a))"
  assumes max_size: "size_of (TYPE('a)) < min memory_size addr_space_size"

  fixes to_bytes :: "'a \<Rightarrow> byte list"
  fixes from_bytes :: "byte list \<Rightarrow> 'a"
  assumes storable: "from_bytes (to_bytes v) = v"
  assumes size_length: "length (to_bytes v) = size_of TYPE('a)"
  assumes restorable: "length bs = size_of TYPE('a)
                       \<Longrightarrow> to_bytes (from_bytes bs) = bs"

  (* "required alignment of value in bytes" *)
  fixes align_of :: "'a itself \<Rightarrow> nat"
  assumes sane_alignment: "align_of (TYPE('a)) dvd memory_size \<and>
                           align_of (TYPE('a)) dvd addr_space_size"
  (* "a unique type tag for this type of value" *)
  fixes type_tag :: "'a itself \<Rightarrow> type_tag"
  (*XXX: redundant since tags removed, but could be useful otherwise *)

begin

definition
  mem_type_decode :: "byte list \<Rightarrow> ('a \<times> byte list)" where
  "mem_type_decode bs \<equiv> let sz = size_of TYPE('a) in
                       (from_bytes (take sz bs), drop sz bs)"

lemma snd_mem_type_decode:
  "snd (mem_type_decode bs) = drop (size_of TYPE('a)) bs"
  unfolding mem_type_decode_def Let_def
  by simp (*XXX: unused?*)

end

text \<open>Extra mem\_type lemmas.\<close>

lemma to_bytes_nil_all:
  assumes a: "to_bytes (x::'a::mem_type) = []"
  shows "to_bytes (y::'a::mem_type) = []"
proof -
  have "length (to_bytes x) = length (to_bytes y)"
    by (simp add: size_length)
  thus ?thesis using a by auto
qed

text \<open>
  In order to make records mem_types, we need to disregard their ability to
  be extended. When we discard the @{text "more"} part of a record for
  encoding, we must somehow still reconstruct it after decoding. What we
  really want is to have a class of records extending unit. A class containing
  only unit isn't possible, but a class of types with only one member is
  sufficient, as @{text "undefined"} is a reliable reconstruction of any
  discarded extension.
\<close>
class unitary =
  fixes the_value :: "'a"
  assumes only_one_value: "(x::'a) = y" (* Unused. Required to fix 'a. *)
(* XXX: this isn't currently used at Michael N's C parser uses L4 records which
        don't support extending, but do support recursive records *)

instance unit :: unitary (* XXX: magically ignores one_value instantiation *)
  by (intro_classes, simp)

lemma "x dvd memory_size \<Longrightarrow> 0 < x"
  (*XXX: not sure we'll need this, but we definitely don't need it as an assumption on alignment*)
  by (case_tac x, auto simp: memory_size)

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory Word_Lemmas_32_Internal
imports Word_Lib_Sumo Machine_Word_32
begin

lemmas sint_eq_uint_32 = sint_eq_uint_2pl[where 'a=32, simplified]

lemmas sle_positive_32 = sle_le_2pl[where 'a=32, simplified]

lemmas sless_positive_32 = sless_less_2pl[where 'a=32, simplified]

lemma zero_le_sint_32:
  "\<lbrakk> 0 \<le> (a :: word32); a < 0x80000000 \<rbrakk>
   \<Longrightarrow> 0 \<le> sint a"
  by (clarsimp simp: sint_eq_uint_32 unat_less_helper)

lemmas unat_add_simple = iffD1[OF unat_add_lem[where 'a = 32, folded word_bits_def]]

lemma upto_enum_inc_1:
  "a < 2 ^ word_bits - 1
   \<Longrightarrow> [(0:: 'a :: len word) .e. 1 + a] = [0.e.a] @ [(1+a)]"
  using upper_trivial upto_enum_inc_1_len by force

lemmas upt_enum_offset_trivial =
  upt_enum_offset_trivial[where 'a=32, folded word_bits_def]

lemmas unat32_eq_of_nat = unat_eq_of_nat[where 'a=32, folded word_bits_def]

declare mask_32_max_word[simp]

lemma le_32_mask_eq:
  "(bits :: word32) \<le> 32 \<Longrightarrow> bits && mask 6 = bits"
  by (fastforce elim: le_less_trans intro: less_mask_eq)

lemmas scast_1_32[simp] = scast_1[where 'a=32]

lemmas mask_32_id[simp] = mask_len_id[where 'a=32, folded word_bits_def]

lemmas t2p_shiftr_32 = t2p_shiftr[where 'a=32, folded word_bits_def]

lemma mask_eq1_nochoice:
  "(x :: word32) && 1 = x
   \<Longrightarrow> x = 0 \<or> x = 1"
  using mask_eq1_nochoice len32 by force

lemmas const_le_unat_word_32 = const_le_unat[where 'a=32, folded word_bits_def]

lemmas createNewCaps_guard_helper =
  createNewCaps_guard[where 'a=32, folded word_bits_def]

lemma word_log2_max_word32[simp]:
  "word_log2 (w :: 32 word) < 32"
  using word_log2_max[where w=w]
  by (simp add: word_size)

(* FIXME: specialize using pow_sub_less_word *)
lemma mapping_two_power_16_64_inequality:
  assumes sz: "sz \<le> 4" and len: "unat (len :: word32) = 2 ^ sz"
  shows "unat (len * 8 - 1) \<le> 127"
  using pow_sub_less[where 'a=32 and b=3, simplified]
proof -
  have len2: "len = 2 ^ sz"
    apply (rule word_unat.Rep_eqD, simp only: len)
    using sz
    apply simp
    done

  show ?thesis using two_power_increasing_less_1[where 'a=32 and n="sz + 3" and m=7]
    by (simp add: word_le_nat_alt sz power_add len2 field_simps bintrunc_Suc_numeral)
qed

lemmas pre_helper2_32 = pre_helper2[where 'a=32, folded word_bits_def]

lemmas of_nat_shift_distinct_helper_machine =
  of_nat_shift_distinct_helper[where 'a=32, folded word_bits_def]

lemmas ptr_add_distinct_helper_32 =
  ptr_add_distinct_helper[where 'a=32, folded word_bits_def]

lemmas mask_out_eq_0_32 = mask_out_eq_0[where 'a=32, folded word_bits_def]

lemmas neg_mask_mask_unat_32 = neg_mask_mask_unat[where 'a=32, folded word_bits_def]

lemmas unat_less_iff_32 = unat_less_iff[where 'a=32, folded word_bits_def]

lemmas is_aligned_no_overflow3_32 = is_aligned_no_overflow3[where 'a=32, folded word_bits_def]

lemmas unat_ucast_16_32 = unat_signed_ucast_less_ucast[where 'a=16 and 'b=32, simplified]

(* FIXME: generalize? *)
lemma scast_mask_8:
  "scast (mask 8 :: sword32) = (mask 8 :: word32)"
  by (clarsimp simp: mask_eq)

lemmas ucast_le_8_32_equiv = ucast_le_up_down_iff[where 'a=8 and 'b=32, simplified]

lemma signed_unat_minus_one_32:
  "unat (-1 :: 32 signed word) = 4294967295"
  by (simp del: word_pow_0 diff_0 add: unat_sub_if' minus_one_word)

lemmas two_bits_cases_32 = two_bits_cases[where 'a=32, simplified]

lemmas word_ctz_not_minus_1_32 = word_ctz_not_minus_1[where 'a=32, simplified]

lemmas sint_ctz_32 = sint_ctz[where 'a=32, simplified]

(* FIXME: inline these? *)
lemmas scast_specific_plus32 =
  scast_of_nat_signed_to_unsigned_add[where 'a=32 and x="word_ctz x" and y="0x20" for x,
                                      simplified]
lemmas scast_specific_plus32_signed =
  scast_of_nat_unsigned_to_signed_add[where 'a=32 and x="word_ctz x" and y="0x20" for x,
                                      simplified]

lemma neq_0_unat: "x \<noteq> 0 \<Longrightarrow> 0 < unat x" for x::machine_word
  by (simp add: unat_gt_0)

end


section "Program Verification Tactics"

theory program_verification_tactics
  imports
    invariant_simps
    unique_ids
    single_invocation_correctness2
    "Case_Labeling.Case_Labeling"
    execution_invariants2
    execution_invariants_s
    execution_invariants_unused
    crdt_specs
    unique_ids_procedure_check
begin

text "We define some tactics to generate proof obligations for showing a programs correctness.
This theory mainly adds nicer labels to already existing methods using the case labeling package."

context begin
interpretation Labeling_Syntax .

lemma increase_bound:
  assumes "\<exists>bound. (checkCorrect2F ^^Suc bound) bot (progr, {}, S, i)"
  shows "\<exists>bound. (checkCorrect2F ^^bound) bot (progr, {}, S, i)"
  using assms by blast

lemma DC_show_programCorrect:
  fixes ct defines "ct' \<equiv> \<lambda>pos name. (name, pos,[]) # ct"
  assumes invInitial: "C\<langle>Suc n1, ct' n1 ''invariant_initial_state'', n2: invariant_all' (initialState progr)\<rangle>"
    and procedureCorrect: "\<And>S i. \<lbrakk>B\<langle>''in_initial_state'', n2: S\<in>initialStates' progr i\<rangle>\<rbrakk>
          \<Longrightarrow> C\<langle>Suc n2, (''procedure_correct'', n2, [VAR S, VAR i])#ct, n3: procedureCorrect S i\<rangle>"
  shows "C\<langle>n1,ct,n3: programCorrect progr\<rangle>"
  using assms
  unfolding LABEL_simps
  by (metis initialStates'_same procedureCorrect_def show_programCorrect_using_checkCorrect1)

lemma DC_show_procedureCorrect:
  fixes ct defines "ct' \<equiv> \<lambda>pos name. (name, pos,[]) # ct"
  assumes "C\<langle>Suc n1, ct' n1 ''after_invocation'', n2: invariant_all' S\<rangle>"
    and  "B\<langle>''in_initial_state'', n2: invariant_all' S\<rangle> \<Longrightarrow> C\<langle>Suc n2, (''execution'', n2, [])#ct, n3: execution_s_correct S i\<rangle>"
  shows "C\<langle>n1,ct,n3: procedureCorrect S i\<rangle>"
  using assms
  unfolding LABEL_simps by (auto simp add: procedureCorrect_def)

  lemma DC_final2:
    assumes "V\<langle>(n,i,v), ct: a\<rangle>"
    shows "C\<langle>inp,(n,i,v)#ct,Suc inp: a\<rangle>"
    using assms unfolding LABEL_simps by auto

lemma show_initial_state_prop:
  assumes a1: "Si\<in>initialStates' progr i"
and a2: "\<And>S_pre proc initState impl.
       \<lbrakk>
        B\<langle>''Si_def'', n1 : Si = S_pre
        \<lparr>localState := localState S_pre(i \<mapsto> initState),
         currentProc := currentProc S_pre(i \<mapsto> impl),
         visibleCalls := visibleCalls S_pre(i \<mapsto> {}),
         invocOp := invocOp S_pre(i \<mapsto> (proc))\<rparr>\<rangle>;
        B\<langle>''progr_def'', n1 : prog S_pre = progr\<rangle>;
        B\<langle>''proc_initState'', n1 : initState = fst (procedure progr proc)\<rangle>;
        B\<langle>''proc_impl'', n1 : impl = snd (procedure progr proc)\<rangle>;
        B\<langle>''ids_in_args_are_knownIds'', n1 : uniqueIds proc \<subseteq> knownIds S_pre\<rangle>;
        B\<langle>''invariant_pre'', n1 : invariant_all' S_pre\<rangle>;
        B\<langle>''wf_pre'', n1 : state_wellFormed S_pre\<rangle>;
        B\<langle>''i_fresh'', n1 : invocOp S_pre i = None\<rangle>;
        B\<langle>''no_uncommitted_txns'', n1 : \<forall>tx. txStatus S_pre tx \<noteq> Some Uncommitted\<rangle>;
        B\<langle>''no_txns_in_i'', n1 : \<forall>tx. txOrigin S_pre tx \<noteq> Some i\<rangle>
        \<rbrakk> \<Longrightarrow> C\<langle>Suc n1, (''show_P'', n1, [VAR S_pre, VAR proc, VAR  initState, VAR  impl])#ct, n2 :   P Si i\<rangle>"
  shows "C\<langle>n1, ct, n : P Si i\<rangle>"
  unfolding LABEL_simps
proof -
  from a1[unfolded initialStates'_def]
  obtain S proc initState impl
    where "prog S = progr"
      and "procedure progr proc = (initState, impl)"
      and "uniqueIds proc \<subseteq> knownIds S"
      and "invariant_all' S"
      and "state_wellFormed S"
      and "invocOp S i = None"
      and "\<forall>tx. txStatus S tx \<noteq> Some Uncommitted"
      and "\<forall>tx. txOrigin S tx \<noteq> Some i"
      and "Si = S\<lparr>localState := localState S(i \<mapsto> initState), currentProc := currentProc S(i \<mapsto> impl), visibleCalls := visibleCalls S(i \<mapsto> {}),
             invocOp := invocOp S(i \<mapsto> proc)\<rparr>"
    by auto
  note facts = this

  show "P Si i"
    apply (rule a2[unfolded LABEL_simps])
    using facts by auto

qed

end

method M_show_programCorrect =
  ((rule Initial_Label,
    rule DC_show_programCorrect;
   (rule DC_final2 | rule DC_final)),
   casify)

method M_show_procedureCorrect =
  ((rule Initial_Label,
    rule DC_show_procedureCorrect;
   (rule DC_final2 | rule DC_final)),
   casify)

\<comment> \<open>ony unfold definitions, when needed for evaluation:\<close>
lemma state_def[simp]:  "S' ::= S \<Longrightarrow> (currentProc S' i \<triangleq> x) \<longleftrightarrow> (currentProc S i \<triangleq> x)"  by (auto simp add: Def_def)
lemma state_def_h1[simp]: "S' ::= S \<Longrightarrow>  ls_pc (the (localState S' i)) = ls_pc (the (localState S i))" by (auto simp add: Def_def)
lemma state_def_h2[simp]: "S' ::= S \<Longrightarrow>  (currentTx S' i = None) \<longleftrightarrow> (currentTx S i = None)"  by (auto simp add: Def_def)
lemma state_def_currentProc[simp]: "S' ::= S \<Longrightarrow>  currentProc S' i = currentProc S i" by (auto simp add: Def_def)
lemma state_def_currentTx[simp]: "S' ::= S \<Longrightarrow> currentTx S' i = currentTx S i"  by (auto simp add: Def_def)

named_theorems language_construct_defs

method show_procedures_cannot_guess_ids =
  (((auto simp add: language_construct_defs bind_def
        uniqueIds_mapOp_def  uniqueIds_registerOp_def
        split: if_splits)[1])?;
    ((rule procedure_cannot_guess_ids.intros, force); show_procedures_cannot_guess_ids?)?)

(* newId_def atomic_def beginAtomic_def call_def skip_def endAtomic_def return_def *)

end


(*  Title:       Logging-independent Message Anonymity in the Relational Method
    Author:      Pasquale Noce
                 Software Engineer at HID Global, Italy
                 pasquale dot noce dot lavoro at gmail dot com
                 pasquale dot noce at hidglobal dot com
*)

section "Possibility of anonymity compromise for token pseudonymous identifiers"

theory Possibility
  imports Anonymity
begin

text \<open>
\null

This section proves possibility properties @{text tok_id_identified}, @{text sec_id_identified},
which altogether state that the spy can map a token pseudonymous identifier to the related token if
either attack option described in section \ref{Protocol} is viable. Both properties are proven by
construction, namely by creating as many sample protocol runs such as to satisfy their conclusions
if their assumptions are fulfilled.

\null
\<close>

definition tok_id_pubk_prik :: "agent_id \<Rightarrow> agent_id \<Rightarrow> state" where
"tok_id_pubk_prik n m \<equiv>
  insert (Spy, \<langle>n, ID n (Sec_PubKey m)\<rangle>) s\<^sub>0"

definition tok_id_hash :: "agent_id \<Rightarrow> agent_id \<Rightarrow> state" where
"tok_id_hash n m \<equiv>
  insert (Spy, \<langle>n, Hash (ID n (Sec_PubKey m))\<rangle>) (tok_id_pubk_prik n m)"

proposition tok_id_pubk_prik_rel:
 "n \<in> bad_tok_prik \<Longrightarrow> s\<^sub>0 \<Turnstile> tok_id_pubk_prik n m"
by (subgoal_tac "(s\<^sub>0, tok_id_pubk_prik n m) \<in> rel_id_pubk_prik",
 rule r_into_rtrancl, auto simp: tok_id_pubk_prik_def rel_def image_def, blast)

proposition tok_id_pubk_prik_msg:
 "n \<in> bad_tok_prik \<Longrightarrow>
    {ID n (Sec_PubKey m), Hash (ID n (Sec_PubKey m)),
      \<langle>n, ID n (Sec_PubKey m)\<rangle>} \<subseteq> spied (tok_id_pubk_prik n m)"
by (auto simp: tok_id_pubk_prik_def)

proposition tok_id_hash_rel:
 "n \<in> bad_tok_prik \<Longrightarrow> s\<^sub>0 \<Turnstile> tok_id_hash n m"
by (rule rtrancl_into_rtrancl, erule tok_id_pubk_prik_rel [of _ m],
 subgoal_tac "(tok_id_pubk_prik n m, tok_id_hash n m) \<in> rel_id_hash",
 frule_tac [2] tok_id_pubk_prik_msg [of _ m], auto simp: tok_id_hash_def rel_def)

theorem tok_id_identified:
 "n \<in> bad_tok_prik \<Longrightarrow> \<exists>s. s\<^sub>0 \<Turnstile> s \<and> \<langle>n, Hash (ID n (Sec_PubKey m))\<rangle> \<in> spied s"
by (rule exI [of _ "tok_id_hash n m"], drule tok_id_hash_rel [of _ m],
 simp add: tok_id_hash_def)

definition sec_pubk_less :: "agent_id \<Rightarrow> state" where
"sec_pubk_less n \<equiv>
  insert (Spy, PubKey {Tok_PriK n, Rev_PriK}) s\<^sub>0"

definition sec_id_pubk_less :: "agent_id \<Rightarrow> state" where
"sec_id_pubk_less n \<equiv>
  insert (Spy, \<langle>n, PubKey {Tok_PriK n, Rev_PriK}\<rangle>) (sec_pubk_less n)"

definition sec_id_pubk_more :: "agent_id \<Rightarrow> agent_id \<Rightarrow> state" where
"sec_id_pubk_more n m \<equiv>
  insert (Spy, \<langle>n, ID n (Sec_PubKey m)\<rangle>) (sec_id_pubk_less n)"

definition sec_id_hash :: "agent_id \<Rightarrow> agent_id \<Rightarrow> state" where
"sec_id_hash n m \<equiv>
  insert (Spy, \<langle>n, Hash (ID n (Sec_PubKey m))\<rangle>) (sec_id_pubk_more n m)"

lemma sec_id_identified_1:
 "{Tok_PriK n, Sec_PriK m, Rev_PriK} \<noteq> {Tok_PriK n', Rev_PriK}"
by (simp add: set_eq_iff, rule exI [of _ "Sec_PriK m"], insert
 sec_prik_rev sec_prik_tok_prik, simp add: image_def, drule spec [of _ m], auto)

lemma sec_id_identified_2:
 "(Spy, PubKey {Tok_PriK n, Rev_PriK}) \<notin> s\<^sub>0"
by (insert tok_prik_rev sec_id_identified_1, simp add: image_def,
 drule spec [of _ n], auto simp: set_eq_iff)

lemma sec_id_identified_3:
 "{Tok_PriK n, Rev_PriK} =
    {Tok_PriK n, Sec_PriK m, Rev_PriK} - {Sec_PriK m}"
by (insert sec_prik_rev sec_prik_tok_prik, auto)

lemma sec_id_identified_4:
 "PubK {Tok_PriK n, Sec_PriK m, Rev_PriK} =
    PubK (insert (Sec_PriK m) {Tok_PriK n, Rev_PriK})"
by auto

proposition sec_pubk_less_rel:
 "\<lbrakk>{m, m'} \<subseteq> bad_sec_prik; (n, m) \<notin> bad_id; (n, m') \<in> bad_id\<rbrakk> \<Longrightarrow>
    s\<^sub>0 \<Turnstile> sec_pubk_less n"
by (subgoal_tac "(s\<^sub>0, sec_pubk_less n) \<in> rel_pubk_less", rule r_into_rtrancl,
 simp add: rel_def, subst sec_pubk_less_def, subst sec_id_identified_3 [of _ m'],
 simp, (rule exI)+, subst insert_ident, subst sec_id_identified_3 [symmetric],
 insert sec_id_identified_2, auto)

proposition sec_pubk_less_msg:
 "\<lbrakk>{m, m'} \<subseteq> bad_sec_prik; (n, m) \<notin> bad_id; (n, m') \<in> bad_id\<rbrakk> \<Longrightarrow>
    {Sec_PriKey m, Sec_PriKey m', PubKey {Tok_PriK n, Rev_PriK},
      ID n (Sec_PubKey m), Hash (ID n (Sec_PubKey m)),
      \<langle>n, ID n (Sec_PubKey m')\<rangle>} \<subseteq> spied (sec_pubk_less n) \<and>
    {\<langle>n, PubKey {Tok_PriK n, Rev_PriK}\<rangle>, \<langle>n, ID n (Sec_PubKey m)\<rangle>,
      \<langle>n, Hash (ID n (Sec_PubKey m))\<rangle>} \<inter>
      spied (sec_pubk_less n) = {}"
by (insert sec_id_identified_2, auto simp: sec_pubk_less_def image_def
 dest: sec_prik_eq)

proposition sec_id_pubk_less_rel:
 "\<lbrakk>{m, m'} \<subseteq> bad_sec_prik; (n, m) \<notin> bad_id; (n, m') \<in> bad_id\<rbrakk> \<Longrightarrow>
    s\<^sub>0 \<Turnstile> sec_id_pubk_less n"
by (rule rtrancl_into_rtrancl, erule sec_pubk_less_rel, assumption+,
 subgoal_tac "(sec_pubk_less n, sec_id_pubk_less n) \<in> rel_id_pubk_less",
 frule_tac [2] sec_pubk_less_msg, simp_all add: sec_id_pubk_less_def rel_def,
 (rule exI)+, subst sec_id_identified_3 [of _ m'], subst (asm) (1 2)
 sec_id_identified_3, subst insert_ident, insert sec_prik_tok_prik, auto)

proposition sec_id_pubk_less_msg:
 "\<lbrakk>{m, m'} \<subseteq> bad_sec_prik; (n, m) \<notin> bad_id; (n, m') \<in> bad_id\<rbrakk> \<Longrightarrow>
    {Sec_PriKey m, ID n (Sec_PubKey m), Hash (ID n (Sec_PubKey m)),
      \<langle>n, PubKey {Tok_PriK n, Rev_PriK}\<rangle>} \<subseteq>
      spied (sec_id_pubk_less n) \<and>
    {\<langle>n, ID n (Sec_PubKey m)\<rangle>, \<langle>n, Hash (ID n (Sec_PubKey m))\<rangle>} \<inter>
      spied (sec_id_pubk_less n) = {}"
by (drule sec_pubk_less_msg, insert sec_id_identified_1,
 auto simp: sec_id_pubk_less_def)

proposition sec_id_pubk_more_rel:
 "\<lbrakk>{m, m'} \<subseteq> bad_sec_prik; (n, m) \<notin> bad_id; (n, m') \<in> bad_id\<rbrakk> \<Longrightarrow>
    s\<^sub>0 \<Turnstile> sec_id_pubk_more n m"
by (rule rtrancl_into_rtrancl, erule sec_id_pubk_less_rel, assumption+,
 subgoal_tac "(sec_id_pubk_less n, sec_id_pubk_more n m) \<in> rel_id_pubk_more",
 frule_tac [2] sec_id_pubk_less_msg, simp_all add: sec_id_pubk_more_def rel_def,
 (rule exI)+, subst sec_id_identified_4, subst (asm) (1 3) sec_id_identified_4,
 subst insert_ident, simp_all)

proposition sec_id_pubk_more_msg:
 "\<lbrakk>{m, m'} \<subseteq> bad_sec_prik; (n, m) \<notin> bad_id; (n, m') \<in> bad_id\<rbrakk> \<Longrightarrow>
    {ID n (Sec_PubKey m), Hash (ID n (Sec_PubKey m)),
      \<langle>n, ID n (Sec_PubKey m)\<rangle>} \<subseteq> spied (sec_id_pubk_more n m) \<and>
    \<langle>n, Hash (ID n (Sec_PubKey m))\<rangle> \<notin> spied (sec_id_pubk_more n m)"
by (drule sec_id_pubk_less_msg, auto simp: sec_id_pubk_more_def)

proposition sec_id_hash_rel:
 "\<lbrakk>{m, m'} \<subseteq> bad_sec_prik; (n, m) \<notin> bad_id; (n, m') \<in> bad_id\<rbrakk> \<Longrightarrow>
    s\<^sub>0 \<Turnstile> sec_id_hash n m"
by (rule rtrancl_into_rtrancl, erule sec_id_pubk_more_rel, assumption+,
 subgoal_tac "(sec_id_pubk_more n m, sec_id_hash n m) \<in> rel_id_hash",
 frule_tac [2] sec_id_pubk_more_msg, auto simp: sec_id_hash_def rel_def)

theorem sec_id_identified:
 "\<lbrakk>{m, m'} \<subseteq> bad_sec_prik; (n, m') \<in> bad_id\<rbrakk> \<Longrightarrow>
    \<exists>s. s\<^sub>0 \<Turnstile> s \<and> \<langle>n, Hash (ID n (Sec_PubKey m))\<rangle> \<in> spied s"
by (cases "(n, m) \<in> bad_id", blast, rule exI [of _ "sec_id_hash n m"],
 drule sec_id_hash_rel, simp_all add: sec_id_hash_def)

end


           (*-------------------------------------------*
            |                                           |
            |         Safety of Specifications          |
            |                                           |
            *-------------------------------------------*)

theory SeqCtrl_safe
imports MBP_Spec CSP_semantics
begin

(*************************************************************

         1. SeqCtrl: safe order
         2.
         3.
         4.

 *************************************************************)

(* ----------------------------------------- *
 |                    lemmas                 |
 * ----------------------------------------- *)

lemma Seq_blk:
"ALL a P' Blks Deps S. $Seq Blks Deps S ---a---> P'--> S <= Blks
  --> (if (S = Blks) then (a = Ev finish & P' = STOP)
  else (EX n. n:enable Blks Deps S & a = Ev (blk n) &
  P' = $Seq Blks Deps (S Un {n})))"
  apply (auto)
    apply (erule trn.cases, auto)+  (* all cases are checked for ||| *)
  done

(* ----------------------------------------- *
 |                    lemmas                 |
 * ----------------------------------------- *)

lemma Seqctrl_safe_induct:
"ALL s k t P' S.
k < length t -->
       t = rem_tau s -->
       S <= Blks -->
       $Seq Blks Deps S ---s--->> P' -->
       (EX n. t!k = blk n & src Blks Deps n <= dones t k Un S) | (t!k = finish & P' = STOP) "

  apply (rule allI)
  apply (induct_tac s)
   apply (simp)

  apply (simp)
  apply (rule allI)
  apply (rule impI)
  apply (rule allI)
  apply (rule allI)
  apply (rule impI)
  apply (rename_tac a t k P' S)
  apply (simp add: seq_trn_step)
  apply (rule impI)
  apply (erule exE)
  apply (erule conjE)
  apply (insert Seq_blk)
  apply (drule_tac x="a" in spec)
  apply (drule_tac x="P1" in spec)
  apply (drule_tac x="Blks" in spec)
  apply (drule_tac x="Deps" in spec)
  apply (drule_tac x="S" in spec)
  apply (simp)
  apply (case_tac "S = Blks")

(*case S=Blks*)
   apply (simp)
   apply (rule disjI2)
   apply (subgoal_tac "t = [] & P' = STOP")
    apply (simp)
   apply (simp add: stop_seq_trn)

(*case ~S=Blks*)
  apply (simp)
  apply (elim exE conjE disjE)
  apply (simp)

(*case k=0*)
  apply (case_tac "k = 0")
   apply (simp)
   apply (simp add:dones_def)
  apply (simp add:enable_def)

(*case k>0*)
  apply (drule_tac x="k-1" in spec)
  apply (simp)
  (*apply (drule mp)*)
   apply(subgoal_tac "EX k'. k = Suc k'")
    apply (erule exE)
   apply (simp)

  apply (drule_tac x="P'" in spec)
  apply (drule_tac x="insert n S" in spec)
   apply (simp)

   apply (drule mp)
   apply (simp add:enable_def)
   apply (elim exE conjE disjE)
    apply (rule disjI1)
    apply (rule_tac x="na" in exI)
    apply (simp)

    apply (rule order_trans)
     apply (simp)
    apply (simp only: dones_insert)

  (* apply(rule disjI2)*)
   apply (simp)

   apply (simp add: gr0_implies_Suc)

  done

lemma Seqctrl_safe_event_induct:
"ALL s k t P' S. k < length t -->
       t = rem_tau s -->
       S <= Blks -->
       $Seq Blks Deps S ---s--->> P' -->
       (EX n. t!k = blk n) | (t!k = finish & P' = STOP)"
  apply (rule allI)
  apply (induct_tac s)
   apply (simp)

  apply (simp)
  apply (rule allI)
  apply (rule impI)
  apply (rule allI)
  apply (rule allI)
  apply (rule impI)
  apply (rename_tac a t k P' S)
  apply (simp add: seq_trn_step)
  apply (rule impI)
  apply (erule exE)
  apply (erule conjE)
  apply (insert Seq_blk)
  apply (drule_tac x="a" in spec)
  apply (drule_tac x="P1" in spec)
  apply (drule_tac x="Blks" in spec)
  apply (drule_tac x="Deps" in spec)
  apply (drule_tac x="S" in spec)
  apply (simp)
  apply (case_tac "S = Blks")

(*case S=Blks*)
   apply (simp)
   apply (rule disjI2)
  apply(subgoal_tac "t = [] & P' = STOP")
    apply (simp)
   apply (simp add: stop_seq_trn)
  apply (simp)
  apply (elim exE conjE disjE)
  apply (simp)
  apply (case_tac "k = 0")
   apply (simp)
  apply (drule_tac x="k-1" in spec)
  apply (simp)
  apply (drule mp)
   apply(subgoal_tac "EX k'. k = Suc k'")
    apply (erule exE)
    apply (simp)
   apply (simp add: gr0_implies_Suc)
  apply (drule_tac x="P'" in spec)
  apply (drule_tac x="insert n S" in spec)
  apply (simp)
  apply (simp add:enable_def)
  done

lemma Seqctrl_safe_event:
" t:traces(SeqCtrl Blks Deps) ==> k < length(t)
 ==> (EX n. t!k = blk n | t!k = finish)"
  apply(simp add: traces_def)
  apply(erule exE)
  apply(erule conjE)
  apply(erule exE)
  apply (rename_tac P')
  apply (simp add: SeqCtrl_def)
  apply (insert Seqctrl_safe_event_induct[of Blks Deps])
  apply (drule_tac x="s" in spec)
  apply (drule_tac x="k" in spec)
  apply (drule_tac x="t" in spec)
  apply (drule_tac x="P'" in spec)
  apply (drule_tac x="{}" in spec)
  apply (simp)
  apply (elim exE conjE disjE)
  apply (simp)
  apply (simp)
  done

(* ----------------------------------------- *
 |          tamon Proposition 5.1             |
 * ----------------------------------------- *)
lemma Seqctrl_safe:
"t:traces(SeqCtrl Blks Deps) ==> k < length(t)
 ==> (EX n. t!k = blk n & src Blks Deps n <= dones t k)
 | t!k = finish"
  apply (simp add:traces_def)
  apply (elim exE conjE)
  apply (simp add:SeqCtrl_def)
  apply (insert Seqctrl_safe_induct  [of Blks Deps])
  apply (drule_tac x="s" in spec)
  apply (drule_tac x="k" in spec)
  apply (drule_tac x="t" in spec)
  apply (drule_tac x="x" in spec)
  apply (drule_tac x="{}" in spec)
  apply (simp)
  apply (elim exE conjE disjE)
   apply (simp)

  apply (simp)
  done

end


(*
Title: WHATandWHERE-Security
Authors: Sylvia Grewe, Alexander Lux, Heiko Mantel, Jens Sauer
*)
theory Parallel_Composition
imports Up_To_Technique MWLs
begin

locale WHATWHERE_Secure_Programs =
L : MWLs_semantics "E" "BMap"
+ WWs : WHATWHERE "MWLsSteps_det" "E" "pp" "DA" "lH"
for E :: "('exp, 'id, 'val) Evalfunction"
and BMap :: "'val \<Rightarrow> bool"
and DA :: "('id, 'd::order) DomainAssignment"
and lH :: "('d, 'exp) lHatches"
begin

lemma SdlHPPB_restricted_on_PP_is_SdlHPPB:
  assumes SdlHPPB: "SdlHPPB d PP R'"
  assumes inR': "(V,V) \<in> R'"
  assumes Rdef: "R = {(V',V''). (V',V'') \<in> R'
    \<and> set (PPV V') \<subseteq> set (PPV V)
    \<and> set (PPV V'') \<subseteq> set (PPV V)}"
  shows "SdlHPPB d PP R"
proof (simp add: Strong_dlHPP_Bisimulation_def, auto)
  from SdlHPPB have "sym R'"
    by (simp add: Strong_dlHPP_Bisimulation_def)
  with Rdef show "sym R"
    by (simp add: sym_def)
next
  from SdlHPPB have "trans R'"
    by (simp add: Strong_dlHPP_Bisimulation_def)
  with Rdef show "trans R"
    by (simp add: trans_def, auto)
next
  fix V' V''
  assume inR_part: "(V',V'') \<in> R"
  with SdlHPPB Rdef show "length V' = length V''"
    by (simp add: Strong_dlHPP_Bisimulation_def, auto)
next
  fix V' V'' i
  assume inR_part: "(V',V'') \<in> R"
  assume irange: "i < length V'"
  assume notIDC:
    "\<not> IDC d (V'!i) (htchLoc (pp (V'!i)))"
  with SdlHPPB inR_part irange Rdef
  show "NDC d (V'!i)"
    by (simp add: Strong_dlHPP_Bisimulation_def, auto)
next
  fix V' V'' i \<alpha> p m1 m1' m2
  assume inR_part: "(V',V'') \<in> R"
  assume irange: "i < length V'"
  assume step: "\<langle>V'!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle>"
  assume dhequal: "m1 \<sim>\<^bsub>d,(htchLocSet PP)\<^esub> m1'"

  from inR_part SdlHPPB Rdef have eqlen: "length V' = length V''"
    by (simp add: Strong_dlHPP_Bisimulation_def, auto)

  from inR_part Rdef
  have "set (PPV V') \<subseteq> set (PPV V) \<and> set (PPV V'') \<subseteq> set (PPV V)"
    by auto

  with irange PPc_in_PPV_version eqlen
  have PPc_Vs_at_i:
    "set (PPc (V'!i)) \<subseteq> set (PPV V) \<and> set (PPc (V''!i)) \<subseteq> set (PPV V)"
    by (metis subset_trans)

  from SdlHPPB inR_part Rdef irange step dhequal
    strongdlHPPB_aux[of "d" "PP" "R'" "i"
    "V'" "V''" "m1" "\<alpha>" "p" "m2" "m1'"]
  obtain p' \<alpha>' m2' where stepreq: "\<langle>V''!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
    stepResultsinR p p' R' \<and> (\<alpha>,\<alpha>') \<in> R' \<and>
    dhequality_alternative d PP (pp (V'!i)) m2 m2'"
    by auto
  have Rpp': "stepResultsinR p p' R"
  proof -
    {
      fix c c'
      assume step1: "\<langle>V'!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>Some c,m2\<rangle>"
      assume step2: "\<langle>V''!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>Some c',m2'\<rangle>"
      assume inR'_res: "([c],[c']) \<in> R'"

      from PPc_Vs_at_i step1 step2 PPsc_of_step
      have "set (PPc c) \<subseteq> set (PPV V) \<and> set (PPc c') \<subseteq> set (PPV V)"
        by (metis (no_types) option.sel xt1(6))

      with inR'_res Rdef have "([c],[c']) \<in> R"
        by auto
    }
    thus ?thesis
      by (metis step stepResultsinR_def stepreq)
  qed

  have R\<alpha>\<alpha>': "(\<alpha>,\<alpha>') \<in> R"
  proof -
    from PPc_Vs_at_i step stepreq PPs\<alpha>_of_step have
      "set (PPV \<alpha>) \<subseteq> set (PPV V) \<and> set (PPV \<alpha>') \<subseteq> set (PPV V)"
      by (metis (no_types) xt1(6))
    with stepreq Rdef show ?thesis
      by auto
  qed

  from stepreq Rpp' R\<alpha>\<alpha>' show
    "\<exists>p' \<alpha>' m2'. \<langle>V''!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
    stepResultsinR p p' R \<and> (\<alpha>,\<alpha>') \<in> R \<and>
    dhequality_alternative d PP (pp (V'!i)) m2 m2'"
    by auto
qed

theorem parallel_composition:
  "\<lbrakk> \<forall>i < length V. WHATWHERE_Secure [V!i]; unique_PPV V \<rbrakk>
  \<Longrightarrow> WHATWHERE_Secure V"
proof (simp add: WHATWHERE_Secure_def, induct V, auto)
  fix d PP
  from WHATWHERE_empty
  show "\<exists>R. SdlHPPB d PP R \<and> ([],[]) \<in> R"
    by (simp add: WHATWHERE_Secure_def)
next
  fix c V d PP
  assume IH: "\<lbrakk> \<forall>i < length V.
    \<forall>d PP. \<exists>R. SdlHPPB d PP R \<and> ([V!i],[V!i]) \<in> R;
    unique_PPV V \<rbrakk>
    \<Longrightarrow> \<forall>d PP. \<exists>R. SdlHPPB d PP R \<and> (V,V) \<in> R"
  assume ISassump: "\<forall>i < Suc (length V).
    \<forall>d PP. \<exists>R. SdlHPPB d PP R \<and> ([(c#V)!i],[(c#V)!i]) \<in> R"
  assume uniPPcV: "unique_PPV (c#V)"

  hence IHassump1: "unique_PPV V"
    by (simp add: unique_PPV_def)

  from uniPPcV have nocommonPP: "set (PPc c) \<inter> set (PPV V) = {}"
    by (simp add: unique_PPV_def)

  from ISassump have IHassump2: "\<forall>i < length V.
    \<forall>d PP. \<exists>R. SdlHPPB d PP R \<and> ([V!i],[V!i]) \<in> R"
    by auto

  with IHassump1 IH obtain RV' where RV'assump:
    "SdlHPPB d PP RV' \<and> (V,V) \<in> RV'"
    by blast

  def RV \<equiv> "{(V',V''). (V',V'') \<in> RV' \<and> set (PPV V') \<subseteq> set (PPV V)
    \<and> set (PPV V'') \<subseteq> set (PPV V)}"

  with RV'assump RV_def SdlHPPB_restricted_on_PP_is_SdlHPPB
  have SdlHPPRV: "SdlHPPB d PP RV"
    by force

  from ISassump obtain Rc' where Rc'assump:
    "SdlHPPB d PP Rc' \<and> ([c],[c]) \<in> Rc'"
    by (metis append_Nil drop_Nil neq0_conv not_Cons_self
      nth_append_length Cons_nth_drop_Suc zero_less_Suc)

  def Rc \<equiv> "{(V',V''). (V',V'') \<in> Rc' \<and> set (PPV V') \<subseteq> set (PPc c)
    \<and> set (PPV V'') \<subseteq> set (PPc c)}"

  with Rc'assump Rc_def SdlHPPB_restricted_on_PP_is_SdlHPPB
  have SdlHPPRc: "SdlHPPB d PP Rc"
    by force

  from nocommonPP have "Domain RV \<inter> Domain Rc \<subseteq> {[]}"
    by (simp add: RV_def Rc_def, auto,
      metis Int_mono inf_commute inf_idem le_bot nocommonPP unique_V_uneq)

  with commonArefl_subset_commonDomain
  have Areflassump1: "Arefl RV \<inter> Arefl Rc \<subseteq> {[]}"
    by force

  def R \<equiv> "{(V',V''). \<exists>c c' W W'. V' = c#W \<and> V'' = c'#W' \<and> W \<noteq> []
    \<and> W' \<noteq> [] \<and> ([c],[c']) \<in> Rc \<and> (W,W') \<in> RV}"

  with RV_def RV'assump Rc_def Rc'assump have inR:
    "V \<noteq> [] \<Longrightarrow> (c#V,c#V) \<in> R"
    by auto

  from R_def Rc_def RV_def nocommonPP
  have "Domain R \<inter> Domain (Rc \<union> RV) = {}"
    by (simp add: R_def Rc_def RV_def, auto,
      metis inf_bot_right le_inf_iff subset_empty unique_V_uneq,
      metis (hide_lams, no_types) inf_absorb1 inf_bot_right le_inf_iff unique_c_uneq)

  with commonArefl_subset_commonDomain
  have Areflassump2: "Arefl R \<inter> Arefl (Rc \<union> RV) \<subseteq> {[]}"
    by force

  have disjuptoR:
    "disj_dlHPP_Bisimulation_Up_To_R' d PP (Rc \<union> RV) R"
    proof (simp add: disj_dlHPP_Bisimulation_Up_To_R'_def, auto)
        from Areflassump1 SdlHPPRc SdlHPPRV Union_Strong_dlHPP_Bisim
        show "SdlHPPB d PP (Rc \<union> RV)"
          by force
      next
        from SdlHPPRV have symRV: "sym RV"
          by (simp add: Strong_dlHPP_Bisimulation_def)
        from SdlHPPRc have symRc: "sym Rc"
          by (simp add: Strong_dlHPP_Bisimulation_def)
        with symRV R_def show "sym R"
          by (simp add: sym_def, auto)
      next
        from SdlHPPRV have transRV: "trans RV"
          by (simp add: Strong_dlHPP_Bisimulation_def)
        from SdlHPPRc have transRc: "trans Rc"
          by (simp add: Strong_dlHPP_Bisimulation_def)
        show "trans R"
           proof -
            {
            fix V V' V''
            assume p1: "(V,V') \<in> R"
            assume p2: "(V',V'') \<in> R"
            have "(V,V'') \<in> R"
              proof -
                from p1 R_def obtain c c' W W' where p1assump:
                  "V = c#W \<and> V' = c'#W' \<and> W \<noteq> [] \<and> W' \<noteq> [] \<and>
                  ([c],[c']) \<in> Rc \<and> (W,W') \<in> RV"
                  by auto
                with p2 R_def obtain c'' W'' where p2assump:
                  "V'' = c''#W'' \<and> W'' \<noteq> [] \<and>
                  ([c'],[c'']) \<in> Rc \<and> (W',W'') \<in> RV"
                  by auto
                with p1assump transRc transRV have
                  trans_assump: "([c],[c'']) \<in> Rc \<and> (W,W'') \<in> RV"
                  by (simp add: trans_def, blast)
                with p1assump p2assump R_def show ?thesis
                  by auto
              qed
             }
            thus ?thesis unfolding trans_def by blast
           qed
      next
        fix V V'
        assume "(V,V') \<in> R"
        with R_def SdlHPPRV show "length V = length V'"
          by (simp add: Strong_dlHPP_Bisimulation_def, auto)
      next
        fix V V' i
        assume inR: "(V,V') \<in> R"
        assume irange: "i < length V"
        assume notIDC: "\<not> IDC d (V!i)
          (htchLoc (pp (V!i)))"
        from inR R_def obtain c c' W W' where VV'assump:
          "V = c#W \<and> V'=c'#W' \<and> W \<noteq> [] \<and> W' \<noteq> [] \<and>
          ([c],[c']) \<in> Rc \<and> (W,W') \<in> RV"
          by auto
        -- "Case separation for i"
        from VV'assump SdlHPPRc have Case_i0:
          "i = 0 \<Longrightarrow> (NDC d (V!i) \<or>
            IDC d (V!i) (htchLoc (pp (V!i))))"
          by (simp add: Strong_dlHPP_Bisimulation_def, auto)

        from VV'assump SdlHPPRV have "\<forall>i < length W.
          (NDC d (W!i) \<or>
            IDC d (W!i) (htchLoc (pp (W!i))))"
          by (simp add: Strong_dlHPP_Bisimulation_def, auto)

        with irange VV'assump have Case_in0:
          "i > 0 \<Longrightarrow> (NDC d (V!i) \<or>
          IDC d (V!i) (htchLoc (pp (V!i))))"
          by simp
        from notIDC Case_i0 Case_in0
        show "NDC d (V!i)"
          by auto
      next
        fix V V' m1 m1' m2 \<alpha> p i
        assume inR: "(V,V') \<in> R"
        assume irange: "i < length V"
        assume step: "\<langle>V!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle>"
        assume dhequal: "m1 \<sim>\<^bsub>d,(htchLocSet PP)\<^esub> m1'"

        from inR R_def obtain c c' W W' where VV'assump:
          "V = c#W \<and> V'=c'#W' \<and> W \<noteq> [] \<and> W' \<noteq> [] \<and>
          ([c],[c']) \<in> Rc \<and> (W,W') \<in> RV"
          by auto
        -- "Case separation for i"
        from VV'assump SdlHPPRc strongdlHPPB_aux[of "d" "PP"
          "Rc" "0" "[c]" "[c']"] step dhequal
        have Case_i0:
          "i = 0 \<Longrightarrow> \<exists>p' \<alpha>' m2'.
          \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
          stepResultsinR p p' (R \<union> (Rc \<union> RV)) \<and>
          ((\<alpha>,\<alpha>') \<in> R \<or> (\<alpha>,\<alpha>') \<in> Rc \<or> (\<alpha>,\<alpha>') \<in> RV) \<and>
          dhequality_alternative d PP (pp (V!i)) m2 m2'"
          by (simp add: stepResultsinR_def, blast)

        from step VV'assump irange have rewV:
          "i > 0 \<Longrightarrow> (i-Suc 0) < length W \<and> V!i = W!(i-Suc 0)"
          by simp

        with irange VV'assump step dhequal SdlHPPRV
          strongdlHPPB_aux[of "d" "PP" "RV" _ "W" "W'"]
        have Case_in0:
          "i > 0 \<Longrightarrow>  \<exists>p' \<alpha>' m2'.
          \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
          stepResultsinR p p' (R \<union> (Rc \<union> RV)) \<and>
          ((\<alpha>,\<alpha>') \<in> R \<or> (\<alpha>,\<alpha>') \<in> Rc \<or> (\<alpha>,\<alpha>') \<in> RV) \<and>
          dhequality_alternative d PP (pp (V!i)) m2 m2'"
          by (simp add: stepResultsinR_def, blast)

        from Case_i0 Case_in0
        show "\<exists>p' \<alpha>' m2'.
          \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
          stepResultsinR p p' (R \<union> (Rc \<union> RV)) \<and>
          ((\<alpha>,\<alpha>') \<in> R \<or> (\<alpha>,\<alpha>') \<in> Rc \<or> (\<alpha>,\<alpha>') \<in> RV) \<and>
          dhequality_alternative d PP (pp (V!i)) m2 m2'"
          by auto
      qed
  with Areflassump2 Rc'assump Up_To_Technique
  show "\<exists>R. SdlHPPB d PP R \<and> (c#V, c#V) \<in> R"
    by (metis UnCI inR)

qed

end

end


(*  Title:      HOL/Auth/n_mutualExFsm_lemma_inv__3_on_rules.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_mutualExFsm Protocol Case Study*}

theory n_mutualExFsm_lemma_inv__3_on_rules imports n_mutualExFsm_lemma_on_inv__3
begin
section{*All lemmas on causal relation between inv__3*}
lemma lemma_inv__3_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__3  p__Inv0 p__Inv1)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i. i\<le>N\<and>r=n_fsm  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_fsm  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_fsmVsinv__3) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


(* @TAG(OTHER_LGPL) *)

(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      HoarePartialDef.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

section {* Hoare Logic for Partial Correctness *}
theory HoarePartialDef imports Semantic begin

type_synonym ('s,'p) quadruple = "('s assn \<times> 'p \<times> 's assn \<times> 's assn)"

subsection {* Validity of Hoare Tuples: @{text "\<Gamma>,\<Theta>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"} *}

definition
  valid :: "[('s,'p,'f) body,'f set,'s assn,('s,'p,'f) com,'s assn,'s assn] => bool"
                ("_\<Turnstile>\<^bsub>'/_\<^esub>/ _ _ _,_"  [61,60,1000, 20, 1000,1000] 60)
where
 "\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A \<equiv> \<forall>s t. \<Gamma>\<turnstile>\<langle>c,s\<rangle> \<Rightarrow> t \<longrightarrow> s \<in> Normal ` P \<longrightarrow> t \<notin> Fault ` F
                      \<longrightarrow>  t \<in>  Normal ` Q \<union> Abrupt ` A"

definition
  cvalid::
  "[('s,'p,'f) body,('s,'p) quadruple set,'f set,
      's assn,('s,'p,'f) com,'s assn,'s assn] =>bool"
                ("_,_\<Turnstile>\<^bsub>'/_\<^esub>/ _ _ _,_"  [61,60,60,1000, 20, 1000,1000] 60)
where
 "\<Gamma>,\<Theta>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A \<equiv> (\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P (Call p) Q,A) \<longrightarrow> \<Gamma> \<Turnstile>\<^bsub>/F\<^esub> P c Q,A"

definition
  nvalid :: "[('s,'p,'f) body,nat,'f set,
                's assn,('s,'p,'f) com,'s assn,'s assn] => bool"
                ("_\<Turnstile>_:\<^bsub>'/_\<^esub>/ _ _ _,_"  [61,60,60,1000, 20, 1000,1000] 60)
where
 "\<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A \<equiv> \<forall>s t. \<Gamma>\<turnstile>\<langle>c,s \<rangle> =n\<Rightarrow> t \<longrightarrow> s \<in> Normal ` P \<longrightarrow> t \<notin> Fault ` F
                        \<longrightarrow> t \<in>  Normal ` Q \<union> Abrupt ` A"

definition
  cnvalid::
  "[('s,'p,'f) body,('s,'p) quadruple set,nat,'f set,
     's assn,('s,'p,'f) com,'s assn,'s assn] \<Rightarrow> bool"
                ("_,_\<Turnstile>_:\<^bsub>'/_\<^esub>/ _ _ _,_"  [61,60,60,60,1000, 20, 1000,1000] 60)
where
 "\<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A \<equiv> (\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P (Call p) Q,A) \<longrightarrow> \<Gamma> \<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A"

notation (ascii)
  valid  ("_|='/_/ _ _ _,_"  [61,60,1000, 20, 1000,1000] 60) and
  cvalid  ("_,_|='/_/ _ _ _,_"  [61,60,60,1000, 20, 1000,1000] 60) and
  nvalid  ("_|=_:'/_/ _ _ _,_"  [61,60,60,1000, 20, 1000,1000] 60) and
  cnvalid  ("_,_|=_:'/_/ _ _ _,_"  [61,60,60,60,1000, 20, 1000,1000] 60)

subsection {*Properties of Validity *}

lemma valid_iff_nvalid: "\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A = (\<forall>n. \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A)"
  apply (simp only: valid_def nvalid_def exec_iff_execn )
  apply (blast dest: exec_final_notin_to_execn)
  done

lemma cnvalid_to_cvalid: "(\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A) \<Longrightarrow> \<Gamma>,\<Theta>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"
  apply (unfold cvalid_def cnvalid_def valid_iff_nvalid [THEN eq_reflection])
  apply fast
  done

lemma nvalidI:
 "\<lbrakk>\<And>s t. \<lbrakk>\<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> =n\<Rightarrow> t;s \<in> P; t\<notin> Fault ` F\<rbrakk> \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A\<rbrakk>
  \<Longrightarrow> \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A"
  by (auto simp add: nvalid_def)

lemma validI:
 "\<lbrakk>\<And>s t. \<lbrakk>\<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> \<Rightarrow> t;s \<in> P; t\<notin>Fault ` F\<rbrakk> \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A\<rbrakk>
  \<Longrightarrow> \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"
  by (auto simp add: valid_def)

lemma cvalidI:
 "\<lbrakk>\<And>s t. \<lbrakk>\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P (Call p) Q,A;\<Gamma>\<turnstile>\<langle>c,Normal s\<rangle> \<Rightarrow> t;s \<in> P;t\<notin>Fault ` F\<rbrakk>
          \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"
  by (auto simp add: cvalid_def valid_def)

lemma cvalidD:
 "\<lbrakk>\<Gamma>,\<Theta>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A;\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P (Call p) Q,A;\<Gamma>\<turnstile>\<langle>c,Normal s\<rangle> \<Rightarrow> t;s \<in> P;t\<notin>Fault ` F\<rbrakk>
  \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A"
  by (auto simp add: cvalid_def valid_def)

lemma cnvalidI:
 "\<lbrakk>\<And>s t. \<lbrakk>\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P (Call p) Q,A;
   \<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> =n\<Rightarrow> t;s \<in> P;t\<notin>Fault ` F\<rbrakk>
          \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A"
  by (auto simp add: cnvalid_def nvalid_def)

lemma cnvalidD:
 "\<lbrakk>\<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A;\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P (Call p) Q,A;
   \<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> =n\<Rightarrow> t;s \<in> P;
   t\<notin>Fault ` F\<rbrakk>
  \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A"
  by (auto simp add: cnvalid_def nvalid_def)

lemma nvalid_augment_Faults:
  assumes validn:"\<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A"
  assumes F': "F \<subseteq> F'"
  shows "\<Gamma>\<Turnstile>n:\<^bsub>/F'\<^esub> P c Q,A"
proof (rule nvalidI)
  fix s t
  assume exec: "\<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> =n\<Rightarrow> t"
  assume P: "s \<in> P"
  assume F: "t \<notin> Fault ` F'"
  with F' have "t \<notin> Fault ` F"
    by blast
  with exec P validn
  show "t \<in> Normal ` Q \<union> Abrupt ` A"
    by (auto simp add: nvalid_def)
qed

lemma valid_augment_Faults:
  assumes validn:"\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"
  assumes F': "F \<subseteq> F'"
  shows "\<Gamma>\<Turnstile>\<^bsub>/F'\<^esub> P c Q,A"
proof (rule validI)
  fix s t
  assume exec: "\<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> \<Rightarrow> t"
  assume P: "s \<in> P"
  assume F: "t \<notin> Fault ` F'"
  with F' have "t \<notin> Fault ` F"
    by blast
  with exec P validn
  show "t \<in> Normal ` Q \<union> Abrupt ` A"
    by (auto simp add: valid_def)
qed

lemma nvalid_to_nvalid_strip:
  assumes validn:"\<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A"
  assumes F': "F' \<subseteq> -F"
  shows "strip F' \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A"
proof (rule nvalidI)
  fix s t
  assume exec_strip: "strip F' \<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> =n\<Rightarrow> t"
  assume P: "s \<in> P"
  assume F: "t \<notin> Fault ` F"
  from exec_strip obtain t' where
    exec: "\<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> =n\<Rightarrow> t'" and
    t': "t' \<in> Fault ` (-F') \<longrightarrow> t'=t" "\<not> isFault t' \<longrightarrow> t'=t"
    by (blast dest: execn_strip_to_execn)
  show "t \<in> Normal ` Q \<union> Abrupt ` A"
  proof (cases "t' \<in> Fault ` F")
    case True
    with t' F F' have False
      by blast
    thus ?thesis ..
  next
    case False
    with exec P validn
    have "t' \<in> Normal ` Q \<union> Abrupt ` A"
      by (auto simp add: nvalid_def)
    moreover
    from this t' have "t'=t"
      by auto
    ultimately show ?thesis
      by simp
  qed
qed

lemma valid_to_valid_strip:
  assumes valid:"\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"
  assumes F': "F' \<subseteq> -F"
  shows "strip F' \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"
proof (rule validI)
  fix s t
  assume exec_strip: "strip F' \<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> \<Rightarrow> t"
  assume P: "s \<in> P"
  assume F: "t \<notin> Fault ` F"
  from exec_strip obtain t' where
    exec: "\<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> \<Rightarrow> t'" and
    t': "t' \<in> Fault ` (-F') \<longrightarrow> t'=t" "\<not> isFault t' \<longrightarrow> t'=t"
    by (blast dest: exec_strip_to_exec)
  show "t \<in> Normal ` Q \<union> Abrupt ` A"
  proof (cases "t' \<in> Fault ` F")
    case True
    with t' F F' have False
      by blast
    thus ?thesis ..
  next
    case False
    with exec P valid
    have "t' \<in> Normal ` Q \<union> Abrupt ` A"
      by (auto simp add: valid_def)
    moreover
    from this t' have "t'=t"
      by auto
    ultimately show ?thesis
      by simp
  qed
qed

subsection {* The Hoare Rules: @{text "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"} *}

lemma mono_WeakenContext: "A \<subseteq> B \<Longrightarrow>
        (\<lambda>(P, c, Q, A'). (\<Gamma>, \<Theta>, F, P, c, Q, A') \<in> A) x \<longrightarrow>
        (\<lambda>(P, c, Q, A'). (\<Gamma>, \<Theta>, F, P, c, Q, A') \<in> B) x"
apply blast
done

inductive "hoarep"::"[('s,'p,'f) body,('s,'p) quadruple set,'f set,
    's assn,('s,'p,'f) com, 's assn,'s assn] => bool"
    ("(3_,_/\<turnstile>\<^bsub>'/_ \<^esub>(_/ (_)/ _,/_))" [60,60,60,1000,20,1000,1000]60)
  for \<Gamma>::"('s,'p,'f) body"
where
  Skip: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> Q Skip Q,A"

| Basic: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. f s \<in> Q} (Basic f) Q,A"

| Spec: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. (\<forall>t. (s,t) \<in> r \<longrightarrow> t \<in> Q) \<and> (\<exists>t. (s,t) \<in> r)} (Spec r) Q,A"

| Seq: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c\<^sub>1 R,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c\<^sub>2 Q,A\<rbrakk>
        \<Longrightarrow>
        \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Seq c\<^sub>1 c\<^sub>2) Q,A"

| Cond: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> b) c\<^sub>1 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> - b) c\<^sub>2 Q,A\<rbrakk>
         \<Longrightarrow>
         \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Cond b c\<^sub>1 c\<^sub>2) Q,A"

| While: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> b) c P,A
          \<Longrightarrow>
          \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (While b c) (P \<inter> - b),A"

| Guard: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (g \<inter> P) c Q,A
          \<Longrightarrow>
          \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (g \<inter> P) (Guard f g c) Q,A"

| Guarantee: "\<lbrakk>f \<in> F; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (g \<inter> P) c Q,A\<rbrakk>
              \<Longrightarrow>
              \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Guard f g c) Q,A"

| CallRec:
  "\<lbrakk>(P,p,Q,A) \<in> Specs;
    \<forall>(P,p,Q,A) \<in> Specs. p \<in> dom \<Gamma> \<and> \<Gamma>,\<Theta>\<union>Specs\<turnstile>\<^bsub>/F\<^esub> P (the (\<Gamma> p)) Q,A \<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Call p) Q,A"

| DynCom:
      "\<forall>s \<in> P. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (c s) Q,A
      \<Longrightarrow>
      \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (DynCom c) Q,A"

| Throw: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> A Throw Q,A"

| Catch: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c\<^sub>1 Q,R; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c\<^sub>2 Q,A\<rbrakk> \<Longrightarrow>  \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P Catch c\<^sub>1 c\<^sub>2 Q,A"

| Conseq: "\<forall>s \<in> P. \<exists>P' Q' A'. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' c Q',A' \<and> s \<in> P' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A
           \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"

| Asm: "\<lbrakk>(P,p,Q,A) \<in> \<Theta>\<rbrakk>
         \<Longrightarrow>
         \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Call p) Q,A"

| ExFalso: "\<lbrakk>\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A; \<not> \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  -- {* This is a hack rule that enables us to derive completeness for
        an arbitrary context @{text "\<Theta>"}, from completeness for an empty context.*}

text {* Does not work, because of rule ExFalso, the context @{text "\<Theta>"} is to blame.
 A weaker version with empty context can be derived from soundness
 and completeness later on. *}
lemma hoare_strip_\<Gamma>:
  assumes deriv: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P p Q,A"
  shows "strip (-F) \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P p Q,A"
using deriv
proof induct
  case Skip thus ?case by (iprover intro: hoarep.Skip)
next
  case Basic thus ?case by (iprover intro: hoarep.Basic)
next
  case Spec thus ?case by (iprover intro: hoarep.Spec)
next
  case Seq thus ?case by (iprover intro: hoarep.Seq)
next
  case Cond thus ?case by (iprover intro: hoarep.Cond)
next
  case While thus ?case by (iprover intro: hoarep.While)
next
  case Guard thus ?case by (iprover intro: hoarep.Guard)
(*next
  case CallSpec thus ?case by (iprover intro: hoarep.CallSpec)
next
  case (CallRec A Abr Abr' Init P Post Pre Procs Q R Result Return Z \<Gamma> \<Theta> init p
         result return )
  from CallRec.hyps
  have "\<forall>p\<in>Procs. \<forall>Z. (strip \<Gamma>),\<Theta> \<union>
             (\<Union>\<^bsub>p\<in>Procs\<^esub>
                 \<Union>\<^bsub>Z\<^esub> {(Pre p Z, Call (Init p) p (Return p) (Result p),
                      Post p Z, Abr p Z)})\<turnstile>
            (Pre p Z) (the (\<Gamma> p)) (R p Z),(Abr' p Z)" by blast
  hence "\<forall>p\<in>Procs. \<forall>Z. (strip \<Gamma>),\<Theta> \<union>
             (\<Union>\<^bsub>p\<in>Procs\<^esub>
                 \<Union>\<^bsub>Z\<^esub> {(Pre p Z, Call (Init p) p (Return p) (Result p),
                      Post p Z, Abr p Z)})\<turnstile>
            (Pre p Z) (the ((strip \<Gamma>) p)) (R p Z),(Abr' p Z)"
    by (auto intro: hoarep.StripI)
  then show ?case
    apply -
    apply (rule hoarep.CallRec)
    apply (assumption | simp only:dom_strip)+
    done*)
next
  case DynCom
  thus ?case
    by - (rule hoarep.DynCom,best  elim!: ballE exE)
next
  case Throw thus ?case by (iprover intro: hoarep.Throw)
next
  case Catch thus ?case by (iprover intro: hoarep.Catch)
(*next
  case CONSEQ thus ?case apply (auto intro: hoarep.CONSEQ)*)
next
  case Asm thus ?case by (iprover intro: hoarep.Asm)
next
  case ExFalso
  thus ?case
    oops

lemma hoare_augment_context:
  assumes deriv: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P p Q,A"
  shows "\<And>\<Theta>'. \<Theta> \<subseteq> \<Theta>' \<Longrightarrow> \<Gamma>,\<Theta>'\<turnstile>\<^bsub>/F\<^esub> P p Q,A"
using deriv
proof (induct)
  case CallRec
  case (CallRec P p Q A Specs \<Theta> F \<Theta>')
  from CallRec.prems
  have "\<Theta>\<union>Specs
       \<subseteq> \<Theta>'\<union>Specs"
    by blast
  with CallRec.hyps (2)
  have "\<forall>(P,p,Q,A)\<in>Specs.  p \<in> dom \<Gamma> \<and> \<Gamma>,\<Theta>'\<union>Specs \<turnstile>\<^bsub>/F\<^esub> P  (the (\<Gamma> p)) Q,A"
    by fastforce

  with CallRec show ?case by - (rule hoarep.CallRec)
next
  case DynCom thus ?case by (blast intro: hoarep.DynCom)
next
  case (Conseq P \<Theta> F c Q A \<Theta>')
  from Conseq
  have "\<forall>s \<in> P.
         (\<exists>P' Q' A'. \<Gamma>,\<Theta>' \<turnstile>\<^bsub>/F\<^esub> P' c Q',A' \<and> s \<in> P' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A)"
    by blast
  with Conseq show ?case by - (rule hoarep.Conseq)
next
  case (ExFalso \<Theta> F P c Q A \<Theta>')
  have valid_ctxt: "\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A" "\<Theta> \<subseteq> \<Theta>'" by fact+
  hence "\<forall>n. \<Gamma>,\<Theta>'\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A"
    by (simp add: cnvalid_def) blast
  moreover have invalid: "\<not> \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"  by fact
  ultimately show ?case
    by (rule hoarep.ExFalso)
qed (blast intro: hoarep.intros)+

subsection {* Some Derived Rules *}

lemma  Conseq': "\<forall>s. s \<in> P \<longrightarrow>
            (\<exists>P' Q' A'.
              (\<forall> Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) c (Q' Z),(A' Z)) \<and>
                    (\<exists>Z. s \<in> P' Z \<and> (Q' Z \<subseteq> Q) \<and> (A' Z \<subseteq> A)))
           \<Longrightarrow>
           \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
apply (rule Conseq)
apply (rule ballI)
apply (erule_tac x=s in allE)
apply (clarify)
apply (rule_tac x="P' Z" in exI)
apply (rule_tac x="Q' Z" in exI)
apply (rule_tac x="A' Z" in exI)
apply blast
done

lemma conseq:"\<lbrakk>\<forall>Z. \<Gamma>,\<Theta> \<turnstile>\<^bsub>/F\<^esub> (P' Z) c (Q' Z),(A' Z);
              \<forall>s. s \<in> P \<longrightarrow> (\<exists> Z. s\<in>P' Z \<and> (Q' Z \<subseteq> Q) \<and> (A' Z \<subseteq> A))\<rbrakk>
              \<Longrightarrow>
              \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  by (rule Conseq) blast

theorem conseqPrePost [trans]:
  "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' c Q',A' \<Longrightarrow> P \<subseteq> P' \<Longrightarrow>  Q' \<subseteq> Q \<Longrightarrow> A' \<subseteq> A \<Longrightarrow>  \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  by (rule conseq [where ?P'="\<lambda>Z. P'" and ?Q'="\<lambda>Z. Q'"]) auto

lemma conseqPre [trans]: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' c Q,A \<Longrightarrow> P \<subseteq> P' \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
by (rule conseq) auto

lemma conseqPost [trans]: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q',A' \<Longrightarrow> Q' \<subseteq> Q \<Longrightarrow> A' \<subseteq> A
 \<Longrightarrow>   \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  by (rule conseq) auto

lemma CallRec':
  "\<lbrakk>p\<in>Procs; Procs \<subseteq> dom \<Gamma>;
   \<forall>p\<in>Procs.
    \<forall>Z. \<Gamma>,\<Theta> \<union> (\<Union>p\<in>Procs. \<Union>Z. {((P p Z),p,Q p Z,A p Z)})
        \<turnstile>\<^bsub>/F\<^esub> (P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)\<rbrakk>
   \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P p Z) (Call p) (Q p Z),(A p Z)"
apply (rule CallRec [where Specs="\<Union>p\<in>Procs. \<Union>Z. {((P p Z),p,Q p Z,A p Z)}"])
apply  blast
apply blast
done

end