theory Prelims
  imports "../TLA-Utils"
begin

typedecl Client
typedecl Resource

definition modifyAt :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)"
  where "modifyAt f a0 mb a \<equiv> if a = a0 then mb (f a) else f a"

lemma modifyAt_eq_simp[simp]: "modifyAt f a mb a = mb (f a)" by (simp add: modifyAt_def)
lemma modifyAt_ne_simp[simp]: "a \<noteq> a0 \<Longrightarrow> modifyAt f a0 mb a = f a" by (simp add: modifyAt_def)

definition updated :: "('a \<Rightarrow> 'b) stfun \<Rightarrow> 'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> action"
  where "updated f a mb st \<equiv> f (snd st) = modifyAt (f (fst st)) a mb"

lemma "\<turnstile> updated f a mb \<longrightarrow> id<f$,#a> = (\<lambda>f a. mb (f a))<$f,#a>" by (auto simp add: updated_def modifyAt_def)
lemma "a \<noteq> a' \<Longrightarrow> \<turnstile> updated f a mb \<longrightarrow> id<f$,#a'> = id<$f,#a'>" by (auto simp add: updated_def modifyAt_def)

definition add :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" where "add A B \<equiv> B \<union> A"
definition del :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" where "del A B \<equiv> B - A"

lemma add_simp[simp]: "(r \<in> add A B) = (r \<in> A \<or> r \<in> B)" by (auto simp add: add_def)
lemma del_simp[simp]: "(r \<in> del A B) = (r \<notin> A \<and> r \<in> B)" by (auto simp add: del_def)

lemma wf_less_finite:
  shows "wf {(S1, S2). finite S2 \<and> S1 \<subset> S2}"
  by (rule iffD1 [OF cong [OF refl, where f = wf and x = finite_psubset]],
      simp_all, auto simp add: finite_psubset_def)

end


(*******************************************************************************

  Project: Refining Authenticated Key Agreement with Strong Adversaries

  Module:  Message_derivation.thy (Isabelle/HOL 2016-1)
  ID:      $Id: Message_derivation.thy 132885 2016-12-23 18:41:32Z csprenge $
  Author:  Joseph Lallemand, INRIA Nancy <joseph.lallemand@loria.fr>
           Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>

  A theory of message derivations (analz, synth, parts).
  Based on Larry Paulson's theory HOL/Auth/Message.thy, but extended with
  - composed keys
  - including ephemeral asymmetric keys
  - Diffie-Hellman exponentiation and associated equational theory

  Copyright (c) 2015-2016 Joseph Lallemand and Christoph Sprenger
  Licence: LGPL

*******************************************************************************)

section \<open>Message theory\<close>

theory Message_derivation
imports Messages
begin

text \<open>This theory is adapted from Larry Paulson's original Message theory.\<close>

(****************************************************************************************)
subsection \<open>Message composition\<close>
(****************************************************************************************)

text \<open>Dolev-Yao message synthesis.\<close>

inductive_set
  synth :: "msg set \<Rightarrow> msg set"
  for H :: "msg set"
  where
    Ax [intro]: "X \<in> H \<Longrightarrow> X \<in> synth H"
  | Agent [simp, intro]: "Agent A \<in> synth H"
  | Number [simp, intro]: "Number n \<in> synth H"
  | NonceA [simp, intro]: "NonceA n \<in> synth H"
  | EpubKA [simp, intro]: "epubKA n \<in> synth H"
  | EpriKA [simp, intro]: "epriKA n \<in> synth H"
  | Hash [intro]: "X \<in> synth H \<Longrightarrow> Hash X \<in> synth H"
  | Pair [intro]: "X \<in> synth H \<Longrightarrow> Y \<in> synth H \<Longrightarrow> (Pair X Y) \<in> synth H"
  | Enc [intro]: "X \<in> synth H \<Longrightarrow> Y \<in> synth H \<Longrightarrow> (Enc X Y) \<in> synth H"
  | Aenc [intro]: "X \<in> synth H \<Longrightarrow> Y \<in> synth H \<Longrightarrow> (Aenc X Y) \<in> synth H"
  | Sign [intro]: "X \<in> synth H \<Longrightarrow> Y \<in> synth H \<Longrightarrow> Sign X Y \<in> synth H"
  | Exp [intro]: "X \<in> synth H \<Longrightarrow> Y \<in> synth H \<Longrightarrow> (Exp X Y) \<in> synth H"

text \<open>Lemmas about Dolev-Yao message synthesis.\<close>

lemma synth_mono [mono_set]: "G \<subseteq> H \<Longrightarrow> synth G \<subseteq> synth H"
  by (auto, erule synth.induct, auto)

lemmas synth_monotone = synth_mono [THEN [2] rev_subsetD]

\<comment> \<open>\<open>[elim!]\<close> slows down certain proofs, e.g., \<open>\<lbrakk> synth H \<inter> B \<subseteq> {} \<rbrakk> \<Longrightarrow> P\<close>\<close>
inductive_cases NonceF_synth: "NonceF n \<in> synth H"
inductive_cases LtK_synth: "LtK K \<in> synth H"
inductive_cases EpubKF_synth: "epubKF K \<in> synth H"
inductive_cases EpriKF_synth: "epriKF K \<in> synth H"
inductive_cases Hash_synth: "Hash X \<in> synth H"
inductive_cases Pair_synth: "Pair X Y \<in> synth H"
inductive_cases Enc_synth: "Enc X K \<in> synth H"
inductive_cases Aenc_synth: "Aenc X K \<in> synth H"
inductive_cases Sign_synth: "Sign X K \<in> synth H"
inductive_cases Tag_synth: "Tag t \<in> synth H"

lemma EpriK_synth [elim]: "epriK K \<in> synth H \<Longrightarrow>
       epriK K \<in> H \<or> (\<exists> N. epriK K = epriKA N)"
by (cases K, auto elim: EpriKF_synth)

lemma EpubK_synth [elim]: "epubK K \<in> synth H \<Longrightarrow>
       epubK K \<in> H \<or> (\<exists> N. epubK K = epubKA N)"
by (cases K, auto elim: EpubKF_synth)

lemmas synth_inversion [elim] =
  NonceF_synth LtK_synth EpubKF_synth EpriKF_synth Hash_synth Pair_synth
  Enc_synth Aenc_synth Sign_synth Tag_synth

lemma synth_increasing: "H \<subseteq> synth H"
by blast

lemma synth_Int1: "x \<in> synth (A \<inter> B) \<Longrightarrow> x \<in> synth A "
  by (erule synth.induct) (auto)

lemma synth_Int2: "x \<in> synth (A \<inter> B) \<Longrightarrow> x \<in> synth B"
  by (erule synth.induct) (auto)

lemma synth_Int: "x \<in> synth (A \<inter> B) \<Longrightarrow> x \<in> synth A \<inter> synth B"
  by (blast intro: synth_Int1 synth_Int2)

lemma synth_Un: "synth G \<union> synth H \<subseteq> synth (G \<union> H)"
by (intro Un_least synth_mono Un_upper1 Un_upper2)

lemma synth_insert: "insert X (synth H) \<subseteq> synth (insert X H)"
by (blast intro: synth_mono [THEN [2] rev_subsetD])

lemma synth_synthD [dest!]: "X \<in> synth (synth H) \<Longrightarrow> X \<in> synth H"
by (erule synth.induct, blast+)

lemma synth_idem [simp]: "synth (synth H) = synth H"
by blast

lemma synth_subset_iff: "synth G \<subseteq> synth H \<longleftrightarrow> G \<subseteq> synth H"
by (blast dest: synth_mono)

lemma synth_trans: "\<lbrakk> X \<in> synth G; G \<subseteq> synth H \<rbrakk> \<Longrightarrow> X \<in> synth H"
by (drule synth_mono, blast)

lemma synth_cut: "\<lbrakk> Y \<in> synth (insert X H); X \<in> synth H \<rbrakk> \<Longrightarrow> Y \<in> synth H"
by (erule synth_trans, blast)

lemma Nonce_synth_eq [simp]: "(NonceF N \<in> synth H) = (NonceF N \<in> H)"
by blast

lemma LtK_synth_eq [simp]: "(LtK K \<in> synth H) = (LtK K \<in> H)"
by blast

lemma EpubKF_synth_eq [simp]: "(epubKF K \<in> synth H) = (epubKF K \<in> H)"
by blast

lemma EpriKF_synth_eq [simp]: "(epriKF K \<in> synth H) = (epriKF K \<in> H)"
by blast

lemma Enc_synth_eq1 [simp]:
     "K \<notin> synth H \<Longrightarrow> (Enc X K \<in> synth H) = (Enc X K \<in> H)"
by blast

lemma Enc_synth_eq2 [simp]:
     "X \<notin> synth H \<Longrightarrow> (Enc X K \<in> synth H) = (Enc X K \<in> H)"
by blast

lemma Aenc_synth_eq1 [simp]:
     "K \<notin> synth H \<Longrightarrow> (Aenc X K \<in> synth H) = (Aenc X K \<in> H)"
by blast

lemma Aenc_synth_eq2 [simp]:
     "X \<notin> synth H \<Longrightarrow> (Aenc X K \<in> synth H) = (Aenc X K \<in> H)"
by blast

lemma Sign_synth_eq1 [simp]:
     "K \<notin> synth H \<Longrightarrow> (Sign X K \<in> synth H) = (Sign X K \<in> H)"
by blast

lemma Sign_synth_eq2 [simp]:
     "X \<notin> synth H \<Longrightarrow> (Sign X K \<in> synth H) = (Sign X K \<in> H)"
by blast

(****************************************************************************************)
subsection \<open>Message decomposition\<close>
(****************************************************************************************)

text \<open>Dolev-Yao message decomposition using known keys.\<close>

inductive_set
  analz :: "msg set \<Rightarrow> msg set"
  for H :: "msg set"
  where
    Ax [intro]: "X \<in> H \<Longrightarrow> X \<in> analz H"
  | Fst: "Pair X Y \<in> analz H \<Longrightarrow> X \<in> analz H"
  | Snd: "Pair X Y \<in> analz H \<Longrightarrow> Y \<in> analz H"
  | Dec [dest]:
      "\<lbrakk> Enc X Y \<in> analz H; Y \<in> synth (analz H) \<rbrakk> \<Longrightarrow> X \<in> analz H"
  | Adec_lt [dest]:
      "\<lbrakk> Aenc X (LtK (publK Y)) \<in> analz H; priK Y \<in> analz H \<rbrakk> \<Longrightarrow> X \<in> analz H"
  | Adec_eph [dest]:
      "\<lbrakk> Aenc X (EphK (epublK Y)) \<in> analz H; epriK Y \<in> synth (analz H) \<rbrakk> \<Longrightarrow> X \<in> analz H"
  | Sign_getmsg [dest]:
      "Sign X (priK Y) \<in> analz H \<Longrightarrow> pubK Y \<in> analz H \<Longrightarrow> X \<in> analz H"

text \<open>Lemmas about Dolev-Yao message decomposition.\<close>

lemma analz_mono: "G \<subseteq> H \<Longrightarrow> analz(G) \<subseteq> analz(H)"
by (safe, erule analz.induct) (auto dest: Fst Snd synth_Int2)

lemmas analz_monotone = analz_mono [THEN [2] rev_subsetD]

lemma Pair_analz [elim!]:
  "\<lbrakk> Pair X Y \<in> analz H; \<lbrakk> X \<in> analz H; Y \<in> analz H \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
by (blast dest: analz.Fst analz.Snd)

lemma analz_empty [simp]: "analz {} = {}"
by (safe, erule analz.induct) (blast+)

lemma analz_increasing: "H \<subseteq> analz(H)"
by auto

lemma analz_analzD [dest!]: "X \<in> analz (analz H) \<Longrightarrow> X \<in> analz H"
by (induction X rule: analz.induct) (auto dest: synth_monotone)

lemma analz_idem [simp]: "analz (analz H) = analz H"
by auto

lemma analz_Un: "analz G \<union> analz H \<subseteq> analz (G \<union> H)"
by (intro Un_least analz_mono Un_upper1 Un_upper2)

lemma analz_insertI: "X \<in> analz H \<Longrightarrow> X \<in> analz (insert Y H)"
by (blast intro: analz_monotone)

lemma analz_insert: "insert X (analz H) \<subseteq> analz (insert X H)"
by (blast intro: analz_monotone)

lemmas analz_insert_eq_I = equalityI [OF subsetI analz_insert]

lemma analz_subset_iff [simp]: "analz G \<subseteq> analz H \<longleftrightarrow> G \<subseteq> analz H"
by (blast dest: analz_mono)

lemma analz_trans: "X \<in> analz G \<Longrightarrow>  G \<subseteq> analz H \<Longrightarrow> X \<in> analz H"
by (drule analz_mono) blast

lemma analz_cut: "Y \<in> analz (insert X H) \<Longrightarrow>  X \<in> analz H \<Longrightarrow> Y \<in> analz H"
by (erule analz_trans) blast

lemma analz_insert_eq: "X \<in> analz H \<Longrightarrow> analz (insert X H) = analz H"
by (blast intro: analz_cut analz_insertI)

lemma analz_subset_cong:
  "analz G \<subseteq> analz G' \<Longrightarrow>
   analz H \<subseteq> analz H' \<Longrightarrow>
   analz (G \<union> H) \<subseteq> analz (G' \<union> H')"
apply simp
apply (iprover intro: conjI subset_trans analz_mono Un_upper1 Un_upper2)
done

lemma analz_cong:
  "analz G = analz G' \<Longrightarrow>
   analz H = analz H' \<Longrightarrow>
   analz (G \<union> H) = analz (G' \<union> H')"
by (intro equalityI analz_subset_cong, simp_all)

lemma analz_insert_cong:
  "analz H = analz H' \<Longrightarrow>
   analz (insert X H) = analz (insert X H')"
by (force simp only: insert_def intro!: analz_cong)

lemma analz_trivial:
  "\<forall>X Y. Pair X Y \<notin> H \<Longrightarrow>
   \<forall>X Y. Enc X Y \<notin> H \<Longrightarrow>
   \<forall>X Y. Aenc X Y \<notin> H \<Longrightarrow>
   \<forall>X Y. Sign X Y \<notin> H \<Longrightarrow>
   analz H = H"
apply safe
apply (erule analz.induct, blast+)
done

lemma analz_analz_Un [simp]: "analz (analz G \<union> H) = analz (G \<union> H)"
apply (intro equalityI analz_subset_cong)+
apply simp_all
done

lemma analz_Un_analz [simp]: "analz (G \<union> analz H) = analz (G \<union> H)"
by (subst Un_commute, auto)+

text \<open>Lemmas about analz and insert.\<close>

lemma analz_insert_Agent [simp]:
  "analz (insert (Agent A) H) = insert (Agent A) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct)
thm analz.induct
apply fastforce
apply fastforce
apply fastforce
defer 1
apply fastforce
defer 1
apply fastforce

apply (rename_tac x X Y)
apply (subgoal_tac "Y \<in> synth (analz H)", auto)
apply (thin_tac "Enc X Y \<in> Z" for Z)+
apply (drule synth_Int2, auto)
apply (erule synth.induct, auto)

apply (rename_tac X Y)
apply (subgoal_tac "epriK Y \<in> synth (analz H)", auto)
apply (thin_tac "Aenc X (epubK Y) \<in> Z" for Z)+
apply (erule synth.induct, auto)
done

(****************************************************************************************)
subsection \<open>Lemmas about combined composition/decomposition\<close>
(****************************************************************************************)

lemma synth_analz_incr: "H \<subseteq> synth (analz H)"
by auto

lemmas synth_analz_increasing = synth_analz_incr [THEN [2] rev_subsetD]

lemma synth_analz_mono: "G \<subseteq> H \<Longrightarrow> synth (analz G) \<subseteq> synth (analz H)"
by (blast intro!: analz_mono synth_mono)

lemmas synth_analz_monotone = synth_analz_mono [THEN [2] rev_subsetD]

lemma lem1:
  "Y \<in> synth (analz (synth G \<union> H) \<inter> (analz (G \<union> H) \<union> synth G))
\<Longrightarrow> Y \<in> synth (analz (G \<union> H))"
apply (rule subsetD, auto simp add: synth_subset_iff intro: analz_increasing synth_monotone)
done

lemma analz_synth_Un: "analz (synth G \<union> H) = analz (G \<union> H) \<union> synth G"
proof (intro equalityI subsetI)
  fix x
  assume "x \<in> analz (synth G \<union> H)"
  thus "x \<in> analz (G \<union> H) \<union> synth G"
  by (induction x rule: analz.induct)
     (auto simp add: lem2 intro: analz_monotone Fst Snd Dec Adec_eph Adec_lt Sign_getmsg
           dest: lem1)
next
  fix x
  assume "x \<in> analz (G \<union> H) \<union> synth G"
  thus "x \<in> analz (synth G \<union> H)"
    by (blast intro: analz_monotone)
qed

lemma analz_synth: "analz (synth H) = analz H \<union> synth H"
by (rule analz_synth_Un [where H="{}", simplified])

lemma analz_synth_Un2 [simp]: "analz (G \<union> synth H) = analz (G \<union> H) \<union> synth H"
by (subst Un_commute, auto simp add: analz_synth_Un)+

lemma synth_analz_synth [simp]: "synth (analz (synth H)) = synth (analz H)"
by (auto del:subsetI) (auto simp add: synth_subset_iff analz_synth)

lemma analz_synth_analz [simp]: "analz (synth (analz H)) = synth (analz H)"
by (auto simp add: analz_synth)

lemma synth_analz_idem [simp]: "synth (analz (synth (analz H))) = synth (analz H)"
by (simp only: analz_synth_analz) simp

lemma insert_subset_synth_analz [simp]:
  "X \<in> synth (analz H) \<Longrightarrow> insert X H \<subseteq> synth (analz H)"
by auto

lemma synth_analz_insert [simp]:
  assumes "X \<in> synth (analz H)"
  shows "synth (analz (insert X H)) = synth (analz H)"
using assms
proof (intro equalityI subsetI)
  fix Z
  assume "Z \<in> synth (analz (insert X H))"
  hence "Z \<in> synth (analz (synth (analz H)))" using assms
    by - (erule synth_analz_monotone, rule insert_subset_synth_analz)
  thus "Z \<in> synth (analz H)" using assms by simp
qed (auto intro: synth_analz_monotone)

(****************************************************************************************)
subsection \<open>Accessible message parts\<close>
(****************************************************************************************)

text \<open>Accessible message parts: all subterms that are in principle extractable
by the Dolev-Yao attacker, i.e., provided he knows all keys. Note that keys in
key positions and messages under hashes are not message parts in this sense.\<close>

inductive_set
  parts :: "msg set => msg set"
  for H :: "msg set"
where
    Inj [intro]: "X \<in> H \<Longrightarrow> X \<in> parts H"
  | Fst [intro]: "Pair X Y \<in> parts H \<Longrightarrow> X \<in> parts H"
  | Snd [intro]: "Pair X Y \<in> parts H \<Longrightarrow> Y \<in> parts H"
  | Dec [intro]: "Enc X Y \<in> parts H \<Longrightarrow> X \<in> parts H"
  | Adec [intro]: "Aenc X Y \<in> parts H \<Longrightarrow> X \<in> parts H"
  | Sign_getmsg [intro]: "Sign X Y \<in> parts H \<Longrightarrow> X \<in> parts H"

text \<open>Lemmas about accessible message parts.\<close>

lemma parts_mono [mono_set]: "G \<subseteq> H \<Longrightarrow> parts G \<subseteq> parts H"
by (auto, erule parts.induct, auto)

lemmas parts_monotone = parts_mono [THEN [2] rev_subsetD]

lemma Pair_parts [elim]:
  "\<lbrakk> Pair X Y \<in> parts H; \<lbrakk> X \<in> parts H; Y \<in> parts H \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
by blast

lemma parts_increasing: "H \<subseteq> parts H"
by blast

lemmas parts_insertI = subset_insertI [THEN parts_mono, THEN subsetD]

lemma parts_empty [simp]: "parts {} = {}"
by (safe, erule parts.induct, auto)

lemma parts_atomic [simp]: "atomic x \<Longrightarrow> parts {x} = {x}"
by (auto, erule parts.induct, auto)

lemma parts_InsecTag [simp]: "parts {Tag t} = {Tag t}"
by (safe, erule parts.induct) (auto)

lemma parts_emptyE [elim!]: "X \<in> parts {} \<Longrightarrow> P"
by simp

lemma parts_Tags [simp]:
  "parts Tags = Tags"
by (rule, rule, erule parts.induct, auto)

lemma parts_singleton: "X \<in> parts H \<Longrightarrow> \<exists> Y\<in>H. X \<in> parts {Y}"
by (erule parts.induct, blast+)

lemma parts_Un [simp]: "parts (G \<union> H) = parts G \<union> parts H"
proof
  show "parts (G \<union> H) \<subseteq> parts G \<union> parts H"
    by (rule, erule parts.induct) (auto)
next
  show "parts G \<union> parts H \<subseteq> parts (G \<union> H)"
    by (intro Un_least parts_mono Un_upper1 Un_upper2)
qed

lemma parts_insert_subset_Un:
  assumes "X \<in> G"
  shows "parts (insert X H) \<subseteq> parts G \<union> parts H"
proof -
  from assms have "parts (insert X H) \<subseteq> parts (G \<union> H)" by (blast intro!: parts_mono)
  thus ?thesis by simp
qed

lemma parts_insert: "parts (insert X H) = parts {X} \<union> parts H"
by (blast intro!: parts_insert_subset_Un intro: parts_monotone)

lemma parts_insert2:
  "parts (insert X (insert Y H)) = parts {X} \<union> parts {Y} \<union> parts H"
apply (simp add: Un_assoc)
apply (simp add: parts_insert [symmetric])
done

lemma parts_UN [simp]: "parts (\<Union>x\<in>A. H x) = (\<Union>x\<in>A. parts(H x))" (is "?X = ?Y")
proof
  show "?X \<subseteq> ?Y" by (rule subsetI, erule parts.induct) (blast+)
next
  show "?Y \<subseteq> ?X" by (intro UN_least parts_mono UN_upper)
qed

lemmas in_parts_UnE [elim!] = parts_Un [THEN equalityD1, THEN subsetD, THEN UnE]

lemma parts_insert_subset: "insert X (parts H) \<subseteq> parts (insert X H)"
by (blast intro: parts_mono [THEN [2] rev_subsetD])

lemma parts_partsD [dest!]: "X \<in> parts (parts H) \<Longrightarrow> X \<in> parts H"
by (erule parts.induct, blast+)

lemma parts_idem [simp]: "parts (parts H) = parts H"
by blast

lemma parts_subset_iff [simp]: "(parts G \<subseteq> parts H) \<longleftrightarrow> (G \<subseteq> parts H)"
by (blast dest: parts_mono)

lemma parts_trans: "X \<in> parts G \<Longrightarrow>  G \<subseteq> parts H \<Longrightarrow> X \<in> parts H"
by (drule parts_mono, blast)

lemma parts_cut:
  "Y \<in> parts (insert X G) \<Longrightarrow>  X \<in> parts H \<Longrightarrow> Y \<in> parts (G \<union> H)"
by (blast intro: parts_trans)

lemma parts_cut_eq [simp]: "X \<in> parts H \<Longrightarrow> parts (insert X H) = parts H"
by (force dest!: parts_cut intro: parts_insertI)

lemmas parts_insert_eq_I = equalityI [OF subsetI parts_insert_subset]

lemma parts_insert_Agent [simp]:
  "parts (insert (Agent agt) H) = insert (Agent agt) (parts H)"
by (rule parts_insert_eq_I, erule parts.induct, auto)

lemma parts_insert_Nonce [simp]:
  "parts (insert (Nonce N) H) = insert (Nonce N) (parts H)"
by (rule parts_insert_eq_I, erule parts.induct, auto)

lemma parts_insert_Number [simp]:
  "parts (insert (Number N) H) = insert (Number N) (parts H)"
by (rule parts_insert_eq_I, erule parts.induct, auto)

lemma parts_insert_LtK [simp]:
  "parts (insert (LtK K) H) = insert (LtK K) (parts H)"
by (rule parts_insert_eq_I, erule parts.induct, auto)

lemma parts_insert_Hash [simp]:
  "parts (insert (Hash X) H) = insert (Hash X) (parts H)"
by (rule parts_insert_eq_I, erule parts.induct, auto)

lemma parts_insert_Enc [simp]:
  "parts (insert (Enc X Y) H) = insert (Enc X Y) (parts {X} \<union> parts H)"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
done

lemma parts_insert_Aenc [simp]:
  "parts (insert (Aenc X Y) H) = insert (Aenc X Y) (parts {X} \<union> parts H)"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
done

lemma parts_insert_Sign [simp]:
  "parts (insert (Sign X Y) H) = insert (Sign X Y) (parts {X} \<union> parts H)"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
done

lemma parts_insert_Pair [simp]:
  "parts (insert (Pair X Y) H) = insert (Pair X Y) (parts {X} \<union> parts {Y} \<union> parts H)"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
done

subsubsection \<open>Lemmas about combinations with composition and decomposition\<close>
(****************************************************************************************)

lemma analz_subset_parts: "analz H \<subseteq> parts H"
apply (rule subsetI)
apply (erule analz.induct, blast+)
done

lemmas analz_into_parts [simp] = analz_subset_parts [THEN subsetD]

lemmas not_parts_not_analz = analz_subset_parts [THEN contra_subsetD]

lemma parts_analz [simp]: "parts (analz H) = parts H"
apply (rule equalityI)
apply (rule analz_subset_parts [THEN parts_mono, THEN subset_trans], simp)
apply (blast intro: analz_increasing [THEN parts_mono, THEN subsetD])
done

lemma analz_parts [simp]: "analz (parts H) = parts H"
apply auto
apply (erule analz.induct, auto)
done

lemma parts_synth [simp]: "parts (synth H) = parts H \<union> synth H"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct)
apply (blast intro: synth_increasing [THEN parts_mono, THEN subsetD] )+
done

lemma Fake_parts_insert:
  "X \<in> synth (analz H) \<Longrightarrow> parts (insert X H) \<subseteq> synth (analz H) \<union> parts H"
apply (drule parts_insert_subset_Un)
apply (simp (no_asm_use))
apply blast
done

lemma Fake_parts_insert_in_Un:
  "Z \<in> parts (insert X H) \<Longrightarrow>
   X \<in> synth (analz H) \<Longrightarrow>
   Z \<in>  synth (analz H) \<union> parts H"
by (blast dest: Fake_parts_insert [THEN subsetD, dest])

lemma analz_conj_parts [simp]:
  "X \<in> analz H \<and> X \<in> parts H \<longleftrightarrow> X \<in> analz H"
by (blast intro: analz_subset_parts [THEN subsetD])

lemma analz_disj_parts [simp]:
  "X \<in> analz H \<or> X \<in> parts H \<longleftrightarrow> X \<in> parts H"
by (blast intro: analz_subset_parts [THEN subsetD])

(****************************************************************************************)
subsection \<open>More lemmas about combinations of closures\<close>
(****************************************************************************************)

text \<open>Combinations of @{term synth} and @{term analz}.\<close>

lemma Pair_synth_analz [simp]:
  "Pair X Y \<in> synth (analz H) \<longleftrightarrow> X \<in> synth (analz H) \<and> Y \<in> synth (analz H)"
by blast

lemma Enc_synth_analz:
  "Y \<in> synth (analz H) \<Longrightarrow>
   (Enc X Y \<in> synth (analz H)) \<longleftrightarrow> (X \<in> synth (analz H))"
by blast

lemma Hash_synth_analz [simp]:
  "X \<notin> synth (analz H) \<Longrightarrow>
   (Hash (Pair X Y) \<in> synth (analz H)) \<longleftrightarrow> (Hash (Pair X Y) \<in> analz H)"
by blast

lemma gen_analz_insert_eq:
  "\<lbrakk> X \<in> analz G; G \<subseteq> H \<rbrakk> \<Longrightarrow> analz (insert X H) = analz H"
by (blast intro: analz_cut analz_insertI analz_monotone)

lemma synth_analz_insert_eq:
  "\<lbrakk> X \<in> synth (analz G); G \<subseteq> H \<rbrakk> \<Longrightarrow> synth (analz (insert X H)) = synth (analz H)"
by (blast intro!: synth_analz_insert synth_analz_monotone)

lemma Fake_parts_sing:
  "X \<in> synth (analz H) \<Longrightarrow> parts {X} \<subseteq> synth (analz H) \<union> parts H"
apply (rule subset_trans)
apply (erule_tac [2] Fake_parts_insert)
apply (rule parts_mono, blast)
done

lemmas Fake_parts_sing_imp_Un = Fake_parts_sing [THEN [2] rev_subsetD]

lemma analz_hash_nonce [simp]:
  "analz {M. \<exists>N. M = Hash (Nonce N)} = {M. \<exists>N. M = Hash (Nonce N)}"
by (auto, rule analz.induct, auto)

lemma synth_analz_hash_nonce [simp]:
  "NonceF N \<notin> synth (analz {M. \<exists>N. M = Hash (Nonce N)})"
by auto

lemma synth_analz_idem_mono:
  "S \<subseteq> synth (analz S') \<Longrightarrow> synth (analz S) \<subseteq> synth (analz S')"
by (frule synth_analz_mono, auto)

lemmas synth_analz_idem_monoI =
  synth_analz_idem_mono [THEN [2] rev_subsetD]

lemma analz_synth_subset:
  "analz X \<subseteq> synth (analz X') \<Longrightarrow>
   analz Y \<subseteq> synth (analz Y') \<Longrightarrow>
   analz (X \<union> Y) \<subseteq> synth (analz (X' \<union> Y'))"
proof -
  assume "analz X \<subseteq> synth (analz X')"
  then have HX:"analz X \<subseteq> analz (synth (analz X'))" by blast
  assume "analz Y \<subseteq> synth (analz Y')"
  then have HY:"analz Y \<subseteq> analz (synth (analz Y'))" by blast
  from analz_subset_cong [OF HX HY]
  have "analz (X \<union> Y) \<subseteq> analz (synth (analz X') \<union> synth (analz Y'))"
    by blast
  also have "... \<subseteq> analz (synth (analz X' \<union> analz Y'))"
    by (intro analz_mono synth_Un)
  also have "... \<subseteq> analz (synth (analz (X' \<union> Y')))"
    by (intro synth_mono analz_mono analz_Un)
  also have "... \<subseteq> synth (analz (X' \<union> Y'))"
    by auto
  finally show "analz (X \<union> Y) \<subseteq> synth (analz (X' \<union> Y'))"
    by auto
qed

lemma analz_synth_subset_Un1 :
  "analz X \<subseteq> synth (analz X') \<Longrightarrow> analz (X \<union> Y) \<subseteq> synth (analz (X' \<union> Y))"
using analz_synth_subset by blast

lemma analz_synth_subset_Un2 :
  "analz X \<subseteq> synth (analz X') \<Longrightarrow> analz (Y \<union> X) \<subseteq> synth (analz (Y \<union> X'))"
using analz_synth_subset by blast

lemma analz_synth_insert:
  "analz X \<subseteq> synth (analz X') \<Longrightarrow> analz (insert Y X) \<subseteq> synth (analz (insert Y X'))"
by (metis analz_synth_subset_Un2 insert_def)

lemma Fake_analz_insert_Un:
  assumes "Y \<in> analz (insert X H)" and "X \<in> synth (analz G)"
  shows "Y \<in> synth (analz G) \<union> analz (G \<union> H)"
proof -
  from assms have "Y \<in> analz (synth (analz G) \<union> H)"
    by (blast intro: analz_mono [THEN [2] rev_subsetD]
                     analz_mono [THEN synth_mono, THEN [2] rev_subsetD])
  thus ?thesis by (simp add: sup.commute)
qed

end


(******************************************************************************)
(* Project: Isabelle/UTP: Unifying Theories of Programming in Isabelle/HOL    *)
(* File: designs.thy                                                          *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@gmail.com and simon.foster@york.ac.uk                  *)
(******************************************************************************)
(* LAST REVIEWED: 09 Jun 2022 *)

section \<open>Theory of Designs\<close>

theory designs
imports utheory
begin

subsection \<open>Type Injections\<close>

inject_type bool

subsection \<open>Theory Variables\<close>

declare_uvar ok :: "bool"

subsection \<open>Operators\<close>

definition design :: "upred \<Rightarrow> upred \<Rightarrow> upred" (infix "\<turnstile>\<^sub>p" 90) where
"P \<turnstile>\<^sub>p Q = `ok \<and> {P} \<Rightarrow> ok' \<and> {Q}`"

declare design_def [evalp]

subsection \<open>Parser Extensions\<close>

syntax "_udesign" :: "uterm \<Rightarrow> uterm \<Rightarrow> uterm" (infix "\<turnstile>" 90)

translations "_udesign P Q" \<rightharpoonup> "P \<turnstile>\<^sub>p Q"

subsection \<open>Healthiness Conditions\<close>

definition H1 :: "hcond" where
"H1 P = `ok \<Rightarrow> {P}`"

declare H1_def [evalp]

subsection \<open>Theorems\<close>

theorem design_H1 :
"P \<turnstile>\<^sub>p Q is H1"
apply (unfold evalp)
apply (auto)
done
end


(*  Title:      HOL/Auth/Shared.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge

Theory of Shared Keys (common to all symmetric-key protocols)

Shared, long-term keys; initial states of agents
*)

theory Shared
imports Event All_Symmetric
begin

consts
  shrK    :: "agent => key"  (*symmetric keys*)

specification (shrK)
  inj_shrK: "inj shrK"
  --{*No two agents have the same long-term key*}
   apply (rule exI [of _ "case_agent 0 (\<lambda>n. n + 2) 1"])
   apply (simp add: inj_on_def split: agent.split)
   done

text{*Server knows all long-term keys; other agents know only their own*}

overloading
  initState \<equiv> initState
begin

primrec initState where
  initState_Server:  "initState Server     = Key ` range shrK"
| initState_Friend:  "initState (Friend i) = {Key (shrK (Friend i))}"
| initState_Spy:     "initState Spy        = Key`shrK`bad"

end

subsection{*Basic properties of shrK*}

(*Injectiveness: Agents' long-term keys are distinct.*)
lemmas shrK_injective = inj_shrK [THEN inj_eq]
declare shrK_injective [iff]

lemma invKey_K [simp]: "invKey K = K"
apply (insert isSym_keys)
apply (simp add: symKeys_def)
done

lemma analz_Decrypt' [dest]:
     "[| Crypt K X \<in> analz H;  Key K  \<in> analz H |] ==> X \<in> analz H"
by auto

text{*Now cancel the @{text dest} attribute given to
 @{text analz.Decrypt} in its declaration.*}
declare analz.Decrypt [rule del]

text{*Rewrites should not refer to  @{term "initState(Friend i)"} because
  that expression is not in normal form.*}

lemma keysFor_parts_initState [simp]: "keysFor (parts (initState C)) = {}"
apply (unfold keysFor_def)
apply (induct_tac "C", auto)
done

(*Specialized to shared-key model: no @{term invKey}*)
lemma keysFor_parts_insert:
     "[| K \<in> keysFor (parts (insert X G));  X \<in> synth (analz H) |]
      ==> K \<in> keysFor (parts (G \<union> H)) | Key K \<in> parts H"
by (metis invKey_K keysFor_parts_insert)

lemma Crypt_imp_keysFor: "Crypt K X \<in> H ==> K \<in> keysFor H"
by (metis Crypt_imp_invKey_keysFor invKey_K)

subsection{*Function "knows"*}

(*Spy sees shared keys of agents!*)
lemma Spy_knows_Spy_bad [intro!]: "A: bad ==> Key (shrK A) \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) add: imageI knows_Cons split add: event.split)
done

(*For case analysis on whether or not an agent is compromised*)
lemma Crypt_Spy_analz_bad: "[| Crypt (shrK A) X \<in> analz (knows Spy evs);  A: bad |]
      ==> X \<in> analz (knows Spy evs)"
by (metis Spy_knows_Spy_bad analz.Inj analz_Decrypt')

(** Fresh keys never clash with long-term shared keys **)

(*Agents see their own shared keys!*)
lemma shrK_in_initState [iff]: "Key (shrK A) \<in> initState A"
by (induct_tac "A", auto)

lemma shrK_in_used [iff]: "Key (shrK A) \<in> used evs"
by (rule initState_into_used, blast)

(*Used in parts_induct_tac and analz_Fake_tac to distinguish session keys
  from long-term shared keys*)
lemma Key_not_used [simp]: "Key K \<notin> used evs ==> K \<notin> range shrK"
by blast

lemma shrK_neq [simp]: "Key K \<notin> used evs ==> shrK B \<noteq> K"
by blast

lemmas shrK_sym_neq = shrK_neq [THEN not_sym]
declare shrK_sym_neq [simp]

subsection{*Fresh nonces*}

lemma Nonce_notin_initState [iff]: "Nonce N \<notin> parts (initState B)"
by (induct_tac "B", auto)

lemma Nonce_notin_used_empty [simp]: "Nonce N \<notin> used []"
by (simp add: used_Nil)

subsection{*Supply fresh nonces for possibility theorems.*}

(*In any trace, there is an upper bound N on the greatest nonce in use.*)
lemma Nonce_supply_lemma: "\<exists>N. ALL n. N<=n --> Nonce n \<notin> used evs"
apply (induct_tac "evs")
apply (rule_tac x = 0 in exI)
apply (simp_all (no_asm_simp) add: used_Cons split add: event.split)
apply (metis le_sup_iff msg_Nonce_supply)
done

lemma Nonce_supply1: "\<exists>N. Nonce N \<notin> used evs"
by (metis Nonce_supply_lemma order_eq_iff)

lemma Nonce_supply2: "\<exists>N N'. Nonce N \<notin> used evs & Nonce N' \<notin> used evs' & N \<noteq> N'"
apply (cut_tac evs = evs in Nonce_supply_lemma)
apply (cut_tac evs = "evs'" in Nonce_supply_lemma, clarify)
apply (metis Suc_n_not_le_n nat_le_linear)
done

lemma Nonce_supply3: "\<exists>N N' N''. Nonce N \<notin> used evs & Nonce N' \<notin> used evs' &
                    Nonce N'' \<notin> used evs'' & N \<noteq> N' & N' \<noteq> N'' & N \<noteq> N''"
apply (cut_tac evs = evs in Nonce_supply_lemma)
apply (cut_tac evs = "evs'" in Nonce_supply_lemma)
apply (cut_tac evs = "evs''" in Nonce_supply_lemma, clarify)
apply (rule_tac x = N in exI)
apply (rule_tac x = "Suc (N+Na)" in exI)
apply (rule_tac x = "Suc (Suc (N+Na+Nb))" in exI)
apply (simp (no_asm_simp) add: less_not_refl3 le_add1 le_add2 less_Suc_eq_le)
done

lemma Nonce_supply: "Nonce (@ N. Nonce N \<notin> used evs) \<notin> used evs"
apply (rule Nonce_supply_lemma [THEN exE])
apply (rule someI, blast)
done

text{*Unlike the corresponding property of nonces, we cannot prove
    @{term "finite KK ==> \<exists>K. K \<notin> KK & Key K \<notin> used evs"}.
    We have infinitely many agents and there is nothing to stop their
    long-term keys from exhausting all the natural numbers.  Instead,
    possibility theorems must assume the existence of a few keys.*}

subsection{*Specialized Rewriting for Theorems About @{term analz} and Image*}

lemma subset_Compl_range: "A <= - (range shrK) ==> shrK x \<notin> A"
by blast

lemma insert_Key_singleton: "insert (Key K) H = Key ` {K} \<union> H"
by blast

lemma insert_Key_image: "insert (Key K) (Key`KK \<union> C) = Key`(insert K KK) \<union> C"
by blast

(** Reverse the normal simplification of "image" to build up (not break down)
    the set of keys.  Use analz_insert_eq with (Un_upper2 RS analz_mono) to
    erase occurrences of forwarded message components (X). **)

lemmas analz_image_freshK_simps =
       simp_thms mem_simps --{*these two allow its use with @{text "only:"}*}
       disj_comms
       image_insert [THEN sym] image_Un [THEN sym] empty_subsetI insert_subset
       analz_insert_eq Un_upper2 [THEN analz_mono, THEN [2] rev_subsetD]
       insert_Key_singleton subset_Compl_range
       Key_not_used insert_Key_image Un_assoc [THEN sym]

(*Lemma for the trivial direction of the if-and-only-if*)
lemma analz_image_freshK_lemma:
     "(Key K \<in> analz (Key`nE \<union> H)) --> (K \<in> nE | Key K \<in> analz H)  ==>
         (Key K \<in> analz (Key`nE \<union> H)) = (K \<in> nE | Key K \<in> analz H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

subsection{*Tactics for possibility theorems*}

ML
{*
structure Shared =
struct

(*Omitting used_Says makes the tactic much faster: it leaves expressions
    such as  Nonce ?N \<notin> used evs that match Nonce_supply*)
fun possibility_tac ctxt =
   (REPEAT
    (ALLGOALS (simp_tac (ctxt
          delsimps [@{thm used_Says}, @{thm used_Notes}, @{thm used_Gets}]
          setSolver safe_solver))
     THEN
     REPEAT_FIRST (eq_assume_tac ORELSE'
                   resolve_tac [refl, conjI, @{thm Nonce_supply}])))

(*For harder protocols (such as Recur) where we have to set up some
  nonces and keys initially*)
fun basic_possibility_tac ctxt =
    REPEAT
    (ALLGOALS (asm_simp_tac (ctxt setSolver safe_solver))
     THEN
     REPEAT_FIRST (resolve_tac [refl, conjI]))

val analz_image_freshK_ss =
  simpset_of
   (@{context} delsimps [image_insert, image_Un]
      delsimps [@{thm imp_disjL}]    (*reduces blow-up*)
      addsimps @{thms analz_image_freshK_simps})

end
*}

(*Lets blast_tac perform this step without needing the simplifier*)
lemma invKey_shrK_iff [iff]:
     "(Key (invKey K) \<in> X) = (Key K \<in> X)"
by auto

(*Specialized methods*)

method_setup analz_freshK = {*
    Scan.succeed (fn ctxt =>
     (SIMPLE_METHOD
      (EVERY [REPEAT_FIRST (resolve_tac [allI, ballI, impI]),
          REPEAT_FIRST (rtac @{thm analz_image_freshK_lemma}),
          ALLGOALS (asm_simp_tac (put_simpset Shared.analz_image_freshK_ss ctxt))]))) *}
    "for proving the Session Key Compromise theorem"

method_setup possibility = {*
    Scan.succeed (fn ctxt => SIMPLE_METHOD (Shared.possibility_tac ctxt)) *}
    "for proving possibility theorems"

method_setup basic_possibility = {*
    Scan.succeed (fn ctxt => SIMPLE_METHOD (Shared.basic_possibility_tac ctxt)) *}
    "for proving possibility theorems"

lemma knows_subset_knows_Cons: "knows A evs <= knows A (e # evs)"
by (cases e) (auto simp: knows_Cons)

end


subsection \<open>Definition of \texorpdfstring{$\Psi$}{Psi}\label{sec:psi}\<close>

theory Psi
  imports SortKeys "HOL-Eisbach.Eisbach"
begin

fun extended_size :: "('a sort_key) extended \<Rightarrow> nat"
  where
    "extended_size \<lbrakk>x\<rbrakk> = size x" |
    "extended_size _ = 0"

lemma extended_simps [simp]:
  "(\<turnstile> < x) = (x \<noteq> \<turnstile>)"
  "(\<lbrakk>x'\<rbrakk> < \<lbrakk>y'\<rbrakk>) = (x' < y')"
  "\<lbrakk>x'\<rbrakk> < \<stileturn>"
  "\<not>(\<lbrakk>x'\<rbrakk> < \<turnstile>)"
  "\<not>(\<stileturn> < x)"
  "\<turnstile> \<le> x"
  "(\<lbrakk>x'\<rbrakk> \<le> \<lbrakk>y'\<rbrakk>) = ((x' :: 'a :: linorder) \<le> y')"
  "x \<le> \<stileturn>"
  "\<not>(\<lbrakk>x'\<rbrakk> \<le> \<turnstile>)"
  "(\<stileturn> \<le> x) = (x = \<stileturn>)"
  by (case_tac [!] x, simp_all add:less_extended_def less_eq_extended_def le_less)

fun int_size where "int_size (l,u) = max (extended_size l) (extended_size u)"

lemma position_cases:
  assumes "\<And> y z. x = \<lbrakk>NonFinal (y,Left) z\<rbrakk> \<Longrightarrow> p"
  assumes "\<And> y z. x = \<lbrakk>NonFinal (y,Right) z\<rbrakk> \<Longrightarrow> p"
  assumes "\<And> y. x = \<lbrakk>Final y\<rbrakk> \<Longrightarrow> p"
  assumes "x = \<turnstile> \<Longrightarrow> p"
  assumes "x = \<stileturn> \<Longrightarrow> p"
  shows "p"
  by (metis assms embed_dir.cases extended_size.cases sort_key_embedding.cases)

fun derive_pos ::
  "('a :: linorder) \<times> sort_dir \<Rightarrow> 'a sort_key extended \<Rightarrow> 'a sort_key extended"
  where
    "derive_pos h \<lbrakk>NonFinal x y\<rbrakk> =
      (if h < x then \<stileturn> else (if x < h then \<turnstile> else \<lbrakk>y\<rbrakk>))" |
    "derive_pos h \<lbrakk>Final x\<rbrakk> =
      (if fst h < x \<or> fst h = x \<and> snd h = Left then \<stileturn> else \<turnstile>)" |
    "derive_pos _ \<turnstile> = \<turnstile>" |
    "derive_pos _ \<stileturn> = \<stileturn>"

lemma derive_pos_mono: "x \<le> y \<Longrightarrow> derive_pos h x \<le> derive_pos h y"
  apply (cases h, cases "snd h")
  apply (rule_tac [!] position_cases [where x=x])
  apply (rule_tac [!] position_cases [where x=y])
  by (simp_all, auto)

fun \<gamma> :: "('a :: linorder) position \<Rightarrow> sort_dir \<Rightarrow> 'a \<times> sort_dir"
  where
    "\<gamma> \<lbrakk>NonFinal x y\<rbrakk> _ = x" |
    "\<gamma> \<lbrakk>Final x\<rbrakk> d = (x,d)" |
    "\<gamma> \<turnstile> _ = undefined" |
    "\<gamma> \<stileturn> _ = undefined"

fun derive_left  where
  "derive_left (l, u) = (derive_pos (\<gamma> l Right) l, derive_pos (\<gamma> l Right) u)"

fun derive_right where
  "derive_right (l, u) = (derive_pos (\<gamma> u Left) l, derive_pos (\<gamma> u Left) u)"

fun is_interval where "is_interval (l,u) = (l < u)"

fun elem where "elem x (l,u) = (l < x \<and> x < u)"

fun subset where "subset (l,u) (l',u') = (l' \<le> l \<and> u \<le> u')"

method interval_split for x :: "('a :: linorder) position \<times> 'a position" =
  (case_tac [!] x,
   rule_tac [!] position_cases [where x="fst x"],
   rule_tac [!] position_cases [where x="snd x"])

lemma derive_size:
  "\<lbrakk>Final i\<rbrakk> \<le> fst x \<and> is_interval x \<Longrightarrow> int_size (derive_left x) < int_size x"
  "snd x \<le> \<lbrakk>Final i\<rbrakk> \<and> is_interval x \<Longrightarrow> int_size (derive_right x) < int_size x"
  by (interval_split x, simp_all add:less_SucI)

lemma derive_interval:
  "\<lbrakk>Final i\<rbrakk> \<le> fst x \<Longrightarrow> is_interval x \<Longrightarrow> is_interval (derive_left x)"
  "snd x \<le> \<lbrakk>Final i\<rbrakk> \<Longrightarrow> is_interval x \<Longrightarrow> is_interval (derive_right x)"
  by (interval_split x, simp_all, auto)

function \<Psi> :: "('a :: linorder) position \<times> 'a position \<Rightarrow> 'a \<Rightarrow> 'a sort_key"
  where
    "\<Psi> (l,u) i = Final i"
      if "l < \<lbrakk>Final i\<rbrakk> \<and> \<lbrakk>Final i\<rbrakk> < u" |
    "\<Psi> (l,u) i = NonFinal (\<gamma> l Right) (\<Psi> (derive_left (l,u)) i)"
      if "\<lbrakk>Final i\<rbrakk> \<le> l \<and> l < u" |
    "\<Psi> (l,u) i = NonFinal (\<gamma> u Left) (\<Psi> (derive_right (l,u)) i)"
      if "u \<le> \<lbrakk>Final i\<rbrakk> \<and> l < u" |
    "\<Psi> (l,u) i = undefined" if "u \<le> l"
  by (metis leI old.prod.exhaust, auto)

termination
  apply (relation "measure (\<lambda>(p,i). int_size p)", simp)
  using derive_size by fastforce+

proposition psi_elem: "is_interval x \<Longrightarrow> elem \<lbrakk>\<Psi> x i\<rbrakk> x"
proof (induct "int_size x" arbitrary:x rule: nat_less_induct)
  case 1
  consider (a) "\<lbrakk>Final i\<rbrakk> \<le> fst x" | (b) "elem \<lbrakk>Final i\<rbrakk> x" | (c) "snd x \<le> \<lbrakk>Final i\<rbrakk>"
    using not_le by (metis elem.simps prod.collapse)
  then show ?case
  proof (cases)
    case a
    hence "elem  \<lbrakk>\<Psi> (derive_left x) i\<rbrakk> (derive_left x)"
      by (metis 1 derive_size(1) derive_interval(1))
    then show ?thesis using a "1"(2)
      by (interval_split x, simp_all del:\<Psi>.simps, auto)
  next
    case b
    then show ?thesis by (cases x, simp)
  next
    case c
    hence "elem  \<lbrakk>\<Psi> (derive_right x) i\<rbrakk> (derive_right x)"
      by (metis 1 derive_size(2) derive_interval(2))
    then show ?thesis using c "1"(2)
      by (interval_split x, simp_all del:\<Psi>.simps, auto)
  qed
qed

proposition psi_mono:
  assumes "i1 < i2"
  shows "is_interval x \<Longrightarrow> \<Psi> x i1 < \<Psi> x i2"
proof (induct "int_size x" arbitrary:x rule: nat_less_induct)
  case 1
  have a:"\<lbrakk>Final i1\<rbrakk> < \<lbrakk>Final i2\<rbrakk>"
    using assms by auto
  then consider
    (a) "\<lbrakk>Final i1\<rbrakk> \<le> fst x \<and> \<lbrakk>Final i2\<rbrakk> \<le> fst x" |
    (b) "\<lbrakk>Final i1\<rbrakk> \<le> fst x \<and> elem \<lbrakk>Final i2\<rbrakk> x" |
    (c) "\<lbrakk>Final i1\<rbrakk> \<le> fst x \<and> snd x \<le> \<lbrakk>Final i2\<rbrakk>" |
    (d) "elem \<lbrakk>Final i1\<rbrakk> x  \<and> elem \<lbrakk>Final i2\<rbrakk> x" |
    (e) "elem \<lbrakk>Final i1\<rbrakk> x \<and> snd x \<le> \<lbrakk>Final i2\<rbrakk>" |
    (f) "snd x \<le> \<lbrakk>Final i2\<rbrakk> \<and> snd x \<le> \<lbrakk>Final i1\<rbrakk>"
    using assms "1"(2) apply (cases x)
    by (metis (mono_tags, hide_lams) dual_order.strict_trans elem.simps
        fst_conv leI snd_conv)
  then show ?case
  proof (cases)
    case a
    hence "\<Psi> (derive_left x) i1  < \<Psi> (derive_left x) i2"
      by (metis 1 derive_size(1) derive_interval(1))
    thus ?thesis using a "1"(2) by (cases x, simp)
  next
    case b
    thus ?thesis using "1"(2) apply (cases x, simp)
      by (rule_tac [!] position_cases [where x="fst x"], simp_all)
  next
    case c
    show ?thesis
    proof (cases "\<gamma> (fst x) Right = \<gamma> (snd x) Left")
      case True
      have e:"is_interval (derive_left x)" using c "1"(2) derive_interval(1) by blast
      have f:"derive_left x = derive_right x" using True by (cases x, simp)
      have h:"\<Psi> (derive_left x) i1 < \<Psi> (derive_right x) i2"
        apply (cases x, simp only: f)
        by (metis "1.hyps" "1.prems" c derive_size(2) e f)
      show ?thesis using c "1"(2) h True by (cases x, simp)
    next
      case False
      hence "\<gamma> (fst x) Right < \<gamma> (snd x) Left" using "1"(2) c
      by (interval_split x, simp_all, auto)
      then show ?thesis using c "1"(2) by (cases x, simp)
    qed
  next
    case d
    thus ?thesis using "1"(2) a by (cases x, simp)
  next
    case e
    thus ?thesis using "1"(2) apply (cases x, simp)
      by (rule_tac [!] position_cases [where x="snd x"], simp_all del:\<Psi>.simps)
  next
    case f
    hence b:"\<Psi> (derive_right x) i1  < \<Psi> (derive_right x) i2"
      by (metis 1 derive_size(2) derive_interval(2))
    thus ?thesis using f "1"(2) by (cases x, simp)
  qed
qed

proposition psi_narrow:
  "elem \<lbrakk>\<Psi> x' i\<rbrakk> x \<Longrightarrow> subset x x' \<Longrightarrow> \<Psi> x' i = \<Psi> x i"
proof (induct "int_size x'" arbitrary: x x' rule: nat_less_induct)
  case 1
  have a: "is_interval x" using "1"(2)
    by (metis dual_order.strict_trans elem.elims(2) is_interval.simps)
  have d: "is_interval x'" using a "1"(3) apply (cases x', cases x, simp) by auto
  consider
    (before) "\<lbrakk>Final i\<rbrakk> \<le> fst x'" |
    (between) "elem \<lbrakk>Final i\<rbrakk> x'" |
    (after) "snd x' \<le> \<lbrakk>Final i\<rbrakk>" using 1 apply simp
    by (metis elem.simps leI prod.collapse)
  then show ?case
  proof (cases)
    case before
    have b: "\<lbrakk>Final i\<rbrakk> \<le> fst x" using before 1 apply (cases x)
      by (metis dual_order.trans fst_conv subset.elims(2))
    obtain z where z_def: "\<Psi> x' i = NonFinal (\<gamma> (fst x') Right) z"
      using before d apply (cases x') by simp
    have c:"\<gamma> (fst x') Right = \<gamma> (fst x) Right"
      using "1"(3) z_def "1"(2) apply (cases x, cases x', simp)
      apply (rule_tac [!] position_cases [where x="fst x"])
      apply (rule_tac [!] position_cases [where x="fst x'"])
      using before by (simp_all del:\<Psi>.simps, auto)
    have c1:"subset (derive_left x) (derive_left x')"
      using c "1"(3) by (cases x, cases x', simp add:derive_pos_mono)
    have g:"z = \<Psi> (derive_left x') i" using z_def before d by (cases x', simp)
    have "elem \<lbrakk>NonFinal (\<gamma> (fst x) Right) z\<rbrakk> x"
      using "1"(2) z_def by (simp add: c)
    hence "elem \<lbrakk>z\<rbrakk> (derive_left x)" using before b
      by (interval_split x, simp_all del:\<Psi>.simps, auto)
    hence "\<Psi> (derive_left x') i = \<Psi> (derive_left x) i"
      using "1"(1) before d c1 apply (simp only:g)
      by (metis (no_types) derive_size(1))
    thus ?thesis using before b a d c by (cases x, cases x', simp)
  next
    case between
    thus ?thesis using 1 by (cases x, cases x', auto)
  next
    case after
    have b: "snd x \<le> \<lbrakk>Final i\<rbrakk>" using after 1 apply (cases x)
      by (metis (mono_tags, hide_lams) dual_order.trans prod.exhaust_sel
          subset.simps)
    obtain z where z_def:"\<Psi> x' i = NonFinal (\<gamma> (snd x') Left) z"
      using after d by (cases x', simp)
    have c:"\<gamma> (snd x') Left = \<gamma> (snd x) Left"
      using "1"(3) z_def "1"(2) apply (simp, cases x, cases x')
      apply (rule_tac [!] position_cases [where x="snd x"])
      apply (rule_tac [!] position_cases [where x="snd x'"]) using after
      by (simp_all del:\<Psi>.simps, auto)
    have c1:"subset (derive_right x) (derive_right x')"
      using c "1"(3) by (cases x, cases x', simp add:derive_pos_mono)
    have g:"z = \<Psi> (derive_right x') i" using z_def after d by (cases x', simp)
    have "elem \<lbrakk>NonFinal (\<gamma> (snd x) Left) z\<rbrakk> x"
      using "1"(2) z_def by (simp add: c)
    hence "elem \<lbrakk>z\<rbrakk> (derive_right x)" using after b
      by (interval_split x, simp_all del:\<Psi>.simps, auto)
    hence "\<Psi> (derive_right x') i = \<Psi> (derive_right x) i"
      using "1"(1) after d c1 apply (simp only:g)
      by (metis (no_types) derive_size(2))
    thus ?thesis using after b a d c by (cases x, cases x', simp)
  qed
qed

definition preserve_order :: "'a :: linorder \<Rightarrow> 'a \<Rightarrow> 'b :: linorder \<Rightarrow> 'b \<Rightarrow> bool"
  where "preserve_order x y u v \<equiv> (x < y \<longrightarrow> u < v) \<and> (x > y \<longrightarrow> u > v)"

proposition psi_preserve_order:
  fixes l l' u u' i i'
  assumes "elem \<lbrakk>\<Psi> (l, u) i\<rbrakk> (l',u')"
  assumes "elem \<lbrakk>\<Psi> (l', u') i'\<rbrakk> (l, u)"
  shows "preserve_order i i' \<lbrakk>\<Psi> (l,u) i\<rbrakk> \<lbrakk>\<Psi> (l', u') i'\<rbrakk>"
proof -
  have "l < u" using assms(2) by auto
  hence a:"elem \<lbrakk>\<Psi> (l, u) i\<rbrakk> (max l l', min u u')"
    using assms(1) psi_elem by fastforce
  hence b:"\<Psi> (l,u) i = \<Psi> (max l l', min u u') i"
    by (simp add: psi_narrow)
  have "l' < u'" using assms(1) by auto
  hence "elem \<lbrakk>\<Psi> (l',u') i'\<rbrakk> (max l l', min u u')"
    using assms(2) psi_elem by fastforce
  hence c:"\<Psi> (l',u') i' = \<Psi> (max l l', min u u') i'"
    by (simp add: psi_narrow)
  hence "max l l' < min u u'" using a min_def by auto
  then show ?thesis apply (simp only: preserve_order_def b c)
    using psi_mono extended_simps(2) is_interval.simps by blast
qed

end