(*

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.

*)

(* ######################################################################### *)
chapter "Deterministic Exception Handler for the MIPS R4600"
(* ######################################################################### *)

(*<*)
theory MipsTLBReplacementHandlerDeter
  imports MipsTLB MipsTLBPageTable
begin
(*>*)

text "This model is a deterministic version of a TLB + exceptin handler for
      the MIPS R4600 TLB model. In this model, each page table entry for a
      particular VPN will always be present int the very same entry in the
      TLB, if at all. "

(* ========================================================================= *)
section "MIPS TLB + MIPS PageTables"
(* ========================================================================= *)

text "We now define the combination of a MIPS TLB and a MIPS PageTable. All
      entries of the TLB will be populated based on the page table."

record MipsTLBPT =
  tlb :: MIPSTLB
  pte :: MIPSPT

(* ========================================================================= *)
section "Deterministic Exception Handler"
(* ========================================================================= *)

text "This MIPS TLB exception handler replaces an entry of the TLB with
      the contents of the page table in a deterministic fashion, i.e.
      for each VPN the entry to be replaced will always be the same. For
      this we defined first a TLB index function."

(* ------------------------------------------------------------------------- *)
subsection "TLB Index calculation"
(* ------------------------------------------------------------------------- *)

text "We define the following function that takes a TLB entry and a TLB and
      produces an natural number, i.e. the index of the entry in the TLB. For
      this we use a simple hash function from the VPN2 of the entry modulo
      the TLB capacity."

definition MIPSTLBIndex :: "MIPSTLB \<Rightarrow> TLBENTRY \<Rightarrow> nat"
  where "MIPSTLBIndex t e = ((vpn2 (hi (e))) mod (capacity t))"

text "The definition above will always produce a TLB Index which is within the
      valid range of the TLB i.e. does not exceed it's capacity."

lemma MIPSTLBIndex_in_range:
  "\<forall>e.  (capacity t) > 0 \<Longrightarrow>  MIPSTLBIndex t e <  (capacity t)"
  by(auto simp:MIPSTLBIndex_def)

text "Moreover, this definition of the index calculation gives us that if the
      calculated indexes are different this implies that the two entries are not
      the same."

lemma "\<And>e f. MIPSTLBIndex t e \<noteq> MIPSTLBIndex t f
                  \<Longrightarrow> ((vpn2 (hi e)) \<noteq> (vpn2 (hi f)))"
  by(auto simp add:MIPSTLBIndex_def)

lemma "\<And>e f. MIPSTLBIndex t e \<noteq> MIPSTLBIndex t f \<Longrightarrow> e \<noteq> f"
  by(auto simp add:MIPSTLBIndex_def)

(* ------------------------------------------------------------------------- *)
subsection "Deterministic Exception Handler"
(* ------------------------------------------------------------------------- *)

text "Based on the index calculation above we can define the deterministic
      exception handler.  "

definition MipsTLBPT_update_tlb :: "MipsTLBPT \<Rightarrow> ASID \<Rightarrow> VPN  \<Rightarrow> MipsTLBPT"
  where "MipsTLBPT_update_tlb mpt as vpn = \<lparr>
         tlb = \<lparr>
            capacity = (capacity (tlb mpt)),
            wired = (wired (tlb mpt)),
            random = random (tlb mpt),
            entries = (entries (tlb mpt))(
               (MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn))
                :=  MIPSPT_mk_tlbentry (pte mpt) as vpn) \<rparr>,
         pte = (pte mpt)\<rparr>"

text "we show that the definition produces the same result as when using the
      tlbwi function, and therefore we can use the simpler, direct
      equivalent."

lemma MipsTLBPT_update_equivalence:
  "(capacity  (tlb mpt)) > 0  \<Longrightarrow>
    {\<lparr>tlb = t, pte = (pte mpt)\<rparr> | t.
       t \<in> tlbwi (MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn))
                 (MIPSPT_mk_tlbentry (pte mpt) as vpn) (tlb mpt)}
     = {MipsTLBPT_update_tlb mpt as vpn}"
by(simp add:MipsTLBPT_update_tlb_def tlbwi_def MIPSTLBIndex_def)

text "The TLB update function does not change the capacity of the TLB."

lemma MipsTLBPT_det_capacity :
  "(capacity (tlb (MipsTLBPT_update_tlb mpt as vpn))) = (capacity (tlb mpt))"
  by(simp add:MipsTLBPT_update_tlb_def)

(* ========================================================================= *)
section "Valid TLB+PageTables"
(* ========================================================================= *)

text "We say that the combination is valid, if both the TLB and the page table
     are valid. In addition, the TLB is an instance of the page table if there
     is a corresponding entry in the page table for all entries in the TLB with
     a matching ASID. In addition, the deterministic replacement handler
     ensures a particular location for the entry."

definition MipsTLBPT_is_instance :: "MipsTLBPT \<Rightarrow> bool"
  where "MipsTLBPT_is_instance mt = (\<forall>i<(capacity (tlb mt)).
       (((entries (tlb mt) i) =
            MIPSPT_mk_tlbentry (pte mt) (asid (hi(entries (tlb mt) i))) (vpn2(hi(entries (tlb mt) i)))) \<and>
       (i = MIPSTLBIndex (tlb mt) (entries (tlb mt) i))))"

text "If the TLB is an instance of the page table then forall entries if
      the ASID matches with the the ASID of the page table, then the
      TLB entry must be the same as if its created from the page table."

lemma  "MipsTLBPT_is_instance mt \<Longrightarrow>i < (capacity (tlb mt)) \<Longrightarrow>
      (entries (tlb mt) i) = MIPSPT_mk_tlbentry (pte mt)  (asid (hi(entries (tlb mt) i))) (vpn2(hi(entries (tlb mt) i)))"
  by(simp add:MipsTLBPT_is_instance_def)

text "We therefore can define the validity of a MIPS TLB + PageTable combination
      as the page tables and the TLB are valid and the TLB is an instance of
      the page tables."

definition MipsTLBPT_valid :: "MipsTLBPT \<Rightarrow> bool"
  where "MipsTLBPT_valid mt = ((MIPSPT_valid (pte mt)) \<and> (TLBValid (tlb mt))
                              \<and> (MipsTLBPT_is_instance mt) )"

text "If the MIPS TLB and PageTables are valid then for all VPNs the translate
      set of the TLB must be a subset of equal to the translate set of the
      PageTable."

(* TODO *)

lemma "\<forall>vpn. MipsTLBPT_valid mt \<Longrightarrow> MIPSTLB_translate (tlb mpt) as vpn
                 \<subseteq>  MIPSPT_translate (pte mpt) as vpn"
  oops

(* ========================================================================= *)
section "Translate Function"
(* ========================================================================= *)

text "The Translate function checks whether the VPN can be translated using the
      TLB. "

definition MipsTLBPT_translate :: "MipsTLBPT \<Rightarrow> ASID \<Rightarrow> VPN \<Rightarrow> PFN set"
  where "MipsTLBPT_translate  mtlb as vpn =
          MIPSTLB_translate (tlb (MipsTLBPT_update_tlb mtlb as vpn)) as vpn "

(* ========================================================================= *)
section "Proofs"
(* ========================================================================= *)

text "Next we proof that if the state of the MIPSTLB and page tables is valid
      then handling an exception will always results in a valid state again."

lemma MipsTLBT_keeps_instance:
  "\<And>vpn mpt as. MipsTLBPT_valid mpt \<Longrightarrow> vpn < MIPSPT_EntriesMax
           \<Longrightarrow> MipsTLBPT_is_instance(MipsTLBPT_update_tlb mpt as vpn)"
  apply(simp add:MipsTLBPT_valid_def)
  apply(simp add:MipsTLBPT_is_instance_def)
  apply(simp add:MipsTLBPT_update_tlb_def MIPSTLBIndex_in_range
                 MIPSPT_TLBENTRY_asidmatch)
  apply(simp add:MIPSTLBIndex_def)
  apply(simp add:MIPSPT_mk_tlbentry_def)
  apply(simp add:TLBENTRY.make_def)
  done

lemma MipsTLBPT_not_match :
assumes valid: "MipsTLBPT_valid mpt"
    and inrange: "\<And>vpn. vpn < MIPSPT_EntriesMax"
    and inoteq : "\<And>i vpn. i \<noteq>  MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn)"
    and ibound: "\<And>i. i < (capacity (tlb mt))"
  shows "\<And>i vpn.  EntryMatch (MIPSPT_mk_tlbentry (pte mpt) as vpn) (entries (tlb mpt) i) \<Longrightarrow> False"
proof -
  from valid have inst: "MipsTLBPT_is_instance mpt"
    by(simp add:MipsTLBPT_valid_def)

  from  inoteq ibound inrange inst have nomatch:
    "\<And>i.  EntryASIDMatch (MIPSPT_mk_tlbentry (pte mpt) as vpn) (entries (tlb mpt) i) = False"
    by(auto simp add:EntryASIDMatch_def MipsTLBPT_is_instance_def MIPSPT_TLBENTRY_asid_is
                     MIPSPT_mk_tlbentry_def TLBENTRY.make_def)

  from  inoteq ibound inrange inst nomatch
    show "\<And>i vpn.  EntryMatch (MIPSPT_mk_tlbentry (pte mpt) as vpn) (entries (tlb mpt) i) \<Longrightarrow> False"
    by(auto simp:EntryASIDMatch_def)
qed

lemma MipsTLBT_keeps_TLBValid :
  assumes valid: "MipsTLBPT_valid mpt "
    and inrange: "\<And>vpn. vpn < MIPSPT_EntriesMax"
    and inrange2: "\<And>as. ASIDValid as"
      shows "\<And>vpn as. TLBValid(tlb (MipsTLBPT_update_tlb mpt as vpn))"
proof -
  from valid have X0: "TLBValid (tlb mpt)"
    by(auto simp add:MipsTLBPT_valid_def)

  from X0 have alleven: "\<forall>i < (capacity (tlb mpt)). even (vpn2 (hi (entries (tlb mpt) i)))"
    by(simp add:TLBValid_def TLBEntryWellFormed_def TLBENTRYWellFormed_def TLBENTRYHIWellFormed_def
                VPN2Valid_def)

  also have X1: "\<And>vpn as. (wired (tlb (MipsTLBPT_update_tlb mpt as vpn))) =  (wired (tlb mpt)) "
    by(simp add:MipsTLBPT_update_tlb_def)

  from valid have X2: "MipsTLBPT_is_instance mpt"
    by(auto simp:MipsTLBPT_valid_def)

  from valid have X3: " MIPSPT_valid (pte mpt)"
    by(auto simp:MipsTLBPT_valid_def)

  from inrange inrange2 X3 have X5:
      "\<And>vpn as. TLBENTRYWellFormed ( MIPSPT_mk_tlbentry (pte mpt) as vpn) "
      by(simp add:MIPSPT_TLBENTRY_wellformed)

  from inrange X3 X0 X5 have X4: "\<And>vpn as. \<forall>i<(capacity (tlb mpt)).
        TLBEntryWellFormed (tlb (MipsTLBPT_update_tlb mpt as vpn)) i"
  proof -

    have A0:  "\<And>vpn as. (\<forall>i<(capacity (tlb mpt)).
           TLBEntryWellFormed (tlb (MipsTLBPT_update_tlb mpt as vpn)) i) =
          (\<forall>i<(capacity (tlb mpt)).
              (i = (MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn))
                   \<longrightarrow> TLBEntryWellFormed (tlb (MipsTLBPT_update_tlb mpt as vpn)) i) \<and>
              (i \<noteq> (MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn))
                   \<longrightarrow> TLBEntryWellFormed (tlb (MipsTLBPT_update_tlb mpt as vpn)) i))"
      by(auto)

    have A1:  "... = ( \<lambda>vpn as. \<forall>i<(capacity (tlb mpt)).
        (i = MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn)
            \<longrightarrow> TLBENTRYWellFormed (MIPSPT_mk_tlbentry (pte mpt) as vpn)) \<and>
        (i \<noteq> MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn)
            \<longrightarrow> TLBENTRYWellFormed (entries (tlb mpt) i)))"

      by(simp add:MipsTLBPT_update_tlb_def TLBEntryWellFormed_def)

    with inrange A1 A0 X0 X3 show "\<And>vpn as. \<forall>i<(capacity (tlb mpt)).
        TLBEntryWellFormed (tlb (MipsTLBPT_update_tlb mpt as vpn)) i"
      by(auto simp:MIPSPT_TLBENTRY_wellformed TLBValid_def TLBEntryWellFormed_def MIPSTLBIndex_in_range)
  qed

  from X0 X1 X4 have X6:
      "\<And>vpn as. TLBValid (tlb (MipsTLBPT_update_tlb mpt as vpn)) =
      (\<forall>i<(capacity (tlb mpt)).
          TLBEntryConflictSet (entries (tlb (MipsTLBPT_update_tlb mpt as vpn)) i)
                              (tlb (MipsTLBPT_update_tlb mpt as vpn)) \<subseteq> {i})"
    by(simp add:TLBValid_def MipsTLBPT_det_capacity)

  from inrange X2 have X7: "... =  (\<lambda>vpn as. \<forall>i<(capacity (tlb mpt)).
        {ia. ia < (capacity (tlb mpt)) \<and>
            EntryMatch (entries (tlb (MipsTLBPT_update_tlb mpt as vpn)) ia)
                       (entries (tlb (MipsTLBPT_update_tlb mpt as vpn)) i)} \<subseteq> {i})"
   by(simp add:TLBEntryConflictSet_def MipsTLBPT_det_capacity)

  from inrange X2 have X8: "... = (\<lambda>vpn as. \<forall>i. (i = MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn) \<longrightarrow>
          {ia. ia \<noteq> MIPSTLBIndex  (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn)
            \<longrightarrow> ia < (capacity (tlb mpt)) \<and> EntryMatch (MIPSPT_mk_tlbentry (pte mpt) as vpn) (entries (tlb mpt) ia)}
          \<subseteq> {MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as  vpn)}) \<and>
         (i \<noteq> MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt)as vpn) \<longrightarrow>
          i < (capacity (tlb mpt)) \<longrightarrow>
          {ia. (ia = MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn)
              \<longrightarrow> EntryMatch (MIPSPT_mk_tlbentry (pte mpt) as vpn) (entries (tlb mpt) i)) \<and>
               (ia \<noteq> MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn)
              \<longrightarrow> ia < (capacity (tlb mpt)) \<and> EntryMatch (entries (tlb mpt) i) (entries (tlb mpt) ia))}
          \<subseteq> {i}))"
    by(auto simp add:MipsTLBPT_update_tlb_def MIPSTLBIndex_in_range EntryMatch_true EntryMatch_commute  )

  from inrange valid  have X10: "... =  (\<lambda>vpn as. \<forall>i. (i = MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn)
         \<longrightarrow>  {ia. ia \<noteq> MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn)
              \<longrightarrow> ia < (capacity (tlb mpt)) \<and> EntryMatch (MIPSPT_mk_tlbentry (pte mpt) as vpn) (entries (tlb mpt) ia)}
          \<subseteq> {MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn)}) \<and>
         (i \<noteq> MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn) \<longrightarrow>
          i < (capacity (tlb mpt)) \<longrightarrow>
          {ia. ia \<noteq> MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn) \<and>
                ia < (capacity (tlb mpt)) \<and> EntryMatch (entries (tlb mpt) i) (entries (tlb mpt) ia)}
          \<subseteq> {i}))"
    by(auto simp add:MipsTLBPT_not_match)

    from inrange valid X0 have X11:  "... =  (\<lambda>vpn as. \<forall>i. (i = MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn) \<longrightarrow>
          {ia. ia \<noteq> MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn)
      \<longrightarrow> ia < (capacity (tlb mpt)) \<and> EntryMatch (MIPSPT_mk_tlbentry (pte mpt) as vpn) (entries (tlb mpt) ia)}
          \<subseteq> {MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn)}))"
      by(auto simp add:TLBValid_def TLBEntryConflictSet_def)

    have X12: "... = (\<lambda>vpn as. {ia. ia \<noteq> MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn)
      \<longrightarrow> ia < (capacity (tlb mpt)) \<and> EntryMatch (MIPSPT_mk_tlbentry (pte mpt) as vpn) (entries (tlb mpt) ia)}
          \<subseteq> {MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn)})"
      by(auto)

    have X13: "... = (\<lambda>vpn as.
          { MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn) } \<union>
          {ia. ia < (capacity (tlb mpt)) \<and> EntryMatch (MIPSPT_mk_tlbentry (pte mpt) as vpn) (entries (tlb mpt) ia)}
          \<subseteq> {MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn)})"
      by(auto)

    have X14: "... =  (\<lambda>vpn as.
          { MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn) } \<union>
           {ia. ia < (capacity (tlb mpt))
              \<and>  ia \<noteq>  MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn)
              \<and> EntryMatch (MIPSPT_mk_tlbentry (pte mpt) as vpn) (entries (tlb mpt) ia)} \<union>
           {ia. ia < (capacity (tlb mpt))
              \<and> ia =  MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn)
              \<and> EntryMatch (MIPSPT_mk_tlbentry (pte mpt) as vpn) (entries (tlb mpt) ia)}
          \<subseteq> {MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn)})"
     by(auto)

   have X15: "... =  (\<lambda>vpn as.
     {ia. ia < (capacity (tlb mpt))
        \<and> ia \<noteq> MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn)
        \<and> EntryMatch (MIPSPT_mk_tlbentry (pte mpt) as vpn) (entries (tlb mpt) ia)} \<union>
     {ia. ia < (capacity (tlb mpt))
        \<and> ia = MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn)
        \<and> EntryMatch (MIPSPT_mk_tlbentry (pte mpt) as vpn) (entries (tlb mpt) ia)}
     \<subseteq> {MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn)})"
     by(simp)

   from valid inrange have X16: "... = ( \<lambda>vpn as.
      {ia. ia < (capacity (tlb mpt))
          \<and> ia = MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn)
          \<and> EntryMatch (MIPSPT_mk_tlbentry (pte mpt) as vpn) (entries (tlb mpt) ia)}
     \<subseteq> {MIPSTLBIndex (tlb mpt) (MIPSPT_mk_tlbentry (pte mpt) as vpn)})"
     by(auto simp add:MipsTLBPT_not_match )

   with valid inrange alleven inrange2 X0 X1 X2 X3 X4 X5 X6 X7 X8 X10 X11 X12 X13 X14 X15 X16
    show "\<And>vpn as. TLBValid(tlb (MipsTLBPT_update_tlb mpt as vpn))"
      by(auto)
qed

lemma MipsTLBT_keeps_ptvalid: "\<And>vpn mpt as. MipsTLBPT_valid mpt \<Longrightarrow> vpn < MIPSPT_EntriesMax
           \<Longrightarrow>  MIPSPT_valid (pte (MipsTLBPT_update_tlb mpt as vpn))"
  by(simp add:MipsTLBPT_valid_def MipsTLBPT_update_tlb_def)

lemma
    assumes valid: "MipsTLBPT_valid mpt "
    and inrange: "\<And>vpn. vpn < MIPSPT_EntriesMax"
    and inrange2: "\<And>as. ASIDValid as"
shows  "\<And>vpn as.  MipsTLBPT_valid(MipsTLBPT_update_tlb mpt as vpn)"
  apply(subst MipsTLBPT_valid_def)
  apply(simp add:MipsTLBT_keeps_ptvalid valid inrange)
  apply(simp add:MipsTLBT_keeps_instance valid inrange)
  apply(simp add:MipsTLBT_keeps_TLBValid valid inrange inrange2)
  done

(* ========================================================================= *)
section "Equivalence to Large TLB"
(* ========================================================================= *)

text "Next we show that for all "

lemma "\<And>mpt vpn as. MipsTLBPT_translate mpt as vpn = MIPSTLB_translate (MipsTLBLarge_create (pte mpt)) as vpn"
  oops

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Early_Sim_Pres
  imports Weak_Early_Sim
begin

lemma tauPres:
  fixes P    :: pi
  and   Q    :: pi
  and   Rel  :: "(pi \<times> pi) set"
  and   Rel' :: "(pi \<times> pi) set"

  assumes PRelQ: "(P, Q) \<in> Rel"

  shows "\<tau>.(P) \<leadsto><Rel> \<tau>.(Q)"
proof(induct rule: simCases)
  case(Bound Q' a x)
  have "\<tau>.(Q) \<longmapsto>a<\<nu>x> \<prec> Q'" by fact
  hence False by(induct rule: tauCases', auto)
  thus ?case by simp
next
  case(Free Q' \<alpha>)
  have "\<tau>.(Q) \<longmapsto>(\<alpha> \<prec> Q')" by fact
  thus ?case
  proof(induct rule: tauCases', auto simp only: pi.inject residual.inject)
    have "\<tau>.(P) \<Longrightarrow>\<^sup>^ \<tau> \<prec> P" by(rule Tau)
    with PRelQ show "\<exists>P'. \<tau>.(P) \<Longrightarrow>\<^sup>^\<tau> \<prec> P' \<and> (P', Q) \<in> Rel" by blast
  qed
qed

lemma inputPres:
  fixes P    :: pi
  and   x    :: name
  and   Q    :: pi
  and   a    :: name
  and   Rel  :: "(pi \<times> pi) set"

  assumes PRelQ: "\<forall>y. (P[x::=y], Q[x::=y]) \<in> Rel"
  and     Eqvt: "eqvt Rel"

  shows "a<x>.P \<leadsto><Rel> a<x>.Q"
using Eqvt
proof(induct rule: simCasesCont[where C="(x, a, P, Q)"])
  case(Bound b y Q')
  from \<open>y \<sharp> (x, a, P, Q)\<close> have "y \<noteq> x" "y \<noteq> a" "y \<sharp> P" "y \<sharp> Q" by simp+
  from \<open>a<x>.Q \<longmapsto>b<\<nu>y> \<prec> Q'\<close> \<open>y \<noteq> a\<close> \<open>y \<noteq> x\<close> \<open>y \<sharp> Q\<close> show ?case
    by(erule_tac inputCases') auto
next
  case(Free \<alpha> Q')
  from \<open>a<x>.Q \<longmapsto> \<alpha> \<prec> Q'\<close>
  show ?case
  proof(induct rule: inputCases)
    case(cInput u)
    have "a<x>.P \<Longrightarrow>\<^sup>^(a<u>) \<prec> P[x::=u]"
      by(rule Input)
    moreover from PRelQ have "(P[x::=u], Q[x::=u]) \<in> Rel" by auto
    ultimately show ?case by blast
  qed
qed

lemma outputPres:
  fixes P    :: pi
  and   Q    :: pi
  and   a    :: name
  and   b    :: name
  and   Rel  :: "(pi \<times> pi) set"

  assumes PRelQ: "(P, Q) \<in> Rel"

  shows "a{b}.P \<leadsto><Rel> a{b}.Q"
proof(induct rule: simCases)
  case(Bound Q' c x)
  have "a{b}.Q \<longmapsto>c<\<nu>x> \<prec> Q'" by fact
  hence False by(induct rule: outputCases', auto)
  thus ?case by simp
next
  case(Free Q' \<alpha>)
  have "a{b}.Q \<longmapsto>\<alpha> \<prec> Q'" by fact
  thus "\<exists>P'. a{b}.P \<Longrightarrow>\<^sup>^ \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"
  proof(induct rule: outputCases', auto simp add: pi.inject residual.inject)
    have "a{b}.P \<Longrightarrow>\<^sup>^ a[b] \<prec> P" by(rule Output)
    with PRelQ show "\<exists>P'. a{b}.P \<Longrightarrow>\<^sup>^ a[b] \<prec> P' \<and> (P', Q) \<in> Rel" by blast
  qed
qed

  assumes PSimQ: "P \<leadsto><Rel> Q"
  and     RelRel': "Rel \<subseteq> Rel'"
  and     RelStay: "\<And>R S c. (R, S) \<in> Rel \<Longrightarrow> ([c\<frown>c]R, S) \<in> Rel"

  shows "[a\<frown>b]P \<leadsto><Rel'> [a\<frown>b]Q"
proof(induct rule: simCases)
  case(Bound Q' c x)
  have "x \<sharp> [a\<frown>b]P" by fact
  hence xFreshP: "(x::name) \<sharp> P" by simp
  have "[a\<frown>b]Q \<longmapsto>c<\<nu>x> \<prec> Q'" by fact
  thus ?case
  proof(induct rule: matchCases)
    case Match
    have "Q \<longmapsto>c<\<nu>x> \<prec> Q'" by fact
    with PSimQ xFreshP obtain P' where PTrans: "P \<Longrightarrow>c<\<nu>x> \<prec> P'"
                                   and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: simE)
    from PTrans have "[a\<frown>a]P \<Longrightarrow>c<\<nu>x> \<prec> P'" by(rule Weak_Early_Step_Semantics.Match)
    moreover from P'RelQ' RelRel' have "(P', Q') \<in> Rel'" by blast
    ultimately show ?case by blast
  qed
next
  case(Free Q' \<alpha>)
  have "[a\<frown>b]Q \<longmapsto>\<alpha> \<prec> Q'" by fact
  thus ?case
  proof(induct rule: matchCases)
    case Match
    have "Q \<longmapsto> \<alpha> \<prec> Q'" by fact
    with PSimQ obtain P' where "P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P'" and "(P', Q') \<in> Rel"
      by(blast dest: simE)
    thus ?case
    proof(induct rule: transitionCases)
      case Step
      have "P \<Longrightarrow>\<alpha> \<prec> P'" by fact
      hence "[a\<frown>a]P \<Longrightarrow>\<alpha> \<prec> P'" by(rule Weak_Early_Step_Semantics.Match)
      with RelRel' \<open>(P', Q') \<in> Rel\<close> show ?case by(force simp add: weakFreeTransition_def)
    next
      case Stay
      have "[a\<frown>a]P \<Longrightarrow>\<^sup>^\<tau> \<prec> [a\<frown>a]P" by(simp add: weakFreeTransition_def)
      moreover from \<open>(P, Q') \<in> Rel\<close> have "([a\<frown>a]P, Q') \<in> Rel" by(blast intro: RelStay)
      ultimately show ?case using RelRel' by blast
    qed
  qed
qed

lemma mismatchPres:
  fixes P    :: pi
  and   Q    :: pi
  and   a    :: name
  and   b    :: name
  and   Rel  :: "(pi \<times> pi) set"
  and   Rel' :: "(pi \<times> pi) set"

  assumes PSimQ: "P \<leadsto><Rel> Q"
  and     RelRel': "Rel \<subseteq> Rel'"
  and     RelStay: "\<And>R S c d. \<lbrakk>(R, S) \<in> Rel; c \<noteq> d\<rbrakk> \<Longrightarrow> ([c\<noteq>d]R, S) \<in> Rel"

  shows "[a\<noteq>b]P \<leadsto><Rel'> [a\<noteq>b]Q"
proof(induct rule: simCases)
  case(Bound Q' c x)
  have "x \<sharp> [a\<noteq>b]P" by fact
  hence xFreshP: "(x::name) \<sharp> P" by simp
  have "[a\<noteq>b]Q \<longmapsto>c<\<nu>x> \<prec> Q'" by fact
  thus ?case
  proof(induct rule: mismatchCases)
    case Mismatch
    have aineqb: "a \<noteq> b" by fact
    have "Q \<longmapsto>c<\<nu>x> \<prec> Q'" by fact
    with PSimQ xFreshP obtain P' where PTrans: "P \<Longrightarrow>c<\<nu>x> \<prec> P'"
                                   and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: simE)
    from PTrans aineqb have "[a\<noteq>b]P \<Longrightarrow>c<\<nu>x> \<prec> P'" by(rule Weak_Early_Step_Semantics.Mismatch)
    moreover from P'RelQ' RelRel' have "(P', Q') \<in> Rel'" by blast
    ultimately show ?case by blast
  qed
next
  case(Free Q' \<alpha>)
  have "[a\<noteq>b]Q \<longmapsto>\<alpha> \<prec> Q'" by fact
  thus ?case
  proof(induct rule: mismatchCases)
    case Mismatch
    have aineqb: "a \<noteq> b" by fact
    have "Q \<longmapsto> \<alpha> \<prec> Q'" by fact
    with PSimQ obtain P' where "P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P'" and "(P', Q') \<in> Rel"
      by(blast dest: simE)
    thus ?case
    proof(induct rule: transitionCases)
      case Step
      have "P \<Longrightarrow>\<alpha> \<prec> P'" by fact
      hence "[a\<noteq>b]P \<Longrightarrow>\<alpha> \<prec> P'" using aineqb by(rule Weak_Early_Step_Semantics.Mismatch)
      with RelRel' \<open>(P', Q') \<in> Rel\<close> show ?case by(force simp add: weakFreeTransition_def)
    next
      case Stay
      have "[a\<noteq>b]P \<Longrightarrow>\<^sup>^\<tau> \<prec> [a\<noteq>b]P" by(simp add: weakFreeTransition_def)
      moreover from \<open>(P, Q') \<in> Rel\<close> aineqb have "([a\<noteq>b]P, Q') \<in> Rel" by(blast intro: RelStay)
      ultimately show ?case using RelRel' by blast
    qed
  qed
qed

lemma parCompose:
  fixes P     :: pi
  and   Q     :: pi
  and   R     :: pi
  and   S     :: pi
  and   Rel   :: "(pi \<times> pi) set"
  and   Rel'  :: "(pi \<times> pi) set"
  and   Rel'' :: "(pi \<times> pi) set"

  assumes PSimQ:    "P \<leadsto><Rel> Q"
  and     RSimT:    "R \<leadsto><Rel'> S"
  and     PRelQ:    "(P, Q) \<in> Rel"
  and     RRel'T:   "(R, S) \<in> Rel'"
  and     Par:      "\<And>P' Q' R' S'. \<lbrakk>(P', Q') \<in> Rel; (R', S') \<in> Rel'\<rbrakk> \<Longrightarrow> (P' \<parallel> R', Q' \<parallel> S') \<in> Rel''"
  and     Res:      "\<And>T U x. (T, U) \<in> Rel'' \<Longrightarrow> (<\<nu>x>T, <\<nu>x>U) \<in> Rel''"

  shows "P \<parallel> R \<leadsto><Rel''> Q \<parallel> S"
proof -
  show ?thesis
  proof(induct rule: simCases)
    case(Bound Q' a x)
    have "x \<sharp> P \<parallel> R" by fact
    hence xFreshP: "x \<sharp> P" and xFreshR: "x \<sharp> R" by simp+
    have "Q \<parallel> S \<longmapsto>a<\<nu>x> \<prec> Q'" by fact
    thus ?case
    proof(induct rule: parCasesB)
      case(cPar1 Q')
      have QTrans: "Q \<longmapsto> a<\<nu>x> \<prec> Q'" and xFreshT: "x \<sharp> S" by fact+
      from xFreshP PSimQ QTrans obtain P' where PTrans:"P \<Longrightarrow>a<\<nu>x> \<prec> P'"
                                            and P'RelQ': "(P', Q') \<in> Rel"
        by(blast dest: simE)
      from PTrans xFreshR have "P \<parallel> R \<Longrightarrow>a<\<nu>x> \<prec> (P' \<parallel> R)" by(rule Weak_Early_Step_Semantics.Par1B)
      moreover from P'RelQ' RRel'T have "(P' \<parallel> R, Q' \<parallel> S) \<in> Rel''" by(rule Par)
      ultimately show ?case by blast
    next
      case(cPar2 S')
      have STrans: "S \<longmapsto> a<\<nu>x> \<prec> S'" and xFreshQ: "x \<sharp> Q" by fact+
      from xFreshR RSimT STrans obtain R' where RTrans:"R \<Longrightarrow>a<\<nu>x> \<prec> R'"
                                            and R'Rel'T': "(R', S') \<in>  Rel'"
        by(blast dest: simE)
      from RTrans xFreshP xFreshR have ParTrans: "P \<parallel> R \<Longrightarrow>a<\<nu>x> \<prec> (P \<parallel> R')"
        by(blast intro: Weak_Early_Step_Semantics.Par2B)
      moreover from PRelQ R'Rel'T' have "(P \<parallel> R', Q \<parallel>  S') \<in> Rel''" by(rule Par)
      ultimately show ?case by blast
    qed
  next
    case(Free QT' \<alpha>)
    have "Q \<parallel> S \<longmapsto> \<alpha> \<prec> QT'" by fact
    thus ?case
    proof(induct rule: parCasesF[of _ _ _ _ _ "(P, R)"])
      case(cPar1 Q')
      have "Q \<longmapsto> \<alpha> \<prec> Q'" by fact
      with PSimQ obtain P' where PTrans: "P \<Longrightarrow>\<^sup>^ \<alpha> \<prec> P'" and PRel: "(P', Q') \<in> Rel"
        by(blast dest: simE)
      from PTrans have Trans: "P \<parallel> R \<Longrightarrow>\<^sup>^ \<alpha> \<prec> P' \<parallel> R" by(rule Weak_Early_Semantics.Par1F)
      moreover from PRel RRel'T have "(P' \<parallel> R, Q' \<parallel> S) \<in> Rel''" by(blast intro: Par)
      ultimately show ?case by blast
    next
      case(cPar2 S')
      have "S \<longmapsto> \<alpha> \<prec> S'" by fact
      with RSimT obtain R' where RTrans: "R \<Longrightarrow>\<^sup>^ \<alpha> \<prec> R'" and RRel: "(R', S') \<in> Rel'"
        by(blast dest: simE)
      from RTrans have Trans: "P \<parallel> R \<Longrightarrow>\<^sup>^ \<alpha> \<prec> P \<parallel> R'" by(rule Weak_Early_Semantics.Par2F)
      moreover from PRelQ RRel have "(P \<parallel> R', Q \<parallel> S') \<in> Rel''" by(blast intro: Par)
      ultimately show ?case by blast
    next
      case(cComm1 Q' S' a b)
      have QTrans: "Q \<longmapsto> a<b> \<prec> Q'" and STrans: "S \<longmapsto> a[b] \<prec> S'" by fact+

      from PSimQ QTrans obtain P' where PTrans: "P \<Longrightarrow>a<b> \<prec> P'"
                                    and P'RelQ': "(P', Q') \<in> Rel"
        by(fastforce dest: simE simp add: weakFreeTransition_def)

      from RSimT STrans obtain R' where RTrans: "R \<Longrightarrow>a[b] \<prec> R'"
                                    and RRel: "(R', S') \<in> Rel'"
        by(fastforce dest: simE simp add: weakFreeTransition_def)

      from PTrans RTrans have "P \<parallel> R \<Longrightarrow>\<tau> \<prec> P' \<parallel> R'" by(rule Weak_Early_Step_Semantics.Comm1)
      hence "P \<parallel> R \<Longrightarrow>\<^sup>^\<tau> \<prec> P' \<parallel> R'"
        by(auto simp add: trancl_into_rtrancl dest: Weak_Early_Step_Semantics.tauTransitionChain)

      moreover from P'RelQ' RRel have "(P' \<parallel> R', Q' \<parallel> S') \<in> Rel''" by(rule Par)
      ultimately show ?case by blast
    next
      case(cComm2 Q' S' a b)
      have QTrans: "Q \<longmapsto>a[b] \<prec> Q'" and STrans: "S \<longmapsto>a<b> \<prec> S'" by fact+

      from PSimQ QTrans obtain P' where PTrans: "P \<Longrightarrow>a[b] \<prec> P'"
                                    and PRel: "(P', Q') \<in> Rel"
        by(fastforce dest: simE simp add: weakFreeTransition_def)

      from RSimT STrans obtain R' where RTrans: "R \<Longrightarrow>a<b> \<prec> R'"
                                   and R'Rel'T': "(R', S') \<in> Rel'"
        by(fastforce dest: simE simp add: weakFreeTransition_def)

      from PTrans RTrans have "P \<parallel> R \<Longrightarrow>\<tau> \<prec> P' \<parallel> R'" by(rule Weak_Early_Step_Semantics.Comm2)
      hence "P \<parallel> R \<Longrightarrow>\<^sup>^\<tau> \<prec> P' \<parallel> R'"
        by(auto simp add: trancl_into_rtrancl dest: Weak_Early_Step_Semantics.tauTransitionChain)
      moreover from PRel R'Rel'T' have "(P' \<parallel> R', Q' \<parallel> S') \<in> Rel''" by(rule Par)
      ultimately show ?case by blast
    next
      case(cClose1 Q' S' a x)
      have QTrans: "Q \<longmapsto>a<x> \<prec> Q'" and STrans: "S \<longmapsto>a<\<nu>x> \<prec> S'" by fact+
      have "x \<sharp> (P, R)" by fact
      hence xFreshP: "x \<sharp> P" and xFreshR: "x \<sharp> R" by(simp add: fresh_prod)+

      from PSimQ QTrans obtain P' where PTrans: "P \<Longrightarrow>a<x> \<prec> P'"
                                    and P'RelQ': "(P', Q') \<in> Rel"
        by(fastforce dest: simE simp add: weakFreeTransition_def)

      from RSimT STrans xFreshR obtain R' where RTrans: "R \<Longrightarrow>a<\<nu>x> \<prec> R'"
                                            and R'Rel'T': "(R', S') \<in> Rel'"
        by(blast dest: simE)

      from PTrans RTrans xFreshP have Trans: "P \<parallel> R \<Longrightarrow>\<tau> \<prec> <\<nu>x>(P' \<parallel> R')"
        by(rule Weak_Early_Step_Semantics.Close1)
      hence "P \<parallel> R \<Longrightarrow>\<^sup>^\<tau> \<prec> <\<nu>x>(P' \<parallel> R')"
        by(auto simp add: trancl_into_rtrancl dest: Weak_Early_Step_Semantics.tauTransitionChain)
      moreover from P'RelQ' R'Rel'T' have "(<\<nu>x>(P' \<parallel> R'), <\<nu>x>(Q' \<parallel> S')) \<in> Rel''"
        by(blast intro: Par Res)
      ultimately show ?case by blast
    next
      case(cClose2 Q' S' a x)
      have QTrans: "Q \<longmapsto>a<\<nu>x> \<prec> Q'" and STrans: "S \<longmapsto>a<x> \<prec> S'" by fact+
      have "x \<sharp> (P, R)" by fact
      hence xFreshR: "x \<sharp> R" and xFreshP: "x \<sharp> P" by(simp add: fresh_prod)+

      from PSimQ QTrans xFreshP obtain P' where PTrans: "P \<Longrightarrow>a<\<nu>x> \<prec> P'"
                                            and P'RelQ': "(P', Q') \<in> Rel"
        by(blast dest: simE)

      from RSimT STrans obtain R' where RTrans: "R \<Longrightarrow>a<x> \<prec> R'"
                                    and R'Rel'T': "(R', S') \<in> Rel'"
        by(fastforce dest: simE simp add: weakFreeTransition_def)
      from PTrans RTrans xFreshR have Trans: "P \<parallel> R \<Longrightarrow>\<tau> \<prec> <\<nu>x>(P' \<parallel> R')"
        by(rule Weak_Early_Step_Semantics.Close2)
      hence "P \<parallel> R \<Longrightarrow>\<^sup>^\<tau> \<prec> <\<nu>x>(P' \<parallel> R')"
        by(auto simp add: trancl_into_rtrancl dest: Weak_Early_Step_Semantics.tauTransitionChain)
      moreover from P'RelQ' R'Rel'T' have "(<\<nu>x>(P' \<parallel> R'), <\<nu>x>(Q' \<parallel> S')) \<in> Rel''"
        by(blast intro: Par Res)
      ultimately show ?case by blast
    qed
  qed
qed

lemma parPres:
  fixes P   :: pi
  and   Q   :: pi
  and   R   :: pi
  and   a   :: name
  and   Rel :: "(pi \<times> pi) set"
  and   Rel' :: "(pi \<times> pi) set"

  assumes PSimQ:    "P \<leadsto><Rel> Q"
  and     PRelQ:    "(P, Q) \<in> Rel"
  and     Par:      "\<And>S T U. (S, T) \<in> Rel \<Longrightarrow> (S \<parallel> U, T \<parallel> U) \<in> Rel'"
  and     Res:      "\<And>S T x. (S, T) \<in> Rel' \<Longrightarrow> (<\<nu>x>S, <\<nu>x>T) \<in> Rel'"

  shows "P \<parallel> R \<leadsto><Rel'> Q \<parallel> R"
proof -
  note PSimQ
  moreover have RSimR: "R \<leadsto><Id> R" by(auto intro: reflexive)
  moreover note PRelQ moreover have "(R, R) \<in> Id" by auto
  moreover from Par have "\<And>P Q R T. \<lbrakk>(P, Q) \<in> Rel; (R, T) \<in> Id\<rbrakk> \<Longrightarrow> (P \<parallel> R, Q \<parallel> T) \<in> Rel'"
    by auto
  ultimately show ?thesis using Res by(rule parCompose)
qed

  assumes PSimQ: "P \<leadsto><Rel> Q"
  and     ResRel: "\<And>R S y. (R, S) \<in> Rel \<Longrightarrow> (<\<nu>y>R, <\<nu>y>S) \<in> Rel'"
  and     RelRel': "Rel \<subseteq> Rel'"
  and     EqvtRel: "eqvt Rel"
  and     EqvtRel': "eqvt Rel'"

  shows "<\<nu>x>P \<leadsto><Rel'> <\<nu>x>Q"
proof -
  from EqvtRel' show ?thesis
  proof(induct rule: simCasesCont[where C="(P, x)"])
    case(Bound a y Q')
    have Trans: "<\<nu>x>Q \<longmapsto>a<\<nu>y> \<prec> Q'" by fact
    have "y \<sharp> (P, x)" by fact
    hence yineqx: "y \<noteq> x" and yFreshP: "y \<sharp> P" by(simp add: fresh_prod)+
    from Trans yineqx show ?case
    proof(induct rule: resCasesB)
      case(Open Q')
      have QTrans: "Q \<longmapsto>a[x] \<prec> Q'" and aineqx: "a \<noteq> x" by fact+

      from PSimQ QTrans obtain P' where PTrans: "P \<Longrightarrow>\<^sup>^a[x] \<prec> P'"
                                    and P'RelQ': "(P', Q') \<in> Rel"
        by(blast dest: simE)

      from PTrans aineqx have "<\<nu>x>P \<Longrightarrow>a<\<nu>x> \<prec> P'"
        by(force intro: Weak_Early_Step_Semantics.Open simp add: weakFreeTransition_def)
      with \<open>y \<sharp> P\<close> \<open>y \<noteq> x\<close> have "<\<nu>x>P \<Longrightarrow>a<\<nu>y> \<prec> ([(y, x)] \<bullet> P')"
        by(force intro: weakTransitionAlpha simp add: abs_fresh name_swap)
      moreover from EqvtRel P'RelQ' RelRel' have "([(y, x)] \<bullet> P', [(y, x)] \<bullet> Q') \<in> Rel'"
        by(blast intro: eqvtRelI)
      ultimately show ?case by blast
    next
      case(Res Q')
      have QTrans: "Q \<longmapsto>a<\<nu>y> \<prec> Q'" and xineqa: "x \<noteq> a" by fact+

      from PSimQ yFreshP QTrans obtain P' where PTrans: "P \<Longrightarrow>a<\<nu>y> \<prec> P'"
                                            and P'RelQ': "(P', Q') \<in> Rel"
        by(blast dest: simE)
      from PTrans xineqa yineqx yFreshP have ResTrans: "<\<nu>x>P \<Longrightarrow>a<\<nu>y> \<prec> (<\<nu>x>P')"
        by(blast intro: Weak_Early_Step_Semantics.ResB)
      moreover from P'RelQ' have "((<\<nu>x>P'), (<\<nu>x>Q')) \<in> Rel'"
        by(rule ResRel)
      ultimately show ?case by blast
    qed
  next
    case(Free \<alpha> Q')
    have QTrans: "<\<nu>x>Q \<longmapsto> \<alpha> \<prec> Q'" by fact
    have "\<exists>c::name. c \<sharp> (P, Q, Q', \<alpha>)" by(blast intro: name_exists_fresh)
    then obtain c::name where cFreshQ: "c \<sharp> Q" and cFreshAlpha: "c \<sharp> \<alpha>" and cFreshQ': "c \<sharp> Q'" and cFreshP: "c \<sharp> P"
      by(force simp add: fresh_prod)
    from cFreshP have "<\<nu>x>P = <\<nu>c>([(x, c)] \<bullet> P)" by(simp add: alphaRes)
    moreover have "\<exists>P'.<\<nu>c>([(x, c)] \<bullet> P) \<Longrightarrow>\<^sup>^ \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel'"
    proof -
      from QTrans cFreshQ have "<\<nu>c>([(x, c)] \<bullet> Q) \<longmapsto>\<alpha> \<prec> Q'" by(simp add: alphaRes)
      moreover have "c \<sharp> \<alpha>" by(rule cFreshAlpha)
      moreover from PSimQ EqvtRel have "([(x, c)] \<bullet> P) \<leadsto><Rel> ([(x, c)] \<bullet> Q)"
        by(blast intro: eqvtI)
      ultimately show ?thesis
        apply(induct rule: resCasesF, auto simp add: residual.inject pi.inject name_abs_eq)
        by(blast intro: ResF ResRel dest: simE)
    qed

    ultimately show ?case by force
  qed
qed

lemma resChainI:
  fixes P   :: pi
  and   Q   :: pi
  and   Rel :: "(pi \<times> pi) set"
  and   lst :: "name list"

  assumes eqvtRel: "eqvt Rel"
  and     Res:     "\<And>R S y. (R, S) \<in> Rel \<Longrightarrow> (<\<nu>y>R, <\<nu>y>S) \<in> Rel"
  and     PRelQ:   "P \<leadsto><Rel> Q"

  shows "(resChain lst) P \<leadsto><Rel> (resChain lst) Q"
proof -
  show ?thesis
  proof(induct lst) (* Base case *)
    from PRelQ show "resChain [] P \<leadsto><Rel> resChain [] Q" by simp
  next (* Inductive step *)
    fix a lst
    assume IH: "(resChain lst P) \<leadsto><Rel> (resChain lst Q)"
    moreover from Res have "\<And>P Q a. (P, Q) \<in> Rel \<Longrightarrow> (<\<nu>a>P, <\<nu>a>Q) \<in> Rel"
      by simp
    moreover have "Rel \<subseteq> Rel" by simp
    ultimately have "<\<nu>a>(resChain lst P) \<leadsto><Rel> <\<nu>a>(resChain lst Q)" using eqvtRel
      by(rule_tac resPres)
    thus "resChain (a # lst) P \<leadsto><Rel> resChain (a # lst) Q"
      by simp
  qed
qed

  and     ParComp:     "\<And>R S T U. \<lbrakk>(R, S) \<in> Rel; (T, U) \<in> Rel'\<rbrakk> \<Longrightarrow> (R \<parallel> T, S \<parallel> U) \<in> Rel'"
  and     Res:         "\<And>R S x. (R, S) \<in> Rel' \<Longrightarrow> (<\<nu>x>R, <\<nu>x>S) \<in> Rel'"

  and     RelStay:        "\<And>R S. (R \<parallel> !R, S) \<in> Rel' \<Longrightarrow> (!R, S) \<in> Rel'"
  and     BangRelRel': "(bangRel Rel) \<subseteq> Rel'"
  and     eqvtRel':    "eqvt Rel'"

  shows "!P \<leadsto><Rel'> !Q"
proof -
  let ?Sim = "\<lambda>P Rs. (\<forall>a x Q'. Rs = a<\<nu>x> \<prec> Q' \<longrightarrow> x \<sharp> P \<longrightarrow> (\<exists>P'. P \<Longrightarrow>a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel')) \<and>
                     (\<forall>\<alpha> Q'. Rs = \<alpha> \<prec> Q' \<longrightarrow> (\<exists>P'. P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel'))"
  {
    fix Rs P
    assume "!Q \<longmapsto> Rs" and "(P, !Q) \<in> bangRel Rel"
    hence "?Sim P Rs" using PRelQ
    proof(nominal_induct avoiding: P rule: bangInduct)
      case(Par1B a x Q')
      have QTrans: "Q \<longmapsto>a<\<nu>x> \<prec> Q'" and xFreshQ: "x \<sharp> Q" by fact+
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" and "x \<sharp> P" by fact+
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelT: "(R, !Q) \<in> bangRel Rel" by fact+
        have "x \<sharp> P \<parallel> R" by fact
        hence xFreshP: "x \<sharp> P" and xFreshR: "x \<sharp> R" by simp+
        from PRelQ have PSimQ: "P \<leadsto><Rel> Q" by(rule Sim)
        from \<open>x \<sharp> P\<close> \<open>x \<sharp> Q\<close> show ?case
        proof(auto simp add: residual.inject alpha' name_fresh_fresh)
          from PSimQ QTrans xFreshP obtain P' where PTrans: "P \<Longrightarrow>a<\<nu>x> \<prec> P'"
                                                and P'RelQ': "(P', Q') \<in> Rel"
            by(blast dest: simE)
          from PTrans xFreshR have "P \<parallel> R \<Longrightarrow>a<\<nu>x>\<prec> (P' \<parallel> R)"
            by(rule Weak_Early_Step_Semantics.Par1B)
          moreover from P'RelQ' RBangRelT BangRelRel' have "(P' \<parallel> R, Q' \<parallel> !Q) \<in> Rel'"
            by(blast intro: Rel.BRPar)
          ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>a<\<nu>x> \<prec> P' \<and> (P', Q' \<parallel> !Q) \<in> Rel'" by blast
        next
          fix y
          assume "(y::name) \<sharp> Q'" and "y \<sharp> P" and "y \<sharp> R"
          from QTrans \<open>y \<sharp> Q'\<close> have "Q \<longmapsto>a<\<nu>y> \<prec> ([(x, y)] \<bullet> Q')" by(simp add: alphaBoundOutput)
          with PSimQ \<open>y \<sharp> P\<close> obtain P' where PTrans: "P \<Longrightarrow>a<\<nu>y> \<prec> P'"
                                         and P'RelQ': "(P', [(x, y)] \<bullet> Q') \<in> Rel"
            by(blast dest: simE)
          from PTrans \<open>y \<sharp> R\<close> have "P \<parallel> R \<Longrightarrow>a<\<nu>y>\<prec> (P' \<parallel> R)" by(rule Weak_Early_Step_Semantics.Par1B)
          moreover from P'RelQ' RBangRelT BangRelRel' have "(P' \<parallel> R, ([(y, x)] \<bullet> Q') \<parallel> !Q) \<in> Rel'"
            by(fastforce intro: Rel.BRPar simp add: name_swap)
          ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>a<\<nu>y> \<prec> P' \<and> (P', ([(y, x)] \<bullet> Q') \<parallel> !Q) \<in> Rel'" by blast
        qed
      qed
    next
      case(Par1F \<alpha> Q' P)
      have QTrans: "Q \<longmapsto>\<alpha> \<prec> Q'" by fact
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" by fact
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelQ: "(R, !Q) \<in> bangRel Rel" by fact+
        show ?case
        proof(auto simp add: residual.inject)
          from PRelQ have "P \<leadsto><Rel> Q" by(rule Sim)
          with QTrans obtain P' where PTrans: "P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
            by(blast dest: simE)

          from PTrans have "P \<parallel> R \<Longrightarrow>\<^sup>^\<alpha> \<prec> P' \<parallel> R" by(rule Weak_Early_Semantics.Par1F)
          moreover from P'RelQ' RBangRelQ have "(P' \<parallel> R, Q' \<parallel> !Q) \<in> bangRel Rel"
            by(rule Rel.BRPar)
          ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>\<^sup>^\<alpha> \<prec> P' \<and> (P', Q' \<parallel> !Q) \<in> Rel'" using BangRelRel' by blast
        qed
      qed
    next
      case(Par2B a x Q' P)
      hence IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim P (a<\<nu>x> \<prec> Q')" by simp
      have xFreshQ: "x \<sharp> Q" by fact
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" and "x \<sharp> P" by fact+
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelQ: "(R, !Q) \<in> bangRel Rel" by fact+
        have "x \<sharp> P \<parallel> R" by fact
        hence xFreshP: "x \<sharp> P" and xFreshR: "x \<sharp> R" by simp+
        show ?case using \<open>x \<sharp> Q\<close>
        proof(auto simp add: residual.inject alpha' name_fresh_fresh)
          from IH RBangRelQ have "?Sim R (a<\<nu>x> \<prec> Q')" by blast
          with xFreshR obtain R' where RTrans: "R \<Longrightarrow>a<\<nu>x> \<prec> R'" and R'BangRelQ': "(R', Q') \<in> Rel'"
            by(blast dest: simE)
          from RTrans xFreshP have "P \<parallel> R \<Longrightarrow>a<\<nu>x> \<prec> (P \<parallel> R')"
            by(auto intro: Weak_Early_Step_Semantics.Par2B)
          moreover from PRelQ R'BangRelQ' have "(P \<parallel> R', Q \<parallel> Q') \<in> Rel'"
            by(rule ParComp)
          ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>a<\<nu>x> \<prec> P' \<and> (P', Q \<parallel> Q') \<in> Rel'" by blast
        next
          fix y
          assume "(y::name) \<sharp> Q'" and "y \<sharp> R" and "y \<sharp> P"
          from IH RBangRelQ have "?Sim R (a<\<nu>x> \<prec> Q')" by blast
          with \<open>y \<sharp> Q'\<close> have  "?Sim R (a<\<nu>y> \<prec> ([(x, y)] \<bullet> Q'))" by(simp add: alphaBoundOutput)
          with \<open>y \<sharp> R\<close>obtain R' where RTrans: "R \<Longrightarrow>a<\<nu>y> \<prec> R'" and R'BangRelQ': "(R', [(x, y)] \<bullet> Q') \<in> Rel'"
            by(blast dest: simE)
          from RTrans \<open>y \<sharp> P\<close> have "P \<parallel> R \<Longrightarrow>a<\<nu>y> \<prec> (P \<parallel> R')"
            by(auto intro: Weak_Early_Step_Semantics.Par2B)
          moreover from PRelQ R'BangRelQ' have "(P \<parallel> R', Q \<parallel> ([(y, x)] \<bullet> Q')) \<in> Rel'"
            by(fastforce intro: ParComp simp add: name_swap)
          ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>a<\<nu>y> \<prec> P' \<and> (P', Q \<parallel> ([(y, x)] \<bullet> Q')) \<in> Rel'" by blast
        qed
      qed
    next
      case(Par2F \<alpha> Q' P)
      hence IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim P (\<alpha> \<prec> Q')" by simp
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" by fact
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelQ: "(R, !Q) \<in> bangRel Rel" by fact+
        show ?case
        proof(auto simp add: residual.inject)
          from RBangRelQ have "?Sim R (\<alpha> \<prec> Q')" by(rule IH)
          then obtain R' where RTrans: "R \<Longrightarrow>\<^sup>^\<alpha> \<prec> R'" and R'RelQ': "(R', Q') \<in> Rel'"
            by(blast dest: simE)
          from RTrans have "P \<parallel> R \<Longrightarrow>\<^sup>^\<alpha> \<prec> P \<parallel> R'" by(rule Weak_Early_Semantics.Par2F)
          moreover from PRelQ R'RelQ' have "(P \<parallel> R', Q \<parallel> Q') \<in> Rel'" by(rule ParComp)
          ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>\<^sup>^\<alpha> \<prec> P' \<and> (P', Q \<parallel> Q') \<in> Rel'" by blast
        qed
      qed
    next
      case(Comm1 a Q' b Q'' P)
      hence IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim P (a[b] \<prec> Q'')" by simp
      have QTrans: "Q \<longmapsto> a<b> \<prec> Q'" by fact
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" by fact
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelQ: "(R, !Q) \<in> bangRel Rel" by fact+
        show ?case
        proof(auto simp add: residual.inject)
          from PRelQ have "P \<leadsto><Rel> Q" by(rule Sim)
          with QTrans obtain P' where PTrans: "P \<Longrightarrow>a<b> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
            by(fastforce dest: simE simp add: weakFreeTransition_def)

          from RBangRelQ have "?Sim R (a[b] \<prec> Q'')" by(rule IH)
          then obtain R' where RTrans: "R \<Longrightarrow>a[b] \<prec> R'"
                           and R'RelQ'': "(R', Q'') \<in> Rel'"
            by(fastforce dest: simE simp add: weakFreeTransition_def)
          from PTrans RTrans have "P \<parallel> R \<Longrightarrow>\<tau> \<prec> (P' \<parallel> R')"
            by(rule Weak_Early_Step_Semantics.Comm1)
          hence "P \<parallel> R \<Longrightarrow>\<^sub>\<tau> P' \<parallel> R'"
            by(auto simp add: trancl_into_rtrancl dest: Weak_Early_Step_Semantics.tauTransitionChain)
          moreover from P'RelQ' R'RelQ'' have "(P' \<parallel> R', Q' \<parallel> Q'') \<in> Rel'"
            by(rule ParComp)
          ultimately show "\<exists>P'. (P \<parallel> R, P') \<in> {(P, P'). P \<longmapsto> \<tau> \<prec> P'}\<^sup>* \<and> (P', Q' \<parallel> Q'') \<in> Rel'"
            by auto
        qed
      qed
    next
      case(Comm2 a b Q' Q'' P)
      hence IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim P (a<b> \<prec> Q'')" by simp
      have QTrans: "Q \<longmapsto>a[b] \<prec> Q'" by fact
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" by fact
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelQ: "(R, !Q) \<in> bangRel Rel" by fact+
        show ?case
        proof(auto simp add: residual.inject)
          from PRelQ have "P \<leadsto><Rel> Q" by(rule Sim)
          with QTrans obtain P' where PTrans: "P \<Longrightarrow>a[b] \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
            by(fastforce dest: simE simp add: weakFreeTransition_def)

          from RBangRelQ have "?Sim R (a<b> \<prec> Q'')" by(rule IH)
          then obtain R' where RTrans: "R \<Longrightarrow>a<b> \<prec> R'" and R'BangRelQ'': "(R', Q'') \<in> Rel'"
            by(fastforce dest: simE simp add: weakFreeTransition_def)

          from PTrans RTrans have "P \<parallel> R \<Longrightarrow>\<tau> \<prec> (P' \<parallel> R')"
            by(rule Weak_Early_Step_Semantics.Comm2)
          hence "P \<parallel> R \<Longrightarrow>\<^sub>\<tau> P' \<parallel> R'"
            by(auto simp add: trancl_into_rtrancl dest: Weak_Early_Step_Semantics.tauTransitionChain)
          moreover from P'RelQ' R'BangRelQ'' have "(P' \<parallel> R', Q' \<parallel> Q'') \<in> Rel'"
            by(rule ParComp)
          ultimately show "\<exists>P'. (P \<parallel> R, P') \<in> {(P, P'). P \<longmapsto> \<tau> \<prec> P'}\<^sup>* \<and> (P', Q' \<parallel> Q'') \<in> Rel'" by auto
        qed
      qed
    next
      case(Close1 a x Q' Q'' P)
      hence IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim P (a<\<nu>x> \<prec> Q'')" by simp
      have QTrans: "Q \<longmapsto> a<x> \<prec> Q'" by fact
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" and "x \<sharp> P" by fact+
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelQ: "(R, !Q) \<in> bangRel Rel" by fact+
        have "x \<sharp> P \<parallel> R" by fact
        hence xFreshR: "x \<sharp> R" and xFreshP: "x \<sharp> P" by simp+
        show ?case
        proof(auto simp add: residual.inject)
          from PRelQ have "P \<leadsto><Rel> Q" by(rule Sim)
          with QTrans obtain P' where PTrans: "P \<Longrightarrow>a<x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
            by(fastforce dest: simE simp add: weakFreeTransition_def)

          from RBangRelQ have "?Sim R (a<\<nu>x> \<prec> Q'') " by(rule IH)
          with xFreshR obtain R' where RTrans: "R \<Longrightarrow>a<\<nu>x> \<prec> R'"
                                   and R'RelQ'': "(R', Q'') \<in> Rel'"
            by(blast dest: simE)

          from PTrans RTrans xFreshP have "P \<parallel> R \<Longrightarrow>\<tau> \<prec> <\<nu>x>(P' \<parallel> R')"
            by(rule Weak_Early_Step_Semantics.Close1)
          moreover from P'RelQ' R'RelQ'' have "(<\<nu>x>(P' \<parallel> R'), <\<nu>x>(Q' \<parallel> Q'')) \<in> Rel'"
            by(force intro: ParComp Res)
          ultimately show "\<exists>P'. (P \<parallel> R, P') \<in> {(P, P'). P \<longmapsto> \<tau> \<prec> P'}\<^sup>* \<and> (P', <\<nu>x>(Q' \<parallel> Q'')) \<in> Rel'" by auto
        qed
      qed
    next
      case(Close2 a x Q' Q'' P)
      hence IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim P (a<x> \<prec> Q'')" by simp
      have QTrans: "Q \<longmapsto> a<\<nu>x> \<prec> Q'" by fact
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" and "x \<sharp> P" by fact+
      thus ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        have PRelQ: "(P, Q) \<in> Rel" and RBangRelQ: "(R, !Q) \<in> bangRel Rel" by fact+
        have "x \<sharp> P \<parallel> R" by fact
        hence xFreshP: "x \<sharp> P" and xFreshR: "x \<sharp> R" by simp+
        show ?case
        proof(auto simp add: residual.inject)
          from PRelQ have "P \<leadsto><Rel> Q" by(rule Sim)
          with QTrans xFreshP obtain P' where PTrans: "P \<Longrightarrow>a<\<nu>x> \<prec> P'"
                                          and P'RelQ': "(P', Q') \<in> Rel"
            by(blast dest: simE)

          from RBangRelQ have "?Sim R (a<x> \<prec> Q'')" by(rule IH)
          with xFreshR obtain R' where RTrans: "R \<Longrightarrow>a<x> \<prec> R'"
                                       and R'RelQ'': "(R', Q'') \<in> Rel'"
            by(fastforce simp add: weakFreeTransition_def)
          from PTrans RTrans xFreshR have "P \<parallel> R \<Longrightarrow>\<tau> \<prec> <\<nu>x>(P' \<parallel> R')"
            by(rule Weak_Early_Step_Semantics.Close2)
          moreover from P'RelQ' R'RelQ'' have "(<\<nu>x>(P' \<parallel> R'), <\<nu>x>(Q' \<parallel> Q'')) \<in> Rel'"
            by(force intro: ParComp Res)
          ultimately show "\<exists>P'. (P \<parallel> R, P') \<in> {(P, P'). P \<longmapsto> \<tau> \<prec> P'}\<^sup>* \<and> (P', <\<nu>x>(Q' \<parallel> Q'')) \<in> Rel'" by auto
        qed
      qed
    next
      case(Bang Rs)
      hence IH: "\<And>P. (P, Q \<parallel> !Q) \<in> bangRel Rel \<Longrightarrow> ?Sim P Rs" by simp
      have "(P, !Q) \<in> bangRel Rel" by fact
      thus ?case
      proof(induct rule: BRBangCases)
        case(BRBang P)
        have PRelQ: "(P, Q) \<in> Rel" by fact
        hence "(!P, !Q) \<in> bangRel Rel" by(rule Rel.BRBang)
        with PRelQ have "(P \<parallel> !P, Q \<parallel> !Q) \<in> bangRel Rel" by(rule Rel.BRPar)
        hence IH: "?Sim (P \<parallel> !P) Rs" by(rule IH)
        show ?case
        proof(intro conjI allI impI)
          fix Q' a x
          assume "Rs = a<\<nu>x> \<prec> Q'" and "x \<sharp> !P"
          then obtain P' where PTrans: "(P \<parallel> !P) \<Longrightarrow>a<\<nu>x> \<prec> P'"
                           and P'RelQ': "(P', Q') \<in> Rel'" using IH
            by(auto simp add: residual.inject)
          from PTrans have "!P \<Longrightarrow>a<\<nu>x> \<prec> P'"
            by(force intro: Weak_Early_Step_Semantics.Bang simp add: weakFreeTransition_def)
          with P'RelQ' show "\<exists>P'. !P \<Longrightarrow>a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel'" by blast
        next
          fix Q' \<alpha>
          assume "Rs = \<alpha> \<prec> Q'"
          then obtain P' where PTrans: "(P \<parallel> !P) \<Longrightarrow>\<^sup>^\<alpha> \<prec> P'"
                           and P'RelQ': "(P', Q') \<in> Rel'" using IH
            by auto
          from PTrans show "\<exists>P'. !P \<Longrightarrow>\<^sup>^\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel'" using P'RelQ'
          proof(induct rule: transitionCases)
            case Step
            have "P \<parallel> !P \<Longrightarrow>\<alpha> \<prec> P'" by fact
            hence "!P \<Longrightarrow>\<alpha> \<prec> P'" by(rule Weak_Early_Step_Semantics.Bang)
            with P'RelQ' show ?case by(force simp add: weakFreeTransition_def)
          next
            case Stay
            have "!P \<Longrightarrow>\<^sup>^\<tau> \<prec> !P" by(simp add: weakFreeTransition_def)
            moreover assume "(P \<parallel> !P, Q') \<in> Rel'"
            hence "(!P, Q') \<in> Rel'" by(blast intro: RelStay)
            ultimately show ?case by blast
          qed
        qed
      qed
    qed
  }
  moreover from PRelQ have "(!P, !Q) \<in> bangRel Rel" by(rule Rel.BRBang)
  ultimately show ?thesis by(auto simp add: weakSimulation_def)
qed

lemma bangRelSim:
  fixes P    :: pi
  and   Q    :: pi
  and   Rel  :: "(pi \<times> pi) set"
  and   Rel'l :: "(pi \<times> pi) set"

  assumes PBangRelQ: "(P, Q) \<in> bangRel Rel"
  and     Sim:       "\<And>R S. (R, S) \<in> Rel \<Longrightarrow> R \<leadsto><Rel> S"

  and     ParComp:     "\<And>R S T U. \<lbrakk>(R, S) \<in> Rel; (T, U) \<in> Rel'\<rbrakk> \<Longrightarrow> (R \<parallel> T, S \<parallel> U) \<in> Rel'"
  and     Res:         "\<And>R S x. (R, S) \<in> Rel' \<Longrightarrow> (<\<nu>x>R, <\<nu>x>S) \<in> Rel'"

  and     RelStay:        "\<And>R S. (R \<parallel> !R, S) \<in> Rel' \<Longrightarrow> (!R, S) \<in> Rel'"
  and     BangRelRel': "(bangRel Rel) \<subseteq> Rel'"
  and     eqvtRel':    "eqvt Rel'"
  and     Eqvt: "eqvt Rel"

  shows "P \<leadsto><Rel'> Q"
proof -
  from PBangRelQ show ?thesis
  proof(induct rule: bangRel.induct)
    case(BRBang P Q)
    have PRelQ: "(P, Q) \<in> Rel" by fact
    thus ?case using ParComp Res BangRelRel' eqvtRel' Eqvt RelStay Sim
      by(rule_tac bangPres)
  next
    case(BRPar P Q R T)
    have "(P, Q) \<in> Rel" by fact
    moreover hence "P \<leadsto><Rel> Q" by(rule Sim)
    moreover have "R \<leadsto><Rel'> T" by fact
    moreover have "(R, T) \<in> bangRel Rel" by fact
    ultimately show ?case using ParComp eqvtRel' Res Eqvt BangRelRel'
      by(blast intro: parCompose)
  next
    case(BRRes P Q x)
    have "P \<leadsto><Rel'> Q" by fact
    thus ?case using BangRelRel' eqvtRel' Res by(blast intro: resPres)
  qed
qed

end


(*
 * Copyright 2016, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

(*
 * Program specifications generated from:
 *   cogent --type-proof=FunFun --fml-typing-tree fun.cogent
 *   cogent -gfun_dsl --infer-c-func=fun.ac fun.cogent && cat fun_dsl.c fun_pp_inferred.c > fun.c
 *)
theory FunFun
imports
  "../Cogent_Corres"
  "../TypeProofGen"
  "../Corres_Tac"
  "../Tidy"
begin

lemmas abbreviated_type_defs =
  TrueI

definition
  "abs_type \<equiv> ([], (TUnit, TFun TUnit TUnit))"

definition
  "i_type \<equiv> ([], (TUnit, TUnit))"

definition
  "i \<equiv> Let (Var 0) (Var 0)"

definition
  "i2_type \<equiv> ([], (TUnit, TUnit))"

definition
  "i2 \<equiv> Let (Var 0) (App (Fun i []) (Var 0))"

definition
  "f_type \<equiv> ([], (TUnit, TUnit))"

definition
  "f \<equiv> Let (Var 0) (Let (App (AFun ''abs'' []) (Var 0)) (App (Var 0) (Var 1)))"

definition
  "\<Xi> func_name' \<equiv> case func_name' of ''abs'' \<Rightarrow> abs_type | ''i'' \<Rightarrow> i_type | ''i2'' \<Rightarrow> i2_type | ''f'' \<Rightarrow> f_type"

definition
  "\<xi> func_name' \<equiv> case func_name' of ''abs'' \<Rightarrow> undefined"

definition
  "i_typetree \<equiv> TyTrSplit (Cons (Some TSK_L) []) [] TyTrLeaf [Some TUnit] TyTrLeaf"

definition
  "i2_typetree \<equiv> TyTrSplit (Cons (Some TSK_L) []) [] TyTrLeaf [Some TUnit] TyTrLeaf"

definition
  "f_typetree \<equiv> TyTrSplit (Cons (Some TSK_L) []) [] TyTrLeaf [Some TUnit] (TyTrSplit (Cons (Some TSK_S) (Cons None [])) [] TyTrLeaf [Some (TFun TUnit TUnit)] TyTrLeaf)"

ML {* open TTyping_Tactics *}

ML_quiet {*
val typing_helper_1_script : tac list = [
(RTac @{thm kind_tunit[where k = "{E,S,D}"]})
] *}

lemma typing_helper_1[unfolded abbreviated_type_defs] :
  "kinding [] TUnit {E, S, D}"
  apply (unfold abbreviated_type_defs)?
  apply (tactic {* map (fn t => DETERM (interpret_tac t @{context} 1)) typing_helper_1_script |> EVERY *})
  done

ML_quiet {*
val typing_helper_2_script : tac list = [
(SimpTac ([],[(nth @{thms HOL.simp_thms} (25-1)),(nth @{thms HOL.simp_thms} (26-1))]))
] *}

lemma typing_helper_2[unfolded abbreviated_type_defs] :
  "list_all2 (kinding []) [] []"
  apply (unfold abbreviated_type_defs)?
  apply (tactic {* map (fn t => DETERM (interpret_tac t @{context} 1)) typing_helper_2_script |> EVERY *})
  done

ML_quiet {*
val typing_helper_3_script : tac list = [
(RTac @{thm kind_tfun[where k = "{E,S,D}"]}),
(RTac @{thm typing_helper_1}),
(RTac @{thm typing_helper_1})
] *}

lemma typing_helper_3[unfolded abbreviated_type_defs] :
  "kinding [] (TFun TUnit TUnit) {E, S, D}"
  apply (unfold abbreviated_type_defs)?
  apply (tactic {* map (fn t => DETERM (interpret_tac t @{context} 1)) typing_helper_3_script |> EVERY *})
  done

ML_quiet {*
val typing_helper_4_script : tac list = [
(RTac @{thm kind_tfun[where k = "{E,S,D}"]}),
(RTac @{thm typing_helper_1}),
(RTac @{thm typing_helper_3})
] *}

lemma typing_helper_4[unfolded abbreviated_type_defs] :
  "kinding [] (TFun TUnit (TFun TUnit TUnit)) {E, S, D}"
  apply (unfold abbreviated_type_defs)?
  apply (tactic {* map (fn t => DETERM (interpret_tac t @{context} 1)) typing_helper_4_script |> EVERY *})
  done

ML_quiet {*
val i_typecorrect_script : hints list = [
KindingTacs [(RTac @{thm typing_helper_1})],
KindingTacs [(RTac @{thm typing_helper_1})],
TypingTacs [],
TypingTacs []
] *}

ML_quiet {*
val i_ttyping_details_future = get_all_typing_details_future @{context} "i"
   i_typecorrect_script*}

lemma i_typecorrect :
  "\<Xi>, fst i_type, (i_typetree, [Some (fst (snd i_type))]) T\<turnstile> i : snd (snd i_type)"
  apply (tactic {* resolve_future_typecorrect @{context} i_ttyping_details_future *})
  done

ML_quiet {*
val i2_typecorrect_script : hints list = [
KindingTacs [(RTac @{thm typing_helper_1})],
KindingTacs [(RTac @{thm typing_helper_1})],
TypingTacs [],
TypingTacs [(RTac @{thm typing_app}),(SplitsTac (2,[(0,[(RTac @{thm split_comp.right}),(RTac @{thm typing_helper_1})])])),(RTac @{thm typing_fun'}),(RTac @{thm i_typecorrect[simplified i_type_def i_typetree_def, simplified]}),(RTac @{thm typing_helper_2}),(SimpTac ([],[])),(SimpTac ([],[])),(RTac @{thm exI[where x = "{E,S,D}"]}),(RTac @{thm typing_helper_1}),(SimpTac ([@{thm empty_def}],[])),(WeakeningTac []),(RTac @{thm typing_var}),(SimpTac ([@{thm empty_def}],[])),(WeakeningTac [@{thm typing_helper_1}]),(SimpTac ([],[]))]
] *}

ML_quiet {*
val i2_ttyping_details_future = get_all_typing_details_future @{context} "i2"
   i2_typecorrect_script*}

lemma i2_typecorrect :
  "\<Xi>, fst i2_type, (i2_typetree, [Some (fst (snd i2_type))]) T\<turnstile> i2 : snd (snd i2_type)"
  apply (tactic {* resolve_future_typecorrect @{context} i2_ttyping_details_future *})
  done

ML_quiet {*
val f_typecorrect_script : hints list = [
KindingTacs [(RTac @{thm typing_helper_1})],
KindingTacs [(RTac @{thm typing_helper_1})],
TypingTacs [],
KindingTacs [(RTac @{thm typing_helper_3})],
TypingTacs [(RTac @{thm typing_app}),(SplitsTac (2,[(0,[(RTac @{thm split_comp.right}),(RTac @{thm typing_helper_1})])])),(RTac @{thm typing_afun'}),(SimpTac ([@{thm \<Xi>_def},@{thm abs_type_def}],[])),(RTac @{thm typing_helper_2}),(SimpTac ([],[])),(SimpTac ([],[])),(RTac @{thm exI[where x = "{E,S,D}"]}),(RTac @{thm typing_helper_4}),(SimpTac ([@{thm empty_def}],[])),(WeakeningTac []),(RTac @{thm typing_var}),(SimpTac ([@{thm empty_def}],[])),(WeakeningTac [@{thm typing_helper_1}]),(SimpTac ([],[]))],
TypingTacs [(RTac @{thm typing_app}),(SplitsTac (3,[(0,[(RTac @{thm split_comp.left}),(RTac @{thm typing_helper_3})]),(1,[(RTac @{thm split_comp.right}),(RTac @{thm typing_helper_1})])])),(RTac @{thm typing_var}),(SimpTac ([@{thm empty_def}],[])),(WeakeningTac [@{thm typing_helper_3}]),(SimpTac ([],[])),(RTac @{thm typing_var}),(SimpTac ([@{thm empty_def}],[])),(WeakeningTac [@{thm typing_helper_1}]),(SimpTac ([],[]))]
] *}

ML_quiet {*
val f_ttyping_details_future = get_all_typing_details_future @{context} "f"
   f_typecorrect_script*}

lemma f_typecorrect :
  "\<Xi>, fst f_type, (f_typetree, [Some (fst (snd f_type))]) T\<turnstile> f : snd (snd f_type)"
  apply (tactic {* resolve_future_typecorrect @{context} f_ttyping_details_future *})
  done

ML_quiet {*
val (_, i_typing_tree, i_typing_bucket)
= Future.join i_ttyping_details_future
*}

ML_quiet {*
val (_, i2_typing_tree, i2_typing_bucket)
= Future.join i2_ttyping_details_future
*}

ML_quiet {*
val (_, f_typing_tree, f_typing_bucket)
= Future.join f_ttyping_details_future
*}

new_C_include_dir "../../cogent/tests"
install_C_file "fun.c"
autocorres [ts_rules = nondet, no_opt, skip_word_abs] "fun.c"

instantiation bool_t_C :: cogent_C_val
begin
definition type_rel_bool_t_C_def:
  "type_rel typ (_ :: bool_t_C itself) \<equiv> (typ = RPrim Bool)"

definition val_rel_bool_t_C_def:
  "val_rel uv (x :: bool_t_C) \<equiv> uv = UPrim (LBool (bool_t_C.boolean_C x \<noteq> 0))"
instance ..
end

instantiation unit_t_C :: cogent_C_val begin
  definition type_rel_unit_t_C: "type_rel r (_ :: unit_t_C itself) \<equiv> r = RUnit"
  definition val_rel_unit_t_C: "val_rel uv (_ :: unit_t_C) \<equiv> uv = UUnit"
  instance ..
end

(* [abs, f] is a non-terminating program, so we cannot prove correspondence. *)
context "fun" begin
  thm abs'_def
  thm f'.simps dispatch_t1'.simps
end

(* [i, i2] is a terminating program. *)
locale fun_u_sem = "fun" + update_sem_init
begin

local_setup {* fold tidy_C_fun_def' ["i", "i2"] *}
thm i_def i'_def' i2_def i2'_def'

lemmas corres_nested_let = TrueI (* unused *)

lemma i_corres: "val_rel a a' \<Longrightarrow> corres srel i (i' a') \<xi> [a] \<Xi> [Some TUnit] \<sigma> s"
  apply (tactic {* corres_tac @{context}
    (peel_two i_typing_tree)
    @{thms i_def i'_def' i_type_def abbreviated_type_defs} [] []
    @{thm TrueI} [] [] [] [] @{thm LETBANG_TRUE_def} [] true *})
  done

lemma i2_corres: "val_rel a a' \<Longrightarrow> corres srel i2 (i2' a') \<xi> [a] \<Xi> [Some TUnit] \<sigma> s"
  apply (tactic {* corres_tac @{context}
    (peel_two i2_typing_tree)
    @{thms i2_def i2'_def' i2_type_def abbreviated_type_defs} [] @{thms i_corres}
    @{thm TrueI} [] [] [] [] @{thm LETBANG_TRUE_def} [] true *})
  done

end

end