(*  File:       Loop_Composition.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Loop Composition\<close>

theory Loop_Composition
  imports "Basic_Modules/Component_Types/Termination_Condition"
          "Basic_Modules/Defer_Module"
          Sequential_Composition
begin

text \<open>
  The loop composition uses the same module in sequence,
  combined with a termination condition, until either
  (1) the termination condition is met or
  (2) no new decisions are made (i.e., a fixed point is reached).
\<close>

subsection \<open>Definition\<close>

lemma loop_termination_helper:
  assumes
    not_term: "\<not>t (acc A p)" and
    subset: "defer (acc \<triangleright> m) A p \<subset> defer acc A p" and
    not_inf: "\<not>infinite (defer acc A p)"
  shows
    "((acc \<triangleright> m, m, t, A, p), (acc, m, t, A, p)) \<in>
        measure (\<lambda>(acc, m, t, A, p). card (defer acc A p))"
  using assms psubset_card_mono
  by simp

text \<open>
  This function handles the accumulator for the following loop composition
  function.
\<close>

function loop_comp_helper ::
    "'a Electoral_Module \<Rightarrow> 'a Electoral_Module \<Rightarrow>
        'a Termination_Condition \<Rightarrow> 'a Electoral_Module" where
  "t (acc A p) \<or> \<not>((defer (acc \<triangleright> m) A p) \<subset> (defer acc A p)) \<or>
    infinite (defer acc A p) \<Longrightarrow>
      loop_comp_helper acc m t A p = acc A p" |
  "\<not>(t (acc A p) \<or> \<not>((defer (acc \<triangleright> m) A p) \<subset> (defer acc A p)) \<or>
    infinite (defer acc A p)) \<Longrightarrow>
      loop_comp_helper acc m t A p = loop_comp_helper (acc \<triangleright> m) m t A p"
proof -
  fix
    P :: bool and
    x :: "('a Electoral_Module) \<times> ('a Electoral_Module) \<times>
          ('a Termination_Condition) \<times> 'a set \<times> 'a Profile"
  assume
    a1: "\<And> t acc A p m.
          \<lbrakk>t (acc A p) \<or> \<not> defer (acc \<triangleright> m) A p \<subset> defer acc A p \<or>
              infinite (defer acc A p);
            x = (acc, m, t, A, p)\<rbrakk> \<Longrightarrow> P" and
    a2: "\<And> t acc A p m.
          \<lbrakk>\<not> (t (acc A p) \<or> \<not> defer (acc \<triangleright> m) A p \<subset> defer acc A p \<or>
              infinite (defer acc A p));
            x = (acc, m, t, A, p)\<rbrakk> \<Longrightarrow> P"
  have "\<exists> f A p p2 g. (g, f, p, A, p2) = x"
    using prod_cases5
    by metis
  thus P
    using a2 a1
    by (metis (no_types))
next
  show
    "\<And> t acc A p m ta acca Aa pa ma.
       t (acc A p) \<or> \<not> defer (acc \<triangleright> m) A p \<subset> defer acc A p \<or>
        infinite (defer acc A p) \<Longrightarrow>
          ta (acca Aa pa) \<or> \<not> defer (acca \<triangleright> ma) Aa pa \<subset> defer acca Aa pa \<or>
          infinite (defer acca Aa pa) \<Longrightarrow>
           (acc, m, t, A, p) = (acca, ma, ta, Aa, pa) \<Longrightarrow>
              acc A p = acca Aa pa"
    by fastforce
next
  show
    "\<And> t acc A p m ta acca Aa pa ma.
       t (acc A p) \<or> \<not> defer (acc \<triangleright> m) A p \<subset> defer acc A p \<or>
        infinite (defer acc A p) \<Longrightarrow>
          \<not> (ta (acca Aa pa) \<or> \<not> defer (acca \<triangleright> ma) Aa pa \<subset> defer acca Aa pa \<or>
          infinite (defer acca Aa pa)) \<Longrightarrow>
           (acc, m, t, A, p) = (acca, ma, ta, Aa, pa) \<Longrightarrow>
              acc A p = loop_comp_helper_sumC (acca \<triangleright> ma, ma, ta, Aa, pa)"
  proof -
    fix
      t :: "'a Termination_Condition" and
      acc :: "'a Electoral_Module" and
      A :: "'a set" and
      p :: "'a Profile" and
      m :: "'a Electoral_Module" and
      ta :: "'a Termination_Condition" and
      acca :: "'a Electoral_Module" and
      Aa :: "'a set" and
      pa :: "'a Profile" and
      ma :: "'a Electoral_Module"
    assume
      a1: "t (acc A p) \<or> \<not> defer (acc \<triangleright> m) A p \<subset> defer acc A p \<or>
            infinite (defer acc A p)" and
      a2: "\<not> (ta (acca Aa pa) \<or> \<not> defer (acca \<triangleright> ma) Aa pa \<subset> defer acca Aa pa \<or>
            infinite (defer acca Aa pa))" and
      "(acc, m, t, A, p) = (acca, ma, ta, Aa, pa)"
    hence False
      using a2 a1
      by force
  thus "acc A p = loop_comp_helper_sumC (acca \<triangleright> ma, ma, ta, Aa, pa)"
    by auto
qed
next
  show
    "\<And> t acc A p m ta acca Aa pa ma.
       \<not> (t (acc A p) \<or> \<not> defer (acc \<triangleright> m) A p \<subset> defer acc A p \<or>
          infinite (defer acc A p)) \<Longrightarrow>
           \<not> (ta (acca Aa pa) \<or> \<not> defer (acca \<triangleright> ma) Aa pa \<subset> defer acca Aa pa \<or>
            infinite (defer acca Aa pa)) \<Longrightarrow>
             (acc, m, t, A, p) = (acca, ma, ta, Aa, pa) \<Longrightarrow>
                loop_comp_helper_sumC (acc \<triangleright> m, m, t, A, p) =
                  loop_comp_helper_sumC (acca \<triangleright> ma, ma, ta, Aa, pa)"
    by force
qed
termination
proof -
  have func_term:
    "\<exists> r. wf r \<and>
        (\<forall>p f (A::'a set) prof g.
          p (f A prof) \<or>
          \<not> defer (f \<triangleright> g) A prof \<subset> defer f A prof \<or>
          infinite (defer f A prof) \<or>
          ((f \<triangleright> g, g, p, A, prof), (f, g, p, A, prof)) \<in> r)"
    using loop_termination_helper wf_measure "termination"
    by (metis (no_types))
  hence
    "\<forall> r p.
      Ex ((\<lambda> ra. \<forall> f (A::'a set) prof pa g.
            \<exists> prof2 pb p_rel pc pd h (B::'a set) prof3 i pe.
        \<not> wf r \<or>
          loop_comp_helper_dom
            (p::('a Electoral_Module) \<times> (_ Electoral_Module) \<times>
              (_ Termination_Condition) \<times> _ set \<times> _ Profile) \<or>
          infinite (defer f A prof) \<or>
          pa (f A prof) \<and>
            wf
              (prof2::((
                ('a Electoral_Module) \<times> ('a Electoral_Module) \<times>
                ('a Termination_Condition) \<times> 'a set \<times> 'a Profile) \<times> _) set) \<and>
            \<not> loop_comp_helper_dom (pb::
                ('a Electoral_Module) \<times> (_ Electoral_Module) \<times>
                (_ Termination_Condition) \<times> _ set \<times> _ Profile) \<or>
          wf p_rel \<and> \<not> defer (f \<triangleright> g) A prof \<subset> defer f A prof \<and>
            \<not> loop_comp_helper_dom
                (pc::('a Electoral_Module) \<times> (_ Electoral_Module) \<times>
                  (_ Termination_Condition) \<times> _ set \<times> _ Profile) \<or>
            ((f \<triangleright> g, g, pa, A, prof), f, g, pa, A, prof) \<in> p_rel \<and> wf p_rel \<and>
            \<not> loop_comp_helper_dom
                (pd::('a Electoral_Module) \<times> (_ Electoral_Module) \<times>
                  (_ Termination_Condition) \<times> _ set \<times> _ Profile) \<or>
            finite (defer h B prof3) \<and>
            defer (h \<triangleright> i) B prof3 \<subset> defer h B prof3 \<and>
            \<not> pe (h B prof3) \<and>
            ((h \<triangleright> i, i, pe, B, prof3), h, i, pe, B, prof3) \<notin> r)::
          ((('a Electoral_Module) \<times> ('a Electoral_Module) \<times>
            ('a Termination_Condition) \<times> 'a set \<times> 'a Profile) \<times>
            ('a Electoral_Module) \<times> ('a Electoral_Module) \<times>
            ('a Termination_Condition) \<times> 'a set \<times> 'a Profile) set \<Rightarrow> bool)"
    by metis
  obtain
    p_rel ::  "((('a Electoral_Module) \<times> ('a Electoral_Module) \<times>
               ('a Termination_Condition) \<times> 'a set \<times> 'a Profile) \<times>
               ('a Electoral_Module) \<times> ('a Electoral_Module) \<times>
               ('a Termination_Condition) \<times> 'a set \<times> 'a Profile) set" where
      "wf p_rel \<and>
        (\<forall> p f A prof g. p (f A prof) \<or>
          \<not> defer (f \<triangleright> g) A prof \<subset> defer f A prof \<or>
          infinite (defer f A prof) \<or>
          ((f \<triangleright> g, g, p, A, prof), f, g, p, A, prof) \<in> p_rel)"
    using func_term
    by presburger
  thus ?thesis
    using "termination"
    by metis
qed

lemma loop_comp_code_helper[code]:
  "loop_comp_helper acc m t A p =
    (if (t (acc A p) \<or> \<not>((defer (acc \<triangleright> m) A p) \<subset> (defer acc A p)) \<or>
      infinite (defer acc A p))
    then (acc A p) else (loop_comp_helper (acc \<triangleright> m) m t A p))"
  by simp

function loop_composition ::
    "'a Electoral_Module \<Rightarrow> 'a Termination_Condition \<Rightarrow>
        'a Electoral_Module" where
  "t ({}, {}, A) \<Longrightarrow>
    loop_composition m t A p = defer_module A p" |
  "\<not>(t ({}, {}, A)) \<Longrightarrow>
    loop_composition m t A p = (loop_comp_helper m m t) A p"
  by (fastforce, simp_all)
termination
  using "termination" wf_empty
  by blast

abbreviation loop ::
  "'a Electoral_Module \<Rightarrow> 'a Termination_Condition \<Rightarrow> 'a Electoral_Module"
    ("_ \<circlearrowleft>\<^sub>_" 50) where
  "m \<circlearrowleft>\<^sub>t \<equiv> loop_composition m t"

lemma loop_comp_code[code]:
  "loop_composition m t A p =
    (if (t ({},{},A))
    then (defer_module A p) else (loop_comp_helper m m t) A p)"
  by simp

lemma loop_comp_helper_imp_partit:
  assumes
    module_m: "electoral_module m" and
    profile: "finite_profile A p"
  shows
    "electoral_module acc \<and> (n = card (defer acc A p)) \<Longrightarrow>
        well_formed A (loop_comp_helper acc m t A p)"
proof (induct arbitrary: acc rule: less_induct)
  case (less)
  have
    "\<forall> (f::'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Result) g.
      (electoral_module f \<and> electoral_module g) \<longrightarrow>
        electoral_module (f \<triangleright> g)"
    by auto
  hence "electoral_module (acc \<triangleright> m)"
    using less.prems module_m
    by metis
  hence wf_acc:
    "\<not> t (acc A p) \<and> \<not> t (acc A p) \<and>
      defer (acc \<triangleright> m) A p \<subset> defer acc A p \<and>
      finite (defer acc A p) \<longrightarrow>
        well_formed A (loop_comp_helper acc m t A p)"
    using less.hyps less.prems loop_comp_helper.simps(2)
          psubset_card_mono
  by metis
  have "well_formed A (acc A p)"
    using less.prems profile
    unfolding electoral_module_def
    by blast
  thus ?case
    using wf_acc loop_comp_helper.simps(1)
    by (metis (no_types))
qed

subsection \<open>Soundness\<close>

theorem loop_comp_sound:
  assumes "electoral_module m"
  shows "electoral_module (m \<circlearrowleft>\<^sub>t)"
  using def_mod_sound loop_composition.simps(1) loop_composition.simps(2)
        loop_comp_helper_imp_partit assms
  unfolding electoral_module_def
  by metis

lemma loop_comp_helper_imp_no_def_incr:
  assumes
    module_m: "electoral_module m" and
    profile: "finite_profile A p"
  shows
    "(electoral_module acc \<and> n = card (defer acc A p)) \<Longrightarrow>
        defer (loop_comp_helper acc m t) A p \<subseteq> defer acc A p"
proof (induct arbitrary: acc rule: less_induct)
  case (less)
  have emod_acc_m: "electoral_module (acc \<triangleright> m)"
    using less.prems module_m
    by simp
  have "\<forall> A A'. infinite (A::'a set) \<or> \<not> A' \<subset> A \<or> card A' < card A"
    using psubset_card_mono
    by metis
  hence
    "\<not> t (acc A p) \<and> defer (acc \<triangleright> m) A p \<subset> defer acc A p \<and>
      finite (defer acc A p) \<longrightarrow>
        defer (loop_comp_helper (acc \<triangleright> m) m t) A p \<subseteq> defer acc A p"
    using emod_acc_m less.hyps less.prems
    by blast
  hence
    "\<not> t (acc A p) \<and> defer (acc \<triangleright> m) A p \<subset> defer acc A p \<and>
        finite (defer acc A p) \<longrightarrow>
          defer (loop_comp_helper acc m t) A p \<subseteq> defer acc A p"
    using loop_comp_helper.simps(2)
    by (metis (no_types))
  thus ?case
    using eq_iff loop_comp_helper.simps(1)
    by (metis (no_types))
qed

subsection \<open>Lemmata\<close>

lemma loop_comp_helper_def_lift_inv_helper:
  assumes
    monotone_m: "defer_lift_invariance m" and
    f_prof: "finite_profile A p"
  shows
    "(defer_lift_invariance acc \<and> n = card (defer acc A p)) \<longrightarrow>
        (\<forall> q a.
          (a \<in> (defer (loop_comp_helper acc m t) A p) \<and>
            lifted A p q a) \<longrightarrow>
                (loop_comp_helper acc m t) A p =
                  (loop_comp_helper acc m t) A q)"
proof (induct n arbitrary: acc rule: less_induct)
  case (less n)
  have defer_card_comp:
    "defer_lift_invariance acc \<longrightarrow>
        (\<forall> q a. (a \<in> (defer (acc \<triangleright> m) A p) \<and> lifted A p q a) \<longrightarrow>
            card (defer (acc \<triangleright> m) A p) = card (defer (acc \<triangleright> m) A q))"
    using monotone_m def_lift_inv_seq_comp_help
    by metis
  have defer_card_acc:
    "defer_lift_invariance acc \<longrightarrow>
        (\<forall> q a. (a \<in> (defer (acc) A p) \<and> lifted A p q a) \<longrightarrow>
            card (defer (acc) A p) = card (defer (acc) A q))"
    unfolding defer_lift_invariance_def
    by simp
  hence defer_card_acc_2:
    "defer_lift_invariance acc \<longrightarrow>
        (\<forall> q a. (a \<in> (defer (acc \<triangleright> m) A p) \<and> lifted A p q a) \<longrightarrow>
            card (defer (acc) A p) = card (defer (acc) A q))"
    using monotone_m f_prof seq_comp_def_set_trans
    unfolding defer_lift_invariance_def
    by metis
  thus ?case
  proof cases
    assume card_unchanged: "card (defer (acc \<triangleright> m) A p) = card (defer acc A p)"
    with defer_card_comp defer_card_acc monotone_m
    have
      "defer_lift_invariance (acc) \<longrightarrow>
          (\<forall> q a. (a \<in> (defer (acc) A p) \<and> lifted A p q a) \<longrightarrow>
              (loop_comp_helper acc m t) A q = acc A q)"
    proof (safe)
      fix
        q :: "'a Profile" and
        a :: "'a"
      assume
        def_card_eq:
        "card (defer (acc \<triangleright> m) A p) = card (defer acc A p)" and
        dli_acc: "defer_lift_invariance acc" and
        def_seq_lift_card:
        "\<forall> q a. a \<in> defer (acc \<triangleright> m) A p \<and> Profile.lifted A p q a \<longrightarrow>
          card (defer (acc \<triangleright> m) A p) = card (defer (acc \<triangleright> m) A q)" and
        a_in_def_acc: "a \<in> defer acc A p" and
        lifted_A: "Profile.lifted A p q a"
      have emod_m: "electoral_module m"
        using monotone_m
        unfolding defer_lift_invariance_def
        by simp
      have emod_acc: "electoral_module acc"
        using dli_acc
        unfolding defer_lift_invariance_def
        by simp
      have acc_eq_pq: "acc A q = acc A p"
        using a_in_def_acc dli_acc lifted_A
        unfolding defer_lift_invariance_def
        by (metis (full_types))
      with emod_acc emod_m
      have
        "finite (defer acc A p) \<longrightarrow>
          loop_comp_helper acc m t A q = acc A q"
        using a_in_def_acc def_card_eq def_seq_lift_card
              dual_order.strict_iff_order f_prof lifted_A
              loop_comp_code_helper psubset_card_mono
              seq_comp_def_set_bounded
        by (metis (no_types))
      thus "loop_comp_helper acc m t A q = acc A q"
        using acc_eq_pq loop_comp_code_helper
        by (metis (full_types))
    qed
    moreover from card_unchanged
    have "(loop_comp_helper acc m t) A p = acc A p"
      using loop_comp_helper.simps(1) order.strict_iff_order
            psubset_card_mono
      by metis
    ultimately have
      "(defer_lift_invariance (acc \<triangleright> m) \<and> defer_lift_invariance acc) \<longrightarrow>
          (\<forall> q a. (a \<in> (defer (loop_comp_helper acc m t) A p) \<and>
              lifted A p q a) \<longrightarrow>
                  (loop_comp_helper acc m t) A p =
                    (loop_comp_helper acc m t) A q)"
      unfolding defer_lift_invariance_def
      by metis
    thus ?thesis
      using monotone_m seq_comp_presv_def_lift_inv
      by blast
  next
    assume card_changed:
      "\<not> (card (defer (acc \<triangleright> m) A p) = card (defer acc A p))"
    with f_prof seq_comp_def_card_bounded
    have card_smaller_for_p:
      "electoral_module (acc) \<longrightarrow>
          (card (defer (acc \<triangleright> m) A p) < card (defer acc A p))"
      using monotone_m order.not_eq_order_implies_strict
      unfolding defer_lift_invariance_def
      by (metis (full_types))
    with defer_card_acc_2 defer_card_comp
    have card_changed_for_q:
      "defer_lift_invariance (acc) \<longrightarrow>
          (\<forall> q a. (a \<in> (defer (acc \<triangleright> m) A p) \<and> lifted A p q a) \<longrightarrow>
              (card (defer (acc \<triangleright> m) A q) < card (defer acc A q)))"
      unfolding defer_lift_invariance_def
      by (metis (no_types, lifting))
    thus ?thesis
    proof cases
      assume t_not_satisfied_for_p: "\<not> t (acc A p)"
      hence t_not_satisfied_for_q:
        "defer_lift_invariance (acc) \<longrightarrow>
            (\<forall> q a. (a \<in> (defer (acc \<triangleright> m) A p) \<and> lifted A p q a) \<longrightarrow>
                \<not> t (acc A q))"
        using monotone_m f_prof seq_comp_def_set_trans
        unfolding defer_lift_invariance_def
        by metis
      from card_changed defer_card_comp defer_card_acc
      have dli_card_def:
        "(defer_lift_invariance (acc \<triangleright> m) \<and> defer_lift_invariance (acc)) \<longrightarrow>
            (\<forall> q a. (a \<in> (defer (acc \<triangleright> m) A p) \<and> Profile.lifted A p q a) \<longrightarrow>
                card (defer (acc \<triangleright> m) A q) \<noteq> (card (defer acc A q)))"
      proof -
        have
          "\<forall> f.
            (defer_lift_invariance f \<or>
              (\<exists> A prof prof2 (a::'a).
                f A prof \<noteq> f A prof2 \<and>
                  Profile.lifted A prof prof2 a \<and>
                  a \<in> defer f A prof) \<or> \<not> electoral_module f) \<and>
                  ((\<forall> A p1 p2 b. f A p1 = f A p2 \<or> \<not> Profile.lifted A p1 p2 b \<or>
                    b \<notin> defer f A p1) \<and>
                  electoral_module f \<or> \<not> defer_lift_invariance f)"
          unfolding defer_lift_invariance_def
          by blast
        thus ?thesis
          using card_changed monotone_m f_prof seq_comp_def_set_trans
          by (metis (no_types, opaque_lifting))
      qed
      hence dli_def_subset:
        "defer_lift_invariance (acc \<triangleright> m) \<and> defer_lift_invariance (acc) \<longrightarrow>
            (\<forall> q a. (a \<in> (defer (acc \<triangleright> m) A p) \<and> lifted A p q a) \<longrightarrow>
                defer (acc \<triangleright> m) A q \<subset> defer acc A q)"
      proof -
        {
          fix
            alt :: 'a and
            prof :: "'a Profile"
          have
            "(\<not> defer_lift_invariance (acc \<triangleright> m) \<or> \<not> defer_lift_invariance acc) \<or>
              (alt \<notin> defer (acc \<triangleright> m) A p \<or> \<not> lifted A p prof alt) \<or>
              defer (acc \<triangleright> m) A prof \<subset> defer acc A prof"
            using Profile.lifted_def dli_card_def defer_lift_invariance_def
                  monotone_m psubsetI seq_comp_def_set_bounded
            by (metis (no_types))
        }
        thus ?thesis
          by metis
      qed
      with t_not_satisfied_for_p
      have rec_step_q:
        "(defer_lift_invariance (acc \<triangleright> m) \<and> defer_lift_invariance (acc)) \<longrightarrow>
            (\<forall> q a. (a \<in> (defer (acc \<triangleright> m) A p) \<and> lifted A p q a) \<longrightarrow>
                loop_comp_helper acc m t A q =
                  loop_comp_helper (acc \<triangleright> m) m t A q)"
      proof (safe)
        fix
          q :: "'a Profile" and
          a :: "'a"
        assume
          a_in_def_impl_def_subset:
          "\<forall> q a. a \<in> defer (acc \<triangleright> m) A p \<and> lifted A p q a \<longrightarrow>
            defer (acc \<triangleright> m) A q \<subset> defer acc A q" and
          dli_acc: "defer_lift_invariance acc" and
          a_in_def_seq_acc_m: "a \<in> defer (acc \<triangleright> m) A p" and
          lifted_pq_a: "lifted A p q a"
        have defer_subset_acc:
          "defer (acc \<triangleright> m) A q \<subset> defer acc A q"
          using a_in_def_impl_def_subset lifted_pq_a
                a_in_def_seq_acc_m
          by metis
        have "electoral_module acc"
          using dli_acc
          unfolding defer_lift_invariance_def
          by simp
        hence "finite (defer acc A q) \<and> \<not> t (acc A q)"
          using lifted_def dli_acc a_in_def_seq_acc_m
                lifted_pq_a def_presv_fin_prof
                t_not_satisfied_for_q
          by metis
        with defer_subset_acc
        show
          "loop_comp_helper acc m t A q =
            loop_comp_helper (acc \<triangleright> m) m t A q"
          using loop_comp_code_helper
          by metis
      qed
      have rec_step_p:
        "electoral_module acc \<longrightarrow>
            loop_comp_helper acc m t A p = loop_comp_helper (acc \<triangleright> m) m t A p"
      proof (safe)
        assume emod_acc: "electoral_module acc"
        have emod_implies_defer_subset:
          "electoral_module m \<longrightarrow> defer (acc \<triangleright> m) A p \<subseteq> defer acc A p"
          using emod_acc f_prof seq_comp_def_set_bounded
          by blast
        have card_ineq: "card (defer (acc \<triangleright> m) A p) < card (defer acc A p)"
          using card_smaller_for_p emod_acc
          by force
        have fin_def_limited_acc:
          "finite_profile (defer acc A p) (limit_profile (defer acc A p) p)"
          using def_presv_fin_prof emod_acc f_prof
          by metis
        have "defer (acc \<triangleright> m) A p \<subseteq> defer acc A p"
          using emod_implies_defer_subset defer_lift_invariance_def monotone_m
          by blast
        hence "defer (acc \<triangleright> m) A p \<subset> defer acc A p"
          using fin_def_limited_acc card_ineq card_psubset
          by metis
        with fin_def_limited_acc
        show "loop_comp_helper acc m t A p = loop_comp_helper (acc \<triangleright> m) m t A p"
          using loop_comp_code_helper t_not_satisfied_for_p
          by (metis (no_types))
      qed
      show ?thesis
      proof (safe)
        fix
          q :: "'a Profile" and
          a :: "'a"
        assume
          dli_acc: "defer_lift_invariance acc" and
          n_card_acc: "n = card (defer acc A p)" and
          a_in_defer_lch: "a \<in> defer (loop_comp_helper acc m t) A p" and
          a_lifted: "Profile.lifted A p q a"
        hence emod_acc: "electoral_module acc"
          unfolding defer_lift_invariance_def
          by metis
        have "defer_lift_invariance (acc \<triangleright> m) \<and> a \<in> defer (acc \<triangleright> m) A p"
          using a_in_defer_lch defer_lift_invariance_def dli_acc
                f_prof loop_comp_helper_imp_no_def_incr monotone_m
                rec_step_p seq_comp_presv_def_lift_inv subsetD
          by (metis (no_types))
        with emod_acc
        show "loop_comp_helper acc m t A p = loop_comp_helper acc m t A q"
          using a_in_defer_lch a_lifted card_smaller_for_p dli_acc
                less.hyps n_card_acc rec_step_p rec_step_q
          by (metis (full_types))
      qed
    next
      assume "\<not> \<not>t (acc A p)"
      thus ?thesis
        using loop_comp_helper.simps(1)
        unfolding defer_lift_invariance_def
        by metis
    qed
  qed
qed

lemma loop_comp_helper_def_lift_inv:
  assumes
    monotone_m: "defer_lift_invariance m" and
    monotone_acc: "defer_lift_invariance acc" and
    profile: "finite_profile A p"
  shows
    "\<forall> q a. (lifted A p q a \<and> a \<in> (defer (loop_comp_helper acc m t) A p)) \<longrightarrow>
        (loop_comp_helper acc m t) A p = (loop_comp_helper acc m t) A q"
  using loop_comp_helper_def_lift_inv_helper
        monotone_m monotone_acc profile
  by blast

lemma loop_comp_helper_def_lift_inv2:
  assumes
    monotone_m: "defer_lift_invariance m" and
    monotone_acc: "defer_lift_invariance acc" and
    finite_A_p: "finite_profile A p" and
    lifted_A_pq: "lifted A p q a" and
    a_in_defer_acc: "a \<in> defer (loop_comp_helper acc m t) A p"
  shows "(loop_comp_helper acc m t) A p = (loop_comp_helper acc m t) A q"
  using finite_A_p lifted_A_pq a_in_defer_acc
        loop_comp_helper_def_lift_inv
        monotone_acc monotone_m
  by blast

lemma lifted_imp_fin_prof:
  assumes "lifted A p q a"
  shows "finite_profile A p"
  using assms
  unfolding Profile.lifted_def
  by simp

lemma loop_comp_helper_presv_def_lift_inv:
  assumes
    monotone_m: "defer_lift_invariance m" and
    monotone_acc: "defer_lift_invariance acc"
  shows "defer_lift_invariance (loop_comp_helper acc m t)"
proof (unfold defer_lift_invariance_def, safe)
  show "electoral_module (loop_comp_helper acc m t)"
    using electoral_modI loop_comp_helper_imp_partit monotone_acc monotone_m
    unfolding defer_lift_invariance_def
    by (metis (no_types))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    q :: "'a Profile" and
    a :: "'a"
  assume
    defer_a: "a \<in> defer (loop_comp_helper acc m t) A p" and
    lift_a: "Profile.lifted A p q a"
  show "loop_comp_helper acc m t A p = loop_comp_helper acc m t A q"
    using defer_a lift_a lifted_imp_fin_prof loop_comp_helper_def_lift_inv
          monotone_acc monotone_m
    by (metis (full_types))
qed

lemma loop_comp_presv_non_electing_helper:
  assumes
    non_electing_m: "non_electing m" and
    non_electing_acc: "non_electing acc" and
    f_prof: "finite_profile A p" and
    acc_defer_card: "n = card (defer acc A p)"
  shows "elect (loop_comp_helper acc m t) A p = {}"
  using acc_defer_card non_electing_acc
proof (induct n arbitrary: acc rule: less_induct)
  case (less n)
  thus ?case
  proof (safe)
    fix x :: "'a"
    assume
      y_acc_no_elect:
      "(\<And> y acc'. y < card (defer acc A p) \<Longrightarrow>
        y = card (defer acc' A p) \<Longrightarrow> non_electing acc' \<Longrightarrow>
          elect (loop_comp_helper acc' m t) A p = {})" and
      acc_non_elect: "non_electing acc" and
      x_in_acc_elect: "x \<in> elect (loop_comp_helper acc m t) A p"
    have
      "\<forall> (f::'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Result) g.
        (non_electing f \<and> non_electing g) \<longrightarrow>
          non_electing (f \<triangleright> g)"
      by simp
    hence seq_acc_m_non_elect: "non_electing (acc \<triangleright> m)"
      using acc_non_elect non_electing_m
      by blast
    have "\<forall> A B. (finite (A::'a set) \<and> B \<subset> A) \<longrightarrow> card B < card A"
      using psubset_card_mono
      by metis
    hence card_ineq:
      "\<forall> A B. (finite (A::'a set) \<and> B \<subset> A) \<longrightarrow> card B < card A"
      by presburger
    have no_elect_acc: "elect acc A p = {}"
      using acc_non_elect f_prof non_electing_def
      by auto
    have card_n_no_elect:
      "\<forall> n f.
        (n < card (defer acc A p) \<and> n = card (defer f A p) \<and> non_electing f) \<longrightarrow>
          elect (loop_comp_helper f m t) A p = {}"
      using y_acc_no_elect
      by blast
    have
      "\<And> f.
        (finite (defer acc A p) \<and> defer f A p \<subset> defer acc A p \<and> non_electing f) \<longrightarrow>
          elect (loop_comp_helper f m t) A p = {}"
      using card_n_no_elect psubset_card_mono
      by metis
    hence loop_helper_term:
      "(\<not> t (acc A p) \<and> defer (acc \<triangleright> m) A p \<subset> defer acc A p \<and>
            finite (defer acc A p)) \<and>
          \<not> t (acc A p) \<longrightarrow>
        elect (loop_comp_helper acc m t) A p = {}"
      using loop_comp_code_helper seq_acc_m_non_elect
      by (metis (no_types))
    obtain set_func :: "'a set \<Rightarrow> 'a" where
      "\<forall> A. (A = {} \<longrightarrow> (\<forall> a. a \<notin> A)) \<and> (A \<noteq> {} \<longrightarrow> set_func A \<in> A)"
      using all_not_in_conv
      by (metis (no_types))
    thus "x \<in> {}"
      using loop_comp_code_helper no_elect_acc x_in_acc_elect loop_helper_term
      by (metis (no_types))
  qed
qed

lemma loop_comp_helper_iter_elim_def_n_helper:
  assumes
    non_electing_m: "non_electing m" and
    single_elimination: "eliminates 1 m" and
    terminate_if_n_left: "\<forall> r. ((t r) \<longleftrightarrow> (card (defer_r r) = x))" and
    x_greater_zero: "x > 0" and
    f_prof: "finite_profile A p" and
    n_acc_defer_card: "n = card (defer acc A p)" and
    n_ge_x: "n \<ge> x" and
    def_card_gt_one: "card (defer acc A p) > 1" and
    acc_nonelect: "non_electing acc"
  shows "card (defer (loop_comp_helper acc m t) A p) = x"
  using n_ge_x def_card_gt_one acc_nonelect n_acc_defer_card
proof (induct n arbitrary: acc rule: less_induct)
  (* Likely, this induction here makes little sense, as it is over the size
     of the defer set. The expectation is going forward as in (acc \<triangleright> m),
     but that would imply that the defer set is shrinking with each step.
     It might be worth revising this proof at some point in the future. *)
  case (less n)
  have mod_acc: "electoral_module acc"
    using less.prems(3) non_electing_def
    by metis
  hence step_reduces_defer_set:
    "defer (acc \<triangleright> m) A p \<subset> defer acc A p"
    using seq_comp_elim_one_red_def_set single_elimination
          f_prof less.prems(2)
    by metis
  thus ?case
  proof (cases "t (acc A p)")
    case True (* Terminate now *)
    hence "(loop_comp_helper acc m t A p) = acc A p"
      by simp
    thus "card (defer_r (loop_comp_helper acc m t A p)) = x"
      using terminate_if_n_left True
      by metis
  next
    case False (* Termination condition not met *)
    hence card_not_eq_x: "card (defer acc A p) \<noteq> x"
      using terminate_if_n_left
      by metis
    have "\<not>(infinite (defer acc A p))"
      using def_presv_fin_prof f_prof mod_acc
      by (metis (full_types))
    hence rec_step:
      "loop_comp_helper acc m t A p = loop_comp_helper (acc \<triangleright> m) m t A p"
      using False loop_comp_helper.simps(2) step_reduces_defer_set
      by metis
    have card_too_big: "card (defer acc A p) > x"
      using card_not_eq_x dual_order.order_iff_strict less.prems(1, 4)
      by simp
    hence enough_leftover: "card (defer acc A p) > 1"
      using x_greater_zero
      by simp
    obtain k where
      new_card_k: "k = card (defer (acc \<triangleright> m) A p)"
      by metis
    have "defer acc A p \<subseteq> A"
      using defer_in_alts f_prof mod_acc
      by metis
    hence step_profile:
      "finite_profile (defer acc A p) (limit_profile (defer acc A p) p)"
      using f_prof limit_profile_sound
      by metis
    hence
      "card (defer m (defer acc A p) (limit_profile (defer acc A p) p)) =
        card (defer acc A p) - 1"
      using enough_leftover non_electing_m single_elim_decr_def_card2
            single_elimination
      by metis
    hence k_card: "k = card (defer acc A p) - 1"
      using mod_acc f_prof new_card_k non_electing_def
            non_electing_m seq_comp_defers_def_set
      by metis
    hence new_card_still_big_enough: "x \<le> k"
      using card_too_big
      by linarith
    show ?thesis
    proof (cases "x < k")
      case True
      hence "1 < card (defer (acc \<triangleright> m) A p)"
        using new_card_k x_greater_zero
        by linarith
      moreover have "k < n"
        using step_reduces_defer_set step_profile psubset_card_mono
              new_card_k less.prems(4)
        by blast
      moreover have "electoral_module (acc \<triangleright> m)"
        using mod_acc eliminates_def seq_comp_sound
              single_elimination
        by metis
      moreover have "non_electing (acc \<triangleright> m)"
        using less.prems(3) non_electing_m
        by simp
      ultimately have
        "card (defer (loop_comp_helper (acc \<triangleright> m) m t) A p) = x"
        using new_card_k new_card_still_big_enough less.hyps
        by metis
      thus ?thesis
        using rec_step
        by presburger
    next
      case False (* k \<le> x (but actually, we can show k = x) *)
      thus ?thesis
        using dual_order.strict_iff_order new_card_k
              new_card_still_big_enough rec_step
              terminate_if_n_left
        by simp
    qed
  qed
qed

lemma loop_comp_helper_iter_elim_def_n:
  assumes
    non_electing_m: "non_electing m" and
    single_elimination: "eliminates 1 m" and
    terminate_if_n_left: "\<forall> r. ((t r) \<longleftrightarrow> (card (defer_r r) = x))" and
    x_greater_zero: "x > 0" and
    f_prof: "finite_profile A p" and
    acc_defers_enough: "card (defer acc A p) \<ge> x" and
    non_electing_acc: "non_electing acc"
  shows "card (defer (loop_comp_helper acc m t) A p) = x"
  using acc_defers_enough gr_implies_not0 le_neq_implies_less
        less_one linorder_neqE_nat loop_comp_helper.simps(1)
        loop_comp_helper_iter_elim_def_n_helper non_electing_acc
        non_electing_m f_prof single_elimination nat_neq_iff
        terminate_if_n_left x_greater_zero less_le
  by (metis (no_types, lifting))

lemma iter_elim_def_n_helper:
  assumes
    non_electing_m: "non_electing m" and
    single_elimination: "eliminates 1 m" and
    terminate_if_n_left: "\<forall> r. ((t r) \<longleftrightarrow> (card (defer_r r) = x))" and
    x_greater_zero: "x > 0" and
    f_prof: "finite_profile A p" and
    enough_alternatives: "card A \<ge> x"
  shows "card (defer (m \<circlearrowleft>\<^sub>t) A p) = x"
proof cases
  assume "card A = x"
  thus ?thesis
    by (simp add: terminate_if_n_left)
next
  assume card_not_x: "\<not> card A = x"
  thus ?thesis
  proof cases
    assume "card A < x"
    thus ?thesis
      using enough_alternatives not_le
      by blast
  next
    assume "\<not>card A < x"
    hence card_big_enough_A: "card A > x"
      using card_not_x
      by linarith
    hence card_m: "card (defer m A p) = card A - 1"
      using non_electing_m f_prof single_elimination
            single_elim_decr_def_card2 x_greater_zero
      by fastforce
    hence card_big_enough_m: "card (defer m A p) \<ge> x"
      using card_big_enough_A
      by linarith
    hence "(m \<circlearrowleft>\<^sub>t) A p = (loop_comp_helper m m t) A p"
      by (simp add: card_not_x terminate_if_n_left)
    thus ?thesis
      using card_big_enough_m non_electing_m f_prof single_elimination
            terminate_if_n_left x_greater_zero
            loop_comp_helper_iter_elim_def_n
      by metis
  qed
qed

subsection \<open>Composition Rules\<close>

text \<open>
  The loop composition preserves defer-lift-invariance.
\<close>

theorem loop_comp_presv_def_lift_inv[simp]:
  assumes "defer_lift_invariance m"
  shows "defer_lift_invariance (m \<circlearrowleft>\<^sub>t)"
proof (unfold defer_lift_invariance_def, safe)
  from assms
  have "electoral_module m"
    unfolding defer_lift_invariance_def
    by simp
  thus "electoral_module (m \<circlearrowleft>\<^sub>t)"
    by (simp add: loop_comp_sound)
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    q :: "'a Profile" and
    a :: "'a"
  assume
    a_in_loop_defer: "a \<in> defer (m \<circlearrowleft>\<^sub>t) A p" and
    lifted_a: "Profile.lifted A p q a"
  have defer_lift_loop:
    "\<forall> p q a. (a \<in> (defer (m \<circlearrowleft>\<^sub>t) A p) \<and> lifted A p q a) \<longrightarrow>
        (m \<circlearrowleft>\<^sub>t) A p = (m \<circlearrowleft>\<^sub>t) A q"
    using assms lifted_imp_fin_prof loop_comp_helper_def_lift_inv2
          loop_composition.simps defer_module.simps
    by (metis (full_types))
  show "(m \<circlearrowleft>\<^sub>t) A p = (m \<circlearrowleft>\<^sub>t) A q"
    using a_in_loop_defer lifted_a defer_lift_loop
    by metis
qed

text \<open>
  The loop composition preserves the property non-electing.
\<close>

theorem loop_comp_presv_non_electing[simp]:
  assumes non_electing_m: "non_electing m"
  shows "non_electing (m \<circlearrowleft>\<^sub>t)"
proof (unfold non_electing_def, safe, simp_all)
  show "electoral_module (m \<circlearrowleft>\<^sub>t)"
    using loop_comp_sound non_electing_m
    unfolding non_electing_def
    by metis
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    x :: "'a"
  assume
    "finite A" and
    "profile A p" and
    "x \<in> elect (m \<circlearrowleft>\<^sub>t) A p"
  thus False
    using def_mod_non_electing loop_comp_presv_non_electing_helper
          non_electing_m empty_iff loop_comp_code
    unfolding non_electing_def
    by (metis (no_types))
qed

theorem iter_elim_def_n[simp]:
  assumes
    non_electing_m: "non_electing m" and
    single_elimination: "eliminates 1 m" and
    terminate_if_n_left: "\<forall> r. ((t r) \<longleftrightarrow> (card (defer_r r) = n))" and
    x_greater_zero: "n > 0"
  shows "defers n (m \<circlearrowleft>\<^sub>t)"
proof (unfold defers_def, safe)
  show "electoral_module (m \<circlearrowleft>\<^sub>t)"
    using loop_comp_sound non_electing_m
    unfolding non_electing_def
    by metis
next
  fix
    A :: "'a set" and
    p :: "'a Profile"
  assume
    "n \<le> card A" and
    "finite A" and
    "profile A p"
  thus "card (defer (m \<circlearrowleft>\<^sub>t) A p) = n"
    using iter_elim_def_n_helper non_electing_m single_elimination
          terminate_if_n_left x_greater_zero
    by metis
qed

end


(*  Author:     Giampaolo Bella, Catania University
*)

section\<open>Bella's modification of the Shoup-Rubin protocol\<close>

theory ShoupRubinBella imports Smartcard begin

text\<open>The modifications are that message 7 now mentions A, while message 10
now mentions Nb and B. The lack of explicitness of the original version was
discovered by investigating adherence to the principle of Goal
Availability. Only the updated version makes the goals of confidentiality,
authentication and key distribution available to both peers.\<close>

axiomatization sesK :: "nat*key => key"
where
   (*sesK is injective on each component*)
   inj_sesK [iff]: "(sesK(m,k) = sesK(m',k')) = (m = m' \<and> k = k')" and

   (*all long-term keys differ from sesK*)
   shrK_disj_sesK [iff]: "shrK A \<noteq> sesK(m,pk)" and
   crdK_disj_sesK [iff]: "crdK C \<noteq> sesK(m,pk)" and
   pin_disj_sesK  [iff]: "pin P \<noteq> sesK(m,pk)" and
   pairK_disj_sesK[iff]: "pairK(A,B) \<noteq> sesK(m,pk)" and

   (*needed for base case in analz_image_freshK*)
   Atomic_distrib [iff]: "Atomic`(KEY`K \<union> NONCE`N) =
                   Atomic`(KEY`K) \<union> Atomic`(NONCE`N)" and

  (*this protocol makes the assumption of secure means
    between each agent and his smartcard*)
   shouprubin_assumes_securemeans [iff]: "evs \<in> srb \<Longrightarrow> secureM"

definition Unique :: "[event, event list] => bool" ("Unique _ on _") where
   "Unique ev on evs ==
      ev \<notin> set (tl (dropWhile (% z. z \<noteq> ev) evs))"

inductive_set srb :: "event list set"
  where

    Nil:  "[]\<in> srb"

  | Fake: "\<lbrakk> evsF \<in> srb;  X \<in> synth (analz (knows Spy evsF));
             illegalUse(Card B) \<rbrakk>
          \<Longrightarrow> Says Spy A X #
              Inputs Spy (Card B) X # evsF \<in> srb"

(*In general this rule causes the assumption Card B \<notin> cloned
  in most guarantees for B - starting with confidentiality -
  otherwise pairK_confidential could not apply*)
  | Forge:
         "\<lbrakk> evsFo \<in> srb; Nonce Nb \<in> analz (knows Spy evsFo);
             Key (pairK(A,B)) \<in> knows Spy evsFo \<rbrakk>
          \<Longrightarrow> Notes Spy (Key (sesK(Nb,pairK(A,B)))) # evsFo \<in> srb"

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

(*A AND THE SERVER*)
  | SR_U1:  "\<lbrakk> evs1 \<in> srb; A \<noteq> Server \<rbrakk>
          \<Longrightarrow> Says A Server \<lbrace>Agent A, Agent B\<rbrace>
                # evs1 \<in> srb"

  | SR_U2:  "\<lbrakk> evs2 \<in> srb;
             Gets Server \<lbrace>Agent A, Agent B\<rbrace> \<in> set evs2 \<rbrakk>
          \<Longrightarrow> Says Server A \<lbrace>Nonce (Pairkey(A,B)),
                           Crypt (shrK A) \<lbrace>Nonce (Pairkey(A,B)), Agent B\<rbrace>
                  \<rbrace>
                # evs2 \<in> srb"

(*A AND HER CARD*)
(*A cannot decrypt the verifier for she dosn't know shrK A,
  but the pairkey is recognisable*)
  | SR_U3:  "\<lbrakk> evs3 \<in> srb; legalUse(Card A);
             Says A Server \<lbrace>Agent A, Agent B\<rbrace> \<in> set evs3;
             Gets A \<lbrace>Nonce Pk, Certificate\<rbrace> \<in> set evs3 \<rbrakk>
          \<Longrightarrow> Inputs A (Card A) (Agent A)
                # evs3 \<in> srb"   (*however A only queries her card
if she has previously contacted the server to initiate with some B.
Otherwise she would do so even if the Server had not been active.
Still, this doesn't and can't mean that the pairkey originated with
the server*)

(*The card outputs the nonce Na to A*)
  | SR_U4:  "\<lbrakk> evs4 \<in> srb;
             Nonce Na \<notin> used evs4; legalUse(Card A); A \<noteq> Server;
             Inputs A (Card A) (Agent A) \<in> set evs4 \<rbrakk>
       \<Longrightarrow> Outpts (Card A) A \<lbrace>Nonce Na, Crypt (crdK (Card A)) (Nonce Na)\<rbrace>
              # evs4 \<in> srb"

(*The card can be exploited by the spy*)
(*because of the assumptions on the card, A is certainly not server nor spy*)
  | SR_U4Fake: "\<lbrakk> evs4F \<in> srb; Nonce Na \<notin> used evs4F;
             illegalUse(Card A);
             Inputs Spy (Card A) (Agent A) \<in> set evs4F \<rbrakk>
      \<Longrightarrow> Outpts (Card A) Spy \<lbrace>Nonce Na, Crypt (crdK (Card A)) (Nonce Na)\<rbrace>
            # evs4F \<in> srb"

(*A TOWARDS B*)
  | SR_U5:  "\<lbrakk> evs5 \<in> srb;
             Outpts (Card A) A \<lbrace>Nonce Na, Certificate\<rbrace> \<in> set evs5;
             \<forall> p q. Certificate \<noteq> \<lbrace>p, q\<rbrace> \<rbrakk>
          \<Longrightarrow> Says A B \<lbrace>Agent A, Nonce Na\<rbrace> # evs5 \<in> srb"
(*A must check that the verifier is not a compound message,
  otherwise this would also fire after SR_U7 *)

(*B AND HIS CARD*)
  | SR_U6:  "\<lbrakk> evs6 \<in> srb; legalUse(Card B);
             Gets B \<lbrace>Agent A, Nonce Na\<rbrace> \<in> set evs6 \<rbrakk>
          \<Longrightarrow> Inputs B (Card B) \<lbrace>Agent A, Nonce Na\<rbrace>
                # evs6 \<in> srb"
(*B gets back from the card the session key and various verifiers*)
  | SR_U7:  "\<lbrakk> evs7 \<in> srb;
             Nonce Nb \<notin> used evs7; legalUse(Card B); B \<noteq> Server;
             K = sesK(Nb,pairK(A,B));
             Key K \<notin> used evs7;
             Inputs B (Card B) \<lbrace>Agent A, Nonce Na\<rbrace> \<in> set evs7\<rbrakk>
    \<Longrightarrow> Outpts (Card B) B \<lbrace>Nonce Nb, Agent A, Key K,
                            Crypt (pairK(A,B)) \<lbrace>Nonce Na, Nonce Nb\<rbrace>,
                            Crypt (pairK(A,B)) (Nonce Nb)\<rbrace>
                # evs7 \<in> srb"
(*The card can be exploited by the spy*)
(*because of the assumptions on the card, A is certainly not server nor spy*)
  | SR_U7Fake:  "\<lbrakk> evs7F \<in> srb; Nonce Nb \<notin> used evs7F;
             illegalUse(Card B);
             K = sesK(Nb,pairK(A,B));
             Key K \<notin> used evs7F;
             Inputs Spy (Card B) \<lbrace>Agent A, Nonce Na\<rbrace> \<in> set evs7F \<rbrakk>
          \<Longrightarrow> Outpts (Card B) Spy \<lbrace>Nonce Nb, Agent A, Key K,
                            Crypt (pairK(A,B)) \<lbrace>Nonce Na, Nonce Nb\<rbrace>,
                            Crypt (pairK(A,B)) (Nonce Nb)\<rbrace>
                # evs7F \<in> srb"

(*B TOWARDS A*)
(*having sent an input that mentions A is the only memory B relies on,
  since the output doesn't mention A - lack of explicitness*)
  | SR_U8:  "\<lbrakk> evs8 \<in> srb;
             Inputs B (Card B) \<lbrace>Agent A, Nonce Na\<rbrace> \<in> set evs8;
             Outpts (Card B) B \<lbrace>Nonce Nb, Agent A, Key K,
                                 Cert1, Cert2\<rbrace> \<in> set evs8 \<rbrakk>
          \<Longrightarrow> Says B A \<lbrace>Nonce Nb, Cert1\<rbrace> # evs8 \<in> srb"

(*A AND HER CARD*)
(*A cannot check the form of the verifiers - although I can prove the form of
  Cert2 - and just feeds her card with what she's got*)
  | SR_U9:  "\<lbrakk> evs9 \<in> srb; legalUse(Card A);
             Gets A \<lbrace>Nonce Pk, Cert1\<rbrace> \<in> set evs9;
             Outpts (Card A) A \<lbrace>Nonce Na, Cert2\<rbrace> \<in> set evs9;
             Gets A \<lbrace>Nonce Nb, Cert3\<rbrace> \<in> set evs9;
             \<forall> p q. Cert2 \<noteq> \<lbrace>p, q\<rbrace> \<rbrakk>
          \<Longrightarrow> Inputs A (Card A)
                 \<lbrace>Agent B, Nonce Na, Nonce Nb, Nonce Pk,
                  Cert1, Cert3, Cert2\<rbrace>
                # evs9 \<in> srb"
(*But the card will only give outputs to the inputs of the correct form*)
  | SR_U10: "\<lbrakk> evs10 \<in> srb; legalUse(Card A); A \<noteq> Server;
             K = sesK(Nb,pairK(A,B));
             Inputs A (Card A) \<lbrace>Agent B, Nonce Na, Nonce Nb,
                                 Nonce (Pairkey(A,B)),
                                 Crypt (shrK A) \<lbrace>Nonce (Pairkey(A,B)),
                                                   Agent B\<rbrace>,
                                 Crypt (pairK(A,B)) \<lbrace>Nonce Na, Nonce Nb\<rbrace>,
                                 Crypt (crdK (Card A)) (Nonce Na)\<rbrace>
               \<in> set evs10 \<rbrakk>
          \<Longrightarrow> Outpts (Card A) A \<lbrace>Agent B, Nonce Nb,
                                 Key K, Crypt (pairK(A,B)) (Nonce Nb)\<rbrace>
                 # evs10 \<in> srb"
(*The card can be exploited by the spy*)
(*because of the assumptions on the card, A is certainly not server nor spy*)
  | SR_U10Fake: "\<lbrakk> evs10F \<in> srb;
             illegalUse(Card A);
             K = sesK(Nb,pairK(A,B));
             Inputs Spy (Card A) \<lbrace>Agent B, Nonce Na, Nonce Nb,
                                   Nonce (Pairkey(A,B)),
                                   Crypt (shrK A) \<lbrace>Nonce (Pairkey(A,B)),
                                                    Agent B\<rbrace>,
                                   Crypt (pairK(A,B)) \<lbrace>Nonce Na, Nonce Nb\<rbrace>,
                                   Crypt (crdK (Card A)) (Nonce Na)\<rbrace>
               \<in> set evs10F \<rbrakk>
          \<Longrightarrow> Outpts (Card A) Spy \<lbrace>Agent B, Nonce Nb,
                                   Key K, Crypt (pairK(A,B)) (Nonce Nb)\<rbrace>
                 # evs10F \<in> srb"

(*A TOWARDS B*)
(*having initiated with B is the only memory A relies on,
  since the output doesn't mention B - lack of explicitness*)
  | SR_U11: "\<lbrakk> evs11 \<in> srb;
             Says A Server \<lbrace>Agent A, Agent B\<rbrace> \<in> set evs11;
             Outpts (Card A) A \<lbrace>Agent B, Nonce Nb, Key K, Certificate\<rbrace>
               \<in> set evs11 \<rbrakk>
          \<Longrightarrow> Says A B (Certificate)
                 # evs11 \<in> srb"

(*Both peers may leak by accident the session keys obtained from their
  cards*)
  | Oops1:
     "\<lbrakk> evsO1 \<in> srb;
         Outpts (Card B) B \<lbrace>Nonce Nb, Agent A, Key K, Cert1, Cert2\<rbrace>
           \<in> set evsO1 \<rbrakk>
     \<Longrightarrow> Notes Spy \<lbrace>Key K, Nonce Nb, Agent A, Agent B\<rbrace> # evsO1 \<in> srb"

  | Oops2:
     "\<lbrakk> evsO2 \<in> srb;
         Outpts (Card A) A \<lbrace>Agent B, Nonce Nb, Key K, Certificate\<rbrace>
           \<in> set evsO2 \<rbrakk>
    \<Longrightarrow> Notes Spy \<lbrace>Key K, Nonce Nb, Agent A, Agent B\<rbrace> # evsO2 \<in> srb"

(*To solve Fake case when it doesn't involve analz - used to be condensed
  into Fake_parts_insert_tac*)
declare Fake_parts_insert_in_Un  [dest]
declare analz_into_parts [dest]
(*declare parts_insertI [intro]*)

(*General facts about message reception*)
lemma Gets_imp_Says:
       "\<lbrakk> Gets B X \<in> set evs; evs \<in> srb \<rbrakk> \<Longrightarrow> \<exists> A. Says A B X \<in> set evs"
apply (erule rev_mp, erule srb.induct)
apply auto
done

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

lemma Gets_imp_knows_Spy_parts_Snd:
     "\<lbrakk> Gets B \<lbrace>X, Y\<rbrace> \<in> set evs; evs \<in> srb \<rbrakk>  \<Longrightarrow> Y \<in> parts (knows Spy evs)"
apply (blast dest!: Gets_imp_Says Says_imp_knows_Spy parts.Inj parts.Snd)
done

lemma Gets_imp_knows_Spy_analz_Snd:
     "\<lbrakk> Gets B \<lbrace>X, Y\<rbrace> \<in> set evs; evs \<in> srb \<rbrakk>  \<Longrightarrow> Y \<in> analz (knows Spy evs)"
apply (blast dest!: Gets_imp_Says Says_imp_knows_Spy analz.Inj analz.Snd)
done

(*end general facts*)

(*Begin lemmas on secure means, from Event.thy, proved for shouprubin. They help
  the simplifier, especially in analz_image_freshK*)

lemma Inputs_imp_knows_Spy_secureM_srb:
      "\<lbrakk> Inputs Spy C X \<in> set evs; evs \<in> srb \<rbrakk> \<Longrightarrow> X \<in> knows Spy evs"
apply (simp (no_asm_simp) add: Inputs_imp_knows_Spy_secureM)
done

lemma knows_Spy_Inputs_secureM_srb_Spy:
      "evs \<in>srb \<Longrightarrow> knows Spy (Inputs Spy C X # evs) = insert X (knows Spy evs)"
apply (simp (no_asm_simp))
done

lemma knows_Spy_Inputs_secureM_srb:
    "\<lbrakk> A \<noteq> Spy; evs \<in>srb \<rbrakk> \<Longrightarrow> knows Spy (Inputs A C X # evs) =  knows Spy evs"
apply (simp (no_asm_simp))
done

lemma knows_Spy_Outpts_secureM_srb_Spy:
      "evs \<in>srb \<Longrightarrow> knows Spy (Outpts C Spy X # evs) = insert X (knows Spy evs)"
apply (simp (no_asm_simp))
done

lemma knows_Spy_Outpts_secureM_srb:
     "\<lbrakk> A \<noteq> Spy; evs \<in>srb \<rbrakk> \<Longrightarrow> knows Spy (Outpts C A X # evs) =  knows Spy evs"
apply (simp (no_asm_simp))
done

(*End lemmas on secure means for shouprubin*)

(*BEGIN technical lemmas - evolution of forwarding lemmas*)

(*If an honest agent uses a smart card, then the card is his/her own, is
  not stolen, and the agent has received suitable data to feed the card.
  In other words, these are guarantees that an honest agent can only use
  his/her own card, and must use it correctly.
  On the contrary, the spy can "Inputs" any cloned cards also by the Fake rule.

  Instead of Auto_tac, proofs here used to asm-simplify and then force-tac.
*)
lemma Inputs_A_Card_3:
    "\<lbrakk> Inputs A C (Agent A) \<in> set evs; A \<noteq> Spy; evs \<in> srb \<rbrakk>
     \<Longrightarrow> legalUse(C) \<and> C = (Card A) \<and>
      (\<exists> Pk Certificate. Gets A \<lbrace>Pk, Certificate\<rbrace> \<in> set evs)"
apply (erule rev_mp, erule srb.induct)
apply auto
done

lemma Inputs_B_Card_6:
     "\<lbrakk> Inputs B C \<lbrace>Agent A, Nonce Na\<rbrace> \<in> set evs; B \<noteq> Spy; evs \<in> srb \<rbrakk>
      \<Longrightarrow> legalUse(C) \<and> C = (Card B) \<and> Gets B \<lbrace>Agent A, Nonce Na\<rbrace> \<in> set evs"
apply (erule rev_mp, erule srb.induct)
apply auto
done

lemma Inputs_A_Card_9:
     "\<lbrakk> Inputs A C \<lbrace>Agent B, Nonce Na, Nonce Nb, Nonce Pk,
                                           Cert1, Cert2, Cert3\<rbrace> \<in> set evs;
         A \<noteq> Spy; evs \<in> srb \<rbrakk>
  \<Longrightarrow> legalUse(C) \<and> C = (Card A) \<and>
      Gets A \<lbrace>Nonce Pk, Cert1\<rbrace> \<in> set evs     \<and>
      Outpts (Card A) A \<lbrace>Nonce Na, Cert3\<rbrace> \<in> set evs        \<and>
      Gets A \<lbrace>Nonce Nb, Cert2\<rbrace> \<in> set evs"
apply (erule rev_mp, erule srb.induct)
apply auto
done

(*The two occurrences of A in the Outpts event don't match SR_U4Fake, where
  A cannot be the Spy. Hence the card is legally usable by rule SR_U4*)
lemma Outpts_A_Card_4:
     "\<lbrakk> Outpts C A \<lbrace>Nonce Na, (Crypt (crdK (Card A)) (Nonce Na))\<rbrace> \<in> set evs;
         evs \<in> srb \<rbrakk>
     \<Longrightarrow> legalUse(C) \<and> C = (Card A) \<and>
         Inputs A (Card A) (Agent A) \<in> set evs"
apply (erule rev_mp, erule srb.induct)
apply auto
done

(*First certificate is made explicit so that a comment similar to the previous
  applies. This also provides Na to the Inputs event in the conclusion*)
lemma Outpts_B_Card_7:
      "\<lbrakk> Outpts C B \<lbrace>Nonce Nb, Agent A, Key K,
                      Crypt (pairK(A,B)) \<lbrace>Nonce Na, Nonce Nb\<rbrace>,
                      Cert2\<rbrace> \<in> set evs;
         evs \<in> srb \<rbrakk>
     \<Longrightarrow> legalUse(C) \<and> C = (Card B) \<and>
         Inputs B (Card B) \<lbrace>Agent A, Nonce Na\<rbrace> \<in> set evs"
apply (erule rev_mp, erule srb.induct)
apply auto
done

lemma Outpts_A_Card_10:
     "\<lbrakk> Outpts C A \<lbrace>Agent B, Nonce Nb,
                    Key K, (Crypt (pairK(A,B)) (Nonce Nb))\<rbrace> \<in> set evs;
         evs \<in> srb \<rbrakk>
     \<Longrightarrow> legalUse(C) \<and> C = (Card A) \<and>
         (\<exists> Na Ver1 Ver2 Ver3.
       Inputs A (Card A) \<lbrace>Agent B, Nonce Na, Nonce Nb, Nonce (Pairkey(A,B)),
                              Ver1, Ver2, Ver3\<rbrace> \<in> set evs)"
apply (erule rev_mp, erule srb.induct)
apply auto
done

(*
Contrarily to original version, A doesn't need to check the form of the
certificate to learn that her peer is B. The goal is available to A.
*)
lemma Outpts_A_Card_10_imp_Inputs:
     "\<lbrakk> Outpts (Card A) A \<lbrace>Agent B, Nonce Nb, Key K, Certificate\<rbrace>
          \<in> set evs; evs \<in> srb \<rbrakk>
     \<Longrightarrow> (\<exists> Na Ver1 Ver2 Ver3.
       Inputs A (Card A) \<lbrace>Agent B, Nonce Na, Nonce Nb, Nonce (Pairkey(A,B)),
                              Ver1, Ver2, Ver3\<rbrace> \<in> set evs)"
apply (erule rev_mp, erule srb.induct)
apply simp_all
apply blast+
done

(*Weaker version: if the agent can't check the forms of the verifiers, then
  the agent must not be the spy so as to solve SR_U4Fake. The verifier must be
  recognised as some cyphertex in order to distinguish from case SR_U7,
  concerning B's output, which also begins with a nonce.
*)
lemma Outpts_honest_A_Card_4:
     "\<lbrakk> Outpts C A \<lbrace>Nonce Na, Crypt K X\<rbrace> \<in>set evs;
         A \<noteq> Spy;  evs \<in> srb \<rbrakk>
     \<Longrightarrow> legalUse(C) \<and> C = (Card A) \<and>
         Inputs A (Card A) (Agent A) \<in> set evs"
apply (erule rev_mp, erule srb.induct)
apply auto
done

(*alternative formulation of same theorem
Goal "\<lbrakk> Outpts C A \<lbrace>Nonce Na, Certificate\<rbrace> \<in> set evs;
         \<forall> p q. Certificate \<noteq> \<lbrace>p, q\<rbrace>;
         A \<noteq> Spy; evs \<in> srb \<rbrakk>
     \<Longrightarrow> legalUse(C) \<and> C = (Card A) \<and>
         Inputs A (Card A) (Agent A) \<in> set evs"
same proof
*)

lemma Outpts_honest_B_Card_7:
    "\<lbrakk> Outpts C B \<lbrace>Nonce Nb, Agent A, Key K, Cert1, Cert2\<rbrace> \<in> set evs;
       B \<noteq> Spy; evs \<in> srb \<rbrakk>
   \<Longrightarrow> legalUse(C) \<and> C = (Card B) \<and>
       (\<exists> Na. Inputs B (Card B) \<lbrace>Agent A, Nonce Na\<rbrace> \<in> set evs)"
apply (erule rev_mp, erule srb.induct)
apply auto
done

lemma Outpts_honest_A_Card_10:
     "\<lbrakk> Outpts C A \<lbrace>Agent B, Nonce Nb, Key K, Certificate\<rbrace> \<in> set evs;
         A \<noteq> Spy; evs \<in> srb \<rbrakk>
     \<Longrightarrow> legalUse (C) \<and> C = (Card A) \<and>
         (\<exists> Na Pk Ver1 Ver2 Ver3.
          Inputs A (Card A) \<lbrace>Agent B, Nonce Na, Nonce Nb, Pk,
                              Ver1, Ver2, Ver3\<rbrace> \<in> set evs)"
apply (erule rev_mp, erule srb.induct)
apply simp_all
apply blast+
done
(*-END-*)

(*Even weaker versions: if the agent can't check the forms of the verifiers
  and the agent may be the spy, then we must know what card the agent
  is getting the output from.
*)
lemma Outpts_which_Card_4:
    "\<lbrakk> Outpts (Card A) A \<lbrace>Nonce Na, Crypt K X\<rbrace> \<in> set evs; evs \<in> srb \<rbrakk>
    \<Longrightarrow> Inputs A (Card A) (Agent A) \<in> set evs"
apply (erule rev_mp, erule srb.induct)
apply (simp_all (no_asm_simp))
apply clarify
done

lemma Outpts_which_Card_7:
  "\<lbrakk> Outpts (Card B) B \<lbrace>Nonce Nb, Agent A, Key K, Cert1, Cert2\<rbrace>
       \<in> set evs;  evs \<in> srb \<rbrakk>
     \<Longrightarrow> \<exists> Na. Inputs B (Card B) \<lbrace>Agent A, Nonce Na\<rbrace> \<in> set evs"
apply (erule rev_mp, erule srb.induct)
apply auto
done

(*This goal is now available - in the sense of Goal Availability*)
lemma Outpts_which_Card_10:
    "\<lbrakk> Outpts (Card A) A \<lbrace>Agent B, Nonce Nb, Key K, Certificate \<rbrace> \<in> set evs;
       evs \<in> srb \<rbrakk>
    \<Longrightarrow> \<exists> Na. Inputs A (Card A) \<lbrace>Agent B, Nonce Na, Nonce Nb, Nonce (Pairkey(A,B)),
                            Crypt (shrK A) \<lbrace>Nonce (Pairkey(A,B)), Agent B\<rbrace>,
                            Crypt (pairK(A,B)) \<lbrace>Nonce Na, Nonce Nb\<rbrace>,
                            Crypt (crdK (Card A)) (Nonce Na) \<rbrace> \<in> set evs"
apply (erule rev_mp, erule srb.induct)
apply auto
done

(*Lemmas on the form of outputs*)

(*A needs to check that the verifier is a cipher for it to come from SR_U4
  otherwise it could come from SR_U7 *)
lemma Outpts_A_Card_form_4:
  "\<lbrakk> Outpts (Card A) A \<lbrace>Nonce Na, Certificate\<rbrace> \<in> set evs;
         \<forall> p q. Certificate \<noteq> \<lbrace>p, q\<rbrace>; evs \<in> srb \<rbrakk>
     \<Longrightarrow> Certificate = (Crypt (crdK (Card A)) (Nonce Na))"
apply (erule rev_mp, erule srb.induct)
apply (simp_all (no_asm_simp))
done

lemma Outpts_B_Card_form_7:
   "\<lbrakk> Outpts (Card B) B \<lbrace>Nonce Nb, Agent A, Key K, Cert1, Cert2\<rbrace>
        \<in> set evs; evs \<in> srb \<rbrakk>
      \<Longrightarrow> \<exists> Na.
          K = sesK(Nb,pairK(A,B)) \<and>
          Cert1 = (Crypt (pairK(A,B)) \<lbrace>Nonce Na, Nonce Nb\<rbrace>) \<and>
          Cert2 = (Crypt (pairK(A,B)) (Nonce Nb))"
apply (erule rev_mp, erule srb.induct)
apply auto
done

lemma Outpts_A_Card_form_10:
   "\<lbrakk> Outpts (Card A) A \<lbrace>Agent B, Nonce Nb, Key K, Certificate\<rbrace>
        \<in> set evs; evs \<in> srb \<rbrakk>
      \<Longrightarrow> K = sesK(Nb,pairK(A,B)) \<and>
          Certificate = (Crypt (pairK(A,B)) (Nonce Nb))"
apply (erule rev_mp, erule srb.induct)
apply (simp_all (no_asm_simp))
done

lemma Outpts_A_Card_form_bis:
  "\<lbrakk> Outpts (Card A') A' \<lbrace>Agent B', Nonce Nb', Key (sesK(Nb,pairK(A,B))),
     Certificate\<rbrace> \<in> set evs;
         evs \<in> srb \<rbrakk>
      \<Longrightarrow> A' = A \<and> B' = B \<and> Nb = Nb' \<and>
          Certificate = (Crypt (pairK(A,B)) (Nonce Nb))"
apply (erule rev_mp, erule srb.induct)
apply (simp_all (no_asm_simp))
done

(*\<dots> and Inputs *)

lemma Inputs_A_Card_form_9:

     "\<lbrakk> Inputs A (Card A) \<lbrace>Agent B, Nonce Na, Nonce Nb, Nonce Pk,
                             Cert1, Cert2, Cert3\<rbrace> \<in> set evs;
         evs \<in> srb \<rbrakk>
  \<Longrightarrow>    Cert3 = Crypt (crdK (Card A)) (Nonce Na)"
apply (erule rev_mp)
apply (erule srb.induct)
apply (simp_all (no_asm_simp))
(*Fake*)
apply force
(*SR_U9*)
apply (blast dest!: Outpts_A_Card_form_4)
done
(* Pk, Cert1, Cert2 cannot be made explicit because they traversed the network in the clear *)

(*General guarantees on Inputs and Outpts*)

(*for any agents*)

lemma Inputs_Card_legalUse:
  "\<lbrakk> Inputs A (Card A) X \<in> set evs; evs \<in> srb \<rbrakk> \<Longrightarrow> legalUse(Card A)"
apply (erule rev_mp, erule srb.induct)
apply auto
done

lemma Outpts_Card_legalUse:
  "\<lbrakk> Outpts (Card A) A X \<in> set evs; evs \<in> srb \<rbrakk> \<Longrightarrow> legalUse(Card A)"
apply (erule rev_mp, erule srb.induct)
apply auto
done

(*for honest agents*)

lemma Inputs_Card: "\<lbrakk> Inputs A C X \<in> set evs; A \<noteq> Spy; evs \<in> srb \<rbrakk>
      \<Longrightarrow> C = (Card A) \<and> legalUse(C)"
apply (erule rev_mp, erule srb.induct)
apply auto
done

lemma Outpts_Card: "\<lbrakk> Outpts C A X \<in> set evs; A \<noteq> Spy; evs \<in> srb \<rbrakk>
      \<Longrightarrow> C = (Card A) \<and> legalUse(C)"
apply (erule rev_mp, erule srb.induct)
apply auto
done

lemma Inputs_Outpts_Card:
     "\<lbrakk> Inputs A C X \<in> set evs \<or> Outpts C A Y \<in> set evs;
         A \<noteq> Spy; evs \<in> srb \<rbrakk>
     \<Longrightarrow> C = (Card A) \<and> legalUse(Card A)"
apply (blast dest: Inputs_Card Outpts_Card)
done

(*for the spy - they stress that the model behaves as it is meant to*)

(*The or version can be also proved directly.
  It stresses that the spy may use either her own legally usable card or
  all the illegally usable cards.
*)
lemma Inputs_Card_Spy:
  "\<lbrakk> Inputs Spy C X \<in> set evs \<or> Outpts C Spy X \<in> set evs; evs \<in> srb \<rbrakk>
      \<Longrightarrow> C = (Card Spy) \<and> legalUse(Card Spy) \<or>
          (\<exists> A. C = (Card A) \<and> illegalUse(Card A))"
apply (erule rev_mp, erule srb.induct)
apply auto
done

(*END technical lemmas*)

(*BEGIN unicity theorems: certain items uniquely identify a smart card's
                          output*)

(*A's card's first output: the nonce uniquely identifies the rest*)
lemma Outpts_A_Card_unique_nonce:
     "\<lbrakk> Outpts (Card A) A \<lbrace>Nonce Na, Crypt (crdK (Card A)) (Nonce Na)\<rbrace>
           \<in> set evs;
         Outpts (Card A') A' \<lbrace>Nonce Na, Crypt (crdK (Card A')) (Nonce Na)\<rbrace>
           \<in> set evs;
         evs \<in> srb \<rbrakk> \<Longrightarrow> A=A'"
apply (erule rev_mp, erule rev_mp, erule srb.induct, simp_all)
apply (fastforce dest: Outpts_parts_used)
apply blast
done

(*B's card's output: the NONCE uniquely identifies the rest*)
lemma Outpts_B_Card_unique_nonce:
     "\<lbrakk> Outpts (Card B) B \<lbrace>Nonce Nb, Agent A, Key SK, Cert1, Cert2\<rbrace> \<in> set evs;
      Outpts (Card B') B' \<lbrace>Nonce Nb, Agent A', Key SK', Cert1', Cert2'\<rbrace> \<in> set evs;
       evs \<in> srb \<rbrakk> \<Longrightarrow> B=B' \<and> A=A' \<and> SK=SK' \<and> Cert1=Cert1' \<and> Cert2=Cert2'"
apply (erule rev_mp, erule rev_mp, erule srb.induct, simp_all)
apply (fastforce dest: Outpts_parts_used)
apply blast
done

(*B's card's output: the SESKEY uniquely identifies the rest*)
lemma Outpts_B_Card_unique_key:
     "\<lbrakk> Outpts (Card B) B \<lbrace>Nonce Nb, Agent A, Key SK, Cert1, Cert2\<rbrace> \<in> set evs;
      Outpts (Card B') B' \<lbrace>Nonce Nb', Agent A', Key SK, Cert1', Cert2'\<rbrace> \<in> set evs;
       evs \<in> srb \<rbrakk> \<Longrightarrow> B=B' \<and> A=A' \<and> Nb=Nb' \<and> Cert1=Cert1' \<and> Cert2=Cert2'"
apply (erule rev_mp, erule rev_mp, erule srb.induct, simp_all)
apply (fastforce dest: Outpts_parts_used)
apply blast
done

lemma Outpts_A_Card_unique_key:
   "\<lbrakk> Outpts (Card A) A \<lbrace>Agent B, Nonce Nb, Key K, V\<rbrace> \<in> set evs;
      Outpts (Card A') A' \<lbrace>Agent B', Nonce Nb', Key K, V'\<rbrace> \<in> set evs;
         evs \<in> srb \<rbrakk> \<Longrightarrow> A=A' \<and> B=B' \<and> Nb=Nb' \<and> V=V'"
apply (erule rev_mp, erule rev_mp, erule srb.induct, simp_all)
apply (blast dest: Outpts_A_Card_form_bis)
apply blast
done

(*Revised unicity theorem - applies to both steps 4 and 7*)
lemma Outpts_A_Card_Unique:
  "\<lbrakk> Outpts (Card A) A \<lbrace>Nonce Na, rest\<rbrace> \<in> set evs; evs \<in> srb \<rbrakk>
     \<Longrightarrow> Unique (Outpts (Card A) A \<lbrace>Nonce Na, rest\<rbrace>) on evs"
apply (erule rev_mp, erule srb.induct, simp_all add: Unique_def)
apply (fastforce dest: Outpts_parts_used)
apply blast
apply (fastforce dest: Outpts_parts_used)
apply blast
done

(*can't prove the same on evs10 for it doesn't have a freshness assumption!*)

(*END unicity theorems*)

(*BEGIN counterguarantees about spy's knowledge*)

(*on nonces*)

lemma Spy_knows_Na:
      "\<lbrakk> Says A B \<lbrace>Agent A, Nonce Na\<rbrace> \<in> set evs; evs \<in> srb \<rbrakk>
      \<Longrightarrow> Nonce Na \<in> analz (knows Spy evs)"
apply (blast dest!: Says_imp_knows_Spy [THEN analz.Inj, THEN analz.Snd])
done

lemma Spy_knows_Nb:
      "\<lbrakk> Says B A \<lbrace>Nonce Nb, Certificate\<rbrace> \<in> set evs; evs \<in> srb \<rbrakk>
      \<Longrightarrow> Nonce Nb \<in> analz (knows Spy evs)"
apply (blast dest!: Says_imp_knows_Spy [THEN analz.Inj, THEN analz.Fst])
done

(*on Pairkey*)

lemma Pairkey_Gets_analz_knows_Spy:
      "\<lbrakk> Gets A \<lbrace>Nonce (Pairkey(A,B)), Certificate\<rbrace> \<in> set evs; evs \<in> srb \<rbrakk>
      \<Longrightarrow> Nonce (Pairkey(A,B)) \<in> analz (knows Spy evs)"
apply (blast dest!: Gets_imp_knows_Spy [THEN analz.Inj])
done

lemma Pairkey_Inputs_imp_Gets:
     "\<lbrakk> Inputs A (Card A)
           \<lbrace>Agent B, Nonce Na, Nonce Nb, Nonce (Pairkey(A,B)),
             Cert1, Cert3, Cert2\<rbrace> \<in> set evs;
         A \<noteq> Spy; evs \<in> srb \<rbrakk>
      \<Longrightarrow> Gets A \<lbrace>Nonce (Pairkey(A,B)), Cert1\<rbrace> \<in> set evs"
apply (erule rev_mp, erule srb.induct)
apply (simp_all (no_asm_simp))
apply force
done

lemma Pairkey_Inputs_analz_knows_Spy:
     "\<lbrakk> Inputs A (Card A)
           \<lbrace>Agent B, Nonce Na, Nonce Nb, Nonce (Pairkey(A,B)),
             Cert1, Cert3, Cert2\<rbrace> \<in> set evs;
         evs \<in> srb \<rbrakk>
     \<Longrightarrow> Nonce (Pairkey(A,B)) \<in> analz (knows Spy evs)"
apply (case_tac "A = Spy")
apply (fastforce dest!: Inputs_imp_knows_Spy_secureM [THEN analz.Inj])
apply (blast dest!: Pairkey_Inputs_imp_Gets [THEN Pairkey_Gets_analz_knows_Spy])
done

(* This fails on base case because of XOR properties.
lemma Pairkey_authentic:
  "\<lbrakk> Nonce (Pairkey(A,B)) \<in> parts (knows Spy evs);
     Card A \<notin> cloned; evs \<in> sr \<rbrakk>
 \<Longrightarrow> \<exists> cert. Says Server A \<lbrace>Nonce (Pairkey(A,B)), Cert\<rbrace> \<in> set evs"
apply (erule rev_mp)
apply (erule sr.induct, simp_all)
apply clarify
oops

 1. \<And>x a b.
       \<lbrakk>Card A \<notin> cloned; Pairkey (A, B) = Pairkey (a, b); Card a \<in> cloned;
        Card b \<in> cloned\<rbrakk>
       \<Longrightarrow> False
*)

(*END counterguarantees on spy's knowledge*)

(*BEGIN rewrite rules for parts operator*)

declare shrK_disj_sesK [THEN not_sym, iff]
declare pin_disj_sesK [THEN not_sym, iff]
declare crdK_disj_sesK [THEN not_sym, iff]
declare pairK_disj_sesK [THEN not_sym, iff]

ML
\<open>
structure ShoupRubinBella =
struct

fun prepare_tac ctxt =
 (*SR_U8*)   forward_tac ctxt [@{thm Outpts_B_Card_form_7}] 14 THEN
 (*SR_U8*)   clarify_tac ctxt 15 THEN
 (*SR_U9*)   forward_tac ctxt [@{thm Outpts_A_Card_form_4}] 16 THEN
 (*SR_U11*)  forward_tac ctxt [@{thm Outpts_A_Card_form_10}] 21

fun parts_prepare_tac ctxt =
           prepare_tac ctxt THEN
 (*SR_U9*)   dresolve_tac ctxt [@{thm Gets_imp_knows_Spy_parts_Snd}] 18 THEN
 (*SR_U9*)   dresolve_tac ctxt [@{thm Gets_imp_knows_Spy_parts_Snd}] 19 THEN
 (*Oops1*) dresolve_tac ctxt [@{thm Outpts_B_Card_form_7}] 25    THEN
 (*Oops2*) dresolve_tac ctxt [@{thm Outpts_A_Card_form_10}] 27 THEN
 (*Base*)  (force_tac ctxt) 1

fun analz_prepare_tac ctxt =
         prepare_tac ctxt THEN
         dresolve_tac ctxt @{thms Gets_imp_knows_Spy_analz_Snd} 18 THEN
 (*SR_U9*) dresolve_tac ctxt @{thms Gets_imp_knows_Spy_analz_Snd} 19 THEN
         REPEAT_FIRST (eresolve_tac ctxt [asm_rl, conjE] ORELSE' hyp_subst_tac ctxt)

end
\<close>

method_setup prepare = \<open>
    Scan.succeed (fn ctxt => SIMPLE_METHOD (ShoupRubinBella.prepare_tac ctxt))\<close>
  "to launch a few simple facts that will help the simplifier"

method_setup parts_prepare = \<open>
    Scan.succeed (fn ctxt => SIMPLE_METHOD (ShoupRubinBella.parts_prepare_tac ctxt))\<close>
  "additional facts to reason about parts"

method_setup analz_prepare = \<open>
    Scan.succeed (fn ctxt => SIMPLE_METHOD (ShoupRubinBella.analz_prepare_tac ctxt))\<close>
  "additional facts to reason about analz"

lemma Spy_parts_keys [simp]: "evs \<in> srb \<Longrightarrow>
  (Key (shrK P) \<in> parts (knows Spy evs)) = (Card P \<in> cloned) \<and>
  (Key (pin P) \<in> parts (knows Spy evs)) = (P \<in> bad \<or> Card P \<in> cloned) \<and>
  (Key (crdK C) \<in> parts (knows Spy evs)) = (C \<in> cloned) \<and>
  (Key (pairK(A,B)) \<in> parts (knows Spy evs)) = (Card B \<in> cloned)"
apply (erule srb.induct)
apply parts_prepare
apply simp_all
apply (blast intro: parts_insertI)
done

(*END rewrite rules for parts operator*)

(*BEGIN rewrite rules for analz operator*)

lemma Spy_analz_shrK[simp]: "evs \<in> srb \<Longrightarrow>
  (Key (shrK P) \<in> analz (knows Spy evs)) = (Card P \<in> cloned)"
apply (auto dest!: Spy_knows_cloned)
done

lemma Spy_analz_crdK[simp]: "evs \<in> srb \<Longrightarrow>
  (Key (crdK C) \<in> analz (knows Spy evs)) = (C \<in> cloned)"
apply (auto dest!: Spy_knows_cloned)
done

lemma Spy_analz_pairK[simp]: "evs \<in> srb \<Longrightarrow>
  (Key (pairK(A,B)) \<in> analz (knows Spy evs)) = (Card B \<in> cloned)"
apply (auto dest!: Spy_knows_cloned)
done

(*Because initState contains a set of nonces, this is needed for base case of
  analz_image_freshK*)
lemma analz_image_Key_Un_Nonce:
  "analz (Key ` K \<union> Nonce ` N) = Key ` K \<union> Nonce ` N"
  by (auto simp del: parts_image)

method_setup sc_analz_freshK = \<open>
    Scan.succeed (fn ctxt =>
     (SIMPLE_METHOD
      (EVERY [REPEAT_FIRST (resolve_tac ctxt [allI, ballI, impI]),
          REPEAT_FIRST (resolve_tac ctxt @{thms analz_image_freshK_lemma}),
          ALLGOALS (asm_simp_tac (put_simpset Smartcard.analz_image_freshK_ss ctxt
              addsimps [@{thm knows_Spy_Inputs_secureM_srb_Spy},
                  @{thm knows_Spy_Outpts_secureM_srb_Spy},
                  @{thm shouprubin_assumes_securemeans},
                  @{thm analz_image_Key_Un_Nonce}]))])))\<close>
    "for proving the Session Key Compromise theorem for smartcard protocols"

lemma analz_image_freshK [rule_format]:
     "evs \<in> srb \<Longrightarrow>      \<forall> K KK.
          (Key K \<in> analz (Key`KK \<union> (knows Spy evs))) =
          (K \<in> KK \<or> Key K \<in> analz (knows Spy evs))"
apply (erule srb.induct)
apply analz_prepare
apply sc_analz_freshK
apply spy_analz
done

lemma analz_insert_freshK: "evs \<in> srb \<Longrightarrow>
         Key K \<in> analz (insert (Key K') (knows Spy evs)) =
         (K = K' \<or> Key K \<in> analz (knows Spy evs))"
apply (simp only: analz_image_freshK_simps analz_image_freshK)
done

(*END rewrite rules for analz operator*)

(*BEGIN authenticity theorems*)

lemma Na_Nb_certificate_authentic:
     "\<lbrakk> Crypt (pairK(A,B)) \<lbrace>Nonce Na, Nonce Nb\<rbrace> \<in> parts (knows Spy evs);
         \<not>illegalUse(Card B);
         evs \<in> srb \<rbrakk>
     \<Longrightarrow> Outpts (Card B) B \<lbrace>Nonce Nb, Agent A, Key (sesK(Nb,pairK(A,B))),
                Crypt (pairK(A,B)) \<lbrace>Nonce Na, Nonce Nb\<rbrace>,
                Crypt (pairK(A,B)) (Nonce Nb)\<rbrace> \<in> set evs"
apply (erule rev_mp, erule srb.induct)
apply parts_prepare
apply simp_all
(*Fake*)
apply spy_analz
(*SR_U7F*)
apply clarify
(*SR_U8*)
apply clarify
done

lemma Nb_certificate_authentic:
      "\<lbrakk> Crypt (pairK(A,B)) (Nonce Nb) \<in> parts (knows Spy evs);
         B \<noteq> Spy; \<not>illegalUse(Card A); \<not>illegalUse(Card B);
         evs \<in> srb \<rbrakk>
     \<Longrightarrow> Outpts (Card A) A \<lbrace>Agent B, Nonce Nb, Key (sesK(Nb,pairK(A,B))),
                             Crypt (pairK(A,B)) (Nonce Nb)\<rbrace> \<in> set evs"
apply (erule rev_mp, erule srb.induct)
apply parts_prepare
apply (case_tac [17] "Aa = Spy")
apply simp_all
(*Fake*)
apply spy_analz
(*SR_U7F, SR_U10F*)
apply clarify+
done

(*Discovering the very origin of the Nb certificate...*)
lemma Outpts_A_Card_imp_pairK_parts:
     "\<lbrakk> Outpts (Card A) A  \<lbrace>Agent B, Nonce Nb,
                    Key K, Certificate\<rbrace> \<in> set evs;
        evs \<in> srb \<rbrakk>
    \<Longrightarrow> \<exists> Na. Crypt (pairK(A,B)) \<lbrace>Nonce Na, Nonce Nb\<rbrace> \<in> parts (knows Spy evs)"
apply (erule rev_mp, erule srb.induct)
apply parts_prepare
apply simp_all
(*Fake*)
apply (blast dest: parts_insertI)
(*SR_U7*)
apply force
(*SR_U7F*)
apply force
(*SR_U8*)
apply blast
(*SR_U10*)
apply (blast dest: Inputs_imp_knows_Spy_secureM_srb parts.Inj Inputs_A_Card_9 Gets_imp_knows_Spy elim: knows_Spy_partsEs)
(*SR_U10F*)
apply (blast dest: Inputs_imp_knows_Spy_secureM_srb [THEN parts.Inj]
                   Inputs_A_Card_9 Gets_imp_knows_Spy
             elim: knows_Spy_partsEs)
done

lemma Nb_certificate_authentic_bis:
     "\<lbrakk> Crypt (pairK(A,B)) (Nonce Nb) \<in> parts (knows Spy evs);
         B \<noteq> Spy; \<not>illegalUse(Card B);
         evs \<in> srb \<rbrakk>
 \<Longrightarrow> \<exists> Na. Outpts (Card B) B \<lbrace>Nonce Nb, Agent A, Key (sesK(Nb,pairK(A,B))),
                   Crypt (pairK(A,B)) \<lbrace>Nonce Na, Nonce Nb\<rbrace>,
                   Crypt (pairK(A,B)) (Nonce Nb)\<rbrace> \<in> set evs"
apply (erule rev_mp, erule srb.induct)
apply parts_prepare
apply (simp_all (no_asm_simp))
(*Fake*)
apply spy_analz
(*SR_U7*)
apply blast
(*SR_U7F*)
apply blast
(*SR_U8*)
apply force
(*SR_U10*)
apply (blast dest: Na_Nb_certificate_authentic Inputs_imp_knows_Spy_secureM_srb [THEN parts.Inj] elim: knows_Spy_partsEs)
(*SR_U10F*)
apply (blast dest: Na_Nb_certificate_authentic Inputs_imp_knows_Spy_secureM_srb [THEN parts.Inj] elim: knows_Spy_partsEs)
(*SR_U11*)
apply (blast dest: Na_Nb_certificate_authentic Outpts_A_Card_imp_pairK_parts)
done

lemma Pairkey_certificate_authentic:
    "\<lbrakk> Crypt (shrK A) \<lbrace>Nonce Pk, Agent B\<rbrace> \<in> parts (knows Spy evs);
         Card A \<notin> cloned; evs \<in> srb \<rbrakk>
     \<Longrightarrow> Pk = Pairkey(A,B) \<and>
         Says Server A \<lbrace>Nonce Pk,
                        Crypt (shrK A) \<lbrace>Nonce Pk, Agent B\<rbrace>\<rbrace>
           \<in> set evs"
apply (erule rev_mp, erule srb.induct)
apply parts_prepare
apply (simp_all (no_asm_simp))
(*Fake*)
apply spy_analz
(*SR_U8*)
apply force
done

lemma sesK_authentic:
     "\<lbrakk> Key (sesK(Nb,pairK(A,B))) \<in> parts (knows Spy evs);
         A \<noteq> Spy; B \<noteq> Spy; \<not>illegalUse(Card A); \<not>illegalUse(Card B);
         evs \<in> srb \<rbrakk>
      \<Longrightarrow> Notes Spy \<lbrace>Key (sesK(Nb,pairK(A,B))), Nonce Nb, Agent A, Agent B\<rbrace>
           \<in> set evs"
apply (erule rev_mp, erule srb.induct)
apply parts_prepare
apply (simp_all)
(*fake*)
apply spy_analz
(*forge*)
apply (fastforce dest: analz.Inj)
(*SR_U7: used B\<noteq>Spy*)
(*SR_U7F*)
apply clarify
(*SR_U10: used A\<noteq>Spy*)
(*SR_U10F*)
apply clarify
done

(*END authenticity theorems*)

(*BEGIN confidentiality theorems*)

lemma Confidentiality:
     "\<lbrakk> Notes Spy \<lbrace>Key (sesK(Nb,pairK(A,B))), Nonce Nb, Agent A, Agent B\<rbrace>
           \<notin> set evs;
        A \<noteq> Spy; B \<noteq> Spy; \<not>illegalUse(Card A); \<not>illegalUse(Card B);
        evs \<in> srb \<rbrakk>
      \<Longrightarrow> Key (sesK(Nb,pairK(A,B))) \<notin> analz (knows Spy evs)"
apply (blast intro: sesK_authentic)
done

lemma Confidentiality_B:
     "\<lbrakk> Outpts (Card B) B \<lbrace>Nonce Nb, Agent A, Key K, Cert1, Cert2\<rbrace>
          \<in> set evs;
        Notes Spy \<lbrace>Key K, Nonce Nb, Agent A, Agent B\<rbrace> \<notin> set evs;
        A \<noteq> Spy; B \<noteq> Spy; \<not>illegalUse(Card A); Card B \<notin> cloned;
        evs \<in> srb \<rbrakk>
      \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
apply (erule rev_mp, erule rev_mp, erule srb.induct)
apply analz_prepare
apply (simp_all add: analz_insert_eq analz_insert_freshK pushes split_ifs)
(*Fake*)
apply spy_analz
(*Forge*)
apply (rotate_tac 7)
apply (drule parts.Inj)
apply (fastforce dest: Outpts_B_Card_form_7)
(*SR_U7*)
apply (blast dest!: Outpts_B_Card_form_7)
(*SR_U7F*)
apply clarify
apply (drule Outpts_parts_used)
apply simp
(*faster than
  apply (fastforce dest: Outpts_parts_used)
*)
(*SR_U10*)
apply (fastforce dest: Outpts_B_Card_form_7)
(*SR_U10F - uses assumption Card A not cloned*)
apply clarify
apply (drule Outpts_B_Card_form_7, assumption)
apply simp
(*Oops1*)
apply (blast dest!: Outpts_B_Card_form_7)
(*Oops2*)
apply (blast dest!: Outpts_B_Card_form_7 Outpts_A_Card_form_10)
done

(*END confidentiality theorems*)

(*BEGIN authentication theorems*)

lemma A_authenticates_B:
     "\<lbrakk> Outpts (Card A) A  \<lbrace>Agent B, Nonce Nb, Key K, Certificate\<rbrace> \<in> set evs;
        \<not>illegalUse(Card B);
        evs \<in> srb \<rbrakk>
 \<Longrightarrow> \<exists> Na. Outpts (Card B) B \<lbrace>Nonce Nb, Agent A, Key K,
                Crypt (pairK(A,B)) \<lbrace>Nonce Na, Nonce Nb\<rbrace>,
                Crypt (pairK(A,B)) (Nonce Nb)\<rbrace> \<in> set evs"
apply (blast dest: Na_Nb_certificate_authentic Outpts_A_Card_form_10 Outpts_A_Card_imp_pairK_parts)
done

lemma A_authenticates_B_Gets:
     "\<lbrakk> Gets A \<lbrace>Nonce Nb, Crypt (pairK(A,B)) \<lbrace>Nonce Na, Nonce Nb\<rbrace>\<rbrace>
           \<in> set evs;
         \<not>illegalUse(Card B);
         evs \<in> srb \<rbrakk>
    \<Longrightarrow> Outpts (Card B) B \<lbrace>Nonce Nb, Agent A, Key (sesK(Nb, pairK (A, B))),
                             Crypt (pairK(A,B)) \<lbrace>Nonce Na, Nonce Nb\<rbrace>,
                             Crypt (pairK(A,B)) (Nonce Nb)\<rbrace> \<in> set evs"
apply (blast dest: Gets_imp_knows_Spy [THEN parts.Inj, THEN parts.Snd, THEN Na_Nb_certificate_authentic])
done

lemma A_authenticates_B_bis:
     "\<lbrakk> Outpts (Card A) A  \<lbrace>Agent B, Nonce Nb, Key K, Cert2\<rbrace> \<in> set evs;
        \<not>illegalUse(Card B);
        evs \<in> srb \<rbrakk>
 \<Longrightarrow> \<exists> Cert1. Outpts (Card B) B \<lbrace>Nonce Nb, Agent A, Key K, Cert1, Cert2\<rbrace>
                \<in> set evs"
apply (blast dest: Na_Nb_certificate_authentic Outpts_A_Card_form_10 Outpts_A_Card_imp_pairK_parts)
done

lemma B_authenticates_A:
     "\<lbrakk> Gets B (Crypt (pairK(A,B)) (Nonce Nb)) \<in> set evs;
         B \<noteq> Spy; \<not>illegalUse(Card A); \<not>illegalUse(Card B);
         evs \<in> srb \<rbrakk>
      \<Longrightarrow> Outpts (Card A) A  \<lbrace>Agent B, Nonce Nb,
         Key (sesK(Nb,pairK(A,B))), Crypt (pairK(A,B)) (Nonce Nb)\<rbrace> \<in> set evs"
apply (erule rev_mp)
apply (erule srb.induct)
apply (simp_all (no_asm_simp))
apply (blast dest: Says_imp_knows_Spy [THEN parts.Inj] Nb_certificate_authentic)
done

lemma B_authenticates_A_bis:
     "\<lbrakk> Outpts (Card B) B \<lbrace>Nonce Nb, Agent A, Key K, Cert1, Cert2\<rbrace> \<in> set evs;
        Gets B (Cert2) \<in> set evs;
         B \<noteq> Spy; \<not>illegalUse(Card A); \<not>illegalUse(Card B);
         evs \<in> srb \<rbrakk>
      \<Longrightarrow> Outpts (Card A) A  \<lbrace>Agent B, Nonce Nb, Key K, Cert2\<rbrace> \<in> set evs"
apply (blast dest: Outpts_B_Card_form_7 B_authenticates_A)
done

(*END authentication theorems*)

lemma Confidentiality_A:
      "\<lbrakk> Outpts (Card A) A \<lbrace>Agent B, Nonce Nb,
                       Key K, Certificate\<rbrace> \<in> set evs;
         Notes Spy \<lbrace>Key K, Nonce Nb, Agent A, Agent B\<rbrace> \<notin> set evs;
         A \<noteq> Spy; B \<noteq> Spy; \<not>illegalUse(Card A); \<not>illegalUse(Card B);
         evs \<in> srb \<rbrakk>
     \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
apply (drule A_authenticates_B)
prefer 3
apply (erule exE)
apply (drule Confidentiality_B)
apply auto
done

lemma Outpts_imp_knows_agents_secureM_srb:
   "\<lbrakk> Outpts (Card A) A X \<in> set evs; evs \<in> srb \<rbrakk> \<Longrightarrow> X \<in> knows A evs"
apply (simp (no_asm_simp) add: Outpts_imp_knows_agents_secureM)
done

(*BEGIN key distribution theorems*)
lemma A_keydist_to_B:
   "\<lbrakk> Outpts (Card A) A \<lbrace>Agent B, Nonce Nb, Key K, Certificate\<rbrace> \<in> set evs;
         \<not>illegalUse(Card B);
         evs \<in> srb \<rbrakk>
     \<Longrightarrow> Key K \<in> analz (knows B evs)"
apply (drule A_authenticates_B)
prefer 3
apply (erule exE)
apply (rule Outpts_imp_knows_agents_secureM_srb [THEN analz.Inj, THEN analz.Snd, THEN analz.Snd, THEN analz.Fst])
apply assumption+
done

lemma B_keydist_to_A:
"\<lbrakk> Outpts (Card B) B \<lbrace>Nonce Nb, Agent A, Key K, Cert1, Cert2\<rbrace> \<in> set evs;
   Gets B (Cert2) \<in> set evs;
   B \<noteq> Spy; \<not>illegalUse(Card A); \<not>illegalUse(Card B);
   evs \<in> srb \<rbrakk>
 \<Longrightarrow> Key K \<in> analz (knows A evs)"
apply (frule Outpts_B_Card_form_7)
apply assumption apply simp
apply (frule B_authenticates_A)
apply (rule_tac [5] Outpts_imp_knows_agents_secureM_srb [THEN analz.Inj, THEN analz.Snd, THEN analz.Snd, THEN analz.Fst])
apply simp+
done

(*END key distribution theorems*)

(*BEGIN further theorems about authenticity of verifiers - useful to cards,
  and somewhat to agents *)

(*MSG11
If B receives the verifier of msg11, then the verifier originated with msg7.
This is clearly not available to B: B can't check the form of the verifier because he doesn't know pairK(A,B)
*)
lemma Nb_certificate_authentic_B:
     "\<lbrakk> Gets B (Crypt (pairK(A,B)) (Nonce Nb)) \<in> set evs;
        B \<noteq> Spy; \<not>illegalUse(Card B);
        evs \<in> srb \<rbrakk>
     \<Longrightarrow> \<exists> Na.
            Outpts (Card B) B \<lbrace>Nonce Nb, Agent A, Key (sesK(Nb,pairK(A,B))),
                Crypt (pairK(A,B)) \<lbrace>Nonce Na, Nonce Nb\<rbrace>,
                Crypt (pairK(A,B)) (Nonce Nb)\<rbrace> \<in> set evs"
apply (blast dest: Gets_imp_knows_Spy [THEN parts.Inj, THEN Nb_certificate_authentic_bis])
done

(*MSG10
If A obtains the verifier of msg10, then the verifier originated with msg7:
A_authenticates_B. It is useful to A, who can check the form of the
verifier by application of Outpts_A_Card_form_10.
*)

(*MSG9
The first verifier verifies the Pairkey to the card: since it's encrypted
under Ka, it must come from the server (if A's card is not cloned).
The second verifier verifies both nonces, since it's encrypted under the
pairK, it must originate with B's card  (if A and B's cards not cloned).
The third verifier verifies Na: since it's encrytped under the card's key,
it originated with the card; so the card does not need to save Na
in the first place and do a comparison now: it just verifies Na through the
verifier. Three theorems related to these three statements.

Recall that a card can check the form of the verifiers (can decrypt them),
while an agent in general cannot, if not provided with a suitable theorem.
*)

(*Card A can't reckon the pairkey - we need to guarantee its integrity!*)
lemma Pairkey_certificate_authentic_A_Card:
     "\<lbrakk> Inputs A (Card A)
             \<lbrace>Agent B, Nonce Na, Nonce Nb, Nonce Pk,
               Crypt (shrK A) \<lbrace>Nonce Pk, Agent B\<rbrace>,
               Cert2, Cert3\<rbrace> \<in> set evs;
         A \<noteq> Spy; Card A \<notin> cloned; evs \<in> srb \<rbrakk>
     \<Longrightarrow> Pk = Pairkey(A,B) \<and>
         Says Server A \<lbrace>Nonce (Pairkey(A,B)),
                  Crypt (shrK A) \<lbrace>Nonce (Pairkey(A,B)), Agent B\<rbrace>\<rbrace>
           \<in> set evs "
apply (blast dest: Inputs_A_Card_9 Gets_imp_knows_Spy [THEN parts.Inj, THEN parts.Snd] Pairkey_certificate_authentic)
done
(*the second conjunct of the thesis might be regarded as a form of integrity
  in the sense of Neuman-Ts'o*)

lemma Na_Nb_certificate_authentic_A_Card:
      "\<lbrakk> Inputs A (Card A)
             \<lbrace>Agent B, Nonce Na, Nonce Nb, Nonce Pk,
          Cert1, Crypt (pairK(A,B)) \<lbrace>Nonce Na, Nonce Nb\<rbrace>, Cert3\<rbrace> \<in> set evs;
      A \<noteq> Spy; \<not>illegalUse(Card B); evs \<in> srb \<rbrakk>
   \<Longrightarrow> Outpts (Card B) B \<lbrace>Nonce Nb, Agent A, Key (sesK(Nb, pairK (A, B))),
                             Crypt (pairK(A,B)) \<lbrace>Nonce Na, Nonce Nb\<rbrace>,
                             Crypt (pairK(A,B)) (Nonce Nb)\<rbrace>
           \<in> set evs "
apply (frule Inputs_A_Card_9)
apply assumption+
apply (blast dest: Inputs_A_Card_9 Gets_imp_knows_Spy [THEN parts.Inj, THEN parts.Snd, THEN Na_Nb_certificate_authentic])
done

lemma Na_authentic_A_Card:
     "\<lbrakk> Inputs A (Card A)
             \<lbrace>Agent B, Nonce Na, Nonce Nb, Nonce Pk,
                Cert1, Cert2, Cert3\<rbrace> \<in> set evs;
         A \<noteq> Spy; evs \<in> srb \<rbrakk>
     \<Longrightarrow> Outpts (Card A) A \<lbrace>Nonce Na, Cert3\<rbrace>
           \<in> set evs"
apply (blast dest: Inputs_A_Card_9)
done

(* These three theorems for Card A can be put together trivially.
They are separated to highlight the different requirements on agents
and their cards.*)

lemma Inputs_A_Card_9_authentic:
  "\<lbrakk> Inputs A (Card A)
             \<lbrace>Agent B, Nonce Na, Nonce Nb, Nonce Pk,
               Crypt (shrK A) \<lbrace>Nonce Pk, Agent B\<rbrace>,
               Crypt (pairK(A,B)) \<lbrace>Nonce Na, Nonce Nb\<rbrace>, Cert3\<rbrace> \<in> set evs;
    A \<noteq> Spy; Card A \<notin> cloned; \<not>illegalUse(Card B); evs \<in> srb \<rbrakk>
    \<Longrightarrow>  Says Server A \<lbrace>Nonce Pk, Crypt (shrK A) \<lbrace>Nonce Pk, Agent B\<rbrace>\<rbrace>
           \<in> set evs  \<and>
       Outpts (Card B) B \<lbrace>Nonce Nb, Agent A,  Key (sesK(Nb, pairK (A, B))),
                             Crypt (pairK(A,B)) \<lbrace>Nonce Na, Nonce Nb\<rbrace>,
                             Crypt (pairK(A,B)) (Nonce Nb)\<rbrace>
           \<in> set evs  \<and>
         Outpts (Card A) A \<lbrace>Nonce Na, Cert3\<rbrace>
           \<in> set evs"
apply (blast dest: Inputs_A_Card_9 Na_Nb_certificate_authentic Gets_imp_knows_Spy [THEN parts.Inj, THEN parts.Snd] Pairkey_certificate_authentic)
done

(*MSG8
Nothing to prove because the message is a cleartext that comes from the
network*)

(*Other messages: nothing to prove because the verifiers involved are new*)

(*END further theorems about authenticity of verifiers*)

(* BEGIN trivial guarantees on outputs for agents *)

(*MSG4*)
lemma SR_U4_imp:
     "\<lbrakk> Outpts (Card A) A \<lbrace>Nonce Na, Crypt (crdK (Card A)) (Nonce Na)\<rbrace>
           \<in> set evs;
         A \<noteq> Spy; evs \<in> srb \<rbrakk>
     \<Longrightarrow> \<exists> Pk V. Gets A \<lbrace>Pk, V\<rbrace> \<in> set evs"
apply (blast dest: Outpts_A_Card_4 Inputs_A_Card_3)
done
(*weak: could strengthen the model adding verifier for the Pairkey to msg3*)

(*MSG7*)
lemma SR_U7_imp:
     "\<lbrakk> Outpts (Card B) B \<lbrace>Nonce Nb, Agent A, Key K,
                      Crypt (pairK(A,B)) \<lbrace>Nonce Na, Nonce Nb\<rbrace>,
                      Cert2\<rbrace> \<in> set evs;
         B \<noteq> Spy; evs \<in> srb \<rbrakk>
     \<Longrightarrow> Gets B \<lbrace>Agent A, Nonce Na\<rbrace> \<in> set evs"
apply (blast dest: Outpts_B_Card_7 Inputs_B_Card_6)
done

(*MSG10*)
lemma SR_U10_imp:
     "\<lbrakk> Outpts (Card A) A \<lbrace>Agent B, Nonce Nb,
                           Key K, Crypt (pairK(A,B)) (Nonce Nb)\<rbrace>
         \<in> set evs;
        A \<noteq> Spy; evs \<in> srb \<rbrakk>
     \<Longrightarrow> \<exists> Cert1 Cert2.
                   Gets A \<lbrace>Nonce (Pairkey (A, B)), Cert1\<rbrace> \<in> set evs \<and>
                   Gets A \<lbrace>Nonce Nb, Cert2\<rbrace> \<in> set evs"
apply (blast dest: Outpts_A_Card_10 Inputs_A_Card_9)
done

(*END trivial guarantees on outputs for agents*)

(*INTEGRITY*)
lemma Outpts_Server_not_evs:
      "evs \<in> srb \<Longrightarrow> Outpts (Card Server) P X \<notin> set evs"
apply (erule srb.induct)
apply auto
done

text\<open>\<^term>\<open>step2_integrity\<close> also is a reliability theorem\<close>
lemma Says_Server_message_form:
     "\<lbrakk> Says Server A \<lbrace>Pk, Certificate\<rbrace> \<in> set evs;
         evs \<in> srb \<rbrakk>
     \<Longrightarrow> \<exists> B. Pk = Nonce (Pairkey(A,B)) \<and>
         Certificate = Crypt (shrK A) \<lbrace>Nonce (Pairkey(A,B)), Agent B\<rbrace>"
apply (erule rev_mp)
apply (erule srb.induct)
apply auto
apply (blast dest!: Outpts_Server_not_evs)+
done
(*cannot be made useful to A in form of a Gets event*)

text\<open>
  step4integrity is \<^term>\<open>Outpts_A_Card_form_4\<close>

  step7integrity is \<^term>\<open>Outpts_B_Card_form_7\<close>
\<close>

lemma step8_integrity:
     "\<lbrakk> Says B A \<lbrace>Nonce Nb, Certificate\<rbrace> \<in> set evs;
         B \<noteq> Server; B \<noteq> Spy; evs \<in> srb \<rbrakk>
     \<Longrightarrow> \<exists> Cert2 K.
    Outpts (Card B) B \<lbrace>Nonce Nb, Agent A, Key K, Certificate, Cert2\<rbrace> \<in> set evs"
apply (erule rev_mp)
apply (erule srb.induct)
prefer 18 apply (fastforce dest: Outpts_A_Card_form_10)
apply auto
done

text\<open>step9integrity is \<^term>\<open>Inputs_A_Card_form_9\<close>
        step10integrity is \<^term>\<open>Outpts_A_Card_form_10\<close>.
\<close>

lemma step11_integrity:
     "\<lbrakk> Says A B (Certificate) \<in> set evs;
         \<forall> p q. Certificate \<noteq> \<lbrace>p, q\<rbrace>;
         A \<noteq> Spy; evs \<in> srb \<rbrakk>
     \<Longrightarrow> \<exists> K Nb.
      Outpts (Card A) A \<lbrace>Agent B, Nonce Nb, Key K, Certificate\<rbrace> \<in> set evs"
apply (erule rev_mp)
apply (erule srb.induct)
apply auto
done

end


(*  Title:      HOL/MicroJava/Comp/TranslCompTp.thy
    Author:     Martin Strecker
*)

theory TranslCompTp
imports Index "../BV/JVMType"
begin

(**********************************************************************)

definition comb :: "['a \<Rightarrow> 'b list \<times> 'c, 'c \<Rightarrow> 'b list \<times> 'd, 'a] \<Rightarrow> 'b list \<times> 'd"
  (infixr "\<box>" 55)
where
  "comb == (\<lambda> f1 f2 x0. let (xs1, x1) = f1 x0;
                            (xs2, x2) = f2 x1
                        in  (xs1 @ xs2, x2))"

definition comb_nil :: "'a \<Rightarrow> 'b list \<times> 'a" where
  "comb_nil a == ([], a)"

lemma comb_nil_left [simp]: "comb_nil \<box> f = f"
  by (simp add: comb_def comb_nil_def split_beta)

lemma comb_nil_right [simp]: "f \<box> comb_nil = f"
  by (simp add: comb_def comb_nil_def split_beta)

lemma comb_assoc [simp]: "(fa \<box> fb) \<box> fc = fa \<box> (fb \<box> fc)"
  by (simp add: comb_def split_beta)

lemma comb_inv:
  "(xs', x') = (f1 \<box> f2) x0 \<Longrightarrow>
  \<exists>xs1 x1 xs2 x2. (xs1, x1) = (f1 x0) \<and> (xs2, x2) = f2 x1 \<and> xs'= xs1 @ xs2 \<and> x'=x2"
  by (case_tac "f1 x0") (simp add: comb_def split_beta)

(**********************************************************************)

abbreviation (input)
  mt_of :: "method_type \<times> state_type \<Rightarrow> method_type"
  where "mt_of == fst"

abbreviation (input)
  sttp_of :: "method_type \<times> state_type \<Rightarrow> state_type"
  where "sttp_of == snd"

definition nochangeST :: "state_type \<Rightarrow> method_type \<times> state_type" where
  "nochangeST sttp == ([Some sttp], sttp)"

definition pushST :: "[ty list, state_type] \<Rightarrow> method_type \<times> state_type" where
  "pushST tps == (\<lambda> (ST, LT). ([Some (ST, LT)], (tps @ ST, LT)))"

definition dupST :: "state_type \<Rightarrow> method_type \<times> state_type" where
  "dupST == (\<lambda> (ST, LT). ([Some (ST, LT)], (hd ST # ST, LT)))"

definition dup_x1ST :: "state_type \<Rightarrow> method_type \<times> state_type" where
  "dup_x1ST == (\<lambda> (ST, LT). ([Some (ST, LT)],
                             (hd ST # hd (tl ST) # hd ST # (tl (tl ST)), LT)))"

definition popST :: "[nat, state_type] \<Rightarrow> method_type \<times> state_type" where
  "popST n == (\<lambda> (ST, LT). ([Some (ST, LT)], (drop n ST, LT)))"

definition replST :: "[nat, ty, state_type] \<Rightarrow> method_type \<times> state_type" where
  "replST n tp == (\<lambda> (ST, LT). ([Some (ST, LT)], (tp # (drop n ST), LT)))"

definition storeST :: "[nat, ty, state_type] \<Rightarrow> method_type \<times> state_type" where
  "storeST i tp == (\<lambda> (ST, LT). ([Some (ST, LT)], (tl ST, LT [i:= OK tp])))"

(* Expressions *)

primrec compTpExpr :: "java_mb \<Rightarrow> java_mb prog \<Rightarrow> expr \<Rightarrow>
    state_type \<Rightarrow> method_type \<times> state_type"
  and compTpExprs :: "java_mb \<Rightarrow> java_mb prog \<Rightarrow> expr list \<Rightarrow>
    state_type \<Rightarrow> method_type \<times> state_type"
where
  "compTpExpr jmb G (NewC c) = pushST [Class c]"
| "compTpExpr jmb G (Cast c e) = (compTpExpr jmb G e) \<box> (replST 1 (Class c))"
| "compTpExpr jmb G (Lit val) = pushST [the (typeof (\<lambda>v. None) val)]"
| "compTpExpr jmb G (BinOp bo e1 e2) =
     (compTpExpr jmb G e1) \<box> (compTpExpr jmb G e2) \<box>
     (case bo of
       Eq => popST 2 \<box> pushST [PrimT Boolean] \<box> popST 1 \<box> pushST [PrimT Boolean]
     | Add => replST 2 (PrimT Integer))"
| "compTpExpr jmb G (LAcc vn) = (\<lambda> (ST, LT).
      pushST [ok_val (LT ! (index jmb vn))] (ST, LT))"
| "compTpExpr jmb G (vn::=e) =
      (compTpExpr jmb G e) \<box> dupST \<box> (popST 1)"
| "compTpExpr jmb G ( {cn}e..fn ) =
      (compTpExpr jmb G e) \<box> replST 1 (snd (the (field (G,cn) fn)))"
| "compTpExpr jmb G (FAss cn e1 fn e2 ) =
      (compTpExpr jmb G e1) \<box> (compTpExpr jmb G e2) \<box> dup_x1ST \<box> (popST 2)"
| "compTpExpr jmb G ({C}a..mn({fpTs}ps)) =
       (compTpExpr jmb G a) \<box> (compTpExprs jmb G ps) \<box>
       (replST ((length ps) + 1) (method_rT (the (method (G,C) (mn,fpTs)))))"
| "compTpExprs jmb G [] = comb_nil"
| "compTpExprs jmb G (e#es) = (compTpExpr jmb G e) \<box> (compTpExprs jmb G es)"

(* Statements *)
primrec compTpStmt :: "java_mb \<Rightarrow> java_mb prog \<Rightarrow> stmt \<Rightarrow>
    state_type \<Rightarrow> method_type \<times> state_type"
where
  "compTpStmt jmb G Skip = comb_nil"
| "compTpStmt jmb G (Expr e) =  (compTpExpr jmb G e) \<box> popST 1"
| "compTpStmt jmb G (c1;; c2) = (compTpStmt jmb G c1) \<box> (compTpStmt jmb G c2)"
| "compTpStmt jmb G (If(e) c1 Else c2) =
      (pushST [PrimT Boolean]) \<box> (compTpExpr jmb G e) \<box> popST 2 \<box>
      (compTpStmt jmb G c1) \<box> nochangeST \<box> (compTpStmt jmb G c2)"
| "compTpStmt jmb G (While(e) c) =
      (pushST [PrimT Boolean]) \<box> (compTpExpr jmb G e) \<box> popST 2 \<box>
      (compTpStmt jmb G c) \<box> nochangeST"

definition compTpInit :: "java_mb \<Rightarrow> (vname * ty)
                   \<Rightarrow> state_type \<Rightarrow> method_type \<times> state_type" where
  "compTpInit jmb == (\<lambda> (vn,ty). (pushST [ty]) \<box>  (storeST (index jmb vn) ty))"

primrec compTpInitLvars :: "[java_mb, (vname \<times> ty) list] \<Rightarrow>
    state_type \<Rightarrow> method_type \<times> state_type"
where
  "compTpInitLvars jmb [] = comb_nil"
| "compTpInitLvars jmb (lv#lvars) = (compTpInit jmb lv) \<box> (compTpInitLvars jmb lvars)"

definition start_ST :: "opstack_type" where
  "start_ST == []"

definition start_LT :: "cname \<Rightarrow> ty list \<Rightarrow> nat \<Rightarrow> locvars_type" where
  "start_LT C pTs n ==  (OK (Class C))#((map OK pTs))@(replicate n Err)"

definition compTpMethod  :: "[java_mb prog, cname, java_mb mdecl] \<Rightarrow> method_type" where
  "compTpMethod G C == \<lambda> ((mn,pTs),rT, jmb).
                         let (pns,lvars,blk,res) = jmb
                         in (mt_of
                            ((compTpInitLvars jmb lvars \<box>
                              compTpStmt jmb G blk \<box>
                              compTpExpr jmb G res \<box>
                              nochangeST)
                                (start_ST, start_LT C pTs (length lvars))))"

definition compTp :: "java_mb prog => prog_type" where
  "compTp G C sig == let (D, rT, jmb) = (the (method (G, C) sig))
                      in compTpMethod G C (sig, rT, jmb)"

(**********************************************************************)
  (* Computing the maximum stack size from the method_type *)

definition ssize_sto :: "(state_type option) \<Rightarrow> nat" where
  "ssize_sto sto ==  case sto of None \<Rightarrow> 0 | (Some (ST, LT)) \<Rightarrow> length ST"

definition max_of_list :: "nat list \<Rightarrow> nat" where
  "max_of_list xs == foldr max xs 0"

definition max_ssize :: "method_type \<Rightarrow> nat" where
  "max_ssize mt == max_of_list (map ssize_sto mt)"

end