(*
 * Copyright 2015, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(*  WP-specific Eisbach methods *)

theory Eisbach_WP
imports
  "../../Eisbach_Methods"
  "../NonDetMonadVCG"
  "../../Conjuncts"
  "../../Rule_By_Method"
  "WPI"
begin

text \<open>
  Methods for manipulating the post conditions of hoare triples as if they
  were proper subgoals.

  post_asm can be used with the @ attribute to modify existing proofs. Useful
  for proving large postconditions in one proof and then subsequently decomposing it.

\<close>
context begin

definition "packed_valid P f si r s \<equiv> P si \<and> (r, s) \<in> fst (f si)"

lemma packed_validE:"(\<And>si r s. packed_valid P f si r s \<Longrightarrow> Q r s) \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>"
  by (clarsimp simp: valid_def packed_valid_def)

lemma packed_validI: "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<Longrightarrow> \<forall>si r s. packed_valid P f si r s \<longrightarrow> Q r s"
  apply (clarsimp simp: valid_def packed_valid_def)
  by auto

definition "packed_validR P f si r s \<equiv> P si \<and> (Inr r, s) \<in> fst (f si)"

lemma packed_validRE:"(\<And>si r s. packed_validR P f si r s \<Longrightarrow> Q r s) \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,-"
  apply (clarsimp simp: validE_R_def validE_def valid_def packed_validR_def)
  by (metis sum.case sumE)

lemma packed_validRI: "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,- \<Longrightarrow> \<forall>si r s. packed_validR P f si r s \<longrightarrow> Q r s"
  apply (clarsimp simp: valid_def validE_R_def validE_def packed_validR_def)
  by fastforce

lemma trivial_imp: "\<forall>r s. Q r s \<longrightarrow> Q r s" by simp

lemma uncurry2: "\<forall>r s. Q r s \<and> Q' r s \<longrightarrow> Q'' r s \<Longrightarrow> \<forall>r s. Q r s \<longrightarrow> Q' r s \<longrightarrow> Q'' r s"
  by simp

named_theorems hoare_post_imps

lemmas [hoare_post_imps] = hoare_post_imp_R hoare_post_imp[rotated]

method post_asm_raw methods m =
  (drule hoare_post_imps,
   atomize (full),
   focus_concl
     \<open>intro impI allI,
      m,
      atomize (full),
      ((rule uncurry2)+)?\<close>,
   rule trivial_imp)

method post_asm methods m =
  (post_asm_raw \<open>(simp only: bipred_conj_def pred_conj_def)?,(elim conjE)?,m\<close>)

named_theorems packed_validEs

lemmas [packed_validEs] = packed_validE packed_validRE

named_theorems packed_validIs

lemmas [packed_validIs] = packed_validI packed_validRI

method post_raw methods m =
  (focus_concl
    \<open>rule packed_validEs,
     focus_concl \<open>m,fold_subgoals\<close>,
     atomize (full),
     rule packed_validI\<close>)

method post_strong methods m_distinct m_all =
  (post_raw
     \<open>(simp only: pred_conj_def bipred_conj_def)?,
      (intro impI conjI allI)?,
      distinct_subgoals_strong \<open>m_distinct\<close>,
      all \<open>m_all\<close>,
      fold_subgoals\<close>)

method post methods m = post_strong \<open>(assumption | erule mp)+\<close> \<open>m\<close>

end

text \<open>
  Method (meant to be used with @ as an attribute) used for producing multiple facts out of
  a single hoare triple with a conjunction in its post condition.
\<close>

context begin

private lemma hoare_decompose:
  "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>r s. Q r s \<and> Q' r s\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<and> \<lbrace>P\<rbrace> f \<lbrace>Q'\<rbrace>"
  by (fastforce simp add: valid_def pred_conj_def)

private lemma hoare_decomposeE_R:
  "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>r s. Q r s \<and> Q' r s\<rbrace>,- \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,- \<and> \<lbrace>P\<rbrace> f \<lbrace>Q'\<rbrace>,-"
  by (fastforce simp add: validE_R_def validE_def valid_def pred_conj_def split: prod.splits sum.splits)

private lemma hoare_decomposeE_E:
  "\<lbrace>P\<rbrace> f -,\<lbrace>\<lambda>r s. Q r s \<and> Q' r s\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> f -,\<lbrace>Q\<rbrace> \<and> \<lbrace>P\<rbrace> f -,\<lbrace>Q'\<rbrace>"
  by (fastforce simp add: validE_E_def validE_def valid_def pred_conj_def split: prod.splits sum.splits)

private lemma hoare_decomposeE:
  "\<lbrace>P\<rbrace> f \<lbrace>\<lambda>r s. E r s \<and> E' r s\<rbrace>,\<lbrace>\<lambda>r s. R r s \<and> R' r s\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>E\<rbrace>,- \<and> \<lbrace>P\<rbrace> f \<lbrace>E'\<rbrace>,- \<and> \<lbrace>P\<rbrace> f -,\<lbrace>R\<rbrace> \<and> \<lbrace>P\<rbrace> f -,\<lbrace>R'\<rbrace>"
  by (fastforce simp add: validE_R_def validE_E_def validE_def valid_def pred_conj_def split: prod.splits sum.splits)

private lemmas hoare_decomposes' = hoare_decompose hoare_decomposeE_R hoare_decomposeE_E hoare_decomposeE

private method add_pred_conj = (subst pred_conj_def[symmetric])
private method add_bipred_conj = (subst bipred_conj_def[symmetric])

private lemmas hoare_decomposes[THEN conjE] =
  hoare_decomposes'
  hoare_decomposes'[# \<open>add_pred_conj\<close>]
  hoare_decomposes'[# \<open>add_bipred_conj\<close>]
  hoare_decomposeE[# \<open>add_pred_conj, add_pred_conj\<close>]
  hoare_decomposeE[# \<open>add_bipred_conj, add_pred_conj\<close>]
  hoare_decomposeE[# \<open>add_pred_conj, add_bipred_conj\<close>]
  hoare_decomposeE[# \<open>add_bipred_conj, add_bipred_conj\<close>]

method hoare_decompose = (elim hoare_decomposes)

end

notepad begin
  fix A :: "'a \<Rightarrow> bool" and B C D f
  assume A: "\<And>s. A s = True" and
         B: "\<And>s :: 'a. B s = True" and
         C: "\<And>s :: 'a. C s = True" and
         D: "\<And>s :: 'a. D s = True" and
         f: "f = (return () :: ('a,unit) nondet_monad)"

  have f_valid[@ \<open>hoare_decompose\<close>,conjuncts]: "\<lbrace>A\<rbrace> f \<lbrace>\<lambda>_. B and C and D\<rbrace>"
  apply (simp add: f)
  apply wp
  by (simp add: B C D)

  note f_valid' = conjuncts

  have f_d: "\<lbrace>A\<rbrace> f \<lbrace>\<lambda>_. D\<rbrace>" by (rule f_valid')

  have f_valid_interm: "\<lbrace>A\<rbrace> f \<lbrace>\<lambda>_. B and C and (\<lambda>s. D s \<longrightarrow> B s)\<rbrace>"
  apply (post_strong \<open>simp\<close> \<open>-\<close>)
  apply (wp f_valid')
  by simp

  (* All rotations are attempted when strengthening *)

  have f_valid_interm: "\<lbrace>A\<rbrace> f \<lbrace>\<lambda>_. (\<lambda>s. D s \<longrightarrow> B s) and B and C \<rbrace>"
  apply (post_strong \<open>simp\<close> \<open>-\<close>, wp f_valid')
  by simp

end

end


section\<open>Inductive Study of Confidentiality against the General Attacker\<close>

theory  ConfidentialityGA imports NS_Public_Bad_GA begin

text\<open>New subsidiary lemmas to reason on a generic agent initial state\<close>

lemma parts_initState: "parts(initState C) = initState C"
by (cases C, simp)

lemma analz_initState: "analz(initState C) = initState C"
by (cases C, force dest: analz_into_parts)

text\<open>Generalising over all initial secrets the existing treatment, which is limited to private encryption keys\<close>

definition staticSecret :: "agent \<Rightarrow> msg set" where
 [simp]: "staticSecret A == {Key (priEK A), Key (priSK A), Key (shrK A)}"

text\<open>More subsidiary lemmas combining initial secrets and knowledge of generic agent\<close>

lemma staticSecret_in_initState [simp]:
"staticSecret A \<subseteq> initState A"
by (cases A, simp)
thm parts_insert

lemma staticSecretA_notin_initStateB:
"m \<in> staticSecret A \<Longrightarrow> m \<in> initState B = (A=B)"
by (cases B, auto)

lemma staticSecretA_notin_parts_initStateB:
"m \<in> staticSecret A \<Longrightarrow> m \<in> parts(initState B) = (A=B)"
by (cases B, auto)

lemma staticSecretA_notin_analz_initStateB:
"m \<in> staticSecret A \<Longrightarrow> m \<in> analz(initState B) = (A=B)"
by (cases B, force dest: analz_into_parts)

lemma staticSecret_synth_eq:
"m \<in> staticSecret A \<Longrightarrow> (m \<in> synth H) = (m \<in> H)"
apply force
done

declare staticSecret_def [simp del]

lemma nonce_notin_analz_initState:
  "Nonce N \<notin> analz(initState A)"
by(cases A, auto dest: analz_into_parts)

subsection\<open>Protocol independent study\<close>

lemma staticSecret_parts_agent:
 "\<lbrakk>m \<in> parts (knows C evs); m \<in> staticSecret A\<rbrakk> \<Longrightarrow>
   A=C \<or>
  (\<exists>D E X. Says D E X \<in> set evs \<and> m \<in> parts{X}) \<or>
  (\<exists>Y. Notes C Y \<in> set evs \<and> m \<in> parts{Y})"
apply (erule rev_mp)
apply (induct_tac evs)
txt\<open>@{subgoals [display,indent =1]}\<close>
apply (simp add: staticSecretA_notin_parts_initStateB)
apply (induct_tac a)
(*Says*)
apply (rule impI)
apply simp
apply (drule parts_insert [THEN equalityD1, THEN subsetD])
apply blast
(*Gets*)
apply simp
(*Notes*)
apply simp
apply clarify
txt\<open>@{subgoals [display,indent =1]}\<close>
apply (drule parts_insert [THEN equalityD1, THEN subsetD])
apply blast
done

lemma staticSecret_analz_agent:
 "\<lbrakk>m \<in> analz (knows C evs); m \<in> staticSecret A\<rbrakk> \<Longrightarrow>
   A=C \<or>
  (\<exists>D E X. Says D E X \<in> set evs \<and> m \<in> parts{X}) \<or>
  (\<exists>Y. Notes C Y \<in> set evs \<and> m \<in> parts{Y})"
by (drule analz_into_parts [THEN staticSecret_parts_agent])

lemma secret_parts_agent:
 "m \<in> parts (knows C evs)  \<Longrightarrow> m \<in> initState C \<or>
 (\<exists>A B X. Says A B X \<in> set evs \<and> m \<in> parts{X}) \<or>
 (\<exists>Y. Notes C Y \<in> set evs \<and> m \<in> parts{Y})"
apply (erule rev_mp)
apply (induct_tac "evs")
apply (simp add: parts_initState)
apply (induct_tac "a")
(*Says*)
apply (rule impI)
apply simp
apply (drule parts_insert [THEN equalityD1, THEN subsetD])
apply blast
(*Gets*)
apply simp
(*Notes*)
apply simp
apply clarify
apply (drule parts_insert [THEN equalityD1, THEN subsetD])
apply blast
done

subsection\<open>Protocol dependent study\<close>

(*NS_no_Notes moved up in NS_Public_Bad_GA.thy so that it's visible to a sibling theory of this one's

As with DolevYao, studying a guarantee similar to
NS_no_Says_staticSecret makes the specialisation proof strategy collapse, because it elicits the same assumptions of the theorem that should be specified.
*)

lemma NS_staticSecret_parts_agent_weak:
 "\<lbrakk>m \<in> parts (knows C evs); m \<in> staticSecret A;
   evs \<in> ns_public\<rbrakk> \<Longrightarrow>
  A=C \<or> (\<exists>D E X. Says D E X \<in> set evs \<and> m \<in> parts{X})"
apply (blast dest: NS_no_Notes staticSecret_parts_agent)
done

text\<open>Can't prove the homologous theorem of NS\_Says\_Spy\_staticSecret, hence the specialisation proof strategy cannot be applied\<close>

(*Simple though illustrative corollary*)
(*note use of Says_imp_knows, an enforcement of the threat model*)
lemma NS_staticSecret_parts_agent_parts:
"\<lbrakk>m \<in> parts (knows C evs); m \<in> staticSecret A; A\<noteq>C; evs \<in> ns_public\<rbrakk> \<Longrightarrow>
  m \<in> parts(knows D evs)"
apply (blast dest: NS_staticSecret_parts_agent_weak Says_imp_knows [THEN parts.Inj] parts_trans)
(*Alternative proof
apply (blast dest: staticSecret_parts_agent NS_no_Notes Says_imp_knows [THEN parts.Inj] parts_trans)*)
done

text\<open>
The previous theorems show that in general any agent could send anybody's initial secret, namely the threat model does not impose anything against it. However, the actual protocol specification will, where agents either follow the protocol or build messages out of their traffic analysis - this is actually the same in DY

Therefore, we are only left with the direct proof strategy.
\<close>

lemma NS_staticSecret_parts_agent:
 "\<lbrakk>m \<in> parts (knows C evs); m \<in> staticSecret A;
   C\<noteq>A; evs \<in> ns_public\<rbrakk>
 \<Longrightarrow> \<exists> B X. Says A B X \<in> set evs \<and> m \<in> parts {X}"
apply (erule rev_mp, erule ns_public.induct)
(*Nil*)
apply (simp add: staticSecretA_notin_parts_initStateB)
(*Fake*)
apply simp
apply clarify
apply (drule parts_insert [THEN equalityD1, THEN subsetD])(*shot1*)
apply (case_tac "Aa=A")
apply clarify
txt\<open>@{subgoals [display,indent=1,goals_limit=2]}\<close>
apply blast
(*Aa\<noteq>A*)
apply simp
apply clarify (*applies induction hypothesis!*)(*shot2*)
txt\<open>@{subgoals [display,indent=1,goals_limit=1]}\<close>
apply (drule Fake_parts_sing [THEN subsetD], simp)  (*shot3*)
apply (simp add: staticSecret_synth_eq)
txt\<open>@{subgoals [display,indent=1,goals_limit=1]}\<close>
apply (blast dest: NS_staticSecret_parts_agent_parts)
(*rest!*)
apply (force simp add: staticSecret_def)+
done

lemma NS_agent_see_staticSecret:
 "\<lbrakk>m \<in> staticSecret A; C\<noteq>A; evs \<in> ns_public\<rbrakk>
 \<Longrightarrow> m \<in> parts (knows C evs) = (\<exists> B X. Says A B X \<in> set evs \<and> m \<in> parts {X})"
apply (force dest: NS_staticSecret_parts_agent Says_imp_knows [THEN parts.Inj] intro: parts_trans)
done

declare analz.Decrypt [rule del]

lemma analz_insert_analz: "
\<lbrakk> c \<notin> parts{Z}; \<forall>K. Key K \<notin> parts{Z}; c \<in> analz(insert Z H)\<rbrakk> \<Longrightarrow> c \<in> analz H"
apply (erule rev_mp, erule rev_mp)
apply (erule analz.induct)
prefer 4
apply clarify
txt\<open>@{subgoals [display,indent=1,goals_limit=1]}\<close>
apply (blast dest: parts.Body analz.Decrypt)
apply blast+
done

lemma Agent_not_see_NA:
     "\<lbrakk> Key (priEK B) \<notin> analz(knows C evs);
        Key (priEK A) \<notin> analz(knows C evs);
        \<forall>S R Y. Says S R Y \<in> set evs \<longrightarrow>
         Y = Crypt (pubEK B) \<lbrace>Nonce NA, Agent A\<rbrace> \<or>
         Y = Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace> \<or>
         Nonce NA \<notin> parts{Y} \<and> (\<forall>K. Key K \<notin> parts{Y});
        C\<noteq>A; C\<noteq>B;  evs \<in> ns_public\<rbrakk>
       \<Longrightarrow> Nonce NA \<notin> analz (knows C evs)"
apply (erule rev_mp, erule rev_mp, erule rev_mp, erule ns_public.induct)
apply (simp add: nonce_notin_analz_initState)
apply clarify
apply simp
(*fixing confidentiality of both private keys*)
apply (drule subset_insertI [THEN analz_mono, THEN contra_subsetD])+
txt\<open>@{subgoals [display,indent=1,goals_limit=1]}\<close>
apply (subgoal_tac "
        \<forall>S R Y.
           (S = Aa \<and> R = Ba \<and> Y = X \<longrightarrow>
            X = Crypt (pubK B) \<lbrace>Nonce NA, Agent A\<rbrace> \<or>
            X = Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB\<rbrace> \<or>
            Nonce NA \<notin> parts {X} \<and> (\<forall>K. Key K \<notin> parts {X}))")
prefer 2
apply blast
apply simp
txt\<open>@{subgoals [display,indent=1,goals_limit=1]}\<close>
apply (force dest!: analz_insert_analz)
(*Alternative proof
apply (erule disjE) apply simp
apply (erule disjE) apply simp
apply (blast dest: analz_insert_analz)
*)
apply auto
done

end


theory "BAN_concrete_Andrew_Secure_RPC_cert_auto"
imports
  "ESPLogic"
begin

(* section:  BAN concrete Andrew Secure RPC  *)

(* text:
  Modeled after the model in the SPORE library.

  Notable differences:

    1. 'succ(x)' is invertible. Hence, we just model it as a tuple ('succ',x) of
       a global constant 'succ' and the variable x.  This means that we only
       exploit the tagging properties of 'succ', but do not assume any
       information hiding.

    2. Instead of implicit typing, we are using explicit global constants to
       discern messages.
 *)

role A
where "A =
  [ Send ''1'' <| sAV ''A'', sN ''Na'' |>
  , Recv ''2'' <| sMV ''B'',
                  PEnc <| sC ''2'', sN ''Na'', sMV ''Kab'' |>
                       ( sKbd (AVar ''A'') (MVar ''B'') )
               |>
  , Send ''3'' ( PEnc <| sC ''3'', sN ''Na'' |> ( sMV ''Kab'' ) )
  , Recv ''4'' ( sMV ''Nb'' )
  ]"

role B
where "B =
  [ Recv ''1'' <| sMV ''A'', sMV ''Na'' |>
  , Send ''2'' <| sAV ''B'',
                  PEnc <| sC ''2'', sMV ''Na'', sN ''Kab'' |>
                       ( sKbd (MVar ''A'') (AVar ''B'') )
               |>
  , Recv ''3'' ( PEnc <| sC ''3'', sMV ''Na'' |> ( sN ''Kab'' ) )
  , Send ''4'' ( sN ''Nb'' )
  ]"

protocol Andrew
where "Andrew = { A, B }"

locale restricted_Andrew_state = Andrew_state

type_invariant Andrew_msc_typing for Andrew
where "Andrew_msc_typing = mk_typing
  [ ((B, ''A''), (KnownT B_1))
  , ((A, ''B''), (KnownT A_2))
  , ((A, ''Kab''), (SumT (KnownT A_2) (NonceT B ''Kab'')))
  , ((B, ''Na''), (KnownT B_1))
  , ((A, ''Nb''), (KnownT A_4))
  ]"

sublocale Andrew_state < Andrew_msc_typing_state
proof -
  have "(t,r,s) : approx Andrew_msc_typing"
  proof(cases rule: reachable_in_approxI_ext
        [OF Andrew_msc_typing.monoTyp, completeness_cases_rule])
    case (A_2_B t r s tid0)
    then interpret state: Andrew_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = A_2_B
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (A_2_Kab t r s tid0)
    then interpret state: Andrew_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = A_2_Kab
    thus ?case
    proof(sources! "
        Enc {| LC ''2'', LN ''Na'' tid0, s(MV ''Kab'' tid0) |}
            ( Kbd ( s(AV ''A'' tid0) ) ( s(MV ''B'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (B_1_A t r s tid0)
    then interpret state: Andrew_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = B_1_A
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (B_1_Na t r s tid0)
    then interpret state: Andrew_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = B_1_Na
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  qed
  thus "Andrew_msc_typing_state t r s" by unfold_locales auto
qed

text{* Prove secrecy of long-term keys. *}
context Andrew_state begin

  (* This rule is unsafe in general, but OK here,
     as we are only reasoning about static compromise.
  *)
  lemma static_longterm_key_reveal[dest!]:
    "predOrd t (LKR a) e ==> RLKR a : reveals t"
    by (auto intro: compr_predOrdI)

  lemma longterm_private_key_secrecy:
    assumes facts:
      "SK m : knows t"
      "RLKR m ~: reveals t"
    shows "False"
  using facts by (sources "SK m")

  lemma longterm_sym_ud_key_secrecy:
    assumes facts:
      "K m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
    shows "False"
  using facts by (sources "K m1 m2")

  lemma longterm_sym_bd_key_secrecy:
    assumes facts:
      "Kbd m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
      "m1 : Agent"
      "m2 : Agent"
    shows "False"
  proof -
    from facts
    have "KShr (agents {m1, m2}) : knows t"
      by (auto simp: Kbd_def)
    thus ?thesis using facts
    proof (sources "KShr (agents {m1, m2})")
    qed (auto simp: agents_def Agent_def)
  qed

  lemmas ltk_secrecy =
    longterm_sym_ud_key_secrecy
    longterm_sym_ud_key_secrecy[OF in_knows_predOrd1]
    longterm_sym_bd_key_secrecy
    longterm_sym_bd_key_secrecy[OF in_knows_predOrd1]
    longterm_private_key_secrecy
    longterm_private_key_secrecy[OF in_knows_predOrd1]

end

(* subsection:  Security Properties  *)

lemma (in restricted_Andrew_state) B_sec_Kab:
  assumes facts:
    "roleMap r tid0 = Some B"
    "RLKR(s(AV ''B'' tid0)) ~: reveals t"
    "RLKR(s(MV ''A'' tid0)) ~: reveals t"
    "LN ''Kab'' tid0 : knows t"
  shows "False"
using facts proof(sources! " LN ''Kab'' tid0 ")
  case B_2_Kab note_unified facts = this facts
  thus ?thesis by (auto dest!: ltk_secrecy)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_Andrew_state) A_sec_Kab:
  assumes facts:
    "roleMap r tid0 = Some A"
    "RLKR(s(AV ''A'' tid0)) ~: reveals t"
    "RLKR(s(MV ''B'' tid0)) ~: reveals t"
    "( tid0, A_2 ) : steps t"
    "s(MV ''Kab'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''2'', LN ''Na'' tid0, s(MV ''Kab'' tid0) |}
                       ( Kbd ( s(AV ''A'' tid0) ) ( s(MV ''B'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (B_2_enc tid1) note_unified facts = this facts
    hence "Kbd ( s(AV ''B'' tid1) )
               ( s(MV ''A'' tid1) ) = Kbd ( s(AV ''A'' tid0) ) ( s(MV ''B'' tid0) )"
      by simp note facts = this facts
    thus ?thesis proof(cases rule: Kbd_cases)
      case noswap note_unified facts = this facts
      thus ?thesis by (fastforce dest: B_sec_Kab intro: event_predOrdI)
    next
      case swapped note_unified facts = this facts
      thus ?thesis by (fastforce dest: B_sec_Kab intro: event_predOrdI)
    qed (fastforce+)?
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

(* text:
No agreement on the agent identities is achieved because they may be swapped
due to the bidirectional shared key. As Lowe noted this gives rise to an attack
on entity authentication.
 *)

lemma (in restricted_Andrew_state) A_noninjective_agreement:
  assumes facts:
    "roleMap r tid1 = Some A"
    "RLKR(s(AV ''A'' tid1)) ~: reveals t"
    "RLKR(s(MV ''B'' tid1)) ~: reveals t"
    "( tid1, A_2 ) : steps t"
  shows
    "(?  tid2.
        roleMap r tid2 = Some B &
        LN ''Na'' tid1 = s(MV ''Na'' tid2) &
        s(MV ''Kab'' tid1) = LN ''Kab'' tid2)"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''2'', LN ''Na'' tid1, s(MV ''Kab'' tid1) |}
                       ( Kbd ( s(AV ''A'' tid1) ) ( s(MV ''B'' tid1) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (B_2_enc tid2) note_unified facts = this facts
    thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_Andrew_state) B_noninjective_agreement:
  assumes facts:
    "roleMap r tid1 = Some B"
    "RLKR(s(AV ''B'' tid1)) ~: reveals t"
    "RLKR(s(MV ''A'' tid1)) ~: reveals t"
    "( tid1, B_3 ) : steps t"
  shows
    "(?  tid2.
        roleMap r tid2 = Some A &
        s(MV ''Na'' tid1) = LN ''Na'' tid2 &
        LN ''Kab'' tid1 = s(MV ''Kab'' tid2))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''3'', s(MV ''Na'' tid1) |} ( LN ''Kab'' tid1 ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (fastforce dest: B_sec_Kab intro: event_predOrdI)
  next
    case (A_3_enc tid2) note_unified facts = this facts
    thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

end


theory GTT_Transitive_Closure
  imports GTT_Compose
begin

subsection \<open>GTT closure under transitivity\<close>

inductive_set \<Delta>_trancl_set :: "('q, 'f) ta \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q \<times> 'q) set" for A B where
  \<Delta>_set_cong: "TA_rule f ps p |\<in>| rules A \<Longrightarrow> TA_rule f qs q |\<in>| rules B \<Longrightarrow> length ps = length qs \<Longrightarrow>
   (\<And>i. i < length qs \<Longrightarrow> (ps ! i, qs ! i) \<in> \<Delta>_trancl_set A B) \<Longrightarrow> (p, q) \<in> \<Delta>_trancl_set A B"
| \<Delta>_set_eps1: "(p, p') |\<in>| eps A \<Longrightarrow> (p, q) \<in> \<Delta>_trancl_set A B \<Longrightarrow> (p', q) \<in> \<Delta>_trancl_set A B"
| \<Delta>_set_eps2: "(q, q') |\<in>| eps B \<Longrightarrow> (p, q) \<in> \<Delta>_trancl_set A B \<Longrightarrow> (p, q') \<in> \<Delta>_trancl_set A B"
| \<Delta>_set_trans: "(p, q) \<in> \<Delta>_trancl_set A B \<Longrightarrow> (q, r) \<in> \<Delta>_trancl_set A B \<Longrightarrow> (p, r) \<in> \<Delta>_trancl_set A B"

lemma \<Delta>_trancl_set_states: "\<Delta>_trancl_set \<A> \<B> \<subseteq> fset (\<Q> \<A> |\<times>| \<Q> \<B>)"
proof -
  {fix p q assume "(p, q) \<in> \<Delta>_trancl_set \<A> \<B>" then have "(p, q) \<in> fset (\<Q> \<A> |\<times>| \<Q> \<B>)"
      by (induct) (auto dest: rule_statesD eps_statesD simp flip: fmember_iff_member_fset)}
  then show ?thesis by auto
qed

lemma finite_\<Delta>_trancl_set [simp]: "finite (\<Delta>_trancl_set \<A> \<B>)"
  using finite_subset[OF \<Delta>_trancl_set_states]
  by simp

context
includes fset.lifting
begin
lift_definition \<Delta>_trancl :: "('q, 'f) ta \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q \<times> 'q) fset" is \<Delta>_trancl_set by simp
lemmas \<Delta>_trancl_cong = \<Delta>_set_cong [Transfer.transferred]
lemmas \<Delta>_trancl_eps1 = \<Delta>_set_eps1 [Transfer.transferred]
lemmas \<Delta>_trancl_eps2 = \<Delta>_set_eps2 [Transfer.transferred]
lemmas \<Delta>_trancl_cases = \<Delta>_trancl_set.cases[Transfer.transferred]
lemmas \<Delta>_trancl_induct [consumes 1, case_names \<Delta>_cong \<Delta>_eps1 \<Delta>_eps2 \<Delta>_trans] = \<Delta>_trancl_set.induct[Transfer.transferred]
lemmas \<Delta>_trancl_intros = \<Delta>_trancl_set.intros[Transfer.transferred]
lemmas \<Delta>_trancl_simps = \<Delta>_trancl_set.simps[Transfer.transferred]
end

lemma \<Delta>_trancl_cl [simp]:
  "(\<Delta>_trancl A B)|\<^sup>+| = \<Delta>_trancl A B"
proof -
  {fix s t assume "(s, t) |\<in>| (\<Delta>_trancl A B)|\<^sup>+|" then have "(s, t) |\<in>| \<Delta>_trancl A B"
      by (induct rule: ftrancl_induct) (auto intro: \<Delta>_trancl_intros)}
  then show ?thesis by auto
qed

lemma \<Delta>_trancl_states: "\<Delta>_trancl \<A> \<B> |\<subseteq>| (\<Q> \<A> |\<times>| \<Q> \<B>)"
  using \<Delta>_trancl_set_states
  by (metis \<Delta>_trancl.rep_eq fSigma_cong less_eq_fset.rep_eq)

definition GTT_trancl where
  "GTT_trancl G =
    (let \<Delta> = \<Delta>_trancl (snd G) (fst G) in
    (TA (rules (fst G)) (eps (fst G) |\<union>| \<Delta>),
                   TA (rules (snd G)) (eps (snd G) |\<union>| (\<Delta>|\<inverse>|))))"

lemma \<Delta>_trancl_inv:
  "(\<Delta>_trancl A B)|\<inverse>| = \<Delta>_trancl B A"
proof -
  have [dest]: "(p, q) |\<in>| \<Delta>_trancl A B \<Longrightarrow> (q, p) |\<in>| \<Delta>_trancl B A" for p q A B
    by (induct rule: \<Delta>_trancl_induct) (auto intro: \<Delta>_trancl_intros)
  show ?thesis by auto
qed

lemma gtt_states_GTT_trancl:
  "gtt_states (GTT_trancl G) |\<subseteq>| gtt_states G"
  unfolding GTT_trancl_def
  by (auto simp: gtt_states_def \<Q>_def \<Delta>_trancl_inv dest!: fsubsetD[OF \<Delta>_trancl_states] simp flip: fmember_iff_member_fset)

lemma gtt_syms_GTT_trancl:
  "gtt_syms (GTT_trancl G) = gtt_syms G"
  by (auto simp: GTT_trancl_def ta_sig_def \<Delta>_trancl_inv)

lemma GTT_trancl_base:
  "gtt_lang G \<subseteq> gtt_lang (GTT_trancl G)"
  using gtt_lang_mono[of G "GTT_trancl G"] by (auto simp: \<Delta>_trancl_inv GTT_trancl_def)

lemma GTT_trancl_trans:
  "gtt_lang (GTT_comp (GTT_trancl G) (GTT_trancl G)) \<subseteq> gtt_lang (GTT_trancl G)"
proof -
  have [dest]: "(p, q) |\<in>| \<Delta>\<^sub>\<epsilon> (TA (rules A) (eps A |\<union>| (\<Delta>_trancl B A)))
    (TA (rules B) (eps B |\<union>| (\<Delta>_trancl A B))) \<Longrightarrow> (p, q) |\<in>| \<Delta>_trancl A B" for p q A B
    by (induct rule: \<Delta>\<^sub>\<epsilon>_induct) (auto intro: \<Delta>_trancl_intros simp: \<Delta>_trancl_inv[of B A, symmetric])
  show ?thesis
    by (intro gtt_lang_mono[of "GTT_comp (GTT_trancl G) (GTT_trancl G)" "GTT_trancl G"])
       (auto simp: GTT_comp_def GTT_trancl_def fmember.abs_eq \<Delta>_trancl_inv)
qed

lemma agtt_lang_base:
  "agtt_lang G \<subseteq> agtt_lang (GTT_trancl G)"
  by (rule agtt_lang_mono) (auto simp: GTT_trancl_def \<Delta>_trancl_inv)

lemma \<Delta>\<^sub>\<epsilon>_tr_incl:
  "\<Delta>\<^sub>\<epsilon> (TA (rules A) (eps A |\<union>| \<Delta>_trancl B A)) (TA (rules B)  (eps B |\<union>| \<Delta>_trancl A B)) = \<Delta>_trancl A B"
   (is "?LS = ?RS")
proof -
  {fix p q assume "(p, q) |\<in>| ?LS" then have "(p, q) |\<in>| ?RS"
      by (induct rule: \<Delta>\<^sub>\<epsilon>_induct)
         (auto simp: \<Delta>_trancl_inv[of B A, symmetric] intro: \<Delta>_trancl_intros)}
  moreover
  {fix p q assume "(p, q) |\<in>| ?RS" then have "(p, q) |\<in>| ?LS"
      by (induct rule: \<Delta>_trancl_induct)
        (auto simp: \<Delta>_trancl_inv[of B A, symmetric] intro: \<Delta>\<^sub>\<epsilon>_intros)}
  ultimately show ?thesis
    by auto
qed

lemma agtt_lang_trans:
  "gcomp_rel UNIV (agtt_lang (GTT_trancl G)) (agtt_lang (GTT_trancl G)) \<subseteq> agtt_lang (GTT_trancl G)"
proof -
  have [intro!, dest]: "(p, q) |\<in>| \<Delta>\<^sub>\<epsilon> (TA (rules A) (eps A |\<union>| (\<Delta>_trancl B A)))
    (TA (rules B) (eps B |\<union>| (\<Delta>_trancl A B))) \<Longrightarrow> (p, q) |\<in>| \<Delta>_trancl A B" for p q A B
    by (induct rule: \<Delta>\<^sub>\<epsilon>_induct) (auto intro: \<Delta>_trancl_intros simp: \<Delta>_trancl_inv[of B A, symmetric])
  show ?thesis
    by (rule subset_trans[OF gtt_comp_acomplete agtt_lang_mono])
       (auto simp: GTT_comp_def GTT_trancl_def \<Delta>_trancl_inv)
qed

lemma GTT_trancl_acomplete:
  "gtrancl_rel UNIV (agtt_lang G) \<subseteq> agtt_lang (GTT_trancl G)"
  unfolding gtrancl_rel_def
  using agtt_lang_base[of G] gmctxt_cl_mono_rel[OF agtt_lang_base[of G], of UNIV]
  using agtt_lang_trans[of G]
  unfolding gcomp_rel_def
  by (intro kleene_trancl_induct) blast+

lemma Restr_rtrancl_gtt_lang_eq_trancl_gtt_lang:
  "(gtt_lang G)\<^sup>* = (gtt_lang G)\<^sup>+"
  by (auto simp: rtrancl_trancl_reflcl simp del: reflcl_trancl dest: tranclD tranclD2 intro: gmctxt_cl_refl)

lemma GTT_trancl_complete:
  "(gtt_lang G)\<^sup>+ \<subseteq> gtt_lang (GTT_trancl G)"
  using GTT_trancl_base subset_trans[OF gtt_comp_lang_complete GTT_trancl_trans]
  by (metis trancl_id trancl_mono_set trans_O_iff)

lemma trancl_gtt_lang_arg_closed:
  assumes "length ss = length ts" "\<forall>i < length ts. (ss ! i, ts ! i) \<in> (gtt_lang \<G>)\<^sup>+"
  shows "(GFun f ss, GFun f ts) \<in> (gtt_lang \<G>)\<^sup>+" (is "?e \<in> _")
proof -
  have "all_ctxt_closed UNIV ((gtt_lang \<G>)\<^sup>+)" by (intro all_ctxt_closed_trancl) auto
  from all_ctxt_closedD[OF this _ assms] show ?thesis
    by auto
qed

lemma \<Delta>_trancl_sound:
  assumes "(p, q) |\<in>| \<Delta>_trancl A B"
  obtains s t where "(s, t) \<in> (gtt_lang (B, A))\<^sup>+" "p |\<in>| gta_der A s" "q |\<in>| gta_der B t"
  using assms
proof (induct arbitrary: thesis rule: \<Delta>_trancl_induct)
  case (\<Delta>_cong f ps p qs q)
  have "\<exists>si ti. (si, ti) \<in> (gtt_lang (B, A))\<^sup>+ \<and> ps ! i |\<in>| gta_der A (si) \<and>
      qs ! i |\<in>| gta_der B (ti)" if "i < length qs" for i
    using \<Delta>_cong(5)[OF that] by metis
  then obtain ss ts where
    "\<And>i. i < length qs \<Longrightarrow> (ss i, ts i) \<in> (gtt_lang (B, A))\<^sup>+ \<and> ps ! i |\<in>| gta_der A (ss i) \<and> qs ! i |\<in>| gta_der B (ts i)" by metis
  then show ?case using \<Delta>_cong(1-5)
    by (intro \<Delta>_cong(6)[of "GFun f (map ss [0..<length ps])" "GFun f (map ts [0..<length qs])"])
       (auto simp: gta_der_def intro!: trancl_gtt_lang_arg_closed)
next
  case (\<Delta>_eps1 p p' q) then show ?case
    by (metis gta_der_def ta_der_eps)
next
  case (\<Delta>_eps2 q q' p) then show ?case
    by (metis gta_der_def ta_der_eps)
next
  case (\<Delta>_trans p q r)
  obtain s1 t1 where "(s1, t1) \<in> (gtt_lang (B, A))\<^sup>+" "p |\<in>| gta_der A s1" "q |\<in>| gta_der B t1"
    using \<Delta>_trans(2) .note 1 = this
  obtain s2 t2 where "(s2, t2) \<in> (gtt_lang (B, A))\<^sup>+" "q |\<in>| gta_der A s2" "r |\<in>| gta_der B t2"
    using \<Delta>_trans(4) . note 2 = this
  have "(t1, s2) \<in> gtt_lang (B, A)" using 1(1,3) 2(1,2)
    by (auto simp: Restr_rtrancl_gtt_lang_eq_trancl_gtt_lang[symmetric] gtt_lang_join)
  then have "(s1, t2) \<in> (gtt_lang (B, A))\<^sup>+" using 1(1) 2(1)
    by (meson trancl.trancl_into_trancl trancl_trans)
  then show ?case using 1(2) 2(3) by (auto intro: \<Delta>_trans(5)[of s1 t2])
qed

lemma GTT_trancl_sound_aux:
  assumes "p |\<in>| gta_der (TA (rules A) (eps A |\<union>| (\<Delta>_trancl B A))) s"
  shows "\<exists>t. (s, t) \<in> (gtt_lang (A, B))\<^sup>+ \<and> p |\<in>| gta_der A t"
  using assms
proof (induct s arbitrary: p)
  case (GFun f ss)
  let ?eps = "eps A |\<union>| \<Delta>_trancl B A"
  obtain qs q where q: "TA_rule f qs q |\<in>| rules A" "q = p \<or> (q, p) |\<in>| ?eps|\<^sup>+|" "length qs = length ss"
   "\<And>i. i < length ss \<Longrightarrow> qs ! i |\<in>| gta_der (TA (rules A) ?eps) (ss ! i)"
    using GFun(2) by (auto simp: gta_der_def)
  have "\<And>i. i < length ss \<Longrightarrow> \<exists>ti. (ss ! i, ti) \<in> (gtt_lang (A, B))\<^sup>+ \<and> qs ! i |\<in>| gta_der A (ti)"
    using GFun(1)[OF nth_mem q(4)] unfolding gta_der_def by fastforce
  then obtain ts where ts: "\<And>i. i < length ss \<Longrightarrow> (ss ! i, ts i) \<in> (gtt_lang (A, B))\<^sup>+ \<and> qs ! i |\<in>| gta_der A (ts i)"
    by metis
  then have q': "q |\<in>| gta_der A (GFun f (map ts [0..<length ss]))"
    "(GFun f ss, GFun f (map ts [0..<length ss])) \<in> (gtt_lang (A, B))\<^sup>+" using q(1, 3)
    by (auto simp: gta_der_def intro!: exI[of _ qs] exI[of _ q] trancl_gtt_lang_arg_closed)
  {fix p q u assume ass: "(p, q) |\<in>| \<Delta>_trancl B A" "(GFun f ss, u) \<in> (gtt_lang (A, B))\<^sup>+ \<and> p |\<in>| gta_der A u"
    from \<Delta>_trancl_sound[OF this(1)] obtain s t
      where "(s, t) \<in> (gtt_lang (A, B))\<^sup>+" "p |\<in>| gta_der B s" "q |\<in>| gta_der A t" . note st = this
    have "(u, s) \<in> gtt_lang (A, B)" using st conjunct2[OF ass(2)]
      by (auto simp: Restr_rtrancl_gtt_lang_eq_trancl_gtt_lang[symmetric] gtt_lang_join)
    then have "(GFun f ss, t) \<in> (gtt_lang (A, B))\<^sup>+"
      using ass st(1) by (meson trancl_into_trancl2 trancl_trans)
    then have "\<exists> s t. (GFun f ss, t) \<in> (gtt_lang (A, B))\<^sup>+ \<and> q |\<in>| gta_der A t" using st by blast}
  note trancl_step = this
  show ?case
  proof (cases "q = p")
    case True
    then show ?thesis using ts q(1, 3)
      by (auto simp: gta_der_def intro!: exI[of _"GFun f (map ts [0..< length ss])"] trancl_gtt_lang_arg_closed) blast
  next
    case False
    then have "(q, p) |\<in>| ?eps|\<^sup>+|" using q(2) by simp
    then show ?thesis using q(1) q'
    proof (induct rule: ftrancl_induct)
      case (Base q p) from Base(1) show ?case
      proof
        assume "(q, p) |\<in>| eps A" then show ?thesis using Base(2) ts q(3)
          by (auto simp: gta_der_def intro!: exI[of _"GFun f (map ts [0..< length ss])"]
                         trancl_gtt_lang_arg_closed exI[of _ qs] exI[of _ q])
      next
        assume "(q, p) |\<in>| (\<Delta>_trancl B A)"
        then have "(q, p) |\<in>| \<Delta>_trancl B A" by (simp add: fmember.abs_eq)
        from trancl_step[OF this] show ?thesis using Base(3, 4)
          by auto
      qed
    next
      case (Step p q r)
      from Step(2, 4-) obtain s' where s': "(GFun f ss, s') \<in> (gtt_lang (A, B))\<^sup>+ \<and> q |\<in>| gta_der A s'" by auto
      show ?case using Step(3)
      proof
        assume "(q, r) |\<in>| eps A" then show ?thesis using s'
          by (auto simp: gta_der_def ta_der_eps intro!: exI[of _ s'])
      next
        assume "(q, r) |\<in>| \<Delta>_trancl B A"
        then have "(q, r) |\<in>| \<Delta>_trancl B A" by (simp add: fmember.abs_eq)
        from trancl_step[OF this] show ?thesis using s' by auto
      qed
    qed
  qed
qed

lemma GTT_trancl_asound:
  "agtt_lang (GTT_trancl G) \<subseteq> gtrancl_rel UNIV (agtt_lang G)"
proof (intro subrelI, goal_cases LR)
  case (LR s t)
  then obtain s' q t' where *: "(s, s') \<in> (gtt_lang G)\<^sup>+"
    "q |\<in>| gta_der (fst G) s'" "q |\<in>| gta_der (snd G) t'" "(t', t) \<in> (gtt_lang G)\<^sup>+"
    by (auto simp: agtt_lang_def GTT_trancl_def trancl_converse \<Delta>_trancl_inv
      simp flip: gtt_lang_swap[of "fst G" "snd G", unfolded prod.collapse agtt_lang_def, simplified]
      dest!: GTT_trancl_sound_aux)
  then have "(s', t') \<in> agtt_lang G" using *(2,3)
    by (auto simp: agtt_lang_def)
  then show ?case using *(1,4) unfolding gtrancl_rel_def
    by auto
qed

lemma GTT_trancl_sound:
  "gtt_lang (GTT_trancl G) \<subseteq> (gtt_lang G)\<^sup>+"
proof -
  note [dest] = GTT_trancl_sound_aux
  have "gtt_accept (GTT_trancl G) s t \<Longrightarrow> (s, t) \<in> (gtt_lang G)\<^sup>+" for s t unfolding gtt_accept_def
  proof (induct rule: gmctxt_cl.induct)
    case (base s t)
    from base obtain q where join: "q |\<in>| gta_der (fst (GTT_trancl G)) s" "q |\<in>| gta_der (snd (GTT_trancl G)) t"
      by (auto simp: agtt_lang_def)
    obtain s' where "(s, s') \<in> (gtt_lang G)\<^sup>+" "q |\<in>| gta_der (fst G) s'" using base join
      by (auto simp: GTT_trancl_def \<Delta>_trancl_inv agtt_lang_def)
    moreover obtain t' where "(t', t) \<in> (gtt_lang G)\<^sup>+" "q |\<in>| gta_der (snd G) t'" using join
      by (auto simp: GTT_trancl_def gtt_lang_swap[of "fst G" "snd G", symmetric] trancl_converse \<Delta>_trancl_inv)
    moreover have "(s', t') \<in> gtt_lang G" using calculation
      by (auto simp: Restr_rtrancl_gtt_lang_eq_trancl_gtt_lang[symmetric] gtt_lang_join)
    ultimately show "(s, t) \<in> (gtt_lang G)\<^sup>+" by (meson trancl.trancl_into_trancl trancl_trans)
  qed (auto intro!: trancl_gtt_lang_arg_closed)
  then show ?thesis by (auto simp: gtt_accept_def)
qed

lemma GTT_trancl_alang:
  "agtt_lang (GTT_trancl G) = gtrancl_rel UNIV (agtt_lang G)"
  using GTT_trancl_asound GTT_trancl_acomplete by blast

lemma GTT_trancl_lang:
  "gtt_lang (GTT_trancl G) = (gtt_lang G)\<^sup>+"
  using GTT_trancl_sound GTT_trancl_complete by blast

end


theory RepeatScorres
  imports
    RepeatShallow
    RepeatMono
    "build/Generated_SCorres_Normal"
begin

section "Shallow repeat loop definition"

overloading repeat' \<equiv> repeat
begin
definition repeat' :: "(64 word, ('a, 'b) StepParam \<Rightarrow> bool, ('a, 'b) StepParam \<Rightarrow> 'a, 'a, 'b) RepParam \<Rightarrow> 'a"
  where
"repeat x =
  repeatatm (unat (RepParam.n\<^sub>f x))
            (\<lambda>(a :: 'a) (b :: 'b). (RepParam.stop\<^sub>f x) \<lparr>StepParam.acc\<^sub>f = a, obsv\<^sub>f = b\<rparr>)
            (\<lambda>(a :: 'a) (b :: 'b). (RepParam.step\<^sub>f x) \<lparr>StepParam.acc\<^sub>f = a, obsv\<^sub>f = b\<rparr>)
            (RepParam.acc\<^sub>f x)
            (RepParam.obsv\<^sub>f x)"
end (* of overloading *)

section "Repeat loop scorres"

context shallow begin

lemma vrepeat_bod_scorres:
  "\<lbrakk>rel_leq \<xi>' \<xi>'';
    valRel \<xi>'' (x ::(64 word, ('c, 'd) StepParam \<Rightarrow> bool,  ('c, 'd) StepParam \<Rightarrow> 'c, 'c, 'd) RepParam)
      (VRecord [VPrim (LU64 n), f, g, acc, obsv]); is_vvalfun f; is_vvalfun g;
    vrepeat_bod \<xi>' (unat n) (vvalfun_to_expr f) (vvalfun_to_expr g) acc obsv v'\<rbrakk>
   \<Longrightarrow> valRel \<xi>''
              (repeatatm (unat (n\<^sub>f x)) (\<lambda>a b. stop\<^sub>f x \<lparr>StepParam.acc\<^sub>f = a, obsv\<^sub>f = b\<rparr>)
                (\<lambda>a b. step\<^sub>f x \<lparr>StepParam.acc\<^sub>f = a, obsv\<^sub>f = b\<rparr>) (RepParam.acc\<^sub>f x) (RepParam.obsv\<^sub>f x))
              v'"
  apply (induct n arbitrary: acc x)
   apply (clarsimp simp: valRel_RepParam)
   apply (subst repeatatm.simps)
   apply simp
  apply (drule unatSuc; clarsimp)
  apply (rename_tac n acc x b)
  apply (case_tac b; clarsimp)
   apply (clarsimp simp: valRel_RepParam)
   apply (subst repeatatm.simps; clarsimp)
   apply (erule notE)
   apply (erule disjE; clarsimp)
    apply (elim v_sem_appE v_sem_funE v_sem_varE; clarsimp)
    apply (erule_tac x = "\<lparr>StepParam.acc\<^sub>f = RepParam.acc\<^sub>f x, obsv\<^sub>f = RepParam.obsv\<^sub>f x\<rparr>" in allE)
    apply (erule_tac x = "VRecord [v', obsv]" in allE)
    apply (erule impE, simp add: valRel_StepParam)
    apply (erule_tac x = "VPrim (LBool True)" in allE)
    apply (drule_tac \<xi>b = \<xi>'' in  v_sem_v_sem_all_rel_leqD(1)[rotated 1]; simp)
   apply (elim v_sem_appE v_sem_afunE v_sem_varE; clarsimp)
   apply (erule_tac x = "\<lparr>StepParam.acc\<^sub>f = RepParam.acc\<^sub>f x, obsv\<^sub>f = RepParam.obsv\<^sub>f x\<rparr>" in allE)
   apply (erule_tac x = "VRecord [v', obsv]" in allE)
   apply (erule impE, simp add: valRel_StepParam)
   apply (erule_tac x = "VPrim (LBool True)" in allE)
   apply (erule impE; simp?)
   apply (rule rel_leqD[rotated 1]; assumption)
  apply (rename_tac acc')
  apply (drule_tac x = acc' in meta_spec)
  apply clarsimp
  apply (drule_tac
      x = "\<lparr>RepParam.n\<^sub>f = n, stop\<^sub>f = stop\<^sub>f x, step\<^sub>f = step\<^sub>f x,
            acc\<^sub>f = step\<^sub>f x \<lparr>StepParam.acc\<^sub>f = RepParam.acc\<^sub>f x, obsv\<^sub>f = RepParam.obsv\<^sub>f x\<rparr>,
            obsv\<^sub>f = RepParam.obsv\<^sub>f x \<rparr>" in meta_spec)
  apply (elim meta_allE meta_impE; assumption?)
   apply (clarsimp simp: valRel_RepParam)
   apply (thin_tac "_ \<or> _")
   apply (thin_tac "_, _ \<turnstile> _ \<Down> _")
   apply (elim disjE v_sem_appE v_sem_varE; clarsimp; elim v_sem_funE v_sem_afunE; clarsimp)
    apply (erule_tac x = "\<lparr>StepParam.acc\<^sub>f = RepParam.acc\<^sub>f x, obsv\<^sub>f = RepParam.obsv\<^sub>f x\<rparr>" in allE)
    apply (erule_tac x = "VRecord [acc, obsv]" in allE)
    apply (erule impE, simp add: valRel_StepParam)
    apply (erule_tac x = acc' in allE)
    apply (drule_tac \<xi>b = \<xi>'' in  v_sem_v_sem_all_rel_leqD(1)[rotated 1]; simp)
   apply (erule_tac x = "\<lparr>StepParam.acc\<^sub>f = RepParam.acc\<^sub>f x, obsv\<^sub>f = RepParam.obsv\<^sub>f x\<rparr>" in allE)
   apply (erule_tac x = "VRecord [acc, obsv]" in allE)
   apply (erule impE, simp add: valRel_StepParam)
   apply (erule_tac x = acc' in allE)
   apply (erule impE; simp?)
   apply (rule rel_leqD[rotated 1]; assumption)
  apply clarsimp
  apply (subst (asm) valRel_RepParam; clarsimp)
  apply (erule v_sem_appE; erule disjE; clarsimp; elim v_sem_funE v_sem_afunE v_sem_varE; clarsimp)
   apply (erule_tac x = "\<lparr>StepParam.acc\<^sub>f = RepParam.acc\<^sub>f x, obsv\<^sub>f = RepParam.obsv\<^sub>f x\<rparr>" in allE)
   apply (erule_tac x = "VRecord [acc, obsv]" in allE)
   apply (erule impE, simp add: valRel_StepParam)
   apply (erule_tac x = "VPrim (LBool False)" in allE)
   apply (erule impE; simp?)
   apply (rule rel_leqD[rotated 1]; assumption)
   apply (subst repeatatm.simps; clarsimp)
  apply (erule_tac x = "\<lparr>StepParam.acc\<^sub>f = RepParam.acc\<^sub>f x, obsv\<^sub>f = RepParam.obsv\<^sub>f x\<rparr>" in allE)
  apply (erule_tac x = "VRecord [acc, obsv]" in allE)
  apply (erule impE, simp add: valRel_StepParam)
  apply (erule_tac x = "VPrim (LBool False)" in allE)
  apply (erule impE, rule v_sem_v_sem_all_rel_leqD(1); simp)
  apply (subst repeatatm.simps; clarsimp)
  done

lemma repeat_scorres:
  "\<lbrakk>rel_leq \<xi>' \<xi>''; \<xi>'' ''repeat'' = prepeat \<xi>'\<rbrakk> \<Longrightarrow>
     scorres repeat (AFun ''repeat'' ts []) \<gamma> \<xi>''"
  unfolding scorres_def
  apply clarsimp
  apply (erule v_sem_afunE; clarsimp)
  apply (erule notE)
  unfolding repeat'_def prepeat_def
  apply clarsimp
  apply (rule vrepeat_bod_scorres; simp?)
  done

end (* of context *)

end


theory sch
  imports task2
begin

definition Pr :: char where "Pr = CHR ''p''"

definition G :: char where "G = CHR ''g''"

fun sched_push :: "tid \<Rightarrow> estate \<Rightarrow> state \<Rightarrow> estate" where
  "sched_push t (Sch p rn rp) s = Sch (p @ [(s (CHR ''p''), t)]) rn rp"
| "sched_push t (Task st ent tp) s = undefined"
| "sched_push t None s = undefined"

fun sched_assign :: "tid \<Rightarrow> estate \<Rightarrow> state \<Rightarrow> estate" where
  "sched_assign t (Sch p rn rp) s = Sch p t (s (CHR ''p''))"
| "sched_assign t (Task st ent tp) s = undefined"
| "sched_assign t None s = undefined"

fun get_max_default :: "real \<times> tid \<Rightarrow> (real \<times> tid) list \<Rightarrow> real \<times> tid" where
  "get_max_default (prior, t) [] = (prior, t)"
| "get_max_default (prior, t) ((prior2, t2) # rest) =
    (if prior \<ge> prior2 then
       get_max_default (prior, t) rest
     else
       get_max_default (prior2, t2) rest)"

fun get_max :: "(real \<times> tid) list \<Rightarrow> real \<times> tid" where
  "get_max [] = (-1, -1)"
| "get_max ((prior, t) # rest) = get_max_default (prior, t) rest"

fun del_proc :: "(real \<times> tid) list \<Rightarrow> tid \<Rightarrow> (real \<times> tid) list" where
  "del_proc [] t = []"
| "del_proc ((prior, t) # rest) t2 =
    (if t = t2 then rest
     else (prior, t) # del_proc rest t2)"

fun sched_get_max :: "estate \<Rightarrow> state \<Rightarrow> estate" where
  "sched_get_max (Sch p rn rp) s =
    (let (prior, t) = get_max p in Sch (del_proc p t) t prior)"
| "sched_get_max (Task st ent tp) s = undefined"
| "sched_get_max None s = undefined"

fun sched_get_max' :: "estate \<Rightarrow> estate" where
  "sched_get_max' (Sch p rn rp) =
    (let (prior, t) = get_max p in Sch (del_proc p t) t prior)"
| "sched_get_max' (Task st ent tp) = undefined"
| "sched_get_max' None = undefined"

lemma sched_get_max_eq:
"sched_get_max e s = sched_get_max' e"
  apply(cases e)
  by auto

fun sched_clear :: "estate \<Rightarrow> state \<Rightarrow> estate" where
  "sched_clear (Sch p rn rp) s = Sch [] (-1) (-1)"
| "sched_clear (Task st ent tp) s = undefined"
| "sched_clear None s = undefined"

fun sched_clear' :: "estate \<Rightarrow> estate" where
  "sched_clear' (Sch p rn rp) = Sch [] (-1) (-1)"
| "sched_clear' (Task st ent tp) = undefined"
| "sched_clear' None = undefined"

lemma sched_clear_eq:
"sched_clear e s = sched_clear' e"
  apply(cases e)
  by auto

fun sched_del_proc :: "tid \<Rightarrow> estate \<Rightarrow> state \<Rightarrow> estate" where
  "sched_del_proc t (Sch p rn rp) s = Sch (del_proc p t) rn rp"
| "sched_del_proc t (Task st ent tp) s = undefined"
| "sched_del_proc t None s = undefined"

fun sched_del_proc' :: "tid \<Rightarrow> estate \<Rightarrow> estate" where
  "sched_del_proc' t (Sch p rn rp) = Sch (del_proc p t) rn rp"
| "sched_del_proc' t (Task st ent tp) = undefined"
| "sched_del_proc' t None = undefined"

lemma sched_del_proc_eq:
"sched_del_proc t e s = sched_del_proc' t e"
  apply(cases e)
  by auto

fun run_now_assign :: "real \<Rightarrow> estate \<Rightarrow> state \<Rightarrow> estate" where
"run_now_assign rn (Sch p n rp) s = (Sch p rn rp)"

fun run_prior_assign :: "estate \<Rightarrow> state \<Rightarrow> estate" where
"run_prior_assign (Sch p n rp) s = (Sch p n (s Pr))"

definition properp :: "tid \<Rightarrow> real \<Rightarrow> bool" where
"properp rn rp = ((rn = 1 \<longleftrightarrow> rp = 2) \<and> (rn = 2 \<longleftrightarrow> rp = 1) \<and> (rn = -1 \<longleftrightarrow> rp = -1) \<and> rp \<in> {-1,1,2} \<and> rn \<in> {-1,1,2})"

fun properl :: "(real \<times> tid) list \<Rightarrow> bool" where
  "properl [] = True"
| "properl ((rp,rn) # v) = (properl v \<and> properp rn rp \<and> rn > 0 \<and> rn \<noteq> 1)"

lemma properl_p1:
"properl (p @ [(a, b)]) = (properl p \<and> properp b a \<and> b > 0 \<and> b \<noteq> 1)"
proof(induction p arbitrary: a b)
  case Nil
  then show ?case
    by auto
next
  case (Cons c p)
  show ?case
    apply(cases c)
    subgoal for ca cb
      apply simp
      using Cons[of a b]
      by auto
done
qed

lemma properl_p2:
"properl p \<Longrightarrow> properp rn rp \<Longrightarrow> properp (snd(get_max_default (rp,rn) p)) (fst(get_max_default (rp,rn) p))"
proof(induction p arbitrary: rn rp)
  case Nil
  then show ?case
    by auto
next
  case (Cons c p)
  then show ?case
    apply(cases c)
    subgoal for a b
      by auto
    done
qed

lemma properl_p3:
"properl p \<Longrightarrow> properp (snd (get_max p)) (fst (get_max p)) "
proof(induction p)
  case Nil
  then show ?case
    apply auto
    unfolding properp_def
    by auto
next
  case (Cons c p)
  then show ?case
    apply(cases c)
    subgoal for a b
      apply auto
      apply(rule properl_p2)
      by auto
    done
qed

lemma properl_p4:
"properl p \<Longrightarrow> properl (del_proc p t)"
proof(induction p)
  case Nil
  then show ?case
    by auto
next
  case (Cons c p)
  then show ?case
    apply(cases c)
    subgoal for a b
     by auto
    done
qed

lemma proper_getmax1':
"fst (get_max_default (a,b) p) < d \<Longrightarrow> a' < d \<Longrightarrow> fst (get_max_default (a,b) (p@[(a',b')])) < d"
proof(induction p arbitrary: a b)
  case Nil
  then show ?case
    by auto
next
  case (Cons g p)
  then show ?case
    apply(cases g)
    subgoal for ga gb
      by auto
    done
qed

lemma proper_getmax1:
"fst (get_max p) < d \<Longrightarrow> a' < d \<Longrightarrow> fst (get_max(p@[(a',b')])) < d"
proof(induction p)
  case Nil
  then show ?case by auto
next
  case (Cons g p)
  then show ?case
    apply (cases g)
    subgoal for ga gb
      apply auto
      using proper_getmax1'
      by auto
    done
qed

lemma proper_getmax2:
"properl p \<Longrightarrow> snd (get_max p) \<noteq> 1 \<and> (gb \<noteq> 1 \<longrightarrow> snd (get_max_default (ga, gb) p) \<noteq> 1)"
proof(induction p arbitrary: ga gb)
  case Nil
  then show ?case
    by auto
next
  case (Cons h p)
  then show ?case
    apply (cases h)
    subgoal for ha hb
      by auto
    done
qed

lemma properl_p5':
  "properl ((a,b)#p) \<Longrightarrow> snd(get_max_default (a,b) p) > 0"
proof(induction p arbitrary: a b)
  case Nil
  then show ?case
    by auto
next
  case (Cons g p)
  then show ?case
    apply(cases g)
    by auto
qed

lemma properl_p5:
"length p > 0 \<Longrightarrow> properl p \<Longrightarrow> properp (snd (get_max p)) (fst (get_max p)) \<and> (snd (get_max p)) > 0 \<and> (snd (get_max p)) \<noteq> 1"
proof(induction p)
  case Nil
  then show ?case
    by auto
next
  case (Cons c p)
  then show ?case
    apply(cases c)
    subgoal for a b
      apply auto
      subgoal
      apply(rule properl_p2)
         apply auto
        done
       prefer 2
      subgoal
        using proper_getmax2 apply auto
        done
      using properl_p5'[of 1 2 p]
      apply auto
      unfolding properp_def
      by auto
    done
qed

definition proper :: "estate \<Rightarrow> bool " where
"proper schs = ((properp (run_now schs) (run_prior schs)) \<and> properl (pool schs))"

definition SCH :: "estate proc" where
"SCH = EChoice [(req_ch 1[?]Pr,IF (\<lambda> s. run_prior (fst s) \<ge> (snd s) Pr) THEN Basic (sched_push 1)
                   ELSE (IF (\<lambda> s. run_now (fst s) = 2) THEN Cm (preempt_ch 2[!](\<lambda>_ . 0)) ELSE Skip FI; Cm (run_ch 1[!](\<lambda>_ . 0));Basic (run_now_assign 1);Basic run_prior_assign) FI),
                (req_ch 2[?]Pr,IF (\<lambda> s. run_prior (fst s) \<ge> (snd s) Pr) THEN Basic (sched_push 2)
                   ELSE (IF (\<lambda> s. run_now (fst s) = 1) THEN Cm (preempt_ch 1[!](\<lambda>_ . 0)) ELSE Skip FI; Cm (run_ch 2[!](\<lambda>_ . 0));Basic (run_now_assign 2);Basic run_prior_assign) FI),
                (free_ch 1[?]G,IF (\<lambda> s. length (pool (fst s)) > 0) THEN ((Basic sched_get_max);(IF (\<lambda> s. run_now (fst s) = 1)THEN Cm (run_ch 1[!](\<lambda>_.0)) ELSE Cm (run_ch 2[!](\<lambda>_.0)) FI))
                   ELSE Basic sched_clear FI),
                (free_ch 2[?]G,IF (\<lambda> s. length (pool (fst s)) > 0) THEN ((Basic sched_get_max);(IF (\<lambda> s. run_now (fst s) = 1)THEN Cm (run_ch 1[!](\<lambda>_.0)) ELSE Cm (run_ch 2[!](\<lambda>_.0)) FI))
                   ELSE Basic sched_clear FI),
                (exit_ch 1[?]G,Basic (sched_del_proc 1)),
                (exit_ch 2[?]G,Basic (sched_del_proc 2))]"

definition QQ :: "(real \<times> tid) list \<Rightarrow> tid \<Rightarrow> real \<Rightarrow> state \<Rightarrow> estate assn \<Rightarrow> estate assn"where
"QQ p rn rp ss P = (\<lambda> s t. (if rp \<ge> 2 then s = (Sch (p @ [(2, 1)]) rn rp,ss(Pr:=2)) \<and> (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (req_ch 1) 2 ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2}))) t
        else if rn = 2 then s = (Sch p 1 2, ss(Pr:=2)) \<and> (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (req_ch 1) 2 ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2})) @\<^sub>t ((Out0\<^sub>t (preempt_ch 2) 0) @\<^sub>t (Out0\<^sub>t (run_ch 1) 0) \<or>\<^sub>t (Waitp\<^sub>t  ({preempt_ch 2},{})) @\<^sub>t true\<^sub>A \<or>\<^sub>t (Out0\<^sub>t (preempt_ch 2) 0) @\<^sub>t(Waitp\<^sub>t  ({run_ch 1},{})) @\<^sub>t true\<^sub>A)) t
                        else s = (Sch p 1 2, ss(Pr:=2)) \<and> (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (req_ch 1) 2 ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2})) @\<^sub>t ((Out0\<^sub>t (run_ch 1) 0) \<or>\<^sub>t (Waitp\<^sub>t ({run_ch 1},{})) @\<^sub>t true\<^sub>A )) t)
         \<or> (\<exists> v\<noteq>2. (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (req_ch 1) v ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2})) @\<^sub>t true\<^sub>A ) t)
                        \<or> (if rp \<ge> 1 then s = (Sch (p @ [(1, 2)]) rn rp,ss(Pr:=1)) \<and> (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (req_ch 2) 1 ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2}))) t
        else if rn = 1 then s = (Sch p 2 1, ss(Pr:=1)) \<and> (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (req_ch 2) 1 ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2})) @\<^sub>t ((Out0\<^sub>t (preempt_ch 1) 0) @\<^sub>t (Out0\<^sub>t (run_ch 2) 0) \<or>\<^sub>t (Waitp\<^sub>t  ({preempt_ch 1},{})) @\<^sub>t true\<^sub>A \<or>\<^sub>t (Out0\<^sub>t (preempt_ch 1) 0) @\<^sub>t(Waitp\<^sub>t  ({run_ch 2},{})) @\<^sub>t true\<^sub>A)) t
                        else s = (Sch p 2 1, ss(Pr:=1)) \<and> (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (req_ch 2) 1 ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2})) @\<^sub>t ((Out0\<^sub>t (run_ch 2) 0) \<or>\<^sub>t (Waitp\<^sub>t  ({run_ch 2},{})) @\<^sub>t true\<^sub>A )) t)
         \<or> (\<exists> v\<noteq>1. (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (req_ch 2) v ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2})) @\<^sub>t true\<^sub>A ) t)
         \<or> (\<exists> v. if length p > 0 then s = (sched_get_max'(Sch p rn rp),ss(G:=v))
                    \<and> (if run_now(sched_get_max'(Sch p rn rp)) = 1
                        then (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (free_ch 1) v ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2})) @\<^sub>t ((Out0\<^sub>t (run_ch 1) 0) \<or>\<^sub>t (Waitp\<^sub>t  ({run_ch 1},{})) @\<^sub>t true\<^sub>A )) t
                        else (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (free_ch 1) v ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2})) @\<^sub>t ((Out0\<^sub>t (run_ch 2) 0) \<or>\<^sub>t (Waitp\<^sub>t  ({run_ch 2},{})) @\<^sub>t true\<^sub>A )) t)
                  else s = (sched_clear'(Sch p rn rp),ss(G:=v)) \<and> (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (free_ch 1) v ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2}))) t)
        \<or>  (\<exists> v. if length p > 0 then s = (sched_get_max'(Sch p rn rp),ss(G:=v))
                    \<and> (if run_now(sched_get_max'(Sch p rn rp)) = 1
                        then (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (free_ch 2) v ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2})) @\<^sub>t ((Out0\<^sub>t (run_ch 1) 0) \<or>\<^sub>t (Waitp\<^sub>t  ({run_ch 1},{})) @\<^sub>t true\<^sub>A )) t
                        else (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (free_ch 2) v ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2})) @\<^sub>t ((Out0\<^sub>t (run_ch 2) 0) \<or>\<^sub>t (Waitp\<^sub>t  ({run_ch 2},{})) @\<^sub>t true\<^sub>A )) t)
                  else s = (sched_clear'(Sch p rn rp),ss(G:=v)) \<and> (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (free_ch 2) v ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2}))) t)
        \<or>  (\<exists> v. s = (sched_del_proc' 1 (Sch p rn rp),ss(G:=v)) \<and> (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (exit_ch 1) v ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2}))) t)
        \<or>  (\<exists> v. s = (sched_del_proc' 2 (Sch p rn rp),ss(G:=v)) \<and> (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (exit_ch 2) v ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2}))) t))"

lemma Sch_Valid_1:
"\<Turnstile> {\<lambda>s t. s = (Sch p rn rp,ss) \<and> P s t}
   SCH
    {\<lambda> s t. QQ p rn rp ss P s t}"
  unfolding  SCH_def
  apply(rule Valid_echoice)
  apply auto
  subgoal for i a p2
    apply(cases i)
    subgoal
      apply auto
      apply(rule exI[where x="\<lambda> s t. (s = (Sch p rn rp, ss(Pr:=2)) \<and> (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (req_ch 1) 2 ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2}))) t) \<or>
                                     (\<exists> v\<noteq>2. s = (Sch p rn rp, ss(Pr:=v)) \<and> (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (req_ch 1) v ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2}))) t)"])

      apply(rule conjI)
      subgoal
        apply(rule Valid_pre_or)
        subgoal
        apply(rule Valid_strengthen_post)
          prefer 2
           apply(rule Valid_cond_sp)
            apply(rule Valid_basic_sp1)
           apply(rule Valid_seq)
            apply(rule Valid_cond_sp)
             apply(rule Valid_send_sp_assm0)
            apply(rule Valid_skip)
           apply(rule Valid_seq)
            apply(rule Valid_send_sp_assm0)
            apply(rule Valid_seq)
            apply(rule Valid_basic_sp1)
           apply(rule Valid_basic_sp1)
          apply(rule entails_disjE')
          subgoal
            unfolding entails_def
            apply(rule allI)+
            subgoal for s tr
              apply auto
              unfolding QQ_def
              apply(rule disjI1)
              apply (auto simp add: Pr_def)
              by (metis prod.exhaust_sel)
            done
          subgoal
            unfolding entails_def
            apply(rule allI)+
            subgoal for s tr
              apply auto
              unfolding QQ_def
              apply(rule disjI1)
              apply(cases s)
              apply (auto simp add: Pr_def pure_assn_def conj_assn_def join_assn_def)
              subgoal for tr2 tr1b tr2a tr2b
                apply(rule exI[where x=tr1b])
                apply auto
                apply(rule exI[where x=tr2b])
                apply auto
                unfolding disj_assn_def
                apply(erule disjE)
                subgoal
                  apply(erule disjE)
                  subgoal by auto
                  subgoal
                    apply(rule disjI2)
                    apply(rule disjI1)
                    by(auto simp add: true_assn_def)
                  done
                subgoal
                apply(erule disjE)
                  subgoal
                    apply(rule disjI2)
                    apply(rule disjI2)
                    by(auto simp add: true_assn_def)
                  subgoal
                    apply(rule disjI2)
                    apply(rule disjI1)
                    by(auto simp add: true_assn_def)
                  done
                done
              subgoal for tr2 tr1a tr2a
                apply(rule exI[where x=tr1a])
                by auto
              done
            done
          done
        subgoal
          apply(rule Valid_ex_pre)
          subgoal for v
          apply(rule Valid_weaken_pre[where P'="\<lambda> s t. (\<up>(v\<noteq>2) \<and>\<^sub>t (P (Sch p rn rp, ss)) @\<^sub>t
                    Inrdy\<^sub>t (Sch p rn rp, ss) (req_ch 1) v ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2}))t"])
          subgoal
            unfolding entails_def pure_assn_def conj_assn_def
            by auto
          subgoal
            apply(rule Valid_strengthen_post)
             prefer 2
             apply(rule Valid_true)
            unfolding QQ_def
            apply(rule entails_disjI2')
            unfolding entails_def
            by (auto simp add:pure_assn_def conj_assn_def join_assoc)
          done
        done
      done
      apply(rule conjI)
      subgoal unfolding entails_def
        apply(rule allI)+
        subgoal for s tr
          apply(rule impI)
          apply simp
          apply(rule allI)
          subgoal for v
            apply(cases "v=2")
            subgoal apply(rule disjI1)
              apply auto
              apply(auto simp add:join_assn_def)
              using inrdy_assn.intros(1) by blast
            subgoal apply(rule disjI2)
              apply auto
              apply(rule exI[where x=v])
              apply simp
              apply(auto simp add:join_assn_def)
              using inrdy_assn.intros(1) by blast
            done
          done
        done
      subgoal unfolding entails_def
        apply(rule allI)+
        subgoal for s tr
          apply(rule impI)
          apply simp
          apply(rule allI)
          subgoal for d
          apply(rule impI)
          apply(rule allI)
          subgoal for v
            apply(cases "v=2")
            subgoal apply(rule disjI1)
              apply auto
              apply(auto simp add:join_assn_def)
              using inrdy_assn.intros(2) by blast
            subgoal apply(rule disjI2)
              apply auto
              apply(rule exI[where x=v])
              apply simp
              apply(auto simp add:join_assn_def)
              using inrdy_assn.intros(2) by blast
            done
          done
        done
      done
    done
  subgoal for i'
    apply(cases i')
    subgoal
      apply auto
      apply(rule exI[where x="\<lambda> s t. (s = (Sch p rn rp, ss(Pr:=1)) \<and> (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (req_ch 2) 1 ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2}))) t) \<or>
                                     (\<exists> v\<noteq>1. s = (Sch p rn rp, ss(Pr:=v)) \<and> (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (req_ch 2) v ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2}))) t)"])
      apply(rule conjI)
      subgoal
        apply(rule Valid_pre_or)
        subgoal
        apply(rule Valid_strengthen_post)
          prefer 2
           apply(rule Valid_cond_sp)
            apply(rule Valid_basic_sp1)
           apply(rule Valid_seq)
            apply(rule Valid_cond_sp)
             apply(rule Valid_send_sp_assm0)
            apply(rule Valid_skip)
           apply(rule Valid_seq)
            apply(rule Valid_send_sp_assm0)
            apply(rule Valid_seq)
            apply(rule Valid_basic_sp1)
           apply(rule Valid_basic_sp1)
          apply(rule entails_disjE')
          subgoal
            unfolding entails_def
            apply(rule allI)+
            subgoal for s tr
              apply auto
              unfolding QQ_def
              apply(rule disjI2)
              apply(rule disjI2)
              apply(rule disjI1)
              apply (auto simp add: Pr_def)
              by (metis prod.exhaust_sel)
            done
          subgoal
            unfolding entails_def
            apply(rule allI)+
            subgoal for s tr
              apply auto
              unfolding QQ_def
              apply(rule disjI2)
              apply(rule disjI2)
              apply(rule disjI1)
              apply(cases s)
              apply (auto simp add: Pr_def pure_assn_def conj_assn_def join_assn_def)
              subgoal for tr2 tr1b tr2a tr2b
                apply(rule exI[where x=tr1b])
                apply auto
                apply(rule exI[where x=tr2b])
                apply auto
                unfolding disj_assn_def
                apply(erule disjE)
                subgoal
                  apply(erule disjE)
                  subgoal by auto
                  subgoal
                    apply(rule disjI2)
                    apply(rule disjI1)
                    by(auto simp add: true_assn_def)
                  done
                subgoal
                apply(erule disjE)
                  subgoal
                    apply(rule disjI2)
                    apply(rule disjI2)
                    by(auto simp add: true_assn_def)
                  subgoal
                    apply(rule disjI2)
                    apply(rule disjI1)
                    by(auto simp add: true_assn_def)
                  done
                done
              subgoal for tr2 tr1a tr2a
                apply(rule exI[where x=tr1a])
                by auto
              done
            done
          done
        subgoal
          apply(rule Valid_ex_pre)
          subgoal for v
          apply(rule Valid_weaken_pre[where P'="\<lambda> s t. (\<up>(v\<noteq>1) \<and>\<^sub>t (P (Sch p rn rp, ss)) @\<^sub>t
                    Inrdy\<^sub>t (Sch p rn rp, ss) (req_ch 2) v ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2}))t"])
          subgoal
            unfolding entails_def pure_assn_def conj_assn_def
            by auto
          subgoal
            apply(rule Valid_strengthen_post)
             prefer 2
             apply(rule Valid_true)
            unfolding QQ_def
            apply(rule entails_disjI2')
            unfolding entails_def
            by (auto simp add:pure_assn_def conj_assn_def join_assoc)
          done
        done
      done
      apply(rule conjI)
      subgoal unfolding entails_def
        apply(rule allI)+
        subgoal for s tr
          apply(rule impI)
          apply simp
          apply(rule allI)
          subgoal for v
            apply(cases "v=1")
            subgoal apply(rule disjI1)
              apply auto
              apply(auto simp add:join_assn_def)
              using inrdy_assn.intros(1) by blast
            subgoal apply(rule disjI2)
              apply auto
              apply(rule exI[where x=v])
              apply simp
              apply(auto simp add:join_assn_def)
              using inrdy_assn.intros(1) by blast
            done
          done
        done
      subgoal unfolding entails_def
        apply(rule allI)+
        subgoal for s tr
          apply(rule impI)
          apply simp
          apply(rule allI)
          subgoal for d
          apply(rule impI)
          apply(rule allI)
          subgoal for v
            apply(cases "v=1")
            subgoal apply(rule disjI1)
              apply auto
              apply(auto simp add:join_assn_def)
              using inrdy_assn.intros(2) by blast
            subgoal apply(rule disjI2)
              apply auto
              apply(rule exI[where x=v])
              apply simp
              apply(auto simp add:join_assn_def)
              using inrdy_assn.intros(2) by blast
            done
          done
        done
      done
    done
  subgoal for i''
    apply(cases i'')
    subgoal
      apply auto
      apply(rule exI[where x="\<lambda> s t. (\<exists> v. s = (Sch p rn rp, ss(G:=v)) \<and> (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (free_ch 1) v ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2}))) t)"])
      apply(rule conjI)
      subgoal
        apply(rule Valid_strengthen_post)
        prefer 2
         apply(rule Valid_cond_sp)
          apply(rule Valid_seq)
           apply(rule Valid_basic_sp1)
          apply(rule Valid_cond_sp)
           apply(rule Valid_send_sp_assm0)
          apply(rule Valid_send_sp_assm0)
         apply(rule Valid_basic_sp1)
        apply(rule entails_disjE')
         apply(rule entails_disjE')
        subgoal
          unfolding QQ_def entails_def
          apply(rule allI)+
          apply(rule impI)
          subgoal for s tr
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI1)
            apply (auto simp add: pure_assn_def conj_assn_def join_assn_def disj_assn_def)
            subgoal for v tr2 tr1a tr2a
              apply(cases s)
              apply(rule exI[where x=v])
              by auto
            subgoal for v tr1a tr2a tr1b tr2b
              apply(cases s)
              apply(rule exI[where x=v])
              apply (auto simp add:true_assn_def)
              apply(rule exI[where x=tr1a])
              apply (auto simp add:true_assn_def)
              done
            done
          done
        subgoal
          unfolding QQ_def entails_def
          apply(rule allI)+
          apply(rule impI)
          subgoal for s tr
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI1)
            apply (auto simp add: pure_assn_def conj_assn_def join_assn_def disj_assn_def)
            subgoal for v tr2 tr1a tr2a
              apply(cases s)
              apply(rule exI[where x=v])
              by auto
            subgoal for v tr1a tr2a tr1b tr2b
              apply(cases s)
              apply(rule exI[where x=v])
              apply (auto simp add:true_assn_def)
              apply(rule exI[where x=tr1a])
              apply (auto simp add:true_assn_def)
              done
            done
          done
        subgoal
          unfolding QQ_def entails_def
          apply(rule allI)+
          apply(rule impI)
          subgoal for s tr
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI1)
            apply (auto simp add: pure_assn_def conj_assn_def join_assn_def disj_assn_def)
            subgoal for v tr1 tr2
              apply(cases s)
              apply(rule exI[where x=v])
              by auto
            done
          done
        done
      apply(rule conjI)
      subgoal unfolding entails_def
        apply(rule allI)+
        apply(rule impI)
        apply auto
        by (metis (no_types, opaque_lifting) inrdy_assn.intros(1) join_assn_def)
      subgoal unfolding entails_def
        apply(rule allI)+
        apply(rule impI)
        apply auto
        subgoal for tr d v
          apply(rule exI[where x=v])
          apply (auto simp add:join_assn_def)
          apply(rule exI[where x=tr])
          apply auto
          apply(rule )
          by auto
        done
      done
    subgoal for i'''
      apply(cases i''')
    subgoal
      apply auto
      apply(rule exI[where x="\<lambda> s t. (\<exists> v. s = (Sch p rn rp, ss(G:=v)) \<and> (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (free_ch 2) v ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2}))) t)"])
      apply(rule conjI)
      subgoal
        apply(rule Valid_strengthen_post)
        prefer 2
         apply(rule Valid_cond_sp)
          apply(rule Valid_seq)
           apply(rule Valid_basic_sp1)
          apply(rule Valid_cond_sp)
           apply(rule Valid_send_sp_assm0)
          apply(rule Valid_send_sp_assm0)
         apply(rule Valid_basic_sp1)
        apply(rule entails_disjE')
         apply(rule entails_disjE')
        subgoal
          unfolding QQ_def entails_def
          apply(rule allI)+
          apply(rule impI)
          subgoal for s tr
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI1)
            apply (auto simp add: pure_assn_def conj_assn_def join_assn_def disj_assn_def)
            subgoal for v tr2 tr1a tr2a
              apply(cases s)
              apply(rule exI[where x=v])
              by auto
            subgoal for v tr1a tr2a tr1b tr2b
              apply(cases s)
              apply(rule exI[where x=v])
              apply (auto simp add:true_assn_def)
              apply(rule exI[where x=tr1a])
              apply (auto simp add:true_assn_def)
              done
            done
          done
        subgoal
          unfolding QQ_def entails_def
          apply(rule allI)+
          apply(rule impI)
          subgoal for s tr
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI1)
            apply (auto simp add: pure_assn_def conj_assn_def join_assn_def disj_assn_def)
            subgoal for v tr2 tr1a tr2a
              apply(cases s)
              apply(rule exI[where x=v])
              by auto
            subgoal for v tr1a tr2a tr1b tr2b
              apply(cases s)
              apply(rule exI[where x=v])
              apply (auto simp add:true_assn_def)
              apply(rule exI[where x=tr1a])
              apply (auto simp add:true_assn_def)
              done
            done
          done
        subgoal
          unfolding QQ_def entails_def
          apply(rule allI)+
          apply(rule impI)
          subgoal for s tr
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI1)
            apply (auto simp add: pure_assn_def conj_assn_def join_assn_def disj_assn_def)
            subgoal for v tr1 tr2
              apply(cases s)
              apply(rule exI[where x=v])
              by auto
            done
          done
        done
      apply(rule conjI)
      subgoal unfolding entails_def
        apply(rule allI)+
        apply(rule impI)
        apply auto
        by (metis (no_types, opaque_lifting) inrdy_assn.intros(1) join_assn_def)
      subgoal unfolding entails_def
        apply(rule allI)+
        apply(rule impI)
        apply auto
        subgoal for tr d v
          apply(rule exI[where x=v])
          apply (auto simp add:join_assn_def)
          apply(rule exI[where x=tr])
          apply auto
          apply(rule )
          by auto
        done
      done
    subgoal for i''''
      apply(cases i'''')
      subgoal
        apply auto
        apply(rule exI[where x="\<lambda> s t. (\<exists> v. s = (Sch p rn rp, ss(G:=v)) \<and> (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (exit_ch 1) v ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2}))) t)"])
        apply(rule conjI)
        subgoal
          apply(rule Valid_ex_pre)
          apply(rule Valid_strengthen_post)
           prefer 2
           apply(rule Valid_basic_sp1)
          apply auto
          unfolding QQ_def entails_def
          apply(rule allI)+
          apply(rule impI)
          apply(rule disjI2)
          apply(rule disjI2)
          apply(rule disjI2)
          apply(rule disjI2)
          apply(rule disjI2)
          apply(rule disjI2)
          apply(rule disjI1)
          by auto
        apply(rule conjI)
        subgoal
          unfolding entails_def
          apply auto
          by (metis inrdy_assn.intros(1) join_assn_def)
        subgoal
          unfolding entails_def
          apply (auto simp add:join_assn_def)
          subgoal for tr d v
            apply(rule exI[where x=v])
            apply auto
            apply(rule exI[where x=tr])
            apply auto
            apply(rule ) by auto
          done
        done
      subgoal for i'''''
        subgoal
        apply auto
        apply(rule exI[where x="\<lambda> s t. (\<exists> v. s = (Sch p rn rp, ss(G:=v)) \<and> (P (Sch p rn rp, ss) @\<^sub>t (Inrdy\<^sub>t (Sch p rn rp, ss) (exit_ch 2) v ({},{req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2}))) t)"])
        apply(rule conjI)
        subgoal
          apply(rule Valid_ex_pre)
          apply(rule Valid_strengthen_post)
           prefer 2
           apply(rule Valid_basic_sp1)
          apply auto
          unfolding QQ_def entails_def
          apply(rule allI)+
          apply(rule impI)
          apply(rule disjI2)
          apply(rule disjI2)
          apply(rule disjI2)
          apply(rule disjI2)
          apply(rule disjI2)
          apply(rule disjI2)
          apply(rule disjI2)
          by auto
        apply(rule conjI)
        subgoal
          unfolding entails_def
          apply auto
          by (metis inrdy_assn.intros(1) join_assn_def)
        subgoal
          unfolding entails_def
          apply (auto simp add:join_assn_def)
          subgoal for tr d v
            apply(rule exI[where x=v])
            apply auto
            apply(rule exI[where x=tr])
            apply auto
            apply(rule ) by auto
          done
        done
      done
    done
  done
  done
  done
  done
  done

fun SCH_tr:: "nat \<Rightarrow> estate ext_state \<Rightarrow> estate tassn" where
  "SCH_tr 0 (Sch p rn rp,ss)  = emp\<^sub>t"
| "SCH_tr (Suc k) (Sch p rn rp,ss) = (
   (Inrdy\<^sub>t (Sch p rn rp, ss) (req_ch 1) 2
               ({}, {req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2}))
              @\<^sub>t (if rp \<ge> 2 then SCH_tr k (Sch (p @ [(2, 1)]) rn rp,ss(Pr := 2))
               else if rn = 2 then Out0\<^sub>t (preempt_ch 2) 0 @\<^sub>t Out0\<^sub>t (run_ch 1) 0 @\<^sub>t SCH_tr k (Sch p 1 2,ss(Pr := 2)) \<or>\<^sub>t
                                     Waitp\<^sub>t  ({preempt_ch 2}, {}) @\<^sub>t true\<^sub>A \<or>\<^sub>t
                                      Out0\<^sub>t (preempt_ch 2) 0 @\<^sub>t Waitp\<^sub>t  ({run_ch 1}, {}) @\<^sub>t true\<^sub>A
                              else Out0\<^sub>t (run_ch 1) 0 @\<^sub>t SCH_tr k (Sch p 1 2,ss(Pr := 2))\<or>\<^sub>t
                                     Waitp\<^sub>t ({run_ch 1}, {}) @\<^sub>t true\<^sub>A)
 \<or>\<^sub>t(\<exists>\<^sub>t v. \<up>(v\<noteq>2) \<and>\<^sub>t  Inrdy\<^sub>t (Sch p rn rp, ss) (req_ch 1) v ({}, {req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2}) @\<^sub>t true\<^sub>A )
 \<or>\<^sub>t(Inrdy\<^sub>t (Sch p rn rp, ss) (req_ch 2) 1
               ({}, {req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2}))
              @\<^sub>t (if rp \<ge> 1 then SCH_tr k (Sch (p @ [(1, 2)]) rn rp,ss(Pr := 1))
               else if rn = 1 then Out0\<^sub>t (preempt_ch 1) 0 @\<^sub>t Out0\<^sub>t (run_ch 2) 0 @\<^sub>t SCH_tr k (Sch p 2 1,ss(Pr := 1)) \<or>\<^sub>t
                                     Waitp\<^sub>t  ({preempt_ch 1}, {}) @\<^sub>t true\<^sub>A \<or>\<^sub>t
                                      Out0\<^sub>t (preempt_ch 1) 0 @\<^sub>t Waitp\<^sub>t  ({run_ch 2}, {}) @\<^sub>t true\<^sub>A
                              else Out0\<^sub>t (run_ch 2) 0 @\<^sub>t SCH_tr k (Sch p 2 1,ss(Pr := 1))\<or>\<^sub>t
                                     Waitp\<^sub>t ({run_ch 2}, {}) @\<^sub>t true\<^sub>A)
  \<or>\<^sub>t(\<exists>\<^sub>t v. \<up>(v\<noteq>1) \<and>\<^sub>t  Inrdy\<^sub>t (Sch p rn rp, ss) (req_ch 2) v ({}, {req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2}) @\<^sub>t true\<^sub>A )
  \<or>\<^sub>t(\<exists>\<^sub>t v. Inrdy\<^sub>t (Sch p rn rp, ss) (free_ch 1) v ({}, {req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2}) @\<^sub>t
          (if length p > 0 then if run_now (sched_get_max' (Sch p rn rp)) = 1
                                then  (Out0\<^sub>t (run_ch 1) 0 @\<^sub>t SCH_tr k (sched_get_max' (Sch p rn rp), ss(G := v)) \<or>\<^sub>t
                                       Waitp\<^sub>t  ({run_ch 1}, {}) @\<^sub>t true\<^sub>A)
                                else  (Out0\<^sub>t (run_ch 2) 0 @\<^sub>t SCH_tr k (sched_get_max' (Sch p rn rp), ss(G := v)) \<or>\<^sub>t
                                       Waitp\<^sub>t  ({run_ch 2}, {}) @\<^sub>t true\<^sub>A)
                           else SCH_tr k (sched_clear' (Sch p rn rp), ss(G := v))))
  \<or>\<^sub>t(\<exists>\<^sub>t v. Inrdy\<^sub>t (Sch p rn rp, ss) (free_ch 2) v ({}, {req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2}) @\<^sub>t
          (if length p > 0 then if run_now (sched_get_max' (Sch p rn rp)) = 1
                                then  (Out0\<^sub>t (run_ch 1) 0 @\<^sub>t SCH_tr k (sched_get_max' (Sch p rn rp), ss(G := v)) \<or>\<^sub>t
                                       Waitp\<^sub>t  ({run_ch 1}, {}) @\<^sub>t true\<^sub>A)
                                else  (Out0\<^sub>t (run_ch 2) 0 @\<^sub>t SCH_tr k (sched_get_max' (Sch p rn rp), ss(G := v)) \<or>\<^sub>t
                                       Waitp\<^sub>t  ({run_ch 2}, {}) @\<^sub>t true\<^sub>A)
                           else SCH_tr k (sched_clear' (Sch p rn rp), ss(G := v))))
  \<or>\<^sub>t(\<exists>\<^sub>t v. Inrdy\<^sub>t (Sch p rn rp, ss) (exit_ch 1) v ({}, {req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2})
                             @\<^sub>t SCH_tr k (sched_del_proc' 1 (Sch p rn rp), ss(G := v)))
  \<or>\<^sub>t(\<exists>\<^sub>t v. Inrdy\<^sub>t (Sch p rn rp, ss) (exit_ch 2) v ({}, {req_ch 1, req_ch 2, free_ch 1, free_ch 2, exit_ch 1, exit_ch 2})
                             @\<^sub>t SCH_tr k (sched_del_proc' 2 (Sch p rn rp), ss(G := v)))
)"

lemma Valid_SCH_rep:
  "\<Turnstile> {\<lambda>s t. s = (Sch p rn rp,ss) \<and> emp\<^sub>t t}
                      Rep SCH
      {\<lambda>s t. (\<exists>n. (emp\<^sub>t @\<^sub>t SCH_tr n (Sch p rn rp,ss)) t)}"
apply(rule Valid_rep'')
  subgoal for n P
    apply(induction n arbitrary:P p rn rp ss)
    subgoal for P
      apply auto
      apply(rule Valid_strengthen_post)
       prefer 2
       apply(rule Valid_skip)
      unfolding entails_def by auto
    subgoal premises pre for n P p rn rp ss
      subgoal
        unfolding RepN.simps
        apply(rule Valid_seq)
         apply(rule Sch_Valid_1)
        thm pre
        unfolding QQ_def
        apply(rule Valid_pre_or)
        subgoal
          apply(cases "2\<le>rp")
          subgoal
            apply(rule Valid_strengthen_post)
             prefer 2
             apply simp
             apply(rule pre)
            apply(simp only:join_assoc)
            apply(rule tassn_to_assn)
            apply(rule entails_tassn_cancel_left)
            unfolding entails_tassn_def
            apply(rule allI)
            apply(rule impI)
            unfolding disj_assn_def SCH_tr.simps
            apply(rule disjI1)
            by auto
          apply(cases "rn = 2")
          subgoal
            apply(rule Valid_strengthen_post)
             prefer 2
             apply simp
             apply(rule pre)
            apply(simp only:join_assoc)
            apply(rule tassn_to_assn)
            apply(rule entails_tassn_cancel_left)
            unfolding entails_tassn_def
            apply(rule allI)
            apply(rule impI)
            unfolding disj_assn_def SCH_tr.simps
            apply(rule disjI1)
            apply (auto simp add:join_assn_def true_assn_def)
            subgoal by metis
            subgoal by metis
            subgoal by metis
            done
          subgoal
            apply(rule Valid_strengthen_post)
             prefer 2
             apply simp
             apply(rule pre)
            apply(simp only:join_assoc)
            apply(rule tassn_to_assn)
            apply(rule entails_tassn_cancel_left)
            unfolding entails_tassn_def
            apply(rule allI)
            apply(rule impI)
            unfolding disj_assn_def SCH_tr.simps
            apply(rule disjI1)
            apply (auto simp add:join_assn_def true_assn_def)
            by metis
          done
        apply(rule Valid_pre_or)
        subgoal
          apply(rule Valid_ex_pre)
          apply(rule Valid_strengthen_post)
          prefer 2
           apply(rule Valid_true)
          subgoal for v
            apply(rule tassn_to_assn)
            apply (simp del:SCH_tr.simps add:join_assoc)
            apply(rule impI)
            apply(rule entails_tassn_cancel_left)
            unfolding entails_tassn_def
            apply(rule allI)
            apply(rule impI)
            unfolding disj_assn_def SCH_tr.simps
            apply(rule disjI2)
            apply(rule disjI1)
            by (auto simp add:join_assn_def true_assn_def ex_assn_def pure_assn_def conj_assn_def)
          done
        apply(rule Valid_pre_or)
        subgoal
          apply(cases "1\<le>rp")
          subgoal
            apply(rule Valid_strengthen_post)
             prefer 2
             apply simp
             apply(rule pre)
            apply(simp only:join_assoc)
            apply(rule tassn_to_assn)
            apply(rule entails_tassn_cancel_left)
            unfolding entails_tassn_def
            apply(rule allI)
            apply(rule impI)
            unfolding disj_assn_def SCH_tr.simps
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI1)
            by auto
          apply(cases "rn = 1")
          subgoal
            apply(rule Valid_strengthen_post)
             prefer 2
             apply simp
             apply(rule pre)
            apply(simp only:join_assoc)
            apply(rule tassn_to_assn)
            apply(rule entails_tassn_cancel_left)
            unfolding entails_tassn_def
            apply(rule allI)
            apply(rule impI)
            unfolding disj_assn_def SCH_tr.simps
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI1)
            apply (auto simp add:join_assn_def true_assn_def)
            subgoal by metis
            subgoal by metis
            subgoal by metis
            done
          subgoal
            apply(rule Valid_strengthen_post)
             prefer 2
             apply simp
             apply(rule pre)
            apply(simp only:join_assoc)
            apply(rule tassn_to_assn)
            apply(rule entails_tassn_cancel_left)
            unfolding entails_tassn_def
            apply(rule allI)
            apply(rule impI)
            unfolding disj_assn_def SCH_tr.simps
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI1)
            apply (auto simp add:join_assn_def true_assn_def)
            by metis
          done
        apply(rule Valid_pre_or)
        subgoal
          apply(rule Valid_ex_pre)
          apply(rule Valid_strengthen_post)
          prefer 2
           apply(rule Valid_true)
          subgoal for v
            apply(rule tassn_to_assn)
            apply (simp del:SCH_tr.simps add:join_assoc)
            apply(rule impI)
            apply(rule entails_tassn_cancel_left)
            unfolding entails_tassn_def
            apply(rule allI)
            apply(rule impI)
            unfolding disj_assn_def SCH_tr.simps
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI2)
            apply(rule disjI1)
            by (auto simp add:join_assn_def true_assn_def ex_assn_def pure_assn_def conj_assn_def)
          done
        apply(rule Valid_pre_or)
        subgoal
          apply(rule Valid_ex_pre)
          subgoal for v
          apply(cases "length p > 0")
            subgoal
              apply(cases "run_now (sched_get_max' (Sch p rn rp)) = 1")
              subgoal
                apply (simp del: SCH_tr.simps)
                 apply(cases "get_max p")
                subgoal for pp tt
                  apply (simp del: SCH_tr.simps)
                  apply(rule Valid_strengthen_post)
                   prefer 2
                   apply(rule pre)
                  apply(rule tassn_to_assn)
                  apply(simp del: SCH_tr.simps add: join_assoc)
                  apply(rule entails_tassn_cancel_left)
                  unfolding entails_tassn_def
                  apply(rule allI)
                  apply(rule impI)
                  unfolding disj_assn_def SCH_tr.simps
                  apply(rule disjI2)
                  apply(rule disjI2)
                  apply(rule disjI2)
                  apply(rule disjI2)
                  apply(rule disjI1)
                  apply (auto simp add:join_assn_def true_assn_def ex_assn_def pure_assn_def conj_assn_def)
                  subgoal by metis
                  subgoal by metis
                  done
                done
              subgoal
                apply (simp del: SCH_tr.simps)
                 apply(cases "get_max p")
                subgoal for pp tt
                  apply (simp del: SCH_tr.simps)
                  apply(rule Valid_strengthen_post)
                   prefer 2
                   apply(rule pre)
                  apply(rule tassn_to_assn)
                  apply(simp del: SCH_tr.simps add: join_assoc)
                  apply(rule entails_tassn_cancel_left)
                  unfolding entails_tassn_def
                  apply(rule allI)
                  apply(rule impI)
                  unfolding disj_assn_def SCH_tr.simps
                  apply(rule disjI2)
                  apply(rule disjI2)
                  apply(rule disjI2)
                  apply(rule disjI2)
                  apply(rule disjI1)
                  apply (auto simp add:join_assn_def true_assn_def ex_assn_def pure_assn_def conj_assn_def)
                  subgoal by metis
                  subgoal by metis
                  done
                done
              done
            subgoal
              apply (simp del: SCH_tr.simps)
              apply(rule Valid_strengthen_post)
              prefer 2
              apply(rule pre)
              apply(rule tassn_to_assn)
              apply(simp del: SCH_tr.simps add: join_assoc)
              apply(rule entails_tassn_cancel_left)
              unfolding entails_tassn_def
              apply(rule allI)
              apply(rule impI)
              unfolding disj_assn_def SCH_tr.simps
              apply(rule disjI2)
              apply(rule disjI2)
              apply(rule disjI2)
              apply(rule disjI2)
              apply(rule disjI1)
              by(auto simp add: ex_assn_def)
            done
          done
        apply(rule Valid_pre_or)
        subgoal
          apply(rule Valid_ex_pre)
          subgoal for v
          apply(cases "length p > 0")
            subgoal
              apply(cases "run_now (sched_get_max' (Sch p rn rp)) = 1")
              subgoal
                apply (simp del: SCH_tr.simps)
                 apply(cases "get_max p")
                subgoal for pp tt
                  apply (simp del: SCH_tr.simps)
                  apply(rule Valid_strengthen_post)
                   prefer 2
                   apply(rule pre)
                  apply(rule tassn_to_assn)
                  apply(simp del: SCH_tr.simps add: join_assoc)
                  apply(rule entails_tassn_cancel_left)
                  unfolding entails_tassn_def
                  apply(rule allI)
                  apply(rule impI)
                  unfolding disj_assn_def SCH_tr.simps
                  apply(rule disjI2)
                  apply(rule disjI2)
                  apply(rule disjI2)
                  apply(rule disjI2)
                  apply(rule disjI2)
                  apply (auto simp add:join_assn_def true_assn_def ex_assn_def pure_assn_def conj_assn_def)
                  subgoal by metis
                  subgoal by metis
                  done
                done
              subgoal
                apply (simp del: SCH_tr.simps)
                 apply(cases "get_max p")
                subgoal for pp tt
                  apply (simp del: SCH_tr.simps)
                  apply(rule Valid_strengthen_post)
                   prefer 2
                   apply(rule pre)
                  apply(rule tassn_to_assn)
                  apply(simp del: SCH_tr.simps add: join_assoc)
                  apply(rule entails_tassn_cancel_left)
                  unfolding entails_tassn_def
                  apply(rule allI)
                  apply(rule impI)
                  unfolding disj_assn_def SCH_tr.simps
                  apply(rule disjI2)
                  apply(rule disjI2)
                  apply(rule disjI2)
                  apply(rule disjI2)
                  apply(rule disjI2)
                  apply(rule disjI1)
                  apply (auto simp add:join_assn_def true_assn_def ex_assn_def pure_assn_def conj_assn_def)
                  subgoal by metis
                  subgoal by metis
                  done
                done
              done
            subgoal
              apply (simp del: SCH_tr.simps)
              apply(rule Valid_strengthen_post)
              prefer 2
              apply(rule pre)
              apply(rule tassn_to_assn)
              apply(simp del: SCH_tr.simps add: join_assoc)
              apply(rule entails_tassn_cancel_left)
              unfolding entails_tassn_def
              apply(rule allI)
              apply(rule impI)
              unfolding disj_assn_def SCH_tr.simps
              apply(rule disjI2)
              apply(rule disjI2)
              apply(rule disjI2)
              apply(rule disjI2)
              apply(rule disjI2)
              apply(rule disjI1)
              by(auto simp add: ex_assn_def)
            done
          done
        apply(rule Valid_pre_or)
        subgoal
          apply(rule Valid_ex_pre)
          subgoal for v
            apply (simp del: SCH_tr.simps)
            apply(rule Valid_strengthen_post)
              prefer 2
              apply(rule pre)
              apply(rule tassn_to_assn)
              apply(simp del: SCH_tr.simps add: join_assoc)
              apply(rule entails_tassn_cancel_left)
              unfolding entails_tassn_def
              apply(rule allI)
              apply(rule impI)
              unfolding disj_assn_def SCH_tr.simps
              apply(rule disjI2)
              apply(rule disjI2)
              apply(rule disjI2)
              apply(rule disjI2)
              apply(rule disjI2)
              apply(rule disjI2)
              apply(rule disjI1)
              by(auto simp add: ex_assn_def)
            done
          subgoal
          apply(rule Valid_ex_pre)
          subgoal for v
            apply (simp del: SCH_tr.simps)
            apply(rule Valid_strengthen_post)
              prefer 2
              apply(rule pre)
              apply(rule tassn_to_assn)
              apply(simp del: SCH_tr.simps add: join_assoc)
              apply(rule entails_tassn_cancel_left)
              unfolding entails_tassn_def
              apply(rule allI)
              apply(rule impI)
              unfolding disj_assn_def SCH_tr.simps
              apply(rule disjI2)
              apply(rule disjI2)
              apply(rule disjI2)
              apply(rule disjI2)
              apply(rule disjI2)
              apply(rule disjI2)
              apply(rule disjI2)
              by(auto simp add: ex_assn_def)
            done
          done
        done
      done
    done

end