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

header{*The n_moesi Protocol Case Study*}

theory n_moesi_lemma_inv__1_on_rules imports n_moesi_lemma_on_inv__1
begin
section{*All lemmas on causal relation between inv__1*}
lemma lemma_inv__1_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__1  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i. i\<le>N\<and>r=n_rule_t1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_rule_t2 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_rul_t3 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_rul_t4 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_rul_t5 N i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_rule_t1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_rule_t1Vsinv__1) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_rule_t2 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_rule_t2Vsinv__1) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_rul_t3 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_rul_t3Vsinv__1) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_rul_t4 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_rul_t4Vsinv__1) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_rul_t5 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_rul_t5Vsinv__1) done
    }

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

end


theory Impl_List_Playground_ChairNetwork_statefulpolicy_example
imports "../TopoS_Impl"
begin

text{*An example of our chair network [simplified]*}

abbreviation "V\<equiv>TopoS_Vertices.V"

text{*Our access control view on the network*}
  definition ChairNetwork_empty :: "vString list_graph" where
    "ChairNetwork_empty \<equiv> \<lparr> nodesL = [V ''WebSrv'', V ''FilesSrv'', V ''Printer'',
                                V ''Students'',
                                V ''Employees'',
                                V ''Internet''],
                      edgesL = [] \<rparr>"

  lemma "valid_list_graph ChairNetwork_empty" by eval

subsection{*Our security requirements*}
  subsubsection{*We have a server with confidential data*}
    definition ConfidentialChairData::"(vString SecurityInvariant)" where
      "ConfidentialChairData \<equiv> new_configured_list_SecurityInvariant SINVAR_BLPtrusted_impl.SINVAR_LIB_BLPtrusted \<lparr>
          node_properties = [V ''FilesSrv'' \<mapsto> \<lparr> privacy_level = 1, trusted = False \<rparr>,
                             V ''Employees'' \<mapsto> \<lparr> privacy_level = 0, trusted = True \<rparr>],
          model_global_properties = ()
          \<rparr>"

  subsubsection{* accessibly by employees and students*}
    definition "PrintingACL \<equiv> new_configured_list_SecurityInvariant SINVAR_LIB_CommunicationPartners \<lparr>
          node_properties = [V ''Printer'' \<mapsto> Master [V ''Employees'', V ''Students''],
                             V ''Employees'' \<mapsto> Care,
                             V ''Students'' \<mapsto> Care],
          model_global_properties = ()
          \<rparr>"

  subsubsection{* Printers are information sinks *}
    definition "PrintingSink \<equiv> new_configured_list_SecurityInvariant SINVAR_LIB_Sink \<lparr>
          node_properties = [V ''Printer'' \<mapsto> Sink],
          model_global_properties = ()
          \<rparr>"

  subsubsection{*Students and Employees may access each other but are not accessible from the outside*}
    definition "InternalSubnet \<equiv> new_configured_list_SecurityInvariant SINVAR_LIB_SubnetsInGW \<lparr>
          node_properties = [V ''Students'' \<mapsto> Member, V ''Employees'' \<mapsto> Member],
          model_global_properties = ()
          \<rparr>"

  subsubsection{* The files server is only accessibly by employees*}
    definition "FilesSrcACL \<equiv> new_configured_list_SecurityInvariant SINVAR_LIB_CommunicationPartners \<lparr>
          node_properties = [V ''FilesSrv'' \<mapsto> Master [V ''Employees''],
                             V ''Employees'' \<mapsto> Care],
          model_global_properties = ()
          \<rparr>"

definition "ChairSecurityRequirements = [ConfidentialChairData, PrintingACL, PrintingSink, InternalSubnet, FilesSrcACL]"

lemma "\<forall>m \<in> set ChairSecurityRequirements. implc_sinvar m ChairNetwork_empty" by eval

value "implc_get_offending_flows ChairSecurityRequirements ChairNetwork_empty"
value "generate_valid_topology ChairSecurityRequirements ChairNetwork_empty"

value "List.product (nodesL ChairNetwork_empty) (nodesL ChairNetwork_empty)"

definition "ChairNetwork = generate_valid_topology ChairSecurityRequirements
      \<lparr>nodesL = nodesL ChairNetwork_empty, edgesL = List.product (nodesL ChairNetwork_empty) (nodesL ChairNetwork_empty) \<rparr>"

value "ChairNetwork"

ML{*
vizualize_graph @{context} @{term "ChairSecurityRequirements"} @{term "ChairNetwork"};
*}

definition "ChairNetwork_stateful_IFS = \<lparr> hostsL = nodesL ChairNetwork, flows_fixL = edgesL ChairNetwork, flows_stateL = filter_IFS_no_violations ChairNetwork ChairSecurityRequirements \<rparr>"
value "edgesL ChairNetwork"
value "filter_IFS_no_violations ChairNetwork ChairSecurityRequirements"
value "ChairNetwork_stateful_IFS"
lemma "set (flows_stateL ChairNetwork_stateful_IFS) \<subseteq> (set (flows_fixL ChairNetwork_stateful_IFS))" by eval (*must always hold*)
value "(set (flows_fixL ChairNetwork_stateful_IFS)) - set (flows_stateL ChairNetwork_stateful_IFS)"
(*only problems: printers!!!*)
value "stateful_list_policy_to_list_graph ChairNetwork_stateful_IFS"
lemma "set (filter_IFS_no_violations ChairNetwork [ConfidentialChairData]) = set (edgesL ChairNetwork)" by eval

definition "ChairNetwork_stateful_ACS = \<lparr> hostsL = nodesL ChairNetwork, flows_fixL = edgesL ChairNetwork, flows_stateL = filter_compliant_stateful_ACS ChairNetwork ChairSecurityRequirements \<rparr>"
value "edgesL ChairNetwork"
value "filter_compliant_stateful_ACS ChairNetwork ChairSecurityRequirements"
value "ChairNetwork_stateful_ACS"
lemma "set (flows_stateL ChairNetwork_stateful_ACS) \<subseteq> (set (flows_fixL ChairNetwork_stateful_ACS))" by eval (*must always hold*)
value "(set (flows_fixL ChairNetwork_stateful_ACS)) - set (flows_stateL ChairNetwork_stateful_ACS)"

(*flows that are already allowed in both directions are not marked as stateful*)
value "((set (flows_fixL ChairNetwork_stateful_ACS)) - set (flows_stateL ChairNetwork_stateful_ACS)) - set (backlinks (flows_fixL ChairNetwork_stateful_ACS))"

(*the new backflows*)
value "set (edgesL (stateful_list_policy_to_list_graph ChairNetwork_stateful_ACS)) - (set (edgesL ChairNetwork))"

(*the resulting ACS graph*)
value "stateful_list_policy_to_list_graph ChairNetwork_stateful_ACS"

value "generate_valid_stateful_policy_IFSACS ChairNetwork ChairSecurityRequirements"
value "generate_valid_stateful_policy_IFSACS_2 ChairNetwork ChairSecurityRequirements"
lemma "set (flows_fixL (generate_valid_stateful_policy_IFSACS ChairNetwork ChairSecurityRequirements)) = set (flows_fixL (generate_valid_stateful_policy_IFSACS_2 ChairNetwork ChairSecurityRequirements))" by eval
lemma "set (flows_stateL (generate_valid_stateful_policy_IFSACS ChairNetwork ChairSecurityRequirements)) = set (flows_stateL (generate_valid_stateful_policy_IFSACS_2 ChairNetwork ChairSecurityRequirements))" by eval

definition "ChairNetwork_stateful = generate_valid_stateful_policy_IFSACS ChairNetwork ChairSecurityRequirements"

ML_val{*
visualize_edges @{context} @{term "flows_fixL ChairNetwork_stateful"}
    [("edge [dir=\"arrow\", style=dashed, color=\"#FF8822\", constraint=false]", @{term "flows_stateL ChairNetwork_stateful"})];
*}

(*these requirements impose no restrictoins on the stateful flows*)
definition "ChairNetwork_stateful_v2 = generate_valid_stateful_policy_IFSACS ChairNetwork [ConfidentialChairData, PrintingACL,  InternalSubnet, FilesSrcACL]"
ML_val{*
visualize_edges @{context} @{term "flows_fixL ChairNetwork_stateful_v2"}
    [("edge [dir=\"arrow\", style=dashed, color=\"#FF8822\", constraint=false]", @{term "flows_stateL ChairNetwork_stateful_v2"})];
*}

(*The sink requirements imposes the restriction that the printer cannot answer*)
definition "ChairNetwork_stateful_v3 = generate_valid_stateful_policy_IFSACS ChairNetwork [PrintingSink]"
ML_val{*
visualize_edges @{context} @{term "flows_fixL ChairNetwork_stateful_v3"}
    [("edge [dir=\"arrow\", style=dashed, color=\"#FF8822\", constraint=false]", @{term "flows_stateL ChairNetwork_stateful_v3"})];
*}

subsection{*An example of bad side-effects in access control policies*}

  definition ACL_not_with::"(vString SecurityInvariant)" where
    "ACL_not_with \<equiv> new_configured_list_SecurityInvariant SINVAR_ACLnotCommunicateWith_impl.SINVAR_LIB_ACLnotCommunicateWith \<lparr>
        node_properties = [V ''A'' \<mapsto> {V ''C''},
                           V ''B'' \<mapsto> {},
                           V ''C'' \<mapsto> {}],
        model_global_properties = ()
        \<rparr>"

  definition simple_network :: "vString list_graph" where
    "simple_network \<equiv> \<lparr> nodesL = [V ''A'', V ''B'', V ''C''],
                      edgesL = [(V ''B'', V ''A''), (V ''B'', V ''C'')] \<rparr>"

  lemma "valid_list_graph ChairNetwork_empty" by eval
  lemma "\<forall>m \<in> set [ACL_not_with]. implc_sinvar m simple_network" by eval

  lemma "implc_get_offending_flows [ACL_not_with] simple_network = []" by eval
  lemma "implc_get_offending_flows [ACL_not_with]
    \<lparr> nodesL = [V ''A'', V ''B'', V ''C''], edgesL = [(V ''B'', V ''A''), (V ''B'', V ''C''), (V ''A'', V ''B'')] \<rparr> =
      [[(V ''B'', V ''C'')], [(V ''A'', V ''B'')]]" by eval
  lemma "implc_get_offending_flows [ACL_not_with]
    \<lparr> nodesL = [V ''A'', V ''B'', V ''C''], edgesL = [(V ''B'', V ''A''), (V ''B'', V ''C''), (V ''C'', V ''B'')] \<rparr> =
      []" by eval

value "generate_valid_stateful_policy_IFSACS simple_network [ACL_not_with]"
value "generate_valid_stateful_policy_IFSACS_2 simple_network [ACL_not_with]"

subsection{*performance test*}
(*6 minutes , about 1.8k edges in graph, most of the times, no requirements apply, simply added some nodes, edges to the chair network. topology is valid*)
(*value "generate_valid_stateful_policy_IFSACS biggraph ChairSecurityRequirements"*)

end


theory IICF_Array_Map_Total
imports "../Intf/IICF_Map" IICF_Array
begin
  text \<open>
    Map implementation where lookup is only valid for elements
    already in the map.
  \<close>

  type_synonym 'a amt1 = "'a list"

  definition amt1_rel :: "nat \<Rightarrow> ('a amt1 \<times> (nat\<rightharpoonup>'a)) set"
    where "amt1_rel N \<equiv> {(xs,m). length xs = N \<and> dom m \<subseteq> {0..<N} \<and> (\<forall>k v. m k = Some v \<longrightarrow> v=xs!k)}"

  definition amt1_init :: "nat \<Rightarrow> 'a::llvm_rep amt1 nres" where "amt1_init N \<equiv> RETURN (replicate N init)"
  definition amt1_lookup :: "nat \<Rightarrow> 'a amt1 \<Rightarrow> 'a nres"
    where "amt1_lookup k m \<equiv> mop_list_get m k"

  definition amt1_update :: "nat \<Rightarrow> 'a \<Rightarrow> 'a amt1 \<Rightarrow> 'a amt1 nres"
    where "amt1_update k v m \<equiv> mop_list_set m k v"

  sepref_decl_op amt_empty: "\<lambda>(N::nat). Map.empty :: nat \<rightharpoonup> _" :: "nat_rel \<rightarrow> \<langle>nat_rel,V\<rangle> map_rel" .

  lemma amt_fold_custom_empty:
    "op_map_empty = op_amt_empty N"
    "Map.empty = op_amt_empty N"
    "mop_map_empty = mop_amt_empty N"
    by auto

  lemma amt1_empty_refine: "(amt1_init,mop_amt_empty)
    \<in> nat_rel \<rightarrow>\<^sub>f\<^sub>d (\<lambda>N. \<langle>amt1_rel N\<rangle>nres_rel)"
    unfolding amt1_init_def
    by (auto intro!: frefI nres_relI simp: amt1_rel_def in_br_conv fun_eq_iff)

  lemma amt1_lookup_refine:
    "(amt1_lookup, mop_map_the_lookup) \<in> nbn_rel N \<rightarrow> amt1_rel N \<rightarrow> \<langle>Id\<rangle>nres_rel"
    apply (clarsimp simp: amt1_lookup_def)
    apply (refine_vcg)
    apply (auto simp: amt1_rel_def in_br_conv)
    done

  lemma amt1_update_refine:
    "(amt1_update, mop_map_update)
      \<in> nbn_rel N \<rightarrow>Id \<rightarrow> amt1_rel N \<rightarrow> \<langle>amt1_rel N\<rangle>nres_rel"
    unfolding amt1_update_def
    apply (refine_vcg frefI)
    by (auto simp: amt1_rel_def in_br_conv fun_eq_iff)

  context
    fixes L :: "'l::len2 itself"
    (*notes [fcomp_norm_unfold] = snatb_rel_def[symmetric]*)
  begin

    private abbreviation (input) "amt2_assn \<equiv> array_assn id_assn"

    definition "amt_assn V N \<equiv> hr_comp
      (hr_comp amt2_assn (amt1_rel N))
      (\<langle>nat_rel, the_pure V\<rangle>map_rel)"
    lemmas [fcomp_norm_unfold] = amt_assn_def[symmetric]

    lemma amt_assn_fold'[fcomp_norm_unfold]:
      "hrr_comp nat_rel (\<lambda>x _. hr_comp (IICF_Array.array_assn id_assn) (amt1_rel x))
                        (\<lambda>x. \<langle>nat_rel, the_pure V\<rangle>map_rel) = (\<lambda>N _. amt_assn V N)"
      unfolding amt_assn_def
      by (auto simp: fun_eq_iff hrr_comp_def pred_lift_extract_simps; smt non_dep_def)

    lemma amt_assn_intf[intf_of_assn]: "intf_of_assn V TYPE('v) \<Longrightarrow> intf_of_assn (amt_assn V N) (TYPE((nat,'v)i_map))"
      by simp

    sepref_definition amt_init_impl [llvm_inline] is "amt1_init"
      :: "(snat_assn' TYPE('l))\<^sup>k \<rightarrow>\<^sub>a amt2_assn"
      unfolding amt1_init_def
      supply [sepref_import_param] = IdI[of init]
      apply (subst array_fold_custom_replicate)
      by sepref

    sepref_decl_impl (ismop) amt_empty: amt_init_impl.refine[FCOMP amt1_empty_refine] .

    sepref_definition amt_lookup_impl [llvm_inline] is "uncurry amt1_lookup"
      :: "(snat_assn' TYPE('l))\<^sup>k *\<^sub>a amt2_assn\<^sup>k \<rightarrow>\<^sub>a id_assn"
      unfolding amt1_lookup_def
      by sepref
    sepref_decl_impl (ismop) amt_lookup_impl.refine[FCOMP amt1_lookup_refine]
      uses mop_map_the_lookup.fref[where K=Id] .

    sepref_definition amt_update_impl [llvm_inline] is "uncurry2 amt1_update"
      :: "(snat_assn' TYPE('l))\<^sup>k *\<^sub>a id_assn\<^sup>k *\<^sub>a amt2_assn\<^sup>d \<rightarrow>\<^sub>a amt2_assn"
      unfolding amt1_update_def
      by sepref
    sepref_decl_impl (ismop) amt_update_impl.refine[FCOMP amt1_update_refine]
      uses mop_map_update.fref[where K=Id] .

  end

  type_synonym ('v) amt = "'v ptr"

  schematic_goal [sepref_frame_free_rules]: "MK_FREE (amt_assn N V) (?fr)"
    unfolding amt_assn_def
    by sepref_dbg_side

end


(*  Title:      HOL/Proofs/Lambda/ListBeta.thy
    Author:     Tobias Nipkow
    Copyright   1998 TU Muenchen
*)

section {* Lifting beta-reduction to lists *}

theory ListBeta imports ListApplication ListOrder begin

text {*
  Lifting beta-reduction to lists of terms, reducing exactly one element.
*}

abbreviation
  list_beta :: "dB list => dB list => bool"  (infixl "=>" 50) where
  "rs => ss == step1 beta rs ss"

lemma head_Var_reduction:
  "Var n \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> v \<Longrightarrow> \<exists>ss. rs => ss \<and> v = Var n \<degree>\<degree> ss"
  apply (induct u == "Var n \<degree>\<degree> rs" v arbitrary: rs set: beta)
     apply simp
    apply (rule_tac xs = rs in rev_exhaust)
     apply simp
    apply (atomize, force intro: append_step1I)
   apply (rule_tac xs = rs in rev_exhaust)
    apply simp
    apply (auto 0 3 intro: disjI2 [THEN append_step1I])
  done

lemma apps_betasE [elim!]:
  assumes major: "r \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> s"
    and cases: "!!r'. [| r \<rightarrow>\<^sub>\<beta> r'; s = r' \<degree>\<degree> rs |] ==> R"
      "!!rs'. [| rs => rs'; s = r \<degree>\<degree> rs' |] ==> R"
      "!!t u us. [| r = Abs t; rs = u # us; s = t[u/0] \<degree>\<degree> us |] ==> R"
  shows R
proof -
  from major have
   "(\<exists>r'. r \<rightarrow>\<^sub>\<beta> r' \<and> s = r' \<degree>\<degree> rs) \<or>
    (\<exists>rs'. rs => rs' \<and> s = r \<degree>\<degree> rs') \<or>
    (\<exists>t u us. r = Abs t \<and> rs = u # us \<and> s = t[u/0] \<degree>\<degree> us)"
    apply (induct u == "r \<degree>\<degree> rs" s arbitrary: r rs set: beta)
       apply (case_tac r)
         apply simp
        apply (simp add: App_eq_foldl_conv)
        apply (split split_if_asm)
         apply simp
         apply blast
        apply simp
       apply (simp add: App_eq_foldl_conv)
       apply (split split_if_asm)
        apply simp
       apply simp
      apply (drule App_eq_foldl_conv [THEN iffD1])
      apply (split split_if_asm)
       apply simp
       apply blast
      apply (force intro!: disjI1 [THEN append_step1I])
     apply (drule App_eq_foldl_conv [THEN iffD1])
     apply (split split_if_asm)
      apply simp
      apply blast
     apply (clarify, auto 0 3 intro!: exI intro: append_step1I)
    done
  with cases show ?thesis by blast
qed

lemma apps_preserves_beta [simp]:
    "r \<rightarrow>\<^sub>\<beta> s ==> r \<degree>\<degree> ss \<rightarrow>\<^sub>\<beta> s \<degree>\<degree> ss"
  by (induct ss rule: rev_induct) auto

lemma apps_preserves_beta2 [simp]:
    "r ->> s ==> r \<degree>\<degree> ss ->> s \<degree>\<degree> ss"
  apply (induct set: rtranclp)
   apply blast
  apply (blast intro: apps_preserves_beta rtranclp.rtrancl_into_rtrancl)
  done

lemma apps_preserves_betas [simp]:
    "rs => ss \<Longrightarrow> r \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> r \<degree>\<degree> ss"
  apply (induct rs arbitrary: ss rule: rev_induct)
   apply simp
  apply simp
  apply (rule_tac xs = ss in rev_exhaust)
   apply simp
  apply simp
  apply (drule Snoc_step1_SnocD)
  apply blast
  done

end


(*<*)
(*
 * Copyright 2015, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory CIMP_one_place_buffer
imports
  "../CIMP"
begin

(*>*)
section\<open>Example: a one-place buffer \label{sec:one_place_buffer}\<close>

text\<open>

To demonstrate the CIMP reasoning infrastructure, we treat the trivial
one-place buffer example of \<^citet>\<open>\<open>\S3.3\<close> in "DBLP:journals/toplas/LamportS84"\<close>. Note that the
semantics for our language is different to \<^cite>\<open>"DBLP:journals/toplas/LamportS84" using "citeauthor"\<close>'s, who
treated a historical variant of CSP (i.e., not the one in \<^cite>\<open>"Hoare:1985"\<close>).

We introduce some syntax for fixed-topology (static channel-based)
scenarios.

\<close>

abbreviation
  rcv_syn :: "'location \<Rightarrow> 'channel \<Rightarrow> ('val \<Rightarrow> 'state \<Rightarrow> 'state)
           \<Rightarrow> (unit, 'location, 'channel \<times> 'val, 'state) com" ("\<lbrace>_\<rbrace>/ _\<triangleright>_" [0,0,81] 81)
where
  "\<lbrace>l\<rbrace> ch\<triangleright>f \<equiv> \<lbrace>l\<rbrace> Response (\<lambda>q s. if fst q = ch then {(f (snd q) s, ())} else {})"

abbreviation
  snd_syn :: "'location \<Rightarrow> 'channel \<Rightarrow> ('state \<Rightarrow> 'val)
          \<Rightarrow> (unit, 'location, 'channel \<times> 'val, 'state) com" ("\<lbrace>_\<rbrace>/ _\<triangleleft>_" [0,0,81] 81)
where
  "\<lbrace>l\<rbrace> ch\<triangleleft>f \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (ch, f s)) (\<lambda>ans s. {s})"

text\<open>

These definitions largely follow \<^citet>\<open>"DBLP:journals/toplas/LamportS84"\<close>. We have three processes
communicating over two channels. We enumerate program locations.

\<close>

datatype ex_chname = \<xi>12 | \<xi>23
type_synonym ex_val = nat
type_synonym ex_ch = "ex_chname \<times> ex_val"
datatype ex_loc = r12 | r23 | s23 | s12
datatype ex_proc = p1 | p2 | p3

type_synonym ex_pgm = "(unit, ex_loc, ex_ch, ex_val) com"
type_synonym ex_pred = "(unit, ex_loc, ex_proc, ex_ch, ex_val) state_pred"
type_synonym ex_state = "(unit, ex_loc, ex_proc, ex_ch, ex_val) system_state"
type_synonym ex_sys = "(unit, ex_loc, ex_proc, ex_ch, ex_val) system"
type_synonym ex_history = "(ex_ch \<times> unit) list"

text\<open>

We further specialise these for our particular example.

\<close>

primrec
  ex_coms :: "ex_proc \<Rightarrow> ex_pgm"
where
  "ex_coms p1 = \<lbrace>s12\<rbrace> \<xi>12\<triangleleft>id"
| "ex_coms p2 = LOOP DO \<lbrace>r12\<rbrace> \<xi>12\<triangleright>(\<lambda>v _. v) ;; \<lbrace>s23\<rbrace> \<xi>23\<triangleleft>id OD"
| "ex_coms p3 = \<lbrace>r23\<rbrace> \<xi>23\<triangleright>(\<lambda>v _. v)"

text\<open>

Each process starts with an arbitrary initial local state.

\<close>

abbreviation ex_init :: "(ex_proc \<Rightarrow> ex_val) \<Rightarrow> bool" where
  "ex_init \<equiv> \<langle>True\<rangle>"

abbreviation sys :: ex_sys where
  "sys \<equiv> \<lparr>PGMs = ex_coms, INIT = ex_init, FAIR = \<langle>True\<rangle>\<rparr>" (* FIXME add fairness hypotheses *)

text\<open>

The following adapts Kai Engelhardt's, from his notes titled
\emph{Proving an Asynchronous Message Passing Program Correct},
2011. The history variable tracks the causality of the system, which I
feel is missing in Lamport's treatment. We tack on Lamport's invariant
so we can establish \<open>Etern_pred\<close>.

\<close>

abbreviation
  filter_on_channel :: "ex_chname \<Rightarrow> ex_state \<Rightarrow> ex_val list" ("\<downharpoonright>_" [100] 101)
where
  "\<downharpoonright>ch \<equiv> map (snd \<circ> fst) \<circ> filter ((=) ch \<circ> fst \<circ> fst) \<circ> HST"

definition IL :: ex_pred where
  "IL = pred_conjoin [
       at p1 s12 \<^bold>\<longrightarrow> LIST_NULL \<downharpoonright>\<xi>12
     , terminated p1 \<^bold>\<longrightarrow> \<downharpoonright>\<xi>12 \<^bold>= (\<lambda>s. [s\<down> p1])
     , at p2 r12 \<^bold>\<longrightarrow> \<downharpoonright>\<xi>12 \<^bold>= \<downharpoonright>\<xi>23
     , at p2 s23 \<^bold>\<longrightarrow> \<downharpoonright>\<xi>12 \<^bold>= \<downharpoonright>\<xi>23 \<^bold>@ (\<lambda>s. [s\<down> p2]) \<^bold>\<and> (\<lambda>s. s\<down> p1 = s\<down> p2)
     , at p3 r23 \<^bold>\<longrightarrow> LIST_NULL \<downharpoonright>\<xi>23
     , terminated p3 \<^bold>\<longrightarrow> \<downharpoonright>\<xi>23 \<^bold>= (\<lambda>s. [s\<down> p2]) \<^bold>\<and> (\<lambda>s. s\<down> p1 = s\<down> p3)
     ]"

text\<open>

If @{const p3} terminates, then it has @{const p1}'s value. This is
stronger than \<^cite>\<open>"DBLP:journals/toplas/LamportS84" using "citeauthor"\<close>'s as we don't ask that the first
process has also terminated.

\<close>

definition Etern_pred :: ex_pred where
  "Etern_pred = (terminated p3 \<^bold>\<longrightarrow> (\<lambda>s. s\<down> p1 = s\<down> p3))"

text\<open>

Proofs from here down.

\<close>

lemma correct_system:
  assumes "IL sh"
  shows "Etern_pred sh"
using assms unfolding Etern_pred_def IL_def by simp

lemma IL_p1: "ex_coms, p1, lconst {} \<turnstile> \<lbrace>IL\<rbrace> \<lbrace>s12\<rbrace> \<xi>12\<triangleleft>(\<lambda>s. s)"
apply (rule vcg.intros)
apply (rename_tac p')
apply (case_tac p'; clarsimp simp: IL_def atLs_def)
done

lemma IL_p2: "ex_coms, p2, lconst {r12} \<turnstile> \<lbrace>IL\<rbrace> \<lbrace>s23\<rbrace> \<xi>23\<triangleleft>(\<lambda>s. s)"
apply (rule vcg.intros)
apply (rename_tac p')
apply (case_tac p'; clarsimp simp: IL_def)
done

lemma IL: "sys \<Turnstile>\<^bsub>pre\<^esub> IL"
apply (rule VCG)
 apply (clarsimp simp: IL_def atLs_def dest!: initial_stateD)
apply (rename_tac p)
apply (case_tac p; clarsimp simp: IL_p1 IL_p2)
done

lemma IL_valid: "sys \<Turnstile> \<box>\<lceil>IL\<rceil>"
by (rule valid_prerun_lift[OF IL])

(*<*)

end
(*>*)


(*
    Author:      David Sanan
    Maintainer:  David Sanan, sanan at ntu edu sg
    License:     LGPL
*)

(*  Title:      XVCGCon.thy
    Author:     David Sanan, NTU

Copyright (C) 2015-2016 David Sanan
Some rights reserved, NTU
This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

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

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

theory XVcgCon
imports VcgCon

begin

text {* We introduce a syntactic variant of the let-expression so that we can
safely unfold it during verification condition generation. With the new
theorem attribute @{text "vcg_simp"} we can declare equalities to be used
by the verification condition generator, while simplifying assertions.
*}

syntax
"_Let'" :: "[letbinds, basicblock] => basicblock"  ("(LET (_)/ IN (_))" 23)

translations
  "_Let' (_binds b bs) e"  == "_Let' b (_Let' bs e)"
  "_Let' (_bind x a) e"    == "CONST Let' a (%x. e)"

lemma Let'_unfold [vcg_simp]: "Let' x f = f x"
  by (simp add: Let'_def Let_def)

lemma Let'_split_conv [vcg_simp]:
  "(Let' x  (\<lambda>p. (case_prod (f p) (g p)))) =
   (Let' x  (\<lambda>p. (f p) (fst (g p)) (snd (g p))))"
  by (simp add: split_def)

end


(*  Title:      HOL/Imperative_HOL/Ref.thy
    Author:     John Matthews, Galois Connections; Alexander Krauss, Lukas Bulwahn & Florian Haftmann, TU Muenchen
*)

section {* Monadic references *}

theory Ref
imports Array
begin

text {*
  Imperative reference operations; modeled after their ML counterparts.
  See @{url "http://caml.inria.fr/pub/docs/manual-caml-light/node14.15.html"}
  and @{url "http://www.smlnj.org/doc/Conversion/top-level-comparison.html"}
*}

subsection {* Primitives *}

definition present :: "heap \<Rightarrow> 'a\<Colon>heap ref \<Rightarrow> bool" where
  "present h r \<longleftrightarrow> addr_of_ref r < lim h"

definition get :: "heap \<Rightarrow> 'a\<Colon>heap ref \<Rightarrow> 'a" where
  "get h = from_nat \<circ> refs h TYPEREP('a) \<circ> addr_of_ref"

definition set :: "'a\<Colon>heap ref \<Rightarrow> 'a \<Rightarrow> heap \<Rightarrow> heap" where
  "set r x = refs_update
    (\<lambda>h. h(TYPEREP('a) := ((h (TYPEREP('a))) (addr_of_ref r := to_nat x))))"

definition alloc :: "'a \<Rightarrow> heap \<Rightarrow> 'a\<Colon>heap ref \<times> heap" where
  "alloc x h = (let
     l = lim h;
     r = Ref l
   in (r, set r x (h\<lparr>lim := l + 1\<rparr>)))"

definition noteq :: "'a\<Colon>heap ref \<Rightarrow> 'b\<Colon>heap ref \<Rightarrow> bool" (infix "=!=" 70) where
  "r =!= s \<longleftrightarrow> TYPEREP('a) \<noteq> TYPEREP('b) \<or> addr_of_ref r \<noteq> addr_of_ref s"

subsection {* Monad operations *}

definition ref :: "'a\<Colon>heap \<Rightarrow> 'a ref Heap" where
  [code del]: "ref v = Heap_Monad.heap (alloc v)"

definition lookup :: "'a\<Colon>heap ref \<Rightarrow> 'a Heap" ("!_" 61) where
  [code del]: "lookup r = Heap_Monad.tap (\<lambda>h. get h r)"

definition update :: "'a ref \<Rightarrow> 'a\<Colon>heap \<Rightarrow> unit Heap" ("_ := _" 62) where
  [code del]: "update r v = Heap_Monad.heap (\<lambda>h. ((), set r v h))"

definition change :: "('a\<Colon>heap \<Rightarrow> 'a) \<Rightarrow> 'a ref \<Rightarrow> 'a Heap" where
  "change f r = do {
     x \<leftarrow> ! r;
     let y = f x;
     r := y;
     return y
   }"

subsection {* Properties *}

text {* Primitives *}

lemma noteq_sym: "r =!= s \<Longrightarrow> s =!= r"
  and unequal [simp]: "r \<noteq> r' \<longleftrightarrow> r =!= r'" -- "same types!"
  by (auto simp add: noteq_def)

lemma noteq_irrefl: "r =!= r \<Longrightarrow> False"
  by (auto simp add: noteq_def)

lemma present_alloc_neq: "present h r \<Longrightarrow> r =!= fst (alloc v h)"
  by (simp add: present_def alloc_def noteq_def Let_def)

lemma next_fresh [simp]:
  assumes "(r, h') = alloc x h"
  shows "\<not> present h r"
  using assms by (cases h) (auto simp add: alloc_def present_def Let_def)

lemma next_present [simp]:
  assumes "(r, h') = alloc x h"
  shows "present h' r"
  using assms by (cases h) (auto simp add: alloc_def set_def present_def Let_def)

lemma get_set_eq [simp]:
  "get (set r x h) r = x"
  by (simp add: get_def set_def)

lemma get_set_neq [simp]:
  "r =!= s \<Longrightarrow> get (set s x h) r = get h r"
  by (simp add: noteq_def get_def set_def)

lemma set_same [simp]:
  "set r x (set r y h) = set r x h"
  by (simp add: set_def)

lemma not_present_alloc [simp]:
  "\<not> present h (fst (alloc v h))"
  by (simp add: present_def alloc_def Let_def)

lemma set_set_swap:
  "r =!= r' \<Longrightarrow> set r x (set r' x' h) = set r' x' (set r x h)"
  by (simp add: noteq_def set_def fun_eq_iff)

lemma alloc_set:
  "fst (alloc x (set r x' h)) = fst (alloc x h)"
  by (simp add: alloc_def set_def Let_def)

lemma get_alloc [simp]:
  "get (snd (alloc x h)) (fst (alloc x' h)) = x"
  by (simp add: alloc_def Let_def)

lemma set_alloc [simp]:
  "set (fst (alloc v h)) v' (snd (alloc v h)) = snd (alloc v' h)"
  by (simp add: alloc_def Let_def)

lemma get_alloc_neq: "r =!= fst (alloc v h) \<Longrightarrow>
  get (snd (alloc v h)) r  = get h r"
  by (simp add: get_def set_def alloc_def Let_def noteq_def)

lemma lim_set [simp]:
  "lim (set r v h) = lim h"
  by (simp add: set_def)

lemma present_alloc [simp]:
  "present h r \<Longrightarrow> present (snd (alloc v h)) r"
  by (simp add: present_def alloc_def Let_def)

lemma present_set [simp]:
  "present (set r v h) = present h"
  by (simp add: present_def fun_eq_iff)

lemma noteq_I:
  "present h r \<Longrightarrow> \<not> present h r' \<Longrightarrow> r =!= r'"
  by (auto simp add: noteq_def present_def)

text {* Monad operations *}

lemma execute_ref [execute_simps]:
  "execute (ref v) h = Some (alloc v h)"
  by (simp add: ref_def execute_simps)

lemma success_refI [success_intros]:
  "success (ref v) h"
  by (auto intro: success_intros simp add: ref_def)

lemma effect_refI [effect_intros]:
  assumes "(r, h') = alloc v h"
  shows "effect (ref v) h h' r"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_refE [effect_elims]:
  assumes "effect (ref v) h h' r"
  obtains "get h' r = v" and "present h' r" and "\<not> present h r"
  using assms by (rule effectE) (simp add: execute_simps)

lemma execute_lookup [execute_simps]:
  "Heap_Monad.execute (lookup r) h = Some (get h r, h)"
  by (simp add: lookup_def execute_simps)

lemma success_lookupI [success_intros]:
  "success (lookup r) h"
  by (auto intro: success_intros  simp add: lookup_def)

lemma effect_lookupI [effect_intros]:
  assumes "h' = h" "x = get h r"
  shows "effect (!r) h h' x"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_lookupE [effect_elims]:
  assumes "effect (!r) h h' x"
  obtains "h' = h" "x = get h r"
  using assms by (rule effectE) (simp add: execute_simps)

lemma execute_update [execute_simps]:
  "Heap_Monad.execute (update r v) h = Some ((), set r v h)"
  by (simp add: update_def execute_simps)

lemma success_updateI [success_intros]:
  "success (update r v) h"
  by (auto intro: success_intros  simp add: update_def)

lemma effect_updateI [effect_intros]:
  assumes "h' = set r v h"
  shows "effect (r := v) h h' x"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_updateE [effect_elims]:
  assumes "effect (r' := v) h h' r"
  obtains "h' = set r' v h"
  using assms by (rule effectE) (simp add: execute_simps)

lemma execute_change [execute_simps]:
  "Heap_Monad.execute (change f r) h = Some (f (get h r), set r (f (get h r)) h)"
  by (simp add: change_def bind_def Let_def execute_simps)

lemma success_changeI [success_intros]:
  "success (change f r) h"
  by (auto intro!: success_intros effect_intros simp add: change_def)

lemma effect_changeI [effect_intros]:
  assumes "h' = set r (f (get h r)) h" "x = f (get h r)"
  shows "effect (change f r) h h' x"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_changeE [effect_elims]:
  assumes "effect (change f r') h h' r"
  obtains "h' = set r' (f (get h r')) h" "r = f (get h r')"
  using assms by (rule effectE) (simp add: execute_simps)

lemma lookup_chain:
  "(!r \<guillemotright> f) = f"
  by (rule Heap_eqI) (auto simp add: lookup_def execute_simps intro: execute_bind)

lemma update_change [code]:
  "r := e = change (\<lambda>_. e) r \<guillemotright> return ()"
  by (rule Heap_eqI) (simp add: change_def lookup_chain)

text {* Non-interaction between imperative arrays and imperative references *}

lemma array_get_set [simp]:
  "Array.get (set r v h) = Array.get h"
  by (simp add: Array.get_def set_def fun_eq_iff)

lemma get_update [simp]:
  "get (Array.update a i v h) r = get h r"
  by (simp add: get_def Array.update_def Array.set_def)

lemma alloc_update:
  "fst (alloc v (Array.update a i v' h)) = fst (alloc v h)"
  by (simp add: Array.update_def Array.get_def Array.set_def alloc_def Let_def)

lemma update_set_swap:
  "Array.update a i v (set r v' h) = set r v' (Array.update a i v h)"
  by (simp add: Array.update_def Array.get_def Array.set_def set_def)

lemma length_alloc [simp]:
  "Array.length (snd (alloc v h)) a = Array.length h a"
  by (simp add: Array.length_def Array.get_def alloc_def set_def Let_def)

lemma array_get_alloc [simp]:
  "Array.get (snd (alloc v h)) = Array.get h"
  by (simp add: Array.get_def alloc_def set_def Let_def fun_eq_iff)

lemma present_update [simp]:
  "present (Array.update a i v h) = present h"
  by (simp add: Array.update_def Array.set_def fun_eq_iff present_def)

lemma array_present_set [simp]:
  "Array.present (set r v h) = Array.present h"
  by (simp add: Array.present_def set_def fun_eq_iff)

lemma array_present_alloc [simp]:
  "Array.present h a \<Longrightarrow> Array.present (snd (alloc v h)) a"
  by (simp add: Array.present_def alloc_def Let_def)

lemma set_array_set_swap:
  "Array.set a xs (set r x' h) = set r x' (Array.set a xs h)"
  by (simp add: Array.set_def set_def)

hide_const (open) present get set alloc noteq lookup update change

subsection {* Code generator setup *}

text {* Intermediate operation avoids invariance problem in @{text Scala} (similar to value restriction) *}

definition ref' where
  [code del]: "ref' = ref"

text {* SML / Eval *}

code_printing type_constructor ref \<rightharpoonup> (SML) "_/ ref"
code_printing type_constructor ref \<rightharpoonup> (Eval) "_/ Unsynchronized.ref"
code_printing constant Ref \<rightharpoonup> (SML) "raise/ (Fail/ \"bare Ref\")"
code_printing constant ref' \<rightharpoonup> (SML) "(fn/ ()/ =>/ ref/ _)"
code_printing constant ref' \<rightharpoonup> (Eval) "(fn/ ()/ =>/ Unsynchronized.ref/ _)"
code_printing constant Ref.lookup \<rightharpoonup> (SML) "(fn/ ()/ =>/ !/ _)"
code_printing constant Ref.update \<rightharpoonup> (SML) "(fn/ ()/ =>/ _/ :=/ _)"
code_printing constant "HOL.equal :: 'a ref \<Rightarrow> 'a ref \<Rightarrow> bool" \<rightharpoonup> (SML) infixl 6 "="

code_reserved Eval Unsynchronized

text {* OCaml *}

code_printing type_constructor ref \<rightharpoonup> (OCaml) "_/ ref"
code_printing constant Ref \<rightharpoonup> (OCaml) "failwith/ \"bare Ref\""
code_printing constant ref' \<rightharpoonup> (OCaml) "(fun/ ()/ ->/ ref/ _)"
code_printing constant Ref.lookup \<rightharpoonup> (OCaml) "(fun/ ()/ ->/ !/ _)"
code_printing constant Ref.update \<rightharpoonup> (OCaml) "(fun/ ()/ ->/ _/ :=/ _)"
code_printing constant "HOL.equal :: 'a ref \<Rightarrow> 'a ref \<Rightarrow> bool" \<rightharpoonup> (OCaml) infixl 4 "="

code_reserved OCaml ref

text {* Haskell *}

code_printing type_constructor ref \<rightharpoonup> (Haskell) "Heap.STRef/ Heap.RealWorld/ _"
code_printing constant Ref \<rightharpoonup> (Haskell) "error/ \"bare Ref\""
code_printing constant ref' \<rightharpoonup> (Haskell) "Heap.newSTRef"
code_printing constant Ref.lookup \<rightharpoonup> (Haskell) "Heap.readSTRef"
code_printing constant Ref.update \<rightharpoonup> (Haskell) "Heap.writeSTRef"
code_printing constant "HOL.equal :: 'a ref \<Rightarrow> 'a ref \<Rightarrow> bool" \<rightharpoonup> (Haskell) infix 4 "=="
code_printing class_instance ref :: HOL.equal \<rightharpoonup> (Haskell) -

text {* Scala *}

code_printing type_constructor ref \<rightharpoonup> (Scala) "!Ref[_]"
code_printing constant Ref \<rightharpoonup> (Scala) "!sys.error(\"bare Ref\")"
code_printing constant ref' \<rightharpoonup> (Scala) "('_: Unit)/ =>/ Ref((_))"
code_printing constant Ref.lookup \<rightharpoonup> (Scala) "('_: Unit)/ =>/ Ref.lookup((_))"
code_printing constant Ref.update \<rightharpoonup> (Scala) "('_: Unit)/ =>/ Ref.update((_), (_))"
code_printing constant "HOL.equal :: 'a ref \<Rightarrow> 'a ref \<Rightarrow> bool" \<rightharpoonup> (Scala) infixl 5 "=="

end


section \<open>Explore and Enumerate Nodes of Nondeterministic Büchi Automata\<close>

theory NBA_Translate
imports NBA_Explicit
begin

  subsection \<open>Syntax\<close>

  (* TODO: this syntax has unnecessarily high inner binding strength, requiring extra parentheses
    the regular let syntax correctly uses inner binding strength 0: ("(2_ =/ _)" 10) *)
  no_syntax "_do_let" :: "[pttrn, 'a] \<Rightarrow> do_bind" ("(2let _ =/ _)" [1000, 13] 13)
  syntax "_do_let" :: "[pttrn, 'a] \<Rightarrow> do_bind" ("(2let _ =/ _)" 13)

  section \<open>Image on Explicit Automata\<close>

  (* TODO: this should not be needed, only use nba_image *)
  definition nbae_image where "nbae_image f A \<equiv> nbae (alphabete A) (f ` initiale A)
    ((\<lambda> (p, a, q). (f p, a, f q)) ` transitione A) (f ` acceptinge A)"

  lemma nbae_image_param[param]: "(nbae_image, nbae_image) \<in> (S \<rightarrow> T) \<rightarrow> \<langle>L, S\<rangle> nbae_rel \<rightarrow> \<langle>L, T\<rangle> nbae_rel"
    unfolding nbae_image_def by parametricity

  lemma nbae_image_id[simp]: "nbae_image id = id" unfolding nbae_image_def by auto
  lemma nbae_image_nba_nbae: "nbae_image f (nba_nbae A) = nbae
    (alphabet A) (f ` initial A)
    (\<Union> p \<in> nodes A. \<Union> a \<in> alphabet A. f ` {p} \<times> {a} \<times> f ` transition A a p)
    (f ` {p \<in> nodes A. accepting A p})"
    unfolding nba_nbae_def nbae_image_def nbae.simps Set.filter_def by force

  section \<open>Exploration and Translation\<close>

  definition trans_spec where
    "trans_spec A f \<equiv> \<Union> p \<in> nodes A. \<Union> a \<in> alphabet A. f ` {p} \<times> {a} \<times> f ` transition A a p"

  definition trans_algo where
    "trans_algo N L S f \<equiv>
      FOREACH N (\<lambda> p T. do {
        ASSERT (p \<in> N);
        FOREACH L (\<lambda> a T. do {
          ASSERT (a \<in> L);
          FOREACH (S a p) (\<lambda> q T. do {
            ASSERT (q \<in> S a p);
            ASSERT ((f p, a, f q) \<notin> T);
            RETURN (insert (f p, a, f q) T) }
          ) T }
        ) T }
      ) {}"

  lemma trans_algo_refine:
    assumes "finite (nodes A)" "finite (alphabet A)" "inj_on f (nodes A)"
    assumes "N = nodes A" "L = alphabet A" "S = transition A"
    shows "(trans_algo N L S f, SPEC (HOL.eq (trans_spec A f))) \<in> \<langle>Id\<rangle> nres_rel"
  unfolding trans_algo_def trans_spec_def assms(4-6)
  proof (refine_vcg FOREACH_rule_insert_eq)
    show "finite (nodes A)" using assms(1) by this
    show "(\<Union> p \<in> nodes A. \<Union> a \<in> alphabet A. f ` {p} \<times> {a} \<times> f ` transition A a p) =
      (\<Union> p \<in> nodes A. \<Union> a \<in> alphabet A. f ` {p} \<times> {a} \<times> f ` transition A a p)" by rule
    show "(\<Union> p \<in> {}. \<Union> a \<in> alphabet A. f ` {p} \<times> {a} \<times> f ` transition A a p) = {}" by simp
    fix T x
    assume 1: "T \<subseteq> nodes A" "x \<in> nodes A" "x \<notin> T"
    show "finite (alphabet A)" using assms(2) by this
    show "(\<Union> a \<in> {}. f ` {x} \<times> {a} \<times> f ` transition A a x) \<union>
      (\<Union> p \<in> T. \<Union> a \<in> alphabet A. f ` {p} \<times> {a} \<times> f ` transition A a p) =
      (\<Union> p \<in> T. \<Union> a \<in> alphabet A. f ` {p} \<times> {a} \<times> f ` transition A a p)"
      "(\<Union> a \<in> alphabet A. f ` {x} \<times> {a} \<times> f ` transition A a x) \<union>
      (\<Union> p \<in> T. \<Union> a \<in> alphabet A. f ` {p} \<times> {a} \<times> f ` transition A a p) =
      (\<Union> p \<in> insert x T. \<Union> a \<in> alphabet A. f ` {p} \<times> {a} \<times> f ` transition A a p)" by auto
    fix Ta xa
    assume 2: "Ta \<subseteq> alphabet A" "xa \<in> alphabet A" "xa \<notin> Ta"
    show "finite (transition A xa x)" using 1 2 assms(1) by (meson infinite_subset nba.nodes_transition subsetI)
    show "(f ` {x} \<times> {xa} \<times> f ` transition A xa x) \<union>
      (\<Union> a \<in> Ta. f ` {x} \<times> {a} \<times> f ` transition A a x) \<union>
      (\<Union> p \<in> T. \<Union> a \<in> alphabet A. f ` {p} \<times> {a} \<times> f ` transition A a p) =
      (\<Union> a \<in> insert xa Ta. f ` {x} \<times> {a} \<times> f ` transition A a x) \<union>
      (\<Union> p \<in> T. \<Union> a \<in> alphabet A. f ` {p} \<times> {a} \<times> f ` transition A a p)"
      by auto
    show "(f ` {x} \<times> {xa} \<times> f ` {}) \<union>
      (\<Union> a \<in> Ta. f ` {x} \<times> {a} \<times> f ` transition A a x) \<union>
      (\<Union> p \<in> T. \<Union> a \<in> alphabet A. f ` {p} \<times> {a} \<times> f ` transition A a p) =
      (\<Union> a \<in> Ta. f ` {x} \<times> {a} \<times> f ` transition A a x) \<union>
      (\<Union> p \<in> T. \<Union> a \<in> alphabet A. f ` {p} \<times> {a} \<times> f ` transition A a p)"
      by auto
    fix Tb xb
    assume 3: "Tb \<subseteq> transition A xa x" "xb \<in> transition A xa x" "xb \<notin> Tb"
    show "(f x, xa, f xb) \<notin> f ` {x} \<times> {xa} \<times> f ` Tb \<union>
      (\<Union> a \<in> Ta. f ` {x} \<times> {a} \<times> f ` transition A a x) \<union>
      (\<Union> p \<in> T. \<Union> a \<in> alphabet A. f ` {p} \<times> {a} \<times> f ` transition A a p)"
      using 1 2 3 assms(3) by (blast dest: inj_onD)
    show "f ` {x} \<times> {xa} \<times> f ` insert xb Tb \<union>
      (\<Union> a \<in> Ta. f ` {x} \<times> {a} \<times> f ` transition A a x) \<union>
      (\<Union> p \<in> T. \<Union> a \<in> alphabet A. f ` {p} \<times> {a} \<times> f ` transition A a p) =
      insert (f x, xa, f xb) (f ` {x} \<times> {xa} \<times> f ` Tb \<union>
      (\<Union> a \<in> Ta. f ` {x} \<times> {a} \<times> f ` transition A a x) \<union>
      (\<Union> p \<in> T. \<Union> a \<in> alphabet A. f ` {p} \<times> {a} \<times> f ` transition A a p))"
      by auto
  qed

  (* TODO: move this to nondeterministic automaton
    there, it will have to be treated more elementarily
    at least until we abstract from NBA_Refine to do that there aswell *)
  definition nba_image :: "('state\<^sub>1 \<Rightarrow> 'state\<^sub>2) \<Rightarrow> ('label, 'state\<^sub>1) nba \<Rightarrow> ('label, 'state\<^sub>2) nba" where
    "nba_image f A \<equiv> nba
      (alphabet A)
      (f ` initial A)
      (\<lambda> a p. f ` transition A a (inv_into (nodes A) f p))
      (\<lambda> p. accepting A (inv_into (nodes A) f p))"

  lemma nba_image_rel[param]:
    assumes "inj_on f (nodes A)"
    shows "(A, nba_image f A) \<in> \<langle>Id_on (alphabet A), br f (\<lambda> p. p \<in> nodes A)\<rangle> nba_rel"
  proof -
    have "A = nba (alphabet A) (initial A) (transition A) (accepting A)" by simp
    also have "(\<dots>, nba_image f A) \<in> \<langle>Id_on (alphabet A), br f (\<lambda> p. p \<in> nodes A)\<rangle> nba_rel"
      using assms unfolding nba_image_def
      by (parametricity) (auto intro: nba_rel_eq simp: in_br_conv br_set_rel_alt)
    finally show ?thesis by this
  qed

  lemma nba_image_nodes[simp]:
    assumes "inj_on f (nodes A)"
    shows "nodes (nba_image f A) = f ` nodes A"
  proof -
    have "(nodes A, nodes (nba_image f A)) \<in> \<langle>br f (\<lambda> p. p \<in> nodes A)\<rangle> set_rel"
      using assms by parametricity
    then show ?thesis unfolding br_set_rel_alt by simp
  qed
  lemma nba_image_language[simp]:
    assumes "inj_on f (nodes A)"
    shows "language (nba_image f A) = language A"
  proof -
    have "(language A, language (nba_image f A)) \<in> \<langle>\<langle>Id_on (alphabet A)\<rangle> stream_rel\<rangle> set_rel"
      using assms by parametricity
    then show ?thesis by simp
  qed

  lemma nba_image_nbae:
    assumes "inj_on f (nodes A)"
    shows "nbae_image f (nba_nbae A) = nba_nbae (nba_image f A)"
    unfolding nbae_image_nba_nbae
    unfolding nba_nbae_def
    unfolding nba_image_nodes[OF assms]
    unfolding nbae.simps
    unfolding nba_image_def
    unfolding nba.sel
    using assms by auto

  (* TODO: with this, maybe much of the nbae infrastructure is obsolete?
    since now there is very little happening in terms of relations, maybe we can even make do
    with just the abstraction function *)
  (* TODO: maybe the specification for translation is just that the translated automaton
    is related in \<langle>Id_on (alphabet A), ???\<rangle> nba_rel? *)
  definition op_translate :: "('label, 'state) nba \<Rightarrow> ('label, nat) nbae nres" where
    "op_translate A \<equiv> SPEC (\<lambda> B. \<exists> f. inj_on f (nodes A) \<and> B = nba_nbae (nba_image f A))"

  lemma op_translate_language:
    assumes "(RETURN Ai, op_translate A) \<in> \<langle>\<langle>Id, nat_rel\<rangle> nbaei_nbae_rel\<rangle> nres_rel"
    shows "language (nbae_nba (nbaei_nbae Ai)) = language A"
  proof -
    (* TODO: can we leave all this inside the nres without explicit obtain? *)
    obtain f where 1:
      "(Ai, nba_nbae (nba_image f A)) \<in> \<langle>Id, nat_rel\<rangle> nbaei_nbae_rel" "inj_on f (nodes A)"
      using assms[unfolded in_nres_rel_iff op_translate_def, THEN RETURN_ref_SPECD]
      by metis
    let ?C = "nba_image f A"
    have "(nbae_nba (nbaei_nbae Ai), nbae_nba (id (nba_nbae ?C))) \<in> \<langle>Id, nat_rel\<rangle> nba_rel"
      using 1(1) by parametricity auto
    also have "nbae_nba (id (nba_nbae ?C)) = (nbae_nba \<circ> nba_nbae) ?C" by simp
    also have "(\<dots>, id ?C) \<in> \<langle>Id_on (alphabet ?C), Id_on (nodes ?C)\<rangle> nba_rel" by parametricity
    finally have 2: "(nbae_nba (nbaei_nbae Ai), ?C) \<in>
      \<langle>Id_on (alphabet ?C), Id_on (nodes ?C)\<rangle> nba_rel" by simp
    have "(language (nbae_nba (nbaei_nbae Ai)), language ?C) \<in>
      \<langle>\<langle>Id_on (alphabet ?C)\<rangle> stream_rel\<rangle> set_rel"
      using 2 by parametricity
    also have "language ?C = language A" using 1(2) by simp
    finally show ?thesis by simp
  qed

  (* TODO: make separate implementations for "nba_nbae" and "op_set_enumerate \<bind> nbae_image"
    make sure to do regression tests along the way *)
  (* TODO: since we have translate_impl, maybe just having a good nba_nbae implementation is enough? *)
  schematic_goal to_nbaei_impl:
    fixes S :: "('statei \<times> 'state) set"
    assumes [simp]: "finite (nodes A)"
    assumes [autoref_ga_rules]: "is_bounded_hashcode S seq bhc"
    assumes [autoref_ga_rules]: "is_valid_def_hm_size TYPE('statei) hms"
    assumes [autoref_rules]: "(seq, HOL.eq) \<in> S \<rightarrow> S \<rightarrow> bool_rel"
    assumes [autoref_rules]: "(Ai, A) \<in> \<langle>L, S\<rangle> nbai_nba_rel"
    shows "(?f :: ?'a, do {
        let N = nodes A;
        f \<leftarrow> op_set_enumerate N;
        ASSERT (dom f = N);
        ASSERT (\<forall> p \<in> initial A. f p \<noteq> None);
        ASSERT (\<forall> a \<in> alphabet A. \<forall> p \<in> dom f. \<forall> q \<in> transition A a p. f q \<noteq> None);
        T \<leftarrow> trans_algo N (alphabet A) (transition A) (\<lambda> x. the (f x));
        RETURN (nbae (alphabet A) ((\<lambda> x. the (f x)) ` initial A) T
          ((\<lambda> x. the (f x)) ` {p \<in> N. accepting A p}))
      }) \<in> ?R"
    unfolding trans_algo_def by (autoref_monadic (plain))
  concrete_definition to_nbaei_impl uses to_nbaei_impl

  context
  begin

    interpretation autoref_syn by this

    lemma to_nbaei_impl_refine[autoref_rules]:
      fixes S :: "('statei \<times> 'state) set"
      assumes "SIDE_PRECOND (finite (nodes A))"
      assumes "SIDE_GEN_ALGO (is_bounded_hashcode S seq bhc)"
      assumes "SIDE_GEN_ALGO (is_valid_def_hm_size TYPE('statei) hms)"
      assumes "GEN_OP seq HOL.eq (S \<rightarrow> S \<rightarrow> bool_rel)"
      assumes "(Ai, A) \<in> \<langle>L, S\<rangle> nbai_nba_rel"
      shows "(RETURN (to_nbaei_impl seq bhc hms Ai),
        (OP op_translate ::: \<langle>L, S\<rangle> nbai_nba_rel \<rightarrow> \<langle>\<langle>L, nat_rel\<rangle> nbaei_nbae_rel\<rangle> nres_rel) $ A) \<in>
        \<langle>\<langle>L, nat_rel\<rangle> nbaei_nbae_rel\<rangle> nres_rel"
    proof -
      have 1: "finite (alphabet A)"
        using nbai_nba_param(2)[param_fo, OF assms(5)] list_set_rel_finite
        unfolding finite_set_rel_def by auto
      note to_nbaei_impl.refine[OF assms[unfolded autoref_tag_defs]]
      also have "(do {
          let N = nodes A;
          f \<leftarrow> op_set_enumerate N;
          ASSERT (dom f = N);
          ASSERT (\<forall> p \<in> initial A. f p \<noteq> None);
          ASSERT (\<forall> a \<in> alphabet A. \<forall> p \<in> dom f. \<forall> q \<in> transition A a p. f q \<noteq> None);
          T \<leftarrow> trans_algo N (alphabet A) (transition A) (\<lambda> x. the (f x));
          RETURN (nbae (alphabet A) ((\<lambda> x. the (f x)) ` initial A) T ((\<lambda> x. the (f x)) ` {p \<in> N. accepting A p}))
        }, do {
          f \<leftarrow> op_set_enumerate (nodes A);
          T \<leftarrow> SPEC (HOL.eq (trans_spec A (\<lambda> x. the (f x))));
          RETURN (nbae (alphabet A) ((\<lambda> x. the (f x)) ` initial A) T ((\<lambda> x. the (f x)) ` {p \<in> nodes A. accepting A p}))
        }) \<in> \<langle>Id\<rangle> nres_rel"
        unfolding Let_def comp_apply op_set_enumerate_def using assms(1) 1
        by (refine_vcg vcg0[OF trans_algo_refine]) (auto intro!: inj_on_map_the[unfolded comp_apply])
      also have "(do {
          f \<leftarrow> op_set_enumerate (nodes A);
          T \<leftarrow> SPEC (HOL.eq (trans_spec A (\<lambda> x. the (f x))));
          RETURN (nbae (alphabet A) ((\<lambda> x. the (f x)) ` initial A) T ((\<lambda> x. the (f x)) ` {p \<in> nodes A. accepting A p}))
        }, do {
          f \<leftarrow> op_set_enumerate (nodes A);
          RETURN (nbae_image (the \<circ> f) (nba_nbae A))
        }) \<in> \<langle>Id\<rangle> nres_rel"
        unfolding trans_spec_def nbae_image_nba_nbae by refine_vcg force
      also have "(do {
          f \<leftarrow> op_set_enumerate (nodes A);
          RETURN (nbae_image (the \<circ> f) (nba_nbae A))
        }, do {
          f \<leftarrow> op_set_enumerate (nodes A);
          RETURN (nba_nbae (nba_image (the \<circ> f) A))
        }) \<in> \<langle>Id\<rangle> nres_rel"
        unfolding op_set_enumerate_def by (refine_vcg) (simp add: inj_on_map_the nba_image_nbae)
      also have "(do {
          f \<leftarrow> op_set_enumerate (nodes A);
          RETURN (nba_nbae (nba_image (the \<circ> f) A))
        }, op_translate A) \<in> \<langle>Id\<rangle> nres_rel"
        unfolding op_set_enumerate_def op_translate_def
        by (refine_vcg) (metis Collect_mem_eq inj_on_map_the subset_Collect_conv)
      finally show ?thesis unfolding nres_rel_comp by simp
    qed

  end

end


theory CallArityEnd2End
imports ArityTransform CoCallAnalysisImpl
begin

locale CallArityEnd2End
begin
sublocale CoCallAnalysisImpl.

lemma fresh_var_eqE[elim_format]: "fresh_var e = x \<Longrightarrow> x \<notin>  fv e"
  by (metis fresh_var_not_free)

lemma example1:
  fixes e :: exp
  fixes f g x y z :: var
  assumes Aexp_e: "\<And>a. Aexp e\<cdot>a = esing x\<cdot>(up\<cdot>a) \<squnion> esing y\<cdot>(up\<cdot>a)"
  assumes ccExp_e: "\<And>a. CCexp e\<cdot>a = \<bottom>"
  assumes [simp]: "transform 1 e = e"
  assumes "isVal e"
  assumes disj: "y \<noteq> f" "y \<noteq> g" "x \<noteq> y" "z \<noteq> f" "z \<noteq> g" "y \<noteq> x"
  assumes fresh: "atom z \<sharp> e"
  shows "transform 1 (let y be  App (Var f) g in (let x be e in (Var x))) =
         let y be (Lam [z]. App (App (Var f) g) z) in (let x be (Lam [z]. App e z) in (Var x))"
proof-
  from arg_cong[where f = edom, OF Aexp_e]
  have "x \<in> fv e" by simp (metis Aexp_edom' insert_subset)
  hence [simp]: "\<not> nonrec [(x,e)]"
    by (simp add: nonrec_def)

  from \<open>isVal e\<close>
  have [simp]: "thunks [(x, e)] = {}"
    by (simp add: thunks_Cons)

  have [simp]: "CCfix [(x, e)]\<cdot>(esing x\<cdot>(up\<cdot>1) \<squnion> esing y\<cdot>(up\<cdot>1), \<bottom>) = \<bottom>"
    unfolding CCfix_def
    apply (simp add: fix_bottom_iff ccBindsExtra_simp)
    apply (simp add: ccBind_eq disj ccExp_e)
    done

  have [simp]: "Afix [(x, e)]\<cdot>(esing x\<cdot>(up\<cdot>1)) = esing x\<cdot>(up\<cdot>1) \<squnion> esing y\<cdot>(up\<cdot>1)"
    unfolding Afix_def
    apply simp
    apply (rule fix_eqI)
    apply (simp add: disj Aexp_e)
    apply (case_tac "z x")
    apply (auto simp add: disj Aexp_e)
    done

  have [simp]: "Aheap [(y, App (Var f) g)] (let x be e in Var x)\<cdot>1 = esing y\<cdot>((Aexp (let x be e in Var x )\<cdot>1) y)"
    by (auto simp add:  Aheap_nonrec_simp ABind_nonrec_eq pure_fresh fresh_at_base disj)

  have [simp]: "(Aexp (let x be e in Var x)\<cdot>1) = esing y\<cdot>(up\<cdot>1)"
    by (simp add: env_restr_join disj)

  have [simp]: "Aheap [(x, e)] (Var x)\<cdot>1 = esing x\<cdot>(up\<cdot>1)"
    by (simp add: env_restr_join disj)

  have 1: "1 = inc\<cdot>0" apply (simp add: inc_def) apply transfer apply simp done

  have [simp]: "Aeta_expand 1 (App (Var f) g) = (Lam [z]. App (App (Var f) g) z)"
    apply (simp add: 1 del: exp_assn.eq_iff)
    apply (subst change_Lam_Variable[of z "fresh_var (App (Var f) g)"])
    apply (auto simp add: fresh_Pair fresh_at_base pure_fresh disj intro!: flip_fresh_fresh  elim!: fresh_var_eqE)
    done

  have [simp]: "Aeta_expand 1 e = (Lam [z]. App e z)"
    apply (simp add: 1 del: exp_assn.eq_iff)
    apply (subst change_Lam_Variable[of z "fresh_var e"])
    apply (auto simp add: fresh_Pair fresh_at_base pure_fresh disj fresh intro!: flip_fresh_fresh  elim!: fresh_var_eqE)
    done

  show ?thesis
    by (simp del: Let_eq_iff add: map_transform_Cons map_transform_Nil disj[symmetric])
qed

end
end


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

  Project: Development of Security Protocols by Refinement

  Module:  Refinement/a0i_agree.thy (Isabelle/HOL 2016-1)
  ID:      $Id: a0i_agree.thy 134924 2017-05-24 17:23:15Z csprenge $
  Author:  Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>

  One-Way authentication protocols
  Initial Model: Injective agreement

  Copyright (c) 2009-2016 Christoph Sprenger
  Licence: LGPL

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

section \<open>Injective Agreement\<close>

theory a0i_agree imports a0n_agree
begin

text \<open>This refinement adds injectiveness to the agreement property.\<close>

(******************************************************************************)
subsection \<open>State\<close>
(******************************************************************************)

text \<open>The state and observations are the same as in the previous model.\<close>

type_synonym
  'd a0i_state = "'d a0n_state"

type_synonym
  'd a0i_obs = "'d a0n_obs"

(******************************************************************************)
subsection \<open>Events\<close>
(******************************************************************************)

text \<open>We just refine the commit event. Everything else remains the same.\<close>

abbreviation
  a0i_init :: "'ds a0n_state set"
where
  "a0i_init \<equiv> a0n_init"

abbreviation
  a0i_running :: "[agent list, 'ds] \<Rightarrow> ('ds a0i_state \<times> 'ds a0i_state) set"
where
  "a0i_running \<equiv> a0n_running"

definition
  a0i_commit ::
    "[agent list, 'ds] \<Rightarrow> ('ds a0i_state \<times> 'ds a0i_state) set"
where
  "a0i_commit h d \<equiv> {(s, s').
    \<comment> \<open>guards:\<close>
    (set h \<subseteq> good \<longrightarrow> d \<notin> corrupted s \<longrightarrow>
       signals s (Commit h d) < signals s (Running h d)) \<and>

    \<comment> \<open>actions:\<close>
    s' = s\<lparr>
      signals := (signals s)(Commit h d := signals s (Commit h d) + 1)
    \<rparr>
  }"

abbreviation
  a0i_corrupt :: "'ds set \<Rightarrow> ('ds a0i_state \<times> 'ds a0i_state) set"
where
  "a0i_corrupt \<equiv> a0n_corrupt"

text \<open>Transition system.\<close>

definition
  a0i_trans :: "('ds a0i_state \<times> 'ds a0i_state) set" where
  "a0i_trans \<equiv> (\<Union> h d ds.
     a0i_running h d \<union>
     a0i_commit h d \<union>
     a0i_corrupt ds \<union>
     Id
  )"

definition
  a0i :: "('ds a0i_state, 'ds a0i_obs) spec" where
  "a0i \<equiv> \<lparr>
    init = a0i_init,
    trans = a0i_trans,
    obs = id
  \<rparr>"

lemmas a0i_defs =
  a0n_defs a0i_def a0i_trans_def a0i_commit_def

text \<open>Any property is trivially observable.\<close>

lemma a0i_obs [simp]: "obs a0i = id"
by (simp add: a0i_def)

lemma a0i_anyP_observable [iff]: "observable (obs a0i) P"
by (auto)

(******************************************************************************)
subsection \<open>Invariants\<close>
(******************************************************************************)

subsubsection \<open>Injective agreement.\<close>
(******************************************************************************)

definition
  a0i_inv1_iagree :: "'ds a0i_state set"
where
  "a0i_inv1_iagree \<equiv> {s. \<forall>h d.
     set h \<subseteq> good \<longrightarrow> d \<notin> corrupted s \<longrightarrow>
       signals s (Commit h d) \<le> signals s (Running h d)
  }"

lemmas a0i_inv1_iagreeI =
  a0i_inv1_iagree_def [THEN setc_def_to_intro, rule_format]
lemmas a0i_inv1_iagreeE [elim] =
  a0i_inv1_iagree_def [THEN setc_def_to_elim, rule_format]
lemmas a0i_inv1_iagreeD =
  a0i_inv1_iagree_def [THEN setc_def_to_dest, rule_format, rotated 1]

lemma PO_a0i_inv1_iagree_init [iff]:
  "init a0i \<subseteq> a0i_inv1_iagree"
by (auto simp add: a0i_defs intro!: a0i_inv1_iagreeI)

lemma PO_a0i_inv1_iagree_trans [iff]:
  "{a0i_inv1_iagree} trans a0i {> a0i_inv1_iagree}"
apply (auto simp add: PO_hoare_defs a0i_defs intro!: a0i_inv1_iagreeI)
apply (auto dest: a0i_inv1_iagreeD intro: le_SucI)
done

lemma PO_a0i_inv1_iagree [iff]: "reach a0i \<subseteq> a0i_inv1_iagree"
by (rule inv_rule_basic) (auto)

text \<open>As an external invariant.\<close>

lemma PO_a0i_obs_inv1_iagree [iff]: "oreach a0i \<subseteq> a0i_inv1_iagree"
apply (rule external_from_internal_invariant, fast)
apply (subst a0i_def, auto)
done

(******************************************************************************)
subsection \<open>Refinement\<close>
(******************************************************************************)

definition
  med0n0i :: "'d a0i_obs \<Rightarrow> 'd a0i_obs"
where
  "med0n0i \<equiv> id"

definition
  R0n0i :: "('d a0n_state \<times> 'd a0i_state) set"
where
  "R0n0i \<equiv> Id"

lemma PO_a0i_running_refines_a0n_running:
  "{R0n0i}
     (a0n_running h d), (a0i_running h d)
   {> R0n0i}"
by (unfold R0n0i_def) (rule relhoare_refl)

lemma PO_a0i_commit_refines_a0n_commit:
  "{R0n0i}
     (a0n_commit h d), (a0i_commit h d)
   {> R0n0i}"
by (auto simp add: PO_rhoare_defs R0n0i_def a0i_defs)

lemma PO_a0i_corrupt_refines_a0n_corrupt:
  "{R0n0i}
     (a0n_corrupt d), (a0i_corrupt d)
   {> R0n0i}"
by (unfold R0n0i_def) (rule relhoare_refl)

lemmas PO_a0i_trans_refines_a0n_trans =
  PO_a0i_running_refines_a0n_running
  PO_a0i_commit_refines_a0n_commit
  PO_a0i_corrupt_refines_a0n_corrupt

text \<open>All together now...\<close>

lemma PO_m1_refines_init_a0n [iff]:
  "init a0i \<subseteq> R0n0i``(init a0n)"
by (auto simp add: R0n0i_def a0i_defs)

lemma PO_m1_refines_trans_a0n [iff]:
  "{R0n0i}
     (trans a0n), (trans a0i)
   {> R0n0i}"
by (auto simp add: a0n_def a0n_trans_def a0i_def a0i_trans_def
         intro!: PO_a0i_trans_refines_a0n_trans)

lemma PO_obs_consistent [iff]:
  "obs_consistent R0n0i med0n0i a0n a0i"
by (auto simp add: obs_consistent_def R0n0i_def med0n0i_def a0i_def a0n_def)

lemma PO_a0i_refines_a0n:
  "refines R0n0i med0n0i a0n a0i"
by (rule Refinement_basic) (auto)

(******************************************************************************)
subsection \<open>Derived invariants\<close>
(******************************************************************************)

lemma iagree_implies_niagree [iff]: "a0i_inv1_iagree \<subseteq> a0n_inv1_niagree"
apply (auto intro!: a0n_inv1_niagreeI)
apply (drule_tac d=d in a0i_inv1_iagreeD, auto)
done

text \<open>Non-injective agreeement as internal and external invariants.\<close>

lemma PO_a0i_a0n_inv1_niagree [iff]: "reach a0i \<subseteq> a0n_inv1_niagree"
by (rule subset_trans, rule, rule)

lemma PO_a0i_obs_a0n_inv1_niagree [iff]: "oreach a0i \<subseteq> a0n_inv1_niagree"
by (rule subset_trans, rule, rule)

end


(*  Title:       N2M
    Authors:     Jasmin Blanchette, Andrei Popescu, Dmitriy Traytel
    Maintainer:  Dmitriy Traytel <traytel at inf.ethz.ch>
*)

section \<open>Mutual View on Nested Datatypes\<close>

(*<*)
theory N2M
  imports "HOL-Library.BNF_Axiomatization"
begin
(*>*)

notation BNF_Def.convol ("<_, _>")

declare [[bnf_internals]]

declare [[typedef_overloaded]]

bnf_axiomatization ('a, 'b) F0 [wits: "'a \<Rightarrow> ('a, 'b) F0"]
bnf_axiomatization ('a, 'b) G0 [wits: "'a \<Rightarrow> ('a, 'b) G0"]

subsection \<open>Nested Definition\<close>

datatype 'a F = CF "('a, 'a F) F0"
datatype 'a G = CG "('a, ('a G) F) G0"

type_synonym ('b, 'c) F_pre_F = "('c, 'b) F0"
type_synonym ('c, 'a) G_pre_G = "('a, 'c F) G0"

term "ctor_fold_F :: (('b, 'c) F_pre_F \<Rightarrow> 'b) \<Rightarrow> 'c F \<Rightarrow> 'b"
term "ctor_fold_G :: (('c, 'a) G_pre_G \<Rightarrow> 'c) \<Rightarrow> 'a G \<Rightarrow> 'c"
term "ctor_rec_F :: (('c F \<times> 'b, 'c) F_pre_F \<Rightarrow> 'b) \<Rightarrow> 'c F \<Rightarrow> 'b"
term "ctor_rec_G :: (('a G \<times> 'c, 'a) G_pre_G \<Rightarrow> 'c) \<Rightarrow> 'a G \<Rightarrow> 'c"
thm F.ctor_rel_induct
thm G.ctor_rel_induct[unfolded rel_pre_G_def id_apply]

subsection \<open>Isomorphic Mutual Definition\<close>

datatype 'a G\<^sub>M = CG "('a, 'a GF\<^sub>M) G0"
  and  'a GF\<^sub>M = CF "('a G\<^sub>M, 'a GF\<^sub>M) F0"

type_synonym ('b, 'c) GF\<^sub>M_pre_GF\<^sub>M = "('c, 'b) F0"
type_synonym ('c, 'a) G\<^sub>M_pre_G\<^sub>M = "('a, 'c) G0"

term "ctor_fold_G\<^sub>M :: (('c, 'a) G\<^sub>M_pre_G\<^sub>M \<Rightarrow> 'b) \<Rightarrow> (('c, 'b) GF\<^sub>M_pre_GF\<^sub>M \<Rightarrow> 'c) \<Rightarrow> 'a G\<^sub>M \<Rightarrow> 'b"
term "ctor_fold_GF\<^sub>M :: (('c, 'a) G\<^sub>M_pre_G\<^sub>M \<Rightarrow> 'b) \<Rightarrow> (('c, 'b) GF\<^sub>M_pre_GF\<^sub>M \<Rightarrow> 'c) \<Rightarrow> 'a GF\<^sub>M \<Rightarrow> 'c"
term "ctor_rec_G\<^sub>M :: (('a GF\<^sub>M \<times> 'c, 'a) G\<^sub>M_pre_G\<^sub>M \<Rightarrow> 'b) \<Rightarrow> (('a GF\<^sub>M \<times> 'c, 'a G\<^sub>M \<times> 'b) GF\<^sub>M_pre_GF\<^sub>M \<Rightarrow> 'c) \<Rightarrow> 'a G\<^sub>M \<Rightarrow> 'b"
term "ctor_rec_GF\<^sub>M :: (('a GF\<^sub>M \<times> 'c, 'a) G\<^sub>M_pre_G\<^sub>M \<Rightarrow> 'b) \<Rightarrow> (('a GF\<^sub>M \<times> 'c, 'a G\<^sub>M \<times> 'b) GF\<^sub>M_pre_GF\<^sub>M \<Rightarrow> 'c) \<Rightarrow> 'a GF\<^sub>M \<Rightarrow> 'c"
thm G\<^sub>M_GF\<^sub>M.ctor_rel_induct[unfolded rel_pre_G\<^sub>M_def rel_pre_GF\<^sub>M_def]

subsection \<open>Mutualization\<close>

subsubsection \<open>Iterators\<close>

definition n2m_ctor_fold_G :: "(('c, 'a) G\<^sub>M_pre_G\<^sub>M \<Rightarrow> 'b) \<Rightarrow> (('c, 'b) GF\<^sub>M_pre_GF\<^sub>M \<Rightarrow> 'c) \<Rightarrow> 'a G \<Rightarrow> 'b"
  where "n2m_ctor_fold_G s1 s2 = ctor_fold_G (s1 o
    map_pre_G\<^sub>M id (id :: unit \<Rightarrow> unit) (ctor_fold_F (s2 o BNF_Composition.id_bnf o BNF_Composition.id_bnf)) o BNF_Composition.id_bnf o BNF_Composition.id_bnf)"
definition n2m_ctor_fold_G_F :: "(('c, 'a) G\<^sub>M_pre_G\<^sub>M \<Rightarrow> 'b) \<Rightarrow> (('c, 'b) GF\<^sub>M_pre_GF\<^sub>M \<Rightarrow> 'c) \<Rightarrow> 'a G F \<Rightarrow> 'c"
  where "n2m_ctor_fold_G_F s1 s2 = ctor_fold_F (s2 o map_pre_GF\<^sub>M (id :: unit \<Rightarrow> unit) (n2m_ctor_fold_G s1 s2) id o BNF_Composition.id_bnf o BNF_Composition.id_bnf)"

lemma G_ctor_o_rec: "ctor_rec_G s o ctor_G = s o map_pre_G id (BNF_Def.convol id (ctor_rec_G s))"
  unfolding fun_eq_iff o_apply G.ctor_rec by simp
lemma F_ctor_o_rec: "ctor_rec_F s o ctor_F = s o map_pre_F id (BNF_Def.convol id (ctor_rec_F s))"
  unfolding fun_eq_iff o_apply F.ctor_rec by simp

lemma n2m_ctor_fold_G:
  "n2m_ctor_fold_G s1 s2 o ctor_G = s1 o map_pre_G\<^sub>M id id (n2m_ctor_fold_G_F s1 s2) o BNF_Composition.id_bnf o BNF_Composition.id_bnf"
  unfolding n2m_ctor_fold_G_def n2m_ctor_fold_G_F_def
    map_pre_G_def map_pre_F_def map_pre_G\<^sub>M_def map_pre_GF\<^sub>M_def
    G_ctor_o_fold id_apply comp_id id_comp comp_assoc
    rewriteL_comp_comp[OF type_copy_map_comp0_undo[OF BNF_Composition.type_definition_id_bnf_UNIV BNF_Composition.type_definition_id_bnf_UNIV BNF_Composition.type_definition_id_bnf_UNIV pre_G\<^sub>M.map_comp0[unfolded map_pre_G\<^sub>M_def]]]
    F.ctor_fold_o_map
    rewriteL_comp_comp[OF type_copy_Rep_o_Abs[OF BNF_Composition.type_definition_id_bnf_UNIV]] ..

lemma n2m_ctor_fold_G_F:
  "n2m_ctor_fold_G_F s1 s2 o ctor_F = s2 o map_pre_GF\<^sub>M id (n2m_ctor_fold_G s1 s2) (n2m_ctor_fold_G_F s1 s2) o BNF_Composition.id_bnf o BNF_Composition.id_bnf"
  unfolding n2m_ctor_fold_G_F_def map_pre_F_def map_pre_G\<^sub>M_def map_pre_GF\<^sub>M_def
    F_ctor_o_fold id_apply comp_id id_comp comp_assoc
    rewriteL_comp_comp[OF F0.map_comp0[symmetric]]
    rewriteL_comp_comp[OF type_copy_Rep_o_Abs[OF BNF_Composition.type_definition_id_bnf_UNIV]] ..

subsubsection \<open>Recursors\<close>

definition n2m_ctor_rec_G ::
  "(('a G F \<times> 'c, 'a) G\<^sub>M_pre_G\<^sub>M \<Rightarrow> 'b) \<Rightarrow> (('a G F \<times> 'c, 'a G \<times> 'b) GF\<^sub>M_pre_GF\<^sub>M \<Rightarrow> 'c) \<Rightarrow> 'a G \<Rightarrow> 'b"
  where "n2m_ctor_rec_G s1 s2 =
    ctor_rec_G (s1 o
      map_pre_G\<^sub>M id (id :: unit \<Rightarrow> unit)
        (BNF_Def.convol (map_F fst) (ctor_rec_F (s2 o map_pre_GF\<^sub>M (id :: unit \<Rightarrow> unit) id (map_prod (map_F fst) id) o BNF_Composition.id_bnf o BNF_Composition.id_bnf))) o
      BNF_Composition.id_bnf o BNF_Composition.id_bnf)"

definition n2m_ctor_rec_G_F ::
  "(('a G F \<times> 'c, 'a) G\<^sub>M_pre_G\<^sub>M \<Rightarrow> 'b) \<Rightarrow> (('a G F \<times> 'c, 'a G \<times> 'b) GF\<^sub>M_pre_GF\<^sub>M \<Rightarrow> 'c) \<Rightarrow> 'a G F \<Rightarrow> 'c"
  where "n2m_ctor_rec_G_F s1 s2 = ctor_rec_F (s2 o map_pre_GF\<^sub>M (id :: unit \<Rightarrow> unit) (BNF_Def.convol id (n2m_ctor_rec_G s1 s2)) id o BNF_Composition.id_bnf o BNF_Composition.id_bnf)"

lemma n2m_ctor_rec_G:
  "n2m_ctor_rec_G s1 s2 o ctor_G = s1 o map_pre_G\<^sub>M id id (BNF_Def.convol id (n2m_ctor_rec_G_F s1 s2)) o BNF_Composition.id_bnf o BNF_Composition.id_bnf"
  unfolding n2m_ctor_rec_G_def n2m_ctor_rec_G_F_def
    map_pre_G_def map_pre_F_def map_pre_G\<^sub>M_def map_pre_GF\<^sub>M_def
    G_ctor_o_rec
    id_apply comp_id id_comp comp_assoc map_prod.comp map_prod.id
    fst_convol map_prod_o_convol convol_o
    rewriteL_comp_comp[OF G0.map_comp0[symmetric]]
    rewriteL_comp_comp[OF F0.map_comp0[symmetric]]
    F.map_comp0[symmetric] F.map_id0
    F.ctor_rec_o_map
    rewriteL_comp_comp[OF type_copy_Rep_o_Abs[OF BNF_Composition.type_definition_id_bnf_UNIV]] ..

lemma n2m_ctor_rec_G_F:
  "n2m_ctor_rec_G_F s1 s2 o ctor_F = s2 o map_pre_GF\<^sub>M id (BNF_Def.convol id (n2m_ctor_rec_G s1 s2)) (BNF_Def.convol id (n2m_ctor_rec_G_F s1 s2)) o BNF_Composition.id_bnf o BNF_Composition.id_bnf"
  unfolding n2m_ctor_rec_G_F_def map_pre_F_def map_pre_G\<^sub>M_def map_pre_GF\<^sub>M_def
    F_ctor_o_rec id_apply comp_id id_comp comp_assoc
    rewriteL_comp_comp[OF F0.map_comp0[symmetric]]
    rewriteL_comp_comp[OF type_copy_Rep_o_Abs[OF BNF_Composition.type_definition_id_bnf_UNIV]] ..

subsubsection \<open>Induction\<close>

lemma n2m_rel_induct_G_G_F:
  assumes IH1: "\<forall>x y. BNF_Def.vimage2p (BNF_Composition.id_bnf o BNF_Composition.id_bnf) (BNF_Composition.id_bnf o BNF_Composition.id_bnf) (rel_pre_G\<^sub>M P R S) x y \<longrightarrow> R (ctor_G x) (ctor_G y)"
    and     IH2: "\<forall>x y. BNF_Def.vimage2p (BNF_Composition.id_bnf o BNF_Composition.id_bnf) (BNF_Composition.id_bnf o BNF_Composition.id_bnf) (rel_pre_GF\<^sub>M P R S) x y \<longrightarrow> S (ctor_F x) (ctor_F y)"
  shows "rel_G P \<le> R \<and> rel_F (rel_G P) \<le> S"
  apply (rule context_conjI)
  apply (rule G.ctor_rel_induct[unfolded rel_pre_G_def id_apply vimage2p_def o_apply])
  apply (erule mp[OF spec2[OF IH1], OF vimage2p_mono[OF _ pre_G\<^sub>M.rel_mono], unfolded vimage2p_def o_apply rel_pre_G\<^sub>M_def type_definition.Abs_inverse[OF BNF_Composition.type_definition_id_bnf_UNIV UNIV_I]])
  apply (rule order_refl)
  apply (rule order_refl)
  apply (rule F.ctor_rel_induct[unfolded rel_pre_F_def id_apply vimage2p_def o_apply])
  apply (erule mp[OF spec2[OF IH2], unfolded vimage2p_def o_apply rel_pre_GF\<^sub>M_def type_definition.Abs_inverse[OF BNF_Composition.type_definition_id_bnf_UNIV UNIV_I]])

  apply (rule F.ctor_rel_induct[unfolded rel_pre_F_def id_apply vimage2p_def o_apply])
  apply (erule mp[OF spec2[OF IH2], OF vimage2p_mono[OF _ pre_GF\<^sub>M.rel_mono], unfolded vimage2p_def o_apply rel_pre_GF\<^sub>M_def type_definition.Abs_inverse[OF BNF_Composition.type_definition_id_bnf_UNIV UNIV_I]])
  apply (rule order_refl)
  apply assumption
  apply (rule order_refl)
  done

lemmas n2m_ctor_induct_G_G_F = spec[OF spec [OF
      n2m_rel_induct_G_G_F[of "(=)" "BNF_Def.Grp (Collect R) id" "BNF_Def.Grp (Collect S) id" for R S,
        unfolded G.rel_eq F.rel_eq eq_le_Grp_id_iff all_simps(1,2)[symmetric]]],
    unfolded eq_alt pre_G\<^sub>M.rel_Grp pre_GF\<^sub>M.rel_Grp pre_G\<^sub>M.map_id0 pre_GF\<^sub>M.map_id0,
    unfolded vimage2p_comp vimage2p_id comp_apply comp_id Grp_id_mono_subst
    type_copy_vimage2p_Grp_Rep[OF BNF_Composition.type_definition_id_bnf_UNIV]
    type_copy_Abs_o_Rep[OF BNF_Composition.type_definition_id_bnf_UNIV]
    eqTrueI[OF subset_UNIV] simp_thms(22)
    atomize_conjL[symmetric] atomize_all[symmetric] atomize_imp[symmetric],
    unfolded subset_iff mem_Collect_eq]

section \<open>Mutual View on Nested Coatatypes\<close>

bnf_axiomatization ('a, 'b) coF0
bnf_axiomatization ('a, 'b) coG0

subsection \<open>Nested definition\<close>

codatatype 'a coF = CcoF "('a, 'a coF) coF0"
codatatype 'a coG = CcoG "('a, ('a coG) coF) coG0"

type_synonym ('b, 'c) coF_pre_coF = "('c, 'b) coF0"
type_synonym ('c, 'a) coG_pre_coG = "('a, 'c coF) coG0"

term "dtor_unfold_coF :: ('b \<Rightarrow> ('b, 'c) coF_pre_coF) \<Rightarrow> 'b \<Rightarrow> 'c coF"
term "dtor_unfold_coG :: ('c \<Rightarrow> ('c, 'a) coG_pre_coG) \<Rightarrow> 'c \<Rightarrow> 'a coG"
term "dtor_corec_coF :: ('b \<Rightarrow> ('c coF + 'b, 'c) coF_pre_coF) \<Rightarrow> 'b \<Rightarrow> 'c coF"
term "dtor_corec_coG :: ('c \<Rightarrow> ('a coG + 'c, 'a) coG_pre_coG) \<Rightarrow> 'c \<Rightarrow> 'a coG"
thm coF.dtor_rel_coinduct
thm coG.dtor_rel_coinduct[unfolded rel_pre_coG_def id_apply]

subsection \<open>Isomorphic Mutual Definition\<close>

codatatype 'a coG\<^sub>M = CcoG "('a, 'a coGcoF\<^sub>M) coG0"
  and  'a coGcoF\<^sub>M = CcoF "('a coG\<^sub>M, 'a coGcoF\<^sub>M) coF0"

type_synonym ('b, 'c) coGcoF\<^sub>M_pre_coGcoF\<^sub>M = "('c, 'b) coF0"
type_synonym ('c, 'a) coG\<^sub>M_pre_coG\<^sub>M = "('a, 'c) coG0"

term "dtor_unfold_coG\<^sub>M :: ('b \<Rightarrow> ('c, 'a) coG\<^sub>M_pre_coG\<^sub>M) \<Rightarrow> ('c \<Rightarrow> ('c, 'b) coGcoF\<^sub>M_pre_coGcoF\<^sub>M) \<Rightarrow> 'b \<Rightarrow> 'a coG\<^sub>M"
term "dtor_unfold_coGcoF\<^sub>M :: ('b \<Rightarrow> ('c, 'a) coG\<^sub>M_pre_coG\<^sub>M) \<Rightarrow> ('c \<Rightarrow> ('c, 'b) coGcoF\<^sub>M_pre_coGcoF\<^sub>M) \<Rightarrow> 'c \<Rightarrow> 'a coGcoF\<^sub>M"
term "dtor_corec_coG\<^sub>M :: ('b \<Rightarrow> ('a coGcoF\<^sub>M + 'c, 'a) coG\<^sub>M_pre_coG\<^sub>M) \<Rightarrow> ('c \<Rightarrow> ('a coGcoF\<^sub>M + 'c, 'a coG\<^sub>M + 'b) coGcoF\<^sub>M_pre_coGcoF\<^sub>M) \<Rightarrow> 'b \<Rightarrow> 'a coG\<^sub>M"
term "dtor_corec_coGcoF\<^sub>M :: ('b \<Rightarrow> ('a coGcoF\<^sub>M + 'c, 'a) coG\<^sub>M_pre_coG\<^sub>M) \<Rightarrow> ('c \<Rightarrow> ('a coGcoF\<^sub>M + 'c, 'a coG\<^sub>M + 'b) coGcoF\<^sub>M_pre_coGcoF\<^sub>M) \<Rightarrow> 'c \<Rightarrow> 'a coGcoF\<^sub>M"
thm coG\<^sub>M_coGcoF\<^sub>M.dtor_rel_coinduct[unfolded rel_pre_coG\<^sub>M_def rel_pre_coGcoF\<^sub>M_def]

subsection \<open>Mutualization\<close>

subsubsection \<open>Coiterators\<close>

definition n2m_dtor_unfold_coG :: "('b \<Rightarrow> ('c, 'a) coG\<^sub>M_pre_coG\<^sub>M) \<Rightarrow> ('c \<Rightarrow> ('c, 'b) coGcoF\<^sub>M_pre_coGcoF\<^sub>M) \<Rightarrow> 'b \<Rightarrow> 'a coG"
  where "n2m_dtor_unfold_coG s1 s2 = dtor_unfold_coG (BNF_Composition.id_bnf o BNF_Composition.id_bnf o
    map_pre_coG\<^sub>M id (id :: unit \<Rightarrow> unit) (dtor_unfold_coF (BNF_Composition.id_bnf o BNF_Composition.id_bnf o s2)) o s1)"
definition n2m_dtor_unfold_coG_coF :: "('b \<Rightarrow> ('c, 'a) coG\<^sub>M_pre_coG\<^sub>M) \<Rightarrow> ('c \<Rightarrow> ('c, 'b) coGcoF\<^sub>M_pre_coGcoF\<^sub>M) \<Rightarrow> 'c \<Rightarrow> 'a coG coF"
  where "n2m_dtor_unfold_coG_coF s1 s2 = dtor_unfold_coF (BNF_Composition.id_bnf o BNF_Composition.id_bnf o map_pre_coGcoF\<^sub>M (id :: unit \<Rightarrow> unit) (n2m_dtor_unfold_coG s1 s2) id o s2)"

lemma coG_dtor_o_unfold: "dtor_coG o dtor_unfold_coG s = map_pre_coG id (dtor_unfold_coG s) o s"
  unfolding fun_eq_iff o_apply coG.dtor_unfold by simp
lemma coF_dtor_o_unfold: "dtor_coF o dtor_unfold_coF s = map_pre_coF id (dtor_unfold_coF s) o s"
  unfolding fun_eq_iff o_apply coF.dtor_unfold by simp

lemma coG_dtor_o_corec: "dtor_coG o dtor_corec_coG s = map_pre_coG id (case_sum id (dtor_corec_coG s)) o s"
  unfolding fun_eq_iff o_apply coG.dtor_corec by simp
lemma coF_dtor_o_corec: "dtor_coF o dtor_corec_coF s = map_pre_coF id (case_sum id (dtor_corec_coF s)) o s"
  unfolding fun_eq_iff o_apply coF.dtor_corec by simp

lemma n2m_dtor_unfold_coG:
  "dtor_coG o n2m_dtor_unfold_coG s1 s2 = BNF_Composition.id_bnf o BNF_Composition.id_bnf o map_pre_coG\<^sub>M id id (n2m_dtor_unfold_coG_coF s1 s2) o s1"
  unfolding n2m_dtor_unfold_coG_def n2m_dtor_unfold_coG_coF_def
    map_pre_coG_def map_pre_coF_def map_pre_coG\<^sub>M_def map_pre_coGcoF\<^sub>M_def
    coG_dtor_o_unfold id_apply comp_id id_comp comp_assoc
    rewriteL_comp_comp[OF type_copy_map_comp0_undo[OF BNF_Composition.type_definition_id_bnf_UNIV BNF_Composition.type_definition_id_bnf_UNIV BNF_Composition.type_definition_id_bnf_UNIV pre_coG\<^sub>M.map_comp0[unfolded map_pre_coG\<^sub>M_def]]]
    coF.dtor_unfold_o_map
    rewriteL_comp_comp[OF type_copy_Rep_o_Abs[OF BNF_Composition.type_definition_id_bnf_UNIV]] ..

lemma n2m_dtor_unfold_coG_coF:
  "dtor_coF o n2m_dtor_unfold_coG_coF s1 s2 = BNF_Composition.id_bnf o BNF_Composition.id_bnf o map_pre_coGcoF\<^sub>M id (n2m_dtor_unfold_coG s1 s2) (n2m_dtor_unfold_coG_coF s1 s2) o s2"
  unfolding n2m_dtor_unfold_coG_coF_def map_pre_coF_def map_pre_coG\<^sub>M_def map_pre_coGcoF\<^sub>M_def
    coF_dtor_o_unfold id_apply comp_id id_comp comp_assoc
    rewriteL_comp_comp[OF coF0.map_comp0[symmetric]]
    rewriteL_comp_comp[OF type_copy_Rep_o_Abs[OF BNF_Composition.type_definition_id_bnf_UNIV]] ..

subsubsection \<open>Corecursors\<close>

definition n2m_dtor_corec_coG ::
  "('b \<Rightarrow> ('a coG coF + 'c, 'a) coG\<^sub>M_pre_coG\<^sub>M) \<Rightarrow> ('c \<Rightarrow> ('a coG coF + 'c, 'a coG + 'b) coGcoF\<^sub>M_pre_coGcoF\<^sub>M) \<Rightarrow> 'b \<Rightarrow> 'a coG"
  where "n2m_dtor_corec_coG s1 s2 =
    dtor_corec_coG (BNF_Composition.id_bnf o BNF_Composition.id_bnf o
      map_pre_coG\<^sub>M id (id :: unit \<Rightarrow> unit)
        (case_sum (map_coF Inl) (dtor_corec_coF (BNF_Composition.id_bnf o BNF_Composition.id_bnf o map_pre_coGcoF\<^sub>M (id :: unit \<Rightarrow> unit) id (map_sum (map_coF Inl) id) o s2))) o
      s1)"

definition n2m_dtor_corec_coG_coF ::
  "('b \<Rightarrow> ('a coG coF + 'c, 'a) coG\<^sub>M_pre_coG\<^sub>M) \<Rightarrow> ('c \<Rightarrow> ('a coG coF + 'c, 'a coG + 'b) coGcoF\<^sub>M_pre_coGcoF\<^sub>M) \<Rightarrow> 'c \<Rightarrow> 'a coG coF"
  where "n2m_dtor_corec_coG_coF s1 s2 = dtor_corec_coF (BNF_Composition.id_bnf o BNF_Composition.id_bnf o map_pre_coGcoF\<^sub>M (id :: unit \<Rightarrow> unit) (case_sum id (n2m_dtor_corec_coG s1 s2)) id o s2)"

lemma n2m_dtor_corec_coG:
  "dtor_coG o n2m_dtor_corec_coG s1 s2 = BNF_Composition.id_bnf o BNF_Composition.id_bnf o map_pre_coG\<^sub>M id id (case_sum id (n2m_dtor_corec_coG_coF s1 s2)) o s1"
  unfolding n2m_dtor_corec_coG_def n2m_dtor_corec_coG_coF_def
    map_pre_coG_def map_pre_coF_def map_pre_coG\<^sub>M_def map_pre_coGcoF\<^sub>M_def
    coG_dtor_o_corec
    id_apply comp_id id_comp comp_assoc[symmetric] map_sum.comp map_sum.id
    case_sum_o_inj(1) case_sum_o_map_sum o_case_sum
    rewriteR_comp_comp[OF coG0.map_comp0[symmetric]]
    rewriteR_comp_comp[OF coF0.map_comp0[symmetric]]
    coF.map_comp0[symmetric] coF.map_id0
    coF.dtor_corec_o_map
    rewriteR_comp_comp[OF type_copy_Rep_o_Abs[OF BNF_Composition.type_definition_id_bnf_UNIV]] ..

lemma n2m_dtor_corec_coG_coF:
  "dtor_coF o n2m_dtor_corec_coG_coF s1 s2 = BNF_Composition.id_bnf o BNF_Composition.id_bnf o map_pre_coGcoF\<^sub>M id (case_sum id (n2m_dtor_corec_coG s1 s2)) (case_sum id (n2m_dtor_corec_coG_coF s1 s2)) o s2"
  unfolding n2m_dtor_corec_coG_coF_def map_pre_coF_def map_pre_coG\<^sub>M_def map_pre_coGcoF\<^sub>M_def
    coF_dtor_o_corec id_apply comp_id id_comp comp_assoc
    rewriteL_comp_comp[OF coF0.map_comp0[symmetric]]
    rewriteL_comp_comp[OF type_copy_Rep_o_Abs[OF BNF_Composition.type_definition_id_bnf_UNIV]] ..

subsubsection \<open>Coinduction\<close>

lemma n2m_rel_coinduct_coG_coG_coF:
  assumes CIH1: "\<forall>x y. R x y \<longrightarrow> BNF_Def.vimage2p (BNF_Composition.id_bnf o BNF_Composition.id_bnf) (BNF_Composition.id_bnf o BNF_Composition.id_bnf) (rel_pre_coG\<^sub>M P R S) (dtor_coG x) (dtor_coG y)"
    and     CIH2: "\<forall>x y. S x y \<longrightarrow> BNF_Def.vimage2p (BNF_Composition.id_bnf o BNF_Composition.id_bnf) (BNF_Composition.id_bnf o BNF_Composition.id_bnf) (rel_pre_coGcoF\<^sub>M P R S) (dtor_coF x) (dtor_coF y)"
  shows "R \<le> rel_coG P \<and> S \<le> rel_coF (rel_coG P)"
  apply (rule context_conjI)
  apply (rule coG.dtor_rel_coinduct[unfolded rel_pre_coG_def id_apply vimage2p_def o_apply])
  apply (erule mp[OF spec2[OF CIH1], THEN vimage2p_mono[OF _ pre_coG\<^sub>M.rel_mono], unfolded vimage2p_def o_apply rel_pre_coG\<^sub>M_def type_definition.Abs_inverse[OF BNF_Composition.type_definition_id_bnf_UNIV UNIV_I]])
  apply (rule order_refl)
  apply (rule order_refl)
  apply (rule coF.dtor_rel_coinduct[unfolded rel_pre_coF_def id_apply vimage2p_def o_apply])
  apply (erule mp[OF spec2[OF CIH2], unfolded vimage2p_def o_apply rel_pre_coGcoF\<^sub>M_def type_definition.Abs_inverse[OF BNF_Composition.type_definition_id_bnf_UNIV UNIV_I]])

  apply (rule coF.dtor_rel_coinduct[unfolded rel_pre_coF_def id_apply vimage2p_def o_apply])
  apply (erule mp[OF spec2[OF CIH2], THEN vimage2p_mono[OF _ pre_coGcoF\<^sub>M.rel_mono], unfolded vimage2p_def o_apply rel_pre_coGcoF\<^sub>M_def type_definition.Abs_inverse[OF BNF_Composition.type_definition_id_bnf_UNIV UNIV_I]])
  apply (rule order_refl)
  apply assumption
  apply (rule order_refl)
  done

lemmas n2m_ctor_induct_coG_coG_coF = spec[OF spec[OF spec[OF spec[OF
          n2m_rel_coinduct_coG_coG_coF[of _ "(=)",
            unfolded coG.rel_eq coF.rel_eq le_fun_def le_bool_def all_simps(1,2)[symmetric]]]]]]

(*<*)
end
(*>*)


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

(*
 * Tactic for solving monadic equalities, such as:
 *
 * (liftE (return 3) = returnOk 3
 *
 * Theorems of the form:
 *
 *   ((a, s') \<in> fst (A s)) = P a s s'
 *
 * and
 *
 *   snd (A s) = P s
 *
 * are added to the "monad_eq" set.
 *)
theory MonadEq
imports "Monad_WP/NonDetMonadVCG"
begin

(* Setup "monad_eq" attributes. *)
ML \<open>
structure MonadEqThms = Named_Thms (
    val name = Binding.name "monad_eq"
    val description = "monad equality-prover theorems"
    )
\<close>
attribute_setup monad_eq = \<open>
  Attrib.add_del
    (Thm.declaration_attribute MonadEqThms.add_thm)
    (Thm.declaration_attribute MonadEqThms.del_thm)\<close>
  "Monad equality-prover theorems"

(* Setup tactic. *)

ML \<open>
fun monad_eq_tac ctxt =
let
  (* Set a simpset as being hidden, so warnings are not printed from it. *)
  val ctxt' = Context_Position.set_visible false ctxt
in
  CHANGED (clarsimp_tac (ctxt' addsimps (MonadEqThms.get ctxt')) 1)
end
\<close>

method_setup monad_eq = \<open>
    Method.sections Clasimp.clasimp_modifiers >> (K (SIMPLE_METHOD o monad_eq_tac))\<close>
  "prove equality on monads"

lemma monad_eq_simp_state [monad_eq]:
  "((A :: ('s, 'a) nondet_monad) s = B s') =
      ((\<forall>r t. (r, t) \<in> fst (A s) \<longrightarrow> (r, t) \<in> fst (B s'))
         \<and> (\<forall>r t. (r, t) \<in> fst (B s') \<longrightarrow> (r, t) \<in> fst (A s))
         \<and> (snd (A s) = snd (B s')))"
  apply (auto intro!: set_eqI prod_eqI)
  done

lemma monad_eq_simp [monad_eq]:
  "((A :: ('s, 'a) nondet_monad) = B) =
      ((\<forall>r t s. (r, t) \<in> fst (A s) \<longrightarrow> (r, t) \<in> fst (B s))
         \<and> (\<forall>r t s. (r, t) \<in> fst (B s) \<longrightarrow> (r, t) \<in> fst (A s))
         \<and> (\<forall>x. snd (A x) = snd (B x)))"
  apply (auto intro!: set_eqI prod_eqI)
  done

declare in_monad [monad_eq]
declare in_bindE [monad_eq]

(* Test *)
lemma "returnOk 3 = liftE (return 3)"
  apply monad_eq
  oops

end


(*  Title:       Lib.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

header "Generic functions and lemmas"

theory Lib
imports Main
begin

definition
  TT :: "'a \<Rightarrow> bool"
where
  "TT = (\<lambda>_. True)"

lemma TT_True [intro, simp]: "TT a"
  unfolding TT_def by simp

lemma in_set_tl: "x \<in> set (tl xs) \<Longrightarrow> x \<in> set xs"
  by (metis Nil_tl insert_iff list.collapse set_simps(2))

lemma nat_le_eq_or_lt [elim]:
    fixes x :: nat
  assumes "x \<le> y"
      and eq: "x = y \<Longrightarrow> P x y"
      and lt: "x < y \<Longrightarrow> P x y"
    shows "P x y"
  using assms unfolding nat_less_le by auto

lemma disjoint_commute:
  "(A \<inter> B = {}) \<Longrightarrow> (B \<inter> A = {})"
  by auto

definition
  default :: "('i \<Rightarrow> 's) \<Rightarrow> ('i \<Rightarrow> 's option) \<Rightarrow> ('i \<Rightarrow> 's)"
where
  "default df f = (\<lambda>i. case f i of None \<Rightarrow> df i | Some s \<Rightarrow> s)"

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Late_Bisim_Pres
  imports Weak_Late_Bisim_SC Weak_Late_Sim_Pres Strong_Late_Bisim_SC
begin

lemma tauPres:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<approx> Q"

  shows "\<tau>.(P) \<approx> \<tau>.(Q)"
proof -
  let ?X = "{(\<tau>.(P), \<tau>.(Q)) | P Q. P \<approx> Q}"
  from assms have "(\<tau>.(P), \<tau>.(Q)) \<in> ?X" by auto
  thus ?thesis
    by(coinduct rule: weakBisimCoinduct)
      (auto simp add: pi.inject intro:  Weak_Late_Sim_Pres.tauPres symmetric)
qed

lemma inputPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   x :: name

  assumes PSimQ: "\<forall>y. P[x::=y] \<approx> Q[x::=y]"

  shows "a<x>.P \<approx> a<x>.Q"
proof -
  let ?X = "{(a<x>.P, a<x>.Q) | a x P Q. \<forall>y. P[x::=y] \<approx> Q[x::=y]}"
  {
    fix axP axQ p
    assume "(axP, axQ) \<in> ?X"
    then obtain a x P Q where A: "\<forall>y. P[x::=y] \<approx> Q[x::=y]" and B: "axP = a<x>.P" and C: "axQ = a<x>.Q"
      by auto
    have "\<And>y. ((p::name prm) \<bullet> P)[(p \<bullet> x)::=y] \<approx> (p \<bullet> Q)[(p \<bullet> x)::=y]"
    proof -
      fix y
      from A have "P[x::=(rev p \<bullet> y)] \<approx> Q[x::=(rev p \<bullet> y)]"
        by blast
      hence "(p \<bullet> (P[x::=(rev p \<bullet> y)])) \<approx> p \<bullet> (Q[x::=(rev p \<bullet> y)])"
        by(rule eqvtI)
      thus "(p \<bullet> P)[(p \<bullet> x)::=y] \<approx> (p \<bullet> Q)[(p \<bullet> x)::=y]"
        by(simp add: eqvts pt_pi_rev[OF pt_name_inst, OF at_name_inst])
    qed
    hence "((p::name prm) \<bullet> axP, p \<bullet> axQ) \<in> ?X" using B C
      by auto
  }
  hence "eqvt ?X" by(simp add: eqvt_def)

  from PSimQ have "(a<x>.P, a<x>.Q) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cSim P Q)
    thus ?case using \<open>eqvt ?X\<close>
      by(force intro: inputPres)
  next
    case(cSym P Q)
    thus ?case
      by(blast dest: symmetric)
  qed
qed

lemma outputPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   b :: name

  assumes "P \<approx> Q"

  shows "a{b}.(P) \<approx> a{b}.(Q)"
proof -
  let ?X = "{(a{b}.(P), a{b}.(Q)) | a b P Q. P \<approx> Q}"
  from assms have "(a{b}.(P), a{b}.(Q)) \<in> ?X" by auto
  thus ?thesis
    by(coinduct rule: weakBisimCoinduct)
      (auto simp add: pi.inject intro:  Weak_Late_Sim_Pres.outputPres symmetric)
qed

  shows "<\<nu>x>P \<approx> <\<nu>x>Q"
proof -
  let ?X = "{x. \<exists>P Q. P \<approx> Q \<and> (\<exists>a. x = (<\<nu>a>P, <\<nu>a>Q))}"
  from PBiSimQ have "(<\<nu>x>P, <\<nu>x>Q) \<in> ?X" by blast
  moreover have "\<And>P Q a. P \<leadsto>\<^sup>^<weakBisim> Q \<Longrightarrow> <\<nu>a>P \<leadsto>\<^sup>^<(?X \<union> weakBisim)> <\<nu>a>Q"
  proof -
    fix P Q a
    assume PSimQ: "P \<leadsto>\<^sup>^<weakBisim> Q"
    moreover have "\<And>P Q a. P \<approx> Q \<Longrightarrow> (<\<nu>a>P, <\<nu>a>Q) \<in> ?X \<union> weakBisim" by blast
    moreover have "weakBisim \<subseteq> ?X \<union> weakBisim" by blast
    moreover have "eqvt weakBisim" by(rule eqvt)
    moreover have "eqvt (?X \<union> weakBisim)"
      by(auto simp add: eqvt_def dest: eqvtI)+
    ultimately show "<\<nu>a>P \<leadsto>\<^sup>^<(?X \<union> weakBisim)> <\<nu>a>Q"
      by(rule Weak_Late_Sim_Pres.resPres)
  qed

  ultimately show ?thesis using PBiSimQ
    by(coinduct rule: weakBisimCoinductAux, blast dest: unfoldE)
qed

  assumes "P \<approx> Q"

  shows "[a\<frown>b]P \<approx> [a\<frown>b]Q"
proof -
  let ?X = "{([a\<frown>b]P, [a\<frown>b]Q) | a b P Q. P \<approx> Q}"
  from assms have "([a\<frown>b]P, [a\<frown>b]Q) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cSim P Q)
    {
      fix P Q a b
      assume "P \<approx> Q"
      hence "P \<leadsto>\<^sup>^<weakBisim> Q" by(rule unfoldE)
      moreover {
        fix P Q a
        assume "P \<approx> Q"
        moreover have "[a\<frown>a]P \<approx> P" by(rule matchId)
        ultimately have "[a\<frown>a]P \<approx> Q" by(blast intro: transitive)
      }
      moreover have "weakBisim \<subseteq> ?X \<union> weakBisim" by blast
      ultimately have "[a\<frown>b]P \<leadsto>\<^sup>^<(?X \<union> weakBisim)> [a\<frown>b]Q"
        by(rule matchPres)
    }
    with \<open>(P, Q) \<in> ?X\<close> show ?case by auto
  next
    case(cSym P Q)
    thus ?case by(auto simp add: pi.inject dest: symmetric)
  qed
qed

lemma mismatchPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   b :: name

  assumes "P \<approx> Q"

  shows "[a\<noteq>b]P \<approx> [a\<noteq>b]Q"
proof -
  let ?X = "{([a\<noteq>b]P, [a\<noteq>b]Q) | a b P Q. P \<approx> Q}"
  from assms have "([a\<noteq>b]P, [a\<noteq>b]Q) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cSim P Q)
    {
      fix P Q a b
      assume "P \<approx> Q"
      hence "P \<leadsto>\<^sup>^<weakBisim> Q" by(rule unfoldE)
      moreover {
        fix P Q a b
        assume "P \<approx> Q" and "(a::name) \<noteq> b"
        note \<open>P \<approx> Q\<close>
        moreover from \<open>a \<noteq> b\<close> have "[a\<noteq>b]P \<approx> P" by(rule mismatchId)
        ultimately have "[a\<noteq>b]P \<approx> Q" by(blast intro: transitive)
      }
      moreover have "weakBisim \<subseteq> ?X \<union> weakBisim" by blast
      ultimately have "[a\<noteq>b]P \<leadsto>\<^sup>^<(?X \<union> weakBisim)> [a\<noteq>b]Q"
        by(rule mismatchPres)
    }
    with \<open>(P, Q) \<in> ?X\<close> show ?case by auto
  next
    case(cSym P Q)
    thus ?case by(auto simp add: pi.inject dest: symmetric)
  qed
qed

lemma parPres:
  fixes P :: pi
  and   Q :: pi
  and   R :: pi

  assumes "P \<approx> Q"

  shows "P \<parallel> R \<approx> Q \<parallel> R"
proof -
  let ?ParSet = "{(resChain lst (P \<parallel> R), resChain lst (Q \<parallel> R)) | lst P Q R. P \<approx> Q}"
  have BC: "\<And>P Q. P \<parallel> Q = resChain [] (P \<parallel> Q)" by auto
  from assms have "(P \<parallel> R, Q \<parallel> R) \<in> ?ParSet" by(blast intro: BC)
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cSim PR QR)
    {
      fix P Q R lst
      assume "P \<approx> Q"

      from eqvtI have "eqvt (?ParSet \<union> weakBisim)"
        by(auto simp add: eqvt_def, blast)
      moreover have "\<And>P Q a. (P, Q) \<in> ?ParSet \<union> weakBisim \<Longrightarrow> (<\<nu>a>P, <\<nu>a>Q) \<in> ?ParSet \<union> weakBisim"
        by(blast intro: resChain.step[THEN sym] resPres)
      moreover {
        from \<open>P \<approx> Q\<close> have "P \<leadsto>\<^sup>^<weakBisim> Q" by(rule unfoldE)
        moreover note \<open>P \<approx> Q\<close>
        moreover {
          fix P Q R
          assume "P \<approx> Q"
          moreover have "P \<parallel> R = resChain [] (P \<parallel> R)" by simp
          moreover have "Q \<parallel> R = resChain [] (Q \<parallel> R)" by simp
          ultimately have "(P \<parallel> R, Q \<parallel> R) \<in> ?ParSet \<union> weakBisim" by blast
        }
        moreover {
          fix P Q a
          assume A: "(P, Q) \<in> ?ParSet \<union> weakBisim"
          hence "(<\<nu>a>P, <\<nu>a>Q) \<in> ?ParSet \<union> weakBisim" (is "?goal")
            apply(auto intro: resPres)
            by(rule_tac x="a#lst" in exI) auto
        }
        ultimately have "(P \<parallel> R) \<leadsto>\<^sup>^<(?ParSet \<union> weakBisim)> (Q \<parallel> R)" using eqvt \<open>eqvt(?ParSet \<union> weakBisim)\<close>
          by(rule Weak_Late_Sim_Pres.parPres)
      }

      ultimately have "resChain lst (P \<parallel> R) \<leadsto>\<^sup>^<(?ParSet \<union> weakBisim)> resChain lst (Q \<parallel> R)"
        by(rule resChainI)
    }
    with \<open>(PR, QR) \<in> ?ParSet\<close> show ?case by blast
  next
    case(cSym PR QR)
    thus ?case by(auto dest: symmetric)
  qed
qed

  assumes PBisimQ: "P \<approx> Q"

  shows "!P \<approx> !Q"
proof -
  let ?X = "(bangRel weakBisim)"
  let ?Y = "Strong_Late_Bisim.bisim O (bangRel weakBisim) O Strong_Late_Bisim.bisim"

  from eqvt Strong_Late_Bisim.bisimEqvt have eqvtY: "eqvt ?Y" by(blast intro: eqvtBangRel)
  have XsubY: "?X \<subseteq> ?Y" by(auto intro: Strong_Late_Bisim.reflexive)

  have RelStay: "\<And>P Q. (P \<parallel> !P, Q) \<in> ?Y \<Longrightarrow> (!P, Q) \<in> ?Y"
  proof(auto)
    fix P Q R T
    assume PBisimQ: "P \<parallel> !P \<sim> Q"
       and QBRR: "(Q, R) \<in> bangRel weakBisim"
       and RBisimT: "R \<sim> T"
    have "!P \<sim> Q"
    proof -
      have "!P \<sim> P \<parallel> !P" by(rule Strong_Late_Bisim_SC.bangSC)
      thus ?thesis using PBisimQ by(rule Strong_Late_Bisim.transitive)
    qed
    with QBRR RBisimT show "(!P, T) \<in> ?Y" by blast
  qed

  have ParCompose: "\<And>P Q R T. \<lbrakk>P \<approx> Q; (R, T) \<in> ?Y\<rbrakk> \<Longrightarrow> (P \<parallel> R, Q \<parallel> T) \<in> ?Y"
  proof -
    fix P Q R T
    assume PBisimQ: "P \<approx> Q"
       and RYT:     "(R, T) \<in> ?Y"
    thus "(P \<parallel> R, Q \<parallel> T) \<in> ?Y"
    proof(auto)
      fix T' R'
      assume T'BisimT: "T' \<sim> T" and RBisimR': "R \<sim> R'"
         and R'BRT': "(R', T') \<in> bangRel weakBisim"
      have "P \<parallel> R \<sim> P \<parallel> R'"
      proof -
        from RBisimR' have "R \<parallel> P \<sim> R' \<parallel> P" by(rule Strong_Late_Bisim_Pres.parPres)
        moreover have "P \<parallel> R \<sim> R \<parallel> P" and "R' \<parallel> P \<sim> P \<parallel> R'" by(rule Strong_Late_Bisim_SC.parSym)+
        ultimately show ?thesis by(blast intro: Strong_Late_Bisim.transitive)
      qed
      moreover from PBisimQ R'BRT' have "(P \<parallel> R', Q \<parallel> T') \<in> bangRel weakBisim" by(rule BRPar)
      moreover have "Q \<parallel> T' \<sim> Q \<parallel> T"
      proof -
        from T'BisimT have "T' \<parallel> Q \<sim> T \<parallel> Q" by(rule Strong_Late_Bisim_Pres.parPres)
        moreover have "Q \<parallel> T' \<sim> T' \<parallel> Q" and "T \<parallel> Q \<sim> Q \<parallel> T" by(rule Strong_Late_Bisim_SC.parSym)+
        ultimately show ?thesis by(blast intro: Strong_Late_Bisim.transitive)
      qed
      ultimately show ?thesis by blast
    qed
  qed

  have ResCong: "\<And>P Q x. (P, Q) \<in> ?Y \<Longrightarrow> (<\<nu>x>P, <\<nu>x>Q) \<in> ?Y"
    by(auto intro: BRRes Strong_Late_Bisim_Pres.resPres transitive)

  from PBisimQ have "(!P, !Q) \<in> ?X" by(rule BRBang)
  moreover from eqvt have "eqvt (bangRel weakBisim)" by(rule eqvtBangRel)
  ultimately show ?thesis
  proof(coinduct rule: weakBisimTransitiveCoinduct)
    case(cSim P Q)
    from \<open>(P, Q) \<in> ?X\<close>
    show "P \<leadsto>\<^sup>^<?Y> Q"
    proof(induct)
      case(BRBang P Q)
      have "P \<approx> Q" by fact
      moreover hence "P \<leadsto>\<^sup>^<weakBisim> Q" by(blast dest: unfoldE)
      moreover have "\<And>P Q. P \<approx> Q \<Longrightarrow> P \<leadsto>\<^sup>^<weakBisim> Q" by(blast dest: unfoldE)
      moreover from Strong_Late_Bisim.bisimEqvt eqvt have "eqvt ?Y" by(blast intro: eqvtBangRel)

      ultimately show "!P \<leadsto>\<^sup>^<?Y> !Q" using ParCompose ResCong RelStay XsubY
        by(rule_tac Weak_Late_Sim_Pres.bangPres, simp_all)
    next
      case(BRPar P Q R T)
      have PBiSimQ: "P \<approx> Q" by fact
      have RBangRelT: "(R, T) \<in> ?X" by fact
      have RSimT: "R \<leadsto>\<^sup>^<?Y> T" by fact
      moreover from PBiSimQ  have "P \<leadsto>\<^sup>^<weakBisim> Q" by(blast dest: unfoldE)
      moreover from RBangRelT have "(R, T) \<in> ?Y" by(blast intro: Strong_Late_Bisim.reflexive)
      ultimately show "P \<parallel> R \<leadsto>\<^sup>^<?Y> Q \<parallel> T" using ParCompose ResCong eqvt eqvtY \<open>P \<approx> Q\<close>
        by(rule_tac Weak_Late_Sim_Pres.parCompose)
    next
      case(BRRes P Q x)
      have "P \<leadsto>\<^sup>^<?Y> Q" by fact
      thus "<\<nu>x>P \<leadsto>\<^sup>^<?Y> <\<nu>x>Q" using ResCong eqvtY XsubY
        by(rule_tac Weak_Late_Sim_Pres.resPres, simp_all)
    qed
  next
    case(cSym P Q)
    thus ?case by(metis symmetric bangRelSymetric)
  qed
qed

end