theory "Amended_Needham_Schroeder_Symmetric_Key_cert_auto"
imports
  "ESPLogic"
begin

(* section:  The Amended Needham Schroeder Symmetric Key Protocol  *)

(* text:
  Modelled according to the desciprtion in the SPORE library:

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

  Notable differences:

    1. Instead of assuming a typed model we are using global constants to
       ensure distinctness of messages from different steps.

    2. We use the weaker authentication property of non-injective agreement
       instead of injective agreement because the later cannot yet be proven
       automatically. However, based on the resulting Isabelle file it would be
       easy to also derive injective agreement from the proven non-injective
       variants.

    3. We model the invertible function 'dec(x)' as tupling with a fixed public
       constant 'dec'; i.e., we only exploit 'dec's tagging capabilities.

    TODO: Check that this protocol can also be verified with bidirectional
    shared keys.
 *)

role I
where "I =
  [ Send ''1'' ( sAV ''I'' )
  , Recv ''2'' ( sMV ''RequestR'' )
  , Send ''3'' <| sAV ''I'', sAV ''R'', sN ''ni'', sMV ''RequestR'' |>
  , Recv ''4'' <| sMV ''S'',
                  PEnc <| sC ''2'', sN ''ni'', sAV ''R'', sMV ''kIR'', sMV ''TicketR'' |>
                       ( PSymK ( sAV ''I'' ) ( sMV ''S'' ) )
               |>
  , Send ''5'' ( sMV ''TicketR'' )
  , Recv ''6'' ( PEnc <| sC ''4'', sMV ''nr'' |> ( sMV ''kIR'' ) )
  , Send ''7'' ( PEnc <| sC ''5'', sC ''dec'', sMV ''nr'' |>
                      ( sMV ''kIR'' )
               )
  ]"

role R
where "R =
  [ Recv ''1'' ( sMV ''I'' )
  , Send ''2'' ( PEnc <| sC ''1'', sMV ''I'', sN ''nr'' |>
                      ( sK ''R'' ''S'' )
               )
  , Recv ''5'' ( PEnc <| sC ''3'', sMV ''kIR'', sN ''nr'', sMV ''I'' |>
                      ( sK ''R'' ''S'' )
               )
  , Send ''6'' ( PEnc <| sC ''4'', sN ''nr'' |> ( sMV ''kIR'' ) )
  , Recv ''7'' ( PEnc <| sC ''5'', sC ''dec'', sN ''nr'' |> ( sMV ''kIR'' )
               )
  ]"

role S
where "S =
  [ Recv ''3'' <| sMV ''I'', sMV ''R'', sMV ''ni'',
                  PEnc <| sC ''1'', sMV ''I'', sMV ''nr'' |>
                       ( PSymK ( sMV ''R'' ) ( sAV ''S'' ) )
               |>
  , Send ''4'' <| sAV ''S'',
                  PEnc <| sC ''2'', sMV ''ni'', sMV ''R'', sN ''kIR'',
                          PEnc <| sC ''3'', sN ''kIR'', sMV ''nr'', sMV ''I'' |>
                               ( PSymK ( sMV ''R'' ) ( sAV ''S'' ) )
                       |>
                       ( PSymK ( sMV ''I'' ) ( sAV ''S'' ) )
               |>
  ]"

protocol AmendedNS
where "AmendedNS = { I, R, S }"

locale restricted_AmendedNS_state = AmendedNS_state

(* subsection:  Security Properties  *)

type_invariant AmendedNS_msc_typing for AmendedNS
where "AmendedNS_msc_typing = mk_typing
  [ ((R, ''I''), (KnownT R_1))
  , ((S, ''I''), (KnownT S_3))
  , ((S, ''R''), (KnownT S_3))
  , ((I, ''RequestR''), (KnownT I_2))
  , ((I, ''S''), (KnownT I_4))
  , ((I, ''TicketR''),
     (SumT (KnownT I_4) (EncT (TupT (ConstT ''3'') (TupT (NonceT S ''kIR'') (TupT (SumT (KnownT I_4) (NonceT R ''nr'')) AgentT))) (KT AgentT AgentT))))
  , ((I, ''kIR''), (SumT (KnownT I_4) (NonceT S ''kIR'')))
  , ((R, ''kIR''), (SumT (KnownT R_5) (NonceT S ''kIR'')))
  , ((S, ''ni''), (KnownT S_3))
  , ((I, ''nr''), (SumT (KnownT I_6) (NonceT R ''nr'')))
  , ((S, ''nr''), (SumT (KnownT S_3) (NonceT R ''nr'')))
  ]"

sublocale AmendedNS_state < AmendedNS_msc_typing_state
proof -
  have "(t,r,s) : approx AmendedNS_msc_typing"
  proof(cases rule: reachable_in_approxI_ext
        [OF AmendedNS_msc_typing.monoTyp, completeness_cases_rule])
    case (I_4_S t r s tid0)
    then interpret state: AmendedNS_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = I_4_S
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (I_4_TicketR t r s tid0)
    then interpret state: AmendedNS_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = I_4_TicketR
    thus ?case
    proof(sources! "
        Enc {| LC ''2'', LN ''ni'' tid0, s(AV ''R'' tid0), s(MV ''kIR'' tid0),
               s(MV ''TicketR'' tid0)
            |}
            ( K ( s(AV ''I'' tid0) ) ( s(MV ''S'' tid0) ) ) ")
      case (S_4_enc tid1) note_unified facts = this facts
      thus ?thesis proof(sources! "
                       Enc {| LC ''1'', s(AV ''I'' tid0), s(MV ''nr'' tid1) |}
                           ( K ( s(AV ''R'' tid0) ) ( s(AV ''S'' tid1) ) ) ")
      qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (I_4_kIR t r s tid0)
    then interpret state: AmendedNS_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = I_4_kIR
    thus ?case
    proof(sources! "
        Enc {| LC ''2'', LN ''ni'' tid0, s(AV ''R'' tid0), s(MV ''kIR'' tid0),
               s(MV ''TicketR'' tid0)
            |}
            ( K ( s(AV ''I'' tid0) ) ( s(MV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (I_6_nr t r s tid0)
    then interpret state: AmendedNS_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = I_6_nr
    thus ?case
    proof(sources! "
        Enc {| LC ''4'', s(MV ''nr'' tid0) |} ( s(MV ''kIR'' tid0) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (R_5_kIR t r s tid0)
    then interpret state: AmendedNS_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = R_5_kIR
    thus ?case
    proof(sources! "
        Enc {| LC ''3'', s(MV ''kIR'' tid0), LN ''nr'' tid0, s(MV ''I'' tid0) |}
            ( K ( s(AV ''R'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (S_3_I t r s tid0)
    then interpret state: AmendedNS_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_3_I
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (S_3_R t r s tid0)
    then interpret state: AmendedNS_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_3_R
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (S_3_ni t r s tid0)
    then interpret state: AmendedNS_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_3_ni
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (S_3_nr t r s tid0)
    then interpret state: AmendedNS_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_3_nr
    thus ?case
    proof(sources! "
        Enc {| LC ''1'', s(MV ''I'' tid0), s(MV ''nr'' tid0) |}
            ( K ( s(MV ''R'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  qed
  thus "AmendedNS_msc_typing_state t r s" by unfold_locales auto
qed

text{* Prove secrecy of long-term keys. *}
context AmendedNS_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

lemma (in restricted_AmendedNS_state) S_kir_sec:
  assumes facts:
    "roleMap r tid0 = Some S"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "RLKR(s(MV ''I'' tid0)) ~: reveals t"
    "RLKR(s(MV ''R'' tid0)) ~: reveals t"
    "LN ''kIR'' tid0 : knows t"
  shows "False"
using facts proof(sources! " LN ''kIR'' tid0 ")
  case (I_5_TicketR_kIR tid1 a0 a1 a2 a3) note_unified facts = this facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''2'', LN ''ni'' tid1, s(AV ''R'' tid1), s(MV ''kIR'' tid1),
                          Enc {| LC ''3'', LN ''kIR'' tid0, a0, a1 |} ( K ( a2 ) ( a3 ) )
                       |}
                       ( K ( s(AV ''I'' tid1) ) ( s(MV ''S'' tid1) ) ) ")
    case (S_4_enc tid2) note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
next
  case S_4_kIR note_unified facts = this facts
  thus ?thesis by (auto dest!: ltk_secrecy)
next
  case S_4_kIR_1 note_unified facts = this facts
  thus ?thesis by (auto dest!: ltk_secrecy)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_AmendedNS_state) I_kir_sec:
  assumes facts:
    "roleMap r tid0 = Some I"
    "RLKR(s(AV ''I'' tid0)) ~: reveals t"
    "RLKR(s(AV ''R'' tid0)) ~: reveals t"
    "RLKR(s(MV ''S'' tid0)) ~: reveals t"
    "( tid0, I_4 ) : steps t"
    "s(MV ''kIR'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''2'', LN ''ni'' tid0, s(AV ''R'' tid0), s(MV ''kIR'' tid0),
                          s(MV ''TicketR'' tid0)
                       |}
                       ( K ( s(AV ''I'' tid0) ) ( s(MV ''S'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_4_enc tid1) note_unified facts = this facts
    thus ?thesis by (fastforce dest: S_kir_sec intro: event_predOrdI)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_AmendedNS_state) R_kir_sec:
  assumes facts:
    "roleMap r tid0 = Some R"
    "RLKR(s(AV ''R'' tid0)) ~: reveals t"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "RLKR(s(MV ''I'' tid0)) ~: reveals t"
    "( tid0, R_5 ) : steps t"
    "s(MV ''kIR'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''3'', s(MV ''kIR'' tid0), LN ''nr'' tid0, s(MV ''I'' tid0) |}
                       ( K ( s(AV ''R'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (I_5_TicketR_enc tid1 tid2 a0 a1 a2 a3) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''2'', LN ''ni'' tid1, s(AV ''R'' tid1), s(MV ''kIR'' tid1),
                            Enc {| LC ''3'', LN ''kIR'' tid2, LN ''nr'' tid0, a1 |}
                                ( K ( s(AV ''R'' tid0) ) ( s(AV ''S'' tid0) ) )
                         |}
                         ( K ( s(AV ''I'' tid1) ) ( s(MV ''S'' tid1) ) ) ")
      case (S_4_enc tid3) note_unified facts = this facts
      thus ?thesis by (fastforce dest: S_kir_sec intro: event_predOrdI)
    qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
  next
    case (S_4_enc_1 tid1) note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_AmendedNS_state) I_ni_agree:
  assumes facts:
    "roleMap r tid1 = Some I"
    "RLKR(s(AV ''I'' tid1)) ~: reveals t"
    "RLKR(s(AV ''R'' tid1)) ~: reveals t"
    "RLKR(s(MV ''S'' tid1)) ~: reveals t"
    "( tid1, I_6 ) : steps t"
  shows
    "(?  tid2.
        (?  tid3.
           roleMap r tid2 = Some R &
           roleMap r tid3 = Some S &
           s(AV ''I'' tid1) = s(MV ''I'' tid2) &
           s(MV ''I'' tid2) = s(MV ''I'' tid3) &
           s(AV ''R'' tid1) = s(AV ''R'' tid2) &
           s(AV ''R'' tid2) = s(MV ''R'' tid3) &
           s(MV ''S'' tid1) = s(AV ''S'' tid2) &
           s(AV ''S'' tid2) = s(AV ''S'' tid3) &
           LN ''ni'' tid1 = s(MV ''ni'' tid3) &
           s(MV ''nr'' tid1) = LN ''nr'' tid2 &
           LN ''nr'' tid2 = s(MV ''nr'' tid3) &
           s(MV ''kIR'' tid1) = s(MV ''kIR'' tid2) &
           s(MV ''kIR'' tid2) = LN ''kIR'' tid3))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''2'', LN ''ni'' tid1, s(AV ''R'' tid1), s(MV ''kIR'' tid1),
                          s(MV ''TicketR'' tid1)
                       |}
                       ( K ( s(AV ''I'' tid1) ) ( s(MV ''S'' tid1) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_4_enc tid2) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''4'', s(MV ''nr'' tid1) |} ( LN ''kIR'' tid2 ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (fastforce dest: S_kir_sec intro: event_predOrdI)
    next
      case (R_6_enc tid3) note_unified facts = this facts
      thus ?thesis proof(sources! "
                       Enc {| LC ''3'', LN ''kIR'' tid2, LN ''nr'' tid3, s(MV ''I'' tid3) |}
                           ( K ( s(AV ''R'' tid3) ) ( s(AV ''S'' tid3) ) ) ")
        case fake note_unified facts = this facts
        thus ?thesis by (fastforce dest: S_kir_sec intro: event_predOrdI)
      next
        case (I_5_TicketR_enc tid4 tid5 a0 a1 a2 a3) note_unified facts = this facts
        thus ?thesis proof(sources! "
                         Enc {| LC ''2'', LN ''ni'' tid4, s(AV ''R'' tid4), s(MV ''kIR'' tid4),
                                Enc {| LC ''3'', LN ''kIR'' tid2, LN ''nr'' tid3, a1 |}
                                    ( K ( s(AV ''R'' tid3) ) ( s(AV ''S'' tid3) ) )
                             |}
                             ( K ( s(AV ''I'' tid4) ) ( s(MV ''S'' tid4) ) ) ")
          case (S_4_enc tid5) 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_4_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

lemma (in restricted_AmendedNS_state) R_ni_agree:
  assumes facts:
    "roleMap r tid2 = Some R"
    "RLKR(s(AV ''R'' tid2)) ~: reveals t"
    "RLKR(s(AV ''S'' tid2)) ~: reveals t"
    "RLKR(s(MV ''I'' tid2)) ~: reveals t"
    "( tid2, R_7 ) : steps t"
  shows
    "(?  tid1.
        (?  tid3.
           roleMap r tid1 = Some I &
           roleMap r tid3 = Some S &
           s(AV ''I'' tid1) = s(MV ''I'' tid2) &
           s(MV ''I'' tid2) = s(MV ''I'' tid3) &
           s(AV ''R'' tid1) = s(AV ''R'' tid2) &
           s(AV ''R'' tid2) = s(MV ''R'' tid3) &
           s(MV ''S'' tid1) = s(AV ''S'' tid2) &
           s(AV ''S'' tid2) = s(AV ''S'' tid3) &
           LN ''ni'' tid1 = s(MV ''ni'' tid3) &
           s(MV ''nr'' tid1) = LN ''nr'' tid2 &
           LN ''nr'' tid2 = s(MV ''nr'' tid3) &
           s(MV ''kIR'' tid1) = s(MV ''kIR'' tid2) &
           s(MV ''kIR'' tid2) = LN ''kIR'' tid3))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''3'', s(MV ''kIR'' tid2), LN ''nr'' tid2, s(MV ''I'' tid2) |}
                       ( K ( s(AV ''R'' tid2) ) ( s(AV ''S'' tid2) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (I_5_TicketR_enc tid3 tid4 a0 a1 a2 a3) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''2'', LN ''ni'' tid3, s(AV ''R'' tid3), s(MV ''kIR'' tid3),
                            Enc {| LC ''3'', LN ''kIR'' tid4, LN ''nr'' tid2, a1 |}
                                ( K ( s(AV ''R'' tid2) ) ( s(AV ''S'' tid2) ) )
                         |}
                         ( K ( s(AV ''I'' tid3) ) ( s(MV ''S'' tid3) ) ) ")
      case (S_4_enc tid5) note_unified facts = this facts
      thus ?thesis proof(sources! "
                       Enc {| LC ''5'', LC ''dec'', LN ''nr'' tid2 |} ( LN ''kIR'' tid4 ) ")
        case fake note_unified facts = this facts
        thus ?thesis by (fastforce dest: S_kir_sec intro: event_predOrdI)
      next
        case (I_7_enc tid5) note_unified facts = this facts
        thus ?thesis proof(sources! "
                         Enc {| LC ''2'', LN ''ni'' tid5, s(AV ''R'' tid5), LN ''kIR'' tid4,
                                s(MV ''TicketR'' tid5)
                             |}
                             ( K ( s(AV ''I'' tid5) ) ( s(MV ''S'' tid5) ) ) ")
          case fake note_unified facts = this facts
          thus ?thesis by (fastforce dest: S_kir_sec intro: event_predOrdI)
        next
          case (S_4_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, ((((clarsimp, order?) | order | fast))+)?)
  next
    case (S_4_enc_1 tid3) note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

end


theory Sep_Forward
  imports
 Extended_Separation_Algebra
begin

lemma sep_conj_sep_impl_spec: "\<lbrakk>((Q -* R) \<and>* P) h; \<And>h. (Q -* R) h \<Longrightarrow> (P \<longrightarrow>* R') h\<rbrakk> \<Longrightarrow> R' h"
  by (metis (full_types) sep.mult_commute sep_conj_sep_impl2)

ML {*
fun sep_flatten_full ctxt =
let
  fun simptac i =
    CHANGED_PROP (full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms sep_conj_ac}
                                                               addsimps @{thms triv_forall_equality}) i)
in
  UNSOLVED' simptac
end
*}

method_setup sep_flatten = {* Scan.succeed (SIMPLE_METHOD' o sep_flatten_full) *}

method sep_invert = ((erule sep_septraction_snake | sep_erule (direct) sep_conj_sep_impl_spec),
                      sep_flatten?; sep_invert?)

lemma sep_conj_coimpl_cancel: "(P \<and>* R) s \<Longrightarrow> (\<And>s. Q s \<Longrightarrow> P s) \<Longrightarrow> precise P \<Longrightarrow>
                               (\<And>s. R s \<Longrightarrow> R' s) \<Longrightarrow> (Q \<leadsto>* R') s"
  apply (clarsimp simp: sep_conj_def sep_coimpl_def pred_neg_def)
  apply (clarsimp simp: precise_def)
  apply (erule_tac x=s in allE)
  apply (erule_tac x=x in allE)
  apply (erule_tac x=xa in allE)
  apply (clarsimp, drule mp)
  apply (intro conjI)
  apply (fastforce simp: sep_substate_def)
  apply (fastforce simp: sep_substate_def)
apply (clarsimp)
  by (metis sep_add_cancelD sep_add_commute sep_disj_commuteI)

lemma sep_conj_coimpl_cancel': "(P \<and>* R) s \<Longrightarrow> (\<And>s. P s \<Longrightarrow> Q s) \<Longrightarrow> precise Q \<Longrightarrow>
                               (\<And>s. R s \<Longrightarrow> R' s) \<Longrightarrow> (Q \<leadsto>* R') s"
  apply (clarsimp simp: sep_conj_def sep_coimpl_def pred_neg_def)
  apply (clarsimp simp: precise_def)
  apply (erule_tac x=s in allE)
  apply (erule_tac x=x in allE)
  apply (erule_tac x=xa in allE)
  apply (clarsimp, drule mp)
  apply (intro conjI)
  apply (fastforce simp: sep_substate_def)
  apply (fastforce simp: sep_substate_def)
apply (clarsimp)
  by (metis sep_add_cancelD sep_add_commute sep_disj_commuteI)

lemma sep_conj_coimpl_cancel'': "(\<And>s. pred_imp P Q s) \<Longrightarrow> (P \<and>* R) s \<Longrightarrow>  precise Q \<Longrightarrow>
                               (\<And>s. R s \<Longrightarrow> R' s) \<Longrightarrow> (Q \<leadsto>* R') s"
  by (simp add: sep_conj_coimpl_cancel')

lemma sep_conj_coimpl_cancel''': "(\<And>s. pred_imp Q P s) \<Longrightarrow> (P \<and>* R) s  \<Longrightarrow> precise P \<Longrightarrow>
                               (\<And>s. R s \<Longrightarrow> R' s) \<Longrightarrow> (Q \<leadsto>* R') s"
  by (simp add: sep_conj_coimpl_cancel)

lemma sep_coimpl_cancel': "(\<And>s. pred_imp Q P s) \<Longrightarrow> (P \<leadsto>* R) s   \<Longrightarrow>
                               (\<And>s. R s \<Longrightarrow> R' s) \<Longrightarrow> (Q \<leadsto>* R') s"
  by (metis pred_neg_def sep_coimpl_def sep_conj_def)

definition "pointer P \<equiv> (\<forall>x y. \<forall>s R. (P x \<and>* R) s \<longrightarrow> (P y \<leadsto>* R and (\<lambda>s. x = y)) s)"

lemma sep_conj_pointer_coimpl_cancel: "(P x \<and>* R) s  \<Longrightarrow> pointer P \<Longrightarrow>
                               (\<And>s. R s \<Longrightarrow> y = x \<Longrightarrow>  R'  s) \<Longrightarrow> (P y \<leadsto>* R') s"
  apply (clarsimp simp: pointer_def)
  apply (erule_tac x=x in allE)
  apply (erule_tac x=y in allE)
 apply (erule_tac x=s in allE)
 apply (erule_tac x=R in allE)
  apply (clarsimp simp: pred_conj_def)
  apply (erule sep_coimpl_cancel'[rotated]; simp)
done

named_theorems precise

method septract_cancel declares precise =
   ((sep_erule (direct) sep_cancel[simplified atomize_imp, THEN sep_conj_coimpl_cancel''], rule precise) |
   (sep_erule (direct) sep_cancel[simplified atomize_imp, THEN sep_conj_coimpl_cancel'''], rule precise) |
    erule sep_cancel[simplified atomize_imp, THEN sep_coimpl_cancel'] |
    (sep_erule (direct) sep_conj_pointer_coimpl_cancel , rule precise))

method abs_used for P = (match (P) in "\<lambda>s. ?P" \<Rightarrow> \<open>fail\<close> \<bar> _ \<Rightarrow> \<open>-\<close>)

method sep_lift = match conclusion in "(_ \<longrightarrow>* _) s" for s :: "_ :: sep_algebra" \<Rightarrow>
                  \<open>((match premises in I[thin]: "P s" for P \<Rightarrow>
                      \<open>abs_used P,  rule sep_curry[where h=s and P=P, rotated, OF I]\<close>))\<close>

method sep_snake_uncurry = match conclusion in "(_ \<leadsto>* _) s" for s :: "_ :: sep_algebra" \<Rightarrow>
                  \<open>((match premises in I[thin]: "P s" for P \<Rightarrow>
                      \<open>abs_used P, rule sep_snake_septraction[where s=s and Q=P, OF I]\<close>))\<close>

lemma septract_impl_cancel: "(P -* Q) s  \<Longrightarrow> (\<And>s. Q s \<Longrightarrow> Q' s) \<Longrightarrow> strictly_exact P \<Longrightarrow> (P \<longrightarrow>* Q') s"
  apply (clarsimp simp: septraction_def sep_impl_def pred_neg_def strictly_exact_def)
  by (fastforce)

method sep_forward = (sep_cancel | septract_cancel |  sep_lift |
                              sep_snake_uncurry )

method sep_forward_solve = (solves \<open>sep_invert;
         (sep_forward) +\<close>)

end


theory Lookup_Ext
  imports
    Lookup
    "../Extended_Assertion"
    "../Assertion_Tree_Lookup"
begin

context rbt_impl
begin

interpretation v_option: option_impl value_assn .

lemma lookup_correct_ext [vcg_rules]:
  assumes
    copy_rule [vcg_rules]:
    "\<And>v vi.
      llvm_htriple
      (\<upharpoonleft>value_assn v vi)
      (value_copy vi)
      (\<lambda>r. \<upharpoonleft>value_assn v vi ** \<upharpoonleft>value_assn v r)
    "
  shows
    "
      llvm_htriple
      (rbt_assn_ext t {} ti ** \<upharpoonleft>key_assn kn ki)
      (lookup value_copy ki ti)
      (\<lambda>opt.
        \<upharpoonleft>value_option_assn (rbt_lookup (rbt_of t) kn) opt **
        rbt_assn_ext t {} ti **
        \<upharpoonleft>key_assn kn ki)
    "
proof(induction t arbitrary: ti)
  case ATEmpty
  then show ?case
    unfolding value_option_assn_def
    apply (subst lookup.simps)
    apply vcg
    done
next
  case (ATBranch c l k v r)

  note [vcg_rules] = ATBranch.IH

  from ATBranch show ?case
    apply (subst lookup.simps)
    apply vcg
    unfolding value_option_assn_def
    apply vcg
    done
qed

lemma lookup_ptr_corrext_ext [vcg_rules]:
  "
    llvm_htriple
    (rbt_assn_ext t {} ti ** \<upharpoonleft>key_assn kn ki ** \<up>(rbt_sorted (rbt_of t)))
    (lookup_ptr ki ti)
    (\<lambda>ptr. rbt_assn_ext t {} ti ** \<upharpoonleft>key_assn kn ki **
      \<up>(if rbt_lookup (rbt_of t) kn = None then ptr = null else ptr_of_key t ti kn = Some ptr))
  "
proof(induction t arbitrary: ti)
  case ATEmpty
  then show ?case
    apply(subst lookup_ptr.simps)
    apply vcg
    done
next
  case (ATBranch c k v ci li ki vi ri al ar)

  note ATBranch[vcg_rules]

  show ?case
    apply(subst lookup_ptr.simps)
    apply vcg
    subgoal
      apply vcg_compat
      apply (sepwith simp)
       apply (cases "rbt_lookup (rbt_of al) kn")
        apply (auto simp add: ptr_of_key.simps)
      done

    apply vcg
    subgoal
      apply vcg_compat
      apply (sepwith simp)
      apply (cases "rbt_lookup (rbt_of ar) kn")
      apply (auto simp add: ptr_of_key.simps)
      done

    apply vcg
    subgoal
      apply vcg_compat
      apply (sep | simp add: ptr_of_key.simps)+
      done
    done
qed

end

end


(*  Title:      Coinductive/Coinductive_Stream.thy
    Author:     Peter Gammie and Andreas Lochbihler
*)
section \<open>Infinite lists as a codatatype\<close>

theory Coinductive_Stream
imports
  "HOL-Library.Stream"
  "HOL-Library.Linear_Temporal_Logic_on_Streams"
  Coinductive_List
begin

lemma eq_onpI: "P x \<Longrightarrow> eq_onp P x x"
by(simp add: eq_onp_def)

primcorec unfold_stream :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'b stream" where
  "unfold_stream g1 g2 a = g1 a ## unfold_stream g1 g2 (g2 a)"

text \<open>
  The following setup should be done by the BNF package.
\<close>

text \<open>congruence rule\<close>

declare stream.map_cong [cong]

text \<open>lemmas about generated constants\<close>

lemma eq_SConsD: "xs = SCons y ys \<Longrightarrow> shd xs = y \<and> stl xs = ys"
by auto

declare stream.map_ident[simp]

lemma smap_eq_SCons_conv:
  "smap f xs = y ## ys \<longleftrightarrow>
  (\<exists>x xs'. xs = x ## xs' \<and> y = f x \<and> ys = smap f xs')"
by(cases xs)(auto)

lemma smap_unfold_stream:
  "smap f (unfold_stream SHD STL b) = unfold_stream (f \<circ> SHD) STL b"
by(coinduction arbitrary: b) auto

lemma smap_corec_stream:
  "smap f (corec_stream SHD endORmore STL_end STL_more b) =
   corec_stream (f \<circ> SHD) endORmore (smap f \<circ> STL_end) STL_more b"
by(coinduction arbitrary: b rule: stream.coinduct_strong) auto

lemma unfold_stream_ltl_unroll:
  "unfold_stream SHD STL (STL b) = unfold_stream (SHD \<circ> STL) STL b"
by(coinduction arbitrary: b) auto

lemma unfold_stream_eq_SCons [simp]:
  "unfold_stream SHD STL b = x ## xs \<longleftrightarrow>
  x = SHD b \<and> xs = unfold_stream SHD STL (STL b)"
by(subst unfold_stream.ctr) auto

lemma unfold_stream_id [simp]: "unfold_stream shd stl xs = xs"
by(coinduction arbitrary: xs) simp_all

lemma sset_neq_empty [simp]: "sset xs \<noteq> {}"
by(cases xs) simp_all

declare stream.set_sel(1)[simp]

lemma sset_stl: "sset (stl xs) \<subseteq> sset xs"
by(cases xs) auto

text \<open>induction rules\<close>

lemmas stream_set_induct = sset_induct

subsection \<open>Lemmas about operations from @{theory "HOL-Library.Stream"}\<close>

lemma szip_iterates:
  "szip (siterate f a) (siterate g b) = siterate (map_prod f g) (a, b)"
by(coinduction arbitrary: a b) auto

lemma szip_smap1: "szip (smap f xs) ys = smap (apfst f) (szip xs ys)"
by(coinduction arbitrary: xs ys) auto

lemma szip_smap2: "szip xs (smap g ys) = smap (apsnd g) (szip xs ys)"
by(coinduction arbitrary: xs ys) auto

lemma szip_smap [simp]: "szip (smap f xs) (smap g ys) = smap (map_prod f g) (szip xs ys)"
by(coinduction arbitrary: xs ys) auto

lemma smap_fst_szip [simp]: "smap fst (szip xs ys) = xs"
by(coinduction arbitrary: xs ys) auto

lemma smap_snd_szip [simp]: "smap snd (szip xs ys) = ys"
by(coinduction arbitrary: xs ys) auto

lemma snth_shift: "snth (shift xs ys) n = (if n < length xs then xs ! n else snth ys (n - length xs))"
by simp

declare szip_unfold [simp, nitpick_simp]

lemma szip_shift:
  "length xs = length us
  \<Longrightarrow> szip (xs @- ys) (us @- zs) = zip xs us @- szip ys zs"
by(induct xs arbitrary: us)(auto simp add: Suc_length_conv)

subsection \<open>Link @{typ "'a stream"} to @{typ "'a llist"}\<close>

definition llist_of_stream :: "'a stream \<Rightarrow> 'a llist"
where "llist_of_stream = unfold_llist (\<lambda>_. False) shd stl"

definition stream_of_llist :: "'a llist \<Rightarrow> 'a stream"
where "stream_of_llist = unfold_stream lhd ltl"

lemma lnull_llist_of_stream [simp]: "\<not> lnull (llist_of_stream xs)"
by(simp add: llist_of_stream_def)

lemma ltl_llist_of_stream [simp]: "ltl (llist_of_stream xs) = llist_of_stream (stl xs)"
by(simp add: llist_of_stream_def)

lemma stl_stream_of_llist [simp]: "stl (stream_of_llist xs) = stream_of_llist (ltl xs)"
by(simp add: stream_of_llist_def)

lemma shd_stream_of_llist [simp]: "shd (stream_of_llist xs) = lhd xs"
by(simp add: stream_of_llist_def)

lemma lhd_llist_of_stream [simp]: "lhd (llist_of_stream xs) = shd xs"
by(simp add: llist_of_stream_def)

lemma stream_of_llist_llist_of_stream [simp]:
  "stream_of_llist (llist_of_stream xs) = xs"
by(coinduction arbitrary: xs) simp_all

lemma llist_of_stream_stream_of_llist [simp]:
  "\<not> lfinite xs \<Longrightarrow> llist_of_stream (stream_of_llist xs) = xs"
by(coinduction arbitrary: xs) auto

lemma lfinite_llist_of_stream [simp]: "\<not> lfinite (llist_of_stream xs)"
proof
  assume "lfinite (llist_of_stream xs)"
  thus False
    by(induct "llist_of_stream xs" arbitrary: xs rule: lfinite_induct) auto
qed

lemma stream_from_llist: "type_definition llist_of_stream stream_of_llist {xs. \<not> lfinite xs}"
by(unfold_locales) simp_all

interpretation stream: type_definition llist_of_stream stream_of_llist "{xs. \<not> lfinite xs}"
by(fact stream_from_llist)

declare stream.exhaust[cases type: stream]

locale stream_from_llist_setup
begin
setup_lifting stream_from_llist
end

context
begin

interpretation stream_from_llist_setup .

lemma cr_streamI: "\<not> lfinite xs \<Longrightarrow> cr_stream xs (stream_of_llist xs)"
by(simp add: cr_stream_def Abs_stream_inverse)

lemma llist_of_stream_unfold_stream [simp]:
  "llist_of_stream (unfold_stream SHD STL x) = unfold_llist (\<lambda>_. False) SHD STL x"
by(coinduction arbitrary: x) auto

lemma llist_of_stream_corec_stream [simp]:
  "llist_of_stream (corec_stream SHD endORmore STL_more STL_end x) =
   corec_llist (\<lambda>_. False) SHD endORmore (llist_of_stream \<circ> STL_more) STL_end x"
by(coinduction arbitrary: x rule: llist.coinduct_strong) auto

lemma LCons_llist_of_stream [simp]: "LCons x (llist_of_stream xs) = llist_of_stream (x ## xs)"
by(rule sym)(simp add: llist_of_stream_def)

lemma lmap_llist_of_stream [simp]:
  "lmap f (llist_of_stream xs) = llist_of_stream (smap f xs)"
by(coinduction arbitrary: xs) auto

lemma lset_llist_of_stream [simp]: "lset (llist_of_stream xs) = sset xs" (is "?lhs = ?rhs")
proof(intro set_eqI iffI)
  fix x
  assume "x \<in> ?lhs"
  thus "x \<in> ?rhs"
    by(induct "llist_of_stream xs" arbitrary: xs rule: llist_set_induct)
      (auto dest: stream.set_sel(2))
next
  fix x
  assume "x \<in> ?rhs"
  thus "x \<in> ?lhs"
  proof(induct)
    case (shd xs)
    thus ?case using llist.set_sel(1)[of "llist_of_stream xs"] by simp
  next
    case stl
    thus ?case
      by(auto simp add: ltl_llist_of_stream[symmetric] simp del: ltl_llist_of_stream dest: in_lset_ltlD)
  qed
qed

lemma lnth_list_of_stream [simp]:
  "lnth (llist_of_stream xs) = snth xs"
proof
  fix n
  show "lnth (llist_of_stream xs) n = snth xs n"
    by(induction n arbitrary: xs)(simp_all add: lnth_0_conv_lhd lnth_ltl[symmetric])
qed

lemma llist_of_stream_siterates [simp]: "llist_of_stream (siterate f x) = iterates f x"
by(coinduction arbitrary: x) auto

lemma lappend_llist_of_stream_conv_shift [simp]:
  "lappend (llist_of xs) (llist_of_stream ys) = llist_of_stream (xs @- ys)"
by(induct xs) simp_all

lemma lzip_llist_of_stream [simp]:
  "lzip (llist_of_stream xs) (llist_of_stream ys) = llist_of_stream (szip xs ys)"
by(coinduction arbitrary: xs ys) auto

context includes lifting_syntax
begin

lemma lmap_infinite_transfer [transfer_rule]:
  "((=) ===> eq_onp (\<lambda>xs. \<not> lfinite xs) ===> eq_onp (\<lambda>xs. \<not> lfinite xs)) lmap lmap"
by(simp add: rel_fun_def eq_onp_def)

lemma lset_infinite_transfer [transfer_rule]:
  "(eq_onp (\<lambda>xs. \<not> lfinite xs) ===> (=)) lset lset"
by(simp add: rel_fun_def eq_onp_def)

lemma unfold_stream_transfer [transfer_rule]:
  "((=) ===> (=) ===> (=) ===> pcr_stream (=)) (unfold_llist (\<lambda>_. False)) unfold_stream"
by(auto simp add: stream.pcr_cr_eq cr_stream_def intro!: rel_funI)

lemma corec_stream_transfer [transfer_rule]:
  "((=) ===> (=) ===> ((=) ===> pcr_stream (=)) ===> (=) ===> (=) ===> pcr_stream (=))
   (corec_llist (\<lambda>_. False)) corec_stream"
apply(auto intro!: rel_funI simp add: cr_stream_def stream.pcr_cr_eq)
apply(rule fun_cong) back
apply(rule_tac x=yc in fun_cong)
apply(rule_tac x=xb in arg_cong)
apply(auto elim: rel_funE)
done

lemma shd_transfer [transfer_rule]: "(pcr_stream A ===> A) lhd shd"
by(auto simp add: pcr_stream_def cr_stream_def intro!: rel_funI relcomppI)(frule llist_all2_lhdD, auto dest: llist_all2_lnullD)

lemma stl_transfer [transfer_rule]: "(pcr_stream A ===> pcr_stream A) ltl stl"
by(auto simp add: pcr_stream_def cr_stream_def intro!: rel_funI relcomppI dest: llist_all2_ltlI)

lemma llist_of_stream_transfer [transfer_rule]: "(pcr_stream (=) ===> (=)) id llist_of_stream"
by(simp add: rel_fun_def stream.pcr_cr_eq cr_stream_def)

lemma stream_of_llist_transfer [transfer_rule]:
  "(eq_onp (\<lambda>xs. \<not> lfinite xs) ===> pcr_stream (=)) (\<lambda>xs. xs) stream_of_llist"
by(simp add: eq_onp_def rel_fun_def stream.pcr_cr_eq cr_stream_def)

lemma SCons_transfer [transfer_rule]:
  "(A ===> pcr_stream A ===> pcr_stream A) LCons (##)"
by(auto simp add: cr_stream_def pcr_stream_def intro!: rel_funI relcomppI intro: llist_all2_expand)

lemma sset_transfer [transfer_rule]: "(pcr_stream A ===> rel_set A) lset sset"
by(auto 4 3 simp add: pcr_stream_def cr_stream_def intro!: rel_funI relcomppI rel_setI dest: llist_all2_lsetD1 llist_all2_lsetD2)

lemma smap_transfer [transfer_rule]:
  "((A ===> B) ===> pcr_stream A ===> pcr_stream B) lmap smap"
by(auto simp add: cr_stream_def pcr_stream_def intro!: rel_funI relcomppI dest: lmap_transfer[THEN rel_funD] elim: rel_funD)

lemma snth_transfer [transfer_rule]: "(pcr_stream (=) ===> (=)) lnth snth"
by(rule rel_funI)(clarsimp simp add: stream.pcr_cr_eq cr_stream_def fun_eq_iff)

lemma siterate_transfer [transfer_rule]:
  "((=) ===> (=) ===> pcr_stream (=)) iterates siterate"
by(rule rel_funI)+(clarsimp simp add: stream.pcr_cr_eq cr_stream_def)

context
  fixes xs
  assumes inf: "\<not> lfinite xs"
  notes [transfer_rule] = eq_onpI[where P="\<lambda>xs. \<not> lfinite xs", OF inf]
begin

lemma sset_stream_of_llist [simp]:
  assumes "\<not> lfinite xs"
  shows "sset (stream_of_llist xs) = lset xs"
by transfer simp

end

lemma llist_all2_llist_of_stream [simp]:
  "llist_all2 P (llist_of_stream xs) (llist_of_stream ys) = stream_all2 P xs ys"
apply(cases xs ys rule: stream.Abs_cases[case_product stream.Abs_cases])
apply(simp add: llist_all2_def stream_all2_def)
apply(safe elim!: GrpE)
 apply(rule_tac b="stream_of_llist b" in relcomppI; auto intro!: GrpI)
apply(rule_tac b="llist_of_stream b" in relcomppI; auto intro!: GrpI)
done

lemma stream_all2_transfer [transfer_rule]:
  "((=) ===> pcr_stream (=) ===> pcr_stream (=) ===> (=)) llist_all2 stream_all2"
by(simp add: rel_fun_def stream.pcr_cr_eq cr_stream_def)

lemma stream_all2_coinduct:
  assumes "X xs ys"
  and "\<And>xs ys. X xs ys \<Longrightarrow> P (shd xs) (shd ys) \<and> (X (stl xs) (stl ys) \<or> stream_all2 P (stl xs) (stl ys))"
  shows "stream_all2 P xs ys"
using assms
apply transfer
apply(rule_tac X="\<lambda>xs ys. \<not> lfinite xs \<and> \<not> lfinite ys \<and> X xs ys" in llist_all2_coinduct)
apply auto
done

lemma shift_transfer [transfer_rule]:
  "((=) ===> pcr_stream (=) ===> pcr_stream (=)) (lappend \<circ> llist_of) shift"
by(clarsimp simp add: rel_fun_def stream.pcr_cr_eq cr_stream_def)

lemma szip_transfer [transfer_rule]:
  "(pcr_stream (=) ===> pcr_stream (=) ===> pcr_stream (=)) lzip szip"
by(simp add: stream.pcr_cr_eq cr_stream_def rel_fun_def)

subsection \<open>Link @{typ "'a stream"} with @{typ "nat \<Rightarrow> 'a"}\<close>

lift_definition of_seq :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a stream" is "inf_llist" by simp

lemma of_seq_rec [code]: "of_seq f = f 0 ## of_seq (f \<circ> Suc)"
by transfer (subst inf_llist_rec, simp add: o_def)

lemma snth_of_seq [simp]: "snth (of_seq f) = f"
by transfer (simp add: fun_eq_iff)

lemma snth_SCons: "snth (x ## xs) n = (case n of 0 \<Rightarrow> x | Suc n' \<Rightarrow> snth xs n')"
by(simp split: nat.split)

lemma snth_SCons_simps [simp]:
  shows snth_SCons_0: "(x ## xs) !! 0 = x"
  and snth_SCons_Suc: "(x ## xs) !! Suc n = xs !! n"
by(simp_all add: snth_SCons)

lemma of_seq_snth [simp]: "of_seq (snth xs) = xs"
by transfer simp

lemma shd_of_seq [simp]: "shd (of_seq f) = f 0"
by transfer simp

lemma stl_of_seq [simp]: "stl (of_seq f) = of_seq (\<lambda>n. f (Suc n))"
by transfer simp

lemma sset_of_seq [simp]: "sset (of_seq f) = range f"
by transfer simp

lemma smap_of_seq [simp]: "smap f (of_seq g) = of_seq (f \<circ> g)"
by transfer simp
end

subsection\<open>Function iteration @{const siterate}  and @{term sconst}\<close>

lemmas siterate [nitpick_simp] = siterate.code

lemma smap_iterates: "smap f (siterate f x) = siterate f (f x)"
by transfer (rule lmap_iterates)

lemma siterate_smap: "siterate f x = x ## (smap f (siterate f x))"
by transfer (rule iterates_lmap)

lemma siterate_conv_of_seq: "siterate f a = of_seq (\<lambda>n. (f ^^ n) a)"
by transfer (rule iterates_conv_inf_llist)

lemma szip_sconst1 [simp]: "szip (sconst a) xs = smap (Pair a) xs"
by(coinduction arbitrary: xs) auto

lemma szip_sconst2 [simp]: "szip xs (sconst b) = smap (\<lambda>x. (x, b)) xs"
by(coinduction arbitrary: xs) auto

end

subsection \<open> Counting elements \<close>

partial_function (lfp) scount :: "('s stream \<Rightarrow> bool) \<Rightarrow> 's stream \<Rightarrow> enat" where
  "scount P \<omega> = (if P \<omega> then eSuc (scount P (stl \<omega>)) else scount P (stl \<omega>))"

lemma scount_simps:
  "P \<omega> \<Longrightarrow> scount P \<omega> = eSuc (scount P (stl \<omega>))"
  "\<not> P \<omega> \<Longrightarrow> scount P \<omega> = scount P (stl \<omega>)"
  using scount.simps[of P \<omega>] by auto

lemma scount_eq_0I: "alw (not P) \<omega> \<Longrightarrow> scount P \<omega> = 0"
  by (induct arbitrary: \<omega> rule: scount.fixp_induct)
     (auto simp: bot_enat_def intro!: admissible_all admissible_imp admissible_eq_mcontI mcont_const)

lemma scount_eq_0_iff: "scount P \<omega> = 0 \<longleftrightarrow> alw (not P) \<omega>"
  by (metis scount_eq_0D scount_eq_0I)

lemma
  assumes "ev (alw (not P)) \<omega>"
  shows scount_eq_card: "scount P \<omega> = enat (card {i. P (sdrop i \<omega>)})"
    and ev_alw_not_HLD_finite: "finite {i. P (sdrop i \<omega>)}"
  using assms
proof (induction \<omega>)
  case (step \<omega>)
  have eq: "{i. P (sdrop i \<omega>)} = (if P \<omega> then {0} else {}) \<union> (Suc ` {i. P (sdrop i (stl \<omega>))})"
    apply (intro set_eqI)
    apply (case_tac x)
    apply (auto simp: image_iff)
    done
  { case 1 show ?case
      using step unfolding eq by (auto simp: scount_simps card_image zero_notin_Suc_image eSuc_enat) }
  { case 2 show ?case
      using step unfolding eq by auto }
next
   case (base \<omega>)
   then have [simp]: "{i. P (sdrop i \<omega>)} = {}"
     by (simp add: not_HLD alw_iff_sdrop)
   { case 1 show ?case using base by (simp add: scount_eq_0I enat_0) }
   { case 2 show ?case by simp }
qed

lemma scount_finite: "ev (alw (not P)) \<omega> \<Longrightarrow> scount P \<omega> < \<infinity>"
  using scount_eq_card[of P \<omega>] by auto

lemma scount_infinite:
  "alw (ev P) \<omega> \<Longrightarrow> scount P \<omega> = \<infinity>"
proof (coinduction arbitrary: \<omega> rule: enat_coinduct)
  case (Eq_enat \<omega>)
  then have "ev P \<omega>" "alw (ev P) \<omega>"
    by auto
  then show ?case
    by (induction rule: ev_induct_strong) (auto simp add: scount_simps)
qed

lemma scount_infinite_iff: "scount P \<omega> = \<infinity> \<longleftrightarrow> alw (ev P) \<omega>"
  by (metis enat_ord_simps(4) not_alw_not scount_finite scount_infinite)

lemma scount_eq:
  "scount P \<omega> = (if alw (ev P) \<omega> then \<infinity> else enat (card {i. P (sdrop i \<omega>)}))"
  by (auto simp: scount_infinite_iff scount_eq_card not_alw_iff not_ev_iff)

subsection \<open> First index of an element \<close>

partial_function (gfp) sfirst :: "('s stream \<Rightarrow> bool) \<Rightarrow> 's stream \<Rightarrow> enat" where
  "sfirst P \<omega> = (if P \<omega> then 0 else eSuc (sfirst P (stl \<omega>)))"

lemma sfirst_eq_0: "sfirst P \<omega> = 0 \<longleftrightarrow> P \<omega>"
  by (subst sfirst.simps) auto

lemma sfirst_0[simp]: "P \<omega> \<Longrightarrow> sfirst P \<omega> = 0"
  by (subst sfirst.simps) auto

lemma sfirst_eSuc[simp]: "\<not> P \<omega> \<Longrightarrow> sfirst P \<omega> = eSuc (sfirst P (stl \<omega>))"
  by (subst sfirst.simps) auto

lemma less_sfirstD:
  fixes n :: nat
  assumes "enat n < sfirst P \<omega>" shows "\<not> P (sdrop n \<omega>)"
  using assms
proof (induction n arbitrary: \<omega>)
  case (Suc n) then show ?case
    by (auto simp: sfirst.simps[of _ \<omega>] eSuc_enat[symmetric] split: if_split_asm)
qed (simp add: enat_0 sfirst_eq_0)

lemma sfirst_finite: "sfirst P \<omega> < \<infinity> \<longleftrightarrow> ev P \<omega>"
proof
  assume "sfirst P \<omega> < \<infinity>"
  then obtain n where "sfirst P \<omega> = enat n" by auto
  then show "ev P \<omega>"
  proof (induction n arbitrary: \<omega>)
    case (Suc n) then show ?case
      by (auto simp add: eSuc_enat[symmetric] sfirst.simps[of P \<omega>] split: if_split_asm)
  qed (auto simp add: enat_0 sfirst_eq_0)
next
  assume "ev P \<omega>" then show "sfirst P \<omega> < \<infinity>"
    by (induction rule: ev_induct_strong) (auto simp: eSuc_enat)
qed

lemma sfirst_Stream: "sfirst P (s ## x) = (if P (s ## x) then 0 else eSuc (sfirst P x))"
  by (subst sfirst.simps) (simp add: HLD_iff)

lemma less_sfirst_iff: "(not P until (alw P)) \<omega> \<Longrightarrow> enat n < sfirst P \<omega> \<longleftrightarrow> \<not> P (sdrop n \<omega>)"
proof (induction n arbitrary: \<omega>)
  case 0 then show ?case
    by (simp add: enat_0 sfirst_eq_0 HLD_iff)
next
  case (Suc n)
  from Suc.prems have **: "P \<omega> \<Longrightarrow> P (stl \<omega>)"
    by (auto elim: UNTIL.cases)
  have *: "\<not> P (sdrop n (stl \<omega>)) \<longleftrightarrow> enat n < sfirst P (stl \<omega>)"
    using Suc.prems by (intro Suc.IH[symmetric]) (auto intro: UNTIL.intros elim: UNTIL.cases)
  show ?case
    unfolding sdrop.simps * by (cases "P \<omega>") (simp_all add: ** eSuc_enat[symmetric])
qed

lemma sfirst_eq_Inf: "sfirst P \<omega> = Inf {enat i | i. P (sdrop i \<omega>)}"
proof (rule antisym)
  show "sfirst P \<omega> \<le> \<Sqinter>{enat i |i. P (sdrop i \<omega>)}"
  proof (safe intro!: Inf_greatest)
    fix \<omega> i assume "P (sdrop i \<omega>)" then show "sfirst P \<omega> \<le> enat i"
    proof (induction i arbitrary: \<omega>)
      case (Suc i) then show ?case
       by (auto simp add: sfirst.simps[of P \<omega>] eSuc_enat[symmetric])
    qed auto
  qed
  show "\<Sqinter>{enat i |i. P (sdrop i \<omega>)} \<le> sfirst P \<omega>"
  proof (induction arbitrary: \<omega> rule: sfirst.fixp_induct)
    case (3 f)
    have "{enat i |i. P (sdrop i \<omega>)} = (if P \<omega> then {0} else {}) \<union> eSuc ` {enat i |i. P (sdrop i (stl \<omega>))}"
      apply (intro set_eqI)
      apply (case_tac x rule: enat_coexhaust)
      apply (auto simp add: enat_0_iff image_iff eSuc_enat_iff)
      done
    with 3[of "stl \<omega>"] show ?case
      by (auto simp: inf.absorb1 eSuc_Inf[symmetric])
  qed simp_all
qed

lemma sfirst_eq_enat_iff: "sfirst P \<omega> = enat n \<longleftrightarrow> ev_at P n \<omega>"
  by (induction n arbitrary: \<omega>)
     (simp_all add: eSuc_enat[symmetric] sfirst.simps enat_0)

subsection \<open>\<open>stakeWhile\<close>\<close>

definition stakeWhile :: "('a \<Rightarrow> bool) \<Rightarrow> 'a stream \<Rightarrow> 'a llist"
where "stakeWhile P xs = ltakeWhile P (llist_of_stream xs)"

lemma stakeWhile_SCons [simp]:
  "stakeWhile P (x ## xs) = (if P x then LCons x (stakeWhile P xs) else LNil)"
by(simp add: stakeWhile_def LCons_llist_of_stream[symmetric] del: LCons_llist_of_stream)

lemma lnull_stakeWhile [simp]: "lnull (stakeWhile P xs) \<longleftrightarrow> \<not> P (shd xs)"
by(simp add: stakeWhile_def)

lemma lhd_stakeWhile [simp]: "P (shd xs) \<Longrightarrow> lhd (stakeWhile P xs) = shd xs"
by(simp add: stakeWhile_def)

lemma ltl_stakeWhile [simp]:
  "ltl (stakeWhile P xs) = (if P (shd xs) then stakeWhile P (stl xs) else LNil)"
by(simp add: stakeWhile_def)

lemma stakeWhile_K_False [simp]: "stakeWhile (\<lambda>_. False) xs = LNil"
by(simp add: stakeWhile_def)

lemma stakeWhile_K_True [simp]: "stakeWhile (\<lambda>_. True) xs = llist_of_stream xs"
by(simp add: stakeWhile_def)

lemma stakeWhile_smap: "stakeWhile P (smap f xs) = lmap f (stakeWhile (P \<circ> f) xs)"
by(simp add: stakeWhile_def ltakeWhile_lmap[symmetric] del: o_apply)

lemma lfinite_stakeWhile [simp]: "lfinite (stakeWhile P xs) \<longleftrightarrow> (\<exists>x\<in>sset xs. \<not> P x)"
by(simp add: stakeWhile_def lfinite_ltakeWhile)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_list_return_2
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) y2 = y2"
| "x (cons2 z2 xs) y2 = cons2 z2 (x xs y2)"

fun y :: "'a list => ('a => 'b list) => 'b list" where
"y (nil2) y2 = nil2"
| "y (cons2 z2 xs) y2 = x (y2 z2) (y xs y2)"

fun return :: "'a => 'a list" where
"return z = cons2 z (nil2)"

theorem property0 :
  "((y xs (% (z :: 'a) => return z)) = xs)"
  oops

end


theory Aleph_Relative
  imports
    CardinalArith_Relative
begin

definition
  HAleph :: "[i,i] \<Rightarrow> i" where
  "HAleph(i,r) \<equiv> if(\<not>(Ord(i)),i,if(i=0, nat, if(\<not>Limit(i) \<and> i\<noteq>0,
                            csucc(r`( \<Union> i )),
                                   \<Union>j\<in>i. r`j)))"

reldb_add functional "Limit" "Limit"
relationalize "Limit" "is_Limit" external
synthesize "is_Limit" from_definition
arity_theorem for "is_Limit_fm"

relativize functional "HAleph" "HAleph_rel"
relationalize "HAleph_rel" "is_HAleph"

synthesize "is_HAleph" from_definition assuming "nonempty"
arity_theorem intermediate for "is_HAleph_fm"

lemma arity_is_HAleph_fm_aux:
  assumes
    "i \<in> nat" "r \<in> nat"
    \<comment> \<open>NOTE: assumptions are \<^bold>\<open>not\<close> used, but if omitted, next lemma fails!\<close>
  shows
    "arity(Replace_fm(8 +\<^sub>\<omega> i, \<cdot>10 +\<^sub>\<omega> r`0 is 1\<cdot>, 3)) = 9 +\<^sub>\<omega> i \<union> pred(pred(11 +\<^sub>\<omega> r))"
  using arity_Replace_fm[of "\<cdot> (10+\<^sub>\<omega>r)`0 is 1\<cdot>" "8+\<^sub>\<omega>i" 3 "(11+\<^sub>\<omega>r) \<union> 1 \<union> 2"]
    ord_simp_union
  by (auto simp:arity)

lemma arity_is_HAleph_fm[arity]:
  assumes
    "i \<in> nat" "r \<in> nat" "l \<in> nat"
  shows
    "arity(is_HAleph_fm(i, r, l)) =  succ(i) \<union> succ(l) \<union> succ(r)"
  using assms pred_Un arity_is_HAleph_fm_aux arity_is_HAleph_fm'
  by auto

definition
  Aleph' :: "i => i"  where
  "Aleph'(a) == transrec(a,\<lambda>i r. HAleph(i,r))"

relativize functional "Aleph'" "Aleph_rel"
relationalize "Aleph_rel" "is_Aleph"

txt\<open>The extra assumptions \<^term>\<open>a < length(env)\<close> and \<^term>\<open>c < length(env)\<close>
    in this schematic goal (and the following results on synthesis that
    depend on it) are imposed by @{thm [source] is_transrec_iff_sats}.\<close>
schematic_goal sats_is_Aleph_fm_auto:
  "a \<in> nat \<Longrightarrow> c \<in> nat \<Longrightarrow> env \<in> list(A) \<Longrightarrow>
  a < length(env) \<Longrightarrow> c < length(env) \<Longrightarrow> 0 \<in> A \<Longrightarrow>
  is_Aleph(##A, nth(a, env), nth(c, env)) \<longleftrightarrow> A, env \<Turnstile> ?fm(a, c)"
  unfolding is_Aleph_def
proof (rule is_transrec_iff_sats, rule_tac [1] is_HAleph_iff_sats)
  fix a0 a1 a2 a3 a4 a5 a6 a7
  let ?env' = "Cons(a0, Cons(a1, Cons(a2, Cons(a3, Cons(a4, Cons(a5, Cons(a6, Cons(a7, env))))))))"
  show "nth(2, ?env') = a2"
    "nth(1, ?env') = a1"
    "nth(0, ?env') = a0"
    "nth(c, env) = nth(c, env)"
    by simp_all
qed simp_all

synthesize_notc "is_Aleph" from_schematic

notation is_Aleph_fm (\<open>\<cdot>\<aleph>'(_') is _\<cdot>\<close>)

lemma is_Aleph_fm_type [TC]: "a \<in> nat \<Longrightarrow> c \<in> nat \<Longrightarrow> is_Aleph_fm(a, c) \<in> formula"
  unfolding is_Aleph_fm_def by simp

lemma sats_is_Aleph_fm:
  assumes "f\<in>nat" "r\<in>nat" "env \<in> list(A)" "0\<in>A" "f < length(env)" "r< length(env)"
  shows "is_Aleph(##A, nth(f, env), nth(r, env)) \<longleftrightarrow> A, env \<Turnstile> is_Aleph_fm(f,r)"
  using assms sats_is_Aleph_fm_auto unfolding is_Aleph_def is_Aleph_fm_def by simp

lemma is_Aleph_iff_sats [iff_sats]:
  assumes
    "nth(f, env) = fa" "nth(r, env) = ra" "f < length(env)" "r< length(env)"
    "f \<in> nat" "r \<in> nat" "env \<in> list(A)" "0\<in>A"
  shows "is_Aleph(##A,fa,ra) \<longleftrightarrow> A, env \<Turnstile> is_Aleph_fm(f,r)"
  using assms sats_is_Aleph_fm[of f r env A] by simp

arity_theorem for "is_Aleph_fm"

lemma (in M_cardinal_arith_jump) is_Limit_iff:
  assumes "M(a)"
  shows "is_Limit(M,a) \<longleftrightarrow> Limit(a)"
  unfolding is_Limit_def Limit_def using lt_abs transM[OF ltD \<open>M(a)\<close>] assms
  by auto

lemma HAleph_eq_Aleph_recursive:
  "Ord(i) \<Longrightarrow> HAleph(i,r) = (if i = 0 then nat
                else if \<exists>j. i = succ(j) then csucc(r ` (THE j. i = succ(j))) else \<Union>j<i. r ` j)"
proof -
  assume "Ord(i)"
  moreover from this
  have "i = succ(j) \<Longrightarrow> (\<Union>succ(j)) = j" for j
    using Ord_Union_succ_eq by simp
  moreover from \<open>Ord(i)\<close>
  have "(\<exists>j. i = succ(j)) \<longleftrightarrow> \<not>Limit(i) \<and> i \<noteq> 0"
    using Ord_cases_disj by auto
  ultimately
  show ?thesis
    unfolding HAleph_def OUnion_def
    by auto
qed

lemma Aleph'_eq_Aleph: "Ord(a) \<Longrightarrow> Aleph'(a) = Aleph(a)"
  unfolding Aleph'_def Aleph_def transrec2_def
  using HAleph_eq_Aleph_recursive
  by (intro transrec_equal_on_Ord) auto

reldb_rem functional "Aleph'"
reldb_rem relational "is_Aleph"
reldb_add functional "Aleph" "Aleph_rel"
reldb_add relational "Aleph" "is_Aleph"

abbreviation
  Aleph_r :: "[i,i\<Rightarrow>o] \<Rightarrow> i" (\<open>\<aleph>\<^bsub>_\<^esub>\<^bsup>_\<^esup>\<close>) where
  "Aleph_r(a,M) \<equiv> Aleph_rel(M,a)"

abbreviation
  Aleph_r_set :: "[i,i] \<Rightarrow> i" (\<open>\<aleph>\<^bsub>_\<^esub>\<^bsup>_\<^esup>\<close>) where
  "Aleph_r_set(a,M) \<equiv> Aleph_rel(##M,a)"

lemma Aleph_rel_def': "Aleph_rel(M,a) \<equiv> transrec(a, \<lambda>i r. HAleph_rel(M, i, r))"
  unfolding Aleph_rel_def .

lemma succ_mem_Limit: "Limit(j) \<Longrightarrow> i \<in> j \<Longrightarrow> succ(i) \<in> j"
  using Limit_has_succ[THEN ltD] ltI Limit_is_Ord by auto

locale M_pre_aleph = M_eclose + M_cardinal_arith_jump +
  assumes
    haleph_transrec_replacement: "M(a) \<Longrightarrow> transrec_replacement(M,is_HAleph(M),a)"

begin

lemma aux_ex_Replace_funapply:
  assumes "M(a)" "M(f)"
  shows "\<exists>x[M]. is_Replace(M, a, \<lambda>j y. f ` j = y, x)"
proof -
  have "{f`j . j\<in>a} = {y . j\<in>a , f ` j=y}"
    "{y . j\<in>a , f ` j=y} = {y . j\<in>a , y =f ` j}"
    by auto
  moreover
  note assms
  moreover from calculation
  have "x \<in> a \<Longrightarrow> y = f `x \<Longrightarrow> M(y)" for x y
    using transM[OF _ \<open>M(a)\<close>] by auto
  moreover from assms
  have "M({f`j . j\<in>a})"
    using transM[OF _ \<open>M(a)\<close>] RepFun_closed[OF apply_replacement] by simp
  ultimately
  have 2:"is_Replace(M, a, \<lambda>j y. y = f ` j, {f`j . j\<in>a})"
    using Replace_abs[of _ _ "\<lambda>j y. y = f ` j",OF \<open>M(a)\<close>,THEN iffD2]
    by auto
  with \<open>M({f`j . j\<in>a})\<close>
  show ?thesis
    using
      is_Replace_cong[of _ _ M "\<lambda>j y. y = f ` j" "\<lambda>j y. f ` j = y", THEN iffD1,OF _ _ _ 2]
    by auto
qed

lemma is_HAleph_zero:
  assumes "M(f)"
  shows "is_HAleph(M,0,f,res) \<longleftrightarrow> res = nat"
  unfolding is_HAleph_def
  using Ord_0 If_abs is_Limit_iff is_csucc_iff assms aux_ex_Replace_funapply
  by auto

lemma is_HAleph_succ:
  assumes "M(f)" "M(x)" "Ord(x)" "M(res)"
  shows "is_HAleph(M,succ(x),f,res) \<longleftrightarrow> res = csucc_rel(M,f`x)"
  unfolding is_HAleph_def
  using assms is_Limit_iff is_csucc_iff aux_ex_Replace_funapply If_abs Ord_Union_succ_eq
  by simp

lemma is_HAleph_limit:
  assumes "M(f)" "M(x)" "Limit(x)" "M(res)"
  shows "is_HAleph(M,x,f,res) \<longleftrightarrow> res = (\<Union>{y . i\<in>x ,M(i) \<and> M(y) \<and> y = f`i})"
proof -
  from assms
  have "univalent(M, x, \<lambda>j y. y = f ` j  )"
    "(\<And>xa y. xa \<in> x \<Longrightarrow> f ` xa = y \<Longrightarrow> M(y))"
    "{y . x \<in> x, f ` x = y} = {y . i\<in>x ,M(i) \<and> M(y) \<and> y = f`i}"
    using univalent_triv[of M x "\<lambda>j .f ` j"] transM[OF _ \<open>M(x)\<close>]
    by auto
  moreover
  from this
  have "univalent(M, x, \<lambda>j y. f ` j = y )"
    by (rule_tac univalent_cong[of x x M " \<lambda>j y. y = f ` j" " \<lambda>j y. f ` j=y",THEN iffD1], auto)
  moreover
  from this
  have "univalent(M, x, \<lambda>j y. M(j) \<and> M(y) \<and> f ` j = y )"
    by auto
  ultimately
  show ?thesis
    unfolding is_HAleph_def
    using assms is_Limit_iff Limit_is_Ord zero_not_Limit If_abs is_csucc_iff
      Replace_abs apply_replacement
    by auto
qed

lemma is_HAleph_iff:
  assumes "M(a)" "M(f)" "M(res)"
  shows "is_HAleph(M, a, f, res) \<longleftrightarrow> res = HAleph_rel(M, a, f)"
proof(cases "Ord(a)")
  case True
  note Ord_cases[OF \<open>Ord(a)\<close>]
  then
  show ?thesis
  proof(cases )
    case 1
    with True assms
    show ?thesis
      using is_HAleph_zero unfolding HAleph_rel_def
      by simp
  next
    case (2 j)
    with True assms
    show ?thesis
      using is_HAleph_succ Ord_Union_succ_eq
      unfolding HAleph_rel_def
      by simp
  next
    case 3
    with assms
    show ?thesis
      using is_HAleph_limit zero_not_Limit Limit_is_Ord
      unfolding HAleph_rel_def
      by auto
  qed
next
  case False
  then
  have "\<not>Limit(a)" "a\<noteq>0" "\<And> x . Ord(x) \<Longrightarrow> a\<noteq>succ(x)"
    using Limit_is_Ord by auto
  with False
  show ?thesis
    unfolding is_HAleph_def HAleph_rel_def
    using assms is_Limit_iff If_abs is_csucc_iff aux_ex_Replace_funapply
    by auto
qed

lemma HAleph_rel_closed [intro,simp]:
  assumes "function(f)" "M(a)" "M(f)"
  shows "M(HAleph_rel(M,a,f))"
  unfolding HAleph_rel_def
  using assms apply_replacement
  by simp

lemma Aleph_rel_closed[intro, simp]:
  assumes "Ord(a)" "M(a)"
  shows "M(Aleph_rel(M,a))"
proof -
  have "relation2(M, is_HAleph(M), HAleph_rel(M))"
    unfolding relation2_def using is_HAleph_iff assms by simp
  moreover
  have "\<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(HAleph_rel(M, x, g))"
    using HAleph_rel_closed by simp
  moreover
  note assms
  ultimately
  show ?thesis
    unfolding Aleph_rel_def
    using transrec_closed[of "is_HAleph(M)" a "HAleph_rel(M)"]
      haleph_transrec_replacement  by simp
qed

lemma Aleph_rel_zero: "\<aleph>\<^bsub>0\<^esub>\<^bsup>M\<^esup> = nat"
  using def_transrec [OF Aleph_rel_def',of _ 0]
  unfolding HAleph_rel_def by simp

lemma Aleph_rel_succ: "Ord(\<alpha>) \<Longrightarrow> M(\<alpha>) \<Longrightarrow> \<aleph>\<^bsub>succ(\<alpha>)\<^esub>\<^bsup>M\<^esup> = (\<aleph>\<^bsub>\<alpha>\<^esub>\<^bsup>M\<^esup>\<^sup>+)\<^bsup>M\<^esup>"
  using Ord_Union_succ_eq
  by (subst def_transrec [OF Aleph_rel_def'])
    (simp add:HAleph_rel_def)

lemma Aleph_rel_limit:
  assumes "Limit(\<alpha>)" "M(\<alpha>)"
  shows "\<aleph>\<^bsub>\<alpha>\<^esub>\<^bsup>M\<^esup> = \<Union>{\<aleph>\<^bsub>j\<^esub>\<^bsup>M\<^esup> . j \<in> \<alpha>}"
proof -
  note trans=transM[OF _ \<open>M(\<alpha>)\<close>]
  from \<open>M(\<alpha>)\<close>
  have "\<aleph>\<^bsub>\<alpha>\<^esub>\<^bsup>M\<^esup> = HAleph_rel(M, \<alpha>, \<lambda>x\<in>\<alpha>. \<aleph>\<^bsub>x\<^esub>\<^bsup>M\<^esup>)"
    using def_transrec [OF Aleph_rel_def',of M \<alpha>] by simp
  also
  have "... = \<Union>{a . j \<in> \<alpha>, M(a) \<and> a = \<aleph>\<^bsub>j\<^esub>\<^bsup>M\<^esup>}"
    unfolding HAleph_rel_def
    using assms zero_not_Limit Limit_is_Ord trans by auto
  also
  have "... = \<Union>{\<aleph>\<^bsub>j\<^esub>\<^bsup>M\<^esup> . j \<in> \<alpha>}"
    using Aleph_rel_closed[OF _ trans] Ord_in_Ord Limit_is_Ord[OF \<open>Limit(\<alpha>)\<close>] by auto
  finally
  show ?thesis .
qed

lemma is_Aleph_iff:
  assumes "Ord(a)" "M(a)" "M(res)"
  shows "is_Aleph(M, a, res) \<longleftrightarrow> res = \<aleph>\<^bsub>a\<^esub>\<^bsup>M\<^esup>"
proof -
  have "relation2(M, is_HAleph(M), HAleph_rel(M))"
    unfolding relation2_def using is_HAleph_iff assms by simp
  moreover
  have "\<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(HAleph_rel(M, x, g))"
    using HAleph_rel_closed by simp
  ultimately
  show ?thesis
    using assms transrec_abs haleph_transrec_replacement
    unfolding is_Aleph_def Aleph_rel_def
    by simp
qed

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

locale M_aleph = M_pre_aleph +
  assumes
    aleph_rel_separation: "Ord(x) \<Longrightarrow> M(x) \<Longrightarrow> separation(M, \<lambda>y. \<exists>z\<in>x. y = \<aleph>\<^bsub>z\<^esub>\<^bsup>M\<^esup>)"
begin

lemma Aleph_rel_cont: "Limit(l) \<Longrightarrow> M(l) \<Longrightarrow> \<aleph>\<^bsub>l\<^esub>\<^bsup>M\<^esup> = (\<Union>i<l. \<aleph>\<^bsub>i\<^esub>\<^bsup>M\<^esup>)"
  using Limit_is_Ord Aleph_rel_limit
  by (simp add:OUnion_def)

lemma Ord_Aleph_rel:
  assumes "Ord(a)"
  shows "M(a) \<Longrightarrow> Ord(\<aleph>\<^bsub>a\<^esub>\<^bsup>M\<^esup>)"
  using \<open>Ord(a)\<close>
proof(induct a rule:trans_induct3)
  case 0
  show ?case using Aleph_rel_zero by simp
next
  case (succ x)
  with \<open>Ord(x)\<close>
  have "M(x)" "Ord(\<aleph>\<^bsub>x\<^esub>\<^bsup>M\<^esup>)" by simp_all
  with \<open>Ord(x)\<close>
  have "Ord(csucc_rel(M,\<aleph>\<^bsub>x\<^esub>\<^bsup>M\<^esup>))"
    using Card_rel_is_Ord Card_rel_csucc_rel
    by simp
  with \<open>Ord(x)\<close> \<open>M(x)\<close>
  show ?case using Aleph_rel_succ by simp
next
  case (limit x)
  note trans=transM[OF _ \<open>M(x)\<close>]
  from limit
  have "\<aleph>\<^bsub>x\<^esub>\<^bsup>M\<^esup> = (\<Union>i\<in>x. \<aleph>\<^bsub>i\<^esub>\<^bsup>M\<^esup>)"
    using Aleph_rel_cont OUnion_def Limit_is_Ord
    by auto
  with limit
  show ?case using Ord_UN trans by auto
qed

lemma Aleph_rel_increasing:
  assumes "a < b" and types: "M(a)" "M(b)"
  shows "\<aleph>\<^bsub>a\<^esub>\<^bsup>M\<^esup> < \<aleph>\<^bsub>b\<^esub>\<^bsup>M\<^esup>"
proof -
  { fix x
    from assms
    have "Ord(b)"
      by (blast intro: lt_Ord2)
    moreover
    assume "M(x)"
    moreover
    note \<open>M(b)\<close>
    ultimately
    have "x < b \<Longrightarrow> \<aleph>\<^bsub>x\<^esub>\<^bsup>M\<^esup> < \<aleph>\<^bsub>b\<^esub>\<^bsup>M\<^esup>"
    proof (induct b arbitrary: x rule: trans_induct3)
      case 0 thus ?case by simp
    next
      case (succ b)
      then
      show ?case
        using Card_rel_csucc_rel Ord_Aleph_rel Ord_Union_succ_eq lt_csucc_rel
          lt_trans[of _ "\<aleph>\<^bsub>b\<^esub>\<^bsup>M\<^esup>" "csucc\<^bsup>M\<^esup>(\<aleph>\<^bsub>b\<^esub>\<^bsup>M\<^esup>)"]
        by (subst (2) def_transrec[OF Aleph_rel_def'])
          (auto simp add: le_iff HAleph_rel_def)
    next
      case (limit l)
      then
      have sc: "succ(x) < l"
        by (blast intro: Limit_has_succ)
      then
      have "\<aleph>\<^bsub>x\<^esub>\<^bsup>M\<^esup> < (\<Union>j<l. \<aleph>\<^bsub>j\<^esub>\<^bsup>M\<^esup>)"
        using limit Ord_Aleph_rel Ord_OUN
      proof(rule_tac OUN_upper_lt,blast intro: Card_rel_is_Ord ltD lt_Ord)
        from \<open>x<l\<close> \<open>Limit(l)\<close>
        have "Ord(x)"
          using Limit_is_Ord Ord_in_Ord
          by (auto dest!:ltD)
        with \<open>M(x)\<close>
        show "\<aleph>\<^bsub>x\<^esub>\<^bsup>M\<^esup> < \<aleph>\<^bsub>succ(x)\<^esub>\<^bsup>M\<^esup>"
          using Card_rel_csucc_rel Ord_Aleph_rel lt_csucc_rel
            ltD[THEN [2] Ord_in_Ord] succ_in_MI[OF \<open>M(x)\<close>]
            Aleph_rel_succ[of x]
          by (simp)
      next
        from \<open>M(l)\<close> \<open>Limit(l)\<close>
        show "Ord(\<Union>j<l. \<aleph>\<^bsub>j\<^esub>\<^bsup>M\<^esup>)"
          using Ord_Aleph_rel lt_Ord Limit_is_Ord Ord_in_Ord
          by (rule_tac Ord_OUN)
            (auto dest:transM ltD intro!:Ord_Aleph_rel)
      qed
      then
      show ?case using limit Aleph_rel_cont by simp
    qed
  }
  with types assms
  show ?thesis by simp
qed

lemma Card_rel_Aleph_rel [simp, intro]:
  assumes "Ord(a)" and types: "M(a)" shows "Card\<^bsup>M\<^esup>(\<aleph>\<^bsub>a\<^esub>\<^bsup>M\<^esup>)"
  using assms
proof (induct rule:trans_induct3)
  case 0
  then
  show ?case
    using Aleph_rel_zero Card_rel_nat by simp
next
  case (succ x)
  then
  show ?case
    using Card_rel_csucc_rel Ord_Aleph_rel Aleph_rel_succ
    by simp
next
  case (limit x)
  moreover from this
  have "Ord(x)"
    using Limit_is_Ord by simp
  from this
  have "{y . z \<in> x, M(y) \<and> M(z) \<and> y = \<aleph>\<^bsub>z\<^esub>\<^bsup>M\<^esup>} = {y . z \<in> x, M(y) \<and> M(z) \<and> Ord(z) \<and> y = \<aleph>\<^bsub>z\<^esub>\<^bsup>M\<^esup>}"
    using Ord_in_Ord by simp
  moreover from \<open>Ord(x)\<close>
  have "{y . z \<in> x, M(y) \<and> M(z) \<and> Ord(z) \<and> y = \<aleph>\<^bsub>z\<^esub>\<^bsup>M\<^esup>} = {y . z \<in> x, M(z) \<and> y = \<aleph>\<^bsub>z\<^esub>\<^bsup>M\<^esup>}"
    using Ord_in_Ord by blast
  moreover from \<open>Ord(x)\<close> \<open>M(x)\<close>
  have "{y . z \<in> x, M(z) \<and> y = \<aleph>\<^bsub>z\<^esub>\<^bsup>M\<^esup>} \<subseteq>  \<aleph>\<^bsub>x\<^esub>\<^bsup>M\<^esup>"
    using Aleph_rel_increasing
    by (auto dest:ltD transM intro:ltI)
  with calculation
  have "{y . z \<in> x, M(z) \<and> y = \<aleph>\<^bsub>z\<^esub>\<^bsup>M\<^esup>} = {y \<in> \<aleph>\<^bsub>x\<^esub>\<^bsup>M\<^esup> . (\<exists>z \<in> x. y = \<aleph>\<^bsub>z\<^esub>\<^bsup>M\<^esup>)}"
    by (blast dest:transM)
  with calculation
  have "{y . z \<in> x, M(y) \<and> M(z) \<and> y = \<aleph>\<^bsub>z\<^esub>\<^bsup>M\<^esup>} = {y \<in> \<aleph>\<^bsub>x\<^esub>\<^bsup>M\<^esup> . (\<exists>z \<in> x. y = \<aleph>\<^bsub>z\<^esub>\<^bsup>M\<^esup>)}"
    by simp
  moreover from \<open>Ord(x)\<close> \<open>M(x)\<close>
  have "M({y \<in> \<aleph>\<^bsub>x\<^esub>\<^bsup>M\<^esup> . (\<exists>z \<in> x. y = \<aleph>\<^bsub>z\<^esub>\<^bsup>M\<^esup>)})"
    using aleph_rel_separation
    by simp
  ultimately
  show ?case
    using Ord_Aleph_rel Card_nat Limit_is_Ord Card_relI
    by (subst def_transrec [OF Aleph_rel_def'])
      (auto simp add:HAleph_rel_def)
qed

lemmas nat_subset_Aleph_rel_1 =
  Ord_lt_subset[OF Ord_Aleph_rel[of 1] Aleph_rel_increasing[of 0 1,simplified],simplified]

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

end


theory Kruskal_Time
  imports MaxNode_Impl
    Union_Find_Time
begin

locale Kruskal_final = Kruskal_intermediate  E forest connected path weight
  for E :: "nat uprod set" and forest connected path
      and weight :: "nat uprod \<Rightarrow> int"
    + fixes getEdges getEdges_time getEdges_impl
  assumes E: "E \<noteq>{}"
    and getEdges_Spec: "getEdges \<le> \<Down> Id (getEdges' weight E (enat (getEdges_time (card E))))"
    and getEdges_impl_refines:
          "(uncurry0 getEdges_impl, uncurry0 getEdges) \<in> unit_assn\<^sup>k
                   \<rightarrow>\<^sub>a list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn)"
begin

sublocale  Kruskal_intermediate_Impl E forest connected path weight getEdges getEdges_impl
      "getEdges_time (card E)" "sortEdges'_time (card E)" "uf_init_time (Suc (Max V))"
      "uf_cmp_time (Suc (Max V))" "uf_union_time (Suc (Max V))"
      is_uf uf_init uf_init_time uf_cmp uf_cmp_time uf_union uf_union_time
      sortEdges' sortEdges'_time
  apply(unfold_locales)
        apply (fact E)
       apply(fact getEdges_Spec)
      apply(fact getEdges_impl_refines)
  by auto

thm kruskal_correct_forest

term minBasis_time
thm minBasis_time_def

definition (in -) "kruskal_time gt  \<equiv> \<lambda>(cE, M). gt cE + sortEdges'_time cE + (12 + uf_init_time (Suc M)) + cE * (uf_cmp_time (Suc M) + (23 + uf_union_time (Suc M)))"
definition (in -) "kruskal_time'  \<equiv> \<lambda>(cE, M). sortEdges'_time cE + (12 + uf_init_time (M + 1)) + cE * (uf_cmp_time (M + 1) + (23 + uf_union_time (M + 1)))"

term minBasis_time

lemma mBT: "minBasis_time = kruskal_time getEdges_time (card E, Max V)"
  unfolding minBasis_time_def kruskal_time_def by simp

definition "kruskal_final = kruskal' getEdges_impl uf_init uf_cmp uf_union sortEdges'"

  concrete_definition (in -) kruskal_final
    uses Kruskal_final.kruskal_final_def

lemma k_c: "<timeCredit_assn (kruskal_time getEdges_time (card E, Max V))> kruskal <\<lambda>r. \<exists>\<^sub>Ara. hr_comp (da_assn id_assn) lst_graph_rel ra r * \<up> (MST ra)>\<^sub>t"
  unfolding mBT[symmetric] using kruskal_correct_forest by simp

thm sortEdges'_time_bound uf_init_bound uf_cmp_time_bound uf_union_time_bound

lemma uf_init_bound[asym_bound]: "uf_init_time \<in> \<Theta>(\<lambda>n. n)"
  unfolding uf_init_time_def by auto2

lemma (in -) kruskal_time'_bound:
  shows "kruskal_time'  \<in> \<Theta>\<^sub>2(\<lambda>(E::nat,M::nat). E * ln E + M + E * ln M )"
  unfolding kruskal_time'_def
  by (auto2)

lemma (in -) kruskal_time_split: "kruskal_time gt  = (\<lambda>(cE,M). gt cE) +  kruskal_time'"
  apply(rule ext) apply (simp add: kruskal_time'_def kruskal_time_def) by auto

lemma (in -) polylog00: "polylog 0 0 m = 1" unfolding polylog_def by simp

lemma (in -) kruskal_time_plus_linear:
  assumes "gt \<in> \<Theta>(\<lambda>n. n)"
  shows "kruskal_time gt \<in> \<Theta>\<^sub>2(\<lambda>(E::nat,M::nat). E * ln E + M + E * ln M )" (is "_ \<in> ?T")
proof -
  have A: "(\<lambda>x. real (gt (fst x))) \<in> \<Theta>\<^sub>2 (\<lambda>(n::nat, m::nat). real n)"
    using mult_Theta_bivariate1[unfolded polylog2_def polylog_def, of gt 1 0 ]
    apply auto using assms by simp

  have split: "\<And>x. gt (fst x) + kruskal_time' x = kruskal_time gt x"
    unfolding kruskal_time'_def kruskal_time_def by auto

  have r: "(\<lambda>x. real (gt (fst x) + kruskal_time' x)) \<in> \<Theta>\<^sub>2 ((\<lambda>x. case x of (n, m) \<Rightarrow> real n) + (\<lambda>x. case x of (E, M) \<Rightarrow> real E * ln (real E) + real M + real E * ln (real M)))"
    apply(rule bigtheta_add[OF _ _ A kruskal_time'_bound ])
    subgoal apply(auto simp: eventually_nonneg_def eventually_sequentially)

      using eventually_prod_same by force
    subgoal apply(auto simp: eventually_nonneg_def eventually_sequentially)
      apply(subst eventually_prod_same) apply auto apply(rule exI[where x="\<lambda>x. x\<ge>1"])
      by simp
    done

  { fix x y :: nat and c
    assume t: "y\<ge>1 " " x\<ge>1 " " 1 \<le> c * ln (real x)" "c>0"
    then have t': "real y + real x * ln (real y) \<ge> 0"
      by simp
    from t have "real x \<le> c * real x * ln (real x)" by auto
    also have "\<dots> \<le> c * (real x * ln (real x) + real y + real x * ln (real y)) "
      using t' t by auto
    finally
    have "real x \<le> c * (real x * ln (real x) + real y + real x * ln (real y)) " .
  } note blub = this

  have 2: "?T = \<Theta>\<^sub>2 ((\<lambda>x. case x of (n, m) \<Rightarrow> real n) + (\<lambda>x. case x of (E, M) \<Rightarrow> real E * ln (real E) + real M + real E * ln (real M)))"
    apply(subst plus_absorb1')
    subgoal apply(rule landau_o.smallI) apply(subst eventually_prod_same)
      subgoal for c apply(rule exI[where x="\<lambda>x::nat. real x \<le> c * \<bar>real x * ln (real x)\<bar> \<and> x\<ge>1"])
        apply safe subgoal apply(simp add: eventually_sequentially) apply (rule exI[where x="max (max 1 (nat (ceiling (exp (1/c))))) (nat (ceiling (1/c)))"])
          apply auto
          by (metis exp_gt_zero exp_le_cancel_iff exp_ln less_le_trans mult.commute pos_divide_le_eq)
          apply auto  apply(rule blub) by auto
        done
    by simp

  show ?thesis
    unfolding split[symmetric] 2
    using r .
qed

end

end


(*  Title:      HOL/Statespace/StateFun.thy
    Author:     Norbert Schirmer, TU Muenchen
*)

section {* State Space Representation as Function \label{sec:StateFun}*}

theory StateFun imports DistinctTreeProver
begin

text {* The state space is represented as a function from names to
values. We neither fix the type of names nor the type of values. We
define lookup and update functions and provide simprocs that simplify
expressions containing these, similar to HOL-records.

The lookup and update function get constructor/destructor functions as
parameters. These are used to embed various HOL-types into the
abstract value type. Conceptually the abstract value type is a sum of
all types that we attempt to store in the state space.

The update is actually generalized to a map function. The map supplies
better compositionality, especially if you think of nested state
spaces.  *}

definition K_statefun :: "'a \<Rightarrow> 'b \<Rightarrow> 'a" where "K_statefun c x \<equiv> c"

lemma K_statefun_apply [simp]: "K_statefun c x = c"
  by (simp add: K_statefun_def)

lemma K_statefun_comp [simp]: "(K_statefun c \<circ> f) = K_statefun c"
  by (rule ext) (simp add: comp_def)

lemma K_statefun_cong [cong]: "K_statefun c x = K_statefun c x"
  by (rule refl)

definition lookup :: "('v \<Rightarrow> 'a) \<Rightarrow> 'n \<Rightarrow> ('n \<Rightarrow> 'v) \<Rightarrow> 'a"
  where "lookup destr n s = destr (s n)"

definition update ::
  "('v \<Rightarrow> 'a1) \<Rightarrow> ('a2 \<Rightarrow> 'v) \<Rightarrow> 'n \<Rightarrow> ('a1 \<Rightarrow> 'a2) \<Rightarrow> ('n \<Rightarrow> 'v) \<Rightarrow> ('n \<Rightarrow> 'v)"
  where "update destr constr n f s = s(n := constr (f (destr (s n))))"

lemma lookup_update_same:
  "(\<And>v. destr (constr v) = v) \<Longrightarrow> lookup destr n (update destr constr n f s) =
         f (destr (s n))"
  by (simp add: lookup_def update_def)

lemma lookup_update_id_same:
  "lookup destr n (update destr' id n (K_statefun (lookup id n s')) s) =
     lookup destr n s'"
  by (simp add: lookup_def update_def)

lemma lookup_update_other:
  "n\<noteq>m \<Longrightarrow> lookup destr n (update destr' constr m f s) = lookup destr n s"
  by (simp add: lookup_def update_def)

lemma id_id_cancel: "id (id x) = x"
  by (simp add: id_def)

lemma destr_contstr_comp_id: "(\<And>v. destr (constr v) = v) \<Longrightarrow> destr \<circ> constr = id"
  by (rule ext) simp

lemma block_conj_cong: "(P \<and> Q) = (P \<and> Q)"
  by simp

lemma conj1_False: "P \<equiv> False \<Longrightarrow> (P \<and> Q) \<equiv> False"
  by simp

lemma conj2_False: "Q \<equiv> False \<Longrightarrow> (P \<and> Q) \<equiv> False"
  by simp

lemma conj_True: "P \<equiv> True \<Longrightarrow> Q \<equiv> True \<Longrightarrow> (P \<and> Q) \<equiv> True"
  by simp

lemma conj_cong: "P \<equiv> P' \<Longrightarrow> Q \<equiv> Q' \<Longrightarrow> (P \<and> Q) \<equiv> (P' \<and> Q')"
  by simp

lemma update_apply: "(update destr constr n f s x) =
     (if x=n then constr (f (destr (s n))) else s x)"
  by (simp add: update_def)

lemma ex_id: "\<exists>x. id x = y"
  by (simp add: id_def)

lemma swap_ex_eq:
  "\<exists>s. f s = x \<equiv> True \<Longrightarrow>
   \<exists>s. x = f s \<equiv> True"
  apply (rule eq_reflection)
  apply auto
  done

lemmas meta_ext = eq_reflection [OF ext]

(* This lemma only works if the store is welltyped:
    "\<exists>x.  s ''n'' = (c x)"
   or in general when c (d x) = x,
     (for example: c=id and d=id)
 *)
lemma "update d c n (K_statespace (lookup d n s)) s = s"
  apply (simp add: update_def lookup_def)
  apply (rule ext)
  apply simp
  oops

end