(*  Title:      HOL/Auth/CertifiedEmail.thy
    Author:     Giampaolo Bella, Christiano Longo and Lawrence C Paulson
*)

section{*The Certified Electronic Mail Protocol by Abadi et al.*}

theory CertifiedEmail imports Public begin

abbreviation
  TTP :: agent where
  "TTP == Server"

abbreviation
  RPwd :: "agent => key" where
  "RPwd == shrK"

(*FIXME: the four options should be represented by pairs of 0 or 1.
  Right now only BothAuth is modelled.*)
consts
  NoAuth   :: nat
  TTPAuth  :: nat
  SAuth    :: nat
  BothAuth :: nat

text{*We formalize a fixed way of computing responses.  Could be better.*}
definition "response" :: "agent => agent => nat => msg" where
   "response S R q == Hash {|Agent S, Key (shrK R), Nonce q|}"

inductive_set certified_mail :: "event list set"
  where

  Nil: --{*The empty trace*}
     "[] \<in> certified_mail"

| Fake: --{*The Spy may say anything he can say.  The sender field is correct,
          but agents don't use that information.*}
      "[| evsf \<in> certified_mail; X \<in> synth(analz(spies evsf))|]
       ==> Says Spy B X # evsf \<in> certified_mail"

| FakeSSL: --{*The Spy may open SSL sessions with TTP, who is the only agent
    equipped with the necessary credentials to serve as an SSL server.*}
         "[| evsfssl \<in> certified_mail; X \<in> synth(analz(spies evsfssl))|]
          ==> Notes TTP {|Agent Spy, Agent TTP, X|} # evsfssl \<in> certified_mail"

| CM1: --{*The sender approaches the recipient.  The message is a number.*}
 "[|evs1 \<in> certified_mail;
    Key K \<notin> used evs1;
    K \<in> symKeys;
    Nonce q \<notin> used evs1;
    hs = Hash{|Number cleartext, Nonce q, response S R q, Crypt K (Number m)|};
    S2TTP = Crypt(pubEK TTP) {|Agent S, Number BothAuth, Key K, Agent R, hs|}|]
  ==> Says S R {|Agent S, Agent TTP, Crypt K (Number m), Number BothAuth,
                 Number cleartext, Nonce q, S2TTP|} # evs1
        \<in> certified_mail"

| CM2: --{*The recipient records @{term S2TTP} while transmitting it and her
     password to @{term TTP} over an SSL channel.*}
 "[|evs2 \<in> certified_mail;
    Gets R {|Agent S, Agent TTP, em, Number BothAuth, Number cleartext,
             Nonce q, S2TTP|} \<in> set evs2;
    TTP \<noteq> R;
    hr = Hash {|Number cleartext, Nonce q, response S R q, em|} |]
  ==>
   Notes TTP {|Agent R, Agent TTP, S2TTP, Key(RPwd R), hr|} # evs2
      \<in> certified_mail"

| CM3: --{*@{term TTP} simultaneously reveals the key to the recipient and gives
         a receipt to the sender.  The SSL channel does not authenticate
         the client (@{term R}), but @{term TTP} accepts the message only
         if the given password is that of the claimed sender, @{term R}.
         He replies over the established SSL channel.*}
 "[|evs3 \<in> certified_mail;
    Notes TTP {|Agent R, Agent TTP, S2TTP, Key(RPwd R), hr|} \<in> set evs3;
    S2TTP = Crypt (pubEK TTP)
                     {|Agent S, Number BothAuth, Key k, Agent R, hs|};
    TTP \<noteq> R;  hs = hr;  k \<in> symKeys|]
  ==>
   Notes R {|Agent TTP, Agent R, Key k, hr|} #
   Gets S (Crypt (priSK TTP) S2TTP) #
   Says TTP S (Crypt (priSK TTP) S2TTP) # evs3 \<in> certified_mail"

| Reception:
 "[|evsr \<in> certified_mail; Says A B X \<in> set evsr|]
  ==> Gets B X#evsr \<in> certified_mail"

declare Says_imp_knows_Spy [THEN analz.Inj, dest]
declare analz_into_parts [dest]

(*A "possibility property": there are traces that reach the end*)
lemma "[| Key K \<notin> used []; K \<in> symKeys |] ==>
       \<exists>S2TTP. \<exists>evs \<in> certified_mail.
           Says TTP S (Crypt (priSK TTP) S2TTP) \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] certified_mail.Nil
                    [THEN certified_mail.CM1, THEN certified_mail.Reception,
                     THEN certified_mail.CM2,
                     THEN certified_mail.CM3])
apply (possibility, auto)
done

lemma Gets_imp_Says:
 "[| Gets B X \<in> set evs; evs \<in> certified_mail |] ==> \<exists>A. Says A B X \<in> set evs"
apply (erule rev_mp)
apply (erule certified_mail.induct, auto)
done

lemma Gets_imp_parts_knows_Spy:
     "[|Gets A X \<in> set evs; evs \<in> certified_mail|] ==> X \<in> parts(spies evs)"
apply (drule Gets_imp_Says, simp)
apply (blast dest: Says_imp_knows_Spy parts.Inj)
done

lemma CM2_S2TTP_analz_knows_Spy:
 "[|Gets R {|Agent A, Agent B, em, Number AO, Number cleartext,
              Nonce q, S2TTP|} \<in> set evs;
    evs \<in> certified_mail|]
  ==> S2TTP \<in> analz(spies evs)"
apply (drule Gets_imp_Says, simp)
apply (blast dest: Says_imp_knows_Spy analz.Inj)
done

lemmas CM2_S2TTP_parts_knows_Spy =
    CM2_S2TTP_analz_knows_Spy [THEN analz_subset_parts [THEN subsetD]]

lemma hr_form_lemma [rule_format]:
 "evs \<in> certified_mail
  ==> hr \<notin> synth (analz (spies evs)) -->
      (\<forall>S2TTP. Notes TTP {|Agent R, Agent TTP, S2TTP, pwd, hr|}
          \<in> set evs -->
      (\<exists>clt q S em. hr = Hash {|Number clt, Nonce q, response S R q, em|}))"
apply (erule certified_mail.induct)
apply (synth_analz_mono_contra, simp_all, blast+)
done

text{*Cannot strengthen the first disjunct to @{term "R\<noteq>Spy"} because
the fakessl rule allows Spy to spoof the sender's name.  Maybe can
strengthen the second disjunct with @{term "R\<noteq>Spy"}.*}
lemma hr_form:
 "[|Notes TTP {|Agent R, Agent TTP, S2TTP, pwd, hr|} \<in> set evs;
    evs \<in> certified_mail|]
  ==> hr \<in> synth (analz (spies evs)) |
      (\<exists>clt q S em. hr = Hash {|Number clt, Nonce q, response S R q, em|})"
by (blast intro: hr_form_lemma)

lemma Spy_dont_know_private_keys [dest!]:
    "[|Key (privateKey b A) \<in> parts (spies evs); evs \<in> certified_mail|]
     ==> A \<in> bad"
apply (erule rev_mp)
apply (erule certified_mail.induct, simp_all)
txt{*Fake*}
apply (blast dest: Fake_parts_insert_in_Un)
txt{*Message 1*}
apply blast
txt{*Message 3*}
apply (frule_tac hr_form, assumption)
apply (elim disjE exE)
apply (simp_all add: parts_insert2)
 apply (force dest!: parts_insert_subset_Un [THEN [2] rev_subsetD]
                     analz_subset_parts [THEN subsetD], blast)
done

lemma Spy_know_private_keys_iff [simp]:
    "evs \<in> certified_mail
     ==> (Key (privateKey b A) \<in> parts (spies evs)) = (A \<in> bad)"
by blast

lemma Spy_dont_know_TTPKey_parts [simp]:
     "evs \<in> certified_mail ==> Key (privateKey b TTP) \<notin> parts(spies evs)"
by simp

lemma Spy_dont_know_TTPKey_analz [simp]:
     "evs \<in> certified_mail ==> Key (privateKey b TTP) \<notin> analz(spies evs)"
by auto

text{*Thus, prove any goal that assumes that @{term Spy} knows a private key
belonging to @{term TTP}*}
declare Spy_dont_know_TTPKey_parts [THEN [2] rev_notE, elim!]

lemma CM3_k_parts_knows_Spy:
 "[| evs \<in> certified_mail;
     Notes TTP {|Agent A, Agent TTP,
                 Crypt (pubEK TTP) {|Agent S, Number AO, Key K,
                 Agent R, hs|}, Key (RPwd R), hs|} \<in> set evs|]
  ==> Key K \<in> parts(spies evs)"
apply (rotate_tac 1)
apply (erule rev_mp)
apply (erule certified_mail.induct, simp_all)
   apply (blast  intro:parts_insertI)
txt{*Fake SSL*}
apply (blast dest: parts.Body)
txt{*Message 2*}
apply (blast dest!: Gets_imp_Says elim!: knows_Spy_partsEs)
txt{*Message 3*}
apply (metis parts_insertI)
done

lemma Spy_dont_know_RPwd [rule_format]:
    "evs \<in> certified_mail ==> Key (RPwd A) \<in> parts(spies evs) --> A \<in> bad"
apply (erule certified_mail.induct, simp_all)
txt{*Fake*}
apply (blast dest: Fake_parts_insert_in_Un)
txt{*Message 1*}
apply blast
txt{*Message 3*}
apply (frule CM3_k_parts_knows_Spy, assumption)
apply (frule_tac hr_form, assumption)
apply (elim disjE exE)
apply (simp_all add: parts_insert2)
apply (force dest!: parts_insert_subset_Un [THEN [2] rev_subsetD]
                    analz_subset_parts [THEN subsetD])
done

lemma Spy_know_RPwd_iff [simp]:
    "evs \<in> certified_mail ==> (Key (RPwd A) \<in> parts(spies evs)) = (A\<in>bad)"
by (auto simp add: Spy_dont_know_RPwd)

lemma Spy_analz_RPwd_iff [simp]:
    "evs \<in> certified_mail ==> (Key (RPwd A) \<in> analz(spies evs)) = (A\<in>bad)"
by (metis Spy_know_RPwd_iff Spy_spies_bad_shrK analz.Inj analz_into_parts)

text{*Unused, but a guarantee of sorts*}
theorem CertAutenticity:
     "[|Crypt (priSK TTP) X \<in> parts (spies evs); evs \<in> certified_mail|]
      ==> \<exists>A. Says TTP A (Crypt (priSK TTP) X) \<in> set evs"
apply (erule rev_mp)
apply (erule certified_mail.induct, simp_all)
txt{*Fake*}
apply (blast dest: Spy_dont_know_private_keys Fake_parts_insert_in_Un)
txt{*Message 1*}
apply blast
txt{*Message 3*}
apply (frule_tac hr_form, assumption)
apply (elim disjE exE)
apply (simp_all add: parts_insert2 parts_insert_knows_A)
 apply (blast dest!: Fake_parts_sing_imp_Un, blast)
done

subsection{*Proving Confidentiality Results*}

lemma analz_image_freshK [rule_format]:
 "evs \<in> certified_mail ==>
   \<forall>K KK. invKey (pubEK TTP) \<notin> KK -->
          (Key K \<in> analz (Key`KK Un (spies evs))) =
          (K \<in> KK | Key K \<in> analz (spies evs))"
apply (erule certified_mail.induct)
apply (drule_tac [6] A=TTP in symKey_neq_priEK)
apply (erule_tac [6] disjE [OF hr_form])
apply (drule_tac [5] CM2_S2TTP_analz_knows_Spy)
prefer 9
apply (elim exE)
apply (simp_all add: synth_analz_insert_eq
                     subset_trans [OF _ subset_insertI]
                     subset_trans [OF _ Un_upper2]
                del: image_insert image_Un add: analz_image_freshK_simps)
done

lemma analz_insert_freshK:
  "[| evs \<in> certified_mail;  KAB \<noteq> invKey (pubEK TTP) |] ==>
      (Key K \<in> analz (insert (Key KAB) (spies evs))) =
      (K = KAB | Key K \<in> analz (spies evs))"
by (simp only: analz_image_freshK analz_image_freshK_simps)

text{*@{term S2TTP} must have originated from a valid sender
    provided @{term K} is secure.  Proof is surprisingly hard.*}

lemma Notes_SSL_imp_used:
     "[|Notes B {|Agent A, Agent B, X|} \<in> set evs|] ==> X \<in> used evs"
by (blast dest!: Notes_imp_used)

(*The weaker version, replacing "used evs" by "parts (spies evs)",
   isn't inductive: message 3 case can't be proved *)
lemma S2TTP_sender_lemma [rule_format]:
 "evs \<in> certified_mail ==>
    Key K \<notin> analz (spies evs) -->
    (\<forall>AO. Crypt (pubEK TTP)
           {|Agent S, Number AO, Key K, Agent R, hs|} \<in> used evs -->
    (\<exists>m ctxt q.
        hs = Hash{|Number ctxt, Nonce q, response S R q, Crypt K (Number m)|} &
        Says S R
           {|Agent S, Agent TTP, Crypt K (Number m), Number AO,
             Number ctxt, Nonce q,
             Crypt (pubEK TTP)
              {|Agent S, Number AO, Key K, Agent R, hs |}|} \<in> set evs))"
apply (erule certified_mail.induct, analz_mono_contra)
apply (drule_tac [5] CM2_S2TTP_parts_knows_Spy, simp)
apply (simp add: used_Nil Crypt_notin_initState, simp_all)
txt{*Fake*}
apply (blast dest: Fake_parts_sing [THEN subsetD]
             dest!: analz_subset_parts [THEN subsetD])
txt{*Fake SSL*}
apply (blast dest: Fake_parts_sing [THEN subsetD]
             dest: analz_subset_parts [THEN subsetD])
txt{*Message 1*}
apply (clarsimp, blast)
txt{*Message 2*}
apply (simp add: parts_insert2, clarify)
apply (metis parts_cut Un_empty_left usedI)
txt{*Message 3*}
apply (blast dest: Notes_SSL_imp_used used_parts_subset_parts)
done

lemma S2TTP_sender:
 "[|Crypt (pubEK TTP) {|Agent S, Number AO, Key K, Agent R, hs|} \<in> used evs;
    Key K \<notin> analz (spies evs);
    evs \<in> certified_mail|]
  ==> \<exists>m ctxt q.
        hs = Hash{|Number ctxt, Nonce q, response S R q, Crypt K (Number m)|} &
        Says S R
           {|Agent S, Agent TTP, Crypt K (Number m), Number AO,
             Number ctxt, Nonce q,
             Crypt (pubEK TTP)
              {|Agent S, Number AO, Key K, Agent R, hs |}|} \<in> set evs"
by (blast intro: S2TTP_sender_lemma)

text{*Nobody can have used non-existent keys!*}
lemma new_keys_not_used [simp]:
    "[|Key K \<notin> used evs; K \<in> symKeys; evs \<in> certified_mail|]
     ==> K \<notin> keysFor (parts (spies evs))"
apply (erule rev_mp)
apply (erule certified_mail.induct, simp_all)
txt{*Fake*}
apply (force dest!: keysFor_parts_insert)
txt{*Message 1*}
apply blast
txt{*Message 3*}
apply (frule CM3_k_parts_knows_Spy, assumption)
apply (frule_tac hr_form, assumption)
apply (force dest!: keysFor_parts_insert)
done

text{*Less easy to prove @{term "m'=m"}.  Maybe needs a separate unicity
theorem for ciphertexts of the form @{term "Crypt K (Number m)"},
where @{term K} is secure.*}
lemma Key_unique_lemma [rule_format]:
     "evs \<in> certified_mail ==>
       Key K \<notin> analz (spies evs) -->
       (\<forall>m cleartext q hs.
        Says S R
           {|Agent S, Agent TTP, Crypt K (Number m), Number AO,
             Number cleartext, Nonce q,
             Crypt (pubEK TTP) {|Agent S, Number AO, Key K, Agent R, hs|}|}
          \<in> set evs -->
       (\<forall>m' cleartext' q' hs'.
       Says S' R'
           {|Agent S', Agent TTP, Crypt K (Number m'), Number AO',
             Number cleartext', Nonce q',
             Crypt (pubEK TTP) {|Agent S', Number AO', Key K, Agent R', hs'|}|}
          \<in> set evs --> R' = R & S' = S & AO' = AO & hs' = hs))"
apply (erule certified_mail.induct, analz_mono_contra, simp_all)
 prefer 2
 txt{*Message 1*}
 apply (blast dest!: Says_imp_knows_Spy [THEN parts.Inj] new_keys_not_used Crypt_imp_keysFor)
txt{*Fake*}
apply (auto dest!: usedI S2TTP_sender analz_subset_parts [THEN subsetD])
done

text{*The key determines the sender, recipient and protocol options.*}
lemma Key_unique:
      "[|Says S R
           {|Agent S, Agent TTP, Crypt K (Number m), Number AO,
             Number cleartext, Nonce q,
             Crypt (pubEK TTP) {|Agent S, Number AO, Key K, Agent R, hs|}|}
          \<in> set evs;
         Says S' R'
           {|Agent S', Agent TTP, Crypt K (Number m'), Number AO',
             Number cleartext', Nonce q',
             Crypt (pubEK TTP) {|Agent S', Number AO', Key K, Agent R', hs'|}|}
          \<in> set evs;
         Key K \<notin> analz (spies evs);
         evs \<in> certified_mail|]
       ==> R' = R & S' = S & AO' = AO & hs' = hs"
by (rule Key_unique_lemma, assumption+)

subsection{*The Guarantees for Sender and Recipient*}

text{*A Sender's guarantee:
      If Spy gets the key then @{term R} is bad and @{term S} moreover
      gets his return receipt (and therefore has no grounds for complaint).*}
theorem S_fairness_bad_R:
      "[|Says S R {|Agent S, Agent TTP, Crypt K (Number m), Number AO,
                     Number cleartext, Nonce q, S2TTP|} \<in> set evs;
         S2TTP = Crypt (pubEK TTP) {|Agent S, Number AO, Key K, Agent R, hs|};
         Key K \<in> analz (spies evs);
         evs \<in> certified_mail;
         S\<noteq>Spy|]
      ==> R \<in> bad & Gets S (Crypt (priSK TTP) S2TTP) \<in> set evs"
apply (erule rev_mp)
apply (erule ssubst)
apply (erule rev_mp)
apply (erule certified_mail.induct, simp_all)
txt{*Fake*}
apply spy_analz
txt{*Fake SSL*}
apply spy_analz
txt{*Message 3*}
apply (frule_tac hr_form, assumption)
apply (elim disjE exE)
apply (simp_all add: synth_analz_insert_eq
                     subset_trans [OF _ subset_insertI]
                     subset_trans [OF _ Un_upper2]
                del: image_insert image_Un add: analz_image_freshK_simps)
apply (simp_all add: symKey_neq_priEK analz_insert_freshK)
apply (blast dest: Notes_SSL_imp_used S2TTP_sender Key_unique)+
done

text{*Confidentially for the symmetric key*}
theorem Spy_not_see_encrypted_key:
      "[|Says S R {|Agent S, Agent TTP, Crypt K (Number m), Number AO,
                     Number cleartext, Nonce q, S2TTP|} \<in> set evs;
         S2TTP = Crypt (pubEK TTP) {|Agent S, Number AO, Key K, Agent R, hs|};
         evs \<in> certified_mail;
         S\<noteq>Spy; R \<notin> bad|]
      ==> Key K \<notin> analz(spies evs)"
by (blast dest: S_fairness_bad_R)

text{*Agent @{term R}, who may be the Spy, doesn't receive the key
 until @{term S} has access to the return receipt.*}
theorem S_guarantee:
     "[|Says S R {|Agent S, Agent TTP, Crypt K (Number m), Number AO,
                    Number cleartext, Nonce q, S2TTP|} \<in> set evs;
        S2TTP = Crypt (pubEK TTP) {|Agent S, Number AO, Key K, Agent R, hs|};
        Notes R {|Agent TTP, Agent R, Key K, hs|} \<in> set evs;
        S\<noteq>Spy;  evs \<in> certified_mail|]
     ==> Gets S (Crypt (priSK TTP) S2TTP) \<in> set evs"
apply (erule rev_mp)
apply (erule ssubst)
apply (erule rev_mp)
apply (erule certified_mail.induct, simp_all)
txt{*Message 1*}
apply (blast dest: Notes_imp_used)
txt{*Message 3*}
apply (blast dest: Notes_SSL_imp_used S2TTP_sender Key_unique S_fairness_bad_R)
done

text{*If @{term R} sends message 2, and a delivery certificate exists,
 then @{term R} receives the necessary key.  This result is also important
 to @{term S}, as it confirms the validity of the return receipt.*}
theorem RR_validity:
  "[|Crypt (priSK TTP) S2TTP \<in> used evs;
     S2TTP = Crypt (pubEK TTP)
               {|Agent S, Number AO, Key K, Agent R,
                 Hash {|Number cleartext, Nonce q, r, em|}|};
     hr = Hash {|Number cleartext, Nonce q, r, em|};
     R\<noteq>Spy;  evs \<in> certified_mail|]
  ==> Notes R {|Agent TTP, Agent R, Key K, hr|} \<in> set evs"
apply (erule rev_mp)
apply (erule ssubst)
apply (erule ssubst)
apply (erule certified_mail.induct, simp_all)
txt{*Fake*}
apply (blast dest: Fake_parts_sing [THEN subsetD]
             dest!: analz_subset_parts [THEN subsetD])
txt{*Fake SSL*}
apply (blast dest: Fake_parts_sing [THEN subsetD]
            dest!: analz_subset_parts [THEN subsetD])
txt{*Message 2*}
apply (drule CM2_S2TTP_parts_knows_Spy, assumption)
apply (force dest: parts_cut)
txt{*Message 3*}
apply (frule_tac hr_form, assumption)
apply (elim disjE exE, simp_all)
apply (blast dest: Fake_parts_sing [THEN subsetD]
             dest!: analz_subset_parts [THEN subsetD])
done

end


(*  Title:      HOL/HOLCF/IOA/NTP/Impl.thy
    Author:     Tobias Nipkow & Konrad Slind
*)

section {* The implementation *}

theory Impl
imports Sender Receiver Abschannel
begin

type_synonym 'm impl_state
  = "'m sender_state * 'm receiver_state * 'm packet multiset * bool multiset"
  (*  sender_state   *  receiver_state   *    srch_state      * rsch_state *)

definition
  impl_ioa :: "('m action, 'm impl_state)ioa" where
  impl_def: "impl_ioa == (sender_ioa || receiver_ioa || srch_ioa || rsch_ioa)"

definition sen :: "'m impl_state => 'm sender_state" where "sen = fst"
definition rec :: "'m impl_state => 'm receiver_state" where "rec = fst o snd"
definition srch :: "'m impl_state => 'm packet multiset" where "srch = fst o snd o snd"
definition rsch :: "'m impl_state => bool multiset" where "rsch = snd o snd o snd"

definition
  hdr_sum :: "'m packet multiset => bool => nat" where
  "hdr_sum M b == countm M (%pkt. hdr(pkt) = b)"

(* Lemma 5.1 *)
definition
  "inv1(s) ==
     (!b. count (rsent(rec s)) b = count (srcvd(sen s)) b + count (rsch s) b)
   & (!b. count (ssent(sen s)) b
          = hdr_sum (rrcvd(rec s)) b + hdr_sum (srch s) b)"

(* Lemma 5.2 *)
definition
  "inv2(s) ==
  (rbit(rec(s)) = sbit(sen(s)) &
   ssending(sen(s)) &
   count (rsent(rec s)) (~sbit(sen s)) <= count (ssent(sen s)) (~sbit(sen s)) &
   count (ssent(sen s)) (~sbit(sen s)) <= count (rsent(rec s)) (sbit(sen s)))
   |
  (rbit(rec(s)) = (~sbit(sen(s))) &
   rsending(rec(s)) &
   count (ssent(sen s)) (~sbit(sen s)) <= count (rsent(rec s)) (sbit(sen s)) &
   count (rsent(rec s)) (sbit(sen s)) <= count (ssent(sen s)) (sbit(sen s)))"

(* Lemma 5.3 *)
definition
  "inv3(s) ==
   rbit(rec(s)) = sbit(sen(s))
   --> (!m. sq(sen(s))=[] | m ~= hd(sq(sen(s)))
        -->  count (rrcvd(rec s)) (sbit(sen(s)),m)
             + count (srch s) (sbit(sen(s)),m)
            <= count (rsent(rec s)) (~sbit(sen s)))"

(* Lemma 5.4 *)
definition "inv4(s) == rbit(rec(s)) = (~sbit(sen(s))) --> sq(sen(s)) ~= []"

subsection {* Invariants *}

declare le_SucI [simp]

lemmas impl_ioas =
  impl_def sender_ioa_def receiver_ioa_def srch_ioa_thm [THEN eq_reflection]
  rsch_ioa_thm [THEN eq_reflection]

lemmas "transitions" =
  sender_trans_def receiver_trans_def srch_trans_def rsch_trans_def

lemmas [simp] =
  ioa_triple_proj starts_of_par trans_of_par4 in_sender_asig
  in_receiver_asig in_srch_asig in_rsch_asig

declare let_weak_cong [cong]

lemma [simp]:
  "a:actions(sender_asig)
  | a:actions(receiver_asig)
  | a:actions(srch_asig)
  | a:actions(rsch_asig)"
  by (induct a) simp_all

declare split_paired_All [simp del]

(* Three Simp_sets in different sizes
----------------------------------------------

1) simpset() does not unfold the transition relations
2) ss unfolds transition relations
3) renname_ss unfolds transitions and the abstract channel *)

ML {*
val ss = simpset_of (@{context} addsimps @{thms "transitions"});
val rename_ss = simpset_of (put_simpset ss @{context} addsimps @{thms unfold_renaming});

fun tac ctxt =
  asm_simp_tac (put_simpset ss ctxt
    |> Simplifier.add_cong @{thm conj_cong} |> Splitter.add_split @{thm split_if})
fun tac_ren ctxt =
  asm_simp_tac (put_simpset rename_ss ctxt
    |> Simplifier.add_cong @{thm conj_cong} |> Splitter.add_split @{thm split_if})
*}

subsubsection {* Invariant 1 *}

lemma raw_inv1: "invariant impl_ioa inv1"

apply (unfold impl_ioas)
apply (rule invariantI)
apply (simp add: inv1_def hdr_sum_def srcvd_def ssent_def rsent_def rrcvd_def)

apply (simp (no_asm) del: trans_of_par4 add: imp_conjR inv1_def)

txt {* Split proof in two *}
apply (rule conjI)

(* First half *)
apply (simp add: Impl.inv1_def split del: split_if)
apply (induct_tac a)

apply (tactic "EVERY1[tac @{context}, tac @{context}, tac @{context}, tac @{context}]")
apply (tactic "tac @{context} 1")
apply (tactic "tac_ren @{context} 1")

txt {* 5 + 1 *}

apply (tactic "tac @{context} 1")
apply (tactic "tac_ren @{context} 1")

txt {* 4 + 1 *}
apply (tactic {* EVERY1[tac @{context}, tac @{context}, tac @{context}, tac @{context}] *})

txt {* Now the other half *}
apply (simp add: Impl.inv1_def split del: split_if)
apply (induct_tac a)
apply (tactic "EVERY1 [tac @{context}, tac @{context}]")

txt {* detour 1 *}
apply (tactic "tac @{context} 1")
apply (tactic "tac_ren @{context} 1")
apply (rule impI)
apply (erule conjE)+
apply (simp (no_asm_simp) add: hdr_sum_def Multiset.count_def Multiset.countm_nonempty_def
  split add: split_if)
txt {* detour 2 *}
apply (tactic "tac @{context} 1")
apply (tactic "tac_ren @{context} 1")
apply (rule impI)
apply (erule conjE)+
apply (simp add: Impl.hdr_sum_def Multiset.count_def Multiset.countm_nonempty_def
  Multiset.delm_nonempty_def split add: split_if)
apply (rule allI)
apply (rule conjI)
apply (rule impI)
apply hypsubst
apply (rule pred_suc [THEN iffD1])
apply (drule less_le_trans)
apply (cut_tac eq_packet_imp_eq_hdr [unfolded Packet.hdr_def, THEN countm_props])
apply assumption
apply assumption

apply (rule countm_done_delm [THEN mp, symmetric])
apply (rule refl)
apply (simp (no_asm_simp) add: Multiset.count_def)

apply (rule impI)
apply (simp add: neg_flip)
apply hypsubst
apply (rule countm_spurious_delm)
apply (simp (no_asm))

apply (tactic "EVERY1 [tac @{context}, tac @{context}, tac @{context},
  tac @{context}, tac @{context}, tac @{context}]")

done

subsubsection {* INVARIANT 2 *}

lemma raw_inv2: "invariant impl_ioa inv2"

  apply (rule invariantI1)
  txt {* Base case *}
  apply (simp add: inv2_def receiver_projections sender_projections impl_ioas)

  apply (simp (no_asm_simp) add: impl_ioas split del: split_if)
  apply (induct_tac "a")

  txt {* 10 cases. First 4 are simple, since state doesn't change *}

  ML_prf {* val tac2 = asm_full_simp_tac (put_simpset ss @{context} addsimps [@{thm inv2_def}]) *}

  txt {* 10 - 7 *}
  apply (tactic "EVERY1 [tac2,tac2,tac2,tac2]")
  txt {* 6 *}
  apply (tactic {* forward_tac [rewrite_rule @{context} [@{thm Impl.inv1_def}]
                               (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct1] 1 *})

  txt {* 6 - 5 *}
  apply (tactic "EVERY1 [tac2,tac2]")

  txt {* 4 *}
  apply (tactic {* forward_tac [rewrite_rule @{context} [@{thm Impl.inv1_def}]
                                (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct1] 1 *})
  apply (tactic "tac2 1")

  txt {* 3 *}
  apply (tactic {* forward_tac [rewrite_rule @{context} [@{thm Impl.inv1_def}]
    (@{thm raw_inv1} RS @{thm invariantE})] 1 *})

  apply (tactic "tac2 1")
  apply (tactic {* fold_goals_tac @{context} [rewrite_rule @{context} [@{thm Packet.hdr_def}]
    (@{thm Impl.hdr_sum_def})] *})
  apply arith

  txt {* 2 *}
  apply (tactic "tac2 1")
  apply (tactic {* forward_tac [rewrite_rule @{context} [@{thm Impl.inv1_def}]
                               (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct1] 1 *})
  apply (intro strip)
  apply (erule conjE)+
  apply simp

  txt {* 1 *}
  apply (tactic "tac2 1")
  apply (tactic {* forward_tac [rewrite_rule @{context} [@{thm Impl.inv1_def}]
                               (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct2] 1 *})
  apply (intro strip)
  apply (erule conjE)+
  apply (tactic {* fold_goals_tac @{context}
    [rewrite_rule @{context} [@{thm Packet.hdr_def}] (@{thm Impl.hdr_sum_def})] *})
  apply simp

  done

subsubsection {* INVARIANT 3 *}

lemma raw_inv3: "invariant impl_ioa inv3"

  apply (rule invariantI)
  txt {* Base case *}
  apply (simp add: Impl.inv3_def receiver_projections sender_projections impl_ioas)

  apply (simp (no_asm_simp) add: impl_ioas split del: split_if)
  apply (induct_tac "a")

  ML_prf {* val tac3 = asm_full_simp_tac (put_simpset ss @{context} addsimps [@{thm inv3_def}]) *}

  txt {* 10 - 8 *}

  apply (tactic "EVERY1[tac3,tac3,tac3]")

  apply (tactic "tac_ren @{context} 1")
  apply (intro strip, (erule conjE)+)
  apply hypsubst
  apply (erule exE)
  apply simp

  txt {* 7 *}
  apply (tactic "tac3 1")
  apply (tactic "tac_ren @{context} 1")
  apply force

  txt {* 6 - 3 *}

  apply (tactic "EVERY1[tac3,tac3,tac3,tac3]")

  txt {* 2 *}
  apply (tactic "asm_full_simp_tac (put_simpset ss @{context}) 1")
  apply (simp (no_asm) add: inv3_def)
  apply (intro strip, (erule conjE)+)
  apply (rule imp_disjL [THEN iffD1])
  apply (rule impI)
  apply (tactic {* forward_tac [rewrite_rule @{context} [@{thm Impl.inv2_def}]
    (@{thm raw_inv2} RS @{thm invariantE})] 1 *})
  apply simp
  apply (erule conjE)+
  apply (rule_tac j = "count (ssent (sen s)) (~sbit (sen s))" and
    k = "count (rsent (rec s)) (sbit (sen s))" in le_trans)
  apply (tactic {* forward_tac [rewrite_rule @{context} [@{thm inv1_def}]
                                (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct2] 1 *})
  apply (simp add: hdr_sum_def Multiset.count_def)
  apply (rule add_le_mono)
  apply (rule countm_props)
  apply (simp (no_asm))
  apply (rule countm_props)
  apply (simp (no_asm))
  apply assumption

  txt {* 1 *}
  apply (tactic "tac3 1")
  apply (intro strip, (erule conjE)+)
  apply (rule imp_disjL [THEN iffD1])
  apply (rule impI)
  apply (tactic {* forward_tac [rewrite_rule @{context} [@{thm Impl.inv2_def}]
    (@{thm raw_inv2} RS @{thm invariantE})] 1 *})
  apply simp
  done

subsubsection {* INVARIANT 4 *}

lemma raw_inv4: "invariant impl_ioa inv4"

  apply (rule invariantI)
  txt {* Base case *}
  apply (simp add: Impl.inv4_def receiver_projections sender_projections impl_ioas)

  apply (simp (no_asm_simp) add: impl_ioas split del: split_if)
  apply (induct_tac "a")

  ML_prf {* val tac4 =  asm_full_simp_tac (put_simpset ss @{context} addsimps [@{thm inv4_def}]) *}

  txt {* 10 - 2 *}

  apply (tactic "EVERY1[tac4,tac4,tac4,tac4,tac4,tac4,tac4,tac4,tac4]")

  txt {* 2 b *}

  apply (intro strip, (erule conjE)+)
  apply (tactic {* forward_tac [rewrite_rule @{context} [@{thm Impl.inv2_def}]
                               (@{thm raw_inv2} RS @{thm invariantE})] 1 *})
  apply simp

  txt {* 1 *}
  apply (tactic "tac4 1")
  apply (intro strip, (erule conjE)+)
  apply (rule ccontr)
  apply (tactic {* forward_tac [rewrite_rule @{context} [@{thm Impl.inv2_def}]
                               (@{thm raw_inv2} RS @{thm invariantE})] 1 *})
  apply (tactic {* forward_tac [rewrite_rule @{context} [@{thm Impl.inv3_def}]
                               (@{thm raw_inv3} RS @{thm invariantE})] 1 *})
  apply simp
  apply (rename_tac m, erule_tac x = "m" in allE)
  apply simp
  done

text {* rebind them *}

lemmas inv1 = raw_inv1 [THEN invariantE, unfolded inv1_def]
  and inv2 = raw_inv2 [THEN invariantE, unfolded inv2_def]
  and inv3 = raw_inv3 [THEN invariantE, unfolded inv3_def]
  and inv4 = raw_inv4 [THEN invariantE, unfolded inv4_def]

end


(*  Title:      Word_Misc.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter {* More about words *}

theory Word_Misc imports
  "~~/src/HOL/Word/Word"
  More_Bits_Int
begin

text {*
  The separate code target @{text SML_word} collects setups for the
  code generator that PolyML does not provide.
*}

setup {* Code_Target.add_derived_target ("SML_word", [(Code_ML.target_SML, I)]) *}

code_identifier code_module Word_Misc \<rightharpoonup>
  (SML) Word and (Haskell) Word and (OCaml) Word and (Scala) Word

context
includes integer.lifting
begin
lift_definition word_of_integer :: "integer \<Rightarrow> 'a :: len0 word" is word_of_int .

lemma word_of_integer_code [code]: "word_of_integer n = word_of_int (int_of_integer n)"
by(simp add: word_of_integer.rep_eq)
end

lemma shiftr_zero_size: "size x \<le> n \<Longrightarrow> x >> n = (0 :: 'a :: len0 word)"
by(rule word_eqI)(auto simp add: nth_shiftr dest: test_bit_size)

lemma mask_full [simp]: "mask (len_of TYPE('a :: len)) = (-1 :: 'a word)"
by(simp add: mask_def word_pow_0)

lemma set_bit_beyond: fixes x :: "'a :: len0 word" shows
  "size x \<le> n \<Longrightarrow> set_bit x n b = x"
by(auto intro: word_eqI simp add: test_bit_set_gen word_size)

lemma word_of_int_code [code abstract]:
  "uint (word_of_int x :: 'a word) = x AND bin_mask (len_of TYPE('a :: len0))"
by(simp add: uint_word_of_int and_bin_mask_conv_mod)

context begin interpretation lifting_syntax .

lemma shiftl_transfer [transfer_rule]:
  "(pcr_word ===> op = ===> pcr_word) op << op <<"
by(auto intro!: rel_funI word_eqI simp add: word.pcr_cr_eq cr_word_def word_size nth_shiftl)

end

lemma set_bits_K_False [simp]: "set_bits (\<lambda>_. False) = (0 :: 'a :: len0 word)"
by(rule word_eqI)(simp add: test_bit.eq_norm)

lemma test_bit_1' [simp]: "(1 :: 'a :: len0 word) !! n \<longleftrightarrow> 0 < len_of TYPE('a) \<and> n = 0"
by(cases n)(simp_all only: one_word_def test_bit_wi bin_nth.simps, simp_all)

lemma mask_0 [simp]: "mask 0 = 0"
by(simp add: Word.mask_def)

lemma shiftl0 [simp]: "x << 0 = (x :: 'a :: len0 word)"
by (metis shiftl_rev shiftr_x_0 word_rev_gal)

lemma mask_1: "mask 1 = 1"
by(simp add: mask_def)

lemma mask_Suc_0: "mask (Suc 0) = 1"
by(simp add: mask_def)

lemma mask_numeral: "mask (numeral n) = 2 * mask (pred_numeral n) + 1"
unfolding mask_def by transfer(simp, simp add: shiftl_int_def)

lemma bin_last_bintrunc: "bin_last (bintrunc l n) = (l > 0 \<and> bin_last n)"
by(cases l) simp_all

lemma word_and_1:
  fixes n :: "_ word"
  shows "n AND 1 = (if n !! 0 then 1 else 0)"
by transfer(rule bin_rl_eqI, simp_all add: bin_rest_trunc bin_last_bintrunc)

lemma bintrunc_shiftl: "bintrunc n (m << i) = bintrunc (n - i) m << i"
proof(induct i arbitrary: n)
  case (Suc i)
  thus ?case by(cases n) simp_all
qed simp

lemma uint_shiftl: "uint (n << i) = bintrunc (size n) (uint n << i)"
unfolding word_size by transfer(simp add: bintrunc_shiftl)

context fixes f :: "nat \<Rightarrow> bool" begin

fun set_bits_aux :: "'a word \<Rightarrow> nat \<Rightarrow> 'a :: len0 word"
where
  "set_bits_aux w 0 = w"
| "set_bits_aux w (Suc n) = set_bits_aux ((w << 1) OR (if f n then 1 else 0)) n"

lemma set_bits_aux_conv: "set_bits_aux w n = (w << n) OR (set_bits f AND mask n)"
apply(induct w n rule: set_bits_aux.induct)
apply(auto 4 3 intro: word_eqI simp add: word_ao_nth nth_shiftl test_bit.eq_norm word_size not_less less_Suc_eq)
done

corollary set_bits_conv_set_bits_aux:
  "set_bits f = (set_bits_aux 0 (len_of TYPE('a)) :: 'a :: len word)"
by(simp add: set_bits_aux_conv)

end

lemma word_test_bit_set_bits: "(BITS n. f n :: 'a :: len0 word) !! n \<longleftrightarrow> n < len_of TYPE('a) \<and> f n"
by(auto simp add: word_set_bits_def test_bit_bl word_bl.Abs_inverse word_size)

lemma word_of_int_conv_set_bits: "word_of_int i = (BITS n. i !! n)"
by(rule word_eqI)(simp add: word_test_bit_set_bits)

text {*
  Division on @{typ "'a word"} is unsigned, but Scala and OCaml only have signed division and modulus.
*}
definition word_sdiv :: "'a :: len word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixl "sdiv" 70)
where [code]:
  "x sdiv y =
   (let x' = sint x; y' = sint y;
        negative = (x' < 0) \<noteq> (y' < 0);
        result = abs x' div abs y'
    in word_of_int (if negative then -result else result))"

definition word_smod :: "'a :: len word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixl "smod" 70)
where [code]:
  "x smod y =
   (let x' = sint x; y' = sint y;
        negative = (x' < 0);
        result = abs x' mod abs y'
    in word_of_int (if negative then -result else result))"

lemma sdiv_smod_id: "(a sdiv b) * b + (a smod b) = a"
proof -
  note [simp] = word_sdiv_def word_smod_def
  have F5: "\<forall>u::'a word. - (- u) = u" by (metis word_sint.Rep_inverse' minus_minus wi_hom_neg)
  have F7: "\<forall>v u::'a word. u + v = v + u" by(metis add.left_commute add_0_right)
  have F8: "\<forall>(w::'a word) (v::int) u::int. word_of_int u + word_of_int v * w = word_of_int (u + v * sint w)"
    by (metis word_sint.Rep_inverse wi_hom_syms(1) wi_hom_syms(3))
  have "\<exists>u. u = - sint b \<and> word_of_int (sint a mod u + - (- u * (sint a div u))) = a"
    using F5 by (metis minus_minus word_sint.Rep_inverse' mult_minus_left add.commute zmod_zdiv_equality)
  hence "word_of_int (sint a mod - sint b + - (sint b * (sint a div - sint b))) = a" by (metis equation_minus_iff)
  hence "word_of_int (sint a mod - sint b) + word_of_int (- (sint a div - sint b)) * b = a"
    using F8 by(metis mult.commute mult_minus_left)
  hence eq: "word_of_int (- (sint a div - sint b)) * b + word_of_int (sint a mod - sint b) = a" using F7 by metis

  show ?thesis
  proof(cases "sint a < 0")
    case True note a = this
    show ?thesis
    proof(cases "sint b < 0")
      case True
      with a show ?thesis
        by simp (metis F7 F8 eq minus_equation_iff minus_mult_minus semiring_div_class.mod_div_equality')
    next
      case False
      from eq have "word_of_int (- (- sint a div sint b)) * b + word_of_int (- (- sint a mod sint b)) = a"
        by (metis div_minus_right mod_minus_right)
      with a False show ?thesis by simp
    qed
  next
    case False note a = this
    show ?thesis
    proof(cases "sint b < 0")
      case True
      with a eq show ?thesis by simp
    next
      case False with a show ?thesis
        by simp (metis wi_hom_add wi_hom_mult add.commute mult.commute word_sint.Rep_inverse add.commute zmod_zdiv_equality)
    qed
  qed
qed

lemma nat_div_eq_Suc_0_iff: "n div m = Suc 0 \<longleftrightarrow> n \<ge> m \<and> n < 2 * (m :: nat)"
  apply (auto simp add: sdl)
  using not_less apply fastforce
  apply (metis One_nat_def Suc_1 div_eq_0_iff lessI neq0_conv td_gal_lt)
  done

lemma word_div_lt_eq_0:
  fixes x :: "'a :: len word"
  shows "x < y \<Longrightarrow> x div y = 0"
by(simp only: word_div_def zero_word_def uint_nat zdiv_int[symmetric] transfer_int_nat_numerals(1) word_less_def div_less)

lemma Suc_0_lt_2p_len_of: "Suc 0 < 2 ^ len_of TYPE('a :: len)"
by (metis One_nat_def len_gt_0 one_less_numeral_iff one_less_power semiring_norm(76))

lemma unat_p2: "n < len_of TYPE('a :: len) \<Longrightarrow> unat (2 ^ n :: 'a word) = 2 ^ n"
proof(induct n)
  case 0 thus ?case by simp
next
  case (Suc n)
  then obtain n' where "len_of TYPE('a) = Suc n'" by(cases "len_of TYPE('a)") simp_all
  with Suc show ?case by(simp add: unat_word_ariths bintrunc_mod2p int_mod_eq')
qed

lemma div_half_nat:
  fixes x y :: nat
  assumes "y \<noteq> 0"
  shows "(x div y, x mod y) = (let q = 2 * (x div 2 div y); r = x - q * y in if y \<le> r then (q + 1, r - y) else (q, r))"
proof -
  let ?q = "2 * (x div 2 div y)"
  have q: "?q = x div y - x div y mod 2"
    by(metis div_mult2_eq mult.commute mult_div_cancel)
  let ?r = "x - ?q * y"
  have r: "?r = x mod y + x div y mod 2 * y"
    by(simp add: q diff_mult_distrib div_mod_equality')(metis diff_diff_cancel mod_less_eq_dividend mod_mult2_eq add.commute mult.commute)

  show ?thesis
  proof(cases "y \<le> x - ?q * y")
    case True
    hence "x div y mod 2 \<noteq> 0" unfolding r
      by(metis Divides.mod_div_equality' True assms diff_is_0_eq div_le_mono mod_by_0 mod_div_trivial mod_self mod_simps(1) mult_div_cancel q)
    hence "x div y = ?q + 1" unfolding q
      by(metis le_add_diff_inverse mod_2_not_eq_zero_eq_one_nat mod_less_eq_dividend add.commute)
    moreover hence "x mod y = ?r - y"
      by simp(metis Divides.mod_div_equality' diff_commute diff_diff_left mult_Suc)
    ultimately show ?thesis using True by(simp add: Let_def)
  next
    case False
    hence "x div y mod 2 = 0" unfolding r
      by(simp add: not_le)(metis Nat.add_0_right assms div_less div_mult_self2 mod_div_trivial mult.commute)
    hence "x div y = ?q" unfolding q by simp
    moreover hence "x mod y = ?r" by (metis mod_div_equality')
    ultimately show ?thesis using False by(simp add: Let_def)
  qed
qed

lemma div_half_word:
  fixes x y :: "'a :: len word"
  assumes "y \<noteq> 0"
  shows "(x div y, x mod y) = (let q = (x >> 1) div y << 1; r = x - q * y in if y \<le> r then (q + 1, r - y) else (q, r))"
proof -
  obtain n where n: "x = of_nat n" "n < 2 ^ len_of TYPE('a)" by(cases x)
  obtain m where m: "y = of_nat m" "m < 2 ^ len_of TYPE('a)" by(cases y)
  let ?q = "(x >> 1) div y << 1"
  let ?q' = "2 * (n div 2 div m)"
  have "n div 2 div m < 2 ^ len_of TYPE('a)" using n by (metis of_nat_inverse unat_lt2p uno_simps(2))
  hence q: "?q = of_nat ?q'" using n m
    apply(simp add: shiftr_def shiftr1_def bin_rest_def uint_nat unat_of_nat shiftl_def shiftl1_def Bit_def word_div_def word_of_nat)
by (metis of_nat_inverse of_nat_numeral uno_simps(2) word_of_nat zdiv_int of_nat_mult)

  from assms have "m \<noteq> 0" using m by -(rule notI, simp)

  from n have "2 * (n div 2 div m) < 2 ^ len_of TYPE('a)"
    by(metis mult.commute div_mult2_eq mult_div_cancel less_imp_diff_less of_nat_inverse unat_lt2p uno_simps(2))
  moreover
  have "2 * (n div 2 div m) * m < 2 ^ len_of TYPE('a)" using n unfolding div_mult2_eq[symmetric]
    by(subst (2) mult.commute)(simp add: div_mod_equality' diff_mult_distrib mult_div_cancel div_mult2_eq)
  moreover have "2 * (n div 2 div m) * m \<le> n"
    by(metis div_mult2_eq div_mult_le mult.assoc mult.commute)
  ultimately
  have r: "x - ?q * y = of_nat (n - ?q' * m)"
    and "y \<le> x - ?q * y \<Longrightarrow> of_nat (n - ?q' * m) - y = of_nat (n - ?q' * m - m)"
    using n m unfolding q
    by(simp_all add: word_sub_wi word_mult_def uint_nat unat_of_nat of_nat_mult [symmetric] word_of_nat[symmetric] zdiff_int word_le_nat_alt del: of_nat_mult)
  thus ?thesis using n m div_half_nat[OF `m \<noteq> 0`, of n] unfolding q
    by(simp add: word_le_nat_alt word_div_def word_mod_def uint_nat unat_of_nat zmod_int[symmetric] zdiv_int[symmetric] word_of_nat[symmetric])(simp add: Let_def split del: split_if split: if_split_asm)
qed

lemma word_div_eq_1_iff: "n div m = 1 \<longleftrightarrow> n \<ge> m \<and> unat n < 2 * unat (m :: 'a :: len word)"
apply(simp only: word_arith_nat_defs word_le_nat_alt nat_div_eq_Suc_0_iff[symmetric])
apply(rule word_unat.Abs_inject)
 apply(simp only: unat_div[symmetric] word_unat.Rep)
apply(simp add: unats_def Suc_0_lt_2p_len_of)
done

text {*
  This algorithm implements unsigned division in terms of signed division.
  Taken from Hacker's Delight.
*}

lemma divmod_via_sdivmod:
  fixes x y :: "'a :: len word"
  assumes "y \<noteq> 0"
  shows
  "(x div y, x mod y) =
  (if 1 << (len_of TYPE('a) - 1) \<le> y then if x < y then (0, x) else (1, x - y)
   else let q = ((x >> 1) sdiv y) << 1;
            r = x - q * y
        in if r \<ge> y then (q + 1, r - y) else (q, r))"
proof(cases "1 << (len_of TYPE('a) - 1) \<le> y")
  case True
  note y = this
  show ?thesis
  proof(cases "x < y")
    case True
    hence "x mod y = x"
      by(cases x)(cases y, simp add: word_mod_def uint_nat unat_of_nat zmod_int[symmetric] word_of_nat[symmetric] mod_less word_less_nat_alt)
    thus ?thesis using True y by(simp add: word_div_lt_eq_0)
  next
    case False
    obtain n where n: "y = of_nat n" "n < 2 ^ len_of TYPE('a)" by(cases y)
    have "unat x < 2 ^ len_of TYPE('a)" by(rule unat_lt2p)
    also have "\<dots> = 2 * 2 ^ (len_of TYPE('a) - 1)"
      by(metis Suc_pred len_gt_0 power_Suc One_nat_def)
    also have "\<dots> \<le> 2 * n" using y n
      by(simp add: word_le_nat_alt unat_of_nat unat_p2)
    finally have div: "x div of_nat n = 1" using False n
      by(simp add: word_div_eq_1_iff not_less word_le_nat_alt unat_of_nat)
    moreover have "x mod y = x - x div y * y"
      by (metis add_diff_cancel2 word_mod_div_equality)
    with div n have "x mod y = x - y" by simp
    ultimately show ?thesis using False y n by simp
  qed
next
  case False
  note y = this
  obtain n where n: "x = of_nat n" "n < 2 ^ len_of TYPE('a)" by(cases x)
  hence "int n div 2 + 2 ^ (len_of TYPE('a) - Suc 0) < 2 ^ len_of TYPE('a)"
    by(cases "len_of TYPE('a)")(simp_all, simp only: int_numeral[symmetric] zdiv_int[symmetric] of_nat_power [symmetric])
  with y n have "sint (x >> 1) = uint (x >> 1)"
    by(simp add: sint_uint sbintrunc_mod2p shiftr_div_2n)(simp add: int_mod_eq' uint_nat unat_of_nat)
  moreover have "uint y + 2 ^ (len_of TYPE('a) - Suc 0) < 2 ^ len_of TYPE('a)" using y
    by(cases "len_of TYPE('a)")(simp_all add: not_le, metis lessI word_2p_lem word_less_def word_size)
  hence "sint y = uint y" by(simp add: sint_uint sbintrunc_mod2p int_mod_eq')
  ultimately show ?thesis using y
    by(subst div_half_word[OF assms])(simp add: word_sdiv_def uint_div[symmetric])
qed

lemma word_of_int_via_signed:
  fixes mask
  assumes mask_def: "mask = bin_mask (len_of TYPE('a))"
  and shift_def: "shift = 1 << len_of TYPE('a)"
  and index_def: "index = len_of TYPE('a) - 1"
  and overflow_def:"overflow = 1 << (len_of TYPE('a) - 1)"
  and least_def: "least = - overflow"
  shows
  "(word_of_int i :: 'a :: len word) =
   (let i' = i AND mask
    in if i' !! index then
         if i' - shift < least \<or> overflow \<le> i' - shift then arbitrary1 i' else word_of_int (i' - shift)
       else if i' < least \<or> overflow \<le> i' then arbitrary2 i' else word_of_int i')"
proof -
  def i' \<equiv> "i AND mask"
  have "shift = mask + 1" unfolding assms by(simp add: bin_mask_p1_conv_shift)
  hence "i' < shift" by(simp add: mask_def i'_def int_and_le)
  show ?thesis
  proof(cases "i' !! index")
    case True
    hence unf: "i' = overflow OR i'" unfolding assms i'_def
      by(auto intro!: bin_eqI simp add: bin_nth_ops)
    have "overflow \<le> i'" by(subst unf)(rule le_int_or, simp add: bin_sign_and assms i'_def)
    hence "i' - shift < least \<longleftrightarrow> False" unfolding assms
      by(cases "len_of TYPE('a)")(simp_all add: not_less Bit_def)
    moreover
    have "overflow \<le> i' - shift \<longleftrightarrow> False" using `i' < shift` unfolding assms
      by(cases "len_of TYPE('a)")(auto simp add: not_le Bit_def elim: less_le_trans)
    moreover
    have "word_of_int (i' - shift) = (word_of_int i :: 'a word)" using `i' < shift`
      by(auto intro!: word_eqI simp add: i'_def shift_def mask_def bin_nth_ops bin_nth_minus_p2 bin_sign_and)
    ultimately show ?thesis using True by(simp add: Let_def i'_def)
  next
    case False
    hence "i' = i AND bin_mask (len_of TYPE('a) - 1)" unfolding assms i'_def
      by(clarsimp simp add: i'_def bin_nth_ops intro!: bin_eqI)(cases "len_of TYPE('a)", auto simp add: less_Suc_eq)
    also have "\<dots> \<le> bin_mask (len_of TYPE('a) - 1)" by(rule int_and_le) simp
    also have "\<dots> < overflow" unfolding overflow_def
      by(simp add: bin_mask_p1_conv_shift[symmetric])
    also
    have "least \<le> 0" unfolding least_def overflow_def by simp
    have "0 \<le> i'" by(simp add: i'_def mask_def bin_mask_ge0)
    hence "least \<le> i'" using `least \<le> 0` by simp
    moreover
    have "word_of_int i' = (word_of_int i :: 'a word)"
      by(rule word_eqI)(auto simp add: i'_def bin_nth_ops mask_def)
    ultimately show ?thesis using False by(simp add: Let_def i'_def)
  qed
qed

lemma word_and_mask_or_conv_and_mask:
  "n !! index \<Longrightarrow> (n AND mask index) OR (1 << index) = n AND mask (index + 1)"
by(rule word_eqI)(auto simp add: word_ao_nth word_size nth_shiftl simp del: shiftl_1)

lemma uint_and_mask_or_full:
  fixes n :: "'a :: len word"
  assumes "n !! (len_of TYPE('a) - 1)"
  and "mask1 = mask (len_of TYPE('a) - 1)"
  and "mask2 = 1 << len_of TYPE('a) - 1"
  shows "uint (n AND mask1) OR mask2 = uint n"
proof -
  have "mask2 = uint (1 << len_of TYPE('a) - 1 :: 'a word)" using assms
    by(simp add: uint_shiftl word_size bintrunc_shiftl del: shiftl_1)(metis One_nat_def Suc_diff_Suc bintrunc_minus bintrunc_shiftl diff_self_eq_0 len_gt_0 len_num1 lessI uint_1 uint_word_arith_bintrs(8))
  hence "uint (n AND mask1) OR mask2 = uint (n AND mask1 OR (1 << len_of TYPE('a) - 1 :: 'a word))"
    by(simp add: uint_or)
  also have "\<dots> = uint (n AND mask (len_of TYPE('a) - 1 + 1))"
    using assms by(simp only: word_and_mask_or_conv_and_mask)
  also have "\<dots> = uint n" by simp
  finally show ?thesis .
qed

section {* Quickcheck conversion functions *}

notation scomp (infixl "\<circ>\<rightarrow>" 60)

definition qc_random_cnv ::
  "(natural \<Rightarrow> 'a::term_of) \<Rightarrow> natural \<Rightarrow> Random.seed
    \<Rightarrow> ('a \<times> (unit \<Rightarrow> Code_Evaluation.term)) \<times> Random.seed"
  where "qc_random_cnv a_of_natural i = Random.range (i + 1) \<circ>\<rightarrow> (\<lambda>k. Pair (
       let n = a_of_natural k
       in (n, \<lambda>_. Code_Evaluation.term_of n)))"

no_notation scomp (infixl "\<circ>\<rightarrow>" 60)

definition qc_exhaustive_cnv :: "(natural \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> (bool \<times> term list) option)
  \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
where
  "qc_exhaustive_cnv a_of_natural f d =
   Quickcheck_Exhaustive.exhaustive (%x. f (a_of_natural x)) d"

definition qc_full_exhaustive_cnv ::
  "(natural \<Rightarrow> ('a::term_of)) \<Rightarrow> ('a \<times> (unit \<Rightarrow> term) \<Rightarrow> (bool \<times> term list) option)
  \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
where
  "qc_full_exhaustive_cnv a_of_natural f d = Quickcheck_Exhaustive.full_exhaustive
  (%(x, xt). f (a_of_natural x, %_. Code_Evaluation.term_of (a_of_natural x))) d"

declare [[quickcheck_narrowing_ghc_options = "-XTypeSynonymInstances"]]

definition qc_narrowing_drawn_from :: "'a list \<Rightarrow> integer \<Rightarrow> _"
where
  "qc_narrowing_drawn_from xs =
   foldr Quickcheck_Narrowing.sum (map Quickcheck_Narrowing.cons (butlast xs)) (Quickcheck_Narrowing.cons (last xs))"

locale quickcheck_narrowing_samples =
  fixes a_of_integer :: "integer \<Rightarrow> 'a \<times> 'a :: {partial_term_of, term_of}"
  and zero :: "'a"
  and tr :: "typerep"
begin

function narrowing_samples :: "integer \<Rightarrow> 'a list"
where
  "narrowing_samples i =
   (if i > 0 then let (a, a') = a_of_integer i in narrowing_samples (i - 1) @ [a, a'] else [zero])"
by pat_completeness auto
termination including integer.lifting
proof(relation "measure nat_of_integer")
  fix i :: integer
  assume "0 < i"
  thus "(i - 1, i) \<in> measure nat_of_integer"
    by simp(transfer, simp)
qed simp

definition partial_term_of_sample :: "integer \<Rightarrow> 'a"
where
  "partial_term_of_sample i =
  (if i < 0 then undefined
   else if i = 0 then zero
   else if i mod 2 = 0 then snd (a_of_integer (i div 2))
   else fst (a_of_integer (i div 2 + 1)))"

lemma partial_term_of_code:
  "partial_term_of (ty :: 'a itself) (Quickcheck_Narrowing.Narrowing_variable p t) \<equiv>
    Code_Evaluation.Free (STR ''_'') tr"
  "partial_term_of (ty :: 'a itself) (Quickcheck_Narrowing.Narrowing_constructor i []) \<equiv>
   Code_Evaluation.term_of (partial_term_of_sample i)"
by (rule partial_term_of_anything)+

end

lemmas [code] =
  quickcheck_narrowing_samples.narrowing_samples.simps
  quickcheck_narrowing_samples.partial_term_of_sample_def

end


header {* \isaheader{Set Implementation by Arrays} *}
theory ArraySetImpl
imports
  "../spec/SetSpec"
  "ArrayMapImpl"
  "../gen_algo/SetByMap"
  "../gen_algo/SetGA"
begin
text_raw {*\label{thy:ArraySetImpl}*}

(*@impl Set
  @type ias
  @abbrv ias,is
  Sets of natural numbers implemented by arrays.
*)

subsection "Definitions"
type_synonym ias = "(unit) iam"

setup Locale_Code.open_block
interpretation ias_sbm!: OSetByOMap iam_basic_ops by unfold_locales
setup Locale_Code.close_block
definition ias_ops :: "(nat,ias) oset_ops"
  where [icf_rec_def]:
  "ias_ops \<equiv> ias_sbm.obasic.dflt_oops"

setup Locale_Code.open_block
interpretation ias!: StdOSet ias_ops
  unfolding ias_ops_def by (rule ias_sbm.obasic.dflt_oops_impl)
interpretation ias!: StdSet_no_invar ias_ops
  by unfold_locales (simp add: icf_rec_unf SetByMapDefs.invar_def)
setup Locale_Code.close_block

setup {* ICF_Tools.revert_abbrevs "ias"*}

lemmas ias_it_to_it_map_code_unfold[code_unfold] =
  it_to_it_map_fold'[OF pi_iam]
  it_to_it_map_fold'[OF pi_iam_rev]

lemma pi_ias[proper_it]:
  "proper_it' ias.iteratei ias.iteratei"
  "proper_it' ias.iterateoi ias.iterateoi"
  "proper_it' ias.rev_iterateoi ias.rev_iterateoi"
  unfolding ias.iteratei_def[abs_def] ias.iterateoi_def[abs_def]
    ias.rev_iterateoi_def[abs_def]
  apply (rule proper_it'I icf_proper_iteratorI)+
  done

interpretation
  pi_ias: proper_it_loc ias.iteratei ias.iteratei +
  pi_ias_o: proper_it_loc ias.iterateoi ias.iterateoi +
  pi_ias_ro: proper_it_loc ias.rev_iterateoi ias.rev_iterateoi
  apply unfold_locales by (rule pi_ias)+

definition test_codegen where "test_codegen \<equiv> (
  ias.empty,
  ias.memb,
  ias.ins,
  ias.delete,
  ias.list_it,
  ias.sng,
  ias.isEmpty,
  ias.isSng,
  ias.ball,
  ias.bex,
  ias.size,
  ias.size_abort,
  ias.union,
  ias.union_dj,
  ias.diff,
  ias.filter,
  ias.inter,
  ias.subset,
  ias.equal,
  ias.disjoint,
  ias.disjoint_witness,
  ias.sel,
  ias.to_list,
  ias.from_list,

  ias.ordered_list_it,
  ias.rev_list_it,
  ias.min,
  ias.max,
  ias.to_sorted_list,
  ias.to_rev_list
)"

export_code test_codegen in SML

end


theory IHT_Dynamic_Array_More
imports IHT_Dynamic_Array "../Asymptotics/Asymptotics_1D"
begin

fun dyn_array_P' :: "'a::heap list \<times> nat \<Rightarrow> nat" where
  "dyn_array_P' (xs, n) = 4 * n"
setup \<open>add_rewrite_rule @{thm dyn_array_P'.simps}\<close>

lemma dyn_array_new_P' [rewrite]:
  "dyn_array_P' (replicate 5 0, 0) = 0" by auto2

lemma dyn_array_double_length_P' [rewrite]:
  "dyn_array_P' (double_length_fun (xs, n)) = dyn_array_P' (xs, n)" by auto2

lemma dyn_array_push_array_basic_P' [resolve]:
  "n \<le> length xs \<Longrightarrow>
   dyn_array_P' (xs, n) + 16 \<ge>\<^sub>t dyn_array_P' (push_array_basic_fun x (xs, n)) + 12" by auto2

lemma update_P' [rewrite]:
  "i < n \<Longrightarrow> dyn_array_P' (list_update xs i x, n) = dyn_array_P' (xs, n)" by auto2

lemma dyn_array_destroy_P' [resolve]:
  "dyn_array_P' (xs, n) + 3 \<ge>\<^sub>t 4 * n + 3" by auto2

setup \<open>del_prfstep_thm @{thm dyn_array_P'.simps}\<close>

fun dyn_array'' :: "'a::heap list \<times> nat \<Rightarrow> 'a dynamic_array \<Rightarrow> assn" where
  "dyn_array'' (xs, n) r = dyn_array' (xs, n) r * $(dyn_array_P' (xs, n))"
setup \<open>add_rewrite_ent_rule @{thm dyn_array''.simps}\<close>

lemma dyn_array_new_rule'' [hoare_triple]:
  "<$7>
   dyn_array_new
   <dyn_array'' (replicate 5 0, 0)>\<^sub>t"
@proof
  @have "7 \<ge>\<^sub>t 7 + dyn_array_P' (replicate 5 0, 0)"
@qed

lemma double_length_rule'' [hoare_triple]:
  "length xs = n \<Longrightarrow>
   <dyn_array'' (xs, n) p * $5>
   double_length p
   <dyn_array'' (double_length_fun (xs, n))>\<^sub>t"
@proof
  @have "dyn_array_P' (xs, n) + 5 \<ge>\<^sub>t dyn_array_P' (double_length_fun (xs, n)) + 5"
@qed

lemma push_array_basic_rule'' [hoare_triple]:
  "n < length xs \<Longrightarrow>
   <dyn_array'' (xs, n) p * $16>
    push_array_basic x p
   <dyn_array'' (list_update xs n x, n + 1)>\<^sub>t"
@proof
  @have "dyn_array_P' (xs, n) + 16 \<ge>\<^sub>t dyn_array_P' (push_array_basic_fun x (xs, n)) + 12"
@qed

lemma array_length_rule'' [hoare_triple]:
  "<dyn_array'' (xs, n) p * $1>
   array_length p
   <\<lambda>r. dyn_array'' (xs, n) p * \<up>(r = n)>" by auto2

lemma array_max_rule'' [hoare_triple]:
  "<dyn_array'' (xs, n) p * $1>
   array_max p
   <\<lambda>r. dyn_array'' (xs, n) p * \<up>(r = length xs)>" by auto2

lemma array_nth_rule'' [hoare_triple]:
  "i < n \<Longrightarrow> n \<le> length xs \<Longrightarrow>
   <dyn_array'' (xs, n) p * $1>
   array_nth p i
   <\<lambda>r. dyn_array'' (xs, n) p * \<up>(r = xs ! i)>" by auto2

lemma array_upd_rule'' [hoare_triple]:
  "i < n \<Longrightarrow> n \<le> length xs \<Longrightarrow>
   <dyn_array'' (xs, n) p * $2>
   array_upd i x p
   <\<lambda>_. dyn_array'' (list_update xs i x, n) p>" by auto2

lemma destroy_rule'' [hoare_triple]:
  "n \<le> length xs \<Longrightarrow>
   <dyn_array'' (xs, n) d * $3>
   destroy d
   <\<lambda>r. r \<mapsto>\<^sub>a take n xs>\<^sub>t"
@proof
  @have "dyn_array_P' (xs, n) + 3 \<ge>\<^sub>t 4 * n + 3"
@qed

setup \<open>del_prfstep_thm @{thm dyn_array''.simps}\<close>

section \<open>Derived operations\<close>

lemma push_array_rule'' [hoare_triple]:
  "n \<le> length xs \<Longrightarrow>
   <dyn_array'' (xs, n) p * $23>
   push_array x p
   <dyn_array'' (push_array_fun x (xs, n))>\<^sub>t" by auto2

section \<open>Abstract assertion\<close>

fun abs_array :: "'a::heap list \<times> nat \<Rightarrow> 'a list" where
  "abs_array (xs, n) = take n xs"
setup \<open>add_rewrite_rule @{thm abs_array.simps}\<close>

lemma double_length_abs [rewrite]:
  "length xs = n \<Longrightarrow> abs_array (double_length_fun (xs, n)) = abs_array (xs, n)" by auto2

lemma push_array_basic_abs [rewrite]:
  "n < length xs \<Longrightarrow> abs_array (push_array_basic_fun x (xs, n)) = abs_array (xs, n) @ [x]"
@proof @have "length (take n xs @ [x]) = n + 1" @qed

lemma push_array_fun_abs [rewrite]:
  "n \<le> length xs \<Longrightarrow> abs_array (push_array_fun x (xs, n)) = abs_array (xs, n) @ [x]" by auto2

definition dyn_array :: "'a::heap list \<Rightarrow> 'a dynamic_array \<Rightarrow> assn" where [rewrite_ent]:
  "dyn_array xs a = (\<exists>\<^sub>Ap. dyn_array'' p a * \<up>(snd p \<le> length (fst p)) * \<up>(xs = abs_array p))"

lemma dyn_array_new_rule [hoare_triple]:
  "<$7>
   dyn_array_new
   <dyn_array []>\<^sub>t" by auto2

lemma array_length_rule [hoare_triple]:
  "<dyn_array xs p * $1>
    array_length p
   <\<lambda>r. dyn_array xs p * \<up>(r = length xs)>" by auto2

lemma array_nth_rule [hoare_triple]:
  "i < length xs \<Longrightarrow>
   <dyn_array xs p * $1>
    array_nth p i
   <\<lambda>r. dyn_array xs p * \<up>(r = xs ! i)>" by auto2

lemma array_upd_rule [hoare_triple]:
  "i < length xs \<Longrightarrow>
   <dyn_array xs p * $2>
    array_upd i x p
   <\<lambda>_. dyn_array (list_update xs i x) p>" by auto2

lemma push_array_rule [hoare_triple]:
  "<dyn_array xs p * $23>
    push_array x p
   <dyn_array (xs @ [x])>\<^sub>t" by auto2

lemma destroy_rule [hoare_triple]:
  "<dyn_array xs p * $3>
    destroy p
   <\<lambda>r. r \<mapsto>\<^sub>a xs>\<^sub>t" by auto2

setup \<open>del_simple_datatype "dynamic_array"\<close>
setup \<open>del_prfstep_thm @{thm dyn_array_def}\<close>

section \<open>More operations\<close>

definition array_swap :: "'a::heap dynamic_array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> unit Heap" where
  "array_swap d i j = do {
    x \<leftarrow> array_nth d i;
    y \<leftarrow> array_nth d j;
    array_upd i y d;
    array_upd j x d;
    return ()
   }"

lemma array_swap_rule [hoare_triple]:
  "i < length xs \<Longrightarrow> j < length xs \<Longrightarrow>
   <dyn_array xs p * $7>
   array_swap p i j
   <\<lambda>_. dyn_array (list_swap xs i j) p>" by auto2

text \<open>Filter with dynamic array\<close>

fun dfilter_aux_fun :: "'a list \<Rightarrow> nat \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a list" where
  "dfilter_aux_fun xs 0 P = []"
| "dfilter_aux_fun xs (Suc n) P = (
     if P (xs ! n)
     then dfilter_aux_fun xs n P @ [xs ! n]
     else dfilter_aux_fun xs n P)"
setup \<open>fold add_rewrite_rule @{thms dfilter_aux_fun.simps}\<close>

lemma dfilter_aux_fun_ind [rewrite]:
  "i \<le> length xs \<Longrightarrow> dfilter_aux_fun xs i P = filter P (take i xs)"
  by (induct i) (auto simp add: take_Suc_conv_app_nth)

lemma filtertake_Suc [rewrite]:
  "i < length xs \<Longrightarrow> P (xs !i) \<Longrightarrow> filter P (take (Suc i) xs) = filter P (take i xs) @ [xs ! i]"
  "i < length xs \<Longrightarrow> ~ P (xs !i) \<Longrightarrow> filter P (take (Suc i) xs) = filter P (take i xs)"
  by (auto simp add: take_Suc_conv_app_nth)

fun dfilter_aux :: "('a::{zero,heap}) array \<Rightarrow> 'a dynamic_array \<Rightarrow> nat \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a dynamic_array Heap" where
  "dfilter_aux a d 0 P = return d"
| "dfilter_aux a d (Suc i) P = do {
     d' \<leftarrow> dfilter_aux a d i P;
     x \<leftarrow> Array_Time.nth a i;
     if P x then push_array x d' else return d'
   }"

lemma dfilter_aux_rule [hoare_triple]:
  "i \<le> length xs \<Longrightarrow>
   <a \<mapsto>\<^sub>a xs * dyn_array [] d * $(i * 24 + 1)>
    dfilter_aux a d i P
   <\<lambda>r. a \<mapsto>\<^sub>a xs * dyn_array (filter P (take i xs)) r>\<^sub>t"
@proof @induct i @qed

definition dfilter_impl :: "'a::{zero,heap} array \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a dynamic_array Heap" where
  "dfilter_impl a P = do {
     d \<leftarrow> dyn_array_new;
     alen \<leftarrow> Array_Time.len a;
     dfilter_aux a d alen P
   }"

definition dfilter_impl_time :: "nat \<Rightarrow> nat" where [rewrite]:
  "dfilter_impl_time l = 8 + 1 + (24 * l + 1)"

lemma dfilter_impl_rule[hoare_triple]:
  "<a \<mapsto>\<^sub>a xs * $(dfilter_impl_time (length xs))>
    dfilter_impl a P
   <\<lambda>r. a \<mapsto>\<^sub>a xs * dyn_array (filter P xs) r>\<^sub>t" by auto2

lemma dfilter_impl_time_bound [asym_bound]: "(\<lambda>n. dfilter_impl_time n) \<in> \<Theta>(\<lambda>n. n)"
  unfolding dfilter_impl_time_def by auto2

setup \<open>del_prfstep_thm @{thm dfilter_impl_time_def}\<close>

end


section \<open>Memoization\label{sec:memo}\<close>

theory Optimal_BST_Memo
imports
  Optimal_BST
  "Monad_Memo_DP.State_Main"
  "HOL-Library.Product_Lexorder"
  "HOL-Library.RBT_Mapping"
  Optimal_BST_Examples
begin

text \<open>This theory memoizes the recursive algorithms with the help of our generic memoization
framework. Note that currently only the tree building (function @{const Optimal_BST.opt_bst}) is memoized but not the computation of \<open>w\<close>.\<close>

global_interpretation Wpl
where a = a and b = b for a b
defines w_ab = w and wpl_ab = "wpl.wpl w_ab" .

text \<open>First we express @{const argmin} via @{const fold}.
Primarily because we have a monadic version of @{const fold} already.
At the same time we improve efficiency.\<close>

lemma fold_argmin: "fold (\<lambda>x (m,fm). let fx = f x in if fx \<le> fm then (x,fx) else (m,fm)) xs (x,f x)
 = (argmin f (x#xs), f(argmin f (x#xs)))"
by (induction xs arbitrary: x) (auto simp: Let_def split: prod.split)

lemma argmin_fold: "argmin f xs = (case xs of [] \<Rightarrow> undefined |
  x#xs \<Rightarrow> fst(fold (\<lambda>x (m,fm). let fx = f x in if fx \<le> fm then (x,fx) else (m,fm)) xs (x,f x)))"
apply(auto simp:fold_argmin split: list.split)
apply (meson argmin.elims list.distinct(1))
done

text \<open>The actual memoization of the cubic algorithm:\<close>

context Optimal_BST
begin

memoize_fun opt_bst\<^sub>m: opt_bst with_memory dp_consistency_mapping
monadifies (state) opt_bst.simps[unfolded argmin_fold]
(* FIXME why not argmin_argmin2? memoize_prover breaks!
How about opt_bst_wpl?
*)
thm opt_bst\<^sub>m'.simps

memoize_correct
by memoize_prover

lemmas [code] = opt_bst\<^sub>m.memoized_correct

end

text \<open>Code generation:\<close>

global_interpretation Optimal_BST
where w = "w_ab a b"
rewrites "wpl.wpl (w_ab a b) = wpl_ab a b" for a b
defines opt_bst_ab = opt_bst and opt_bst_ab' = opt_bst\<^sub>m'
by(simp add: wpl_ab_def)

text \<open>Examples:\<close>

lemma "opt_bst_ab a_ex1 b_ex1 0 3 = t_opt_ex1"
by eval

lemma "opt_bst_ab a_ex2 b_ex2 0 13 = t_opt_ex2"
by eval

end