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

section{*Decomposition of Analz into two parts*}

theory Analz imports Extensions begin

text{*decomposition of @{term analz} into two parts:
      @{term pparts} (for pairs) and analz of @{term kparts}*}

subsection{*messages that do not contribute to analz*}

inductive_set
  pparts :: "msg set => msg set"
  for H :: "msg set"
where
  Inj [intro]: "[| X:H; is_MPair X |] ==> X:pparts H"
| Fst [dest]: "[| {|X,Y|}:pparts H; is_MPair X |] ==> X:pparts H"
| Snd [dest]: "[| {|X,Y|}:pparts H; is_MPair Y |] ==> Y:pparts H"

subsection{*basic facts about @{term pparts}*}

lemma pparts_is_MPair [dest]: "X:pparts H ==> is_MPair X"
by (erule pparts.induct, auto)

lemma Crypt_notin_pparts [iff]: "Crypt K X ~:pparts H"
by auto

lemma Key_notin_pparts [iff]: "Key K ~:pparts H"
by auto

lemma Nonce_notin_pparts [iff]: "Nonce n ~:pparts H"
by auto

lemma Number_notin_pparts [iff]: "Number n ~:pparts H"
by auto

lemma Agent_notin_pparts [iff]: "Agent A ~:pparts H"
by auto

lemma pparts_empty [iff]: "pparts {} = {}"
by (auto, erule pparts.induct, auto)

lemma pparts_insertI [intro]: "X:pparts H ==> X:pparts (insert Y H)"
by (erule pparts.induct, auto)

lemma pparts_sub: "[| X:pparts G; G<=H |] ==> X:pparts H"
by (erule pparts.induct, auto)

lemma pparts_insert2 [iff]: "pparts (insert X (insert Y H))
= pparts {X} Un pparts {Y} Un pparts H"
by (rule eq, (erule pparts.induct, auto)+)

lemma pparts_insert_MPair [iff]: "pparts (insert {|X,Y|} H)
= insert {|X,Y|} (pparts ({X,Y} Un H))"
apply (rule eq, (erule pparts.induct, auto)+)
apply (rule_tac Y=Y in pparts.Fst, auto)
apply (erule pparts.induct, auto)
by (rule_tac X=X in pparts.Snd, auto)

lemma pparts_insert_Nonce [iff]: "pparts (insert (Nonce n) H) = pparts H"
by (rule eq, erule pparts.induct, auto)

lemma pparts_insert_Crypt [iff]: "pparts (insert (Crypt K X) H) = pparts H"
by (rule eq, erule pparts.induct, auto)

lemma pparts_insert_Key [iff]: "pparts (insert (Key K) H) = pparts H"
by (rule eq, erule pparts.induct, auto)

lemma pparts_insert_Agent [iff]: "pparts (insert (Agent A) H) = pparts H"
by (rule eq, erule pparts.induct, auto)

lemma pparts_insert_Number [iff]: "pparts (insert (Number n) H) = pparts H"
by (rule eq, erule pparts.induct, auto)

lemma pparts_insert_Hash [iff]: "pparts (insert (Hash X) H) = pparts H"
by (rule eq, erule pparts.induct, auto)

lemma pparts_insert: "X:pparts (insert Y H) ==> X:pparts {Y} Un pparts H"
by (erule pparts.induct, blast+)

lemma insert_pparts: "X:pparts {Y} Un pparts H ==> X:pparts (insert Y H)"
by (safe, erule pparts.induct, auto)

lemma pparts_Un [iff]: "pparts (G Un H) = pparts G Un pparts H"
by (rule eq, erule pparts.induct, auto dest: pparts_sub)

lemma pparts_pparts [iff]: "pparts (pparts H) = pparts H"
by (rule eq, erule pparts.induct, auto)

lemma pparts_insert_eq: "pparts (insert X H) = pparts {X} Un pparts H"
by (rule_tac A=H in insert_Un, rule pparts_Un)

lemmas pparts_insert_substI = pparts_insert_eq [THEN ssubst]

lemma in_pparts: "Y:pparts H ==> EX X. X:H & Y:pparts {X}"
by (erule pparts.induct, auto)

subsection{*facts about @{term pparts} and @{term parts}*}

lemma pparts_no_Nonce [dest]: "[| X:pparts {Y}; Nonce n ~:parts {Y} |]
==> Nonce n ~:parts {X}"
by (erule pparts.induct, simp_all)

subsection{*facts about @{term pparts} and @{term analz}*}

lemma pparts_analz: "X:pparts H ==> X:analz H"
by (erule pparts.induct, auto)

lemma pparts_analz_sub: "[| X:pparts G; G<=H |] ==> X:analz H"
by (auto dest: pparts_sub pparts_analz)

subsection{*messages that contribute to analz*}

inductive_set
  kparts :: "msg set => msg set"
  for H :: "msg set"
where
  Inj [intro]: "[| X:H; not_MPair X |] ==> X:kparts H"
| Fst [intro]: "[| {|X,Y|}:pparts H; not_MPair X |] ==> X:kparts H"
| Snd [intro]: "[| {|X,Y|}:pparts H; not_MPair Y |] ==> Y:kparts H"

subsection{*basic facts about @{term kparts}*}

lemma kparts_not_MPair [dest]: "X:kparts H ==> not_MPair X"
by (erule kparts.induct, auto)

lemma kparts_empty [iff]: "kparts {} = {}"
by (rule eq, erule kparts.induct, auto)

lemma kparts_insertI [intro]: "X:kparts H ==> X:kparts (insert Y H)"
by (erule kparts.induct, auto dest: pparts_insertI)

lemma kparts_insert2 [iff]: "kparts (insert X (insert Y H))
= kparts {X} Un kparts {Y} Un kparts H"
by (rule eq, (erule kparts.induct, auto)+)

lemma kparts_insert_MPair [iff]: "kparts (insert {|X,Y|} H)
= kparts ({X,Y} Un H)"
by (rule eq, (erule kparts.induct, auto)+)

lemma kparts_insert_Nonce [iff]: "kparts (insert (Nonce n) H)
= insert (Nonce n) (kparts H)"
by (rule eq, erule kparts.induct, auto)

lemma kparts_insert_Crypt [iff]: "kparts (insert (Crypt K X) H)
= insert (Crypt K X) (kparts H)"
by (rule eq, erule kparts.induct, auto)

lemma kparts_insert_Key [iff]: "kparts (insert (Key K) H)
= insert (Key K) (kparts H)"
by (rule eq, erule kparts.induct, auto)

lemma kparts_insert_Agent [iff]: "kparts (insert (Agent A) H)
= insert (Agent A) (kparts H)"
by (rule eq, erule kparts.induct, auto)

lemma kparts_insert_Number [iff]: "kparts (insert (Number n) H)
= insert (Number n) (kparts H)"
by (rule eq, erule kparts.induct, auto)

lemma kparts_insert_Hash [iff]: "kparts (insert (Hash X) H)
= insert (Hash X) (kparts H)"
by (rule eq, erule kparts.induct, auto)

lemma kparts_insert: "X:kparts (insert X H) ==> X:kparts {X} Un kparts H"
by (erule kparts.induct, (blast dest: pparts_insert)+)

lemma kparts_insert_fst [rule_format,dest]: "X:kparts (insert Z H) ==>
X ~:kparts H --> X:kparts {Z}"
by (erule kparts.induct, (blast dest: pparts_insert)+)

lemma kparts_sub: "[| X:kparts G; G<=H |] ==> X:kparts H"
by (erule kparts.induct, auto dest: pparts_sub)

lemma kparts_Un [iff]: "kparts (G Un H) = kparts G Un kparts H"
by (rule eq, erule kparts.induct, auto dest: kparts_sub)

lemma pparts_kparts [iff]: "pparts (kparts H) = {}"
by (rule eq, erule pparts.induct, auto)

lemma kparts_kparts [iff]: "kparts (kparts H) = kparts H"
by (rule eq, erule kparts.induct, auto)

lemma kparts_insert_eq: "kparts (insert X H) = kparts {X} Un kparts H"
by (rule_tac A=H in insert_Un, rule kparts_Un)

lemmas kparts_insert_substI = kparts_insert_eq [THEN ssubst]

lemma in_kparts: "Y:kparts H ==> EX X. X:H & Y:kparts {X}"
by (erule kparts.induct, auto dest: in_pparts)

lemma kparts_has_no_pair [iff]: "has_no_pair (kparts H)"
by auto

subsection{*facts about @{term kparts} and @{term parts}*}

lemma kparts_no_Nonce [dest]: "[| X:kparts {Y}; Nonce n ~:parts {Y} |]
==> Nonce n ~:parts {X}"
by (erule kparts.induct, auto)

lemma kparts_parts: "X:kparts H ==> X:parts H"
by (erule kparts.induct, auto dest: pparts_analz)

lemma parts_kparts: "X:parts (kparts H) ==> X:parts H"
by (erule parts.induct, auto dest: kparts_parts
intro: parts.Fst parts.Snd parts.Body)

lemma Crypt_kparts_Nonce_parts [dest]: "[| Crypt K Y:kparts {Z};
Nonce n:parts {Y} |] ==> Nonce n:parts {Z}"
by auto

subsection{*facts about @{term kparts} and @{term analz}*}

lemma kparts_analz: "X:kparts H ==> X:analz H"
by (erule kparts.induct, auto dest: pparts_analz)

lemma kparts_analz_sub: "[| X:kparts G; G<=H |] ==> X:analz H"
by (erule kparts.induct, auto dest: pparts_analz_sub)

lemma analz_kparts [rule_format,dest]: "X:analz H ==>
Y:kparts {X} --> Y:analz H"
by (erule analz.induct, auto dest: kparts_analz_sub)

lemma analz_kparts_analz: "X:analz (kparts H) ==> X:analz H"
by (erule analz.induct, auto dest: kparts_analz)

lemma analz_kparts_insert: "X:analz (kparts (insert Z H)) ==> X:analz (kparts {Z} Un kparts H)"
by (rule analz_sub, auto)

lemma Nonce_kparts_synth [rule_format]: "Y:synth (analz G)
==> Nonce n:kparts {Y} --> Nonce n:analz G"
by (erule synth.induct, auto)

lemma kparts_insert_synth: "[| Y:parts (insert X G); X:synth (analz G);
Nonce n:kparts {Y}; Nonce n ~:analz G |] ==> Y:parts G"
apply (drule parts_insert_substD, clarify)
apply (drule in_sub, drule_tac X=Y in parts_sub, simp)
apply (auto dest: Nonce_kparts_synth)
done

lemma Crypt_insert_synth:
  "[| Crypt K Y:parts (insert X G); X:synth (analz G); Nonce n:kparts {Y}; Nonce n ~:analz G |]
   ==> Crypt K Y:parts G"
by (metis Fake_parts_insert_in_Un Nonce_kparts_synth UnE analz_conj_parts synth_simps(5))

subsection{*analz is pparts + analz of kparts*}

lemma analz_pparts_kparts: "X:analz H ==> X:pparts H | X:analz (kparts H)"
by (erule analz.induct, auto)

lemma analz_pparts_kparts_eq: "analz H = pparts H Un analz (kparts H)"
by (rule eq, auto dest: analz_pparts_kparts pparts_analz analz_kparts_analz)

lemmas analz_pparts_kparts_substI = analz_pparts_kparts_eq [THEN ssubst]
lemmas analz_pparts_kparts_substD = analz_pparts_kparts_eq [THEN sym, THEN ssubst]

end


(*  Title:      Sequents/LK0.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge

There may be printing problems if a seqent is in expanded normal form
(eta-expanded, beta-contracted).
*)

section \<open>Classical First-Order Sequent Calculus\<close>

theory LK0
imports Sequents
begin

class "term"
default_sort "term"

consts

  Trueprop       :: "two_seqi"

  True         :: o
  False        :: o
  equal        :: "['a,'a] \<Rightarrow> o"     (infixl "=" 50)
  Not          :: "o \<Rightarrow> o"           ("\<not> _" [40] 40)
  conj         :: "[o,o] \<Rightarrow> o"       (infixr "\<and>" 35)
  disj         :: "[o,o] \<Rightarrow> o"       (infixr "\<or>" 30)
  imp          :: "[o,o] \<Rightarrow> o"       (infixr "\<longrightarrow>" 25)
  iff          :: "[o,o] \<Rightarrow> o"       (infixr "\<longleftrightarrow>" 25)
  The          :: "('a \<Rightarrow> o) \<Rightarrow> 'a"  (binder "THE " 10)
  All          :: "('a \<Rightarrow> o) \<Rightarrow> o"   (binder "\<forall>" 10)
  Ex           :: "('a \<Rightarrow> o) \<Rightarrow> o"   (binder "\<exists>" 10)

syntax
 "_Trueprop"    :: "two_seqe" ("((_)/ \<turnstile> (_))" [6,6] 5)

parse_translation \<open>[(@{syntax_const "_Trueprop"}, K (two_seq_tr @{const_syntax Trueprop}))]\<close>
print_translation \<open>[(@{const_syntax Trueprop}, K (two_seq_tr' @{syntax_const "_Trueprop"}))]\<close>

abbreviation
  not_equal  (infixl "\<noteq>" 50) where
  "x \<noteq> y \<equiv> \<not> (x = y)"

axiomatization where

  (*Structural rules: contraction, thinning, exchange [Soren Heilmann] *)

  contRS: "$H \<turnstile> $E, $S, $S, $F \<Longrightarrow> $H \<turnstile> $E, $S, $F" and
  contLS: "$H, $S, $S, $G \<turnstile> $E \<Longrightarrow> $H, $S, $G \<turnstile> $E" and

  thinRS: "$H \<turnstile> $E, $F \<Longrightarrow> $H \<turnstile> $E, $S, $F" and
  thinLS: "$H, $G \<turnstile> $E \<Longrightarrow> $H, $S, $G \<turnstile> $E" and

  exchRS: "$H \<turnstile> $E, $R, $S, $F \<Longrightarrow> $H \<turnstile> $E, $S, $R, $F" and
  exchLS: "$H, $R, $S, $G \<turnstile> $E \<Longrightarrow> $H, $S, $R, $G \<turnstile> $E" and

  cut:   "\<lbrakk>$H \<turnstile> $E, P;  $H, P \<turnstile> $E\<rbrakk> \<Longrightarrow> $H \<turnstile> $E" and

  (*Propositional rules*)

  basic: "$H, P, $G \<turnstile> $E, P, $F" and

  conjR: "\<lbrakk>$H\<turnstile> $E, P, $F;  $H\<turnstile> $E, Q, $F\<rbrakk> \<Longrightarrow> $H\<turnstile> $E, P \<and> Q, $F" and
  conjL: "$H, P, Q, $G \<turnstile> $E \<Longrightarrow> $H, P \<and> Q, $G \<turnstile> $E" and

  disjR: "$H \<turnstile> $E, P, Q, $F \<Longrightarrow> $H \<turnstile> $E, P \<or> Q, $F" and
  disjL: "\<lbrakk>$H, P, $G \<turnstile> $E;  $H, Q, $G \<turnstile> $E\<rbrakk> \<Longrightarrow> $H, P \<or> Q, $G \<turnstile> $E" and

  impR:  "$H, P \<turnstile> $E, Q, $F \<Longrightarrow> $H \<turnstile> $E, P \<longrightarrow> Q, $F" and
  impL:  "\<lbrakk>$H,$G \<turnstile> $E,P;  $H, Q, $G \<turnstile> $E\<rbrakk> \<Longrightarrow> $H, P \<longrightarrow> Q, $G \<turnstile> $E" and

  notR:  "$H, P \<turnstile> $E, $F \<Longrightarrow> $H \<turnstile> $E, \<not> P, $F" and
  notL:  "$H, $G \<turnstile> $E, P \<Longrightarrow> $H, \<not> P, $G \<turnstile> $E" and

  FalseL: "$H, False, $G \<turnstile> $E" and

  True_def: "True \<equiv> False \<longrightarrow> False" and
  iff_def:  "P \<longleftrightarrow> Q \<equiv> (P \<longrightarrow> Q) \<and> (Q \<longrightarrow> P)"

axiomatization where
  (*Quantifiers*)

  allR:  "(\<And>x. $H \<turnstile> $E, P(x), $F) \<Longrightarrow> $H \<turnstile> $E, \<forall>x. P(x), $F" and
  allL:  "$H, P(x), $G, \<forall>x. P(x) \<turnstile> $E \<Longrightarrow> $H, \<forall>x. P(x), $G \<turnstile> $E" and

  exR:   "$H \<turnstile> $E, P(x), $F, \<exists>x. P(x) \<Longrightarrow> $H \<turnstile> $E, \<exists>x. P(x), $F" and
  exL:   "(\<And>x. $H, P(x), $G \<turnstile> $E) \<Longrightarrow> $H, \<exists>x. P(x), $G \<turnstile> $E" and

  (*Equality*)
  refl:  "$H \<turnstile> $E, a = a, $F" and
  subst: "\<And>G H E. $H(a), $G(a) \<turnstile> $E(a) \<Longrightarrow> $H(b), a=b, $G(b) \<turnstile> $E(b)"

  (* Reflection *)

axiomatization where
  eq_reflection:  "\<turnstile> x = y \<Longrightarrow> (x \<equiv> y)" and
  iff_reflection: "\<turnstile> P \<longleftrightarrow> Q \<Longrightarrow> (P \<equiv> Q)"

  (*Descriptions*)

axiomatization where
  The: "\<lbrakk>$H \<turnstile> $E, P(a), $F;  \<And>x.$H, P(x) \<turnstile> $E, x=a, $F\<rbrakk> \<Longrightarrow>
         $H \<turnstile> $E, P(THE x. P(x)), $F"

definition If :: "[o, 'a, 'a] \<Rightarrow> 'a" ("(if (_)/ then (_)/ else (_))" 10)
  where "If(P,x,y) \<equiv> THE z::'a. (P \<longrightarrow> z = x) \<and> (\<not> P \<longrightarrow> z = y)"

(** Structural Rules on formulas **)

(*contraction*)

lemma contR: "$H \<turnstile> $E, P, P, $F \<Longrightarrow> $H \<turnstile> $E, P, $F"
  by (rule contRS)

lemma contL: "$H, P, P, $G \<turnstile> $E \<Longrightarrow> $H, P, $G \<turnstile> $E"
  by (rule contLS)

(*thinning*)

lemma thinR: "$H \<turnstile> $E, $F \<Longrightarrow> $H \<turnstile> $E, P, $F"
  by (rule thinRS)

lemma thinL: "$H, $G \<turnstile> $E \<Longrightarrow> $H, P, $G \<turnstile> $E"
  by (rule thinLS)

(*exchange*)

lemma exchR: "$H \<turnstile> $E, Q, P, $F \<Longrightarrow> $H \<turnstile> $E, P, Q, $F"
  by (rule exchRS)

lemma exchL: "$H, Q, P, $G \<turnstile> $E \<Longrightarrow> $H, P, Q, $G \<turnstile> $E"
  by (rule exchLS)

ML \<open>
(*Cut and thin, replacing the right-side formula*)
fun cutR_tac ctxt s i =
  Rule_Insts.res_inst_tac ctxt [((("P", 0), Position.none), s)] [] @{thm cut} i THEN
  resolve_tac ctxt @{thms thinR} i

(*Cut and thin, replacing the left-side formula*)
fun cutL_tac ctxt s i =
  Rule_Insts.res_inst_tac ctxt [((("P", 0), Position.none), s)] [] @{thm cut} i THEN
  resolve_tac ctxt @{thms thinL} (i + 1)
\<close>

(** If-and-only-if rules **)
lemma iffR: "\<lbrakk>$H,P \<turnstile> $E,Q,$F;  $H,Q \<turnstile> $E,P,$F\<rbrakk> \<Longrightarrow> $H \<turnstile> $E, P \<longleftrightarrow> Q, $F"
  apply (unfold iff_def)
  apply (assumption | rule conjR impR)+
  done

lemma iffL: "\<lbrakk>$H,$G \<turnstile> $E,P,Q;  $H,Q,P,$G \<turnstile> $E\<rbrakk> \<Longrightarrow> $H, P \<longleftrightarrow> Q, $G \<turnstile> $E"
  apply (unfold iff_def)
  apply (assumption | rule conjL impL basic)+
  done

lemma iff_refl: "$H \<turnstile> $E, (P \<longleftrightarrow> P), $F"
  apply (rule iffR basic)+
  done

lemma TrueR: "$H \<turnstile> $E, True, $F"
  apply (unfold True_def)
  apply (rule impR)
  apply (rule basic)
  done

(*Descriptions*)
lemma the_equality:
  assumes p1: "$H \<turnstile> $E, P(a), $F"
    and p2: "\<And>x. $H, P(x) \<turnstile> $E, x=a, $F"
  shows "$H \<turnstile> $E, (THE x. P(x)) = a, $F"
  apply (rule cut)
   apply (rule_tac [2] p2)
  apply (rule The, rule thinR, rule exchRS, rule p1)
  apply (rule thinR, rule exchRS, rule p2)
  done

(** Weakened quantifier rules.  Incomplete, they let the search terminate.**)

lemma allL_thin: "$H, P(x), $G \<turnstile> $E \<Longrightarrow> $H, \<forall>x. P(x), $G \<turnstile> $E"
  apply (rule allL)
  apply (erule thinL)
  done

lemma exR_thin: "$H \<turnstile> $E, P(x), $F \<Longrightarrow> $H \<turnstile> $E, \<exists>x. P(x), $F"
  apply (rule exR)
  apply (erule thinR)
  done

(*The rules of LK*)

lemmas [safe] =
  iffR iffL
  notR notL
  impR impL
  disjR disjL
  conjR conjL
  FalseL TrueR
  refl basic
ML \<open>val prop_pack = Cla.get_pack @{context}\<close>

lemmas [safe] = exL allR
lemmas [unsafe] = the_equality exR_thin allL_thin
ML \<open>val LK_pack = Cla.get_pack @{context}\<close>

ML \<open>
  val LK_dup_pack =
    Cla.put_pack prop_pack @{context}
    |> fold_rev Cla.add_safe @{thms allR exL}
    |> fold_rev Cla.add_unsafe @{thms allL exR the_equality}
    |> Cla.get_pack;
\<close>

method_setup fast_prop =
  \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Cla.fast_tac (Cla.put_pack prop_pack ctxt)))\<close>

method_setup fast_dup =
  \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Cla.fast_tac (Cla.put_pack LK_dup_pack ctxt)))\<close>

method_setup best_dup =
  \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Cla.best_tac (Cla.put_pack LK_dup_pack ctxt)))\<close>

method_setup lem = \<open>
  Attrib.thm >> (fn th => fn ctxt =>
    SIMPLE_METHOD' (fn i =>
      resolve_tac ctxt [@{thm thinR} RS @{thm cut}] i THEN
      REPEAT (resolve_tac ctxt @{thms thinL} i) THEN
      resolve_tac ctxt [th] i))
\<close>

lemma mp_R:
  assumes major: "$H \<turnstile> $E, $F, P \<longrightarrow> Q"
    and minor: "$H \<turnstile> $E, $F, P"
  shows "$H \<turnstile> $E, Q, $F"
  apply (rule thinRS [THEN cut], rule major)
  apply step
  apply (rule thinR, rule minor)
  done

lemma mp_L:
  assumes major: "$H, $G \<turnstile> $E, P \<longrightarrow> Q"
    and minor: "$H, $G, Q \<turnstile> $E"
  shows "$H, P, $G \<turnstile> $E"
  apply (rule thinL [THEN cut], rule major)
  apply step
  apply (rule thinL, rule minor)
  done

(** Two rules to generate left- and right- rules from implications **)

lemma R_of_imp:
  assumes major: "\<turnstile> P \<longrightarrow> Q"
    and minor: "$H \<turnstile> $E, $F, P"
  shows "$H \<turnstile> $E, Q, $F"
  apply (rule mp_R)
   apply (rule_tac [2] minor)
  apply (rule thinRS, rule major [THEN thinLS])
  done

lemma L_of_imp:
  assumes major: "\<turnstile> P \<longrightarrow> Q"
    and minor: "$H, $G, Q \<turnstile> $E"
  shows "$H, P, $G \<turnstile> $E"
  apply (rule mp_L)
   apply (rule_tac [2] minor)
  apply (rule thinRS, rule major [THEN thinLS])
  done

(*Can be used to create implications in a subgoal*)
lemma backwards_impR:
  assumes prem: "$H, $G \<turnstile> $E, $F, P \<longrightarrow> Q"
  shows "$H, P, $G \<turnstile> $E, Q, $F"
  apply (rule mp_L)
   apply (rule_tac [2] basic)
  apply (rule thinR, rule prem)
  done

lemma conjunct1: "\<turnstile>P \<and> Q \<Longrightarrow> \<turnstile>P"
  apply (erule thinR [THEN cut])
  apply fast
  done

lemma conjunct2: "\<turnstile>P \<and> Q \<Longrightarrow> \<turnstile>Q"
  apply (erule thinR [THEN cut])
  apply fast
  done

lemma spec: "\<turnstile> (\<forall>x. P(x)) \<Longrightarrow> \<turnstile> P(x)"
  apply (erule thinR [THEN cut])
  apply fast
  done

(** Equality **)

lemma sym: "\<turnstile> a = b \<longrightarrow> b = a"
  by (safe add!: subst)

lemma trans: "\<turnstile> a = b \<longrightarrow> b = c \<longrightarrow> a = c"
  by (safe add!: subst)

(* Symmetry of equality in hypotheses *)
lemmas symL = sym [THEN L_of_imp]

(* Symmetry of equality in hypotheses *)
lemmas symR = sym [THEN R_of_imp]

lemma transR: "\<lbrakk>$H\<turnstile> $E, $F, a = b;  $H\<turnstile> $E, $F, b=c\<rbrakk> \<Longrightarrow> $H\<turnstile> $E, a = c, $F"
  by (rule trans [THEN R_of_imp, THEN mp_R])

(* Two theorms for rewriting only one instance of a definition:
   the first for definitions of formulae and the second for terms *)

lemma def_imp_iff: "(A \<equiv> B) \<Longrightarrow> \<turnstile> A \<longleftrightarrow> B"
  apply unfold
  apply (rule iff_refl)
  done

lemma meta_eq_to_obj_eq: "(A \<equiv> B) \<Longrightarrow> \<turnstile> A = B"
  apply unfold
  apply (rule refl)
  done

(** if-then-else rules **)

lemma if_True: "\<turnstile> (if True then x else y) = x"
  unfolding If_def by fast

lemma if_False: "\<turnstile> (if False then x else y) = y"
  unfolding If_def by fast

lemma if_P: "\<turnstile> P \<Longrightarrow> \<turnstile> (if P then x else y) = x"
  apply (unfold If_def)
  apply (erule thinR [THEN cut])
  apply fast
  done

lemma if_not_P: "\<turnstile> \<not> P \<Longrightarrow> \<turnstile> (if P then x else y) = y"
  apply (unfold If_def)
  apply (erule thinR [THEN cut])
  apply fast
  done

end


header "Small-Step Semantics of Commands"

theory Small_Step imports Star Big_Step begin

subsection "The transition relation"

inductive
  small_step :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "(x ::= a, s) \<rightarrow> (SKIP, s(x := aval a s))" |

Seq1:    "(SKIP;;c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |
Seq2:    "(c\<^sub>1,s) \<rightarrow> (c\<^sub>1',s') \<Longrightarrow> (c\<^sub>1;;c\<^sub>2,s) \<rightarrow> (c\<^sub>1';;c\<^sub>2,s')" |

IfTrue:  "bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>1,s)" |
IfFalse: "\<not>bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow>
            (IF b THEN c;; WHILE b DO c ELSE SKIP,s)"

abbreviation
  small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

subsection{* Executability *}

code_pred small_step .

values "{(c',map t [''x'',''y'',''z'']) |c' t.
   (''x'' ::= V ''z'';; ''y'' ::= V ''x'',
    <''x'' := 3, ''y'' := 7, ''z'' := 5>) \<rightarrow>* (c',t)}"

subsection{* Proof infrastructure *}

subsubsection{* Induction rules *}

text{* The default induction rule @{thm[source] small_step.induct} only works
for lemmas of the form @{text"a \<rightarrow> b \<Longrightarrow> \<dots>"} where @{text a} and @{text b} are
not already pairs @{text"(DUMMY,DUMMY)"}. We can generate a suitable variant
of @{thm[source] small_step.induct} for pairs by ``splitting'' the arguments
@{text"\<rightarrow>"} into pairs: *}
lemmas small_step_induct = small_step.induct[split_format(complete)]

subsubsection{* Proof automation *}

declare small_step.intros[simp,intro]

text{* Rule inversion: *}

inductive_cases SkipE[elim!]: "(SKIP,s) \<rightarrow> ct"
thm SkipE
inductive_cases AssignE[elim!]: "(x::=a,s) \<rightarrow> ct"
thm AssignE
inductive_cases SeqE[elim]: "(c1;;c2,s) \<rightarrow> ct"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<rightarrow> ct"
inductive_cases WhileE[elim]: "(WHILE b DO c, s) \<rightarrow> ct"

text{* A simple property: *}
lemma deterministic:
  "cs \<rightarrow> cs' \<Longrightarrow> cs \<rightarrow> cs'' \<Longrightarrow> cs'' = cs'"
apply(induction arbitrary: cs'' rule: small_step.induct)
apply blast+
done

subsection "Equivalence with big-step semantics"

lemma star_seq2: "(c1,s) \<rightarrow>* (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow>* (c1';;c2,s')"
proof(induction rule: star_induct)
  case refl thus ?case by simp
next
  case step
  thus ?case by (metis Seq2 star.step)
qed

lemma seq_comp:
  "\<lbrakk> (c1,s1) \<rightarrow>* (SKIP,s2); (c2,s2) \<rightarrow>* (SKIP,s3) \<rbrakk>
   \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (SKIP,s3)"
by(blast intro: star.step star_seq2 star_trans)

text{* The following proof corresponds to one on the board where one would
show chains of @{text "\<rightarrow>"} and @{text "\<rightarrow>*"} steps. *}

lemma big_to_small:
  "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
proof (induction rule: big_step.induct)
  fix s show "(SKIP,s) \<rightarrow>* (SKIP,s)" by simp
next
  fix x a s show "(x ::= a,s) \<rightarrow>* (SKIP, s(x := aval a s))" by auto
next
  fix c1 c2 s1 s2 s3
  assume "(c1,s1) \<rightarrow>* (SKIP,s2)" and "(c2,s2) \<rightarrow>* (SKIP,s3)"
  thus "(c1;;c2, s1) \<rightarrow>* (SKIP,s3)" by (rule seq_comp)
next
  fix s::state and b c0 c1 t
  assume "bval b s"
  hence "(IF b THEN c0 ELSE c1,s) \<rightarrow> (c0,s)" by simp
  moreover assume "(c0,s) \<rightarrow>* (SKIP,t)"
  ultimately
  show "(IF b THEN c0 ELSE c1,s) \<rightarrow>* (SKIP,t)" by (metis star.simps)
next
  fix s::state and b c0 c1 t
  assume "\<not>bval b s"
  hence "(IF b THEN c0 ELSE c1,s) \<rightarrow> (c1,s)" by simp
  moreover assume "(c1,s) \<rightarrow>* (SKIP,t)"
  ultimately
  show "(IF b THEN c0 ELSE c1,s) \<rightarrow>* (SKIP,t)" by (metis star.simps)
next
  fix b c and s::state
  assume b: "\<not>bval b s"
  let ?if = "IF b THEN c;; WHILE b DO c ELSE SKIP"
  have "(WHILE b DO c,s) \<rightarrow> (?if, s)" by blast
  moreover have "(?if,s) \<rightarrow> (SKIP, s)" by (simp add: b)
  ultimately show "(WHILE b DO c,s) \<rightarrow>* (SKIP,s)" by(metis star.refl star.step)
next
  fix b c s s' t
  let ?w  = "WHILE b DO c"
  let ?if = "IF b THEN c;; ?w ELSE SKIP"
  assume w: "(?w,s') \<rightarrow>* (SKIP,t)"
  assume c: "(c,s) \<rightarrow>* (SKIP,s')"
  assume b: "bval b s"
  have "(?w,s) \<rightarrow> (?if, s)" by blast
  moreover have "(?if, s) \<rightarrow> (c;; ?w, s)" by (simp add: b)
  moreover have "(c;; ?w,s) \<rightarrow>* (SKIP,t)" by(rule seq_comp[OF c w])
  ultimately show "(WHILE b DO c,s) \<rightarrow>* (SKIP,t)" by (metis star.simps)
qed

text{* Each case of the induction can be proved automatically: *}
lemma  "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
proof (induction rule: big_step.induct)
  case Skip show ?case by blast
next
  case Assign show ?case by blast
next
  case Seq thus ?case by (blast intro: seq_comp)
next
  case IfTrue thus ?case by (blast intro: star.step)
next
  case IfFalse thus ?case by (blast intro: star.step)
next
  case WhileFalse thus ?case
    by (metis star.step star_step1 small_step.IfFalse small_step.While)
next
  case WhileTrue
  thus ?case
    by(metis While seq_comp small_step.IfTrue star.step[of small_step])
qed

lemma small1_big_continue:
  "cs \<rightarrow> cs' \<Longrightarrow> cs' \<Rightarrow> t \<Longrightarrow> cs \<Rightarrow> t"
apply (induction arbitrary: t rule: small_step.induct)
apply auto
done

lemma small_to_big:
  "cs \<rightarrow>* (SKIP,t) \<Longrightarrow> cs \<Rightarrow> t"
apply (induction cs "(SKIP,t)" rule: star.induct)
apply (auto intro: small1_big_continue)
done

text {*
  Finally, the equivalence theorem:
*}
theorem big_iff_small:
  "cs \<Rightarrow> t = cs \<rightarrow>* (SKIP,t)"
by(metis big_to_small small_to_big)

subsection "Final configurations and infinite reductions"

definition "final cs \<longleftrightarrow> \<not>(EX cs'. cs \<rightarrow> cs')"

lemma finalD: "final (c,s) \<Longrightarrow> c = SKIP"
apply(simp add: final_def)
apply(induction c)
apply blast+
done

lemma final_iff_SKIP: "final (c,s) = (c = SKIP)"
by (metis SkipE finalD final_def)

text{* Now we can show that @{text"\<Rightarrow>"} yields a final state iff @{text"\<rightarrow>"}
terminates: *}

lemma big_iff_small_termination:
  "(EX t. cs \<Rightarrow> t) \<longleftrightarrow> (EX cs'. cs \<rightarrow>* cs' \<and> final cs')"
by(simp add: big_iff_small final_iff_SKIP)

text{* This is the same as saying that the absence of a big step result is
equivalent with absence of a terminating small step sequence, i.e.\ with
nontermination.  Since @{text"\<rightarrow>"} is determininistic, there is no difference
between may and must terminate. *}

end


\<^marker>\<open>creator Bernhard Pöttinger\<close>

chapter \<open>PIP: Release\<close>
theory Pip_Release
imports Pip_Shared
begin

paragraph \<open>Verification of PIP release operation\<close>

(* attempt to avoid explicit applications plus_fi_ops_exists, elimination rules *)

lemma search23:
  fixes i1 i2 i3 :: "('a,'b :: cancel_comm_monoid_add) fi"
  assumes "i1 + (i2 + i3) \<noteq> bot"
  shows "i1 + i2 \<noteq> bot" "i1 + i3 \<noteq> bot" "i2 + i3 \<noteq> bot"
proof -
  show "i1 + i2 \<noteq> bot" using plus_fi_ops_exist(1)[of "i1 + i2" i3] using assms by (simp add: algebra_simps)
  have "i1 + i3 + i2 \<noteq> bot" using assms  by (simp add: algebra_simps)
  then show "i1 + i3 \<noteq> bot" using plus_fi_ops_exist(1)[of "i1 + i3" i2] by (simp add: algebra_simps)
  have "i2 + i3 + i1 \<noteq> bot" using assms  by (simp add: algebra_simps)
  then show "i2 + i3 \<noteq> bot" using plus_fi_ops_exist(1)[of "i2 + i3" i1] by (simp add: algebra_simps)
qed

lemma search23':
  fixes i1 i2 i3 :: "('a,'b :: cancel_comm_monoid_add) fi"
  assumes "i1 + i2 + i3 \<noteq> bot"
  shows "i1 + i2 \<noteq> bot" "i1 + i3 \<noteq> bot" "i2 + i3 \<noteq> bot"
proof -
  show "i1 + i2 \<noteq> bot" using plus_fi_ops_exist(1)[of "i1 + i2" i3] using assms by (simp add: algebra_simps)
  have "i1 + i3 + i2 \<noteq> bot" using assms  by (simp add: algebra_simps)
  then show "i1 + i3 \<noteq> bot" using plus_fi_ops_exist(1)[of "i1 + i3" i2] by (simp add: algebra_simps)
  have "i2 + i3 + i1 \<noteq> bot" using assms  by (simp add: algebra_simps)
  then show "i2 + i3 \<noteq> bot" using plus_fi_ops_exist(1)[of "i2 + i3" i1] by (simp add: algebra_simps)
qed

lemma Max_sup_in:
  assumes "finite B" "A \<subseteq> B" "Max B \<in> A"
  shows "Max A = Max B"
  using assms
  by (meson Max.coboundedI Max_eqI in_mono infinite_super)

lemma XD1:
  assumes "ixs + fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = xa then {#} else edge xa (Fields (\<eta> xa) (max q0 (Max (insert t (set_mset (m - {#f#}))))) q0 m) n m) \<noteq> bot"
    and "\<eta> xa \<noteq> Some xa" "Max (insert q0 (set_mset m)) = max q0 (Max (insert t (set_mset (m - {#f#}))))"
  shows "fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>y. if Some y = \<eta> xa then {#Max_mset (add_mset t (m - {#f#}) + {#q0#})#} else {#}) + ixs \<noteq> bot"
proof -
  have "fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>y. if Some y = \<eta> xa then {#Max_mset (add_mset t (m - {#f#}) + {#q0#})#} else {#}) =
        fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = xa then {#} else edge xa (Fields (\<eta> xa) (max q0 (Max (insert t (set_mset (m - {#f#}))))) q0 m) n m)"
    apply (rule fi_cong)
    using assms by (simp_all split: fields.splits)
  then show ?thesis
    using assms by (simp add: algebra_simps)
qed

lemma XD2:
  assumes "ixs + fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = xa then {#} else edge xa (Fields None (Max (insert x3 (set_mset m))) x3 m) n m) \<noteq> bot"
  shows "fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>y. {#}) + ixs \<noteq> bot"
proof -
  have "fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = xa then {#} else edge xa (Fields None (Max (insert x3 (set_mset m))) x3 m) n m) =
        fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>y. {#})"
    by (rule fi_cong, simp_all)
  then show ?thesis
    using assms by (simp add: algebra_simps)
qed

lemma XD3:
  assumes "N1 = N2" "\<forall>n \<in> N1. i1 n = i2 n" "\<forall>n \<in> -N1. o1 n = o2 n"
  shows "if1 + fi N1 i1 o1 = fi N2 i2 o2 + if1"
  using assms
  apply (simp add: algebra_simps)
  apply (rule arg_cong[OF fi_cong])
  by (simp_all add: algebra_simps)

lemma XD4:
  assumes "fi {xb} (\<lambda>_. mm) (\<lambda>y. edge xb (Fs xb) y mm) + i' +
       fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m) \<noteq>
       bot" and "xa \<noteq> xb"
  shows "fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>y. if y = xb then {#Max_mset (add_mset t (m - {#f#}) + {#q0#})#} else {#}) + i' \<noteq> bot"
proof -
  let ?f = "Max (insert q0 (set_mset m))"
  let ?t = "max q0 (Max (insert t (set_mset (m - {#f#}))))"

  let ?ia = "fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m)"
  let ?ia' = "fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>y. if y = xb then {#Max_mset (add_mset t (m - {#f#}) + {#q0#})#} else outf_fi (fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m)) y)"
  let ?ia'' = "fi {xa} (\<lambda>n. if n = xa then add_mset t (m - {#f#}) else {#}) (\<lambda>n. if n = xb then {#max q0 (Max (insert t (set_mset (m - {#f#}))))#} else outf_fi (fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m)) n)"

  let ?ia4 = "fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>y. if y = xb then {#Max_mset (add_mset t (m - {#f#}) + {#q0#})#} else {#})"
  have ia4_ia': "?ia4 = ?ia'"
    by (rule fi_cong, auto)

  let ?ib = "fi {xb} (\<lambda>_. mm) (\<lambda>y. edge xb (Fs xb) y mm)"
  let ?ib'' = "fi {xb}
   (\<lambda>n. add_mset (max q0 (Max (insert t (set_mset (m - {#f#})))))
        (inf_fi (fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m) + fi {xb} (\<lambda>_. mm) (\<lambda>y. edge xb (Fs xb) y mm)) n))
   (\<lambda>n. if n = xb then {#} else edge xb (Fs xb) n mm)"

  have X: "?ia' = ?ia''"
    by (rule fi_cong, auto)
  have XX: "(?ia + ?ib) + i' \<noteq> bot"
    using assms by (simp add: algebra_simps)
  have Y: "?ia + ?ib = ?ia'' + ?ib''"
    apply (rule adjust_interface'[of ?ia ?ib xa xb "{#?t#}", symmetric, simplified])
     apply (fact plus_fi_ops_exist(1)[OF XX]) using assms by simp
  then have Z: "(?ia'' + i') + ?ib'' \<noteq> bot"
    using XX by (simp add: algebra_simps)
  then have "?ia'' + i' \<noteq> bot"
    using plus_fi_ops_exist(1) by auto
  then show ?thesis
    using X assms by (simp add: ia4_ia')
qed

lemma onI:
  assumes "\<And>x. x \<in> X \<Longrightarrow> f x = g x"
  shows "f = g on X"
  using assms by blast

lemma plus_fi_cancel_left:
  assumes "i2 = i2'"
  shows "i1 + i2 = i1 + i2'"
  using assms by simp

lemma plus_fi_cancel_rigtht:
  assumes "i1 = i1'"
  shows "i1 + i2 = i1' + i2"
  using assms by simp

lemmas plus_fi_cancel = plus_fi_cancel_left plus_fi_cancel_right

lemma update_correct:
  fixes i ix ixs :: "(fields ref, int multiset) fi"
  assumes "finite (dom_fi i)" "V \<subseteq> dom_fi i"
    and "f \<in># inf_fi ix x" "\<forall>x \<in> V. f \<notin># fields_qs (Fs x)"
    and "x \<notin> xs"
    and "i = ixs + fi {x}
      (\<lambda>_. inf_fi ix x - {# f #} + (if t \<ge>0 then {# t #} else {#})) (outf_fi ix)"
    and "i \<noteq> bot" "f > t"
    and "\<forall>x' \<in> {x} \<union> xs. case \<eta> x' of Some y \<Rightarrow> y \<in> {x} \<union> xs | _ \<Rightarrow> True"
  shows "<ff.NI (\<eta> x) x (Fs x) m ix * ff.GrI \<eta> Fs xs ixs>
    update x f t
    <\<lambda>_. \<exists>\<^sub>AFs'. ff.GrI \<eta> Fs' ({x} \<union> xs) i>"
  using assms
  apply (induction V arbitrary: t Fs m ix ixs xs \<eta> rule: finite_induct_reverse[where F="dom_fi i" and a=x])

  (* base case*)
    apply (rule cons_pre_rule[OF ent_frame_fwd[OF ff.peek_NI]])
      apply frame_inference+
    apply clarsimp
  subgoal for x F t Fs m ix ixs xs \<eta> unfolding fields_qs_def by (cases "Fs x", auto)

  (* Step case! *)
  subgoal for xa F' t Fs m ix ixs xs \<eta>

    (* get domain of graph *)
    apply (rule cons_pre_rule[OF ent_frame_fwd[OF ff.GrI_dom]])
      apply frame_inference+
    apply clarsimp

    (* unfold function definition*)
    apply (subst update.simps)

    (* non-recursive case 1 *)
    apply (sep_auto simp: pip_simps heap: ll_simps split: fields.splits dest: in_diffD XD1)
    apply (intro ff.GrI_cong onI)
         apply simp
    apply simp
       apply auto[1]
      apply (rule XD3[symmetric])
        apply simp
    apply simp
    apply simp
    (* non-recursive case 2 *)
   apply (sep_auto simp: pip_simps heap: ll_simps split: fields.splits dest: XD2)
   apply (rule ff.GrI_cong[OF _ eq_on_refl])
      apply simp
    apply simp
    apply (simp add: algebra_simps, rule arg_cong[OF fi_cong], simp, simp, simp)

   apply (case_tac "xa \<in> F'")
   (* re-encounter some node *)
    apply (auto)[1]

  (* recursive case for t \<ge> 0 *)
  apply (sep_auto simp: pip_simps heap: ll_simps split: fields.splits dest: XD4)
  subgoal premises prems for q0 xb i' mm
  proof -
    let ?i1 = "fi {xb} (\<lambda>_. mm) (\<lambda>y. edge x (Fs x) y mm)"

    (* related to termination, involves non-trivial arguments *)
    have "m \<noteq> {#}" using prems by auto
    then have neq: "max q0 (Max (set_mset m)) \<noteq> max q0 (Max (insert t (set_mset (m - {#f#}))))"
      using prems by simp
    then have Z: "Max_mset m \<noteq> Max_mset (m - {#f#} + {#t#})" by simp
    have ZZ: "Max (set_mset m) = f" using Max_mset_add_remove[OF \<open>f \<in># m\<close> \<open>t < f\<close> Z[symmetric]] by simp

    have T: "Max_mset (m - {#f#} + {#t#}) \<le> Max_mset m" by (fact Max_mset_add_remove_le[OF \<open>f \<in># m\<close> \<open>t < f\<close>])

    have SS: "max q0 f \<le> f"
    proof (rule ccontr)
      assume "\<not> max q0 f \<le> f"
      then have "f < q0" by simp
      then have "Max (set_mset m) < q0" "Max_mset (m - {#f#} + {#t#}) < q0" using ZZ T by auto
      then have "max q0 (Max (set_mset m)) = max q0 (Max (insert t (set_mset (m - {#f#}))))"
        by (smt add_mset_add_single set_mset_add_mset_insert)
      then show False using neq by simp
    qed
    then have S: "Max (insert q0 (set_mset m)) = f"
      using \<open>m \<noteq> {#}\<close> ZZ by simp

    have SSS: "q0 < f"
      by (smt T ZZ add_mset_add_single neq set_mset_add_mset_insert)

    have LT': "Max_mset (m - {#f#} + {#t#}) < Max_mset m"
      by (fact Max_mset_add_remove_lt[OF \<open>f \<in># m\<close> \<open>t < f\<close> Z[symmetric]])
    then have LT: "max q0 (Max_mset (m - {#f#} + {#t#})) < Max_mset m"
      by (smt add_mset_add_single neq set_mset_add_mset_insert)

    let ?f = "Max (insert q0 (set_mset m))"
    let ?t = "max q0 (Max (insert t (set_mset (m - {#f#}))))"

    have tge0: "?t \<ge> 0" using prems by auto

    (* fake-interface manipulation of ?ia and ?ib, should be automated *)

    let ?ia = "fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m)"
    let ?ia2 = "fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>y. if y = xb then {#Max_mset (add_mset t (m - {#f#}) + {#q0#})#} else {#})"
    let ?ia3 = "fi {xa} (inf_fi (fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m)))
     (\<lambda>n. if n = xb then {#max q0 (Max (insert t (set_mset (m - {#f#}))))#} else outf_fi (fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m)) n)"

    have ia2_ia3: "?ia2 = ?ia3" by (rule fi_cong, auto)

    let ?ib = "fi {xb} (\<lambda>_. mm) (\<lambda>y. edge xb (Fs xb) y mm)"
    let ?ib2 = "fi {xb} (\<lambda>_. inf_fi (fi {xb} (\<lambda>_. mm) (\<lambda>y. edge xb (Fs xb) y mm)) xb + (if 0 \<le> max q0 (Max (insert t (set_mset (m - {#f#})))) then {#max q0 (Max (insert t (set_mset (m - {#f#}))))#} else {#}) - {#f#}) (outf_fi (fi {xb} (\<lambda>_. mm) (\<lambda>y. edge xb (Fs xb) y mm)))"
    let ?ib3 = "fi {xb}
     (\<lambda>n. inf_fi (fi {xb} (\<lambda>_. mm) (\<lambda>y. edge xb (Fs xb) y mm)) n - outf_fi (fi {xa} (\<lambda>_. add_mset t (m - {#f#})) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m)) n +
           {#max q0 (Max (insert t (set_mset (m - {#f#}))))#})
     (outf_fi (fi {xb} (\<lambda>_. mm) (\<lambda>y. edge xb (Fs xb) y mm)))"

    have ib2_ib3: "?ib2 = ?ib3" apply (rule fi_cong) using tge0 S prems by auto

    (* this stuff about the existence of flow interfaces should be automated,
       no idea how to, some idas provided some improvement, this stuff is remaining *)

    have nbot_iaibi': "(?ia + ?ib) + i' \<noteq> bot"
      using prems by (simp add: algebra_simps)
    have nbot_iaib: "?ia + ?ib \<noteq> bot"
      using plus_fi_ops_exist(1)[OF nbot_iaibi'] by simp

    have iaib_ia2ib2: "?ia + ?ib = ?ia2 + ?ib2"
      using adjust_interface_mset'[of ?ia ?ib xa xb "{#?t#}"] ib2_ib3 ia2_ia3 nbot_iaib prems by simp
    then have nbot_ia2ib2: "?ia2 + ?ib2 + i' \<noteq> bot"
      using nbot_iaibi' by (simp add: algebra_simps)

    have nbot_ib_i'ia2: "?ib2 + (i'  + ?ia2) \<noteq> bot"
      using prems iaib_ia2ib2 by (simp add: algebra_simps)

    have nbot: "?i1 \<noteq> bot" "i' \<noteq> bot" "?ib + i' \<noteq> bot" "i' + ?ia \<noteq> bot" "i' + ?ia2 \<noteq> bot"
      using prems nbot_ib_i'ia2 by (auto elim!: search23 search23' simp: prems algebra_simps)

    (* again part of termination *)

    have *: "(?ib + ?ia) + i' \<noteq> bot"
      using prems by (simp add: algebra_simps)
    then have "?ib + ?ia \<noteq> bot"
      using plus_fi_ops_exist[OF *] by simp
    then have "inf_fi ?ib xb = inf_fi (?ib + ?ia) xb + outf_fi ?ia xb"
      using unfold_inf_fi[of ?ib ?ia xb] by simp
    then have f_in_mm: "f \<in># mm"
      apply (simp split: if_splits)
      using prems apply simp
      using S by (metis (no_types, lifting) union_single_eq_member)

    have SSSS: "\<forall>x \<in># m - {#f#}. x < f"
      using ZZ LT' by auto

    show ?thesis
      apply (subst (1) S)
      using prems iaib_ia2ib2 f_in_mm tge0 SSS nbot SSSS
      apply (sep_auto heap: ent_star_mono[OF _ ff.GrI_cong] cons_rule[OF _ _
       prems(1)[of _ xb "\<lambda>y. if y = xa then Fields (Some xb) (max q0 (Max (insert t (set_mset (m - {#f#}))))) q0 (add_mset t (m - {#f#})) else Fs y" "insert xa (dom_fi ixs - {xb})"]]
        simp: tge0 algebra_simps iaib_ia2ib2 nbot intro!: fi_cong ff.GrI_cong split: fields.splits)
    apply (auto split: option.splits simp: nbot algebra_simps)
    done
  qed

 (* recursive case for t < 0, symmetric to above case, in certain aspects nastier than
    above case due to multiset reasoning, case should be eliminated by avoiding the case split
    caused by sep_auto *)
    apply (subst update.simps)
  apply (sep_auto simp: pip_simps heap: ll_simps ff.fold_GrI_rule[where g="\<eta> xa"] split: fields.splits dest: in_diffD XD1 intro: XD2 XD3)
  subgoal premises prems for q0
  proof -
    have "fi {xa} (\<lambda>_. m - {#f#}) (\<lambda>y. if Some y = \<eta> xa then {#Max_mset (m - {#f#} + {#q0#})#} else {#}) =
          fi {xa} (\<lambda>_. m - {#f#}) (\<lambda>n. if n = xa then {#} else edge xa (Fields (\<eta> xa) (Max (insert q0 (set_mset (m - {#f#})))) q0 m) n m)"
      by (rule fi_cong, auto simp: prems)
    then show ?thesis using prems by (simp add: algebra_simps)
  qed
  apply simp
      apply auto[1]
   apply (rule ent_ex_postI)
  apply (rule ff.GrI_cong[OF _ eq_on_refl])
     apply simp
    apply simp
  subgoal premises prems for q0 xb
  proof -
    let ?i1 = "fi {xa} (\<lambda>_. m - {#f#}) (\<lambda>n. if n = xa then {#} else edge xa (Fields (\<eta> xa) (Max (insert q0 (set_mset (m - {#f#})))) q0 m) n m)"
    let ?i2 = "fi {xa} (\<lambda>_. m - {#f#}) (\<lambda>y. if Some y = \<eta> xa then {#Max_mset (m - {#f#} + {#q0#})#} else {#})"
    have "?i1 = ?i2" by (rule fi_cong, auto simp: prems)
    then show ?thesis by (simp add: algebra_simps)
  qed

  apply (sep_auto simp: pip_simps heap: ll_simps ff.fold_GrI_rule[where g="\<eta> xa"] split: fields.splits)
  subgoal premises prems for q0
  proof -
    have "fi {xa} (\<lambda>_. m - {#f#}) (\<lambda>y. {#}) =
          fi {xa} (\<lambda>_. m - {#f#}) (\<lambda>n. if n = xa then {#} else edge xa (Fields None (Max (insert q0 (set_mset m))) q0 m) n m)"
      by (rule fi_cong, auto simp: prems)
    then show ?thesis using prems by (simp add: algebra_simps)
  qed
  apply simp
  apply simp
    apply (rule ent_ex_postI)
  apply clarsimp
   apply (rule ff.GrI_cong[OF _ eq_on_refl])
      apply simp
    apply simp
  apply (simp add: algebra_simps, rule arg_cong[OF fi_cong], simp, simp, simp)
  apply (sep_auto simp: pip_simps heap: ll_simps ff.fold_GrI_rule[where g="\<eta> xa"] split: fields.splits)
  subgoal premises prems for x3 x i' mm
  proof -
    let ?i1 = "fi {xa} (\<lambda>_. m - {#f#}) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some x) (Max (insert x3 (set_mset m))) x3 m) n m)"
    let ?i2 = "fi {x} (\<lambda>_. mm) (\<lambda>y. edge x (Fs x) y mm)"

    let ?i1'' = "fi {xa} (\<lambda>_. m - {#f#}) (\<lambda>y. if y = x then {#Max_mset (m - {#f#} + {#x3#})#} else {#})"

    let ?i1' = "fi {xa} (inf_fi (fi {xa} (\<lambda>_. m - {#f#}) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some x) (Max (insert x3 (set_mset m))) x3 m) n m)))
   (\<lambda>n. if n = x then {#Max_mset (m - {#f#} + {#x3#})#} else outf_fi (fi {xa} (\<lambda>_. m - {#f#}) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some x) (Max (insert x3 (set_mset m))) x3 m) n m)) n)"
    let ?i2' = "fi {x}
     (\<lambda>n. inf_fi (fi {xa} (\<lambda>_. m - {#f#}) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some x) (Max (insert x3 (set_mset m))) x3 m) n m) + fi {x} (\<lambda>_. mm) (\<lambda>y. edge x (Fs x) y mm)) n +
           {#Max_mset (m - {#f#} + {#x3#})#})
     (outf_fi (fi {x} (\<lambda>_. mm) (\<lambda>y. edge x (Fs x) y mm)))"

    have A: "?i1' = ?i1''"
      apply (rule fi_cong)
        apply simp
       apply simp
      by simp

    have "?i1 + ?i2 + i' \<noteq> bot" using prems by (simp add: algebra_simps)
    then have E: "?i1 + ?i2 \<noteq> bot" using search23'[of ?i1 ?i2 i'] by simp

    have B: "?i1' + ?i2' = ?i1 + ?i2"
      apply (rule adjust_interface'[of ?i1 ?i2 xa x "{#Max_mset (m - {#f#} + {#x3#})#}"])
      using E apply simp
        apply simp
       apply simp
      using prems by blast

    have "?i1' + ?i2' + i' \<noteq> bot" using prems E B by (simp add: algebra_simps)
    then have "?i1'' + i' \<noteq> bot" using search23'[of ?i1' ?i2' i'] A by simp
    then show ?thesis using prems by (simp add: algebra_simps)
  qed

    apply simp
  apply simp
  subgoal premises prems for q0 xb i' i1 mm xaa
  proof -
    have S: "Max (insert q0 (set_mset m)) = f"
    proof -
      have "Max (insert q0 (set_mset m)) \<noteq> Max (insert q0 (set_mset (m - {#f#})))" using prems by blast
      show ?thesis
      proof (rule ccontr)
        let ?S = "insert q0 (set_mset m)"
        let ?m = "Max ?S"
        assume "?m \<noteq> f"
        then have "?m \<ge> f" "?m \<in> ?S" using \<open>f \<in># m\<close>
          by (simp, meson Max_in finite_insert finite_set_mset insert_not_empty)
        then have *: "?m > f" using \<open>Max (insert q0 (set_mset m)) \<noteq> f\<close> by linarith
        then have **: "?m \<in> insert q0 (set_mset (m - {#f#}))"
          by (smt \<open>Max (insert q0 (set_mset m)) \<in> insert q0 (set_mset m)\<close> insert_DiffM2 insert_iff mset_right_cancel_elem prems)
        moreover have X: "insert q0 (set_mset (m - {#f#})) \<subseteq> insert q0 (set_mset m)" using \<open>f \<in># m\<close>
          by (metis insert_DiffM insert_mono set_mset_add_mset_insert subset_insertI)
        have "Max (insert q0 (set_mset (m - {#f#}))) = ?m"
          apply (rule Max_sup_in[OF _ X]) using ** by auto
        then show False using prems by simp
      qed
    qed

    let ?ia = "fi {xa} (\<lambda>_. m - {#f#}) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m)"
    let ?ia' = "fi {xa} (\<lambda>_. m - {#f#}) (\<lambda>y. if y = xb then {#Max_mset (m - {#f#} + {#q0#})#} else {#})"
    let ?ia'' = "fi {xa} (inf_fi (fi {xa} (\<lambda>_. m - {#f#}) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m)))
   (\<lambda>n. if n = xb then {#Max_mset (m - {#f#} + {#q0#})#} else outf_fi (fi {xa} (\<lambda>_. m - {#f#}) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m)) n)"

    let ?ib = "fi {xb} (\<lambda>_. mm) (\<lambda>y. edge xb (Fs xb) y mm)"
    let ?ib'' = "fi {xb}
   (\<lambda>n. inf_fi (fi {xa} (\<lambda>_. m - {#f#}) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m) + fi {xb} (\<lambda>_. mm) (\<lambda>y. edge xb (Fs xb) y mm)) n +
         {#Max_mset (m - {#f#} + {#q0#})#})
   (outf_fi (fi {xb} (\<lambda>_. mm) (\<lambda>y. edge xb (Fs xb) y mm)))"

    have "?ia + ?ib + i' \<noteq> bot" using prems by (simp add: algebra_simps)
    then have nbot: "?ib + i' \<noteq> bot" "?ia + ?ib \<noteq> bot" "?ia + i' \<noteq> bot" using search23' by blast+

    let ?ib3 = "fi {xb} (\<lambda>_. add_mset (Max (insert q0 (set_mset (m - {#f#})))) mm - {#f#}) (\<lambda>n. if n = xb then {#} else edge xb (Fs xb) n mm)"
    let ?ib4 = "fi {xb} (\<lambda>_. inf_fi (fi {xb} (\<lambda>_. mm) (\<lambda>y. edge xb (Fs xb) y mm)) xb + (if 0 \<le> Max (insert q0 (set_mset (m - {#f#}))) then {#Max (insert q0 (set_mset (m - {#f#})))#} else {#}) - {#f#})
     (outf_fi (fi {xb} (\<lambda>_. mm) (\<lambda>y. edge xb (Fs xb) y mm)))"

    let ?t = "Max (insert q0 (set_mset (m - {#f#})))"
    have G: "0 \<le> ?t"
      apply (rule order_trans[OF _ Max_ge[of _ q0]])
      using prems by auto

    have L: "Max (insert q0 (set_mset (m - {#f#}))) < f"
    proof -
      have "Max (insert q0 (set_mset m)) \<noteq> Max (insert q0 (set_mset (m - {#f#})))"
        using prems by blast

      show ?thesis
      proof (rule ccontr)
        let ?m = "Max (insert q0 (set_mset (m - {#f#})))"
        assume "\<not> Max (insert q0 (set_mset (m - {#f#}))) < f"
        then have X: "?m \<ge> f" by linarith
        then have "?m \<in> insert q0 (set_mset m)"
          by (metis Max_in empty_not_insert finite_set_mset insertCI insertE insert_DiffM prems(2) set_mset_add_mset_insert)
        with X show False
          by (smt Max.coboundedI S finite.insertI finite_set_mset prems)
      qed
    qed
    then have notin: "f \<notin># m - {#f#}"
      by auto

    have MM: "mm = add_mset (Max (insert q0 (set_mset m))) (inf_fi (?ib + ?ia) xb)"
      using prems unfold_inf_fi[of ?ib ?ia xb] nbot by (simp add: algebra_simps)
    then have F: "f \<in># mm" using S by (metis (no_types, lifting) union_single_eq_member)

    let ?ia4 = "fi {xa} (inf_fi (fi {xa} (\<lambda>_. m - {#f#}) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m)))
   (\<lambda>n. if n = xb then {#Max (insert q0 (set_mset (m - {#f#})))#} else outf_fi (fi {xa} (\<lambda>_. m - {#f#}) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m)) n)"
    let ?ib4 = "fi {xb}
   (\<lambda>n. inf_fi (fi {xb} (\<lambda>_. mm) (\<lambda>y. edge xb (Fs xb) y mm)) n - outf_fi (fi {xa} (\<lambda>_. m - {#f#}) (\<lambda>n. if n = xa then {#} else edge xa (Fields (Some xb) (Max (insert q0 (set_mset m))) q0 m) n m)) n +
         {#Max (insert q0 (set_mset (m - {#f#})))#})
   (outf_fi (fi {xb} (\<lambda>_. mm) (\<lambda>y. edge xb (Fs xb) y mm)))"

    have T: "?ia4 + ?ib4 = ?ia + ?ib"
      apply (rule adjust_interface_mset'[of ?ia ?ib xa xb "{#?t#}"])
      using nbot apply simp
        apply simp
       apply simp
      using prems by blast

    have A: "?ia4 = ?ia'" by (rule fi_cong, auto)

    have BB: "?ib3 = ?ib4"
      apply (rule fi_cong, simp)
      using nbot G prems S apply simp
      by simp

    have X: "?ia' + ?ib3 = ?ia + ?ib"
      using T A BB by (simp add: algebra_simps)

    have "?ia' + ?ib4 + i' \<noteq> bot"
      using T A nbot prems by (auto simp: algebra_simps)
    then have nbot': "i' + ?ia' \<noteq> bot"
      using search23[of ?ia' ?ib4 i'] by (simp add: algebra_simps)

    have D: "dom_fi (?ib + i') = dom_fi i' \<union> {xb}" "dom_fi i' \<union> {xb} = dom_fi ixs" "dom_fi (i' + ?ia') = dom_fi i' \<union> {xa}"
      using nbot prems nbot' by (auto simp: algebra_simps)

    show ?thesis
      apply (subst S)
      apply (rule cons_rule[OF _ _
       prems(1)[of _ xb "\<lambda>y. if y = xa then Fields (Some xb) (Max (set_mset (m - {#f#} + {# q0 #}))) q0 (m - {#f#}) else Fs y" "insert xa (dom_fi ixs - {xb})"]])
                 apply (simp add: algebra_simps prems)
                 apply (rule ent_star_mono[OF ent_refl ff.GrI_cong])
                    apply simp
                   apply simp
                  apply simp
                 apply simp
      subgoal
        apply (rule ent_ex_preI)
        apply (rule_tac x=Fs' in ent_ex_postI)
        apply (rule ff.GrI_cong)
           apply simp
          apply simp
        using D apply auto[1]
        using prems X G by (simp add: algebra_simps)
      using F apply simp
      using prems notin apply (auto split: fields.splits)[1]
      using X G prems apply (simp add: algebra_simps)
      using X G prems apply (simp add: algebra_simps)
      using X G prems apply (simp add: algebra_simps)
      using L apply blast
      using D apply (simp add: algebra_simps prems)
      apply auto[1]
      using prems apply (auto split: option.splits)[1]
      by (metis (no_types) Un_Diff_cancel Un_insert_left Un_insert_right ab_semigroup_add_class.add.commute insert_absorb2 insert_iff prems)
  qed
  done

  using assms apply simp

  done

lemmas pip_simps' = pip_simps fields_y'_def

lemma release_correct:
  assumes "p \<in> X" "r \<in> X" "p \<noteq> r" " \<eta> r = Some p" "i \<noteq> bot"
    and "\<forall>x \<in> X. case \<eta> x of Some y \<Rightarrow> y \<in> X | _ \<Rightarrow> True"
  shows "<ff.GrI \<eta> Fs X i>
    release p r
    <\<lambda>_. \<exists>\<^sub>AFs'. ff.GrI (\<eta>(r := None)) Fs' X i>"
    unfolding release_def
  apply (rule cons_pre_rule[OF ent_frame_fwd[OF ff.GrI_dom]], frame_inference+)
  apply (sep_auto simp: pip_simps' heap: ll_simps split: fields.splits)
  using assms apply simp
  using assms apply simp
  apply (sep_auto simp: pip_simps' heap: ll_simps split: fields.splits)
  using assms apply simp
  using assms apply simp
  using assms dom_fi_plus_fi(2) apply fastforce
  apply (sep_auto simp: pip_simps' heap: ll_simps split: fields.splits)
  subgoal premises prems for m i'a x3 x4
  proof -
    let ?ir = "fi {r} (\<lambda>_. x4) (\<lambda>y. if Some y = \<eta> r then {#Max_mset (x4 + {#x3#})#} else {#})"
    let ?ir' = "fi {r} (inf_fi (fi {r} (\<lambda>_. x4) (\<lambda>y. if Some y = \<eta> r then {#Max_mset (x4 + {#x3#})#} else {#}))) (\<lambda>n. if n = p then 0 else outf_fi (fi {r} (\<lambda>_. x4) (\<lambda>y. if Some y = \<eta> r then {#Max_mset (x4 + {#x3#})#} else {#})) n)"
    let ?ir2 = "fi {r} (\<lambda>_. x4) (\<lambda>y. {#})"
    let ?ip = "fi {p} (\<lambda>_. m) (\<lambda>y. edge p (Fs p) y m)"
    let ?ip' = "fi {p} (\<lambda>n. inf_fi (fi {r} (\<lambda>_. x4) (\<lambda>y. if Some y = \<eta> r then {#Max_mset (x4 + {#x3#})#} else {#}) + fi {p} (\<lambda>_. m) (\<lambda>y. edge p (Fs p) y m)) n + {#}) (outf_fi (fi {p} (\<lambda>_. m) (\<lambda>y. edge p (Fs p) y m)))"

    have ir'_ir2: "?ir' = ?ir2"
      apply (rule fi_cong, auto)
      using assms prems by auto

    have "(?ir + ?ip) + i'a \<noteq> bot" using assms prems by (simp add: algebra_simps)
    then have nbot: "?ir + ?ip \<noteq> bot" using plus_fi_ops_exist(1) by blast
    have "?ir2 + ?ip' = ?ir + ?ip" using assms adjust_interface'[of ?ir ?ip r p 0, OF nbot] ir'_ir2 by simp
    then have "?ir2 + (?ip' + i'a) \<noteq> bot" using prems assms by (simp add: algebra_simps)
    then have "?ip' + (?ir2 + i'a) \<noteq> bot" by (simp add: algebra_simps)
    then have "?ir2 + i'a \<noteq> bot" using plus_fi_ops_exist(2) by blast
    with prems show False by simp
  qed
     apply (cases "Fs r", simp)
    apply (cases "Fs r", simp)
   apply simp

  subgoal for m i'a x3 x4

    apply (rule cons_rule[OF _ _ update_correct[where V="{}"]])
    using assms apply (simp add: algebra_simps, frame_inference)

                 apply (rule ent_ex_preI)
                 apply (rule_tac x=Fs' in ent_ex_postI)
                 apply (rule ff.GrI_cong _ eq_on_refl)
                    apply simp
               apply simp
              apply blast
             apply simp
            apply simp
    apply simp
    subgoal premises prems proof -
      let ?ip = "fi {p} (\<lambda>_. m) (\<lambda>y. edge p (Fs p) y m)"
      let ?ir = "fi {r} (\<lambda>_. x4) (\<lambda>y. if Some y = \<eta> r then {#Max_mset (x4 + {#x3#})#} else {#})"
      have nbot: "?ip + ?ir \<noteq> bot" using prems search23 assms by (simp add: algebra_simps)

      have "outf_fi ?ir p = {#Max_mset (x4 + {#x3#})#}" using assms by simp
      then have "inf_fi ?ip p = inf_fi (?ip + ?ir) p + {#Max_mset (x4 + {#x3#})#}"
        using nbot unfold_inf_fi[of ?ip ?ir p] by simp
      then show ?thesis
        by (smt ab_semigroup_add_class.add.commute add.right_neutral add_diff_cancel_right'
            mset_contains_eq set_mset_add_mset_insert union_mset_add_mset_right)
    qed
         apply simp
    using assms apply simp
    subgoal premises prems proof -
      let ?ip = "fi {p} (\<lambda>_. m) (\<lambda>y. edge p (Fs p) y m)"
      let ?ip2 = "fi {p} (\<lambda>_. m - {#Max (insert x3 (set_mset x4))#}) (\<lambda>n. if n = p then {#} else edge p (Fs p) n m)"
      let ?ip3 = "fi {p} (\<lambda>n. inf_fi (fi {p} (\<lambda>_. m) (\<lambda>y. edge p (Fs p) y m)) n - outf_fi (fi {r} (\<lambda>_. x4) (\<lambda>y. if Some y = \<eta> r then {#Max_mset (x4 + {#x3#})#} else {#})) n + {#}) (outf_fi (fi {p} (\<lambda>_. m) (\<lambda>y. edge p (Fs p) y m)))"
      have A: "?ip2 = ?ip3" by (rule fi_cong, auto simp: prems assms)

      let ?ir = "fi {r} (\<lambda>_. x4) (\<lambda>y. if Some y = \<eta> r then {#Max_mset (x4 + {#x3#})#} else {#})"
      let ?ir2 = "fi {r} (\<lambda>_. x4) (\<lambda>y. {#})"
      let ?ir3 = "fi {r} (inf_fi (fi {r} (\<lambda>_. x4) (\<lambda>y. if Some y = \<eta> r then {#Max_mset (x4 + {#x3#})#} else {#}))) (\<lambda>n. if n = p then {#} else outf_fi (fi {r} (\<lambda>_. x4) (\<lambda>y. if Some y = \<eta> r then {#Max_mset (x4 + {#x3#})#} else {#})) n)"
      have B: "?ir2 = ?ir3" by (rule fi_cong, auto simp: prems assms)

      have *: "(?ip + ?ir) + i'a \<noteq> bot" using prems assms by (simp add: algebra_simps)

      have "?ip + ?ir = ?ip2 + ?ir2"
        using adjust_interface_mset'[of ?ir ?ip r p "{#}"] A B prems assms plus_fi_ops_exist(1)[OF *]
        by (simp add: algebra_simps)
      with assms prems show ?thesis
        by (simp add: algebra_simps)
    qed
    subgoal premises prems proof -
      let ?ip = "fi {p} (\<lambda>_. m) (\<lambda>y. edge p (Fs p) y m) "
      let ?ir = "fi {r} (\<lambda>_. x4) (\<lambda>y. if y = p then {#Max_mset (x4 + {#x3#})#} else {#})"
      have *: "(?ip + ?ir) + i'a \<noteq> bot" using prems assms by (simp add: algebra_simps)
      show ?thesis using plus_fi_ops_exist(1)[OF *] assms prems by simp
    qed
           apply (smt Max_ge finite_insert finite_set_mset insertI1)
    subgoal premises prems proof -
      let ?ip = "fi {p} (\<lambda>_. m) (\<lambda>y. edge p (Fs p) y m)"
      let ?ir = "fi {r} (\<lambda>_. x4) (\<lambda>y. if Some y = \<eta> r then {#Max_mset (x4 + {#x3#})#} else {#})"
      have "?ip + ?ir \<noteq> bot" using prems search23 assms by (simp add: algebra_simps)
      with assms prems show ?thesis by (auto split: option.splits)
    qed
  done
  done

end


theory RT
  imports Main FL.Finite_Linear
begin

section \<open>Refusal Traces\<close>

datatype 'e rtevent = TickRT | EventRT 'e

datatype 'e rtrefusal = RefNil ("\<bullet>\<^sub>\<R>\<^sub>\<T>") | RefSet "'e set" ("[_]\<^sub>\<R>\<^sub>\<T>")

lemma rtrefusal_cases2:
  "(x = (\<bullet>\<^sub>\<R>\<^sub>\<T>, \<bullet>\<^sub>\<R>\<^sub>\<T>) \<Longrightarrow> P) \<Longrightarrow>
    (\<And>Y. x = (\<bullet>\<^sub>\<R>\<^sub>\<T>, [Y]\<^sub>\<R>\<^sub>\<T>) \<Longrightarrow> P) \<Longrightarrow>
    (\<And>X. x = ([X]\<^sub>\<R>\<^sub>\<T>, \<bullet>\<^sub>\<R>\<^sub>\<T>) \<Longrightarrow> P) \<Longrightarrow>
    (\<And>X Y. x = ([X]\<^sub>\<R>\<^sub>\<T>, [Y]\<^sub>\<R>\<^sub>\<T>) \<Longrightarrow> P) \<Longrightarrow> P"
  by (cases x, auto, case_tac a, case_tac b, simp_all, case_tac b, simp_all)

datatype 'e rttrace  = RTRefusal "'e rtrefusal" ("\<langle>_\<rangle>\<^sub>\<R>\<^sub>\<T>") | RTEvent "'e rtrefusal" "'e" "'e rttrace" ("_ #\<^sub>\<R>\<^sub>\<T> _ #\<^sub>\<R>\<^sub>\<T> _" [65,66,67] 65)

fun in_rtrefusal :: "'e \<Rightarrow> 'e rtrefusal \<Rightarrow> bool" (infix "\<in>\<^sub>\<R>\<^sub>\<T>" 50)  where
  "e \<in>\<^sub>\<R>\<^sub>\<T> \<bullet>\<^sub>\<R>\<^sub>\<T> = False" |
  "e \<in>\<^sub>\<R>\<^sub>\<T> [X]\<^sub>\<R>\<^sub>\<T> = (e \<in> X)"

fun subset_refusal :: "'e rtrefusal \<Rightarrow> 'e rtrefusal \<Rightarrow> bool" (infix "\<subseteq>\<^sub>\<R>\<^sub>\<T>" 50)  where
  "\<bullet>\<^sub>\<R>\<^sub>\<T> \<subseteq>\<^sub>\<R>\<^sub>\<T> y = True" |
  "[X]\<^sub>\<R>\<^sub>\<T> \<subseteq>\<^sub>\<R>\<^sub>\<T> \<bullet>\<^sub>\<R>\<^sub>\<T> = False" |
  "[X]\<^sub>\<R>\<^sub>\<T> \<subseteq>\<^sub>\<R>\<^sub>\<T> [Y]\<^sub>\<R>\<^sub>\<T> = (X \<subseteq> Y)"

type_synonym 'e rtprocess = "'e rttrace set"

fun rtWF :: "'e rttrace \<Rightarrow> bool" where
  "rtWF \<langle>X\<rangle>\<^sub>\<R>\<^sub>\<T> = True" |
  "rtWF (X #\<^sub>\<R>\<^sub>\<T> e #\<^sub>\<R>\<^sub>\<T> \<rho>) = (\<not> e \<in>\<^sub>\<R>\<^sub>\<T> X \<and> rtWF \<rho>)"

lemma rttrace_cases:
  "(x = \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> \<Longrightarrow> P) \<Longrightarrow>
    (\<And>X. x = \<langle>[X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> \<Longrightarrow> P) \<Longrightarrow>
    (\<And>a \<rho>. x = \<bullet>\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> \<rho> \<Longrightarrow> P) \<Longrightarrow>
    (\<And>X a \<rho>. x = [X]\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> \<rho> \<Longrightarrow> P) \<Longrightarrow> P"
  by (cases x, auto, case_tac x1, auto, case_tac x21, auto)

lemma rttrace_cases2:
  "(x = (\<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>, \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>) \<Longrightarrow> P) \<Longrightarrow>
    (\<And>Y. x = (\<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>, \<langle>[Y]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>) \<Longrightarrow> P) \<Longrightarrow>
    (\<And>b \<sigma>. x = (\<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>, \<bullet>\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> b #\<^sub>\<R>\<^sub>\<T> \<sigma>) \<Longrightarrow> P) \<Longrightarrow>
    (\<And>Y b \<sigma>. x = (\<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>, [Y]\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> b #\<^sub>\<R>\<^sub>\<T> \<sigma>) \<Longrightarrow> P) \<Longrightarrow>
    (\<And>X. x = (\<langle>[X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>, \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>) \<Longrightarrow> P) \<Longrightarrow>
    (\<And>X Y. x = (\<langle>[X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>, \<langle>[Y]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>) \<Longrightarrow> P) \<Longrightarrow>
    (\<And>X b \<sigma>. x = (\<langle>[X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>, \<bullet>\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> b #\<^sub>\<R>\<^sub>\<T> \<sigma>) \<Longrightarrow> P) \<Longrightarrow>
    (\<And>X Y b \<sigma>. x = (\<langle>[X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>, [Y]\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> b #\<^sub>\<R>\<^sub>\<T> \<sigma>) \<Longrightarrow> P) \<Longrightarrow>
    (\<And>a \<rho>. x = (\<bullet>\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> \<rho>, \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>) \<Longrightarrow> P) \<Longrightarrow>
    (\<And>a \<rho> Y. x = (\<bullet>\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> \<rho>, \<langle>[Y]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>) \<Longrightarrow> P) \<Longrightarrow>
    (\<And>a \<rho> b \<sigma>. x = (\<bullet>\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> \<rho>, \<bullet>\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> b #\<^sub>\<R>\<^sub>\<T> \<sigma>) \<Longrightarrow> P) \<Longrightarrow>
    (\<And>a \<rho> Y b \<sigma>. x = (\<bullet>\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> \<rho>, [Y]\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> b #\<^sub>\<R>\<^sub>\<T> \<sigma>) \<Longrightarrow> P) \<Longrightarrow>
    (\<And>X a \<rho>. x = ([X]\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> \<rho>, \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>) \<Longrightarrow> P) \<Longrightarrow>
    (\<And>X a \<rho> Y. x = ([X]\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> \<rho>, \<langle>[Y]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>) \<Longrightarrow> P) \<Longrightarrow>
    (\<And>X a \<rho> b \<sigma>. x = ([X]\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> \<rho>, \<bullet>\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> b #\<^sub>\<R>\<^sub>\<T> \<sigma>) \<Longrightarrow> P) \<Longrightarrow>
    (\<And>X a \<rho> Y b \<sigma>. x = ([X]\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> \<rho>, [Y]\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> b #\<^sub>\<R>\<^sub>\<T> \<sigma>) \<Longrightarrow> P) \<Longrightarrow> P"
  by (cases x, auto, case_tac a rule:rttrace_cases, simp_all, (case_tac b rule:rttrace_cases, simp_all)+)

section \<open>Healthiness Conditions\<close>

subsection \<open>MRT0\<close>

definition MRT0 :: "'e rtprocess \<Rightarrow> bool" where
  "MRT0 P = (\<langle> \<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> \<in> P)"

subsection \<open>RT1\<close>

fun leq_rttrace :: "'e rttrace \<Rightarrow> 'e rttrace \<Rightarrow> bool" (infix "\<le>\<^sub>\<R>\<^sub>\<T>" 50) where
  "\<langle> \<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>             \<le>\<^sub>\<R>\<^sub>\<T> \<sigma>                   = True" |
  "\<langle> [X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>           \<le>\<^sub>\<R>\<^sub>\<T> \<langle> [Y]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>           = (X \<subseteq> Y)" |
  "\<langle> [X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>           \<le>\<^sub>\<R>\<^sub>\<T> \<langle> \<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>             = False" |
  "\<langle> [X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>           \<le>\<^sub>\<R>\<^sub>\<T> ( [Y]\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> b #\<^sub>\<R>\<^sub>\<T> \<sigma>) = (X \<subseteq> Y)" |
  "\<langle> [X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>           \<le>\<^sub>\<R>\<^sub>\<T> ( \<bullet>\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> b #\<^sub>\<R>\<^sub>\<T> \<sigma>)   = False" |
  "( \<bullet>\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> \<rho>)   \<le>\<^sub>\<R>\<^sub>\<T> ( \<bullet>\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> b #\<^sub>\<R>\<^sub>\<T> \<sigma>)   = (a = b \<and> \<rho> \<le>\<^sub>\<R>\<^sub>\<T> \<sigma>)" |
  "( \<bullet>\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> \<rho>)   \<le>\<^sub>\<R>\<^sub>\<T> ( [Y]\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> b #\<^sub>\<R>\<^sub>\<T> \<sigma>) = (a = b \<and> \<rho> \<le>\<^sub>\<R>\<^sub>\<T> \<sigma>)" |
  "( [X]\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> \<rho>) \<le>\<^sub>\<R>\<^sub>\<T> ( [Y]\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> b #\<^sub>\<R>\<^sub>\<T> \<sigma>) = (X \<subseteq> Y \<and> a = b \<and> \<rho> \<le>\<^sub>\<R>\<^sub>\<T> \<sigma>)" |
  "( [X]\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> \<rho>) \<le>\<^sub>\<R>\<^sub>\<T> ( \<bullet>\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> b #\<^sub>\<R>\<^sub>\<T> \<sigma>)   = False" |
  "( x #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> \<rho>)     \<le>\<^sub>\<R>\<^sub>\<T> \<langle>y\<rangle>\<^sub>\<R>\<^sub>\<T>                = False"

lemma leq_rttrace_refl: "x \<le>\<^sub>\<R>\<^sub>\<T> x"
  by (induct x, case_tac x, auto, case_tac x1a, auto)

lemma leq_rttrace_trans: "\<And>y. x \<le>\<^sub>\<R>\<^sub>\<T> y \<Longrightarrow> y \<le>\<^sub>\<R>\<^sub>\<T> z \<Longrightarrow> x \<le>\<^sub>\<R>\<^sub>\<T> z"
  apply (induct x z rule:leq_rttrace.induct, auto)
  apply (case_tac y, auto, case_tac x1, auto)
  apply (case_tac y, auto, case_tac x1, auto)
  apply (case_tac y, auto, case_tac x1, auto, case_tac x21, auto)
  apply (case_tac y, auto, case_tac x1, auto, case_tac x21, auto)
  apply (case_tac y, auto, case_tac x21, auto)
  apply (case_tac y, auto, case_tac x21, auto)
  apply (case_tac y, auto, case_tac x21, auto)
  apply (case_tac y, auto, case_tac x21, auto)
  apply (case_tac y, auto, case_tac x21, auto)
  apply (case_tac y, auto, case_tac x21, auto)
  apply (case_tac y, auto, case_tac x21, auto)
  apply (case_tac y, auto, case_tac x21, auto)
  apply (case_tac y, auto, (case_tac ya, auto)+)
  done

lemma leq_rttrace_antisym: "x \<le>\<^sub>\<R>\<^sub>\<T> y \<Longrightarrow> y \<le>\<^sub>\<R>\<^sub>\<T> x \<Longrightarrow> x = y"
  by (induct x y rule:leq_rttrace.induct, auto, case_tac \<sigma>, auto, case_tac x1, auto)

definition RT1 :: "'e rtprocess \<Rightarrow> bool" where
  "RT1 P = (\<forall> \<rho> \<sigma>. \<sigma> \<in> P \<and> \<rho> \<le>\<^sub>\<R>\<^sub>\<T> \<sigma> \<longrightarrow> \<rho> \<in> P)"

subsection \<open>RT2\<close>

datatype 'e rttrace_tail = RTEmptyTail | RTEventTail 'e "'e rttrace" (infixr "##\<^sub>\<R>\<^sub>\<T>" 67)
datatype 'e rttrace_init = RTEmptyInit | RTEventInit "'e rtrefusal" 'e "'e rttrace_init"

fun rttrace_init_eq :: "'e rttrace_init \<Rightarrow> 'e rttrace_init \<Rightarrow> bool" where
  "rttrace_init_eq RTEmptyInit RTEmptyInit = False" |
  "rttrace_init_eq RTEmptyInit (RTEventInit x e \<rho>) = False" |
  "rttrace_init_eq (RTEventInit x e \<rho>) RTEmptyInit = False" |
  "rttrace_init_eq (RTEventInit x e \<rho>) (RTEventInit y f \<sigma>) = rttrace_init_eq \<rho> \<sigma>"

fun rttrace2init :: "'e rttrace \<Rightarrow> 'e rttrace_init" where
  "rttrace2init \<langle>y\<rangle>\<^sub>\<R>\<^sub>\<T> = RTEmptyInit" |
  "rttrace2init (x #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> \<rho>) = RTEventInit x a (rttrace2init \<rho>)"

fun rttrace_with_refusal :: "'e rttrace_init \<Rightarrow> 'e rtrefusal \<Rightarrow> 'e rttrace_tail \<Rightarrow> 'e rttrace" ("_ @\<^sub>\<R>\<^sub>\<T> \<langle>_\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> _" [65, 66, 67] 65) where
  "((RTEventInit x a \<rho>) @\<^sub>\<R>\<^sub>\<T> \<langle>y\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> \<sigma>) = (x #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> (\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>y\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> \<sigma>))" |
  "(RTEmptyInit @\<^sub>\<R>\<^sub>\<T> \<langle>y\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> (RTEventTail b \<sigma>)) = (y #\<^sub>\<R>\<^sub>\<T> b #\<^sub>\<R>\<^sub>\<T> \<sigma>)" |
  "(RTEmptyInit @\<^sub>\<R>\<^sub>\<T> \<langle>b\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> RTEmptyTail) = \<langle>b\<rangle>\<^sub>\<R>\<^sub>\<T>"

fun leq_rttrace_init :: "'e rttrace_init \<Rightarrow> 'e rttrace_init \<Rightarrow> bool" where
  "leq_rttrace_init RTEmptyInit \<rho> = True" |
  "leq_rttrace_init (RTEventInit X e \<rho>) RTEmptyInit = False" |
  "leq_rttrace_init (RTEventInit \<bullet>\<^sub>\<R>\<^sub>\<T> e \<rho>) (RTEventInit Y f \<sigma>) = (e = f \<and> leq_rttrace_init \<rho> \<sigma>)" |
  "leq_rttrace_init (RTEventInit [X]\<^sub>\<R>\<^sub>\<T> e \<rho>) (RTEventInit \<bullet>\<^sub>\<R>\<^sub>\<T> f \<sigma>) = False" |
  "leq_rttrace_init (RTEventInit [X]\<^sub>\<R>\<^sub>\<T> e \<rho>) (RTEventInit [Y]\<^sub>\<R>\<^sub>\<T> f \<sigma>) = (X \<subseteq> Y \<and> e = f \<and> leq_rttrace_init \<rho> \<sigma>)"

fun subset_rttrace_init :: "'e rttrace_init \<Rightarrow> 'e rttrace_init \<Rightarrow> bool" where
  "subset_rttrace_init RTEmptyInit RTEmptyInit = True" |
  "subset_rttrace_init (RTEventInit \<bullet>\<^sub>\<R>\<^sub>\<T> e \<rho>) (RTEventInit Y f \<sigma>) = (e = f \<and> subset_rttrace_init \<rho> \<sigma>)" |
  "subset_rttrace_init (RTEventInit [X]\<^sub>\<R>\<^sub>\<T> e \<rho>) (RTEventInit \<bullet>\<^sub>\<R>\<^sub>\<T> f \<sigma>) = False" |
  "subset_rttrace_init (RTEventInit [X]\<^sub>\<R>\<^sub>\<T> e \<rho>) (RTEventInit [Y]\<^sub>\<R>\<^sub>\<T> f \<sigma>) = (X \<subseteq> Y \<and> e = f \<and> subset_rttrace_init \<rho> \<sigma>)" |
  "subset_rttrace_init \<rho> \<sigma> = False"

lemma rttrace_with_refusal_eq1:
  "\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>X\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> RTEmptyTail = \<sigma> @\<^sub>\<R>\<^sub>\<T> \<langle>Y\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> RTEmptyTail \<Longrightarrow> \<rho> = \<sigma>"
  by (induct \<rho> \<sigma> rule: rttrace_init_eq.induct, auto)

lemma rttrace_with_refusal_eq2:
  "\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>X\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> RTEmptyTail = \<sigma> @\<^sub>\<R>\<^sub>\<T> \<langle>Y\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> RTEmptyTail \<Longrightarrow> X = Y"
  by (induct \<rho> \<sigma> rule: rttrace_init_eq.induct, auto)

lemma rttrace_with_refusal_eq3:
  "\<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>X\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>x\<rangle>\<^sub>\<R>\<^sub>\<T> = \<sigma> @\<^sub>\<R>\<^sub>\<T> \<langle>Y\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> f ##\<^sub>\<R>\<^sub>\<T> \<langle>y\<rangle>\<^sub>\<R>\<^sub>\<T> \<Longrightarrow> \<rho> = \<sigma>"
  apply (induct \<rho> \<sigma> rule: rttrace_init_eq.induct, auto)
  apply (metis (full_types) rttrace.simps(4) rttrace_with_refusal.elims rttrace_with_refusal.simps(2))
  using rttrace_with_refusal.elims by blast

definition RT2 :: "'e rtprocess \<Rightarrow> bool" where
  "RT2 P = (\<forall> \<rho> \<sigma> X Y.
    \<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> \<sigma> \<in> P \<and> (\<forall>e\<in>Y. \<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> \<notin> P)
      \<longrightarrow> \<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[X \<union> Y]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> \<sigma> \<in> P)"

subsection \<open>RT3\<close>

fun no_tick :: "'e rtevent rttrace_init \<Rightarrow> bool" where
  "no_tick RTEmptyInit = True" |
  "no_tick (RTEventInit x (EventRT e) \<rho>) = no_tick \<rho>" |
  "no_tick (RTEventInit x (TickRT) \<rho>) = False"

lemma subset_rttrace_init_no_tick1:
  "no_tick \<rho> \<Longrightarrow> subset_rttrace_init \<rho> \<sigma> \<Longrightarrow> no_tick \<sigma>"
  by (induct \<rho> \<sigma> rule:subset_rttrace_init.induct, auto, (case_tac f, auto)+)

lemma subset_rttrace_init_no_tick2:
  "no_tick \<sigma> \<Longrightarrow> subset_rttrace_init \<rho> \<sigma> \<Longrightarrow> no_tick \<rho>"
  by (induct \<rho> \<sigma> rule:subset_rttrace_init.induct, auto, (case_tac f, auto)+)

definition RT3 :: "'e rtevent rtprocess \<Rightarrow> bool" where
  "RT3 P = (\<forall> \<rho> x y e. \<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>x\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>y\<rangle>\<^sub>\<R>\<^sub>\<T> \<in> P \<longrightarrow> no_tick \<rho>)"

lemma RT3_refusal_after_TickRT:
  "\<And>P. RT3 P \<Longrightarrow> (X #\<^sub>\<R>\<^sub>\<T> TickRT #\<^sub>\<R>\<^sub>\<T> \<rho>) \<in> P \<Longrightarrow> \<exists> Y. \<rho> = \<langle>Y\<rangle>\<^sub>\<R>\<^sub>\<T>"
proof (induct \<rho>, auto)
  fix x1a x2 \<rho> P
  assume in_P: "(X #\<^sub>\<R>\<^sub>\<T> TickRT #\<^sub>\<R>\<^sub>\<T> (x1a #\<^sub>\<R>\<^sub>\<T> x2 #\<^sub>\<R>\<^sub>\<T> \<rho>)) \<in> P"
  assume RT3_P: "RT3 P"

  have "\<exists> \<rho>' x e y. (X #\<^sub>\<R>\<^sub>\<T> TickRT #\<^sub>\<R>\<^sub>\<T> (x1a #\<^sub>\<R>\<^sub>\<T> x2 #\<^sub>\<R>\<^sub>\<T> \<rho>)) = (RTEventInit X TickRT \<rho>' @\<^sub>\<R>\<^sub>\<T> \<langle>x\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>y\<rangle>\<^sub>\<R>\<^sub>\<T>)"
    apply (induct \<rho>, auto, rule_tac x = RTEmptyInit in exI, auto)
    by (smt rttrace.inject(2) rttrace_init.exhaust rttrace_with_refusal.simps(1) rttrace_with_refusal.simps(2))
  then obtain \<rho>' x e y where "(X #\<^sub>\<R>\<^sub>\<T> TickRT #\<^sub>\<R>\<^sub>\<T> (x1a #\<^sub>\<R>\<^sub>\<T> x2 #\<^sub>\<R>\<^sub>\<T> \<rho>)) = (RTEventInit X TickRT \<rho>' @\<^sub>\<R>\<^sub>\<T> \<langle>x\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>y\<rangle>\<^sub>\<R>\<^sub>\<T>)"
    by blast
  then have "no_tick (RTEventInit X TickRT \<rho>')"
    using RT3_P in_P unfolding RT3_def by (auto, metis in_P no_tick.simps(3) rttrace_with_refusal.simps(1))
  then show "False"
    by auto
qed

subsection \<open>RT4\<close>

definition RT4 :: "'e rtevent rtprocess \<Rightarrow> bool" where
  "RT4 P = (\<forall> \<rho> x y.
    \<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>x\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> TickRT ##\<^sub>\<R>\<^sub>\<T> \<langle>y\<rangle>\<^sub>\<R>\<^sub>\<T> \<in> P
      \<longrightarrow> x = \<bullet>\<^sub>\<R>\<^sub>\<T> \<and> \<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> TickRT ##\<^sub>\<R>\<^sub>\<T> \<langle>[UNIV]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> \<in> P)"

subsection \<open>RT\<close>

definition RT :: "'e rtevent rtprocess \<Rightarrow> bool" where
  "RT P = ((\<forall>x\<in>P. rtWF x) \<and> MRT0 P \<and> RT1 P \<and> RT2 P \<and> RT3 P \<and> RT4 P)"

definition refinesRT :: "'e rtprocess \<Rightarrow> 'e rtprocess \<Rightarrow> bool" (infix "\<sqsubseteq>\<^sub>\<R>\<^sub>\<T>" 50) where
  "P \<sqsubseteq>\<^sub>\<R>\<^sub>\<T> Q = (Q \<subseteq> P)"

section \<open>Maximal Healthiness Conditions\<close>

subsection \<open>RTM1 (replaces RT1)\<close>

fun leq_rttrace_max :: "'e rttrace \<Rightarrow> 'e rttrace \<Rightarrow> bool" (infix "\<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M>" 50) where
  "\<langle> \<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>             \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> \<sigma>                   = True" |
  "\<langle> [X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>           \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> \<langle> [Y]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>           = (X = Y)" |
  "\<langle> [X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>           \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> \<langle> \<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>             = False" |
  "\<langle> [X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>           \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> ( [Y]\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> b #\<^sub>\<R>\<^sub>\<T> \<sigma>) = (X = Y)" |
  "\<langle> [X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T>           \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> ( \<bullet>\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> b #\<^sub>\<R>\<^sub>\<T> \<sigma>)   = False" |
  "( \<bullet>\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> \<rho>)   \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> ( \<bullet>\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> b #\<^sub>\<R>\<^sub>\<T> \<sigma>)   = (a = b \<and> \<rho> \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> \<sigma>)" |
  "( \<bullet>\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> \<rho>)   \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> ( [Y]\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> b #\<^sub>\<R>\<^sub>\<T> \<sigma>) = (a = b \<and> \<rho> \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> \<sigma>)" |
  "( [X]\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> \<rho>) \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> ( [Y]\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> b #\<^sub>\<R>\<^sub>\<T> \<sigma>) = (X = Y \<and> a = b \<and> \<rho> \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> \<sigma>)" |
  "( [X]\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> \<rho>) \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> ( \<bullet>\<^sub>\<R>\<^sub>\<T> #\<^sub>\<R>\<^sub>\<T> b #\<^sub>\<R>\<^sub>\<T> \<sigma>)   = False" |
  "( x #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> \<rho>)     \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> \<langle>y\<rangle>\<^sub>\<R>\<^sub>\<T>                = False"

lemma leq_rttrace_max_refl: "x \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> x"
  by (induct x, case_tac x, auto, case_tac x1a, auto)

lemma leq_rttrace_max_trans: "\<And>y. x \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> y \<Longrightarrow> y \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> z \<Longrightarrow> x \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> z"
  apply (induct x z rule:leq_rttrace.induct, auto)
  apply (case_tac y, auto, case_tac x1, auto)
  apply (case_tac y, auto, case_tac x1, auto)
  apply (case_tac y, auto, case_tac x1, auto)
  apply (case_tac y, auto, case_tac x1, auto, case_tac x21, auto)
  apply (case_tac y, auto, case_tac x1, auto, case_tac x21, auto)
  apply (case_tac y, auto, case_tac x1, auto, case_tac x21, auto)
  apply (case_tac y, auto, case_tac x21, auto)
  apply (case_tac y, auto, case_tac x21, auto)
  apply (case_tac y, auto, case_tac x21, auto)
  apply (case_tac y, auto, case_tac x21, auto)
  apply (case_tac y, auto, case_tac x21, auto)
  apply (case_tac y, auto, case_tac x21, auto)
  apply (case_tac y, auto, case_tac x21, auto)
  apply (case_tac y, auto, case_tac x21, auto)
  apply (case_tac y, auto, case_tac x21, auto)
  apply (case_tac y, auto, (case_tac ya, auto)+)
  done

lemma leq_rttrace_max_antisym: "x \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> y \<Longrightarrow> y \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> x \<Longrightarrow> x = y"
  by (induct x y rule:leq_rttrace.induct, auto, case_tac \<sigma>, auto, case_tac x1, auto)

lemma leq_rttrace_max_implies_leq_rttrace:
  "\<rho> \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> \<sigma> \<Longrightarrow> \<rho> \<le>\<^sub>\<R>\<^sub>\<T> \<sigma>"
  by (induct \<rho> \<sigma> rule:leq_rttrace_max.induct, auto)

fun leq_rttrace_init_max :: "'e rttrace_init \<Rightarrow> 'e rttrace_init \<Rightarrow> bool" where
  "leq_rttrace_init_max RTEmptyInit \<rho> = True" |
  "leq_rttrace_init_max (RTEventInit X e \<rho>) RTEmptyInit = False" |
  "leq_rttrace_init_max (RTEventInit \<bullet>\<^sub>\<R>\<^sub>\<T> e \<rho>) (RTEventInit Y f \<sigma>) = (e = f \<and> leq_rttrace_init_max \<rho> \<sigma>)" |
  "leq_rttrace_init_max (RTEventInit [X]\<^sub>\<R>\<^sub>\<T> e \<rho>) (RTEventInit \<bullet>\<^sub>\<R>\<^sub>\<T> f \<sigma>) = False" |
  "leq_rttrace_init_max (RTEventInit [X]\<^sub>\<R>\<^sub>\<T> e \<rho>) (RTEventInit [Y]\<^sub>\<R>\<^sub>\<T> f \<sigma>) = (X \<subseteq> Y \<and> e = f \<and> leq_rttrace_init_max \<rho> \<sigma>)"

fun leq_rttrace_rttrace_init_max :: "'e rttrace \<Rightarrow> 'e rttrace_init \<Rightarrow> bool" where
  "leq_rttrace_rttrace_init_max \<langle>x\<rangle>\<^sub>\<R>\<^sub>\<T> RTEmptyInit = False" |
  "leq_rttrace_rttrace_init_max (v #\<^sub>\<R>\<^sub>\<T> va #\<^sub>\<R>\<^sub>\<T> vb) RTEmptyInit = False" |
  "leq_rttrace_rttrace_init_max \<langle>vc\<rangle>\<^sub>\<R>\<^sub>\<T> (RTEventInit v va vb) = (vc = v)" |
  "leq_rttrace_rttrace_init_max (v #\<^sub>\<R>\<^sub>\<T> va #\<^sub>\<R>\<^sub>\<T> vb) (RTEventInit vc vd ve) = (v = vc \<and> va = vd \<and> leq_rttrace_rttrace_init_max vb ve)"

definition RTM1 :: "'e rtprocess \<Rightarrow> bool" where
  "RTM1 P = (\<forall> \<rho> \<sigma>. \<sigma> \<in> P \<and> \<rho> \<le>\<^sub>\<R>\<^sub>\<T>\<^sub>\<M> \<sigma> \<longrightarrow> \<rho> \<in> P)"

lemma RTM1_init_event:
  assumes "RTM1 P"
  shows "RTM1 {\<rho>. (x #\<^sub>\<R>\<^sub>\<T> a #\<^sub>\<R>\<^sub>\<T> \<rho>) \<in> P}"
  using assms unfolding RTM1_def apply auto
  by (metis leq_rttrace_max.simps(6) leq_rttrace_max.simps(8) rtrefusal.exhaust)

subsection \<open>RTM2 (replaces RT2)\<close>

definition RTM2 :: "'e rtprocess \<Rightarrow> bool" where
  "RTM2 P = (\<forall> \<rho> X e. \<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> RTEmptyTail \<in> P \<and> e \<notin> X \<longrightarrow> \<rho> @\<^sub>\<R>\<^sub>\<T> \<langle>[X]\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> @\<^sub>\<R>\<^sub>\<T> e ##\<^sub>\<R>\<^sub>\<T> \<langle>\<bullet>\<^sub>\<R>\<^sub>\<T>\<rangle>\<^sub>\<R>\<^sub>\<T> \<in> P)"

subsection \<open>RTM\<close>

definition RTM :: "'e rtevent rtprocess \<Rightarrow> bool" where
  "RTM P = ((\<forall>x\<in>P. rtWF x) \<and> MRT0 P \<and> RTM1 P \<and> RTM2 P \<and> RT3 P \<and> RT4 P)"

end


(*  Title:      HOL/Nunchaku_Examples/Hotel_Nuns.thy
    Author:     Jasmin Blanchette, Inria Nancy, LORIA, MPII
    Copyright   2010-2011

Nunchaku example based on Tobias Nipkow's hotel key card formalization.
*)

section {* Nunchaku Example Based on Tobias Nipkow's Hotel Key Card
          Formalization *}

theory Hotel_Nuns
imports "../Nunchaku"
begin

nunchaku_params [verbose, max_potential = 0, timeout = 240]

typedecl guest
typedecl key
typedecl room

type_synonym keycard = "key \<times> key"

record state =
  owns :: "room \<Rightarrow> guest option"
  currk :: "room \<Rightarrow> key"
  issued :: "key set"
  cards :: "guest \<Rightarrow> keycard set"
  roomk :: "room \<Rightarrow> key"
  isin :: "room \<Rightarrow> guest set"
  safe :: "room \<Rightarrow> bool"

inductive_set reach :: "state set" where
init:
"inj initk \<Longrightarrow>
 \<lparr>owns = (\<lambda>r. None), currk = initk, issued = range initk, cards = (\<lambda>g. {}),
  roomk = initk, isin = (\<lambda>r. {}), safe = (\<lambda>r. True)\<rparr> \<in> reach" |
check_in:
"\<lbrakk>s \<in> reach; k \<notin> issued s\<rbrakk> \<Longrightarrow>
 s\<lparr>currk := (currk s)(r := k), issued := issued s \<union> {k},
   cards := (cards s)(g := cards s g \<union> {(currk s r, k)}),
   owns :=  (owns s)(r := Some g), safe := (safe s)(r := False)\<rparr> \<in> reach" |
enter_room:
"\<lbrakk>s \<in> reach; (k,k') \<in> cards s g; roomk s r \<in> {k,k'}\<rbrakk> \<Longrightarrow>
 s\<lparr>isin := (isin s)(r := isin s r \<union> {g}),
   roomk := (roomk s)(r := k'),
   safe := (safe s)(r := owns s r = Some g \<and> isin s r = {} (* \<and> k' = currk s r *)
                         \<or> safe s r)\<rparr> \<in> reach" |
exit_room:
"\<lbrakk>s \<in> reach; g \<in> isin s r\<rbrakk> \<Longrightarrow> s\<lparr>isin := (isin s)(r := isin s r - {g})\<rparr> \<in> reach"

theorem safe: "s \<in> reach \<Longrightarrow> safe s r \<Longrightarrow> g \<in> isin s r \<Longrightarrow> owns s r = Some g"
nunchaku [expect = genuine]
oops

end


(*  Title:      HOL/HOLCF/One.thy
    Author:     Oscar Slotosch
*)

section \<open>The unit domain\<close>

theory One
imports Lift
begin

type_synonym
  one = "unit lift"

translations
  (type) "one" <= (type) "unit lift"

definition ONE :: "one"
  where "ONE == Def ()"

text \<open>Exhaustion and Elimination for type @{typ one}\<close>

lemma Exh_one: "t = \<bottom> \<or> t = ONE"
unfolding ONE_def by (induct t) simp_all

lemma oneE [case_names bottom ONE]: "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; p = ONE \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
unfolding ONE_def by (induct p) simp_all

lemma one_induct [case_names bottom ONE]: "\<lbrakk>P \<bottom>; P ONE\<rbrakk> \<Longrightarrow> P x"
by (cases x rule: oneE) simp_all

lemma dist_below_one [simp]: "ONE \<notsqsubseteq> \<bottom>"
unfolding ONE_def by simp

lemma below_ONE [simp]: "x \<sqsubseteq> ONE"
by (induct x rule: one_induct) simp_all

lemma ONE_below_iff [simp]: "ONE \<sqsubseteq> x \<longleftrightarrow> x = ONE"
by (induct x rule: one_induct) simp_all

lemma ONE_defined [simp]: "ONE \<noteq> \<bottom>"
unfolding ONE_def by simp

lemma one_neq_iffs [simp]:
  "x \<noteq> ONE \<longleftrightarrow> x = \<bottom>"
  "ONE \<noteq> x \<longleftrightarrow> x = \<bottom>"
  "x \<noteq> \<bottom> \<longleftrightarrow> x = ONE"
  "\<bottom> \<noteq> x \<longleftrightarrow> x = ONE"
by (induct x rule: one_induct) simp_all

lemma compact_ONE: "compact ONE"
by (rule compact_chfin)

text \<open>Case analysis function for type @{typ one}\<close>

definition
  one_case :: "'a::pcpo \<rightarrow> one \<rightarrow> 'a" where
  "one_case = (\<Lambda> a x. seq\<cdot>x\<cdot>a)"

translations
  "case x of XCONST ONE \<Rightarrow> t" == "CONST one_case\<cdot>t\<cdot>x"
  "case x of XCONST ONE :: 'a \<Rightarrow> t" => "CONST one_case\<cdot>t\<cdot>x"
  "\<Lambda> (XCONST ONE). t" == "CONST one_case\<cdot>t"

lemma one_case1 [simp]: "(case \<bottom> of ONE \<Rightarrow> t) = \<bottom>"
by (simp add: one_case_def)

lemma one_case2 [simp]: "(case ONE of ONE \<Rightarrow> t) = t"
by (simp add: one_case_def)

lemma one_case3 [simp]: "(case x of ONE \<Rightarrow> ONE) = x"
by (induct x rule: one_induct) simp_all

end


theory CollapsibleParticulars
  imports ParticularStructureMorphisms
begin

context ufo_particular_theory_sig
begin

text_raw \<open>\subsection[Collapsability]{Collapsability\isalabel{subsec:collapsability}}\<close>

text \<^marker>\<open>tag bodyonly\<close> \<open>
  While in \autoref{subsec:permutability}, we defined the notion of a permutable
  particular as being one that can, in a sense, be ``seen'' as another, through
  an endomorphism, we here introduce the stronger notion of a collapsible particulars.

  A particular \<open>x\<close> of a particular structure \<open>\<Gamma>\<close> is considered to be collapsible if
  and only if there is at least one other particular \<open>y\<close> of \<open>\<Gamma>\<close> and at least one
  \<open>\<Gamma>\<close>-endomorphism that maps \<open>x\<close> and \<open>y\<close> to the same particular.

  This notion captures the idea of a plurality of particulars that can be seen
  as being essentially the same, with respect to \<open>\<Gamma>\<close>'s structure.

  Formally, we define a collapsible particular as follows:
\<close>

definition collapsible :: \<open>'p \<Rightarrow> bool\<close>  where
  \<open>collapsible x \<equiv> x \<in> \<P> \<and> (\<exists>\<phi> \<in> EndoMorphs\<^bsub>\<Gamma>\<^esub>.\<exists>y \<in> \<P>. x \<noteq> y \<and> \<phi> x = \<phi> y)\<close>

lemma \<^marker>\<open>tag (proof) aponly\<close> collapsibleI[intro]:
  assumes \<open>x \<in> \<P>\<close> \<open>y \<in> \<P>\<close> \<open>\<phi> \<in> EndoMorphs\<^bsub>\<Gamma>\<^esub>\<close> \<open>x \<noteq> y\<close> \<open>\<phi> x = \<phi> y\<close>
  shows \<open>collapsible x\<close>
  using assms by (auto simp: collapsible_def)

lemma \<^marker>\<open>tag (proof) aponly\<close> collapsibleE[elim]:
  assumes \<open>collapsible x\<close>
  obtains \<phi> y where \<open>x \<in> \<P>\<close> \<open>y \<in> \<P>\<close>
      \<open>\<phi> \<in> EndoMorphs\<^bsub>\<Gamma>\<^esub>\<close> \<open>x \<noteq> y\<close> \<open>\<phi> x = \<phi> y\<close>
  using assms by (auto simp: collapsible_def)

lemmas \<^marker>\<open>tag (proof) aponly\<close> collapsible_iff[simp] = collapsible_def

text \<^marker>\<open>tag bodyonly\<close> \<open>
  The set of non-collapsible particulars of \<open>\<Gamma>\<close> is defined as:
\<close>

definition nonCollapsibleParticulars (\<open>\<P>\<^sub>n\<^sub>c\<close>) where
  \<open>\<P>\<^sub>n\<^sub>c \<equiv> { x . x \<in> \<P> \<and> \<not> collapsible x }\<close>

lemma \<^marker>\<open>tag (proof) aponly\<close> nonCollapsibleParticularsI[intro!]:
  assumes \<open>x \<in> \<P>\<close> \<open>\<not> collapsible x\<close>
  shows \<open>x \<in> \<P>\<^sub>n\<^sub>c\<close>
  using assms by (auto simp: nonCollapsibleParticulars_def)

lemma \<^marker>\<open>tag (proof) aponly\<close> nonCollapsibleParticularsE[elim!]:
  assumes \<open>x \<in> \<P>\<^sub>n\<^sub>c\<close>
  obtains \<open>x \<in> \<P>\<close> \<open>\<not> collapsible x\<close>
  using assms by (auto simp: nonCollapsibleParticulars_def)

lemma \<^marker>\<open>tag (proof) aponly\<close> nonCollapsibleParticulars_iff[simp]:
  \<open>x \<in> \<P>\<^sub>n\<^sub>c  \<longleftrightarrow> x \<in> \<P> \<and> \<not> collapsible x\<close>
  by (auto simp: nonCollapsibleParticulars_def)

lemma \<^marker>\<open>tag (proof) aponly\<close> nonCollapsibleParticularsAreParticulars: \<open>\<P>\<^sub>n\<^sub>c \<subseteq> \<P>\<close>
  by blast

end

end


section \<open> Deadlock \<close>

theory ITree_Deadlock
  imports ITree_Divergence
begin

text \<open> Deadlock is an interaction with no visible event \<close>

definition deadlock :: "('e, 'r) itree" where
"deadlock = Vis {}\<^sub>p"

lemma stable_deadlock [simp]: "stable deadlock"
  by (simp add: deadlock_def)

lemma deadlock_trace_to: "deadlock \<midarrow>tr\<leadsto> P \<longleftrightarrow> tr = [] \<and> P = deadlock"
  by (auto simp add: deadlock_def)

lemma pure_deadlock: "pure_itree deadlock"
  by (simp add: deadlock_trace_to pure_itree_def)

lemma div_free_deadlock: "div_free deadlock"
  by (metis deadlock_def div_free_run run_empty)

lemma pure_itree_disj_cases:
  assumes "pure_itree P"
  shows "(\<exists> n v. P = Sils n (Ret v)) \<or> (\<exists> n. P = Sils n deadlock) \<or> P = diverge"
  unfolding deadlock_def
  by (metis assms itree_disj_cases pure_itree_Vis pure_itree_trace_to trace_of_Sils)

lemma pure_itree_cases [case_names rets deadlock diverge, consumes 1]:
  assumes "pure_itree P"
    "\<And> n v. P = Sils n (Ret v) \<Longrightarrow> Q" "\<And> n. P = Sils n deadlock \<Longrightarrow> Q" "P = diverge \<Longrightarrow> Q"
  shows Q
  by (meson assms pure_itree_disj_cases)

lemma deadlock_bind [simp]: "deadlock \<bind> P = deadlock"
  by (metis (no_types, lifting) deadlock_def run_bind run_empty)

lemma retvals_deadlock [simp]: "\<^bold>R(deadlock) = {}"
  by (simp add: deadlock_def)

definition deadlock_free :: "('e, 'r) itree \<Rightarrow> bool" where
"deadlock_free P = (\<forall> tr. \<not> P \<midarrow>tr\<leadsto> deadlock)"

lemma deadlock_free_deadlock: "deadlock_free deadlock = False"
  by (simp add: deadlock_free_def deadlock_trace_to)

lemma deadlock_free_Ret: "deadlock_free (\<checkmark> x)"
  by (simp add: deadlock_def deadlock_free_def)

lemma deadlock_free_Sil: "deadlock_free (Sil P) = deadlock_free P"
  by (metis deadlock_free_def itree.disc(5) stable_deadlock trace_to_Sil trace_to_SilE)

lemma deadlock_free_VisI:
  assumes
    "dom(F) \<noteq> {}" "\<And> e. e \<in> dom(F) \<Longrightarrow> deadlock_free (F(e)\<^sub>p)"
  shows "deadlock_free (Vis F)"
  by (metis assms deadlock_def deadlock_free_def itree.inject(3) pdom_zero trace_to_VisE)

lemma deadlock_free_VisE:
  assumes "deadlock_free (Vis F)"
    "\<lbrakk> dom(F) \<noteq> {}; \<And> e. e \<in> pdom(F) \<Longrightarrow> deadlock_free (F(e)\<^sub>p) \<rbrakk> \<Longrightarrow> thesis"
  shows thesis
  by (metis assms deadlock_def deadlock_free_deadlock deadlock_free_def pdom_empty_iff_dom_empty trace_to.intros(3))

lemma deadlock_free_Vis:
  "deadlock_free (Vis F) = (dom(F) \<noteq> {} \<and> (\<forall>e\<in>pdom(F). deadlock_free (F(e)\<^sub>p)))"
  by (auto intro: deadlock_free_VisI elim: deadlock_free_VisE)

lemma deadlock_free_bindI: "\<lbrakk> deadlock_free P; \<forall> s\<in>\<^bold>R(P). deadlock_free (Q s) \<rbrakk> \<Longrightarrow> deadlock_free (P \<bind> Q)"
  apply (auto elim!:trace_to_bindE bind_VisE' simp add: deadlock_def deadlock_free_def)
  apply (metis retvals_traceI trace_to_Nil)
  apply (meson retvals_traceI)
  done

lemma deadlock_free_bind_iff:
  "deadlock_free (P \<bind> Q) \<longleftrightarrow> (deadlock_free P \<and> (\<forall> s\<in>\<^bold>R(P). deadlock_free (Q s)))"
  apply (auto intro: deadlock_free_bindI)
  apply (auto simp add: deadlock_free_def retvals_def)
  apply (metis deadlock_bind trace_to_bind_left)
  apply (meson trace_to_bind)
  done

lemma deadlock_free_Vis_prism_fun:
  "wb_prism c \<Longrightarrow> deadlock_free (Vis (prism_fun c A (\<lambda> x. (P x, Ret (f x))))) = (\<exists>v\<in>A. P v)"
  by (auto simp add: deadlock_free_Vis dom_prism_fun prism_fun_apply deadlock_free_Ret)

end