(*  Title:      HOL/Auth/Kerberos_BAN_Gets.thy
    Author:     Giampaolo Bella, Catania University
*)

section\<open>The Kerberos Protocol, BAN Version, with Gets event\<close>

theory Kerberos_BAN_Gets imports Public begin

text\<open>From page 251 of
  Burrows, Abadi and Needham (1989).  A Logic of Authentication.
  Proc. Royal Soc. 426

  Confidentiality (secrecy) and authentication properties rely on
  temporal checks: strong guarantees in a little abstracted - but
  very realistic - model.
\<close>

(* Temporal modelization: session keys can be leaked
                          ONLY when they have expired *)

consts

    (*Duration of the session key*)
    sesKlife   :: nat

    (*Duration of the authenticator*)
    authlife :: nat

text\<open>The ticket should remain fresh for two journeys on the network at least\<close>
text\<open>The Gets event causes longer traces for the protocol to reach its end\<close>
specification (sesKlife)
  sesKlife_LB [iff]: "4 \<le> sesKlife"
    by blast

text\<open>The authenticator only for one journey\<close>
text\<open>The Gets event causes longer traces for the protocol to reach its end\<close>
specification (authlife)
  authlife_LB [iff]:    "2 \<le> authlife"
    by blast

abbreviation
  CT :: "event list=>nat" where
  "CT == length"

abbreviation
  expiredK :: "[nat, event list] => bool" where
  "expiredK T evs == sesKlife + T < CT evs"

abbreviation
  expiredA :: "[nat, event list] => bool" where
  "expiredA T evs == authlife + T < CT evs"

definition
 (* Yields the subtrace of a given trace from its beginning to a given event *)
  before :: "[event, event list] => event list" ("before _ on _")
  where "before ev on evs = takeWhile (% z. z ~= ev) (rev evs)"

definition
 (* States than an event really appears only once on a trace *)
  Unique :: "[event, event list] => bool" ("Unique _ on _")
  where "Unique ev on evs = (ev \<notin> set (tl (dropWhile (% z. z \<noteq> ev) evs)))"

inductive_set bankerb_gets :: "event list set"
 where

   Nil:  "[] \<in> bankerb_gets"

 | Fake: "\<lbrakk> evsf \<in> bankerb_gets;  X \<in> synth (analz (knows Spy evsf)) \<rbrakk>
          \<Longrightarrow> Says Spy B X # evsf \<in> bankerb_gets"

 | Reception: "\<lbrakk> evsr\<in> bankerb_gets; Says A B X \<in> set evsr \<rbrakk>
                \<Longrightarrow> Gets B X # evsr \<in> bankerb_gets"

 | BK1:  "\<lbrakk> evs1 \<in> bankerb_gets \<rbrakk>
          \<Longrightarrow> Says A Server \<lbrace>Agent A, Agent B\<rbrace> # evs1
                \<in>  bankerb_gets"

 | BK2:  "\<lbrakk> evs2 \<in> bankerb_gets;  Key K \<notin> used evs2; K \<in> symKeys;
             Gets Server \<lbrace>Agent A, Agent B\<rbrace> \<in> set evs2 \<rbrakk>
          \<Longrightarrow> Says Server A
                (Crypt (shrK A)
                   \<lbrace>Number (CT evs2), Agent B, Key K,
                    (Crypt (shrK B) \<lbrace>Number (CT evs2), Agent A, Key K\<rbrace>)\<rbrace>)
                # evs2 \<in> bankerb_gets"

 | BK3:  "\<lbrakk> evs3 \<in> bankerb_gets;
             Gets A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)
               \<in> set evs3;
             Says A Server \<lbrace>Agent A, Agent B\<rbrace> \<in> set evs3;
             \<not> expiredK Tk evs3 \<rbrakk>
          \<Longrightarrow> Says A B \<lbrace>Ticket, Crypt K \<lbrace>Agent A, Number (CT evs3)\<rbrace> \<rbrace>
               # evs3 \<in> bankerb_gets"

 | BK4:  "\<lbrakk> evs4 \<in> bankerb_gets;
             Gets B \<lbrace>(Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>),
                         (Crypt K \<lbrace>Agent A, Number Ta\<rbrace>) \<rbrace>: set evs4;
             \<not> expiredK Tk evs4;  \<not> expiredA Ta evs4 \<rbrakk>
          \<Longrightarrow> Says B A (Crypt K (Number Ta)) # evs4
                \<in> bankerb_gets"

        (*Old session keys may become compromised*)
 | Oops: "\<lbrakk> evso \<in> bankerb_gets;
         Says Server A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)
               \<in> set evso;
             expiredK Tk evso \<rbrakk>
          \<Longrightarrow> Notes Spy \<lbrace>Number Tk, Key K\<rbrace> # evso \<in> bankerb_gets"

declare Says_imp_knows_Spy [THEN parts.Inj, dest]
declare parts.Body [dest]
declare analz_into_parts [dest]
declare Fake_parts_insert_in_Un [dest]
declare knows_Spy_partsEs [elim]

text\<open>A "possibility property": there are traces that reach the end.\<close>
lemma "\<lbrakk>Key K \<notin> used []; K \<in> symKeys\<rbrakk>
       \<Longrightarrow> \<exists>Timestamp. \<exists>evs \<in> bankerb_gets.
             Says B A (Crypt K (Number Timestamp))
                  \<in> set evs"
apply (cut_tac sesKlife_LB)
apply (cut_tac authlife_LB)
apply (intro exI bexI)
apply (rule_tac [2]
           bankerb_gets.Nil [THEN bankerb_gets.BK1, THEN bankerb_gets.Reception,
                            THEN bankerb_gets.BK2, THEN bankerb_gets.Reception,
                            THEN bankerb_gets.BK3, THEN bankerb_gets.Reception,
                            THEN bankerb_gets.BK4])
apply (possibility, simp_all (no_asm_simp) add: used_Cons)
done

text\<open>Lemmas about reception invariant: if a message is received it certainly
was sent\<close>
lemma Gets_imp_Says :
     "\<lbrakk> Gets B X \<in> set evs; evs \<in> bankerb_gets \<rbrakk> \<Longrightarrow> \<exists>A. Says A B X \<in> set evs"
apply (erule rev_mp)
apply (erule bankerb_gets.induct)
apply auto
done

lemma Gets_imp_knows_Spy:
     "\<lbrakk> Gets B X \<in> set evs; evs \<in> bankerb_gets \<rbrakk>  \<Longrightarrow> X \<in> knows Spy evs"
apply (blast dest!: Gets_imp_Says Says_imp_knows_Spy)
done

lemma Gets_imp_knows_Spy_parts[dest]:
    "\<lbrakk> Gets B X \<in> set evs; evs \<in> bankerb_gets \<rbrakk>  \<Longrightarrow> X \<in> parts (knows Spy evs)"
apply (blast dest: Gets_imp_knows_Spy [THEN parts.Inj])
done

lemma Gets_imp_knows:
     "\<lbrakk> Gets B X \<in> set evs; evs \<in> bankerb_gets \<rbrakk>  \<Longrightarrow> X \<in> knows B evs"
by (metis Gets_imp_knows_Spy Gets_imp_knows_agents)

lemma Gets_imp_knows_analz:
    "\<lbrakk> Gets B X \<in> set evs; evs \<in> bankerb_gets \<rbrakk>  \<Longrightarrow> X \<in> analz (knows B evs)"
apply (blast dest: Gets_imp_knows [THEN analz.Inj])
done

text\<open>Lemmas for reasoning about predicate "before"\<close>
lemma used_Says_rev: "used (evs @ [Says A B X]) = parts {X} \<union> (used evs)"
apply (induct_tac "evs")
apply simp
apply (rename_tac a b)
apply (induct_tac "a")
apply auto
done

lemma used_Notes_rev: "used (evs @ [Notes A X]) = parts {X} \<union> (used evs)"
apply (induct_tac "evs")
apply simp
apply (rename_tac a b)
apply (induct_tac "a")
apply auto
done

lemma used_Gets_rev: "used (evs @ [Gets B X]) = used evs"
apply (induct_tac "evs")
apply simp
apply (rename_tac a b)
apply (induct_tac "a")
apply auto
done

lemma used_evs_rev: "used evs = used (rev evs)"
apply (induct_tac "evs")
apply simp
apply (rename_tac a b)
apply (induct_tac "a")
apply (simp add: used_Says_rev)
apply (simp add: used_Gets_rev)
apply (simp add: used_Notes_rev)
done

lemma used_takeWhile_used [rule_format]:
      "x : used (takeWhile P X) --> x : used X"
apply (induct_tac "X")
apply simp
apply (rename_tac a b)
apply (induct_tac "a")
apply (simp_all add: used_Nil)
apply (blast dest!: initState_into_used)+
done

lemma set_evs_rev: "set evs = set (rev evs)"
apply auto
done

lemma takeWhile_void [rule_format]:
      "x \<notin> set evs \<longrightarrow> takeWhile (\<lambda>z. z \<noteq> x) evs = evs"
apply auto
done

(**** Inductive proofs about bankerb_gets ****)

text\<open>Forwarding Lemma for reasoning about the encrypted portion of message BK3\<close>
lemma BK3_msg_in_parts_knows_Spy:
     "\<lbrakk>Gets A (Crypt KA \<lbrace>Timestamp, B, K, X\<rbrace>) \<in> set evs; evs \<in> bankerb_gets \<rbrakk>
      \<Longrightarrow> X \<in> parts (knows Spy evs)"
apply blast
done

lemma Oops_parts_knows_Spy:
     "Says Server A (Crypt (shrK A) \<lbrace>Timestamp, B, K, X\<rbrace>) \<in> set evs
      \<Longrightarrow> K \<in> parts (knows Spy evs)"
apply blast
done

text\<open>Spy never sees another agent's shared key! (unless it's bad at start)\<close>
lemma Spy_see_shrK [simp]:
     "evs \<in> bankerb_gets \<Longrightarrow> (Key (shrK A) \<in> parts (knows Spy evs)) = (A \<in> bad)"
apply (erule bankerb_gets.induct)
apply (frule_tac [8] Oops_parts_knows_Spy)
apply (frule_tac [6] BK3_msg_in_parts_knows_Spy, simp_all, blast+)
done

lemma Spy_analz_shrK [simp]:
     "evs \<in> bankerb_gets \<Longrightarrow> (Key (shrK A) \<in> analz (knows Spy evs)) = (A \<in> bad)"
by auto

lemma Spy_see_shrK_D [dest!]:
     "\<lbrakk> Key (shrK A) \<in> parts (knows Spy evs);
                evs \<in> bankerb_gets \<rbrakk> \<Longrightarrow> A:bad"
by (blast dest: Spy_see_shrK)

lemmas Spy_analz_shrK_D = analz_subset_parts [THEN subsetD, THEN Spy_see_shrK_D,  dest!]

text\<open>Nobody can have used non-existent keys!\<close>
lemma new_keys_not_used [simp]:
    "\<lbrakk>Key K \<notin> used evs; K \<in> symKeys; evs \<in> bankerb_gets\<rbrakk>
     \<Longrightarrow> K \<notin> keysFor (parts (knows Spy evs))"
apply (erule rev_mp)
apply (erule bankerb_gets.induct)
apply (frule_tac [8] Oops_parts_knows_Spy)
apply (frule_tac [6] BK3_msg_in_parts_knows_Spy, simp_all)
txt\<open>Fake\<close>
apply (force dest!: keysFor_parts_insert)
txt\<open>BK2, BK3, BK4\<close>
apply (force dest!: analz_shrK_Decrypt)+
done

subsection\<open>Lemmas concerning the form of items passed in messages\<close>

text\<open>Describes the form of K, X and K' when the Server sends this message.\<close>
lemma Says_Server_message_form:
     "\<lbrakk> Says Server A (Crypt K' \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)
         \<in> set evs; evs \<in> bankerb_gets \<rbrakk>
      \<Longrightarrow> K' = shrK A & K \<notin> range shrK &
          Ticket = (Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>) &
          Key K \<notin> used(before
                  Says Server A (Crypt K' \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)
                  on evs) &
          Tk = CT(before
                  Says Server A (Crypt K' \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)
                  on evs)"
apply (unfold before_def)
apply (erule rev_mp)
apply (erule bankerb_gets.induct, simp_all)
txt\<open>We need this simplification only for Message 2\<close>
apply (simp (no_asm) add: takeWhile_tail)
apply auto
txt\<open>Two subcases of Message 2. Subcase: used before\<close>
apply (blast dest: used_evs_rev [THEN equalityD2, THEN contra_subsetD]
                   used_takeWhile_used)
txt\<open>subcase: CT before\<close>
apply (fastforce dest!: set_evs_rev [THEN equalityD2, THEN contra_subsetD, THEN takeWhile_void])
done

text\<open>If the encrypted message appears then it originated with the Server
  PROVIDED that A is NOT compromised!
  This allows A to verify freshness of the session key.
\<close>
lemma Kab_authentic:
     "\<lbrakk> Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>
           \<in> parts (knows Spy evs);
         A \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
       \<Longrightarrow> Says Server A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>)
             \<in> set evs"
apply (erule rev_mp)
apply (erule bankerb_gets.induct)
apply (frule_tac [8] Oops_parts_knows_Spy)
apply (frule_tac [6] BK3_msg_in_parts_knows_Spy, simp_all, blast)
done

text\<open>If the TICKET appears then it originated with the Server\<close>
text\<open>FRESHNESS OF THE SESSION KEY to B\<close>
lemma ticket_authentic:
     "\<lbrakk> Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace> \<in> parts (knows Spy evs);
         B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
       \<Longrightarrow> Says Server A
            (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K,
                          Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>\<rbrace>)
           \<in> set evs"
apply (erule rev_mp)
apply (erule bankerb_gets.induct)
apply (frule_tac [8] Oops_parts_knows_Spy)
apply (frule_tac [6] BK3_msg_in_parts_knows_Spy, simp_all, blast)
done

text\<open>EITHER describes the form of X when the following message is sent,
  OR     reduces it to the Fake case.
  Use \<open>Says_Server_message_form\<close> if applicable.\<close>
lemma Gets_Server_message_form:
     "\<lbrakk> Gets A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>)
            \<in> set evs;
         evs \<in> bankerb_gets \<rbrakk>
 \<Longrightarrow> (K \<notin> range shrK & X = (Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>))
          | X \<in> analz (knows Spy evs)"
apply (case_tac "A \<in> bad")
apply (force dest!: Gets_imp_knows_Spy [THEN analz.Inj])
apply (blast dest!: Kab_authentic Says_Server_message_form)
done

text\<open>Reliability guarantees: honest agents act as we expect\<close>

lemma BK3_imp_Gets:
   "\<lbrakk> Says A B \<lbrace>Ticket, Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace> \<in> set evs;
      A \<notin> bad; evs \<in> bankerb_gets \<rbrakk>
    \<Longrightarrow> \<exists> Tk. Gets A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)
      \<in> set evs"
apply (erule rev_mp)
apply (erule bankerb_gets.induct)
apply auto
done

lemma BK4_imp_Gets:
   "\<lbrakk> Says B A (Crypt K (Number Ta)) \<in> set evs;
      B \<notin> bad; evs \<in> bankerb_gets \<rbrakk>
  \<Longrightarrow> \<exists> Tk. Gets B \<lbrace>Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>,
                    Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace> \<in> set evs"
apply (erule rev_mp)
apply (erule bankerb_gets.induct)
apply auto
done

lemma Gets_A_knows_K:
  "\<lbrakk> Gets A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>) \<in> set evs;
     evs \<in> bankerb_gets \<rbrakk>
 \<Longrightarrow> Key K \<in> analz (knows A evs)"
apply (force dest: Gets_imp_knows_analz)
done

lemma Gets_B_knows_K:
  "\<lbrakk> Gets B \<lbrace>Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>,
             Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace> \<in> set evs;
     evs \<in> bankerb_gets \<rbrakk>
 \<Longrightarrow> Key K \<in> analz (knows B evs)"
apply (force dest: Gets_imp_knows_analz)
done

(****
 The following is to prove theorems of the form

  Key K \<in> analz (insert (Key KAB) (knows Spy evs)) \<Longrightarrow>
  Key K \<in> analz (knows Spy evs)

 A more general formula must be proved inductively.

****)

text\<open>Session keys are not used to encrypt other session keys\<close>
lemma analz_image_freshK [rule_format (no_asm)]:
     "evs \<in> bankerb_gets \<Longrightarrow>
   \<forall>K KK. KK \<subseteq> - (range shrK) \<longrightarrow>
          (Key K \<in> analz (Key`KK Un (knows Spy evs))) =
          (K \<in> KK | Key K \<in> analz (knows Spy evs))"
apply (erule bankerb_gets.induct)
apply (drule_tac [8] Says_Server_message_form)
apply (erule_tac [6] Gets_Server_message_form [THEN disjE], analz_freshK, spy_analz, auto)
done

lemma analz_insert_freshK:
     "\<lbrakk> evs \<in> bankerb_gets;  KAB \<notin> range shrK \<rbrakk> \<Longrightarrow>
      (Key K \<in> analz (insert (Key KAB) (knows Spy evs))) =
      (K = KAB | Key K \<in> analz (knows Spy evs))"
by (simp only: analz_image_freshK analz_image_freshK_simps)

text\<open>The session key K uniquely identifies the message\<close>
lemma unique_session_keys:
     "\<lbrakk> Says Server A
           (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>) \<in> set evs;
         Says Server A'
          (Crypt (shrK A') \<lbrace>Number Tk', Agent B', Key K, X'\<rbrace>) \<in> set evs;
         evs \<in> bankerb_gets \<rbrakk> \<Longrightarrow> A=A' & Tk=Tk' & B=B' & X = X'"
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule bankerb_gets.induct)
apply (frule_tac [8] Oops_parts_knows_Spy)
apply (frule_tac [6] BK3_msg_in_parts_knows_Spy, simp_all)
txt\<open>BK2: it can't be a new key\<close>
apply blast
done

lemma unique_session_keys_Gets:
     "\<lbrakk> Gets A
           (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>) \<in> set evs;
        Gets A
          (Crypt (shrK A) \<lbrace>Number Tk', Agent B', Key K, X'\<rbrace>) \<in> set evs;
        A \<notin> bad; evs \<in> bankerb_gets \<rbrakk> \<Longrightarrow> Tk=Tk' & B=B' & X = X'"
apply (blast dest!: Kab_authentic unique_session_keys)
done

lemma Server_Unique:
     "\<lbrakk> Says Server A
            (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>) \<in> set evs;
        evs \<in> bankerb_gets \<rbrakk> \<Longrightarrow>
   Unique Says Server A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)
   on evs"
apply (erule rev_mp, erule bankerb_gets.induct, simp_all add: Unique_def)
apply blast
done

subsection\<open>Non-temporal guarantees, explicitly relying on non-occurrence of
oops events - refined below by temporal guarantees\<close>

text\<open>Non temporal treatment of confidentiality\<close>

text\<open>Lemma: the session key sent in msg BK2 would be lost by oops
    if the spy could see it!\<close>
lemma lemma_conf [rule_format (no_asm)]:
     "\<lbrakk> A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
  \<Longrightarrow> Says Server A
          (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K,
                            Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>\<rbrace>)
         \<in> set evs \<longrightarrow>
      Key K \<in> analz (knows Spy evs) \<longrightarrow> Notes Spy \<lbrace>Number Tk, Key K\<rbrace> \<in> set evs"
apply (erule bankerb_gets.induct)
apply (frule_tac [8] Says_Server_message_form)
apply (frule_tac [6] Gets_Server_message_form [THEN disjE])
apply (simp_all (no_asm_simp) add: analz_insert_eq analz_insert_freshK pushes)
txt\<open>Fake\<close>
apply spy_analz
txt\<open>BK2\<close>
apply (blast intro: parts_insertI)
txt\<open>BK3\<close>
apply (case_tac "Aa \<in> bad")
 prefer 2 apply (blast dest: Kab_authentic unique_session_keys)
apply (blast dest: Gets_imp_knows_Spy [THEN analz.Inj] Crypt_Spy_analz_bad elim!: MPair_analz)
txt\<open>Oops\<close>
apply (blast dest: unique_session_keys)
done

text\<open>Confidentiality for the Server: Spy does not see the keys sent in msg BK2
as long as they have not expired.\<close>
lemma Confidentiality_S:
     "\<lbrakk> Says Server A
          (Crypt K' \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>) \<in> set evs;
        Notes Spy \<lbrace>Number Tk, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets
      \<rbrakk> \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
apply (frule Says_Server_message_form, assumption)
apply (blast intro: lemma_conf)
done

text\<open>Confidentiality for Alice\<close>
lemma Confidentiality_A:
     "\<lbrakk> Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace> \<in> parts (knows Spy evs);
        Notes Spy \<lbrace>Number Tk, Key K\<rbrace> \<notin> set evs;
        A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets
      \<rbrakk> \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
by (blast dest!: Kab_authentic Confidentiality_S)

text\<open>Confidentiality for Bob\<close>
lemma Confidentiality_B:
     "\<lbrakk> Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>
          \<in> parts (knows Spy evs);
        Notes Spy \<lbrace>Number Tk, Key K\<rbrace> \<notin> set evs;
        A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets
      \<rbrakk> \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
by (blast dest!: ticket_authentic Confidentiality_S)

text\<open>Non temporal treatment of authentication\<close>

text\<open>Lemmas \<open>lemma_A\<close> and \<open>lemma_B\<close> in fact are common to both temporal and non-temporal treatments\<close>
lemma lemma_A [rule_format]:
     "\<lbrakk> A \<notin> bad; B \<notin> bad; evs \<in> bankerb_gets \<rbrakk>
      \<Longrightarrow>
         Key K \<notin> analz (knows Spy evs) \<longrightarrow>
         Says Server A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>)
         \<in> set evs \<longrightarrow>
          Crypt K \<lbrace>Agent A, Number Ta\<rbrace> \<in> parts (knows Spy evs) \<longrightarrow>
         Says A B \<lbrace>X, Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace>
             \<in> set evs"
apply (erule bankerb_gets.induct)
apply (frule_tac [8] Oops_parts_knows_Spy)
apply (frule_tac [6] Gets_Server_message_form)
apply (frule_tac [7] BK3_msg_in_parts_knows_Spy, analz_mono_contra)
apply (simp_all (no_asm_simp) add: all_conj_distrib)
txt\<open>Fake\<close>
apply blast
txt\<open>BK2\<close>
apply (force dest: Crypt_imp_invKey_keysFor)
txt\<open>BK3\<close>
apply (blast dest: Kab_authentic unique_session_keys)
done
lemma lemma_B [rule_format]:
     "\<lbrakk> B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
      \<Longrightarrow> Key K \<notin> analz (knows Spy evs) \<longrightarrow>
          Says Server A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>)
          \<in> set evs \<longrightarrow>
          Crypt K (Number Ta) \<in> parts (knows Spy evs) \<longrightarrow>
          Says B A (Crypt K (Number Ta)) \<in> set evs"
apply (erule bankerb_gets.induct)
apply (frule_tac [8] Oops_parts_knows_Spy)
apply (frule_tac [6] Gets_Server_message_form)
apply (drule_tac [7] BK3_msg_in_parts_knows_Spy, analz_mono_contra)
apply (simp_all (no_asm_simp) add: all_conj_distrib)
txt\<open>Fake\<close>
apply blast
txt\<open>BK2\<close>
apply (force dest: Crypt_imp_invKey_keysFor)
txt\<open>BK4\<close>
apply (blast dest: ticket_authentic unique_session_keys
                   Gets_imp_knows_Spy [THEN analz.Inj] Crypt_Spy_analz_bad)
done

text\<open>The "r" suffix indicates theorems where the confidentiality assumptions are relaxed by the corresponding arguments.\<close>

text\<open>Authentication of A to B\<close>
lemma B_authenticates_A_r:
     "\<lbrakk> Crypt K \<lbrace>Agent A, Number Ta\<rbrace> \<in> parts (knows Spy evs);
         Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>  \<in> parts (knows Spy evs);
        Notes Spy \<lbrace>Number Tk, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
      \<Longrightarrow> Says A B \<lbrace>Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>,
                     Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace> \<in> set evs"
by (blast dest!: ticket_authentic
          intro!: lemma_A
          elim!: Confidentiality_S [THEN [2] rev_notE])

text\<open>Authentication of B to A\<close>
lemma A_authenticates_B_r:
     "\<lbrakk> Crypt K (Number Ta) \<in> parts (knows Spy evs);
        Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace> \<in> parts (knows Spy evs);
        Notes Spy \<lbrace>Number Tk, Key K\<rbrace> \<notin> set evs;
        A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
      \<Longrightarrow> Says B A (Crypt K (Number Ta)) \<in> set evs"
by (blast dest!: Kab_authentic
          intro!: lemma_B elim!: Confidentiality_S [THEN [2] rev_notE])

lemma B_authenticates_A:
     "\<lbrakk> Crypt K \<lbrace>Agent A, Number Ta\<rbrace> \<in> parts (spies evs);
         Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>  \<in> parts (spies evs);
        Key K \<notin> analz (spies evs);
         A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
      \<Longrightarrow> Says A B \<lbrace>Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>,
                     Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace> \<in> set evs"
apply (blast dest!: ticket_authentic intro!: lemma_A)
done

lemma A_authenticates_B:
     "\<lbrakk> Crypt K (Number Ta) \<in> parts (spies evs);
        Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace> \<in> parts (spies evs);
        Key K \<notin> analz (spies evs);
        A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
      \<Longrightarrow> Says B A (Crypt K (Number Ta)) \<in> set evs"
apply (blast dest!: Kab_authentic intro!: lemma_B)
done

subsection\<open>Temporal guarantees, relying on a temporal check that insures that
no oops event occurred. These are available in the sense of goal availability\<close>

text\<open>Temporal treatment of confidentiality\<close>

text\<open>Lemma: the session key sent in msg BK2 would be EXPIRED
    if the spy could see it!\<close>
lemma lemma_conf_temporal [rule_format (no_asm)]:
     "\<lbrakk> A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
  \<Longrightarrow> Says Server A
          (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K,
                            Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>\<rbrace>)
         \<in> set evs \<longrightarrow>
      Key K \<in> analz (knows Spy evs) \<longrightarrow> expiredK Tk evs"
apply (erule bankerb_gets.induct)
apply (frule_tac [8] Says_Server_message_form)
apply (frule_tac [6] Gets_Server_message_form [THEN disjE])
apply (simp_all (no_asm_simp) add: less_SucI analz_insert_eq analz_insert_freshK pushes)
txt\<open>Fake\<close>
apply spy_analz
txt\<open>BK2\<close>
apply (blast intro: parts_insertI less_SucI)
txt\<open>BK3\<close>
apply (case_tac "Aa \<in> bad")
 prefer 2 apply (blast dest: Kab_authentic unique_session_keys)
apply (blast dest: Gets_imp_knows_Spy [THEN analz.Inj] Crypt_Spy_analz_bad elim!: MPair_analz intro: less_SucI)
txt\<open>Oops: PROOF FAILS if unsafe intro below\<close>
apply (blast dest: unique_session_keys intro!: less_SucI)
done

text\<open>Confidentiality for the Server: Spy does not see the keys sent in msg BK2
as long as they have not expired.\<close>
lemma Confidentiality_S_temporal:
     "\<lbrakk> Says Server A
          (Crypt K' \<lbrace>Number T, Agent B, Key K, X\<rbrace>) \<in> set evs;
         \<not> expiredK T evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets
      \<rbrakk> \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
apply (frule Says_Server_message_form, assumption)
apply (blast intro: lemma_conf_temporal)
done

text\<open>Confidentiality for Alice\<close>
lemma Confidentiality_A_temporal:
     "\<lbrakk> Crypt (shrK A) \<lbrace>Number T, Agent B, Key K, X\<rbrace> \<in> parts (knows Spy evs);
         \<not> expiredK T evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets
      \<rbrakk> \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
by (blast dest!: Kab_authentic Confidentiality_S_temporal)

text\<open>Confidentiality for Bob\<close>
lemma Confidentiality_B_temporal:
     "\<lbrakk> Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>
          \<in> parts (knows Spy evs);
        \<not> expiredK Tk evs;
        A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets
      \<rbrakk> \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
by (blast dest!: ticket_authentic Confidentiality_S_temporal)

text\<open>Temporal treatment of authentication\<close>

text\<open>Authentication of A to B\<close>
lemma B_authenticates_A_temporal:
     "\<lbrakk> Crypt K \<lbrace>Agent A, Number Ta\<rbrace> \<in> parts (knows Spy evs);
         Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>
         \<in> parts (knows Spy evs);
         \<not> expiredK Tk evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
      \<Longrightarrow> Says A B \<lbrace>Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>,
                     Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace> \<in> set evs"
by (blast dest!: ticket_authentic
          intro!: lemma_A
          elim!: Confidentiality_S_temporal [THEN [2] rev_notE])

text\<open>Authentication of B to A\<close>
lemma A_authenticates_B_temporal:
     "\<lbrakk> Crypt K (Number Ta) \<in> parts (knows Spy evs);
         Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>
         \<in> parts (knows Spy evs);
         \<not> expiredK Tk evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
      \<Longrightarrow> Says B A (Crypt K (Number Ta)) \<in> set evs"
by (blast dest!: Kab_authentic
          intro!: lemma_B elim!: Confidentiality_S_temporal [THEN [2] rev_notE])

subsection\<open>Combined guarantees of key distribution and non-injective agreement on the session keys\<close>

lemma B_authenticates_and_keydist_to_A:
     "\<lbrakk> Gets B \<lbrace>Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>,
                Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace> \<in> set evs;
        Key K \<notin> analz (spies evs);
        A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
    \<Longrightarrow> Says A B \<lbrace>Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>,
                  Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace> \<in> set evs
     \<and>  Key K \<in> analz (knows A evs)"
apply (blast dest: B_authenticates_A BK3_imp_Gets Gets_A_knows_K)
done

lemma A_authenticates_and_keydist_to_B:
     "\<lbrakk> Gets A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>) \<in> set evs;
        Gets A (Crypt K (Number Ta)) \<in> set evs;
        Key K \<notin> analz (spies evs);
        A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
    \<Longrightarrow> Says B A (Crypt K (Number Ta)) \<in> set evs
    \<and>   Key K \<in> analz (knows B evs)"
apply (blast dest: A_authenticates_B BK4_imp_Gets Gets_B_knows_K)
done

end


(*  Title:      HOL/UNITY/Comp/Alloc.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

Specification of Chandy and Charpentier's Allocator
*)

theory Alloc
imports AllocBase "../PPROD"
begin

subsection\<open>State definitions.  OUTPUT variables are locals\<close>

record clientState =
  giv :: "nat list"   \<comment>\<open>client's INPUT history:  tokens GRANTED\<close>
  ask :: "nat list"   \<comment>\<open>client's OUTPUT history: tokens REQUESTED\<close>
  rel :: "nat list"   \<comment>\<open>client's OUTPUT history: tokens RELEASED\<close>

record 'a clientState_d =
  clientState +
  dummy :: 'a       \<comment>\<open>dummy field for new variables\<close>

definition
  \<comment>\<open>DUPLICATED FROM Client.thy, but with "tok" removed\<close>
  \<comment>\<open>Maybe want a special theory section to declare such maps\<close>
  non_dummy :: "'a clientState_d => clientState"
  where "non_dummy s = (|giv = giv s, ask = ask s, rel = rel s|)"

definition
  \<comment>\<open>Renaming map to put a Client into the standard form\<close>
  client_map :: "'a clientState_d => clientState*'a"
  where "client_map = funPair non_dummy dummy"

record allocState =
  allocGiv :: "nat => nat list"   \<comment>\<open>OUTPUT history: source of "giv" for i\<close>
  allocAsk :: "nat => nat list"   \<comment>\<open>INPUT: allocator's copy of "ask" for i\<close>
  allocRel :: "nat => nat list"   \<comment>\<open>INPUT: allocator's copy of "rel" for i\<close>

record 'a allocState_d =
  allocState +
  dummy    :: 'a                \<comment>\<open>dummy field for new variables\<close>

record 'a systemState =
  allocState +
  client :: "nat => clientState"  \<comment>\<open>states of all clients\<close>
  dummy  :: 'a                    \<comment>\<open>dummy field for new variables\<close>

\<comment>\<open>* Resource allocation system specification *\<close>

definition
  \<comment>\<open>spec (1)\<close>
  system_safety :: "'a systemState program set"
  where "system_safety =
     Always {s. (\<Sum>i \<in> lessThan Nclients. (tokens o giv o sub i o client)s)
     \<le> NbT + (\<Sum>i \<in> lessThan Nclients. (tokens o rel o sub i o client)s)}"

definition
  \<comment>\<open>spec (2)\<close>
  system_progress :: "'a systemState program set"
  where "system_progress = (INT i : lessThan Nclients.
                        INT h.
                          {s. h \<le> (ask o sub i o client)s} LeadsTo
                          {s. h pfixLe (giv o sub i o client) s})"

definition
  system_spec :: "'a systemState program set"
  where "system_spec = system_safety Int system_progress"

\<comment>\<open>* Client specification (required) **\<close>

definition
  \<comment>\<open>spec (3)\<close>
  client_increasing :: "'a clientState_d program set"
  where "client_increasing = UNIV guarantees  Increasing ask Int Increasing rel"

definition
  \<comment>\<open>spec (4)\<close>
  client_bounded :: "'a clientState_d program set"
  where "client_bounded = UNIV guarantees  Always {s. ALL elt : set (ask s). elt \<le> NbT}"

definition
  \<comment>\<open>spec (5)\<close>
  client_progress :: "'a clientState_d program set"
  where "client_progress =
         Increasing giv  guarantees
         (INT h. {s. h \<le> giv s & h pfixGe ask s}
                 LeadsTo {s. tokens h \<le> (tokens o rel) s})"

definition
  \<comment>\<open>spec: preserves part\<close>
  client_preserves :: "'a clientState_d program set"
  where "client_preserves = preserves giv Int preserves clientState_d.dummy"

definition
  \<comment>\<open>environmental constraints\<close>
  client_allowed_acts :: "'a clientState_d program set"
  where "client_allowed_acts =
       {F. AllowedActs F =
            insert Id (UNION (preserves (funPair rel ask)) Acts)}"

definition
  client_spec :: "'a clientState_d program set"
  where "client_spec = client_increasing Int client_bounded Int client_progress
                    Int client_allowed_acts Int client_preserves"

\<comment>\<open>* Allocator specification (required) *\<close>

definition
  \<comment>\<open>spec (6)\<close>
  alloc_increasing :: "'a allocState_d program set"
  where "alloc_increasing =
         UNIV  guarantees
         (INT i : lessThan Nclients. Increasing (sub i o allocGiv))"

definition
  \<comment>\<open>spec (7)\<close>
  alloc_safety :: "'a allocState_d program set"
  where "alloc_safety =
         (INT i : lessThan Nclients. Increasing (sub i o allocRel))
         guarantees
         Always {s. (\<Sum>i \<in> lessThan Nclients. (tokens o sub i o allocGiv)s)
         \<le> NbT + (\<Sum>i \<in> lessThan Nclients. (tokens o sub i o allocRel)s)}"

definition
  \<comment>\<open>spec (8)\<close>
  alloc_progress :: "'a allocState_d program set"
  where "alloc_progress =
         (INT i : lessThan Nclients. Increasing (sub i o allocAsk) Int
                                     Increasing (sub i o allocRel))
         Int
         Always {s. ALL i<Nclients.
                     ALL elt : set ((sub i o allocAsk) s). elt \<le> NbT}
         Int
         (INT i : lessThan Nclients.
          INT h. {s. h \<le> (sub i o allocGiv)s & h pfixGe (sub i o allocAsk)s}
                 LeadsTo
                 {s. tokens h \<le> (tokens o sub i o allocRel)s})
         guarantees
             (INT i : lessThan Nclients.
              INT h. {s. h \<le> (sub i o allocAsk) s}
                     LeadsTo
                     {s. h pfixLe (sub i o allocGiv) s})"

  (*NOTE: to follow the original paper, the formula above should have had
        INT h. {s. h i \<le> (sub i o allocGiv)s & h i pfixGe (sub i o allocAsk)s}
               LeadsTo
               {s. tokens h i \<le> (tokens o sub i o allocRel)s})
    thus h should have been a function variable.  However, only h i is ever
    looked at.*)

definition
  \<comment>\<open>spec: preserves part\<close>
  alloc_preserves :: "'a allocState_d program set"
  where "alloc_preserves = preserves allocRel Int preserves allocAsk Int
                        preserves allocState_d.dummy"

definition
  \<comment>\<open>environmental constraints\<close>
  alloc_allowed_acts :: "'a allocState_d program set"
  where "alloc_allowed_acts =
       {F. AllowedActs F =
            insert Id (UNION (preserves allocGiv) Acts)}"

definition
  alloc_spec :: "'a allocState_d program set"
  where "alloc_spec = alloc_increasing Int alloc_safety Int alloc_progress Int
                   alloc_allowed_acts Int alloc_preserves"

\<comment>\<open>* Network specification *\<close>

definition
  \<comment>\<open>spec (9.1)\<close>
  network_ask :: "'a systemState program set"
  where "network_ask = (INT i : lessThan Nclients.
                        Increasing (ask o sub i o client)  guarantees
                        ((sub i o allocAsk) Fols (ask o sub i o client)))"

definition
  \<comment>\<open>spec (9.2)\<close>
  network_giv :: "'a systemState program set"
  where "network_giv = (INT i : lessThan Nclients.
                        Increasing (sub i o allocGiv)
                        guarantees
                        ((giv o sub i o client) Fols (sub i o allocGiv)))"

definition
  \<comment>\<open>spec (9.3)\<close>
  network_rel :: "'a systemState program set"
  where "network_rel = (INT i : lessThan Nclients.
                        Increasing (rel o sub i o client)
                        guarantees
                        ((sub i o allocRel) Fols (rel o sub i o client)))"

definition
  \<comment>\<open>spec: preserves part\<close>
  network_preserves :: "'a systemState program set"
  where "network_preserves =
       preserves allocGiv  Int
       (INT i : lessThan Nclients. preserves (rel o sub i o client)  Int
                                   preserves (ask o sub i o client))"

definition
  \<comment>\<open>environmental constraints\<close>
  network_allowed_acts :: "'a systemState program set"
  where "network_allowed_acts =
       {F. AllowedActs F =
           insert Id
            (UNION (preserves allocRel Int
                    (INT i: lessThan Nclients. preserves(giv o sub i o client)))
                  Acts)}"

definition
  network_spec :: "'a systemState program set"
  where "network_spec = network_ask Int network_giv Int
                     network_rel Int network_allowed_acts Int
                     network_preserves"

\<comment>\<open>* State mappings *\<close>
definition
  sysOfAlloc :: "((nat => clientState) * 'a) allocState_d => 'a systemState"
  where "sysOfAlloc = (%s. let (cl,xtr) = allocState_d.dummy s
                       in (| allocGiv = allocGiv s,
                             allocAsk = allocAsk s,
                             allocRel = allocRel s,
                             client   = cl,
                             dummy    = xtr|))"

definition
  sysOfClient :: "(nat => clientState) * 'a allocState_d => 'a systemState"
  where "sysOfClient = (%(cl,al). (| allocGiv = allocGiv al,
                                 allocAsk = allocAsk al,
                                 allocRel = allocRel al,
                                 client   = cl,
                                 systemState.dummy = allocState_d.dummy al|))"

axiomatization Alloc :: "'a allocState_d program"
  where Alloc: "Alloc : alloc_spec"

axiomatization Client :: "'a clientState_d program"
  where Client: "Client : client_spec"

axiomatization Network :: "'a systemState program"
  where Network: "Network : network_spec"

definition System  :: "'a systemState program"
  where "System = rename sysOfAlloc Alloc \<squnion> Network \<squnion>
                 (rename sysOfClient
                  (plam x: lessThan Nclients. rename client_map Client))"

(**
locale System =
  fixes
    Alloc   :: 'a allocState_d program
    Client  :: 'a clientState_d program
    Network :: 'a systemState program
    System  :: 'a systemState program

  assumes
    Alloc   "Alloc   : alloc_spec"
    Client  "Client  : client_spec"
    Network "Network : network_spec"

  defines
    System_def
      "System == rename sysOfAlloc Alloc
                 \<squnion>
                 Network
                 \<squnion>
                 (rename sysOfClient
                  (plam x: lessThan Nclients. rename client_map Client))"
**)

declare subset_preserves_o [THEN [2] rev_subsetD, intro]
declare subset_preserves_o [THEN [2] rev_subsetD, simp]
declare funPair_o_distrib [simp]
declare Always_INT_distrib [simp]
declare o_apply [simp del]

(*For rewriting of specifications related by "guarantees"*)
lemmas [simp] =
  rename_image_constrains
  rename_image_stable
  rename_image_increasing
  rename_image_invariant
  rename_image_Constrains
  rename_image_Stable
  rename_image_Increasing
  rename_image_Always
  rename_image_leadsTo
  rename_image_LeadsTo
  rename_preserves
  rename_image_preserves
  lift_image_preserves
  bij_image_INT
  bij_is_inj [THEN image_Int]
  bij_image_Collect_eq

ML \<open>
(*Splits up conjunctions & intersections: like CONJUNCTS in the HOL system*)
fun list_of_Int th =
    (list_of_Int (th RS conjunct1) @ list_of_Int (th RS conjunct2))
    handle THM _ => (list_of_Int (th RS IntD1) @ list_of_Int (th RS IntD2))
    handle THM _ => (list_of_Int (th RS @{thm INT_D}))
    handle THM _ => (list_of_Int (th RS bspec))
    handle THM _ => [th];
\<close>

lemmas lessThanBspec = lessThan_iff [THEN iffD2, THEN [2] bspec]

attribute_setup normalized = \<open>
let
  fun normalized th =
    normalized (th RS spec
      handle THM _ => th RS @{thm lessThanBspec}
      handle THM _ => th RS bspec
      handle THM _ => th RS (@{thm guarantees_INT_right_iff} RS iffD1))
    handle THM _ => th;
in
  Scan.succeed (Thm.rule_attribute [] (K normalized))
end
\<close>

(*** bijectivity of sysOfAlloc [MUST BE AUTOMATED] ***)
ML \<open>
fun record_auto_tac ctxt =
  let val ctxt' =
    ctxt addSWrapper Record.split_wrapper
    addsimps
       [@{thm sysOfAlloc_def}, @{thm sysOfClient_def},
        @{thm client_map_def}, @{thm non_dummy_def}, @{thm funPair_def},
        @{thm o_apply}, @{thm Let_def}]
  in auto_tac ctxt' end;

\<close>

method_setup record_auto = \<open>Scan.succeed (SIMPLE_METHOD o record_auto_tac)\<close>

lemma inj_sysOfAlloc [iff]: "inj sysOfAlloc"
  apply (unfold sysOfAlloc_def Let_def)
  apply (rule inj_onI)
  apply record_auto
  done

text\<open>We need the inverse; also having it simplifies the proof of surjectivity\<close>
lemma inv_sysOfAlloc_eq [simp]: "!!s. inv sysOfAlloc s =
             (| allocGiv = allocGiv s,
                allocAsk = allocAsk s,
                allocRel = allocRel s,
                allocState_d.dummy = (client s, dummy s) |)"
  apply (rule inj_sysOfAlloc [THEN inv_f_eq])
  apply record_auto
  done

lemma surj_sysOfAlloc [iff]: "surj sysOfAlloc"
  apply (simp add: surj_iff_all)
  apply record_auto
  done

lemma bij_sysOfAlloc [iff]: "bij sysOfAlloc"
  apply (blast intro: bijI)
  done

subsubsection\<open>bijectivity of @{term sysOfClient}\<close>

lemma inj_sysOfClient [iff]: "inj sysOfClient"
  apply (unfold sysOfClient_def)
  apply (rule inj_onI)
  apply record_auto
  done

lemma inv_sysOfClient_eq [simp]: "!!s. inv sysOfClient s =
             (client s,
              (| allocGiv = allocGiv s,
                 allocAsk = allocAsk s,
                 allocRel = allocRel s,
                 allocState_d.dummy = systemState.dummy s|) )"
  apply (rule inj_sysOfClient [THEN inv_f_eq])
  apply record_auto
  done

lemma surj_sysOfClient [iff]: "surj sysOfClient"
  apply (simp add: surj_iff_all)
  apply record_auto
  done

lemma bij_sysOfClient [iff]: "bij sysOfClient"
  apply (blast intro: bijI)
  done

subsubsection\<open>bijectivity of @{term client_map}\<close>

lemma inj_client_map [iff]: "inj client_map"
  apply (unfold inj_on_def)
  apply record_auto
  done

lemma inv_client_map_eq [simp]: "!!s. inv client_map s =
             (%(x,y).(|giv = giv x, ask = ask x, rel = rel x,
                       clientState_d.dummy = y|)) s"
  apply (rule inj_client_map [THEN inv_f_eq])
  apply record_auto
  done

lemma surj_client_map [iff]: "surj client_map"
  apply (simp add: surj_iff_all)
  apply record_auto
  done

lemma bij_client_map [iff]: "bij client_map"
  apply (blast intro: bijI)
  done

text\<open>o-simprules for @{term client_map}\<close>

lemma fst_o_client_map: "fst o client_map = non_dummy"
  apply (unfold client_map_def)
  apply (rule fst_o_funPair)
  done

ML \<open>ML_Thms.bind_thms ("fst_o_client_map'", make_o_equivs @{context} @{thm fst_o_client_map})\<close>
declare fst_o_client_map' [simp]

lemma snd_o_client_map: "snd o client_map = clientState_d.dummy"
  apply (unfold client_map_def)
  apply (rule snd_o_funPair)
  done

ML \<open>ML_Thms.bind_thms ("snd_o_client_map'", make_o_equivs @{context} @{thm snd_o_client_map})\<close>
declare snd_o_client_map' [simp]

subsection\<open>o-simprules for @{term sysOfAlloc} [MUST BE AUTOMATED]\<close>

lemma client_o_sysOfAlloc: "client o sysOfAlloc = fst o allocState_d.dummy "
  apply record_auto
  done

ML \<open>ML_Thms.bind_thms ("client_o_sysOfAlloc'", make_o_equivs @{context} @{thm client_o_sysOfAlloc})\<close>
declare client_o_sysOfAlloc' [simp]

lemma allocGiv_o_sysOfAlloc_eq: "allocGiv o sysOfAlloc = allocGiv"
  apply record_auto
  done

ML \<open>ML_Thms.bind_thms ("allocGiv_o_sysOfAlloc_eq'", make_o_equivs @{context} @{thm allocGiv_o_sysOfAlloc_eq})\<close>
declare allocGiv_o_sysOfAlloc_eq' [simp]

lemma allocAsk_o_sysOfAlloc_eq: "allocAsk o sysOfAlloc = allocAsk"
  apply record_auto
  done

ML \<open>ML_Thms.bind_thms ("allocAsk_o_sysOfAlloc_eq'", make_o_equivs @{context} @{thm allocAsk_o_sysOfAlloc_eq})\<close>
declare allocAsk_o_sysOfAlloc_eq' [simp]

lemma allocRel_o_sysOfAlloc_eq: "allocRel o sysOfAlloc = allocRel"
  apply record_auto
  done

ML \<open>ML_Thms.bind_thms ("allocRel_o_sysOfAlloc_eq'", make_o_equivs @{context} @{thm allocRel_o_sysOfAlloc_eq})\<close>
declare allocRel_o_sysOfAlloc_eq' [simp]

subsection\<open>o-simprules for @{term sysOfClient} [MUST BE AUTOMATED]\<close>

lemma client_o_sysOfClient: "client o sysOfClient = fst"
  apply record_auto
  done

ML \<open>ML_Thms.bind_thms ("client_o_sysOfClient'", make_o_equivs @{context} @{thm client_o_sysOfClient})\<close>
declare client_o_sysOfClient' [simp]

lemma allocGiv_o_sysOfClient_eq: "allocGiv o sysOfClient = allocGiv o snd "
  apply record_auto
  done

ML \<open>ML_Thms.bind_thms ("allocGiv_o_sysOfClient_eq'", make_o_equivs @{context} @{thm allocGiv_o_sysOfClient_eq})\<close>
declare allocGiv_o_sysOfClient_eq' [simp]

lemma allocAsk_o_sysOfClient_eq: "allocAsk o sysOfClient = allocAsk o snd "
  apply record_auto
  done

ML \<open>ML_Thms.bind_thms ("allocAsk_o_sysOfClient_eq'", make_o_equivs @{context} @{thm allocAsk_o_sysOfClient_eq})\<close>
declare allocAsk_o_sysOfClient_eq' [simp]

lemma allocRel_o_sysOfClient_eq: "allocRel o sysOfClient = allocRel o snd "
  apply record_auto
  done

ML \<open>ML_Thms.bind_thms ("allocRel_o_sysOfClient_eq'", make_o_equivs @{context} @{thm allocRel_o_sysOfClient_eq})\<close>
declare allocRel_o_sysOfClient_eq' [simp]

lemma allocGiv_o_inv_sysOfAlloc_eq: "allocGiv o inv sysOfAlloc = allocGiv"
  apply (simp add: o_def)
  done

ML \<open>ML_Thms.bind_thms ("allocGiv_o_inv_sysOfAlloc_eq'", make_o_equivs @{context} @{thm allocGiv_o_inv_sysOfAlloc_eq})\<close>
declare allocGiv_o_inv_sysOfAlloc_eq' [simp]

lemma allocAsk_o_inv_sysOfAlloc_eq: "allocAsk o inv sysOfAlloc = allocAsk"
  apply (simp add: o_def)
  done

ML \<open>ML_Thms.bind_thms ("allocAsk_o_inv_sysOfAlloc_eq'", make_o_equivs @{context} @{thm allocAsk_o_inv_sysOfAlloc_eq})\<close>
declare allocAsk_o_inv_sysOfAlloc_eq' [simp]

lemma allocRel_o_inv_sysOfAlloc_eq: "allocRel o inv sysOfAlloc = allocRel"
  apply (simp add: o_def)
  done

ML \<open>ML_Thms.bind_thms ("allocRel_o_inv_sysOfAlloc_eq'", make_o_equivs @{context} @{thm allocRel_o_inv_sysOfAlloc_eq})\<close>
declare allocRel_o_inv_sysOfAlloc_eq' [simp]

lemma rel_inv_client_map_drop_map: "(rel o inv client_map o drop_map i o inv sysOfClient) =
      rel o sub i o client"
  apply (simp add: o_def drop_map_def)
  done

ML \<open>ML_Thms.bind_thms ("rel_inv_client_map_drop_map'", make_o_equivs @{context} @{thm rel_inv_client_map_drop_map})\<close>
declare rel_inv_client_map_drop_map [simp]

lemma ask_inv_client_map_drop_map: "(ask o inv client_map o drop_map i o inv sysOfClient) =
      ask o sub i o client"
  apply (simp add: o_def drop_map_def)
  done

ML \<open>ML_Thms.bind_thms ("ask_inv_client_map_drop_map'", make_o_equivs @{context} @{thm ask_inv_client_map_drop_map})\<close>
declare ask_inv_client_map_drop_map [simp]

text\<open>Client : <unfolded specification>\<close>
lemmas client_spec_simps =
  client_spec_def client_increasing_def client_bounded_def
  client_progress_def client_allowed_acts_def client_preserves_def
  guarantees_Int_right

ML \<open>
val [Client_Increasing_ask, Client_Increasing_rel,
     Client_Bounded, Client_Progress, Client_AllowedActs,
     Client_preserves_giv, Client_preserves_dummy] =
        @{thm Client} |> simplify (@{context} addsimps @{thms client_spec_simps})
               |> list_of_Int;

ML_Thms.bind_thm ("Client_Increasing_ask", Client_Increasing_ask);
ML_Thms.bind_thm ("Client_Increasing_rel", Client_Increasing_rel);
ML_Thms.bind_thm ("Client_Bounded", Client_Bounded);
ML_Thms.bind_thm ("Client_Progress", Client_Progress);
ML_Thms.bind_thm ("Client_AllowedActs", Client_AllowedActs);
ML_Thms.bind_thm ("Client_preserves_giv", Client_preserves_giv);
ML_Thms.bind_thm ("Client_preserves_dummy", Client_preserves_dummy);
\<close>

declare
  Client_Increasing_ask [iff]
  Client_Increasing_rel [iff]
  Client_Bounded [iff]
  Client_preserves_giv [iff]
  Client_preserves_dummy [iff]

text\<open>Network : <unfolded specification>\<close>
lemmas network_spec_simps =
  network_spec_def network_ask_def network_giv_def
  network_rel_def network_allowed_acts_def network_preserves_def
  ball_conj_distrib

ML \<open>
val [Network_Ask, Network_Giv, Network_Rel, Network_AllowedActs,
     Network_preserves_allocGiv, Network_preserves_rel,
     Network_preserves_ask]  =
        @{thm Network} |> simplify (@{context} addsimps @{thms network_spec_simps})
                |> list_of_Int;

ML_Thms.bind_thm ("Network_Ask", Network_Ask);
ML_Thms.bind_thm ("Network_Giv", Network_Giv);
ML_Thms.bind_thm ("Network_Rel", Network_Rel);
ML_Thms.bind_thm ("Network_AllowedActs", Network_AllowedActs);
ML_Thms.bind_thm ("Network_preserves_allocGiv", Network_preserves_allocGiv);
ML_Thms.bind_thm ("Network_preserves_rel", Network_preserves_rel);
ML_Thms.bind_thm ("Network_preserves_ask", Network_preserves_ask);
\<close>

declare Network_preserves_allocGiv [iff]

declare
  Network_preserves_rel [simp]
  Network_preserves_ask [simp]

declare
  Network_preserves_rel [simplified o_def, simp]
  Network_preserves_ask [simplified o_def, simp]

text\<open>Alloc : <unfolded specification>\<close>
lemmas alloc_spec_simps =
  alloc_spec_def alloc_increasing_def alloc_safety_def
  alloc_progress_def alloc_allowed_acts_def alloc_preserves_def

ML \<open>
val [Alloc_Increasing_0, Alloc_Safety, Alloc_Progress, Alloc_AllowedActs,
     Alloc_preserves_allocRel, Alloc_preserves_allocAsk,
     Alloc_preserves_dummy] =
        @{thm Alloc} |> simplify (@{context} addsimps @{thms alloc_spec_simps})
              |> list_of_Int;

ML_Thms.bind_thm ("Alloc_Increasing_0", Alloc_Increasing_0);
ML_Thms.bind_thm ("Alloc_Safety", Alloc_Safety);
ML_Thms.bind_thm ("Alloc_Progress", Alloc_Progress);
ML_Thms.bind_thm ("Alloc_AllowedActs", Alloc_AllowedActs);
ML_Thms.bind_thm ("Alloc_preserves_allocRel", Alloc_preserves_allocRel);
ML_Thms.bind_thm ("Alloc_preserves_allocAsk", Alloc_preserves_allocAsk);
ML_Thms.bind_thm ("Alloc_preserves_dummy", Alloc_preserves_dummy);
\<close>

text\<open>Strip off the INT in the guarantees postcondition\<close>

lemmas Alloc_Increasing = Alloc_Increasing_0 [normalized]

declare
  Alloc_preserves_allocRel [iff]
  Alloc_preserves_allocAsk [iff]
  Alloc_preserves_dummy [iff]

subsection\<open>Components Lemmas [MUST BE AUTOMATED]\<close>

lemma Network_component_System: "Network \<squnion>
      ((rename sysOfClient
        (plam x: (lessThan Nclients). rename client_map Client)) \<squnion>
       rename sysOfAlloc Alloc)
      = System"
  by (simp add: System_def Join_ac)

lemma Client_component_System: "(rename sysOfClient
       (plam x: (lessThan Nclients). rename client_map Client)) \<squnion>
      (Network \<squnion> rename sysOfAlloc Alloc)  =  System"
  by (simp add: System_def Join_ac)

lemma Alloc_component_System: "rename sysOfAlloc Alloc \<squnion>
       ((rename sysOfClient (plam x: (lessThan Nclients). rename client_map Client)) \<squnion>
        Network)  =  System"
  by (simp add: System_def Join_ac)

declare
  Client_component_System [iff]
  Network_component_System [iff]
  Alloc_component_System [iff]

text\<open>* These preservation laws should be generated automatically *\<close>

lemma Client_Allowed [simp]: "Allowed Client = preserves rel Int preserves ask"
  by (auto simp add: Allowed_def Client_AllowedActs safety_prop_Acts_iff)

lemma Network_Allowed [simp]: "Allowed Network =
        preserves allocRel Int
        (INT i: lessThan Nclients. preserves(giv o sub i o client))"
  by (auto simp add: Allowed_def Network_AllowedActs safety_prop_Acts_iff)

lemma Alloc_Allowed [simp]: "Allowed Alloc = preserves allocGiv"
  by (auto simp add: Allowed_def Alloc_AllowedActs safety_prop_Acts_iff)

text\<open>needed in \<open>rename_client_map_tac\<close>\<close>
lemma OK_lift_rename_Client [simp]: "OK I (%i. lift i (rename client_map Client))"
  apply (rule OK_lift_I)
  apply auto
  apply (drule_tac w1 = rel in subset_preserves_o [THEN [2] rev_subsetD])
  apply (drule_tac [2] w1 = ask in subset_preserves_o [THEN [2] rev_subsetD])
  apply (auto simp add: o_def split_def)
  done

lemma fst_lift_map_eq_fst [simp]: "fst (lift_map i x) i = fst x"
apply (insert fst_o_lift_map [of i])
apply (drule fun_cong [where x=x])
apply (simp add: o_def)
done

lemma fst_o_lift_map' [simp]:
     "(f \<circ> sub i \<circ> fst \<circ> lift_map i \<circ> g) = f o fst o g"
apply (subst fst_o_lift_map [symmetric])
apply (simp only: o_assoc)
done

(*The proofs of rename_Client_Increasing, rename_Client_Bounded and
  rename_Client_Progress are similar.  All require copying out the original
  Client property.  A forward proof can be constructed as follows:

  Client_Increasing_ask RS
      (bij_client_map RS rename_rename_guarantees_eq RS iffD2)
  RS (lift_lift_guarantees_eq RS iffD2)
  RS guarantees_PLam_I
  RS (bij_sysOfClient RS rename_rename_guarantees_eq RS iffD2)
  |> simplify (simpset() addsimps [lift_image_eq_rename, o_def, split_def,
                                   surj_rename])

However, the "preserves" property remains to be discharged, and the unfolding
of "o" and "sub" complicates subsequent reasoning.

The following tactic works for all three proofs, though it certainly looks
ad-hoc!
*)
ML
\<open>
fun rename_client_map_tac ctxt =
  EVERY [
    simp_tac (ctxt addsimps [@{thm rename_guarantees_eq_rename_inv}]) 1,
    resolve_tac ctxt @{thms guarantees_PLam_I} 1,
    assume_tac ctxt 2,
         (*preserves: routine reasoning*)
    asm_simp_tac (ctxt addsimps [@{thm lift_preserves_sub}]) 2,
         (*the guarantee for  "lift i (rename client_map Client)" *)
    asm_simp_tac
        (ctxt addsimps [@{thm lift_guarantees_eq_lift_inv},
                      @{thm rename_guarantees_eq_rename_inv},
                      @{thm bij_imp_bij_inv}, @{thm surj_rename},
                      @{thm inv_inv_eq}]) 1,
    asm_simp_tac
        (ctxt addsimps [@{thm o_def}, @{thm non_dummy_def}, @{thm guarantees_Int_right}]) 1]
\<close>

method_setup rename_client_map = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD (rename_client_map_tac ctxt))
\<close>

text\<open>Lifting \<open>Client_Increasing\<close> to @{term systemState}\<close>
lemma rename_Client_Increasing: "i : I
      ==> rename sysOfClient (plam x: I. rename client_map Client) :
            UNIV  guarantees
            Increasing (ask o sub i o client) Int
            Increasing (rel o sub i o client)"
  by rename_client_map

lemma preserves_sub_fst_lift_map: "[| F : preserves w; i ~= j |]
      ==> F : preserves (sub i o fst o lift_map j o funPair v w)"
  apply (auto simp add: lift_map_def split_def linorder_neq_iff o_def)
  apply (drule_tac [!] subset_preserves_o [THEN [2] rev_subsetD])
  apply (auto simp add: o_def)
  done

lemma client_preserves_giv_oo_client_map: "[| i < Nclients; j < Nclients |]
      ==> Client : preserves (giv o sub i o fst o lift_map j o client_map)"
  apply (cases "i=j")
  apply (simp, simp add: o_def non_dummy_def)
  apply (drule Client_preserves_dummy [THEN preserves_sub_fst_lift_map])
  apply (drule_tac [!] subset_preserves_o [THEN [2] rev_subsetD])
  apply (simp add: o_def client_map_def)
  done

lemma rename_sysOfClient_ok_Network:
  "rename sysOfClient (plam x: lessThan Nclients. rename client_map Client)
    ok Network"
  by (auto simp add: ok_iff_Allowed client_preserves_giv_oo_client_map)

lemma rename_sysOfClient_ok_Alloc:
  "rename sysOfClient (plam x: lessThan Nclients. rename client_map Client)
    ok rename sysOfAlloc Alloc"
  by (simp add: ok_iff_Allowed)

lemma rename_sysOfAlloc_ok_Network: "rename sysOfAlloc Alloc ok Network"
  by (simp add: ok_iff_Allowed)

declare
  rename_sysOfClient_ok_Network [iff]
  rename_sysOfClient_ok_Alloc [iff]
  rename_sysOfAlloc_ok_Network [iff]

text\<open>The "ok" laws, re-oriented.
  But not sure this works: theorem \<open>ok_commute\<close> is needed below\<close>
declare
  rename_sysOfClient_ok_Network [THEN ok_sym, iff]
  rename_sysOfClient_ok_Alloc [THEN ok_sym, iff]
  rename_sysOfAlloc_ok_Network [THEN ok_sym]

lemma System_Increasing: "i < Nclients
      ==> System : Increasing (ask o sub i o client) Int
                   Increasing (rel o sub i o client)"
  apply (rule component_guaranteesD [OF rename_Client_Increasing Client_component_System])
  apply auto
  done

lemmas rename_guarantees_sysOfAlloc_I =
  bij_sysOfAlloc [THEN rename_rename_guarantees_eq, THEN iffD2]

(*Lifting Alloc_Increasing up to the level of systemState*)
lemmas rename_Alloc_Increasing =
  Alloc_Increasing
    [THEN rename_guarantees_sysOfAlloc_I,
     simplified surj_rename o_def sub_apply
                rename_image_Increasing bij_sysOfAlloc
                allocGiv_o_inv_sysOfAlloc_eq']

lemma System_Increasing_allocGiv:
     "i < Nclients ==> System : Increasing (sub i o allocGiv)"
  apply (unfold System_def)
  apply (simp add: o_def)
  apply (rule rename_Alloc_Increasing [THEN guarantees_Join_I1, THEN guaranteesD])
  apply auto
  done

ML \<open>
ML_Thms.bind_thms ("System_Increasing'", list_of_Int @{thm System_Increasing})
\<close>

declare System_Increasing' [intro!]

text\<open>Follows consequences.
    The "Always (INT ...) formulation expresses the general safety property
    and allows it to be combined using \<open>Always_Int_rule\<close> below.\<close>

lemma System_Follows_rel:
  "i < Nclients ==> System : ((sub i o allocRel) Fols (rel o sub i o client))"
  apply (auto intro!: Network_Rel [THEN component_guaranteesD])
  apply (simp add: ok_commute [of Network])
  done

lemma System_Follows_ask:
  "i < Nclients ==> System : ((sub i o allocAsk) Fols (ask o sub i o client))"
  apply (auto intro!: Network_Ask [THEN component_guaranteesD])
  apply (simp add: ok_commute [of Network])
  done

lemma System_Follows_allocGiv:
  "i < Nclients ==> System : (giv o sub i o client) Fols (sub i o allocGiv)"
  apply (auto intro!: Network_Giv [THEN component_guaranteesD]
    rename_Alloc_Increasing [THEN component_guaranteesD])
  apply (simp_all add: o_def non_dummy_def ok_commute [of Network])
  apply (auto intro!: rename_Alloc_Increasing [THEN component_guaranteesD])
  done

lemma Always_giv_le_allocGiv: "System : Always (INT i: lessThan Nclients.
                       {s. (giv o sub i o client) s \<le> (sub i o allocGiv) s})"
  apply auto
  apply (erule System_Follows_allocGiv [THEN Follows_Bounded])
  done

lemma Always_allocAsk_le_ask: "System : Always (INT i: lessThan Nclients.
                       {s. (sub i o allocAsk) s \<le> (ask o sub i o client) s})"
  apply auto
  apply (erule System_Follows_ask [THEN Follows_Bounded])
  done

lemma Always_allocRel_le_rel: "System : Always (INT i: lessThan Nclients.
                       {s. (sub i o allocRel) s \<le> (rel o sub i o client) s})"
  by (auto intro!: Follows_Bounded System_Follows_rel)

subsection\<open>Proof of the safety property (1)\<close>

text\<open>safety (1), step 1 is \<open>System_Follows_rel\<close>\<close>

text\<open>safety (1), step 2\<close>
(* i < Nclients ==> System : Increasing (sub i o allocRel) *)
lemmas System_Increasing_allocRel = System_Follows_rel [THEN Follows_Increasing1]

(*Lifting Alloc_safety up to the level of systemState.
  Simplifying with o_def gets rid of the translations but it unfortunately
  gets rid of the other "o"s too.*)

text\<open>safety (1), step 3\<close>
lemma System_sum_bounded:
    "System : Always {s. (\<Sum>i \<in> lessThan Nclients. (tokens o sub i o allocGiv) s)
            \<le> NbT + (\<Sum>i \<in> lessThan Nclients. (tokens o sub i o allocRel) s)}"
  apply (simp add: o_apply)
  apply (insert Alloc_Safety [THEN rename_guarantees_sysOfAlloc_I])
  apply (simp add: o_def)
  apply (erule component_guaranteesD)
  apply (auto simp add: System_Increasing_allocRel [simplified sub_apply o_def])
  done

text\<open>Follows reasoning\<close>

lemma Always_tokens_giv_le_allocGiv: "System : Always (INT i: lessThan Nclients.
                          {s. (tokens o giv o sub i o client) s
                           \<le> (tokens o sub i o allocGiv) s})"
  apply (rule Always_giv_le_allocGiv [THEN Always_weaken])
  apply (auto intro: tokens_mono_prefix simp add: o_apply)
  done

lemma Always_tokens_allocRel_le_rel: "System : Always (INT i: lessThan Nclients.
                          {s. (tokens o sub i o allocRel) s
                           \<le> (tokens o rel o sub i o client) s})"
  apply (rule Always_allocRel_le_rel [THEN Always_weaken])
  apply (auto intro: tokens_mono_prefix simp add: o_apply)
  done

text\<open>safety (1), step 4 (final result!)\<close>
theorem System_safety: "System : system_safety"
  apply (unfold system_safety_def)
  apply (tactic \<open>resolve_tac @{context} [Always_Int_rule [@{thm System_sum_bounded},
    @{thm Always_tokens_giv_le_allocGiv}, @{thm Always_tokens_allocRel_le_rel}] RS
    @{thm Always_weaken}] 1\<close>)
  apply auto
  apply (rule sum_fun_mono [THEN order_trans])
  apply (drule_tac [2] order_trans)
  apply (rule_tac [2] add_le_mono [OF order_refl sum_fun_mono])
  prefer 3 apply assumption
  apply auto
  done

subsection \<open>Proof of the progress property (2)\<close>

text\<open>progress (2), step 1 is \<open>System_Follows_ask\<close> and
      \<open>System_Follows_rel\<close>\<close>

text\<open>progress (2), step 2; see also \<open>System_Increasing_allocRel\<close>\<close>
(* i < Nclients ==> System : Increasing (sub i o allocAsk) *)
lemmas System_Increasing_allocAsk =  System_Follows_ask [THEN Follows_Increasing1]

text\<open>progress (2), step 3: lifting \<open>Client_Bounded\<close> to systemState\<close>
lemma rename_Client_Bounded: "i : I
    ==> rename sysOfClient (plam x: I. rename client_map Client) :
          UNIV  guarantees
          Always {s. ALL elt : set ((ask o sub i o client) s). elt \<le> NbT}"
  by rename_client_map

lemma System_Bounded_ask: "i < Nclients
      ==> System : Always
                    {s. ALL elt : set ((ask o sub i o client) s). elt \<le> NbT}"
  apply (rule component_guaranteesD [OF rename_Client_Bounded Client_component_System])
  apply auto
  done

lemma Collect_all_imp_eq: "{x. ALL y. P y --> Q x y} = (INT y: {y. P y}. {x. Q x y})"
  apply blast
  done

text\<open>progress (2), step 4\<close>
lemma System_Bounded_allocAsk: "System : Always {s. ALL i<Nclients.
                          ALL elt : set ((sub i o allocAsk) s). elt \<le> NbT}"
  apply (auto simp add: Collect_all_imp_eq)
  apply (tactic \<open>resolve_tac @{context} [Always_Int_rule [@{thm Always_allocAsk_le_ask},
    @{thm System_Bounded_ask}] RS @{thm Always_weaken}] 1\<close>)
  apply (auto dest: set_mono)
  done

text\<open>progress (2), step 5 is \<open>System_Increasing_allocGiv\<close>\<close>

text\<open>progress (2), step 6\<close>
(* i < Nclients ==> System : Increasing (giv o sub i o client) *)
lemmas System_Increasing_giv =  System_Follows_allocGiv [THEN Follows_Increasing1]

lemma rename_Client_Progress: "i: I
   ==> rename sysOfClient (plam x: I. rename client_map Client)
        : Increasing (giv o sub i o client)
          guarantees
          (INT h. {s. h \<le> (giv o sub i o client) s &
                            h pfixGe (ask o sub i o client) s}
                  LeadsTo {s. tokens h \<le> (tokens o rel o sub i o client) s})"
  apply rename_client_map
  apply (simp add: Client_Progress [simplified o_def])
  done

text\<open>progress (2), step 7\<close>
lemma System_Client_Progress:
  "System : (INT i : (lessThan Nclients).
            INT h. {s. h \<le> (giv o sub i o client) s &
                       h pfixGe (ask o sub i o client) s}
                LeadsTo {s. tokens h \<le> (tokens o rel o sub i o client) s})"
  apply (rule INT_I)
(*Couldn't have just used Auto_tac since the "INT h" must be kept*)
  apply (rule component_guaranteesD [OF rename_Client_Progress Client_component_System])
  apply (auto simp add: System_Increasing_giv)
  done

(*Concludes
 System : {s. k \<le> (sub i o allocGiv) s}
          LeadsTo
          {s. (sub i o allocAsk) s \<le> (ask o sub i o client) s} Int
          {s. k \<le> (giv o sub i o client) s} *)

lemmas System_lemma1 =
  Always_LeadsToD [OF System_Follows_ask [THEN Follows_Bounded]
                      System_Follows_allocGiv [THEN Follows_LeadsTo]]

lemmas System_lemma2 =
  PSP_Stable [OF System_lemma1
              System_Follows_ask [THEN Follows_Increasing1, THEN IncreasingD]]

lemma System_lemma3: "i < Nclients
      ==> System : {s. h \<le> (sub i o allocGiv) s &
                       h pfixGe (sub i o allocAsk) s}
                   LeadsTo
                   {s. h \<le> (giv o sub i o client) s &
                       h pfixGe (ask o sub i o client) s}"
  apply (rule single_LeadsTo_I)
  apply (rule_tac k1 = h and x1 = "(sub i o allocAsk) s"
         in System_lemma2 [THEN LeadsTo_weaken])
  apply auto
  apply (blast intro: trans_Ge [THEN trans_genPrefix, THEN transD] prefix_imp_pfixGe)
  done

text\<open>progress (2), step 8: Client i's "release" action is visible system-wide\<close>
lemma System_Alloc_Client_Progress: "i < Nclients
      ==> System : {s. h \<le> (sub i o allocGiv) s &
                       h pfixGe (sub i o allocAsk) s}
                   LeadsTo {s. tokens h \<le> (tokens o sub i o allocRel) s}"
  apply (rule LeadsTo_Trans)
   prefer 2
   apply (drule System_Follows_rel [THEN
     mono_tokens [THEN mono_Follows_o, THEN [2] rev_subsetD],
     THEN Follows_LeadsTo])
   apply (simp add: o_assoc)
  apply (rule LeadsTo_Trans)
   apply (cut_tac [2] System_Client_Progress)
   prefer 2
   apply (blast intro: LeadsTo_Basis)
  apply (erule System_lemma3)
  done

text\<open>Lifting \<open>Alloc_Progress\<close> up to the level of systemState\<close>

text\<open>progress (2), step 9\<close>
lemma System_Alloc_Progress:
 "System : (INT i : (lessThan Nclients).
            INT h. {s. h \<le> (sub i o allocAsk) s}
                   LeadsTo {s. h pfixLe (sub i o allocGiv) s})"
  apply (simp only: o_apply sub_def)
  apply (insert Alloc_Progress [THEN rename_guarantees_sysOfAlloc_I])
  apply (simp add: o_def del: INT_iff)
  apply (drule component_guaranteesD)
  apply (auto simp add:
    System_Increasing_allocRel [simplified sub_apply o_def]
    System_Increasing_allocAsk [simplified sub_apply o_def]
    System_Bounded_allocAsk [simplified sub_apply o_def]
    System_Alloc_Client_Progress [simplified sub_apply o_def])
  done

text\<open>progress (2), step 10 (final result!)\<close>
lemma System_Progress: "System : system_progress"
  apply (unfold system_progress_def)
  apply (cut_tac System_Alloc_Progress)
  apply auto
  apply (blast intro: LeadsTo_Trans
    System_Follows_allocGiv [THEN Follows_LeadsTo_pfixLe]
    System_Follows_ask [THEN Follows_LeadsTo])
  done

theorem System_correct: "System : system_spec"
  apply (unfold system_spec_def)
  apply (blast intro: System_safety System_Progress)
  done

text\<open>Some obsolete lemmas\<close>

lemma non_dummy_eq_o_funPair: "non_dummy = (% (g,a,r). (| giv = g, ask = a, rel = r |)) o
                              (funPair giv (funPair ask rel))"
  apply (rule ext)
  apply (auto simp add: o_def non_dummy_def)
  done

lemma preserves_non_dummy_eq: "(preserves non_dummy) =
      (preserves rel Int preserves ask Int preserves giv)"
  apply (simp add: non_dummy_eq_o_funPair)
  apply auto
    apply (drule_tac w1 = rel in subset_preserves_o [THEN [2] rev_subsetD])
    apply (drule_tac [2] w1 = ask in subset_preserves_o [THEN [2] rev_subsetD])
    apply (drule_tac [3] w1 = giv in subset_preserves_o [THEN [2] rev_subsetD])
    apply (auto simp add: o_def)
  done

text\<open>Could go to Extend.ML\<close>
lemma bij_fst_inv_inv_eq: "bij f ==> fst (inv (%(x, u). inv f x) z) = f z"
  apply (rule fst_inv_equalityI)
   apply (rule_tac f = "%z. (f z, h z)" for h in surjI)
   apply (simp add: bij_is_inj inv_f_f)
  apply (simp add: bij_is_surj surj_f_inv_f)
  done

end


theory isTramMap
imports trapezoidalMap
begin

(*Definition für trapMap*)
definition intersectionYNode :: "tDag \<Rightarrow> bool" where
  "intersectionYNode D \<equiv> \<forall> A B. (A \<in> set (yDagList D) \<and> B \<in> set (yDagList D)) \<longrightarrow>
  \<not>intersect (fst A) (snd A) (fst B) (snd B)"
definition isTramMap :: "tDag \<Rightarrow> bool" where
  "isTramMap D \<equiv> trapezList (tDagList D) \<and> pointsInTramMap D
  \<and> trapezMapNeighbor D \<and> uniqueXCoord (xDagList D) \<and> intersectionYNode D"

(*isTramMap gilt für einen tDag bestehend aus einem Trapez*)
lemma isTramMapRBox[simp]: "isTrapez X \<Longrightarrow> isTramMap (Tip X)"
  apply (auto simp add: isTramMap_def pointInDag_def pointInTrapez_def trapezList_def)
by (auto simp add: rBoxPointsInTramMap intersectionYNode_def)

(*definition für komp. segment mit einer Trap-Map*)
definition segmentXNode :: "tDag \<Rightarrow> point2d \<Rightarrow> bool" where
  "segmentXNode D P \<equiv> \<forall> a. a \<in> set (xDagList D) \<and> a \<noteq> P \<longrightarrow> xCoord a \<noteq> xCoord P"
lemma segmentAndDagUnicX[simp]:"segmentXNode D P \<Longrightarrow> P \<notin> set (xDagList D) \<Longrightarrow>
  uniqueXCoord (xDagList D @ [P])"
  apply (auto simp add: segmentXNode_def)
  apply (case_tac "\<exists> a. a \<in> set (xDagList D)", erule exE)
  apply (erule_tac x=a in allE, simp, safe)
oops

definition segmentCompWithDag :: "tDag \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> bool" where
  "isTramMap D \<Longrightarrow> segmentCompWithDag D P Q \<equiv> leftFrom P Q \<and> pointInDag D P \<and> pointInDag D Q
  \<and> segmentXNode D P \<and> segmentXNode D Q
  \<and> (\<forall> A. A \<in> set (yDagList D) \<longrightarrow> \<not>intersect (fst A) (snd A) P Q)"
lemma segmentCompWithDagSym[simp]: "isTramMap D \<Longrightarrow> segmentCompWithDag D P Q \<Longrightarrow>
  \<forall> A. A \<in> set (yDagList D) \<longrightarrow> \<not>intersect P Q (fst A) (snd A)"
  apply (auto simp add: segmentCompWithDag_def)
  apply (erule_tac x=a in allE, erule_tac x=b in allE, simp)
by (metis NotIntersectSym)

lemma segmentAndDagUnicX1[simp]:"isTramMap D \<Longrightarrow> segmentCompWithDag D P Q \<Longrightarrow>
  P \<notin> set (xDagList D) \<Longrightarrow> Q \<notin> set (xDagList D) \<Longrightarrow> uniqueXCoord (xDagList D @ [P, Q])"
oops

lemma pointNotXNode: "isTramMap D \<Longrightarrow> segmentCompWithDag D P Q \<Longrightarrow>
  \<forall> T. T \<in> set (tDagList D) \<longrightarrow> rightP T \<noteq> P \<and> leftP T \<noteq> P \<Longrightarrow> P \<notin> set (xDagList D)"
oops

(*##############intersectionYNode###############*)

lemma replaceTipNoIntersect[intro]: "isTramMap D \<Longrightarrow> segmentCompWithDag D P Q \<Longrightarrow>
  intersectionYNode (replaceTip oT (newDag D T TM P Q) D)"
  apply (auto simp add: intersectionYNode_def)
  apply (insert replaceTipYDagList1, atomize)
  apply (erule_tac x="(a, b)" in allE, erule_tac x=oT in allE,
    erule_tac x="newDag D T TM P Q" in allE, erule_tac x=D in allE)
  apply (insert replaceTipYDagList1, atomize)
  apply (erule_tac x="(aa, ba)" in allE, erule_tac x=oT in allE,
    erule_tac x="newDag D T TM P Q" in allE, erule_tac x=D in allE, auto)
  apply (simp add: intersectionYNode_def isTramMap_def)
  using segmentCompWithDag_def apply auto[1]
by (meson BNF_Greatest_Fixpoint.subst_Pair segmentCompWithDagSym)

(*kein y-Node schneidet ein anderes y-Node*)
lemma addSegmentNoIntersect: "isTramMap D \<Longrightarrow> leftFrom P Q \<Longrightarrow> segmentCompWithDag D P Q \<Longrightarrow>
  intersectionYNode (addSegmentToTrapMap D P Q)"
  apply (auto simp add: addSegmentToTrapMap_def intersectionYNode_def)
  apply (cut_tac a="(a, b)" and P=P and Q=Q and D=D and TM="intersectedTrapez D P Q"
    and TN="intersectedTrapez D P Q" in replaceYDagListElem)
  apply (cut_tac a="(aa, ba)" and P=P and Q=Q and D=D and TM="intersectedTrapez D P Q"
    and TN="intersectedTrapez D P Q" in replaceYDagListElem)
  apply (safe)
  apply (simp add: intersectionYNode_def isTramMap_def)
  apply (simp add: segmentCompWithDag_def)
  apply (metis fst_conv segmentCompWithDagSym snd_conv)
by (simp)

(*##############trapezList###############*)
lemma newTrapezPointsXOrder1[simp]: "isTrapez T \<Longrightarrow> pointInTrapez T P \<Longrightarrow> pointInTrapez T Q \<Longrightarrow>
  leftFrom P Q \<Longrightarrow> trapezPointsXOrder (Abs_trapez (topT T, (P, Q), P, Q))"
  apply (auto simp add: trapezPointsXOrder_def)
  using isTrapez_def trapezPointsXOrder_def apply blast
by (simp add: isTrapez_def leftP_def pointInTrapez_def trapezPointsXOrder_def xCoord_def)+

lemma newTrapezA[simp]: "isTrapez T \<Longrightarrow> pointInTrapez T P \<Longrightarrow> pointInTrapez T Q \<Longrightarrow> leftFrom P Q \<Longrightarrow>
  trapezList (tDagList(newDagSimpA T P Q))"
  apply (simp add: newDagSimpA_def trapezList_def, auto)
  apply (auto simp add: isTrapez_def)
oops
lemma addSegmentTrapezList: "isTramMap D \<Longrightarrow> leftFrom P Q \<Longrightarrow> pointInDag D P \<Longrightarrow> pointInDag D Q \<Longrightarrow>
  segmentCompWithDag D P Q \<Longrightarrow> trapezList (tDagList (addSegmentToTrapMap D P Q))"
oops

(*##############isTramMap für rBox###############*)
lemma "isTrapez R \<Longrightarrow> segmentCompWithDag (Tip R) P Q \<Longrightarrow>
  trapezMapNeighbor (addSegmentToTrapMap (Tip R) P Q)"
  apply (simp add: addSegmentToTrapMap_def segmentCompWithDag_def)
  apply (subgoal_tac "intersectedTrapez (Tip R) P Q = [R]", simp)
  apply (simp add: trapezMapNeighbor_def, auto)
  apply (simp add: newDag_def)
  apply (simp only: newDagSimp_def)
  apply (case_tac "leftP R \<noteq> P \<and> rightP R \<noteq> Q", simp)
    apply (simp add:  newDagSimpQ_def newDagSimpA_def)
oops

(*##############pointsInTramMap###############*)
lemma newDagPointInTrapez: "D = (Node (Tip (Abs_trapez (topT T, (P, Q), P, Q))) (yNode (P, Q))
  (Tip (Abs_trapez ((P, Q), bottomT T, P, Q)))) \<Longrightarrow> leftFrom P Q \<Longrightarrow> pointInDag D a \<Longrightarrow>
  leftTurn P Q a \<Longrightarrow> trapezList (tDagList D) \<Longrightarrow> pointInTrapez (Abs_trapez (topT T, (P, Q), P, Q)) a"
  apply (auto simp add: pointInDag_def)
  apply (cut_tac T="(Abs_trapez ((P, Q), bottomT T, P, Q))" and P=a in isNotInTrapez)
by (auto simp add: trapezListSimp)

lemma addSegmentPointsInTramMap: "isTrapez T \<Longrightarrow> pointInTrapez T P \<Longrightarrow> pointInTrapez T Q \<Longrightarrow>
  pointsInTramMap (newDagSimpA T P Q)"
  apply (auto simp add: newDagSimpA_def pointsInTramMap_def)
  apply (subgoal_tac "isTrapez (Abs_trapez (topT T, (P, Q), P, Q))")
  apply (metis bottomT leftP leftPRigthFromRightP1 leftRightTurn newDagPointInTrapez newDagSimpA_def
    newTrapezA snd_conv)
oops

lemma addSegmentPointsInTramMap: "isTrapez T \<Longrightarrow> pointInTrapez T P \<Longrightarrow> pointInTrapez T Q \<Longrightarrow>
  pointsInTramMap (newDagSimp T P Q)"
  apply (simp add: newDagSimp_def)
oops
lemma addSegmentPointsInTramMap: "isTramMap D \<Longrightarrow> leftFrom P Q \<Longrightarrow> pointInDag D P \<Longrightarrow> pointInDag D Q \<Longrightarrow>
  segmentCompWithDag D P Q \<Longrightarrow> pointsInTramMap (addSegmentToTrapMap D P Q)"
  apply (simp add: addSegmentToTrapMap_def)
oops

(*##############uniqueXCoord for xDagList ###############*)
(*x-Nodes eines newDagSimp*)
lemma newDagSimpLeftCorner[simp]:"leftFrom P Q \<Longrightarrow> leftP T = P \<Longrightarrow>
  a \<in> set (xDagList (newDagSimp T P Q)) \<Longrightarrow> a \<noteq> P"
  apply (auto simp add: newDagSimp_def)
  apply (case_tac "rightP T \<noteq> Q ")
    apply (simp add: newDagSimpQ_def newDagSimpA_def, blast)
by (auto simp add: newDagSimpA_def)
lemma newDagSimpRightCorner[simp]:"leftFrom P Q \<Longrightarrow> rightP T = Q \<Longrightarrow>
  a \<in> set (xDagList (newDagSimp T P Q)) \<Longrightarrow> a \<noteq> Q"
  apply (auto simp add: newDagSimp_def)
  apply (case_tac "leftP T \<noteq> P ")
    apply (simp add: newDagSimpQ_def newDagSimpA_def, blast)
by (auto simp add: newDagSimpA_def)
(*x-Nodes eines newDag*)
lemma newDagLeftCorner[simp]:"leftFrom P Q \<Longrightarrow> leftP T = P \<Longrightarrow>
  a \<in> set (xDagList (newDag D T TM P Q)) \<Longrightarrow> a \<noteq> P"
  apply (auto simp add: newDag_def)
  apply (case_tac "length TM = Suc 0", simp)
    using newDagSimpLeftCorner apply blast
  apply (case_tac "queryTrapezoidMap D (leftP T) = T")
    apply (auto simp add: newDagFirst_def newDagFirstY_def)
  apply (case_tac "queryTrapezoidMap D Q = T \<or> rightP T = Q")
    apply (auto simp add: newDagLast_def newDagLastY_def)
  apply (case_tac "rightP (queryTrapezoidMap D Q) = Q")
    apply (simp add: newDagLastY_def)
  apply (simp, safe, metis)
by (simp add: newDagLastY_def)
lemma newDagRightCorner[simp]:"leftFrom P Q \<Longrightarrow> rightP T = Q \<Longrightarrow>
  a \<in> set (xDagList (newDag D T TM P Q)) \<Longrightarrow> a \<noteq> Q"
  apply (auto simp add: newDag_def)
  apply (case_tac "length TM = Suc 0", simp)
    using newDagSimpRightCorner apply blast
  apply (simp)
  apply (case_tac "queryTrapezoidMap D P = T", simp)
    apply (subgoal_tac "xDagList (newDagFirst T TM P (rightP T)) = [P]
      \<or> xDagList (newDagFirst T TM P (rightP T)) = []")
    apply (metis empty_iff insert_iff list.set(1) list.set(2) pointsUniqueXCoord uniqueX_notIn)
    using xDagListNewDagFirst apply blast
  apply (case_tac "queryTrapezoidMap D (rightP T) = T")
    apply (auto simp add: newDagLast_def newDagLastY_def)
done

(*welche Elemente besitz xDagList eines tDag's nach dem ein Trapez durch newDag ersetzt wurde*)
lemma replaceTipElement[intro]:"a \<in> set (xDagList (replaceTip T (newDag D T TM P Q) D)) \<Longrightarrow>
  a \<in> set (xDagList D) \<or> a \<in> set [P,Q]"
  apply (cut_tac oT=T and nT="newDag D T TM P Q" and D=D and a=a in replaceTipXDagList1, assumption)
  apply (erule disjE, simp)
  apply (thin_tac "a \<in> set (xDagList (replaceTip T (newDag D T TM P Q) D))")
by (metis insert_iff list.set(2) xDagListNewDag)

(*wie oft kommt P in xDagList vor nachdem ein Trapez mit newDag ersetzt wurde*)
lemma "isTramMap D \<Longrightarrow> segmentCompWithDag D P Q \<Longrightarrow> leftP T = P \<Longrightarrow>
   List.count (xDagList (replaceTip T (newDag D T TM P Q) D)) P \<le> 1"
  apply (case_tac "\<exists> a. a \<in> set (xDagList (replaceTip T (newDag D T TM P Q) D))")
  apply (erule exE)
  apply (subgoal_tac "\<forall> a. a \<in> set (xDagList (replaceTip T (newDag D T TM P Q) D)) \<longrightarrow>
         a \<in> set (xDagList D) \<or> a \<in> set (xDagList (newDag D T TM P Q))")
  apply (auto)
  apply (subgoal_tac "xDagList (newDag D T TM (leftP T) Q) = [Q] \<or>
    xDagList (newDag D T TM (leftP T) Q) = []")
  apply (auto)
  apply (subgoal_tac "Q \<noteq> P")
  apply (subgoal_tac "List.count (xDagList D) (leftP T) \<le> Suc 0")
  apply (erule_tac x=a in allE, simp)
  defer
  using isTramMap_def uniqueXNotDouble apply auto[1]
oops
lemma "isTramMap D \<Longrightarrow> leftFrom P Q \<Longrightarrow> pointInDag D P \<Longrightarrow> pointInDag D Q \<Longrightarrow>
  segmentCompWithDag D P Q \<Longrightarrow>
  List.count (xDagList (replaceDag D (intersectedTrapez D P Q) TM P Q)) Q = 1"
  apply (subgoal_tac "\<not>(\<exists> i. i < length (intersectedTrapez D P Q) - 1 \<and> i \<noteq> 0
    \<and> rightP ((intersectedTrapez D P Q)!i) = Q)")
  apply (subgoal_tac "\<not>(\<exists> i. i < length (intersectedTrapez D P Q) \<and> i \<noteq> 0
    \<and> leftP ((intersectedTrapez D P Q)!i) = P)")
  apply (induct D "intersectedTrapez D P Q" TM P Q rule: replaceDag.induct)
  apply (simp del: newDagSimpRightCorner newDagSimpLeftCorner)
  (*apply (metis (mono_tags) followSeg.simps intersectedTrapez_def isTramMap_def
    list.sel(2) list.sel(3) not_Cons_self2)*)
oops

(*alle x-Nodes besitzen unterschiedliche x-Koordinaten*)
lemma addSegmentsUnicX: "isTramMap D \<Longrightarrow> leftFrom P Q \<Longrightarrow> pointInDag D P \<Longrightarrow> pointInDag D Q \<Longrightarrow>
  segmentCompWithDag D P Q \<Longrightarrow> uniqueXCoord (xDagList (addSegmentToTrapMap D P Q))"
  (*nur da erste Trapez kann P entrhalten und das letzte Trapez Q,
    die mittleren Trapeze enthalten nichts*)
  apply (simp add: addSegmentToTrapMap_def)
    apply (case_tac "leftP (hd (intersectedTrapez D P Q)) \<noteq> P")
    apply (case_tac "rightP (last (intersectedTrapez D P Q)) \<noteq> Q")
  apply (subgoal_tac "\<forall> (a::point2d). List.count
    (xDagList (replaceDag D (intersectedTrapez D P Q) (intersectedTrapez D P Q) P Q)) a \<le> 1")

oops

(*####################*)

lemma "isTramMap D \<Longrightarrow> segmentCompWithDag D P Q \<Longrightarrow> D = addSegmentToTrapMap D P Q \<Longrightarrow>
  P \<in> set (xDagList D) \<and> Q \<in> set (xDagList D)"
oops
lemma addSegmentPointsInMap: "isTramMap D \<Longrightarrow> leftFrom P Q \<Longrightarrow> pointInDag D P \<Longrightarrow> pointInDag D Q \<Longrightarrow>
  segmentCompWithDag D P Q \<Longrightarrow> pointsInTramMap (addSegmentToTrapMap D P Q)"
  apply (simp add: addSegmentToTrapMap_def)
oops

theorem "isTramMap D \<Longrightarrow> leftFrom P Q \<Longrightarrow> pointInDag D P \<Longrightarrow> pointInDag D Q \<Longrightarrow>
  segmentCompWithDag D P Q \<Longrightarrow> isTramMap (addSegmentToTrapMap D P Q)"
  apply (simp add: addSegmentToTrapMap_def)
oops

end