theory TopoS_Helper
imports Main TopoS_Interface
  TopoS_ENF
  vertex_example_simps
begin

lemma (in SecurityInvariant_preliminaries) sinvar_valid_remove_flattened_offending_flows:
  assumes "wf_graph \<lparr>nodes = nodesG, edges = edgesG\<rparr>" (*TODO: we could get rid of this assumption*)
  shows "sinvar \<lparr>nodes = nodesG, edges = edgesG - \<Union> (set_offending_flows \<lparr>nodes = nodesG, edges = edgesG\<rparr> nP) \<rparr> nP"
proof -
  { fix f
    assume *: "f\<in>set_offending_flows \<lparr>nodes = nodesG, edges = edgesG\<rparr> nP"

    from * have 1: "sinvar \<lparr>nodes = nodesG, edges = edgesG - f \<rparr> nP"
      by (metis (opaque_lifting, mono_tags) SecurityInvariant_withOffendingFlows.valid_without_offending_flows delete_edges_simp2 graph.select_convs(1) graph.select_convs(2))
    from * have 2: "edgesG - \<Union> (set_offending_flows \<lparr>nodes = nodesG, edges = edgesG\<rparr> nP) \<subseteq> edgesG - f"
      by blast
    note 1 2
  }
  with assms show ?thesis
    by (metis (opaque_lifting, no_types) Diff_empty Union_empty defined_offending equals0I mono_sinvar wf_graph_remove_edges)
qed

lemma (in SecurityInvariant_preliminaries) sinvar_valid_remove_SOME_offending_flows:
  assumes "set_offending_flows \<lparr>nodes = nodesG, edges = edgesG\<rparr> nP \<noteq> {}"
  shows "sinvar \<lparr>nodes = nodesG, edges = edgesG - (SOME F. F \<in> set_offending_flows \<lparr>nodes = nodesG, edges = edgesG\<rparr> nP) \<rparr> nP"
proof -
  { fix f
    assume *: "f\<in>set_offending_flows \<lparr>nodes = nodesG, edges = edgesG\<rparr> nP"

    from * have 1: "sinvar \<lparr>nodes = nodesG, edges = edgesG - f \<rparr> nP"
      by (metis (opaque_lifting, mono_tags) SecurityInvariant_withOffendingFlows.valid_without_offending_flows delete_edges_simp2 graph.select_convs(1) graph.select_convs(2))
    from * have 2: "edgesG - \<Union> (set_offending_flows \<lparr>nodes = nodesG, edges = edgesG\<rparr> nP) \<subseteq> edgesG - f"
      by blast
    note 1 2
  }
  with assms show ?thesis by (simp add: some_in_eq)
qed

lemma (in SecurityInvariant_preliminaries) sinvar_valid_remove_minimalize_offending_overapprox:
  assumes "wf_graph \<lparr>nodes = nodesG, edges = edgesG\<rparr>"
      and "\<not> sinvar \<lparr>nodes = nodesG, edges = edgesG\<rparr> nP" (*"set_offending_flows \<lparr>nodes = nodesG, edges = edgesG\<rparr> nP \<noteq> {}"*)
      and "set Es = edgesG" and "distinct Es"
  shows "sinvar \<lparr>nodes = nodesG, edges = edgesG -
              set (minimalize_offending_overapprox Es [] \<lparr>nodes = nodesG, edges = edgesG\<rparr> nP) \<rparr> nP"
proof -
  from assms have off_Es: "is_offending_flows (set Es) \<lparr>nodes = nodesG, edges = edgesG\<rparr> nP"
    by (metis (no_types, lifting) Diff_cancel
        SecurityInvariant_withOffendingFlows.valid_empty_edges_iff_exists_offending_flows defined_offending
        delete_edges_simp2 graph.select_convs(2) is_offending_flows_def sinvar_monoI)
  from minimalize_offending_overapprox_gives_back_an_offending_flow[OF assms(1) off_Es _ assms(4)] have
    in_offending: "set (minimalize_offending_overapprox Es [] \<lparr>nodes = nodesG, edges = edgesG\<rparr> nP)
      \<in> set_offending_flows \<lparr>nodes = nodesG, edges = edgesG\<rparr> nP"
     using assms(3) by simp

  { fix f
    assume *: "f\<in>set_offending_flows \<lparr>nodes = nodesG, edges = edgesG\<rparr> nP"
    from * have 1: "sinvar \<lparr>nodes = nodesG, edges = edgesG - f \<rparr> nP"
      by (metis (opaque_lifting, mono_tags) SecurityInvariant_withOffendingFlows.valid_without_offending_flows delete_edges_simp2 graph.select_convs(1) graph.select_convs(2))
    note 1
  }
  with in_offending show ?thesis by (simp add: some_in_eq)
qed

end


(* Author: Andreas Lochbihler, Digital Asset *)

theory Code_Lazy_Demo imports
  "HOL-Library.Code_Lazy"
  "HOL-Library.Debug"
  "HOL-Library.RBT_Impl"
begin

text \<open>This theory demonstrates the use of the \<^theory>\<open>HOL-Library.Code_Lazy\<close> theory.\<close>

section \<open>Streams\<close>

text \<open>Lazy evaluation for streams\<close>

codatatype 'a stream =
  SCons (shd: 'a) (stl: "'a stream") (infixr "##" 65)

primcorec up :: "nat \<Rightarrow> nat stream" where
  "up n = n ## up (n + 1)"

primrec stake :: "nat \<Rightarrow> 'a stream \<Rightarrow> 'a list" where
  "stake 0 xs = []"
| "stake (Suc n) xs = shd xs # stake n (stl xs)"

code_thms up stake \<comment> \<open>The original code equations\<close>

code_lazy_type stream

code_thms up stake \<comment> \<open>The lazified code equations\<close>

value "stake 5 (up 3)"

section \<open>Finite lazy lists\<close>

text \<open>Lazy types need not be infinite. We can also have lazy types that are finite.\<close>

datatype 'a llist
  = LNil ("\<^bold>\<lbrakk>\<^bold>\<rbrakk>")
  | LCons (lhd: 'a) (ltl: "'a llist") (infixr "###" 65)

syntax "_llist" :: "args => 'a list"    ("\<^bold>\<lbrakk>(_)\<^bold>\<rbrakk>")
translations
  "\<^bold>\<lbrakk>x, xs\<^bold>\<rbrakk>" == "x###\<^bold>\<lbrakk>xs\<^bold>\<rbrakk>"
  "\<^bold>\<lbrakk>x\<^bold>\<rbrakk>" == "x###\<^bold>\<lbrakk>\<^bold>\<rbrakk>"

fun lnth :: "nat \<Rightarrow> 'a llist \<Rightarrow> 'a" where
  "lnth 0 (x ### xs) = x"
| "lnth (Suc n) (x ### xs) = lnth n xs"

definition llist :: "nat llist" where
  "llist = \<^bold>\<lbrakk>1, 2, 3, hd [], 4\<^bold>\<rbrakk>"

code_lazy_type llist

value [code] "llist"
value [code] "lnth 2 llist"
value [code] "let x = lnth 2 llist in (x, llist)"

fun lfilter :: "('a \<Rightarrow> bool) \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
  "lfilter P \<^bold>\<lbrakk>\<^bold>\<rbrakk> = \<^bold>\<lbrakk>\<^bold>\<rbrakk>"
| "lfilter P (x ### xs) =
   (if P x then x ### lfilter P xs else lfilter P xs)"

export_code lfilter in SML file_prefix lfilter

value [code] "lfilter odd llist"

value [code] "lhd (lfilter odd llist)"

section \<open>Iterator for red-black trees\<close>

text \<open>Thanks to laziness, we do not need to program a complicated iterator for a tree.
  A conversion function to lazy lists is enough.\<close>

primrec lappend :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> 'a llist"
  (infixr "@@" 65) where
  "\<^bold>\<lbrakk>\<^bold>\<rbrakk> @@ ys = ys"
| "(x ### xs) @@ ys = x ### (xs @@ ys)"

primrec rbt_iterator :: "('a, 'b) rbt \<Rightarrow> ('a \<times> 'b) llist" where
  "rbt_iterator rbt.Empty = \<^bold>\<lbrakk>\<^bold>\<rbrakk>"
| "rbt_iterator (Branch _ l k v r) =
   (let _ = Debug.flush (STR ''tick'') in
   rbt_iterator l @@ (k, v) ### rbt_iterator r)"

definition tree :: "(nat, unit) rbt"
  where "tree = fold (\<lambda>k. rbt_insert k ()) [0..<100] rbt.Empty"

definition find_min :: "('a :: linorder, 'b) rbt \<Rightarrow> ('a \<times> 'b) option" where
  "find_min rbt =
  (case rbt_iterator rbt of \<^bold>\<lbrakk>\<^bold>\<rbrakk> \<Rightarrow> None
   | kv ### _ \<Rightarrow> Some kv)"

value "find_min tree" \<comment> \<open>Observe that \<^const>\<open>rbt_iterator\<close> is evaluated only for going down
  to the first leaf, not for the whole tree (as seen by the ticks).\<close>

text \<open>With strict lists, the whole tree is converted into a list.\<close>

deactivate_lazy_type llist
value "find_min tree"
activate_lazy_type llist

section \<open>Branching datatypes\<close>

datatype tree
  = L              ("\<spadesuit>")
  | Node tree tree (infix "\<triangle>" 900)

notation (output) Node ("\<triangle>(//\<^bold>l: _//\<^bold>r: _)")

code_lazy_type tree

fun mk_tree :: "nat \<Rightarrow> tree" where mk_tree_0:
  "mk_tree 0 = \<spadesuit>"
| "mk_tree (Suc n) = (let t = mk_tree n in t \<triangle> t)"

declare mk_tree.simps [code]

code_thms mk_tree

function subtree :: "bool list \<Rightarrow> tree \<Rightarrow> tree" where
  "subtree [] t = t"
| "subtree (True # p) (l \<triangle> r) = subtree p l"
| "subtree (False # p) (l \<triangle> r) = subtree p r"
| "subtree _ \<spadesuit> = \<spadesuit>"
  by pat_completeness auto
termination by lexicographic_order

value [code] "mk_tree 10"
value [code] "let t = mk_tree 10; _ = subtree [True, True, False, False] t in t"
  \<comment> \<open>Since \<^const>\<open>mk_tree\<close> shares the two subtrees of a node thanks to the let binding,
      digging into one subtree spreads to the whole tree.\<close>
value [code] "let t = mk_tree 3; _ = subtree [True, True, False, False] t in t"

lemma mk_tree_Suc_debug [code]: \<comment> \<open>Make the evaluation visible with tracing.\<close>
  "mk_tree (Suc n) =
  (let _ = Debug.flush (STR ''tick''); t = mk_tree n in t \<triangle> t)"
  by simp

value [code] "mk_tree 10"
  \<comment> \<open>The recursive call to \<^const>\<open>mk_tree\<close> is not guarded by a lazy constructor,
      so all the suspensions are built up immediately.\<close>

lemma mk_tree_Suc [code]: "mk_tree (Suc n) = mk_tree n \<triangle> mk_tree n"
  \<comment> \<open>In this code equation, there is no sharing and the recursive calls are guarded by a constructor.\<close>
  by(simp add: Let_def)

value [code] "mk_tree 10"
value [code] "let t = mk_tree 10; _ = subtree [True, True, False, False] t in t"

lemma mk_tree_Suc_debug' [code]:
  "mk_tree (Suc n) = (let _ = Debug.flush (STR ''tick'') in mk_tree n \<triangle> mk_tree n)"
  by(simp add: Let_def)

value [code] "mk_tree 10" \<comment> \<open>Only one tick thanks to the guarding constructor\<close>
value [code] "let t = mk_tree 10; _ = subtree [True, True, False, False] t in t"
value [code] "let t = mk_tree 3; _ = subtree [True, True, False, False] t in t"

section \<open>Pattern matching elimination\<close>

text \<open>The pattern matching elimination handles deep pattern matches and overlapping equations
 and only eliminates necessary pattern matches.\<close>

function crazy :: "nat llist llist \<Rightarrow> tree \<Rightarrow> bool \<Rightarrow> unit" where
  "crazy (\<^bold>\<lbrakk>0\<^bold>\<rbrakk> ### xs) _ _    = Debug.flush (1 :: integer)"
| "crazy xs          \<spadesuit> True = Debug.flush (2 :: integer)"
| "crazy xs          t  b   = Debug.flush (3 :: integer)"
  by pat_completeness auto
termination by lexicographic_order

code_thms crazy

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
(*
  Changes since submission on 2009-11-26:

  2009-12-10: OrderedSet, implemented iterators, min, max, to_sorted_list

*)

header {* \isaheader{Set Implementation by Red-Black-Tree} *}
theory RBTSetImpl
imports
  "../spec/SetSpec"
  "RBTMapImpl"
  "../gen_algo/SetByMap"
  "../gen_algo/SetGA"
begin
text_raw {*\label{thy:RBTSetImpl}*}
(*@impl Set
  @type ('a::linorder) rs
  @abbrv rs,r
  Sets over linearly ordered elements implemented by red-black trees.
*)

subsection "Definitions"
type_synonym
  'a rs = "('a::linorder,unit) rm"

setup Locale_Code.open_block
interpretation rs_sbm!: OSetByOMap rm_basic_ops by unfold_locales
setup Locale_Code.close_block

definition rs_ops :: "('x::linorder,'x rs) oset_ops"
  where [icf_rec_def]: "rs_ops \<equiv> rs_sbm.obasic.dflt_oops"

setup Locale_Code.open_block
interpretation rs!: StdOSetDefs rs_ops .
interpretation rs!: StdOSet rs_ops
  unfolding rs_ops_def
  by (rule rs_sbm.obasic.dflt_oops_impl)

interpretation rs!: StdSet_no_invar rs_ops
  by unfold_locales (simp add: icf_rec_unf SetByMapDefs.invar_def)
setup Locale_Code.close_block

setup {* ICF_Tools.revert_abbrevs "rs"*}

lemmas rbt_it_to_it_map_code_unfold[code_unfold] =
  it_to_it_map_fold'[OF pi_rm]
  it_to_it_map_fold'[OF pi_rm_rev]

lemma pi_rs[proper_it]:
  "proper_it' rs.iteratei rs.iteratei"
  "proper_it' rs.iterateoi rs.iterateoi"
  "proper_it' rs.rev_iterateoi rs.rev_iterateoi"
  unfolding rs.iteratei_def[abs_def] rs.iterateoi_def[abs_def]
    rs.rev_iterateoi_def[abs_def]
  by (rule proper_it'I icf_proper_iteratorI)+

interpretation
  pi_rs: proper_it_loc rs.iteratei rs.iteratei +
  pi_rs_o: proper_it_loc rs.iterateoi rs.iterateoi +
  pi_rs_ro: proper_it_loc rs.rev_iterateoi rs.rev_iterateoi
  by unfold_locales (rule pi_rs)+

definition test_codegen where "test_codegen \<equiv> (
  rs.empty,
  rs.memb,
  rs.ins,
  rs.delete,
  rs.list_it,
  rs.sng,
  rs.isEmpty,
  rs.isSng,
  rs.ball,
  rs.bex,
  rs.size,
  rs.size_abort,
  rs.union,
  rs.union_dj,
  rs.diff,
  rs.filter,
  rs.inter,
  rs.subset,
  rs.equal,
  rs.disjoint,
  rs.disjoint_witness,
  rs.sel,
  rs.to_list,
  rs.from_list,

  rs.ordered_list_it,
  rs.rev_list_it,
  rs.min,
  rs.max,
  rs.to_sorted_list,
  rs.to_rev_list
)"

export_code test_codegen in SML

end


theory Abstract_System
  imports SE_Monad
begin

locale det_system =
  fixes step :: "(unit,'s) se"
  fixes halted :: "'s \<Rightarrow> bool"
begin

  definition "step_rel s s' \<equiv>
    case s of
      None \<Rightarrow> False
    | Some s \<Rightarrow> \<not>halted s \<and> map_option snd (step s) = s'"

  fun terminated where
    "terminated (Some s) = halted s"
  | "terminated None = True "

  lemma terminated_no_step[simp, intro]: "terminated s \<Longrightarrow> \<not>step_rel s s'"
    by (auto simp: step_rel_def split: option.splits)

  lemma terminated_no_step': "terminated s \<longleftrightarrow> (\<forall>s'. \<not>step_rel s s')"
    by (cases s; auto simp: step_rel_def split: option.splits)

  definition "is_result s s' \<equiv> step_rel\<^sup>*\<^sup>* (Some s) s' \<and> terminated s'"

  lemma is_result_1_step_eq: "\<not>halted s \<Longrightarrow> step s = Some ((),sh) \<Longrightarrow> is_result s s' \<longleftrightarrow> is_result sh s'"
    apply (rule iffI)
    subgoal
      unfolding is_result_def step_rel_def
      by (auto split: option.splits elim: converse_rtranclpE)
    subgoal
      unfolding is_result_def
      apply simp
      apply (rule converse_rtranclp_into_rtranclp)
      apply (auto simp: step_rel_def) []
      by simp
    done

  lemma result_determ: "is_result s s' \<Longrightarrow> is_result s s'' \<Longrightarrow> s'=s''"
    unfolding is_result_def
    apply safe
    apply (induction rule: converse_rtranclp_induct)
    apply (erule converse_rtranclpE; auto; fail)

    apply (erule converse_rtranclpE[of _ _ s'']; clarsimp)
    apply (auto simp: step_rel_def split: option.splits; fail)
    done

  definition "yields' s \<equiv> if \<exists>s'. is_result s s' then Some (THE s'. is_result s s') else None"

  lemma yields_eq_Some_conv: "yields' s = Some s' \<longleftrightarrow> is_result s s'"
    unfolding yields'_def using result_determ
    by (auto simp: theI2)

  lemma yields_eq_None_conv: "yields' s = None \<longleftrightarrow> (\<nexists>s'. is_result s s')"
    unfolding yields'_def by auto

  lemma halted_res[simp]: "halted s \<Longrightarrow> is_result s (Some s)"
    by (auto simp: is_result_def)

  lemma exec1_None_res[simp]: "\<lbrakk>step s = None; \<not> halted s\<rbrakk> \<Longrightarrow> is_result s None"
    by (auto simp: is_result_def step_rel_def r_into_rtranclp)

  lemma yields_unfold: "yields' s = (
    if halted s then
      Some (Some s)
    else
      case step s of
        Some (_,s') \<Rightarrow> yields' s'
      | None \<Rightarrow> Some None
    )"
    apply (clarsimp split: option.splits simp: yields_eq_Some_conv yields_eq_None_conv)
    subgoal for s'
      apply (cases "yields' s"; cases "yields' s'"; simp only:)
      apply (auto
        split: option.splits
        simp: yields_eq_Some_conv yields_eq_None_conv is_result_1_step_eq result_determ
        )+
      done
    done

  lemma yields'_simps[simp]:
    "halted s \<Longrightarrow> yields' s = Some (Some s)"
    "\<not>halted s \<Longrightarrow> step s = Some ((),s') \<Longrightarrow> yields' s = yields' s'"
    "\<not>halted s \<Longrightarrow> step s = None \<Longrightarrow> yields' s = Some None"
    by (subst yields_unfold; auto split: option.splits)+

  definition "is_invar \<phi> \<equiv> \<forall>s. \<phi> s \<and> \<not>halted s \<longrightarrow> wps step (\<lambda>_. \<phi>) s"
  definition "is_weak_invar \<phi> \<equiv> \<forall>s s'. \<phi> s \<and> \<not>halted s \<and> step s = Some ((),s') \<longrightarrow> \<phi> s'"

  lemma is_invar_step: "is_invar \<phi> \<Longrightarrow> \<phi> s \<Longrightarrow> step_rel (Some s) so' \<Longrightarrow> \<exists>s'. so'=Some s' \<and> \<phi> s'"
    by (auto simp: is_invar_def wps_def step_rel_def split: option.splits)

  lemma is_weak_invar_step: "is_weak_invar \<phi> \<Longrightarrow> \<phi> s \<Longrightarrow> step_rel (Some s) (Some s') \<Longrightarrow> \<phi> s'"
    by (auto simp: is_weak_invar_def wps_def step_rel_def split: option.splits)

  lemma is_invar_exec:
    assumes "is_invar \<phi>"
    assumes "\<phi> s"
    assumes "step_rel\<^sup>*\<^sup>* (Some s) so'"
    shows "\<exists>s'. so'=Some s' \<and> \<phi> s'"
    using assms(3,2)
    apply (induction a\<equiv>"Some s" arbitrary: s rule: converse_rtranclp_induct)
    subgoal by simp
    apply (drule (1) is_invar_step[OF \<open>is_invar \<phi>\<close>])
    by auto

  lemma step_rel_rtrancl_None_eq[simp]: "step_rel\<^sup>*\<^sup>* None s \<longleftrightarrow> s=None"
    using converse_rtranclpE by fastforce

  lemma is_weak_invar_exec:
    assumes "is_weak_invar \<phi>"
    assumes "\<phi> s"
    assumes "step_rel\<^sup>*\<^sup>* (Some s) (Some s')"
    shows "\<phi> s'"
    using assms(3,2)
    apply (induction a\<equiv>"Some s" arbitrary: s rule: converse_rtranclp_induct)
    subgoal by simp
    subgoal for z s
      apply (cases z; simp)
      apply (drule (1) is_weak_invar_step[OF \<open>is_weak_invar \<phi>\<close>])
      by auto
    done

  lemma is_invar_yields:
    assumes "is_invar \<phi>"
    assumes "\<phi> s"
    assumes "yields' s = Some so'"
    shows "\<exists>s'. so'=Some s' \<and> halted s' \<and> \<phi> s'"
    using assms
    apply (auto simp: yields_eq_Some_conv is_result_def is_invar_exec)
    using is_invar_exec terminated.simps(1) by blast

  lemma is_weak_invar_yields:
    assumes "is_weak_invar \<phi>"
    assumes "\<phi> s"
    assumes "yields' s = Some (Some s')"
    shows "\<phi> s'"
    using assms
    by (auto simp: yields_eq_Some_conv is_result_def is_weak_invar_exec)

  lemma is_invarI:
    assumes "\<And>s. \<lbrakk> \<phi> s; \<not>halted s \<rbrakk> \<Longrightarrow> wps step (\<lambda>_. \<phi>) s"
    shows "is_invar \<phi>"
    using assms
    unfolding is_invar_def by blast

  lemma is_weak_invarI:
    assumes "\<And>s s'. \<lbrakk> \<phi> s; \<not>halted s; step s = Some ((),s') \<rbrakk> \<Longrightarrow> \<phi> s'"
    shows "is_weak_invar \<phi>"
    using assms
    unfolding is_weak_invar_def by blast

  lemma app_weak_invar:
    assumes "is_weak_invar \<phi>'"
    assumes "\<not>halted s" "\<phi>' s"
    assumes "wps step (\<lambda>_ s'. \<phi>' s' \<longrightarrow> \<phi> s') s"
    shows "wps step (\<lambda>_. \<phi>) s"
    using assms unfolding is_weak_invar_def wps_def
    by (auto split: option.splits)

  lemma is_weak_invarD:
    assumes "is_weak_invar \<phi>"
    assumes "\<phi> s" "\<not>halted s"
    assumes "step s = Some ((),s')"
    shows "\<phi> s'"
    using assms
    by (auto simp: is_weak_invar_def)

end

locale std_invar_system = det_system step halted for step :: "(unit,'s) se" and halted +
  fixes stdI :: "'s \<Rightarrow> bool"
  assumes stdI: "is_weak_invar stdI"
begin
  definition "is_std_invar \<phi> \<equiv> is_invar (\<lambda>s. stdI s \<and> \<phi> s)"

  lemma is_std_invarI:
    assumes "\<And>s. \<lbrakk> \<phi> s; stdI s; \<not>halted s \<rbrakk> \<Longrightarrow> wps step (\<lambda>_ s'. stdI s' \<longrightarrow> \<phi> s') s"
    shows "is_std_invar \<phi>"
    unfolding is_std_invar_def
    apply (rule is_invarI)
    apply (rule app_weak_invar[OF stdI]; simp)
    using assms by blast

  definition "htriple P Q \<equiv> \<forall>s. stdI s \<and> P s \<longrightarrow> (case yields' s of
      None \<Rightarrow> True
    | Some None \<Rightarrow> False
    | Some (Some s') \<Rightarrow> Q s'
  )"

  lemma htripleI:
    assumes "\<And>s so'. \<lbrakk> stdI s; P s; yields' s = Some so' \<rbrakk> \<Longrightarrow> \<exists>s'. so' = Some s' \<and> (stdI s' \<longrightarrow> Q s')"
    shows "local.htriple P Q"
    using assms unfolding htriple_def
    using local.is_weak_invar_yields local.stdI
    by (fastforce split: option.split)

end

locale floyd_system = std_invar_system step halted stdI for step :: "(unit,'s) se" and halted stdI +
  fixes \<Theta> :: "'s \<rightharpoonup> bool"
begin
  definition "has_invar s \<equiv> halted s \<or> \<Theta> s \<noteq> None"

  lemma has_invar_simps[simp]:
    "\<Theta> s = Some x \<Longrightarrow> has_invar s"
    "\<Theta> s = None \<Longrightarrow> has_invar s = halted s"
    by (auto simp: has_invar_def)

  sublocale isys: det_system step has_invar .

  definition "invar s \<equiv>
    case isys.yields' s of
      None \<Rightarrow> False
    | Some so' \<Rightarrow> (case so' of None \<Rightarrow> False | Some s' \<Rightarrow> \<Theta> s' = Some True)
    "

  lemma invar_unfold:
    "invar s = (case \<Theta> s of Some b \<Rightarrow> b | None \<Rightarrow> (\<not>halted s \<and> wps (step) (\<lambda>_. invar) s))"
    unfolding invar_def wps_def
    apply (subst isys.yields_unfold)
    by (auto split: option.splits)

  lemma invar_imp_\<Theta>_true: "invar s \<Longrightarrow> has_invar s \<Longrightarrow> \<Theta> s = Some True"
    unfolding invar_def by (auto split: option.splits)

  lemma invarI:
    assumes "\<And>s. \<lbrakk> \<Theta> s = Some True; stdI s; \<not>halted s \<rbrakk> \<Longrightarrow> wps step (\<lambda>_ s'. stdI s' \<longrightarrow> invar s') s"
    shows "is_std_invar invar"
  proof (rule is_std_invarI)
    fix s
    assume "invar s" "\<not>halted s" "stdI s"

    from \<open>invar s\<close> consider (HAS_INVAR) "\<Theta> s = Some True" | (NO_INVAR) "\<Theta> s = None"
      using has_invar_def invar_imp_\<Theta>_true by blast
    then show "wps step (\<lambda>_ s'. stdI s' \<longrightarrow> invar s') s" proof cases
      case HAS_INVAR
      then show ?thesis
        using \<open>\<not> halted s\<close> \<open>stdI s\<close> assms by blast
    next
      case NO_INVAR
      hence "\<not>has_invar s" using \<open>\<not> halted s\<close> by (auto simp: has_invar_def)
      then show ?thesis
        using \<open>invar s\<close> invar_step wps_mono by fastforce
    qed
  qed

  lemma halted_invar_conv:
    assumes [simp]: "halted s"
    shows "invar s \<longleftrightarrow> \<Theta> s = Some True"
    by (subst invar_unfold) (auto split: option.split)

  lemma std_invar_yields:
    assumes "is_std_invar invar"
    assumes "stdI s" "invar s" "yields' s = Some so'"
    shows "\<exists>s'. so' = Some s' \<and> halted s' \<and> stdI s' \<and> \<Theta> s' = Some True"
  proof -
    from assms(1) have "is_invar (\<lambda>s. stdI s \<and> invar s)" by (simp add: is_std_invar_def)
    note X1 = is_invar_yields[OF this]

    from assms(2-) X1 obtain s' where X2: "so' = Some s'" "halted s'" "stdI s'" "invar s'"
      by auto
    with halted_invar_conv have "\<Theta> s' = Some True" by blast
    with X2 show ?thesis by blast
  qed

end

locale cfg_system = std_invar_system step halted stdI for step :: "(unit,'s) se" and halted stdI +
  fixes location :: "'s \<Rightarrow> 'loc"
begin
  definition linvar :: "('loc \<Rightarrow> ('s \<Rightarrow> bool) option) \<Rightarrow> 's \<Rightarrow> bool option" where
    "linvar \<Theta> s \<equiv>
        case \<Theta> (location s) of
          None \<Rightarrow> None
        | Some \<phi> \<Rightarrow> Some (\<phi> s)"

  sublocale floyd: floyd_system step halted stdI "linvar \<Theta>" for \<Theta> by standard

  definition "floyd_vcs \<Theta>' \<Theta> \<equiv>
    \<forall>\<phi> s. \<Theta>' (location s) = Some \<phi> \<and> \<phi> s \<and> stdI s \<and> \<not>halted s \<longrightarrow> wps step (\<lambda>_ s'. stdI s' \<longrightarrow> floyd.invar \<Theta> s') s"

  lemma floyd_vcs_emptyI:
    "floyd_vcs Map.empty \<Theta>"
    by (auto simp: floyd_vcs_def)

  lemma floyd_vcs_updI:
    assumes "floyd_vcs \<Theta>' \<Theta>"
    assumes "\<And>s. \<lbrakk> location s = l; \<phi> s; stdI s; \<not>halted s \<rbrakk> \<Longrightarrow> wps step (\<lambda>_ s'. stdI s' \<longrightarrow> floyd.invar \<Theta> s') s"
    shows "floyd_vcs (\<Theta>'(l\<mapsto>\<phi>)) \<Theta>"
    using assms
    by (auto simp: floyd_vcs_def)

  lemmas floyd_vcsI = floyd_vcs_emptyI floyd_vcs_updI

  lemma linvar_conv:
    "linvar \<Theta> s = None \<longleftrightarrow> \<Theta> (location s) = None"
    "linvar \<Theta> s = Some b \<longleftrightarrow> (\<exists>\<phi>. \<Theta> (location s) = Some \<phi> \<and> b=\<phi> s)"
    by (auto simp: linvar_def split: option.splits)

  lemma floyd_invarI: "floyd_vcs \<Theta> \<Theta> \<Longrightarrow> is_std_invar (floyd.invar \<Theta>)"
    apply (rule floyd.invarI)
    unfolding floyd_vcs_def
    by (auto simp: linvar_conv)

  lemma linvar_unfoldI:
    assumes "case \<Theta> (location s) of
        None \<Rightarrow> \<not>halted s \<and> wps step (\<lambda>_. floyd.invar \<Theta>) s
      | Some \<phi> \<Rightarrow> \<phi> s"
    shows "floyd.invar \<Theta> s"
    apply (subst floyd.invar_unfold)
    using assms
    by (auto simp: linvar_conv split: option.split)

  lemma floyd_htripleI:
    assumes "\<And>s. P s \<Longrightarrow> floyd.invar \<Theta> s" \<comment> \<open>Precondition implies invariant\<close>
    assumes "is_std_invar (floyd.invar \<Theta>)" \<comment> \<open>Invariant\<close>
    assumes "\<And>s \<phi>. \<lbrakk> halted s; stdI s; \<Theta> (location s) = Some \<phi>; \<phi> s \<rbrakk> \<Longrightarrow> Q s" \<comment> \<open>On termination, invariant implies postcondition\<close>
    shows "local.htriple P Q"
    apply (rule htripleI)
    subgoal for s so'
      using floyd.std_invar_yields[OF assms(2), of s so']
      apply (clarsimp simp: linvar_conv)
      using assms(1,3) by blast
    done

end

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |                    May 2005               |
            |                   June 2005  (modified)   |
            |              September 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_T_law_alpha_par
imports CSP_T_op_alpha_par CSP_T_law_decompo
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)

(* Isabelle 2013
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)
declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]

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

         1. associativity of |[X,Y]|
         2. commutativity of |[X,Y]|
         3. monotonicity of |[X,Y]|
         4.

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

(*********************************************************
                        P |[X,Y]| Q
 *********************************************************)

(************************************
 |         SKIP and SKIP            |
 ************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspT_SKIP_Alpha_parallel:
  "(SKIP |[{}, {}]| SKIP) =T[M1,M2] SKIP"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule)
 apply (simp add: in_traces in_traces_Alpha_parallel)
 apply (simp add: sett_subset_Tick)

(* <= *)
 apply (rule)
 apply (simp add: in_traces in_traces_Alpha_parallel)
 apply (simp add: sett_subset_Tick)
 apply (insert rest_tr_sett_subseteq_sett[of _ "{}"])
 apply (auto)
done

(************************************
 |          associativity           |
 ************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspT_Alpha_parallel_assoc:
  "(P1 |[X1, X2]| P2) |[X1 Un X2, X3]| P3 =T[M,M]
   P1 |[X1, X2 Un X3]| (P2 |[X2, X3]| P3)"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule)
 apply (simp add: in_traces_Alpha_parallel)
 apply (elim conjE exE)
 apply (simp add: Un_upper1 Un_upper2 rest_tr_of_rest_tr_subset)
 apply (simp add: Un_assoc)

(* <= *)
 apply (rule)
 apply (simp add: in_traces_Alpha_parallel)
 apply (elim conjE exE)
 apply (simp add: Un_upper1 Un_upper2 rest_tr_of_rest_tr_subset)
 apply (simp add: Un_assoc)
done

lemma cspT_Alpha_parallel_assoc_sym:
  "P1 |[X1, X2 Un X3]| (P2 |[X2, X3]| P3) =T[M,M]
   (P1 |[X1, X2]| P2) |[X1 Un X2, X3]| P3"
apply (rule cspT_sym)
by (simp add: cspT_Alpha_parallel_assoc)

(************************************
 |          commutativity           |
 ************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspT_Alpha_parallel_commut:
  "(P1 |[X1, X2]| P2) =T[M,M] (P2 |[X2, X1]| P1)"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule)
 apply (simp add: in_traces_Alpha_parallel)
 apply (fast)

(* <= *)
 apply (rule)
 apply (simp add: in_traces_Alpha_parallel)
 apply (fast)
done

(************************************
 |          monotonicity            |
 ************************************)

(*------------------*
 |      csp law M   |
 *------------------*)

lemma cspT_Alpha_parallel_mono:
  "[| X1 = X2 ; Y1 = Y2 ;
      P1 <=T[M1,M2] Q1 ;
      P2 <=T[M1,M2] Q2 |]
           ==> P1 |[X1,Y1]| P2 <=T[M1,M2] Q1 |[X2,Y2]| Q2"
apply (simp add: Alpha_parallel_def)
apply (simp add: cspT_Parallel_mono)
done

lemma cspT_Alpha_parallel_cong:
  "[| X1 = X2 ; Y1 = Y2 ;
      P1 =T[M1,M2] Q1 ;
      P2 =T[M1,M2] Q2 |]
           ==> P1 |[X1,Y1]| P2 =T[M1,M2] Q1 |[X2,Y2]| Q2"
by (simp add: cspT_eq_ref_iff cspT_Alpha_parallel_mono)

lemmas cspT_decompo_Alpha_parallel = cspT_Alpha_parallel_mono
                                     cspT_Alpha_parallel_cong

(****************** to add them again ******************)
(* 2013
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)

declare Sup_image_eq [simp]
declare Inf_image_eq [simp]
end


(* Author: Andreas Lochbihler, ETH Zurich
   Author: Joshua Schneider, ETH Zurich *)

section \<open>Subtypes\<close>

theory Subtypes imports
  Axiomatised_BNF_CC
  "HOL-Library.BNF_Axiomatization"
begin

subsection \<open>\BNFCC{} structure\<close>

consts P :: "('live1, 'live2, 'co1, 'co2, 'contra1, 'contra2, 'fixed) G \<Rightarrow> bool"

axiomatization where
  P_map: "\<And>x l1 l2 co1 co2 contra1 contra2. P x \<Longrightarrow> P (map_G l1 l2 co1 co2 contra1 contra2 x)"
  \<comment> \<open>@{term "{x. P x}"} is closed under the mapper of @{type G}\<close>
and
  ex_P: "\<exists>x. P x" \<comment> \<open>@{term "{x. P x}"} is non-empty\<close>

typedef (overloaded) ('live1, 'live2, 'co1, 'co2, 'contra1, 'contra2, 'fixed) S =
  "{x :: ('live1, 'live2, 'co1, 'co2, 'contra1, 'contra2, 'fixed) G. P x}" by (simp add: ex_P)

text \<open>The subtype @{type S} is isomorphic to the set @{term "{x. P x}"}.\<close>

context includes lifting_syntax
begin

definition rel_S :: "('live1 \<Rightarrow> 'live1' \<Rightarrow> bool) \<Rightarrow> ('live2 \<Rightarrow> 'live2' \<Rightarrow> bool) \<Rightarrow>
    ('co1 \<Rightarrow> 'co1' \<Rightarrow> bool) \<Rightarrow> ('co2 \<Rightarrow> 'co2' \<Rightarrow> bool) \<Rightarrow>
    ('contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool) \<Rightarrow> ('contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool) \<Rightarrow>
    ('live1, 'live2, 'co1, 'co2, 'contra1, 'contra2, 'fixed) S \<Rightarrow>
    ('live1', 'live2', 'co1', 'co2', 'contra1', 'contra2', 'fixed) S \<Rightarrow> bool"
  where
    "rel_S L1 L2 Co1 Co2 Contra1 Contra2 = vimage2p Rep_S Rep_S (rel_G L1 L2 Co1 Co2 Contra1 Contra2)"

definition map_S :: "('live1 \<Rightarrow> 'live1') \<Rightarrow> ('live2 \<Rightarrow> 'live2') \<Rightarrow>
    ('co1 \<Rightarrow> 'co1') \<Rightarrow> ('co2 \<Rightarrow> 'co2') \<Rightarrow>
    ('contra1' \<Rightarrow> 'contra1) \<Rightarrow> ('contra2' \<Rightarrow> 'contra2) \<Rightarrow>
    ('live1, 'live2, 'co1, 'co2, 'contra1, 'contra2, 'fixed) S \<Rightarrow>
    ('live1', 'live2', 'co1', 'co2', 'contra1', 'contra2', 'fixed) S"
  where
    "map_S = (id ---> id ---> id ---> id ---> id ---> id ---> Rep_S ---> Abs_S) map_G"

lemma rel_S_mono:
  "\<lbrakk> L1 \<le> L1'; L2 \<le> L2'; Co1 \<le> Co1'; Co2 \<le> Co2'; Contra1' \<le> Contra1; Contra2' \<le> Contra2 \<rbrakk>
  \<Longrightarrow> rel_S L1 L2 Co1 Co2 Contra1 Contra2 \<le> rel_S L1' L2' Co1' Co2' Contra1' Contra2'"
  unfolding rel_S_def
  apply(rule predicate2I)
  apply(simp add: vimage2p_def)
  by(erule rel_G_mono')

lemma rel_S_eq: "rel_S (=) (=) (=) (=) (=) (=) = (=)"
  unfolding rel_S_def by(clarsimp simp add: vimage2p_def fun_eq_iff rel_G_eq Rep_S_inject)

lemma rel_S_conversep:
  "rel_S L1\<inverse>\<inverse> L2\<inverse>\<inverse> Co1\<inverse>\<inverse> Co2\<inverse>\<inverse> Contra1\<inverse>\<inverse> Contra2\<inverse>\<inverse> = (rel_S L1 L2 Co1 Co2 Contra1 Contra2)\<inverse>\<inverse>"
  unfolding rel_S_def apply(simp add: vimage2p_def)
  apply(subst rel_G_conversep)
  apply(simp add: map_fun_def fun_eq_iff)
  done

lemma map_S_id0: "map_S id id id id id id = id"
  by(simp add: map_S_def fun_eq_iff map_G_id Rep_S_inverse)

lemma map_S_id: "map_S id id id id id id x = x"
  by (simp add: map_S_id0)

lemma map_S_comp:
  "map_S l1 l2 co1 co2 contra1 contra2 \<circ> map_S l1' l2' co1' co2' contra1' contra2' =
  map_S (l1 \<circ> l1') (l2 \<circ> l2') (co1 \<circ> co1') (co2 \<circ> co2') (contra1' \<circ> contra1) (contra2' \<circ> contra2)"
  apply (rule ext)
  apply (simp add: map_S_def)
  apply (subst Abs_S_inverse)
  subgoal for x using Rep_S[of x] by(simp add: P_map)
  apply (subst map_G_comp[THEN fun_cong, simplified])
  apply simp
  done

lemma map_S_parametric:
  "((L1 ===> L1') ===> (L2 ===> L2') ===> (Co1 ===> Co1') ===> (Co2 ===> Co2') ===>
    (Contra1' ===> Contra1) ===> (Contra2' ===> Contra2) ===>
  rel_S L1 L2 Co1 Co2 Contra1 Contra2 ===> rel_S L1' L2' Co1' Co2' Contra1' Contra2')
  map_S map_S"
  apply(rule rel_funI)+
  unfolding rel_S_def map_S_def
  apply(simp add: vimage2p_def)
  apply(subst Abs_S_inverse)
  subgoal for \<dots> x _ using Rep_S[of x] by(simp add: P_map)
  apply(subst Abs_S_inverse)
  subgoal for \<dots> y using Rep_S[of y] by(simp add: P_map)
  by(erule map_G_parametric[THEN rel_funD, THEN rel_funD, THEN rel_funD, THEN rel_funD,
        THEN rel_funD, THEN rel_funD, THEN rel_funD, rotated -1])

lemmas map_S_rel_cong = map_S_parametric[unfolded rel_fun_def, rule_format, rotated -1]

end (* context includes lifting_syntax *)

definition rel_S_pos_distr_cond :: "('co1 \<Rightarrow> 'co1' \<Rightarrow> bool) \<Rightarrow> ('co1' \<Rightarrow> 'co1'' \<Rightarrow> bool) \<Rightarrow>
    ('co2 \<Rightarrow> 'co2' \<Rightarrow> bool) \<Rightarrow> ('co2' \<Rightarrow> 'co2'' \<Rightarrow> bool) \<Rightarrow>
    ('contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool) \<Rightarrow> ('contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool) \<Rightarrow>
    ('contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool) \<Rightarrow> ('contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool) \<Rightarrow>
    ('l1 \<times> 'l1' \<times> 'l1'' \<times> 'l2 \<times> 'l2' \<times> 'l2'' \<times> 'f) itself \<Rightarrow> bool" where
  "rel_S_pos_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' _ \<longleftrightarrow>
  (\<forall>(L1 :: 'l1 \<Rightarrow> 'l1' \<Rightarrow> bool) (L1' :: 'l1' \<Rightarrow> 'l1'' \<Rightarrow> bool)
    (L2 :: 'l2 \<Rightarrow> 'l2' \<Rightarrow> bool) (L2' :: 'l2' \<Rightarrow> 'l2'' \<Rightarrow> bool).
    (rel_S L1 L2 Co1 Co2 Contra1 Contra2 :: (_, _, _, _, _, _, 'f) S \<Rightarrow> _) OO
      rel_S L1' L2' Co1' Co2' Contra1' Contra2' \<le>
    rel_S (L1 OO L1') (L2 OO L2') (Co1 OO Co1') (Co2 OO Co2')
      (Contra1 OO Contra1') (Contra2 OO Contra2'))"

definition rel_S_neg_distr_cond :: "('co1 \<Rightarrow> 'co1' \<Rightarrow> bool) \<Rightarrow> ('co1' \<Rightarrow> 'co1'' \<Rightarrow> bool) \<Rightarrow>
    ('co2 \<Rightarrow> 'co2' \<Rightarrow> bool) \<Rightarrow> ('co2' \<Rightarrow> 'co2'' \<Rightarrow> bool) \<Rightarrow>
    ('contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool) \<Rightarrow> ('contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool) \<Rightarrow>
    ('contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool) \<Rightarrow> ('contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool) \<Rightarrow>
    ('l1 \<times> 'l1' \<times> 'l1'' \<times> 'l2 \<times> 'l2' \<times> 'l2'' \<times> 'f) itself \<Rightarrow> bool" where
  "rel_S_neg_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' _ \<longleftrightarrow>
  (\<forall>(L1 :: 'l1 \<Rightarrow> 'l1' \<Rightarrow> bool) (L1' :: 'l1' \<Rightarrow> 'l1'' \<Rightarrow> bool)
    (L2 :: 'l2 \<Rightarrow> 'l2' \<Rightarrow> bool) (L2' :: 'l2' \<Rightarrow> 'l2'' \<Rightarrow> bool).
    rel_S (L1 OO L1') (L2 OO L2') (Co1 OO Co1') (Co2 OO Co2')
      (Contra1 OO Contra1') (Contra2 OO Contra2') \<le>
    (rel_S L1 L2 Co1 Co2 Contra1 Contra2 :: (_, _, _, _, _, _, 'f) S \<Rightarrow> _) OO
      rel_S L1' L2' Co1' Co2' Contra1' Contra2')"

axiomatization where
  rel_S_neg_distr_cond_eq:
  "\<And>tytok. rel_S_neg_distr_cond (=) (=) (=) (=) (=) (=) (=) (=) tytok"

text \<open>The subtype inherits the conditions for positive subdistributivity.\<close>

lemma rel_S_pos_distr_imp:
  fixes Co1 :: "'co1 \<Rightarrow> 'co1' \<Rightarrow> bool" and Co1' :: "'co1' \<Rightarrow> 'co1'' \<Rightarrow> bool"
    and Co2 :: "'co2 \<Rightarrow> 'co2' \<Rightarrow> bool" and Co2' :: "'co2' \<Rightarrow> 'co2'' \<Rightarrow> bool"
    and Contra1 :: "'contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool" and Contra1' :: "'contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool"
    and Contra2 :: "'contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool" and Contra2' :: "'contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool"
    and tytok_G :: "('l1 \<times> 'l1' \<times> 'l1'' \<times> 'l2 \<times> 'l2' \<times> 'l2'' \<times> 'f) itself"
    and tytok_S :: "('l1 \<times> 'l1' \<times> 'l1'' \<times> 'l2 \<times> 'l2' \<times> 'l2'' \<times> 'f) itself"
  assumes "rel_G_pos_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok_G"
  shows "rel_S_pos_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok_S"
  unfolding rel_S_pos_distr_cond_def rel_S_def
  apply(simp add: vimage2p_def)
  apply(intro allI predicate2I)
  apply(clarsimp)
  apply(rule rel_G_pos_distr[THEN predicate2D])
   apply(rule assms)
  apply(rule relcomppI)
   apply simp
  apply simp
  done

lemma rel_S_pos_distr_cond_eq:
  "\<And>tytok. rel_S_pos_distr_cond (=) (=) (=) (=) (=) (=) (=) (=) tytok"
  by (intro rel_S_pos_distr_imp rel_G_pos_distr_cond_eq)

lemmas
  rel_S_pos_distr = rel_S_pos_distr_cond_def[THEN iffD1, rule_format] and
  rel_S_neg_distr = rel_S_neg_distr_cond_def[THEN iffD1, rule_format]

text \<open>
  The following composition witness depends only on the abstract condition
  @{const rel_S_neg_distr_cond}, without additional assumptions.
\<close>

consts
  rel_S_witness :: "('l1 \<Rightarrow> 'l1'' \<Rightarrow> bool) \<Rightarrow> ('l2 \<Rightarrow> 'l2'' \<Rightarrow> bool) \<Rightarrow>
    ('co1 \<Rightarrow> 'co1' \<Rightarrow> bool) \<Rightarrow> ('co1' \<Rightarrow> 'co1'' \<Rightarrow> bool) \<Rightarrow>
    ('co2 \<Rightarrow> 'co2' \<Rightarrow> bool) \<Rightarrow> ('co2' \<Rightarrow> 'co2'' \<Rightarrow> bool) \<Rightarrow>
    ('contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool) \<Rightarrow> ('contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool) \<Rightarrow>
    ('contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool) \<Rightarrow> ('contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool) \<Rightarrow>
    ('l1, 'l2, 'co1, 'co2, 'contra1, 'contra2, 'f) S \<times>
    ('l1'', 'l2'', 'co1'', 'co2'', 'contra1'', 'contra2'', 'f) S \<Rightarrow>
    ('l1 \<times> 'l1'', 'l2 \<times> 'l2'', 'co1', 'co2', 'contra1', 'contra2', 'f) S"

specification (rel_S_witness)
  rel_S_witness1: "\<And>L1 L2 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2'
    (tytok :: ('l1 \<times> ('l1 \<times> 'l1'') \<times> 'l1'' \<times> 'l2 \<times> ('l2 \<times> 'l2'') \<times> 'l2'' \<times> 'f) itself)
    (x :: ('l1, 'l2, _, _, _, _, 'f) S) (y :: ('l1'', 'l2'', _, _, _, _, 'f) S).
    \<lbrakk> rel_S_neg_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok;
      rel_S L1 L2 (Co1 OO Co1') (Co2 OO Co2') (Contra1 OO Contra1') (Contra2 OO Contra2') x y \<rbrakk> \<Longrightarrow>
    rel_S (\<lambda>x (x', y). x' = x \<and> L1 x y) (\<lambda>x (x', y). x' = x \<and> L2 x y) Co1 Co2 Contra1 Contra2 x
    (rel_S_witness L1 L2 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' (x, y))"
  rel_S_witness2:"\<And>L1 L2 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2'
    (tytok :: ('l1 \<times> ('l1 \<times> 'l1'') \<times> 'l1'' \<times> 'l2 \<times> ('l2 \<times> 'l2'') \<times> 'l2'' \<times> 'f) itself)
    (x :: ('l1, 'l2, _, _, _, _, 'f) S) (y :: ('l1'', 'l2'', _, _, _, _, 'f) S).
    \<lbrakk> rel_S_neg_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok;
      rel_S L1 L2 (Co1 OO Co1') (Co2 OO Co2') (Contra1 OO Contra1') (Contra2 OO Contra2') x y \<rbrakk> \<Longrightarrow>
    rel_S (\<lambda>(x, y') y. y' = y \<and> L1 x y) (\<lambda>(x, y') y. y' = y \<and> L2 x y) Co1' Co2' Contra1' Contra2'
    (rel_S_witness L1 L2 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' (x, y)) y"
  apply(rule exI[where x="\<lambda>L1 L2 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' (x, y). SOME z.
     rel_S (\<lambda>x (x', y). x' = x \<and> L1 x y) (\<lambda>x (x', y). x' = x \<and> L2 x y) Co1 Co2 Contra1 Contra2 x z \<and>
     rel_S (\<lambda>(x, y') y. y' = y \<and> L1 x y) (\<lambda>(x, y') y. y' = y \<and> L2 x y) Co1' Co2' Contra1' Contra2' z y"])
  apply(fold all_conj_distrib)
  apply(rule allI)+
  apply(fold imp_conjR)
  apply(rule impI)+
  apply clarify
  apply(rule someI_ex)
  subgoal for L1 L2 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' x y
    apply(drule rel_S_neg_distr[where
          ?L1.0 = "\<lambda>x (x', y). x' = x \<and> L1 x y" and ?L1'.0 = "\<lambda>(x, y) y'. y = y' \<and> L1 x y'" and
          ?L2.0 = "\<lambda>x (x', y). x' = x \<and> L2 x y" and ?L2'.0 = "\<lambda>(x, y) y'. y = y' \<and> L2 x y'"])
    apply(drule predicate2D)
     apply(erule rel_S_mono[THEN predicate2D, rotated -1]; fastforce)
    apply(erule relcomppE)
    apply(rule exI conjI)+
     apply assumption+
    done
  done

definition set1_S :: "('live1, 'live2, 'co1, 'co2, 'contra1, 'contra2, 'fixed) S \<Rightarrow> 'live1 set"
  where "set1_S = set1_G \<circ> Rep_S"

definition set2_S :: "('live1, 'live2, 'co1, 'co2, 'contra1, 'contra2, 'fixed) S \<Rightarrow> 'live2 set"
  where "set2_S = set2_G \<circ> Rep_S"

lemma rel_S_alt:
  "rel_S L1 L2 (=) (=) (=) (=) x y \<longleftrightarrow> (\<exists>z. (set1_S z \<subseteq> {(x, y). L1 x y} \<and>
  set2_S z \<subseteq> {(x, y). L2 x y}) \<and> map_S fst fst id id id id z = x \<and> map_S snd snd id id id id z = y)"
  unfolding set1_S_def set2_S_def o_def
  apply(rule iffI)
  subgoal
    apply(subst (asm) (3 4 5 7) OO_eq[symmetric])
    apply(rule exI[where x="rel_S_witness L1 L2 (=) (=) (=) (=) (=) (=) (=) (=) (x, y)"])
    apply(frule rel_S_witness1[OF rel_S_neg_distr_cond_eq])
    apply(drule rel_S_witness2[OF rel_S_neg_distr_cond_eq])
    apply(auto simp add: rel_S_def vimage2p_def rell_G_def[symmetric])
       apply(drule (1) G.Domainp_rel[THEN eq_refl, THEN predicate1D,
          OF DomainPI, unfolded pred_G_def, THEN conjunct1, THEN bspec,
          of "conversep _" "conversep _",
          unfolded G.rel_conversep Domainp_conversep, unfolded conversep_iff])
       apply(simp add: Rangep.simps)
      apply(drule (1) G.Domainp_rel[THEN eq_refl, THEN predicate1D, OF DomainPI,
          unfolded pred_G_def, THEN conjunct2, THEN bspec, of "conversep _" "conversep _",
          unfolded G.rel_conversep Domainp_conversep, unfolded conversep_iff])
      apply(simp add: Rangep.simps)
     apply(rewrite in "_ = \<hole>" map_S_id[symmetric])
     apply(rule sym)
     apply(subst rel_S_eq[symmetric])
     apply(rule map_S_parametric[THEN rel_funD, THEN rel_funD, THEN rel_funD, THEN rel_funD,
          THEN rel_funD, THEN rel_funD, THEN rel_funD, rotated -1])
           apply(simp add: rel_S_def vimage2p_def)
           apply(subst rell_G_def[symmetric])
           apply assumption
          apply(simp_all add: rel_fun_def)
    apply(rewrite in "_ = \<hole>" map_S_id[symmetric])
    apply(subst rel_S_eq[symmetric])
    apply(rule map_S_parametric[THEN rel_funD, THEN rel_funD, THEN rel_funD, THEN rel_funD,
          THEN rel_funD, THEN rel_funD, THEN rel_funD, rotated -1])
          apply(simp add: rel_S_def vimage2p_def)
          apply(subst rell_G_def[symmetric])
          apply assumption
         apply(simp_all add: rel_fun_def)
    done
  subgoal
    apply(elim conjE exE)
    apply hypsubst
    apply(rule map_S_parametric[where ?L1.0="eq_onp (\<lambda>(x, y). L1 x y)" and
          ?L2.0="eq_onp (\<lambda>(x, y). L2 x y)", THEN rel_funD, THEN rel_funD, THEN rel_funD,
          THEN rel_funD, THEN rel_funD, THEN rel_funD, THEN rel_funD, rotated -1])
          apply(simp add: rel_S_def vimage2p_def)
          apply(subst rell_G_def[symmetric])
          apply(rule G.rel_refl_strong)
           apply(drule (1) subsetD)
           apply(simp add: eq_onp_def)
          apply(drule (1) subsetD)
          apply(simp add: eq_onp_def)
         apply(simp_all add: rel_fun_def eq_onp_def)
    done
  done

bnf "('live1, 'live2, 'co1, 'co2, 'contra1, 'contra2, 'fixed) S"
  map: "\<lambda>l1 l2. map_S l1 l2 id id id id"
  sets: "set1_S" "set2_S"
  bd: "bd_G :: ('co1, 'co2, 'contra1, 'contra2, 'fixed) Gbd rel"
  rel: "\<lambda>L1 L2. rel_S L1 L2 (=) (=) (=) (=)"
  subgoal by (rule map_S_id0)
  subgoal by (simp add: map_S_comp)
  subgoal
    apply(simp add: map_S_def set1_S_def set2_S_def)
    apply(rule arg_cong[where f="Abs_S"])
    apply(fold mapl_G_def)
    apply(rule G.map_cong[OF refl])
     apply simp_all
    done
  subgoal
    apply(simp add: set1_S_def map_S_def fun_eq_iff)
    apply(subst Abs_S_inverse)
    subgoal for x using Rep_S[of x] by(simp add: P_map)
    apply(simp add: G.set_map mapl_G_def[symmetric])
    done
  subgoal
    apply(simp add: set2_S_def map_S_def fun_eq_iff)
    apply(subst Abs_S_inverse)
    subgoal for x using Rep_S[of x] by(simp add: P_map)
    apply(simp add: G.set_map mapl_G_def[symmetric])
    done
  subgoal by(rule bd_G_card_order)
  subgoal by(rule bd_G_cinfinite)
  subgoal
    apply (simp add: set1_S_def)
    apply (rule set1_G_bound)
    done
  subgoal
    apply (simp add: set2_S_def)
    apply (rule set2_G_bound)
    done
  subgoal
    apply(subst (23 24 25 27) eq_OO[symmetric])
    apply(rule rel_S_pos_distr_cond_def[THEN iffD1, rule_format])
    apply(rule rel_S_pos_distr_imp)
    apply(rule rel_G_pos_distr_cond_eq)
    done
  subgoal
    apply(rule ext)+
    apply(rule rel_S_alt)
    done
  done

subsection \<open>Closedness under zippings\<close>

lemma P_zip_closed: \<comment> \<open>This is @{command lift_bnf}'s property that is too strong.\<close>
  assumes "P (mapl_G fst fst z)" "P (mapl_G snd snd z)"
  shows "P z"
  oops

consts rel_S_neg_distr_cond' :: "('co1 \<Rightarrow> 'co1' \<Rightarrow> bool) \<Rightarrow> ('co1' \<Rightarrow> 'co1'' \<Rightarrow> bool) \<Rightarrow>
    ('co2 \<Rightarrow> 'co2' \<Rightarrow> bool) \<Rightarrow> ('co2' \<Rightarrow> 'co2'' \<Rightarrow> bool) \<Rightarrow>
    ('contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool) \<Rightarrow> ('contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool) \<Rightarrow>
    ('contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool) \<Rightarrow> ('contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool) \<Rightarrow>
    ('l1 \<times> 'l1' \<times> 'l1'' \<times> 'l2 \<times> 'l2' \<times> 'l2'' \<times> 'f) itself \<Rightarrow> bool"

text \<open>
  If the set @{term "{x. P x}"} is closed under zippings for @{const rel_S_neg_distr_cond'},
  we inherit the condition for negative subdistributivity from @{type G}.
\<close>

axiomatization where
  P_rel_G_zipping: "\<And>(L1 :: 'l1 \<Rightarrow> 'l1'' \<Rightarrow> bool) (L2 :: 'l2 \<Rightarrow> 'l2'' \<Rightarrow> bool)
    Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2'
    (tytok :: ('l1 \<times> ('l1 \<times> 'l1'') \<times> 'l1'' \<times> 'l2 \<times> ('l2 \<times> 'l2'') \<times> 'l2'' \<times> 'f) itself) x y z.
    \<lbrakk> P x; P y;
      rel_G L1 L2 (Co1 OO Co1') (Co2 OO Co2') (Contra1 OO Contra1') (Contra2 OO Contra2') x y;
      rel_G (\<lambda>x (x', y). x' = x \<and> L1 x y) (\<lambda>x (x', y). x' = x \<and> L2 x y) Co1 Co2 Contra1 Contra2 x z;
      rel_G (\<lambda>(x, y') y. y' = y \<and> L1 x y) (\<lambda>(x, y') y. y' = y \<and> L2 x y) Co1' Co2' Contra1' Contra2' z y;
      rel_S_neg_distr_cond' Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok \<rbrakk>
    \<Longrightarrow> P z"
  and
  rel_S_neg_distr_cond'_stronger: "\<And>Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok.
    rel_S_neg_distr_cond' Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok \<Longrightarrow>
    rel_G_neg_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok"
  and
  rel_S_neg_distr_cond'_eq:
  "\<And>tytok. rel_S_neg_distr_cond' (=) (=) (=) (=) (=) (=) (=) (=) tytok"

context includes lifting_syntax
begin

definition rel_S_witness' :: "('live1 \<Rightarrow> 'live1'' \<Rightarrow> bool) \<Rightarrow> ('live2 \<Rightarrow> 'live2'' \<Rightarrow> bool) \<Rightarrow>
    ('co1 \<Rightarrow> 'co1' \<Rightarrow> bool) \<Rightarrow> ('co1' \<Rightarrow> 'co1'' \<Rightarrow> bool) \<Rightarrow>
    ('co2 \<Rightarrow> 'co2' \<Rightarrow> bool) \<Rightarrow> ('co2' \<Rightarrow> 'co2'' \<Rightarrow> bool) \<Rightarrow>
    ('contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool) \<Rightarrow> ('contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool) \<Rightarrow>
    ('contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool) \<Rightarrow> ('contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool) \<Rightarrow>
    ('live1, 'live2, 'co1, 'co2, 'contra1, 'contra2, 'fixed) S \<times>
    ('live1'', 'live2'', 'co1'', 'co2'', 'contra1'', 'contra2'', 'fixed) S \<Rightarrow>
    ('live1 \<times> 'live1'', 'live2 \<times> 'live2'', 'co1', 'co2', 'contra1', 'contra2', 'fixed) S"
  where
    "rel_S_witness' = (id ---> id ---> id ---> id ---> id ---> id --->
    id ---> id ---> id ---> id ---> map_prod Rep_S Rep_S ---> Abs_S) rel_G_witness"

lemma rel_S_witness'1:
  fixes L1 :: "'l1 \<Rightarrow> 'l1'' \<Rightarrow> bool" and L2 :: "'l2 \<Rightarrow> 'l2'' \<Rightarrow> bool"
    and Co1 :: "'co1 \<Rightarrow> 'co1' \<Rightarrow> bool" and Co1' :: "'co1' \<Rightarrow> 'co1'' \<Rightarrow> bool"
    and Co2 :: "'co2 \<Rightarrow> 'co2' \<Rightarrow> bool" and Co2' :: "'co2' \<Rightarrow> 'co2'' \<Rightarrow> bool"
    and Contra1 :: "'contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool" and Contra1' :: "'contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool"
    and Contra2 :: "'contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool" and Contra2' :: "'contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool"
    and tytok :: "('l1 \<times> ('l1 \<times> 'l1'') \<times> 'l1'' \<times> 'l2 \<times> ('l2 \<times> 'l2'') \<times> 'l2'' \<times> 'f) itself"
    and x :: "(_, _, _, _, _, _, 'f) S"
  assumes "rel_S L1 L2 (Co1 OO Co1') (Co2 OO Co2') (Contra1 OO Contra1') (Contra2 OO Contra2') x y"
    and "rel_S_neg_distr_cond' Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok"
  shows "rel_S (\<lambda>x (x', y). x' = x \<and> L1 x y) (\<lambda>x (x', y). x' = x \<and> L2 x y) Co1 Co2 Contra1 Contra2 x
    (rel_S_witness' L1 L2 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' (x, y))"
  using assms unfolding rel_S_def rel_S_witness'_def
  apply(simp add: vimage2p_def)
  apply(subst Abs_S_inverse)
   apply(simp)
   apply(rule P_rel_G_zipping[OF Rep_S[of x, simplified] Rep_S[of y, simplified], rotated])
      apply(erule rel_G_witness1[rotated])
      apply(erule rel_S_neg_distr_cond'_stronger)
     apply(erule rel_G_witness2[rotated])
     apply(erule rel_S_neg_distr_cond'_stronger)
    apply(assumption)
   apply(assumption)
  apply(erule rel_G_witness1[rotated])
  apply(erule rel_S_neg_distr_cond'_stronger)
  done

lemma rel_S_witness'2:
  fixes L1 :: "'l1 \<Rightarrow> 'l1'' \<Rightarrow> bool" and L2 :: "'l2 \<Rightarrow> 'l2'' \<Rightarrow> bool"
    and Co1 :: "'co1 \<Rightarrow> 'co1' \<Rightarrow> bool" and Co1' :: "'co1' \<Rightarrow> 'co1'' \<Rightarrow> bool"
    and Co2 :: "'co2 \<Rightarrow> 'co2' \<Rightarrow> bool" and Co2' :: "'co2' \<Rightarrow> 'co2'' \<Rightarrow> bool"
    and Contra1 :: "'contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool" and Contra1' :: "'contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool"
    and Contra2 :: "'contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool" and Contra2' :: "'contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool"
    and tytok :: "('l1 \<times> ('l1 \<times> 'l1'') \<times> 'l1'' \<times> 'l2 \<times> ('l2 \<times> 'l2'') \<times> 'l2'' \<times> 'f) itself"
    and x :: "(_, _, _, _, _, _, 'f) S"
  assumes "rel_S L1 L2 (Co1 OO Co1') (Co2 OO Co2') (Contra1 OO Contra1') (Contra2 OO Contra2') x y"
    and "rel_S_neg_distr_cond' Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok"
  shows "rel_S (\<lambda>(x, y') y. y' = y \<and> L1 x y) (\<lambda>(x, y') y. y' = y \<and> L2 x y) Co1' Co2' Contra1' Contra2'
    (rel_S_witness' L1 L2 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' (x, y)) y"
  using assms unfolding rel_S_def rel_S_witness'_def
  apply(simp add: vimage2p_def)
  apply(subst Abs_S_inverse)
   apply(simp)
   apply(rule P_rel_G_zipping[OF Rep_S[of x, simplified] Rep_S[of y, simplified], rotated])
      apply(erule rel_G_witness1[rotated])
      apply(erule rel_S_neg_distr_cond'_stronger)
     apply(erule rel_G_witness2[rotated])
     apply(erule rel_S_neg_distr_cond'_stronger)
    apply(assumption)
   apply(assumption)
  apply(erule rel_G_witness2[rotated])
  apply(erule rel_S_neg_distr_cond'_stronger)
  done

lemma rel_S_neg_distr_imp:
  fixes Co1 :: "'co1 \<Rightarrow> 'co1' \<Rightarrow> bool" and Co1' :: "'co1' \<Rightarrow> 'co1'' \<Rightarrow> bool"
    and Co2 :: "'co2 \<Rightarrow> 'co2' \<Rightarrow> bool" and Co2' :: "'co2' \<Rightarrow> 'co2'' \<Rightarrow> bool"
    and Contra1 :: "'contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool" and Contra1' :: "'contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool"
    and Contra2 :: "'contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool" and Contra2' :: "'contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool"
    and tytok_S' :: "('l1 \<times> ('l1 \<times> 'l1'') \<times> 'l1'' \<times> 'l2 \<times> ('l2 \<times> 'l2'') \<times> 'l2'' \<times> 'f) itself"
    and tytok_S :: "('l1 \<times> 'l1' \<times> 'l1'' \<times> 'l2 \<times> 'l2' \<times> 'l2'' \<times> 'f) itself"
  assumes "rel_S_neg_distr_cond' Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok_S'"
  shows "rel_S_neg_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok_S"
  unfolding rel_S_neg_distr_cond_def
proof (intro allI predicate2I relcomppI)
  fix L1 :: "'l1 \<Rightarrow> 'l1' \<Rightarrow> bool" and L1' :: "'l1' \<Rightarrow> 'l1'' \<Rightarrow> bool"
    and L2 :: "'l2 \<Rightarrow> 'l2' \<Rightarrow> bool" and L2' :: "'l2' \<Rightarrow> 'l2'' \<Rightarrow> bool"
    and x :: "(_, _, _, _, _, _, 'f) S" and y :: "(_, _, _, _, _, _, 'f) S"
  assume *: "rel_S (L1 OO L1') (L2 OO L2') (Co1 OO Co1') (Co2 OO Co2')
    (Contra1 OO Contra1') (Contra2 OO Contra2') x y"
  let ?z = "map_S (relcompp_witness L1 L1') (relcompp_witness L2 L2') id id id id
    (rel_S_witness' (L1 OO L1') (L2 OO L2') Co1 Co1' Co2 Co2'
    Contra1 Contra1' Contra2 Contra2' (x, y))"
  show "rel_S L1 L2 Co1 Co2 Contra1 Contra2 x ?z"
    apply(subst map_S_id[symmetric])
    apply(rule map_S_rel_cong)
          apply(rule rel_S_witness'1[OF * assms])
         apply(auto simp add: vimage2p_def del: relcomppE elim!: relcompp_witness)
    done
  show "rel_S L1' L2' Co1' Co2' Contra1' Contra2' ?z y"
    apply(rewrite in "rel_S _ _ _ _ _ _ _ \<hole>" map_S_id[symmetric])
    apply(rule map_S_rel_cong)
          apply(rule rel_S_witness'2[OF * assms])
         apply(auto simp add: vimage2p_def del: relcomppE elim!: relcompp_witness)
    done
qed

end (* context includes lifting_syntax *)

subsection \<open>Subtypes of BNFs without co- and contravariance\<close>

text \<open>
  If all variables are live, @{command lift_bnf}'s requirement \<open>P_zip_closed\<close> is equivalent
  to our closedness under zippings, and Popescu's weaker condition is equivalent to negative
  subdistributivity restricted to the subset.
\<close>

bnf_axiomatization 'a H

consts Q :: "'a H \<Rightarrow> bool"

axiomatization where
  Q_map: "\<And>x l. Q x \<Longrightarrow> Q (map_H l x)"

lemma Q_rel_H_zipping:
  fixes x :: "'a H" and y :: "'c H" and z :: "('a \<times> 'c) H"
  assumes Q_zip: "\<And>z :: ('a \<times> 'c) H. \<lbrakk> Q (map_H fst z); Q (map_H snd z) \<rbrakk> \<Longrightarrow> Q z"
    and "Q x" and "Q y" and "rel_H L x y"
    and related: "rel_H (\<lambda>x (x', y). x' = x \<and> L x y) x z" "rel_H (\<lambda>(x, y') y. y' = y \<and> L x y) z y"
  shows "Q z"
proof -
  have "map_H fst z = x" proof -
    from related(1) have "rel_H (=) x (map_H fst z)"
      by (auto simp add: H.rel_map elim: H.rel_mono_strong)
    then show ?thesis by (simp add: H.rel_eq)
  qed
  moreover have "map_H snd z = y" proof -
    from related(2) have "rel_H (=) (map_H snd z) y"
      by (auto simp add: H.rel_map elim: H.rel_mono_strong)
    then show ?thesis by (simp add: H.rel_eq)
  qed
  moreover note \<open>Q x\<close> \<open>Q y\<close>
  ultimately show ?thesis using Q_zip by blast
qed

lemma Q_zip:
  fixes z :: "('a \<times> 'c) H"
  assumes Q_rel_H_zipping: "\<And>(L :: 'a \<Rightarrow> 'c \<Rightarrow> _) x y z.
      \<lbrakk> Q x; Q y; rel_H L x y; rel_H (\<lambda>x (x', y). x' = x \<and> L x y) x z;
        rel_H (\<lambda>(x, y') y. y' = y \<and> L x y) z y \<rbrakk> \<Longrightarrow> Q z"
    and "Q (map_H fst z)" and "Q (map_H snd z)"
  shows "Q z"
proof -
  let ?L = "\<lambda>a (a', b). a' = a \<and> top a b" and ?L' = "\<lambda>(b, c') c. c' = c \<and> top b c"
  have *: "rel_H ?L (map_H fst z) z" "rel_H ?L' z (map_H snd z)"
    by (auto simp add: H.rel_map Grp_apply intro!: H.rel_refl_strong)
  then have "rel_H (?L OO ?L') (map_H fst z) (map_H snd z)"
    by (auto simp add: H.rel_compp)
  then have "rel_H top (map_H fst z) (map_H snd z)"
    by (simp add: relcompp_apply[abs_def] top_fun_def)
  with \<open>Q (map_H fst z)\<close> \<open>Q (map_H snd z)\<close> * show "Q z"
    using Q_rel_H_zipping by blast
qed

lemma Q_neg_distr:
  fixes x :: "'a H" and y :: "'c H"
  assumes Q_zip_weak: "\<And>z :: ('a \<times> 'c) H. \<lbrakk> Q (map_H fst z); Q (map_H snd z) \<rbrakk> \<Longrightarrow>
      \<exists>z'. Q z' \<and> set_H z' \<subseteq> set_H z \<and> map_H fst z' = map_H fst z \<and> map_H snd z' = map_H snd z"
    and "Q x" and "Q y" and related: "rel_H (L OO L') x y"
  shows "(rel_H L OO eq_onp Q OO rel_H L') x y"
proof -
  from related obtain z where
    *: "set_H z \<subseteq> {(x, y). (L OO L') x y}" "map_H fst z = x" "map_H snd z = y"
    unfolding H.rel_compp_Grp by (blast elim: GrpE)
  with \<open>Q x\<close> \<open>Q y\<close> have "Q (map_H fst z)" and "Q (map_H snd z)" by simp_all
  then obtain z' where "Q z'" "set_H z' \<subseteq> set_H z"
    "map_H fst z' = map_H fst z" "map_H snd z' = map_H snd z"
    using Q_zip_weak by blast
  with * have **: "set_H z' \<subseteq> {(x, y). (L OO L') x y}" "x = map_H fst z'" "y = map_H snd z'"
    by simp_all
  let ?z = "map_H (relcompp_witness L L') z'"
  from \<open>Q z'\<close> have "Q ?z" by (rule Q_map)
  moreover have "rel_H L x ?z" "rel_H L' ?z y"
    using ** by (auto simp add: H.rel_map intro!: H.rel_refl_strong
        relcompp_witness[of L L' "fst p" "snd p" for p, simplified])
  ultimately show ?thesis unfolding eq_onp_def by blast
qed

lemma Q_zip_weak:
  fixes z :: "('a \<times> 'c) H"
  assumes Q_neg_distr: "\<And>(L :: 'a \<Rightarrow> ('a \<times> 'c) \<Rightarrow> _) (L' :: ('a \<times> 'c) \<Rightarrow> 'c \<Rightarrow> bool) x y.
      \<lbrakk> Q x; Q y; rel_H (L OO L') x y \<rbrakk> \<Longrightarrow> (rel_H L OO eq_onp Q OO rel_H L') x y"
    and "Q (map_H fst z)" and "Q (map_H snd z)"
  obtains z' where "Q z'" and "set_H z' \<subseteq> set_H z"
    and "map_H fst z' = map_H fst z" and "map_H snd z' = map_H snd z"
proof -
  let ?L = "(Grp (set_H z) fst)\<inverse>\<inverse>" and ?L' = "Grp (set_H z) snd"
  have "rel_H ?L (map_H fst z) z" "rel_H ?L' z (map_H snd z)"
    by (auto simp add: H.rel_map Grp_apply intro!: H.rel_refl_strong)
  then have "rel_H (?L OO ?L') (map_H fst z) (map_H snd z)"
    by (auto simp add: H.rel_compp)
  with \<open>Q (map_H fst z)\<close> \<open>Q (map_H snd z)\<close>
  have "(rel_H ?L OO eq_onp Q OO rel_H ?L') (map_H fst z) (map_H snd z)"
    by (rule Q_neg_distr)
  then obtain z' where "Q z'" "rel_H ?L (map_H fst z) z'" "rel_H ?L' z' (map_H snd z)"
    unfolding eq_onp_def by blast
  then have "rel_H (\<lambda>a b. snd b = snd a \<and> a \<in> set_H z) z' z"
    by (simp add: H.rel_map Grp_apply)
  then have "rel_H (\<lambda>a b. a \<in> set_H z) z' z"
    by (auto elim: H.rel_mono_strong)
  then have "pred_H (Domainp (\<lambda>a (b :: ('a \<times> 'c)). a \<in> set_H z)) z'"
    by (auto simp add: H.Domainp_rel[symmetric] Domainp_iff)
  then have "set_H z' \<subseteq> set_H z"
    unfolding H.axiom10_H by auto
  moreover have "map_H fst z' = map_H fst z"
    apply (rule sym)
    apply (subst H.rel_eq[symmetric])
    apply (subst H.rel_map(2))
    apply (rule H.rel_mono_strong)
     apply (fact \<open>rel_H ?L (map_H fst z) z'\<close>)
    apply (simp add: Grp_apply)
    done
  moreover have "map_H snd z' = map_H snd z"
    apply (subst H.rel_eq[symmetric])
    apply (subst H.rel_map(1))
    apply (rule H.rel_mono_strong)
     apply (fact \<open>rel_H ?L' z' (map_H snd z)\<close>)
    apply (simp add: Grp_apply)
    done
  moreover note \<open>Q z'\<close>
  ultimately show thesis using that by blast
qed

end


theory ILL_predlog
imports ILL
begin

typedecl plf

consts
  conj :: "[plf,plf] \<Rightarrow> plf"   (infixr "&" 35)
  disj :: "[plf,plf] \<Rightarrow> plf"   (infixr "|" 35)
  impl :: "[plf,plf] \<Rightarrow> plf"   (infixr ">" 35)
  eq :: "[plf,plf] \<Rightarrow> plf"   (infixr "=" 35)
  ff :: "plf"    ("ff")

  PL    :: "plf \<Rightarrow> o"      ("[* / _ / *]" [] 100)

syntax
  "_NG" :: "plf \<Rightarrow> plf"   ("- _ " [50] 55)

translations
  "[* A & B *]" \<rightleftharpoons> "[*A*] && [*B*]"
  "[* A | B *]" \<rightleftharpoons> "![*A*] ++ ![*B*]"
  "[* - A *]" \<rightleftharpoons> "[*A > ff*]"
  "[* ff *]" \<rightleftharpoons> "0"
  "[* A = B *]" \<rightharpoonup> "[* (A > B) & (B > A) *]"

  "[* A > B *]" \<rightleftharpoons> "![*A*] -o [*B*]"

(* another translations for linear implication:
  "[* A > B *]" == "!([*A*] -o [*B*])" *)

(* from [kleene 52] pp 118,119 *)

lemma k49a: "\<turnstile> [* A > ( - ( - A)) *]"
  by best_safe

lemma k49b: "\<turnstile> [*( - ( - ( - A))) = ( - A)*]"
  by best_safe

lemma k49c: "\<turnstile> [* (A | - A) > ( - - A = A) *]"
  by best_safe

lemma k50a: "\<turnstile> [* - (A = - A) *]"
  by best_power

lemma k51a: "\<turnstile> [* - - (A | - A) *]"
  by best_safe

lemma k51b: "\<turnstile> [* - - (- - A > A) *]"
  by best_power

lemma k56a: "\<turnstile> [* (A | B) > - (- A & - B) *]"
  by best_safe

lemma k56b: "\<turnstile> [* (-A | B) > - (A & -B) *]"
  by best_safe

lemma k57a: "\<turnstile> [* (A & B) > - (-A | -B) *]"
  by best_safe

lemma k57b: "\<turnstile> [* (A & -B) > -(-A | B) *]"
  by best_power

lemma k58a: "\<turnstile> [* (A > B) > - (A & -B) *]"
  by best_safe

lemma k58b: "\<turnstile> [* (A > -B) = -(A & B) *]"
  by best_safe

lemma k58c: "\<turnstile> [* - (A & B) = (- - A > - B) *]"
  by best_safe

lemma k58d: "\<turnstile> [* (- - A > - B) = - - (-A | -B) *]"
  by best_safe

lemma k58e: "! [* - -B > B *] \<turnstile> [* (- -A > B) = (A > B) *]"
  by best_safe

lemma k58f: "! [* - -B > B *] \<turnstile> [* (A > B) = - (A & -B) *]"
  by best_safe

lemma k58g: "\<turnstile> [* (- -A > B) > - (A & -B) *]"
  by best_safe

lemma k59a: "\<turnstile> [* (-A | B) > (A > B) *]"
  by best_safe

lemma k59b: "\<turnstile> [* (A > B) > - - (-A | B) *]"
  by best_power

lemma k59c: "\<turnstile> [* (-A > B) > - -(A | B) *]"
  by best_power

lemma k60a: "\<turnstile> [* (A & B) > - (A > -B) *]"
  by best_safe

lemma k60b: "\<turnstile> [* (A & -B) > - (A > B) *]"
  by best_safe

lemma k60c: "\<turnstile> [* ( - - A & B) > - (A > -B) *]"
  by best_safe

lemma k60d: "\<turnstile> [* (- - A & - B) = - (A > B) *]"
  by best_safe

lemma k60e: "\<turnstile> [* - (A > B) = - (-A | B) *]"
  by best_safe

lemma k60f: "\<turnstile> [* - (-A | B) = - - (A & -B) *]"
  by best_safe

lemma k60g: "\<turnstile> [* - - (A > B) = - (A & -B) *]"
  by best_power

lemma k60h: "\<turnstile> [* - (A & -B) = (A > - -B) *]"
  by best_safe

lemma k60i: "\<turnstile> [* (A > - -B) = (- -A > - -B) *]"
  by best_safe

lemma k61a: "\<turnstile> [* (A | B) > (-A > B) *]"
  by best_safe

lemma k61b: "\<turnstile> [* - (A | B) = - (-A > B) *]"
  by best_power

lemma k62a: "\<turnstile> [* (-A | -B) > - (A & B) *]"
  by best_safe

end


theory Rot13
imports Verifuck
begin

definition "rot13 =  ''
-,+[                         Read first character and start outer character reading loop
    -[                       Skip forward if character is 0
        >>++++[>++++++++<-]  Set up divisor (32) for division loop
                               (MEMORY LAYOUT: dividend copy remainder divisor quotient zero zero)
        <+<-[                Set up dividend (x minus 1) and enter division loop
            >+>+>-[>>>]      Increase copy and remainder / reduce divisor / Normal case: skip forward
            <[[>+<-]>>+>]    Special case: move remainder back to divisor and increase quotient
            <<<<<-           Decrement dividend
        ]                    End division loop
    ]>>>[-]+                 End skip loop; zero former divisor and reuse space for a flag
    >--[-[<->+++[-]]]<[         Zero that flag unless quotient was 2 or 3; zero quotient; check flag
        ++++++++++++<[       If flag then set up divisor (13) for second division loop
                               (MEMORY LAYOUT: zero copy dividend divisor remainder quotient zero zero)
            >-[>+>>]         Reduce divisor; Normal case: increase remainder
            >[+[<+>-]>+>>]   Special case: increase remainder / move it back to divisor / increase quotient
            <<<<<-           Decrease dividend
        ]                    End division loop
        >>[<+>-]             Add remainder back to divisor to get a useful 13
        >[                   Skip forward if quotient was 0
            -[               Decrement quotient and skip forward if quotient was 1
                -<<[-]>>     Zero quotient and divisor if quotient was 2
            ]<<[<<->>-]>>    Zero divisor and subtract 13 from copy if quotient was 1
        ]<<[<<+>>-]          Zero divisor and add 13 to copy if quotient was 0
    ]                        End outer skip loop (jump to here if ((character minus 1)/32) was not 2 or 3)
    <[-]                     Clear remainder from first division if second division was skipped
    <.[-]                    Output ROT13ed character from copy and clear it
    <-,+                     Read next character
]                            End character reading loop''"

value[code] "parse_instrs rot13"

value[code] "map byte_to_char (run_bf (parse_instrs rot13) (map char_to_byte ''Hello World!''))"
lemma "let result = run_bf (parse_instrs rot13) (map char_to_byte ''Hello World!'') in
         map byte_to_char result = ''Uryyb Jbeyq!''" by eval

value "bounded_machine 102 (parse_instrs rot13) [] (Machine empty_tape (Buffer (map char_to_byte ''Hello World!'') read_byte []))"

lemma "case run_bf_bounded 60000 (parse_instrs rot13) (map char_to_byte ''Hello World!'') of Inr result \<Rightarrow>
         map byte_to_char result = ''Uryyb Jbeyq!''" by eval

end


subsection \<open>The view-partitioning equivalence relation\<close>

theory Step_vpeq
  imports Step Step_invariants
begin

text \<open>The view consists of
 \begin{enumerate}
 \item View of object values.
 \item View of subject-subject dynamic policy. The threads can discover the policy
       at runtime, e.g. by calling ipc() and observing success or failure.
 \item View of subject-object dynamic policy. The threads can discover the policy
       at runtime, e.g. by calling open() and observing success or failure.
 \end{enumerate}
\<close>

definition vpeq_obj :: "partition_id_t \<Rightarrow> state_t \<Rightarrow> state_t \<Rightarrow> bool" where
  "vpeq_obj u s t \<equiv> \<forall> obj_id . Policy.sp_spec_subj_obj u obj_id READ \<longrightarrow> (obj s) obj_id = (obj t) obj_id"

definition vpeq_subj_subj :: "partition_id_t \<Rightarrow> state_t \<Rightarrow> state_t \<Rightarrow> bool" where
  "vpeq_subj_subj u s t \<equiv>
    \<forall> v . ((Policy.sp_spec_subj_subj u v \<longrightarrow> sp_impl_subj_subj s u v = sp_impl_subj_subj t u v)
           \<and> (Policy.sp_spec_subj_subj v u \<longrightarrow> sp_impl_subj_subj s v u = sp_impl_subj_subj t v u))"

definition vpeq_subj_obj :: "partition_id_t \<Rightarrow> state_t \<Rightarrow> state_t \<Rightarrow> bool" where
  "vpeq_subj_obj u s t \<equiv>
   \<forall> ob m p1 .
     (Policy.sp_spec_subj_obj u ob m \<longrightarrow> sp_impl_subj_obj s u ob m = sp_impl_subj_obj t u ob m)
   \<and> (Policy.sp_spec_subj_obj p1 ob PROVIDE \<and> (Policy.sp_spec_subj_obj u ob READ \<or> Policy.sp_spec_subj_obj u ob WRITE) \<longrightarrow>
         sp_impl_subj_obj s p1 ob PROVIDE = sp_impl_subj_obj t p1 ob PROVIDE)"

definition vpeq_local :: "partition_id_t \<Rightarrow> state_t \<Rightarrow> state_t \<Rightarrow> bool" where
 "vpeq_local u s t \<equiv>
    \<forall> tid . (partition tid) = u \<longrightarrow> (thread s tid) = (thread t tid)"

definition "vpeq u s t \<equiv>
   vpeq_obj u s t \<and> vpeq_subj_subj u s t \<and> vpeq_subj_obj u s t \<and> vpeq_local u s t"

subsubsection \<open>Elementary properties\<close>

lemma vpeq_rel:
  shows vpeq_refl: "vpeq u s s"
    and vpeq_sym [sym]: "vpeq u s t \<Longrightarrow> vpeq u t s"
    and vpeq_trans [trans]: "\<lbrakk> vpeq u s1 s2 ; vpeq u s2 s3 \<rbrakk> \<Longrightarrow> vpeq u s1 s3"
  unfolding vpeq_def vpeq_obj_def vpeq_subj_subj_def vpeq_subj_obj_def vpeq_local_def
    by auto

text \<open>Auxiliary equivalence relation.\<close>

lemma set_object_value_ign:
  assumes eq_obs: "~ Policy.sp_spec_subj_obj u x READ"
    shows "vpeq u s (set_object_value x y s)"
proof -
  from assms show ?thesis
    unfolding vpeq_def vpeq_obj_def vpeq_subj_subj_def vpeq_subj_obj_def set_object_value_def
              vpeq_local_def
    by auto
qed

text \<open>Context-switch and fetch operations are also consistent with vpeq
        and locally respect everything.\<close>

theorem cswitch_consistency_and_respect:
  fixes u :: partition_id_t
    and s :: state_t
    and new_current :: thread_id_t
  assumes "atomic_step_invariant s"
  shows "vpeq u s (s \<lparr> current := new_current \<rparr>)"
proof -
  show ?thesis
    unfolding vpeq_def vpeq_obj_def vpeq_subj_subj_def vpeq_subj_obj_def vpeq_local_def
    by auto
qed

end


(*  Title:      HOL/Auth/WooLam.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge
*)

section{*The Woo-Lam Protocol*}

theory WooLam imports Public begin

text{*Simplified version from page 11 of
  Abadi and Needham (1996).
  Prudent Engineering Practice for Cryptographic Protocols.
  IEEE Trans. S.E. 22(1), pages 6-15.

Note: this differs from the Woo-Lam protocol discussed by Lowe (1996):
  Some New Attacks upon Security Protocols.
  Computer Security Foundations Workshop
*}

inductive_set woolam :: "event list set"
  where
         (*Initial trace is empty*)
   Nil:  "[] \<in> woolam"

         (** These rules allow agents to send messages to themselves **)

         (*The spy MAY say anything he CAN say.  We do not expect him to
           invent new nonces here, but he can also use NS1.  Common to
           all similar protocols.*)
 | Fake: "[| evsf \<in> woolam;  X \<in> synth (analz (spies evsf)) |]
          ==> Says Spy B X  # evsf \<in> woolam"

         (*Alice initiates a protocol run*)
 | WL1:  "evs1 \<in> woolam ==> Says A B (Agent A) # evs1 \<in> woolam"

         (*Bob responds to Alice's message with a challenge.*)
 | WL2:  "[| evs2 \<in> woolam;  Says A' B (Agent A) \<in> set evs2 |]
          ==> Says B A (Nonce NB) # evs2 \<in> woolam"

         (*Alice responds to Bob's challenge by encrypting NB with her key.
           B is *not* properly determined -- Alice essentially broadcasts
           her reply.*)
 | WL3:  "[| evs3 \<in> woolam;
             Says A  B (Agent A)  \<in> set evs3;
             Says B' A (Nonce NB) \<in> set evs3 |]
          ==> Says A B (Crypt (shrK A) (Nonce NB)) # evs3 \<in> woolam"

         (*Bob forwards Alice's response to the Server.  NOTE: usually
           the messages are shown in chronological order, for clarity.
           But here, exchanging the two events would cause the lemma
           WL4_analz_spies to pick up the wrong assumption!*)
 | WL4:  "[| evs4 \<in> woolam;
             Says A'  B X         \<in> set evs4;
             Says A'' B (Agent A) \<in> set evs4 |]
          ==> Says B Server {|Agent A, Agent B, X|} # evs4 \<in> woolam"

         (*Server decrypts Alice's response for Bob.*)
 | WL5:  "[| evs5 \<in> woolam;
             Says B' Server {|Agent A, Agent B, Crypt (shrK A) (Nonce NB)|}
               \<in> set evs5 |]
          ==> Says Server B (Crypt (shrK B) {|Agent A, Nonce NB|})
                 # evs5 \<in> woolam"

declare Says_imp_knows_Spy [THEN analz.Inj, dest]
declare parts.Body  [dest]
declare analz_into_parts [dest]
declare Fake_parts_insert_in_Un  [dest]

(*A "possibility property": there are traces that reach the end*)
lemma "\<exists>NB. \<exists>evs \<in> woolam.
             Says Server B (Crypt (shrK B) {|Agent A, Nonce NB|}) \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] woolam.Nil
                    [THEN woolam.WL1, THEN woolam.WL2, THEN woolam.WL3,
                     THEN woolam.WL4, THEN woolam.WL5], possibility)
done

(*Could prove forwarding lemmas for WL4, but we do not need them!*)

(**** Inductive proofs about woolam ****)

(** Theorems of the form X \<notin> parts (spies evs) imply that NOBODY
    sends messages containing X! **)

(*Spy never sees a good agent's shared key!*)
lemma Spy_see_shrK [simp]:
     "evs \<in> woolam ==> (Key (shrK A) \<in> parts (spies evs)) = (A \<in> bad)"
by (erule woolam.induct, force, simp_all, blast+)

lemma Spy_analz_shrK [simp]:
     "evs \<in> woolam ==> (Key (shrK A) \<in> analz (spies evs)) = (A \<in> bad)"
by auto

lemma Spy_see_shrK_D [dest!]:
     "[|Key (shrK A) \<in> parts (knows Spy evs);  evs \<in> woolam|] ==> A \<in> bad"
by (blast dest: Spy_see_shrK)

(**** Autheticity properties for Woo-Lam ****)

(*** WL4 ***)

(*If the encrypted message appears then it originated with Alice*)
lemma NB_Crypt_imp_Alice_msg:
     "[| Crypt (shrK A) (Nonce NB) \<in> parts (spies evs);
         A \<notin> bad;  evs \<in> woolam |]
      ==> \<exists>B. Says A B (Crypt (shrK A) (Nonce NB)) \<in> set evs"
by (erule rev_mp, erule woolam.induct, force, simp_all, blast+)

(*Guarantee for Server: if it gets a message containing a certificate from
  Alice, then she originated that certificate.  But we DO NOT know that B
  ever saw it: the Spy may have rerouted the message to the Server.*)
lemma Server_trusts_WL4 [dest]:
     "[| Says B' Server {|Agent A, Agent B, Crypt (shrK A) (Nonce NB)|}
           \<in> set evs;
         A \<notin> bad;  evs \<in> woolam |]
      ==> \<exists>B. Says A B (Crypt (shrK A) (Nonce NB)) \<in> set evs"
by (blast intro!: NB_Crypt_imp_Alice_msg)

(*** WL5 ***)

(*Server sent WL5 only if it received the right sort of message*)
lemma Server_sent_WL5 [dest]:
     "[| Says Server B (Crypt (shrK B) {|Agent A, NB|}) \<in> set evs;
         evs \<in> woolam |]
      ==> \<exists>B'. Says B' Server {|Agent A, Agent B, Crypt (shrK A) NB|}
             \<in> set evs"
by (erule rev_mp, erule woolam.induct, force, simp_all, blast+)

(*If the encrypted message appears then it originated with the Server!*)
lemma NB_Crypt_imp_Server_msg [rule_format]:
     "[| Crypt (shrK B) {|Agent A, NB|} \<in> parts (spies evs);
         B \<notin> bad;  evs \<in> woolam |]
      ==> Says Server B (Crypt (shrK B) {|Agent A, NB|}) \<in> set evs"
by (erule rev_mp, erule woolam.induct, force, simp_all, blast+)

(*Guarantee for B.  If B gets the Server's certificate then A has encrypted
  the nonce using her key.  This event can be no older than the nonce itself.
  But A may have sent the nonce to some other agent and it could have reached
  the Server via the Spy.*)
lemma B_trusts_WL5:
     "[| Says S B (Crypt (shrK B) {|Agent A, Nonce NB|}): set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> woolam  |]
      ==> \<exists>B. Says A B (Crypt (shrK A) (Nonce NB)) \<in> set evs"
by (blast dest!: NB_Crypt_imp_Server_msg)

(*B only issues challenges in response to WL1.  Not used.*)
lemma B_said_WL2:
     "[| Says B A (Nonce NB) \<in> set evs;  B \<noteq> Spy;  evs \<in> woolam |]
      ==> \<exists>A'. Says A' B (Agent A) \<in> set evs"
by (erule rev_mp, erule woolam.induct, force, simp_all, blast+)

(**CANNOT be proved because A doesn't know where challenges come from...*)
lemma "[| A \<notin> bad;  B \<noteq> Spy;  evs \<in> woolam |]
  ==> Crypt (shrK A) (Nonce NB) \<in> parts (spies evs) &
      Says B A (Nonce NB) \<in> set evs
      --> Says A B (Crypt (shrK A) (Nonce NB)) \<in> set evs"
apply (erule rev_mp, erule woolam.induct, force, simp_all, blast, auto)
oops

end