theory "WooLam_cert_auto"
imports
  "ESPLogic"
begin

(* section:  Woo and Lam Mutual Authentication Protocol  *)

(* text:
  Modeled after the description in the SPORE library:

    http://www.lsv.ens-cachan.fr/Software/spore/wooLamMutual.html

  Notable differences:

    1. We are using explicit global constants to discern between different
       encryptions instead of the implicit typing, which introduces
       ambiguities. This implies that we are not precisely modeling the Woo and
       Lam protocol of the SPORE library and hence we may miss some attacks
       possible on it. However, every implementation of the SPORE model could
       easily be changed to our version and benefit from the full correctness
       proof.
 *)

role A
where "A =
  [ Send ''1'' <| sAV ''A'', sN ''na'' |>
  , Recv ''2'' <| sMV ''B'', sMV ''nb'' |>
  , Send ''3'' ( PEnc <| sC ''enc3'', sAV ''A'', sMV ''B'', sN ''na'',
                         sMV ''nb''
                      |>
                      ( sK ''A'' ''S'' )
               )
  , Recv ''6'' <| PEnc <| sC ''enc51'', sMV ''B'', sN ''na'', sMV ''nb'',
                          sMV ''kab''
                       |>
                       ( sK ''A'' ''S'' ),
                  PEnc <| sC ''enc6'', sN ''na'', sMV ''nb'' |> ( sMV ''kab'' )
               |>
  , Send ''7'' ( PEnc <| sC ''enc7'', sMV ''nb'' |> ( sMV ''kab'' ) )
  ]"

role B
where "B =
  [ Recv ''1'' <| sMV ''A'', sMV ''na'' |>
  , Send ''2'' <| sAV ''B'', sN ''nb'' |>
  , Recv ''3'' ( sMV ''Ticket1'' )
  , Send ''4'' <| sMV ''Ticket1'',
                  PEnc <| sC ''enc4'', sMV ''A'', sAV ''B'', sMV ''na'', sN ''nb'' |>
                       ( sK ''B'' ''S'' )
               |>
  , Recv ''5'' <| sMV ''Ticket2'',
                  PEnc <| sC ''enc52'', sMV ''A'', sMV ''na'', sN ''nb'', sMV ''kab'' |>
                       ( sK ''B'' ''S'' )
               |>
  , Send ''6'' <| sMV ''Ticket2'',
                  PEnc <| sC ''enc6'', sMV ''na'', sN ''nb'' |> ( sMV ''kab'' )
               |>
  , Recv ''7'' ( PEnc <| sC ''enc7'', sN ''nb'' |> ( sMV ''kab'' ) )
  ]"

role S
where "S =
  [ Recv ''4'' <| PEnc <| sC ''enc3'', sMV ''A'', sMV ''B'', sMV ''na'',
                          sMV ''nb''
                       |>
                       ( PSymK ( sMV ''A'' ) ( sAV ''S'' ) ),
                  PEnc <| sC ''enc4'', sMV ''A'', sMV ''B'', sMV ''na'', sMV ''nb'' |>
                       ( PSymK ( sMV ''A'' ) ( sAV ''S'' ) )
               |>
  , Send ''5'' <| PEnc <| sC ''enc51'', sMV ''B'', sMV ''na'', sMV ''nb'',
                          sN ''kab''
                       |>
                       ( PSymK ( sMV ''A'' ) ( sAV ''S'' ) ),
                  PEnc <| sC ''enc52'', sMV ''A'', sMV ''na'', sMV ''nb'', sN ''kab'' |>
                       ( PSymK ( sMV ''B'' ) ( sAV ''S'' ) )
               |>
  ]"

protocol WooLam
where "WooLam = { A, B, S }"

locale restricted_WooLam_state = WooLam_state

type_invariant WooLam_msc_typing for WooLam
where "WooLam_msc_typing = mk_typing
  [ ((B, ''A''), (KnownT B_1))
  , ((S, ''A''), (SumT (KnownT S_4) AgentT))
  , ((A, ''B''), (KnownT A_2))
  , ((S, ''B''), (SumT (KnownT S_4) AgentT))
  , ((B, ''Ticket1''), (KnownT B_3))
  , ((B, ''Ticket2''), (KnownT B_5))
  , ((A, ''kab''), (SumT (KnownT A_6) (NonceT S ''kab'')))
  , ((B, ''kab''), (SumT (KnownT B_5) (NonceT S ''kab'')))
  , ((B, ''na''), (KnownT B_1))
  , ((S, ''na''), (SumT (KnownT S_4) (NonceT A ''na'')))
  , ((A, ''nb''), (KnownT A_2))
  , ((S, ''nb''), (SumT (KnownT S_4) (NonceT B ''nb'')))
  ]"

sublocale WooLam_state < WooLam_msc_typing_state
proof -
  have "(t,r,s) : approx WooLam_msc_typing"
  proof(cases rule: reachable_in_approxI_ext
        [OF WooLam_msc_typing.monoTyp, completeness_cases_rule])
    case (A_2_B t r s tid0)
    then interpret state: WooLam_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_nb t r s tid0)
    then interpret state: WooLam_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = A_2_nb
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (A_6_kab t r s tid0)
    then interpret state: WooLam_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = A_6_kab
    thus ?case
    proof(sources! "
        Enc {| LC ''enc51'', s(MV ''B'' tid0), LN ''na'' tid0, s(MV ''nb'' tid0),
               s(MV ''kab'' tid0)
            |}
            ( K ( s(AV ''A'' tid0) ) ( s(AV ''S'' 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: WooLam_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: WooLam_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)
  next
    case (B_5_Ticket2 t r s tid0)
    then interpret state: WooLam_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = B_5_Ticket2
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (B_5_kab t r s tid0)
    then interpret state: WooLam_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = B_5_kab
    thus ?case
    proof(sources! "
        Enc {| LC ''enc52'', s(MV ''A'' tid0), s(MV ''na'' tid0), LN ''nb'' tid0,
               s(MV ''kab'' tid0)
            |}
            ( K ( s(AV ''B'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (S_4_A t r s tid0)
    then interpret state: WooLam_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_4_A
    thus ?case
    proof(sources! "
        Enc {| LC ''enc3'', s(MV ''A'' tid0), s(MV ''B'' tid0),
               s(MV ''na'' tid0), s(MV ''nb'' tid0)
            |}
            ( K ( s(MV ''A'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (S_4_B t r s tid0)
    then interpret state: WooLam_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_4_B
    thus ?case
    proof(sources! "
        Enc {| LC ''enc3'', s(MV ''A'' tid0), s(MV ''B'' tid0),
               s(MV ''na'' tid0), s(MV ''nb'' tid0)
            |}
            ( K ( s(MV ''A'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (S_4_na t r s tid0)
    then interpret state: WooLam_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_4_na
    thus ?case
    proof(sources! "
        Enc {| LC ''enc3'', s(MV ''A'' tid0), s(MV ''B'' tid0),
               s(MV ''na'' tid0), s(MV ''nb'' tid0)
            |}
            ( K ( s(MV ''A'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (S_4_nb t r s tid0)
    then interpret state: WooLam_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_4_nb
    thus ?case
    proof(sources! "
        Enc {| LC ''enc3'', s(MV ''A'' tid0), s(MV ''B'' tid0),
               s(MV ''na'' tid0), s(MV ''nb'' tid0)
            |}
            ( K ( s(MV ''A'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  qed
  thus "WooLam_msc_typing_state t r s" by unfold_locales auto
qed

text{* Prove secrecy of long-term keys. *}
context WooLam_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:  Secrecy Properties  *)

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

lemma (in restricted_WooLam_state) A_sec_kab:
  assumes facts:
    "roleMap r tid0 = Some A"
    "RLKR(s(AV ''A'' tid0)) ~: reveals t"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "RLKR(s(MV ''B'' tid0)) ~: reveals t"
    "( tid0, A_6 ) : steps t"
    "s(MV ''kab'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''enc51'', s(MV ''B'' tid0), LN ''na'' tid0, s(MV ''nb'' tid0),
                          s(MV ''kab'' tid0)
                       |}
                       ( K ( s(AV ''A'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_5_enc tid1) note_unified facts = this facts
    thus ?thesis by (fastforce dest: S_sec_kab intro: event_predOrdI)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_WooLam_state) B_sec_kab:
  assumes facts:
    "roleMap r tid0 = Some B"
    "RLKR(s(AV ''B'' tid0)) ~: reveals t"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "RLKR(s(MV ''A'' tid0)) ~: reveals t"
    "( tid0, B_5 ) : steps t"
    "s(MV ''kab'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''enc52'', s(MV ''A'' tid0), s(MV ''na'' tid0), LN ''nb'' tid0,
                          s(MV ''kab'' tid0)
                       |}
                       ( K ( s(AV ''B'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_5_enc_1 tid1) note_unified facts = this facts
    thus ?thesis by (fastforce dest: S_sec_kab intro: event_predOrdI)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_WooLam_state) A_sec_inv_kab:
  assumes facts:
    "roleMap r tid0 = Some A"
    "RLKR(s(AV ''A'' tid0)) ~: reveals t"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "RLKR(s(MV ''B'' tid0)) ~: reveals t"
    "( tid0, A_6 ) : steps t"
    "inv(s(MV ''kab'' tid0)) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''enc51'', s(MV ''B'' tid0), LN ''na'' tid0, s(MV ''nb'' tid0),
                          s(MV ''kab'' tid0)
                       |}
                       ( K ( s(AV ''A'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_5_enc tid1) note_unified facts = this facts
    thus ?thesis by (fastforce dest: S_sec_kab intro: event_predOrdI)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_WooLam_state) B_sec_inv_kab:
  assumes facts:
    "roleMap r tid0 = Some B"
    "RLKR(s(AV ''B'' tid0)) ~: reveals t"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "RLKR(s(MV ''A'' tid0)) ~: reveals t"
    "( tid0, B_5 ) : steps t"
    "inv(s(MV ''kab'' tid0)) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''enc52'', s(MV ''A'' tid0), s(MV ''na'' tid0), LN ''nb'' tid0,
                          s(MV ''kab'' tid0)
                       |}
                       ( K ( s(AV ''B'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_5_enc_1 tid1) note_unified facts = this facts
    thus ?thesis by (fastforce dest: S_sec_kab intro: event_predOrdI)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

(* subsection:  Authentication  *)

lemma (in restricted_WooLam_state) na_first_send:
  assumes facts:
    "roleMap r tid1 = Some A"
    "LN ''na'' tid1 : knows t"
  shows "predOrd t (St( tid1, A_1 )) (Ln(LN ''na'' tid1))"
using facts proof(sources! " LN ''na'' tid1 ")
  case A_1_na note_unified facts = this facts
  thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
next
  case A_3_na note_unified facts = this facts
  thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
next
  case (S_5_na tid2) note_unified facts = this facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''enc3'', s(MV ''A'' tid2), s(MV ''B'' tid2), LN ''na'' tid1,
                          s(MV ''nb'' tid2)
                       |}
                       ( K ( s(MV ''A'' tid2) ) ( s(AV ''S'' tid2) ) ) ")
    case (A_3_enc tid3) note_unified facts = this facts
    thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
  qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
next
  case (S_5_na_1 tid2) note_unified facts = this facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''enc3'', s(MV ''A'' tid2), s(MV ''B'' tid2), LN ''na'' tid1,
                          s(MV ''nb'' tid2)
                       |}
                       ( K ( s(MV ''A'' tid2) ) ( s(AV ''S'' tid2) ) ) ")
    case (A_3_enc tid3) note_unified facts = this facts
    thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
  qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_WooLam_state) nb_first_send:
  assumes facts:
    "roleMap r tid1 = Some B"
    "LN ''nb'' tid1 : knows t"
  shows "predOrd t (St( tid1, B_2 )) (Ln(LN ''nb'' tid1))"
using facts proof(sources! " LN ''nb'' tid1 ")
  case B_2_nb note_unified facts = this facts
  thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
next
  case B_4_nb note_unified facts = this facts
  thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
next
  case B_6_nb note_unified facts = this facts
  thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
next
  case (S_5_nb tid2) note_unified facts = this facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''enc3'', s(MV ''A'' tid2), s(MV ''B'' tid2),
                          s(MV ''na'' tid2), LN ''nb'' tid1
                       |}
                       ( K ( s(MV ''A'' tid2) ) ( s(AV ''S'' tid2) ) ) ")
  qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
next
  case (S_5_nb_1 tid2) note_unified facts = this facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''enc3'', s(MV ''A'' tid2), s(MV ''B'' tid2),
                          s(MV ''na'' tid2), LN ''nb'' tid1
                       |}
                       ( K ( s(MV ''A'' tid2) ) ( s(AV ''S'' tid2) ) ) ")
  qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_WooLam_state) A_ni_synch:
  assumes facts:
    "roleMap r tid1 = Some A"
    "RLKR(s(AV ''A'' tid1)) ~: reveals t"
    "RLKR(s(AV ''S'' tid1)) ~: reveals t"
    "RLKR(s(MV ''B'' tid1)) ~: reveals t"
    "( tid1, A_6 ) : steps t"
  shows
    "(?  tid2.
        (?  tid3.
           roleMap r tid2 = Some B &
           roleMap r tid3 = Some S &
           s(AV ''A'' tid1) = s(MV ''A'' tid2) &
           s(MV ''B'' tid1) = s(AV ''B'' tid2) &
           s(AV ''S'' tid1) = s(AV ''S'' tid2) &
           LN ''na'' tid1 = s(MV ''na'' tid2) &
           s(MV ''nb'' tid1) = LN ''nb'' tid2 &
           s(MV ''kab'' tid1) = s(MV ''kab'' tid2) &
           s(AV ''A'' tid1) = s(MV ''A'' tid3) &
           s(MV ''B'' tid1) = s(MV ''B'' tid3) &
           s(AV ''S'' tid1) = s(AV ''S'' tid3) &
           LN ''na'' tid1 = s(MV ''na'' tid3) &
           s(MV ''nb'' tid1) = s(MV ''nb'' tid3) &
           s(MV ''kab'' tid1) = LN ''kab'' tid3 &
           predOrd t (St( tid1, A_1 )) (St( tid2, B_1 )) &
           predOrd t (St( tid2, B_1 )) (St( tid2, B_2 )) &
           predOrd t (St( tid2, B_2 )) (St( tid1, A_2 )) &
           predOrd t (St( tid1, A_2 )) (St( tid1, A_3 )) &
           predOrd t (St( tid1, A_3 )) (St( tid3, S_4 )) &
           predOrd t (St( tid3, S_4 )) (St( tid3, S_5 )) &
           predOrd t (St( tid3, S_5 )) (St( tid2, B_5 )) &
           predOrd t (St( tid2, B_5 )) (St( tid2, B_6 )) &
           predOrd t (St( tid2, B_6 )) (St( tid1, A_6 )) &
           predOrd t (St( tid2, B_3 )) (St( tid2, B_4 )) &
           predOrd t (St( tid2, B_4 )) (St( tid3, S_4 ))))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''enc51'', s(MV ''B'' tid1), LN ''na'' tid1, s(MV ''nb'' tid1),
                          s(MV ''kab'' tid1)
                       |}
                       ( K ( s(AV ''A'' tid1) ) ( s(AV ''S'' tid1) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_5_enc tid2) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''enc3'', s(AV ''A'' tid1), s(MV ''B'' tid1), LN ''na'' tid1,
                            s(MV ''nb'' tid1)
                         |}
                         ( K ( s(AV ''A'' tid1) ) ( s(AV ''S'' tid1) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (auto dest!: ltk_secrecy)
    next
      case (A_3_enc tid3) note_unified facts = this facts
      thus ?thesis proof(sources! "
                       Enc {| LC ''enc4'', s(AV ''A'' tid1), s(MV ''B'' tid1), LN ''na'' tid1,
                              s(MV ''nb'' tid1)
                           |}
                           ( K ( s(AV ''A'' tid1) ) ( s(AV ''S'' tid1) ) ) ")
        case fake note_unified facts = this facts
        thus ?thesis by (auto dest!: ltk_secrecy)
      next
        case (B_4_enc tid3) note_unified facts = this facts
        have f1: "roleMap r tid1 = Some A" using facts by (auto intro: event_predOrdI)
        have f2: "LN ''na'' tid1 : knows t" using facts by (auto intro: event_predOrdI)
        note facts = facts na_first_send[OF f1 f2, simplified]
        have f1: "roleMap r tid3 = Some B" using facts by (auto intro: event_predOrdI)
        have f2: "LN ''nb'' tid3 : knows t" using facts by (auto intro: event_predOrdI)
        note facts = facts nb_first_send[OF f1 f2, simplified]
        thus ?thesis proof(sources! "
                         Enc {| LC ''enc6'', LN ''na'' tid1, LN ''nb'' tid3 |}
                             ( LN ''kab'' tid2 ) ")
          case fake note_unified facts = this facts
          thus ?thesis by (fastforce dest: S_sec_kab intro: event_predOrdI)
        next
          case (B_6_enc tid4) note_unified facts = this facts
          thus ?thesis proof(sources! "
                           Enc {| LC ''enc52'', s(AV ''A'' tid1), LN ''na'' tid1, LN ''nb'' tid3,
                                  LN ''kab'' tid2
                               |}
                               ( K ( s(AV ''A'' tid1) ) ( s(AV ''S'' tid1) ) ) ")
            case fake note_unified facts = this facts
            thus ?thesis by (auto dest!: ltk_secrecy)
          next
            case (S_5_enc_1 tid4) note_unified facts = this facts
            thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
          qed (safe?, simp_all?, insert facts, (fastforce+)?)
        qed (safe?, simp_all?, insert facts, (fastforce+)?)
      qed (safe?, simp_all?, insert facts, (fastforce+)?)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_WooLam_state) B_ni_synch:
  assumes facts:
    "roleMap r tid2 = Some B"
    "RLKR(s(AV ''B'' tid2)) ~: reveals t"
    "RLKR(s(AV ''S'' tid2)) ~: reveals t"
    "RLKR(s(MV ''A'' tid2)) ~: reveals t"
    "( tid2, B_7 ) : steps t"
  shows
    "(?  tid1.
        (?  tid3.
           roleMap r tid1 = Some A &
           roleMap r tid3 = Some S &
           s(MV ''A'' tid2) = s(AV ''A'' tid1) &
           s(AV ''B'' tid2) = s(MV ''B'' tid1) &
           s(AV ''S'' tid2) = s(AV ''S'' tid1) &
           s(MV ''na'' tid2) = LN ''na'' tid1 &
           LN ''nb'' tid2 = s(MV ''nb'' tid1) &
           s(MV ''kab'' tid2) = s(MV ''kab'' tid1) &
           s(MV ''A'' tid2) = s(MV ''A'' tid3) &
           s(AV ''B'' tid2) = s(MV ''B'' tid3) &
           s(AV ''S'' tid2) = s(AV ''S'' tid3) &
           s(MV ''na'' tid2) = s(MV ''na'' tid3) &
           LN ''nb'' tid2 = s(MV ''nb'' tid3) &
           s(MV ''kab'' tid2) = LN ''kab'' tid3 &
           predOrd t (St( tid1, A_1 )) (St( tid2, B_1 )) &
           predOrd t (St( tid2, B_1 )) (St( tid2, B_2 )) &
           predOrd t (St( tid2, B_2 )) (St( tid1, A_2 )) &
           predOrd t (St( tid1, A_2 )) (St( tid1, A_3 )) &
           predOrd t (St( tid1, A_3 )) (St( tid3, S_4 )) &
           predOrd t (St( tid3, S_4 )) (St( tid3, S_5 )) &
           predOrd t (St( tid3, S_5 )) (St( tid2, B_5 )) &
           predOrd t (St( tid2, B_5 )) (St( tid2, B_6 )) &
           predOrd t (St( tid2, B_6 )) (St( tid1, A_6 )) &
           predOrd t (St( tid1, A_6 )) (St( tid1, A_7 )) &
           predOrd t (St( tid1, A_7 )) (St( tid2, B_7 )) &
           predOrd t (St( tid2, B_3 )) (St( tid2, B_4 )) &
           predOrd t (St( tid2, B_4 )) (St( tid3, S_4 ))))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''enc52'', s(MV ''A'' tid2), s(MV ''na'' tid2), LN ''nb'' tid2,
                          s(MV ''kab'' tid2)
                       |}
                       ( K ( s(AV ''B'' tid2) ) ( s(AV ''S'' tid2) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_5_enc_1 tid3) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''enc3'', s(MV ''A'' tid2), s(AV ''B'' tid2),
                            s(MV ''na'' tid2), LN ''nb'' tid2
                         |}
                         ( K ( s(MV ''A'' tid2) ) ( s(AV ''S'' tid2) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (auto dest!: ltk_secrecy)
    next
      case (A_3_enc tid4) note_unified facts = this facts
      have f1: "roleMap r tid4 = Some A" using facts by (auto intro: event_predOrdI)
      have f2: "LN ''na'' tid4 : knows t" using facts by (auto intro: event_predOrdI)
      note facts = facts na_first_send[OF f1 f2, simplified]
      have f1: "roleMap r tid2 = Some B" using facts by (auto intro: event_predOrdI)
      have f2: "LN ''nb'' tid2 : knows t" using facts by (auto intro: event_predOrdI)
      note facts = facts nb_first_send[OF f1 f2, simplified]
      thus ?thesis proof(sources! "
                       Enc {| LC ''enc7'', LN ''nb'' tid2 |} ( LN ''kab'' tid3 ) ")
        case fake note_unified facts = this facts
        thus ?thesis by (fastforce dest: S_sec_kab intro: event_predOrdI)
      next
        case (A_7_enc tid5) note_unified facts = this facts
        thus ?thesis proof(sources! "
                         Enc {| LC ''enc4'', s(AV ''A'' tid4), s(AV ''B'' tid2), LN ''na'' tid4,
                                LN ''nb'' tid2
                             |}
                             ( K ( s(AV ''A'' tid4) ) ( s(AV ''S'' tid2) ) ) ")
          case fake note_unified facts = this facts
          thus ?thesis by (auto dest!: ltk_secrecy)
        next
          case (B_4_enc tid6) note_unified facts = this facts
          thus ?thesis proof(sources! "
                           Enc {| LC ''enc6'', LN ''na'' tid5, LN ''nb'' tid2 |}
                               ( LN ''kab'' tid3 ) ")
            case fake note_unified facts = this facts
            thus ?thesis by (fastforce dest: S_sec_kab intro: event_predOrdI)
          next
            case (B_6_enc tid6) note_unified facts = this facts
            thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
          qed (safe?, simp_all?, insert facts, (fastforce+)?)
        qed (safe?, simp_all?, insert facts, (fastforce+)?)
      qed (safe?, simp_all?, insert facts, (fastforce+)?)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_WooLam_state) S_ni_synch:
  assumes facts:
    "roleMap r tid3 = Some S"
    "RLKR(s(AV ''S'' tid3)) ~: reveals t"
    "RLKR(s(MV ''A'' tid3)) ~: reveals t"
    "RLKR(s(MV ''B'' tid3)) ~: reveals t"
    "( tid3, S_4 ) : steps t"
  shows
    "(?  tid1.
        (?  tid2.
           roleMap r tid1 = Some A &
           roleMap r tid2 = Some B &
           s(MV ''A'' tid2) = s(AV ''A'' tid1) &
           s(AV ''B'' tid2) = s(MV ''B'' tid1) &
           s(AV ''S'' tid2) = s(AV ''S'' tid1) &
           s(MV ''na'' tid2) = LN ''na'' tid1 &
           LN ''nb'' tid2 = s(MV ''nb'' tid1) &
           s(MV ''A'' tid2) = s(MV ''A'' tid3) &
           s(AV ''B'' tid2) = s(MV ''B'' tid3) &
           s(AV ''S'' tid2) = s(AV ''S'' tid3) &
           s(MV ''na'' tid2) = s(MV ''na'' tid3) &
           LN ''nb'' tid2 = s(MV ''nb'' tid3) &
           predOrd t (St( tid1, A_1 )) (St( tid2, B_1 )) &
           predOrd t (St( tid2, B_1 )) (St( tid2, B_2 )) &
           predOrd t (St( tid2, B_2 )) (St( tid1, A_2 )) &
           predOrd t (St( tid1, A_2 )) (St( tid1, A_3 )) &
           predOrd t (St( tid1, A_3 )) (St( tid3, S_4 )) &
           predOrd t (St( tid2, B_3 )) (St( tid2, B_4 )) &
           predOrd t (St( tid2, B_4 )) (St( tid3, S_4 ))))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''enc3'', s(MV ''A'' tid3), s(MV ''B'' tid3),
                          s(MV ''na'' tid3), s(MV ''nb'' tid3)
                       |}
                       ( K ( s(MV ''A'' tid3) ) ( s(AV ''S'' tid3) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (A_3_enc tid4) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''enc4'', s(AV ''A'' tid4), s(MV ''B'' tid3), LN ''na'' tid4,
                            s(MV ''nb'' tid3)
                         |}
                         ( K ( s(AV ''A'' tid4) ) ( s(AV ''S'' tid3) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (auto dest!: ltk_secrecy)
    next
      case (B_4_enc tid5) note_unified facts = this facts
      have f1: "roleMap r tid4 = Some A" using facts by (auto intro: event_predOrdI)
      have f2: "LN ''na'' tid4 : knows t" using facts by (auto intro: event_predOrdI)
      note facts = facts na_first_send[OF f1 f2, simplified]
      have f1: "roleMap r tid5 = Some B" using facts by (auto intro: event_predOrdI)
      have f2: "LN ''nb'' tid5 : knows t" using facts by (auto intro: event_predOrdI)
      note facts = facts nb_first_send[OF f1 f2, simplified]
      thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

end


theory TransformTools
imports "Launchbury.Nominal-HOLCF" Launchbury.Terms Launchbury.Substitution Launchbury.Env
begin

default_sort type

fun lift_transform :: "('a::cont_pt \<Rightarrow> exp \<Rightarrow> exp) \<Rightarrow> ('a\<^sub>\<bottom> \<Rightarrow> exp \<Rightarrow> exp)"
  where "lift_transform t Ibottom  e = e"
  |     "lift_transform t (Iup a) e = t a e"

lemma lift_transform_simps[simp]:
  "lift_transform t \<bottom> e = e"
  "lift_transform t (up\<cdot>a) e = t a e"
  apply (metis inst_up_pcpo lift_transform.simps(1))
  apply (simp add: up_def cont_Iup)
  done

lemma lift_transform_eqvt[eqvt]: "\<pi> \<bullet>  lift_transform t a e = lift_transform (\<pi> \<bullet> t) (\<pi> \<bullet> a) (\<pi> \<bullet> e)"
  by (cases "a") simp_all

lemma lift_transform_fun_cong[fundef_cong]:
  "(\<And> a. t1 a e1 = t2 a e1) \<Longrightarrow> a1 = a2 \<Longrightarrow> e1 = e2 \<Longrightarrow> lift_transform t1 a1 e1 = lift_transform t2 a2 e2"
  by (cases "(t2,a2,e2)" rule: lift_transform.cases) auto

lemma subst_lift_transform:
  assumes "\<And> a. (t a e)[x ::= y] = t a (e[x ::= y])"
  shows "(lift_transform t a e)[x ::=y] = lift_transform t a (e[x ::= y])"
  using assms by (cases a) auto

definition
  map_transform :: "('a::cont_pt \<Rightarrow> exp \<Rightarrow> exp) \<Rightarrow> (var \<Rightarrow> 'a\<^sub>\<bottom>) \<Rightarrow> heap \<Rightarrow> heap"
  where "map_transform t ae = map_ran (\<lambda> x e . lift_transform t (ae x) e)"

lemma map_transform_eqvt[eqvt]: "\<pi> \<bullet> map_transform t ae = map_transform (\<pi> \<bullet> t) (\<pi> \<bullet> ae)"
  unfolding map_transform_def by simp

lemma domA_map_transform[simp]: "domA (map_transform t ae \<Gamma>) = domA \<Gamma>"
  unfolding map_transform_def by simp

lemma length_map_transform[simp]: "length (map_transform t ae xs) = length xs"
  unfolding map_transform_def map_ran_def by simp

lemma map_transform_delete:
  "map_transform t ae (delete x \<Gamma>) = delete x (map_transform t ae \<Gamma>)"
  unfolding map_transform_def by (simp add: map_ran_delete)

lemma map_transform_restrA:
  "map_transform t ae (restrictA S \<Gamma>) = restrictA S (map_transform t ae \<Gamma>)"
  unfolding map_transform_def by (auto simp add: map_ran_restrictA)

lemma delete_map_transform_env_delete:
  "delete x (map_transform t (env_delete x ae) \<Gamma>) = delete x (map_transform t ae \<Gamma>)"
  unfolding map_transform_def by (induction \<Gamma>) auto

lemma map_transform_Nil[simp]:
  "map_transform t ae [] = []"
  unfolding map_transform_def by simp

lemma map_transform_Cons:
  "map_transform t ae ((x,e)# \<Gamma>) = (x, lift_transform t (ae x) e) #  (map_transform t ae \<Gamma>)"
  unfolding map_transform_def by simp

lemma map_transform_append:
  "map_transform t ae (\<Delta>@\<Gamma>) = map_transform t ae \<Delta> @ map_transform t ae \<Gamma>"
  unfolding map_transform_def by (simp add: map_ran_append)

lemma map_transform_fundef_cong[fundef_cong]:
  "(\<And>x e a. (x,e) \<in> set m1 \<Longrightarrow> t1 a e = t2 a e) \<Longrightarrow> ae1 = ae2 \<Longrightarrow> m1 = m2 \<Longrightarrow> map_transform t1 ae1 m1 = map_transform t2 ae2 m2"
  by (induction m2 arbitrary: m1)
     (fastforce simp add: map_transform_Nil map_transform_Cons intro!: lift_transform_fun_cong)+

lemma map_transform_cong:
  "(\<And>x. x \<in> domA m1 \<Longrightarrow> ae x = ae' x) \<Longrightarrow> m1 = m2 \<Longrightarrow> map_transform t ae m1 = map_transform t ae' m2"
  unfolding map_transform_def by (auto intro!: map_ran_cong dest: domA_from_set)

lemma map_of_map_transform: "map_of (map_transform t ae \<Gamma>) x = map_option (lift_transform t (ae x)) (map_of \<Gamma> x)"
  unfolding map_transform_def by (simp add: map_ran_conv)

lemma supp_map_transform_step:
  assumes "\<And> x e a. (x, e) \<in> set \<Gamma> \<Longrightarrow> supp (t a e) \<subseteq> supp e"
  shows "supp (map_transform t ae \<Gamma>) \<subseteq> supp \<Gamma>"
  using assms
    apply (induction \<Gamma>)
    apply (auto simp add: supp_Nil supp_Cons map_transform_Nil map_transform_Cons supp_Pair pure_supp)
    apply (case_tac "ae a")
    apply (fastforce)+
    done

lemma subst_map_transform:
  assumes "\<And> x' e a. (x',e) : set \<Gamma> \<Longrightarrow> (t a e)[x ::= y] = t a (e[x ::= y])"
  shows "(map_transform t ae \<Gamma>)[x ::h=y] = map_transform t ae (\<Gamma>[x ::h= y])"
  using assms
  apply (induction \<Gamma>)
  apply (auto simp add: map_transform_Nil map_transform_Cons)
  apply (subst subst_lift_transform)
  apply auto
  done

locale supp_bounded_transform =
  fixes trans :: "'a::cont_pt \<Rightarrow> exp \<Rightarrow> exp"
  assumes supp_trans: "supp (trans a e) \<subseteq> supp e"
begin
  lemma supp_lift_transform: "supp (lift_transform trans a e) \<subseteq> supp e"
    by (cases "(trans, a, e)" rule:lift_transform.cases) (auto dest!: subsetD[OF supp_trans])

  lemma supp_map_transform: "supp (map_transform trans ae \<Gamma>) \<subseteq> supp \<Gamma>"
  unfolding map_transform_def
     by (induction \<Gamma>) (auto simp add: supp_Pair supp_Cons dest!: subsetD[OF supp_lift_transform])

  lemma fresh_transform[intro]: "a \<sharp> e \<Longrightarrow> a \<sharp> trans n e"
    by (auto simp add: fresh_def) (auto dest!: subsetD[OF supp_trans])

  lemma fresh_star_transform[intro]: "a \<sharp>* e \<Longrightarrow> a \<sharp>* trans n e"
    by (auto simp add: fresh_star_def)

  lemma fresh_map_transform[intro]: "a \<sharp> \<Gamma> \<Longrightarrow> a \<sharp> map_transform trans ae \<Gamma>"
    unfolding fresh_def using supp_map_transform by auto

  lemma fresh_star_map_transform[intro]: "a \<sharp>* \<Gamma> \<Longrightarrow> a \<sharp>* map_transform trans ae \<Gamma>"
    by (auto simp add: fresh_star_def)
end

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)
theory TraceMonadLemmas
imports TraceMonadVCG
begin

lemma mapM_Cons:
  "mapM f (x # xs) = do
    y \<leftarrow> f x;
    ys \<leftarrow> mapM f xs;
    return (y # ys)
  od"
  and mapM_Nil:
  "mapM f [] = return []"
  by (simp_all add: mapM_def sequence_def)

lemma mapM_x_Cons:
  "mapM_x f (x # xs) = do
    y \<leftarrow> f x;
    mapM_x f xs
  od"
  and mapM_x_Nil:
  "mapM_x f [] = return ()"
  by (simp_all add: mapM_x_def sequence_x_def)

lemma mapM_append:
  "mapM f (xs @ ys) = (do
    fxs \<leftarrow> mapM f xs;
    fys \<leftarrow> mapM f ys;
    return (fxs @ fys)
  od)"
  by (induct xs, simp_all add: mapM_Cons mapM_Nil bind_assoc)

lemma mapM_x_append:
  "mapM_x f (xs @ ys) = (do
    x \<leftarrow> mapM_x f xs;
    mapM_x f ys
  od)"
  by (induct xs, simp_all add: mapM_x_Cons mapM_x_Nil bind_assoc)

lemma mapM_map:
  "mapM f (map g xs) = mapM (f o g) xs"
  by (induct xs; simp add: mapM_Nil mapM_Cons)

lemma mapM_x_map:
  "mapM_x f (map g xs) = mapM_x (f o g) xs"
  by (induct xs; simp add: mapM_x_Nil mapM_x_Cons)

primrec
  repeat_n :: "nat \<Rightarrow> ('s, unit) tmonad \<Rightarrow> ('s, unit) tmonad"
where
    "repeat_n 0 f = return ()"
  | "repeat_n (Suc n) f = do f; repeat_n n f od"

lemma repeat_n_mapM_x:
  "repeat_n n f = mapM_x (\<lambda>_. f) (replicate n ())"
  by (induct n, simp_all add: mapM_x_Cons mapM_x_Nil)

definition
  repeat :: "('s, unit) tmonad \<Rightarrow> ('s, unit) tmonad"
where
  "repeat f = do n \<leftarrow> select UNIV; repeat_n n f od"

definition
  env_step :: "('s,unit) tmonad"
where
  "env_step =
  (do
    s' \<leftarrow> select UNIV;
    put_trace_elem (Env, s');
    put s'
  od)"

abbreviation
  "env_n_steps n \<equiv> repeat_n n env_step"

lemma elem_select_bind:
  "(tr, res) \<in> (do x \<leftarrow> select S; f x od) s
    = (\<exists>x \<in> S. (tr, res) \<in> f x s)"
  by (simp add: bind_def select_def)

lemma select_bind_UN:
  "(do x \<leftarrow> select S; f x od) = (\<lambda>s. \<Union>x \<in> S. f x s)"
  by (rule ext, auto simp: elem_select_bind)

lemma select_early:
  "S \<noteq> {}
    \<Longrightarrow> do x \<leftarrow> f; y \<leftarrow> select S; g x y od
        = do y \<leftarrow> select S; x \<leftarrow> f; g x y od"
  apply (simp add: bind_def select_def Sigma_def)
  apply (rule ext)
  apply (fastforce elim: rev_bexI image_eqI[rotated] split: tmres.split_asm)
  done

lemma repeat_n_choice:
  "S \<noteq> {}
    \<Longrightarrow> repeat_n n (do x \<leftarrow> select S; f x od)
        = (do xs \<leftarrow> select {xs. set xs \<subseteq> S \<and> length xs = n}; mapM_x f xs od)"
  apply (induct n; simp?)
   apply (simp add: select_def bind_def mapM_x_Nil cong: conj_cong)
  apply (simp add: select_early bind_assoc)
  apply (subst select_early)
   apply simp
   apply (auto intro: exI[where x="replicate n xs" for n xs])[1]
  apply (simp(no_asm) add: fun_eq_iff set_eq_iff elem_select_bind)
  apply (simp only: conj_comms[where Q="length xs = n" for xs n])
  apply (simp only: ex_simps[symmetric] conj_assoc length_Suc_conv, simp)
  apply (auto simp: mapM_x_Cons)
  done

lemma repeat_choice:
  "S \<noteq> {}
    \<Longrightarrow> repeat (do x \<leftarrow> select S; f x od)
        = (do xs \<leftarrow> select {xs. set xs \<subseteq> S}; mapM_x f xs od)"
  apply (simp add: repeat_def repeat_n_choice)
  apply (simp(no_asm) add: fun_eq_iff set_eq_iff elem_select_bind)
  done

lemma put_trace_append:
  "put_trace (xs @ ys) = do put_trace ys; put_trace xs od"
  by (induct xs; simp add: bind_assoc)

lemma put_trace_elem_put_comm:
  "do y \<leftarrow> put_trace_elem x; put s od
    = do y \<leftarrow> put s; put_trace_elem x od"
  by (simp add: put_def put_trace_elem_def bind_def insert_commute)

lemma put_trace_put_comm:
  "do y \<leftarrow> put_trace xs; put s od
    = do y \<leftarrow> put s; put_trace xs od"
  apply (rule sym; induct xs; simp)
  apply (simp add: bind_assoc put_trace_elem_put_comm)
  apply (simp add: bind_assoc[symmetric])
  done

lemma mapM_x_comm:
  "(\<forall>x \<in> set xs. do y \<leftarrow> g; f x od = do y \<leftarrow> f x; g od)
    \<Longrightarrow> do y \<leftarrow> g; mapM_x f xs od = do y \<leftarrow> mapM_x f xs; g od"
  apply (induct xs; simp add: mapM_x_Nil mapM_x_Cons)
  apply (simp add: bind_assoc[symmetric], simp add: bind_assoc)
  done

lemma mapM_x_split:
  "(\<forall>x \<in> set xs. \<forall>y \<in> set xs. do z \<leftarrow> g y; f x od = do (z :: unit) \<leftarrow> f x; g y od)
    \<Longrightarrow> mapM_x (\<lambda>x. do z \<leftarrow> f x; g x od) xs = do y \<leftarrow> mapM_x f xs; mapM_x g xs od"
  apply (induct xs; simp add: mapM_x_Nil mapM_x_Cons bind_assoc)
  apply (subst bind_assoc[symmetric], subst mapM_x_comm[where f=f and g="g x" for x])
   apply simp
  apply (simp add: bind_assoc)
  done

lemma mapM_x_put:
  "mapM_x put xs = unless (xs = []) (put (last xs))"
  apply (induct xs rule: rev_induct)
   apply (simp add: mapM_x_Nil unless_def when_def)
  apply (simp add: mapM_x_append mapM_x_Cons mapM_x_Nil)
  apply (simp add: bind_def unless_def when_def put_def return_def)
  done

lemma put_trace_mapM_x:
  "put_trace xs = mapM_x put_trace_elem (rev xs)"
  by (induct xs; simp add: mapM_x_Nil mapM_x_append mapM_x_Cons)

lemma rev_surj:
  "surj rev"
  by (rule_tac f=rev in surjI, simp)

lemma select_image:
  "select (f ` S) = do x \<leftarrow> select S; return (f x) od"
  by (auto simp add: bind_def select_def return_def Sigma_def)

lemma env_steps_repeat:
  "env_steps = repeat env_step"
  apply (simp add: env_step_def repeat_choice env_steps_def
                   select_early)
  apply (simp add: put_trace_elem_put_comm)
  apply (simp add: mapM_x_split put_trace_elem_put_comm put_trace_put_comm
                   mapM_x_put)
  apply (simp add: put_trace_mapM_x rev_map mapM_x_map o_def)
  apply (subst rev_surj[symmetric], simp add: select_image bind_assoc)
  apply (rule arg_cong2[where f=bind, OF refl ext])
  apply (simp add: bind_def get_def put_def unless_def when_def return_def)
  apply (simp add: last_st_tr_def hd_map hd_rev)
  done

lemma repeat_n_plus:
  "repeat_n (n + m) f = do repeat_n n f; repeat_n m f od"
  by (induct n; simp add: bind_assoc)

lemma repeat_eq_twice[simp]:
  "(do x \<leftarrow> repeat f; repeat f od) = repeat f"
  apply (simp add: repeat_def select_early)
  apply (simp add: bind_assoc repeat_n_plus[symmetric, simplified])
  apply (simp add: bind_def select_def Sigma_def)
  apply (rule ext, fastforce intro: exI[where x=0])
  done

lemmas bind_then_eq = arg_cong2[where f=bind, OF _ refl]
lemmas repeat_eq_twice_then[simp]
    = repeat_eq_twice[THEN bind_then_eq, simplified bind_assoc]

lemmas env_steps_eq_twice[simp]
    = repeat_eq_twice[where f=env_step, folded env_steps_repeat]
lemmas env_steps_eq_twice_then[simp]
    = env_steps_eq_twice[THEN bind_then_eq, simplified bind_assoc]

lemmas mapM_collapse_append = mapM_append[symmetric, THEN bind_then_eq,
    simplified bind_assoc, simplified]

lemma prefix_closed_mapM[rule_format, wp_split]:
  "(\<forall>x \<in> set xs. prefix_closed (f x)) \<Longrightarrow> prefix_closed (mapM f xs)"
  apply (induct xs)
   apply (simp add: mapM_def sequence_def)
  apply (clarsimp simp: mapM_Cons)
  apply (intro prefix_closed_bind allI; clarsimp)
  done

lemma modify_id:
  "modify id = return ()"
  by (simp add: modify_def get_def bind_def put_def return_def)

lemma modify_modify:
  "(do x \<leftarrow> modify f; modify (g x) od) = modify (g () o f)"
  by (simp add: bind_def simpler_modify_def)

lemmas modify_modify_bind = arg_cong2[where f=bind,
  OF modify_modify refl, simplified bind_assoc]

lemma select_single:
  "select {x} = return x"
  by (simp add: select_def return_def)

lemma put_then_get[unfolded K_bind_def]:
  "do put s; get od = do put s; return s od"
  by (simp add: put_def bind_def get_def return_def)

lemmas put_then_get_then
    = put_then_get[THEN bind_then_eq, simplified bind_assoc return_bind]

lemmas bind_promote_If
    = if_distrib[where f="\<lambda>f. bind f g" for g]
      if_distrib[where f="\<lambda>g. bind f g" for f]

lemma bind_promote_If2:
  "do x \<leftarrow> f; if P then g x else h x od
    = (if P then bind f g else bind f h)"
  by simp

lemma exec_put_trace[unfolded K_bind_def]:
  "(do put_trace xs; f od) s
    = (\<Union>n \<in> {n. 0 < n \<and> n \<le> length xs}. {(drop n xs, Incomplete)})
        \<union> ((\<lambda>(a, b). (a @ xs, b)) ` f s)"
  apply (simp add: put_trace_eq_drop bind_def)
  apply (safe; (clarsimp split: if_split_asm)?;
      fastforce intro: bexI[where x=0] rev_bexI)
  done

lemma if_fun_lift:
  "(if P then f else g) x = (if P then f x else g x)"
  by simp

lemma UN_If_distrib:
  "(\<Union>x \<in> S. if P x then A x else B x)
    = ((\<Union>x \<in> S \<inter> {x. P x}. A x) \<union> (\<Union>x \<in> S \<inter> {x. \<not> P x}. B x))"
  by (fastforce split: if_split_asm)

lemma Await_redef:
  "Await P = do
    s1 \<leftarrow> select {s. P s};
    env_steps;
    s \<leftarrow> get;
    select (if P s then {()} else {})
  od"
  apply (simp add: Await_def env_steps_def bind_assoc)
  apply (cases "{s. P s} = {}")
   apply (simp add: select_def bind_def get_def)
  apply (rule ext)
  apply (simp add: exec_get select_bind_UN put_then_get_then)
  apply (simp add: bind_promote_If2 if_fun_lift if_distrib[where f=select])
  apply (simp add: exec_put_trace cong: if_cong)
  apply (simp add: put_def bind_def select_def cong: if_cong)
  apply (strengthen equalityI)
  apply clarsimp
  apply (strengthen exI[where x="s # xs" for s xs])
  apply (strengthen exI[where x="Suc n" for n])
  apply simp
  apply blast
  done

lemma bind_apply_cong':
  "f s = f' s
    \<Longrightarrow> (\<forall>rv s'. (rv, s') \<in> mres (f s) \<longrightarrow> g rv s' = g' rv s')
    \<Longrightarrow> bind f g s = bind f' g' s"
  apply (simp add: bind_def)
  apply (rule SUP_cong; simp?)
  apply (clarsimp split: tmres.split)
  apply (drule spec2, drule mp, erule in_mres)
  apply simp
  done

lemmas bind_apply_cong = bind_apply_cong'[rule_format]

lemma select_empty_bind[simp]:
  "select {} >>= f = select {}"
  by (simp add: select_def bind_def)

lemma fail_bind[simp]:
  "fail >>= f = fail"
  by (simp add: bind_def fail_def)

lemma eq_Me_neq_Env:
  "(x = Me) = (x \<noteq> Env)"
  by (cases x; simp)

lemma validI_invariant_imp:
  assumes v: "\<lbrace>P\<rbrace>,\<lbrace>R\<rbrace> f \<lbrace>G\<rbrace>,\<lbrace>Q\<rbrace>"
    and P: "\<forall>s0 s. P s0 s \<longrightarrow> I s0"
    and R: "\<forall>s0 s. I s0 \<longrightarrow> R s0 s \<longrightarrow> I s"
    and G: "\<forall>s0 s. I s0 \<longrightarrow> G s0 s \<longrightarrow> I s"
  shows "\<lbrace>P\<rbrace>,\<lbrace>R\<rbrace> f \<lbrace>\<lambda>s0 s. I s0 \<and> I s \<and> G s0 s\<rbrace>,\<lbrace>\<lambda>rv s0 s. I s0 \<and> Q rv s0 s\<rbrace>"
proof -
  { fix tr s0 i
  assume r: "rely_cond R s0 tr" and g: "guar_cond G s0 tr"
    and I: "I s0"
  hence imp: "\<forall>(_, s, s') \<in> trace_steps (rev tr) s0. I s \<longrightarrow> I s'"
    apply (clarsimp simp: guar_cond_def rely_cond_def)
    apply (drule(1) bspec)+
    apply (clarsimp simp: eq_Me_neq_Env)
    apply (metis R G)
    done
  hence "i < length tr \<longrightarrow> I (snd (rev tr ! i))"
    using I
    apply (induct i)
     apply (clarsimp simp: neq_Nil_conv[where xs="rev tr" for tr, simplified])
    apply clarsimp
    apply (drule bspec, fastforce simp add: trace_steps_nth)
    apply simp
    done
  }
  note I = this
  show ?thesis
    using v
    apply (clarsimp simp: validI_def rely_def imp_conjL)
    apply (drule spec2, drule(1) mp)+
    apply clarsimp
    apply (frule P[rule_format])
    apply (clarsimp simp: guar_cond_def trace_steps_nth I last_st_tr_def
                          hd_append last_rev[symmetric]
                          last_conv_nth rev_map)
    done
qed

lemma validI_guar_post_conj_lift:
  "\<lbrace>P\<rbrace>,\<lbrace>R\<rbrace> f \<lbrace>G1\<rbrace>,\<lbrace>Q1\<rbrace>
    \<Longrightarrow> \<lbrace>P\<rbrace>,\<lbrace>R\<rbrace> f \<lbrace>G2\<rbrace>,\<lbrace>Q2\<rbrace>
    \<Longrightarrow> \<lbrace>P\<rbrace>,\<lbrace>R\<rbrace> f \<lbrace>\<lambda>s0 s. G1 s0 s \<and> G2 s0 s\<rbrace>,\<lbrace>\<lambda>rv s0 s. Q1 rv s0 s \<and> Q2 rv s0 s\<rbrace>"
  apply (frule validI_prefix_closed)
  apply (subst validI_def, clarsimp simp: rely_def)
  apply (drule(3) validI_D)+
  apply (auto simp: guar_cond_def)
  done

lemmas modify_prefix_closed[simp] =
  modify_wp[THEN valid_validI_wp[OF no_trace_all(3)], THEN validI_prefix_closed]
lemmas await_prefix_closed[simp] = Await_sync_twp[THEN validI_prefix_closed]

lemma repeat_prefix_closed[intro!]:
  "prefix_closed f \<Longrightarrow> prefix_closed (repeat f)"
  apply (simp add: repeat_def)
  apply (rule prefix_closed_bind; clarsimp)
  apply (rename_tac n)
  apply (induct_tac n; simp)
  apply (auto intro: prefix_closed_bind)
  done

end


(*
 * Copyright 2014, 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)
 *)

theory MultByAdd
imports
  "../../AutoCorres"
begin

(* Parse the input file. *)
install_C_file "mult_by_add.c"

(* Abstract the input file. *)
autocorres [ ts_force nondet = mult_by_add ] "mult_by_add.c"

context mult_by_add begin

(*
 * Prove the function returns the correct result, and (simultaneously)
 * does not fail and terminates.
 *)
lemma "\<lbrace> \<lambda>s. True \<rbrace> mult_by_add' a b \<lbrace> \<lambda>r s. r = a * b \<rbrace>!"
  (* Unfold function definition. *)
  apply (clarsimp simp: mult_by_add'_def)

  (* Annotate while loop with an invariant and measure. *)
  apply (subst whileLoop_add_inv
    [where I="\<lambda>(a', r) s. (a' * b) + r = (a * b)"
       and M="\<lambda>((a', _), s). unat a'"])

  (* Run "wp" weakest precondition tactic, and solve verification *
   * conditions generated by it. *)
  apply wp
     apply (simp add: field_simps)
    apply unat_arith
   apply (simp add: split_def word_neq_0_conv[symmetric])
  apply (simp add: split_def | wp)+
  done

(*
 * Equivalent partial-correctness proof using Simpl framework.
 *)
lemma "\<Gamma> \<turnstile> {s. s = t} \<acute>ret__unsigned :== CALL mult_by_add(\<acute>a, \<acute>b) \<lbrace> (\<acute>ret__unsigned = \<^bsup>t\<^esup>a * \<^bsup>t\<^esup>b) \<rbrace>"
  (* Unfold the body. *)
  apply vcg_step
   defer

   (* Annotate the while loop with an invariant and variant. *)
   apply (subst whileAnno_def)
   apply (subst whileAnno_def [symmetric,
     where I=" \<lbrace> (\<acute>a * \<acute>b + \<acute>result) = (\<^bsup>t\<^esup>a * \<^bsup>t\<^esup>b) \<rbrace>"
     and V="measure (\<lambda>s. unat (a_' s))"])

  (* Solve the remaining conditions. *)
   apply vcg
   apply (fastforce intro: unat_mono simp: gt0_iff_gem1 field_simps less_1_simp scast_id)+
  done

end

end


(*  Title:      JinjaThreads/Basic/Set_without_equal.thy
    Author:     Andreas Lochbihler
*)

theory Set_without_equal
imports Main
begin

text \<open>
  Adapt @{type "set"} code setup such that @{const "insert"},
  @{const "union"}, and @{term "set_of_pred"} do not generate
  sort constraint @{class equal}.
\<close>

definition insert' :: "'a \<Rightarrow> 'a set \<Rightarrow> 'a set"
where "insert' = Set.insert"

definition union' :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set"
where "union' A B = sup A B"

declare
  insert'_def [symmetric, code_unfold]
  union'_def [symmetric, code_unfold]

lemma insert'_code:
  "insert' x (set xs) = set (x # xs)"
  by (rule set_eqI) (simp add: insert'_def)

lemma union'_code:
  "union' (set xs) (set ys) = set (xs @ ys)"
  by (rule set_eqI) (simp add: union'_def fun_eq_iff)

declare
  insert'_code [code]
  union'_code [code]

text \<open>Merge name spaces to avoid cyclic module dependencies\<close>

code_identifier
  code_module Set_without_equal \<rightharpoonup>
    (SML) Set and (Haskell) Set and (OCaml) Set

end


theory Proof_1_8
  imports Proofs_1
begin

theorem proof_1_8: "VC8 inv1 env s0 user_value pressure_value"
  apply(simp only: VC8_def inv1_def R1_def extraInv_def)
  apply(rule impI)
  apply(rule conjI)
   apply(rule conjI)
    apply simp
   apply((rule allI)+)
   apply(rule impI)
  subgoal premises prems for s1 s2
    using prems(2) apply(simp split: if_splits)
    using prems
     apply (smt (z3) getPstate.simps(9) substate_refl)
    using prems(1)
    by (meson prems(2))