theory LiarsStreet  (*Christoph Benzmüller, 2020*)
  imports Main

(*
abbrevs
 Nilda="\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a" and Nilda="\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a" and And="( \<^bold>a\<^bold>n\<^bold>d )" and Or="( \<^bold>o\<^bold>r )" and Not="(\<^bold>n\<^bold>o\<^bold>t )" and If_then="(\<^bold>I\<^bold>f \<^bold>t\<^bold>h\<^bold>e\<^bold>n )"
 and LiarsStreet="\<^bold>L\<^bold>i\<^bold>a\<^bold>r\<^bold>s\<^bold>S\<^bold>t\<^bold>r\<^bold>e\<^bold>e\<^bold>t" and TruthtellersRoad="\<^bold>T\<^bold>r\<^bold>u\<^bold>t\<^bold>h\<^bold>t\<^bold>e\<^bold>l\<^bold>l\<^bold>e\<^bold>r\<^bold>s\<^bold>R\<^bold>o\<^bold>a\<^bold>d" and Lies="\<^bold>(l\<^bold>i\<^bold>e\<^bold>s )"
 and Says_the_truth="(\<^bold>s\<^bold>a\<^bold>y\<^bold>s\<^bold>-\<^bold>t\<^bold>h\<^bold>e\<^bold>-\<^bold>t\<^bold>r\<^bold>u\<^bold>t\<^bold>h )" and Lives_not_in="( \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>n\<^bold>o\<^bold>t\<^bold>-\<^bold>i\<^bold>n )"
 and Neither_nor_live_in="( \<^bold>n\<^bold>e\<^bold>i\<^bold>t\<^bold>h\<^bold>e\<^bold>r  \<^bold>n\<^bold>o\<^bold>r  \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>-\<^bold>i\<^bold>n )" and Both_live_in="( \<^bold>\<^bold>b\<^bold>o\<^bold>t\<^bold>h  \<^bold>a\<^bold>n\<^bold>d  \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>-\<^bold>i\<^bold>n )"
*)

begin
(*unimportant*) nitpick_params [user_axioms,format=2,show_all]
(*unimportant*) declare [[show_abbrevs=false]]

(***********************************************************************************
 ******************  Some Basic Types of our Ontology ******************************
 ***********************************************************************************)
(* There are some kids, could be many more *)
datatype Entity = Nilda ("\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a") | Carla  ("\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a")
print_theorems

lemma "\<not>(\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a = \<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a)" sledgehammer by simp

(* There are some roads, could be many more *)
datatype Street = LiarsStreet ("\<^bold>L\<^bold>i\<^bold>a\<^bold>r\<^bold>s\<^bold>S\<^bold>t\<^bold>r\<^bold>e\<^bold>e\<^bold>t") | TruthtellersRoad ("\<^bold>T\<^bold>r\<^bold>u\<^bold>t\<^bold>h\<^bold>t\<^bold>e\<^bold>l\<^bold>l\<^bold>e\<^bold>r\<^bold>s\<^bold>R\<^bold>o\<^bold>a\<^bold>d")

(***********************************************************************************
 ******************  Controlled Natural Language Library ***************************
 ******************  Logic and Modalities ******************************************
 ***********************************************************************************)

definition And ("_ \<^bold>a\<^bold>n\<^bold>d _") where "X \<^bold>a\<^bold>n\<^bold>d Y \<equiv> X \<and> Y"
abbreviation Or ("_ \<^bold>o\<^bold>r _") where "X \<^bold>o\<^bold>r Y \<equiv> X \<or> Y"
definition Not ("\<^bold>n\<^bold>o\<^bold>t _") where "\<^bold>n\<^bold>o\<^bold>t X \<equiv> \<not>X"
definition If_then ("\<^bold>I\<^bold>f _ \<^bold>t\<^bold>h\<^bold>e\<^bold>n _") where "\<^bold>I\<^bold>f X \<^bold>t\<^bold>h\<^bold>e\<^bold>n Y \<equiv> X \<longrightarrow> Y"

(* "Says" "Knows" "Belief" "Obligation", etc. as uninterpreted truth-functions
   --- which, of course, will lead to known paradoxes *)
consts  Says::"Entity\<Rightarrow>bool\<Rightarrow>bool"  ("_ \<^bold>s\<^bold>a\<^bold>y\<^bold>s _")
consts  Knows::"Entity\<Rightarrow>bool\<Rightarrow>bool"  ("_ \<^bold>k\<^bold>n\<^bold>o\<^bold>w\<^bold>s _")
consts  Believes::"Entity\<Rightarrow>bool\<Rightarrow>bool"  ("_ \<^bold>b\<^bold>e\<^bold>l\<^bold>i\<^bold>e\<^bold>v\<^bold>e\<^bold>s _")
consts  Obligation::"Entity\<Rightarrow>bool\<Rightarrow>bool"  ("_ \<^bold>m\<^bold>u\<^bold>s\<^bold>t\<^bold>-\<^bold>d\<^bold>o _")

(* We can introduce some further derived modal NL phrases *)
definition Lies ("\<^bold>l\<^bold>i\<^bold>e\<^bold>s _") where "\<^bold>l\<^bold>i\<^bold>e\<^bold>s X \<equiv> \<forall>Y. \<^bold>I\<^bold>f (X \<^bold>s\<^bold>a\<^bold>y\<^bold>s Y) \<^bold>t\<^bold>h\<^bold>e\<^bold>n \<^bold>n\<^bold>o\<^bold>t Y"
definition Says_the_truth ("\<^bold>s\<^bold>a\<^bold>y\<^bold>s\<^bold>-\<^bold>t\<^bold>h\<^bold>e\<^bold>-\<^bold>t\<^bold>r\<^bold>u\<^bold>t\<^bold>h _")
  where "\<^bold>s\<^bold>a\<^bold>y\<^bold>s\<^bold>-\<^bold>t\<^bold>h\<^bold>e\<^bold>-\<^bold>t\<^bold>r\<^bold>u\<^bold>t\<^bold>h X \<equiv> \<forall>Y. \<^bold>I\<^bold>f (X \<^bold>s\<^bold>a\<^bold>y\<^bold>s Y) \<^bold>t\<^bold>h\<^bold>e\<^bold>n Y"

(* We add the above defintions to our "bag" called "Defs" — Unimportant *)
named_theorems Defs
declare Lies_def [Defs] Says_the_truth_def [Defs]

(***********************************************************************************
 ****************** Controlled Natural Language Library ****************************
 ****************** Domain specific concepts ***************************************
 ***********************************************************************************)

(* Uninterpreted predicate: Lives_in *)
consts Lives_in::"Entity\<Rightarrow>Street\<Rightarrow>bool" ("_ \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n _")

(* Further derived NL phrases that concern "Lives_in" *)
definition Lives_not_in ("_ \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>n\<^bold>o\<^bold>t\<^bold>-\<^bold>i\<^bold>n _")
  where "X \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>n\<^bold>o\<^bold>t\<^bold>-\<^bold>i\<^bold>n G \<equiv> \<^bold>n\<^bold>o\<^bold>t (X \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n G)"
definition Neither_nor_live_in ("\<^bold>n\<^bold>e\<^bold>i\<^bold>t\<^bold>h\<^bold>e\<^bold>r _ \<^bold>n\<^bold>o\<^bold>r _ \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>-\<^bold>i\<^bold>n _")
  where "\<^bold>n\<^bold>e\<^bold>i\<^bold>t\<^bold>h\<^bold>e\<^bold>r X \<^bold>n\<^bold>o\<^bold>r Y \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>-\<^bold>i\<^bold>n G \<equiv> (\<^bold>n\<^bold>o\<^bold>t (X \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n G)) \<^bold>a\<^bold>n\<^bold>d (\<^bold>n\<^bold>o\<^bold>t (Y \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n G))"
definition Both_live_in ("\<^bold>b\<^bold>o\<^bold>t\<^bold>h _ \<^bold>a\<^bold>n\<^bold>d _ \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>-\<^bold>i\<^bold>n _")
  where "\<^bold>b\<^bold>o\<^bold>t\<^bold>h X \<^bold>a\<^bold>n\<^bold>d Y \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>-\<^bold>i\<^bold>n G \<equiv> (X \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n G) \<^bold>a\<^bold>n\<^bold>d (Y \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n G)"

(* We add the above defintions to our "bag" called "Defs" — Unimportant *)
declare Lives_not_in_def [Defs] Neither_nor_live_in_def [Defs] Both_live_in_def [Defs]

(***********************************************************************************
 ****************** Example Queries ************************************************
 ***********************************************************************************)

axiomatization where
A1:  "\<forall>X. \<^bold>I\<^bold>f (X \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n \<^bold>L\<^bold>i\<^bold>a\<^bold>r\<^bold>s\<^bold>S\<^bold>t\<^bold>r\<^bold>e\<^bold>e\<^bold>t) \<^bold>t\<^bold>h\<^bold>e\<^bold>n (\<^bold>l\<^bold>i\<^bold>e\<^bold>s X)"  and
A2:  "\<forall>X. \<^bold>I\<^bold>f (X \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n \<^bold>T\<^bold>r\<^bold>u\<^bold>t\<^bold>h\<^bold>t\<^bold>e\<^bold>l\<^bold>l\<^bold>e\<^bold>r\<^bold>s\<^bold>R\<^bold>o\<^bold>a\<^bold>d) \<^bold>t\<^bold>h\<^bold>e\<^bold>n (\<^bold>s\<^bold>a\<^bold>y\<^bold>s\<^bold>-\<^bold>t\<^bold>h\<^bold>e\<^bold>-\<^bold>t\<^bold>r\<^bold>u\<^bold>t\<^bold>h X)"

lemma Question1:
  assumes
   "\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a \<^bold>s\<^bold>a\<^bold>y\<^bold>s (\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n \<^bold>T\<^bold>r\<^bold>u\<^bold>t\<^bold>h\<^bold>t\<^bold>e\<^bold>l\<^bold>l\<^bold>e\<^bold>r\<^bold>s\<^bold>R\<^bold>o\<^bold>a\<^bold>d)"
   "\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>s\<^bold>a\<^bold>y\<^bold>s (\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n \<^bold>T\<^bold>r\<^bold>u\<^bold>t\<^bold>h\<^bold>t\<^bold>e\<^bold>l\<^bold>l\<^bold>e\<^bold>r\<^bold>s\<^bold>R\<^bold>o\<^bold>a\<^bold>d)"
  shows
   "((\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n S1) \<^bold>a\<^bold>n\<^bold>d (\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n S2))"
  nitpick[satisfy] oops

lemma Question1b:
  assumes
   "\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a \<^bold>s\<^bold>a\<^bold>y\<^bold>s (\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n \<^bold>T\<^bold>r\<^bold>u\<^bold>t\<^bold>h\<^bold>t\<^bold>e\<^bold>l\<^bold>l\<^bold>e\<^bold>r\<^bold>s\<^bold>R\<^bold>o\<^bold>a\<^bold>d)"
   "\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>s\<^bold>a\<^bold>y\<^bold>s (\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n \<^bold>T\<^bold>r\<^bold>u\<^bold>t\<^bold>h\<^bold>t\<^bold>e\<^bold>l\<^bold>l\<^bold>e\<^bold>r\<^bold>s\<^bold>R\<^bold>o\<^bold>a\<^bold>d)"
  shows
   "((\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n \<^bold>L\<^bold>i\<^bold>a\<^bold>r\<^bold>s\<^bold>S\<^bold>t\<^bold>r\<^bold>e\<^bold>e\<^bold>t) \<^bold>a\<^bold>n\<^bold>d (\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n S2))"
  nitpick[satisfy] oops

lemma Question2:
  assumes
   "\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a \<^bold>s\<^bold>a\<^bold>y\<^bold>s (\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n \<^bold>L\<^bold>i\<^bold>a\<^bold>r\<^bold>s\<^bold>S\<^bold>t\<^bold>r\<^bold>e\<^bold>e\<^bold>t)"
   "\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>s\<^bold>a\<^bold>y\<^bold>s (\<^bold>n\<^bold>e\<^bold>i\<^bold>t\<^bold>h\<^bold>e\<^bold>r \<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a \<^bold>n\<^bold>o\<^bold>r \<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>-\<^bold>i\<^bold>n \<^bold>L\<^bold>i\<^bold>a\<^bold>r\<^bold>s\<^bold>S\<^bold>t\<^bold>r\<^bold>e\<^bold>e\<^bold>t)"
  shows
   "((\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n S1) \<^bold>a\<^bold>n\<^bold>d (\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n S2))"
  nitpick[satisfy] oops

lemma Question3:
  assumes
   "\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a \<^bold>s\<^bold>a\<^bold>y\<^bold>s (\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n \<^bold>L\<^bold>i\<^bold>a\<^bold>r\<^bold>s\<^bold>S\<^bold>t\<^bold>r\<^bold>e\<^bold>e\<^bold>t)"
   "\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>s\<^bold>a\<^bold>y\<^bold>s (\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n \<^bold>L\<^bold>i\<^bold>a\<^bold>r\<^bold>s\<^bold>S\<^bold>t\<^bold>r\<^bold>e\<^bold>e\<^bold>t)"
 shows
   "((\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n S1) \<^bold>a\<^bold>n\<^bold>d (\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n S2))"
  nitpick[satisfy] oops

(*** Do we run into Paradoxes with the modelling of modalities? ***)

consts It_holds_that_One_plus_One_Equals_Two::bool
       It_holds_that_Fermats_last_Theorem_is_True::bool

lemma Question8:
  assumes
   "It_holds_that_One_plus_One_Equals_Two"
   "It_holds_that_Fermats_last_Theorem_is_True"
   "\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>s\<^bold>a\<^bold>y\<^bold>s It_holds_that_One_plus_One_Equals_Two"
  shows
   "\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>s\<^bold>a\<^bold>y\<^bold>s It_holds_that_Fermats_last_Theorem_is_True"
  using assms(1) assms(2) assms(3) by auto

lemma Question9:
  assumes
   "It_holds_that_One_plus_One_Equals_Two"
   "It_holds_that_Fermats_last_Theorem_is_True"
   "\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>k\<^bold>n\<^bold>o\<^bold>w\<^bold>s It_holds_that_One_plus_One_Equals_Two"
  shows
   "\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>k\<^bold>n\<^bold>o\<^bold>w\<^bold>s It_holds_that_Fermats_last_Theorem_is_True"
  sledgehammer [verbose](assms)
  nitpick oops

end


header {* Compositional Reasoning *}

(*<*)
theory Compositional_Reasoning
imports BD_Security
begin
(*>*)

context BD_Security begin

subsection{* Preliminaries *}

definition "disjAll \<Delta>s s vl s1 vl1 \<equiv> (\<exists>\<Delta> \<in> \<Delta>s. \<Delta> s vl s1 vl1)"

lemma disjAll_simps[simp]:
  "disjAll {} \<equiv> \<lambda>_ _ _ _. False"
  "disjAll (insert \<Delta> \<Delta>s) \<equiv> \<lambda>s vl s1 vl1. \<Delta> s vl s1 vl1 \<or> disjAll \<Delta>s s vl s1 vl1"
  unfolding disjAll_def[abs_def] by auto

lemma iaction_mono:
assumes 1: "iaction \<Delta> s vl s1 vl1" and 2: "\<And> s vl s1 vl1. \<Delta> s vl s1 vl1 \<Longrightarrow> \<Delta>' s vl s1 vl1"
shows "iaction \<Delta>' s vl s1 vl1"
proof-
  obtain a1 ou1 s1' vl1'
  where "step s1 a1 = (ou1, s1')" and "\<phi> (Trans s1 a1 ou1 s1')"
  and "consume (Trans s1 a1 ou1 s1') vl1 vl1'" and "\<not> \<gamma> (Trans s1 a1 ou1 s1')"
  and "\<Delta> s vl s1' vl1'" using 1 unfolding iaction_def by auto
  thus ?thesis unfolding iaction_def using 2 apply -
  by (rule exI[of _ a1], rule exI[of _ ou1], rule exI[of _ s1'], rule exI[of _ vl1']) auto
qed

lemma match_mono:
assumes 1: "match \<Delta> s s1 vl1 a ou s' vl'" and 2: "\<And> s vl s1 vl1. \<Delta> s vl s1 vl1 \<Longrightarrow> \<Delta>' s vl s1 vl1"
shows "match \<Delta>' s s1 vl1 a ou s' vl'"
proof-
  obtain a1 ou1 s1' vl1'
  where "\<Delta> s' vl' s1' vl1'"
  and "step s1 a1 = (ou1, s1')"
  and "consume (Trans s1 a1 ou1 s1') vl1 vl1'"
  and "\<gamma> (Trans s a ou s') = \<gamma> (Trans s1 a1 ou1 s1')"
  and "(\<gamma> (Trans s a ou s') \<longrightarrow> g (Trans s a ou s') = g (Trans s1 a1 ou1 s1'))"
  using 1 unfolding match_def by auto
  thus ?thesis unfolding match_def using 2 apply -
  by (rule exI[of _ a1], rule exI[of _ ou1], rule exI[of _ s1'], rule exI[of _ vl1']) auto
qed

lemma ignore_mono:
assumes 1: "ignore \<Delta> s s1 vl1 a ou s' vl'" and 2: "\<And> s vl s1 vl1. \<Delta> s vl s1 vl1 \<Longrightarrow> \<Delta>' s vl s1 vl1"
shows "ignore \<Delta>' s s1 vl1 a ou s' vl'"
using assms unfolding ignore_def by auto

lemma reaction_mono:
assumes 1: "reaction \<Delta> s vl s1 vl1" and 2: "\<And> s vl s1 vl1. \<Delta> s vl s1 vl1 \<Longrightarrow> \<Delta>' s vl s1 vl1"
shows "reaction \<Delta>' s vl s1 vl1"
proof
  fix a ou s' vl'
  assume "step s a = (ou, s')" and "\<not> T (Trans s a ou s')" and "consume (Trans s a ou s') vl vl'"
  hence "match \<Delta> s s1 vl1 a ou s' vl' \<or> ignore \<Delta> s s1 vl1 a ou s' vl'" (is "?m \<or> ?i")
  using 1 unfolding reaction_def by auto
  thus "match \<Delta>' s s1 vl1 a ou s' vl' \<or> ignore \<Delta>' s s1 vl1 a ou s' vl'" (is "?m' \<or> ?i'")
  proof
    assume ?m from match_mono[OF this 2] show ?thesis by simp
  next
    assume ?i from ignore_mono[OF this 2] show ?thesis by simp
  qed
qed

subsection{* Decomposition into an arbitrary network of components *}

(* Unwind not to itself, but to a disjunction of other relations: *)
definition unwind_to where
"unwind_to \<Delta> \<Delta>s \<equiv>
 \<forall> s vl s1 vl1.
   reachNT s \<and> reach s1 \<and> \<Delta> s vl s1 vl1
   \<longrightarrow>
   vl \<noteq> [] \<and> exit s (hd vl)
   \<or>
   iaction (disjAll \<Delta>s) s vl s1 vl1
   \<or>
   (vl \<noteq> [] \<or> vl1 = []) \<and> reaction (disjAll \<Delta>s) s vl s1 vl1"

lemma unwind_toI[intro?]:
assumes
"\<And> s vl s1 vl1.
   \<lbrakk>reachNT s; reach s1; \<Delta> s vl s1 vl1\<rbrakk>
   \<Longrightarrow>
   vl \<noteq> [] \<and> exit s (hd vl)
   \<or>
   iaction (disjAll \<Delta>s) s vl s1 vl1
   \<or>
   (vl \<noteq> [] \<or> vl1 = []) \<and> reaction (disjAll \<Delta>s) s vl s1 vl1"
shows "unwind_to \<Delta> \<Delta>s"
using assms unfolding unwind_to_def by auto

(* Decomposition: *)
lemma unwind_dec:
assumes ne: "\<And> \<Delta>. \<Delta> \<in> \<Delta>s \<Longrightarrow> next \<Delta> \<subseteq> \<Delta>s \<and> unwind_to \<Delta> (next \<Delta>)"
shows "unwind (disjAll \<Delta>s)" (is "unwind ?\<Delta>")
proof
  fix s s1 :: 'state and vl vl1 :: "'value list"
  assume r: "reachNT s" "reach s1" and \<Delta>: "?\<Delta> s vl s1 vl1"
  then obtain \<Delta> where \<Delta>: "\<Delta> \<in> \<Delta>s" and 2: "\<Delta> s vl s1 vl1" unfolding disjAll_def by auto
  let ?\<Delta>s' = "next \<Delta>"  let ?\<Delta>' = "disjAll ?\<Delta>s'"
  have "(vl \<noteq> [] \<and> exit s (hd vl)) \<or>
        iaction ?\<Delta>' s vl s1 vl1 \<or>
        ((vl \<noteq> [] \<or> vl1 = []) \<and> reaction ?\<Delta>' s vl s1 vl1)"
  using 2 \<Delta> ne r unfolding unwind_to_def by auto
  moreover have "\<And> s vl s1 vl1. ?\<Delta>' s vl s1 vl1 \<Longrightarrow> ?\<Delta> s vl s1 vl1"
  using ne[OF \<Delta>] unfolding disjAll_def by auto
  ultimately show
       "(vl \<noteq> [] \<and> exit s (hd vl)) \<or>
        iaction ?\<Delta> s vl s1 vl1 \<or>
        ((vl \<noteq> [] \<or> vl1 = []) \<and> reaction ?\<Delta> s vl s1 vl1)"
  using iaction_mono[of ?\<Delta>' _ _ _ _ ?\<Delta>] reaction_mono[of ?\<Delta>' _ _ _ _ ?\<Delta>] by blast
qed

lemma init_dec:
assumes \<Delta>0: "\<Delta>0 \<in> \<Delta>s"
and i: "\<And> vl vl1. B vl vl1 \<Longrightarrow> \<Delta>0 istate vl istate vl1"
shows "\<forall> vl vl1. B vl vl1 \<longrightarrow> disjAll \<Delta>s istate vl istate vl1"
using assms unfolding disjAll_def by auto

theorem unwind_dec_secure:
assumes \<Delta>0: "\<Delta>0 \<in> \<Delta>s"
and i: "\<And> vl vl1. B vl vl1 \<Longrightarrow> \<Delta>0 istate vl istate vl1"
and ne: "\<And> \<Delta>. \<Delta> \<in> \<Delta>s \<Longrightarrow> next \<Delta> \<subseteq> \<Delta>s \<and> unwind_to \<Delta> (next \<Delta>)"
shows secure
using init_dec[OF \<Delta>0 i] unwind_dec[OF ne] unwind_secure by metis

subsection{* A customization for linear modular reasoning *}

(* The customization assumes that each component unwinds only into itself,
its successor or an exit component.  *)

definition unwind_cont where
"unwind_cont \<Delta> \<Delta>s \<equiv>
 \<forall> s vl s1 vl1.
   reachNT s \<and> reach s1 \<and> \<Delta> s vl s1 vl1
   \<longrightarrow>
   iaction (disjAll \<Delta>s) s vl s1 vl1
   \<or>
   ((vl \<noteq> [] \<or> vl1 = []) \<and> reaction (disjAll \<Delta>s) s vl s1 vl1)"

lemma unwind_contI[intro?]:
assumes
"\<And> s vl s1 vl1.
   \<lbrakk>reachNT s; reach s1; \<Delta> s vl s1 vl1\<rbrakk>
   \<Longrightarrow>
   iaction (disjAll \<Delta>s) s vl s1 vl1
   \<or>
   ((vl \<noteq> [] \<or> vl1 = []) \<and> reaction (disjAll \<Delta>s) s vl s1 vl1)"
shows "unwind_cont \<Delta> \<Delta>s"
using assms unfolding unwind_cont_def by auto

definition unwind_exit where
"unwind_exit \<Delta>e \<equiv>
 \<forall> s vl s1 vl1.
   reachNT s \<and> reach s1 \<and> \<Delta>e s vl s1 vl1
   \<longrightarrow>
   vl \<noteq> [] \<and> exit s (hd vl)"

lemma unwind_exitI[intro?]:
assumes
"\<And> s vl s1 vl1.
   \<lbrakk>reachNT s; reach s1; \<Delta>e s vl s1 vl1\<rbrakk>
   \<Longrightarrow>
   vl \<noteq> [] \<and> exit s (hd vl)"
shows "unwind_exit \<Delta>e"
using assms unfolding unwind_exit_def by auto

fun allConsec :: "'a list \<Rightarrow> ('a * 'a) set" where
  "allConsec [] = {}"
| "allConsec [a] = {}"
| "allConsec (a # b # as) = insert (a,b) (allConsec (b#as))"

lemma set_allConsec:
assumes "\<Delta> \<in> set \<Delta>s'" and "\<Delta>s = \<Delta>s' ## \<Delta>1"
shows "\<exists> \<Delta>2. (\<Delta>,\<Delta>2) \<in> allConsec \<Delta>s"
using assms proof (induction \<Delta>s' arbitrary: \<Delta>s)
  case Nil thus ?case by auto
next
  case (Cons \<Delta>3 \<Delta>s' \<Delta>s)
  show ?case proof(cases "\<Delta> = \<Delta>3")
    case True
    show ?thesis proof(cases \<Delta>s')
      case Nil
      show ?thesis unfolding `\<Delta>s = (\<Delta>3 # \<Delta>s') ## \<Delta>1` Nil True by (rule exI[of _ \<Delta>1]) simp
    next
      case (Cons \<Delta>4 \<Delta>s'')
      show ?thesis unfolding `\<Delta>s = (\<Delta>3 # \<Delta>s') ## \<Delta>1` Cons True by (rule exI[of _ \<Delta>4]) simp
    qed
  next
    case False hence "\<Delta> \<in> set \<Delta>s'" using Cons by auto
    then obtain \<Delta>2 where "(\<Delta>, \<Delta>2) \<in> allConsec (\<Delta>s' ## \<Delta>1)" using Cons by auto
    thus ?thesis unfolding `\<Delta>s = (\<Delta>3 # \<Delta>s') ## \<Delta>1` by (intro exI[of _ \<Delta>2]) (cases \<Delta>s', auto)
  qed
qed

lemma allConsec_set:
assumes "(\<Delta>1,\<Delta>2) \<in> allConsec \<Delta>s"
shows "\<Delta>1 \<in> set \<Delta>s \<and> \<Delta>2 \<in> set \<Delta>s"
using assms by (induct \<Delta>s rule: allConsec.induct) auto

(* Liniar decomposition: *)
theorem unwind_decomp_secure:
assumes n: "\<Delta>s \<noteq> []"
and i: "\<And> vl vl1. B vl vl1 \<Longrightarrow> hd \<Delta>s istate vl istate vl1"
and c: "\<And> \<Delta>1 \<Delta>2. (\<Delta>1,\<Delta>2) \<in> allConsec \<Delta>s \<Longrightarrow> unwind_cont \<Delta>1 {\<Delta>1, \<Delta>2, \<Delta>e}"
and l: "unwind_cont (last \<Delta>s) {last \<Delta>s, \<Delta>e}"
and e: "unwind_exit \<Delta>e"
shows secure
proof-
  let ?\<Delta>0 = "hd \<Delta>s"  let ?\<Delta>s = "insert \<Delta>e (set \<Delta>s)"
  def "next" \<equiv>
  "\<lambda> \<Delta>1.
     if \<Delta>1 = \<Delta>e then {}
     else if \<Delta>1 = last \<Delta>s then {\<Delta>1,\<Delta>e}
     else {\<Delta>1,SOME \<Delta>2. (\<Delta>1,\<Delta>2) \<in> allConsec \<Delta>s,\<Delta>e}"
  show ?thesis
  proof(rule unwind_dec_secure)
    show "?\<Delta>0 \<in> ?\<Delta>s" using n by auto
  next
    fix vl vl1 assume "B vl vl1"
    thus "?\<Delta>0 istate vl istate vl1" by fact
  next
    fix \<Delta>
    assume 1: "\<Delta> \<in> ?\<Delta>s" show "next \<Delta> \<subseteq> ?\<Delta>s \<and> unwind_to \<Delta> (next \<Delta>)"
    proof-
      {assume "\<Delta> = \<Delta>e"
       hence ?thesis using e unfolding next_def unwind_exit_def unwind_to_def by auto
      }
      moreover
      {assume "\<Delta> = last \<Delta>s" and "\<Delta> \<noteq> \<Delta>e"
       hence ?thesis using n l unfolding next_def unwind_cont_def unwind_to_def by simp
      }
      moreover
      {assume 1: "\<Delta> \<in> set \<Delta>s" and 2: "\<Delta> \<noteq> last \<Delta>s" "\<Delta> \<noteq> \<Delta>e"
       then obtain \<Delta>' \<Delta>s' where \<Delta>s: "\<Delta>s = \<Delta>s' ## \<Delta>'" and \<Delta>: "\<Delta> \<in> set \<Delta>s'"
       by (metis (no_types) append_Cons append_assoc in_set_conv_decomp last_snoc rev_exhaust)
       have "\<exists> \<Delta>2. (\<Delta>, \<Delta>2) \<in> allConsec \<Delta>s" using set_allConsec[OF \<Delta> \<Delta>s] .
       hence "(\<Delta>, SOME \<Delta>2. (\<Delta>, \<Delta>2) \<in> allConsec \<Delta>s) \<in> allConsec \<Delta>s" by (metis (lifting) someI_ex)
       hence ?thesis using 1 2 c unfolding next_def unwind_cont_def unwind_to_def
       by simp (metis (no_types) allConsec_set)
      }
      ultimately show ?thesis using 1 by blast
    qed
  qed
qed

subsection{* Instances *}

corollary unwind_decomp3_secure:
assumes
i: "\<And> vl vl1. B vl vl1 \<Longrightarrow> \<Delta>1 istate vl istate vl1"
and c1: "unwind_cont \<Delta>1 {\<Delta>1, \<Delta>2, \<Delta>e}"
and c2: "unwind_cont \<Delta>2 {\<Delta>2, \<Delta>3, \<Delta>e}"
and l: "unwind_cont \<Delta>3 {\<Delta>3, \<Delta>e}"
and e: "unwind_exit \<Delta>e"
shows secure
apply(rule unwind_decomp_secure[of "[\<Delta>1, \<Delta>2, \<Delta>3]" \<Delta>e])
using assms by auto

corollary unwind_decomp4_secure:
assumes
i: "\<And> vl vl1. B vl vl1 \<Longrightarrow> \<Delta>1 istate vl istate vl1"
and c1: "unwind_cont \<Delta>1 {\<Delta>1, \<Delta>2, \<Delta>e}"
and c2: "unwind_cont \<Delta>2 {\<Delta>2, \<Delta>3, \<Delta>e}"
and c3: "unwind_cont \<Delta>3 {\<Delta>3, \<Delta>4, \<Delta>e}"
and l: "unwind_cont \<Delta>4 {\<Delta>4, \<Delta>e}"
and e: "unwind_exit \<Delta>e"
shows secure
apply(rule unwind_decomp_secure[of "[\<Delta>1, \<Delta>2, \<Delta>3, \<Delta>4]" \<Delta>e])
using assms by auto

corollary unwind_decomp5_secure:
assumes
i: "\<And> vl vl1. B vl vl1 \<Longrightarrow> \<Delta>1 istate vl istate vl1"
and c1: "unwind_cont \<Delta>1 {\<Delta>1, \<Delta>2, \<Delta>e}"
and c2: "unwind_cont \<Delta>2 {\<Delta>2, \<Delta>3, \<Delta>e}"
and c3: "unwind_cont \<Delta>3 {\<Delta>3, \<Delta>4, \<Delta>e}"
and c4: "unwind_cont \<Delta>4 {\<Delta>4, \<Delta>5, \<Delta>e}"
and l: "unwind_cont \<Delta>5 {\<Delta>5, \<Delta>e}"
and e: "unwind_exit \<Delta>e"
shows secure
apply(rule unwind_decomp_secure[of "[\<Delta>1, \<Delta>2, \<Delta>3, \<Delta>4, \<Delta>5]" \<Delta>e])
using assms by auto

(*<*)

end (* context BD_Security *)

end

(*>*)


section "Auxiliary algebraic laws for abrupt designs"
theory algebraic_laws_fault_aux
imports "../../../theories/Fault/utp_fault_designs"

begin
named_theorems uflt_simpl and uflt_cond and uflt_comp and uflt_lens
subsection {*THM setup*}
declare design_condr[urel_cond]

subsection {*abrupt alphabet behavior*}

lemma assigns_flt_alpha:
  "(fault :== (\<not> &fault)) = (\<lceil>II\<rceil>\<^sub>F\<^sub>L\<^sub>T \<and>  $fault\<acute> =\<^sub>u (\<not>$fault) \<and> $ok =\<^sub>u $ok\<acute>)"
  "(ok :== (\<not> &ok)) = (\<lceil>II\<rceil>\<^sub>F\<^sub>L\<^sub>T \<and>  $fault\<acute> =\<^sub>u $fault \<and> $ok =\<^sub>u (\<not>$ok\<acute>))"
  by rel_auto+

lemma vwb_of_fault[simp]:
  "vwb_lens ok" "vwb_lens fault"
  by simp_all

lemma unrest_pre_out\<alpha>_flt[unrest]: "out\<alpha> \<sharp> \<lceil>b\<rceil>\<^sub>F\<^sub>L\<^sub>T\<^sub><"
  by (transfer, auto simp add: out\<alpha>_def lens_prod_def)

lemma unrest_post_in\<alpha>_flt[unrest]: "in\<alpha> \<sharp> \<lceil>b\<rceil>\<^sub>F\<^sub>L\<^sub>T\<^sub>>"
  by (transfer, auto simp add: in\<alpha>_def lens_prod_def)

lemma unrest_ok_fault_rel_uexpr_lift_cpf[unrest]:
  "$ok \<sharp> \<lceil>P\<rceil>\<^sub>F\<^sub>L\<^sub>T" "$ok\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>F\<^sub>L\<^sub>T"
  "$fault \<sharp> \<lceil>P\<rceil>\<^sub>F\<^sub>L\<^sub>T" "$fault\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>F\<^sub>L\<^sub>T"
  by (pred_auto)+

lemma unrest_ok_fault_rel_usubst_lift_cpf[unrest]:
  "$ok\<acute> \<sharp> \<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>F\<^sub>L\<^sub>T" "$ok \<sharp> \<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>F\<^sub>L\<^sub>T"
  "$fault\<acute> \<sharp> \<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>F\<^sub>L\<^sub>T" "$fault \<sharp> \<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>F\<^sub>L\<^sub>T"
  by rel_auto+

lemma unrest_in_out_rel_ok_fault_res_flt [unrest]:
  "$ok \<sharp> (P \<restriction>\<^sub>\<alpha> ok)" "$ok\<acute> \<sharp> (P \<restriction>\<^sub>\<alpha> ok)"
  "$fault \<sharp> (P \<restriction>\<^sub>\<alpha> fault)" "$fault\<acute> \<sharp> (P \<restriction>\<^sub>\<alpha> fault)"
  by (simp_all add: rel_var_res_def unrest)

lemma uflt_alphabet_unrest[unrest]:(*FIXEME:These laws should be generated automatically by alphabet backend since all the fields of alphabet are independant*)
  "$ok\<acute> \<sharp> $fault\<acute>" "$ok \<sharp> $fault"
  "$ok\<acute> \<sharp> $x" "$ok \<sharp> $fault\<acute>"
  "$fault\<acute> \<sharp> $ok\<acute>" "$fault \<sharp> $ok "
  "$fault \<sharp> $ok\<acute>" "$fault\<acute> \<sharp> $x"
  by pred_simp+

lemma cpf_ord [usubst]:
  "$ok \<prec>\<^sub>v $ok\<acute>" "$abrupt \<prec>\<^sub>v $abrupt\<acute>" "$ok \<prec>\<^sub>v $abrupt\<acute>"
  "$ok \<prec>\<^sub>v $abrupt" "$ok\<acute> \<prec>\<^sub>v $abrupt\<acute>" "$ok\<acute> \<prec>\<^sub>v $abrupt"
  by (simp_all add: var_name_ord_def)

lemma rel_usubst_lift_cpf_in_out_fault_ok[usubst]:
  "\<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>F\<^sub>L\<^sub>T \<dagger> $fault = $fault" "\<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>F\<^sub>L\<^sub>T \<dagger> (\<not>$fault) = (\<not>$fault)"
  "\<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>F\<^sub>L\<^sub>T \<dagger> ($ok) = ($ok)" "\<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>F\<^sub>L\<^sub>T \<dagger> (\<not>$ok) = (\<not>$ok)"
  "\<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>F\<^sub>L\<^sub>T \<dagger> ($fault\<acute>) = (($fault\<acute>))" "\<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>F\<^sub>L\<^sub>T \<dagger> (\<not>$fault\<acute>) = (\<not>$fault\<acute>)"
  "\<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>F\<^sub>L\<^sub>T \<dagger> ($ok\<acute>) = ($ok\<acute>)"  "\<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>F\<^sub>L\<^sub>T \<dagger> (\<not>$ok\<acute>) = (\<not>$ok\<acute>)"
  by (simp_all add: usubst unrest)

lemma abrupt_ok_simpl[uflt_comp]:
  "($fault ;; Simpl\<^sub>F\<^sub>L\<^sub>T P) = $fault" "(\<not>$ok ;; Simpl\<^sub>F\<^sub>L\<^sub>T P) = (\<not>$ok)"
  "($fault ;; (P \<turnstile> Q)) = $fault" "(\<not>$ok ;; (P \<turnstile> Q)) = (\<not>$ok)"
  "(\<not>$fault ;; Simpl\<^sub>F\<^sub>L\<^sub>T P) = (\<not>$fault)" "(\<not>$ok ;; Simpl\<^sub>F\<^sub>L\<^sub>T P) = (\<not>$ok)"
  "(\<not>$fault ;; (P \<turnstile> Q)) = (\<not>$fault)" "(\<not>$ok ;; (P \<turnstile> Q)) = (\<not>$ok)"
  "($fault\<acute> ;; Simpl\<^sub>F\<^sub>L\<^sub>T P) = $fault\<acute>"
  "(\<not>$fault\<acute> ;; Simpl\<^sub>F\<^sub>L\<^sub>T P) = (\<not>$fault\<acute>)"
  by rel_auto+

lemma simpl_flt_in_ok:
  "Simpl\<^sub>F\<^sub>L\<^sub>T ($ok) = ((\<not>$fault \<and> ($ok \<Rightarrow>$ok\<acute>)) \<or> (II))"
  by rel_auto

lemma  simpl_flt_our_ok:
  "Simpl\<^sub>F\<^sub>L\<^sub>T ($ok\<acute>) = ((\<not>$fault \<and> ($ok \<Rightarrow>$ok\<acute>)) \<or> (II))"
  by rel_auto

lemma simpl_flt_in_abrupt:
  "Simpl\<^sub>F\<^sub>L\<^sub>T ($fault) = ((\<not>$fault \<and> ($ok \<Rightarrow>($ok\<acute> \<and> $fault))) \<or> ($fault \<and> II))"
  by rel_auto

lemma simpl_flt_alt_def:
  "Simpl\<^sub>F\<^sub>L\<^sub>T (P) = ((\<not>$fault \<and> ($ok \<Rightarrow>($ok\<acute> \<and> P))) \<or> ($fault \<and> II))"
  by rel_auto

subsection {*Healthiness condition behavior*}

lemma rel_usubst_cpf_c3_flt[usubst]:
  assumes "$ok \<sharp> \<sigma>" "$ok\<acute> \<sharp> \<sigma> "
  shows "\<sigma> \<dagger> C3_flt(P) = (\<sigma> \<dagger> P \<triangleleft> \<sigma> \<dagger> (\<not>$fault) \<triangleright> (\<sigma> \<dagger> II))"
  using assms unfolding C3_flt_def
  by (simp add: usubst)

lemma Simpl_flt_idem[simp]: "Simpl\<^sub>F\<^sub>L\<^sub>T(Simpl\<^sub>F\<^sub>L\<^sub>T(P)) = Simpl\<^sub>F\<^sub>L\<^sub>T(P)"
  by (rel_auto)

lemma simpl_flt_Idempotent: "Idempotent Simpl\<^sub>F\<^sub>L\<^sub>T"
  by (simp add: Idempotent_def)

lemma Simpl_flt_mono: "P \<sqsubseteq> Q \<Longrightarrow> Simpl\<^sub>F\<^sub>L\<^sub>T(P) \<sqsubseteq> Simpl\<^sub>F\<^sub>L\<^sub>T(Q)"
  by (rel_auto)

lemma simpl_flt_Monotonic: "Monotonic Simpl\<^sub>F\<^sub>L\<^sub>T"
  by (simp add: Monotonic_def Simpl_flt_mono)

lemma simpl_flt_def:
  "Simpl\<^sub>F\<^sub>L\<^sub>T(P) = ((\<lceil>true\<rceil>\<^sub>F\<^sub>L\<^sub>T \<turnstile> P) \<triangleleft> \<not>$fault \<triangleright>  II)"
  unfolding C3_flt_def ..

lemma simpl_flt_condr[uflt_simpl]:
  "Simpl\<^sub>F\<^sub>L\<^sub>T(P \<triangleleft> b \<triangleright> Q) = (Simpl\<^sub>F\<^sub>L\<^sub>T(P) \<triangleleft> b \<triangleright> Simpl\<^sub>F\<^sub>L\<^sub>T(Q))"
  unfolding simpl_flt_def
  by (simp add: urel_cond)

lemma simpl_abr_skip_abr[uflt_simpl]:
  "Simpl\<^sub>F\<^sub>L\<^sub>T(SKIP\<^sub>F\<^sub>L\<^sub>T) = (SKIP\<^sub>F\<^sub>L\<^sub>T)"
  by (simp add: urel_cond urel_defs)

lemma simpl_flt_assign_flt[uflt_simpl]:
  "Simpl\<^sub>F\<^sub>L\<^sub>T(\<langle>\<sigma>\<rangle>\<^sub>F\<^sub>L\<^sub>T) = (\<langle>\<sigma>\<rangle>\<^sub>F\<^sub>L\<^sub>T)"
  by (simp add: urel_cond urel_defs)

lemma simpl_flt_form:
  "Simpl\<^sub>F\<^sub>L\<^sub>T(P) = (((\<not>$fault) \<and> (\<lceil>true\<rceil>\<^sub>F\<^sub>L\<^sub>T \<turnstile> (P)))  \<or> ($fault \<and> II))"
  by rel_auto

lemma abrupt_simpl_flt[uflt_simpl]:
  "($fault \<and> Simpl\<^sub>F\<^sub>L\<^sub>T(P)) = ($fault \<and>II)"
   by rel_auto

lemma nabrupt_simpl_flt[uflt_simpl]:
  "(\<not>$fault \<and> Simpl\<^sub>F\<^sub>L\<^sub>T(P)) = (\<not>$fault \<and> (\<lceil>true\<rceil>\<^sub>F\<^sub>L\<^sub>T \<turnstile> (P)))"
  by (rel_auto)

definition design_flt_sup :: "('\<alpha>,'\<beta>) rel_cpf set \<Rightarrow> ('\<alpha>,'\<beta>) rel_cpf" ("\<Sqinter>\<^sub>F\<^sub>L\<^sub>T_" [900] 900) where
"\<Sqinter>\<^sub>F\<^sub>L\<^sub>T A = (if (A = {}) then \<top>\<^sub>F\<^sub>L\<^sub>T else \<Sqinter> A)"

lemma simpl_flt_Continuous: "Continuous Simpl\<^sub>F\<^sub>L\<^sub>T"
  unfolding Continuous_def SUP_def apply rel_simp
  unfolding  SUP_def
  apply transfer apply auto
done

lemma simpl_flt_R3_conj:
  "Simpl\<^sub>F\<^sub>L\<^sub>T(P \<and> Q) = (Simpl\<^sub>F\<^sub>L\<^sub>T(P) \<and> Simpl\<^sub>F\<^sub>L\<^sub>T(Q))"
  by (rel_auto)

lemma simpl_flt_disj:
  "Simpl\<^sub>F\<^sub>L\<^sub>T(P \<or> Q) = (Simpl\<^sub>F\<^sub>L\<^sub>T(P) \<or> Simpl\<^sub>F\<^sub>L\<^sub>T(Q))"
  by (rel_auto)

lemma Simpl_flt_USUP:
  assumes "A \<noteq> {}"
  shows "Simpl\<^sub>F\<^sub>L\<^sub>T(\<Sqinter> i \<in> A \<bullet> P(i)) = (\<Sqinter> i \<in> A \<bullet> Simpl\<^sub>F\<^sub>L\<^sub>T(P(i)))"
  using assms by (rel_auto)

lemma design_flt_sup_non_empty [simp]:
  "A \<noteq> {} \<Longrightarrow> \<Sqinter>\<^sub>F\<^sub>L\<^sub>T A = \<Sqinter> A"
  by (simp add: design_flt_sup_def)

subsection {*Signature behavior*}

lemma design_top_flt:
  "(P \<turnstile> Q) \<sqsubseteq> \<top>\<^sub>F\<^sub>L\<^sub>T"
  by (rel_auto)

lemma design_flt_sup_empty [simp]:
  "\<Sqinter>\<^sub>F\<^sub>L\<^sub>T {} = \<top>\<^sub>F\<^sub>L\<^sub>T"
  by (simp add: design_flt_sup_def)

abbreviation design_inf :: "('\<alpha>, '\<beta>) rel_des set \<Rightarrow> ('\<alpha>, '\<beta>) rel_des" ("\<Squnion>\<^sub>F\<^sub>L\<^sub>T_" [900] 900) where
"\<Squnion>\<^sub>F\<^sub>L\<^sub>T A \<equiv> \<Squnion> A"

lemma design_bottom_flt:
  "\<bottom>\<^sub>F\<^sub>L\<^sub>T \<sqsubseteq> (P \<turnstile> Q)"
  by simp

lemma Simpl_flt_UINF:
  assumes "A \<noteq> {}"
  shows "Simpl\<^sub>F\<^sub>L\<^sub>T(\<Squnion> i \<in> A \<bullet> P(i)) = (\<Squnion> i \<in> A \<bullet> Simpl\<^sub>F\<^sub>L\<^sub>T(P(i)))"
  using assms by (rel_auto)

lemma skip_cpf_def:
  "II = (\<lceil>II\<rceil>\<^sub>F\<^sub>L\<^sub>T \<and> $fault =\<^sub>u $fault\<acute> \<and> $ok =\<^sub>u $ok\<acute>)"
  by rel_auto

lemma skip_lift_flt_def:
  "\<lceil>II\<rceil>\<^sub>F\<^sub>L\<^sub>T = ($\<Sigma>\<^sub>F\<^sub>L\<^sub>T\<acute> =\<^sub>u $\<Sigma>\<^sub>F\<^sub>L\<^sub>T)"
  by rel_auto

lemma seqr_fault_true [usubst]:
  "(P ;; Q) \<^sub>f\<^sub>t = (P \<^sub>f\<^sub>t ;; Q)"
  by (rel_auto)

lemma seqr_fault_false [usubst]:
  "(P ;; Q) \<^sub>f\<^sub>f = (P \<^sub>f\<^sub>f ;; Q)"
  by (rel_auto)

lemma rel_usubst_lift_cpf_uexpr_lift_cpf[usubst]:
  "\<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>F\<^sub>L\<^sub>T \<dagger> \<lceil>P\<rceil>\<^sub>F\<^sub>L\<^sub>T = \<lceil>\<sigma> \<dagger> P\<rceil>\<^sub>F\<^sub>L\<^sub>T"
  by rel_auto

lemma usubst_lift_cpf_assigns_lift_cpf [usubst]:
  "\<lceil>\<sigma>\<rceil>\<^sub>s\<^sub>F\<^sub>L\<^sub>T \<dagger> \<lceil>\<langle>\<rho>\<rangle>\<^sub>a\<rceil>\<^sub>F\<^sub>L\<^sub>T = \<lceil>\<langle>\<rho> \<circ> \<sigma>\<rangle>\<^sub>a\<rceil>\<^sub>F\<^sub>L\<^sub>T"
  by (simp add: usubst)

lemma usubst_lift_cpf_pre_uexpr_lift_cpf[usubst]:
  "\<lceil>\<sigma>\<rceil>\<^sub>s\<^sub>F\<^sub>L\<^sub>T \<dagger> \<lceil>b\<rceil>\<^sub>F\<^sub>L\<^sub>T\<^sub>< = \<lceil>\<sigma> \<dagger> b\<rceil>\<^sub>F\<^sub>L\<^sub>T\<^sub><"
  by (simp add: usubst)

lemma rel_usubst_lift_cpf_design[usubst]:
  "(\<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>F\<^sub>L\<^sub>T \<dagger> (Q \<turnstile> P)) = (\<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>F\<^sub>L\<^sub>T \<dagger> Q) \<turnstile> (\<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>F\<^sub>L\<^sub>T \<dagger> P)"
  by (simp add: usubst unrest)

lemma usubst_cpf_true[usubst]:
  "\<sigma> \<dagger> \<lceil>true\<rceil>\<^sub>F\<^sub>L\<^sub>T = \<lceil>true\<rceil>\<^sub>F\<^sub>L\<^sub>T"
  by rel_auto

lemma usubst_cpf_false[usubst]:
  "\<sigma> \<dagger> \<lceil>false\<rceil>\<^sub>F\<^sub>L\<^sub>T = \<lceil>false\<rceil>\<^sub>F\<^sub>L\<^sub>T"
  by rel_auto

lemma rel_usubst_cpf_skip_cpf[usubst]:
  "(\<sigma> \<dagger> II) = ((\<sigma> \<dagger> \<lceil>II\<rceil>\<^sub>F\<^sub>L\<^sub>T) \<and> \<sigma> \<dagger> $fault =\<^sub>u \<sigma> \<dagger> $fault\<acute> \<and> \<sigma> \<dagger> $ok =\<^sub>u \<sigma> \<dagger> $ok\<acute>)"
  by (simp add: usubst unrest skip_cpf_def)

lemma usubst_lift_cpf_skip_lift_cpf[usubst]:
  "(\<lceil>\<sigma>\<rceil>\<^sub>s\<^sub>F\<^sub>L\<^sub>T \<dagger> \<lceil>II\<rceil>\<^sub>F\<^sub>L\<^sub>T) = \<lceil>\<langle>\<sigma>\<rangle>\<^sub>a\<rceil>\<^sub>F\<^sub>L\<^sub>T"
  unfolding skip_r_def
  by (simp add: usubst_lift_cpf_assigns_lift_cpf)

lemma usubst_cpf_skip_cpf [usubst]:
  assumes "$ok \<sharp> \<sigma>" "$ok\<acute> \<sharp> \<sigma> "
  shows
  "(\<sigma> \<dagger> SKIP\<^sub>F\<^sub>L\<^sub>T) = (\<lceil>true\<rceil>\<^sub>F\<^sub>L\<^sub>T \<turnstile> (\<sigma> \<dagger> (\<not>$fault\<acute> \<and> \<lceil>II\<rceil>\<^sub>F\<^sub>L\<^sub>T)) \<triangleleft> \<sigma> \<dagger> (\<not>$fault) \<triangleright> (\<sigma> \<dagger> (II)))"
  using assms unfolding skip_flt_def
  by (simp add: usubst)

lemma usubst_cpf_assigns_cpf [usubst]:
  assumes "$ok \<sharp> \<sigma>" "$ok\<acute> \<sharp> \<sigma> "
  shows
  "\<sigma> \<dagger> \<langle>\<rho>\<rangle>\<^sub>F\<^sub>L\<^sub>T = (\<lceil>true\<rceil>\<^sub>F\<^sub>L\<^sub>T \<turnstile> (\<sigma> \<dagger> ((\<not>$fault\<acute>) \<and> \<lceil>\<langle>\<rho>\<rangle>\<^sub>a\<rceil>\<^sub>F\<^sub>L\<^sub>T)) \<triangleleft> \<sigma> \<dagger> (\<not>$fault) \<triangleright>  (\<sigma> \<dagger> (II)))"
  using assms unfolding assigns_flt_def
  by (simp add: usubst)

lemma c3_flt_comp_left_distr:
  "(C3_flt (P) ;; R) = ((P;;R) \<triangleleft> \<not>$fault \<triangleright> (II ;; R))"
  apply pred_simp
  apply rel_simp
  apply fastforce
done

lemma c3_flt_comp_semir:
  "(C3_flt(P) ;; C3_flt(R)) = C3_flt (P ;; C3_flt(R))"
  by rel_auto

lemma c3_flt_comp_simpl[uflt_comp]:
  "(C3_flt(P) ;; C3_flt(R)) = ((P ;; C3_flt(R)) \<triangleleft> \<not>$fault \<triangleright> (II))"
  by rel_auto

lemma simpl_flt_comp_semir:
  "(Simpl\<^sub>F\<^sub>L\<^sub>T(P) ;; Simpl\<^sub>F\<^sub>L\<^sub>T(R)) = Simpl\<^sub>F\<^sub>L\<^sub>T ((\<lceil>true\<rceil>\<^sub>F\<^sub>L\<^sub>T \<turnstile> P) ;; Simpl\<^sub>F\<^sub>L\<^sub>T(R))"
  by rel_auto

theorem design_top_flt_left_zero[uflt_comp]:
  "(\<top>\<^sub>F\<^sub>L\<^sub>T ;; (P \<turnstile> Q)) = \<top>\<^sub>F\<^sub>L\<^sub>T"
  by (rel_auto)

theorem Simpl_flt_top_flt_left_zero[uflt_comp]:
  "(\<top>\<^sub>F\<^sub>L\<^sub>T ;; Simpl\<^sub>F\<^sub>L\<^sub>T (P)) = \<top>\<^sub>F\<^sub>L\<^sub>T"
  by (rel_auto)

lemma assigns_lift_cpf_comp_rel_cpf[uflt_comp]:
  assumes "$ok \<sharp> P" "$fault \<sharp> P"
  shows  "(\<lceil>\<langle>\<sigma>\<rangle>\<^sub>a\<rceil>\<^sub>F\<^sub>L\<^sub>T ;; P) = (\<lceil>\<sigma>\<rceil>\<^sub>s\<^sub>F\<^sub>L\<^sub>T \<dagger> P)"
  apply (insert assms)
  apply pred_simp
  apply rel_blast
done

lemma lift_des_skip_dr_unit_flt [uflt_comp]:
  "(\<lceil>P\<rceil>\<^sub>F\<^sub>L\<^sub>T ;; \<lceil>II\<rceil>\<^sub>F\<^sub>L\<^sub>T) = \<lceil>P\<rceil>\<^sub>F\<^sub>L\<^sub>T"
  "(\<lceil>II\<rceil>\<^sub>F\<^sub>L\<^sub>T ;; \<lceil>P\<rceil>\<^sub>F\<^sub>L\<^sub>T) = \<lceil>P\<rceil>\<^sub>F\<^sub>L\<^sub>T"
  by (rel_auto)+

lemma skip_cpf_left_comp_simpl[uflt_comp]:
  "(SKIP\<^sub>F\<^sub>L\<^sub>T ;; Simpl\<^sub>F\<^sub>L\<^sub>T(R)) = (Simpl\<^sub>F\<^sub>L\<^sub>T(R))"
  by rel_auto

lemma skip_cpf_right_comp_simpl[uflt_comp]:
  "(Simpl\<^sub>F\<^sub>L\<^sub>T(R) ;; SKIP\<^sub>F\<^sub>L\<^sub>T) = (Simpl\<^sub>F\<^sub>L\<^sub>T(R))"
  by rel_auto

lemma assign_flt_alt_def:
  "\<langle>\<sigma>\<rangle>\<^sub>F\<^sub>L\<^sub>T = Simpl\<^sub>F\<^sub>L\<^sub>T (\<not>$fault\<acute> \<and> \<lceil>\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> II\<rceil>\<^sub>F\<^sub>L\<^sub>T)"
  by rel_auto

lemma assign_flt_left_comp_c3[uflt_comp]:
  "\<langle>a\<rangle>\<^sub>F\<^sub>L\<^sub>T ;; C3_flt (P \<turnstile> Q) = C3_flt (\<lceil>a\<rceil>\<^sub>s\<^sub>F\<^sub>L\<^sub>T \<dagger> (P \<turnstile>  Q))"
  by rel_auto

lemma assigns_flt_comp[uflt_comp]:
  "(\<langle>f\<rangle>\<^sub>F\<^sub>L\<^sub>T ;; \<langle>g\<rangle>\<^sub>F\<^sub>L\<^sub>T) = \<langle>g \<circ> f\<rangle>\<^sub>F\<^sub>L\<^sub>T"
  by rel_auto

lemma usubst_cpf_des_cond_flt [usubst]:
  "\<lbrakk>$ok \<sharp> \<sigma>; $ok\<acute> \<sharp> \<sigma> \<rbrakk> \<Longrightarrow>
    \<sigma> \<dagger> (R \<turnstile> bif b then P else Q eif) =
    (\<sigma> \<dagger> R \<turnstile>  (\<sigma> \<dagger> P \<triangleleft> \<sigma> \<dagger> \<lceil>b\<rceil>\<^sub>F\<^sub>L\<^sub>T\<^sub>< \<triangleright> \<sigma> \<dagger> Q))"
  by (simp add: usubst)

lemma comp_cond_flt_left_distr[uflt_comp]:
  "((bif b then Simpl\<^sub>F\<^sub>L\<^sub>T P else Simpl\<^sub>F\<^sub>L\<^sub>T Q eif) ;; Simpl\<^sub>F\<^sub>L\<^sub>T R) =
    (bif b then (Simpl\<^sub>F\<^sub>L\<^sub>T P ;; Simpl\<^sub>F\<^sub>L\<^sub>T R) else (Simpl\<^sub>F\<^sub>L\<^sub>T Q ;; Simpl\<^sub>F\<^sub>L\<^sub>T R) eif)"
  apply pred_simp
  apply rel_simp
done

lemma if_mono:
  "\<lbrakk> P\<^sub>1 \<sqsubseteq> P\<^sub>2; Q\<^sub>1 \<sqsubseteq> Q\<^sub>2 \<rbrakk> \<Longrightarrow> (bif b then P\<^sub>1 else Q\<^sub>1 eif) \<sqsubseteq> (bif b then P\<^sub>2 else Q\<^sub>2 eif)"
  by rel_auto

lemma design_post_seqr_rcond_left_not_ivar[urel_cond]:
  "S \<turnstile> (\<lceil>true\<rceil>\<^sub>F\<^sub>L\<^sub>T \<turnstile> (\<lceil>R\<rceil>\<^sub>F\<^sub>L\<^sub>T \<and> $x\<acute>) ;; P \<triangleleft> \<not> $x \<triangleright> Q) =
   S \<turnstile> (\<lceil>true\<rceil>\<^sub>F\<^sub>L\<^sub>T \<turnstile> (\<lceil>R\<rceil>\<^sub>F\<^sub>L\<^sub>T \<and> $x\<acute>);; Q)"
  apply pred_simp
  apply fastforce
done

lemma  design_post_seqr_rcond_left_ivar [urel_cond]:
  "S \<turnstile> (\<lceil>true\<rceil>\<^sub>F\<^sub>L\<^sub>T \<turnstile> (\<lceil>R\<rceil>\<^sub>F\<^sub>L\<^sub>T \<and>  $x\<acute>) ;; P \<triangleleft> $x \<triangleright> Q) =
   S \<turnstile> (\<lceil>true\<rceil>\<^sub>F\<^sub>L\<^sub>T \<turnstile> (\<lceil>R\<rceil>\<^sub>F\<^sub>L\<^sub>T \<and>  $x\<acute>);; P)"
  apply pred_simp
  apply fastforce
done

subsection {*While abrupt usubst*}

subsection {*block abrupt usubst*}

subsection {*Catch abrupt usubst*}

end


theory SumRandom_Update
  imports SumRandom_Abstractions

begin

context SumRandom begin

section random_with_seed
(*

definition
  abbreviatedType1 :: " Cogent.type"
where
  "abbreviatedType1 \<equiv>
      TRecord [(''seed'',  (TPrim (Num U64), Present)),
               (''value'', (TPrim (Num U64), Present))] Unboxed"

lemmas abbreviated_type_defs =
  abbreviatedType1_def

definition
  rand_with_seed_type :: " Cogent.kind list \<times>  Cogent.type \<times>  Cogent.type"
where
  "rand_with_seed_type \<equiv> ([], (TPrim (Num U64), abbreviatedType1))"

*)
thm rand_with_seed'_def
term rand_with_seed'
term val_rel
term "rand_with_seed' 1"
find_theorems val_rel

print_locale SumRandom
print_locale Random_seed_cogent_shallow

thm Random_seed_ACInstall.random_seed.rand_with_seed'_ac_corres
find_theorems "_::((lifted_globals, 'a) nondet_monad \<Rightarrow>_)"
definition rand_with_seed_u:: "(funtyp, abstyp, ptrtyp) ufundef" where
  "rand_with_seed_u x y \<equiv>
      let (\<sigma>, s) = x;
         (\<sigma>', sv) = y

      in
         \<exists> (seed::8 word) (seed'::8 word) (v::8 word) .
           s = UPrim (LU8 seed) \<and>
           sv = URecord [ (UPrim (LU8 seed'), RPrim (Num U8)),
                           (UPrim (LU8 v), RPrim (Num U8))] \<and>
           val_rel
           \<sigma>' = \<sigma>"

lemma rand_with_seed_u_preservation:
  "\<lbrakk>upd.uval_typing \<Xi>' \<sigma> v (TCon ''WordArray'' [t] (Boxed ReadOnly ptrl)) r w;
    rand_with_seed_u (\<sigma>, v) (\<sigma>', v')\<rbrakk>
    \<Longrightarrow> \<exists>r' w'. upd.uval_typing \<Xi>' \<sigma>' v' (TPrim (Num U32)) r' w' \<and> r' \<subseteq> r \<and> upd.frame \<sigma> w \<sigma>' w'"
  apply ( simp add: rand_with_seed_u_def elim: upd.uval_typing.cases)

end (* of context *)

end


theory iPropShallow
imports DerivedConstructions "../SpanningTree/SpanningTreeCameras" Namespace
  ProofSearchPredicates "../HeapLang/PrimitiveLaws" View ProphMap
begin

(*
  The functorial definition of iprop is as follows (unused arguments omitted):

  gmapF := ((loc\<rightharpoonup>((loc option\<times>loc option) ex))\<times>frac) option auth
  markingF := loc set auth
  b invF := (name\<rightharpoonup>b later ag) auth
  heapF := (loc\<rightharpoonup>(dfrac\<times>val ag)) auth
  (b,_) resF := gmapF \<times> markingF \<times> b invF \<times> heapF
  iprop := (iprop,iprop) resF upred
*)

type_synonym 'a pre_inv = "(name, 'a later) map_view \<times> name dset \<times> name dfset"

ML \<open>
  local
  type camera_data = {
    camera: typ,
    name: string,
    getter: term option,
    constructor: term option
  }

  type cameras_data = {
    number: int,
    cameras: camera_data list,
    cmraPT: typ option
  }

  (* Names *)
  val resFN = Binding.name "resF"
  val invN = Binding.name "inv"
  val resN = Binding.name "res"
  val ipropN = Binding.name "iprop"
  val getter_prefix = "get_"
  val constructor_prefix = "constr_"
  val gnameN = "name"
  val mapN = "map_res"

  (* Types *)
  val pre_ipropT = \<^typ>\<open>pre_iprop\<close>
  val gnameT = \<^typ>\<open>gname\<close>
  fun mk_opt T = Type (\<^type_name>\<open>option\<close>, [T])
  fun mk_res_mapT res = gnameT --> mk_opt res (* This might need to be (gname,res) fmap *)
  val invT = \<^typ>\<open>'a pre_inv\<close>
  val heapT = \<^typ>\<open>heap_lang_heap\<close>
  val cinvT = \<^typ>\<open>frac option\<close>
  val aT = \<^typ>\<open>'a\<close>
  val base_cameraT = HOLogic.mk_prodT (mk_res_mapT cinvT,
    HOLogic.mk_prodT (mk_res_mapT invT, mk_res_mapT heapT))

  fun mk_pred cmraT = typ_subst_atomic [(aT,cmraT)] \<^typ>\<open>'a upred_f\<close>
  fun subst_aT fp cmraT = typ_subst_atomic [(aT,fp)] cmraT
  fun add_cameraT cmraT cmrasT = HOLogic.mk_prodT (cmraT,cmrasT)
  fun fixed_cmras preT = [
    {camera = cinvT, name = "cinv", getter = NONE, constructor = NONE},
    {camera = subst_aT preT invT, name = "inv", getter = NONE, constructor = NONE},
    {camera = heapT, name = "heap", getter = NONE, constructor = NONE}
   ]
  val mk_cmraT = curry (Library.foldr (uncurry add_cameraT))
  val mk_maps = map mk_res_mapT

  (* Setup to generate getters for single cameras from the camera product *)
  val gname_param = Free (gnameN, gnameT)
  fun mk_def trm lthy = let val prop_trm = HOLogic.mk_Trueprop trm
    in Specification.definition NONE [] [] ((Binding.empty,[]), prop_trm) lthy |> snd end

  fun mk_defs (cmras_data:cameras_data) lthy =
    let fun mk_getter name cmraT =
          Free (getter_prefix ^ name, [gnameT, the (#cmraPT cmras_data)]--->mk_opt cmraT)$gname_param
        fun mk_own name cmraT =
          Free (constructor_prefix ^ name, [gnameT,cmraT]--->(the (#cmraPT cmras_data)))$gname_param$
          Free (Binding.name_of resN, cmraT)
    in
      Library.foldl (fn (lthy, cmra_data:camera_data) =>
        (mk_def (curry HOLogic.mk_eq (mk_getter (#name cmra_data) (#camera cmra_data))
          (the (#getter cmra_data)))
       #> mk_def (curry HOLogic.mk_eq (mk_own (#name cmra_data) (#camera cmra_data))
          (the (#constructor cmra_data))))
       lthy)
      (lthy, #cameras cmras_data)
    end

  val dummy_fst = Const (\<^const_name>\<open>fst\<close>, dummyT)
  val dummy_snd = Const (\<^const_name>\<open>snd\<close>, dummyT)
  val dummy_comp = Const (\<^const_name>\<open>comp\<close>, dummyT)
  val dummy_I = Const (\<^const_name>\<open>id\<close>, dummyT)
  val dummy_eps = Const (\<^const_name>\<open>\<epsilon>\<close>, dummyT)
  val dummy_cmra_object = Free (Binding.name_of resN, dummyT)
  val map_param = Bound 0
  val lookup_name = Abs (mapN, dummyT, map_param$gname_param)
  fun mk_some trm = Const (\<^const_name>\<open>Some\<close>, dummyT-->mk_opt dummyT)$trm
  fun mk_singleton_map res =
    Const (\<^const_name>\<open>fun_upd\<close>, [mk_res_mapT dummyT,gnameT,dummyT]--->mk_res_mapT dummyT)
    $Const ("Map.empty", mk_res_mapT dummyT)
    $gname_param$(mk_some res)
  fun mk_comp_lookup getter = Const (\<^const_name>\<open>comp\<close>, dummyT)$lookup_name$getter

  fun mk_getter levels is_heap =
    let val base = if is_heap then dummy_I else dummy_fst
      fun add_level 0 = base
        | add_level n = dummy_comp$(add_level (n-1))$dummy_snd
    in mk_comp_lookup (add_level levels) end

  fun mk_getters ({ number, cameras, cmraPT}: cameras_data) = let
    fun mk_getters_levels _ _ [] = []
      | mk_getters_levels levels n ((cmra: camera_data)::cameras) =
        {camera = #camera cmra, name = #name cmra,
          getter= if n=levels then SOME (mk_getter n true) else SOME (mk_getter n false),
          constructor = #constructor cmra
        }::(mk_getters_levels levels (n+1) cameras)
    in { number = number, cameras = mk_getters_levels (number-1) 0 cameras, cmraPT = cmraPT }
    end

  fun mk_own levels is_heap =
    let val base = if is_heap then mk_singleton_map dummy_cmra_object
      else curry HOLogic.mk_prod (mk_singleton_map dummy_cmra_object) dummy_eps
      fun add_level 0 = base
        | add_level n = curry HOLogic.mk_prod dummy_eps (add_level (n-1))
    in add_level levels end

    fun mk_owns ({ number, cameras, cmraPT}: cameras_data) = let
    fun mk_owns_levels _ _ [] = []
      | mk_owns_levels levels n ((cmra: camera_data)::cameras) =
        {camera = #camera cmra, name = #name cmra,
          getter = #getter cmra,
          constructor = if n=levels then SOME (mk_own n true) else SOME (mk_own n false)
        }::(mk_owns_levels levels (n+1) cameras)
    in { number = number, cameras = mk_owns_levels (number-1) 0 cameras, cmraPT = cmraPT }
    end

  (* Setup functions *)
  fun def_resF cmraT = (#2 o Typedecl.abbrev_global (resFN,["'a", "'b"],NoSyn) cmraT)
  fun def_inv preT = (#2 o Typedecl.abbrev_global (invN,[],NoSyn) (subst_aT preT invT))
  fun def_res cmraT = (#2 o Typedecl.abbrev_global (resN,[],NoSyn) cmraT)
  fun def_iprop cmraT = (#2 o Typedecl.abbrev_global (ipropN,[],NoSyn) (mk_pred cmraT))

  fun wrap_quick_and_dirtys_mode f thy =
    let val qad = Config.get_global thy quick_and_dirty in
      thy |> Config.put_global quick_and_dirty true |> f |> Config.put_global quick_and_dirty qad
    end

  in

  fun mk_iprop cmras thy =
    let
      val cmras_raw = map (fn (cmra,name)=>{camera=cmra, name=name, getter=NONE, constructor=NONE}) cmras
      val cmra_data = {number = length cmras+3, cameras = cmras_raw@fixed_cmras pre_ipropT, cmraPT = NONE}
      val cmra_data = mk_getters cmra_data
      val cmra_data = mk_owns cmra_data
      val cmraT = subst_aT pre_ipropT base_cameraT |> mk_cmraT (mk_maps (map fst cmras))
      val cmra_data = {number = #number cmra_data, cameras = #cameras cmra_data, cmraPT = SOME cmraT}
    in thy |>
      wrap_quick_and_dirtys_mode (fn thy => thy
        |> def_resF cmraT |> def_inv pre_ipropT |> def_res cmraT |> def_iprop cmraT
        |> Named_Target.theory_map (mk_defs cmra_data)
      )
    end
end;
\<close>

type_synonym lockG = "unit ex"

setup \<open>mk_iprop [(\<^typ>\<open>graphUR auth\<close>, "graph"), (\<^typ>\<open>markingUR auth\<close>, "markings"),
  (\<^typ>\<open>heap_lang_proph_map\<close>, "proph"), (\<^typ>\<open>lockG\<close>, "lock")]\<close>

text \<open>Again some experiments wrt the iprop fixed-point\<close>
definition inv_map :: "('a::cofe \<Rightarrow> 'b::cofe) \<Rightarrow> ('a pre_inv \<Rightarrow> 'b pre_inv)" where
  "inv_map (f::'a\<Rightarrow>'b) = map_prod (map_map_view (map_later f)) id"

lift_definition marking_map :: "('a::cofe -n> 'b::cofe) \<Rightarrow> (markingUR auth -n> markingUR auth)" is
  "\<lambda>_. id" by (rule discrete_ne)

lemma "contractive marking_map"
  unfolding contr_contr_alt contractive_alt_def
  apply transfer by (simp add: ofe_refl)

lift_definition later_map :: "('a::cofe -n> 'b::cofe) \<Rightarrow> ('a later -n> 'b later)" is
  "\<lambda>(f::'a\<Rightarrow>'b) (l::'a later). map_later f l"
  unfolding non_expansive_def
  by (auto simp: n_equiv_later_def later.map_sel)

lemma contr_later: "contractive later_map"
  unfolding contr_contr_alt contractive_alt_def
  apply transfer by (auto simp: later.map_sel n_equiv_later_def split: nat.split)

lemma "contr_ne f \<Longrightarrow> contr_ne (later_map f)"
apply transfer
unfolding contr_contr_alt contractive_alt_def non_expansive_def
apply (auto simp: later.map_sel n_equiv_later_def split: nat.splits)
by (metis Suc_pred)

lift_definition ag_map :: "('a::cofe -n> 'b::cofe) \<Rightarrow> ('a ag -n> 'b ag)" is
  "\<lambda>(f::'a\<Rightarrow>'b) (a::'a ag). map_ag f a"
  unfolding non_expansive_def
  apply (auto simp: n_equiv_ag_def)
  apply (smt (verit, best) image_iff map_ag.rep_eq)
  by (smt (verit, best) ag.set_map image_iff)

lemma "contr_ne f \<Longrightarrow> contr_ne (ag_map f)"
apply transfer
unfolding contr_contr_alt contractive_alt_def non_expansive_def
apply (auto simp: non_expansive_def n_equiv_ag_def image_iff map_ag.rep_eq ag.set_map split: nat.splits)
using Rep_ag apply fastforce
using Rep_ag apply fastforce
by metis+

lift_definition ag_map_contr :: "('a::cofe -n> 'b::cofe) -c> ('a later -n> 'b later)" is
  "later_map" by (rule contr_later)

locale T_iso =
fixes to_iso :: "'a::ofe \<Rightarrow> 'b::ofe" and from_iso :: "'b \<Rightarrow> 'a"
assumes isomorph1: "ofe_eq (to_iso (from_iso x)) x" and isomorph2: "ofe_eq (from_iso (to_iso y)) y"
  and to_ne: "non_expansive to_iso" and from_ne: "non_expansive from_iso"

lemma
assumes iso: "T_iso to from"
shows "n_equiv n x y \<longleftrightarrow> n_equiv n (to x) (to y)"
proof
assume "n_equiv n x y"
from non_expansiveE[OF T_iso.to_ne[OF iso], OF this] show "n_equiv n (to x) (to y)" by simp
next
assume "n_equiv n (to x) (to y)"
from non_expansiveE[OF T_iso.from_ne[OF iso], OF this] have "n_equiv n (from (to x)) (from (to y))"
  by simp
with T_iso.isomorph2[OF iso] show "n_equiv n x y"
by (meson ofe_eq_equiv ofe_trans_eqL)
qed

lemma "\<exists>(to_iso::markingUR auth\<Rightarrow>markingUR auth) from_iso. T_iso to_iso from_iso"
proof -
have "T_iso (id::markingUR auth \<Rightarrow> markingUR auth) id"
  by (auto simp: T_iso_def ofe_refl non_expansive_def ofe_limit)
then show ?thesis by auto
qed

consts isos :: "('a::ofe pre_inv \<Rightarrow> 'a) \<times>('a \<Rightarrow> 'a pre_inv)"
specification (isos)
  is_iso: "T_iso (fst isos) (snd isos)"
  sorry

text \<open>inG instance examples\<close>
interpretation idInG: inG "\<lambda>\<gamma> (m::gname \<rightharpoonup> 'a::ucamera). m \<gamma>" "\<lambda>\<gamma> x. [\<gamma>\<mapsto>x]"
apply (auto simp: inG_def prod_n_valid_def \<epsilon>_n_valid op_prod_def \<epsilon>_left_id)
apply (auto simp: pcore_prod_def pcore_fun_def \<epsilon>_fun_def \<epsilon>_option_def pcore_option_def comp_def
  split: option.splits)
using singleton_map_only_n_equiv by metis

interpretation invInG: inG get_inv constr_inv
  apply (auto simp: inG_def get_inv_def constr_inv_def dest!: singleton_map_only_n_equiv)
  apply (auto simp: d_equiv n_equiv_fun_def n_equiv_option_def prod_n_valid_def \<epsilon>_n_valid op_prod_def \<epsilon>_left_id)
  by (auto simp: pcore_prod_def pcore_fun_def \<epsilon>_fun_def \<epsilon>_option_def pcore_option_def comp_def
    constr_inv_def split: option.splits)

global_interpretation lockInG: inG get_lock constr_lock
apply (auto simp: get_lock_def constr_lock_def d_equiv inG_def prod_n_valid_def \<epsilon>_n_valid op_prod_def
  \<epsilon>_left_id intro: map_upd_eqD1)
by (auto simp: pcore_prod_def pcore_fun_def \<epsilon>_fun_def \<epsilon>_option_def pcore_option_def comp_def
  constr_lock_def singleton_map_n_incl split: option.splits)

global_interpretation prophInG: inG get_proph constr_proph
apply (auto simp: get_proph_def constr_proph_def d_equiv inG_def prod_n_valid_def \<epsilon>_n_valid op_prod_def
  \<epsilon>_left_id intro: map_upd_eqD1)
by (auto simp: pcore_prod_def pcore_fun_def \<epsilon>_fun_def \<epsilon>_option_def pcore_option_def comp_def
  constr_proph_def singleton_map_n_incl split: option.splits)

context begin
private lemma testlemma: "inG (getter::gname\<Rightarrow>'a::ucamera\<Rightarrow>lockG option) put
  \<Longrightarrow> 1=2" sorry

thm testlemma[OF lockInG.inG_axioms]
end
end


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

section{*The Yahalom Protocol, Variant 2*}

theory Yahalom2 imports Public begin

text{*
This version trades encryption of NB for additional explicitness in YM3.
Also in YM3, care is taken to make the two certificates distinct.

From page 259 of
  Burrows, Abadi and Needham (1989).  A Logic of Authentication.
  Proc. Royal Soc. 426

This theory has the prototypical example of a secrecy relation, KeyCryptNonce.
*}

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

         (*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> yahalom;  X \<in> synth (analz (knows Spy evsf)) |]
          ==> Says Spy B X  # evsf \<in> yahalom"

         (*A message that has been sent can be received by the
           intended recipient.*)
 | Reception: "[| evsr \<in> yahalom;  Says A B X \<in> set evsr |]
               ==> Gets B X # evsr \<in> yahalom"

         (*Alice initiates a protocol run*)
 | YM1:  "[| evs1 \<in> yahalom;  Nonce NA \<notin> used evs1 |]
          ==> Says A B {|Agent A, Nonce NA|} # evs1 \<in> yahalom"

         (*Bob's response to Alice's message.*)
 | YM2:  "[| evs2 \<in> yahalom;  Nonce NB \<notin> used evs2;
             Gets B {|Agent A, Nonce NA|} \<in> set evs2 |]
          ==> Says B Server
                  {|Agent B, Nonce NB, Crypt (shrK B) {|Agent A, Nonce NA|}|}
                # evs2 \<in> yahalom"

         (*The Server receives Bob's message.  He responds by sending a
           new session key to Alice, with a certificate for forwarding to Bob.
           Both agents are quoted in the 2nd certificate to prevent attacks!*)
 | YM3:  "[| evs3 \<in> yahalom;  Key KAB \<notin> used evs3;
             Gets Server {|Agent B, Nonce NB,
                           Crypt (shrK B) {|Agent A, Nonce NA|}|}
               \<in> set evs3 |]
          ==> Says Server A
               {|Nonce NB,
                 Crypt (shrK A) {|Agent B, Key KAB, Nonce NA|},
                 Crypt (shrK B) {|Agent A, Agent B, Key KAB, Nonce NB|}|}
                 # evs3 \<in> yahalom"

         (*Alice receives the Server's (?) message, checks her Nonce, and
           uses the new session key to send Bob his Nonce.*)
 | YM4:  "[| evs4 \<in> yahalom;
             Gets A {|Nonce NB, Crypt (shrK A) {|Agent B, Key K, Nonce NA|},
                      X|}  \<in> set evs4;
             Says A B {|Agent A, Nonce NA|} \<in> set evs4 |]
          ==> Says A B {|X, Crypt K (Nonce NB)|} # evs4 \<in> yahalom"

         (*This message models possible leaks of session keys.  The nonces
           identify the protocol run.  Quoting Server here ensures they are
           correct. *)
 | Oops: "[| evso \<in> yahalom;
             Says Server A {|Nonce NB,
                             Crypt (shrK A) {|Agent B, Key K, Nonce NA|},
                             X|}  \<in> set evso |]
          ==> Notes Spy {|Nonce NA, Nonce NB, Key K|} # evso \<in> yahalom"

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

text{*A "possibility property": there are traces that reach the end*}
lemma "Key K \<notin> used []
       ==> \<exists>X NB. \<exists>evs \<in> yahalom.
             Says A B {|X, Crypt K (Nonce NB)|} \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] yahalom.Nil
                    [THEN yahalom.YM1, THEN yahalom.Reception,
                     THEN yahalom.YM2, THEN yahalom.Reception,
                     THEN yahalom.YM3, THEN yahalom.Reception,
                     THEN yahalom.YM4])
apply (possibility, simp add: used_Cons)
done

lemma Gets_imp_Says:
     "[| Gets B X \<in> set evs; evs \<in> yahalom |] ==> \<exists>A. Says A B X \<in> set evs"
by (erule rev_mp, erule yahalom.induct, auto)

text{*Must be proved separately for each protocol*}
lemma Gets_imp_knows_Spy:
     "[| Gets B X \<in> set evs; evs \<in> yahalom |]  ==> X \<in> knows Spy evs"
by (blast dest!: Gets_imp_Says Says_imp_knows_Spy)

declare Gets_imp_knows_Spy [THEN analz.Inj, dest]

subsection{*Inductive Proofs*}

text{*Result for reasoning about the encrypted portion of messages.
Lets us treat YM4 using a similar argument as for the Fake case.*}
lemma YM4_analz_knows_Spy:
     "[| Gets A {|NB, Crypt (shrK A) Y, X|} \<in> set evs;  evs \<in> yahalom |]
      ==> X \<in> analz (knows Spy evs)"
by blast

lemmas YM4_parts_knows_Spy =
       YM4_analz_knows_Spy [THEN analz_into_parts]

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

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

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

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

text{*Nobody can have used non-existent keys!
    Needed to apply @{text analz_insert_Key}*}
lemma new_keys_not_used [simp]:
    "[|Key K \<notin> used evs; K \<in> symKeys; evs \<in> yahalom|]
     ==> K \<notin> keysFor (parts (spies evs))"
apply (erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt{*Fake*}
apply (force dest!: keysFor_parts_insert)
txt{*YM3*}
apply blast
txt{*YM4*}
apply auto
apply (blast dest!: Gets_imp_knows_Spy [THEN parts.Inj])
done

text{*Describes the form of K when the Server sends this message.  Useful for
  Oops as well as main secrecy property.*}
lemma Says_Server_message_form:
     "[| Says Server A {|nb', Crypt (shrK A) {|Agent B, Key K, na|}, X|}
          \<in> set evs;  evs \<in> yahalom |]
      ==> K \<notin> range shrK"
by (erule rev_mp, erule yahalom.induct, simp_all)

(****
 The following is to prove theorems of the form

          Key K \<in> analz (insert (Key KAB) (knows Spy evs)) ==>
          Key K \<in> analz (knows Spy evs)

 A more general formula must be proved inductively.
****)

(** Session keys are not used to encrypt other session keys **)

lemma analz_image_freshK [rule_format]:
 "evs \<in> yahalom ==>
   \<forall>K KK. KK <= - (range shrK) -->
          (Key K \<in> analz (Key`KK Un (knows Spy evs))) =
          (K \<in> KK | Key K \<in> analz (knows Spy evs))"
apply (erule yahalom.induct)
apply (frule_tac [8] Says_Server_message_form)
apply (drule_tac [7] YM4_analz_knows_Spy, analz_freshK, spy_analz, blast)
done

lemma analz_insert_freshK:
     "[| evs \<in> yahalom;  KAB \<notin> range shrK |] ==>
      (Key K \<in> analz (insert (Key KAB) (knows Spy evs))) =
      (K = KAB | Key K \<in> analz (knows Spy evs))"
by (simp only: analz_image_freshK analz_image_freshK_simps)

text{*The Key K uniquely identifies the Server's  message*}
lemma unique_session_keys:
     "[| Says Server A
          {|nb, Crypt (shrK A) {|Agent B, Key K, na|}, X|} \<in> set evs;
        Says Server A'
          {|nb', Crypt (shrK A') {|Agent B', Key K, na'|}, X'|} \<in> set evs;
        evs \<in> yahalom |]
     ==> A=A' & B=B' & na=na' & nb=nb'"
apply (erule rev_mp, erule rev_mp)
apply (erule yahalom.induct, simp_all)
txt{*YM3, by freshness*}
apply blast
done

subsection{*Crucial Secrecy Property: Spy Does Not See Key @{term KAB}*}

lemma secrecy_lemma:
     "[| A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> Says Server A
            {|nb, Crypt (shrK A) {|Agent B, Key K, na|},
                  Crypt (shrK B) {|Agent A, Agent B, Key K, nb|}|}
           \<in> set evs -->
          Notes Spy {|na, nb, Key K|} \<notin> set evs -->
          Key K \<notin> analz (knows Spy evs)"
apply (erule yahalom.induct, force, frule_tac [7] Says_Server_message_form,
       drule_tac [6] YM4_analz_knows_Spy)
apply (simp_all add: pushes analz_insert_eq analz_insert_freshK, spy_analz)
apply (blast dest: unique_session_keys)+  (*YM3, Oops*)
done

text{*Final version*}
lemma Spy_not_see_encrypted_key:
     "[| Says Server A
            {|nb, Crypt (shrK A) {|Agent B, Key K, na|},
                  Crypt (shrK B) {|Agent A, Agent B, Key K, nb|}|}
         \<in> set evs;
         Notes Spy {|na, nb, Key K|} \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> Key K \<notin> analz (knows Spy evs)"
by (blast dest: secrecy_lemma Says_Server_message_form)

text{*This form is an immediate consequence of the previous result.  It is
similar to the assertions established by other methods.  It is equivalent
to the previous result in that the Spy already has @{term analz} and
@{term synth} at his disposal.  However, the conclusion
@{term "Key K \<notin> knows Spy evs"} appears not to be inductive: all the cases
other than Fake are trivial, while Fake requires
@{term "Key K \<notin> analz (knows Spy evs)"}. *}
lemma Spy_not_know_encrypted_key:
     "[| Says Server A
            {|nb, Crypt (shrK A) {|Agent B, Key K, na|},
                  Crypt (shrK B) {|Agent A, Agent B, Key K, nb|}|}
         \<in> set evs;
         Notes Spy {|na, nb, Key K|} \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> Key K \<notin> knows Spy evs"
by (blast dest: Spy_not_see_encrypted_key)

subsection{*Security Guarantee for A upon receiving YM3*}

text{*If the encrypted message appears then it originated with the Server.
  May now apply @{text Spy_not_see_encrypted_key}, subject to its conditions.*}
lemma A_trusts_YM3:
     "[| Crypt (shrK A) {|Agent B, Key K, na|} \<in> parts (knows Spy evs);
         A \<notin> bad;  evs \<in> yahalom |]
      ==> \<exists>nb. Says Server A
                    {|nb, Crypt (shrK A) {|Agent B, Key K, na|},
                          Crypt (shrK B) {|Agent A, Agent B, Key K, nb|}|}
                  \<in> set evs"
apply (erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt{*Fake, YM3*}
apply blast+
done

text{*The obvious combination of @{text A_trusts_YM3} with
@{text Spy_not_see_encrypted_key}*}
theorem A_gets_good_key:
     "[| Crypt (shrK A) {|Agent B, Key K, na|} \<in> parts (knows Spy evs);
         \<forall>nb. Notes Spy {|na, nb, Key K|} \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> Key K \<notin> analz (knows Spy evs)"
by (blast dest!: A_trusts_YM3 Spy_not_see_encrypted_key)

subsection{*Security Guarantee for B upon receiving YM4*}

text{*B knows, by the first part of A's message, that the Server distributed
  the key for A and B, and has associated it with NB.*}
lemma B_trusts_YM4_shrK:
     "[| Crypt (shrK B) {|Agent A, Agent B, Key K, Nonce NB|}
           \<in> parts (knows Spy evs);
         B \<notin> bad;  evs \<in> yahalom |]
  ==> \<exists>NA. Says Server A
             {|Nonce NB,
               Crypt (shrK A) {|Agent B, Key K, Nonce NA|},
               Crypt (shrK B) {|Agent A, Agent B, Key K, Nonce NB|}|}
             \<in> set evs"
apply (erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt{*Fake, YM3*}
apply blast+
done

text{*With this protocol variant, we don't need the 2nd part of YM4 at all:
  Nonce NB is available in the first part.*}

text{*What can B deduce from receipt of YM4?  Stronger and simpler than Yahalom
  because we do not have to show that NB is secret. *}
lemma B_trusts_YM4:
     "[| Gets B {|Crypt (shrK B) {|Agent A, Agent B, Key K, Nonce NB|},  X|}
           \<in> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
  ==> \<exists>NA. Says Server A
             {|Nonce NB,
               Crypt (shrK A) {|Agent B, Key K, Nonce NA|},
               Crypt (shrK B) {|Agent A, Agent B, Key K, Nonce NB|}|}
            \<in> set evs"
by (blast dest!: B_trusts_YM4_shrK)

text{*The obvious combination of @{text B_trusts_YM4} with
@{text Spy_not_see_encrypted_key}*}
theorem B_gets_good_key:
     "[| Gets B {|Crypt (shrK B) {|Agent A, Agent B, Key K, Nonce NB|}, X|}
           \<in> set evs;
         \<forall>na. Notes Spy {|na, Nonce NB, Key K|} \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> Key K \<notin> analz (knows Spy evs)"
by (blast dest!: B_trusts_YM4 Spy_not_see_encrypted_key)

subsection{*Authenticating B to A*}

text{*The encryption in message YM2 tells us it cannot be faked.*}
lemma B_Said_YM2:
     "[| Crypt (shrK B) {|Agent A, Nonce NA|} \<in> parts (knows Spy evs);
         B \<notin> bad;  evs \<in> yahalom |]
      ==> \<exists>NB. Says B Server {|Agent B, Nonce NB,
                               Crypt (shrK B) {|Agent A, Nonce NA|}|}
                      \<in> set evs"
apply (erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt{*Fake, YM2*}
apply blast+
done

text{*If the server sends YM3 then B sent YM2, perhaps with a different NB*}
lemma YM3_auth_B_to_A_lemma:
     "[| Says Server A {|nb, Crypt (shrK A) {|Agent B, Key K, Nonce NA|}, X|}
           \<in> set evs;
         B \<notin> bad;  evs \<in> yahalom |]
      ==> \<exists>nb'. Says B Server {|Agent B, nb',
                                   Crypt (shrK B) {|Agent A, Nonce NA|}|}
                       \<in> set evs"
apply (erule rev_mp)
apply (erule yahalom.induct, simp_all)
txt{*Fake, YM2, YM3*}
apply (blast dest!: B_Said_YM2)+
done

text{*If A receives YM3 then B has used nonce NA (and therefore is alive)*}
theorem YM3_auth_B_to_A:
     "[| Gets A {|nb, Crypt (shrK A) {|Agent B, Key K, Nonce NA|}, X|}
           \<in> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
 ==> \<exists>nb'. Says B Server
                  {|Agent B, nb', Crypt (shrK B) {|Agent A, Nonce NA|}|}
               \<in> set evs"
by (blast dest!: A_trusts_YM3 YM3_auth_B_to_A_lemma)

subsection{*Authenticating A to B*}

text{*using the certificate @{term "Crypt K (Nonce NB)"}*}

text{*Assuming the session key is secure, if both certificates are present then
  A has said NB.  We can't be sure about the rest of A's message, but only
  NB matters for freshness.  Note that @{term "Key K \<notin> analz (knows Spy evs)"}
  must be the FIRST antecedent of the induction formula.*}

text{*This lemma allows a use of @{text unique_session_keys} in the next proof,
  which otherwise is extremely slow.*}
lemma secure_unique_session_keys:
     "[| Crypt (shrK A) {|Agent B, Key K, na|} \<in> analz (spies evs);
         Crypt (shrK A') {|Agent B', Key K, na'|} \<in> analz (spies evs);
         Key K \<notin> analz (knows Spy evs);  evs \<in> yahalom |]
     ==> A=A' & B=B'"
by (blast dest!: A_trusts_YM3 dest: unique_session_keys Crypt_Spy_analz_bad)

lemma Auth_A_to_B_lemma [rule_format]:
     "evs \<in> yahalom
      ==> Key K \<notin> analz (knows Spy evs) -->
          K \<in> symKeys -->
          Crypt K (Nonce NB) \<in> parts (knows Spy evs) -->
          Crypt (shrK B) {|Agent A, Agent B, Key K, Nonce NB|}
            \<in> parts (knows Spy evs) -->
          B \<notin> bad -->
          (\<exists>X. Says A B {|X, Crypt K (Nonce NB)|} \<in> set evs)"
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy)
apply (analz_mono_contra, simp_all)
txt{*Fake*}
apply blast
txt{*YM3: by @{text new_keys_not_used}, the message
   @{term "Crypt K (Nonce NB)"} could not exist*}
apply (force dest!: Crypt_imp_keysFor)
txt{*YM4: was   @{term "Crypt K (Nonce NB)"} the very last message?  If so,
    apply unicity of session keys; if not, use the induction hypothesis*}
apply (blast dest!: B_trusts_YM4_shrK dest: secure_unique_session_keys)
done

text{*If B receives YM4 then A has used nonce NB (and therefore is alive).
  Moreover, A associates K with NB (thus is talking about the same run).
  Other premises guarantee secrecy of K.*}
theorem YM4_imp_A_Said_YM3 [rule_format]:
     "[| Gets B {|Crypt (shrK B) {|Agent A, Agent B, Key K, Nonce NB|},
                  Crypt K (Nonce NB)|} \<in> set evs;
         (\<forall>NA. Notes Spy {|Nonce NA, Nonce NB, Key K|} \<notin> set evs);
         K \<in> symKeys;  A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> \<exists>X. Says A B {|X, Crypt K (Nonce NB)|} \<in> set evs"
by (blast intro: Auth_A_to_B_lemma
          dest: Spy_not_see_encrypted_key B_trusts_YM4_shrK)

end


(*
 * Copyright (C) 2014, National ICT Australia Limited. All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are
 * met:
 *
 *  * Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 *
 *  * Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 *
 *  * The name of National ICT Australia Limited nor the names of its
 *    contributors may be used to endorse or promote products derived from
 *    this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
 * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
 * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
 * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *)

header "Machine Word Setup"

theory WordSetup
imports WordEnum DistinctProp

begin

text {* This theory defines the standard platform-specific word size
and alignment. *}

definition
  word_bits :: nat where
  "word_bits \<equiv> len_of TYPE(32)"

definition
  word_size :: "'a :: numeral" where
  "word_size \<equiv> 4"

lemma word_bits_conv:
  "word_bits = 32" unfolding word_bits_def by simp

lemma word_bits_word_size_conv:
  "word_bits = word_size * 8"
  unfolding word_bits_def word_size_def by simp

definition
  is_aligned :: "'a :: len word \<Rightarrow> nat \<Rightarrow> bool" where
  "is_aligned ptr n \<equiv> 2^n dvd unat ptr"

definition
  ptr_add :: "word32 \<Rightarrow> nat \<Rightarrow> word32" where
  "ptr_add ptr n \<equiv> ptr + of_nat n"

definition
  complement :: "('a :: len) word \<Rightarrow> 'a word"  where
 "complement x \<equiv> x xor -1"

definition
  alignUp :: "'a::len word \<Rightarrow> nat \<Rightarrow> 'a word" where
 "alignUp x n \<equiv> x + 2 ^ n - 1 && complement (2 ^ n - 1)"

end