theory SpreadGetSet
  imports Main
 "build_spread/Spread_dargentfull_CorresProof"

begin
context spread_dargentfull begin
definition find_position :: "nat \<Rightarrow> nat \<Rightarrow> nat \<times> nat"
  where "find_position si offset  = (offset div si, offset mod si)"

definition get_bit :: "(('a::len0) word)['n::finite] \<Rightarrow> nat \<Rightarrow> bool"
  where "get_bit arr pos =
                (let (byte, off) = find_position LENGTH('a) pos in
                 arr.[byte] !! off )"

definition raw_get_bit :: "(('a::len0) word)['n::finite] \<Rightarrow> nat \<Rightarrow> 'a word"
  where "raw_get_bit arr pos =
                (let (byte, off) = find_position LENGTH('a) pos in
                 arr.[byte] && 2^off )"

definition size_of_arr :: "(('a::len0) word)['n::finite] \<Rightarrow> nat"
  where "size_of_arr _ = CARD('n)"

definition size_of_arr_bits :: "(('a::len0) word)['n::finite] \<Rightarrow> nat"
  where "size_of_arr_bits _ = LENGTH('a)*CARD('n)"

ML \<open>
fun getter_sanity_tac ctxt =
 let
    val gets = Proof_Context.get_thms ctxt
    val get  = Proof_Context.get_thm ctxt
  in
  K (print_tac ctxt "debut_getter")
THEN'
 (asm_full_simp_tac (ctxt addsimps [(get "find_position_def")])
THEN'
 (fn i =>
TRY (REPEAT_ALL_NEW (eresolve_tac ctxt @{thms exE conjE}) i))
(* THEN' K (print_tac ctxt "coucou") *)
THEN' custom_get_set_different_field_tac ctxt
) end
\<close>

lemma wesh : "x < LENGTH('a) \<Longrightarrow> (((2 ^ x) :: ('a :: len0)  word) !! n) = (x = n)"
  by sorry
ML \<open>
fun setter_sanity_tac ctxt =
 let
    val gets = Proof_Context.get_thms ctxt
    val get  = Proof_Context.get_thm ctxt
  in
  K (print_tac ctxt "debut")
THEN'
 (asm_full_simp_tac (ctxt addsimps
 [get "find_position_def", get "size_of_arr_bits_def"]))
THEN'
(asm_full_simp_tac ((clear_simpset ctxt) addsimps
 (gets "numeral.simps")))
THEN' asm_full_simp_tac ctxt
(* THEN'  K (print_tac ctxt "suite") *)
THEN'
 (fn i =>
TRY (REPEAT_ALL_NEW (eresolve_tac ctxt @{thms exE conjE}) i))
(* THEN'  K (print_tac ctxt "resuite") *)
 THEN'  (fn i =>
TRY (REPEAT_ALL_NEW (eresolve_tac ctxt @{thms less_zeroE less_SucE}) i))

 (* THEN' K (print_tac ctxt "coucou")  *)
THEN_ALL_NEW custom_get_set_different_field_tac (ctxt addsimps @{thms wesh})
 end
\<close>
ML \<open>
fun prove_thm ctxt assms concl tactic =
let
val clean = HOLogic.mk_Trueprop o strip_atype
val thm0 = mk_meta_imps (map clean assms) (concl |> clean) ctxt
val names =  Variable.add_free_names ctxt thm0 []
in
Goal.prove ctxt names [] thm0
( fn {context, prems} => tactic context 1)
end
\<close>

ML \<open>
val uvals =
Symtab.lookup (UVals.get @{theory}) "spread_dargentfull.c"
|> the
(* Filter those with custom layouts*)
 |> get_uval_custom_layout_records
\<close>
ML \<open>
 val uval0 = hd uvals
\<close>

ML \<open>
val (info0, lay0) =
case get_uval_layout uval0 of
CustomLayout (info,
Const ("Option.option.Some", _) $
( Const ("Cogent.ptr_layout.LayRecord", _) $
layout)) =>
(info,
layout |> HOLogic.dest_list
|> map HOLogic.dest_prod
|> map (apfst HOLogic.dest_string)
|> Symtab.make
)

val field0 = hd info0
val layfield0 = Symtab.lookup lay0 (# name field0) |> the
\<close>

ML \<open>
val get_data =
get_uval_name uval0 ^ "_C.data_C"
\<close>

ML \<open>
fun make_getter_sanity_thm ctxt layfield (field_info : field_layout) =
let
val ass =
  @{term
  "\<lambda>  lay data.
   (\<forall> x\<in> set(layout_taken_bit_list lay).
  get_bit (data s) x = get_bit (data t) x)
  "
  } $ layfield $ (Syntax.read_term ctxt get_data)
val concl = @{term "\<lambda> getter . getter s = getter t"  }
        $ # isa_getter field_info
in
prove_thm ctxt [ass] concl getter_sanity_tac
end

\<close>
ML \<open>
fun make_setter_sanity_thm ctxt layfield (field_info : field_layout) =
let

 val data = Syntax.read_term ctxt get_data
val ass1 =
  @{term
  "\<lambda>  data .x < size_of_arr_bits (data s)
  "
  } $ data
val ass2 =
  @{term
  "\<lambda>  lay .x \<notin> set (layout_taken_bit_list lay)
  "
  } $ layfield
val concl = @{term "\<lambda> data setter .
   raw_get_bit (data (setter s b)) x = raw_get_bit (data s) x"  }
        $ data
        $ # isa_setter field_info
in
prove_thm ctxt [ass1, ass2] concl (fn ctxt => fn _ => print_tac ctxt "coucuo" THEN cheat_tactic ctxt)(* setter_sanity_tac *)
end
\<close>

ML \<open>
fun make_getset_sanity_thms ctxt (uval : field_layout uval) : (thm * thm) list =
let
val (info, lays) =
case get_uval_layout uval of
CustomLayout (info,
Const ("Option.option.Some", _) $
( Const ("Cogent.ptr_layout.LayRecord", _) $
layout)) =>
(info,
layout |> HOLogic.dest_list
|> map HOLogic.dest_prod
|> map (apfst HOLogic.dest_string)
|> Symtab.make
)
in
map (
fn field =>
let val lay = Symtab.lookup lays (# name field) |> the in
(make_getter_sanity_thm ctxt  lay field,
make_setter_sanity_thm ctxt lay field)
end
)

 info

end
\<close>

lemma raw_get_bit_eq : "raw_get_bit x n = raw_get_bit y n \<Longrightarrow> get_bit x n = get_bit y n"
  by sorry

lemma find_pos_split : " P (find_position q x)
  = ((\<forall> p r. find_position q x = (p, r) \<longrightarrow>
r < q \<longrightarrow> p < n div q \<longrightarrow>  P (p, r))
\<and> (\<forall> r. find_position q x = (n div q, r) \<longrightarrow> r < n mod q \<longrightarrow> P ( (n div q), r) )
\<and> (\<forall> p r. find_position q x = (p, r) \<longrightarrow> (x \<ge> n \<or> q = 0) \<longrightarrow> P ( p, r) )
)
"
  by sorry

lemma "x < size_of_arr_bits (data_C s) \<Longrightarrow>
    x \<notin> set (layout_taken_bit_list (LayBitRange (64, 2))) \<Longrightarrow>
    get_bit (data_C (deref_d21_set_b s b)) x = get_bit (data_C s) x "
  apply(rule raw_get_bit_eq )
apply(simp add:raw_get_bit_def)
apply( split find_pos_split[of _ _ _  32])

end

lemma "x < size_of_arr_bits (data_C s) \<Longrightarrow>
    x \<notin> set (layout_taken_bit_list
               (LayVariant (Suc 0, Suc 0) [(''A'', 0, LayBitRange (Suc 0, 0)), (''B'', Suc 0, LayBitRange (Suc 0, 67))])) \<Longrightarrow>
    raw_get_bit (data_C (deref_d14_set_a s b)) x = raw_get_bit (data_C s) x "
  apply(tactic \<open>setter_sanity_tac @{context} 1\<close> )
(* ca ne marche pas ! *)

lemma "x < size_of_arr_bits (data_C s) \<Longrightarrow>
    x \<notin> set (layout_taken_bit_list (LayBitRange (64, 2))) \<Longrightarrow>
    raw_get_bit (data_C (deref_d21_set_b s b)) x = raw_get_bit (data_C s) x "
apply(tactic \<open>setter_sanity_tac @{context} 1\<close> )

ML \<open>
val thms = make_getset_sanity_thms @{context} uval0
\<close>

end

end


theory SNS_IAS_Eduroam_Spoofing
imports
  Iptables_Semantics.Parser
begin

section\<open>Example: Eduroam and sns.ias Firewall Script\<close>

definition "everything_but_my_ip = all_but_those_ips [(ipv4addr_of_dotdecimal (131,159,207,206), 32)]"

text\<open>Incoming: everything but my IP\<close>
definition "ipassignment_incoming = [(Iface ''wlan0'', everything_but_my_ip), (Iface ''lo'', [(0,0)])]"

lemma "ipassmt_sanity_nowildcards (map_of ipassignment_incoming)" by eval

text\<open>Outgoing: only my IP\<close>
definition "ipassignment_outgoing = [(Iface ''wlan0'',  [(ipv4addr_of_dotdecimal (131,159,207,206), 32)]), (Iface ''lo'', [(0,0)])]"

lemma "ipassmt_sanity_nowildcards (map_of ipassignment_outgoing)" by eval

parse_iptables_save eduroam_fw="eduroam_iptables-save"

thm eduroam_fw_def
thm eduroam_fw_INPUT_default_policy_def

value[code] "debug_ipassmt_ipv4 ipassignment_incoming (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw))"

value[code] "unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)"

value[code] "collect_ifaces (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw))"

lemma "ipassmt_sanity_defined (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)) (map_of_ipassmt ipassignment_incoming)" by eval
lemma "ipassmt_sanity_defined (unfold_ruleset_OUTPUT eduroam_fw_OUTPUT_default_policy (map_of_string_ipv4 eduroam_fw)) (map_of_ipassmt ipassignment_outgoing)" by eval

value[code] "debug_ipassmt_ipv4 ipassignment_incoming (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw))"
value[code] "debug_ipassmt_ipv4 ipassignment_outgoing (unfold_ruleset_OUTPUT eduroam_fw_OUTPUT_default_policy (map_of_string_ipv4 eduroam_fw))"

text\<open>The ruleset\<close>
lemma "check_simple_fw_preconditions (upper_closure (packet_assume_new (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw))))" by eval
value[code] "map simple_rule_ipv4_toString (to_simple_firewall (upper_closure (packet_assume_new (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)))))"
lemma "simple_fw_valid (to_simple_firewall (upper_closure (packet_assume_new (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)))))" by eval
lemma "simple_fw_valid (to_simple_firewall (lower_closure (packet_assume_new (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)))))" by eval

text\<open>We do not need to call things such as @{const transform_optimize_dnf_strict} because the
     firewall already is in @{const normalized_nnf_match} (required for @{const no_spoofing_iface})\<close>
lemma "transform_optimize_dnf_strict (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)) =
          unfold_ruleset_INPUT action.Drop (map_of_string_ipv4 eduroam_fw)" by eval

text\<open>The ruleset prevents spoofed incoming packets\<close>
lemma "no_spoofing_iface (Iface ''wlan0'')
        (map_of_ipassmt ipassignment_incoming) (unfold_ruleset_INPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw))" by eval

text\<open>Ruleset does not prevent that I'm spoofing (which is not necessary anyways since I need root right to spoof, which
      would also enable me to deactivate the firewall). This is only a one-user laptop!\<close>

lemma "transform_optimize_dnf_strict (unfold_ruleset_OUTPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)) =
        unfold_ruleset_OUTPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw)" by eval

lemma "\<not> no_spoofing_iface (Iface ''wlan0'')
        (map_of_ipassmt ipassignment_outgoing) (unfold_ruleset_OUTPUT eduroam_fw_INPUT_default_policy (map_of_string_ipv4 eduroam_fw))" by eval

end


theory Proof_3_500
  imports Proofs3
begin

theorem proof_3_500: "VC500 inv3 env s0 PdOut_value paid_value opened_value"
  apply(unfold VC500_def)
  apply simp
  apply(unfold inv3_def R3_def)
  apply(rule impI)
  apply(rule conjI)
   apply(rule conjI)
    apply simp
   apply(unfold extraInv_def)[1]
   apply(erule conjE)
   apply(erule conjE)
  subgoal premises vc_prems
    apply((rule allI)+)
    apply(rule impI)
    apply(simp split: if_splits)
    using vc_prems(1,3) substate_refl[of s0] apply blast
    using vc_prems(2) by auto


(*
 * Copyright 2022, Proofcraft Pty Ltd
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory Named_Eta_Test
imports Lib.Named_Eta
begin

experiment
begin

declare [[eta_contract=false]] (* for display only, it does not affect terms *)

(* tactical invocation example *)
schematic_goal
  "\<And>y. ?Q y False \<Longrightarrow> ?P y (\<lambda>x. f x)"
  apply (tactic \<open>named_eta_tac "x" @{context}\<close>)
  apply assumption
  done

(* method invocation example *)
schematic_goal
  "\<And>y. ?Q y False \<Longrightarrow> ?P y (\<lambda>x. f x)"
  apply (named_eta x)
  apply assumption
  done

lemma
  "P x (\<lambda>z. g (\<lambda>x. f x) z)"
  "\<And>P z. Q z \<Longrightarrow> P (\<lambda>x. f x)"
  apply -
  (* only affects one subgoal *)
  prefer 2
  apply (named_eta x)
  prefer 2
  (* only contract "z" *)
  apply (named_eta z)
  (* now only contract "x" *)
  apply (named_eta x)
  oops

lemma (* nested lambdas *)
  "\<lbrakk> X; P (\<lambda>x. (f (\<lambda>x. g y x))) \<rbrakk> \<Longrightarrow> P (\<lambda>x. (f (\<lambda>x. g y x)))"
  apply (named_eta x)
  apply assumption
  done

ML \<open>
  (* nameless abstractions: *)
  val t = Abs ("", @{typ bool}, @{term "f (\<lambda>x. g x) :: bool \<Rightarrow> bool"} $ Bound 0)
  val ct = Thm.cterm_of @{context} t
  (* contracts only the nameless "a" lambda: *)
  val thm = Named_Eta.named_eta_conv "" @{context} ct
\<close>

end

end


(*  Title:        Notions of Topology for C2KA
    Author:       Maxime Buyse <maxime.buyse at polytechnique.edu>, 2019
    Maintainers:  Maxime Buyse <maxime.buyse at polytechnique.edu> and Jason Jaskolka <jason.jaskolka at carleton.ca>
*)

section \<open>Notions of Topology for \CCKAabbrv \label{sec:topology}\<close>

text \<open>
Orbits, stabilisers, and fixed points are notions that allow us to perceive a kind of topology of a system
with respect to the stimulus-response relationships among system agents. In this context, the term ``topology''
is used to capture the relationships (influence) and connectedness via stimuli of the agents in a distributed
system. It intends to capture a kind of reachability in terms of the possible behaviours for a given agent.

A \CCKAabbrv consists of two semimodules~$\ActSemimodule$ and~$\OutSemimodule$ for which we have a
\leftAct{\stim}~$\lSact$ and a \rightAct{\cka}~$\rKact$. Therefore, there are two complementary notions of orbits,
stabilisers, and fixed points within the context of agent behaviours and stimuli, respectively. In this way, one
can use these notions to think about distributed systems from two different perspectives, namely the behavioural
perspective provided by the action of stimuli on agent behaviours described by~$\ActSemimodule$ and the external
event (stimulus) perspective provided by the action of agent behaviours on stimuli described by~$\OutSemimodule$.
In this section, only the treatment of these notions with respect to the \leftSemimodule{\stim}~$\ActSemimodule$
and agent behaviours is provided. The same notions for the \rightSemimodule{\cka}~$\OutSemimodule$ and stimuli
can be provided in a very similar way.

When discussing the interplay between \CCKAabbrv and the notions of orbits, stabilisers, and fixed points, the
partial order of sub-behaviours~$\CKAle$ is extended to sets in order to express sets of agent behaviours
encompassing one another. For two subsets of agent behaviours~$A,B \STleq \CKAset$, we say that~$A$
\emph{is encompassed by}~$B$ (or~$B$ \emph{encompasses}~$A$), written~$\CKAencompass{A}{B}$, if and only
if~$\biglnotation{\forall}{a}{a \in A}{\lnotation{\exists}{b}{b \in B}{a \CKAle b}}$. In essence,~$A \CKAenc B$
indicates that every behaviour contained within the set~$A$ is a sub-behaviour of at least one behaviour in the
set~$B$. The encompassing relation~$\STIMenc$ for stimuli can be defined similarly.

Throughout this section, let~$\ActSemimodule$ be the unitary and zero-preserving \leftSemimodule{\stim} of a
\CCKAabbrv and let~$a \in \CKAset$.
\<close>

theory Topology_C2KA
  imports C2KA
begin

no_notation
comp (infixl "\<circ>" 55)
and rtrancl ("(_\<^sup>*)" [1000] 999)

text \<open>
The locale \emph{topology-c2ka} extends the axiomatisation of \emph{c2ka} to support the notions of topology.
\<close>

locale topology_c2ka = c2ka +
  fixes orbit :: "'a::cka \<Rightarrow> 'a::cka set" ("Orb")
  and strong_orbit :: "'a::cka \<Rightarrow> 'a::cka set" ("Orb\<^sub>S")
  and stabiliser :: "'a::cka \<Rightarrow> 'b::stimuli set" ("Stab")
  and fixed :: "'a::cka \<Rightarrow> bool"
  and encompassing_relation_behaviours :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool"  (infix "\<lless>\<^sub>\<K>" 50)
  and encompassing_relation_stimuli :: "'b set \<Rightarrow> 'b set \<Rightarrow> bool"  (infix "\<lless>\<^sub>\<S>" 50)
  and induced :: "'a::cka \<Rightarrow> 'a::cka \<Rightarrow> bool" (infix "\<lhd>" 50)
  and orbit_equivalent :: "'a::cka \<Rightarrow> 'a::cka \<Rightarrow> bool" (infix "\<sim>\<^sub>\<K>" 50)
  assumes orb_def: "x \<in> Orb(a) \<longleftrightarrow> (\<exists>s. (s \<circ> a = x))"
  and orbs_def: "b \<in> Orb\<^sub>S(a) \<longleftrightarrow> Orb(b) = Orb(a)"
  and stab_def: "s \<in> Stab(a) \<longleftrightarrow> s \<circ> a = a"
  and fixed_def: "fixed(a) \<longleftrightarrow> (\<forall>s::'b. s\<noteq>\<dd> \<longrightarrow> s \<circ> a = a)"
  and erb_def: "A \<lless>\<^sub>\<K> B \<longleftrightarrow> (\<forall>a::'a. a \<in> A \<longrightarrow> (\<exists>b. b \<in> B \<and> a \<le>\<^sub>\<K> b))"
  and ers_def: "E \<lless>\<^sub>\<S> F \<longleftrightarrow> (\<forall>a::'b. a \<in> E \<longrightarrow> (\<exists>b. b \<in> F \<and> a \<le>\<^sub>\<S> b))"
  and induced_def: "a \<lhd> b \<longleftrightarrow> b \<in> Orb(a)"
  and orbit_equivalent_def: "a \<sim>\<^sub>\<K> b \<longleftrightarrow> Orb(a) = Orb(b)"
begin

subsection \<open>Orbits \label{sub:orbits}\<close>

text \<open>
The \emph{orbit} of~$a$ in~$\stim$ is the set given by~$\orb{a} = \sets{\lAct{a}{s}}{s \in \STIMset}$. The orbit of
an agent~$a \in \CKAset$ represents the set of all possible behavioural responses from an agent behaving as~$a$ to
any stimulus from~$\stim$. In this way, the orbit of a given agent can be perceived as the set of all possible
future behaviours for that agent.
\<close>

text \<open>
Lemma \emph{inf-K-enc-orb} provides an isotonicity law with respect to the orbits and the encompassing relation for agent behaviours.
\<close>

lemma inf_K_enc_orb: "a \<le>\<^sub>\<K> b \<Longrightarrow> Orb(a) \<lless>\<^sub>\<K> Orb(b)"
  unfolding erb_def orb_def
  using inf_K_next_behaviour by blast

text \<open>
The following lemmas provide a selection of properties regarding orbits and the encompassing relation for agent behaviours.
\<close>

lemma enc_orb_add: "Orb(a) \<lless>\<^sub>\<K> Orb(a + b)"
  using  inf_K_enc_orb inf_add_K_right by auto

lemma enc_orb_exchange: "Orb((a*b) ; (c*d)) \<lless>\<^sub>\<K> Orb((a;c) * (b;d))"
  using inf_K_enc_orb exchange_2 by blast

lemma enc_orb_seq_par: "Orb(a;b) \<lless>\<^sub>\<K> Orb(a*b)"
  using inf_K_enc_orb seq_inf_par by auto

lemma enc_orb_add_seq_par: "Orb(a;b + b;a) \<lless>\<^sub>\<K> Orb(a*b)"
  using inf_K_enc_orb add_seq_inf_par by auto

lemma enc_orb_parseq: "Orb((a*b);c) \<lless>\<^sub>\<K> Orb(a*(b;c))"
  using inf_K_enc_orb exchange_3 by blast

lemma enc_orb_seqpar: "Orb(a;(b*c)) \<lless>\<^sub>\<K> Orb((a;b)*c)"
  using inf_K_enc_orb exchange_4 by blast

lemma enc_orb_seqstar_parstar: "Orb(a\<^sup>;) \<lless>\<^sub>\<K> Orb(a\<^sup>*)"
  using inf_K_enc_orb seqstar_inf_parstar by auto

lemma enc_orb_union: "Orb(a) \<lless>\<^sub>\<K> Orb(c) \<and> Orb(b) \<lless>\<^sub>\<K> Orb(c)
\<longleftrightarrow> Orb(a) \<union> Orb(b) \<lless>\<^sub>\<K>  Orb(c)"
  unfolding erb_def
  by auto

subsection \<open>Stabilisers \label{sub:stabilisers}\<close>

text \<open>
The \emph{stabiliser} of~$a$ in~$\stim$ is the set given by~$\stab{a} = \sets{s \in \STIMset}{\lAct{a}{s} = a}$.
The stabiliser of an agent~$a \in \CKAset$ represents the set of stimuli which have no observable influence
(or act as neutral stimuli) on an agent behaving as~$a$.
\<close>

text \<open>
Lemma \emph{enc-stab-inter-add} provides a property regarding stabilisers and the encompassing relation for stimuli.
\<close>

lemma enc_stab_inter_add: "Stab(a) \<inter> Stab(b) \<lless>\<^sub>\<S> Stab(a + b)"
  unfolding ers_def
  by (auto simp add: stab_def, rename_tac s, rule_tac x="s" in exI, simp)

subsection \<open>Fixed Points \label{sub:fixed_points}\<close>

text \<open>
An element~$a \in \CKAset$ is called a \emph{fixed point} if~$\lnotation{\forall}{s}{s \in \STIMset \STdiff \set{\Dstim}}{\lAct{a}{s} = a}$.\linebreak
When an agent behaviour is a fixed point, it is not influenced by any stimulus other than the deactivation stimulus~$\Dstim$.
It is important to note that since~$\ActSemimodule$ is zero-preserving, every agent behaviour becomes inactive when subjected to the
deactivation stimulus~$\Dstim$. Because of this, we exclude this special case when discussing fixed point agent behaviours.
\<close>

lemma zerofix [simp]: "s \<circ> 0 = 0"
proof -
  have "0 = \<dd> \<circ> a" by simp
  hence "s \<circ> 0 = s \<circ> (\<dd> \<circ> a)" by simp
  hence "s \<circ> 0 = (s \<odot> \<dd>) \<circ> a" by (simp only: lsemimodule3 [symmetric])
  thus "s \<circ> 0 = 0" by simp
qed

text \<open>
The following lemmas provide a selection of properties regarding fixed agent behaviours.
\<close>

lemma fixed_zero: "fixed(0)"
  unfolding fixed_def
  by simp

lemma fixed_a_b_add: "fixed(a) \<and> fixed(b) \<longrightarrow> fixed(a + b)"
  unfolding fixed_def
  by simp

lemma fix_not_deactivation: "s \<circ> a = a \<and> \<lambda>(s,a) = \<dd> \<Longrightarrow> a = 0"
proof -
  assume E: "s \<circ> a = a \<and> \<lambda>(s,a) = \<dd>"
  hence "s \<circ> (a;1) = a" by simp
  hence "(s\<circ>a) ; (\<lambda>(s,a)\<circ>1) = a" by (simp only: cascadingaxiom)
  hence "0 = a" by (simp add: E)
  thus ?thesis by auto
qed

lemma fixed_a_b_seq: "fixed(a) \<and> fixed(b) \<longrightarrow> fixed(a ; b)"
  unfolding fixed_def
proof (rule impI)
  assume hyp: "(\<forall>s. s \<noteq> \<dd> \<longrightarrow> s \<circ> a = a) \<and> (\<forall>s. s \<noteq> \<dd> \<longrightarrow> s \<circ> b = b)"
  have C1: "(\<forall>s. \<lambda>(s,a) = \<dd> \<longrightarrow> s \<noteq> \<dd> \<longrightarrow> s \<circ> (a ; b) = a ; b)"
  proof -
    have E: "(\<forall>s. s \<noteq> \<dd> \<and> \<lambda>(s,a) = \<dd> \<longrightarrow> s \<circ> (a ; b) = 0)" by simp
    hence "(\<forall>s. s \<noteq> \<dd> \<and> \<lambda>(s,a) = \<dd> \<longrightarrow> s \<circ> a = a \<and> \<lambda>(s,a) = \<dd>)"
      by (simp add: hyp)
    moreover have "(\<forall>s. s \<circ> a = a \<and> \<lambda>(s,a) = \<dd> \<longrightarrow> a = 0)"
      by (simp add: fix_not_deactivation)
    ultimately have "(\<forall>s. s \<noteq> \<dd> \<and> \<lambda>(s,a) = \<dd> \<longrightarrow> a = 0)" by auto
    thus ?thesis by (auto simp add: E)
  qed
  moreover have C2: "(\<forall>s. \<lambda>(s,a) \<noteq> \<dd> \<longrightarrow> s \<noteq> \<dd> \<longrightarrow> s \<circ> (a ; b) = a ; b)"
    by (simp add: hyp)
  ultimately show "(\<forall>s. s \<noteq> \<dd> \<longrightarrow> s \<circ> (a ; b) = a ; b)" by blast
qed

subsection \<open>Strong Orbits and Induced Behaviours \label{sub:strong_orbits_and_induced_behaviours}\<close>

text \<open>
The \emph{strong orbit} of~$a$ in~$\stim$ is the set given by~$\orbS{a} = \sets{b \in \CKAset}{\orb{b} = \orb{a}}$.
Two agents are in the same strong orbit, denoted~$a \CKAsim b$ for~$a,b \in \CKAset$, if and only if their orbits are
identical. This is to say when~$a \CKAsim b$, if an agent behaving as~$a$ is influenced by a stimulus to behave as~$b$,
then there exists a stimulus which influences the agent, now behaving as~$b$, to revert back to its original behaviour~$a$.

The influence of stimuli on agent behaviours is called the \emph{induced behaviours} via stimuli. Let~$a,b \in \CKAset$
be agent behaviours with~$a \neq b$. We say that~$b$ is \emph{induced by~$a$ via stimuli} (denoted by~$\induced{b}{a}$)
if and only if~$\lnotation{\exists}{s}{s \in \STIMset}{\lAct{a}{s} = b}$. The notion of induced behaviours allows us to make
some predictions about the evolution of agent behaviours in a given system by providing some insight into how different agents
can respond to any stimuli.
\<close>

text \<open>
Lemma \emph{fixed-not-induce} states that if an agent has a fixed point behaviour, then it does not induce any agent behaviours via  stimuli besides the inactive behaviour~$0$.
\<close>

lemma fixed_not_induce: "fixed(a) \<longrightarrow> (\<forall>b. b \<noteq> 0 \<and> b \<noteq> a \<longrightarrow> \<not>(a \<lhd> b))"
proof -
  have "\<And>s. s = \<dd> \<or> s \<noteq> \<dd> \<Longrightarrow> (\<forall>t. t \<noteq> \<dd> \<longrightarrow> t \<circ> a = a) \<Longrightarrow> s \<circ> a \<noteq> 0
\<Longrightarrow> s \<circ> a \<noteq> a \<Longrightarrow> False"
    by (erule disjE, simp_all)
  hence "\<And>s. (\<forall>t. t \<noteq> \<dd> \<longrightarrow> t \<circ> a = a) \<Longrightarrow> s \<circ> a \<noteq> 0 \<Longrightarrow> s \<circ> a \<noteq> a \<Longrightarrow> False"
    by simp
  thus ?thesis
    unfolding fixed_def induced_def orb_def
    by auto
qed

text \<open>
Lemma \emph{strong-orbit-both-induced} states that all agent behaviours which belong to the same strong orbit are mutually induced via some (possibly different) stimuli.
This is to say that if two agent behaviours are in the same strong orbit, then there exists inverse stimuli for each agent behaviour in a
strong orbit allowing an agent to revert back to its previous behaviour.
\<close>

lemma in_own_orbit: "a \<in> Orb(a)"
  unfolding orb_def
  by (rule_tac x="\<nn>" in exI, simp)

lemma strong_orbit_both_induced: "a \<sim>\<^sub>\<K> b \<longrightarrow> a \<lhd> b \<and> b \<lhd> a"
  unfolding orbit_equivalent_def induced_def
  by (blast intro: in_own_orbit)

text \<open>
Lemma \emph{strong-orbit-induce-same} states that if two agent behaviours are in the same strong orbit, then a third behaviour can be induced via  stimuli by either of
the behaviours within the strong orbit. This is to say that each behaviour in a strong orbit can induce the same set of behaviours
(perhaps via different stimuli).
\<close>

end

end


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

(* License: BSD, terms see file ./LICENSE *)

theory SepTactic
imports SepInv
begin

section "sep_point_tac"

definition sep_conj_extract :: "heap_assert \<Rightarrow> heap_assert" where
  "sep_conj_extract \<equiv> id"

definition sep_points :: "heap_assert \<Rightarrow> heap_assert" where
  "sep_points P \<equiv> P \<and>\<^sup>* sep_true"

lemma sep_conj_extract1D:
  "(P \<and>\<^sup>* Q) s \<Longrightarrow> sep_conj_extract (P \<and>\<^sup>* Q) s"
  by (simp add: sep_conj_extract_def)

lemma sep_conj_extract2D:
  "sep_conj_extract P s \<Longrightarrow> P s \<and> (sep_conj_extract P \<and>\<^sup>* sep_true) s"
  by (auto simp: sep_conj_extract_def elim: sep_conj_sep_true)

lemma sep_conj_extract_assoc:
  "sep_conj_extract ((P \<and>\<^sup>* Q) \<and>\<^sup>* R) = sep_conj_extract (P \<and>\<^sup>* (Q \<and>\<^sup>* R))"
  by (simp add: sep_conj_ac)

lemma sep_conj_extract_decomposeD:
  "(sep_conj_extract (P \<and>\<^sup>* Q) \<and>\<^sup>* sep_true) s \<Longrightarrow> sep_points P s \<and>
      (sep_conj_extract Q \<and>\<^sup>* sep_true) s"
  apply (rule conjI)
   apply(simp add: sep_conj_extract_def sep_points_def sep_conj_ac)
   apply(erule (1) sep_conj_impl, simp)
  apply(simp add: sep_conj_extract_def sep_conj_ac)
  apply(subst (asm) sep_conj_assoc [symmetric])
  apply(subst (asm) sep_conj_com)
  apply(subst (asm) sep_conj_assoc)
  apply(erule (1) sep_conj_impl)
  apply simp
  done

lemma sep_conj_extract_decomposeD2:
  "(sep_conj_extract P \<and>\<^sup>* sep_true) s \<Longrightarrow> sep_points P s"
  by (simp add: sep_conj_extract_def sep_points_def)

lemma sep_point_mapD:
  "sep_points (p \<mapsto>\<^sup>i\<^sub>g v) s \<Longrightarrow> (p \<hookrightarrow>\<^sup>i\<^sub>g v) s"
  by (simp add: sep_points_def sep_map_inv_def sep_map'_inv_def sep_map'_def
                sep_conj_ac)

lemma sep_point_map_excD:
  "sep_points (p \<mapsto>\<^sub>g v) s \<Longrightarrow> (p \<hookrightarrow>\<^sub>g v) s"
  by (simp add: sep_points_def sep_map'_def)

lemma sep_point_otherD:
  "sep_points P s \<Longrightarrow> True"
  by (rule TrueI)

ML \<open>

val sep_point_ds = [@{thm sep_point_mapD}, @{thm sep_point_map_excD}]

fun sep_point_tacs ds ctxt  = [
    REPEAT1 (dresolve_tac ctxt [@{thm sep_conj_extract1D}] 1),
    REPEAT1 (dresolve_tac ctxt [@{thm sep_conj_extract2D}] 1),
    clarify_tac ctxt 1,
    TRY (full_simp_tac (put_simpset HOL_ss ctxt addsimps
        [@{thm sep_conj_extract_assoc}]) 1),
    REPEAT (dresolve_tac ctxt [@{thm sep_conj_extract_decomposeD},
        @{thm sep_conj_extract_decomposeD2}] 1 THEN
        clarify_tac ctxt 1),
    TRY (full_simp_tac ctxt 1),
    REPEAT (dresolve_tac ctxt (sep_point_ds@ds) 1),
    REPEAT (dresolve_tac ctxt [@{thm sep_point_otherD}] 1),
    TRY (full_simp_tac ctxt 1)
  ]

fun sep_point_tac ds ctxt = EVERY (sep_point_tacs ds ctxt)
\<close>

method_setup sep_point_tac =
  "Attrib.thms >> (fn thms => Method.SIMPLE_METHOD o sep_point_tac thms)"
  "extract points-to facts from separation assertions in assumptions"

lemma "(P \<and>\<^sup>* p \<mapsto>\<^sub>g v \<and>\<^sup>* Q) s \<Longrightarrow> (p \<hookrightarrow>\<^bsub>g\<^esub> v) s"
  by sep_point_tac

section "sep_exists_tac"

ML\<open>
fun sep_exists_tac ctxt = full_simp_tac
    (put_simpset HOL_ss ctxt addsimps [@{thm "sep_conj_exists1"}, @{thm "sep_conj_exists2"}])
\<close>

method_setup sep_exists_tac =
  "Scan.succeed (Method.SIMPLE_METHOD' o sep_exists_tac)"
  "push existentials inside separation assertions to the outside"

lemma "(P \<and>\<^sup>* (\<lambda>s. (\<exists>x. Q x s))) s \<Longrightarrow> \<exists>x. (P \<and>\<^sup>* Q x) s"
  by sep_exists_tac

section "sep_select_tac"

definition sep_mark :: "heap_assert \<Rightarrow> heap_assert" where
  "sep_mark \<equiv> id"

definition sep_mark2 :: "heap_assert \<Rightarrow> heap_assert" where
  "sep_mark2 \<equiv> id"

lemma sep_mark2_id:
  "sep_mark2 P = P"
  by (simp add: sep_mark2_def)

lemma sep_markI:
  "(\<box> \<and>\<^sup>* sep_mark (P \<and>\<^sup>* Q)) s \<Longrightarrow> (P \<and>\<^sup>* Q) s"
  by (simp add: sep_mark_def sep_conj_empty)

lemma sep_mark_match:
  "(R \<and>\<^sup>* sep_mark2 P \<and>\<^sup>* Q) s \<Longrightarrow> (R \<and>\<^sup>* sep_mark (P \<and>\<^sup>* Q)) s"
  by (simp add: sep_mark_def sep_mark2_def)

lemma sep_mark_match2:
  "(R \<and>\<^sup>* sep_mark2 P) s \<Longrightarrow> (R \<and>\<^sup>* sep_mark P) s"
  by (simp add: sep_mark_def sep_mark2_def)

lemma sep_mark_mismatch:
  "((R \<and>\<^sup>* P) \<and>\<^sup>* sep_mark Q) s \<Longrightarrow> (R \<and>\<^sup>* sep_mark (P \<and>\<^sup>* Q)) s"
  by (simp add: sep_mark_def sep_conj_ac)

lemma sep_mark_mismatch2:
  "(R \<and>\<^sup>* P) s \<Longrightarrow> (R \<and>\<^sup>* sep_mark P) s"
  by (simp add: sep_mark_def)

lemma sep_emp_rem:
  "P s \<Longrightarrow> (\<box> \<and>\<^sup>* P) s"
  by (simp add: sep_conj_empty)

lemma sep_mark2_left:
  "(P \<and>\<^sup>* (sep_mark2 Q \<and>\<^sup>* R)) = (sep_mark2 Q \<and>\<^sup>* (P \<and>\<^sup>* R))"
  by (rule sep_conj_left_com)

lemma sep_mark2_left2:
  "(P \<and>\<^sup>* sep_mark2 Q) = (sep_mark2 Q \<and>\<^sup>* P)"
  by (rule sep_conj_com)

ML \<open>

(* Replace all occurrences of an underscore that does not have an alphanumeric
   on either side of it *)
local
  val dummy_char = #" ";
  fun get_next (x::_) = x
    | get_next [] = dummy_char;
  fun nth_id n = "SEPTAC"^(Int.toString n);

  fun ok_char c = not (Char.isAlphaNum c);

  fun can_replace (prev,cur,last) =
        (ok_char prev) andalso (cur = #"_") andalso (ok_char last);

  fun replace_usc n prev_char (x::xs) =
      let val (xs', ys) = replace_usc (n+1) x xs
      in
        if can_replace (prev_char,x,get_next xs)
        then (nth_id n::xs', nth_id n::ys)
        else (String.str x::xs', ys)
      end
    | replace_usc _ _ [] = ([],[])
in
  val rusc = apfst String.concat o replace_usc 0 dummy_char o String.explode
end;

(* some tests *)
rusc "(_ +\<^sub>p _) \<mapsto> _";
rusc "_ \<mapsto>\<^sub>_ _";
rusc "_";
rusc "_ O_o _"
\<close>

ML\<open>

fun sep_select_tacs s ctxt  =
  let val (str, vars) = rusc s
      val subst = [((Lexicon.read_indexname "P", Position.none), str)]
      val fixes = map (fn v => (Binding.name v, NONE, Mixfix.NoSyn)) vars
  in
  [
    TRY (simp_tac (put_simpset HOL_ss ctxt addsimps [@{thm sep_conj_assoc}]) 1),
    resolve_tac ctxt [@{thm sep_markI}] 1,
    REPEAT (Rule_Insts.res_inst_tac ctxt subst fixes @{thm sep_mark_match} 1 ORELSE
      (Rule_Insts.res_inst_tac ctxt subst fixes @{thm sep_mark_match2} 1 ORELSE
      resolve_tac ctxt [@{thm sep_mark_mismatch}] 1 ORELSE
      resolve_tac ctxt [@{thm sep_mark_mismatch2}] 1)),
    TRY (simp_tac (put_simpset HOL_ss ctxt addsimps [@{thm sep_conj_assoc}]) 1),
    resolve_tac ctxt [@{thm sep_emp_rem}] 1,
    TRY (simp_tac (put_simpset HOL_ss ctxt addsimps [@{thm sep_mark2_left},
      @{thm sep_mark2_left2}]) 1),
    TRY (simp_tac (put_simpset HOL_ss ctxt addsimps [@{thm sep_mark2_id}]) 1)
  ]
  end

fun sep_select_tac s ctxt = SELECT_GOAL (EVERY (sep_select_tacs s ctxt))

fun lift_parser p (ctxt,ts) =
  let val (r, ts') = p ts
  in (r, (ctxt,ts')) end
\<close>

method_setup sep_select_tac =
  \<open>lift_parser Args.name >> (fn s => Method.SIMPLE_METHOD' o sep_select_tac s)\<close>
  "takes a target conjunct in the goal and reorders it to the front"

lemma
  "\<And>R x f n. ((P::heap_assert) \<and>\<^sup>* fac x n \<and>\<^sup>* R (f x)) s"
  apply(sep_select_tac "fac _ _")
  apply(sep_select_tac "R _")
  apply(sep_select_tac "fac x _")
  apply(sep_select_tac "R _")
  oops

lemma
  "((P::heap_assert) \<and>\<^sup>* fac x n) s"
  apply(sep_select_tac "fac _ _")
  oops

lemma
  "((P::heap_assert) \<and>\<^sup>* long_name) s"
  apply(sep_select_tac "long_name")
  oops

consts c_guard :: "'a::c_type ptr_guard"

lemma sep_heap_update'_hrs:
  "(c_guard \<turnstile>\<^sub>s\<^sup>i p \<and>\<^sup>* (p \<mapsto>\<^sup>i\<^sub>c_guard v \<longrightarrow>\<^sup>* P)) (lift_state s) \<Longrightarrow>
      P (lift_state (hrs_mem_update (heap_update p (v::'a::mem_type)) s))"
  by (case_tac s)
     (simp add: hrs_mem_update_def, erule sep_heap_update')

lemma sep_map_lift_wp_hrs:
  "\<lbrakk> \<exists>v. (p \<mapsto>\<^sup>i\<^sub>c_guard v \<and>\<^sup>* (p \<mapsto>\<^sup>i\<^sub>c_guard v \<longrightarrow>\<^sup>* P v)) (lift_state s) \<rbrakk>
      \<Longrightarrow> P (lift (hrs_mem s) (p::'a::mem_type ptr)) (lift_state s)"
  by (case_tac s)
     (simp add: hrs_mem_def, erule sep_map_lift_wp)

lemma ptr_retyp_sep_cut'_wp_hrs:
  "\<lbrakk> (sep_cut' (ptr_val p) (size_of TYPE('a)) \<and>\<^sup>* (c_guard \<turnstile>\<^sub>s\<^sup>i p \<longrightarrow>\<^sup>* P))
      (lift_state s); c_guard (p::'a::mem_type ptr) \<rbrakk>
      \<Longrightarrow> P (lift_state (hrs_htd_update (ptr_retyp p) s))"
  by (case_tac s)
     (simp add: hrs_htd_update_def, erule (1) ptr_retyp_sep_cut'_wp)

ML \<open>

fun destruct bs (Bound n)      = Free (List.nth (bs,n))
  | destruct bs (Abs (s,ty,t)) = destruct ((s,ty)::bs) t
  | destruct bs (l$r)          = destruct bs l $ destruct bs r
  | destruct _  x              = x

fun schems (Abs (_,_,t)) = schems t
  | schems (l$r)         = schems l + schems r
  | schems (Var _)       = 1
  | schems _             = 0

fun hrs_mem_update (Const (@{const_name "HeapRawState.hrs_mem_update"},_)$_$s) = SOME s
  | hrs_mem_update _                                             = NONE

fun hrs_htd_update (Const (@{const_name "HeapRawState.hrs_htd_update"},_)$_$s) = SOME s
  | hrs_htd_update _                                             = NONE

fun lift_state_arg _   _  (Const (@{const_name "TypHeap.lift_state"},_)$s) = SOME s
  | lift_state_arg thy nc (l$r)                              =
        (case lift_state_arg thy nc r of
          SOME s => if nc orelse hrs_mem_update s <> NONE orelse
                        hrs_htd_update s <> NONE then SOME s
                        else lift_state_arg thy nc l
         | NONE   => lift_state_arg thy nc l)
  | lift_state_arg thy nc (Abs (_,_,t))                      =
        lift_state_arg thy nc t
  | lift_state_arg _ _ _ =
        NONE (*error (Sign.string_of_term thy s)*)

fun term_of_thm thm = Thm.term_of (Thm.cprop_of thm)

fun lift_tac ctxt s old_schems =
  Rule_Insts.res_inst_tac ctxt [((Lexicon.read_indexname "s",Position.none),s)] [] @{thm sep_map_lift_wp_hrs} 1 THEN
  (fn thm => if schems (term_of_thm thm) = old_schems then all_tac thm
                 else no_tac thm)

fun heap_update_tac ctxt s =
  Rule_Insts.res_inst_tac ctxt [((Lexicon.read_indexname "s",Position.none),s)] [] @{thm sep_heap_update'_hrs} 1

fun ptr_retyp_tac ctxt s =
  Rule_Insts.res_inst_tac ctxt [((Lexicon.read_indexname "s",Position.none),s)] [] @{thm ptr_retyp_sep_cut'_wp_hrs} 1

fun sep_wp_step_tac' ctxt lift_only s old_schems = let
  fun prt s = (
    case s of
        Free (a, _) => a
      | _ => raise TERM ("Not a free variable",[s]))
  val state = prt s
  val step = case hrs_mem_update s of
               SOME s => heap_update_tac ctxt (prt s)
             | NONE => case hrs_htd_update s of
                         SOME s => ptr_retyp_tac ctxt (prt s)
                       | NONE => no_tac
in
  TRY (lift_tac ctxt state old_schems) THEN (if lift_only then all_tac else step)
end

fun sep_wp_step_tac ctxt lift_only thm = let
  val t = term_of_thm thm
  val thy = Proof_Context.theory_of ctxt
  val old_schems = schems t
  val s = lift_state_arg thy lift_only (destruct [] t)
in
  (case s of
    SOME state => sep_wp_step_tac' ctxt lift_only state old_schems
   | NONE => no_tac) thm
end

fun sep_wp_tac ctxt = (REPEAT (sep_wp_step_tac ctxt false)) THEN sep_wp_step_tac ctxt true

\<close>

method_setup sep_wp_tac =
  "Scan.succeed (Method.SIMPLE_METHOD o sep_wp_tac)"
  "apply WP separation logic rules to goal"

(* see testfiles/sep_example_pre_list.thy for a more detailed example *)
lemma
  "((\<lambda>z. lift (hrs_mem s) (p::(32 word) ptr) + 1 = 2) \<and>\<^sup>* P) (lift_state s)"
  apply sep_wp_tac
  oops

end


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

  Project: Development of Security Protocols by Refinement

  Module:  Refinement/Runs.thy (Isabelle/HOL 2016-1)
  ID:      $Id: Runs.thy 132773 2016-12-09 15:30:22Z csprenge $
  Author:  Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>

  Protocol runs: local state of executing protocol roles

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

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

section \<open>Protocol runs\<close>

theory Runs imports Atoms
begin

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

text \<open>Define some typical roles.\<close>

datatype role_t = Init | Resp | Serv

fun
  roleIdx :: "role_t \<Rightarrow> nat"
where
  "roleIdx Init = 0"
| "roleIdx Resp = 1"
| "roleIdx Serv = 2"

text \<open>The type of runs is a partial function from run identifiers to
a triple consisting of a role, a list of agents, and a list of atomic messages
recorded during the run's execution.

The type of roles could be made a parameter for more flexibility.\<close>

type_synonym
  rid_t = "fid_t"

type_synonym
  runs_t = "rid_t \<rightharpoonup> role_t \<times> agent list \<times> atom list"

subsection \<open>Run abstraction\<close>
(******************************************************************************)

text \<open>Define a function that lifts a function on roles and atom lists
to a function on runs.\<close>

definition
  map_runs :: "([role_t, atom list] \<Rightarrow> atom list) \<Rightarrow> runs_t \<Rightarrow> runs_t"
where
  "map_runs h runz rid \<equiv> case runz rid of
     None \<Rightarrow> None
   | Some (rol, agts, al) \<Rightarrow> Some (rol, agts, h rol al)"

lemma map_runs_empty [simp]: "map_runs h Map.empty = Map.empty"
by (rule ext) (auto simp add: map_runs_def)

lemma map_runs_dom [simp]: "dom (map_runs h runz) = dom runz"
by (auto simp add: map_runs_def split: option.split_asm)

lemma map_runs_update [simp]:
  "map_runs h (runz(R \<mapsto> (rol, agts, al)))
   = (map_runs h runz)(R \<mapsto> (rol, agts, h rol al))"
by (auto simp add: map_runs_def)

end


theory ArityAnalysisImpl
imports ArityAnalysisFix ArityAnalysisPreImpl
begin

definition Real_Aexp where "Real_Aexp = ArityAnalysisPreImpl.Aexp ArityAnalysis.Afix"

lemma heap_exp_are_smaller:  "e \<in> snd ` set \<Gamma> \<Longrightarrow> size e \<le> size_list (\<lambda>p. size (snd p)) \<Gamma>"
  by (metis (mono_tags) imageE order_refl size_list_estimation')

interpretation ArityAnalysisPreImpl ArityAnalysis.Afix where "Aexp = ArityAnalysisImpl.Real_Aexp"
  unfolding Real_Aexp_def atomize_conj
  apply (rule conjI[OF _ refl])
  apply default
  apply (perm_simp, rule)
  apply (rule ArityAnalysisFix.Afix_cong)
  apply (metis heap_exp_are_smaller)
  apply assumption
  done

interpretation ArityAnalysis Aexp.

lemma Aexp_edom': "edom (Aexp e\<cdot>a) \<subseteq> fv e"
  by (nominal_induct arbitrary: a rule: exp_strong_induct) fastforce+

end


section \<open>Final Instantiation of Algorithms Related to Complementation\<close>

theory Complementation_Final
imports
  "Complementation_Implement"
  "Formula"
  "Transition_Systems_and_Automata.NBA_Translate"
  "Transition_Systems_and_Automata.NGBA_Algorithms"
  "HOL-Library.Multiset"
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)

  subsection \<open>Hashcodes on Complement States\<close>

  definition "hci k \<equiv> uint32_of_nat k * 1103515245 + 12345"
  definition "hc \<equiv> \<lambda> (p, q, b). hci p + hci q * 31 + (if b then 1 else 0)"
  definition "list_hash xs \<equiv> fold (xor \<circ> hc) xs 0"

  lemma list_hash_eq:
    assumes "distinct xs" "distinct ys" "set xs = set ys"
    shows "list_hash xs = list_hash ys"
  proof -
    have "mset (remdups xs) = mset (remdups ys)" using assms(3)
      using set_eq_iff_mset_remdups_eq by blast
    then have "mset xs = mset ys" using assms(1, 2) by (simp add: distinct_remdups_id)
    have "fold (xor \<circ> hc) xs = fold (xor \<circ> hc) ys"
      apply (rule fold_multiset_equiv)
       apply (simp_all add: fun_eq_iff ac_simps)
      using \<open>mset xs = mset ys\<close> .
    then show ?thesis unfolding list_hash_def by simp
  qed

  definition state_hash :: "nat \<Rightarrow> Complementation_Implement.state \<Rightarrow> nat" where
    "state_hash n p \<equiv> nat_of_hashcode (list_hash p) mod n"

  lemma state_hash_bounded_hashcode[autoref_ga_rules]: "is_bounded_hashcode state_rel
    (gen_equals (Gen_Map.gen_ball (foldli \<circ> list_map_to_list)) (list_map_lookup (=))
    (prod_eq (=) (\<longleftrightarrow>))) state_hash"
  proof
    show [param]: "(gen_equals (Gen_Map.gen_ball (foldli \<circ> list_map_to_list)) (list_map_lookup (=))
      (prod_eq (=) (\<longleftrightarrow>)), (=)) \<in> state_rel \<rightarrow> state_rel \<rightarrow> bool_rel" by autoref
    show "state_hash n xs = state_hash n ys" if "xs \<in> Domain state_rel" "ys \<in> Domain state_rel"
      "gen_equals (Gen_Map.gen_ball (foldli \<circ> list_map_to_list))
      (list_map_lookup (=)) (prod_eq (=) (=)) xs ys" for xs ys n
    proof -
      have 1: "distinct (map fst xs)" "distinct (map fst ys)"
        using that(1, 2) unfolding list_map_rel_def list_map_invar_def by (auto simp: in_br_conv)
      have 2: "distinct xs" "distinct ys" using 1 by (auto intro: distinct_mapI)
      have 3: "(xs, map_of xs) \<in> state_rel" "(ys, map_of ys) \<in> state_rel"
        using 1 unfolding list_map_rel_def list_map_invar_def by (auto simp: in_br_conv)
      have 4: "(gen_equals (Gen_Map.gen_ball (foldli \<circ> list_map_to_list)) (list_map_lookup (=))
        (prod_eq (=) (\<longleftrightarrow>)) xs ys, map_of xs = map_of ys) \<in> bool_rel" using 3 by parametricity
      have 5: "map_to_set (map_of xs) = map_to_set (map_of ys)" using that(3) 4 by simp
      have 6: "set xs = set ys" using map_to_set_map_of 1 5 by blast
      show "state_hash n xs = state_hash n ys" unfolding state_hash_def using list_hash_eq 2 6 by metis
    qed
    show "state_hash n x < n" if "1 < n" for n x using that unfolding state_hash_def by simp
  qed

  subsection \<open>Complementation\<close>

  schematic_goal complement_impl:
    assumes [simp]: "finite (NBA.nodes A)"
    assumes [autoref_rules]: "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(?f :: ?'c, op_translate (complement_4 A)) \<in> ?R"
    by (autoref_monadic (plain))
  concrete_definition complement_impl uses complement_impl

  theorem complement_impl_correct:
    assumes "finite (NBA.nodes A)"
    assumes "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "NBA.language (nbae_nba (nbaei_nbae (complement_impl Ai))) =
      streams (nba.alphabet A) - NBA.language A"
    using op_translate_language[OF complement_impl.refine[OF assms]]
    using complement_4_correct[OF assms(1)]
    by simp

  subsection \<open>Language Subset\<close>

  definition [simp]: "op_language_subset A B \<equiv> NBA.language A \<subseteq> NBA.language B"

  lemmas [autoref_op_pat] = op_language_subset_def[symmetric]

  schematic_goal language_subset_impl:
    assumes [simp]: "finite (NBA.nodes B)"
    assumes [autoref_rules]: "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    assumes [autoref_rules]: "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(?f :: ?'c, do {
      let AB' = intersect' A (complement_4 B);
      ASSERT (finite (NGBA.nodes AB'));
      RETURN (NGBA.language AB' = {})
    }) \<in> ?R"
		by (autoref_monadic (plain))
  concrete_definition language_subset_impl uses language_subset_impl
  lemma language_subset_impl_refine[autoref_rules]:
    assumes "SIDE_PRECOND (finite (NBA.nodes A))"
    assumes "SIDE_PRECOND (finite (NBA.nodes B))"
    assumes "SIDE_PRECOND (nba.alphabet A \<subseteq> nba.alphabet B)"
    assumes "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    assumes "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(language_subset_impl Ai Bi, (OP op_language_subset :::
      \<langle>Id, nat_rel\<rangle> nbai_nba_rel \<rightarrow> \<langle>Id, nat_rel\<rangle> nbai_nba_rel \<rightarrow> bool_rel) $ A $ B) \<in> bool_rel"
  proof -
    have "(RETURN (language_subset_impl Ai Bi), do {
      let AB' = intersect' A (complement_4 B);
      ASSERT (finite (NGBA.nodes AB'));
      RETURN (NGBA.language AB' = {})
    }) \<in> \<langle>bool_rel\<rangle> nres_rel"
      using language_subset_impl.refine assms(2, 4, 5) unfolding autoref_tag_defs by this
    also have "(do {
      let AB' = intersect' A (complement_4 B);
      ASSERT (finite (NGBA.nodes AB'));
      RETURN (NGBA.language AB' = {})
    }, RETURN (NBA.language A \<subseteq> NBA.language B)) \<in> \<langle>bool_rel\<rangle> nres_rel"
    proof refine_vcg
      show "finite (NGBA.nodes (intersect' A (complement_4 B)))" using assms(1, 2) by auto
      have 1: "NBA.language A \<subseteq> streams (nba.alphabet B)"
        using nba.language_alphabet streams_mono2 assms(3) unfolding autoref_tag_defs by blast
      have 2: "NBA.language (complement_4 B) = streams (nba.alphabet B) - NBA.language B"
        using complement_4_correct assms(2) by auto
      show "(NGBA.language (intersect' A (complement_4 B)) = {},
        NBA.language A \<subseteq> NBA.language B) \<in> bool_rel" using 1 2 by auto
    qed
    finally show ?thesis using RETURN_nres_relD unfolding nres_rel_comp by force
  qed

  subsection \<open>Language Equality\<close>

  definition [simp]: "op_language_equal A B \<equiv> NBA.language A = NBA.language B"

  lemmas [autoref_op_pat] = op_language_equal_def[symmetric]

  schematic_goal language_equal_impl:
    assumes [simp]: "finite (NBA.nodes A)"
    assumes [simp]: "finite (NBA.nodes B)"
    assumes [simp]: "nba.alphabet A = nba.alphabet B"
    assumes [autoref_rules]: "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    assumes [autoref_rules]: "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(?f :: ?'c, NBA.language A \<subseteq> NBA.language B \<and> NBA.language B \<subseteq> NBA.language A) \<in> ?R"
    by autoref
  concrete_definition language_equal_impl uses language_equal_impl
  lemma language_equal_impl_refine[autoref_rules]:
    assumes "SIDE_PRECOND (finite (NBA.nodes A))"
    assumes "SIDE_PRECOND (finite (NBA.nodes B))"
    assumes "SIDE_PRECOND (nba.alphabet A = nba.alphabet B)"
    assumes "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    assumes "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(language_equal_impl Ai Bi, (OP op_language_equal :::
      \<langle>Id, nat_rel\<rangle> nbai_nba_rel \<rightarrow> \<langle>Id, nat_rel\<rangle> nbai_nba_rel \<rightarrow> bool_rel) $ A $ B) \<in> bool_rel"
    using language_equal_impl.refine[OF assms[unfolded autoref_tag_defs]] by auto

  schematic_goal product_impl:
    assumes [simp]: "finite (NBA.nodes B)"
    assumes [autoref_rules]: "(Ai, A) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    assumes [autoref_rules]: "(Bi, B) \<in> \<langle>Id, nat_rel\<rangle> nbai_nba_rel"
    shows "(?f :: ?'c, do {
      let AB' = intersect A (complement_4 B);
      ASSERT (finite (NBA.nodes AB'));
      op_translate AB'
    }) \<in> ?R"
		by (autoref_monadic (plain))
  concrete_definition product_impl uses product_impl

  (* TODO: possible optimizations:
    - introduce op_map_map operation for maps instead of manually iterating via FOREACH
    - consolidate various binds and maps in expand_map_get_7 *)
  export_code
    Set.empty Set.insert Set.member
    "Inf :: 'a set set \<Rightarrow> 'a set" "Sup :: 'a set set \<Rightarrow> 'a set" image Pow set
    nat_of_integer integer_of_nat
    Variable Negation Conjunction Disjunction satisfies map_formula
    nbaei alphabetei initialei transitionei acceptingei
    nbae_nba_impl complement_impl language_equal_impl product_impl
    in SML module_name Complementation file_prefix Complementation

end


(*  Title:      HOL/HOLCF/IOA/meta_theory/CompoScheds.thy
    Author:     Olaf Müller
*)

section {* Compositionality on Schedule level *}

theory CompoScheds
imports CompoExecs
begin

definition
  mkex2 :: "('a,'s)ioa => ('a,'t)ioa => 'a Seq ->
              ('a,'s)pairs -> ('a,'t)pairs ->
              ('s => 't => ('a,'s*'t)pairs)" where
  "mkex2 A B = (fix$(LAM h sch exA exB. (%s t. case sch of
       nil => nil
    | x##xs =>
      (case x of
        UU => UU
      | Def y =>
         (if y:act A then
             (if y:act B then
                (case HD$exA of
                   UU => UU
                 | Def a => (case HD$exB of
                              UU => UU
                            | Def b =>
                   (y,(snd a,snd b))>>
                     (h$xs$(TL$exA)$(TL$exB)) (snd a) (snd b)))
              else
                (case HD$exA of
                   UU => UU
                 | Def a =>
                   (y,(snd a,t))>>(h$xs$(TL$exA)$exB) (snd a) t)
              )
          else
             (if y:act B then
                (case HD$exB of
                   UU => UU
                 | Def b =>
                   (y,(s,snd b))>>(h$xs$exA$(TL$exB)) s (snd b))
             else
               UU
             )
         )
       ))))"

definition
  mkex :: "('a,'s)ioa => ('a,'t)ioa => 'a Seq =>
              ('a,'s)execution => ('a,'t)execution =>('a,'s*'t)execution" where
  "mkex A B sch exA exB =
       ((fst exA,fst exB),
        (mkex2 A B$sch$(snd exA)$(snd exB)) (fst exA) (fst exB))"

definition
  par_scheds ::"['a schedule_module,'a schedule_module] => 'a schedule_module" where
  "par_scheds SchedsA SchedsB =
      (let schA = fst SchedsA; sigA = snd SchedsA;
           schB = fst SchedsB; sigB = snd SchedsB
       in
       (    {sch. Filter (%a. a:actions sigA)$sch : schA}
        Int {sch. Filter (%a. a:actions sigB)$sch : schB}
        Int {sch. Forall (%x. x:(actions sigA Un actions sigB)) sch},
        asig_comp sigA sigB))"

subsection "mkex rewrite rules"

lemma mkex2_unfold:
"mkex2 A B = (LAM sch exA exB. (%s t. case sch of
      nil => nil
   | x##xs =>
     (case x of
       UU => UU
     | Def y =>
        (if y:act A then
            (if y:act B then
               (case HD$exA of
                  UU => UU
                | Def a => (case HD$exB of
                             UU => UU
                           | Def b =>
                  (y,(snd a,snd b))>>
                    (mkex2 A B$xs$(TL$exA)$(TL$exB)) (snd a) (snd b)))
             else
               (case HD$exA of
                  UU => UU
                | Def a =>
                  (y,(snd a,t))>>(mkex2 A B$xs$(TL$exA)$exB) (snd a) t)
             )
         else
            (if y:act B then
               (case HD$exB of
                  UU => UU
                | Def b =>
                  (y,(s,snd b))>>(mkex2 A B$xs$exA$(TL$exB)) s (snd b))
            else
              UU
            )
        )
      )))"
apply (rule trans)
apply (rule fix_eq2)
apply (simp only: mkex2_def)
apply (rule beta_cfun)
apply simp
done

lemma mkex2_UU: "(mkex2 A B$UU$exA$exB) s t = UU"
apply (subst mkex2_unfold)
apply simp
done

lemma mkex2_nil: "(mkex2 A B$nil$exA$exB) s t= nil"
apply (subst mkex2_unfold)
apply simp
done

lemma mkex2_cons_1: "[| x:act A; x~:act B; HD$exA=Def a|]
    ==> (mkex2 A B$(x>>sch)$exA$exB) s t =
        (x,snd a,t) >> (mkex2 A B$sch$(TL$exA)$exB) (snd a) t"
apply (rule trans)
apply (subst mkex2_unfold)
apply (simp add: Consq_def If_and_if)
apply (simp add: Consq_def)
done

lemma mkex2_cons_2: "[| x~:act A; x:act B; HD$exB=Def b|]
    ==> (mkex2 A B$(x>>sch)$exA$exB) s t =
        (x,s,snd b) >> (mkex2 A B$sch$exA$(TL$exB)) s (snd b)"
apply (rule trans)
apply (subst mkex2_unfold)
apply (simp add: Consq_def If_and_if)
apply (simp add: Consq_def)
done

lemma mkex2_cons_3: "[| x:act A; x:act B; HD$exA=Def a;HD$exB=Def b|]
    ==> (mkex2 A B$(x>>sch)$exA$exB) s t =
         (x,snd a,snd b) >>
            (mkex2 A B$sch$(TL$exA)$(TL$exB)) (snd a) (snd b)"
apply (rule trans)
apply (subst mkex2_unfold)
apply (simp add: Consq_def If_and_if)
apply (simp add: Consq_def)
done

declare mkex2_UU [simp] mkex2_nil [simp] mkex2_cons_1 [simp]
  mkex2_cons_2 [simp] mkex2_cons_3 [simp]

subsection {* mkex *}

lemma mkex_UU: "mkex A B UU  (s,exA) (t,exB) = ((s,t),UU)"
apply (simp add: mkex_def)
done

lemma mkex_nil: "mkex A B nil (s,exA) (t,exB) = ((s,t),nil)"
apply (simp add: mkex_def)
done

lemma mkex_cons_1: "[| x:act A; x~:act B |]
    ==> mkex A B (x>>sch) (s,a>>exA) (t,exB)  =
        ((s,t), (x,snd a,t) >> snd (mkex A B sch (snd a,exA) (t,exB)))"
apply (simp (no_asm) add: mkex_def)
apply (cut_tac exA = "a>>exA" in mkex2_cons_1)
apply auto
done

lemma mkex_cons_2: "[| x~:act A; x:act B |]
    ==> mkex A B (x>>sch) (s,exA) (t,b>>exB) =
        ((s,t), (x,s,snd b) >> snd (mkex A B sch (s,exA) (snd b,exB)))"
apply (simp (no_asm) add: mkex_def)
apply (cut_tac exB = "b>>exB" in mkex2_cons_2)
apply auto
done

lemma mkex_cons_3: "[| x:act A; x:act B |]
    ==>  mkex A B (x>>sch) (s,a>>exA) (t,b>>exB) =
         ((s,t), (x,snd a,snd b) >> snd (mkex A B sch (snd a,exA) (snd b,exB)))"
apply (simp (no_asm) add: mkex_def)
apply (cut_tac exB = "b>>exB" and exA = "a>>exA" in mkex2_cons_3)
apply auto
done

declare mkex2_UU [simp del] mkex2_nil [simp del]
  mkex2_cons_1 [simp del] mkex2_cons_2 [simp del] mkex2_cons_3 [simp del]

lemmas composch_simps = mkex_UU mkex_nil mkex_cons_1 mkex_cons_2 mkex_cons_3

declare composch_simps [simp]

subsection {* COMPOSITIONALITY on SCHEDULE Level *}

subsubsection "Lemmas for ==>"

(* --------------------------------------------------------------------- *)
(*    Lemma_2_1 :  tfilter(ex) and filter_act are commutative            *)
(* --------------------------------------------------------------------- *)

lemma lemma_2_1a:
   "filter_act$(Filter_ex2 (asig_of A)$xs)=
    Filter (%a. a:act A)$(filter_act$xs)"

apply (unfold filter_act_def Filter_ex2_def)
apply (simp (no_asm) add: MapFilter o_def)
done

(* --------------------------------------------------------------------- *)
(*    Lemma_2_2 : State-projections do not affect filter_act             *)
(* --------------------------------------------------------------------- *)

lemma lemma_2_1b:
   "filter_act$(ProjA2$xs) =filter_act$xs &
    filter_act$(ProjB2$xs) =filter_act$xs"
apply (tactic {* pair_induct_tac @{context} "xs" [] 1 *})
done

(* --------------------------------------------------------------------- *)
(*             Schedules of A||B have only  A- or B-actions              *)
(* --------------------------------------------------------------------- *)

(* very similar to lemma_1_1c, but it is not checking if every action element of
   an ex is in A or B, but after projecting it onto the action schedule. Of course, this
   is the same proposition, but we cannot change this one, when then rather lemma_1_1c  *)

lemma sch_actions_in_AorB: "!s. is_exec_frag (A||B) (s,xs)
   --> Forall (%x. x:act (A||B)) (filter_act$xs)"

apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def}, @{thm Forall_def},
  @{thm sforall_def}] 1 *})
(* main case *)
apply auto
apply (simp add: trans_of_defs2 actions_asig_comp asig_of_par)
done

subsubsection "Lemmas for <=="

(*---------------------------------------------------------------------------
    Filtering actions out of mkex(sch,exA,exB) yields the oracle sch
                             structural induction
  --------------------------------------------------------------------------- *)

lemma Mapfst_mkex_is_sch: "! exA exB s t.
  Forall (%x. x:act (A||B)) sch  &
  Filter (%a. a:act A)$sch << filter_act$exA &
  Filter (%a. a:act B)$sch << filter_act$exB
  --> filter_act$(snd (mkex A B sch (s,exA) (t,exB))) = sch"

apply (tactic {* Seq_induct_tac @{context} "sch" [@{thm Filter_def}, @{thm Forall_def},
  @{thm sforall_def}, @{thm mkex_def}] 1 *})

(* main case *)
(* splitting into 4 cases according to a:A, a:B *)
apply auto

(* Case y:A, y:B *)
apply (tactic {* Seq_case_simp_tac @{context} "exA" 1 *})
(* Case exA=UU, Case exA=nil*)
(* These UU and nil cases are the only places where the assumption filter A sch<<f_act exA
   is used! --> to generate a contradiction using  ~a>>ss<< UU(nil), using theorems
   Cons_not_less_UU and Cons_not_less_nil  *)
apply (tactic {* Seq_case_simp_tac @{context} "exB" 1 *})
(* Case exA=a>>x, exB=b>>y *)
(* here it is important that Seq_case_simp_tac uses no !full!_simp_tac for the cons case,
   as otherwise mkex_cons_3 would  not be rewritten without use of rotate_tac: then tactic
   would not be generally applicable *)
apply simp

(* Case y:A, y~:B *)
apply (tactic {* Seq_case_simp_tac @{context} "exA" 1 *})
apply simp

(* Case y~:A, y:B *)
apply (tactic {* Seq_case_simp_tac @{context} "exB" 1 *})
apply simp

(* Case y~:A, y~:B *)
apply (simp add: asig_of_par actions_asig_comp)
done

(* generalizing the proof above to a proof method *)

ML {*

local
  val defs = [@{thm Filter_def}, @{thm Forall_def}, @{thm sforall_def}, @{thm mkex_def},
    @{thm stutter_def}]
  val asigs = [@{thm asig_of_par}, @{thm actions_asig_comp}]
in

fun mkex_induct_tac ctxt sch exA exB =
  EVERY'[Seq_induct_tac ctxt sch defs,
         asm_full_simp_tac ctxt,
         SELECT_GOAL
          (safe_tac (Context.raw_transfer (Proof_Context.theory_of ctxt) @{theory_context Fun})),
         Seq_case_simp_tac ctxt exA,
         Seq_case_simp_tac ctxt exB,
         asm_full_simp_tac ctxt,
         Seq_case_simp_tac ctxt exA,
         asm_full_simp_tac ctxt,
         Seq_case_simp_tac ctxt exB,
         asm_full_simp_tac ctxt,
         asm_full_simp_tac (ctxt addsimps asigs)
        ]

end
*}

method_setup mkex_induct = {*
  Scan.lift (Args.name -- Args.name -- Args.name)
    >> (fn ((sch, exA), exB) => fn ctxt => SIMPLE_METHOD' (mkex_induct_tac ctxt sch exA exB))
*}

(*---------------------------------------------------------------------------
               Projection of mkex(sch,exA,exB) onto A stutters on A
                             structural induction
  --------------------------------------------------------------------------- *)

lemma stutterA_mkex: "! exA exB s t.
  Forall (%x. x:act (A||B)) sch &
  Filter (%a. a:act A)$sch << filter_act$exA &
  Filter (%a. a:act B)$sch << filter_act$exB
  --> stutter (asig_of A) (s,ProjA2$(snd (mkex A B sch (s,exA) (t,exB))))"
  by (mkex_induct sch exA exB)

lemma stutter_mkex_on_A: "[|
  Forall (%x. x:act (A||B)) sch ;
  Filter (%a. a:act A)$sch << filter_act$(snd exA) ;
  Filter (%a. a:act B)$sch << filter_act$(snd exB) |]
  ==> stutter (asig_of A) (ProjA (mkex A B sch exA exB))"

apply (cut_tac stutterA_mkex)
apply (simp add: stutter_def ProjA_def mkex_def)
apply (erule allE)+
apply (drule mp)
prefer 2 apply (assumption)
apply simp
done

(*---------------------------------------------------------------------------
               Projection of mkex(sch,exA,exB) onto B stutters on B
                             structural induction
  --------------------------------------------------------------------------- *)

lemma stutterB_mkex: "! exA exB s t.
  Forall (%x. x:act (A||B)) sch &
  Filter (%a. a:act A)$sch << filter_act$exA &
  Filter (%a. a:act B)$sch << filter_act$exB
  --> stutter (asig_of B) (t,ProjB2$(snd (mkex A B sch (s,exA) (t,exB))))"
  by (mkex_induct sch exA exB)

lemma stutter_mkex_on_B: "[|
  Forall (%x. x:act (A||B)) sch ;
  Filter (%a. a:act A)$sch << filter_act$(snd exA) ;
  Filter (%a. a:act B)$sch << filter_act$(snd exB) |]
  ==> stutter (asig_of B) (ProjB (mkex A B sch exA exB))"
apply (cut_tac stutterB_mkex)
apply (simp add: stutter_def ProjB_def mkex_def)
apply (erule allE)+
apply (drule mp)
prefer 2 apply (assumption)
apply simp
done

(*---------------------------------------------------------------------------
     Filter of mkex(sch,exA,exB) to A after projection onto A is exA
        --  using zip$(proj1$exA)$(proj2$exA) instead of exA    --
        --           because of admissibility problems          --
                             structural induction
  --------------------------------------------------------------------------- *)

lemma filter_mkex_is_exA_tmp: "! exA exB s t.
  Forall (%x. x:act (A||B)) sch &
  Filter (%a. a:act A)$sch << filter_act$exA  &
  Filter (%a. a:act B)$sch << filter_act$exB
  --> Filter_ex2 (asig_of A)$(ProjA2$(snd (mkex A B sch (s,exA) (t,exB)))) =
      Zip$(Filter (%a. a:act A)$sch)$(Map snd$exA)"
  by (mkex_induct sch exB exA)

(*---------------------------------------------------------------------------
                      zip$(proj1$y)$(proj2$y) = y   (using the lift operations)
                    lemma for admissibility problems
  --------------------------------------------------------------------------- *)

lemma Zip_Map_fst_snd: "Zip$(Map fst$y)$(Map snd$y) = y"
apply (tactic {* Seq_induct_tac @{context} "y" [] 1 *})
done

(*---------------------------------------------------------------------------
      filter A$sch = proj1$ex   -->  zip$(filter A$sch)$(proj2$ex) = ex
         lemma for eliminating non admissible equations in assumptions
  --------------------------------------------------------------------------- *)

lemma trick_against_eq_in_ass: "!! sch ex.
  Filter (%a. a:act AB)$sch = filter_act$ex
  ==> ex = Zip$(Filter (%a. a:act AB)$sch)$(Map snd$ex)"
apply (simp add: filter_act_def)
apply (rule Zip_Map_fst_snd [symmetric])
done

(*---------------------------------------------------------------------------
     Filter of mkex(sch,exA,exB) to A after projection onto A is exA
                       using the above trick
  --------------------------------------------------------------------------- *)

lemma filter_mkex_is_exA: "!!sch exA exB.
  [| Forall (%a. a:act (A||B)) sch ;
  Filter (%a. a:act A)$sch = filter_act$(snd exA)  ;
  Filter (%a. a:act B)$sch = filter_act$(snd exB) |]
  ==> Filter_ex (asig_of A) (ProjA (mkex A B sch exA exB)) = exA"
apply (simp add: ProjA_def Filter_ex_def)
apply (tactic {* pair_tac @{context} "exA" 1 *})
apply (tactic {* pair_tac @{context} "exB" 1 *})
apply (rule conjI)
apply (simp (no_asm) add: mkex_def)
apply (simplesubst trick_against_eq_in_ass)
back
apply assumption
apply (simp add: filter_mkex_is_exA_tmp)
done

(*---------------------------------------------------------------------------
     Filter of mkex(sch,exA,exB) to B after projection onto B is exB
        --  using zip$(proj1$exB)$(proj2$exB) instead of exB    --
        --           because of admissibility problems          --
                             structural induction
  --------------------------------------------------------------------------- *)

lemma filter_mkex_is_exB_tmp: "! exA exB s t.
  Forall (%x. x:act (A||B)) sch &
  Filter (%a. a:act A)$sch << filter_act$exA  &
  Filter (%a. a:act B)$sch << filter_act$exB
  --> Filter_ex2 (asig_of B)$(ProjB2$(snd (mkex A B sch (s,exA) (t,exB)))) =
      Zip$(Filter (%a. a:act B)$sch)$(Map snd$exB)"

(* notice necessary change of arguments exA and exB *)
  by (mkex_induct sch exA exB)

(*---------------------------------------------------------------------------
     Filter of mkex(sch,exA,exB) to A after projection onto B is exB
                       using the above trick
  --------------------------------------------------------------------------- *)

lemma filter_mkex_is_exB: "!!sch exA exB.
  [| Forall (%a. a:act (A||B)) sch ;
  Filter (%a. a:act A)$sch = filter_act$(snd exA)  ;
  Filter (%a. a:act B)$sch = filter_act$(snd exB) |]
  ==> Filter_ex (asig_of B) (ProjB (mkex A B sch exA exB)) = exB"
apply (simp add: ProjB_def Filter_ex_def)
apply (tactic {* pair_tac @{context} "exA" 1 *})
apply (tactic {* pair_tac @{context} "exB" 1 *})
apply (rule conjI)
apply (simp (no_asm) add: mkex_def)
apply (simplesubst trick_against_eq_in_ass)
back
apply assumption
apply (simp add: filter_mkex_is_exB_tmp)
done

(* --------------------------------------------------------------------- *)
(*                    mkex has only  A- or B-actions                    *)
(* --------------------------------------------------------------------- *)

lemma mkex_actions_in_AorB: "!s t exA exB.
  Forall (%x. x : act (A || B)) sch &
  Filter (%a. a:act A)$sch << filter_act$exA  &
  Filter (%a. a:act B)$sch << filter_act$exB
   --> Forall (%x. fst x : act (A ||B))
         (snd (mkex A B sch (s,exA) (t,exB)))"
  by (mkex_induct sch exA exB)

(* ------------------------------------------------------------------ *)
(*           COMPOSITIONALITY   on    SCHEDULE      Level             *)
(*                          Main Theorem                              *)
(* ------------------------------------------------------------------ *)

lemma compositionality_sch:
"(sch : schedules (A||B)) =
  (Filter (%a. a:act A)$sch : schedules A &
   Filter (%a. a:act B)$sch : schedules B &
   Forall (%x. x:act (A||B)) sch)"
apply (simp (no_asm) add: schedules_def has_schedule_def)
apply auto
(* ==> *)
apply (rule_tac x = "Filter_ex (asig_of A) (ProjA ex) " in bexI)
prefer 2
apply (simp add: compositionality_ex)
apply (simp (no_asm) add: Filter_ex_def ProjA_def lemma_2_1a lemma_2_1b)
apply (rule_tac x = "Filter_ex (asig_of B) (ProjB ex) " in bexI)
prefer 2
apply (simp add: compositionality_ex)
apply (simp (no_asm) add: Filter_ex_def ProjB_def lemma_2_1a lemma_2_1b)
apply (simp add: executions_def)
apply (tactic {* pair_tac @{context} "ex" 1 *})
apply (erule conjE)
apply (simp add: sch_actions_in_AorB)

(* <== *)

(* mkex is exactly the construction of exA||B out of exA, exB, and the oracle sch,
   we need here *)
apply (rename_tac exA exB)
apply (rule_tac x = "mkex A B sch exA exB" in bexI)
(* mkex actions are just the oracle *)
apply (tactic {* pair_tac @{context} "exA" 1 *})
apply (tactic {* pair_tac @{context} "exB" 1 *})
apply (simp add: Mapfst_mkex_is_sch)

(* mkex is an execution -- use compositionality on ex-level *)
apply (simp add: compositionality_ex)
apply (simp add: stutter_mkex_on_A stutter_mkex_on_B filter_mkex_is_exB filter_mkex_is_exA)
apply (tactic {* pair_tac @{context} "exA" 1 *})
apply (tactic {* pair_tac @{context} "exB" 1 *})
apply (simp add: mkex_actions_in_AorB)
done

subsection {* COMPOSITIONALITY on SCHEDULE Level -- for Modules *}

lemma compositionality_sch_modules:
  "Scheds (A||B) = par_scheds (Scheds A) (Scheds B)"

apply (unfold Scheds_def par_scheds_def)
apply (simp add: asig_of_par)
apply (rule set_eqI)
apply (simp add: compositionality_sch actions_of_par)
done

declare compoex_simps [simp del]
declare composch_simps [simp del]

end