theory FO_Proofs_Very_Slow
  imports FO_Proofs0
begin

(* This file contains a proof that runs *very* slowly.
   Since this file will be loaded each time qrhl-tool starts up,
   we have commented the proof out and replaced it by "sorry".
   To check the proof, simply remove the "sorry" and comment the
   proof back in. *)

lemma queryH_invariant_vc:
  fixes Hq1 :: "ciph \<Rightarrow> key" and H1 :: "msg \<Rightarrow> key"
  assumes [simp]: "declared_qvars \<lbrakk>Gin1,tmp_Gin2,Gout1,tmp_Gout2,quantA1,quantA2,Hin1,Hout1,Hin2,Hout2,Gin2,Gout2\<rbrakk>"
  (* Copy & paste of subgoal in QRHL tool *)
  shows "\<CC>\<ll>\<aa>[H1 = mk_Hq Hq2 H02 G2 pk2] \<sqinter>
(Uoracle H1\<guillemotright>\<lbrakk>Hin1, Hout1\<rbrakk> \<cdot> \<lbrakk>quantA1, Hin1, Hout1, Gin1, Gout1\<rbrakk> \<equiv>\<qq>
\<lbrakk>quantA2, Hin2, Hout2, tmp_Gin2, tmp_Gout2\<rbrakk>) \<sqinter> Span {ket 0}\<guillemotright>\<lbrakk>Gout2\<rbrakk> \<le> \<CC>\<ll>\<aa>[isometry comm_op] \<sqinter>
((comm_op\<guillemotright>\<lbrakk>Hin2, Gin2\<rbrakk>)* \<cdot> (\<CC>\<ll>\<aa>[isometry (Uoracle G2)] \<sqinter> ((Uoracle G2\<guillemotright>\<lbrakk>Gin2, Gout2\<rbrakk>)* \<cdot>
(\<CC>\<ll>\<aa>[isometry (Uoracle (\<lambda>(m, g). mk_Hq' Hq2 H02 g pk2 m))] \<sqinter> ((Uoracle (\<lambda>(m, g). mk_Hq'
Hq2 H02 g pk2 m)\<guillemotright>variable_concat \<lbrakk>Gin2, Gout2\<rbrakk> \<lbrakk>Hout2\<rbrakk>)* \<cdot> (\<CC>\<ll>\<aa>[isometry (Uoracle G2)] \<sqinter>
((Uoracle G2\<guillemotright>\<lbrakk>Gin2, Gout2\<rbrakk>)* \<cdot> (\<CC>\<ll>\<aa>[isometry comm_op] \<sqinter> ((comm_op\<guillemotright>\<lbrakk>Hin2, Gin2\<rbrakk>)* \<cdot>
(\<CC>\<ll>\<aa>[H1 = mk_Hq Hq2 H02 G2 pk2] \<sqinter> \<lbrakk>quantA1, Hin1, Hout1, Gin1, Gout1\<rbrakk> \<equiv>\<qq>
\<lbrakk>quantA2, Hin2, Hout2, tmp_Gin2, tmp_Gout2\<rbrakk> \<sqinter> (comm_op\<guillemotright>\<lbrakk>Hin2, Gin2\<rbrakk> \<cdot> \<top>))) \<sqinter>
(Uoracle G2\<guillemotright>\<lbrakk>Gin2, Gout2\<rbrakk> \<cdot> \<top>))) \<sqinter> (Uoracle (\<lambda>(m, g). mk_Hq' Hq2 H02 g pk2 m)\<guillemotright>variable_concat
 \<lbrakk>Gin2, Gout2\<rbrakk> \<lbrakk>Hout2\<rbrakk> \<cdot> \<top>))) \<sqinter> (Uoracle G2\<guillemotright>\<lbrakk>Gin2, Gout2\<rbrakk> \<cdot> \<top>))) \<sqinter> (comm_op\<guillemotright>\<lbrakk>Hin2, Gin2\<rbrakk> \<cdot> \<top>)))"
    (is "Cla[?class] \<sqinter> _ \<sqinter> _ \<le> ?post")

  sorry

(*
proof (cases ?class)
  case True
  (* define cla where "cla = ((classA1, c1, K'1, b1, in_pk1, in_cstar1, Kstar1) = (classA2, c2, K'2, b2, in_pk2, in_cstar2, Kstar2) \<and> G1 = G2 \<and> H1 = (\<lambda>m. Hq2 (encrT G2 pk2 m)) \<and> Hq1 = Hq2 \<and> cstar1 = adv_cstar2)" *)
  define h1 where "h1 = Uoracle H1\<guillemotright>\<lbrakk>Hin1, Hout1\<rbrakk>"
  define qeq where "qeq = \<lbrakk>quantA1, Hin1, Hout1, Gin1, Gout1\<rbrakk> \<equiv>\<qq> \<lbrakk>quantA2, Hin2, Hout2, tmp_Gin2, tmp_Gout2\<rbrakk>"
  define ket0 where "ket0 = Span {ket 0}\<guillemotright>\<lbrakk>Gout2\<rbrakk>"

  obtain UoracleH where UoracleH1: "Uoracle H1\<guillemotright>\<lbrakk>Hin1, Hout1\<rbrakk> = UoracleH\<guillemotright>\<lbrakk>quantA1, Hin1, Hout1, Gin1, Gout1\<rbrakk>"
    and UoracleH2: "Uoracle H1\<guillemotright>\<lbrakk>Hin2, Hout2\<rbrakk> = UoracleH\<guillemotright>\<lbrakk>quantA2, Hin2, Hout2, tmp_Gin2, tmp_Gout2\<rbrakk>"
    apply (atomize_elim, rule exI)
    apply (subst lift_extendL[symmetric, where Q="\<lbrakk>Hin1, Hout1, Gin1, Gout1\<rbrakk>"], simp)
    apply (subst lift_extendL[symmetric, where Q="\<lbrakk>Hin2, Hout2, tmp_Gin2, tmp_Gout2\<rbrakk>"], simp)
    apply (subst assoc_op_lift'[where Q="\<lbrakk>Hin1\<rbrakk>"])
    apply (subst assoc_op_lift'[where Q="\<lbrakk>Hin2\<rbrakk>"])
    apply (subst lift_extendR[symmetric, where Q="\<lbrakk>Hin1, Hout1\<rbrakk>"], simp)
    apply (subst lift_extendR[symmetric, where Q="\<lbrakk>Hin2, Hout2\<rbrakk>"], simp)
    by simp
  have UoracleH_sa[simp]: "UoracleH* = UoracleH"
    apply (subst lift_eqOp[symmetric, where Q="\<lbrakk>quantA1, Hin1, Hout1, Gin1, Gout1\<rbrakk>"])
    by (simp_all add: UoracleH1[symmetric] adjoint_lift[symmetric])
  have unitary_UoracleH[simp]: "unitary UoracleH"
    unfolding unitary_def apply simp
    apply (subst lift_eqOp[symmetric, where Q="\<lbrakk>quantA1, Hin1, Hout1, Gin1, Gout1\<rbrakk>"], simp)
    by (simp flip: lift_timesOp UoracleH1, simp)
  have move_Cla_up: "unitary A \<Longrightarrow> A \<cdot> (Cla[X] \<sqinter> S) = Cla[X] \<sqinter> (A \<cdot> S)" for A X S
    by simp

  have conj_True: "(True \<and> True) = True" by simp

  have Cla_True': "x = True \<Longrightarrow> Cla[x] = top" for x by simp

  define comm1 UG2 UHq2
    where "comm1 = comm_op\<guillemotright>\<lbrakk>Hin2, Gin2\<rbrakk>"
      (* and "comm2 = comm_op\<guillemotright>\<lbrakk>Gout2, Gout2\<rbrakk>" *)
      and "UG2 = Uoracle G2\<guillemotright>\<lbrakk>Gin2, Gout2\<rbrakk>"
      and "UHq2 = Uoracle (\<lambda>(m, g). mk_Hq' Hq2 H02 g pk2 m)\<guillemotright>variable_concat \<lbrakk>Gin2, Gout2\<rbrakk> \<lbrakk>Hout2\<rbrakk>"
  (* Simplifier should be able to do this automatically, but runs too long *)
  have post: "?post =
    ((comm1 \<cdot> UG2 \<cdot> UHq2 \<cdot> UG2 \<cdot> comm1)* \<cdot> (qeq))" (is "_ = (applyOpSpace (?op* ) _)")
    unfolding comm1_def UG2_def UHq2_def
    apply (subst Cla_True', simp add: True)+
    apply (simp only: inf_top_left inf_top_right)
    apply (subst unitary_image, simp)+
    apply (simp only: inf_top_left inf_top_right)
    apply (simp only: adjoint_lift adj_comm_op Uoracle_selfadjoint times_adjoint)
    apply (simp only: timesOp_assoc_clinear_space[symmetric] timesOp_assoc[symmetric])
    by (simp only: qeq_def)

  have move: "S \<le> U* \<cdot> T" if "U \<cdot> S \<le> T" and [simp]: "unitary U" for T :: "'z subspace" and U and S :: "'y subspace"
    using applyOpSpace_mono[OF that(1), where A="U*"]
    by (simp flip: timesOp_assoc_clinear_space)

  let ?h2 = "Uoracle H1\<guillemotright>\<lbrakk>Hin2, Hout2\<rbrakk>"

  define Q where "Q = \<lbrakk>quantA1, quantA2, Hin1, Hout1, Gin1, Gout1, Hin2, Hout2, Gin2, Gout2, tmp_Gin2, tmp_Gout2\<rbrakk>"
  have distinct_Q: "distinct_qvars Q"
    unfolding Q_def by simp
  have pred_local: "predicate_local ((h1 \<cdot> qeq) \<sqinter> ket0) Q"
    unfolding qeq_def ket0_def Q_def h1_def by auto
  have op_local: "operator_local (comm1 \<cdot> UG2 \<cdot> UHq2 \<cdot> UG2 \<cdot> comm1) Q"
    unfolding Q_def comm1_def UG2_def UHq2_def by auto
  have h1_local: "operator_local (Uoracle H1\<guillemotright>\<lbrakk>Hin2, Hout2\<rbrakk>) Q"
    unfolding Q_def by auto

  let ?basis = "{ket (a1,a2,hin1,hout1,gin1,gout1,hin2,hout2,gin2,0,qh_gin2,qh_gout2) | a1 a2 hin1 hout1 gin1 gout1 hin2 hout2 gin2 qh_gin2 qh_gout2. True}"
  have span_basis: "liftSpace (Span ?basis) Q = ket0"
  proof -
    have 1: "Span ?basis
      = Span (range ket) \<otimes> Span (range ket) \<otimes> Span (range ket) \<otimes> Span (range ket) \<comment> \<open>a1,a2,hin1,hout1\<close>
       \<otimes> Span (range ket) \<otimes> Span (range ket) \<otimes> Span (range ket) \<otimes> Span (range ket) \<comment> \<open>gin1,gout1,hin2,hout2\<close>
       \<otimes> Span (range ket) \<otimes> Span {ket 0} \<otimes> Span (range ket) \<otimes> Span (range ket)"
      unfolding span_tensor
      apply (auto simp: ket_product image_def simp flip: ex_simps(2))
      by meson
    have 2: "\<dots> \<guillemotright> Q = ket0"
      unfolding ket0_def Q_def
      by (auto simp: tensor_lift)
    show ?thesis
      unfolding 1 2 by simp
  qed

  have eq: "applyOp ?op (lift_vector x Q \<psi>') = applyOp ?h2 (lift_vector x Q \<psi>')" if "x \<in> ?basis" and "\<psi>' \<in> lift_rest Q" for x \<psi>'
  proof -
    from that obtain a1 a2 hin1 hout1 gin1 gout1 hin2 hout2 gin2 qh_gin2 qh_gout2
      where x: "x = ket (a1, a2, hin1, hout1, gin1, gout1, hin2, hout2, gin2, 0, qh_gin2, qh_gout2)"
      by auto

    have "comm1 \<cdot> lift_vector x Q \<psi>'
       = lift_vector (ket (a1, a2, hin1, hout1, gin1, gout1, gin2, hout2, hin2, 0, qh_gin2, qh_gout2)) Q \<psi>'"
      unfolding comm1_def
      apply (rewrite at "comm_op \<guillemotright> _" reorder_variables_hint_def[symmetric, where R="Q"])
      unfolding Q_def
      using [[simp_depth_limit=80]] apply simp
      by (simp add: x applyOp_lift times_applyOp ket_product tensorOp_applyOp_distr)

    also have "UG2 \<cdot> \<dots> = lift_vector (ket (a1, a2, hin1, hout1, gin1, gout1, gin2, hout2, hin2, G2 hin2, qh_gin2, qh_gout2)) Q \<psi>'"
      unfolding UG2_def
      apply (rewrite at "Uoracle _ \<guillemotright> _" reorder_variables_hint_def[symmetric, where R="Q"])
      unfolding Q_def
      using [[simp_depth_limit=80]] apply simp
      apply (simp add: applyOp_lift times_applyOp ket_product tensorOp_applyOp_distr)
      by -

    also have "UHq2 \<cdot> \<dots> = lift_vector (ket (a1, a2, hin1, hout1, gin1, gout1, gin2, hout2 + mk_Hq' Hq2 H02 (G2 hin2) pk2 hin2, hin2, G2 hin2, qh_gin2, qh_gout2)) Q \<psi>'"
    (* also have "UHq2 \<cdot> \<dots> = lift_vector (ket (a1, a2, hin1, hout1, gin1, gout1, gin2, hout2 + mk_Hq' Hq2 H02 (G2 hin2) pk2 hin2, hin2, G2 hin2, gout2)) Q \<psi>'" *)
      unfolding UHq2_def
      apply (rewrite at "Uoracle _ \<guillemotright> _" reorder_variables_hint_def[symmetric, where R="Q"])
      unfolding Q_def
      using [[simp_depth_limit=80]] apply simp
      apply (simp add: applyOp_lift times_applyOp ket_product tensorOp_applyOp_distr)
      apply (simp flip: ket_product)
      apply (simp add: encrT_def applyOp_lift times_applyOp ket_product tensorOp_applyOp_distr)
      by -

    also have "\<dots> = lift_vector (ket (a1, a2, hin1, hout1, gin1, gout1, gin2, hout2 + H1 hin2, hin2, G2 hin2, qh_gin2, qh_gout2)) Q \<psi>'"
    (* also have "\<dots> = lift_vector (ket (a1, a2, hin1, hout1, gin1, gout1, gin2, hout2 + H1 hin2, hin2, G2 hin2, gout2)) Q \<psi>'" *)
      by (simp add: True mk_Hq_def mk_Hq'_def encrT_def msg_spaceT_def)

    also have "UG2 \<cdot> \<dots> = lift_vector (ket (a1, a2, hin1, hout1, gin1, gout1, gin2, hout2 + H1 hin2, hin2, 0, qh_gin2, qh_gout2)) Q \<psi>'"
    (* also have "UG2 \<cdot> \<dots> = lift_vector (ket (a1, a2, hin1, hout1, gin1, gout1, gin2, hout2 + H1 hin2, hin2, 0, gout2)) Q \<psi>'" *)
      unfolding UG2_def
      apply (rewrite at "Uoracle _ \<guillemotright> _" reorder_variables_hint_def[symmetric, where R="Q"])
      unfolding Q_def
      using [[simp_depth_limit=80]] apply simp
      apply (simp add: applyOp_lift times_applyOp ket_product tensorOp_applyOp_distr)
      by -

    also have "comm1 \<cdot> \<dots> = lift_vector (ket (a1, a2, hin1, hout1, gin1, gout1, hin2, hout2 + H1 hin2, gin2, 0, qh_gin2, qh_gout2)) Q \<psi>'"
    (* also have "comm1 \<cdot> \<dots> = lift_vector (ket (a1, a2, hin1, hout1, gin1, gout1, hin2, hout2 + H1 hin2, gin2, gout2, 0)) Q \<psi>'" *)
      unfolding comm1_def
      apply (rewrite at "comm_op \<guillemotright> _" reorder_variables_hint_def[symmetric, where R="Q"])
      unfolding Q_def
      using [[simp_depth_limit=80]] apply simp
      by (simp add: applyOp_lift times_applyOp ket_product tensorOp_applyOp_distr)

    also have "\<dots> = Uoracle H1\<guillemotright>\<lbrakk>Hin2, Hout2\<rbrakk> \<cdot> lift_vector x Q \<psi>'"
      apply (rewrite at "Uoracle _ \<guillemotright> _" reorder_variables_hint_def[symmetric, where R="Q"])
      unfolding Q_def
      using [[simp_depth_limit=80]] apply simp
      apply (simp add: x applyOp_lift times_applyOp ket_product tensorOp_applyOp_distr)
      by -

    finally show ?thesis
      by (simp add: times_applyOp)
  qed

  have "?op \<cdot> (applyOpSpace h1 qeq \<sqinter> ket0) = ?h2 \<cdot> (applyOpSpace h1 qeq \<sqinter> ket0)"
    using distinct_Q pred_local op_local h1_local
    apply (rule applyOpSpace_eq'[where Q=Q and G="?basis"])
     apply (rule eq)
      apply simp
     apply simp
    by (subst span_basis, simp)

  also have "\<dots> \<le> qeq"
    unfolding h1_def ket0_def qeq_def
    unfolding  UoracleH1 UoracleH2
    by (simp del: UoracleH_sa)
  finally have "?op \<cdot> (applyOpSpace h1 qeq \<sqinter> ket0) \<le> qeq"
    by assumption
  then have "applyOpSpace h1 qeq \<sqinter> ket0 \<le> ?op* \<cdot> qeq"
    apply (rule move) by (simp add: comm1_def UG2_def UHq2_def)
  then show ?thesis
    apply (subst post)
    apply (subst eqTrueI[OF True])
    by (simp only: classical_true inf_top_left h1_def ket0_def qeq_def)
next
  case False
  show ?thesis
    apply (simp only: False classical_false inf_bot_left)
    by simp
qed
*)

end


(*  Title:      HOL/Auth/n_deadlock_lemma_inv__1_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

(*header{*The n_deadlock Protocol Case Study*}*)

theory n_deadlock_lemma_inv__1_on_rules imports n_deadlock_lemma_on_inv__1
begin
section{*All lemmas on causal relation between inv__1*}
lemma lemma_inv__1_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__1  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Crit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Exit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Idle  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_TryVsinv__1) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Crit  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_CritVsinv__1) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Exit  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_ExitVsinv__1) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Idle  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_IdleVsinv__1) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


(*  Title:      HOL/Auth/Guard/Proto.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2002  University of Cambridge
*)

section{*Other Protocol-Independent Results*}

theory Proto imports Guard_Public begin

subsection{*protocols*}

type_synonym rule = "event set * event"

abbreviation
  msg' :: "rule => msg" where
  "msg' R == msg (snd R)"

type_synonym proto = "rule set"

definition wdef :: "proto => bool" where
"wdef p == ALL R k. R:p --> Number k:parts {msg' R}
--> Number k:parts (msg`(fst R))"

subsection{*substitutions*}

record subs =
  agent   :: "agent => agent"
  nonce :: "nat => nat"
  nb    :: "nat => msg"
  key   :: "key => key"

primrec apm :: "subs => msg => msg" where
  "apm s (Agent A) = Agent (agent s A)"
| "apm s (Nonce n) = Nonce (nonce s n)"
| "apm s (Number n) = nb s n"
| "apm s (Key K) = Key (key s K)"
| "apm s (Hash X) = Hash (apm s X)"
| "apm s (Crypt K X) = (
if (EX A. K = pubK A) then Crypt (pubK (agent s (agt K))) (apm s X)
else if (EX A. K = priK A) then Crypt (priK (agent s (agt K))) (apm s X)
else Crypt (key s K) (apm s X))"
| "apm s {|X,Y|} = {|apm s X, apm s Y|}"

lemma apm_parts: "X:parts {Y} ==> apm s X:parts {apm s Y}"
apply (erule parts.induct, simp_all, blast)
apply (erule parts.Fst)
apply (erule parts.Snd)
by (erule parts.Body)+

lemma Nonce_apm [rule_format]: "Nonce n:parts {apm s X} ==>
(ALL k. Number k:parts {X} --> Nonce n ~:parts {nb s k}) -->
(EX k. Nonce k:parts {X} & nonce s k = n)"
by (induct X, simp_all, blast)

lemma wdef_Nonce: "[| Nonce n:parts {apm s X}; R:p; msg' R = X; wdef p;
Nonce n ~:parts (apm s `(msg `(fst R))) |] ==>
(EX k. Nonce k:parts {X} & nonce s k = n)"
apply (erule Nonce_apm, unfold wdef_def)
apply (drule_tac x=R in spec, drule_tac x=k in spec, clarsimp simp: image_eq_UN)
apply (drule_tac x=x in bspec, simp)
apply (drule_tac Y="msg x" and s=s in apm_parts, simp)
by (blast dest: parts_parts)

primrec ap :: "subs => event => event" where
  "ap s (Says A B X) = Says (agent s A) (agent s B) (apm s X)"
| "ap s (Gets A X) = Gets (agent s A) (apm s X)"
| "ap s (Notes A X) = Notes (agent s A) (apm s X)"

abbreviation
  ap' :: "subs => rule => event" where
  "ap' s R == ap s (snd R)"

abbreviation
  apm' :: "subs => rule => msg" where
  "apm' s R == apm s (msg' R)"

abbreviation
  priK' :: "subs => agent => key" where
  "priK' s A == priK (agent s A)"

abbreviation
  pubK' :: "subs => agent => key" where
  "pubK' s A == pubK (agent s A)"

subsection{*nonces generated by a rule*}

definition newn :: "rule => nat set" where
"newn R == {n. Nonce n:parts {msg (snd R)} & Nonce n ~:parts (msg`(fst R))}"

lemma newn_parts: "n:newn R ==> Nonce (nonce s n):parts {apm' s R}"
by (auto simp: newn_def dest: apm_parts)

subsection{*traces generated by a protocol*}

definition ok :: "event list => rule => subs => bool" where
"ok evs R s == ((ALL x. x:fst R --> ap s x:set evs)
& (ALL n. n:newn R --> Nonce (nonce s n) ~:used evs))"

inductive_set
  tr :: "proto => event list set"
  for p :: proto
where

  Nil [intro]: "[]:tr p"

| Fake [intro]: "[| evsf:tr p; X:synth (analz (spies evsf)) |]
  ==> Says Spy B X # evsf:tr p"

| Proto [intro]: "[| evs:tr p; R:p; ok evs R s |] ==> ap' s R # evs:tr p"

subsection{*general properties*}

lemma one_step_tr [iff]: "one_step (tr p)"
apply (unfold one_step_def, clarify)
by (ind_cases "ev # evs:tr p" for ev evs, auto)

definition has_only_Says' :: "proto => bool" where
"has_only_Says' p == ALL R. R:p --> is_Says (snd R)"

lemma has_only_Says'D: "[| R:p; has_only_Says' p |]
==> (EX A B X. snd R = Says A B X)"
by (unfold has_only_Says'_def is_Says_def, blast)

lemma has_only_Says_tr [simp]: "has_only_Says' p ==> has_only_Says (tr p)"
apply (unfold has_only_Says_def)
apply (rule allI, rule allI, rule impI)
apply (erule tr.induct)
apply (auto simp: has_only_Says'_def ok_def)
by (drule_tac x=a in spec, auto simp: is_Says_def)

lemma has_only_Says'_in_trD: "[| has_only_Says' p; list @ ev # evs1 \<in> tr p |]
==> (EX A B X. ev = Says A B X)"
by (drule has_only_Says_tr, auto)

lemma ok_not_used: "[| Nonce n ~:used evs; ok evs R s;
ALL x. x:fst R --> is_Says x |] ==> Nonce n ~:parts (apm s `(msg `(fst R)))"
apply (unfold ok_def, clarsimp simp: image_eq_UN)
apply (drule_tac x=x in spec, drule_tac x=x in spec)
by (auto simp: is_Says_def dest: Says_imp_spies not_used_not_spied parts_parts)

lemma ok_is_Says: "[| evs' @ ev # evs:tr p; ok evs R s; has_only_Says' p;
R:p; x:fst R |] ==> is_Says x"
apply (unfold ok_def is_Says_def, clarify)
apply (drule_tac x=x in spec, simp)
apply (subgoal_tac "one_step (tr p)")
apply (drule trunc, simp, drule one_step_Cons, simp)
apply (drule has_only_SaysD, simp+)
by (clarify, case_tac x, auto)

subsection{*types*}

type_synonym keyfun = "rule => subs => nat => event list => key set"

type_synonym secfun = "rule => nat => subs => key set => msg"

subsection{*introduction of a fresh guarded nonce*}

definition fresh :: "proto => rule => subs => nat => key set => event list
=> bool" where
"fresh p R s n Ks evs == (EX evs1 evs2. evs = evs2 @ ap' s R # evs1
& Nonce n ~:used evs1 & R:p & ok evs1 R s & Nonce n:parts {apm' s R}
& apm' s R:guard n Ks)"

lemma freshD: "fresh p R s n Ks evs ==> (EX evs1 evs2.
evs = evs2 @ ap' s R # evs1 & Nonce n ~:used evs1 & R:p & ok evs1 R s
& Nonce n:parts {apm' s R} & apm' s R:guard n Ks)"
by (unfold fresh_def, blast)

lemma freshI [intro]: "[| Nonce n ~:used evs1; R:p; Nonce n:parts {apm' s R};
ok evs1 R s; apm' s R:guard n Ks |]
==> fresh p R s n Ks (list @ ap' s R # evs1)"
by (unfold fresh_def, blast)

lemma freshI': "[| Nonce n ~:used evs1; (l,r):p;
Nonce n:parts {apm s (msg r)}; ok evs1 (l,r) s; apm s (msg r):guard n Ks |]
==> fresh p (l,r) s n Ks (evs2 @ ap s r # evs1)"
by (drule freshI, simp+)

lemma fresh_used: "[| fresh p R' s' n Ks evs; has_only_Says' p |]
==> Nonce n:used evs"
apply (unfold fresh_def, clarify)
apply (drule has_only_Says'D)
by (auto intro: parts_used_app)

lemma fresh_newn: "[| evs' @ ap' s R # evs:tr p; wdef p; has_only_Says' p;
Nonce n ~:used evs; R:p; ok evs R s; Nonce n:parts {apm' s R} |]
==> EX k. k:newn R & nonce s k = n"
apply (drule wdef_Nonce, simp+)
apply (frule ok_not_used, simp+)
apply (clarify, erule ok_is_Says, simp+)
apply (clarify, rule_tac x=k in exI, simp add: newn_def image_eq_UN)
apply (clarify, drule_tac Y="msg x" and s=s in apm_parts)
apply (drule ok_not_used, simp+)
by (clarify, erule ok_is_Says, simp_all add: image_eq_UN)

lemma fresh_rule: "[| evs' @ ev # evs:tr p; wdef p; Nonce n ~:used evs;
Nonce n:parts {msg ev} |] ==> EX R s. R:p & ap' s R = ev"
apply (drule trunc, simp, ind_cases "ev # evs:tr p", simp)
by (drule_tac x=X in in_sub, drule parts_sub, simp, simp, blast+)

lemma fresh_ruleD: "[| fresh p R' s' n Ks evs; keys R' s' n evs <= Ks; wdef p;
has_only_Says' p; evs:tr p; ALL R k s. nonce s k = n --> Nonce n:used evs -->
R:p --> k:newn R --> Nonce n:parts {apm' s R} --> apm' s R:guard n Ks -->
apm' s R:parts (spies evs) --> keys R s n evs <= Ks --> P |] ==> P"
apply (frule fresh_used, simp)
apply (unfold fresh_def, clarify)
apply (drule_tac x=R' in spec)
apply (drule fresh_newn, simp+, clarify)
apply (drule_tac x=k in spec)
apply (drule_tac x=s' in spec)
apply (subgoal_tac "apm' s' R':parts (spies (evs2 @ ap' s' R' # evs1))")
apply (case_tac R', drule has_only_Says'D, simp, clarsimp)
apply (case_tac R', drule has_only_Says'D, simp, clarsimp)
apply (rule_tac Y="apm s' X" in parts_parts, blast)
by (rule parts.Inj, rule Says_imp_spies, simp, blast)

subsection{*safe keys*}

definition safe :: "key set => msg set => bool" where
"safe Ks G == ALL K. K:Ks --> Key K ~:analz G"

lemma safeD [dest]: "[| safe Ks G; K:Ks |] ==> Key K ~:analz G"
by (unfold safe_def, blast)

lemma safe_insert: "safe Ks (insert X G) ==> safe Ks G"
by (unfold safe_def, blast)

lemma Guard_safe: "[| Guard n Ks G; safe Ks G |] ==> Nonce n ~:analz G"
by (blast dest: Guard_invKey)

subsection{*guardedness preservation*}

definition preserv :: "proto => keyfun => nat => key set => bool" where
"preserv p keys n Ks == (ALL evs R' s' R s. evs:tr p -->
Guard n Ks (spies evs) --> safe Ks (spies evs) --> fresh p R' s' n Ks evs -->
keys R' s' n evs <= Ks --> R:p --> ok evs R s --> apm' s R:guard n Ks)"

lemma preservD: "[| preserv p keys n Ks; evs:tr p; Guard n Ks (spies evs);
safe Ks (spies evs); fresh p R' s' n Ks evs; R:p; ok evs R s;
keys R' s' n evs <= Ks |] ==> apm' s R:guard n Ks"
by (unfold preserv_def, blast)

lemma preservD': "[| preserv p keys n Ks; evs:tr p; Guard n Ks (spies evs);
safe Ks (spies evs); fresh p R' s' n Ks evs; (l,Says A B X):p;
ok evs (l,Says A B X) s; keys R' s' n evs <= Ks |] ==> apm s X:guard n Ks"
by (drule preservD, simp+)

subsection{*monotonic keyfun*}

definition monoton :: "proto => keyfun => bool" where
"monoton p keys == ALL R' s' n ev evs. ev # evs:tr p -->
keys R' s' n evs <= keys R' s' n (ev # evs)"

lemma monotonD [dest]: "[| keys R' s' n (ev # evs) <= Ks; monoton p keys;
ev # evs:tr p |] ==> keys R' s' n evs <= Ks"
by (unfold monoton_def, blast)

subsection{*guardedness theorem*}

lemma Guard_tr [rule_format]: "[| evs:tr p; has_only_Says' p;
preserv p keys n Ks; monoton p keys; Guard n Ks (initState Spy) |] ==>
safe Ks (spies evs) --> fresh p R' s' n Ks evs --> keys R' s' n evs <= Ks -->
Guard n Ks (spies evs)"
apply (erule tr.induct)
(* Nil *)
apply simp
(* Fake *)
apply (clarify, drule freshD, clarsimp)
apply (case_tac evs2)
(* evs2 = [] *)
apply (frule has_only_Says'D, simp)
apply (clarsimp, blast)
(* evs2 = aa # list *)
apply (clarsimp, rule conjI)
apply (blast dest: safe_insert)
(* X:guard n Ks *)
apply (rule in_synth_Guard, simp, rule Guard_analz)
apply (blast dest: safe_insert)
apply (drule safe_insert, simp add: safe_def)
(* Proto *)
apply (clarify, drule freshD, clarify)
apply (case_tac evs2)
(* evs2 = [] *)
apply (frule has_only_Says'D, simp)
apply (frule_tac R=R' in has_only_Says'D, simp)
apply (case_tac R', clarsimp, blast)
(* evs2 = ab # list *)
apply (frule has_only_Says'D, simp)
apply (clarsimp, rule conjI)
apply (drule Proto, simp+, blast dest: safe_insert)
(* apm s X:guard n Ks *)
apply (frule Proto, simp+)
apply (erule preservD', simp+)
apply (blast dest: safe_insert)
apply (blast dest: safe_insert)
by (blast, simp, simp, blast)

subsection{*useful properties for guardedness*}

lemma newn_neq_used: "[| Nonce n:used evs; ok evs R s; k:newn R |]
==> n ~= nonce s k"
by (auto simp: ok_def)

lemma ok_Guard: "[| ok evs R s; Guard n Ks (spies evs); x:fst R; is_Says x |]
==> apm s (msg x):parts (spies evs) & apm s (msg x):guard n Ks"
apply (unfold ok_def is_Says_def, clarify)
apply (drule_tac x="Says A B X" in spec, simp)
by (drule Says_imp_spies, auto intro: parts_parts)

lemma ok_parts_not_new: "[| Y:parts (spies evs); Nonce (nonce s n):parts {Y};
ok evs R s |] ==> n ~:newn R"
by (auto simp: ok_def dest: not_used_not_spied parts_parts)

subsection{*unicity*}

definition uniq :: "proto => secfun => bool" where
"uniq p secret == ALL evs R R' n n' Ks s s'. R:p --> R':p -->
n:newn R --> n':newn R' --> nonce s n = nonce s' n' -->
Nonce (nonce s n):parts {apm' s R} --> Nonce (nonce s n):parts {apm' s' R'} -->
apm' s R:guard (nonce s n) Ks --> apm' s' R':guard (nonce s n) Ks -->
evs:tr p --> Nonce (nonce s n) ~:analz (spies evs) -->
secret R n s Ks:parts (spies evs) --> secret R' n' s' Ks:parts (spies evs) -->
secret R n s Ks = secret R' n' s' Ks"

lemma uniqD: "[| uniq p secret; evs: tr p; R:p; R':p; n:newn R; n':newn R';
nonce s n = nonce s' n'; Nonce (nonce s n) ~:analz (spies evs);
Nonce (nonce s n):parts {apm' s R}; Nonce (nonce s n):parts {apm' s' R'};
secret R n s Ks:parts (spies evs); secret R' n' s' Ks:parts (spies evs);
apm' s R:guard (nonce s n) Ks; apm' s' R':guard (nonce s n) Ks |] ==>
secret R n s Ks = secret R' n' s' Ks"
by (unfold uniq_def, blast)

definition ord :: "proto => (rule => rule => bool) => bool" where
"ord p inff == ALL R R'. R:p --> R':p --> ~ inff R R' --> inff R' R"

lemma ordD: "[| ord p inff; ~ inff R R'; R:p; R':p |] ==> inff R' R"
by (unfold ord_def, blast)

definition uniq' :: "proto => (rule => rule => bool) => secfun => bool" where
"uniq' p inff secret == ALL evs R R' n n' Ks s s'. R:p --> R':p -->
inff R R' --> n:newn R --> n':newn R' --> nonce s n = nonce s' n' -->
Nonce (nonce s n):parts {apm' s R} --> Nonce (nonce s n):parts {apm' s' R'} -->
apm' s R:guard (nonce s n) Ks --> apm' s' R':guard (nonce s n) Ks -->
evs:tr p --> Nonce (nonce s n) ~:analz (spies evs) -->
secret R n s Ks:parts (spies evs) --> secret R' n' s' Ks:parts (spies evs) -->
secret R n s Ks = secret R' n' s' Ks"

lemma uniq'D: "[| uniq' p inff secret; evs: tr p; inff R R'; R:p; R':p; n:newn R;
n':newn R'; nonce s n = nonce s' n'; Nonce (nonce s n) ~:analz (spies evs);
Nonce (nonce s n):parts {apm' s R}; Nonce (nonce s n):parts {apm' s' R'};
secret R n s Ks:parts (spies evs); secret R' n' s' Ks:parts (spies evs);
apm' s R:guard (nonce s n) Ks; apm' s' R':guard (nonce s n) Ks |] ==>
secret R n s Ks = secret R' n' s' Ks"
by (unfold uniq'_def, blast)

lemma uniq'_imp_uniq: "[| uniq' p inff secret; ord p inff |] ==> uniq p secret"
apply (unfold uniq_def)
apply (rule allI)+
apply (case_tac "inff R R'")
apply (blast dest: uniq'D)
by (auto dest: ordD uniq'D intro: sym)

subsection{*Needham-Schroeder-Lowe*}

definition a :: agent where "a == Friend 0"
definition b :: agent where "b == Friend 1"
definition a' :: agent where "a' == Friend 2"
definition b' :: agent where "b' == Friend 3"
definition Na :: nat where "Na == 0"
definition Nb :: nat where "Nb == 1"

abbreviation
  ns1 :: rule where
  "ns1 == ({}, Says a b (Crypt (pubK b) {|Nonce Na, Agent a|}))"

abbreviation
  ns2 :: rule where
  "ns2 == ({Says a' b (Crypt (pubK b) {|Nonce Na, Agent a|})},
    Says b a (Crypt (pubK a) {|Nonce Na, Nonce Nb, Agent b|}))"

abbreviation
  ns3 :: rule where
  "ns3 == ({Says a b (Crypt (pubK b) {|Nonce Na, Agent a|}),
    Says b' a (Crypt (pubK a) {|Nonce Na, Nonce Nb, Agent b|})},
    Says a b (Crypt (pubK b) (Nonce Nb)))"

inductive_set ns :: proto where
  [iff]: "ns1:ns"
| [iff]: "ns2:ns"
| [iff]: "ns3:ns"

abbreviation (input)
  ns3a :: event where
  "ns3a == Says a b (Crypt (pubK b) {|Nonce Na, Agent a|})"

abbreviation (input)
  ns3b :: event where
  "ns3b == Says b' a (Crypt (pubK a) {|Nonce Na, Nonce Nb, Agent b|})"

definition keys :: "keyfun" where
"keys R' s' n evs == {priK' s' a, priK' s' b}"

lemma "monoton ns keys"
by (simp add: keys_def monoton_def)

definition secret :: "secfun" where
"secret R n s Ks ==
(if R=ns1 then apm s (Crypt (pubK b) {|Nonce Na, Agent a|})
else if R=ns2 then apm s (Crypt (pubK a) {|Nonce Na, Nonce Nb, Agent b|})
else Number 0)"

definition inf :: "rule => rule => bool" where
"inf R R' == (R=ns1 | (R=ns2 & R'~=ns1) | (R=ns3 & R'=ns3))"

lemma inf_is_ord [iff]: "ord ns inf"
apply (unfold ord_def inf_def)
apply (rule allI)+
apply (rule impI)
apply (simp add: split_paired_all)
by (rule impI, erule ns.cases, simp_all)+

subsection{*general properties*}

lemma ns_has_only_Says' [iff]: "has_only_Says' ns"
apply (unfold has_only_Says'_def)
apply (rule allI, rule impI)
apply (simp add: split_paired_all)
by (erule ns.cases, auto)

lemma newn_ns1 [iff]: "newn ns1 = {Na}"
by (simp add: newn_def)

lemma newn_ns2 [iff]: "newn ns2 = {Nb}"
by (auto simp: newn_def Na_def Nb_def)

lemma newn_ns3 [iff]: "newn ns3 = {}"
by (auto simp: newn_def)

lemma ns_wdef [iff]: "wdef ns"
by (auto simp: wdef_def elim: ns.cases)

subsection{*guardedness for NSL*}

lemma "uniq ns secret ==> preserv ns keys n Ks"
apply (unfold preserv_def)
apply (rule allI)+
apply (rule impI, rule impI, rule impI, rule impI, rule impI)
apply (erule fresh_ruleD, simp, simp, simp, simp)
apply (rule allI)+
apply (rule impI, rule impI, rule impI)
apply (simp add: split_paired_all)
apply (erule ns.cases)
(* fresh with NS1 *)
apply (rule impI, rule impI, rule impI, rule impI, rule impI, rule impI)
apply (erule ns.cases)
(* NS1 *)
apply clarsimp
apply (frule newn_neq_used, simp, simp)
apply (rule No_Nonce, simp)
(* NS2 *)
apply clarsimp
apply (frule newn_neq_used, simp, simp)
apply (case_tac "nonce sa Na = nonce s Na")
apply (frule Guard_safe, simp)
apply (frule Crypt_guard_invKey, simp)
apply (frule ok_Guard, simp, simp, simp, clarsimp)
apply (frule_tac K="pubK' s b" in Crypt_guard_invKey, simp)
apply (frule_tac R=ns1 and R'=ns1 and Ks=Ks and s=sa and s'=s in uniqD, simp+)
apply (simp add: secret_def, simp add: secret_def, force, force)
apply (simp add: secret_def keys_def, blast)
apply (rule No_Nonce, simp)
(* NS3 *)
apply clarsimp
apply (case_tac "nonce sa Na = nonce s Nb")
apply (frule Guard_safe, simp)
apply (frule Crypt_guard_invKey, simp)
apply (frule_tac x=ns3b in ok_Guard, simp, simp, simp, clarsimp)
apply (frule_tac K="pubK' s a" in Crypt_guard_invKey, simp)
apply (frule_tac R=ns1 and R'=ns2 and Ks=Ks and s=sa and s'=s in uniqD, simp+)
apply (simp add: secret_def, simp add: secret_def, force, force)
apply (simp add: secret_def, rule No_Nonce, simp)
(* fresh with NS2 *)
apply (rule impI, rule impI, rule impI, rule impI, rule impI, rule impI)
apply (erule ns.cases)
(* NS1 *)
apply clarsimp
apply (frule newn_neq_used, simp, simp)
apply (rule No_Nonce, simp)
(* NS2 *)
apply clarsimp
apply (frule newn_neq_used, simp, simp)
apply (case_tac "nonce sa Nb = nonce s Na")
apply (frule Guard_safe, simp)
apply (frule Crypt_guard_invKey, simp)
apply (frule ok_Guard, simp, simp, simp, clarsimp)
apply (frule_tac K="pubK' s b" in Crypt_guard_invKey, simp)
apply (frule_tac R=ns2 and R'=ns1 and Ks=Ks and s=sa and s'=s in uniqD, simp+)
apply (simp add: secret_def, simp add: secret_def, force, force)
apply (simp add: secret_def, rule No_Nonce, simp)
(* NS3 *)
apply clarsimp
apply (case_tac "nonce sa Nb = nonce s Nb")
apply (frule Guard_safe, simp)
apply (frule Crypt_guard_invKey, simp)
apply (frule_tac x=ns3b in ok_Guard, simp, simp, simp, clarsimp)
apply (frule_tac K="pubK' s a" in Crypt_guard_invKey, simp)
apply (frule_tac R=ns2 and R'=ns2 and Ks=Ks and s=sa and s'=s in uniqD, simp+)
apply (simp add: secret_def, simp add: secret_def, force, force)
apply (simp add: secret_def keys_def, blast)
apply (rule No_Nonce, simp)
(* fresh with NS3 *)
by simp

subsection{*unicity for NSL*}

lemma "uniq' ns inf secret"
apply (unfold uniq'_def)
apply (rule allI)+
apply (simp add: split_paired_all)
apply (rule impI, erule ns.cases)
(* R = ns1 *)
apply (rule impI, erule ns.cases)
(* R' = ns1 *)
apply (rule impI, rule impI, rule impI, rule impI)
apply (rule impI, rule impI, rule impI, rule impI)
apply (rule impI, erule tr.induct)
(* Nil *)
apply (simp add: secret_def)
(* Fake *)
apply (clarify, simp add: secret_def)
apply (drule notin_analz_insert)
apply (drule Crypt_insert_synth, simp, simp, simp)
apply (drule Crypt_insert_synth, simp, simp, simp, simp)
(* Proto *)
apply (erule_tac P="ok evsa R sa" in rev_mp)
apply (simp add: split_paired_all)
apply (erule ns.cases)
(* ns1 *)
apply (clarify, simp add: secret_def)
apply (erule disjE, erule disjE, clarsimp)
apply (drule ok_parts_not_new, simp, simp, simp)
apply (clarify, drule ok_parts_not_new, simp, simp, simp)
(* ns2 *)
apply (simp add: secret_def)
(* ns3 *)
apply (simp add: secret_def)
(* R' = ns2 *)
apply (rule impI, rule impI, rule impI, rule impI)
apply (rule impI, rule impI, rule impI, rule impI)
apply (rule impI, erule tr.induct)
(* Nil *)
apply (simp add: secret_def)
(* Fake *)
apply (clarify, simp add: secret_def)
apply (drule notin_analz_insert)
apply (drule Crypt_insert_synth, simp, simp, simp)
apply (drule_tac n="nonce s' Nb" in Crypt_insert_synth, simp, simp, simp, simp)
(* Proto *)
apply (erule_tac P="ok evsa R sa" in rev_mp)
apply (simp add: split_paired_all)
apply (erule ns.cases)
(* ns1 *)
apply (clarify, simp add: secret_def)
apply (drule_tac s=sa and n=Na in ok_parts_not_new, simp, simp, simp)
(* ns2 *)
apply (clarify, simp add: secret_def)
apply (drule_tac s=sa and n=Nb in ok_parts_not_new, simp, simp, simp)
(* ns3 *)
apply (simp add: secret_def)
(* R' = ns3 *)
apply simp
(* R = ns2 *)
apply (rule impI, erule ns.cases)
(* R' = ns1 *)
apply (simp only: inf_def, blast)
(* R' = ns2 *)
apply (rule impI, rule impI, rule impI, rule impI)
apply (rule impI, rule impI, rule impI, rule impI)
apply (rule impI, erule tr.induct)
(* Nil *)
apply (simp add: secret_def)
(* Fake *)
apply (clarify, simp add: secret_def)
apply (drule notin_analz_insert)
apply (drule_tac n="nonce s' Nb" in Crypt_insert_synth, simp, simp, simp)
apply (drule_tac n="nonce s' Nb" in Crypt_insert_synth, simp, simp, simp, simp)
(* Proto *)
apply (erule_tac P="ok evsa R sa" in rev_mp)
apply (simp add: split_paired_all)
apply (erule ns.cases)
(* ns1 *)
apply (simp add: secret_def)
(* ns2 *)
apply (clarify, simp add: secret_def)
apply (erule disjE, erule disjE, clarsimp, clarsimp)
apply (drule_tac s=sa and n=Nb in ok_parts_not_new, simp, simp, simp)
apply (erule disjE, clarsimp)
apply (drule_tac s=sa and n=Nb in ok_parts_not_new, simp, simp, simp)
by (simp_all add: secret_def)

end


theory StackCorrectness
imports StackConversion "../01Expression/02SmallStep/SmallStepEvaluate" "../Utilities/Iterate"
begin

lemma complete': "e \<leadsto> e' \<Longrightarrow> unstack_state rs \<Sigma> = e \<Longrightarrow> \<exists>\<Sigma>'. \<Sigma> \<leadsto>\<^sub>s \<Sigma>' \<and> unstack_state rs \<Sigma>' = e'"
  proof (induction e e' rule: evaluate.induct)
  case (ev_app1 e\<^sub>1 e\<^sub>1' e\<^sub>2)
    thus ?case by simp
  next case ev_app2
    thus ?case by simp
  next case ev_app_let
    thus ?case by simp
  next case ev_let1
    thus ?case by simp
  next case ev_let2
    thus ?case by simp
  next case ev_let3
    thus ?case by simp
  next case ev_proj1
    thus ?case by simp
  next case ev_proj2
    thus ?case by simp
  next case ev_proj_let
    thus ?case by simp
  next case ev_case1
    thus ?case by simp
  next case ev_case2
    thus ?case by simp
  next case ev_case_let
    thus ?case by simp
  next case ev_unfold1
    thus ?case by simp
  next case ev_unfold2
    thus ?case by simp
  next case ev_unfold_let
    thus ?case by simp
  next case ev_tyapp1
    thus ?case by simp
  next case ev_tyapp2
    thus ?case by simp
  next case ev_tyapp_let
    thus ?case by simp
  next case ev_tylet
    thus ?case by simp
  qed

lemma complete: "iter (op \<leadsto>) e e' \<Longrightarrow> unstack_state rs \<Sigma> = e \<Longrightarrow>
    \<exists>\<Sigma>'. iter (op \<leadsto>\<^sub>s) \<Sigma> \<Sigma>' \<and> unstack_state rs \<Sigma>' = e'"
  proof (induction e e' arbitrary: \<Sigma> rule: iter.induct)
  case iter_refl
    thus ?case by (metis iter.iter_refl)
  next case (iter_step e e' e'')
    then obtain \<Sigma>' where "\<Sigma> \<leadsto>\<^sub>s \<Sigma>' \<and> unstack_state rs \<Sigma>' = e'" by (metis complete')
    moreover with iter_step obtain \<Sigma>'' where "iter (op \<leadsto>\<^sub>s) \<Sigma>' \<Sigma>'' \<and> unstack_state rs \<Sigma>'' = e''"
      by fastforce
    ultimately have "iter (op \<leadsto>\<^sub>s) \<Sigma> \<Sigma>'' \<and> unstack_state rs \<Sigma>'' = e''" by fastforce
    thus ?case by fastforce
  qed

lemma sound': "\<Sigma> \<leadsto>\<^sub>s \<Sigma>' \<Longrightarrow> unstack_state rs \<Sigma> = e \<Longrightarrow>
    \<exists>rs' e'. unstack_state rs' \<Sigma>' = e' \<and> (e \<leadsto> e' \<or> e = e')"
  proof (induction \<Sigma> \<Sigma>' arbitrary: e rule: EvaluateStack.evaluate.induct)
  case (ev_var x s h)
    hence "unstack rs s (Var x) h = e" by simp

    have "e \<leadsto> unstack rs' (SRef x # s) (lookup\<^sub>h h x) h \<or>
      e = unstack rs' (SRef x # s) (lookup\<^sub>h h x) h" by simp
    thus ?case by fastforce
  next case (ev_abs t e\<^sub>1 s h)
    hence "unstack rs s (Abs t e\<^sub>1) h = e" by simp
    thus ?case by fastforce
  next case (ev_app e\<^sub>1 e\<^sub>2 s h)
    hence "unstack ([] # rs) (SApp e\<^sub>2 # s) e\<^sub>1 h = e" by simp
    thus ?case by fastforce
  next case (ev_let e\<^sub>1 e\<^sub>2 s h)
    hence "unstack rs s (Let e\<^sub>1 e\<^sub>2) h = e" by simp

    have "e \<leadsto> unstack rs' s (subst\<^sub>x\<^sub>e 0 (length\<^sub>h h) e\<^sub>2) (extend\<^sub>h h e\<^sub>1) \<or>
      unstack rs' s (subst\<^sub>x\<^sub>e 0 (length\<^sub>h h) e\<^sub>2) (extend\<^sub>h h e\<^sub>1) = e" by simp
    thus ?case by fastforce
  next case (ev_rec xs s h)
    hence "unstack rs s (Rec xs) h = e" by simp
    thus ?case by fastforce
  next case (ev_proj e\<^sub>1 l s h)
    hence "unstack ([] # rs) (SProj l # s) e\<^sub>1 h = e" by simp
    thus ?case by fastforce
  next case (ev_inj l ts x s h)
    hence "unstack rs s (Inj l ts x) h = e" by simp
    thus ?case by fastforce
  next case (ev_case e\<^sub>1 t cs s h)
    hence "unstack ([] # rs) (SCase t cs # s) e\<^sub>1 h = e" by simp
    thus ?case by fastforce
  next case (ev_fold t x s h)
    hence "unstack rs s (Fold t x) h = e" by simp
    thus ?case by fastforce
  next case (ev_unfold t e\<^sub>1 s h)
    hence "unstack ([] # rs) (SUnfold t # s) e\<^sub>1 h = e" by simp
    thus ?case by fastforce
  next case (ev_tyabs k e\<^sub>1 s h)
    hence "unstack rs s (TyAbs k e\<^sub>1) h = e" by simp
    thus ?case by fastforce
  next case (ev_tyapp e\<^sub>1 t s h)
    hence "unstack ([] # rs) (STyApp t # s) e\<^sub>1 h = e" by simp
    thus ?case by fastforce
  next case (ev_tylet t e\<^sub>1 s h)
    hence "unstack rs s (TyLet t e\<^sub>1) h = e" by simp

    have "e \<leadsto> unstack rs' s (subst\<^sub>t\<^sub>e 0 t e\<^sub>1) h \<or> e = unstack rs' s (subst\<^sub>t\<^sub>e 0 t e\<^sub>1) h" by simp
    thus ?case by fastforce
  next case ret_ref
    thus ?case by simp
  next case ret_app
    thus ?case by simp
  next case ret_proj
    thus ?case by simp
  next case ret_case
    thus ?case by simp
  next case ret_unfold
    thus ?case by simp
  next case ret_tyapp
    thus ?case by simp
  qed

lemma sound: "iter (op \<leadsto>\<^sub>s) \<Sigma> \<Sigma>' \<Longrightarrow> unstack_state rs \<Sigma> = e \<Longrightarrow>
    \<exists>rs'. iter (op \<leadsto>) e (unstack_state rs' \<Sigma>')"
  proof (induction \<Sigma> \<Sigma>' arbitrary: e rs rule: iter.induct)
  case (iter_refl \<Sigma>)
    moreover have "iter (op \<leadsto>) (unstack_state rs \<Sigma>) (unstack_state rs \<Sigma>)" by simp
    ultimately show ?case by fastforce
  next case (iter_step \<Sigma> \<Sigma>' \<Sigma>'')
    then obtain rs' e' where "unstack_state rs' \<Sigma>' = e' \<and> (e \<leadsto> e' \<or> e = e')" by (metis sound')
    moreover with iter_step obtain rs'' where "iter (op \<leadsto>) e' (unstack_state rs'' \<Sigma>'')" by fastforce
    ultimately have "iter (op \<leadsto>) e (unstack_state rs'' \<Sigma>'')" by fastforce
    thus ?case by fastforce
  qed

end