(*  Title:      HOL/Extraction.thy
    Author:     Stefan Berghofer, TU Muenchen
*)

section \<open>Program extraction for HOL\<close>

theory Extraction
imports Option
begin

subsection \<open>Setup\<close>

setup \<open>
  Extraction.add_types
      [("bool", ([], NONE))] #>
  Extraction.set_preprocessor (fn thy =>
    Proofterm.rewrite_proof_notypes
      ([], Rewrite_HOL_Proof.elim_cong :: Proof_Rewrite_Rules.rprocs true) o
    Proofterm.rewrite_proof thy
      (Rewrite_HOL_Proof.rews,
       Proof_Rewrite_Rules.rprocs true @ [Proof_Rewrite_Rules.expand_of_class thy]) o
    Proof_Rewrite_Rules.elim_vars (curry Const \<^const_name>\<open>default\<close>))
\<close>

lemmas [extraction_expand] =
  meta_spec atomize_eq atomize_all atomize_imp atomize_conj
  allE rev_mp conjE Eq_TrueI Eq_FalseI eqTrueI eqTrueE eq_cong2
  notE' impE' impE iffE imp_cong simp_thms eq_True eq_False
  induct_forall_eq induct_implies_eq induct_equal_eq induct_conj_eq
  induct_atomize induct_atomize' induct_rulify induct_rulify'
  induct_rulify_fallback induct_trueI
  True_implies_equals implies_True_equals TrueE
  False_implies_equals implies_False_swap

lemmas [extraction_expand_def] =
  HOL.induct_forall_def HOL.induct_implies_def HOL.induct_equal_def HOL.induct_conj_def
  HOL.induct_true_def HOL.induct_false_def

datatype (plugins only: code extraction) sumbool = Left | Right

subsection \<open>Type of extracted program\<close>

extract_type
  "typeof (Trueprop P) \<equiv> typeof P"

  "typeof P \<equiv> Type (TYPE(Null)) \<Longrightarrow> typeof Q \<equiv> Type (TYPE('Q)) \<Longrightarrow>
     typeof (P \<longrightarrow> Q) \<equiv> Type (TYPE('Q))"

  "typeof Q \<equiv> Type (TYPE(Null)) \<Longrightarrow> typeof (P \<longrightarrow> Q) \<equiv> Type (TYPE(Null))"

  "typeof P \<equiv> Type (TYPE('P)) \<Longrightarrow> typeof Q \<equiv> Type (TYPE('Q)) \<Longrightarrow>
     typeof (P \<longrightarrow> Q) \<equiv> Type (TYPE('P \<Rightarrow> 'Q))"

  "(\<lambda>x. typeof (P x)) \<equiv> (\<lambda>x. Type (TYPE(Null))) \<Longrightarrow>
     typeof (\<forall>x. P x) \<equiv> Type (TYPE(Null))"

  "(\<lambda>x. typeof (P x)) \<equiv> (\<lambda>x. Type (TYPE('P))) \<Longrightarrow>
     typeof (\<forall>x::'a. P x) \<equiv> Type (TYPE('a \<Rightarrow> 'P))"

  "(\<lambda>x. typeof (P x)) \<equiv> (\<lambda>x. Type (TYPE(Null))) \<Longrightarrow>
     typeof (\<exists>x::'a. P x) \<equiv> Type (TYPE('a))"

  "(\<lambda>x. typeof (P x)) \<equiv> (\<lambda>x. Type (TYPE('P))) \<Longrightarrow>
     typeof (\<exists>x::'a. P x) \<equiv> Type (TYPE('a \<times> 'P))"

  "typeof P \<equiv> Type (TYPE(Null)) \<Longrightarrow> typeof Q \<equiv> Type (TYPE(Null)) \<Longrightarrow>
     typeof (P \<or> Q) \<equiv> Type (TYPE(sumbool))"

  "typeof P \<equiv> Type (TYPE(Null)) \<Longrightarrow> typeof Q \<equiv> Type (TYPE('Q)) \<Longrightarrow>
     typeof (P \<or> Q) \<equiv> Type (TYPE('Q option))"

  "typeof P \<equiv> Type (TYPE('P)) \<Longrightarrow> typeof Q \<equiv> Type (TYPE(Null)) \<Longrightarrow>
     typeof (P \<or> Q) \<equiv> Type (TYPE('P option))"

  "typeof P \<equiv> Type (TYPE('P)) \<Longrightarrow> typeof Q \<equiv> Type (TYPE('Q)) \<Longrightarrow>
     typeof (P \<or> Q) \<equiv> Type (TYPE('P + 'Q))"

  "typeof P \<equiv> Type (TYPE(Null)) \<Longrightarrow> typeof Q \<equiv> Type (TYPE('Q)) \<Longrightarrow>
     typeof (P \<and> Q) \<equiv> Type (TYPE('Q))"

  "typeof P \<equiv> Type (TYPE('P)) \<Longrightarrow> typeof Q \<equiv> Type (TYPE(Null)) \<Longrightarrow>
     typeof (P \<and> Q) \<equiv> Type (TYPE('P))"

  "typeof P \<equiv> Type (TYPE('P)) \<Longrightarrow> typeof Q \<equiv> Type (TYPE('Q)) \<Longrightarrow>
     typeof (P \<and> Q) \<equiv> Type (TYPE('P \<times> 'Q))"

  "typeof (P = Q) \<equiv> typeof ((P \<longrightarrow> Q) \<and> (Q \<longrightarrow> P))"

  "typeof (x \<in> P) \<equiv> typeof P"

subsection \<open>Realizability\<close>

realizability
  "(realizes t (Trueprop P)) \<equiv> (Trueprop (realizes t P))"

  "(typeof P) \<equiv> (Type (TYPE(Null))) \<Longrightarrow>
     (realizes t (P \<longrightarrow> Q)) \<equiv> (realizes Null P \<longrightarrow> realizes t Q)"

  "(typeof P) \<equiv> (Type (TYPE('P))) \<Longrightarrow>
   (typeof Q) \<equiv> (Type (TYPE(Null))) \<Longrightarrow>
     (realizes t (P \<longrightarrow> Q)) \<equiv> (\<forall>x::'P. realizes x P \<longrightarrow> realizes Null Q)"

  "(realizes t (P \<longrightarrow> Q)) \<equiv> (\<forall>x. realizes x P \<longrightarrow> realizes (t x) Q)"

  "(\<lambda>x. typeof (P x)) \<equiv> (\<lambda>x. Type (TYPE(Null))) \<Longrightarrow>
     (realizes t (\<forall>x. P x)) \<equiv> (\<forall>x. realizes Null (P x))"

  "(realizes t (\<forall>x. P x)) \<equiv> (\<forall>x. realizes (t x) (P x))"

  "(\<lambda>x. typeof (P x)) \<equiv> (\<lambda>x. Type (TYPE(Null))) \<Longrightarrow>
     (realizes t (\<exists>x. P x)) \<equiv> (realizes Null (P t))"

  "(realizes t (\<exists>x. P x)) \<equiv> (realizes (snd t) (P (fst t)))"

  "(typeof P) \<equiv> (Type (TYPE(Null))) \<Longrightarrow>
   (typeof Q) \<equiv> (Type (TYPE(Null))) \<Longrightarrow>
     (realizes t (P \<or> Q)) \<equiv>
     (case t of Left \<Rightarrow> realizes Null P | Right \<Rightarrow> realizes Null Q)"

  "(typeof P) \<equiv> (Type (TYPE(Null))) \<Longrightarrow>
     (realizes t (P \<or> Q)) \<equiv>
     (case t of None \<Rightarrow> realizes Null P | Some q \<Rightarrow> realizes q Q)"

  "(typeof Q) \<equiv> (Type (TYPE(Null))) \<Longrightarrow>
     (realizes t (P \<or> Q)) \<equiv>
     (case t of None \<Rightarrow> realizes Null Q | Some p \<Rightarrow> realizes p P)"

  "(realizes t (P \<or> Q)) \<equiv>
   (case t of Inl p \<Rightarrow> realizes p P | Inr q \<Rightarrow> realizes q Q)"

  "(typeof P) \<equiv> (Type (TYPE(Null))) \<Longrightarrow>
     (realizes t (P \<and> Q)) \<equiv> (realizes Null P \<and> realizes t Q)"

  "(typeof Q) \<equiv> (Type (TYPE(Null))) \<Longrightarrow>
     (realizes t (P \<and> Q)) \<equiv> (realizes t P \<and> realizes Null Q)"

  "(realizes t (P \<and> Q)) \<equiv> (realizes (fst t) P \<and> realizes (snd t) Q)"

  "typeof P \<equiv> Type (TYPE(Null)) \<Longrightarrow>
     realizes t (\<not> P) \<equiv> \<not> realizes Null P"

  "typeof P \<equiv> Type (TYPE('P)) \<Longrightarrow>
     realizes t (\<not> P) \<equiv> (\<forall>x::'P. \<not> realizes x P)"

  "typeof (P::bool) \<equiv> Type (TYPE(Null)) \<Longrightarrow>
   typeof Q \<equiv> Type (TYPE(Null)) \<Longrightarrow>
     realizes t (P = Q) \<equiv> realizes Null P = realizes Null Q"

  "(realizes t (P = Q)) \<equiv> (realizes t ((P \<longrightarrow> Q) \<and> (Q \<longrightarrow> P)))"

subsection \<open>Computational content of basic inference rules\<close>

theorem disjE_realizer:
  assumes r: "case x of Inl p \<Rightarrow> P p | Inr q \<Rightarrow> Q q"
  and r1: "\<And>p. P p \<Longrightarrow> R (f p)" and r2: "\<And>q. Q q \<Longrightarrow> R (g q)"
  shows "R (case x of Inl p \<Rightarrow> f p | Inr q \<Rightarrow> g q)"
proof (cases x)
  case Inl
  with r show ?thesis by simp (rule r1)
next
  case Inr
  with r show ?thesis by simp (rule r2)
qed

theorem disjE_realizer2:
  assumes r: "case x of None \<Rightarrow> P | Some q \<Rightarrow> Q q"
  and r1: "P \<Longrightarrow> R f" and r2: "\<And>q. Q q \<Longrightarrow> R (g q)"
  shows "R (case x of None \<Rightarrow> f | Some q \<Rightarrow> g q)"
proof (cases x)
  case None
  with r show ?thesis by simp (rule r1)
next
  case Some
  with r show ?thesis by simp (rule r2)
qed

theorem disjE_realizer3:
  assumes r: "case x of Left \<Rightarrow> P | Right \<Rightarrow> Q"
  and r1: "P \<Longrightarrow> R f" and r2: "Q \<Longrightarrow> R g"
  shows "R (case x of Left \<Rightarrow> f | Right \<Rightarrow> g)"
proof (cases x)
  case Left
  with r show ?thesis by simp (rule r1)
next
  case Right
  with r show ?thesis by simp (rule r2)
qed

theorem conjI_realizer:
  "P p \<Longrightarrow> Q q \<Longrightarrow> P (fst (p, q)) \<and> Q (snd (p, q))"
  by simp

theorem exI_realizer:
  "P y x \<Longrightarrow> P (snd (x, y)) (fst (x, y))" by simp

theorem exE_realizer: "P (snd p) (fst p) \<Longrightarrow>
  (\<And>x y. P y x \<Longrightarrow> Q (f x y)) \<Longrightarrow> Q (let (x, y) = p in f x y)"
  by (cases p) (simp add: Let_def)

theorem exE_realizer': "P (snd p) (fst p) \<Longrightarrow>
  (\<And>x y. P y x \<Longrightarrow> Q) \<Longrightarrow> Q" by (cases p) simp

realizers
  impI (P, Q): "\<lambda>pq. pq"
    "\<^bold>\<lambda>(c: _) (d: _) P Q pq (h: _). allI \<cdot> _ \<bullet> c \<bullet> (\<^bold>\<lambda>x. impI \<cdot> _ \<cdot> _ \<bullet> (h \<cdot> x))"

  impI (P): "Null"
    "\<^bold>\<lambda>(c: _) P Q (h: _). allI \<cdot> _ \<bullet> c \<bullet> (\<^bold>\<lambda>x. impI \<cdot> _ \<cdot> _ \<bullet> (h \<cdot> x))"

  impI (Q): "\<lambda>q. q" "\<^bold>\<lambda>(c: _) P Q q. impI \<cdot> _ \<cdot> _"

  impI: "Null" "impI"

  mp (P, Q): "\<lambda>pq. pq"
    "\<^bold>\<lambda>(c: _) (d: _) P Q pq (h: _) p. mp \<cdot> _ \<cdot> _ \<bullet> (spec \<cdot> _ \<cdot> p \<bullet> c \<bullet> h)"

  mp (P): "Null"
    "\<^bold>\<lambda>(c: _) P Q (h: _) p. mp \<cdot> _ \<cdot> _ \<bullet> (spec \<cdot> _ \<cdot> p \<bullet> c \<bullet> h)"

  mp (Q): "\<lambda>q. q" "\<^bold>\<lambda>(c: _) P Q q. mp \<cdot> _ \<cdot> _"

  mp: "Null" "mp"

  allI (P): "\<lambda>p. p" "\<^bold>\<lambda>(c: _) P (d: _) p. allI \<cdot> _ \<bullet> d"

  allI: "Null" "allI"

  spec (P): "\<lambda>x p. p x" "\<^bold>\<lambda>(c: _) P x (d: _) p. spec \<cdot> _ \<cdot> x \<bullet> d"

  spec: "Null" "spec"

  exI (P): "\<lambda>x p. (x, p)" "\<^bold>\<lambda>(c: _) P x (d: _) p. exI_realizer \<cdot> P \<cdot> p \<cdot> x \<bullet> c \<bullet> d"

  exI: "\<lambda>x. x" "\<^bold>\<lambda>P x (c: _) (h: _). h"

  exE (P, Q): "\<lambda>p pq. let (x, y) = p in pq x y"
    "\<^bold>\<lambda>(c: _) (d: _) P Q (e: _) p (h: _) pq. exE_realizer \<cdot> P \<cdot> p \<cdot> Q \<cdot> pq \<bullet> c \<bullet> e \<bullet> d \<bullet> h"

  exE (P): "Null"
    "\<^bold>\<lambda>(c: _) P Q (d: _) p. exE_realizer' \<cdot> _ \<cdot> _ \<cdot> _ \<bullet> c \<bullet> d"

  exE (Q): "\<lambda>x pq. pq x"
    "\<^bold>\<lambda>(c: _) P Q (d: _) x (h1: _) pq (h2: _). h2 \<cdot> x \<bullet> h1"

  exE: "Null"
    "\<^bold>\<lambda>P Q (c: _) x (h1: _) (h2: _). h2 \<cdot> x \<bullet> h1"

  conjI (P, Q): "Pair"
    "\<^bold>\<lambda>(c: _) (d: _) P Q p (h: _) q. conjI_realizer \<cdot> P \<cdot> p \<cdot> Q \<cdot> q \<bullet> c \<bullet> d \<bullet> h"

  conjI (P): "\<lambda>p. p"
    "\<^bold>\<lambda>(c: _) P Q p. conjI \<cdot> _ \<cdot> _"

  conjI (Q): "\<lambda>q. q"
    "\<^bold>\<lambda>(c: _) P Q (h: _) q. conjI \<cdot> _ \<cdot> _ \<bullet> h"

  conjI: "Null" "conjI"

  conjunct1 (P, Q): "fst"
    "\<^bold>\<lambda>(c: _) (d: _) P Q pq. conjunct1 \<cdot> _ \<cdot> _"

  conjunct1 (P): "\<lambda>p. p"
    "\<^bold>\<lambda>(c: _) P Q p. conjunct1 \<cdot> _ \<cdot> _"

  conjunct1 (Q): "Null"
    "\<^bold>\<lambda>(c: _) P Q q. conjunct1 \<cdot> _ \<cdot> _"

  conjunct1: "Null" "conjunct1"

  conjunct2 (P, Q): "snd"
    "\<^bold>\<lambda>(c: _) (d: _) P Q pq. conjunct2 \<cdot> _ \<cdot> _"

  conjunct2 (P): "Null"
    "\<^bold>\<lambda>(c: _) P Q p. conjunct2 \<cdot> _ \<cdot> _"

  conjunct2 (Q): "\<lambda>p. p"
    "\<^bold>\<lambda>(c: _) P Q p. conjunct2 \<cdot> _ \<cdot> _"

  conjunct2: "Null" "conjunct2"

  disjI1 (P, Q): "Inl"
    "\<^bold>\<lambda>(c: _) (d: _) P Q p. iffD2 \<cdot> _ \<cdot> _ \<bullet> (sum.case_1 \<cdot> P \<cdot> _ \<cdot> p \<bullet> arity_type_bool \<bullet> c \<bullet> d)"

  disjI1 (P): "Some"
    "\<^bold>\<lambda>(c: _) P Q p. iffD2 \<cdot> _ \<cdot> _ \<bullet> (option.case_2 \<cdot> _ \<cdot> P \<cdot> p \<bullet> arity_type_bool \<bullet> c)"

  disjI1 (Q): "None"
    "\<^bold>\<lambda>(c: _) P Q. iffD2 \<cdot> _ \<cdot> _ \<bullet> (option.case_1 \<cdot> _ \<cdot> _ \<bullet> arity_type_bool \<bullet> c)"

  disjI1: "Left"
    "\<^bold>\<lambda>P Q. iffD2 \<cdot> _ \<cdot> _ \<bullet> (sumbool.case_1 \<cdot> _ \<cdot> _ \<bullet> arity_type_bool)"

  disjI2 (P, Q): "Inr"
    "\<^bold>\<lambda>(d: _) (c: _) Q P q. iffD2 \<cdot> _ \<cdot> _ \<bullet> (sum.case_2 \<cdot> _ \<cdot> Q \<cdot> q \<bullet> arity_type_bool \<bullet> c \<bullet> d)"

  disjI2 (P): "None"
    "\<^bold>\<lambda>(c: _) Q P. iffD2 \<cdot> _ \<cdot> _ \<bullet> (option.case_1 \<cdot> _ \<cdot> _ \<bullet> arity_type_bool \<bullet> c)"

  disjI2 (Q): "Some"
    "\<^bold>\<lambda>(c: _) Q P q. iffD2 \<cdot> _ \<cdot> _ \<bullet> (option.case_2 \<cdot> _ \<cdot> Q \<cdot> q \<bullet> arity_type_bool \<bullet> c)"

  disjI2: "Right"
    "\<^bold>\<lambda>Q P. iffD2 \<cdot> _ \<cdot> _ \<bullet> (sumbool.case_2 \<cdot> _ \<cdot> _ \<bullet> arity_type_bool)"

  disjE (P, Q, R): "\<lambda>pq pr qr.
     (case pq of Inl p \<Rightarrow> pr p | Inr q \<Rightarrow> qr q)"
    "\<^bold>\<lambda>(c: _) (d: _) (e: _) P Q R pq (h1: _) pr (h2: _) qr.
       disjE_realizer \<cdot> _ \<cdot> _ \<cdot> pq \<cdot> R \<cdot> pr \<cdot> qr \<bullet> c \<bullet> d \<bullet> e \<bullet> h1 \<bullet> h2"

  disjE (Q, R): "\<lambda>pq pr qr.
     (case pq of None \<Rightarrow> pr | Some q \<Rightarrow> qr q)"
    "\<^bold>\<lambda>(c: _) (d: _) P Q R pq (h1: _) pr (h2: _) qr.
       disjE_realizer2 \<cdot> _ \<cdot> _ \<cdot> pq \<cdot> R \<cdot> pr \<cdot> qr \<bullet> c \<bullet> d \<bullet> h1 \<bullet> h2"

  disjE (P, R): "\<lambda>pq pr qr.
     (case pq of None \<Rightarrow> qr | Some p \<Rightarrow> pr p)"
    "\<^bold>\<lambda>(c: _) (d: _) P Q R pq (h1: _) pr (h2: _) qr (h3: _).
       disjE_realizer2 \<cdot> _ \<cdot> _ \<cdot> pq \<cdot> R \<cdot> qr \<cdot> pr \<bullet> c \<bullet> d \<bullet> h1 \<bullet> h3 \<bullet> h2"

  disjE (R): "\<lambda>pq pr qr.
     (case pq of Left \<Rightarrow> pr | Right \<Rightarrow> qr)"
    "\<^bold>\<lambda>(c: _) P Q R pq (h1: _) pr (h2: _) qr.
       disjE_realizer3 \<cdot> _ \<cdot> _ \<cdot> pq \<cdot> R \<cdot> pr \<cdot> qr \<bullet> c \<bullet> h1 \<bullet> h2"

  disjE (P, Q): "Null"
    "\<^bold>\<lambda>(c: _) (d: _) P Q R pq. disjE_realizer \<cdot> _ \<cdot> _ \<cdot> pq \<cdot> (\<lambda>x. R) \<cdot> _ \<cdot> _ \<bullet> c \<bullet> d \<bullet> arity_type_bool"

  disjE (Q): "Null"
    "\<^bold>\<lambda>(c: _) P Q R pq. disjE_realizer2 \<cdot> _ \<cdot> _ \<cdot> pq \<cdot> (\<lambda>x. R) \<cdot> _ \<cdot> _ \<bullet> c \<bullet> arity_type_bool"

  disjE (P): "Null"
    "\<^bold>\<lambda>(c: _) P Q R pq (h1: _) (h2: _) (h3: _).
       disjE_realizer2 \<cdot> _ \<cdot> _ \<cdot> pq \<cdot> (\<lambda>x. R) \<cdot> _ \<cdot> _ \<bullet> c \<bullet> arity_type_bool \<bullet> h1 \<bullet> h3 \<bullet> h2"

  disjE: "Null"
    "\<^bold>\<lambda>P Q R pq. disjE_realizer3 \<cdot> _ \<cdot> _ \<cdot> pq \<cdot> (\<lambda>x. R) \<cdot> _ \<cdot> _ \<bullet> arity_type_bool"

  FalseE (P): "default"
    "\<^bold>\<lambda>(c: _) P. FalseE \<cdot> _"

  FalseE: "Null" "FalseE"

  notI (P): "Null"
    "\<^bold>\<lambda>(c: _) P (h: _). allI \<cdot> _ \<bullet> c \<bullet> (\<^bold>\<lambda>x. notI \<cdot> _ \<bullet> (h \<cdot> x))"

  notI: "Null" "notI"

  notE (P, R): "\<lambda>p. default"
    "\<^bold>\<lambda>(c: _) (d: _) P R (h: _) p. notE \<cdot> _ \<cdot> _ \<bullet> (spec \<cdot> _ \<cdot> p \<bullet> c \<bullet> h)"

  notE (P): "Null"
    "\<^bold>\<lambda>(c: _) P R (h: _) p. notE \<cdot> _ \<cdot> _ \<bullet> (spec \<cdot> _ \<cdot> p \<bullet> c \<bullet> h)"

  notE (R): "default"
    "\<^bold>\<lambda>(c: _) P R. notE \<cdot> _ \<cdot> _"

  notE: "Null" "notE"

  subst (P): "\<lambda>s t ps. ps"
    "\<^bold>\<lambda>(c: _) s t P (d: _) (h: _) ps. subst \<cdot> s \<cdot> t \<cdot> P ps \<bullet> d \<bullet> h"

  subst: "Null" "subst"

  iffD1 (P, Q): "fst"
    "\<^bold>\<lambda>(d: _) (c: _) Q P pq (h: _) p.
       mp \<cdot> _ \<cdot> _ \<bullet> (spec \<cdot> _ \<cdot> p \<bullet> d \<bullet> (conjunct1 \<cdot> _ \<cdot> _ \<bullet> h))"

  iffD1 (P): "\<lambda>p. p"
    "\<^bold>\<lambda>(c: _) Q P p (h: _). mp \<cdot> _ \<cdot> _ \<bullet> (conjunct1 \<cdot> _ \<cdot> _ \<bullet> h)"

  iffD1 (Q): "Null"
    "\<^bold>\<lambda>(c: _) Q P q1 (h: _) q2.
       mp \<cdot> _ \<cdot> _ \<bullet> (spec \<cdot> _ \<cdot> q2 \<bullet> c \<bullet> (conjunct1 \<cdot> _ \<cdot> _ \<bullet> h))"

  iffD1: "Null" "iffD1"

  iffD2 (P, Q): "snd"
    "\<^bold>\<lambda>(c: _) (d: _) P Q pq (h: _) q.
       mp \<cdot> _ \<cdot> _ \<bullet> (spec \<cdot> _ \<cdot> q \<bullet> d \<bullet> (conjunct2 \<cdot> _ \<cdot> _ \<bullet> h))"

  iffD2 (P): "\<lambda>p. p"
    "\<^bold>\<lambda>(c: _) P Q p (h: _). mp \<cdot> _ \<cdot> _ \<bullet> (conjunct2 \<cdot> _ \<cdot> _ \<bullet> h)"

  iffD2 (Q): "Null"
    "\<^bold>\<lambda>(c: _) P Q q1 (h: _) q2.
       mp \<cdot> _ \<cdot> _ \<bullet> (spec \<cdot> _ \<cdot> q2 \<bullet> c \<bullet> (conjunct2 \<cdot> _ \<cdot> _ \<bullet> h))"

  iffD2: "Null" "iffD2"

  iffI (P, Q): "Pair"
    "\<^bold>\<lambda>(c: _) (d: _) P Q pq (h1 : _) qp (h2 : _). conjI_realizer \<cdot>
       (\<lambda>pq. \<forall>x. P x \<longrightarrow> Q (pq x)) \<cdot> pq \<cdot>
       (\<lambda>qp. \<forall>x. Q x \<longrightarrow> P (qp x)) \<cdot> qp \<bullet>
       (arity_type_fun \<bullet> c \<bullet> d) \<bullet>
       (arity_type_fun \<bullet> d \<bullet> c) \<bullet>
       (allI \<cdot> _ \<bullet> c \<bullet> (\<^bold>\<lambda>x. impI \<cdot> _ \<cdot> _ \<bullet> (h1 \<cdot> x))) \<bullet>
       (allI \<cdot> _ \<bullet> d \<bullet> (\<^bold>\<lambda>x. impI \<cdot> _ \<cdot> _ \<bullet> (h2 \<cdot> x)))"

  iffI (P): "\<lambda>p. p"
    "\<^bold>\<lambda>(c: _) P Q (h1 : _) p (h2 : _). conjI \<cdot> _ \<cdot> _ \<bullet>
       (allI \<cdot> _ \<bullet> c \<bullet> (\<^bold>\<lambda>x. impI \<cdot> _ \<cdot> _ \<bullet> (h1 \<cdot> x))) \<bullet>
       (impI \<cdot> _ \<cdot> _ \<bullet> h2)"

  iffI (Q): "\<lambda>q. q"
    "\<^bold>\<lambda>(c: _) P Q q (h1 : _) (h2 : _). conjI \<cdot> _ \<cdot> _ \<bullet>
       (impI \<cdot> _ \<cdot> _ \<bullet> h1) \<bullet>
       (allI \<cdot> _ \<bullet> c \<bullet> (\<^bold>\<lambda>x. impI \<cdot> _ \<cdot> _ \<bullet> (h2 \<cdot> x)))"

  iffI: "Null" "iffI"

end


theory "TLS_cert_auto"
imports
  "ESPLogic"
begin

(* section:  TLS Handshake  *)

(* text:
  Modeled after Paulson`s TLS model in Isabelle/src/HOL/Auth/TLS.thy. Notable
  differences are:

    1. We use explicit global constants to differentiate between different
       encryptions instead of implicit typing.

    2. We model session keys directly as hashes of the relevant information.
       Due to our support for composed keys, we do not need any custom
       axiomatization as Paulson does.

    3. We do not model the ClientResume, ServerResume, and Oops steps. They
       are currently outside the scope of our modelling language.

 *)

role C
where "C =
  [ Send ''1'' <| sAV ''C'', sN ''nc'', sN ''sid'', sN ''pc'' |>
  , Recv ''2'' <| sMV ''ns'', sN ''sid'', sMV ''ps'' |>
  , Send ''ca1'' ( sAV ''S'' )
  , Recv ''ca2'' <| sMV ''CA'',
                    PSign <| sC ''cert'', sAV ''S'', sMV ''pkS'' |>
                          ( PAsymPK ( sMV ''CA'' ) )
                 |>
  , Send ''3'' <| PEnc <| sC ''31'', sN ''pms'' |> ( sMV ''pkS'' ),
                  PSign <| sC ''32'',
                           PHash <| sC ''32'', sMV ''ns'', sAV ''S'', sN ''pms'' |>
                        |>
                        ( sPK ''C'' ),
                  PEnc <| sC ''33'', sN ''sid'',
                          PHash <| sC ''PRF'', sN ''pms'', sN ''nc'', sMV ''ns'' |>, sN ''nc'',
                          sN ''pc'', sAV ''C'', sMV ''ns'', sMV ''ps'', sAV ''S''
                       |>
                       ( PHash <| sC ''clientKey'', sN ''nc'', sMV ''ns'',
                                  PHash <| sC ''PRF'', sN ''pms'', sN ''nc'', sMV ''ns'' |>
                               |>
                       )
               |>
  , Recv ''4'' ( PEnc <| sC ''4'', sN ''sid'',
                         PHash <| sC ''PRF'', sN ''pms'', sN ''nc'', sMV ''ns'' |>, sN ''nc'',
                         sN ''pc'', sAV ''C'', sMV ''ns'', sMV ''ps'', sAV ''S''
                      |>
                      ( PHash <| sC ''serverKey'', sN ''nc'', sMV ''ns'',
                                 PHash <| sC ''PRF'', sN ''pms'', sN ''nc'', sMV ''ns'' |>
                              |>
                      )
               )
  ]"

role CA
where "CA =
  [ Recv ''ca1'' ( sMV ''S'' )
  , Send ''ca2'' <| sAV ''CA'',
                    PSign <| sC ''cert'', sMV ''S'', PAsymPK ( sMV ''S'' ) |> ( sPK ''CA'' )
                 |>
  ]"

role S
where "S =
  [ Recv ''1'' <| sMV ''C'', sMV ''nc'', sMV ''sid'', sMV ''pc'' |>
  , Send ''2'' <| sN ''ns'', sMV ''sid'', sN ''ps'' |>
  , Recv ''3'' <| PEnc <| sC ''31'', sMV ''pms'' |> ( sPK ''S'' ),
                  PSign <| sC ''32'',
                           PHash <| sC ''32'', sN ''ns'', sAV ''S'', sMV ''pms'' |>
                        |>
                        ( PAsymPK ( sMV ''C'' ) ),
                  PEnc <| sC ''33'', sMV ''sid'',
                          PHash <| sC ''PRF'', sMV ''pms'', sMV ''nc'', sN ''ns'' |>, sMV ''nc'',
                          sMV ''pc'', sMV ''C'', sN ''ns'', sN ''ps'', sAV ''S''
                       |>
                       ( PHash <| sC ''clientKey'', sMV ''nc'', sN ''ns'',
                                  PHash <| sC ''PRF'', sMV ''pms'', sMV ''nc'', sN ''ns'' |>
                               |>
                       )
               |>
  , Send ''4'' ( PEnc <| sC ''4'', sMV ''sid'',
                         PHash <| sC ''PRF'', sMV ''pms'', sMV ''nc'', sN ''ns'' |>, sMV ''nc'',
                         sMV ''pc'', sMV ''C'', sN ''ns'', sN ''ps'', sAV ''S''
                      |>
                      ( PHash <| sC ''serverKey'', sMV ''nc'', sN ''ns'',
                                 PHash <| sC ''PRF'', sMV ''pms'', sMV ''nc'', sN ''ns'' |>
                              |>
                      )
               )
  ]"

protocol TLS
where "TLS = { C, CA, S }"

locale restricted_TLS_state = TLS_state +
  assumes uncompromised_CA:
    "!! tid1.
       [| roleMap r tid1 = Some C |] ==> RLKR(s(MV ''CA'' tid1)) ~: reveals t"

type_invariant TLS_msc_typing for TLS
where "TLS_msc_typing = mk_typing
  [ ((S, ''C''), (KnownT S_1))
  , ((C, ''CA''), (KnownT C_ca2))
  , ((CA, ''S''), (KnownT CA_ca1))
  , ((S, ''nc''), (KnownT S_1))
  , ((C, ''ns''), (KnownT C_2))
  , ((S, ''pc''), (KnownT S_1))
  , ((C, ''pkS''), (KnownT C_ca2))
  , ((S, ''pms''), (SumT (KnownT S_3) (NonceT C ''pms'')))
  , ((C, ''ps''), (KnownT C_2))
  , ((S, ''sid''), (KnownT S_1))
  ]"

sublocale TLS_state < TLS_msc_typing_state
proof -
  have "(t,r,s) : approx TLS_msc_typing"
  proof(cases rule: reachable_in_approxI_ext
        [OF TLS_msc_typing.monoTyp, completeness_cases_rule])
    case (C_2_ns t r s tid0)
    then interpret state: TLS_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = C_2_ns
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (C_2_ps t r s tid0)
    then interpret state: TLS_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = C_2_ps
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (C_ca2_CA t r s tid0)
    then interpret state: TLS_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = C_ca2_CA
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (C_ca2_pkS t r s tid0)
    then interpret state: TLS_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = C_ca2_pkS
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (S_1_C t r s tid0)
    then interpret state: TLS_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_1_C
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (S_1_nc t r s tid0)
    then interpret state: TLS_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_1_nc
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (S_1_pc t r s tid0)
    then interpret state: TLS_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_1_pc
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (S_1_sid t r s tid0)
    then interpret state: TLS_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_1_sid
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (S_3_pms t r s tid0)
    then interpret state: TLS_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_3_pms
    thus ?case
    proof(sources! "
        Hash {| LC ''32'', LN ''ns'' tid0, s(AV ''S'' tid0), s(MV ''pms'' tid0)
             |} ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  qed
  thus "TLS_msc_typing_state t r s" by unfold_locales auto
qed

text{* Prove secrecy of long-term keys. *}
context TLS_state begin

  (* This rule is unsafe in general, but OK here,
     as we are only reasoning about static compromise.
  *)
  lemma static_longterm_key_reveal[dest!]:
    "predOrd t (LKR a) e ==> RLKR a : reveals t"
    by (auto intro: compr_predOrdI)

  lemma longterm_private_key_secrecy:
    assumes facts:
      "SK m : knows t"
      "RLKR m ~: reveals t"
    shows "False"
  using facts by (sources "SK m")

  lemma longterm_sym_ud_key_secrecy:
    assumes facts:
      "K m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
    shows "False"
  using facts by (sources "K m1 m2")

  lemma longterm_sym_bd_key_secrecy:
    assumes facts:
      "Kbd m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
      "m1 : Agent"
      "m2 : Agent"
    shows "False"
  proof -
    from facts
    have "KShr (agents {m1, m2}) : knows t"
      by (auto simp: Kbd_def)
    thus ?thesis using facts
    proof (sources "KShr (agents {m1, m2})")
    qed (auto simp: agents_def Agent_def)
  qed

  lemmas ltk_secrecy =
    longterm_sym_ud_key_secrecy
    longterm_sym_ud_key_secrecy[OF in_knows_predOrd1]
    longterm_sym_bd_key_secrecy
    longterm_sym_bd_key_secrecy[OF in_knows_predOrd1]
    longterm_private_key_secrecy
    longterm_private_key_secrecy[OF in_knows_predOrd1]

end

(* text:
We assume that all clients talk to uncompromised certificate authorities.
 *)

(* subsection:  Secrecy Properties  *)

lemma (in restricted_TLS_state) C_pms_sec:
  assumes facts:
    "roleMap r tid0 = Some C"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "LN ''pms'' tid0 : knows t"
  shows "False"
proof -
  have f1: "roleMap r tid0 = Some C" using facts by (auto intro: event_predOrdI)
  note facts = facts uncompromised_CA[OF f1, simplified]
  thus ?thesis proof(sources! " LN ''pms'' tid0 ")
    case C_3_pms note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''cert'', s(AV ''S'' tid0), s(MV ''pkS'' tid0) |}
                         ( SK ( s(MV ''CA'' tid0) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (auto dest!: ltk_secrecy)
    next
      case (CA_ca2_enc tid1) note_unified facts = this facts
      thus ?thesis by (auto dest!: ltk_secrecy)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_TLS_state) C_PRF_sec:
  assumes facts:
    "roleMap r tid0 = Some C"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "Hash {| LC ''PRF'', LN ''pms'' tid0, LN ''nc'' tid0, s(MV ''ns'' tid0)
          |} : knows t"
  shows "False"
using facts proof(sources! "
                Hash {| LC ''PRF'', LN ''pms'' tid0, LN ''nc'' tid0, s(MV ''ns'' tid0)
                     |} ")
  case fake note_unified facts = this facts
  thus ?thesis by (fastforce dest: C_pms_sec intro: event_predOrdI)
next
  case (C_3_hash_2 tid1) note_unified facts = this facts
  thus ?thesis proof(sources! "
                   Hash {| LC ''clientKey'', LN ''nc'' tid0, s(MV ''ns'' tid0),
                           Hash {| LC ''PRF'', LN ''pms'' tid0, LN ''nc'' tid0, s(MV ''ns'' tid0) |}
                        |} ")
  qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
next
  case (S_4_hash tid1) note_unified facts = this facts
  thus ?thesis proof(sources! "
                   Hash {| LC ''serverKey'', LN ''nc'' tid0, LN ''ns'' tid1,
                           Hash {| LC ''PRF'', LN ''pms'' tid0, LN ''nc'' tid0, LN ''ns'' tid1 |}
                        |} ")
  qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_TLS_state) C_clientKey_sec:
  assumes facts:
    "roleMap r tid0 = Some C"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "Hash {| LC ''clientKey'', LN ''nc'' tid0, s(MV ''ns'' tid0),
             Hash {| LC ''PRF'', LN ''pms'' tid0, LN ''nc'' tid0, s(MV ''ns'' tid0) |}
          |} : knows t"
  shows "False"
using facts proof(sources! "
                Hash {| LC ''clientKey'', LN ''nc'' tid0, s(MV ''ns'' tid0),
                        Hash {| LC ''PRF'', LN ''pms'' tid0, LN ''nc'' tid0, s(MV ''ns'' tid0) |}
                     |} ")
  case fake note_unified facts = this facts
  thus ?thesis by (fastforce dest: C_PRF_sec intro: event_predOrdI)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_TLS_state) C_serverKey_sec:
  assumes facts:
    "roleMap r tid0 = Some C"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "Hash {| LC ''serverKey'', LN ''nc'' tid0, s(MV ''ns'' tid0),
             Hash {| LC ''PRF'', LN ''pms'' tid0, LN ''nc'' tid0, s(MV ''ns'' tid0) |}
          |} : knows t"
  shows "False"
using facts proof(sources! "
                Hash {| LC ''serverKey'', LN ''nc'' tid0, s(MV ''ns'' tid0),
                        Hash {| LC ''PRF'', LN ''pms'' tid0, LN ''nc'' tid0, s(MV ''ns'' tid0) |}
                     |} ")
  case fake note_unified facts = this facts
  thus ?thesis by (fastforce dest: C_PRF_sec intro: event_predOrdI)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_TLS_state) S_pms_sec:
  assumes facts:
    "roleMap r tid0 = Some S"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "RLKR(s(MV ''C'' tid0)) ~: reveals t"
    "( tid0, S_4 ) : steps t"
    "s(MV ''pms'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''32'',
                          Hash {| LC ''32'', LN ''ns'' tid0, s(AV ''S'' tid0), s(MV ''pms'' tid0)
                               |}
                       |}
                       ( SK ( s(MV ''C'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (C_3_enc_1 tid1) note_unified facts = this facts
    thus ?thesis by (fastforce dest: C_pms_sec intro: event_predOrdI)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_TLS_state) S_PRF_sec:
  assumes facts:
    "roleMap r tid0 = Some S"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "RLKR(s(MV ''C'' tid0)) ~: reveals t"
    "( tid0, S_4 ) : steps t"
    "Hash {| LC ''PRF'', s(MV ''pms'' tid0), s(MV ''nc'' tid0),
             LN ''ns'' tid0
          |} : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Hash {| LC ''PRF'', s(MV ''pms'' tid0), s(MV ''nc'' tid0), LN ''ns'' tid0
                        |} ")
    case fake note_unified facts = this facts
    thus ?thesis by (fastforce dest: S_pms_sec intro: event_predOrdI)
  next
    case (C_3_hash_2 tid1) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Hash {| LC ''32'', LN ''ns'' tid0, s(AV ''S'' tid0), LN ''pms'' tid1
                          |} ")
      case fake note_unified facts = this facts
      thus ?thesis by (fastforce dest: S_pms_sec intro: event_predOrdI)
    next
      case (C_3_hash tid2) note_unified facts = this facts
      thus ?thesis by (fastforce dest: C_PRF_sec intro: event_predOrdI)
    next
      case (C_3_hash_1 tid2) note_unified facts = this facts
      thus ?thesis by (fastforce dest: C_PRF_sec intro: event_predOrdI)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  next
    case (S_4_hash tid1) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Hash {| LC ''serverKey'', s(MV ''nc'' tid0), LN ''ns'' tid0,
                             Hash {| LC ''PRF'', s(MV ''pms'' tid0), s(MV ''nc'' tid0), LN ''ns'' tid0
                                  |}
                          |} ")
    qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_TLS_state) S_clientKey_sec:
  assumes facts:
    "roleMap r tid0 = Some S"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "RLKR(s(MV ''C'' tid0)) ~: reveals t"
    "( tid0, S_4 ) : steps t"
    "Hash {| LC ''clientKey'', s(MV ''nc'' tid0), LN ''ns'' tid0,
             Hash {| LC ''PRF'', s(MV ''pms'' tid0), s(MV ''nc'' tid0), LN ''ns'' tid0
                  |}
          |} : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Hash {| LC ''clientKey'', s(MV ''nc'' tid0), LN ''ns'' tid0,
                           Hash {| LC ''PRF'', s(MV ''pms'' tid0), s(MV ''nc'' tid0), LN ''ns'' tid0
                                |}
                        |} ")
    case fake note_unified facts = this facts
    thus ?thesis by (fastforce dest: S_PRF_sec intro: event_predOrdI)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_TLS_state) S_serverKey_sec:
  assumes facts:
    "roleMap r tid0 = Some S"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "RLKR(s(MV ''C'' tid0)) ~: reveals t"
    "( tid0, S_4 ) : steps t"
    "Hash {| LC ''serverKey'', s(MV ''nc'' tid0), LN ''ns'' tid0,
             Hash {| LC ''PRF'', s(MV ''pms'' tid0), s(MV ''nc'' tid0), LN ''ns'' tid0
                  |}
          |} : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Hash {| LC ''serverKey'', s(MV ''nc'' tid0), LN ''ns'' tid0,
                           Hash {| LC ''PRF'', s(MV ''pms'' tid0), s(MV ''nc'' tid0), LN ''ns'' tid0
                                |}
                        |} ")
    case fake note_unified facts = this facts
    thus ?thesis by (fastforce dest: S_PRF_sec intro: event_predOrdI)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

(* subsection:  Authentication Properties  *)

(* text:
  First, we prove two first send properties in order to simplify proof search
  for the authentication properties.
 *)

lemma (in restricted_TLS_state) nc_first_send:
  assumes facts:
    "roleMap r tid1 = Some C"
    "LN ''nc'' tid1 : knows t"
  shows "predOrd t (St( tid1, C_1 )) (Ln(LN ''nc'' tid1))"
using facts proof(sources! " LN ''nc'' tid1 ")
  case C_1_nc note_unified facts = this facts
  thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
next
  case C_3_nc note_unified facts = this facts
  thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_TLS_state) ns_first_send:
  assumes facts:
    "roleMap r tid1 = Some S"
    "LN ''ns'' tid1 : knows t"
  shows "predOrd t (St( tid1, S_2 )) (Ln(LN ''ns'' tid1))"
using facts proof(sources! " LN ''ns'' tid1 ")
  case S_2_ns note_unified facts = this facts
  thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
next
  case S_4_ns note_unified facts = this facts
  thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_TLS_state) C_ni_synch:
  assumes facts:
    "roleMap r tid1 = Some C"
    "RLKR(s(AV ''C'' tid1)) ~: reveals t"
    "RLKR(s(AV ''S'' tid1)) ~: reveals t"
    "( tid1, C_4 ) : steps t"
  shows
    "(?  tid2.
        roleMap r tid2 = Some S &
        s(AV ''C'' tid1) = s(MV ''C'' tid2) &
        s(AV ''S'' tid1) = s(AV ''S'' tid2) &
        LN ''nc'' tid1 = s(MV ''nc'' tid2) &
        s(MV ''ns'' tid1) = LN ''ns'' tid2 &
        LN ''pc'' tid1 = s(MV ''pc'' tid2) &
        s(MV ''ps'' tid1) = LN ''ps'' tid2 &
        LN ''sid'' tid1 = s(MV ''sid'' tid2) &
        LN ''pms'' tid1 = s(MV ''pms'' tid2) &
        predOrd t (St( tid1, C_1 )) (St( tid2, S_1 )) &
        predOrd t (St( tid2, S_1 )) (St( tid2, S_2 )) &
        predOrd t (St( tid2, S_2 )) (St( tid1, C_2 )) &
        predOrd t (St( tid1, C_2 )) (St( tid1, C_3 )) &
        predOrd t (St( tid1, C_3 )) (St( tid2, S_3 )) &
        predOrd t (St( tid2, S_3 )) (St( tid2, S_4 )) &
        predOrd t (St( tid2, S_4 )) (St( tid1, C_4 )))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''4'', LN ''sid'' tid1,
                          Hash {| LC ''PRF'', LN ''pms'' tid1, LN ''nc'' tid1, s(MV ''ns'' tid1)
                               |},
                          LN ''nc'' tid1, LN ''pc'' tid1, s(AV ''C'' tid1), s(MV ''ns'' tid1),
                          s(MV ''ps'' tid1), s(AV ''S'' tid1)
                       |}
                       ( Hash {| LC ''serverKey'', LN ''nc'' tid1, s(MV ''ns'' tid1),
                                 Hash {| LC ''PRF'', LN ''pms'' tid1, LN ''nc'' tid1, s(MV ''ns'' tid1) |}
                              |}
                       ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (fastforce dest: C_PRF_sec intro: event_predOrdI)
  next
    case (S_4_enc tid2) note_unified facts = this facts
    have f1: "roleMap r tid1 = Some C" using facts by (auto intro: event_predOrdI)
    have f2: "LN ''nc'' tid1 : knows t" using facts by (auto intro: event_predOrdI)
    note facts = facts nc_first_send[OF f1 f2, simplified]
    have f1: "roleMap r tid2 = Some S" using facts by (auto intro: event_predOrdI)
    have f2: "LN ''ns'' tid2 : knows t" using facts by (auto intro: event_predOrdI)
    note facts = facts ns_first_send[OF f1 f2, simplified]
    thus ?thesis proof(sources! "
                     Enc {| LC ''31'', LN ''pms'' tid1 |} ( PK ( s(AV ''S'' tid1) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (fastforce dest: C_pms_sec intro: event_predOrdI)
    next
      case (C_3_enc tid3) note_unified facts = this facts
      thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_TLS_state) S_ni_synch:
  assumes facts:
    "roleMap r tid2 = Some S"
    "RLKR(s(AV ''S'' tid2)) ~: reveals t"
    "RLKR(s(MV ''C'' tid2)) ~: reveals t"
    "( tid2, S_4 ) : steps t"
  shows
    "(?  tid1.
        roleMap r tid1 = Some C &
        s(AV ''C'' tid1) = s(MV ''C'' tid2) &
        s(AV ''S'' tid1) = s(AV ''S'' tid2) &
        LN ''nc'' tid1 = s(MV ''nc'' tid2) &
        s(MV ''ns'' tid1) = LN ''ns'' tid2 &
        LN ''pc'' tid1 = s(MV ''pc'' tid2) &
        s(MV ''ps'' tid1) = LN ''ps'' tid2 &
        LN ''sid'' tid1 = s(MV ''sid'' tid2) &
        LN ''pms'' tid1 = s(MV ''pms'' tid2) &
        predOrd t (St( tid1, C_1 )) (St( tid2, S_1 )) &
        predOrd t (St( tid2, S_1 )) (St( tid2, S_2 )) &
        predOrd t (St( tid2, S_2 )) (St( tid1, C_2 )) &
        predOrd t (St( tid1, C_2 )) (St( tid1, C_3 )) &
        predOrd t (St( tid1, C_3 )) (St( tid2, S_3 )) &
        predOrd t (St( tid2, S_3 )) (St( tid2, S_4 )))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''33'', s(MV ''sid'' tid2),
                          Hash {| LC ''PRF'', s(MV ''pms'' tid2), s(MV ''nc'' tid2), LN ''ns'' tid2
                               |},
                          s(MV ''nc'' tid2), s(MV ''pc'' tid2), s(MV ''C'' tid2), LN ''ns'' tid2,
                          LN ''ps'' tid2, s(AV ''S'' tid2)
                       |}
                       ( Hash {| LC ''clientKey'', s(MV ''nc'' tid2), LN ''ns'' tid2,
                                 Hash {| LC ''PRF'', s(MV ''pms'' tid2), s(MV ''nc'' tid2), LN ''ns'' tid2
                                      |}
                              |}
                       ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (fastforce dest: S_PRF_sec intro: event_predOrdI)
  next
    case (C_3_enc_2 tid3) note_unified facts = this facts
    have f1: "roleMap r tid3 = Some C" using facts by (auto intro: event_predOrdI)
    have f2: "LN ''nc'' tid3 : knows t" using facts by (auto intro: event_predOrdI)
    note facts = facts nc_first_send[OF f1 f2, simplified]
    have f1: "roleMap r tid2 = Some S" using facts by (auto intro: event_predOrdI)
    have f2: "LN ''ns'' tid2 : knows t" using facts by (auto intro: event_predOrdI)
    note facts = facts ns_first_send[OF f1 f2, simplified]
    thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

end