(*  Title:      HOL/Auth/Guard/Extensions.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2001  University of Cambridge
*)

section \<open>Extensions to Standard Theories\<close>

theory Extensions
imports "../Event"
begin

subsection\<open>Extensions to Theory \<open>Set\<close>\<close>

lemma eq: "[| !!x. x:A ==> x:B; !!x. x:B ==> x:A |] ==> A=B"
by auto

lemma insert_Un: "P ({x} Un A) ==> P (insert x A)"
by simp

lemma in_sub: "x:A ==> {x}<=A"
by auto

subsection\<open>Extensions to Theory \<open>List\<close>\<close>

subsubsection\<open>"remove l x" erase the first element of "l" equal to "x"\<close>

primrec remove :: "'a list => 'a => 'a list" where
"remove [] y = []" |
"remove (x#xs) y = (if x=y then xs else x # remove xs y)"

lemma set_remove: "set (remove l x) <= set l"
by (induct l, auto)

subsection\<open>Extensions to Theory \<open>Message\<close>\<close>

subsubsection\<open>declarations for tactics\<close>

declare analz_subset_parts [THEN subsetD, dest]
declare parts_insert2 [simp]
declare analz_cut [dest]
declare if_split_asm [split]
declare analz_insertI [intro]
declare Un_Diff [simp]

subsubsection\<open>extract the agent number of an Agent message\<close>

primrec agt_nb :: "msg => agent" where
"agt_nb (Agent A) = A"

subsubsection\<open>messages that are pairs\<close>

definition is_MPair :: "msg => bool" where
"is_MPair X == EX Y Z. X = \<lbrace>Y,Z\<rbrace>"

declare is_MPair_def [simp]

lemma MPair_is_MPair [iff]: "is_MPair \<lbrace>X,Y\<rbrace>"
by simp

lemma Agent_isnt_MPair [iff]: "~ is_MPair (Agent A)"
by simp

lemma Number_isnt_MPair [iff]: "~ is_MPair (Number n)"
by simp

lemma Key_isnt_MPair [iff]: "~ is_MPair (Key K)"
by simp

lemma Nonce_isnt_MPair [iff]: "~ is_MPair (Nonce n)"
by simp

lemma Hash_isnt_MPair [iff]: "~ is_MPair (Hash X)"
by simp

lemma Crypt_isnt_MPair [iff]: "~ is_MPair (Crypt K X)"
by simp

abbreviation
  not_MPair :: "msg => bool" where
  "not_MPair X == ~ is_MPair X"

lemma is_MPairE: "[| is_MPair X ==> P; not_MPair X ==> P |] ==> P"
by auto

declare is_MPair_def [simp del]

definition has_no_pair :: "msg set => bool" where
"has_no_pair H == ALL X Y. \<lbrace>X,Y\<rbrace> \<notin> H"

declare has_no_pair_def [simp]

subsubsection\<open>well-foundedness of messages\<close>

lemma wf_Crypt1 [iff]: "Crypt K X ~= X"
by (induct X, auto)

lemma wf_Crypt2 [iff]: "X ~= Crypt K X"
by (induct X, auto)

lemma parts_size: "X:parts {Y} ==> X=Y | size X < size Y"
by (erule parts.induct, auto)

lemma wf_Crypt_parts [iff]: "Crypt K X ~:parts {X}"
by (auto dest: parts_size)

subsubsection\<open>lemmas on keysFor\<close>

definition usekeys :: "msg set => key set" where
"usekeys G == {K. EX Y. Crypt K Y:G}"

lemma finite_keysFor [intro]: "finite G ==> finite (keysFor G)"
apply (simp add: keysFor_def)
apply (rule finite_imageI)
apply (induct G rule: finite_induct)
apply auto
apply (case_tac "EX K X. x = Crypt K X", clarsimp)
apply (subgoal_tac "{Ka. EX Xa. (Ka=K & Xa=X) | Crypt Ka Xa:F}
= insert K (usekeys F)", auto simp: usekeys_def)
by (subgoal_tac "{K. EX X. Crypt K X = x | Crypt K X:F} = usekeys F",
auto simp: usekeys_def)

subsubsection\<open>lemmas on parts\<close>

lemma parts_sub: "[| X:parts G; G<=H |] ==> X:parts H"
by (auto dest: parts_mono)

lemma parts_Diff [dest]: "X:parts (G - H) ==> X:parts G"
by (erule parts_sub, auto)

lemma parts_Diff_notin: "[| Y ~:H; Nonce n ~:parts (H - {Y}) |]
==> Nonce n ~:parts H"
by simp

lemmas parts_insert_substI = parts_insert [THEN ssubst]
lemmas parts_insert_substD = parts_insert [THEN sym, THEN ssubst]

lemma finite_parts_msg [iff]: "finite (parts {X})"
by (induct X, auto)

lemma finite_parts [intro]: "finite H ==> finite (parts H)"
apply (erule finite_induct, simp)
by (rule parts_insert_substI, simp)

lemma parts_parts: "[| X:parts {Y}; Y:parts G |] ==> X:parts G"
by (frule parts_cut, auto)

lemma parts_parts_parts: "[| X:parts {Y}; Y:parts {Z}; Z:parts G |] ==> X:parts G"
by (auto dest: parts_parts)

lemma parts_parts_Crypt: "[| Crypt K X:parts G; Nonce n:parts {X} |]
==> Nonce n:parts G"
by (blast intro: parts.Body dest: parts_parts)

subsubsection\<open>lemmas on synth\<close>

lemma synth_sub: "[| X:synth G; G<=H |] ==> X:synth H"
by (auto dest: synth_mono)

lemma Crypt_synth [rule_format]: "[| X:synth G; Key K ~:G |] ==>
Crypt K Y:parts {X} --> Crypt K Y:parts G"
by (erule synth.induct, auto dest: parts_sub)

subsubsection\<open>lemmas on analz\<close>

lemma analz_UnI1 [intro]: "X:analz G ==> X:analz (G Un H)"
  by (subgoal_tac "G <= G Un H") (blast dest: analz_mono)+

lemma analz_sub: "[| X:analz G; G <= H |] ==> X:analz H"
by (auto dest: analz_mono)

lemma analz_Diff [dest]: "X:analz (G - H) ==> X:analz G"
by (erule analz.induct, auto)

lemmas in_analz_subset_cong = analz_subset_cong [THEN subsetD]

lemma analz_eq: "A=A' ==> analz A = analz A'"
by auto

lemmas insert_commute_substI = insert_commute [THEN ssubst]

lemma analz_insertD:
     "[| Crypt K Y:H; Key (invKey K):H |] ==> analz (insert Y H) = analz H"
by (blast intro: analz.Decrypt analz_insert_eq)

lemma must_decrypt [rule_format,dest]: "[| X:analz H; has_no_pair H |] ==>
X ~:H --> (EX K Y. Crypt K Y:H & Key (invKey K):H)"
by (erule analz.induct, auto)

lemma analz_needs_only_finite: "X:analz H ==> EX G. G <= H & finite G"
by (erule analz.induct, auto)

lemma notin_analz_insert: "X ~:analz (insert Y G) ==> X ~:analz G"
by auto

subsubsection\<open>lemmas on parts, synth and analz\<close>

lemma parts_invKey [rule_format,dest]:"X:parts {Y} ==>
X:analz (insert (Crypt K Y) H) --> X ~:analz H --> Key (invKey K):analz H"
by (erule parts.induct, auto dest: parts.Fst parts.Snd parts.Body)

lemma in_analz: "Y:analz H ==> EX X. X:H & Y:parts {X}"
by (erule analz.induct, auto intro: parts.Fst parts.Snd parts.Body)

lemmas in_analz_subset_parts = analz_subset_parts [THEN subsetD]

lemma Crypt_synth_insert: "[| Crypt K X:parts (insert Y H);
Y:synth (analz H); Key K ~:analz H |] ==> Crypt K X:parts H"
apply (drule parts_insert_substD, clarify)
apply (frule in_sub)
apply (frule parts_mono)
apply auto
done

subsubsection\<open>greatest nonce used in a message\<close>

fun greatest_msg :: "msg => nat"
where
  "greatest_msg (Nonce n) = n"
| "greatest_msg \<lbrace>X,Y\<rbrace> = max (greatest_msg X) (greatest_msg Y)"
| "greatest_msg (Crypt K X) = greatest_msg X"
| "greatest_msg other = 0"

lemma greatest_msg_is_greatest: "Nonce n:parts {X} ==> n <= greatest_msg X"
by (induct X, auto)

subsubsection\<open>sets of keys\<close>

definition keyset :: "msg set => bool" where
"keyset G == ALL X. X:G --> (EX K. X = Key K)"

lemma keyset_in [dest]: "[| keyset G; X:G |] ==> EX K. X = Key K"
by (auto simp: keyset_def)

lemma MPair_notin_keyset [simp]: "keyset G ==> \<lbrace>X,Y\<rbrace> \<notin> G"
by auto

lemma Crypt_notin_keyset [simp]: "keyset G ==> Crypt K X ~:G"
by auto

lemma Nonce_notin_keyset [simp]: "keyset G ==> Nonce n ~:G"
by auto

lemma parts_keyset [simp]: "keyset G ==> parts G = G"
by (auto, erule parts.induct, auto)

subsubsection\<open>keys a priori necessary for decrypting the messages of G\<close>

definition keysfor :: "msg set => msg set" where
"keysfor G == Key ` keysFor (parts G)"

lemma keyset_keysfor [iff]: "keyset (keysfor G)"
by (simp add: keyset_def keysfor_def, blast)

lemma keyset_Diff_keysfor [simp]: "keyset H ==> keyset (H - keysfor G)"
by (auto simp: keyset_def)

lemma keysfor_Crypt: "Crypt K X:parts G ==> Key (invKey K):keysfor G"
by (auto simp: keysfor_def Crypt_imp_invKey_keysFor)

lemma no_key_no_Crypt: "Key K ~:keysfor G ==> Crypt (invKey K) X ~:parts G"
by (auto dest: keysfor_Crypt)

lemma finite_keysfor [intro]: "finite G ==> finite (keysfor G)"
by (auto simp: keysfor_def intro: finite_UN_I)

subsubsection\<open>only the keys necessary for G are useful in analz\<close>

lemma analz_keyset: "keyset H ==>
analz (G Un H) = H - keysfor G Un (analz (G Un (H Int keysfor G)))"
apply (rule eq)
apply (erule analz.induct, blast)
apply (simp, blast)
apply (simp, blast)
apply (case_tac "Key (invKey K):H - keysfor G", clarsimp)
apply (drule_tac X=X in no_key_no_Crypt)
by (auto intro: analz_sub)

lemmas analz_keyset_substD = analz_keyset [THEN sym, THEN ssubst]

subsection\<open>Extensions to Theory \<open>Event\<close>\<close>

subsubsection\<open>general protocol properties\<close>

definition is_Says :: "event => bool" where
"is_Says ev == (EX A B X. ev = Says A B X)"

lemma is_Says_Says [iff]: "is_Says (Says A B X)"
by (simp add: is_Says_def)

(* one could also require that Gets occurs after Says
but this is sufficient for our purpose *)
definition Gets_correct :: "event list set => bool" where
"Gets_correct p == ALL evs B X. evs:p --> Gets B X:set evs
--> (EX A. Says A B X:set evs)"

lemma Gets_correct_Says: "[| Gets_correct p; Gets B X # evs:p |]
==> EX A. Says A B X:set evs"
apply (simp add: Gets_correct_def)
by (drule_tac x="Gets B X # evs" in spec, auto)

definition one_step :: "event list set => bool" where
"one_step p == ALL evs ev. ev#evs:p --> evs:p"

lemma one_step_Cons [dest]: "[| one_step p; ev#evs:p |] ==> evs:p"
by (unfold one_step_def, blast)

lemma one_step_app: "[| evs@evs':p; one_step p; []:p |] ==> evs':p"
by (induct evs, auto)

lemma trunc: "[| evs @ evs':p; one_step p |] ==> evs':p"
by (induct evs, auto)

definition has_only_Says :: "event list set => bool" where
"has_only_Says p == ALL evs ev. evs:p --> ev:set evs
--> (EX A B X. ev = Says A B X)"

lemma has_only_SaysD: "[| ev:set evs; evs:p; has_only_Says p |]
==> EX A B X. ev = Says A B X"
by (unfold has_only_Says_def, blast)

lemma in_has_only_Says [dest]: "[| has_only_Says p; evs:p; ev:set evs |]
==> EX A B X. ev = Says A B X"
by (auto simp: has_only_Says_def)

lemma has_only_Says_imp_Gets_correct [simp]: "has_only_Says p
==> Gets_correct p"
by (auto simp: has_only_Says_def Gets_correct_def)

subsubsection\<open>lemma on knows\<close>

lemma Says_imp_spies2: "Says A B \<lbrace>X,Y\<rbrace> \<in> set evs ==> Y \<in> parts (spies evs)"
by (drule Says_imp_spies, drule parts.Inj, drule parts.Snd, simp)

lemma Says_not_parts: "[| Says A B X:set evs; Y ~:parts (spies evs) |]
==> Y ~:parts {X}"
by (auto dest: Says_imp_spies parts_parts)

subsubsection\<open>knows without initState\<close>

primrec knows' :: "agent => event list => msg set" where
  knows'_Nil: "knows' A [] = {}" |
  knows'_Cons0:
 "knows' A (ev # evs) = (
   if A = Spy then (
     case ev of
       Says A' B X => insert X (knows' A evs)
     | Gets A' X => knows' A evs
     | Notes A' X => if A':bad then insert X (knows' A evs) else knows' A evs
   ) else (
     case ev of
       Says A' B X => if A=A' then insert X (knows' A evs) else knows' A evs
     | Gets A' X => if A=A' then insert X (knows' A evs) else knows' A evs
     | Notes A' X => if A=A' then insert X (knows' A evs) else knows' A evs
   ))"

abbreviation
  spies' :: "event list => msg set" where
  "spies' == knows' Spy"

subsubsection\<open>decomposition of knows into knows' and initState\<close>

lemma knows_decomp: "knows A evs = knows' A evs Un (initState A)"
by (induct evs, auto split: event.split simp: knows.simps)

lemmas knows_decomp_substI = knows_decomp [THEN ssubst]
lemmas knows_decomp_substD = knows_decomp [THEN sym, THEN ssubst]

lemma knows'_sub_knows: "knows' A evs <= knows A evs"
by (auto simp: knows_decomp)

lemma knows'_Cons: "knows' A (ev#evs) = knows' A [ev] Un knows' A evs"
by (induct ev, auto)

lemmas knows'_Cons_substI = knows'_Cons [THEN ssubst]
lemmas knows'_Cons_substD = knows'_Cons [THEN sym, THEN ssubst]

lemma knows_Cons: "knows A (ev#evs) = initState A Un knows' A [ev]
Un knows A evs"
apply (simp only: knows_decomp)
apply (rule_tac s="(knows' A [ev] Un knows' A evs) Un initState A" in trans)
apply (simp only: knows'_Cons [of A ev evs] Un_ac)
apply blast
done

lemmas knows_Cons_substI = knows_Cons [THEN ssubst]
lemmas knows_Cons_substD = knows_Cons [THEN sym, THEN ssubst]

lemma knows'_sub_spies': "[| evs:p; has_only_Says p; one_step p |]
==> knows' A evs <= spies' evs"
by (induct evs, auto split: event.splits)

subsubsection\<open>knows' is finite\<close>

lemma finite_knows' [iff]: "finite (knows' A evs)"
by (induct evs, auto split: event.split simp: knows.simps)

subsubsection\<open>monotonicity of knows\<close>

lemma knows_sub_Cons: "knows A evs <= knows A (ev#evs)"
by(cases A, induct evs, auto simp: knows.simps split:event.split)

lemma knows_ConsI: "X:knows A evs ==> X:knows A (ev#evs)"
by (auto dest: knows_sub_Cons [THEN subsetD])

lemma knows_sub_app: "knows A evs <= knows A (evs @ evs')"
apply (induct evs, auto)
apply (simp add: knows_decomp)
apply (rename_tac a b c)
by (case_tac a, auto simp: knows.simps)

subsubsection\<open>maximum knowledge an agent can have
includes messages sent to the agent\<close>

primrec knows_max' :: "agent => event list => msg set" where
knows_max'_def_Nil: "knows_max' A [] = {}" |
knows_max'_def_Cons: "knows_max' A (ev # evs) = (
  if A=Spy then (
    case ev of
      Says A' B X => insert X (knows_max' A evs)
    | Gets A' X => knows_max' A evs
    | Notes A' X =>
      if A':bad then insert X (knows_max' A evs) else knows_max' A evs
  ) else (
    case ev of
      Says A' B X =>
      if A=A' | A=B then insert X (knows_max' A evs) else knows_max' A evs
    | Gets A' X =>
      if A=A' then insert X (knows_max' A evs) else knows_max' A evs
    | Notes A' X =>
      if A=A' then insert X (knows_max' A evs) else knows_max' A evs
  ))"

definition knows_max :: "agent => event list => msg set" where
"knows_max A evs == knows_max' A evs Un initState A"

abbreviation
  spies_max :: "event list => msg set" where
  "spies_max evs == knows_max Spy evs"

subsubsection\<open>basic facts about @{term knows_max}\<close>

lemma spies_max_spies [iff]: "spies_max evs = spies evs"
by (induct evs, auto simp: knows_max_def split: event.splits)

lemma knows_max'_Cons: "knows_max' A (ev#evs)
= knows_max' A [ev] Un knows_max' A evs"
by (auto split: event.splits)

lemmas knows_max'_Cons_substI = knows_max'_Cons [THEN ssubst]
lemmas knows_max'_Cons_substD = knows_max'_Cons [THEN sym, THEN ssubst]

lemma knows_max_Cons: "knows_max A (ev#evs)
= knows_max' A [ev] Un knows_max A evs"
apply (simp add: knows_max_def del: knows_max'_def_Cons)
apply (rule_tac evs=evs in knows_max'_Cons_substI)
by blast

lemmas knows_max_Cons_substI = knows_max_Cons [THEN ssubst]
lemmas knows_max_Cons_substD = knows_max_Cons [THEN sym, THEN ssubst]

lemma finite_knows_max' [iff]: "finite (knows_max' A evs)"
by (induct evs, auto split: event.split)

lemma knows_max'_sub_spies': "[| evs:p; has_only_Says p; one_step p |]
==> knows_max' A evs <= spies' evs"
by (induct evs, auto split: event.splits)

lemma knows_max'_in_spies' [dest]: "[| evs:p; X:knows_max' A evs;
has_only_Says p; one_step p |] ==> X:spies' evs"
by (rule knows_max'_sub_spies' [THEN subsetD], auto)

lemma knows_max'_app: "knows_max' A (evs @ evs')
= knows_max' A evs Un knows_max' A evs'"
by (induct evs, auto split: event.splits)

lemma Says_to_knows_max': "Says A B X:set evs ==> X:knows_max' B evs"
by (simp add: in_set_conv_decomp, clarify, simp add: knows_max'_app)

lemma Says_from_knows_max': "Says A B X:set evs ==> X:knows_max' A evs"
by (simp add: in_set_conv_decomp, clarify, simp add: knows_max'_app)

subsubsection\<open>used without initState\<close>

primrec used' :: "event list => msg set" where
"used' [] = {}" |
"used' (ev # evs) = (
  case ev of
    Says A B X => parts {X} Un used' evs
    | Gets A X => used' evs
    | Notes A X => parts {X} Un used' evs
  )"

definition init :: "msg set" where
"init == used []"

lemma used_decomp: "used evs = init Un used' evs"
by (induct evs, auto simp: init_def split: event.split)

lemma used'_sub_app: "used' evs <= used' (evs@evs')"
by (induct evs, auto split: event.split)

lemma used'_parts [rule_format]: "X:used' evs ==> Y:parts {X} --> Y:used' evs"
apply (induct evs, simp)
apply (rename_tac a b)
apply (case_tac a, simp_all)
apply (blast dest: parts_trans)+
done

subsubsection\<open>monotonicity of used\<close>

lemma used_sub_Cons: "used evs <= used (ev#evs)"
by (induct evs, (induct ev, auto)+)

lemma used_ConsI: "X:used evs ==> X:used (ev#evs)"
by (auto dest: used_sub_Cons [THEN subsetD])

lemma notin_used_ConsD: "X ~:used (ev#evs) ==> X ~:used evs"
by (auto dest: used_sub_Cons [THEN subsetD])

lemma used_appD [dest]: "X:used (evs @ evs') ==> X:used evs | X:used evs'"
by (induct evs, auto, rename_tac a b, case_tac a, auto)

lemma used_ConsD: "X:used (ev#evs) ==> X:used [ev] | X:used evs"
by (case_tac ev, auto)

lemma used_sub_app: "used evs <= used (evs@evs')"
by (auto simp: used_decomp dest: used'_sub_app [THEN subsetD])

lemma used_appIL: "X:used evs ==> X:used (evs' @ evs)"
by (induct evs', auto intro: used_ConsI)

lemma used_appIR: "X:used evs ==> X:used (evs @ evs')"
by (erule used_sub_app [THEN subsetD])

lemma used_parts: "[| X:parts {Y}; Y:used evs |] ==> X:used evs"
apply (auto simp: used_decomp dest: used'_parts)
by (auto simp: init_def used_Nil dest: parts_trans)

lemma parts_Says_used: "[| Says A B X:set evs; Y:parts {X} |] ==> Y:used evs"
by (induct evs, simp_all, safe, auto intro: used_ConsI)

lemma parts_used_app: "X:parts {Y} ==> X:used (evs @ Says A B Y # evs')"
apply (drule_tac evs="[Says A B Y]" in used_parts, simp, blast)
apply (drule_tac evs'=evs' in used_appIR)
apply (drule_tac evs'=evs in used_appIL)
by simp

subsubsection\<open>lemmas on used and knows\<close>

lemma initState_used: "X:parts (initState A) ==> X:used evs"
by (induct evs, auto simp: used.simps split: event.split)

lemma Says_imp_used: "Says A B X:set evs ==> parts {X} <= used evs"
by (induct evs, auto intro: used_ConsI)

lemma not_used_not_spied: "X ~:used evs ==> X ~:parts (spies evs)"
by (induct evs, auto simp: used_Nil)

lemma not_used_not_parts: "[| Y ~:used evs; Says A B X:set evs |]
==> Y ~:parts {X}"
by (induct evs, auto intro: used_ConsI)

lemma not_used_parts_false: "[| X ~:used evs; Y:parts (spies evs) |]
==> X ~:parts {Y}"
by (auto dest: parts_parts)

lemma known_used [rule_format]: "[| evs:p; Gets_correct p; one_step p |]
==> X:parts (knows A evs) --> X:used evs"
apply (case_tac "A=Spy", blast)
apply (induct evs)
apply (simp add: used.simps, blast)
apply (rename_tac a evs)
apply (frule_tac ev=a and evs=evs in one_step_Cons, simp, clarify)
apply (drule_tac P="%G. X:parts G" in knows_Cons_substD, safe)
apply (erule initState_used)
apply (case_tac a, auto)
apply (rename_tac msg)
apply (drule_tac B=A and X=msg and evs=evs in Gets_correct_Says)
by (auto dest: Says_imp_used intro: used_ConsI)

lemma known_max_used [rule_format]: "[| evs:p; Gets_correct p; one_step p |]
==> X:parts (knows_max A evs) --> X:used evs"
apply (case_tac "A=Spy")
apply force
apply (induct evs)
apply (simp add: knows_max_def used.simps, blast)
apply (rename_tac a evs)
apply (frule_tac ev=a and evs=evs in one_step_Cons, simp, clarify)
apply (drule_tac P="%G. X:parts G" in knows_max_Cons_substD, safe)
apply (case_tac a, auto)
apply (rename_tac msg)
apply (drule_tac B=A and X=msg and evs=evs in Gets_correct_Says)
by (auto simp: knows_max'_Cons dest: Says_imp_used intro: used_ConsI)

lemma not_used_not_known: "[| evs:p; X ~:used evs;
Gets_correct p; one_step p |] ==> X ~:parts (knows A evs)"
by (case_tac "A=Spy", auto dest: not_used_not_spied known_used)

lemma not_used_not_known_max: "[| evs:p; X ~:used evs;
Gets_correct p; one_step p |] ==> X ~:parts (knows_max A evs)"
by (case_tac "A=Spy", auto dest: not_used_not_spied known_max_used)

subsubsection\<open>a nonce or key in a message cannot equal a fresh nonce or key\<close>

lemma Nonce_neq [dest]: "[| Nonce n' ~:used evs;
Says A B X:set evs; Nonce n:parts {X} |] ==> n ~= n'"
by (drule not_used_not_spied, auto dest: Says_imp_knows_Spy parts_sub)

lemma Key_neq [dest]: "[| Key n' ~:used evs;
Says A B X:set evs; Key n:parts {X} |] ==> n ~= n'"
by (drule not_used_not_spied, auto dest: Says_imp_knows_Spy parts_sub)

subsubsection\<open>message of an event\<close>

primrec msg :: "event => msg"
where
  "msg (Says A B X) = X"
| "msg (Gets A X) = X"
| "msg (Notes A X) = X"

lemma used_sub_parts_used: "X:used (ev # evs) ==> X:parts {msg ev} Un used evs"
by (induct ev, auto)

end


section \<open> Normal Reactive Designs \<close>

theory utp_rdes_normal
  imports
    utp_rdes_triples
    (* "UTP1-KAT.utp_kleene" *)
begin

text \<open> These additional healthiness conditions are analogous to H3 \<close>

definition RD3 where
[pred]: "RD3(P) = P ;; II\<^sub>R"

expr_constructor RD3

definition RD3c where
[pred]: "RD3c(P) = P ;; II\<^sub>C"

expr_constructor RD3c

(*
lemma RD3_idem: "RD3(RD3(P)) = RD3(P)"
proof -
  have a: "II\<^sub>R ;; II\<^sub>R = II\<^sub>R"
    by (simp add: SRD_left_unit SRD_srdes_skip)
  show ?thesis
    by (simp add: RD3_def seqr_assoc a)
qed

lemma RD3_Idempotent [closure]: "Idempotent RD3"
  by (simp add: Idempotent_def RD3_idem)
*)

lemma RD3_continuous: "RD3(\<Sqinter>A) = (\<Sqinter>P\<in>A. RD3(P))"
  by (simp add: RD3_def seq_Sup_distr)

lemma RD3_Continuous [closure]: "Continuous RD3"
  by (simp add: Continuous_def RD3_continuous)

lemma RD3_right_subsumes_RD2: "RD2(RD3(P)) = RD3(P)"
proof -
  have a:"II\<^sub>R ;; J = II\<^sub>R"
    by (pred_auto; blast)
  show ?thesis
    by (metis (no_types, opaque_lifting) H2_def RD2_def RD3_def a seqr_assoc)
qed

lemma RD3c_idem: "RD3c(RD3c(P)) = RD3c(P)"
proof -
  have a: "II\<^sub>C ;; II\<^sub>C = II\<^sub>C"
    by pred_auto
  show ?thesis
    by (simp add: RD3c_def seqr_assoc a)
qed

lemma RD3c_Idempotent [closure]: "Idempotent RD3c"
  by (simp add: Idempotent_def RD3c_idem)

lemma RD3c_continuous: "RD3c(\<Sqinter>A) = (\<Sqinter>P\<in>A. RD3c(P))"
  by (simp add: RD3c_def seq_Sup_distr)

lemma RD3c_Continuous [closure]: "Continuous RD3c"
  by (simp add: Continuous_def RD3c_continuous)

lemma RD3c_right_subsumes_RD2: "RD2 (RD3c P) = RD3c P"
proof -
  have a:"II\<^sub>C ;; J = II\<^sub>C"
    by pred_auto
  thus ?thesis
    by (simp add: a H2_def RD2_def RD3c_def seqr_assoc)
qed

lemma RD3_left_subsumes_RD2: "RD3(RD2(P)) = RD3(P)"
proof -
  have a:"J ;; II\<^sub>R = II\<^sub>R"
    by (pred_auto; blast)
  show ?thesis
    by (metis (no_types, opaque_lifting) H2_def RD2_def RD3_def a seqr_assoc)
qed

lemma RD3c_left_subsumes_RD2: "RD3c(RD2(P)) = RD3c(P)"
proof -
  have a:"J ;; II\<^sub>C = II\<^sub>C"
    by pred_auto
  show ?thesis
    by (simp add: H2_def RD2_def RD3c_def a seqr_assoc)
qed

lemma RD3_implies_RD2: "P is RD3 \<Longrightarrow> P is RD2"
  by (metis Healthy_def RD3_right_subsumes_RD2)

(*
lemma RD3_intro_pre:
  assumes "P is SRD" "(\<not>\<^sub>r pre\<^sub>R(P)) ;; true\<^sub>r = (\<not>\<^sub>r pre\<^sub>R(P))" "$st\<^sup>> \<sharp> peri\<^sub>R(P)"
  shows "P is RD3"
proof -
  have "RD3(P) = \<^bold>R\<^sub>s ((\<not>\<^sub>r pre\<^sub>R P) wp\<^sub>r false \<turnstile> (\<exists> $st\<acute> \<bullet> peri\<^sub>R P) \<diamondop> post\<^sub>R P)"
    by (simp add: RD3_def SRD_right_unit_tri_lemma assms)
  also have "... = \<^bold>R\<^sub>s ((\<not>\<^sub>r pre\<^sub>R P) wp\<^sub>r false \<turnstile> peri\<^sub>R P \<diamondop> post\<^sub>R P)"
    by (simp add: assms(3) ex_unrest)
  also have "... = \<^bold>R\<^sub>s ((\<not>\<^sub>r pre\<^sub>R P) wp\<^sub>r false \<turnstile> cmt\<^sub>R P)"
    by (simp add: wait'_cond_peri_post_cmt)
  also have "... = \<^bold>R\<^sub>s (pre\<^sub>R P \<turnstile> cmt\<^sub>R P)"
    by (simp add: assms(2) rpred wp_rea_def R1_preR)
  finally show ?thesis
    by (metis Healthy_def SRD_as_reactive_design assms(1))
qed

lemma RHS_tri_design_RD3_intro:
  assumes
    "$ok\<acute> \<sharp> P" "$ok\<acute> \<sharp> Q" "$ok\<acute> \<sharp> R" "$st\<acute> \<sharp> Q"  "$wait\<acute> \<sharp> R"
    "P is R1" "(\<not>\<^sub>r P) ;; true\<^sub>r = (\<not>\<^sub>r P)"
  shows "\<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R) is RD3"
  apply (simp add: Healthy_def RD3_def)
  apply (subst RHS_tri_design_right_unit_lemma)
  apply (simp_all add:assms ex_unrest rpred)
done

text \<open> RD3 reactive designs are those whose assumption can be written as a conjunction of a
  precondition on (undashed) program variables, and a negated statement about the trace. The latter
  allows us to state that certain events must not occur in the trace -- which are effectively safety
  properties. \<close>

lemma R1_right_unit_lemma:
  "\<lbrakk> out\<alpha> \<sharp> b; out\<alpha> \<sharp> e \<rbrakk> \<Longrightarrow> (\<not>\<^sub>r b \<or> $tr ^\<^sub>u e \<le>\<^sub>u $tr\<acute>) ;; R1(true) = (\<not>\<^sub>r b\<or> $tr ^\<^sub>u e \<le>\<^sub>u $tr\<acute>)"
  by (rel_auto, blast, metis (no_types, lifting) dual_order.trans)

lemma RHS_tri_design_RD3_intro_form:
  assumes
    "out\<alpha> \<sharp> b" "out\<alpha> \<sharp> e" "$ok\<acute> \<sharp> Q" "$st\<acute> \<sharp> Q" "$ok\<acute> \<sharp> R" "$wait\<acute> \<sharp> R"
  shows "\<^bold>R\<^sub>s((b \<and> \<not>\<^sub>r $tr ^\<^sub>u e \<le>\<^sub>u $tr\<acute>) \<turnstile> Q \<diamondop> R) is RD3"
  apply (rule RHS_tri_design_RD3_intro)
        apply (simp_all add: assms unrest closure rpred)
  apply (subst R1_right_unit_lemma)
    apply (simp_all add: assms unrest)
  done
*)

lemma RD1_RD3_commute: "RD1(RD3(P)) = RD3(RD1(P))"
  by (pred_auto, blast+)

lemma RD1_RD3c_commute: "RD1(RD3c(P)) = RD3c(RD1(P))"
  by pred_auto

definition NSRD :: "('s,'t::trace,'\<alpha>) hrel_rsp \<Rightarrow> ('s,'t,'\<alpha>) hrel_rsp"
where [pred]: "NSRD = RD1 \<circ> RD3 \<circ> RHS"

definition NRD :: "('t::trace,'\<alpha>) hrel_rp \<Rightarrow> ('t,'\<alpha>) hrel_rp"
where [pred]: "NRD = RD1 \<circ> RD3c \<circ> RH"

expr_constructor NSRD NRD

lemma NRD_is_RD [closure]: "P is NRD \<Longrightarrow> P is RD"
  by (simp add: Healthy_def NRD_def RD_def)
     (metis (no_types, lifting) R1_R3c_commute R1_seqr R1_skip_rea R2c_R1_seq R2c_R3c_commute R2c_skip_rea R3_skipr R3c_semir_form R3c_via_RD1_R3 RD1_R1_commute RD1_R2c_commute RD1_R3c_commute RD1_RD2_commute RD1_idem RD3c_def RD3c_right_subsumes_RD2 RH_def RP_def RP_idem skip_rea_RD1_skip)

(*
lemma NRD_elim [RD_elim]:
  "\<lbrakk> P is NRD; Q(\<^bold>R(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> post\<^sub>R(P))) \<rbrakk> \<Longrightarrow> Q(P)"
  by (simp add: RD_elim closure)

lemma NRD_idem: "NRD(NRD(P)) = NRD(P)"
  by (metis (no_types, opaque_lifting) Healthy_Idempotent Healthy_def Idempotent_def NRD_def R1_R3c_commute R1_skip_rea R2_R2c_def R2_idem R2_seqr_closure R2c_R3c_commute R2c_skip_rea R3c_Idempotent R3c_def R3c_seq_closure R3c_via_RD1_R3 RD1_RD3c_commute RD1_RH_commute RD1_idem RD3c_def RD3c_idem RD_healths(3) RH_def comp_assoc comp_eq_dest_lhs rdes_left_unital.Healthy_Unit rea_lift_R1 rea_lift_def)

lemma NRD_Idempotent [closure]: "Idempotent NRD"
  by (simp add: Idempotent_def NRD_idem)

lemma NRD_Continuous [closure]: "Continuous NRD"
  by (simp add: Continuous_comp NRD_def RD1_Continuous RD3c_Continuous RH_Continuous)

lemma NRD_form:
  "NRD(P) = \<^bold>R((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> (peri\<^sub>R(P) \<diamondop> post\<^sub>R(P)))"
proof -
  have "NRD(P) = RD3c(RD(P))"
    by (metis NRD_def RD1_RD3c_commute RD3c_left_subsumes_RD2 RD_alt_def comp_eq_dest_lhs)
  also have "... = RD3c(\<^bold>R(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> post\<^sub>R(P)))"
    by (simp add: RD_as_reactive_tri_design)
  also have "... = \<^bold>R(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> post\<^sub>R(P)) ;; II\<^sub>C"
    by (simp add: RD3c_def)
  also have "... = \<^bold>R((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> (peri\<^sub>R(P) \<diamondop> post\<^sub>R(P)))"
    by (simp add: RH_tri_design_right_unit_lemma unrest)
  finally show ?thesis .
qed

lemma NRD_healthy_form:
  assumes "P is NRD"
  shows "\<^bold>R((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> (peri\<^sub>R(P) \<diamondop> post\<^sub>R(P))) = P"
  by (metis Healthy_def NRD_form assms)

lemma NRD_neg_pre_unit:
  assumes "P is NRD"
  shows "(\<not>\<^sub>r pre\<^sub>R(P)) ;; true\<^sub>r = (\<not>\<^sub>r pre\<^sub>R(P))"
proof -
  have "(\<not>\<^sub>r pre\<^sub>R(P)) = (\<not>\<^sub>r pre\<^sub>R(\<^bold>R((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> (peri\<^sub>R(P) \<diamondop> post\<^sub>R(P)))))"
    by (simp add: NRD_healthy_form assms)
  also have "... = R1 (R2c ((\<not>\<^sub>r pre\<^sub>R P) ;; R1 true))"
    by (simp add: rea_pre_RH_design R1_negate_R1 R1_idem R1_rea_not' R2c_rea_not usubst rpred unrest closure)
  also have "... = (\<not>\<^sub>r pre\<^sub>R P) ;; R1 true"
    by (simp add: R1_R2c_seqr_distribute closure assms)
  finally show ?thesis
    by (simp add: rea_not_def)
qed

lemma NRD_wait'_unrest_pre [unrest]:
  assumes "P is NRD"
  shows "$wait\<acute> \<sharp> pre\<^sub>R(P)"
proof -
  have "pre\<^sub>R(P) = pre\<^sub>R(\<^bold>R((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> (peri\<^sub>R(P) \<diamondop> post\<^sub>R(P))))"
    by (simp add: NRD_healthy_form assms)
  also have "... = (R1 (R2c (\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R P) ;; R1 true)))"
    by (simp add: rea_pre_RH_design usubst unrest)
  also have "$wait\<acute> \<sharp> ..."
    by (simp add: R1_def R2c_def unrest)
  finally show ?thesis .
qed

lemma preR_NRD_RR [closure]: "P is NRD \<Longrightarrow> pre\<^sub>R(P) is RR"
  by (rule RR_intro, simp_all add: closure unrest)

lemma NRD_neg_pre_RC [closure]:
  assumes "P is NRD"
  shows "pre\<^sub>R(P) is RC"
  by (rule RC_intro, simp_all add: closure assms NRD_neg_pre_unit rpred)

lemma NRD_intro:
  assumes "P is RD" "(\<not>\<^sub>r pre\<^sub>R(P)) ;; true\<^sub>r = (\<not>\<^sub>r pre\<^sub>R(P))"
  shows "P is NRD"
proof -
  have "NRD(P) = \<^bold>R((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> (peri\<^sub>R(P) \<diamondop> post\<^sub>R(P)))"
    by (simp add: NRD_form)
  also have "... = \<^bold>R(pre\<^sub>R P \<turnstile> peri\<^sub>R P \<diamondop> post\<^sub>R P)"
    by (simp add: assms rpred closure)
  also have "... = P"
    by (simp add: RD_reactive_tri_design assms(1))
  finally show ?thesis
    using Healthy_def by blast
qed

lemma NRD_intro':
  assumes "P is R2" "P is R3c" "P is RD1" "P is RD3c"
  shows "P is NRD"
  by (metis (no_types, opaque_lifting) Healthy_def NRD_def R1_R2c_is_R2 RH_def assms comp_apply)

lemma NRD_RC_intro:
  assumes "P is RD" "pre\<^sub>R(P) is RC"
  shows "P is NRD"
  by (metis Healthy_def NRD_form RD_reactive_tri_design assms(1) assms(2)
      rea_not_false  wp_rea_RC_false wp_rea_def)

lemma NRD_rdes_intro [closure]:
  assumes "P is RC" "Q is RR" "R is RR"
  shows "\<^bold>R(P \<turnstile> Q \<diamondop> R) is NRD"
  by (rule NRD_RC_intro, simp_all add: rdes closure assms unrest)

lemma NRD_composition_wp:
  assumes "P is NRD" "Q is RD"
  shows "P ;; Q =
         \<^bold>R ((pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R Q) \<turnstile> (peri\<^sub>R P \<or> (post\<^sub>R P ;; peri\<^sub>R Q)) \<diamondop> (post\<^sub>R P ;; post\<^sub>R Q))"
  by (simp add: RD_composition_wp assms NRD_is_RD wp_rea_def NRD_neg_pre_unit R1_negate_R1 R1_preR ex_unrest rpred)

lemma NSRD_is_SRD [closure]: "P is NSRD \<Longrightarrow> P is SRD"
  by (simp add: Healthy_def NSRD_def SRD_def, metis Healthy_def RD1_RD3_commute RD2_RHS_commute RD3_def RD3_right_subsumes_RD2 SRD_def SRD_idem SRD_seqr_closure SRD_srdes_skip)

lemma NSRD_elim [RD_elim]:
  "\<lbrakk> P is NSRD; Q(\<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> post\<^sub>R(P))) \<rbrakk> \<Longrightarrow> Q(P)"
  by (simp add: RD_elim closure)

lemma NSRD_idem: "NSRD(NSRD(P)) = NSRD(P)"
  by (metis (no_types, opaque_lifting) Healthy_def NSRD_def RD1_RD2_commute RD1_RD3_commute RD1_RHS_commute RD1_idem RD2_RHS_commute RD2_idem RD3_def RD3_idem RD3_left_subsumes_RD2 RHS_idem SRD_def comp_apply fun.map_comp srdes_left_unital.Healthy_Sequence srdes_left_unital.Healthy_Unit)

lemma NSRD_Idempotent [closure]: "Idempotent NSRD"
  by (simp add: Idempotent_def NSRD_idem)

lemma NSRD_Continuous [closure]: "Continuous NSRD"
  by (simp add: Continuous_comp NSRD_def RD1_Continuous RD3_Continuous RHS_Continuous)

lemma NSRD_form:
  "NSRD(P) = \<^bold>R\<^sub>s((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> ((\<exists> $st\<acute> \<bullet> peri\<^sub>R(P)) \<diamondop> post\<^sub>R(P)))"
proof -
  have "NSRD(P) = RD3(SRD(P))"
    by (metis (no_types, lifting) NSRD_def RD1_RD3_commute RD3_left_subsumes_RD2 SRD_def comp_def)
  also have "... = RD3(\<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> post\<^sub>R(P)))"
    by (simp add: SRD_as_reactive_tri_design)
  also have "... = \<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> post\<^sub>R(P)) ;; II\<^sub>R"
    by (simp add: RD3_def)
  also have "... = \<^bold>R\<^sub>s((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> ((\<exists> $st\<acute> \<bullet> peri\<^sub>R(P)) \<diamondop> post\<^sub>R(P)))"
    by (simp add: RHS_tri_design_right_unit_lemma unrest)
  finally show ?thesis .
qed

lemma NSRD_healthy_form:
  assumes "P is NSRD"
  shows "\<^bold>R\<^sub>s((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> ((\<exists> $st\<acute> \<bullet> peri\<^sub>R(P)) \<diamondop> post\<^sub>R(P))) = P"
  by (metis Healthy_def NSRD_form assms)

lemma NSRD_Sup_closure [closure]:
  assumes "A \<subseteq> \<lbrakk>NSRD\<rbrakk>\<^sub>H" "A \<noteq> {}"
  shows "\<Sqinter> A is NSRD"
proof -
  have "NSRD (\<Sqinter> A) = (\<Sqinter> (NSRD `A))"
    by (simp add: ContinuousD NSRD_Continuous assms(2))
  also have "... = (\<Sqinter> A)"
    by (simp only: Healthy_carrier_image assms)
  finally show ?thesis by (simp add: Healthy_def)
qed

lemma intChoice_NSRD_closed [closure]:
  assumes "P is NSRD" "Q is NSRD"
  shows "P \<sqinter> Q is NSRD"
  using NSRD_Sup_closure[of "{P, Q}"] by (simp add: assms)

lemma NRSD_SUP_closure [closure]:
  "\<lbrakk> \<And> i. i \<in> A \<Longrightarrow> P(i) is NSRD; A \<noteq> {} \<rbrakk> \<Longrightarrow> (\<Sqinter>i\<in>A. P(i)) is NSRD"
  by (rule NSRD_Sup_closure, auto)

lemma NSRD_neg_pre_unit:
  assumes "P is NSRD"
  shows "(\<not>\<^sub>r pre\<^sub>R(P)) ;; true\<^sub>r = (\<not>\<^sub>r pre\<^sub>R(P))"
proof -
  have "(\<not>\<^sub>r pre\<^sub>R(P)) = (\<not>\<^sub>r pre\<^sub>R(\<^bold>R\<^sub>s((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> ((\<exists> $st\<acute> \<bullet> peri\<^sub>R(P)) \<diamondop> post\<^sub>R(P)))))"
    by (simp add: NSRD_healthy_form assms)
  also have "... = R1 (R2c ((\<not>\<^sub>r pre\<^sub>R P) ;; R1 true))"
    by (simp add: rea_pre_RHS_design R1_negate_R1 R1_idem R1_rea_not' R2c_rea_not usubst rpred unrest closure)
  also have "... = (\<not>\<^sub>r pre\<^sub>R P) ;; R1 true"
    by (simp add: R1_R2c_seqr_distribute closure assms)
  finally show ?thesis
    by (simp add: rea_not_def)
qed

lemma NSRD_neg_pre_left_zero:
  assumes "P is NSRD" "Q is R1" "Q is RD1"
  shows "(\<not>\<^sub>r pre\<^sub>R(P)) ;; Q = (\<not>\<^sub>r pre\<^sub>R(P))"
  by (metis (no_types, opaque_lifting) NSRD_neg_pre_unit RD1_left_zero assms(1) assms(2) assms(3) seqr_assoc)

lemma NSRD_st'_unrest_peri [unrest]:
  assumes "P is NSRD"
  shows "$st\<acute> \<sharp> peri\<^sub>R(P)"
proof -
  have "peri\<^sub>R(P) = peri\<^sub>R(\<^bold>R\<^sub>s((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> ((\<exists> $st\<acute> \<bullet> peri\<^sub>R(P)) \<diamondop> post\<^sub>R(P))))"
    by (simp add: NSRD_healthy_form assms)
  also have "... = R1 (R2c (\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R P) ;; R1 true \<Rightarrow>\<^sub>r (\<exists> $st\<acute> \<bullet> peri\<^sub>R P)))"
    by (simp add: rea_peri_RHS_design usubst unrest)
  also have "$st\<acute> \<sharp> ..."
    by (simp add: R1_def R2c_def unrest)
  finally show ?thesis .
qed

lemma NSRD_wait'_unrest_pre [unrest]:
  assumes "P is NSRD"
  shows "$wait\<acute> \<sharp> pre\<^sub>R(P)"
proof -
  have "pre\<^sub>R(P) = pre\<^sub>R(\<^bold>R\<^sub>s((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> ((\<exists> $st\<acute> \<bullet> peri\<^sub>R(P)) \<diamondop> post\<^sub>R(P))))"
    by (simp add: NSRD_healthy_form assms)
  also have "... = (R1 (R2c (\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R P) ;; R1 true)))"
    by (simp add: rea_pre_RHS_design usubst unrest)
  also have "$wait\<acute> \<sharp> ..."
    by (simp add: R1_def R2c_def unrest)
  finally show ?thesis .
qed

lemma NSRD_st'_unrest_pre [unrest]:
  assumes "P is NSRD"
  shows "$st\<acute> \<sharp> pre\<^sub>R(P)"
proof -
  have "pre\<^sub>R(P) = pre\<^sub>R(\<^bold>R\<^sub>s((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> ((\<exists> $st\<acute> \<bullet> peri\<^sub>R(P)) \<diamondop> post\<^sub>R(P))))"
    by (simp add: NSRD_healthy_form assms)
  also have "... = R1 (R2c (\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R P) ;; R1 true))"
    by (simp add: rea_pre_RHS_design usubst unrest)
  also have "$st\<acute> \<sharp> ..."
    by (simp add: R1_def R2c_def unrest)
  finally show ?thesis .
qed

lemma NSRD_peri_under_pre [rpred]:
  "P is NSRD \<Longrightarrow> (pre\<^sub>R P \<Rightarrow>\<^sub>r peri\<^sub>R P) = peri\<^sub>R P"
  by (simp add: SRD_peri_under_pre unrest closure)

lemma NSRD_post_under_pre [rpred]:
  "P is NSRD \<Longrightarrow> (pre\<^sub>R P \<Rightarrow>\<^sub>r post\<^sub>R P) = post\<^sub>R P"
  by (simp add: SRD_post_under_pre unrest closure)

lemma NSRD_peri_seq_under_pre:
  assumes "P is NSRD" "Q is NSRD"
  shows "(pre\<^sub>R P \<Rightarrow>\<^sub>r peri\<^sub>R P \<or> post\<^sub>R P ;; peri\<^sub>R Q) = (peri\<^sub>R P \<or> post\<^sub>R P ;; peri\<^sub>R Q)"
  by (metis NSRD_peri_under_pre assms(1) rea_impl_def utp_pred_laws.disj_assoc)

lemma NSRD_postR_seq_periR_impl:
  assumes "P is NSRD" "Q is NSRD"
  shows "(post\<^sub>R P wp\<^sub>r pre\<^sub>R Q \<Rightarrow>\<^sub>r (post\<^sub>R P ;; peri\<^sub>R Q)) = (post\<^sub>R P ;; peri\<^sub>R Q)"
  by (metis NSRD_is_SRD NSRD_peri_under_pre SRD_healths(2) assms postR_RR wpR_impl_post_spec)

lemma NSRD_postR_seq_postR_impl:
  assumes "P is NSRD" "Q is NSRD"
  shows "(post\<^sub>R P wp\<^sub>r pre\<^sub>R Q \<Rightarrow>\<^sub>r (post\<^sub>R P ;; post\<^sub>R Q)) = (post\<^sub>R P ;; post\<^sub>R Q)"
  by (metis NSRD_is_SRD NSRD_post_under_pre SRD_healths(2) assms postR_RR wpR_impl_post_spec)

lemma NSRD_peri_under_assms:
  assumes "P is NSRD" "Q is NSRD"
  shows "(pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R Q \<Rightarrow>\<^sub>r peri\<^sub>R P \<or> post\<^sub>R P ;; peri\<^sub>R Q) = (peri\<^sub>R P \<or> post\<^sub>R P ;; peri\<^sub>R Q)"
  by (metis (no_types, lifting) NSRD_peri_seq_under_pre assms NSRD_postR_seq_periR_impl rea_impl_conj rea_impl_disj)

lemma NSRD_peri_under_assms':
  assumes "P is NSRD" "Q is NSRD"
  shows "(post\<^sub>R P wp\<^sub>r pre\<^sub>R Q \<Rightarrow>\<^sub>r peri\<^sub>R P \<or> post\<^sub>R P ;; peri\<^sub>R Q) = (peri\<^sub>R P \<or> post\<^sub>R P ;; peri\<^sub>R Q)"
  by (simp add: NSRD_postR_seq_periR_impl assms rea_impl_disj)

lemma NSRD_post_under_assms:
  assumes "P is NSRD" "Q is NSRD"
  shows "(pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R Q \<Rightarrow>\<^sub>r post\<^sub>R P ;; post\<^sub>R Q) = (pre\<^sub>R P \<Rightarrow>\<^sub>r (post\<^sub>R P ;; post\<^sub>R Q))"
  by (metis NSRD_postR_seq_postR_impl assms(1) assms(2) rea_impl_conj)

lemma NSRD_alt_def: "NSRD(P) = RD3(SRD(P))"
  by (metis NSRD_def RD1_RD3_commute RD3_left_subsumes_RD2 SRD_def comp_eq_dest_lhs)

lemma preR_RR [closure]: "P is NSRD \<Longrightarrow> pre\<^sub>R(P) is RR"
  by (rule RR_intro, simp_all add: closure unrest)

lemma NSRD_neg_pre_RC [closure]:
  assumes "P is NSRD"
  shows "pre\<^sub>R(P) is RC"
  by (rule RC_intro, simp_all add: closure assms NSRD_neg_pre_unit rpred)

lemma NSRD_intro:
  assumes "P is SRD" "(\<not>\<^sub>r pre\<^sub>R(P)) ;; true\<^sub>r = (\<not>\<^sub>r pre\<^sub>R(P))" "$st\<acute> \<sharp> peri\<^sub>R(P)"
  shows "P is NSRD"
proof -
  have "NSRD(P) = \<^bold>R\<^sub>s((\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1 true) \<turnstile> ((\<exists> $st\<acute> \<bullet> peri\<^sub>R(P)) \<diamondop> post\<^sub>R(P)))"
    by (simp add: NSRD_form)
  also have "... = \<^bold>R\<^sub>s(pre\<^sub>R P \<turnstile> peri\<^sub>R P \<diamondop> post\<^sub>R P)"
    by (simp add: assms ex_unrest rpred closure)
  also have "... = P"
    by (simp add: SRD_reactive_tri_design assms(1))
  finally show ?thesis
    using Healthy_def by blast
qed

lemma NSRD_intro':
  assumes "P is R2" "P is R3h" "P is RD1" "P is RD3"
  shows "P is NSRD"
  by (metis (no_types, opaque_lifting) Healthy_def NSRD_def R1_R2c_is_R2 RHS_def assms comp_apply)

lemma NSRD_RC_intro:
  assumes "P is SRD" "pre\<^sub>R(P) is RC" "$st\<acute> \<sharp> peri\<^sub>R(P)"
  shows "P is NSRD"
  by (metis Healthy_def NSRD_form SRD_reactive_tri_design assms(1) assms(2) assms(3)
      ex_unrest rea_not_false  wp_rea_RC_false wp_rea_def)

lemma NSRD_rdes_intro [closure]:
  assumes "P is RC" "Q is RR" "R is RR" "$st\<acute> \<sharp> Q"
  shows "\<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R) is NSRD"
  by (rule NSRD_RC_intro, simp_all add: rdes closure assms unrest)

lemma SRD_RD3_implies_NSRD:
  "\<lbrakk> P is SRD; P is RD3 \<rbrakk> \<Longrightarrow> P is NSRD"
  by (metis (no_types, lifting) Healthy_def NSRD_def RHS_idem SRD_healths(4) SRD_reactive_design comp_apply)

lemma NSRD_iff:
  "P is NSRD \<longleftrightarrow> ((P is SRD) \<and> (\<not>\<^sub>r pre\<^sub>R(P)) ;; R1(true) = (\<not>\<^sub>r pre\<^sub>R(P)) \<and> ($st\<acute> \<sharp> peri\<^sub>R(P)))"
  by (meson NSRD_intro NSRD_is_SRD NSRD_neg_pre_unit NSRD_st'_unrest_peri)

lemma NSRD_is_RD3 [closure]:
  assumes "P is NSRD"
  shows "P is RD3"
  by (simp add: NSRD_is_SRD NSRD_neg_pre_unit NSRD_st'_unrest_peri RD3_intro_pre assms)

lemma NSRD_refine_elim:
  assumes
    "P \<sqsubseteq> Q" "P is NSRD" "Q is NSRD"
    "\<lbrakk> `pre\<^sub>R(P) \<Rightarrow> pre\<^sub>R(Q)`; `pre\<^sub>R(P) \<and> peri\<^sub>R(Q) \<Rightarrow> peri\<^sub>R(P)`; `pre\<^sub>R(P) \<and> post\<^sub>R(Q) \<Rightarrow> post\<^sub>R(P)` \<rbrakk> \<Longrightarrow> R"
  shows "R"
proof -
  have "\<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> post\<^sub>R(P)) \<sqsubseteq> \<^bold>R\<^sub>s(pre\<^sub>R(Q) \<turnstile> peri\<^sub>R(Q) \<diamondop> post\<^sub>R(Q))"
    by (simp add: NSRD_is_SRD SRD_reactive_tri_design assms(1) assms(2) assms(3))
  hence 1:"`pre\<^sub>R P \<Rightarrow> pre\<^sub>R Q`" and 2:"`pre\<^sub>R P \<and> peri\<^sub>R Q \<Rightarrow> peri\<^sub>R P`" and 3:"`pre\<^sub>R P \<and> post\<^sub>R Q \<Rightarrow> post\<^sub>R P`"
    by (simp_all add: RHS_tri_design_refine assms closure)
  with assms(4) show ?thesis
    by simp
qed

lemma NSRD_right_unit: "P is NSRD \<Longrightarrow> P ;; II\<^sub>R = P"
  by (metis Healthy_if NSRD_is_RD3 RD3_def)

lemma NSRD_composition_wp:
  assumes "P is NSRD" "Q is SRD"
  shows "P ;; Q =
         \<^bold>R\<^sub>s ((pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R Q) \<turnstile> (peri\<^sub>R P \<or> (post\<^sub>R P ;; peri\<^sub>R Q)) \<diamondop> (post\<^sub>R P ;; post\<^sub>R Q))"
  by (simp add: SRD_composition_wp assms NSRD_is_SRD wp_rea_def NSRD_neg_pre_unit NSRD_st'_unrest_peri R1_negate_R1 R1_preR ex_unrest rpred)

lemma preR_NSRD_seq_lemma:
  assumes "P is NSRD" "Q is SRD"
  shows "R1 (R2c (post\<^sub>R P ;; (\<not>\<^sub>r pre\<^sub>R Q))) = post\<^sub>R P ;; (\<not>\<^sub>r pre\<^sub>R Q)"
proof -
  have "post\<^sub>R P ;; (\<not>\<^sub>r pre\<^sub>R Q) = R1(R2c(post\<^sub>R P)) ;; R1(R2c(\<not>\<^sub>r pre\<^sub>R Q))"
    by (simp add: NSRD_is_SRD R1_R2c_post_RHS R1_rea_not R2c_preR R2c_rea_not assms(1) assms(2))
  also have "... = R1 (R2c (post\<^sub>R P ;; (\<not>\<^sub>r pre\<^sub>R Q)))"
    by (simp add: R1_seqr R2c_R1_seq calculation)
  finally show ?thesis ..
qed

lemma preR_NRD_seq [rdes]:
  assumes "P is NRD" "Q is RD"
  shows "pre\<^sub>R(P ;; Q) = (pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R Q)"
  by (simp add: NRD_composition_wp assms rea_pre_RH_design usubst unrest wp_rea_def R2c_disj
      R1_disj R2c_and R2c_preR R1_R2c_commute[THEN sym] R1_extend_conj' R1_idem R2c_not closure
      R1_rea_not' R2c_rea_not preR_NSRD_seq_lemma Healthy_if)

lemma preR_NSRD_seq [rdes]:
  assumes "P is NSRD" "Q is SRD"
  shows "pre\<^sub>R(P ;; Q) = (pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R Q)"
  by (simp add: NSRD_composition_wp assms rea_pre_RHS_design usubst unrest wp_rea_def R2c_disj
      R1_disj R2c_and R2c_preR R1_R2c_commute[THEN sym] R1_extend_conj' R1_idem R2c_not closure
      R1_rea_not' R2c_rea_not preR_NSRD_seq_lemma)

lemma periR_NSRD_seq [rdes]:
  assumes "P is NSRD" "Q is NSRD"
  shows "peri\<^sub>R(P ;; Q) = ((pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R Q) \<Rightarrow>\<^sub>r (peri\<^sub>R P \<or> (post\<^sub>R P ;; peri\<^sub>R Q)))"
  by (simp add: NSRD_composition_wp assms closure rea_peri_RHS_design usubst unrest wp_rea_def
      R1_extend_conj' R1_disj R1_R2c_seqr_distribute R2c_disj R2c_and R2c_rea_impl R1_rea_impl'
      R2c_preR R2c_periR R1_rea_not' R2c_rea_not R1_peri_SRD)

lemma postR_NSRD_seq [rdes]:
  assumes "P is NSRD" "Q is NSRD"
  shows "post\<^sub>R(P ;; Q) = ((pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R Q) \<Rightarrow>\<^sub>r (post\<^sub>R P ;; post\<^sub>R Q))"
  by (simp add: NSRD_composition_wp assms closure rea_post_RHS_design usubst unrest wp_rea_def
      R1_extend_conj' R1_disj R1_R2c_seqr_distribute R2c_disj R2c_and R2c_rea_impl R1_rea_impl'
      R2c_preR R2c_periR R1_rea_not' R2c_rea_not)

lemma NRD_seqr_closure [closure]:
  assumes "P is NRD" "Q is NRD"
  shows "(P ;; Q) is NRD"
proof -
  have "(\<not>\<^sub>r post\<^sub>R P wp\<^sub>r pre\<^sub>R Q) ;; true\<^sub>r = (\<not>\<^sub>r post\<^sub>R P wp\<^sub>r pre\<^sub>R Q)"
    by (simp add: wp_rea_def rpred assms closure seqr_assoc NRD_neg_pre_unit)
  thus ?thesis
    by (rule_tac NRD_intro, simp_all add: seqr_or_distl NRD_neg_pre_unit assms closure rdes unrest)
qed

lemma NSRD_seqr_closure [closure]:
  assumes "P is NSRD" "Q is NSRD"
  shows "(P ;; Q) is NSRD"
proof -
  have "(\<not>\<^sub>r post\<^sub>R P wp\<^sub>r pre\<^sub>R Q) ;; true\<^sub>r = (\<not>\<^sub>r post\<^sub>R P wp\<^sub>r pre\<^sub>R Q)"
    by (simp add: wp_rea_def rpred assms closure seqr_assoc NSRD_neg_pre_unit)
  moreover have "$st\<acute> \<sharp> pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R Q \<Rightarrow>\<^sub>r peri\<^sub>R P \<or> post\<^sub>R P ;; peri\<^sub>R Q"
    by (simp add: unrest assms wp_rea_def)
  ultimately show ?thesis
    by (rule_tac NSRD_intro, simp_all add: seqr_or_distl NSRD_neg_pre_unit assms closure rdes unrest)
qed

lemma RHS_tri_normal_design_composition:
  assumes
    "$ok\<acute> \<sharp> P" "$ok\<acute> \<sharp> Q\<^sub>1" "$ok\<acute> \<sharp> Q\<^sub>2" "$ok \<sharp> R" "$ok \<sharp> S\<^sub>1" "$ok \<sharp> S\<^sub>2"
    "$wait \<sharp> R" "$wait\<acute> \<sharp> Q\<^sub>2" "$wait \<sharp> S\<^sub>1" "$wait \<sharp> S\<^sub>2"
    "P is R2c" "Q\<^sub>1 is R1" "Q\<^sub>1 is R2c" "Q\<^sub>2 is R1" "Q\<^sub>2 is R2c"
    "R is R2c" "S\<^sub>1 is R1" "S\<^sub>1 is R2c" "S\<^sub>2 is R1" "S\<^sub>2 is R2c"
    "R1 (\<not> P) ;; R1(true) = R1(\<not> P)" "$st\<acute> \<sharp> Q\<^sub>1"
  shows "\<^bold>R\<^sub>s(P \<turnstile> Q\<^sub>1 \<diamondop> Q\<^sub>2) ;; \<^bold>R\<^sub>s(R \<turnstile> S\<^sub>1 \<diamondop> S\<^sub>2)
         = \<^bold>R\<^sub>s((P \<and> Q\<^sub>2 wp\<^sub>r R) \<turnstile> (Q\<^sub>1 \<or> (Q\<^sub>2 ;; S\<^sub>1)) \<diamondop> (Q\<^sub>2 ;; S\<^sub>2))"
proof -
  have "\<^bold>R\<^sub>s(P \<turnstile> Q\<^sub>1 \<diamondop> Q\<^sub>2) ;; \<^bold>R\<^sub>s(R \<turnstile> S\<^sub>1 \<diamondop> S\<^sub>2) =
        \<^bold>R\<^sub>s ((R1 (\<not> P) wp\<^sub>r false \<and> Q\<^sub>2 wp\<^sub>r R) \<turnstile> ((\<exists> $st\<acute> \<bullet> Q\<^sub>1) \<sqinter> (Q\<^sub>2 ;; S\<^sub>1)) \<diamondop> (Q\<^sub>2 ;; S\<^sub>2))"
    by (simp_all add: RHS_tri_design_composition_wp rea_not_def assms unrest)
  also have "... = \<^bold>R\<^sub>s((P \<and> Q\<^sub>2 wp\<^sub>r R) \<turnstile> (Q\<^sub>1 \<or> (Q\<^sub>2 ;; S\<^sub>1)) \<diamondop> (Q\<^sub>2 ;; S\<^sub>2))"
    by (simp add: assms wp_rea_def ex_unrest, rel_auto)
  finally show ?thesis .
qed

lemma RHS_tri_normal_design_composition' [rdes_def]:
  assumes "P is RC" "Q\<^sub>1 is RR" "$st\<acute> \<sharp> Q\<^sub>1" "Q\<^sub>2 is RR" "R is RR" "S\<^sub>1 is RR" "S\<^sub>2 is RR"
  shows "\<^bold>R\<^sub>s(P \<turnstile> Q\<^sub>1 \<diamondop> Q\<^sub>2) ;; \<^bold>R\<^sub>s(R \<turnstile> S\<^sub>1 \<diamondop> S\<^sub>2)
         = \<^bold>R\<^sub>s((P \<and> Q\<^sub>2 wp\<^sub>r R) \<turnstile> (Q\<^sub>1 \<or> (Q\<^sub>2 ;; S\<^sub>1)) \<diamondop> (Q\<^sub>2 ;; S\<^sub>2))"
proof -
  have "R1 (\<not> P) ;; R1 true = R1(\<not> P)"
    using RC_implies_RC1[OF assms(1)]
    by (simp add: Healthy_def RC1_def rea_not_def)
       (metis R1_negate_R1 R1_seqr utp_pred_laws.double_compl)
  thus ?thesis
    by (simp add: RHS_tri_normal_design_composition assms closure unrest RR_implies_R2c)
qed

text \<open> If a normal reactive design has postcondition false, then it is a left zero for sequential
  composition. \<close>

lemma NSRD_seq_post_false:
  assumes "P is NSRD" "Q is SRD" "post\<^sub>R(P) = false"
  shows "P ;; Q = P"
  apply (simp add: NSRD_composition_wp assms wp rpred closure)
  using NSRD_is_SRD SRD_reactive_tri_design assms(1,3) apply fastforce
done

lemma NSRD_srd_skip [closure]: "II\<^sub>R is NSRD"
  by (rule NSRD_intro, simp_all add: rdes closure unrest)

lemma NSRD_Chaos [closure]: "Chaos is NSRD"
  by (rule NSRD_intro, simp_all add: closure rdes unrest)

lemma NSRD_Miracle [closure]: "Miracle is NSRD"
  by (rule NSRD_intro, simp_all add: closure rdes unrest)

text \<open> Post-composing a miracle filters out the non-terminating behaviours \<close>

lemma NSRD_right_Miracle_tri_lemma:
  assumes "P is NSRD"
  shows "P ;; Miracle = \<^bold>R\<^sub>s (pre\<^sub>R P \<turnstile> peri\<^sub>R P \<diamondop> false)"
  by (simp add: NSRD_composition_wp closure assms rdes wp rpred)

lemma Miracle_right_anhil_iff:
  assumes "P is NSRD"
  shows "P ;; Miracle = Miracle \<longleftrightarrow> pre\<^sub>R P = true\<^sub>r \<and> (\<exists> $st\<acute> \<bullet> peri\<^sub>R P) = false"
  by (simp add: SRD_right_Miracle_tri_lemma assms closure, simp add: rdes_def srdes_tri_eq_iff closure assms wp rpred, fastforce)

text \<open> The set of non-terminating behaviours is a subset \<close>

lemma NSRD_right_Miracle_refines:
  assumes "P is NSRD"
  shows "P \<sqsubseteq> P ;; Miracle"
proof -
  have "\<^bold>R\<^sub>s (pre\<^sub>R P \<turnstile> peri\<^sub>R P \<diamondop> post\<^sub>R P) \<sqsubseteq> \<^bold>R\<^sub>s (pre\<^sub>R P \<turnstile> peri\<^sub>R P \<diamondop> false)"
    by (rule srdes_tri_refine_intro, rel_auto+)
  thus ?thesis
    by (simp add: NSRD_elim NSRD_right_Miracle_tri_lemma assms)
qed

text \<open> @{term Chaos} is a right zero of @{term P} precisely when the conjunction of the precondition
  of @{term P} with the weakest precondition under which @{term "post\<^sub>R P"} yields @{term false}
  reduces to @{term false}. This is effectively a feasibility check for reactive designs. \<close>

lemma Chaos_right_anhil_iff:
  assumes "P is NSRD"
  shows "P ;; Chaos = Chaos \<longleftrightarrow> (pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r false) = false"
  by (simp add: SRD_right_Chaos_tri_lemma assms closure, simp add: rdes_def srdes_tri_eq_iff closure assms wp)

lemma upower_Suc_NSRD_closed [closure]:
  "P is NSRD \<Longrightarrow> P \<^bold>^ Suc n is NSRD"
proof (induct n)
  case 0
  then show ?case
    by (simp)
next
  case (Suc n)
  then show ?case
    by (simp add: NSRD_seqr_closure upred_semiring.power_Suc)
qed

lemma NSRD_power_Suc [closure]:
  "P is NSRD \<Longrightarrow> P ;; P \<^bold>^ n is NSRD"
  by (metis upower_Suc_NSRD_closed upred_semiring.power_Suc)

lemma uplus_NSRD_closed [closure]: "P is NSRD \<Longrightarrow> P\<^sup>+ is NSRD"
  by (simp add: uplus_power_def closure)

lemma preR_power:
  assumes "P is NSRD"
  shows "pre\<^sub>R(P ;; P\<^bold>^n) = (\<Squnion> i\<in>{0..n}. (post\<^sub>R(P) \<^bold>^ i) wp\<^sub>r (pre\<^sub>R(P)))"
proof (induct n)
  case 0
  then show ?case
    by (simp add: wp closure)
next
  case (Suc n) note hyp = this
  have "pre\<^sub>R (P \<^bold>^ (Suc n + 1)) = pre\<^sub>R (P ;; P \<^bold>^ (n+1))"
    by (simp add: upred_semiring.power_Suc)
  also have "... = (pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R (P \<^bold>^ (Suc n)))"
    using NSRD_iff assms preR_NSRD_seq upower_Suc_NSRD_closed by fastforce
  also have "... = (pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r (\<Squnion>i\<in>{0..n}. post\<^sub>R P \<^bold>^ i wp\<^sub>r pre\<^sub>R P))"
    by (simp add: hyp upred_semiring.power_Suc)
  also have "... = (pre\<^sub>R P \<and> (\<Squnion>i\<in>{0..n}. post\<^sub>R P wp\<^sub>r (post\<^sub>R P \<^bold>^ i wp\<^sub>r pre\<^sub>R P)))"
    by (simp add: wp)
  also have "... = (pre\<^sub>R P \<and> (\<Squnion>i\<in>{0..n}. (post\<^sub>R P \<^bold>^ (i+1) wp\<^sub>r pre\<^sub>R P)))"
  proof -
    have "\<And> i. R1 (post\<^sub>R P \<^bold>^ i ;; (\<not>\<^sub>r pre\<^sub>R P)) = (post\<^sub>R P \<^bold>^ i ;; (\<not>\<^sub>r pre\<^sub>R P))"
      by (induct_tac i, simp_all add: closure Healthy_if assms)
    thus ?thesis
      by (simp add: wp_rea_def upred_semiring.power_Suc seqr_assoc rpred closure assms)
  qed
  also have "... = (post\<^sub>R P \<^bold>^ 0 wp\<^sub>r pre\<^sub>R P \<and> (\<Squnion>i\<in>{0..n}. (post\<^sub>R P \<^bold>^ (i+1) wp\<^sub>r pre\<^sub>R P)))"
    by (simp add: wp assms closure)
  also have "... = (post\<^sub>R P \<^bold>^ 0 wp\<^sub>r pre\<^sub>R P \<and> (\<Squnion>i\<in>{1..Suc n}. (post\<^sub>R P \<^bold>^ i wp\<^sub>r pre\<^sub>R P)))"
  proof -
    have "(\<Squnion>i\<in>{0..n}. (post\<^sub>R P \<^bold>^ (i+1) wp\<^sub>r pre\<^sub>R P)) = (\<Squnion>i\<in>{1..Suc n}. (post\<^sub>R P \<^bold>^ i wp\<^sub>r pre\<^sub>R P))"
      by (rule cong[of Inf], simp_all add: fun_eq_iff)
         (metis (no_types, lifting) image_Suc_atLeastAtMost image_cong image_image)
    thus ?thesis by simp
  qed
  also have "... = (\<Squnion>i\<in>insert 0 {1..Suc n}. (post\<^sub>R P \<^bold>^ i wp\<^sub>r pre\<^sub>R P))"
    by (simp add: conj_upred_def)
  also have "... = (\<Squnion>i\<in>{0..Suc n}. post\<^sub>R P \<^bold>^ i wp\<^sub>r pre\<^sub>R P)"
    by (simp add: atLeast0_atMost_Suc_eq_insert_0)
  finally show ?case by (simp add: upred_semiring.power_Suc)
qed

lemma preR_power' [rdes]:
  assumes "P is NSRD"
  shows "pre\<^sub>R(P ;; P\<^bold>^n) = (\<Squnion> i\<in>{0..n} \<bullet> (post\<^sub>R(P) \<^bold>^ i) wp\<^sub>r (pre\<^sub>R(P)))"
  by (simp add: preR_power assms USUP_as_Inf[THEN sym], simp add: USUP_as_Inf_image)

lemma preR_power_Suc [rdes]:
  assumes "P is NSRD"
  shows "pre\<^sub>R(P\<^bold>^(Suc n)) = (\<Squnion> i\<in>{0..n} \<bullet> (post\<^sub>R(P) \<^bold>^ i) wp\<^sub>r (pre\<^sub>R(P)))"
  by (simp add: upred_semiring.power_Suc rdes assms)

declare upred_semiring.power_Suc [simp]

lemma periR_power:
  assumes "P is NSRD"
  shows "peri\<^sub>R(P ;; P\<^bold>^n) = (pre\<^sub>R(P\<^bold>^(Suc n)) \<Rightarrow>\<^sub>r (\<Sqinter> i\<in>{0..n}. post\<^sub>R(P) \<^bold>^ i) ;; peri\<^sub>R(P))"
proof (induct n)
  case 0
  then show ?case
    by (simp add: NSRD_is_SRD NSRD_wait'_unrest_pre SRD_peri_under_pre assms)
next
  case (Suc n) note hyp = this
  have "peri\<^sub>R (P \<^bold>^ (Suc n + 1)) = peri\<^sub>R (P ;; P \<^bold>^ (n+1))"
    by (simp)
  also have "... = (pre\<^sub>R(P \<^bold>^ (Suc n + 1)) \<Rightarrow>\<^sub>r (peri\<^sub>R P \<or> post\<^sub>R P ;; peri\<^sub>R (P ;; P \<^bold>^ n)))"
    by (simp add: closure assms rdes)
  also have "... = (pre\<^sub>R(P \<^bold>^ (Suc n + 1)) \<Rightarrow>\<^sub>r (peri\<^sub>R P \<or> post\<^sub>R P ;; (pre\<^sub>R (P \<^bold>^ (Suc n)) \<Rightarrow>\<^sub>r (\<Sqinter>i\<in>{0..n}. post\<^sub>R P \<^bold>^ i) ;; peri\<^sub>R P)))"
    by (simp only: hyp)
  also
  have "... = (pre\<^sub>R P \<Rightarrow>\<^sub>r peri\<^sub>R P \<or> (post\<^sub>R P wp\<^sub>r pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r post\<^sub>R P ;; (pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r (\<Sqinter>i\<in>{0..n}. post\<^sub>R P \<^bold>^ i) ;; peri\<^sub>R P)))"
    by (simp add: rdes closure assms, rel_blast)
  also
  have "... = (pre\<^sub>R P \<Rightarrow>\<^sub>r peri\<^sub>R P \<or> (post\<^sub>R P wp\<^sub>r pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r post\<^sub>R P ;; ((\<Sqinter>i\<in>{0..n}. post\<^sub>R P \<^bold>^ i) ;; peri\<^sub>R P)))"
  proof -
    have "(\<Sqinter>i\<in>{0..n}. post\<^sub>R P \<^bold>^ i) is R1"
      by (simp add: R1_Continuous assms closure)
    hence 1:"((\<Sqinter>i\<in>{0..n}. post\<^sub>R P \<^bold>^ i) ;; peri\<^sub>R P) is R1"
      by (simp add: closure assms)
    hence "(pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r (\<Sqinter>i\<in>{0..n}. post\<^sub>R P \<^bold>^ i) ;; peri\<^sub>R P) is R1"
      by (simp add: closure)
    hence "(post\<^sub>R P wp\<^sub>r pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r post\<^sub>R P ;; (pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r (\<Sqinter>i\<in>{0..n}. post\<^sub>R P \<^bold>^ i) ;; peri\<^sub>R P))
          = (post\<^sub>R P wp\<^sub>r pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r R1(post\<^sub>R P) ;; R1(pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r (\<Sqinter>i\<in>{0..n}. post\<^sub>R P \<^bold>^ i) ;; peri\<^sub>R P))"
      by (simp add: Healthy_if R1_post_SRD assms closure)
    thus ?thesis
      by (simp only: wp_rea_impl_lemma, simp add: Healthy_if 1, simp add: R1_post_SRD assms closure)
  qed
  also
  have "... = (pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r peri\<^sub>R P \<or> post\<^sub>R P ;; ((\<Sqinter>i\<in>{0..n}. post\<^sub>R P \<^bold>^ i) ;; peri\<^sub>R P))"
    by (pred_auto)
  also
  have "... = (pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r peri\<^sub>R P \<or> ((\<Sqinter>i\<in>{0..n}. post\<^sub>R P \<^bold>^ (Suc i)) ;; peri\<^sub>R P))"
    by (simp add: seq_Sup_distl seqr_assoc[THEN sym])
  also
  have "... = (pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r peri\<^sub>R P \<or> ((\<Sqinter>i\<in>{1..Suc n}. post\<^sub>R P \<^bold>^ i) ;; peri\<^sub>R P))"
  proof -
    have "(\<Sqinter>i\<in>{0..n}. post\<^sub>R P \<^bold>^ Suc i) = (\<Sqinter>i\<in>{1..Suc n}. post\<^sub>R P \<^bold>^ i)"
      apply (rule cong[of Sup], auto)
      apply (metis atLeast0AtMost atMost_iff image_Suc_atLeastAtMost rev_image_eqI upred_semiring.power_Suc)
      using Suc_le_D apply fastforce
    done
    thus ?thesis by simp
  qed
  also
  have "... = (pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R (P ;; P \<^bold>^ n) \<Rightarrow>\<^sub>r ((\<Sqinter>i\<in>{0..Suc n}. post\<^sub>R P \<^bold>^ i)) ;; peri\<^sub>R P)"
    by (simp add: SUP_atLeastAtMost_first uinf_or seqr_or_distl seqr_or_distr)
  also
  have "... = (pre\<^sub>R(P\<^bold>^(Suc (Suc n))) \<Rightarrow>\<^sub>r ((\<Sqinter>i\<in>{0..Suc n}. post\<^sub>R P \<^bold>^ i) ;; peri\<^sub>R P))"
    by (simp add: rdes closure assms)
  finally show ?case by (simp)
qed

lemma periR_power' [rdes]:
  assumes "P is NSRD"
  shows "peri\<^sub>R(P ;; P\<^bold>^n) = (pre\<^sub>R(P\<^bold>^(Suc n)) \<Rightarrow>\<^sub>r (\<Sqinter> i\<in>{0..n} \<bullet> post\<^sub>R(P) \<^bold>^ i) ;; peri\<^sub>R(P))"
  by (simp add: periR_power assms UINF_as_Sup[THEN sym], simp add: UINF_as_Sup_image)

lemma periR_power_Suc [rdes]:
  assumes "P is NSRD"
  shows "peri\<^sub>R(P\<^bold>^(Suc n)) = (pre\<^sub>R(P\<^bold>^(Suc n)) \<Rightarrow>\<^sub>r (\<Sqinter> i\<in>{0..n} \<bullet> post\<^sub>R(P) \<^bold>^ i) ;; peri\<^sub>R(P))"
  by (simp add: rdes assms)

lemma postR_power [rdes]:
  assumes "P is NSRD"
  shows "post\<^sub>R(P ;; P\<^bold>^n) = (pre\<^sub>R(P\<^bold>^(Suc n)) \<Rightarrow>\<^sub>r post\<^sub>R(P) \<^bold>^ Suc n)"
proof (induct n)
  case 0
  then show ?case
    by (simp add: NSRD_is_SRD NSRD_wait'_unrest_pre SRD_post_under_pre assms)
next
  case (Suc n) note hyp = this
  have "post\<^sub>R (P \<^bold>^ (Suc n + 1)) = post\<^sub>R (P ;; P \<^bold>^ (n+1))"
    by (simp)
  also have "... = (pre\<^sub>R(P \<^bold>^ (Suc n + 1)) \<Rightarrow>\<^sub>r (post\<^sub>R P ;; post\<^sub>R (P ;; P \<^bold>^ n)))"
    by (simp add: closure assms rdes)
  also have "... = (pre\<^sub>R(P \<^bold>^ (Suc n + 1)) \<Rightarrow>\<^sub>r (post\<^sub>R P ;; (pre\<^sub>R (P \<^bold>^ Suc n) \<Rightarrow>\<^sub>r post\<^sub>R P \<^bold>^ Suc n)))"
    by (simp only: hyp)
  also
  have "... = (pre\<^sub>R P \<Rightarrow>\<^sub>r (post\<^sub>R P wp\<^sub>r pre\<^sub>R (P \<^bold>^ Suc n) \<Rightarrow>\<^sub>r post\<^sub>R P ;; (pre\<^sub>R (P \<^bold>^ Suc n) \<Rightarrow>\<^sub>r post\<^sub>R P \<^bold>^ Suc n)))"
    by (simp add: rdes closure assms, pred_auto)
  also
  have "... = (pre\<^sub>R P \<Rightarrow>\<^sub>r (post\<^sub>R P wp\<^sub>r pre\<^sub>R (P \<^bold>^ Suc n) \<Rightarrow>\<^sub>r post\<^sub>R P ;; post\<^sub>R P \<^bold>^ Suc n))"
    by (metis (no_types, lifting) Healthy_if NSRD_is_SRD NSRD_power_Suc R1_power assms hyp postR_SRD_R1 upred_semiring.power_Suc wp_rea_impl_lemma)
  also
  have "... = (pre\<^sub>R P \<and> post\<^sub>R P wp\<^sub>r pre\<^sub>R (P \<^bold>^ Suc n) \<Rightarrow>\<^sub>r post\<^sub>R P \<^bold>^ Suc (Suc n))"
    by (pred_auto)
  also have "... = (pre\<^sub>R(P\<^bold>^(Suc (Suc n))) \<Rightarrow>\<^sub>r post\<^sub>R P \<^bold>^ Suc (Suc n))"
    by (simp add: rdes closure assms)
  finally show ?case by (simp)
qed

lemma postR_power_Suc [rdes]:
  assumes "P is NSRD"
  shows "post\<^sub>R(P\<^bold>^(Suc n)) = (pre\<^sub>R(P\<^bold>^(Suc n)) \<Rightarrow>\<^sub>r post\<^sub>R(P) \<^bold>^ Suc n)"
  by (simp add: rdes assms)

lemma power_rdes_def [rdes_def]:
  assumes "P is RC" "Q is RR" "R is RR" "$st\<acute> \<sharp> Q"
  shows "(\<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R))\<^bold>^(Suc n)
        = \<^bold>R\<^sub>s((\<Squnion> i\<in>{0..n} \<bullet> (R \<^bold>^ i) wp\<^sub>r P) \<turnstile> ((\<Sqinter> i\<in>{0..n} \<bullet> R \<^bold>^ i) ;; Q) \<diamondop> (R \<^bold>^ Suc n))"
proof (induct n)
  case 0
  then show ?case
    by (simp add: wp assms closure)
next
  case (Suc n)

  have 1: "(P \<and> (\<Squnion> i \<in> {0..n} \<bullet> R wp\<^sub>r (R \<^bold>^ i wp\<^sub>r P))) = (\<Squnion> i \<in> {0..Suc n} \<bullet> R \<^bold>^ i wp\<^sub>r P)"
    (is "?lhs = ?rhs")
  proof -
    have "?lhs = (P \<and> (\<Squnion> i \<in> {0..n} \<bullet> (R \<^bold>^ Suc i wp\<^sub>r P)))"
      by (simp add: wp closure assms)
    also have "... = (P \<and> (\<Squnion> i \<in> {0..n}. (R \<^bold>^ Suc i wp\<^sub>r P)))"
      by (simp only: USUP_as_Inf_collect)
    also have "... = (P \<and> (\<Squnion> i \<in> {1..Suc n}. (R \<^bold>^ i wp\<^sub>r P)))"
      by (metis (no_types, lifting) INF_cong One_nat_def image_Suc_atLeastAtMost image_image)
    also have "... = (\<Squnion> i \<in> insert 0 {1..Suc n}. (R \<^bold>^ i wp\<^sub>r P))"
      by (simp add: wp assms closure conj_upred_def)
    also have "... = (\<Squnion> i \<in> {0..Suc n}. (R \<^bold>^ i wp\<^sub>r P))"
      by (simp add: atLeastAtMost_insertL)
    finally show ?thesis
      by (simp add: USUP_as_Inf_collect)
  qed

  have 2: "(Q \<or> R ;; (\<Sqinter> i \<in> {0..n} \<bullet> R \<^bold>^ i) ;; Q) = (\<Sqinter> i \<in> {0..Suc n} \<bullet> R \<^bold>^ i) ;; Q"
    (is "?lhs = ?rhs")
  proof -
    have "?lhs = (Q \<or> (\<Sqinter> i \<in> {0..n} \<bullet> R \<^bold>^ Suc i) ;; Q)"
      by (simp add: seqr_assoc[THEN sym] seq_UINF_distl)
    also have "... = (Q \<or> (\<Sqinter> i \<in> {0..n}. R \<^bold>^ Suc i) ;; Q)"
      by (simp only: UINF_as_Sup_collect)
    also have "... = (Q \<or> (\<Sqinter> i \<in> {1..Suc n}. R \<^bold>^ i) ;; Q)"
      by (metis One_nat_def image_Suc_atLeastAtMost image_image)
    also have "... = ((\<Sqinter> i \<in> insert 0 {1..Suc n}. R \<^bold>^ i) ;; Q)"
      by (simp add: disj_upred_def[THEN sym] seqr_or_distl)
    also have "... = ((\<Sqinter> i \<in> {0..Suc n}. R \<^bold>^ i) ;; Q)"
      by (simp add: atLeastAtMost_insertL)
    finally show ?thesis
      by (simp add: UINF_as_Sup_collect)
  qed

  have 3: "(\<Sqinter> i \<in> {0..n} \<bullet> R \<^bold>^ i) ;; Q is RR"
  proof -
    have "(\<Sqinter> i \<in> {0..n} \<bullet> R \<^bold>^ i) ;; Q = (\<Sqinter> i \<in> {0..n}. R \<^bold>^ i) ;; Q"
      by (simp add: UINF_as_Sup_collect)
    also have "... = (\<Sqinter> i \<in> insert 0 {1..n}. R \<^bold>^ i) ;; Q"
      by (simp add: atLeastAtMost_insertL)
    also have "... = (Q \<or> (\<Sqinter> i \<in> {1..n}. R \<^bold>^ i) ;; Q)"
      by (metis (no_types, lifting) SUP_insert disj_upred_def seqr_left_unit seqr_or_distl upred_semiring.power_0)
    also have "... = (Q \<or> (\<Sqinter> i \<in> {0..<n}. R \<^bold>^ Suc i) ;; Q)"
      by (metis One_nat_def atLeastLessThanSuc_atLeastAtMost image_Suc_atLeastLessThan image_image)
    also have "... = (Q \<or> (\<Sqinter> i \<in> {0..<n} \<bullet> R \<^bold>^ Suc i) ;; Q)"
      by (simp add: UINF_as_Sup_collect)
    also have "... is RR"
      by (simp_all add: closure assms)
    finally show ?thesis .
  qed
  from 1 2 3 Suc show ?case
    by (simp add: Suc RHS_tri_normal_design_composition' closure assms wp)
qed

declare upred_semiring.power_Suc [simp del]

theorem uplus_rdes_def [rdes_def]:
  assumes "P is RC" "Q is RR" "R is RR" "$st\<acute> \<sharp> Q"
  shows "(\<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R))\<^sup>+ = \<^bold>R\<^sub>s(R\<^sup>\<star>\<^sup>r wp\<^sub>r P \<turnstile> (R\<^sup>\<star>\<^sup>r ;; Q) \<diamondop> R\<^sup>+)"
proof -
  have 1:"(\<Sqinter> i \<bullet> R \<^bold>^ i) ;; Q = R\<^sup>\<star>\<^sup>r ;; Q"
    by (metis (no_types) RA1 assms(2) rea_skip_unit(2) rrel_theory.Star_def ustar_alt_def)
  show ?thesis
    by (simp add: uplus_power_def seq_UINF_distr wp closure assms rdes_def)
       (metis "1" seq_UINF_distr')
qed

subsection \<open> UTP theory \<close>

lemma NSRD_false: "NSRD false = Miracle"
  by (metis Healthy_if NSRD_Miracle NSRD_alt_def NSRD_is_RD3 srdes_theory.healthy_top)

lemma NSRD_true: "NSRD true = Chaos"
  by (metis Healthy_if NSRD_Chaos NSRD_alt_def NSRD_is_RD3 srdes_theory.healthy_bottom)

interpretation nsrdes_theory: utp_theory_kleene NSRD II\<^sub>R
  rewrites "P \<in> carrier nsrdes_theory.thy_order \<longleftrightarrow> P is NSRD"
  and "carrier nsrdes_theory.thy_order \<rightarrow> carrier nsrdes_theory.thy_order \<equiv> \<lbrakk>NSRD\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>NSRD\<rbrakk>\<^sub>H"
  and "le nsrdes_theory.thy_order = (\<sqsubseteq>)"
  and "eq nsrdes_theory.thy_order = (=)"
  and nsrdes_top: "nsrdes_theory.utp_top = Miracle"
  and nsrdes_bottom: "nsrdes_theory.utp_bottom = Chaos"
proof -
  have "utp_theory_continuous NSRD"
    by (unfold_locales, simp_all add: NSRD_idem NSRD_Continuous)
  then interpret utp_theory_continuous NSRD
    by simp
  show t: "utp_top = Miracle" and b:"utp_bottom = Chaos"
    by (simp_all add: healthy_top healthy_bottom NSRD_false NSRD_true)
  show "utp_theory_kleene NSRD II\<^sub>R"
    by (unfold_locales, simp_all add: closure srdes_left_unital.Unit_Left NSRD_right_unit Miracle_left_zero t)
qed (simp_all)

abbreviation TestR ("test\<^sub>R") where
"test\<^sub>R P \<equiv> nsrdes_theory.utp_test P"

definition StarR :: "('s, 't::trace, '\<alpha>) hrel_rsp \<Rightarrow> ('s, 't, '\<alpha>) hrel_rsp" ("_\<^sup>\<star>\<^sup>R" [999] 999) where
"StarR \<equiv> nsrdes_theory.utp_star"

text \<open> We also show how to calculate the Kleene closure of a reactive design. \<close>

thm rdes_def

lemma StarR_rdes_def [rdes_def]:
  assumes "P is RC" "Q is RR" "R is RR" "$st\<acute> \<sharp> Q"
  shows "(\<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R))\<^sup>\<star>\<^sup>R = \<^bold>R\<^sub>s((R\<^sup>\<star>\<^sup>r wp\<^sub>r P) \<turnstile> (R\<^sup>\<star>\<^sup>r ;; Q) \<diamondop> R\<^sup>\<star>\<^sup>r)"
  by (simp add: StarR_def rrel_theory.Star_alt_def nsrdes_theory.Star_alt_def closure assms)
     (simp add: rrel_theory.Star_alt_def assms closure rdes_def unrest rpred disj_upred_def)
*)

end


section\<open>Transitive set models of ZF\<close>
text\<open>This theory defines locales for countable transitive models of $\ZF$,
and on top of that, one that includes a forcing notion. Weakened versions
of both locales are included, that only assume finitely many replacement
instances.\<close>

theory Forcing_Data
  imports
    Forcing_Notions
    Cohen_Posets_Relative
    ZF_Trans_Interpretations
begin

no_notation Aleph (\<open>\<aleph>_\<close> [90] 90)

subsection\<open>A forcing locale and generic filters\<close>

text\<open>Ideally, countability should be separated from the assumption of this locale.
The fact is that our present proofs of the “definition of forces” (and many
consequences) and of the lemma for “forcing a value” of function
unnecessarily depend on the countability of the ground model. \<close>

locale forcing_data1 = forcing_notion + M_ctm1 +
  assumes P_in_M:           "\<bbbP> \<in> M"
    and leq_in_M:         "leq \<in> M"

locale forcing_data2 = forcing_data1 + M_ctm2_AC

locale forcing_data3 = forcing_data2 + M_ctm3_AC

context forcing_data1
begin

lemma P_sub_M : "\<bbbP> \<subseteq> M"
  using transitivity P_in_M by auto

definition
  M_generic :: "i\<Rightarrow>o" where
  "M_generic(G) \<equiv> filter(G) \<and> (\<forall>D\<in>M. D\<subseteq>\<bbbP> \<and> dense(D)\<longrightarrow>D\<inter>G\<noteq>0)"

declare iff_trans [trans]

lemma M_generic_imp_filter[dest]: "M_generic(G) \<Longrightarrow> filter(G)"
  unfolding M_generic_def by blast

lemma generic_filter_existence:
  "p\<in>\<bbbP> \<Longrightarrow> \<exists>G. p\<in>G \<and> M_generic(G)"
proof -
  assume "p\<in>\<bbbP>"
  let ?D="\<lambda>n\<in>nat. (if (enum`n\<subseteq>\<bbbP> \<and> dense(enum`n))  then enum`n else \<bbbP>)"
  have "\<forall>n\<in>nat. ?D`n \<in> Pow(\<bbbP>)"
    by auto
  then
  have "?D:nat\<rightarrow>Pow(\<bbbP>)"
    using lam_type by auto
  have "\<forall>n\<in>nat. dense(?D`n)"
  proof(intro ballI)
    fix n
    assume "n\<in>nat"
    then
    have "dense(?D`n) \<longleftrightarrow> dense(if enum`n \<subseteq> \<bbbP> \<and> dense(enum`n) then enum`n else \<bbbP>)"
      by simp
    also
    have "... \<longleftrightarrow>  (\<not>(enum`n \<subseteq> \<bbbP> \<and> dense(enum`n)) \<longrightarrow> dense(\<bbbP>)) "
      using split_if by simp
    finally
    show "dense(?D`n)"
      using P_dense \<open>n\<in>nat\<close> by auto
  qed
  with \<open>?D\<in>_\<close>
  interpret cg: countable_generic \<bbbP> leq \<one> ?D
    by (unfold_locales, auto)
  from \<open>p\<in>\<bbbP>\<close>
  obtain G where 1: "p\<in>G \<and> filter(G) \<and> (\<forall>n\<in>nat.(?D`n)\<inter>G\<noteq>0)"
    using cg.countable_rasiowa_sikorski[where M="\<lambda>_. M"]  P_sub_M
      M_countable[THEN bij_is_fun] M_countable[THEN bij_is_surj, THEN surj_range]
    unfolding cg.D_generic_def by blast
  then
  have "(\<forall>D\<in>M. D\<subseteq>\<bbbP> \<and> dense(D)\<longrightarrow>D\<inter>G\<noteq>0)"
  proof (intro ballI impI)
    fix D
    assume "D\<in>M" and 2: "D \<subseteq> \<bbbP> \<and> dense(D) "
    moreover
    have "\<forall>y\<in>M. \<exists>x\<in>nat. enum`x= y"
      using M_countable and  bij_is_surj unfolding surj_def by (simp)
    moreover from calculation
    obtain n where Eq10: "n\<in>nat \<and> enum`n = D"
      by auto
    moreover from calculation if_P
    have "?D`n = D"
      by simp
    moreover
    note 1
    ultimately
    show "D\<inter>G\<noteq>0"
      by auto
  qed
  with 1
  show ?thesis
    unfolding M_generic_def by auto
qed

lemma one_in_M: "\<one> \<in> M"
  using one_in_P P_in_M transitivity
  by simp

declare P_in_M [simp,intro]
declare one_in_M [simp,intro]
declare leq_in_M [simp,intro]
declare one_in_P [intro]

end \<comment> \<open>\<^locale>\<open>forcing_data1\<close>\<close>

locale G_generic1 = forcing_data1 +
  fixes G :: "i"
  assumes generic : "M_generic(G)"
begin

lemma G_nonempty: "G\<noteq>0"
  using generic subset_refl[of \<bbbP>] P_dense
  unfolding M_generic_def
  by auto

lemma M_genericD [dest]: "x\<in>G \<Longrightarrow> x\<in>\<bbbP>"
  using generic
  by (blast dest:filterD)

lemma M_generic_leqD [dest]: "p\<in>G \<Longrightarrow> q\<in>\<bbbP> \<Longrightarrow> p\<preceq>q \<Longrightarrow> q\<in>G"
  using generic
  by (blast dest:filter_leqD)

lemma M_generic_compatD [dest]: "p\<in>G \<Longrightarrow> r\<in>G \<Longrightarrow> \<exists>q\<in>G. q\<preceq>p \<and> q\<preceq>r"
  using generic
  by (blast dest:low_bound_filter)

lemma M_generic_denseD [dest]: "dense(D) \<Longrightarrow> D\<subseteq>\<bbbP> \<Longrightarrow> D\<in>M \<Longrightarrow> \<exists>q\<in>G. q\<in>D"
  using generic
  unfolding M_generic_def by blast

lemma G_subset_P: "G\<subseteq>\<bbbP>"
  using generic by auto

lemma one_in_G : "\<one> \<in> G"
proof -
  have "increasing(G)"
    using generic
    unfolding M_generic_def filter_def by simp
  then
  show ?thesis
    using G_nonempty one_max
    unfolding increasing_def by blast
qed

lemma G_subset_M: "G \<subseteq> M"
  using generic transitivity[OF _ P_in_M] by auto

end \<comment> \<open>\<^locale>\<open>G_generic1\<close>\<close>

locale G_generic1_AC = G_generic1 + M_ctm1_AC

end