(*
  Title:      Publisher_Subscriber.thy
  Author:     Diego Marmsoler
*)
section "A Theory of Publisher-Subscriber Architectures"
text\<open>
  In the following, we formalize the specification of the publisher subscriber pattern as described in~\<^cite>\<open>"Marmsoler2018c"\<close>.
\<close>

theory Publisher_Subscriber
imports Singleton
begin

subsection "Subscriptions"

datatype 'evt subscription = sub 'evt | unsub 'evt

subsection "Publisher-Subscriber Architectures"

locale publisher_subscriber =
  pb: singleton pbactive pbcmp +
  sb: dynamic_component sbcmp sbactive
    for pbactive :: "'pid \<Rightarrow> cnf \<Rightarrow> bool" ("\<parallel>_\<parallel>\<^bsub>_\<^esub>" [0,110]60)
    and pbcmp :: "'pid \<Rightarrow> cnf \<Rightarrow> 'PB" ("\<sigma>\<^bsub>_\<^esub>(_)" [0,110]60)
    and sbactive :: "'sid \<Rightarrow> cnf \<Rightarrow> bool" ("\<parallel>_\<parallel>\<^bsub>_\<^esub>" [0,110]60)
    and sbcmp :: "'sid \<Rightarrow> cnf \<Rightarrow> 'SB" ("\<sigma>\<^bsub>_\<^esub>(_)" [0,110]60) +
  fixes pbsb :: "'PB \<Rightarrow> ('evt set) subscription set"
    and pbnt :: "'PB \<Rightarrow> ('evt \<times> 'msg)"
    and sbnt :: "'SB \<Rightarrow> ('evt \<times> 'msg) set"
    and sbsb :: "'SB \<Rightarrow> ('evt set) subscription"
  assumes conn1: "\<And>k pid. \<parallel>pid\<parallel>\<^bsub>k\<^esub>
      \<Longrightarrow> pbsb (\<sigma>\<^bsub>pid\<^esub>(k)) = (\<Union>sid\<in>{sid. \<parallel>sid\<parallel>\<^bsub>k\<^esub>}. {sbsb (\<sigma>\<^bsub>sid\<^esub>(k))})"
    and conn2: "\<And>t n n'' sid pid E e m.
      \<lbrakk>t \<in> arch; \<parallel>pid\<parallel>\<^bsub>t n\<^esub>; \<parallel>sid\<parallel>\<^bsub>t n\<^esub>; sub E = sbsb (\<sigma>\<^bsub>sid\<^esub>(t n)); n''\<ge> n; e \<in> E;
      \<nexists>n' E'. n' \<ge> n \<and> n' \<le> n'' \<and> \<parallel>sid\<parallel>\<^bsub>t n'\<^esub> \<and>
        unsub E' = sbsb (\<sigma>\<^bsub>sid\<^esub>(t n')) \<and> e \<in> E';
      (e, m) = pbnt (\<sigma>\<^bsub>pid\<^esub>(t n'')); \<parallel>sid\<parallel>\<^bsub>t n''\<^esub>\<rbrakk>
      \<Longrightarrow> pbnt (\<sigma>\<^bsub>pid\<^esub>(t n'')) \<in> sbnt (\<sigma>\<^bsub>sid\<^esub>(t n''))"
begin

subsubsection "Calculus Interpretation"
text \<open>
\noindent
@{thm[source] pb.baIA}: @{thm pb.baIA [no_vars]}
\<close>
text \<open>
\noindent
@{thm[source] sb.baIA}: @{thm sb.baIA [no_vars]}
\<close>
subsubsection "Results from Singleton"
abbreviation the_pb :: "'pid" where
"the_pb \<equiv> pb.the_singleton"

text \<open>
\noindent
@{thm[source] pb.ts_prop(1)}: @{thm pb.ts_prop(1) [no_vars]}
\<close>
text \<open>
\noindent
@{thm[source] pb.ts_prop(2)}: @{thm pb.ts_prop(2) [no_vars]}
\<close>

subsubsection "Architectural Guarantees"
text \<open>
  The following theorem ensures that a subscriber indeed receives all messages associated with an event for which he is subscribed.
\<close>

text \<open>
  Since a publisher is actually a singleton, we can provide an alternative version of constraint @{thm[source] conn1}.
\<close>
lemma conn1A:
  fixes k
  shows "pbsb (\<sigma>\<^bsub>the_pb\<^esub>(k)) = (\<Union>sid\<in>{sid. \<parallel>sid\<parallel>\<^bsub>k\<^esub>}. {sbsb (\<sigma>\<^bsub>sid\<^esub>(k))})"
  using conn1[OF pb.ts_prop(2)] .
end

end


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

theory Sep_Attribs
imports Separation_Algebra Sep_Tactic_Helpers
begin

text\<open>Beyond the tactics above, there is also a set of attributes implemented to make proving
       things in separation logic easier. These rules should be considered internals and are not
       intended for direct use.\<close>

lemma sep_curry_atomised: "\<lbrakk>(\<And>s. (P \<and>* Q) s \<longrightarrow> R s); P s \<rbrakk> \<Longrightarrow> (Q \<longrightarrow>* R) s"
  by (clarsimp simp: sep_conj_sep_impl)

lemma sep_remove_pure_imp_sep_imp: "( P \<longrightarrow>* (\<lambda>s. P' \<longrightarrow> Q s)) s \<Longrightarrow> P' \<Longrightarrow> (P \<longrightarrow>* Q) s"
  by (clarsimp)

lemma sep_backward: "\<lbrakk>\<And>s. P s \<longrightarrow> (Q \<and>* T) s; (P \<and>* (Q \<longrightarrow>* R)) s \<rbrakk> \<Longrightarrow> (T \<and>* R) s"
  by (metis sep_conj_commute sep_conj_impl1 sep_mp_frame)

lemma sep_remove_conj: "\<lbrakk>(P \<and>* R) s ; Q\<rbrakk> \<Longrightarrow> ((\<lambda>s. P s \<and> Q) \<and>* R) s "
  apply (clarsimp)
  done

lemma curry: "(P \<longrightarrow> Q \<longrightarrow> R) \<Longrightarrow> (P \<and> Q) \<longrightarrow> R"
  apply (safe)
  done

ML \<open>
local
  fun atomize_thm ctxt thm = Conv.fconv_rule (Object_Logic.atomize ctxt) thm
  fun setup_simpset ctxt = put_simpset HOL_basic_ss ctxt addsimps [(sym OF [@{thm sep_conj_assoc}])]
  fun simp ctxt thm = simplify (setup_simpset ctxt) thm

  fun REPEAT_TRYOF_N _ thm2 0 = thm2
    | REPEAT_TRYOF_N thm1 thm2 n = REPEAT_TRYOF_N thm1 (thm1 OF [thm2]) (n-1)

  fun REPEAT_TRYOF'_N thm1 _    0 = thm1
    | REPEAT_TRYOF'_N thm1 thm2 n = REPEAT_TRYOF'_N (thm1 OF [thm2]) thm2 (n-1)

  fun attribute_thm ctxt thm  thm' =
    REPEAT_TRYOF_N @{thm sep_remove_pure_imp_sep_imp} (thm OF [atomize_thm ctxt thm']) (Thm.nprems_of thm' - 1)

  fun attribute_thm' thm ctxt thm' =
    thm OF [REPEAT_TRYOF_N @{thm curry} (thm' |> atomize_thm ctxt o simp ctxt) (Thm.nprems_of thm' - 1)]

in

(*
 By attributing a theorem with [sep_curry], we can now take a rule (A \<and>* B) \<Longrightarrow> C and turn it into A \<Longrightarrow> (B \<longrightarrow>* C)
*)

fun sep_curry_inner ctxt = attribute_thm ( ctxt) @{thm sep_curry_atomised}
val sep_curry = Thm.rule_attribute [] (fn ctxt => sep_curry_inner (Context.proof_of ctxt))

(*
 The attribute sep_back takes a rule of the form A \<Longrightarrow> B and returns a rule (A \<and>* (B \<longrightarrow>* R)) \<Longrightarrow> R.
 The R then matches with any conclusion. If the theorem is of form (A \<and>* B) \<Longrightarrow> C, it is advised to
 use sep_curry on the theorem first, and then sep_back. This aids sep_cancel in simplifying the result.
*)

fun backward ctxt thm =
  REPEAT_TRYOF'_N (attribute_thm' @{thm sep_backward} ctxt thm) @{thm sep_remove_conj} (Thm.nprems_of thm - 1)

fun backward' ctxt thm = backward (Context.proof_of ctxt) thm

val sep_backward = Thm.rule_attribute [] (backward')

end
\<close>

attribute_setup sep_curry =  \<open>Scan.succeed sep_curry\<close>
attribute_setup sep_backward =  \<open>Scan.succeed sep_backward\<close>

end


theory Flatten_Iter_Spec
  imports
  Basic_Assn
  "Separation_Logic_Imperative_HOL.Imp_List_Spec"
  "HOL-Real_Asymp.Inst_Existentials"
begin

text "This locale takes an iterator that refines a list of elements that themselves
can be iterated and defines an iterator over the flattened list of lower level elements"

locale flatten_iter =
  inner_list: imp_list_iterate is_inner_list inner_is_it inner_it_init inner_it_has_next inner_it_next +
  outer_list: imp_list_iterate is_outer_list outer_is_it outer_it_init outer_it_has_next outer_it_next
  for is_outer_list :: "'l list \<Rightarrow> 'm \<Rightarrow> assn"
  and outer_is_it :: "'l list \<Rightarrow> 'm \<Rightarrow> 'l list \<Rightarrow> 'oit \<Rightarrow> assn"
  and outer_it_init :: "'m \<Rightarrow> ('oit) Heap"
  and outer_it_has_next :: "'oit \<Rightarrow> bool Heap"
  and outer_it_next :: "'oit \<Rightarrow> ('l\<times>'oit) Heap"
  and is_inner_list :: "'a list \<Rightarrow> 'l \<Rightarrow> assn"
  and inner_is_it :: "'a list \<Rightarrow> 'l \<Rightarrow> 'a list \<Rightarrow> 'iit \<Rightarrow> assn"
  and inner_it_init :: "'l \<Rightarrow> ('iit) Heap"
  and inner_it_has_next :: "'iit \<Rightarrow> bool Heap"
  and inner_it_next :: "'iit \<Rightarrow> ('a\<times>'iit) Heap"
begin

fun is_flatten_list :: "'a list list \<Rightarrow> 'a list \<Rightarrow> 'm \<Rightarrow> assn" where
  "is_flatten_list ls' ls lsi = (\<exists>\<^sub>A lsi'.
    is_outer_list lsi' lsi * list_assn is_inner_list ls' lsi' * \<up>(ls = concat ls')
)"

lemma flatten_prec:
  "precise (is_flatten_list ls)"
  apply (intro preciseI)
  apply (auto)
  done

(*type_synonym flatten_it = "'iit \<times> 'oit"*)
fun is_flatten_it :: "'a list list \<Rightarrow> 'a list \<Rightarrow> 'm \<Rightarrow> 'a list \<Rightarrow> ('oit \<times> 'iit option) \<Rightarrow> assn"
  where
"is_flatten_it lsi'' ls lsi [] (oit, None) =
        (\<exists>\<^sub>A lsi'.
          list_assn is_inner_list lsi'' lsi' *
           \<up>(ls = (concat lsi'')) *
          outer_is_it lsi' lsi [] oit
)" |
"is_flatten_it lsi'' ls lsi ls2 (oit, Some iit) =
        (\<exists>\<^sub>A lsi' ls2' ls1' lsi1 lsi2 lsim ls2m lsm ls1m.
          list_assn is_inner_list ls1' lsi1 *
          list_assn is_inner_list ls2' lsi2 *
           \<up>(ls2m \<noteq> [] \<and> ls2 = ls2m@(concat ls2') \<and> ls = (concat (ls1'@lsm#ls2')) \<and> lsi'' = (ls1'@lsm#ls2')) *
          outer_is_it lsi' lsi lsi2 oit *
          \<up>(lsm = ls1m@ls2m \<and> lsi'=(lsi1@lsim#lsi2)) *
          inner_is_it lsm lsim ls2m iit
)
" |
"is_flatten_it _ _ _ _ _ = false"

partial_function (heap) flatten_it_adjust:: "'oit \<Rightarrow> 'iit \<Rightarrow> ('oit \<times> 'iit option) Heap" where
"flatten_it_adjust oit iit = do {
      ihasnext \<leftarrow> inner_it_has_next iit;
      if ihasnext then
        return (oit, Some iit)
      else do {
        ohasnext \<leftarrow> outer_it_has_next oit;
        if \<not>ohasnext then
          return (oit, None)
        else do {
          (next, oit) \<leftarrow> outer_it_next oit;
          nextit \<leftarrow> inner_it_init next;
          flatten_it_adjust oit nextit
        }
      }
  }
"

declare flatten_it_adjust.simps[code]

lemma flatten_it_adjust_rule:
  " <list_assn is_inner_list ls1' ls1 * list_assn is_inner_list ls2' ls2 *
      outer_is_it (ls1@lsim#ls2) lsi ls2 oit * inner_is_it (lsm1@lsm2) lsim lsm2 iit>
  flatten_it_adjust oit iit
  <is_flatten_it (ls1'@(lsm1@lsm2)#ls2') (concat (ls1'@(lsm1@lsm2)#ls2')) lsi (concat (lsm2#ls2'))>\<^sub>t"
proof (induction ls2 arbitrary: ls1' ls1 ls2' lsim lsm1 lsm2 oit iit)
  case Nil
  then show ?case
  apply(subst flatten_it_adjust.simps)
  apply (sep_auto eintros del: exI heap add: inner_list.it_has_next_rule)
  apply(inst_existentials "(ls1 @ lsim # [])" ls2' ls1' ls1 "[]::'l list" lsim lsm2 "lsm1@lsm2")
  subgoal by auto
  subgoal by (sep_auto)
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  subgoal
    apply (vcg (ss))
    apply (sep_auto eintros del: exI)
    apply(inst_existentials "(ls1 @ [lsim])" "ls1'@[lsm1]")
        subgoal
          apply(auto simp add: list_assn_app_one)
          using inner_list.quit_iteration
          by (smt (z3) assn_aci(9) assn_times_comm ent_true_drop(1) fr_refl)
  done
  done
next
  case (Cons a ls2)
  show ?case
  apply(subst flatten_it_adjust.simps)
  apply (sep_auto eintros del: exI heap add: inner_list.it_has_next_rule)
  apply(inst_existentials "(ls1 @ lsim # a # ls2)" ls2' ls1' ls1 "a #ls2" lsim lsm2 "lsm1@lsm2")
  subgoal by auto
  subgoal by (sep_auto)
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  subgoal by simp
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (case_tac ls2')
  apply simp_all
  apply (sep_auto eintros del: exI heap add: inner_list.it_init_rule)
  subgoal for x oit aa list xa
    supply R = "Cons.IH"[of "ls1'@[lsm1]" "ls1@[lsim]" list a oit "[]::'a list" aa xa, simplified]
    thm R
  find_theorems "_ \<Longrightarrow>\<^sub>A _" "<_>_<_>"
  supply Q = Hoare_Triple.cons_pre_rule[of
"inner_is_it aa a aa xa * outer_is_it (ls1 @ lsim # a # ls2) lsi ls2 oit *
     inner_is_it lsm1 lsim [] iit *
     list_assn is_inner_list ls1' ls1 *
     list_assn is_inner_list list ls2 *
     true"
"list_assn is_inner_list ls1' ls1 * is_inner_list lsm1 lsim * list_assn is_inner_list list ls2 *
 outer_is_it (ls1 @ lsim # a # ls2) lsi ls2 oit *
 inner_is_it aa a aa
  xa * true"
]
  thm Q
  apply(rule Q)
  prefer 2
  subgoal by (sep_auto heap add: R intro: inner_list.quit_iteration)
  subgoal using inner_list.quit_iteration
    by (smt (z3) assn_aci(10) assn_times_comm ent_refl_true ent_star_mono_true)
  done
  done
qed

definition flatten_it_init :: "'m \<Rightarrow> _ Heap"
  where "flatten_it_init l = do {
    oit \<leftarrow> outer_it_init l;
    ohasnext \<leftarrow> outer_it_has_next oit;
    if ohasnext then do {
       (next, oit) \<leftarrow> outer_it_next oit;
       nextit \<leftarrow> inner_it_init next;
       flatten_it_adjust oit nextit
    } else return (oit, None)
}"

lemma flatten_it_init_rule[sep_heap_rules]:
    "<is_flatten_list l' l p> flatten_it_init p <is_flatten_it l' l p l>\<^sub>t"
  unfolding flatten_it_init_def
  apply simp
  apply(rule norm_pre_ex_rule)+
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  subgoal for ls' x xa
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply (vcg (ss))
  apply(case_tac ls'; case_tac l')
  apply simp+
  apply(rule impI)
  thm inner_list.it_init_rule
  apply (vcg heap add: inner_list.it_init_rule)
  subgoal for _ nxt oit a list aa lista xaa
  supply R = flatten_it_adjust_rule[of "[]" "[]" lista list a p oit "[]" aa xaa, simplified]
  thm R
  apply (sep_auto heap add: R)
  done
  done
  apply (sep_auto)
  done

definition flatten_it_next where
  "flatten_it_next \<equiv> \<lambda>(oit,iit). do {
    (x, iit) \<leftarrow> inner_it_next (the iit);
    (oit, iit) \<leftarrow> flatten_it_adjust oit iit;
    return (x, (oit,iit))
  }"

lemma flatten_it_next_rule:
    " l' \<noteq> [] \<Longrightarrow>
    <is_flatten_it lsi'' l p l' it>
      flatten_it_next it
    <\<lambda>(a,it'). is_flatten_it lsi'' l p (tl l') it' * \<up>(a=hd l')>\<^sub>t"
  apply(subst flatten_it_next_def)
  thm inner_list.it_next_rule
  apply (vcg (ss))
  apply (vcg (ss))
  apply(case_tac iit; case_tac l')
  apply simp_all
  apply(rule norm_pre_ex_rule)+
  subgoal for oit iit a aa list lsi' ls2' ls1' lsi1 lsi2 lsim ls2m lsm ls1m
    apply(vcg (ss))
    apply(vcg (ss))
    apply(vcg (ss))
    apply(vcg (ss))
    apply(vcg (ss))
    apply(vcg (ss))
    apply(vcg (ss))
    apply(vcg (ss))
    apply(vcg (ss))
    apply(case_tac ls2m)
    apply simp_all
    subgoal for _ _ iita lista
  supply R = flatten_it_adjust_rule[of ls1' lsi1 ls2' lsi2 lsim p oit "ls1m@[aa]" "lista" iita, simplified]
  thm R
  apply (sep_auto heap add: R)
  done
  done
  done

definition flatten_it_has_next where
  "flatten_it_has_next \<equiv> \<lambda>(oit, iit). do {
    return (iit \<noteq> None)
}"

lemma flatten_it_has_next_rule[sep_heap_rules]:
    "<is_flatten_it lsi'' l p l' it>
       flatten_it_has_next it
     <\<lambda>r. is_flatten_it lsi'' l p l' it * \<up>(r\<longleftrightarrow>l'\<noteq>[])>\<^sub>t"
  apply(subst flatten_it_has_next_def)
  apply(sep_auto)
  apply(case_tac iit, case_tac l')
  apply simp_all
  apply sep_auto
  done

declare mult.left_assoc[simp add]
lemma flatten_quit_iteration:
    "is_flatten_it lsi'' l p l' it \<Longrightarrow>\<^sub>A is_flatten_list lsi'' l p * true"
  apply(cases it)
  subgoal for oit iit
    apply(cases iit; cases l')
  proof (goal_cases)
    case 1
    then show ?case
      apply (sep_auto eintros del: exI)
      subgoal for lsi'
        apply(inst_existentials lsi')
        subgoal by (metis (no_types, lifting) assn_aci(10) assn_times_comm fr_refl outer_list.quit_iteration)
        done
      done
  next
    case (2 lsim ll')
    then show ?case
      by (sep_auto eintros del: exI)
  next
    case (3 iit)
    then show ?case
      by (sep_auto eintros del: exI)
  next
  case (4 iit lsim ll')
    then show ?case
      apply (sep_auto eintros del: exI)
      subgoal for ls2' ls1' lsi1 lsi2 lsima ls2m ls1m
        apply(inst_existentials "(lsi1 @ lsima # lsi2)")
        apply(rule entails_preI)
        apply(sep_auto dest!: mod_starD list_assn_len)
            subgoal
              apply(simp add:
                  mult.commute[where ?b="outer_is_it (lsi1 @ lsima # lsi2) p lsi2 oit"]
                  mult.commute[where ?b="is_outer_list (lsi1 @ lsima # lsi2) p"]
                  mult.left_assoc )?
              apply(rule rem_true)
              supply R = ent_star_mono_true[of
                  "outer_is_it (lsi1 @ lsima # lsi2) p lsi2 oit"
                  "is_outer_list (lsi1 @ lsima # lsi2) p"
                  "list_assn is_inner_list ls1' lsi1 *
                         list_assn is_inner_list ls2' lsi2 *
                         inner_is_it (ls1m @ ls2m) lsima ls2m iit"
                  " list_assn is_inner_list ls1' lsi1 *
                         is_inner_list (ls1m @ ls2m) lsima *
                         list_assn is_inner_list ls2' lsi2"
              ,simplified]
              thm R
              apply(rule R)
              subgoal by (rule outer_list.quit_iteration)
              apply(simp add:
                  mult.commute[where ?b="inner_is_it (ls1m @ ls2m) lsima ls2m iit"]
                  mult.commute[where ?b="is_inner_list (ls1m @ ls2m) lsima"]
                  mult.left_assoc)
              apply(rule rem_true)
              supply R = ent_star_mono_true[of
                  "inner_is_it (ls1m @ ls2m) lsima ls2m iit"
                  "is_inner_list (ls1m @ ls2m) lsima"
                  "list_assn is_inner_list ls1' lsi1 *
                         list_assn is_inner_list ls2' lsi2"
                  " list_assn is_inner_list ls1' lsi1 *
                         list_assn is_inner_list ls2' lsi2"
              ,simplified]
              thm R
              apply(rule R)
              subgoal by (rule inner_list.quit_iteration)
              subgoal by sep_auto
              done
            done
          done
      qed
  done
declare mult.left_assoc[simp del]

interpretation flatten_it: imp_list_iterate "is_flatten_list lsi''" "is_flatten_it lsi''" flatten_it_init flatten_it_has_next flatten_it_next
  apply(unfold_locales)
  subgoal
    by (rule flatten_prec)
  subgoal for l p
    by (rule flatten_it_init_rule[of lsi'' l p])
  subgoal for  l' l p it
    by (rule flatten_it_next_rule[of l' lsi'' l p it]) simp
  subgoal for l p l' it
    by (rule flatten_it_has_next_rule[of lsi'' l p l' it])
  subgoal for l p l' it
    by (rule flatten_quit_iteration[of lsi'' l p l' it])
  done
end

end


(*  Title:      HOL/Types_To_Sets/Examples/Prerequisites.thy
    Author:     Ondřej Kunčar, TU München
*)

theory Prerequisites
  imports Main
  keywords "lemmas_with" :: thy_decl
begin

context
  fixes Rep Abs A T
  assumes type: "type_definition Rep Abs A"
  assumes T_def: "T \<equiv> (\<lambda>(x::'a) (y::'b). x = Rep y)"
begin

lemma type_definition_Domainp: "Domainp T = (\<lambda>x. x \<in> A)"
proof -
  interpret type_definition Rep Abs A by(rule type)
  show ?thesis
    unfolding Domainp_iff[abs_def] T_def fun_eq_iff
    by (metis Abs_inverse Rep)
qed

end

subsection \<open>setting up transfer for local typedef\<close>

lemmas [transfer_rule] = \<comment> \<open>prefer right-total rules\<close>
  right_total_All_transfer
  right_total_UNIV_transfer
  right_total_Ex_transfer

locale local_typedef = fixes S ::"'b set" and s::"'s itself"
  assumes Ex_type_definition_S: "\<exists>(Rep::'s \<Rightarrow> 'b) (Abs::'b \<Rightarrow> 's). type_definition Rep Abs S"
begin

definition "rep = fst (SOME (Rep::'s \<Rightarrow> 'b, Abs). type_definition Rep Abs S)"
definition "Abs = snd (SOME (Rep::'s \<Rightarrow> 'b, Abs). type_definition Rep Abs S)"

lemma type_definition_S: "type_definition rep Abs S"
  unfolding Abs_def rep_def split_beta'
  by (rule someI_ex) (use Ex_type_definition_S in auto)

lemma rep_in_S[simp]: "rep x \<in> S"
  and rep_inverse[simp]: "Abs (rep x) = x"
  and Abs_inverse[simp]: "y \<in> S \<Longrightarrow> rep (Abs y) = y"
  using type_definition_S
  unfolding type_definition_def by auto

definition cr_S where "cr_S \<equiv> \<lambda>s b. s = rep b"
lemmas Domainp_cr_S = type_definition_Domainp[OF type_definition_S cr_S_def, transfer_domain_rule]
lemmas right_total_cr_S = typedef_right_total[OF type_definition_S cr_S_def, transfer_rule]
  and bi_unique_cr_S = typedef_bi_unique[OF type_definition_S cr_S_def, transfer_rule]
  and left_unique_cr_S = typedef_left_unique[OF type_definition_S cr_S_def, transfer_rule]
  and right_unique_cr_S = typedef_right_unique[OF type_definition_S cr_S_def, transfer_rule]

lemma cr_S_rep[intro, simp]: "cr_S (rep a) a" by (simp add: cr_S_def)
lemma cr_S_Abs[intro, simp]: "a\<in>S \<Longrightarrow> cr_S a (Abs a)" by (simp add: cr_S_def)

end

subsection \<open>some \<close>

subsection \<open>Tool support\<close>

lemmas subset_iff' = subset_iff[folded Ball_def]

ML \<open>
structure More_Simplifier =
struct

fun asm_full_var_simplify ctxt thm =
  let
    val ((_, [thm']), ctxt') = Variable.import false [thm] ctxt
  in
    Simplifier.asm_full_simplify ctxt' thm'
    |> singleton (Variable.export ctxt' ctxt)
    |> Drule.zero_var_indexes
  end

fun var_simplify_only ctxt ths thm =
  asm_full_var_simplify (Raw_Simplifier.clear_simpset ctxt addsimps ths) thm

val var_simplified = Attrib.thms >>
  (fn ths => Thm.rule_attribute ths
    (fn context => var_simplify_only (Context.proof_of context) ths))

val _ = Theory.setup (Attrib.setup \<^binding>\<open>var_simplified\<close> var_simplified "simplified rule (with vars)")

end
\<close>

ML \<open>
val _ = Outer_Syntax.local_theory' \<^command_keyword>\<open>lemmas_with\<close> "note theorems with (the same) attributes"
    (Parse.attribs --| \<^keyword>\<open>:\<close> -- Parse_Spec.name_facts -- Parse.for_fixes
     >> (fn (((attrs),facts), fixes) =>
      #2 oo Specification.theorems_cmd Thm.theoremK
        (map (apsnd (map (apsnd (fn xs => attrs@xs)))) facts) fixes))
\<close>

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Late_Sim_Pres
  imports Weak_Late_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>\<^sup>^<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 auto
  thus ?case by simp
next
  case(Input Q' a x)
  have "\<tau>.(Q) \<longmapsto>a<x> \<prec> Q'" by fact
  hence False by auto
  thus ?case by simp
next
  case(Free Q' \<alpha>)
  have "\<tau>.(Q) \<longmapsto>(\<alpha> \<prec> Q')" by fact
  thus ?case using PRelQ
  proof(induct rule: tauCases, auto simp add: pi.inject residual.inject)
    have "\<tau>.(P) \<Longrightarrow>\<^sub>l\<^sup>^ \<tau> \<prec> P" by(rule Tau)
    moreover assume "(P, Q') \<in> Rel"
    ultimately show "\<exists>P'. \<tau>.(P) \<Longrightarrow>\<^sub>l\<^sup>^ \<tau> \<prec> P' \<and> (P', Q') \<in> Rel" by blast
  qed
qed

lemma inputPres:
  fixes P    :: pi
  and   Q    :: pi
  and   a    :: name
  and   x    :: 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>\<^sup>^<Rel> a<x>.Q"
proof -
  show ?thesis using Eqvt
  proof(induct rule: simCasesCont[of _ "(P, a, x, Q)"])
    case(Bound Q' b y)
    have "a<x>.Q \<longmapsto>b<\<nu>y> \<prec> Q'" by fact
    hence False by auto
    thus ?case by simp
  next
    case(Input Q' b y)
    have "y \<sharp> (P, a, x, Q)" by fact
    hence yFreshP: "(y::name) \<sharp> P" and yineqx: "y \<noteq> x" and "y \<noteq> a" and "y \<sharp> Q"
      by(simp add: fresh_prod)+
    have "a<x>.Q \<longmapsto>b<y> \<prec> Q'" by fact
    thus ?case using `y \<noteq> a` `y \<noteq> x` `y \<sharp> Q`
    proof(induct rule: inputCases, auto simp add: subject.inject)
      have "\<forall>u. \<exists>P'. a<x>.P \<Longrightarrow>\<^sub>lu in ([(x, y)] \<bullet> P)\<rightarrow>a<y> \<prec> P' \<and> (P', ([(x, y)] \<bullet> Q)[y::=u]) \<in> Rel"
      proof(rule allI)
        fix u
        have "a<x>.P \<Longrightarrow>\<^sub>lu in ([(x, y)] \<bullet> P)\<rightarrow>a<y> \<prec> ([(x, y)] \<bullet> P)[y::=u]" (is "?goal")
        proof -
          from yFreshP have "a<x>.P = a<y>.([(x, y)] \<bullet> P)" by(rule Agent.alphaInput)
          moreover have "a<y>.([(x, y)] \<bullet> P) \<Longrightarrow>\<^sub>lu in ([(x, y)] \<bullet> P)\<rightarrow>a<y> \<prec> ([(x, y)] \<bullet> P)[y::=u]"
            by(rule Weak_Late_Step_Semantics.Input)
          ultimately show ?goal by(simp add: name_swap)
        qed

        moreover have "(([(x, y)] \<bullet> P)[y::=u], ([(x, y)] \<bullet> Q)[y::=u]) \<in> Rel"
        proof -
          from PRelQ have "(P[x::=u], Q[x::=u]) \<in> Rel" by auto
          with `y \<sharp> P` `y \<sharp> Q` show ?thesis by(simp add: renaming)
        qed

        ultimately show "\<exists>P'. a<x>.P \<Longrightarrow>\<^sub>lu in ([(x, y)] \<bullet> P)\<rightarrow>a<y> \<prec> P' \<and> (P', ([(x, y)] \<bullet> Q)[y::=u]) \<in> Rel"
          by blast
      qed

      thus "\<exists>P''. \<forall>u. \<exists>P'. a<x>.P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<y> \<prec> P' \<and> (P', ([(x, y)] \<bullet> Q)[y::=u]) \<in> Rel" by blast
    qed
  next
    case(Free Q' \<alpha>)
    have "a<x>.Q \<longmapsto>\<alpha> \<prec> Q'" by fact
    hence False by auto
    thus ?case by simp
  qed
qed

lemma outputPres:
  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 PRelQ: "(P, Q) \<in> Rel"

  shows "a{b}.P \<leadsto>\<^sup>^<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 auto
  thus ?case by simp
next
  case(Input Q' c x)
  have "a{b}.Q \<longmapsto>c<x> \<prec> Q'" by fact
  hence False by 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>\<^sub>l\<^sup>^ \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel" using PRelQ
  proof(induct rule: outputCases, auto simp add: pi.inject residual.inject)
    have "a{b}.P \<Longrightarrow>\<^sub>l\<^sup>^ a[b] \<prec> P" by(rule Output)
    moreover assume "(P, Q') \<in> Rel"
    ultimately show "\<exists>P'. a{b}.P \<Longrightarrow>\<^sub>l\<^sup>^ a[b] \<prec> P' \<and> (P', Q') \<in> Rel" by blast
  qed
qed

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

  shows "[a\<frown>b]P \<leadsto>\<^sup>^<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 cMatch
    have "Q \<longmapsto>c<\<nu>x> \<prec> Q'" by fact
    with PSimQ xFreshP obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^c<\<nu>x> \<prec> P'"
                                   and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: simE)
    from PTrans have "[a\<frown>a]P \<Longrightarrow>\<^sub>l\<^sup>^c<\<nu>x> \<prec> P'" by(rule Weak_Late_Semantics.Match)
    with P'RelQ' RelRel' show ?case by blast
  qed
next
  case(Input Q' c x)
  have "x \<sharp> [a\<frown>b]P" by fact
  hence xFreshP: "x \<sharp> P" by simp
  have "[a\<frown>b]Q \<longmapsto>c<x> \<prec> Q'" by fact
  thus ?case
  proof(induct rule: matchCases)
    case cMatch
    have "Q \<longmapsto> c<x> \<prec> Q'" by fact
    with PSimQ xFreshP obtain P'' where L1: "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>c<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel"
      by(force intro: simE)
    have "\<forall>u. \<exists>P'. [a\<frown>a]P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>c<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel'"
    proof(rule allI)
      fix u
      from L1 obtain P' where PTrans: "P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>c<x> \<prec> P'" and P'RelQ': "(P', Q'[x::=u]) \<in> Rel"
        by blast
      from PTrans have "[a\<frown>a]P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>c<x> \<prec> P'" by(rule Weak_Late_Step_Semantics.Match)
      with P'RelQ' RelRel' show "\<exists>P'. [a\<frown>a]P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>c<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel'"
        by blast
    qed
    thus ?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 cMatch
    have "Q \<longmapsto> \<alpha> \<prec> Q'" by fact
    with PSimQ obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P'" and PRel: "(P', Q') \<in> Rel"
      by(blast dest: simE)
    from PTrans show ?case
    proof(induct rule: transitionCases)
      case Step
      have "P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'" by fact
      hence "[a\<frown>a]P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'" by(rule Weak_Late_Step_Semantics.Match)
      with PRel RelRel' show ?case by(force simp add: weakTransition_def)
    next
      case Stay
      have "\<alpha> \<prec> P' = \<tau> \<prec> P" by fact
      hence alphaEqTau: "\<alpha> = \<tau>" and PeqP': "P = P'" by(simp add: residual.inject)+
      have "[a\<frown>a]P \<Longrightarrow>\<^sub>l\<^sup>^\<tau> \<prec> [a\<frown>a]P" by(simp add: weakTransition_def)
      moreover from PeqP' PRel have "([a\<frown>a]P, Q') \<in> Rel" by(blast intro: RelStay)
      ultimately show ?case using RelRel' alphaEqTau 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>\<^sup>^<Rel> Q"
  and     RelStay: "\<And>P Q a b. \<lbrakk>(P, Q) \<in> Rel; a \<noteq> b\<rbrakk> \<Longrightarrow> ([a\<noteq>b]P, Q) \<in> Rel"
  and     RelRel': "Rel \<subseteq> Rel'"

  shows "[a\<noteq>b]P \<leadsto>\<^sup>^<Rel'> [a\<noteq>b]Q"
proof(cases "a = b")
  assume "a = b"
  thus ?thesis by(auto simp add: weakSimulation_def)
next
  assume aineqb: "a \<noteq> b"
  show ?thesis
  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 cMismatch
      have "Q \<longmapsto>c<\<nu>x> \<prec> Q'" by fact
      with PSimQ xFreshP obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^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>\<^sub>l\<^sup>^c<\<nu>x> \<prec> P'" by(rule Weak_Late_Semantics.Mismatch)
      with P'RelQ' RelRel' show ?case by blast
    qed
  next
    case(Input Q' c x)
    have "x \<sharp> [a\<noteq>b]P" by fact
    hence xFreshP: "x \<sharp> P" by simp
    have "[a\<noteq>b]Q \<longmapsto>c<x> \<prec> Q'" by fact
    thus ?case
    proof(induct rule: mismatchCases)
      case cMismatch
      have "Q \<longmapsto> c<x> \<prec> Q'" by fact
      with PSimQ xFreshP obtain P'' where L1: "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>c<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel"
        by(force intro: simE)
      have "\<forall>u. \<exists>P'. [a\<noteq>b]P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>c<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel'"
      proof(rule allI)
        fix u
        from L1 obtain P' where PTrans: "P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>c<x> \<prec> P'" and P'RelQ': "(P', Q'[x::=u]) \<in> Rel"
          by blast
        from PTrans aineqb have "[a\<noteq>b]P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>c<x> \<prec> P'" by(rule Weak_Late_Step_Semantics.Mismatch)
        with P'RelQ' RelRel' show "\<exists>P'. [a\<noteq>b]P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>c<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel'"
          by blast
      qed
      thus ?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 cMismatch
      have "a \<noteq> b" by fact
      have "Q \<longmapsto>\<alpha> \<prec> Q'" by fact
      with PSimQ obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P'" and PRel: "(P', Q') \<in> Rel"
        by(blast dest: simE)
      from PTrans show ?case
      proof(induct rule: transitionCases)
        case Step
        have "P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'" by fact
        hence "[a\<noteq>b]P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'" using `a \<noteq> b` by(rule Weak_Late_Step_Semantics.Mismatch)
        with PRel RelRel' show ?case by(force simp add: weakTransition_def)
      next
        case Stay
        have "\<alpha> \<prec> P' = \<tau> \<prec> P" by fact
        hence alphaEqTau: "\<alpha> = \<tau>" and PeqP': "P = P'" by(simp add: residual.inject)+
        have "[a\<noteq>b]P \<Longrightarrow>\<^sub>l\<^sup>^\<tau> \<prec> [a\<noteq>b]P" by(simp add: weakTransition_def)
        moreover from PeqP' PRel aineqb have "([a\<noteq>b]P, Q') \<in> Rel" by(blast intro: RelStay)
        ultimately show ?case using alphaEqTau RelRel' by blast
      qed
    qed
  qed
qed

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

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

  shows "P \<parallel> R \<leadsto>\<^sup>^<Rel''> Q \<parallel> T"
using `eqvt Rel''`
proof(induct rule: simCasesCont[where C="(P, Q, R, T)"])
  case(Bound Q' a x)
  from `x \<sharp> (P, Q, R, T)` have "x \<sharp> P" and "x \<sharp> R" and "x \<sharp> Q" and "x \<sharp> T" by simp+
  from `Q \<parallel> T \<longmapsto> a<\<nu>x> \<prec> Q'` `x \<sharp> Q` `x \<sharp> T`
  show ?case
  proof(induct rule: parCasesB)
    case(cPar1 Q')
    from PSimQ `Q \<longmapsto> a<\<nu>x> \<prec> Q'` `x \<sharp> P` obtain P' where PTrans:"P \<Longrightarrow>\<^sub>l\<^sup>^ a<\<nu>x> \<prec> P'"
                                                      and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: simE)
    from PTrans `x \<sharp> R` have "P \<parallel> R \<Longrightarrow>\<^sub>l\<^sup>^ a<\<nu>x> \<prec> (P' \<parallel> R)" by(rule Weak_Late_Semantics.Par1B)
    moreover from P'RelQ' RRel'T have "(P' \<parallel> R, Q' \<parallel> T) \<in> Rel''" by(rule Par)
    ultimately show ?case by blast
  next
    case(cPar2 T')
    from RSimT `T \<longmapsto> a<\<nu>x> \<prec> T'` `x \<sharp> R` obtain R' where RTrans:"R \<Longrightarrow>\<^sub>l\<^sup>^ a<\<nu>x> \<prec> R'"
                                                      and R'Rel'T': "(R', T') \<in>  Rel'"
      by(blast dest: simE)
    from RTrans `x \<sharp> P` `x \<sharp> R` have ParTrans: "P \<parallel> R \<Longrightarrow>\<^sub>l\<^sup>^ a<\<nu>x> \<prec> (P \<parallel> R')"
      by(blast intro: Weak_Late_Semantics.Par2B)
    moreover from PRelQ R'Rel'T' have "(P \<parallel> R', Q \<parallel>  T') \<in> Rel''" by(rule Par)
    ultimately show ?case by blast
  qed
next
  case(Input Q' a x)
  from `x \<sharp> (P, Q, R, T)` have "x \<sharp> P" and "x \<sharp> R" and "x \<sharp> Q" and "x \<sharp> T" by simp+
  from `Q \<parallel> T \<longmapsto> a<x> \<prec> Q'` `x \<sharp> Q` `x \<sharp> T`
  show ?case
  proof(induct rule: parCasesB)
    case(cPar1 Q')
    from PSimQ `Q \<longmapsto>a<x> \<prec> Q'` `x \<sharp> P` obtain P''
      where L1: "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel"
      by(blast dest: simE)
    have "\<forall>u. \<exists>P'. P \<parallel> R \<Longrightarrow>\<^sub>lu in (P'' \<parallel> R)\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u] \<parallel> T[x::=u]) \<in> Rel''"
    proof(rule allI)
      fix u
      from L1 obtain P' where PTrans:"P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P'"
                          and P'RelQ': "(P', Q'[x::=u]) \<in> Rel" by blast
      from PTrans `x \<sharp> R` have "P \<parallel> R \<Longrightarrow>\<^sub>lu in (P'' \<parallel> R)\<rightarrow>a<x> \<prec> (P' \<parallel> R)"
        by(rule Weak_Late_Step_Semantics.Par1B)
      moreover from P'RelQ' RRel'T have "(P' \<parallel> R, Q'[x::=u] \<parallel> T) \<in> Rel''" by(rule Par)
      ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>\<^sub>lu in (P'' \<parallel> R)\<rightarrow>a<x> \<prec> P' \<and>
                            (P', Q'[x::=u] \<parallel> (T[x::=u])) \<in> Rel''" using `x \<sharp> T`
        by(force simp add: forget)
    qed
    thus ?case by force
  next
    case(cPar2 T')
    from RSimT `T \<longmapsto>a<x> \<prec> T'` `x \<sharp> R` obtain R''
      where L1: "\<forall>u. \<exists>R'. R \<Longrightarrow>\<^sub>lu in R''\<rightarrow>a<x> \<prec> R' \<and> (R', T'[x::=u]) \<in> Rel'"
      by(blast dest: simE)
    have "\<forall>u. \<exists>P'. P \<parallel> R \<Longrightarrow>\<^sub>lu in (P \<parallel> R'')\<rightarrow>a<x> \<prec> P' \<and> (P', Q[x::=u] \<parallel> T'[x::=u]) \<in> Rel''"
    proof(rule allI)
      fix u
      from L1 obtain R' where RTrans:"R \<Longrightarrow>\<^sub>lu in R''\<rightarrow>a<x> \<prec> R'"
                          and R'Rel'T': "(R', T'[x::=u]) \<in>  Rel'" by blast
      from RTrans `x \<sharp> P` have ParTrans: "P \<parallel> R \<Longrightarrow>\<^sub>lu in (P \<parallel> R'')\<rightarrow>a<x> \<prec> (P \<parallel> R')"
        by(rule Weak_Late_Step_Semantics.Par2B)

      moreover from PRelQ R'Rel'T' have "(P \<parallel> R', Q \<parallel>  T'[x::=u]) \<in> Rel''" by(rule Par)

      ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>\<^sub>lu in (P \<parallel> R'')\<rightarrow>a<x> \<prec> P' \<and>
                            (P', Q[x::=u] \<parallel> T'[x::=u]) \<in> Rel''" using `x \<sharp> Q`
        by(force simp add: forget)
    qed
    thus ?case by force
  qed
next
  case(Free QT' \<alpha>)
  have "Q \<parallel> T \<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>\<^sub>l\<^sup>^ \<alpha> \<prec> P'" and PRel: "(P', Q') \<in> Rel"
      by(blast dest: simE)
    from PTrans have Trans: "P \<parallel> R \<Longrightarrow>\<^sub>l\<^sup>^ \<alpha> \<prec> P' \<parallel> R" by(rule Weak_Late_Semantics.Par1F)
    moreover from PRel RRel'T have "(P' \<parallel> R, Q' \<parallel> T) \<in> Rel''" by(blast intro: Par)
    ultimately show ?case by blast
  next
    case(cPar2 T')
    have "T \<longmapsto> \<alpha> \<prec> T'" by fact
    with RSimT obtain R' where RTrans: "R \<Longrightarrow>\<^sub>l\<^sup>^ \<alpha> \<prec> R'" and RRel: "(R', T') \<in> Rel'"
      by(blast dest: simE)
    from RTrans have Trans: "P \<parallel> R \<Longrightarrow>\<^sub>l\<^sup>^ \<alpha> \<prec> P \<parallel> R'" by(rule Weak_Late_Semantics.Par2F)
    moreover from PRelQ RRel have "(P \<parallel> R', Q \<parallel> T') \<in> Rel''" by(blast intro: Par)
    ultimately show ?case by blast
  next
    case(cComm1 Q' T' a b x)
    have QTrans: "Q \<longmapsto> a<x> \<prec> Q'" and TTrans: "T \<longmapsto> a[b] \<prec> T'" by fact+
    have "x \<sharp> (P, R)" by fact
    hence xFreshP: "x \<sharp> P" by(simp add: fresh_prod)

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

    from RSimT TTrans obtain R' where RTrans: "R \<Longrightarrow>\<^sub>l\<^sup>^a[b] \<prec> R'"
                                  and RRel: "(R', T') \<in> Rel'"
      by(blast dest: simE)

    from PTrans RTrans have "P \<parallel> R \<Longrightarrow>\<^sub>l\<^sup>^ \<tau> \<prec> P' \<parallel> R'" by(rule Weak_Late_Semantics.Comm1)
    moreover from P'RelQ' RRel have "(P' \<parallel> R', Q'[x::=b] \<parallel> T') \<in> Rel''" by(rule Par)
    ultimately show ?case by blast
  next
    case(cComm2 Q' T' a b x)
    have QTrans: "Q \<longmapsto>a[b] \<prec> Q'" and TTrans: "T \<longmapsto>a<x> \<prec> T'" by fact+
    have "x \<sharp> (P, R)" by fact
    hence xFreshR: "x \<sharp> R" by(simp add: fresh_prod)

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

    from RSimT TTrans xFreshR obtain R' R'' where RTrans: "R \<Longrightarrow>\<^sub>lb in R''\<rightarrow>a<x> \<prec> R'"
                                              and R'Rel'T': "(R', T'[x::=b]) \<in> Rel'"
      by(blast dest: simE)

    from PTrans RTrans have "P \<parallel> R \<Longrightarrow>\<^sub>l\<^sup>^ \<tau> \<prec> P' \<parallel> R'" by(rule Weak_Late_Semantics.Comm2)
    moreover from PRel R'Rel'T' have "(P' \<parallel> R', Q' \<parallel> T'[x::=b]) \<in> Rel''" by(rule Par)
    ultimately show ?case by blast
  next
    case(cClose1 Q' T' a x y)
    have QTrans: "Q \<longmapsto>a<x> \<prec> Q'" and TTrans: "T \<longmapsto>a<\<nu>y> \<prec> T'" by fact+
    have "x \<sharp> (P, R)" and "y \<sharp> (P, R)" by fact+
    hence xFreshP: "x \<sharp> P" and yFreshR: "y \<sharp> R" and yFreshP: "y \<sharp> P" by(simp add: fresh_prod)+

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

    from RSimT TTrans yFreshR obtain R' where RTrans: "R \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>y> \<prec> R'"
                                          and R'Rel'T': "(R', T') \<in> Rel'"
      by(blast dest: simE)

    from PTrans RTrans yFreshP yFreshR have Trans: "P \<parallel> R \<Longrightarrow>\<^sub>l\<^sup>^ \<tau> \<prec> <\<nu>y>(P' \<parallel> R')"
      by(rule Weak_Late_Semantics.Close1)
    moreover from P'RelQ' R'Rel'T' have "(<\<nu>y>(P' \<parallel> R'), <\<nu>y>(Q'[x::=y] \<parallel> T')) \<in> Rel''"
      by(blast intro: Par Res)
    ultimately show ?case by blast
  next
    case(cClose2 Q' T' a x y)
    have QTrans: "Q \<longmapsto>a<\<nu>y> \<prec> Q'" and TTrans: "T \<longmapsto>a<x> \<prec> T'" by fact+
    have "x \<sharp> (P, R)" and "y \<sharp> (P, R)" by fact+
    hence xFreshR: "x \<sharp> R" and yFreshP: "y \<sharp> P" and yFreshR: "y \<sharp> R" by(simp add: fresh_prod)+

    from PSimQ QTrans yFreshP obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>y> \<prec> P'"
                                          and P'RelQ': "(P', Q') \<in> Rel"
      by(blast dest: simE)

    from RSimT TTrans xFreshR obtain R' R'' where RTrans: "R \<Longrightarrow>\<^sub>ly in R''\<rightarrow>a<x> \<prec> R'"
                                              and R'Rel'T': "(R', T'[x::=y]) \<in> Rel'"
      by(blast dest: simE)

    from PTrans RTrans yFreshP yFreshR have Trans: "P \<parallel> R \<Longrightarrow>\<^sub>l\<^sup>^\<tau> \<prec> <\<nu>y>(P' \<parallel> R')"
      by(rule Weak_Late_Semantics.Close2)
    moreover from P'RelQ' R'Rel'T' have "(<\<nu>y>(P' \<parallel> R'), <\<nu>y>(Q' \<parallel> T'[x::=y])) \<in> Rel''"
      by(blast intro: Par Res)
    ultimately show ?case by blast
  qed
qed

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

  assumes PSimQ:    "P \<leadsto>\<^sup>^<Rel> Q"
  and     PRelQ:    "(P, Q) \<in> Rel"
  and     Par:      "\<And>P Q R. (P, Q) \<in> Rel \<Longrightarrow> (P \<parallel> R, Q \<parallel> R) \<in> Rel'"
  and     Res:      "\<And>P Q a. (P, Q) \<in> Rel' \<Longrightarrow> (<\<nu>a>P, <\<nu>a>Q) \<in> Rel'"
  and     EqvtRel:  "eqvt Rel"
  and     EqvtRel': "eqvt Rel'"

  shows "P \<parallel> R \<leadsto>\<^sup>^<Rel'> Q \<parallel> R"
proof -
  note PSimQ
  moreover have RSimR: "R \<leadsto>\<^sup>^<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
  moreover note Res `eqvt Rel`
  moreover have "eqvt Id" by(auto simp add: eqvt_def)
  ultimately show ?thesis using EqvtRel' by(rule parCompose)
qed

  assumes PSimQ: "P \<leadsto>\<^sup>^<Rel> Q"
  and     ResRel: "\<And>(P::pi) (Q::pi) (x::name). (P, Q) \<in> Rel \<Longrightarrow> (<\<nu>x>P, <\<nu>x>Q) \<in> Rel'"
  and     RelRel': "Rel \<subseteq> Rel'"
  and     EqvtRel: "eqvt Rel"
  and     EqvtRel': "eqvt Rel'"

  shows "<\<nu>x>P \<leadsto>\<^sup>^<Rel'> <\<nu>x>Q"
proof -
  from EqvtRel' show ?thesis
  proof(induct rule: simCasesCont[of _ "(P, Q, x)"])
    case(Bound Q' a y)
    have Trans: "<\<nu>x>Q \<longmapsto>a<\<nu>y> \<prec> Q'" by fact
    have "y \<sharp> (P, Q, x)" by fact
    hence yineqx: "y \<noteq> x" and yFreshP: "y \<sharp> P" and "y \<sharp> Q" by(simp add: fresh_prod)+
    from Trans `y \<noteq> x` `y \<sharp> Q` show ?case
    proof(induct rule: resCasesB)
      case(cOpen a 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>\<^sub>l\<^sup>^a[x] \<prec> P'"
                                    and P'RelQ': "(P', Q') \<in> Rel"
        by(blast dest: simE)

      have "<\<nu>x>P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>y> \<prec> ([(y, x)] \<bullet> P')"
      proof -
        from PTrans aineqx have "<\<nu>x>P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P'" by(rule Weak_Late_Semantics.Open)
        moreover from PTrans yFreshP have "y \<sharp> P'" by(force intro: freshTransition)
        ultimately show ?thesis by(simp add: alphaBoundResidual name_swap)
      qed
      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(cRes Q')
      have QTrans: "Q \<longmapsto>a<\<nu>y> \<prec> Q'" by fact
      from `x \<sharp> BoundOutputS a` have "x \<noteq> a" by simp

      from PSimQ yFreshP QTrans obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>y> \<prec> P'"
                                            and P'RelQ': "(P', Q') \<in> Rel"
        by(blast dest: simE)
      from PTrans `x \<noteq> a` yineqx yFreshP have ResTrans: "<\<nu>x>P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>y> \<prec> (<\<nu>x>P')"
        by(blast intro: Weak_Late_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(Input Q' a y)
    have "y \<sharp> (P, Q, x)" by fact
    hence yineqx: "y \<noteq> x" and yFreshP: "y \<sharp> P" and "y \<sharp> Q" by(simp add: fresh_prod)+
    have "<\<nu>x>Q \<longmapsto>a<y> \<prec> Q'" by fact
    thus ?case using yineqx `y \<sharp> Q`
    proof(induct rule: resCasesB)
      case(cOpen a Q')
      thus ?case by simp
    next
      case(cRes Q')
      have QTrans: "Q \<longmapsto>a<y> \<prec> Q'" by fact
      from `x \<sharp> InputS a` have "x \<noteq> a" by simp

      from PSimQ QTrans yFreshP obtain P''
        where L1: "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<y> \<prec> P' \<and> (P', Q'[y::=u]) \<in> Rel"
        by(blast dest: simE)
      have "\<forall>u. \<exists>P'. <\<nu>x>P \<Longrightarrow>\<^sub>lu in (<\<nu>x>P'')\<rightarrow>a<y> \<prec> P' \<and> (P', (<\<nu>x>Q')[y::=u]) \<in> Rel'"
      proof(rule allI)
        fix u
        show "\<exists>P'. <\<nu>x>P \<Longrightarrow>\<^sub>lu in <\<nu>x>P''\<rightarrow>a<y> \<prec> P' \<and> (P', (<\<nu>x>Q')[y::=u]) \<in> Rel'"
        proof(cases "x=u")
          assume xequ: "x=u"

          have "\<exists>c::name. c \<sharp> (P, P'', Q', x, y, a)" by(blast intro: name_exists_fresh)
          then obtain c::name where cFreshP: "c \<sharp> P" and cFreshP'': "c \<sharp> P''" and cFreshQ': "c \<sharp> Q'"
                                and cineqx: "c \<noteq> x" and cineqy: "c \<noteq> y" and cineqa: "c \<noteq> a"
            by(force simp add: fresh_prod)

          from L1 obtain P' where PTrans: "P \<Longrightarrow>\<^sub>lc in P''\<rightarrow>a<y> \<prec> P'"
                              and P'RelQ': "(P', Q'[y::=c]) \<in> Rel"
            by blast
          have "<\<nu>x>P \<Longrightarrow>\<^sub>lu in (<\<nu>x>P'')\<rightarrow>a<y> \<prec> <\<nu>c>([(x, c)] \<bullet> P')"
          proof -
            from PTrans yineqx `x \<noteq> a` cineqx have "<\<nu>x>P \<Longrightarrow>\<^sub>lc in (<\<nu>x>P'')\<rightarrow>a<y> \<prec> <\<nu>x>P'"
              by(blast intro: Weak_Late_Step_Semantics.ResB)
            hence "([(x, c)] \<bullet> <\<nu>x>P) \<Longrightarrow>\<^sub>l([(x, c)] \<bullet> c) in ([(x, c)] \<bullet> <\<nu>x>P'')\<rightarrow>([(x, c)] \<bullet> a)<([(x, c)] \<bullet> y)> \<prec> [(x, c)] \<bullet> <\<nu>x>P'"
              by(rule Weak_Late_Step_Semantics.eqvtI)
            moreover from cFreshP have "<\<nu>c>([(x, c)] \<bullet> P) = <\<nu>x>P" by(simp add: alphaRes)
            moreover from cFreshP'' have "<\<nu>c>([(x, c)] \<bullet> P'') = <\<nu>x>P''" by(simp add: alphaRes)
            ultimately show ?thesis using `x \<noteq> a` cineqa yineqx cineqy cineqx xequ by(simp add: name_calc)
          qed
          moreover have "(<\<nu>c>([(x, c)] \<bullet> P'), (<\<nu>x>Q')[y::=u]) \<in> Rel'"
          proof -
            from P'RelQ' have "(<\<nu>x>P', <\<nu>x>(Q'[y::=c])) \<in> Rel'" by(rule ResRel)
            with EqvtRel' have "([(x, c)] \<bullet> <\<nu>x>P', [(x, c)] \<bullet> <\<nu>x>(Q'[y::=c])) \<in> Rel'"  by(rule eqvtRelI)
            with cineqy yineqx cineqx have "(<\<nu>c>([(x, c)] \<bullet> P'), (<\<nu>c>([(x, c)] \<bullet> Q'))[y::=x]) \<in> Rel'"
              by(simp add: name_calc eqvt_subs)
            with cFreshQ' xequ show ?thesis by(simp add: alphaRes)
          qed
          ultimately show ?thesis by blast
        next
          assume xinequ: "x \<noteq> u"
          from L1 obtain P' where PTrans: "P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<y> \<prec> P'"
                             and P'RelQ': "(P', Q'[y::=u]) \<in> Rel" by blast

          from PTrans `x \<noteq> a` yineqx xinequ have "<\<nu>x>P \<Longrightarrow>\<^sub>lu in (<\<nu>x>P'')\<rightarrow>a<y> \<prec> <\<nu>x>P'"
            by(blast intro: Weak_Late_Step_Semantics.ResB)
          moreover from P'RelQ' xinequ yineqx have "(<\<nu>x>P', (<\<nu>x>Q')[y::=u]) \<in> Rel'"
            by(force intro: ResRel)
          ultimately show ?thesis by blast
        qed
      qed
      thus ?case by blast
    qed
  next
    case(Free Q' \<alpha>)
    have "<\<nu>x>Q \<longmapsto> \<alpha> \<prec> Q'" by fact
    thus ?case
    proof(induct rule: resCasesF)
      case(cRes Q')
      have "Q \<longmapsto>\<alpha> \<prec> Q'" by fact
      with PSimQ obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^ \<alpha> \<prec> P'"
                             and P'RelQ': "(P', Q') \<in> Rel"
        by(blast dest: simE)

      have "<\<nu>x>P \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> <\<nu>x>P'"
      proof -
        have xFreshAlpha: "x \<sharp> \<alpha>" by fact
        with PTrans show ?thesis by(rule ResF)
      qed
      moreover from P'RelQ' have "(<\<nu>x>P', <\<nu>x>Q') \<in> Rel'" by(rule ResRel)
      ultimately show ?case by blast
    qed
  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>P Q a. (P, Q) \<in> Rel \<Longrightarrow> (<\<nu>a>P, <\<nu>a>Q) \<in> Rel"
  and     PRelQ:   "P \<leadsto>\<^sup>^<Rel> Q"

  shows "(resChain lst) P \<leadsto>\<^sup>^<Rel> (resChain lst) Q"
proof -
  show ?thesis
  proof(induct lst) (* Base case *)
    from PRelQ show "resChain [] P \<leadsto>\<^sup>^<Rel> resChain [] Q" by simp
  next (* Inductive step *)
    fix a lst
    assume IH: "(resChain lst P) \<leadsto>\<^sup>^<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>\<^sup>^<Rel> <\<nu>a>(resChain lst Q)" using eqvtRel
      by(rule_tac resPres)
    thus "resChain (a # lst) P \<leadsto>\<^sup>^<Rel> resChain (a # lst) Q"
      by simp
  qed
qed

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

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

  shows "!P \<leadsto>\<^sup>^<Rel'> !Q"
proof -
  have "\<And>Rs P. \<lbrakk>!Q \<longmapsto> Rs; (P, !Q) \<in> bangRel Rel\<rbrakk> \<Longrightarrow> weakSimAct P Rs P Rel'"
  proof -
    fix Rs P
    assume "!Q \<longmapsto> Rs" and "(P, !Q) \<in> bangRel Rel"
    thus "weakSimAct P Rs P Rel'"
    proof(nominal_induct avoiding: P rule: bangInduct)
      case(cPar1B aa x Q')
      have QTrans: "Q \<longmapsto>aa\<guillemotleft>x\<guillemotright> \<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>\<^sup>^<Rel> Q" by(rule Sim)
        from eqvtRel' show ?case
        proof(induct rule: simActBoundCases)
          case(Input a)
          have "aa = InputS a" by fact
          with PSimQ QTrans xFreshP obtain P''
            where L1: "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel"
            by(blast dest: simE)
          have "\<forall>u. \<exists>P'. P \<parallel> R \<Longrightarrow>\<^sub>lu in (P'' \<parallel> R)\<rightarrow>a<x> \<prec> P' \<and> (P', (Q' \<parallel> !Q)[x::=u]) \<in> Rel'"
          proof(rule allI)
            fix u
            from L1 obtain P' where PTrans: "P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P'"
                                and P'RelQ': "(P', Q'[x::=u]) \<in> Rel"
              by blast

            from PTrans xFreshR have "P \<parallel> R \<Longrightarrow>\<^sub>lu in (P'' \<parallel> R)\<rightarrow>a<x>\<prec> P' \<parallel> R"
              by(rule Weak_Late_Step_Semantics.Par1B)
            moreover have "(P' \<parallel> R, (Q' \<parallel> !Q)[x::=u]) \<in> Rel'"
            proof -
              from P'RelQ' RBangRelT have "(P' \<parallel> R, Q'[x::=u] \<parallel> !Q) \<in> bangRel Rel"
                by(rule Rel.BRPar)
              with xFreshQ BangRelRel' show ?thesis by(auto simp add: forget)
            qed
            ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>\<^sub>lu in (P'' \<parallel> R)\<rightarrow>a<x> \<prec> P' \<and>
                                  (P', (Q' \<parallel> !Q)[x::=u]) \<in> Rel'" by blast
          qed
          thus ?case by blast
        next
          case(BoundOutput a)
          have "aa = BoundOutputS a" by fact
          with PSimQ QTrans xFreshP obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P'"
                                                and P'RelQ': "(P', Q') \<in> Rel"
            by(blast dest: simE)
          from PTrans xFreshR have "P \<parallel> R \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x>\<prec> P' \<parallel> R"
            by(rule Weak_Late_Semantics.Par1B)
          moreover from P'RelQ' RBangRelT BangRelRel' have "(P' \<parallel> R, Q' \<parallel> !Q) \<in> Rel'"
            by(blast intro: Rel.BRPar)
          ultimately show ?case by blast
        qed
      qed
    next
      case(cPar1F \<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(induct rule: simActFreeCases)
          case Der
          from PRelQ have "P \<leadsto>\<^sup>^<Rel> Q" by(rule Sim)
          with QTrans obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
            by(blast dest: simE)

          from PTrans have "P \<parallel> R \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P' \<parallel> R" by(rule Weak_Late_Semantics.Par1F)
          moreover from P'RelQ' RBangRelQ have "(P' \<parallel> R, Q' \<parallel> !Q) \<in> bangRel Rel"
            by(rule Rel.BRPar)
          ultimately show ?case using BangRelRel' by blast
        qed
      qed
    next
      case(cPar2B aa x Q' P)
      have IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> weakSimAct P (aa\<guillemotleft>x\<guillemotright> \<prec> Q') P Rel'" by fact
      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+
        from eqvtRel' show ?case
        proof(induct rule: simActBoundCases)
          case(Input a)
          have "aa = InputS a" by fact
          with RBangRelQ IH have "weakSimAct R (a<x> \<prec> Q') R Rel'" by blast
          with xFreshR obtain R'' where L1: "\<forall>u. \<exists>R'. R \<Longrightarrow>\<^sub>lu in R''\<rightarrow>a<x> \<prec> R' \<and> (R', Q'[x::=u]) \<in> Rel'"
            by(force simp add: weakSimAct_def)
          have "\<forall>u. \<exists>P'. P \<parallel> R \<Longrightarrow>\<^sub>lu in (P \<parallel> R'')\<rightarrow>a<x> \<prec> P' \<and> (P', (Q \<parallel> Q')[x::=u]) \<in> Rel'"
          proof(rule allI)
            fix u
            from L1 obtain R' where RTrans: "R \<Longrightarrow>\<^sub>lu in R''\<rightarrow>a<x> \<prec> R'"
                                and R'Rel'Q': "(R', Q'[x::=u]) \<in> Rel'"
              by blast

            from RTrans xFreshP have "P \<parallel> R \<Longrightarrow>\<^sub>lu in (P \<parallel> R'')\<rightarrow>a<x> \<prec> P \<parallel> R'"
              by(rule Weak_Late_Step_Semantics.Par2B)
            moreover have "(P \<parallel> R', (Q \<parallel> Q')[x::=u]) \<in> Rel'"
            proof -
              from PRelQ R'Rel'Q' have "(P \<parallel> R', Q \<parallel> Q'[x::=u]) \<in> Rel'"
                by(rule ParComp)
              with xFreshQ show ?thesis by(simp add: forget)
            qed
            ultimately show "\<exists>P'. P \<parallel> R \<Longrightarrow>\<^sub>lu in (P \<parallel> R'')\<rightarrow>a<x> \<prec> P' \<and> (P', (Q \<parallel> Q')[x::=u]) \<in> Rel'"
              by blast
          qed
          thus ?case by blast
        next
          case(BoundOutput a)
          have "aa = BoundOutputS a" by fact
          with IH RBangRelQ have "weakSimAct R (a<\<nu>x> \<prec> Q') R Rel'" by blast
          with xFreshR obtain R' where RTrans: "R \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> R'" and R'BangRelQ': "(R', Q') \<in> Rel'"
            by(simp add: weakSimAct_def, blast)

          from RTrans xFreshP have "P \<parallel> R \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P \<parallel> R'"
            by(auto intro: Weak_Late_Semantics.Par2B)
          moreover from PRelQ R'BangRelQ' have "(P \<parallel> R', Q \<parallel> Q') \<in> Rel'"
            by(rule ParComp)
          ultimately show ?case by blast
        qed
      qed
    next
      case(cPar2F \<alpha> Q' P)
      have IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> weakSimAct P (\<alpha> \<prec> Q') P Rel'" 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(induct rule: simActFreeCases)
          case Der
          from RBangRelQ have "weakSimAct R (\<alpha> \<prec> Q') R Rel'" by(rule IH)
          then obtain R' where RTrans: "R \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> R'" and R'RelQ': "(R', Q') \<in> Rel'"
            by(simp add: weakSimAct_def, blast)

          from RTrans have "P \<parallel> R \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P \<parallel> R'" by(rule Weak_Late_Semantics.Par2F)
          moreover from PRelQ R'RelQ' have "(P \<parallel> R', Q \<parallel> Q') \<in> Rel'" by(rule ParComp)
          ultimately show ?case by blast
        qed
      qed
    next
      case(cComm1 a x Q' b Q'' P)
      have QTrans: "Q \<longmapsto> a<x> \<prec> Q'" by fact
      have IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> weakSimAct P (a[b] \<prec> Q'') P Rel'" 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" by simp
        show ?case
        proof(induct rule: simActFreeCases)
          case Der
          from PRelQ have "P \<leadsto>\<^sup>^<Rel> Q" by(rule Sim)
          with QTrans xFreshP obtain P' P'' where PTrans: "P \<Longrightarrow>\<^sub>lb in P''\<rightarrow>a<x> \<prec> P'"
                                              and P'RelQ': "(P', Q'[x::=b]) \<in> Rel"
            by(blast dest: simE)

          from RBangRelQ have "weakSimAct R (a[b] \<prec> Q'') R Rel'" by(rule IH)
          then obtain R' where RTrans: "R \<Longrightarrow>\<^sub>l\<^sup>^a[b] \<prec> R'"
                           and R'RelQ'': "(R', Q'') \<in> Rel'"
            by(simp add: weakSimAct_def, blast)

          from PTrans RTrans have "P \<parallel> R \<Longrightarrow>\<^sub>l\<^sup>^\<tau> \<prec> (P' \<parallel> R')"
            by(rule Weak_Late_Semantics.Comm1)
          moreover from P'RelQ' R'RelQ'' have "(P' \<parallel> R', Q'[x::=b] \<parallel> Q'') \<in> Rel'"
            by(rule ParComp)
          ultimately show ?case by blast
        qed
      qed
    next
      case(cComm2 a b Q' x Q'' P)
      have QTrans: "Q \<longmapsto>a[b] \<prec> Q'" by fact
      have IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> weakSimAct P (a<x> \<prec> Q'') P Rel'" 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" by simp
        show ?case
        proof(induct rule: simActFreeCases)
          case Der
          from PRelQ have "P \<leadsto>\<^sup>^<Rel> Q" by(rule Sim)
          with QTrans obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^a[b] \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
            by(blast dest: simE)

          from RBangRelQ have "weakSimAct R (a<x> \<prec> Q'') R Rel'" by(rule IH)
          with xFreshR obtain R' R'' where RTrans: "R \<Longrightarrow>\<^sub>lb in R''\<rightarrow>a<x> \<prec> R'"
                                       and R'BangRelQ'': "(R', Q''[x::=b]) \<in> Rel'"
            by(simp add: weakSimAct_def, blast)

          from PTrans RTrans have "P \<parallel> R \<Longrightarrow>\<^sub>l\<^sup>^\<tau> \<prec> (P' \<parallel> R')"
            by(rule Weak_Late_Semantics.Comm2)
          moreover from P'RelQ' R'BangRelQ'' have "(P' \<parallel> R', Q' \<parallel> Q''[x::=b]) \<in> Rel'"
            by(rule ParComp)
          ultimately show ?case by blast
        qed
      qed
    next
      case(cClose1 a x Q' y Q'' P)
      have QTrans: "Q \<longmapsto> a<x> \<prec> Q'" by fact
      have IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> weakSimAct P (a<\<nu>y> \<prec> Q'') P Rel'" by fact
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" and "x \<sharp> P" and "y \<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" by simp
        have "y \<sharp> P \<parallel> R" by fact
        hence yFreshR: "y \<sharp> R" and yFreshP: "y \<sharp> P" by simp+
        show ?case
        proof(induct rule: simActFreeCases)
          case Der
          from PRelQ have "P \<leadsto>\<^sup>^<Rel> Q" by(rule Sim)
          with QTrans xFreshP obtain P' P'' where PTrans: "P \<Longrightarrow>\<^sub>ly in P''\<rightarrow>a<x> \<prec> P'"
                                              and P'RelQ': "(P', Q'[x::=y]) \<in> Rel"
            by(blast dest: simE)

          from RBangRelQ have "weakSimAct R (a<\<nu>y> \<prec> Q'') R Rel'" by(rule IH)
          with yFreshR obtain R' where RTrans: "R \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>y> \<prec> R'"
                                   and R'RelQ'': "(R', Q'') \<in> Rel'"
            by(simp add: weakSimAct_def, blast)

          from PTrans RTrans yFreshP yFreshR have "P \<parallel> R \<Longrightarrow>\<^sub>l\<^sup>^\<tau> \<prec> <\<nu>y>(P' \<parallel> R')"
            by(rule Weak_Late_Semantics.Close1)
          moreover from P'RelQ' R'RelQ'' have "(<\<nu>y>(P' \<parallel> R'), <\<nu>y>(Q'[x::=y] \<parallel> Q'')) \<in> Rel'"
            by(force intro: ParComp Res)
          ultimately show ?case by blast
        qed
      qed
    next
      case(cClose2 a y Q' x Q'' P)
      have QTrans: "Q \<longmapsto> a<\<nu>y> \<prec> Q'" by fact
      have IH: "\<And>P. (P, !Q) \<in> bangRel Rel \<Longrightarrow> weakSimAct P (a<x> \<prec> Q'') P Rel'" by fact
      have "(P, Q \<parallel> !Q) \<in> bangRel Rel" and "x \<sharp> P" and "y \<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" by simp
        have "y \<sharp> P \<parallel> R" by fact
        hence yFreshP: "y \<sharp> P" and yFreshR: "y \<sharp> R" by simp+
        show ?case
        proof(induct rule: simActFreeCases)
          case Der
          from PRelQ have "P \<leadsto>\<^sup>^<Rel> Q" by(rule Sim)
          with QTrans yFreshP obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>y> \<prec> P'"
                                          and P'RelQ': "(P', Q') \<in> Rel"
            by(blast dest: simE)

          from RBangRelQ have "weakSimAct R (a<x> \<prec> Q'') R Rel'" by(rule IH)
          with xFreshR obtain R' R'' where RTrans: "R \<Longrightarrow>\<^sub>ly in R''\<rightarrow>a<x> \<prec> R'"
                                       and R'RelQ'': "(R', Q''[x::=y]) \<in> Rel'"
            by(simp add: weakSimAct_def, blast)

          from PTrans RTrans yFreshP yFreshR have "P \<parallel> R \<Longrightarrow>\<^sub>l\<^sup>^\<tau> \<prec> <\<nu>y>(P' \<parallel> R')"
            by(rule Weak_Late_Semantics.Close2)
          moreover from P'RelQ' R'RelQ'' have "(<\<nu>y>(P' \<parallel> R'), <\<nu>y>(Q' \<parallel> Q''[x::=y])) \<in> Rel'"
            by(force intro: ParComp Res)
          ultimately show ?case by blast
        qed
      qed
    next
      case(cBang Rs)
      have IH: "\<And>P. (P, Q \<parallel> !Q) \<in> bangRel Rel \<Longrightarrow> weakSimAct P Rs P Rel'" by fact
      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 "weakSimAct (P \<parallel> !P) Rs (P \<parallel> !P) Rel'" by(rule IH)
        thus ?case
        proof(simp (no_asm) add: weakSimAct_def, auto)
          fix Q' a x
          assume "weakSimAct (P \<parallel> !P) (a<\<nu>x> \<prec> Q') (P \<parallel> !P) Rel'" and "x \<sharp> P"
          then obtain P' where PTrans: "(P \<parallel> !P) \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P'"
                           and P'RelQ': "(P', Q') \<in> Rel'"
            by(simp add: weakSimAct_def, blast)
          from PTrans have "!P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P'"
            by(force intro: Weak_Late_Step_Semantics.Bang simp add: weakTransition_def)
          with P'RelQ' show "\<exists>P'. !P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel'" by blast
        next
          fix Q' a x
          assume "weakSimAct (P \<parallel> !P) (a<x> \<prec> Q') (P \<parallel> !P) Rel'" and "x \<sharp> P"
          then obtain P'' where L1: "\<forall>u. \<exists>P'. P \<parallel> !P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel'"
            by(simp add: weakSimAct_def, blast)
          have "\<forall>u. \<exists>P'. !P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel'"
          proof(rule allI)
            fix u
            from L1 obtain P' where PTrans: "P \<parallel> !P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P'"
                                and P'RelQ': "(P', Q'[x::=u]) \<in> Rel'"
              by blast
            from PTrans have "!P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P'" by(rule Weak_Late_Step_Semantics.Bang)
            with P'RelQ' show "\<exists>P'. !P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel'" by blast
          qed
          thus "\<exists>P''. \<forall>u. \<exists>P'. !P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel'" by blast
        next
          fix Q' \<alpha>
          assume "weakSimAct (P \<parallel> !P) (\<alpha> \<prec> Q') (P \<parallel> !P) Rel'"
          then obtain P' where PTrans: "(P \<parallel> !P) \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P'"
                           and P'RelQ': "(P', Q') \<in> Rel'"
            by(simp add: weakSimAct_def, blast)
          from PTrans show "\<exists>P'. !P \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel'"
          proof(induct rule: transitionCases)
            case Step
            have "P \<parallel> !P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'" by fact
            hence "!P \<Longrightarrow>\<^sub>l\<alpha> \<prec> P'" by(rule Weak_Late_Step_Semantics.Bang)
            with P'RelQ' show ?case by(force simp add: weakTransition_def)
          next
            case Stay
            have "\<alpha> \<prec> P' = \<tau> \<prec> P \<parallel> !P" by fact
            hence \<alpha>eq\<tau>: "\<alpha> = \<tau>" and P'eqP: "P' = P \<parallel> !P" by(simp add: residual.inject)+
            have "!P \<Longrightarrow>\<^sub>l\<^sup>^\<tau> \<prec> !P" by(simp add: weakTransition_def)
            moreover from P'eqP P'RelQ' have "(!P, Q') \<in> Rel'" by(blast intro: RelStay)
            ultimately show ?case using \<alpha>eq\<tau> by blast
          qed
        qed
      qed
    qed
  qed
  moreover from PRelQ have "(!P, !Q) \<in> bangRel Rel" by(rule Rel.BRBang)
  ultimately show ?thesis by(simp add: simDef)
qed

end


section \<open>Bit Block Transfer and Other Array Optimizations\<close>
theory Array_Blit
imports
  "../Sep_Main"
  "HOL-Library.Code_Target_Numeral"
begin

subsection "Definition"

  (* TODO/FIXME: Does not work with same arrays and overlapping ranges.
    Currently, the generated code will throw an exception if the arrays are the same.

    If only used with blit_rule, separation logic guarantees that arrays will be disjoint.
  *)
  primrec blit :: "_ array \<Rightarrow> nat \<Rightarrow> _ array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> unit Heap" where
    "blit _ _ _ _ 0 = return ()"
  | "blit src si dst di (Suc l) = do {
      x \<leftarrow> Array.nth src si;
      Array.upd di x dst;
      blit src (si+1) dst (di+1) l
    }"

  lemma blit_rule[sep_heap_rules]:
    assumes LEN: "si+len \<le> length lsrc" "di+len \<le> length ldst"
    shows
    "< src \<mapsto>\<^sub>a lsrc
      * dst \<mapsto>\<^sub>a ldst >
    blit src si dst di len
    <\<lambda>_. src \<mapsto>\<^sub>a lsrc
      * dst \<mapsto>\<^sub>a (take di ldst @ take len (drop si lsrc) @ drop (di+len) ldst)
    >"
    using LEN
  proof (induction len arbitrary: si di ldst)
    case 0 thus ?case by sep_auto
  next
    case (Suc len)
    note [sep_heap_rules] = Suc.IH

    have [simp]: "\<And>x. lsrc ! si # take len (drop (Suc si) lsrc) @ x
      = take (Suc len) (drop si lsrc) @ x"
      apply simp
      by (metis Suc.prems(1) add_Suc_right Cons_nth_drop_Suc
        less_Suc_eq_le add.commute not_less_eq take_Suc_Cons
        Nat.trans_le_add2)

    from Suc.prems show ?case
      by (sep_auto simp: take_update_last drop_upd_irrelevant)
  qed

  definition nth_oo where "nth_oo v a i \<equiv> do {
    l\<leftarrow>Array.len a;
    if i<l then
      Array.nth a i
    else
      return v
  }"

  definition upd_oo where "upd_oo f i x a \<equiv> do {
    l\<leftarrow>Array.len a;
    if i<l then
      Array.upd i x a
    else
      f
  }"

ML_val Array.update

subsection "Code Generator Setup"
  code_printing code_module "array_blit" \<rightharpoonup> (SML)
    \<open>
   fun array_blit src si dst di len = (
      src=dst andalso raise Fail ("array_blit: Same arrays");
      ArraySlice.copy {
        di = IntInf.toInt di,
        src = ArraySlice.slice (src,IntInf.toInt si,SOME (IntInf.toInt len)),
        dst = dst})

    fun array_nth_oo v a i () = Array.sub(a,IntInf.toInt i) handle Subscript => v | Overflow => v
    fun array_upd_oo f i x a () =
      (Array.update(a,IntInf.toInt i,x); a) handle Subscript => f () | Overflow => f ()

\<close>

  definition blit' where
    [code del]: "blit' src si dst di len
      = blit src (nat_of_integer si) dst (nat_of_integer di)
          (nat_of_integer len)"

  (* TODO: Export to other languages: OCaml, Haskell *)
  code_printing constant blit' \<rightharpoonup>
    (SML) "(fn/ ()/ => /array'_blit _ _ _ _ _)"
    and (Scala) "{ ('_: Unit)/=>/
      def safecopy(src: Array['_], srci: Int, dst: Array['_], dsti: Int, len: Int) = {
        if (src eq dst)
          sys.error(\"array'_blit: Same arrays\")
        else
          System.arraycopy(src, srci, dst, dsti, len)
      }
      safecopy(_.array,_.toInt,_.array,_.toInt,_.toInt)
    }"

  definition [code del]: "nth_oo' v a == nth_oo v a o nat_of_integer"
  definition [code del]: "upd_oo' f == upd_oo f o nat_of_integer"

  lemma [code]:
    "nth_oo v a == nth_oo' v a o integer_of_nat"
    "upd_oo f == upd_oo' f o integer_of_nat"
    by (simp_all add: nth_oo'_def upd_oo'_def o_def)

  text \<open>Fallbacks\<close>
  lemmas [code] = nth_oo'_def[unfolded nth_oo_def[abs_def]]
  lemmas [code] = upd_oo'_def[unfolded upd_oo_def[abs_def]]

  code_printing constant nth_oo' \<rightharpoonup> (SML) "array'_nth'_oo _ _ _"
    | constant upd_oo' \<rightharpoonup> (SML) "array'_upd'_oo _ _ _ _"

subsection \<open>Derived Functions\<close>
  definition "array_shrink a s \<equiv> do {
    \<comment> \<open>Avoiding the need for default value\<close>
    l\<leftarrow>Array.len a;
    if l=s then
      return a
    else if l=0 then
      Array.of_list []
    else do {
      x\<leftarrow>Array.nth a 0;
      a'\<leftarrow>Array.new s x;
      blit a 0 a' 0 s;
      return a'
    }
  }"

  lemma array_shrink_rule[sep_heap_rules]:
    assumes "s\<le>length la"
    shows "< a\<mapsto>\<^sub>ala > array_shrink a s <\<lambda>a'. a'\<mapsto>\<^sub>atake s la >\<^sub>t"
    using assms unfolding array_shrink_def
    by sep_auto

  definition "array_grow a s x \<equiv> do {
    l\<leftarrow>Array.len a;
    if l=s then
      return a
    else do {
      a'\<leftarrow>Array.new s x;
      blit a 0 a' 0 l;
      return a'
    }
  }"

  lemma array_grow_rule[sep_heap_rules]:
    assumes "s\<ge>length la"
    shows "
      < a\<mapsto>\<^sub>ala >
        array_grow a s x
      <\<lambda>a'. a'\<mapsto>\<^sub>a (la @ replicate (s-length la) x)>\<^sub>t"
    using assms
    unfolding array_grow_def
    by sep_auto

  export_code array_grow checking SML Scala

  (* TODO: Are there system-calls for array-copy? *)
  definition "array_copy a \<equiv> do {
    l\<leftarrow>Array.len a;
    if l=0 then
      Array.of_list []
    else do {
      s \<leftarrow> Array.nth a 0;
      a'\<leftarrow>Array.new l s;
      blit a 0 a' 0 l;
      return a'
    }
  }"

  lemma array_copy_rule[sep_heap_rules]:
    "
      < a\<mapsto>\<^sub>al>
        array_copy a
      <\<lambda>a'. a\<mapsto>\<^sub>al * a'\<mapsto>\<^sub>a l>"
    unfolding array_copy_def
    by sep_auto

  export_code array_copy checking SML Scala

end


theory TA_Equivalences
  imports
    TA.Timed_Automata
    TA_Impl.Normalized_Zone_Semantics_Impl_Refine
    TA_Library.Graphs
begin

locale TA_Equiv =
  fixes A B :: "('a, 'c, 't :: time, 's) ta"
  fixes S :: "'s set"
  assumes state_set_trans_of: "state_set (trans_of A) \<subseteq> S"
  assumes invs: "\<forall> l \<in> S. inv_of A l = inv_of B l"
  assumes trans_eq: "trans_of A = trans_of B"
begin

lemma delay1:
  "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>l',u'\<rangle>" if "l \<in> S" "B \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>l',u'\<rangle>"
  using that invs by (auto elim!: step_t.cases)

lemma action1:
  "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>l',u'\<rangle>" if "B \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>l',u'\<rangle>"
proof -
  from that have "l \<in> S" "l' \<in> S"
    using state_set_trans_of by (auto elim!: step_a.cases simp: trans_eq state_set_def)
  with that invs show ?thesis
    by (auto elim!: step_a.cases simp: trans_eq intro: step_a.intros)
qed

lemma delay2:
  "B \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>l',u'\<rangle>" if "l \<in> S" "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>l',u'\<rangle>"
  using that invs by (auto elim!: step_t.cases)

lemma action2:
  "B \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>l',u'\<rangle>" if "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>l',u'\<rangle>"
proof -
  from that have "l \<in> S" "l' \<in> S"
    using state_set_trans_of by (auto elim!: step_a.cases simp: trans_eq[symmetric] state_set_def)
  with that invs show ?thesis
    by (auto elim!: step_a.cases simp: trans_eq [symmetric] intro: step_a.intros)
qed

lemma step1:
  "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow> \<langle>l',u'\<rangle>" if "l \<in> S" "B \<turnstile> \<langle>l, u\<rangle> \<rightarrow> \<langle>l',u'\<rangle>"
  using that(2,1) by cases (auto dest: action1 delay1)

print_locale Bisimulation_Invariant

term "step A"

lemma S_inv:
  "l' \<in> S" if "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow> \<langle>l',u'\<rangle>" "l \<in> S"
  using that state_set_trans_of
  by (auto elim!: step.cases step_a.cases step_t.cases simp: state_set_def)

interpretation interp: Bisimulation_Invariant
  "\<lambda> (l, u) (l', u'). A \<turnstile> \<langle>l, u\<rangle> \<rightarrow> \<langle>l',u'\<rangle>"
  "\<lambda> (l, u) (l', u'). B \<turnstile> \<langle>l, u\<rangle> \<rightarrow> \<langle>l',u'\<rangle>"
  "\<lambda> lu lu'. lu' = lu" "\<lambda> (l, u). l \<in> S" "\<lambda> (l, u). l \<in> S"
  by standard (auto dest: step1 step2 intro: S_inv)

end (* TA Equiv *)

end (* Theory *)


theory Conntrack_State_Transform
imports "Common_Primitive_Matcher"
        "../Semantics_Ternary/Semantics_Ternary"
begin

text\<open>The following function assumes that the packet is in a certain state.\<close>

fun ctstate_assume_state :: "ctstate \<Rightarrow> 'i::len  common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr" where
  "ctstate_assume_state s (Match (CT_State x)) = (if s \<in> x then MatchAny else MatchNot MatchAny)" |
  "ctstate_assume_state s (Match m) = Match m" |
  "ctstate_assume_state s (MatchNot m) = MatchNot (ctstate_assume_state s m)" |
  "ctstate_assume_state _ MatchAny = MatchAny" |
  "ctstate_assume_state s (MatchAnd m1 m2) = MatchAnd (ctstate_assume_state s m1) (ctstate_assume_state s m2)"

lemma ctstate_assume_state: "p_tag_ctstate p = s \<Longrightarrow>
    matches (common_matcher, \<alpha>) (ctstate_assume_state s m) a p \<longleftrightarrow> matches (common_matcher, \<alpha>) m a p"
apply(rule matches_iff_apply_f)
by(induction m rule: ctstate_assume_state.induct) (simp_all)

definition ctstate_assume_new :: "'i::len  common_primitive rule list \<Rightarrow> 'i common_primitive rule list" where
  "ctstate_assume_new \<equiv> optimize_matches (ctstate_assume_state CT_New)"

lemma ctstate_assume_new_simple_ruleset: "simple_ruleset rs \<Longrightarrow> simple_ruleset (ctstate_assume_new rs)"
  by (simp add: ctstate_assume_new_def optimize_matches_simple_ruleset)

text\<open>Usually, the interesting part of a firewall is only about the rules for setting up connections.
      That means, we mostly only care about packets in state @{const CT_New}.
      Use the function @{const ctstate_assume_new} to remove all state matching and just care about
      the connection setup.
\<close>
corollary ctstate_assume_new: "p_tag_ctstate p = CT_New \<Longrightarrow>
  approximating_bigstep_fun (common_matcher, \<alpha>) p (ctstate_assume_new rs) s = approximating_bigstep_fun (common_matcher, \<alpha>) p rs s"
unfolding ctstate_assume_new_def
apply(rule optimize_matches)
apply(simp add: ctstate_assume_state)
done

text\<open>If we assume the CT State is @{const CT_New}, we can also assume that the TCP SYN flag (@{const ipt_tcp_syn}) is set.\<close>

fun ipt_tcp_flags_assume_flag :: "ipt_tcp_flags \<Rightarrow> 'i::len common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr" where
  "ipt_tcp_flags_assume_flag flg (Match (L4_Flags x)) = (if ipt_tcp_flags_equal x flg then MatchAny else (case match_tcp_flags_conjunct_option x flg of None \<Rightarrow> MatchNot MatchAny | Some f3 \<Rightarrow> Match (L4_Flags f3)))" |
  "ipt_tcp_flags_assume_flag flg (Match m) = Match m" |
  "ipt_tcp_flags_assume_flag flg (MatchNot m) = MatchNot (ipt_tcp_flags_assume_flag flg m)" |
  "ipt_tcp_flags_assume_flag _ MatchAny = MatchAny" |
  "ipt_tcp_flags_assume_flag flg (MatchAnd m1 m2) = MatchAnd (ipt_tcp_flags_assume_flag flg m1) (ipt_tcp_flags_assume_flag flg m2)"

lemma ipt_tcp_flags_assume_flag: assumes "match_tcp_flags flg (p_tcp_flags p)"
    shows "matches (common_matcher, \<alpha>) (ipt_tcp_flags_assume_flag flg m) a p \<longleftrightarrow> matches (common_matcher, \<alpha>) m a p"
proof(rule matches_iff_apply_f)
show "ternary_ternary_eval (map_match_tac common_matcher p (ipt_tcp_flags_assume_flag flg m)) = ternary_ternary_eval (map_match_tac common_matcher p m)"
  using assms proof(induction m rule: ipt_tcp_flags_assume_flag.induct)
  case (1 flg x)
    thus ?case
    apply(simp add: ipt_tcp_flags_equal del: match_tcp_flags.simps)
    apply(cases "match_tcp_flags_conjunct_option x flg")
     apply(simp)
     using match_tcp_flags_conjunct_option_None bool_to_ternary_simps(2) apply metis
    apply(simp)
    apply(drule_tac pkt="(p_tcp_flags p)" in match_tcp_flags_conjunct_option_Some)
    by simp
  qed(simp_all del: match_tcp_flags.simps)
qed

definition ipt_tcp_flags_assume_syn :: "'i::len common_primitive rule list \<Rightarrow> 'i common_primitive rule list" where
  "ipt_tcp_flags_assume_syn \<equiv> optimize_matches (ipt_tcp_flags_assume_flag ipt_tcp_syn)"

lemma ipt_tcp_flags_assume_syn_simple_ruleset: "simple_ruleset rs \<Longrightarrow> simple_ruleset (ipt_tcp_flags_assume_syn rs)"
  by (simp add: ipt_tcp_flags_assume_syn_def optimize_matches_simple_ruleset)

corollary ipt_tcp_flags_assume_syn: "match_tcp_flags ipt_tcp_syn (p_tcp_flags p) \<Longrightarrow>
  approximating_bigstep_fun (common_matcher, \<alpha>) p (ipt_tcp_flags_assume_syn rs) s = approximating_bigstep_fun (common_matcher, \<alpha>) p rs s"
unfolding ipt_tcp_flags_assume_syn_def
apply(rule optimize_matches)
apply(simp add: ipt_tcp_flags_assume_flag)
done

definition packet_assume_new :: "'i::len common_primitive rule list \<Rightarrow> 'i common_primitive rule list" where
  "packet_assume_new \<equiv> ctstate_assume_new \<circ> ipt_tcp_flags_assume_syn"

lemma packet_assume_new_simple_ruleset: "simple_ruleset rs \<Longrightarrow> simple_ruleset (packet_assume_new rs)"
  by (simp add: packet_assume_new_def ipt_tcp_flags_assume_syn_simple_ruleset ctstate_assume_new_simple_ruleset)

corollary packet_assume_new: "match_tcp_flags ipt_tcp_syn (p_tcp_flags p) \<Longrightarrow> p_tag_ctstate p = CT_New \<Longrightarrow>
  approximating_bigstep_fun (common_matcher, \<alpha>) p (packet_assume_new rs) s = approximating_bigstep_fun (common_matcher, \<alpha>) p rs s"
unfolding packet_assume_new_def
by (simp add: ctstate_assume_new ipt_tcp_flags_assume_syn)

end