(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

theory Noninterference_Base
imports "Lib.Simulation"
begin

text \<open>
  Toby's extended noninterference definitions to handle dynamic assignment,
  that depends on the current state, of
  the domain that each action is assigned to. This is the gory details
  reported in the the CPP 2012 paper
  \emph{Noninterference for Operating System Kernels}.
\<close>

section \<open>Generic systems\<close>

lemma un_eq:
  "\<lbrakk>S = S'; T = T'\<rbrakk> \<Longrightarrow> S \<union> T = S' \<union> T'"
  by auto

lemma Un_eq:
  "\<lbrakk>\<And> x y. \<lbrakk>x \<in> xs; y \<in> ys\<rbrakk> \<Longrightarrow> P x = Q y; \<exists> x. x \<in> xs; \<exists> y. y \<in> ys\<rbrakk>
    \<Longrightarrow> (\<Union>x\<in>xs. P x) = (\<Union>y\<in>ys. Q y)"
  by auto

lemma Int_eq:
  "\<lbrakk>\<And> x y. \<lbrakk>x \<in> xs; y \<in> ys\<rbrakk> \<Longrightarrow> P x = Q y; \<exists> x. x \<in> xs; \<exists> y. y \<in> ys\<rbrakk>
    \<Longrightarrow> (\<Inter>x\<in>xs. P x) = (\<Inter>y\<in>ys. Q y)"
  by auto

lemma Un_eq_Int:
  assumes ex: "\<exists> x. x \<in> xs"
  assumes ey: "\<exists> y. y \<in> ys"
  assumes a: "\<And> x y. \<lbrakk>x \<in> xs; y \<in> ys\<rbrakk> \<Longrightarrow> S x = S' y"
  shows "(\<Union>x\<in>xs. S x) = (\<Inter>x\<in>ys. S' x)"
  apply(rule equalityI)
   apply(clarsimp)
   apply(drule a, assumption, simp)
  apply clarsimp
  apply(insert ex ey)
  apply clarsimp
  apply(frule a, assumption)
  apply fastforce
  done

subsection\<open>Run function\<close>

primrec Run :: "('e \<Rightarrow> ('s \<times> 's) set) \<Rightarrow> 'e list \<Rightarrow> ('s \<times> 's) set"
where
  "Run Stepf []     = Id" |
  "Run Stepf (a#as) = Stepf a O Run Stepf as"

lemma Run_mid[rule_format]:
  shows
  "(s,u) \<in> Run Stepf (as @ bs) \<longrightarrow> (\<exists> t. (s,t) \<in> Run Stepf as \<and> (t,u) \<in> Run Stepf bs)"
  proof(induct as arbitrary: s u bs)
  case Nil show ?case
   apply(clarsimp)
   done
  next
  case (Cons a as) show ?case
  apply(clarsimp simp: relcomp_def)
  apply(drule "Cons.hyps"[rule_format])
  apply fastforce
  done
qed

lemma Run_trans:
  "\<lbrakk>(s,t) \<in> Run Stepf as; (t,u) \<in> Run Stepf bs\<rbrakk> \<Longrightarrow> (s,u) \<in> Run Stepf (as @ bs)"
  by (induct as arbitrary: bs s t u) auto

lemma Run_app:
  "Run Stepf (as @ bs) = (Run Stepf as) O (Run Stepf bs)"
  apply(rule equalityI)
   apply(fastforce dest: Run_mid)
  apply(fastforce intro: Run_trans)
  done

subsection \<open>Base system locale\<close>

text \<open>An ADT with an initial state.\<close>
locale system =
  fixes A :: "('a,'s,'e) data_type"
  and s0 :: "'s"  (* an initial state *)
begin

(* State 's' is reachable from the initial state 's0'. *)
definition reachable
where
  "reachable s \<equiv> \<exists> js. s \<in> execution A s0 js"

definition Step
where
  "Step a \<equiv> {(s,s') . s' \<in> execution A s [a]}"

(* The system is "observationally deterministic": that is, the
 * observable part of the system is always deterministic. *)
definition obs_det
where
  "obs_det \<equiv> \<forall> s js. (\<exists> s'. execution A s js = {s'})"

lemmas obs_detD = obs_det_def[THEN meta_eq_to_obj_eq, THEN iffD1, rule_format]

(* The abstraction/concretisation functions "Init"/"Fin"
 * don't abstract away information. *)
definition no_abs
where
  "no_abs \<equiv> \<forall> x s as . reachable s \<longrightarrow> x \<in> steps (Simulation.Step A) (Init A s) as
                        \<longrightarrow> Init A (Fin A x) = {x}"

lemmas no_absD = no_abs_def[THEN meta_eq_to_obj_eq, THEN iffD1, rule_format]

end

subsection \<open>Enabled system\<close>

text\<open>
  A system that is always enabled.

  In particular, the system will never be in deadlock, and there
  is always an enabled transition from every reachable state.\<close>

locale enabled_system = system +
  assumes enabled: "(\<exists> js. s \<in> execution A s0 js) \<Longrightarrow> \<exists> s'. s' \<in> execution A s js"
begin

lemma reachable_enabled:
  "reachable s \<Longrightarrow> \<exists> s'. s' \<in> execution A s js"
  apply(simp add: reachable_def)
  apply(erule enabled)
  done

lemma enabled_Step:
  "reachable s \<Longrightarrow> \<exists> s'. (s,s') \<in> Step a"
  apply(simp add: Step_def, blast intro: reachable_enabled)
  done

end

subsection \<open>Step system\<close>

text \<open>A Step system is a system for which a running
   a sequence of events is equivalent to performing a sequence of individual
   steps: one for each event in the sequence in turn. In other words
   running [a,b,c,...] is the same than running [a] then running [b] then ...
   This correspond to projecting to the observable state and deducing the real
   state from that observable state on each event.

   We define the unwinding conditions on this kind of system\<close>
locale Step_system = system A s0
  for A :: "('a,'s,'e) data_type" and s0 :: "'s"  +
  assumes reachable_s0: "reachable s0"
  assumes execution_Run: "reachable s \<Longrightarrow> execution A s as = {s'. (s,s') \<in> Run Step as}"
begin

lemma execution_Run':
  "s \<in> execution A s0 js \<Longrightarrow> execution A s as = {s'. (s,s') \<in> Run Step as}"
  apply(rule execution_Run)
  apply(fastforce simp: reachable_def)
  done

lemma reachable_Run:
  "reachable s \<Longrightarrow> \<exists>as. (s0,s) \<in> Run Step as"
  apply (clarsimp simp add: reachable_def)
  apply (cut_tac as=js in execution_Run[OF reachable_s0])
  apply blast
  done

lemma Run_reachable:
  "\<exists>as. (s0,s) \<in> Run Step as \<Longrightarrow> reachable s"
  apply (clarsimp simp add: reachable_def)
  apply (cut_tac as=as in execution_Run[OF reachable_s0])
  apply blast
  done

lemma reachable_execution:
  "\<lbrakk>reachable s; s' \<in> execution A s js\<rbrakk> \<Longrightarrow> reachable s'"
  apply(clarsimp simp: reachable_def)
  apply(rule_tac x="jsa @ js" in exI)
  apply(frule execution_Run'[where s=s and as=js])
  apply(simp add: execution_Run[where s=s0, simplified reachable_s0])
  apply(fastforce simp: Run_app)
  done

lemma reachable_Step:
  "\<lbrakk>reachable s; (s,s') \<in> Step a\<rbrakk> \<Longrightarrow> reachable s'"
  apply(erule reachable_execution)
  apply(simp add: Step_def)
  done

lemma reachable_induct_helper:
  assumes a:
    "\<And>s s' a. \<lbrakk>reachable s; P s; (s, s') \<in> Step a\<rbrakk> \<Longrightarrow> P s'"
  shows "\<lbrakk>(s0, s1) \<in> Run Step as; P s0\<rbrakk> \<Longrightarrow> P s1"
  apply (induct as arbitrary: s1 rule: rev_induct)
   apply simp
  apply(fastforce dest: Run_mid intro: a Run_reachable)
  done

lemma reachable_induct:
  "\<lbrakk>(\<And>s s' a. reachable s \<Longrightarrow> (s,s') \<in> (Step a) \<Longrightarrow> P s \<Longrightarrow> P s'); reachable s1; P s0\<rbrakk> \<Longrightarrow> P s1"
  apply (drule reachable_Run)
  apply (elim exE)
  apply (rule reachable_induct_helper)
    apply simp+
  done

end

subsection \<open>Init Fin system\<close>

text \<open>An Init Fin system a stronger kind of Step system where know directly
   that Fin and Init behave nicely as nearly "inverse" of each other which imply
   that projecting to observable state then deducing the original state behave
   as expected in Step system.
\<close>

locale Init_Fin_system = system A s0
  for A :: "('a,'s,'e) data_type" and s0 :: "'s"  +
  assumes reachable_s0: "reachable s0"
  assumes Fin_Init: "reachable s \<Longrightarrow> Fin A ` Init A s = {s}"
  assumes Init_Fin: "reachable s \<Longrightarrow> x \<in> steps (Simulation.Step A) (Init A s) as \<Longrightarrow>  x \<in> Init A (Fin A x)"
  assumes obs_det_or_no_abs: "obs_det \<or> no_abs"
begin

lemma execution_subset_Run:
  "reachable s \<Longrightarrow> execution A s as \<subseteq> {s'. (s,s') \<in> Run Step as}"
  apply(induct as arbitrary: s rule: rev_induct)
   apply(simp add: execution_def steps_def Fin_Init)
  apply(simp add: execution_def steps_def)
  apply(rule subsetI)
  apply clarsimp
  apply(rule Run_trans)
   apply blast
  apply(cut_tac x=xc and s=s and as=xs in Init_Fin, (simp add: steps_def)+)
  apply(clarsimp simp: Step_def execution_def steps_def)
  apply blast
  done

lemma Run_subset_execution:
  "\<lbrakk>no_abs; reachable s\<rbrakk> \<Longrightarrow> {s'. (s,s') \<in> Run Step as} \<subseteq> execution A s as"
  apply(induct as arbitrary: s rule: rev_induct)
   apply(simp add: execution_def steps_def Fin_Init)
  apply(simp add: execution_def steps_def)
  apply(rule subsetI)
  apply clarsimp
  apply(drule Run_mid)
  apply clarsimp
  apply(drule_tac x=s in meta_spec)
  apply clarsimp
  apply(drule_tac subsetD)
   apply blast
  apply(clarsimp simp: Image_def image_def Step_def execution_def steps_def)
  apply(rule_tac x=xc in exI)
  apply clarsimp
  apply(rule_tac x=xd in bexI)
   apply assumption
  apply(drule_tac x=xb in no_absD)
    apply(simp add: steps_def Image_def)+
  done

lemma Run_det:
  "obs_det \<Longrightarrow> \<exists> s'. {s'. (s,s') \<in> Run Step as} = {s'}"
  apply(induct as arbitrary: s rule: rev_induct)
   apply simp
  apply(simp add: Run_app relcomp_def)
  apply(drule_tac x=s in meta_spec)
  apply clarsimp
  apply(drule_tac s=s' and js="[x]" in obs_detD)
  apply (clarsimp simp: Step_def)
  apply(rule_tac x="s'a" in exI)
  apply (auto dest: equalityD1)
  done

lemma eq:
  "\<lbrakk>S \<subseteq> T; \<exists> x. S = {x}; \<exists> y. T = {y}\<rbrakk> \<Longrightarrow> S = T"
  apply blast
  done

lemma execution_Run:
  "reachable s \<Longrightarrow> execution A s as = {s'. (s,s') \<in> Run Step as}"
  apply(rule disjE[OF obs_det_or_no_abs])
   apply(rule eq)
     apply(erule execution_subset_Run)
    apply(erule obs_detD)
   apply(erule Run_det)
  apply(rule equalityI)
   apply(erule execution_subset_Run)
  apply(erule (1) Run_subset_execution)
  done

end

lemma Init_Fin_system_Step_system:
  "Init_Fin_system A s0 \<Longrightarrow> Step_system A s0"
  apply(unfold_locales)
   apply(erule Init_Fin_system.reachable_s0)
  apply(erule (1) Init_Fin_system.execution_Run)
  done

sublocale Init_Fin_system \<subseteq> Step_system
  apply(rule Init_Fin_system_Step_system)
  apply(unfold_locales)
  done

subsection \<open>Init inv Fin system\<close>

text \<open>Here we go one step further than the Init_Fin_system:
  In this local Init and Fin are actually inverse of each other
  Fin is injective
  if s : range Fin A then Init A s = {s'} and Fin A s' = s else Init A s = {}.

  The internal state space is thus just a restriction of the observable state space.
\<close>

(* when Init is the inverse image of Fin, the above assumptions are met by a system
   for which Fin is injective, or one that appears deterministic to an observer *)
locale Init_inv_Fin_system = system A s0
  for A :: "('a,'s,'e) data_type" and s0 :: "'s" +
  assumes Fin_Init_s0: "s0 \<in> Fin A ` Init A s0"
  assumes Init_inv_Fin: "reachable s \<Longrightarrow> Init A s = {s'. Fin A s' = s}"
  assumes Fin_inj: "inj (Fin A)"
begin

lemma inv_and_inj: "reachable s \<Longrightarrow> Fin A i = s \<Longrightarrow> Init A s = {i}"
  using Fin_inj Init_inv_Fin by (blast dest:injD)

lemma s0_reachable:
  "reachable s0"
  apply(simp add: reachable_def)
  apply(rule_tac x="[]" in exI)
  apply(simp add: execution_def steps_def)
  using Fin_Init_s0.

lemma foldl_foldl_Step:
  "\<lbrakk>x \<in> foldl (\<lambda>S j. data_type.Step A j `` S) M as;
   M \<subseteq> foldl (\<lambda>S j. data_type.Step A j `` S) B js\<rbrakk>
       \<Longrightarrow> x \<in> foldl (\<lambda>S j. data_type.Step A j `` S)
               (foldl (\<lambda>S j. data_type.Step A j `` S) B js) as"
  apply(induct  as arbitrary: x M js B rule: rev_induct)
   apply fastforce
  apply simp
  apply(erule ImageE)
  apply(drule_tac x=xb in meta_spec)
  apply(drule_tac x=M in meta_spec)
  apply simp
  apply(drule_tac x=js in meta_spec)
  apply(drule_tac x=B in meta_spec, simp)
  apply(blast)
  done

lemma reachable_Fin:
  "\<lbrakk>reachable s;
    x \<in> steps (Simulation.Step A) (Init A s) as\<rbrakk>
   \<Longrightarrow> reachable (Fin A x)"
  apply(cut_tac s=s in Init_inv_Fin, assumption)
  apply(clarsimp simp: reachable_def execution_def steps_def)
  apply(rule_tac x="js@as" in exI)
  apply(rule imageI)
  apply(subgoal_tac "{s'. Fin A s' = Fin A xa} = {xa}")
   apply simp
   apply(erule foldl_foldl_Step)
   apply blast
  apply(blast dest: injD[OF Fin_inj])
  done

end

lemma Init_inv_Fin_system_Init_Fin_system:
  "Init_inv_Fin_system A s0 \<Longrightarrow> Init_Fin_system A s0"
  apply(unfold_locales)
     apply(erule Init_inv_Fin_system.s0_reachable)
    apply(simp add: Init_inv_Fin_system.Init_inv_Fin)
    apply(simp add: image_def)
    apply(fastforce simp: system.reachable_def execution_def)
   apply(cut_tac s="Fin A x" in Init_inv_Fin_system.Init_inv_Fin)
     apply assumption
    apply(blast intro: Init_inv_Fin_system.reachable_Fin)
   apply simp
  apply(rule disjI2)
  apply(clarsimp simp: system.no_abs_def)
  apply(frule Init_inv_Fin_system.Fin_inj)
  apply(cut_tac s="Fin A x" in Init_inv_Fin_system.Init_inv_Fin)
    apply assumption
   apply(blast intro: Init_inv_Fin_system.reachable_Fin)
  apply simp
  apply(fastforce dest: injD)
  done

sublocale Init_inv_Fin_system \<subseteq> Init_Fin_system
  apply(rule Init_inv_Fin_system_Init_Fin_system)
  apply(unfold_locales)
  done

section \<open>Non interference\<close>

subsection \<open>Policy\<close>

text\<open>This local represent an whole infoflow policy with the all the field needed
       for defining non leakage, non interference and non influence\<close>

locale noninterference_policy =
  fixes dom :: "'e \<Rightarrow> 's \<Rightarrow> 'd"        (* dynamic dom assignment *)
  fixes uwr :: "'d \<Rightarrow> ('s \<times> 's) set"  (* unwinding relation *)
  fixes policy :: "('d \<times> 'd) set"     (* who can send info to whom *)
  fixes out :: "'d \<Rightarrow> 's \<Rightarrow> 'p"        (* observable parts of d in state s *)
  fixes schedDomain :: "'d"
  assumes uwr_equiv_rel: "equiv UNIV (uwr u)"
  assumes schedIncludesCurrentDom:
    "(s,t) \<in> uwr schedDomain \<Longrightarrow> dom e s = dom e t"
  assumes schedFlowsToAll:
    "(schedDomain,d) \<in> policy"
  assumes schedNotGlobalChannel:
    "(x,schedDomain) \<in> policy \<Longrightarrow> x = schedDomain"
begin

abbreviation uwr2 :: "'s \<Rightarrow> 'd \<Rightarrow> 's \<Rightarrow> bool" ("(_/ \<sim>_\<sim>/ _)" [50,100,50] 1000)
where
  "s \<sim>u\<sim> t \<equiv> (s,t) \<in> uwr u"

abbreviation policy2 :: "'d \<Rightarrow> 'd \<Rightarrow> bool" (infix "\<leadsto>" 50)
where
  "u \<leadsto> v \<equiv> (u,v) \<in> policy"

lemma uwr_refl:
  "s \<sim>(u::'d)\<sim> s"
  apply(cut_tac u=u in uwr_equiv_rel)
  apply(clarsimp simp: equiv_def)
  apply(blast dest: refl_onD)
  done

lemma uwr_sym:
  "x \<sim>(u::'d)\<sim> y \<Longrightarrow> y \<sim>u\<sim> x"
  apply(cut_tac u=u in uwr_equiv_rel)
  apply(clarsimp simp: equiv_def)
  apply(blast dest: symD)
  done

lemma uwr_trans:
  "\<lbrakk>x \<sim>(u::'d)\<sim> y; y \<sim>u\<sim> z\<rbrakk> \<Longrightarrow> x \<sim>u\<sim> z"
  apply(cut_tac u=u in uwr_equiv_rel)
  apply(clarsimp simp: equiv_def)
  apply(blast dest: transD)
  done

definition sameFor_dom :: "'s \<Rightarrow> 'd set \<Rightarrow> 's \<Rightarrow> bool"  ("(_/ \<approx>_\<approx>/ _)" [50,100,50] 1000)
where
 "s \<approx>us\<approx> t \<equiv> \<forall>u\<in>us. (s,t) \<in> uwr u"

lemma sameFor_subset_dom: "\<lbrakk>s \<approx>(x::'d set)\<approx> t; y \<subseteq> x\<rbrakk> \<Longrightarrow> s \<approx>y\<approx> t"
  by(fastforce simp: sameFor_dom_def)

lemma sameFor_inter_domI: "s \<approx>(S::'d set)\<approx> t \<Longrightarrow> s \<approx>(S \<inter> B)\<approx> t"
  by(auto simp: sameFor_dom_def)

lemma sameFor_sym_dom:
  "s \<approx>(S::'d set)\<approx> t \<Longrightarrow> t \<approx>S\<approx> s"
  by(auto simp: sameFor_dom_def uwr_sym)

end

subsection \<open>Non interference system\<close>

locale noninterference_system = enabled_system A s0 +
                                noninterference_policy dom uwr policy out schedDomain
  for A :: "('a,'s,'e) data_type"
  and s0 :: "'s"
  and dom :: "'e \<Rightarrow> 's \<Rightarrow> 'd"
  and uwr :: "'d \<Rightarrow> ('s \<times> 's) set"
  and policy :: "('d \<times> 'd) set"
  and out :: "'d \<Rightarrow> 's \<Rightarrow> 'p"
  and schedDomain :: "'d"
begin

(* The set of domains (which carry out actions in the list "as") which
 * may influence "u", assuming we start in state "s". *)
primrec
 sources :: "'e list \<Rightarrow> 's \<Rightarrow> 'd \<Rightarrow> 'd set"
where
 sources_Nil: "sources [] s u = {u}"|
 sources_Cons: "sources (a#as) s u = (\<Union>{sources as s' u| s'. (s,s') \<in> Step a}) \<union>
      {w. w = dom a s \<and> (\<exists> v s'. dom a s \<leadsto> v \<and> (s,s') \<in> Step a \<and> v \<in> sources as s' u)}"

declare sources_Nil [simp del]
declare sources_Cons [simp del]

definition obs_equiv :: "'s \<Rightarrow> 'e list \<Rightarrow> 's \<Rightarrow> 'e list \<Rightarrow> 'd \<Rightarrow> bool"
where
  "obs_equiv s as t bs d \<equiv> \<forall> s' t'. s' \<in> execution A s as \<and> t' \<in> execution A t bs \<longrightarrow>
                out d s' = out d t'"

definition uwr_equiv :: "'s \<Rightarrow> 'e list \<Rightarrow> 's \<Rightarrow> 'e list \<Rightarrow> 'd \<Rightarrow> bool"
where
  "uwr_equiv s as t bs d \<equiv> \<forall> s' t'. s' \<in> execution A s as \<and> t' \<in> execution A t bs \<longrightarrow>
                s' \<sim>d\<sim> t'"

text \<open>Nonleakage\<close>
definition Nonleakage :: "bool"
where
  "Nonleakage \<equiv> \<forall>as s u t. reachable s \<and> reachable t \<longrightarrow>
     s \<sim>schedDomain\<sim> t \<longrightarrow>
     s \<approx>(sources as s u)\<approx> t \<longrightarrow> obs_equiv s as t as u"

text \<open>A generalisation of Nonleakage.\<close>
definition Nonleakage_gen :: "bool"
where
  "Nonleakage_gen \<equiv> \<forall>as s u t. reachable s \<and> reachable t \<longrightarrow>
     s \<sim>schedDomain\<sim> t \<longrightarrow>
       s \<approx>(sources as s u)\<approx> t \<longrightarrow> uwr_equiv s as t as u"

lemma uwr_equiv_sym:
  "uwr_equiv s as t bs u \<Longrightarrow> uwr_equiv t bs s as u"
  apply(fastforce simp: uwr_equiv_def uwr_sym)
  done

lemma uwr_equiv_trans:
  "\<lbrakk>reachable t; uwr_equiv s as t bs x; uwr_equiv t bs u cs x\<rbrakk> \<Longrightarrow> uwr_equiv s as u cs x"
  apply(clarsimp simp: uwr_equiv_def)
  apply(cut_tac s=t and js=bs in reachable_enabled)
   apply assumption
  apply(blast intro: uwr_trans)
  done

primrec gen_purge :: "('e list \<Rightarrow> 's \<Rightarrow> 'd \<Rightarrow> 'd set) \<Rightarrow> 'd \<Rightarrow> 'e list \<Rightarrow> 's set \<Rightarrow> 'e list"
where
  Nil : "gen_purge source_func u []     ss = []" |
  Cons: "gen_purge source_func u (a#as) ss =
            (if (\<exists>s\<in>ss. dom a s \<in> source_func (a#as) s u) then
               a#gen_purge source_func u as (\<Union>s\<in>ss. {s'. (s,s') \<in> Step a})
             else
               gen_purge source_func u as ss)"

definition ipurge
where
 "ipurge \<equiv> gen_purge sources"

lemma ipurge_Nil:
  "ipurge u [] ss = []"
  by(auto simp: ipurge_def)

lemma ipurge_Cons:
  "ipurge u (a#as) ss =
     (if (\<exists> s\<in>ss. dom a s \<in> sources (a#as) s u) then
         a#ipurge u as (\<Union>s\<in>ss. {s'. (s,s') \<in> Step a})
      else
         ipurge u as ss)"
  by (auto simp: ipurge_def)

lemma gen_purge_shortens:
  "length (gen_purge sf u as ss) \<le> length as"
  apply(induct as arbitrary: ss)
   apply(simp)
  apply(clarsimp)
  apply(rule le_trans)
   apply assumption
  apply simp
  done

lemma INT_cong':
  assumes a: "\<And> x. Q x \<Longrightarrow> P x = P' x"
  shows
  "\<Inter>{P x|x. Q x} = \<Inter>{P' x|x. Q x}"
  apply (auto simp: a)
  done

text \<open>Standard Noninterference\<close>

definition Noninterference :: "bool"
where
 "Noninterference \<equiv>
  \<forall> u as s. reachable s \<longrightarrow>
         (obs_equiv s as s (ipurge u as {s}) u)"

text \<open>Strong Noninterference\<close>
definition Noninterference_strong :: "bool"
where
 "Noninterference_strong \<equiv>
  \<forall> u as bs s. reachable s \<longrightarrow>
         (ipurge u as {s}) = (ipurge u bs {s}) \<longrightarrow>
         (obs_equiv s as s bs u)"

lemma obs_equiv_sym:
  "obs_equiv s as t bs u \<Longrightarrow> obs_equiv t bs s as u"
  apply(clarsimp simp: obs_equiv_def)
  done

lemma obs_equiv_trans:
  "\<lbrakk>reachable t; obs_equiv s as t bs u; obs_equiv t bs x cs u\<rbrakk> \<Longrightarrow> obs_equiv s as x cs u"
  apply(clarsimp simp: obs_equiv_def)
  apply(cut_tac s=t and js=bs in reachable_enabled, assumption, blast)
  done

lemma Noninterference_Noninterference_strong:
  "\<lbrakk>Noninterference\<rbrakk> \<Longrightarrow> Noninterference_strong"
  apply(clarsimp simp: Noninterference_def Noninterference_strong_def)
  apply(drule_tac x=u in spec)
  apply(frule_tac x=as in spec, drule_tac x=s in spec)
  apply(drule_tac x=bs in spec, drule_tac x=s in spec)
  apply clarsimp
  apply(rule obs_equiv_trans)
    apply assumption
   apply assumption
  apply(erule obs_equiv_sym)
  done

text \<open>Noninfluence -- the combination of Noninterference and
   Nonleakage.

   We add the assumption about equivalence wrt the scheduler's domain, as
   is common in e.g. GVW.\<close>
definition Noninfluence  :: "bool"
where
 "Noninfluence \<equiv>
  \<forall> u as s t. reachable s \<and> reachable t \<longrightarrow>
      s \<approx>(sources as s u)\<approx> t \<longrightarrow>  s \<sim>schedDomain\<sim> t \<longrightarrow>
         obs_equiv s as t (ipurge u as {t}) u"

definition Noninfluence_strong  :: "bool"
where
 "Noninfluence_strong \<equiv>
  \<forall> u as bs s t. reachable s  \<and> reachable t \<longrightarrow>
      s \<approx>(sources as s u)\<approx> t \<longrightarrow>  s \<sim>schedDomain\<sim> t \<longrightarrow>
         ipurge u as {s} = ipurge u bs {s} \<longrightarrow>
         obs_equiv s as t bs u"

lemma notin_policyI:
  "\<lbrakk>dom a s \<notin> sources (a # list) s u; \<exists> s'. (s,s') \<in> Step a \<and> ua \<in> sources list s' u\<rbrakk> \<Longrightarrow>
   (dom a s,ua) \<notin> policy"
  apply(clarsimp simp: sources_Cons)
  done

lemma Noninfluence_strong_Noninterference_strong:
  "Noninfluence_strong \<Longrightarrow> Noninterference_strong"
  apply(clarsimp simp: Noninfluence_strong_def Noninterference_strong_def)
  apply(drule_tac x=u in spec, drule_tac x=as in spec, drule_tac x=bs in spec)
  apply(fastforce simp: sameFor_dom_def uwr_refl)
  done

lemma Noninfluence_strong_Nonleakage:
  "Noninfluence_strong \<Longrightarrow> Nonleakage"
  apply(clarsimp simp: Noninfluence_strong_def Nonleakage_def)
  done

text \<open>This stronger condition is needed
   to make the induction proof work for Noninterference. It can be viewed
   as a generalisation of Noninfluence; hence its name here.
\<close>
definition Noninfluence_gen :: "bool"
where
 "Noninfluence_gen \<equiv>
  \<forall> u as s ts. reachable s \<and> (\<forall> t \<in> ts. reachable t) \<longrightarrow>
      (\<forall>t \<in> ts. s \<approx>(sources as s u)\<approx> t) \<longrightarrow>  (\<forall>t \<in> ts. s \<sim>schedDomain\<sim> t) \<longrightarrow>
         (\<forall>t \<in> ts. uwr_equiv s as t (ipurge u as ts) u)"

definition Noninfluence_uwr  :: "bool"
where
 "Noninfluence_uwr \<equiv>
  \<forall> u as s t. reachable s \<and> reachable t \<longrightarrow>
      s \<approx>(sources as s u)\<approx> t \<longrightarrow>  s \<sim>schedDomain\<sim> t \<longrightarrow>
         uwr_equiv s as t (ipurge u as {t}) u"

definition Noninfluence_strong_uwr :: "bool"
where
 "Noninfluence_strong_uwr \<equiv>
  \<forall> u as bs s t. reachable s  \<and> reachable t \<longrightarrow>
      s \<approx>(sources as s u)\<approx> t \<longrightarrow>  s \<sim>schedDomain\<sim> t \<longrightarrow>
         ipurge u as {s} = ipurge u bs {s} \<longrightarrow>
         uwr_equiv s as t bs u"

definition output_consistent :: "bool"
where
  "output_consistent \<equiv> \<forall> u s s'. s \<sim>u\<sim> s'  \<longrightarrow> (out u s = out u s')"

definition confidentiality_u :: "bool"
where
  "confidentiality_u \<equiv> \<forall> a u s t.  reachable s \<and> reachable t \<longrightarrow>
    s \<sim>schedDomain\<sim> t \<longrightarrow>
    ((dom a s \<leadsto> u) \<longrightarrow> s \<sim>dom a s\<sim> t) \<longrightarrow>
      s \<sim>u\<sim> t \<longrightarrow>
      (\<forall> s' t'. (s,s') \<in> Step a \<and> (t,t') \<in> Step a \<longrightarrow>
        s' \<sim>u\<sim> t')"

lemma no_domain_visible_nondeterminism:
  "\<lbrakk>confidentiality_u; reachable s; (s,s') \<in> Step a; (s,s'') \<in> Step a\<rbrakk> \<Longrightarrow> s' \<sim>d\<sim> s''"
  apply(clarsimp simp: confidentiality_u_def)
  apply(fastforce intro: uwr_refl)
  done

definition integrity_u :: "bool"
where
  "integrity_u \<equiv> \<forall> a u s. reachable  s \<longrightarrow>
   (dom a s,u) \<notin> policy  \<longrightarrow>
   (\<forall> s'. (s,s') \<in> Step a \<longrightarrow> s \<sim>u\<sim> s')"

(*<*)
(* integrity_u actually guarantees this (seemingly) stronger condition *)
definition integrity_u_more :: "bool"
where
  "integrity_u_more \<equiv> \<forall> a u s. reachable s \<longrightarrow>
   (dom a s,u) \<notin> policy \<longrightarrow>
   (\<forall> s' t. s \<sim>u\<sim> t \<and> (s,s') \<in> Step a \<longrightarrow> s' \<sim>u\<sim> t)"

lemma integrity_u_more:
  "integrity_u \<Longrightarrow> integrity_u_more"
  apply(clarsimp simp: integrity_u_more_def integrity_u_def)
  apply(blast dest: uwr_sym uwr_trans)
  done
(*>*)

lemma integrity_uD:
  "\<lbrakk>integrity_u; reachable s; (dom a s,u) \<notin> policy;
    s \<sim>u\<sim> t; (s,s') \<in> Step a\<rbrakk> \<Longrightarrow>
   s' \<sim>u\<sim> t"
  apply(drule integrity_u_more)
  apply(simp add: integrity_u_more_def)
  done

text \<open>
  A weaker version of @{prop confidentiality_u} that, with
  @{prop integrity_u}, implies it.
\<close>
definition confidentiality_u_weak
where
  "confidentiality_u_weak \<equiv> \<forall> a u s t.  reachable s \<and> reachable t \<longrightarrow>
    s \<sim>schedDomain\<sim> t \<longrightarrow> dom a s \<leadsto> u \<longrightarrow> s \<sim>(dom a s)\<sim> t \<longrightarrow>
      s \<sim>u\<sim> t \<longrightarrow>
        (\<forall> s' t'. (s,s') \<in> Step a \<and> (t,t') \<in> Step a \<longrightarrow> s' \<sim>u\<sim> t')"

lemma confidentiality_u_confidentiality_u_weak:
  "confidentiality_u \<Longrightarrow> confidentiality_u_weak"
  apply (simp add: confidentiality_u_def confidentiality_u_weak_def)
  apply blast
  done

lemma impCE':
  "\<lbrakk>P \<longrightarrow> Q; \<lbrakk>P; Q\<rbrakk> \<Longrightarrow> R; \<not> P \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  apply auto
  done

lemma confidentiality_u_weak:
  "\<lbrakk>confidentiality_u_weak; integrity_u\<rbrakk> \<Longrightarrow>
  confidentiality_u"
  apply(clarsimp simp: confidentiality_u_def)
  apply(erule impCE')
   apply(subst (asm) confidentiality_u_weak_def, blast)
  apply(frule integrity_uD, simp+)
  apply(drule_tac s=t and t="s'" in integrity_uD)
      apply assumption
     apply(drule_tac e=a in schedIncludesCurrentDom)
     apply simp
    apply(blast intro: uwr_sym)
   apply assumption
  apply(erule uwr_sym)
  done

lemma obs_equivI:
  "\<lbrakk>output_consistent; uwr_equiv s as t bs ob\<rbrakk> \<Longrightarrow> obs_equiv s as t bs ob"
  apply(clarsimp simp: obs_equiv_def)
  apply(auto simp: uwr_equiv_def output_consistent_def)
  done

lemma Noninfluence_uwr_Noninfluence:
  "\<lbrakk>output_consistent; Noninfluence_uwr\<rbrakk> \<Longrightarrow> Noninfluence"
  apply(clarsimp simp: Noninfluence_def)
  apply(erule obs_equivI)
  apply(auto simp: Noninfluence_uwr_def)
  done

lemma Noninfluence_strong_uwr_Noninfluence_strong:
  "\<lbrakk>output_consistent; Noninfluence_strong_uwr\<rbrakk> \<Longrightarrow> Noninfluence_strong"
  apply(clarsimp simp: Noninfluence_strong_def)
  apply(erule obs_equivI)
  apply(auto simp: Noninfluence_strong_uwr_def)
  done

lemma sched_equiv_preserved:
  "\<lbrakk>confidentiality_u;  reachable s; reachable t;
   s \<sim>schedDomain\<sim> t; (s,s') \<in> Step a; (t,t') \<in> Step a\<rbrakk> \<Longrightarrow>
   s' \<sim>schedDomain\<sim> t'"
  apply(case_tac "dom a s = schedDomain")
   apply(subst (asm) confidentiality_u_def)
   apply(drule_tac x=a in spec)
   apply(drule_tac x=schedDomain in spec)
   apply(drule_tac x=s in spec)
   apply(drule_tac x=t in spec)
   apply simp
  apply(subst (asm) confidentiality_u_def)
  apply(blast intro: schedNotGlobalChannel)
  done

lemma sched_equiv_preserved_left:
  "\<lbrakk>integrity_u; s \<sim>schedDomain\<sim> t;
    dom a s \<noteq> schedDomain; (s,s') \<in> Step a; reachable s\<rbrakk> \<Longrightarrow>
    s' \<sim>schedDomain\<sim> t"
  apply(blast intro: integrity_uD schedNotGlobalChannel)
  done

lemma Noninfluence_gen_Noninterference:
  "\<lbrakk>output_consistent; Noninfluence_gen\<rbrakk> \<Longrightarrow> Noninterference"
  apply(clarsimp simp: Noninterference_def Noninfluence_gen_def)
  apply(erule_tac x=u in allE)
  apply(erule_tac x=as in allE)
  apply(erule_tac x=s in allE)
  apply(erule_tac x="{s}" in allE)
  apply(clarsimp simp: sameFor_dom_def uwr_refl)
  apply(blast intro: obs_equivI)
  done

lemma Noninfluence_gen_Noninfluence:
  "\<lbrakk>output_consistent; Noninfluence_gen\<rbrakk> \<Longrightarrow> Noninfluence"
  apply(clarsimp simp: Noninfluence_def Noninfluence_gen_def)
  apply(erule_tac x=u in allE)
  apply(erule_tac x=as in allE)
  apply(erule_tac x=s in allE)
  apply(erule_tac x="{t}" in allE)
  apply(blast intro: obs_equivI)
  done

lemma Noninfluence_gen_Noninfluence_uwr:
  "\<lbrakk>Noninfluence_gen\<rbrakk> \<Longrightarrow> Noninfluence_uwr"
  apply(clarsimp simp: Noninfluence_uwr_def Noninfluence_gen_def)
  done

lemma Noninfluence_gen_Noninterference_strong:
  "\<lbrakk>output_consistent; Noninfluence_gen\<rbrakk> \<Longrightarrow> Noninterference_strong"
  apply(rule Noninterference_Noninterference_strong)
  apply(blast intro: Noninfluence_gen_Noninterference)
  done

end

subsection \<open>Noninterference on enabled Step system : unwinding system\<close>

locale enabled_Step_system = enabled_system A s0 + Step_system A s0
  for A :: "('a,'s,'e) data_type" and s0 :: "'s"

(* we define the unwinding conditions for any system *)
locale unwinding_system = enabled_Step_system A s0 +
                          noninterference_policy dom uwr policy out schedDomain
  for A :: "('a,'s,'e) data_type"
  and s0 :: "'s"
  and dom :: "'e \<Rightarrow> 's \<Rightarrow> 'd"
  and uwr :: "'d \<Rightarrow> ('s \<times> 's) set"
  and policy :: "('d \<times> 'd) set"
  and out :: "'d \<Rightarrow> 's \<Rightarrow> 'p"
  and schedDomain :: "'d"

sublocale unwinding_system \<subseteq> noninterference_system
  apply(unfold_locales)
  done

context unwinding_system begin

lemma sources_refl:
  "reachable s \<Longrightarrow> u \<in> sources as s u"
  apply(induct as arbitrary: s)
   apply(simp add: sources_Nil)
  apply(simp add: sources_Cons)
  apply(frule_tac a=a in enabled_Step)
  apply (auto simp: reachable_Step)
  done

lemma schedDomain_in_sources_Cons:
  "reachable s \<Longrightarrow> dom a s = schedDomain \<Longrightarrow> dom a s \<in> sources (a#as) s u"
  apply(unfold sources_Cons)
  apply(erule ssubst)
  apply(rule UnI2)
  apply(clarsimp)
  apply(rule_tac x=u in exI)
  apply(safe)
   apply(rule schedFlowsToAll)
  apply(frule_tac a=a in enabled_Step)
  apply(fastforce dest: sources_refl reachable_Step)
  done

lemma sources_eq':
  "confidentiality_u \<and> s \<sim>schedDomain\<sim> t \<and> reachable s \<and> reachable t
   \<longrightarrow> sources as s u = sources as t u"
  proof (induct as arbitrary: s t)
  case Nil show ?case
   apply(simp add: sources_Nil)
   done
  next
  case (Cons a as) show ?case
  apply(clarsimp simp: sources_Cons)
  apply(rule un_eq)
   apply(simp only: Union_eq, simp only: UNION_eq[symmetric])
   apply(rule Un_eq, clarsimp)
     apply(metis "Cons.hyps"[rule_format] sched_equiv_preserved reachable_Step)
    apply(fastforce intro: enabled_Step)
   apply(fastforce intro: enabled_Step)
  apply(clarsimp simp: schedIncludesCurrentDom)
  apply(rule Collect_cong)
  apply(rule conj_cong, rule refl)
  apply(rule iff_exI)
  apply(metis "Cons.hyps"[rule_format] sched_equiv_preserved reachable_Step enabled_Step)
  done
  qed

lemma sources_eq:
  "\<lbrakk>confidentiality_u; s \<sim>schedDomain\<sim> t; reachable s; reachable t\<rbrakk> \<Longrightarrow>
  sources as s u = sources as t u"
  by(rule sources_eq'[rule_format], simp)

lemma sameFor_sources_dom:
  "\<lbrakk>s \<approx>(sources (a#as) s u)\<approx> t; dom a s \<leadsto> x; x \<in> sources as s' u; (s,s') \<in> Step a\<rbrakk> \<Longrightarrow>
   s \<sim>(dom a s)\<sim> t"
  apply(simp add: sameFor_dom_def)
  apply(erule bspec)
  apply(subst sources_Cons)
  apply(rule UnI2)
  apply blast
  done

lemma sources_unwinding_step:
  "\<lbrakk>s \<approx>(sources (a#as) s u)\<approx> t; s \<sim>schedDomain\<sim> t; confidentiality_u;
    (s,s') \<in> Step a; (t,t') \<in> Step a; reachable s; reachable t\<rbrakk>  \<Longrightarrow>
    s' \<approx>(sources as s' u)\<approx> t'"
  apply(clarsimp simp: sameFor_dom_def sources_Cons)
  apply(subst (asm) confidentiality_u_def)
  apply(drule_tac x=a in spec)
  apply(drule_tac x=ua in spec)
  apply(drule_tac x=s in spec)
  apply(drule_tac x=t in spec)
  apply(fastforce intro: sameFor_sources_dom)
  done

lemma ipurge_eq'_helper:
  "\<lbrakk>s \<in> ss; dom a s \<in> sources (a # as) s u; \<forall>s\<in>ts. dom a s \<notin> sources (a # as) s u;
   (\<forall>s t. s \<in> ss \<and> t \<in> ts \<longrightarrow> s \<sim>schedDomain\<sim> t \<and> reachable s \<and> reachable t);
   t \<in> ts; confidentiality_u\<rbrakk> \<Longrightarrow>
  False"
  apply(cut_tac s=s and t=t and as=as and u=u in sources_eq, simp+)
  apply(clarsimp  simp: sources_Cons | safe)+
  apply(rename_tac s')
   apply(drule_tac x=t in bspec, simp)
   apply clarsimp
   apply(cut_tac s=t in enabled_Step, simp)
   apply(erule exE, rename_tac t')
   apply(drule_tac x="sources as t' u" in spec)
   apply(cut_tac s=s' and t=t' and u=u in sources_eq, simp+)
      apply(fastforce elim: sched_equiv_preserved)
     apply(fastforce intro: reachable_Step)
    apply(fastforce intro: reachable_Step)
   apply(fastforce simp: schedIncludesCurrentDom)
  apply(drule_tac x=t in bspec, simp)
  apply clarsimp
  apply(rename_tac v s')
  apply(drule_tac x=v in spec, erule impE, fastforce simp: schedIncludesCurrentDom)
  apply(cut_tac s=t in enabled_Step[where a=a], simp, clarsimp, rename_tac t')
  apply(cut_tac s=s' and t=t' and u=u in sources_eq, simp+)
     apply(fastforce elim: sched_equiv_preserved)
    apply(fastforce intro: reachable_Step)
   apply(fastforce intro: reachable_Step)
  apply(fastforce simp: schedIncludesCurrentDom)
  done

lemma ipurge_eq':
  "(\<forall> s t. s\<in>ss \<and> t\<in>ts \<longrightarrow> s \<sim>schedDomain\<sim> t \<and> reachable s \<and> reachable t) \<and>
   (\<exists> s. s \<in> ss) \<and> (\<exists> t. t \<in> ts) \<and> confidentiality_u
    \<longrightarrow> ipurge u as ss = ipurge u as ts"
  proof (induct as arbitrary: ss ts)
  case Nil show ?case
   apply(simp add: ipurge_def)
   done
  next
  case (Cons a as) show ?case
   apply(clarsimp simp: ipurge_Cons schedIncludesCurrentDom)
   apply(intro conjI impI)
      apply(rule "Cons.hyps"[rule_format])
      apply clarsimp
      apply(metis sched_equiv_preserved reachable_Step enabled_Step)
     apply clarsimp
     apply(drule ipurge_eq'_helper, simp+)[1]
    apply clarsimp
    apply(drule ipurge_eq'_helper, (simp add: uwr_sym)+)[1]
   apply(rule "Cons.hyps"[rule_format], auto)
   done
  qed

lemma ipurge_eq:
  "\<lbrakk>s \<sim>schedDomain\<sim> t; reachable s; reachable t;
    confidentiality_u\<rbrakk> \<Longrightarrow>
   ipurge u as {s} = ipurge u as {t}"
  by(rule ipurge_eq'[rule_format], simp)

lemma Noninfluence_uwr_Noninfluence_strong_uwr:
  "\<lbrakk>confidentiality_u; Noninfluence_uwr\<rbrakk> \<Longrightarrow> Noninfluence_strong_uwr"
  apply(clarsimp simp: Noninfluence_uwr_def Noninfluence_strong_uwr_def)
  apply(frule_tac s=s and t=t and as=as and u=u in ipurge_eq)
     apply assumption+
  apply(frule_tac s=s and t=t and as=bs and u=u in ipurge_eq)
     apply assumption+
  apply clarsimp
  apply(drule_tac x=u in spec)
  apply(frule_tac x=as in spec)
  apply(drule_tac x=s in spec, drule_tac x=t in spec)
  apply(drule_tac x=bs in spec)
  apply(drule_tac x=t in spec, drule_tac x=t in spec)
  apply clarsimp
  apply(rule_tac t=t in uwr_equiv_trans)
    apply assumption
   apply assumption
  apply(rule uwr_equiv_sym)
  apply(clarsimp simp: sameFor_dom_def uwr_refl)
  done

lemma Noninfluence_Noninfluence_strong:
  "\<lbrakk>confidentiality_u; Noninfluence\<rbrakk> \<Longrightarrow> Noninfluence_strong"
  apply(clarsimp simp: Noninfluence_def Noninfluence_strong_def)
  apply(frule_tac s=s and t=t and as=as and u=u in ipurge_eq)
     apply assumption+
  apply(frule_tac s=s and t=t and as=bs and u=u in ipurge_eq)
     apply assumption+
  apply clarsimp
  apply(drule_tac x=u in spec)
  apply(frule_tac x=as in spec)
  apply(drule_tac x=s in spec, drule_tac x=t in spec)
  apply(drule_tac x=bs in spec)
  apply(drule_tac x=t in spec, drule_tac x=t in spec)
  apply clarsimp
  apply(rule_tac t=t in obs_equiv_trans)
    apply assumption
   apply assumption
  apply(rule obs_equiv_sym)
  apply(clarsimp simp: sameFor_dom_def uwr_refl)
  done

lemma dom_in_sources_Cons:
  "\<lbrakk>confidentiality_u; reachable s; reachable t;
    s \<approx>(sources (a#as) s u)\<approx> t; s \<sim>schedDomain\<sim> t;
    (dom a s \<in> sources (a#as) s u)\<rbrakk> \<Longrightarrow>
    (dom a t \<in> sources (a#as) t u)"
  apply(subgoal_tac "dom a s = dom a t")
   apply(fastforce dest: sources_eq)
  apply(blast intro: schedIncludesCurrentDom)
  done

lemma uwr_equiv_Cons_bothI:
   "\<lbrakk>reachable s; reachable t;
     \<forall> s' t'. (s,s') \<in> Step a \<and> (t,t') \<in> Step b \<longrightarrow> uwr_equiv s' as t' bs u\<rbrakk> \<Longrightarrow>
    uwr_equiv s (a # as) t (b # bs) u"
  apply(clarsimp simp: uwr_equiv_def)
  apply(clarsimp simp: execution_Run)
  apply(fastforce simp: execution_Run reachable_Step)
  done

lemma uwr_equiv_Cons_leftI:
   "\<lbrakk>reachable s; \<forall> s'. (s,s') \<in> Step a \<longrightarrow> uwr_equiv s' as t bs u\<rbrakk> \<Longrightarrow>
    uwr_equiv s (a # as) t bs u"
  by(fastforce simp: uwr_equiv_def execution_Run reachable_Step)

lemma notin_policyI':
  "\<lbrakk>reachable s;
    dom a s \<notin> sources (a # list) s u; (s,s') \<in> Step a; ua \<in> sources list s' u\<rbrakk> \<Longrightarrow>
   (dom a s,ua) \<notin> policy"
  apply(rule notin_policyI)
  apply auto
  done

lemma sources_eq_Step:
  "\<lbrakk>integrity_u; confidentiality_u; reachable s; (s,s') \<in> Step a; dom a s \<noteq> schedDomain\<rbrakk> \<Longrightarrow>
   (sources as s' u) = (sources as s u)"
  apply(rule sources_eq, simp+)
    apply(rule_tac t=s and s=s and a=a in sched_equiv_preserved_left,
          (simp add: uwr_refl reachable_Step)+)
  done

lemma sources_equiv_preserved_left:
  "\<lbrakk>integrity_u; confidentiality_u; reachable s; reachable t; s \<sim>schedDomain\<sim> t;
    dom a s \<notin> sources (a#as) s u; s \<approx>sources (a#as) s u\<approx> t; (s,s') \<in> Step a; dom a s \<noteq> schedDomain\<rbrakk>
    \<Longrightarrow> s' \<approx>sources as s' u\<approx> t"
  apply(clarsimp simp: sameFor_dom_def)
  apply(rename_tac v)
  apply(case_tac "(dom a s, v) \<in> policy")
   apply(fastforce simp: sources_Cons)
  apply(fastforce dest: integrity_uD simp: sources_Cons)
  done

lemma Noninfluence_gen:
  "\<lbrakk>confidentiality_u; integrity_u\<rbrakk> \<Longrightarrow> Noninfluence_gen"
  apply(subst Noninfluence_gen_def)
  apply(intro allI)
  proof -
  assume conf: "confidentiality_u"
  assume integ: "integrity_u"
  fix u as s ts
  show "reachable s \<and> Ball ts reachable \<longrightarrow>
          Ball ts (sameFor_dom s (sources as s u)) \<longrightarrow> (\<forall>t\<in>ts. s \<sim>schedDomain\<sim> t)
          \<longrightarrow> (\<forall>t\<in>ts. uwr_equiv s as t (ipurge u as ts) u)"
    proof(induct as arbitrary: s ts)
    case Nil
    show ?case
      apply(clarsimp simp: sameFor_dom_def ipurge_Nil sources_Nil uwr_equiv_def)
      apply(clarsimp simp: execution_Run)
      done
    next
    case (Cons a as)
    show ?case
  apply(clarsimp simp: ipurge_Cons | safe)+
   apply(rule uwr_equiv_Cons_bothI)
     apply assumption
    apply blast
   apply(clarify)
   apply(rename_tac ta tb s' tb')
   apply(rule Cons.hyps[rule_format])
      apply(blast intro: reachable_Step)
     apply(clarsimp)
     apply(rename_tac tc' tc)
     using conf apply(rule_tac s=s and t=tc and a=a in sources_unwinding_step, simp+)[1]
    apply(clarsimp, rename_tac tc' tc)
    apply(rule sched_equiv_preserved[OF conf], (auto simp: sources_refl))[1]
   apply blast
  apply(rename_tac ta)
  apply(rule uwr_equiv_Cons_leftI, blast)
  apply(clarsimp, rename_tac s')
  apply(case_tac "dom a s = schedDomain")
   apply(cut_tac s=s and a=a and as=as and u=u in schedDomain_in_sources_Cons, assumption+)
   apply(metis schedIncludesCurrentDom sources_eq[OF conf])
  apply(rule Cons.hyps[rule_format])
     apply(blast intro: reachable_Step)
    apply(rename_tac tb)
    apply(rule_tac a=a in sources_equiv_preserved_left[OF integ conf], simp+)
       apply(fastforce simp: schedIncludesCurrentDom sources_eq[OF conf])
      apply blast
     apply assumption
    apply assumption
   apply(rule_tac s=s and a=a in sched_equiv_preserved_left[OF integ], simp+)
  done
  qed
  qed

lemma Nonleakage_gen:
  "\<lbrakk>confidentiality_u\<rbrakk> \<Longrightarrow> Nonleakage_gen"
  apply(subst Nonleakage_gen_def)
  apply(rule allI)
  apply(induct_tac as)
   apply(simp add: sources_Nil uwr_equiv_def execution_Run sameFor_dom_def)
  apply(clarsimp)
  apply(rule uwr_equiv_Cons_bothI)
    apply assumption
   apply assumption
  apply clarsimp
  apply(drule_tac x=s' in spec, drule_tac x=u in spec, drule_tac x=t' in spec)
  apply(clarsimp simp: reachable_Step)
  apply(erule impE)
   apply(blast intro: sched_equiv_preserved)
  apply(erule mp)
  apply(blast intro: sources_unwinding_step)
  done

lemma Noninterference:
  "\<lbrakk>confidentiality_u_weak; output_consistent; integrity_u\<rbrakk> \<Longrightarrow>
   Noninterference"
  apply(rule Noninfluence_gen_Noninterference)
   apply assumption
  apply(blast intro: Noninfluence_gen confidentiality_u_weak)
  done

lemma Noninterference_strong:
  "\<lbrakk>confidentiality_u_weak; output_consistent; integrity_u\<rbrakk> \<Longrightarrow>
   Noninterference_strong"
  apply(rule Noninfluence_gen_Noninterference_strong)
   apply assumption
  apply(blast intro: Noninfluence_gen confidentiality_u_weak)
  done

lemma Noninfluence:
  "\<lbrakk>confidentiality_u_weak; output_consistent; integrity_u\<rbrakk> \<Longrightarrow>
   Noninfluence"
  apply(rule Noninfluence_gen_Noninfluence)
   apply assumption
  apply(blast intro: Noninfluence_gen confidentiality_u_weak)
  done

lemma Noninfluence_strong:
  "\<lbrakk>confidentiality_u_weak; output_consistent; integrity_u\<rbrakk> \<Longrightarrow>
   Noninfluence_strong"
  apply(rule Noninfluence_Noninfluence_strong)
   apply(blast intro: confidentiality_u_weak)
  apply(blast intro: Noninfluence)
  done

lemma Noninfluence_uwr:
  "\<lbrakk>confidentiality_u_weak; integrity_u\<rbrakk> \<Longrightarrow>
   Noninfluence_uwr"
  apply(rule Noninfluence_gen_Noninfluence_uwr)
  apply(blast intro: Noninfluence_gen confidentiality_u_weak)
  done

lemma Noninfluence_strong_uwr:
  "\<lbrakk>confidentiality_u_weak; integrity_u\<rbrakk> \<Longrightarrow>
   Noninfluence_strong_uwr"
  apply(rule Noninfluence_uwr_Noninfluence_strong_uwr)
   apply(blast intro: confidentiality_u_weak)
  apply(blast intro: Noninfluence_uwr)
  done

lemma sources_Step:
  "\<lbrakk>reachable s; (dom a s, u) \<notin> policy\<rbrakk> \<Longrightarrow>
  sources [a] s u = {u}"
  apply(auto simp: sources_Cons sources_Nil enabled_Step dest: enabled_Step)
  done

lemma sources_Step_2:
  "\<lbrakk>reachable s; (dom a s, u) \<in> policy\<rbrakk> \<Longrightarrow>
  sources [a] s u = {dom a s,u}"
  apply(auto simp: sources_Cons sources_Nil enabled_Step dest: enabled_Step)
  done

lemma execution_Nil:
  "reachable s \<Longrightarrow> execution A s [] = {s}"
  apply(simp add: execution_Run)
  done

lemma Noninfluence_gen_confidentiality_u_weak:
  "Noninfluence_gen \<Longrightarrow> confidentiality_u_weak"
  apply(clarsimp simp: Noninfluence_gen_def confidentiality_u_weak_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec)
  apply(drule_tac x=s in spec, drule_tac x="{t}" in spec)
  apply(simp add: sources_Step_2 sameFor_dom_def uwr_equiv_def Step_def ipurge_Cons ipurge_Nil
           split: if_splits
             add: schedIncludesCurrentDom)
  done

lemma Noninfluence_strong_uwr_confidentiality_u_weak:
  "Noninfluence_strong_uwr \<Longrightarrow> confidentiality_u_weak"
  apply(clarsimp simp: Noninfluence_strong_uwr_def confidentiality_u_weak_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec, drule_tac x="[a]" in spec)
  apply(drule_tac x=s in spec, drule_tac x=t in spec)
  apply(simp add: sources_Step_2 sameFor_dom_def uwr_equiv_def Step_def)
  done

lemma Nonleakage_gen_confidentiality_u:
  "Nonleakage_gen \<Longrightarrow> confidentiality_u"
  apply(clarsimp simp: Nonleakage_gen_def confidentiality_u_def)
  apply(drule_tac x="[a]" in spec, drule_tac x=s in spec)
  apply(drule_tac x=u in spec, drule_tac x=t in spec)
  apply(case_tac "dom a s \<leadsto> u")
   apply(simp add: sources_Step_2 uwr_equiv_def sameFor_dom_def Step_def)
  apply(simp add: sources_Step uwr_equiv_def sameFor_dom_def Step_def)
  done

lemma Nonleakage_gen_equiv_confidentiality_u:
  "Nonleakage_gen = confidentiality_u"
  apply(blast intro: Nonleakage_gen_confidentiality_u Nonleakage_gen)
  done

lemma non_sched_doms_cannot_schedule:
  "\<lbrakk>integrity_u; reachable s; dom a s \<noteq> schedDomain; (s,s') \<in> Step a\<rbrakk> \<Longrightarrow> s \<sim>schedDomain\<sim> s'"
  apply(drule_tac u=schedDomain in integrity_uD)
      apply assumption
     apply(erule contrapos_nn)
     apply(erule schedNotGlobalChannel)
    apply(rule uwr_refl)
   apply assumption
  apply(erule uwr_sym)
  done

text \<open>
   In systems with just a single event, @{prop integrity_u} is a very strong
   condition. It implies that once the scheduler is not
   running, it can never run again.

   This is one explanation for why seL4 (whose automaton has only a single
   event) doesn't satisfy @{prop integrity_u}.
\<close>
lemma integrity_u_and_single_event_systems:
  "\<lbrakk>integrity_u; reachable s; dom a s \<noteq> schedDomain; s' \<in> execution A s as;
    \<forall> y::'e. y = a\<rbrakk> \<Longrightarrow> dom e s' \<noteq> schedDomain"
  apply(frule_tac x=e in spec)
  apply(erule ssubst)
  apply(rule_tac P="\<lambda>x. x \<noteq> schedDomain" in subst[rotated])
   apply assumption
  apply(induct as arbitrary: s s' a rule: rev_induct)
   apply(simp add: execution_Run)
  apply(simp add: execution_Run)
  apply(drule Run_mid)
  apply(erule exE, rename_tac t)
  apply(drule_tac x=s in meta_spec)
  apply(drule_tac x=t in meta_spec)
  apply(drule_tac x=a in meta_spec)
  apply simp
  apply(rule schedIncludesCurrentDom)
  apply(rule non_sched_doms_cannot_schedule)
     apply assumption
    apply(rule reachable_execution)
     apply assumption
    apply(fastforce simp: execution_Run)
   apply assumption
  apply(drule_tac x=x in spec)
  apply blast
  done

end

subsection \<open>Complete unwinding system\<close>

text \<open>The unwinding conditions are not only sound but also complete when policy is reflexive\<close>
locale complete_unwinding_system = unwinding_system +
  assumes  policy_refl:
  "(u,u) \<in> policy"
begin

lemma Noninfluence_gen_integrity_u:
  "Noninfluence_gen \<Longrightarrow> integrity_u"
  apply(clarsimp simp: Noninfluence_gen_def integrity_u_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec)
  apply(drule_tac x=s in spec, drule_tac x="{s}" in spec)
  apply(simp add: sources_Step sameFor_dom_def uwr_equiv_def Step_def ipurge_Cons ipurge_Nil
           split: if_splits add: uwr_refl policy_refl execution_Nil uwr_sym)
  done

lemma Noninfluence_strong_uwr_integrity_u:
  "Noninfluence_strong_uwr \<Longrightarrow> integrity_u"
  apply(clarsimp simp: Noninfluence_strong_uwr_def integrity_u_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec, drule_tac x="[]" in spec)
  apply(drule_tac x=s in spec, drule_tac x=s in spec)
  apply(simp add: sources_Step sameFor_dom_def uwr_refl uwr_equiv_def Step_def ipurge_Cons
                  ipurge_Nil
           split: if_splits)
   apply(simp add: policy_refl)
  apply(simp add: execution_Nil)
  apply(blast intro: uwr_sym)
  done

text \<open>
   @{prop Noninfluence_gen} actually turns out to be equivalent to @{prop Noninfluence_strong_uwr},
   when the policy is reflexive. So the two unwinding conditions for integrity
   and confidentiality actually turn out to be sound and sufficient for the
   condition we were using them to prove in the first place.
\<close>
lemma Noninfluence_gen_equiv_Noninfluence_strong_uwr:
  "Noninfluence_gen = Noninfluence_strong_uwr"
  apply(rule iffI)
   apply(rule Noninfluence_strong_uwr)
    apply(erule Noninfluence_gen_confidentiality_u_weak)
   apply(erule Noninfluence_gen_integrity_u)
  apply(rule Noninfluence_gen)
   apply(rule confidentiality_u_weak)
    apply(erule Noninfluence_strong_uwr_confidentiality_u_weak)
   apply(erule Noninfluence_strong_uwr_integrity_u)+
  done

end

end


theory Failures

imports
 Main
 Failures_Core
 Failures_BasicOps
begin

text \<open> The conjecture here is that there is a Galois connection between the F4 superset, and
       a subset that doesn't observe it necessarily. \<close>

definition sf2f :: "'a process \<Rightarrow> 'a process"
  where "sf2f P = \<Sqinter>{Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> P \<sqsubseteq> (mkF24 Q)}"

text \<open> The following function is the actual one that matters. \<close>

definition sf25f :: "'a process \<Rightarrow> 'a process"
  where "sf25f P = \<Sqinter>{Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> P \<sqsubseteq> (mkF24 Q)}"

definition unmkF25 :: "'a process \<Rightarrow> 'a process"
  where "unmkF25 P = \<Sqinter>{Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> P \<sqsubseteq> (mkF25 Q)}"

lemma sf2f_mono:
  assumes "P \<sqsubseteq> Q"
  shows "sf2f P \<sqsubseteq> sf2f Q"
  using assms unfolding sf2f_def IntChoice_def apply auto
  by (smt SUP_least UN_I mem_Collect_eq prod.sel(1) prod.sel(2) refines_def refines_tran subsetI)

lemma mkF24_mono:
  assumes "P \<sqsubseteq> Q"
  shows "mkF24 P \<sqsubseteq> mkF24 Q"
  using assms unfolding mkF24_def traces_def refines_def by auto

text \<open> Key theorem would be to show that applying mkF24 and sf2f yields the same? \<close>

lemma T1_dist_IntChoice_two_imp:
  assumes "T1 P" "T1 Q"
  shows "T1 (\<Sqinter>{P,Q})"
  using assms unfolding IntChoice_def apply auto
  unfolding T1_def traces_def by auto

lemma T0_closed_intChoice:
  assumes "T0 P" "T0 Q"
  shows "T0 (P \<sqinter> Q)"
  using assms unfolding intChoice_def T0_def traces_def by auto

lemma T1_closed_intChoice:
  assumes "T1 P" "T1 Q"
  shows "T1 (P \<sqinter> Q)"
  using assms unfolding intChoice_def T1_def traces_def by auto

lemma T2_closed_intChoice:
  assumes "T2 P" "T2 Q"
  shows "T2 (P \<sqinter> Q)"
  using assms unfolding intChoice_def T2_def traces_def by auto

lemma F2_closed_intChoice:
  assumes "F2 P" "F2 Q"
  shows "F2 (P \<sqinter> Q)"
  using assms unfolding intChoice_def F2_def traces_def by auto

lemma F3_closed_intChoice:
  assumes "F3 P" "F3 Q"
  shows "F3 (P \<sqinter> Q)"
  using assms unfolding intChoice_def F3_def traces_def apply auto
  by (metis (mono_tags, lifting) Int_Collect Int_emptyI emptyE mem_Collect_eq)+

lemma T1_IntChoice_dist_two_imp:
  assumes "T1 (\<Sqinter>{P,Q})"
  shows "T1 P \<or> T1 Q"
  using assms unfolding IntChoice_def apply auto
  unfolding T1_def traces_def
  oops

lemma T0_dist_IntChoice:
  assumes "T0`S = {True}"
  shows "T0 (\<Sqinter>S)"
  using assms unfolding IntChoice_def T0_def traces_def by auto

lemma T1_dist_IntChoice:
  assumes "T1`S = {True}"
  shows "T1 (\<Sqinter>S)"
  using assms unfolding IntChoice_def T1_def traces_def apply safe
   apply auto[1]
  by (smt UN_iff imageI mem_Collect_eq singleton_conv2 snd_conv)

lemma T2_closed_IntChoice:
  assumes "T2`S = {True}"
  shows "T2 (\<Sqinter>S)"
  using assms unfolding IntChoice_def
  by (smt T2_def UN_iff fst_conv image_iff singleton_iff snd_conv traces_def)

lemma F2_closed_IntChoice:
  assumes "F2`S = {True}"
  shows "F2 (\<Sqinter>S)"
  using assms unfolding IntChoice_def
  by (smt F2_def UN_iff fst_conv image_iff singleton_iff snd_conv traces_def)

lemma F3_closed_IntChoice:
  assumes "F3`S = {True}"
  shows "F3 (\<Sqinter>S)"
  using assms unfolding IntChoice_def F3_def apply safe
  unfolding traces_def apply simp
  by blast

lemma F5_closed_IntChoice:
  assumes "F5`S = {True}"
  shows "F5 (\<Sqinter>S)"
  using assms unfolding IntChoice_def F5_def apply safe
  unfolding traces_def apply simp
  by blast

lemma F6_closed_IntChoice:
  assumes "F6`S = {True}"
  shows "F6 (\<Sqinter>S)"
  using assms unfolding IntChoice_def F6_def apply safe
  unfolding traces_def apply simp
  by blast

lemma
  assumes "traces(P) \<noteq> {}"
  shows "traces(sf2f P) \<noteq> {}"
  using assms unfolding sf2f_def traces_def apply auto
  oops

abbreviation remTraceTick :: "'a trace \<Rightarrow> 'a trace" where
"remTraceTick s == filter (\<lambda>x. x\<noteq>tick) s"

definition remTick :: "'a process \<Rightarrow> 'a process" where
"remTick P = (fst P,remTraceTick`snd P)"

lemma Tick_last_prefix_remTraceTick:
  assumes "Tick_last t"
  shows "prefix (remTraceTick t) t"
  using assms by(induct rule:Tick_last.induct, auto)

lemma remTraceTick_no_last_tick:
  "s @ [tick] \<noteq> remTraceTick x"
  apply (induct s, auto)
  apply (induct x, auto)
   apply (metis (mono_tags, lifting) filter_eq_ConsD list.inject)
  apply (induct x, auto)
  by (smt append.simps(1) append.simps(2) filter_eq_ConsD hd_Cons_tl list.inject not_Cons_self2)

lemma mkF24_remTick_refines:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P"
  shows "P \<sqsubseteq> mkF24(remTick(P))"
  apply (rule refines_rule)
  using assms unfolding remTick_def mkF24_def traces_def apply auto
  using remTraceTick_no_last_tick apply blast
  using remTraceTick_no_last_tick apply blast
  using T0_def T1_def Tick_last_prefix_remTraceTick traces_def by blast

lemma Tick_last_remTraceTick:
  "Tick_last (remTraceTick x)"
  apply (induct x, auto)
  by (case_tac a, auto)

lemma T0_remTick:
  assumes "T0 P"
  shows "T0 (remTick(P))"
  using assms unfolding T0_def traces_def remTick_def using Tick_last_remTraceTick by auto

lemma T0_remTick:
  assumes "T1 P" "T0 P"
  shows "T1 (remTick(P))"
  using assms unfolding T0_def T1_def traces_def remTick_def oops

lemma always_refines_Div:
  assumes "T1 P"
  shows "\<exists>Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> P \<sqsubseteq> mkF24 Q"
  using assms Div_top
  by (metis F2_Div F3_Div F4_Div F5_Div F6_Div T0_Div T1_Div T2_Div mkF24_fixpoint_imp)

lemma always_refines_F5_Div:
  assumes "T1 P"
  shows "\<exists>Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> P \<sqsubseteq> mkF24 Q"
  using assms Div_top
  by (metis F2_Div F3_Div F4_Div F5_Div F6_Div T0_Div T1_Div T2_Div mkF24_fixpoint_imp)

lemma T1_sf2f_ran:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F4 P"
  shows "T1`{Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> P \<sqsubseteq> mkF24 Q} = {True}"
  using assms apply auto
  using always_refines_Div by fastforce

lemma T0_sf2f_ran:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F4 P"
  shows "T0`{Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> P \<sqsubseteq> mkF24 Q} = {True}"
  using assms apply auto
  using always_refines_Div by fastforce

lemma T2_sf2f_ran:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F4 P"
  shows "T2`{Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> P \<sqsubseteq> mkF24 Q} = {True}"
  using assms apply auto
  using always_refines_Div by fastforce

lemma F2_sf2f_ran:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F4 P"
  shows "F2`{Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> P \<sqsubseteq> mkF24 Q} = {True}"
  using assms apply auto
  using always_refines_Div by fastforce

lemma F3_sf2f_ran:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F4 P"
  shows "F3`{Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> P \<sqsubseteq> mkF24 Q} = {True}"
  using assms apply auto
  using always_refines_Div by fastforce

(* sf25 below *)

lemma T1_sf25f_ran:
  assumes "T1 P"
  shows "T1`{Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> P \<sqsubseteq> mkF24 Q} = {True}"
  using assms apply auto
  using always_refines_F5_Div by fastforce

lemma T0_sf25f_ran:
  assumes "T1 P"
  shows "T0`{Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> P \<sqsubseteq> mkF24 Q} = {True}"
  using assms apply auto
  using always_refines_F5_Div by fastforce

lemma T2_sf25f_ran:
  assumes "T1 P"
  shows "T2`{Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> P \<sqsubseteq> mkF24 Q} = {True}"
  using assms apply auto
  using always_refines_F5_Div by fastforce

lemma F2_sf25f_ran:
  assumes "T1 P"
  shows "F2`{Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> P \<sqsubseteq> mkF24 Q} = {True}"
  using assms apply auto
  using always_refines_F5_Div by fastforce

lemma F3_sf25f_ran:
  assumes "T1 P"
  shows "F3`{Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> P \<sqsubseteq> mkF24 Q} = {True}"
  using assms apply auto
  using always_refines_F5_Div by fastforce

lemma F5_sf25f_ran:
  assumes "T1 P"
  shows "F5`{Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> P \<sqsubseteq> mkF24 Q} = {True}"
  using assms apply auto
  using always_refines_F5_Div by fastforce

lemma F6_sf25f_ran:
  assumes "T1 P"
  shows "F6`{Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> P \<sqsubseteq> mkF24 Q} = {True}"
  using assms apply auto
  using always_refines_F5_Div by fastforce

lemma T1_sf2f:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F4 P"
  shows "T1 (sf2f P)"
  using assms unfolding sf2f_def using T1_sf2f_ran
  by (metis (no_types, lifting) Collect_cong T1_dist_IntChoice)

lemma T0_sf2f:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F4 P"
  shows "T0 (sf2f P)"
  using assms unfolding sf2f_def using T0_sf2f_ran
  by (metis (no_types, lifting) Collect_cong T0_dist_IntChoice)

lemma T2_sf2f:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F4 P"
  shows "T2 (sf2f P)"
  using assms unfolding sf2f_def using T2_sf2f_ran
  by (metis (no_types, lifting) Collect_cong T2_closed_IntChoice)

lemma F3_sf2f:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F4 P"
  shows "F3 (sf2f P)"
  using assms unfolding sf2f_def using F3_sf2f_ran
  by (metis (no_types, lifting) Collect_cong F3_closed_IntChoice)

(* sf25 below *)

lemma T1_sf25f:
  assumes "T1 P"
  shows "T1 (sf25f P)"
  using assms unfolding sf25f_def using T1_sf25f_ran
  by (metis (no_types, lifting) Collect_cong T1_dist_IntChoice)

lemma T0_sf25f:
  assumes "T1 P"
  shows "T0 (sf25f P)"
  using assms unfolding sf25f_def using T0_sf25f_ran
  by (metis (no_types, lifting) Collect_cong T0_dist_IntChoice)

lemma T2_sf25f:
  assumes "T1 P"
  shows "T2 (sf25f P)"
  using assms unfolding sf25f_def using T2_sf25f_ran
  by (metis (no_types, lifting) Collect_cong T2_closed_IntChoice)

lemma F3_sf25f:
  assumes "T1 P"
  shows "F3 (sf25f P)"
  using assms unfolding sf25f_def using F3_sf25f_ran
  by (metis (no_types, lifting) Collect_cong F3_closed_IntChoice)

lemma F5_sf25f:
  assumes "T1 P"
  shows "F5 (sf25f P)"
  using assms unfolding sf25f_def using F5_sf25f_ran
  by (metis (no_types, lifting) Collect_cong F5_closed_IntChoice)

lemma F6_sf25f:
  assumes "T1 P"
  shows "F6 (sf25f P)"
  using assms unfolding sf25f_def using F6_sf25f_ran
  by (metis (no_types, lifting) Collect_cong F6_closed_IntChoice)

lemma traces_eq_traces_mkF24:
  shows "traces P = traces (mkF24 P)"
  unfolding traces_def mkF24_def by auto

lemma traces_eq_traces_mkF25:
  shows "traces P = traces (mkF25 P)"
  unfolding traces_def mkF25_def by auto

(*
lemma traces_eq_traces_unmkF25:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F4 P"
  shows "traces P \<subseteq> traces (unmkF25 P)"
  using assms
  unfolding unmkF25_def mkF25_def refines_def IntChoice_def traces_def apply auto
  by (smt Collect_cong F4_F2_imp_tick_failures UNIV_I case_prod_conv prod.collapse subsetI)*)

lemma traces_eq_traces_sf2f:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F4 P"
  shows "traces P \<subseteq> traces (sf2f P)"
  using assms
  unfolding sf2f_def mkF24_def refines_def IntChoice_def traces_def apply auto
  by (smt Collect_cong F4_F2_imp_tick_failures UNIV_I case_prod_conv prod.collapse subsetI)

lemma T0_empty_failures[simp]:
  assumes "T0 P"
  shows "T0 ({}, snd P)"
  using assms unfolding T0_def traces_def by auto

lemma T1_empty_failures[simp]:
  assumes "T1 P"
  shows "T1({}, snd P)"
  using assms unfolding T1_def traces_def by auto

lemma T2_empty_failures[simp]:
  "T2({}, snd P)"
  unfolding T2_def traces_def by auto

lemma F2_empty_failures[simp]:
  "F2({}, snd P)"
  unfolding F2_def by auto

lemma F3_empty_failures[simp]:
  "F3({}, snd P)"
  unfolding F3_def by auto

lemma F5_empty_failures[simp]:
  "F5({}, snd P)"
  unfolding F5_def by auto

lemma F6_empty_failures[simp]:
  "F6({}, snd P)"
  unfolding F6_def by auto

lemma traces_imp_traces_sf25f:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F4 P"
  shows "traces P \<subseteq> traces (sf25f P)"
  using assms
  unfolding sf25f_def IntChoice_def traces_def apply auto
  apply (rule exI[where x="{}"])
  apply (rule exI[where x="snd P"], auto)
  unfolding mkFailuresF5_def mkF24_def traces_def refines_def traces_def apply auto
  apply (metis F2_def F4_def insert_subset traces_def)
  by (metis F2_def F4_def insert_subset subset_UNIV traces_def)

lemma traces_sf25f_imp_traces:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P"
  shows "traces (sf25f P) \<subseteq> traces P"
  using assms
  unfolding sf25f_def mkF24_def refines_def IntChoice_def traces_def by auto

lemma traces_sf2f_eq_traces:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F4 P"
  shows "traces (sf2f P) \<subseteq> traces P"
  using assms
  unfolding sf2f_def mkF24_def refines_def IntChoice_def traces_def by auto

lemma traces_sf2f_eq:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F4 P"
  shows "traces (sf2f P) = traces P"
  by (simp add: assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) subset_antisym traces_eq_traces_sf2f traces_sf2f_eq_traces)

lemma traces_sf25f_eq:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F4 P"
  shows "traces (sf25f P) = traces P"
  by (simp add: antisym assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) traces_imp_traces_sf25f traces_sf25f_imp_traces)

lemma mkF24_sf2f_refined:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F4 P"
  shows "mkF24 (sf2f P) \<sqsubseteq> P"
proof (rule refines_rule)
  show "fst P \<subseteq> fst (mkF24 (sf2f P))"
    using assms unfolding mkF24_def apply auto
    by (smt IntChoice_def UN_I assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) fst_conv le_sup_iff mem_Collect_eq mkF24_def mkF24_fixpoint_imp refines_refl sf2f_def subsetI subset_eq subset_iff traces_eq_traces_mkF24)

  show "snd P \<subseteq> snd (mkF24 (sf2f P))"
    using assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) traces_def traces_eq_traces_mkF24 traces_eq_traces_sf2f by blast
qed

lemma mkF24_sf25f_refines:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F4 P"
  shows "P \<sqsubseteq> mkF24 (sf25f P)"
proof (rule refines_rule)
  show "snd (mkF24 (sf25f P)) \<subseteq> snd P"
   using assms(1) assms(2) assms(3) assms(4) assms(5) traces_def traces_eq_traces_mkF24 traces_sf25f_imp_traces by blast

  show "fst (mkF24 (sf25f P)) \<subseteq> fst P"
    unfolding sf25f_def mkF24_def traces_def IntChoice_def apply auto
      apply (simp add: refines_def subset_eq)
        apply (metis (no_types, lifting) F2_def F4_def assms(4) assms(6) insert_Diff insert_subset refines_def snd_conv traces_def)
        by (smt Un_subset_iff case_prodI2 fst_conv mem_Collect_eq refines_def subset_eq)
qed

lemma sf25f_mkF24_refined:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F5 P" "F6 P"
  shows "sf25f (mkF24 P) \<sqsubseteq> P"
proof (rule refines_rule)
  show "snd P \<subseteq> snd (sf25f (mkF24 P))"
    by (metis F2_mkF24 F3_mkF24 F4_mkF24 T0_def T1_mkF24 T2_mkF24 assms(1) assms(2) assms(3) assms(4) assms(5) eq_iff traces_def traces_eq_traces_mkF24 traces_sf25f_eq)

  show "fst P \<subseteq> fst (sf25f (mkF24 P))"
    unfolding sf25f_def mkF24_def traces_def IntChoice_def apply auto
    using assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) assms(7) refines_refl by force
qed

text \<open> The following only holds because cardinality of 'a evt, when not tick is
       non-zero? Otherwise they would map to the same. \<close>

lemma Stop_not_Skip_mkF24:
  shows "\<not> mkF24 (StopF) \<sqsubseteq> mkF24(SkipUF)"
  unfolding SkipUF_def StopF_def intChoice_def
  unfolding refines_def mkF24_def traces_def by auto

lemma F6_termination_not_F4:
  assumes "F6 P" "\<exists>s. s@[tick] \<in> snd P"
  shows "\<not> F4 P"
  using assms unfolding F6_def F4_def traces_def by auto

lemma F4_termination_not_F6:
  assumes "F4 P" "\<exists>s. s@[tick] \<in> snd P"
  shows "\<not> F6 P"
  using assms unfolding F6_def F4_def traces_def by auto

lemma mkF24_eq_1:
  assumes "(a, b) \<in> fst Q" "(a, b) \<notin> fst P" "(mkF24 P) \<sqsubseteq> (mkF24 Q)"
  shows "\<exists>s. s @ [tick] \<in> snd P \<and> (a = s \<and> b \<subseteq> UNIV - {tick} \<or> a = s @ [tick])"
  using assms unfolding mkF24_def refines_def traces_def by auto

lemma mkF24_eq_2:
  assumes "(s, b) \<notin> fst P" "s @ [tick] \<in> snd Q" "b \<subseteq> UNIV - {tick}" "(mkF24 P) \<sqsubseteq> (mkF24 Q)"
  shows "\<exists>sa. sa @ [tick] \<in> snd P \<and> (s = sa \<or> s = sa @ [tick])"
  using assms unfolding mkF24_def refines_def traces_def by auto

lemma mkF24_eq_3:
  assumes "(s @ [tick], b) \<notin> fst P" "s @ [tick] \<in> snd Q" "(mkF24 P) \<sqsubseteq> (mkF24 Q)"
  shows "\<exists>sa. sa @ [tick] \<in> snd P \<and> (s @ [tick] = sa \<and> b \<subseteq> UNIV - {tick} \<or> s = sa)"
  using assms unfolding mkF24_def refines_def traces_def by auto

lemma F235_mkF24_rev_mono:
  assumes "(mkF24 P) \<sqsubseteq> (mkF24 Q)" "F2 Q" "F5 Q" "F6 Q" "F2 P" "F5 P" "F6 P"
  shows "fst Q \<subseteq> fst P"
proof -

  have Q_mkF25: "Q = mkF25 Q"
    by (simp add: F5_F2_imp_mkF25_fixpoint assms)

  have P_mkF25: "P = mkF25 P"
    by (simp add: F5_F2_imp_mkF25_fixpoint assms)

   have "fst (mkF25 Q) \<subseteq> fst (mkF25 P)"
      unfolding mkF25_def traces_def apply auto
      using assms mkF24_eq_1
      using F5_def F6_def by blast+

   then have "fst Q \<subseteq> fst P"
     using Q_mkF25 P_mkF25 by auto

   then show ?thesis .
 qed

lemma sf25f_mkF24_refines:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F5 P" "F6 P"
  shows "P \<sqsubseteq> sf25f (mkF24 P)"
proof (rule refines_rule)
  show "snd (sf25f (mkF24 P)) \<subseteq> snd P"
    by (metis F2_mkF24 F3_mkF24 F4_mkF24 T0_def T1_mkF24 T2_mkF24 assms(1) assms(2) assms(3) assms(4) assms(5) eq_iff traces_def traces_eq_traces_mkF24 traces_sf25f_eq)

  show "fst (sf25f (mkF24 P)) \<subseteq> fst P"
  proof -
    have fst_sf25f:"fst (sf25f (mkF24 P)) = {x. \<exists>Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> (mkF24 P) \<sqsubseteq> (mkF24 Q) \<and> x \<in> (fst Q)}"
    proof -
      have "fst (sf25f (mkF24 P)) = fst (\<Sqinter>{Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> (mkF24 P) \<sqsubseteq> (mkF24 Q)})"
        unfolding sf25f_def by auto
      also have "... = \<Union>(fst`{Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> (mkF24 P) \<sqsubseteq> (mkF24 Q)})"
        unfolding IntChoice_def by auto
      also have "... = \<Union>({y. \<exists>x. x \<in> {Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> (mkF24 P) \<sqsubseteq> (mkF24 Q)} \<and> y = (fst x)})"
        by auto
      also have "... = \<Union>({y. \<exists>Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> (mkF24 P) \<sqsubseteq> (mkF24 Q) \<and> y = (fst Q)})"
        by auto (* \<Union>A = {x. \<exists>B \<in> A. x \<in> B} *)
      also have "... = {x. \<exists>B \<in> {y. \<exists>Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> (mkF24 P) \<sqsubseteq> (mkF24 Q) \<and> y = (fst Q)}. x \<in> B}"
        by auto
      also have "... = {x. \<exists>Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> (mkF24 P) \<sqsubseteq> (mkF24 Q) \<and> x \<in> (fst Q)}"
        by auto
      finally show ?thesis .
    qed

    have "{x. \<exists>Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> (mkF24 P) \<sqsubseteq> (mkF24 Q) \<and> x \<in> (fst Q)} \<subseteq> fst P"
      using assms F235_mkF24_rev_mono apply auto
      by (smt fst_conv subset_eq F235_mkF24_rev_mono)

    then have "fst (sf25f (mkF24 P)) \<subseteq> fst P"
      using fst_sf25f by auto

    then show ?thesis .
  qed
qed

lemma sf25f_mkF24_eq:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F5 P" "F6 P"
  shows "sf25f (mkF24 P) = P"
  apply (rule refines_asym)
   apply (simp add: assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) assms(7) sf25f_mkF24_refined)
  using assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) assms(7) sf25f_mkF24_refines by blast

lemma T0_mkFailuresF5_remTraceTick [simp]:
  assumes "T0 P"
  shows "T0(mkFailuresF5 (fst P),remTraceTick`snd P)"
  using assms unfolding T0_def traces_def mkFailuresF5_def apply auto
  using Tick_last_remTraceTick by blast

definition mkF5_weak_failure where "mkF5_weak_failure P == {(t,X). (t = [] \<or> last t \<noteq> tick) \<and> (t,X) \<in> P \<and> (t,X\<union>{tick}) \<in> P}"

definition mkF5_weak :: "'a process \<Rightarrow> 'a process"
  where "mkF5_weak P = (mkF5_weak_failure (fst P), snd P)"

lemma F5_mkF5_weak[simp]:
  shows "F5 (mkF5_weak P)"
  unfolding mkF5_weak_def F5_def mkF5_weak_failure_def by auto

lemma T0_mkF5_weak_failure [simp]:
  assumes "T0 P"
  shows "T0 (mkF5_weak_failure (fst P), snd P)"
  using assms unfolding T0_def traces_def by auto

lemma T1_mkF5_weak_failure [simp]:
  assumes "T1 P"
  shows "T1 (mkF5_weak_failure (fst P), snd P)"
  using assms unfolding T1_def traces_def by auto

lemma T2_mkF5_weak_failure [simp]:
  assumes "T2 P"
  shows "T2 (mkF5_weak_failure (fst P), snd P)"
  using assms unfolding T2_def traces_def mkF5_weak_failure_def by auto

lemma F2_mkF5_weak_failure [simp]:
  assumes "F2 P"
  shows "F2 (mkF5_weak_failure (fst P), snd P)"
  using assms unfolding F2_def traces_def mkF5_weak_failure_def apply auto
  by blast+

lemma F3_mkF5_weak_failure [simp]:
  assumes "F3 P"
  shows "F3 (mkF5_weak_failure (fst P), snd P)"
  using assms unfolding F3_def traces_def mkF5_weak_failure_def apply auto
  proof -
    fix X :: "'a evt set" and Y :: "'a evt set"
  assume a1: "\<forall>s X Y. (s, X) \<in> fst P \<and> Y \<inter> {x. s @ [x] \<in> snd P} = {} \<longrightarrow> (s, X \<union> Y) \<in> fst P"
    assume a2: "([], insert tick X) \<in> fst P"
    assume "Y \<inter> {x. [x] \<in> snd P} = {}"
    then have "Y \<inter> {e. [] @ [e] \<in> snd P} \<subseteq> {}"
  by simp
    then have "([], insert tick X \<union> Y) \<in> fst P"
      using a2 a1 by blast
    then show "([], insert tick (X \<union> Y)) \<in> fst P"
  by force
next
  fix X Y :: "'a evt set" and s :: "'a trace"
  assume as:"\<forall>s X Y. (s, X) \<in> fst P \<and> Y \<inter> {x. s @ [x] \<in> snd P} = {} \<longrightarrow> (s, X \<union> Y) \<in> fst P"
  and as1:"(s, X) \<in> fst P"
  and as2:"(s, insert tick X) \<in> fst P"
  and as3:"Y \<inter> {x. s @ [x] \<in> snd P} = {}"
  and as4:"last s \<noteq> tick"
  show "(s, insert tick (X \<union> Y)) \<in> fst P"
    using as as1 as2 as3 as4 by (metis Un_insert_left)
qed

lemma F5_mkF5_weak_failure [simp]:
  shows "F5 (mkF5_weak_failure (fst P), snd P)"
  unfolding F5_def traces_def mkF5_weak_failure_def by auto

lemma F6_mkF5_weak_failure [simp]:
  shows "F6 (mkF5_weak_failure (fst P), snd P)"
  unfolding F6_def traces_def mkF5_weak_failure_def by auto

lemma mkF24_mkF5_weak_failure:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F4 P"
  shows "P \<sqsubseteq> mkF24 (mkF5_weak_failure (fst P), snd P)"
  using assms unfolding refines_def mkF24_def mkF5_weak_failure_def traces_def apply auto
   apply (metis F2_def F4_def insert_subset traces_def)
  by (metis F2_def F4_def insert_subset subset_UNIV traces_def)

lemma UNIV_tick:
  assumes "(a,b) \<in> fst P" "\<not> b \<subseteq> UNIV-{tick}"
  shows "(a,b\<union>{tick}) \<in> fst P"
  using assms insert_absorb by fastforce

lemma no_tick_then_refuse:
  assumes "F3 P" "(s,b) \<in> fst P" "s @ [tick] \<notin> snd P"
  shows "(s,b\<union>{tick}) \<in> fst P"
  by (metis (no_types, lifting) F3_def Int_emptyI assms mem_Collect_eq singletonD traces_def)

lemma mkF24_sf25f_refined:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F4 P"
  shows "mkF24 (sf25f P) \<sqsubseteq> P"
proof (rule refines_rule)
  show "snd P \<subseteq> snd (mkF24 (sf25f P))"
    by (metis assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) order_refl traces_def traces_eq_traces_mkF24 traces_sf25f_eq)

  show "fst P \<subseteq> fst (mkF24 (sf25f P))"
  proof -
    have A:"fst (mkF24 (sf25f P)) = {y. \<exists>Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> P \<sqsubseteq> (mkF24 Q) \<and> y \<in> fst (mkF24 Q)}"
    proof -
      have "fst (mkF24 (sf25f P)) = fst (mkF24 (\<Sqinter>{Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> P \<sqsubseteq> (mkF24 Q)}))"
        unfolding sf25f_def by auto
      also have "... = fst (\<Sqinter>(mkF24`{Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> P \<sqsubseteq> (mkF24 Q)}))"
        unfolding IntChoice_def mkF24_def traces_def refines_def apply auto
        by blast+
      also have "... = fst (\<Sqinter>({y. \<exists>x. x \<in> {Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> P \<sqsubseteq> (mkF24 Q)} \<and> y = mkF24 x}))"
        unfolding IntChoice_def traces_def refines_def by auto
      also have "... = \<Union>({y. \<exists>x. x \<in> {Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> P \<sqsubseteq> (mkF24 Q)} \<and> y = fst (mkF24 x)})"
        unfolding IntChoice_def traces_def refines_def
        apply auto
        by blast
      also have "... = \<Union>({y. \<exists>Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> P \<sqsubseteq> (mkF24 Q) \<and> y = fst (mkF24 Q)})"
        by auto
      also have "... = {y. \<exists>Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> P \<sqsubseteq> (mkF24 Q) \<and> y \<in> fst (mkF24 Q)}"
        by auto
      finally show ?thesis .
    qed

    have B:"fst P \<subseteq> {y. \<exists>Q. T0 Q \<and> T1 Q \<and> T2 Q \<and> F2 Q \<and> F3 Q \<and> F5 Q \<and> F6 Q \<and> P \<sqsubseteq> (mkF24 Q) \<and> y \<in> fst (mkF24 Q)}"
      apply auto
      using assms
      apply (rule_tac x="mkF5_weak_failure (fst P)" in exI)
      apply (rule exI[where x="snd P"])
      apply auto
      apply (simp add:mkF24_mkF5_weak_failure)
      unfolding mkF24_def mkF5_weak_failure_def traces_def apply auto
      apply (metis (full_types) T2_def append_butlast_last_id traces_def)
      using UNIV_tick no_tick_then_refuse
      by (metis Un_empty_right Un_insert_right)

    have "fst P \<subseteq> fst (mkF24 (sf25f P))"
      using A B by auto
    then show ?thesis .
  qed
qed

lemma mkF24_sf25f_eq:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F4 P"
  shows "mkF24 (sf25f P) = P"
  by (simp add: assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) mkF24_sf25f_refined mkF24_sf25f_refines refines_asym)

lemma mkF24_sf2f_refines:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F4 P"
  shows "P \<sqsubseteq> mkF24 (sf2f P)"
proof (rule refines_rule)
  show "snd (mkF24 (sf2f P)) \<subseteq> snd P"
    by (metis assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) order_refl traces_def traces_eq_traces_mkF24 traces_sf2f_eq)

 show "fst (mkF24 (sf2f P)) \<subseteq> fst P"
   by (smt IntChoice_def SUP_least UN_I UnCI Un_absorb2 assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) case_prodI2 case_prod_conv fst_conv mem_Collect_eq mkF24_def mkF24_fixpoint_imp refines_def refines_refl sf2f_def subset_iff surjective_pairing traces_def traces_eq_traces_mkF24 traces_sf2f_eq)
qed

text \<open> Therefore, our model of failures is just as expressive as stable failures. \<close>

lemma mkF24_sf2f_eq:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F4 P"
  shows "mkF24 (sf2f P) = P"
  by (simp add: assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) mkF24_sf2f_refined mkF24_sf2f_refines refines_asym)

lemma mkF25_unmkF25_refined:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F5 P"
  shows "mkF25 (unmkF25 P) \<sqsubseteq> P"
proof (rule refines_rule)
  show "fst P \<subseteq> fst (mkF25 (unmkF25 P))"
    unfolding mkF25_def unmkF25_def IntChoice_def refines_def apply auto
    proof -
      fix a :: "'a evt list" and b :: "'a evt set"
      assume a1: "(a, b) \<in> fst P"
      assume a2: "\<forall>aa ba. ba \<subseteq> snd P \<longrightarrow> {(t, X). \<exists>Y. (t, Y) \<in> aa \<and> X \<subseteq> insert tick Y} \<subseteq> fst P \<longrightarrow> aa \<subseteq> fst P \<longrightarrow> F3 (aa, ba) \<longrightarrow> F2 (aa, ba) \<longrightarrow> T2 (aa, ba) \<longrightarrow> T1 (aa, ba) \<longrightarrow> T0 (aa, ba) \<longrightarrow> (a, b) \<notin> aa"
      have f3: "F3 (fst P, snd P)"
        by (metis assms(5) prod.collapse)
      have f4: "F2 (fst P, snd P)"
        by (metis assms(4) prod.collapse)
      have f5: "T2 (fst P, snd P)"
        by (simp add: assms(3))
      have f6: "T1 (fst P, snd P)"
        using assms(2) by fastforce
      have f7: "T0 (fst P, snd P)"
        by (simp add: assms(1))
      have "{(es, E). \<exists>Ea. (es, Ea) \<in> fst P \<and> E \<subseteq> insert tick Ea} \<subseteq> fst P"
        using F5_F2_imp_tick_failures assms(4) assms(6) by blast
      then show "\<exists>Y. (\<exists>aa b. T0 (aa, b) \<and> T1 (aa, b) \<and> T2 (aa, b) \<and> F2 (aa, b) \<and> F3 (aa, b) \<and> aa \<subseteq> fst P \<and> {(t, X). \<exists>Y. (t, Y) \<in> aa \<and> X \<subseteq> insert tick Y} \<subseteq> fst P \<and> b \<subseteq> snd P \<and> (a, Y) \<in> aa) \<and> b \<subseteq> insert tick Y"
        using f7 f6 f5 f4 f3 a2 a1 by (meson subsetI)
    qed

  show "snd P \<subseteq> snd (mkF25 (unmkF25 P))"
      unfolding mkF25_def unmkF25_def IntChoice_def refines_def apply auto
      by (metis (mono_tags) F5_F2_imp_tick_failures assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) subset_refl surjective_pairing)
  qed

lemma mkF25_unmkF25_refines:
  shows "P \<sqsubseteq> mkF25 (unmkF25 P)"
proof (rule refines_rule)
  show "fst (mkF25 (unmkF25 P)) \<subseteq> fst P"
    unfolding mkF25_def unmkF25_def IntChoice_def refines_def by auto
  show "snd (mkF25 (unmkF25 P)) \<subseteq> snd P"
    unfolding mkF25_def unmkF25_def IntChoice_def refines_def by auto
qed

lemma mkF25_unmkF25_eq:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P" "F5 P"
  shows "mkF25 (unmkF25 P) = P"
  by (simp add: assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) mkF25_unmkF25_refined mkF25_unmkF25_refines refines_asym)

lemma unmkF25_mkF25_refined:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P"
  shows "unmkF25 (mkF25 P) \<sqsubseteq> P"
proof (rule refines_rule)
  show "fst P \<subseteq> fst (unmkF25 (mkF25 P))"
    unfolding mkF25_def unmkF25_def IntChoice_def refines_def apply auto
    proof -
      fix a :: "'a evt list" and b :: "'a evt set"
      assume "(a, b) \<in> fst P"
      then have "\<exists>Pa. F3 (Pa, snd P) \<and> F2 (Pa, snd P) \<and> T2 (Pa, snd P) \<and> T1 (Pa, snd P) \<and> T0 (Pa, snd P) \<and> (a, b) \<in> Pa \<and> Pa \<subseteq> fst P \<union> {(es, E). \<exists>Ea. (es, Ea) \<in> fst P \<and> E \<subseteq> insert tick Ea} \<and> {(es, E). \<exists>Ea. (es, Ea) \<in> Pa \<and> E \<subseteq> insert tick Ea} \<subseteq> fst P \<union> {(es, E). \<exists>Ea. (es, Ea) \<in> fst P \<and> E \<subseteq> insert tick Ea}"
        using assms(1) assms(2) assms(3) assms(4) assms(5) by force
      then show "\<exists>Pa E. T0 (Pa, E) \<and> T1 (Pa, E) \<and> T2 (Pa, E) \<and> F2 (Pa, E) \<and> F3 (Pa, E) \<and> Pa \<subseteq> fst P \<union> {(es, E). \<exists>Ea. (es, Ea) \<in> fst P \<and> E \<subseteq> insert tick Ea} \<and> {(es, E). \<exists>Ea. (es, Ea) \<in> Pa \<and> E \<subseteq> insert tick Ea} \<subseteq> fst P \<union> {(es, E). \<exists>Ea. (es, Ea) \<in> fst P \<and> E \<subseteq> insert tick Ea} \<and> E \<subseteq> snd P \<and> (a, b) \<in> Pa"
        by auto
    qed

  show "snd P \<subseteq> snd (unmkF25 (mkF25 P))"
    unfolding mkF25_def unmkF25_def IntChoice_def refines_def apply auto
    proof -
      fix x :: "'a evt list"
      assume "x \<in> snd P"
      then have "\<exists>E. (((((x \<in> E \<and> E \<subseteq> snd P) \<and> T2 (fst P, E)) \<and> T1 (fst P, E)) \<and> T0 (fst P, E)) \<and> F3 (fst P, E)) \<and> F2 (fst P, E)"
        by (metis (full_types) assms(1) assms(2) assms(3) assms(4) assms(5) prod.collapse subset_refl)
      then show "\<exists>Pa E. T0 (Pa, E) \<and> T1 (Pa, E) \<and> T2 (Pa, E) \<and> F2 (Pa, E) \<and> F3 (Pa, E) \<and> Pa \<subseteq> fst P \<union> {(es, E). \<exists>Ea. (es, Ea) \<in> fst P \<and> E \<subseteq> insert tick Ea} \<and> {(es, E). \<exists>Ea. (es, Ea) \<in> Pa \<and> E \<subseteq> insert tick Ea} \<subseteq> fst P \<union> {(es, E). \<exists>Ea. (es, Ea) \<in> fst P \<and> E \<subseteq> insert tick Ea} \<and> E \<subseteq> snd P \<and> x \<in> E"
        by blast
    qed
  qed

text \<open> How about the other way around? \<close>

lemma "fst (sf2f (mkF24 (({},{[],[tick]})))) = {}"
  unfolding sf2f_def mkF24_def traces_def IntChoice_def refines_def apply auto
  apply (case_tac aa, auto)
  oops

lemma traces_sf2f_mkF24_eq:
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P"
  shows "traces (sf2f (mkF24 P)) = traces P"
  using assms
  by (metis F2_mkF24 F3_mkF24 F4_mkF24 T0_def T1_mkF24 T2_mkF24 traces_eq_traces_mkF24 traces_sf2f_eq)

lemma mkF24_traces_refines:
  assumes "(mkF24 P) \<sqsubseteq> (mkF24 Q)"
  shows "snd Q \<subseteq> snd P"
  using assms unfolding mkF24_def traces_def apply auto
  by (metis (no_types, lifting) in_mono refines_def snd_conv)

lemma mkF24_dist_intChoice:
  "mkF24(P \<sqinter> Q) = mkF24(P) \<sqinter> mkF24(Q)"
  apply (rule refines_asym)
  unfolding mkF24_def intChoice_def traces_def refines_def by auto

lemma
  assumes "T0 P" "T1 P" "T2 P" "F2 P" "F3 P"
  shows "sf2f(mkF24(P)) \<sqsubseteq> P"
proof (rule refines_rule)
  show "snd P \<subseteq> snd (sf2f (mkF24 P))"
    by (metis F2_mkF24 F3_mkF24 F4_mkF24 T0_def T1_mkF24 T2_mkF24 assms(1) assms(2) assms(3) assms(4) assms(5) eq_iff traces_def traces_eq_traces_mkF24 traces_sf2f_eq)

  show "fst P \<subseteq> fst (sf2f (mkF24 P))"
    unfolding sf2f_def mkF24_def traces_def IntChoice_def apply auto
    using assms(1) assms(2) assms(3) assms(4) assms(5) refines_refl by force
qed

(* Old below *)

definition D1 :: "'a process \<Rightarrow> bool"
 where "D1 P \<equiv> \<forall>s t. s \<in> (snd P) \<longrightarrow> (s@t) \<in> (snd P)"

definition D2 :: "'a process \<Rightarrow> bool"
 where "D2 P \<equiv> \<forall>s X. s \<in> (snd P) \<longrightarrow> (s, X) \<in> (fst P)"

definition trace :: "'a failure \<Rightarrow> 'a trace"
 where "trace f = fst f"

definition fd2r :: "('a failure) set \<Rightarrow> ('a trace) set \<Rightarrow> 'a prel"
 where "fd2r F D = { (s,s'). {the s,the s'} \<subseteq> F \<and> s \<noteq> None \<and> s' \<noteq> None
                             \<and> (\<exists>a. trace (the s') = (trace (the s) @ a))
                             }
                   \<union> { (s,s'). trace (the s) \<in> D \<and>
                               (s'=None \<or> (\<exists>a. trace (the s') = trace (the s) @ a)) } \<union> { (None,None) }"

definition fdP2r :: "'a process \<Rightarrow> 'a prel"
 where "fdP2r P = fd2r (fst P) (snd P)"

definition divFailureStrict :: "('a failure) set \<Rightarrow> ('a trace) set \<Rightarrow> ('a failure) set"
 where "divFailureStrict F D = F \<union> {(s,X). s \<in> D}"

definition divStrict :: "('a trace) set \<Rightarrow> ('a trace) set"
 where "divStrict D = D \<union> {s'. \<exists>s a. s' = s @ a \<and> s \<in> D}"

definition F2f :: "('a failure) set \<Rightarrow> bool"
 where "F2f F \<equiv> \<forall>s X Y. (s, X) \<in> F \<and> Y \<subseteq> X \<longrightarrow> (s, Y) \<in> F"

section {* Relational model*}

subsection {* Healthiness Conditions*}

text {* In a predicative style *}

text {* Prefix closure *}

definition CR1H :: "'a prel \<Rightarrow> bool"
 where "CR1H R = (\<forall>s s'. ((s,s') \<in> R \<and> s\<noteq>None \<and> s'\<noteq>None) \<longrightarrow> (\<exists>t. trace (the s') = trace (the s) @ t))"

text {* Divergence strictness*}

definition CR2H :: "'a prel \<Rightarrow> bool"
 where "CR2H R = (\<forall>s s'. ((s,None) \<in> R \<and> s \<noteq> None \<and> s' \<noteq> None
                  \<and> trace (the s) = trace (the s')) \<longrightarrow> (s',None) \<in> R)"

text {* None to None *}

definition CR3H :: "'a prel \<Rightarrow> bool"
 where "CR3H R = (\<forall>s. s \<noteq> None \<and> (None,s) \<notin> R \<and> (None,None) \<in> R)"

text {* Or in a fixed-point style *}

definition R1H :: "'a prel \<Rightarrow> 'a prel"
 where "R1H R = { (s,s'). \<exists>t.(s,s') \<in> R \<and> s \<noteq> None \<and> trace (the s') = trace (the s) @ t }"

definition R2H :: "'a prel \<Rightarrow> 'a prel"
 where "R2H R = { (s,s'). \<exists>t. (s,None) \<in> R \<and> s \<noteq> None \<and> trace(the s') = trace (the s) @ t \<or> (s,s') \<in> R }"

definition R3H :: "'a prel \<Rightarrow> 'a prel"
 where "R3H R = R \<union> {(None,None)}"

subsection {* Linking from the relational model *}

text {* From a relation to a set of failures. *}

definition r2f :: "'a prel \<Rightarrow> ('a failure) set"
 where "r2f R = { f. \<exists>s s'. (s,s') \<in> R \<and> f = the s' \<and> s \<noteq> None \<and> s' \<noteq> None}"

text {* From a relation to a set of divergences. *}

definition r2d :: "'a prel \<Rightarrow> ('a trace) set"
 where "r2d R = { t. \<exists>s. (s,None) \<in> R \<and> t = trace (the s) \<and> s \<noteq> None}"

text {* From a relation to a CSP process. *}

definition r2P :: "'a prel \<Rightarrow> 'a process"
 where "r2P R = (r2f R, r2d R)"

lemma "CR1H(fd2r F D)"
 apply (simp add:CR1H_def fd2r_def trace_def)
 by auto

lemma "CR2H(fd2r F D)"
 apply (simp add:fd2r_def CR2H_def trace_def)
 by auto

lemma
 assumes "CR3H R" "CR2H R" "CR1H R"
 shows "fd2r (r2f R) (r2d R) = R"
 using assms
 apply (simp add:CR3H_def CR2H_def CR1H_def r2f_def r2d_def fd2r_def trace_def)
 by blast

lemma r2fd_is_F1:
 assumes "CR3H R" "CR2H R" "CR1H R"
 shows "F1((r2f R),(r2d R))"
 using assms unfolding CR1H_def CR2H_def CR3H_def
 by blast

lemma r2fd_is_F2:
 assumes "CR3H R" "CR2H R" "CR1H R"
 shows "F2((r2f R),(r2d R))"
 using assms unfolding CR1H_def CR2H_def CR3H_def
 by blast

lemma r2fd_is_F3:
 assumes "CR3H R" "CR2H R" "CR1H R"
 shows "F3((r2f R),(r2d R))"
 using assms unfolding CR1H_def CR2H_def CR3H_def
 by blast

lemma r2fd_is_D1:
 assumes "CR3H R" "CR2H R" "CR1H R"
 shows "D1((r2f R),(r2d R))"
 using assms unfolding CR1H_def CR2H_def CR3H_def
 by blast

lemma r2fd_is_D2:
 assumes "CR3H R" "CR2H R" "CR1H R"
 shows "D2((r2f R),(r2d R))"
 using assms unfolding CR1H_def CR2H_def CR3H_def
 by blast

lemma r2f_fd2r:
assumes "divStrict D = D" and "divFailureStrict F D = F"
shows "r2f (fd2r F D) = F"
apply auto
apply (simp add:fd2r_def r2f_def trace_def)
apply auto
using assms unfolding divStrict_def divFailureStrict_def
apply (simp add:fd2r_def r2f_def)
apply blast
using assms unfolding divStrict_def divFailureStrict_def
apply (simp add:fd2r_def r2f_def)
by (metis (no_types, lifting) append_Nil2 option.sel)

lemma r2d_fd2r: "r2d (fd2r F D) = D"
apply auto
apply (simp add:fd2r_def r2d_def)
apply blast
apply (simp add:fd2r_def r2d_def)
by (metis option.sel prod.sel(1) trace_def)

lemma D1_is_divStrict:
 shows "D1(P) = (divStrict (snd P) = (snd P))"
 apply (simp add:divStrict_def D1_def)
 by blast

lemma D2_is_divFailureStrict:
 shows "D2(P) = (divFailureStrict (fst P) (snd P) = (fst P))"
 apply (simp add:divFailureStrict_def D2_def)
 by blast

lemma r2P_fdP2r:
 assumes "D1(P)" "D2(P)"
 shows "r2P (fdP2r P) = P"
 apply (simp add:r2P_def fdP2r_def)
 using assms
 by (simp add: D1_is_divStrict D2_is_divFailureStrict r2d_fd2r r2f_fd2r)

lemma fdP2r_r2P:
 assumes "CR3H R"
 shows "fdP2r (r2P R) = R"
 using CR3H_def and assms by blast

end