(*  Title:      POPLmark/POPLmark.thy
    Author:     Stefan Berghofer, TU Muenchen, 2005
*)

theory POPLmark
imports Basis
begin

section {* Formalization of the basic calculus *}

text {*
\label{sec:basic-calculus}
In this section, we describe the formalization of the basic calculus
without records. As a main result, we prove {\it type safety}, presented
as two separate theorems, namely {\it preservation} and {\it progress}.
*}

subsection {* Types and Terms *}

text {*
The types of System \fsub{} are represented by the following datatype:
*}

datatype type =
    TVar nat
  | Top
  | Fun type type    (infixr "\<rightarrow>" 200)
  | TyAll type type  ("(3\<forall><:_./ _)" [0, 10] 10)

text {*
The subtyping and typing judgements depend on a {\it context} (or environment) @{term \<Gamma>}
containing bindings for term and type variables. A context is a list of bindings,
where the @{term i}th element @{term "\<Gamma>\<langle>i\<rangle>"} corresponds to the variable
with index @{term i}.
*}

datatype binding = VarB type | TVarB type
type_synonym env = "binding list"

text {*
In contrast to the usual presentation of type systems often found in textbooks, new
elements are added to the left of a context using the @{text Cons} operator @{text "\<Colon>"} for lists.
We write @{term is_TVarB} for the predicate that returns @{term True} when applied to
a type variable binding, function @{term type_ofB} extracts the type contained in a binding,
and @{term "mapB f"} applies @{term f} to the type contained in a binding.
*}

primrec is_TVarB :: "binding \<Rightarrow> bool"
where
  "is_TVarB (VarB T) = False"
| "is_TVarB (TVarB T) = True"

primrec type_ofB :: "binding \<Rightarrow> type"
where
  "type_ofB (VarB T) = T"
| "type_ofB (TVarB T) = T"

primrec mapB :: "(type \<Rightarrow> type) \<Rightarrow> binding \<Rightarrow> binding"
where
  "mapB f (VarB T) = VarB (f T)"
| "mapB f (TVarB T) = TVarB (f T)"

text {*
The following datatype represents the terms of System \fsub{}:
*}

datatype trm =
    Var nat
  | Abs type trm   ("(3\<lambda>:_./ _)" [0, 10] 10)
  | TAbs type trm  ("(3\<lambda><:_./ _)" [0, 10] 10)
  | App trm trm    (infixl "\<bullet>" 200)
  | TApp trm type  (infixl "\<bullet>\<^sub>\<tau>" 200)

subsection {* Lifting and Substitution *}

text {*
One of the central operations of $\lambda$-calculus is {\it substitution}.
In order to avoid that free variables in a term or type get ``captured''
when substituting it for a variable occurring in the scope of a binder,
we have to increment the indices of its free variables during substitution.
This is done by the lifting functions @{text "\<up>\<^sub>\<tau> n k"} and @{text "\<up> n k"}
for types and terms, respectively, which increment the indices of all free
variables with indices @{text "\<ge> k"} by @{term n}. The lifting functions on
types and terms are defined by
*}

primrec liftT :: "nat \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> type" ("\<up>\<^sub>\<tau>")
where
  "\<up>\<^sub>\<tau> n k (TVar i) = (if i < k then TVar i else TVar (i + n))"
| "\<up>\<^sub>\<tau> n k Top = Top"
| "\<up>\<^sub>\<tau> n k (T \<rightarrow> U) = \<up>\<^sub>\<tau> n k T \<rightarrow> \<up>\<^sub>\<tau> n k U"
| "\<up>\<^sub>\<tau> n k (\<forall><:T. U) = (\<forall><:\<up>\<^sub>\<tau> n k T. \<up>\<^sub>\<tau> n (k + 1) U)"

primrec lift :: "nat \<Rightarrow> nat \<Rightarrow> trm \<Rightarrow> trm" ("\<up>")
where
  "\<up> n k (Var i) = (if i < k then Var i else Var (i + n))"
| "\<up> n k (\<lambda>:T. t) = (\<lambda>:\<up>\<^sub>\<tau> n k T. \<up> n (k + 1) t)"
| "\<up> n k (\<lambda><:T. t) = (\<lambda><:\<up>\<^sub>\<tau> n k T. \<up> n (k + 1) t)"
| "\<up> n k (s \<bullet> t) = \<up> n k s \<bullet> \<up> n k t"
| "\<up> n k (t \<bullet>\<^sub>\<tau> T) = \<up> n k t \<bullet>\<^sub>\<tau> \<up>\<^sub>\<tau> n k T"

text {*
It is useful to also define an ``unlifting'' function @{text "\<down>\<^sub>\<tau> n k"} for
decrementing all free variables with indices @{text "\<ge> k"} by @{term n}.
Moreover, we need several substitution functions, denoted by
\mbox{@{text "T[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>"}}, \mbox{@{text "t[k \<mapsto>\<^sub>\<tau> S]"}}, and \mbox{@{text "t[k \<mapsto> s]"}},
which substitute type variables in types, type variables in terms,
and term variables in terms, respectively. They are defined as follows:
*}

primrec substTT :: "type \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> type"  ("_[_ \<mapsto>\<^sub>\<tau> _]\<^sub>\<tau>" [300, 0, 0] 300)
where
  "(TVar i)[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> =
     (if k < i then TVar (i - 1) else if i = k then \<up>\<^sub>\<tau> k 0 S else TVar i)"
| "Top[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> = Top"
| "(T \<rightarrow> U)[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> = T[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> \<rightarrow> U[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>"
| "(\<forall><:T. U)[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> = (\<forall><:T[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>. U[k+1 \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>)"

primrec decT :: "nat \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> type"  ("\<down>\<^sub>\<tau>")
where
  "\<down>\<^sub>\<tau> 0 k T = T"
| "\<down>\<^sub>\<tau> (Suc n) k T = \<down>\<^sub>\<tau> n k (T[k \<mapsto>\<^sub>\<tau> Top]\<^sub>\<tau>)"

primrec subst :: "trm \<Rightarrow> nat \<Rightarrow> trm \<Rightarrow> trm"  ("_[_ \<mapsto> _]" [300, 0, 0] 300)
where
  "(Var i)[k \<mapsto> s] = (if k < i then Var (i - 1) else if i = k then \<up> k 0 s else Var i)"
| "(t \<bullet> u)[k \<mapsto> s] = t[k \<mapsto> s] \<bullet> u[k \<mapsto> s]"
| "(t \<bullet>\<^sub>\<tau> T)[k \<mapsto> s] = t[k \<mapsto> s] \<bullet>\<^sub>\<tau> \<down>\<^sub>\<tau> 1 k T"
| "(\<lambda>:T. t)[k \<mapsto> s] = (\<lambda>:\<down>\<^sub>\<tau> 1 k T. t[k+1 \<mapsto> s])"
| "(\<lambda><:T. t)[k \<mapsto> s] = (\<lambda><:\<down>\<^sub>\<tau> 1 k T. t[k+1 \<mapsto> s])"

primrec substT :: "trm \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> trm"    ("_[_ \<mapsto>\<^sub>\<tau> _]" [300, 0, 0] 300)
where
  "(Var i)[k \<mapsto>\<^sub>\<tau> S] = (if k < i then Var (i - 1) else Var i)"
| "(t \<bullet> u)[k \<mapsto>\<^sub>\<tau> S] = t[k \<mapsto>\<^sub>\<tau> S] \<bullet> u[k \<mapsto>\<^sub>\<tau> S]"
| "(t \<bullet>\<^sub>\<tau> T)[k \<mapsto>\<^sub>\<tau> S] = t[k \<mapsto>\<^sub>\<tau> S] \<bullet>\<^sub>\<tau> T[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>"
| "(\<lambda>:T. t)[k \<mapsto>\<^sub>\<tau> S] = (\<lambda>:T[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>. t[k+1 \<mapsto>\<^sub>\<tau> S])"
| "(\<lambda><:T. t)[k \<mapsto>\<^sub>\<tau> S] = (\<lambda><:T[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>. t[k+1 \<mapsto>\<^sub>\<tau> S])"

text {*
Lifting and substitution extends to typing contexts as follows:
*}

primrec liftE :: "nat \<Rightarrow> nat \<Rightarrow> env \<Rightarrow> env" ("\<up>\<^sub>e")
where
  "\<up>\<^sub>e n k [] = []"
| "\<up>\<^sub>e n k (B \<Colon> \<Gamma>) = mapB (\<up>\<^sub>\<tau> n (k + \<parallel>\<Gamma>\<parallel>)) B \<Colon> \<up>\<^sub>e n k \<Gamma>"

primrec substE :: "env \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> env"  ("_[_ \<mapsto>\<^sub>\<tau> _]\<^sub>e" [300, 0, 0] 300)
where
  "[][k \<mapsto>\<^sub>\<tau> T]\<^sub>e = []"
| "(B \<Colon> \<Gamma>)[k \<mapsto>\<^sub>\<tau> T]\<^sub>e = mapB (\<lambda>U. U[k + \<parallel>\<Gamma>\<parallel> \<mapsto>\<^sub>\<tau> T]\<^sub>\<tau>) B \<Colon> \<Gamma>[k \<mapsto>\<^sub>\<tau> T]\<^sub>e"

primrec decE :: "nat \<Rightarrow> nat \<Rightarrow> env \<Rightarrow> env"  ("\<down>\<^sub>e")
where
  "\<down>\<^sub>e 0 k \<Gamma> = \<Gamma>"
| "\<down>\<^sub>e (Suc n) k \<Gamma> = \<down>\<^sub>e n k (\<Gamma>[k \<mapsto>\<^sub>\<tau> Top]\<^sub>e)"

text {*
Note that in a context of the form @{term "B \<Colon> \<Gamma>"}, all variables in @{term B} with
indices smaller than the length of @{term \<Gamma>} refer to entries in @{term \<Gamma>} and therefore
must not be affected by substitution and lifting. This is the reason why an
additional offset @{term "\<parallel>\<Gamma>\<parallel>"} needs to be added to the index @{term k}
in the second clauses of the above functions. Some standard properties of lifting
and substitution, which can be proved by structural induction on terms and types,
are proved below. Properties of this kind are
quite standard for encodings using de Bruijn indices and can also be found in
papers by Barras and Werner \cite{Barras-Werner-JAR} and Nipkow \cite{Nipkow-JAR01}.
*}

lemma liftE_length [simp]: "\<parallel>\<up>\<^sub>e n k \<Gamma>\<parallel> = \<parallel>\<Gamma>\<parallel>"
  by (induct \<Gamma>) simp_all

lemma substE_length [simp]: "\<parallel>\<Gamma>[k \<mapsto>\<^sub>\<tau> U]\<^sub>e\<parallel> = \<parallel>\<Gamma>\<parallel>"
  by (induct \<Gamma>) simp_all

lemma liftE_nth [simp]:
  "(\<up>\<^sub>e n k \<Gamma>)\<langle>i\<rangle> = map_option (mapB (\<up>\<^sub>\<tau> n (k + \<parallel>\<Gamma>\<parallel> - i - 1))) (\<Gamma>\<langle>i\<rangle>)"
  apply (induct \<Gamma> arbitrary: i)
  apply simp
  apply simp
  apply (case_tac i)
  apply simp
  apply simp
  done

lemma substE_nth [simp]:
  "(\<Gamma>[0 \<mapsto>\<^sub>\<tau> T]\<^sub>e)\<langle>i\<rangle> = map_option (mapB (\<lambda>U. U[\<parallel>\<Gamma>\<parallel> - i - 1 \<mapsto>\<^sub>\<tau> T]\<^sub>\<tau>)) (\<Gamma>\<langle>i\<rangle>)"
  apply (induct \<Gamma> arbitrary: i)
  apply simp
  apply simp
  apply (case_tac i)
  apply simp
  apply simp
  done

lemma liftT_liftT [simp]:
  "i \<le> j \<Longrightarrow> j \<le> i + m \<Longrightarrow> \<up>\<^sub>\<tau> n j (\<up>\<^sub>\<tau> m i T) = \<up>\<^sub>\<tau> (m + n) i T"
  by (induct T arbitrary: i j m n) simp_all

lemma liftT_liftT' [simp]:
  "i + m \<le> j \<Longrightarrow> \<up>\<^sub>\<tau> n j (\<up>\<^sub>\<tau> m i T) = \<up>\<^sub>\<tau> m i (\<up>\<^sub>\<tau> n (j - m) T)"
  apply (induct T arbitrary: i j m n)
  apply simp_all
  apply arith
  apply (subgoal_tac "Suc j - m = Suc (j - m)")
  apply simp
  apply arith
  done

lemma lift_size [simp]: "size (\<up>\<^sub>\<tau> n k T) = size T"
  by (induct T arbitrary: k) simp_all

lemma liftT0 [simp]: "\<up>\<^sub>\<tau> 0 i T = T"
  by (induct T arbitrary: i) simp_all

lemma lift0 [simp]: "\<up> 0 i t = t"
  by (induct t arbitrary: i) simp_all

theorem substT_liftT [simp]:
  "k \<le> k' \<Longrightarrow> k' < k + n \<Longrightarrow> (\<up>\<^sub>\<tau> n k T)[k' \<mapsto>\<^sub>\<tau> U]\<^sub>\<tau> = \<up>\<^sub>\<tau> (n - 1) k T"
  by (induct T arbitrary: k k') simp_all

theorem liftT_substT' [simp]: "k' < k \<Longrightarrow>
  \<up>\<^sub>\<tau> n k (T[k' \<mapsto>\<^sub>\<tau> U]\<^sub>\<tau>) = \<up>\<^sub>\<tau> n (k + 1) T[k' \<mapsto>\<^sub>\<tau> \<up>\<^sub>\<tau> n (k - k') U]\<^sub>\<tau>"
  apply (induct T arbitrary: k k')
  apply simp_all
  apply arith
  done

lemma liftT_substT_Top [simp]:
  "k \<le> k' \<Longrightarrow> \<up>\<^sub>\<tau> n k' (T[k \<mapsto>\<^sub>\<tau> Top]\<^sub>\<tau>) = \<up>\<^sub>\<tau> n (Suc k') T[k \<mapsto>\<^sub>\<tau> Top]\<^sub>\<tau>"
  apply (induct T arbitrary: k k')
  apply simp_all
  apply arith
  done

lemma liftT_substT_strange:
  "\<up>\<^sub>\<tau> n k T[n + k \<mapsto>\<^sub>\<tau> U]\<^sub>\<tau> = \<up>\<^sub>\<tau> n (Suc k) T[k \<mapsto>\<^sub>\<tau> \<up>\<^sub>\<tau> n 0 U]\<^sub>\<tau>"
  apply (induct T arbitrary: n k)
  apply simp_all
  apply (thin_tac "\<And>x. PROP ?P x")
  apply (drule_tac x=n in meta_spec)
  apply (drule_tac x="Suc k" in meta_spec)
  apply simp
  done

lemma lift_lift [simp]:
  "k \<le> k' \<Longrightarrow> k' \<le> k + n \<Longrightarrow> \<up> n' k' (\<up> n k t) = \<up> (n + n') k t"
  by (induct t arbitrary: k k') simp_all

lemma substT_substT:
  "i \<le> j \<Longrightarrow> T[Suc j \<mapsto>\<^sub>\<tau> V]\<^sub>\<tau>[i \<mapsto>\<^sub>\<tau> U[j - i \<mapsto>\<^sub>\<tau> V]\<^sub>\<tau>]\<^sub>\<tau> = T[i \<mapsto>\<^sub>\<tau> U]\<^sub>\<tau>[j \<mapsto>\<^sub>\<tau> V]\<^sub>\<tau>"
  apply (induct T arbitrary: i j U V)
  apply (simp_all add: diff_Suc split add: nat.split)
  apply (thin_tac "\<And>x. PROP ?P x")
  apply (drule_tac x="Suc i" in meta_spec)
  apply (drule_tac x="Suc j" in meta_spec)
  apply simp
  done

subsection {* Well-formedness *}

text {*
\label{sec:wf}
The subtyping and typing judgements to be defined in \secref{sec:subtyping}
and \secref{sec:typing} may only operate on types and contexts that
are well-formed. Intuitively, a type @{term T} is well-formed with respect to a
context @{term \<Gamma>}, if all variables occurring in it are defined in @{term \<Gamma>}.
More precisely, if @{term T} contains a type variable @{term "TVar i"}, then
the @{term i}th element of @{term \<Gamma>} must exist and have the form @{term "TVarB U"}.
*}

inductive
  well_formed :: "env \<Rightarrow> type \<Rightarrow> bool"  ("_ \<turnstile>\<^sub>w\<^sub>f _" [50, 50] 50)
where
  wf_TVar: "\<Gamma>\<langle>i\<rangle> = \<lfloor>TVarB T\<rfloor> \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f TVar i"
| wf_Top: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f Top"
| wf_arrow: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f U \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<rightarrow> U"
| wf_all: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<Longrightarrow> TVarB T \<Colon> \<Gamma> \<turnstile>\<^sub>w\<^sub>f U \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f (\<forall><:T. U)"

text {*
A context @{term "\<Gamma>"} is well-formed, if all types occurring in it only refer to type variables
declared ``further to the right'':
*}

inductive
  well_formedE :: "env \<Rightarrow> bool"  ("_ \<turnstile>\<^sub>w\<^sub>f" [50] 50)
  and well_formedB :: "env \<Rightarrow> binding \<Rightarrow> bool"  ("_ \<turnstile>\<^sub>w\<^sub>f\<^sub>B _" [50, 50] 50)
where
  "\<Gamma> \<turnstile>\<^sub>w\<^sub>f\<^sub>B B \<equiv> \<Gamma> \<turnstile>\<^sub>w\<^sub>f type_ofB B"
| wf_Nil: "[] \<turnstile>\<^sub>w\<^sub>f"
| wf_Cons: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f\<^sub>B B \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> B \<Colon> \<Gamma> \<turnstile>\<^sub>w\<^sub>f"

text {*
The judgement @{text "\<Gamma> \<turnstile>\<^sub>w\<^sub>f\<^sub>B B"}, which denotes well-formedness of the binding @{term B}
with respect to context @{term \<Gamma>}, is just an abbreviation for @{text "\<Gamma> \<turnstile>\<^sub>w\<^sub>f type_ofB B"}.
We now present a number of properties of the well-formedness judgements that will be used
in the proofs in the following sections.
*}

inductive_cases well_formed_cases:
  "\<Gamma> \<turnstile>\<^sub>w\<^sub>f TVar i"
  "\<Gamma> \<turnstile>\<^sub>w\<^sub>f Top"
  "\<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<rightarrow> U"
  "\<Gamma> \<turnstile>\<^sub>w\<^sub>f (\<forall><:T. U)"

inductive_cases well_formedE_cases:
  "B \<Colon> \<Gamma> \<turnstile>\<^sub>w\<^sub>f"

lemma wf_TVarB: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> TVarB T \<Colon> \<Gamma> \<turnstile>\<^sub>w\<^sub>f"
  by (rule wf_Cons) simp_all

lemma wf_VarB: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> VarB T \<Colon> \<Gamma> \<turnstile>\<^sub>w\<^sub>f"
  by (rule wf_Cons) simp_all

lemma map_is_TVarb:
  "map is_TVarB \<Gamma>' = map is_TVarB \<Gamma> \<Longrightarrow>
    \<Gamma>\<langle>i\<rangle> = \<lfloor>TVarB T\<rfloor> \<Longrightarrow> \<exists>T. \<Gamma>'\<langle>i\<rangle> = \<lfloor>TVarB T\<rfloor>"
  apply (induct \<Gamma> arbitrary: \<Gamma>' T i)
  apply simp
  apply (auto split add: nat.split_asm)
  apply (case_tac z)
  apply simp_all
  done

text {*
A type that is well-formed in a context @{term \<Gamma>} is also well-formed in another context
@{term \<Gamma>'} that contains type variable bindings at the same positions as @{term \<Gamma>}:
*}

lemma wf_equallength:
  assumes H: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f T"
  shows "map is_TVarB \<Gamma>' = map is_TVarB \<Gamma> \<Longrightarrow> \<Gamma>' \<turnstile>\<^sub>w\<^sub>f T" using H
  by (induct arbitrary: \<Gamma>') (auto intro: well_formed.intros dest: map_is_TVarb)

text {*
A well-formed context of the form @{term "\<Delta> @ B \<Colon> \<Gamma>"} remains well-formed if we replace
the binding @{term B} by another well-formed binding @{term B'}:
*}

lemma wfE_replace:
  "\<Delta> @ B \<Colon> \<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f\<^sub>B B' \<Longrightarrow> is_TVarB B' = is_TVarB B \<Longrightarrow>
    \<Delta> @ B' \<Colon> \<Gamma> \<turnstile>\<^sub>w\<^sub>f"
  apply (induct \<Delta>)
  apply simp
  apply (erule wf_Cons)
  apply (erule well_formedE_cases)
  apply assumption
  apply simp
  apply (erule well_formedE_cases)
  apply (rule wf_Cons)
  apply (case_tac a)
  apply simp
  apply (rule wf_equallength)
  apply assumption
  apply simp
  apply simp
  apply (rule wf_equallength)
  apply assumption
  apply simp
  apply simp
  done

text {*
The following weakening lemmas can easily be proved by structural induction on
types and contexts:
*}

lemma wf_weaken:
  assumes H: "\<Delta> @ \<Gamma> \<turnstile>\<^sub>w\<^sub>f T"
  shows "\<up>\<^sub>e (Suc 0) 0 \<Delta> @ B \<Colon> \<Gamma> \<turnstile>\<^sub>w\<^sub>f \<up>\<^sub>\<tau> (Suc 0) \<parallel>\<Delta>\<parallel> T"
  using H
  apply (induct "\<Delta> @ \<Gamma>" T arbitrary: \<Delta>)
  apply simp_all
  apply (rule conjI)
  apply (rule impI)
  apply (rule wf_TVar)
  apply simp
  apply (rule impI)
  apply (rule wf_TVar)
  apply (subgoal_tac "Suc i - \<parallel>\<Delta>\<parallel> = Suc (i - \<parallel>\<Delta>\<parallel>)")
  apply simp
  apply arith
  apply (rule wf_Top)
  apply (rule wf_arrow)
  apply simp
  apply simp
  apply (rule wf_all)
  apply simp
  apply (drule_tac x="TVarB T \<Colon> \<Delta>" in meta_spec)
  apply simp
  done

lemma wf_weaken': "\<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<Longrightarrow> \<Delta> @ \<Gamma> \<turnstile>\<^sub>w\<^sub>f \<up>\<^sub>\<tau> \<parallel>\<Delta>\<parallel> 0 T"
  apply (induct \<Delta>)
  apply simp_all
  apply (drule_tac B=a in wf_weaken [of "[]", simplified])
  apply simp
  done

text {*
Intuitively, lemma @{text wf_weaken} states that a type @{term T} which is well-formed
in a context is still well-formed in a larger context, whereas lemma @{text wfE_weaken}
states that a well-formed context remains well-formed when extended with a
well-formed binding. Owing to the encoding of variables using de Bruijn
indices, the statements of the above lemmas involve additional lifting functions.
The typing judgement, which will be described in \secref{sec:typing}, involves
the lookup of variables in a context. It has already been pointed out earlier that each
entry in a context may only depend on types declared ``further to the right''. To ensure that
a type @{term T} stored at position @{term i} in an environment @{term \<Gamma>} is valid in the full
environment, as opposed to the smaller environment consisting only of the entries in
@{term \<Gamma>} at positions greater than @{term i}, we need to increment the indices of all
free type variables in @{term T} by @{term "Suc i"}:
*}

lemma wf_liftB:
  assumes H: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f"
  shows "\<Gamma>\<langle>i\<rangle> = \<lfloor>VarB T\<rfloor> \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f \<up>\<^sub>\<tau> (Suc i) 0 T"
  using H
  apply (induct arbitrary: i)
  apply simp
  apply (simp split add: nat.split_asm)
  apply (frule_tac B="VarB T" in wf_weaken [of "[]", simplified])
  apply simp+
  apply (rename_tac nat)
  apply (drule_tac x=nat in meta_spec)
  apply simp
  apply (frule_tac T="\<up>\<^sub>\<tau> (Suc nat) 0 T" in wf_weaken [of "[]", simplified])
  apply simp
  done

text {*
We also need lemmas stating that substitution of well-formed types preserves the well-formedness
of types and contexts:
*}

theorem wf_subst:
  "\<Delta> @ B \<Colon> \<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f U \<Longrightarrow> \<Delta>[0 \<mapsto>\<^sub>\<tau> U]\<^sub>e @ \<Gamma> \<turnstile>\<^sub>w\<^sub>f T[\<parallel>\<Delta>\<parallel> \<mapsto>\<^sub>\<tau> U]\<^sub>\<tau>"
  apply (induct T arbitrary: \<Delta>)
  apply simp_all
  apply (rule conjI)
  apply (rule impI)
  apply (drule_tac \<Gamma>=\<Gamma> and \<Delta>="\<Delta>[0 \<mapsto>\<^sub>\<tau> U]\<^sub>e" in wf_weaken')
  apply simp
  apply (rule impI conjI)+
  apply (erule well_formed_cases)
  apply (rule wf_TVar)
  apply (simp split add: nat.split_asm)
  apply (rename_tac nat \<Delta> T nata)
  apply (subgoal_tac "\<parallel>\<Delta>\<parallel> \<le> nat - Suc 0")
  apply (subgoal_tac "nat - Suc \<parallel>\<Delta>\<parallel> = nata")
  apply (simp (no_asm_simp))
  apply arith
  apply arith
  apply (rule impI)
  apply (erule well_formed_cases)
  apply (rule wf_TVar)
  apply simp
  apply (rule wf_Top)
  apply (erule well_formed_cases)
  apply (rule wf_arrow)
  apply simp+
  apply (erule well_formed_cases)
  apply (rule wf_all)
  apply simp
  apply (thin_tac "\<And>x. PROP ?P x")
  apply (drule_tac x="TVarB T1 \<Colon> \<Delta>" in meta_spec)
  apply simp
  done

theorem wfE_subst: "\<Delta> @ B \<Colon> \<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f U \<Longrightarrow> \<Delta>[0 \<mapsto>\<^sub>\<tau> U]\<^sub>e @ \<Gamma> \<turnstile>\<^sub>w\<^sub>f"
  apply (induct \<Delta>)
  apply simp
  apply (erule well_formedE_cases)
  apply assumption
  apply simp
  apply (case_tac a)
  apply (erule well_formedE_cases)
  apply (rule wf_Cons)
  apply simp
  apply (rule wf_subst)
  apply assumption+
  apply simp
  apply (erule well_formedE_cases)
  apply (rule wf_Cons)
  apply simp
  apply (rule wf_subst)
  apply assumption+
  done

subsection {* Subtyping *}

text {*
\label{sec:subtyping}
We now come to the definition of the subtyping judgement @{text "\<Gamma> \<turnstile> T <: U"}.
*}

inductive
  subtyping :: "env \<Rightarrow> type \<Rightarrow> type \<Rightarrow> bool"  ("_ \<turnstile> _ <: _" [50, 50, 50] 50)
where
  SA_Top: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f S \<Longrightarrow> \<Gamma> \<turnstile> S <: Top"
| SA_refl_TVar: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f TVar i \<Longrightarrow> \<Gamma> \<turnstile> TVar i <: TVar i"
| SA_trans_TVar: "\<Gamma>\<langle>i\<rangle> = \<lfloor>TVarB U\<rfloor> \<Longrightarrow>
    \<Gamma> \<turnstile> \<up>\<^sub>\<tau> (Suc i) 0 U <: T \<Longrightarrow> \<Gamma> \<turnstile> TVar i <: T"
| SA_arrow: "\<Gamma> \<turnstile> T\<^sub>1 <: S\<^sub>1 \<Longrightarrow> \<Gamma> \<turnstile> S\<^sub>2 <: T\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> S\<^sub>1 \<rightarrow> S\<^sub>2 <: T\<^sub>1 \<rightarrow> T\<^sub>2"
| SA_all: "\<Gamma> \<turnstile> T\<^sub>1 <: S\<^sub>1 \<Longrightarrow> TVarB T\<^sub>1 \<Colon> \<Gamma> \<turnstile> S\<^sub>2 <: T\<^sub>2 \<Longrightarrow>
    \<Gamma> \<turnstile> (\<forall><:S\<^sub>1. S\<^sub>2) <: (\<forall><:T\<^sub>1. T\<^sub>2)"

text {*
The rules @{text SA_Top} and @{text SA_refl_TVar}, which appear at the leaves of
the derivation tree for a judgement @{term "\<Gamma> \<turnstile> T <: U"}, contain additional
side conditions ensuring the well-formedness of the contexts and types involved.
In order for the rule @{text SA_trans_TVar} to be applicable, the context @{term \<Gamma>}
must be of the form \mbox{@{term "\<Gamma>\<^sub>1 @ B \<Colon> \<Gamma>\<^sub>2"}}, where @{term "\<Gamma>\<^sub>1"} has the length @{term i}.
Since the indices of variables in @{term B} can only refer to variables defined in
@{term "\<Gamma>\<^sub>2"}, they have to be incremented by @{term "Suc i"} to ensure that they point
to the right variables in the larger context @{text \<Gamma>}.
*}

lemma wf_subtype_env:
  assumes PQ: "\<Gamma> \<turnstile> P <: Q"
  shows "\<Gamma> \<turnstile>\<^sub>w\<^sub>f" using PQ
  by induct assumption+

lemma wf_subtype:
  assumes PQ: "\<Gamma> \<turnstile> P <: Q"
  shows "\<Gamma> \<turnstile>\<^sub>w\<^sub>f P \<and> \<Gamma> \<turnstile>\<^sub>w\<^sub>f Q" using PQ
  by induct (auto intro: well_formed.intros elim!: wf_equallength)

lemma wf_subtypeE:
  assumes H: "\<Gamma> \<turnstile> T <: U"
  and H': "\<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f U \<Longrightarrow> P"
  shows "P"
  apply (rule H')
  apply (rule wf_subtype_env)
  apply (rule H)
  apply (rule wf_subtype [OF H, THEN conjunct1])
  apply (rule wf_subtype [OF H, THEN conjunct2])
  done

text {*
By induction on the derivation of @{term "\<Gamma> \<turnstile> T <: U"}, it can easily be shown
that all types and contexts occurring in a subtyping judgement must be well-formed:
*}

lemma wf_subtype_conj:
  "\<Gamma> \<turnstile> T <: U \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f \<and> \<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<and> \<Gamma> \<turnstile>\<^sub>w\<^sub>f U"
  by (erule wf_subtypeE) iprover

text {*
By induction on types, we can prove that the subtyping relation is reflexive:
*}

lemma subtype_refl: -- {* A.1 *}
  "\<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<Longrightarrow> \<Gamma> \<turnstile> T <: T"
  by (induct T arbitrary: \<Gamma>) (blast intro:
    subtyping.intros wf_Nil wf_TVarB elim: well_formed_cases)+

text {*
The weakening lemma for the subtyping relation is proved in two steps:
by induction on the derivation of the subtyping relation, we first prove
that inserting a single type into the context preserves subtyping:
*}

lemma subtype_weaken:
  assumes H: "\<Delta> @ \<Gamma> \<turnstile> P <: Q"
  and wf: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f\<^sub>B B"
  shows "\<up>\<^sub>e 1 0 \<Delta> @ B \<Colon> \<Gamma> \<turnstile> \<up>\<^sub>\<tau> 1 \<parallel>\<Delta>\<parallel> P <: \<up>\<^sub>\<tau> 1 \<parallel>\<Delta>\<parallel> Q" using H
proof (induct "\<Delta> @ \<Gamma>" P Q arbitrary: \<Delta>)
  case SA_Top
  with wf show ?case
    by (auto intro: subtyping.SA_Top wfE_weaken wf_weaken)
next
  case SA_refl_TVar
  with wf show ?case
    by (auto intro!: subtyping.SA_refl_TVar wfE_weaken dest: wf_weaken)
next
  case (SA_trans_TVar i U T)
  thus ?case
  proof (cases "i < \<parallel>\<Delta>\<parallel>")
    case True
    with SA_trans_TVar
    have "(\<up>\<^sub>e 1 0 \<Delta> @ B \<Colon> \<Gamma>)\<langle>i\<rangle> = \<lfloor>TVarB (\<up>\<^sub>\<tau> 1 (\<parallel>\<Delta>\<parallel> - Suc i) U)\<rfloor>"
      by simp
    moreover from True SA_trans_TVar
    have "\<up>\<^sub>e 1 0 \<Delta> @ B \<Colon> \<Gamma> \<turnstile>
      \<up>\<^sub>\<tau> (Suc i) 0 (\<up>\<^sub>\<tau> 1 (\<parallel>\<Delta>\<parallel> - Suc i) U) <: \<up>\<^sub>\<tau> 1 \<parallel>\<Delta>\<parallel> T"
      by simp
    ultimately have "\<up>\<^sub>e 1 0 \<Delta> @ B \<Colon> \<Gamma> \<turnstile> TVar i <: \<up>\<^sub>\<tau> 1 \<parallel>\<Delta>\<parallel> T"
      by (rule subtyping.SA_trans_TVar)
    with True show ?thesis by simp
  next
    case False
    then have "Suc i - \<parallel>\<Delta>\<parallel> = Suc (i - \<parallel>\<Delta>\<parallel>)" by arith
    with False SA_trans_TVar have "(\<up>\<^sub>e 1 0 \<Delta> @ B \<Colon> \<Gamma>)\<langle>Suc i\<rangle> = \<lfloor>TVarB U\<rfloor>"
      by simp
    moreover from False SA_trans_TVar
    have "\<up>\<^sub>e 1 0 \<Delta> @ B \<Colon> \<Gamma> \<turnstile> \<up>\<^sub>\<tau> (Suc (Suc i)) 0 U <: \<up>\<^sub>\<tau> 1 \<parallel>\<Delta>\<parallel> T"
      by simp
    ultimately have "\<up>\<^sub>e 1 0 \<Delta> @ B \<Colon> \<Gamma> \<turnstile> TVar (Suc i) <: \<up>\<^sub>\<tau> 1 \<parallel>\<Delta>\<parallel> T"
      by (rule subtyping.SA_trans_TVar)
    with False show ?thesis by simp
  qed
next
  case SA_arrow
  thus ?case by simp (iprover intro: subtyping.SA_arrow)
next
  case (SA_all T\<^sub>1 S\<^sub>1 S\<^sub>2 T\<^sub>2 \<Delta>)
  with SA_all(4) [of "TVarB T\<^sub>1 \<Colon> \<Delta>"]
  show ?case by simp (iprover intro: subtyping.SA_all)
qed

text {*
All cases are trivial, except for the @{text SA_trans_TVar} case, which
requires a case distinction on whether the index of the variable is smaller
than @{term "\<parallel>\<Delta>\<parallel>"}.
The stronger result that appending a new context @{term \<Delta>} to a context
@{term \<Gamma>} preserves subtyping can be proved by induction on @{term \<Delta>},
using the previous result in the induction step:
*}

lemma subtype_weaken': -- {* A.2 *}
  "\<Gamma> \<turnstile> P <: Q \<Longrightarrow> \<Delta> @ \<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> \<Delta> @ \<Gamma> \<turnstile> \<up>\<^sub>\<tau> \<parallel>\<Delta>\<parallel> 0 P <: \<up>\<^sub>\<tau> \<parallel>\<Delta>\<parallel> 0 Q"
  apply (induct \<Delta>)
  apply simp_all
  apply (erule well_formedE_cases)
  apply simp
  apply (drule_tac B="a" and \<Gamma>="\<Delta> @ \<Gamma>" in subtype_weaken [of "[]", simplified])
  apply simp_all
  done

text {*
An unrestricted transitivity rule has the disadvantage that it can
be applied in any situation. In order to make the above definition of the
subtyping relation {\it syntax-directed}, the transitivity rule @{text "SA_trans_TVar"}
is restricted to the case where the type on the left-hand side of the @{text "<:"}
operator is a variable. However, the unrestricted transitivity rule
can be derived from this definition.
In order for the proof to go through, we have to simultaneously prove
another property called {\it narrowing}.
The two properties are proved by nested induction. The outer induction
is on the size of the type @{term Q}, whereas the two inner inductions for
proving transitivity and narrowing are on the derivation of the
subtyping judgements. The transitivity property is needed in the proof of
narrowing, which is by induction on the derivation of \mbox{@{term "\<Delta> @ TVarB Q \<Colon> \<Gamma> \<turnstile> M <: N"}}.
In the case corresponding to the rule @{text SA_trans_TVar}, we must prove
\mbox{@{term "\<Delta> @ TVarB P \<Colon> \<Gamma> \<turnstile> TVar i <: T"}}. The only interesting case
is the one where @{term "i = \<parallel>\<Delta>\<parallel>"}. By induction hypothesis, we know that
@{term "\<Delta> @ TVarB P \<Colon> \<Gamma> \<turnstile> \<up>\<^sub>\<tau> (i+1) 0 Q <: T"} and
@{term "(\<Delta> @ TVarB Q \<Colon> \<Gamma>)\<langle>i\<rangle> = \<lfloor>TVarB Q\<rfloor>"}.
By assumption, we have @{term "\<Gamma> \<turnstile> P <: Q"} and hence
\mbox{@{term "\<Delta> @ TVarB P \<Colon> \<Gamma> \<turnstile> \<up>\<^sub>\<tau> (i+1) 0 P <: \<up>\<^sub>\<tau> (i+1) 0 Q"}} by weakening.
Since @{term "\<up>\<^sub>\<tau> (i+1) 0 Q"} has the same size as @{term Q}, we can use
the transitivity property, which yields
@{term "\<Delta> @ TVarB P \<Colon> \<Gamma> \<turnstile> \<up>\<^sub>\<tau> (i+1) 0 P <: T"}. The claim then follows
easily by an application of @{text SA_trans_TVar}.
*}

text {*
In the proof of the preservation theorem presented in \secref{sec:evaluation},
we will also need a substitution theorem, which is proved by
induction on the subtyping derivation:
*}

lemma substT_subtype: -- {* A.10 *}
  assumes H: "\<Delta> @ TVarB Q \<Colon> \<Gamma> \<turnstile> S <: T"
  shows "\<Gamma> \<turnstile> P <: Q \<Longrightarrow> \<Delta>[0 \<mapsto>\<^sub>\<tau> P]\<^sub>e @ \<Gamma> \<turnstile> S[\<parallel>\<Delta>\<parallel> \<mapsto>\<^sub>\<tau> P]\<^sub>\<tau> <: T[\<parallel>\<Delta>\<parallel> \<mapsto>\<^sub>\<tau> P]\<^sub>\<tau>"
  using H
  apply (induct "\<Delta> @ TVarB Q \<Colon> \<Gamma>" S T arbitrary: \<Delta>)
  apply simp_all
  apply (rule SA_Top)
  apply (rule wfE_subst)
  apply assumption
  apply (erule wf_subtypeE)
  apply assumption
  apply (rule wf_subst)
  apply assumption
  apply (erule wf_subtypeE)
  apply assumption
  apply (rule impI conjI)+
  apply (rule subtype_refl)
  apply (rule wfE_subst)
  apply assumption
  apply (erule wf_subtypeE)
  apply assumption
  apply (erule wf_subtypeE)
  apply (drule_tac T=P and \<Delta>="\<Delta>[0 \<mapsto>\<^sub>\<tau> P]\<^sub>e" in wf_weaken')
  apply simp
  apply (rule conjI impI)+
  apply (rule SA_refl_TVar)
  apply (rule wfE_subst)
  apply assumption
  apply (erule wf_subtypeE)
  apply assumption
  apply (erule wf_subtypeE)
  apply (drule wf_subst)
  apply assumption
  apply simp
  apply (rule impI)
  apply (rule SA_refl_TVar)
  apply (rule wfE_subst)
  apply assumption
  apply (erule wf_subtypeE)
  apply assumption
  apply (erule wf_subtypeE)
  apply (drule wf_subst)
  apply assumption
  apply simp
  apply (rule conjI impI)+
  apply simp
  apply (drule_tac \<Gamma>=\<Gamma> and \<Delta>="\<Delta>[0 \<mapsto>\<^sub>\<tau> P]\<^sub>e" in subtype_weaken')
  apply (erule wf_subtypeE)+
  apply assumption
  apply simp
  apply (rule subtype_trans(1))
  apply assumption+
  apply (rule conjI impI)+
  apply (rule SA_trans_TVar)
  apply (simp split add: nat.split_asm)
  apply (subgoal_tac "\<parallel>\<Delta>\<parallel> \<le> i - Suc 0")
  apply (rename_tac nat)
  apply (subgoal_tac "i - Suc \<parallel>\<Delta>\<parallel> = nat")
  apply (simp (no_asm_simp))
  apply arith
  apply arith
  apply simp
  apply (rule impI)
  apply (rule SA_trans_TVar)
  apply (simp split add: nat.split_asm)
  apply (subgoal_tac "Suc (\<parallel>\<Delta>\<parallel> - Suc 0) = \<parallel>\<Delta>\<parallel>")
  apply (simp (no_asm_simp))
  apply arith
  apply (rule SA_arrow)
  apply simp+
  apply (rule SA_all)
  apply simp
  apply (drule_tac x="TVarB T\<^sub>1 \<Colon> \<Delta>" in meta_spec)
  apply simp
  done

lemma subst_subtype:
  assumes H: "\<Delta> @ VarB V \<Colon> \<Gamma> \<turnstile> T <: U"
  shows "\<down>\<^sub>e 1 0 \<Delta> @ \<Gamma> \<turnstile> \<down>\<^sub>\<tau> 1 \<parallel>\<Delta>\<parallel> T <: \<down>\<^sub>\<tau> 1 \<parallel>\<Delta>\<parallel> U"
  using H
  apply (induct "\<Delta> @ VarB V \<Colon> \<Gamma>" T U arbitrary: \<Delta>)
  apply simp_all
  apply (rule SA_Top)
  apply (rule wfE_subst)
  apply assumption
  apply (rule wf_Top)
  apply (rule wf_subst)
  apply assumption
  apply (rule wf_Top)
  apply (rule impI conjI)+
  apply (rule SA_Top)
  apply (rule wfE_subst)
  apply assumption
  apply (rule wf_Top)+
  apply (rule conjI impI)+
  apply (rule SA_refl_TVar)
  apply (rule wfE_subst)
  apply assumption
  apply (rule wf_Top)
  apply (drule wf_subst)
  apply (rule wf_Top)
  apply simp
  apply (rule impI)
  apply (rule SA_refl_TVar)
  apply (rule wfE_subst)
  apply assumption
  apply (rule wf_Top)
  apply (drule wf_subst)
  apply (rule wf_Top)
  apply simp
  apply (rule conjI impI)+
  apply simp
  apply (rule conjI impI)+
  apply (simp split add: nat.split_asm)
  apply (rule SA_trans_TVar)
  apply (subgoal_tac "\<parallel>\<Delta>\<parallel> \<le> i - Suc 0")
  apply (rename_tac nat)
  apply (subgoal_tac "i - Suc \<parallel>\<Delta>\<parallel> = nat")
  apply (simp (no_asm_simp))
  apply arith
  apply arith
  apply simp
  apply (rule impI)
  apply (rule SA_trans_TVar)
  apply simp
  apply (subgoal_tac "0 < \<parallel>\<Delta>\<parallel>")
  apply simp
  apply arith
  apply (rule SA_arrow)
  apply simp+
  apply (rule SA_all)
  apply simp
  apply (drule_tac x="TVarB T\<^sub>1 \<Colon> \<Delta>" in meta_spec)
  apply simp
  done

subsection {* Typing *}

text {*
\label{sec:typing}
We are now ready to give a definition of the typing judgement @{text "\<Gamma> \<turnstile> t : T"}.
*}

inductive
  typing :: "env \<Rightarrow> trm \<Rightarrow> type \<Rightarrow> bool"    ("_ \<turnstile> _ : _" [50, 50, 50] 50)
where
  T_Var: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> \<Gamma>\<langle>i\<rangle> = \<lfloor>VarB U\<rfloor> \<Longrightarrow> T = \<up>\<^sub>\<tau> (Suc i) 0 U \<Longrightarrow> \<Gamma> \<turnstile> Var i : T"
| T_Abs: "VarB T\<^sub>1 \<Colon> \<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> (\<lambda>:T\<^sub>1. t\<^sub>2) : T\<^sub>1 \<rightarrow> \<down>\<^sub>\<tau> 1 0 T\<^sub>2"
| T_App: "\<Gamma> \<turnstile> t\<^sub>1 : T\<^sub>1\<^sub>1 \<rightarrow> T\<^sub>1\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>1\<^sub>1 \<Longrightarrow> \<Gamma> \<turnstile> t\<^sub>1 \<bullet> t\<^sub>2 : T\<^sub>1\<^sub>2"
| T_TAbs: "TVarB T\<^sub>1 \<Colon> \<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> (\<lambda><:T\<^sub>1. t\<^sub>2) : (\<forall><:T\<^sub>1. T\<^sub>2)"
| T_TApp: "\<Gamma> \<turnstile> t\<^sub>1 : (\<forall><:T\<^sub>1\<^sub>1. T\<^sub>1\<^sub>2) \<Longrightarrow> \<Gamma> \<turnstile> T\<^sub>2 <: T\<^sub>1\<^sub>1 \<Longrightarrow>
    \<Gamma> \<turnstile> t\<^sub>1 \<bullet>\<^sub>\<tau> T\<^sub>2 : T\<^sub>1\<^sub>2[0 \<mapsto>\<^sub>\<tau> T\<^sub>2]\<^sub>\<tau>"
| T_Sub: "\<Gamma> \<turnstile> t : S \<Longrightarrow> \<Gamma> \<turnstile> S <: T \<Longrightarrow> \<Gamma> \<turnstile> t : T"

text {*
Note that in the rule @{text T_Var}, the indices of the type @{term U} looked up in
the context @{term \<Gamma>} need to be incremented in order for the type to be well-formed
with respect to @{term \<Gamma>}. In the rule @{text T_Abs}, the type @{term "T\<^sub>2"} of the
abstraction body @{term "t\<^sub>2"} may not contain the variable with index @{text 0},
since it is a term variable. To compensate for the disappearance of the context
element @{term "VarB T\<^sub>1"} in the conclusion of thy typing rule, the indices of all
free type variables in @{term "T\<^sub>2"} have to be decremented by @{text 1}.
*}

theorem wf_typeE1:
  assumes H: "\<Gamma> \<turnstile> t : T"
  shows "\<Gamma> \<turnstile>\<^sub>w\<^sub>f" using H
  by induct (blast elim: well_formedE_cases)+

theorem wf_typeE2:
  assumes H: "\<Gamma> \<turnstile> t : T"
  shows "\<Gamma> \<turnstile>\<^sub>w\<^sub>f T" using H
  apply induct
  apply simp
  apply (rule wf_liftB)
  apply assumption+
  apply (drule wf_typeE1)+
  apply (erule well_formedE_cases)+
  apply (rule wf_arrow)
  apply simp
  apply simp
  apply (rule wf_subst [of "[]", simplified])
  apply assumption
  apply (rule wf_Top)
  apply (erule well_formed_cases)
  apply assumption
  apply (rule wf_all)
  apply (drule wf_typeE1)
  apply (erule well_formedE_cases)
  apply simp
  apply assumption
  apply (erule well_formed_cases)
  apply (rule wf_subst [of "[]", simplified])
  apply assumption
  apply (erule wf_subtypeE)
  apply assumption
  apply (erule wf_subtypeE)
  apply assumption
  done

text {*
Like for the subtyping judgement, we can again prove that all types and contexts
involved in a typing judgement are well-formed:
*}
lemma wf_type_conj: "\<Gamma> \<turnstile> t : T \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f \<and> \<Gamma> \<turnstile>\<^sub>w\<^sub>f T"
  by (frule wf_typeE1, drule wf_typeE2) iprover

text {*
The narrowing theorem for the typing judgement states that replacing the type
of a variable in the context by a subtype preserves typability:
*}

lemma narrow_type: -- {* A.7 *}
  assumes H: "\<Delta> @ TVarB Q \<Colon> \<Gamma> \<turnstile> t : T"
  shows "\<Gamma> \<turnstile> P <: Q \<Longrightarrow> \<Delta> @ TVarB P \<Colon> \<Gamma> \<turnstile> t : T"
  using H
  apply (induct "\<Delta> @ TVarB Q \<Colon> \<Gamma>" t T arbitrary: \<Delta>)
  apply simp_all
  apply (rule T_Var)
  apply (erule wfE_replace)
  apply (erule wf_subtypeE)
  apply simp+
  apply (case_tac "i < \<parallel>\<Delta>\<parallel>")
  apply simp
  apply (case_tac "i = \<parallel>\<Delta>\<parallel>")
  apply simp
  apply (simp split add: nat.split nat.split_asm)+
  apply (rule T_Abs [simplified])
  apply (drule_tac x="VarB T\<^sub>1 \<Colon> \<Delta>" in meta_spec)
  apply simp
  apply (rule_tac T\<^sub>1\<^sub>1=T\<^sub>1\<^sub>1 in T_App)
  apply simp+
  apply (rule T_TAbs)
  apply (drule_tac x="TVarB T\<^sub>1 \<Colon> \<Delta>" in meta_spec)
  apply simp
  apply (rule_tac T\<^sub>1\<^sub>1=T\<^sub>1\<^sub>1 in T_TApp)
  apply simp
  apply (rule subtype_trans(2))
  apply assumption+
  apply (rule_tac S=S in T_Sub)
  apply simp
  apply (rule subtype_trans(2))
  apply assumption+
  done

lemma subtype_refl':
  assumes t: "\<Gamma> \<turnstile> t : T"
  shows "\<Gamma> \<turnstile> T <: T"
proof (rule subtype_refl)
  from t show "\<Gamma> \<turnstile>\<^sub>w\<^sub>f" by (rule wf_typeE1)
  from t show "\<Gamma> \<turnstile>\<^sub>w\<^sub>f T" by (rule wf_typeE2)
qed

lemma Abs_type: -- {* A.13(1) *}
  assumes H: "\<Gamma> \<turnstile> (\<lambda>:S. s) : T"
  shows "\<Gamma> \<turnstile> T <: U \<rightarrow> U' \<Longrightarrow>
    (\<And>S'. \<Gamma> \<turnstile> U <: S \<Longrightarrow> VarB S \<Colon> \<Gamma> \<turnstile> s : S' \<Longrightarrow>
      \<Gamma> \<turnstile> \<down>\<^sub>\<tau> 1 0 S' <: U' \<Longrightarrow> P) \<Longrightarrow> P"
  using H
proof (induct \<Gamma> "\<lambda>:S. s" T arbitrary: U U' S s P)
  case (T_Abs T\<^sub>1 \<Gamma> t\<^sub>2 T\<^sub>2)
  from `\<Gamma> \<turnstile> T\<^sub>1 \<rightarrow> \<down>\<^sub>\<tau> 1 0 T\<^sub>2 <: U \<rightarrow> U'`
  obtain ty1: "\<Gamma> \<turnstile> U <: T\<^sub>1" and ty2: "\<Gamma> \<turnstile> \<down>\<^sub>\<tau> 1 0 T\<^sub>2 <: U'"
    by cases simp_all
  from ty1 `VarB T\<^sub>1 \<Colon> \<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>2` ty2
  show ?case by (rule T_Abs)
next
  case (T_Sub \<Gamma> S' T)
  from `\<Gamma> \<turnstile> S' <: T` and `\<Gamma> \<turnstile> T <: U \<rightarrow> U'`
  have "\<Gamma> \<turnstile> S' <: U \<rightarrow> U'" by (rule subtype_trans(1))
  then show ?case
    by (rule T_Sub) (rule T_Sub(5))
qed

lemma Abs_type':
  assumes H: "\<Gamma> \<turnstile> (\<lambda>:S. s) : U \<rightarrow> U'"
  and R: "\<And>S'. \<Gamma> \<turnstile> U <: S \<Longrightarrow> VarB S \<Colon> \<Gamma> \<turnstile> s : S' \<Longrightarrow>
    \<Gamma> \<turnstile> \<down>\<^sub>\<tau> 1 0 S' <: U' \<Longrightarrow> P"
  shows "P" using H subtype_refl' [OF H]
  by (rule Abs_type) (rule R)

lemma TAbs_type: -- {* A.13(2) *}
  assumes H: "\<Gamma> \<turnstile> (\<lambda><:S. s) : T"
  shows "\<Gamma> \<turnstile> T <: (\<forall><:U. U') \<Longrightarrow>
    (\<And>S'. \<Gamma> \<turnstile> U <: S \<Longrightarrow> TVarB U \<Colon> \<Gamma> \<turnstile> s : S' \<Longrightarrow>
      TVarB U \<Colon> \<Gamma> \<turnstile> S' <: U' \<Longrightarrow> P) \<Longrightarrow> P"
  using H
proof (induct \<Gamma> "\<lambda><:S. s" T arbitrary: U U' S s P)
  case (T_TAbs T\<^sub>1 \<Gamma> t\<^sub>2 T\<^sub>2)
  from `\<Gamma> \<turnstile> (\<forall><:T\<^sub>1. T\<^sub>2) <: (\<forall><:U. U')`
  obtain ty1: "\<Gamma> \<turnstile> U <: T\<^sub>1" and ty2: "TVarB U \<Colon> \<Gamma> \<turnstile> T\<^sub>2 <: U'"
    by cases simp_all
  from `TVarB T\<^sub>1 \<Colon> \<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>2`
  have "TVarB U \<Colon> \<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>2" using ty1
    by (rule narrow_type [of "[]", simplified])
  with ty1 show ?case using ty2 by (rule T_TAbs)
next
  case (T_Sub \<Gamma> S' T)
  from `\<Gamma> \<turnstile> S' <: T` and `\<Gamma> \<turnstile> T <: (\<forall><:U. U')`
  have "\<Gamma> \<turnstile> S' <: (\<forall><:U. U')" by (rule subtype_trans(1))
  then show ?case
    by (rule T_Sub) (rule T_Sub(5))
qed

lemma TAbs_type':
  assumes H: "\<Gamma> \<turnstile> (\<lambda><:S. s) : (\<forall><:U. U')"
  and R: "\<And>S'. \<Gamma> \<turnstile> U <: S \<Longrightarrow> TVarB U \<Colon> \<Gamma> \<turnstile> s : S' \<Longrightarrow>
    TVarB U \<Colon> \<Gamma> \<turnstile> S' <: U' \<Longrightarrow> P"
  shows "P" using H subtype_refl' [OF H]
  by (rule TAbs_type) (rule R)

lemma T_eq: "\<Gamma> \<turnstile> t : T \<Longrightarrow> T = T' \<Longrightarrow> \<Gamma> \<turnstile> t : T'" by simp

text {*
The weakening theorem states that inserting a binding @{term B}
does not affect typing:
*}

lemma type_weaken:
  assumes H: "\<Delta> @ \<Gamma> \<turnstile> t : T"
  shows "\<Gamma> \<turnstile>\<^sub>w\<^sub>f\<^sub>B B \<Longrightarrow>
    \<up>\<^sub>e 1 0 \<Delta> @ B \<Colon> \<Gamma> \<turnstile> \<up> 1 \<parallel>\<Delta>\<parallel> t : \<up>\<^sub>\<tau> 1 \<parallel>\<Delta>\<parallel> T" using H
  apply (induct "\<Delta> @ \<Gamma>" t T arbitrary: \<Delta>)
  apply simp_all
  apply (rule conjI)
  apply (rule impI)
  apply (rule T_Var)
  apply (erule wfE_weaken)
  apply simp+
  apply (rule impI)
  apply (rule T_Var)
  apply (erule wfE_weaken)
  apply assumption
  apply (subgoal_tac "Suc i - \<parallel>\<Delta>\<parallel> = Suc (i - \<parallel>\<Delta>\<parallel>)")
  apply simp
  apply arith
  apply (rule refl)
  apply (rule T_Abs [THEN T_eq])
  apply (drule_tac x="VarB T\<^sub>1 \<Colon> \<Delta>" in meta_spec)
  apply simp
  apply simp
  apply (rule_tac T\<^sub>1\<^sub>1="\<up>\<^sub>\<tau> (Suc 0) \<parallel>\<Delta>\<parallel> T\<^sub>1\<^sub>1" in T_App)
  apply simp
  apply simp
  apply (rule T_TAbs)
  apply (drule_tac x="TVarB T\<^sub>1 \<Colon> \<Delta>" in meta_spec)
  apply simp
  apply (erule_tac T_TApp [THEN T_eq])
  apply (drule subtype_weaken)
  apply simp+
  apply (case_tac \<Delta>)
  apply (simp add: liftT_substT_strange [of _ 0, simplified])+
  apply (rule_tac S="\<up>\<^sub>\<tau> (Suc 0) \<parallel>\<Delta>\<parallel> S" in T_Sub)
  apply simp
  apply (drule subtype_weaken)
  apply simp+
  done

text {*
We can strengthen this result, so as to mean that concatenating a new context
@{term \<Delta>} to the context @{term \<Gamma>} preserves typing:
*}

lemma type_weaken': -- {* A.5(6) *}
  "\<Gamma> \<turnstile> t : T \<Longrightarrow> \<Delta> @ \<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> \<Delta> @ \<Gamma> \<turnstile> \<up> \<parallel>\<Delta>\<parallel> 0 t : \<up>\<^sub>\<tau> \<parallel>\<Delta>\<parallel> 0 T"
  apply (induct \<Delta>)
  apply simp
  apply simp
  apply (erule well_formedE_cases)
  apply simp
  apply (drule_tac B=a in type_weaken [of "[]", simplified])
  apply simp+
  done

text {*
This property is proved by structural induction on the context @{term \<Delta>},
using the previous result in the induction step. In the proof of the preservation
theorem, we will need two substitution theorems for term and type variables,
both of which are proved by induction on the typing derivation.
Since term and type variables are stored in the same context, we again have to
decrement the free type variables in @{term \<Delta>} and @{term T} by @{text 1}
in the substitution rule for term variables in order to compensate for the
disappearance of the variable.
*}

theorem subst_type: -- {* A.8 *}
  assumes H: "\<Delta> @ VarB U \<Colon> \<Gamma> \<turnstile> t : T"
  shows "\<Gamma> \<turnstile> u : U \<Longrightarrow>
    \<down>\<^sub>e 1 0 \<Delta> @ \<Gamma> \<turnstile> t[\<parallel>\<Delta>\<parallel> \<mapsto> u] : \<down>\<^sub>\<tau> 1 \<parallel>\<Delta>\<parallel> T" using H
  apply (induct "\<Delta> @ VarB U \<Colon> \<Gamma>" t T arbitrary: \<Delta>)
  apply simp
  apply (rule conjI)
  apply (rule impI)
  apply simp
  apply (drule_tac \<Delta>="\<Delta>[0 \<mapsto>\<^sub>\<tau> Top]\<^sub>e" in type_weaken')
  apply (rule wfE_subst)
  apply assumption
  apply (rule wf_Top)
  apply simp
  apply (rule impI conjI)+
  apply (simp split add: nat.split_asm)
  apply (rule T_Var)
  apply (erule wfE_subst)
  apply (rule wf_Top)
  apply (subgoal_tac "\<parallel>\<Delta>\<parallel> \<le> i - Suc 0")
  apply (rename_tac nat)
  apply (subgoal_tac "i - Suc \<parallel>\<Delta>\<parallel> = nat")
  apply (simp (no_asm_simp))
  apply arith
  apply arith
  apply simp
  apply (rule impI)
  apply (rule T_Var)
  apply (erule wfE_subst)
  apply (rule wf_Top)
  apply simp
  apply (subgoal_tac "Suc (\<parallel>\<Delta>\<parallel> - Suc 0) = \<parallel>\<Delta>\<parallel>")
  apply (simp (no_asm_simp))
  apply arith
  apply simp
  apply (drule_tac x="VarB T\<^sub>1 \<Colon> \<Delta>" in meta_spec)
  apply (rule T_Abs [THEN T_eq])
  apply simp
  apply (simp add: substT_substT [symmetric])
  apply simp
  apply (rule_tac T\<^sub>1\<^sub>1="T\<^sub>1\<^sub>1[\<parallel>\<Delta>\<parallel> \<mapsto>\<^sub>\<tau> Top]\<^sub>\<tau>" in T_App)
  apply simp+
  apply (rule T_TAbs)
  apply (drule_tac x="TVarB T\<^sub>1 \<Colon> \<Delta>" in meta_spec)
  apply simp
  apply simp
  apply (rule T_TApp [THEN T_eq])
  apply simp
  apply (rule subst_subtype [simplified])
  apply assumption
  apply (simp add: substT_substT [symmetric])
  apply (rule_tac S="S[\<parallel>\<Delta>\<parallel> \<mapsto>\<^sub>\<tau> Top]\<^sub>\<tau>" in T_Sub)
  apply simp
  apply simp
  apply (rule subst_subtype [simplified])
  apply assumption
  done

theorem substT_type: -- {* A.11 *}
  assumes H: "\<Delta> @ TVarB Q \<Colon> \<Gamma> \<turnstile> t : T"
  shows "\<Gamma> \<turnstile> P <: Q \<Longrightarrow>
    \<Delta>[0 \<mapsto>\<^sub>\<tau> P]\<^sub>e @ \<Gamma> \<turnstile> t[\<parallel>\<Delta>\<parallel> \<mapsto>\<^sub>\<tau> P] : T[\<parallel>\<Delta>\<parallel> \<mapsto>\<^sub>\<tau> P]\<^sub>\<tau>" using H
  apply (induct "\<Delta> @ TVarB Q \<Colon> \<Gamma>" t T arbitrary: \<Delta>)
  apply simp_all
  apply (rule impI conjI)+
  apply simp
  apply (rule T_Var)
  apply (erule wfE_subst)
  apply (erule wf_subtypeE)
  apply assumption
  apply (simp split add: nat.split_asm)
  apply (subgoal_tac "\<parallel>\<Delta>\<parallel> \<le> i - Suc 0")
  apply (rename_tac nat)
  apply (subgoal_tac "i - Suc \<parallel>\<Delta>\<parallel> = nat")
  apply (simp (no_asm_simp))
  apply arith
  apply arith
  apply simp
  apply (rule impI)
  apply (case_tac "i = \<parallel>\<Delta>\<parallel>")
  apply simp
  apply (rule T_Var)
  apply (erule wfE_subst)
  apply (erule wf_subtypeE)
  apply assumption
  apply simp
  apply (subgoal_tac "i < \<parallel>\<Delta>\<parallel>")
  apply (subgoal_tac "Suc (\<parallel>\<Delta>\<parallel> - Suc 0) = \<parallel>\<Delta>\<parallel>")
  apply (simp (no_asm_simp))
  apply arith
  apply arith
  apply (rule T_Abs [THEN T_eq])
  apply (drule_tac x="VarB T\<^sub>1 \<Colon> \<Delta>" in meta_spec)
  apply simp
  apply (simp add: substT_substT [symmetric])
  apply (rule_tac T\<^sub>1\<^sub>1="T\<^sub>1\<^sub>1[\<parallel>\<Delta>\<parallel> \<mapsto>\<^sub>\<tau> P]\<^sub>\<tau>" in T_App)
  apply simp+
  apply (rule T_TAbs)
  apply (drule_tac x="TVarB T\<^sub>1 \<Colon> \<Delta>" in meta_spec)
  apply simp
  apply (rule T_TApp [THEN T_eq])
  apply simp
  apply (rule substT_subtype)
  apply assumption
  apply assumption
  apply (simp add: substT_substT [symmetric])
  apply (rule_tac S="S[\<parallel>\<Delta>\<parallel> \<mapsto>\<^sub>\<tau> P]\<^sub>\<tau>" in T_Sub)
  apply simp
  apply (rule substT_subtype)
  apply assumption
  apply assumption
  done

subsection {* Evaluation *}

text {*
\label{sec:evaluation}
For the formalization of the evaluation strategy, it is useful to first define
a set of {\it canonical values} that are not evaluated any further. The canonical
values of call-by-value \fsub{} are exactly the abstractions over term and type variables:
*}

inductive_set
  "value" :: "trm set"
where
  Abs: "(\<lambda>:T. t) \<in> value"
| TAbs: "(\<lambda><:T. t) \<in> value"

text {*
The notion of a @{term value} is now used in the defintion of the evaluation
relation \mbox{@{text "t \<longmapsto> t'"}}. There are several ways for defining this evaluation
relation: Aydemir et al.\ \cite{PoplMark} advocate the use of {\it evaluation
contexts} that allow to separate the description of the ``immediate'' reduction rules,
i.e.\ $\beta$-reduction, from the description of the context in which these reductions
may occur in. The rationale behind this approach is to keep the formalization more modular.
We will take a closer look at this style of presentation in section
\secref{sec:evaluation-ctxt}. For the rest of this section, we will use a different
approach: both the ``immediate'' reductions and the reduction context are described
within the same inductive definition, where the context is described by additional
congruence rules.
*}

inductive
  eval :: "trm \<Rightarrow> trm \<Rightarrow> bool"  (infixl "\<longmapsto>" 50)
where
  E_Abs: "v\<^sub>2 \<in> value \<Longrightarrow> (\<lambda>:T\<^sub>1\<^sub>1. t\<^sub>1\<^sub>2) \<bullet> v\<^sub>2 \<longmapsto> t\<^sub>1\<^sub>2[0 \<mapsto> v\<^sub>2]"
| E_TAbs: "(\<lambda><:T\<^sub>1\<^sub>1. t\<^sub>1\<^sub>2) \<bullet>\<^sub>\<tau> T\<^sub>2 \<longmapsto> t\<^sub>1\<^sub>2[0 \<mapsto>\<^sub>\<tau> T\<^sub>2]"
| E_App1: "t \<longmapsto> t' \<Longrightarrow> t \<bullet> u \<longmapsto> t' \<bullet> u"
| E_App2: "v \<in> value \<Longrightarrow> t \<longmapsto> t' \<Longrightarrow> v \<bullet> t \<longmapsto> v \<bullet> t'"
| E_TApp: "t \<longmapsto> t' \<Longrightarrow> t \<bullet>\<^sub>\<tau> T \<longmapsto> t' \<bullet>\<^sub>\<tau> T"

text {*
Here, the rules @{text E_Abs} and @{text E_TAbs} describe the ``immediate'' reductions,
whereas @{text E_App1}, @{text E_App2}, and @{text E_TApp} are additional congruence
rules describing reductions in a context. The most important theorems of this section
are the {\it preservation} theorem, stating that the reduction of a well-typed term
does not change its type, and the {\it progress} theorem, stating that reduction of
a well-typed term does not ``get stuck'' -- in other words, every well-typed, closed
term @{term t} is either a value, or there is a term @{term t'} to which @{term t}
can be reduced. The preservation theorem
is proved by induction on the derivation of @{term "\<Gamma> \<turnstile> t : T"}, followed by a case
distinction on the last rule used in the derivation of @{term "t \<longmapsto> t'"}.
*}

theorem preservation: -- {* A.20 *}
  assumes H: "\<Gamma> \<turnstile> t : T"
  shows "t \<longmapsto> t' \<Longrightarrow> \<Gamma> \<turnstile> t' : T" using H
proof (induct arbitrary: t')
  case (T_Var \<Gamma> i U T t')
  from `Var i \<longmapsto> t'`
  show ?case by cases
next
  case (T_Abs T\<^sub>1 \<Gamma> t\<^sub>2 T\<^sub>2 t')
  from `(\<lambda>:T\<^sub>1. t\<^sub>2) \<longmapsto> t'`
  show ?case by cases
next
  case (T_App \<Gamma> t\<^sub>1 T\<^sub>1\<^sub>1 T\<^sub>1\<^sub>2 t\<^sub>2 t')
  from `t\<^sub>1 \<bullet> t\<^sub>2 \<longmapsto> t'`
  show ?case
  proof cases
    case (E_Abs T\<^sub>1\<^sub>1' t\<^sub>1\<^sub>2)
    with T_App have "\<Gamma> \<turnstile> (\<lambda>:T\<^sub>1\<^sub>1'. t\<^sub>1\<^sub>2) : T\<^sub>1\<^sub>1 \<rightarrow> T\<^sub>1\<^sub>2" by simp
    then obtain S'
      where T\<^sub>1\<^sub>1: "\<Gamma> \<turnstile> T\<^sub>1\<^sub>1 <: T\<^sub>1\<^sub>1'"
      and t\<^sub>1\<^sub>2: "VarB T\<^sub>1\<^sub>1' \<Colon> \<Gamma> \<turnstile> t\<^sub>1\<^sub>2 : S'"
      and S': "\<Gamma> \<turnstile> S'[0 \<mapsto>\<^sub>\<tau> Top]\<^sub>\<tau> <: T\<^sub>1\<^sub>2" by (rule Abs_type' [simplified]) blast
    from `\<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>1\<^sub>1`
    have "\<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>1\<^sub>1'" using T\<^sub>1\<^sub>1 by (rule T_Sub)
    with t\<^sub>1\<^sub>2 have "\<Gamma> \<turnstile> t\<^sub>1\<^sub>2[0 \<mapsto> t\<^sub>2] : S'[0 \<mapsto>\<^sub>\<tau> Top]\<^sub>\<tau>"
      by (rule subst_type [where \<Delta>="[]", simplified])
    hence "\<Gamma> \<turnstile> t\<^sub>1\<^sub>2[0 \<mapsto> t\<^sub>2] : T\<^sub>1\<^sub>2" using S' by (rule T_Sub)
    with E_Abs show ?thesis by simp
  next
    case (E_App1 t'')
    from `t\<^sub>1 \<longmapsto> t''`
    have "\<Gamma> \<turnstile> t'' : T\<^sub>1\<^sub>1 \<rightarrow> T\<^sub>1\<^sub>2" by (rule T_App)
    hence "\<Gamma> \<turnstile> t'' \<bullet> t\<^sub>2 : T\<^sub>1\<^sub>2" using `\<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>1\<^sub>1`
      by (rule typing.T_App)
    with E_App1 show ?thesis by simp
  next
    case (E_App2 t'')
    from `t\<^sub>2 \<longmapsto> t''`
    have "\<Gamma> \<turnstile> t'' : T\<^sub>1\<^sub>1" by (rule T_App)
    with T_App(1) have "\<Gamma> \<turnstile> t\<^sub>1 \<bullet> t'' : T\<^sub>1\<^sub>2"
      by (rule typing.T_App)
    with E_App2 show ?thesis by simp
  qed
next
  case (T_TAbs T\<^sub>1 \<Gamma> t\<^sub>2 T\<^sub>2 t')
  from `(\<lambda><:T\<^sub>1. t\<^sub>2) \<longmapsto> t'`
  show ?case by cases
next
  case (T_TApp \<Gamma> t\<^sub>1 T\<^sub>1\<^sub>1 T\<^sub>1\<^sub>2 T\<^sub>2 t')
  from `t\<^sub>1 \<bullet>\<^sub>\<tau> T\<^sub>2 \<longmapsto> t'`
  show ?case
  proof cases
    case (E_TAbs T\<^sub>1\<^sub>1' t\<^sub>1\<^sub>2)
    with T_TApp have "\<Gamma> \<turnstile> (\<lambda><:T\<^sub>1\<^sub>1'. t\<^sub>1\<^sub>2) : (\<forall><:T\<^sub>1\<^sub>1. T\<^sub>1\<^sub>2)" by simp
    then obtain S'
      where "TVarB T\<^sub>1\<^sub>1 \<Colon> \<Gamma> \<turnstile> t\<^sub>1\<^sub>2 : S'"
      and "TVarB T\<^sub>1\<^sub>1 \<Colon> \<Gamma> \<turnstile> S' <: T\<^sub>1\<^sub>2" by (rule TAbs_type') blast
    hence "TVarB T\<^sub>1\<^sub>1 \<Colon> \<Gamma> \<turnstile> t\<^sub>1\<^sub>2 : T\<^sub>1\<^sub>2" by (rule T_Sub)
    hence "\<Gamma> \<turnstile> t\<^sub>1\<^sub>2[0 \<mapsto>\<^sub>\<tau> T\<^sub>2] : T\<^sub>1\<^sub>2[0 \<mapsto>\<^sub>\<tau> T\<^sub>2]\<^sub>\<tau>" using T_TApp(3)
      by (rule substT_type [where \<Delta>="[]", simplified])
    with E_TAbs show ?thesis by simp
  next
    case (E_TApp t'')
    from `t\<^sub>1 \<longmapsto> t''`
    have "\<Gamma> \<turnstile> t'' : (\<forall><:T\<^sub>1\<^sub>1. T\<^sub>1\<^sub>2)" by (rule T_TApp)
    hence "\<Gamma> \<turnstile> t'' \<bullet>\<^sub>\<tau> T\<^sub>2 : T\<^sub>1\<^sub>2[0 \<mapsto>\<^sub>\<tau> T\<^sub>2]\<^sub>\<tau>" using `\<Gamma> \<turnstile> T\<^sub>2 <: T\<^sub>1\<^sub>1`
      by (rule typing.T_TApp)
    with E_TApp show ?thesis by simp
  qed
next
  case (T_Sub \<Gamma> t S T t')
  from `t \<longmapsto> t'`
  have "\<Gamma> \<turnstile> t' : S" by (rule T_Sub)
  then show ?case using `\<Gamma> \<turnstile> S <: T`
    by (rule typing.T_Sub)
qed

text {*
The progress theorem is also proved by induction on the derivation of
@{term "[] \<turnstile> t : T"}. In the induction steps, we need the following two lemmas
about {\it canonical forms}
stating that closed values of types @{term "T\<^sub>1 \<rightarrow> T\<^sub>2"} and @{term "\<forall><:T\<^sub>1. T\<^sub>2"}
must be abstractions over term and type variables, respectively.
*}

lemma Fun_canonical: -- {* A.14(1) *}
  assumes ty: "[] \<turnstile> v : T\<^sub>1 \<rightarrow> T\<^sub>2"
  shows "v \<in> value \<Longrightarrow> \<exists>t S. v = (\<lambda>:S. t)" using ty
proof (induct "[]::env" v "T\<^sub>1 \<rightarrow> T\<^sub>2" arbitrary: T\<^sub>1 T\<^sub>2)
  case T_Abs
  show ?case by iprover
next
  case (T_App t\<^sub>1 T\<^sub>1\<^sub>1 t\<^sub>2 T\<^sub>1 T\<^sub>2)
  from `t\<^sub>1 \<bullet> t\<^sub>2 \<in> value`
  show ?case by cases
next
  case (T_TApp t\<^sub>1 T\<^sub>1\<^sub>1 T\<^sub>1\<^sub>2 T\<^sub>2 T\<^sub>1 T\<^sub>2')
  from `t\<^sub>1 \<bullet>\<^sub>\<tau> T\<^sub>2 \<in> value`
  show ?case by cases
next
  case (T_Sub t S T\<^sub>1 T\<^sub>2)
  from `[] \<turnstile> S <: T\<^sub>1 \<rightarrow> T\<^sub>2`
  obtain S\<^sub>1 S\<^sub>2 where S: "S = S\<^sub>1 \<rightarrow> S\<^sub>2"
    by cases (auto simp add: T_Sub)
  show ?case by (rule T_Sub S)+
qed simp

lemma TyAll_canonical: -- {* A.14(3) *}
  assumes ty: "[] \<turnstile> v : (\<forall><:T\<^sub>1. T\<^sub>2)"
  shows "v \<in> value \<Longrightarrow> \<exists>t S. v = (\<lambda><:S. t)" using ty
proof (induct "[]::env" v "\<forall><:T\<^sub>1. T\<^sub>2" arbitrary: T\<^sub>1 T\<^sub>2)
  case (T_App t\<^sub>1 T\<^sub>1\<^sub>1 t\<^sub>2 T\<^sub>1 T\<^sub>2)
  from `t\<^sub>1 \<bullet> t\<^sub>2 \<in> value`
  show ?case by cases
next
  case T_TAbs
  show ?case by iprover
next
  case (T_TApp t\<^sub>1 T\<^sub>1\<^sub>1 T\<^sub>1\<^sub>2 T\<^sub>2 T\<^sub>1 T\<^sub>2')
  from `t\<^sub>1 \<bullet>\<^sub>\<tau> T\<^sub>2 \<in> value`
  show ?case by cases
next
  case (T_Sub t S T\<^sub>1 T\<^sub>2)
  from `[] \<turnstile> S <: (\<forall><:T\<^sub>1. T\<^sub>2)`
  obtain S\<^sub>1 S\<^sub>2 where S: "S = (\<forall><:S\<^sub>1. S\<^sub>2)"
    by cases (auto simp add: T_Sub)
  show ?case by (rule T_Sub S)+
qed simp

theorem progress:
  assumes ty: "[] \<turnstile> t : T"
  shows "t \<in> value \<or> (\<exists>t'. t \<longmapsto> t')" using ty
proof (induct "[]::env" t T)
  case T_Var
  thus ?case by simp
next
  case T_Abs
  from value.Abs show ?case ..
next
  case (T_App t\<^sub>1 T\<^sub>1\<^sub>1 T\<^sub>1\<^sub>2 t\<^sub>2)
  hence "t\<^sub>1 \<in> value \<or> (\<exists>t'. t\<^sub>1 \<longmapsto> t')" by simp
  thus ?case
  proof
    assume t\<^sub>1_val: "t\<^sub>1 \<in> value"
    with T_App obtain t S where t\<^sub>1: "t\<^sub>1 = (\<lambda>:S. t)"
      by (auto dest!: Fun_canonical)
    from T_App have "t\<^sub>2 \<in> value \<or> (\<exists>t'. t\<^sub>2 \<longmapsto> t')" by simp
    thus ?thesis
    proof
      assume "t\<^sub>2 \<in> value"
      with t\<^sub>1 have "t\<^sub>1 \<bullet> t\<^sub>2 \<longmapsto> t[0 \<mapsto> t\<^sub>2]"
        by simp (rule eval.intros)
      thus ?thesis by iprover
    next
      assume "\<exists>t'. t\<^sub>2 \<longmapsto> t'"
      then obtain t' where "t\<^sub>2 \<longmapsto> t'" by iprover
      with t\<^sub>1_val have "t\<^sub>1 \<bullet> t\<^sub>2 \<longmapsto> t\<^sub>1 \<bullet> t'" by (rule eval.intros)
      thus ?thesis by iprover
    qed
  next
    assume "\<exists>t'. t\<^sub>1 \<longmapsto> t'"
    then obtain t' where "t\<^sub>1 \<longmapsto> t'" ..
    hence "t\<^sub>1 \<bullet> t\<^sub>2 \<longmapsto> t' \<bullet> t\<^sub>2" by (rule eval.intros)
    thus ?thesis by iprover
  qed
next
  case T_TAbs
  from value.TAbs show ?case ..
next
  case (T_TApp t\<^sub>1 T\<^sub>1\<^sub>1 T\<^sub>1\<^sub>2 T\<^sub>2)
  hence "t\<^sub>1 \<in> value \<or> (\<exists>t'. t\<^sub>1 \<longmapsto> t')" by simp
  thus ?case
  proof
    assume "t\<^sub>1 \<in> value"
    with T_TApp obtain t S where "t\<^sub>1 = (\<lambda><:S. t)"
      by (auto dest!: TyAll_canonical)
    hence "t\<^sub>1 \<bullet>\<^sub>\<tau> T\<^sub>2 \<longmapsto> t[0 \<mapsto>\<^sub>\<tau> T\<^sub>2]" by simp (rule eval.intros)
    thus ?thesis by iprover
  next
    assume "\<exists>t'. t\<^sub>1 \<longmapsto> t'"
    then obtain t' where "t\<^sub>1 \<longmapsto> t'" ..
    hence "t\<^sub>1 \<bullet>\<^sub>\<tau> T\<^sub>2 \<longmapsto> t' \<bullet>\<^sub>\<tau> T\<^sub>2" by (rule eval.intros)
    thus ?thesis by iprover
  qed
next
  case (T_Sub t S T)
  show ?case by (rule T_Sub)
qed

end


theory ExF017
  imports Main
begin

lemma "P a (Q (Q a))  \<longrightarrow> (\<forall>x. \<forall>y. P x (Q y) \<longrightarrow> (\<exists>z. P (Q z) y)) \<longrightarrow> (\<exists>z. P z a)"
proof -
  {
    assume a:"P a (Q (Q a))"
    hence b:"\<exists>z. P z (Q (Q a))" by (rule exI)
    {
      assume c:"(\<forall>x. \<forall>y. P x (Q y) \<longrightarrow> (\<exists>z. P (Q z) y))"
      hence "(\<forall>y. P a (Q y) \<longrightarrow> (\<exists>z. P (Q z) y))"  ..
      hence "(P a (Q (Q a)) \<longrightarrow> (\<exists>z. P (Q z) (Q a)))" ..
      from this a have d:"(\<exists>z. P (Q z) (Q a))" by (rule mp)
      {
        assume e:"(\<forall>z . \<not>P z a)"
        {
          fix b
          assume f:"P (Q b) (Q a)"
          from c have "(\<forall>y. P (Q b) (Q y) \<longrightarrow> (\<exists>z. P (Q z) y))" by (rule allE)
          hence "P (Q b) (Q a) \<longrightarrow> (\<exists>z. P (Q z) a)" by (rule allE)
          from this and  f have g:"\<exists>z. P (Q z) a" by (rule mp)
          {
            fix c
            assume h:"P (Q c) a"
            from e have "\<not>P (Q c) a" by (rule allE)
            with h have False by contradiction
          }
          with g have False by (rule exE)
        }
        with d have False by (rule exE)
      }
      hence e:"\<not>(\<forall>z . \<not>P z a)" by (rule notI)
      have f:"(\<exists>z. P z a)"
      proof -
        {
          assume g:"\<not>(\<exists>z. P z a)"
          have h:"\<forall>z. \<not>P z a"
          proof -
            {
              assume i:"\<not>(\<forall>z . \<not>P z a)"
              {
                fix b
                {
                  assume "P b a"
                  hence "\<exists>z. P z a" by (rule exI)
                  with g have False by contradiction
                }
                hence "\<not>P b a" by (rule notI)
              }
              hence "\<forall>z. \<not>P z a" by (rule allI)
              with i have False by contradiction
            }
            hence "\<not>\<not>(\<forall>z . \<not>P z a)" by (rule notI)
            thus "\<forall>z . \<not>P z a" by (rule notnotD)
          qed
          from h and e have False by contradiction
        }
        hence "\<not>\<not>(\<exists>z. P z a)" by (rule notI)
        thus "\<exists>z. P z a" by (rule notnotD)
      qed
    }
    hence "((\<forall>x. \<forall>y. P x (Q y) \<longrightarrow> (\<exists>z. P (Q z) y))) \<longrightarrow> (\<exists>z. P z a)" by (rule impI)
  }
  thus ?thesis by (rule impI)
qed


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_nat_HSort2Count
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

datatype Heap = Node "Heap" "Nat" "Heap" | Nil

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun hmerge :: "Heap => Heap => Heap" where
  "hmerge (Node z x2 x3) (Node x4 x5 x6) =
   (if le x2 x5 then Node (hmerge x3 (Node x4 x5 x6)) x2 z else
      Node (hmerge (Node z x2 x3) x6) x5 x4)"
| "hmerge (Node z x2 x3) (Nil) = Node z x2 x3"
| "hmerge (Nil) y = y"

(*fun did not finish the proof*)
function toList :: "Heap => Nat list" where
  "toList (Node q y r) = cons2 y (toList (hmerge q r))"
| "toList (Nil) = nil2"
  by pat_completeness auto

fun hinsert :: "Nat => Heap => Heap" where
  "hinsert x y = hmerge (Node Nil x Nil) y"

fun toHeap2 :: "Nat list => Heap" where
  "toHeap2 (nil2) = Nil"
| "toHeap2 (cons2 y xs) = hinsert y (toHeap2 xs)"

fun hsort2 :: "Nat list => Nat list" where
  "hsort2 x = toList (toHeap2 x)"

fun count :: "'a => 'a list => Nat" where
  "count x (nil2) = Z"
| "count x (cons2 z ys) =
     (if (x = z) then plus (S Z) (count x ys) else count x ys)"

theorem property0 :
  "((count x (hsort2 xs)) = (count x xs))"
  oops

end


theory Shortest_Path_Theory
imports
  Complex
  "../Graph_Theory/Graph_Theory"
begin
(*
section {*Shortest Path (with non-negative edge costs)*}
*)
(*
text{* The following theory is used in the verification of a certifying algorithm's checker for shortest path. For more information see \cite{FrameworkVerificationofCertifyingComputations}. *}
*)
locale basic_sp =
  fin_digraph +
  fixes dist :: "'a \<Rightarrow> ereal"
  fixes c :: "'b \<Rightarrow> real"
  fixes s :: "'a"
  assumes general_source_val: "dist s \<le> 0"
  assumes trian:
    "\<And>e. e \<in> arcs G \<Longrightarrow>
      dist (head G e) \<le> dist (tail G e) + c e"

locale basic_just_sp =
  basic_sp +
  fixes enum :: "'a \<Rightarrow> enat"
  assumes just:
    "\<And>v. \<lbrakk>v \<in> verts G; v \<noteq> s; enum v \<noteq> \<infinity>\<rbrakk> \<Longrightarrow>
      \<exists> e \<in> arcs G. v = head G e \<and>
        dist v = dist (tail G e) + c e  \<and>
        enum v = enum (tail G e) + (enat 1)"

locale shortest_path_non_neg_cost =
  basic_just_sp +
  assumes s_in_G: "s \<in> verts G"
  assumes source_val: "dist s = 0"
  assumes no_path: "\<And>v. v \<in> verts G \<Longrightarrow> dist v = \<infinity> \<longleftrightarrow> enum v = \<infinity>"
  assumes non_neg_cost: "\<And>e. e \<in> arcs G \<Longrightarrow> 0 \<le> c e"

locale basic_just_sp_pred =
  basic_sp +
  fixes enum :: "'a \<Rightarrow> enat"
  fixes pred :: "'a \<Rightarrow> 'b option"
  assumes just:
    "\<And>v. \<lbrakk>v \<in> verts G; v \<noteq> s; enum v \<noteq> \<infinity>\<rbrakk> \<Longrightarrow>
      \<exists> e \<in> arcs G.
        e = the (pred v) \<and>
        v = head G e \<and>
        dist v = dist (tail G e) + c e  \<and>
        enum v = enum (tail G e) + (enat 1)"

sublocale basic_just_sp_pred \<subseteq> basic_just_sp
using basic_just_sp_pred_axioms
unfolding basic_just_sp_pred_def
   basic_just_sp_pred_axioms_def
by unfold_locales (blast)

locale shortest_path_non_neg_cost_pred =
  basic_just_sp_pred +
  assumes s_in_G: "s \<in> verts G"
  assumes source_val: "dist s = 0"
  assumes no_path: "\<And>v. v \<in> verts G \<Longrightarrow> dist v = \<infinity> \<longleftrightarrow> enum v = \<infinity>"
  assumes non_neg_cost: "\<And>e. e \<in> arcs G \<Longrightarrow> 0 \<le> c e"

sublocale shortest_path_non_neg_cost_pred \<subseteq> shortest_path_non_neg_cost
using shortest_path_non_neg_cost_pred_axioms
by unfold_locales
   (auto simp: shortest_path_non_neg_cost_pred_def
   shortest_path_non_neg_cost_pred_axioms_def)

lemma tail_value_helper:
  assumes "hd p = last p"
  assumes "distinct p"
  assumes "p \<noteq> []"
  shows "p = [hd p]"
by (metis assms distinct.simps(2) append_butlast_last_id hd_append
  append_self_conv2 distinct_butlast hd_in_set not_distinct_conv_prefix)

lemma (in basic_sp) dist_le_cost:
  fixes v :: 'a
  fixes p :: "'b list"
  assumes "awalk s p v"
  shows "dist v \<le> awalk_cost c p"
  using assms
  proof (induct "length p" arbitrary: p v)
  case 0
    hence "s = v" by auto
    thus ?case using 0(1) general_source_val
      by (metis awalk_cost_Nil length_0_conv zero_ereal_def)
  next
  case (Suc n)
    then obtain p' e where p'e: "p = p' @ [e]"
      by (cases p rule: rev_cases) auto
    then obtain u where ewu: "awalk s p' u \<and> awalk u [e] v"
      using awalk_append_iff Suc(3) by simp
    then have du: "dist u \<le> ereal (awalk_cost c p')"
      using Suc p'e by simp
    from ewu have ust: "u = tail G e" and vta: "v = head G e"
      by auto
    then have "dist v \<le> dist u + c e"
      using ewu du ust trian[where e=e] by force
    with du have "dist v \<le> ereal (awalk_cost c p') + c e"
      by (metis add_right_mono order_trans)
    thus "dist v \<le> awalk_cost c p"
      using awalk_cost_append p'e by simp
  qed

lemma (in fin_digraph) witness_path:
  assumes "\<mu> c s v = ereal r"
  shows "\<exists> p. apath s p v \<and> \<mu> c s v = awalk_cost c p"
proof -
  have sv: "s \<rightarrow>\<^sup>* v"
    using shortest_path_inf[of s v c] assms by fastforce
  {
    fix p assume "awalk s p v"
    then have no_neg_cyc:
    "\<not> (\<exists>w q. awalk w q w \<and> w \<in> set (awalk_verts s p) \<and> awalk_cost c q < 0)"
      using neg_cycle_imp_inf_\<mu> assms by force
  }
  thus ?thesis using no_neg_cyc_reach_imp_path[OF sv] by presburger
qed

lemma (in basic_sp)  dist_le_\<mu>:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v \<le> \<mu> c s v"
proof (rule ccontr)
  assume nt: "\<not> ?thesis"
  show False
  proof (cases "\<mu> c s v")
    show "\<And>r. \<mu> c s v = ereal r \<Longrightarrow> False"
    proof -
      fix r assume r_asm: "\<mu> c s v = ereal r"
      hence sv: "s \<rightarrow>\<^sup>* v"
        using shortest_path_inf[where u=s and v=v and f=c] by auto
      obtain p where
        "awalk s p v"
        "\<mu> c s v = awalk_cost c p"
        using witness_path[OF r_asm] unfolding apath_def by force
      thus False using nt dist_le_cost by simp
    qed
  next
    show "\<mu> c s v = \<infinity> \<Longrightarrow> False" using nt by simp
  next
    show "\<mu> c s v = - \<infinity> \<Longrightarrow> False"
    proof -
      assume asm: "\<mu> c s v = - \<infinity>"
      let ?C = "(\<lambda>x. ereal (awalk_cost c x)) ` {p. awalk s p v}"
      have "\<exists>x\<in> ?C. x < dist v"
        using Inf_ereal_iff [where y ="dist v"and X="?C" and z= "-\<infinity>"]
        nt asm unfolding \<mu>_def INF_def by simp
      then obtain p where
        "awalk s p v"
        "awalk_cost c p < dist v"
        by force
      thus False using dist_le_cost by force
    qed
  qed
qed
(*
text{*
  Proof by induction on enum v (for any v).
  Base case: trivial using assumptions.
  Step case:
   if it holds for (enum v) then it holds for (enum v)+1.
   using assumptions we know v~= s.
   By the induction hypothesis and the lemma dist_le_mu we know \dist(u) = \mu (c, s, u).
   using just we obtain a witnessing edge (u,v) such that
   dist(v) = dist(u) + c (u,v) = \mu (c, s, u) + c(u,v).
   we obtain the shortest path from s to u with cost \mu (c, s, u)
   and append the edge (u,v) to it. It provides a path of cost \mu (c, s, u) +  c (u,v) from s to v.
   Hence \mu(c, s, v) \<le> \mu (c, s, u) +  c (u,v) = \dist(v). By this we conclude our proof.
*}
*)
lemma (in basic_just_sp) dist_ge_\<mu>:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "enum v \<noteq> \<infinity>"
  assumes "dist v \<noteq> -\<infinity>"
  assumes "\<mu> c s s = ereal 0"
  assumes "dist s = 0"
  assumes "\<And>u. u\<in>verts G \<Longrightarrow> u\<noteq>s \<Longrightarrow> enum u \<noteq> enat 0"
  shows "dist v \<ge> \<mu> c s v"
proof -
  obtain n where "enat n = enum v" using assms(2) by force
  thus ?thesis using assms
  proof(induct n arbitrary: v)
  case 0 thus ?case by (cases "v=s", auto)
  next
  case (Suc n)
    thus ?case
    proof (cases "v=s")
    case False
      obtain e where e_assms:
        "e \<in> arcs G"
        "v = head G e"
        "dist v = dist (tail G e) + ereal (c e)"
        "enum v = enum (tail G e) + enat 1"
        using just[OF Suc(3) False Suc(4)] by blast
      then have nsinf:"enum (tail G e) \<noteq> \<infinity>"
        by (metis Suc(2) enat.simps(3) enat_1 plus_enat_simps(2))
      then have ns:"enat n = enum (tail G e)"
        using e_assms(4) Suc(2) by force
      have  ds: "dist (tail G e) = \<mu> c s (tail G e)"
        using Suc(1)[OF ns tail_in_verts[OF e_assms(1)] nsinf]
        Suc(5-8) e_assms(3) dist_le_\<mu>[OF tail_in_verts[OF e_assms(1)]]
        by simp
      have dmuc:"dist v = \<mu> c s (tail G e) + ereal (c e)"
        using e_assms(3) ds  by auto
      thus ?thesis
      proof (cases "dist v = \<infinity>")
      case False
        have "arc_to_ends G e = (tail G e, v)"
          unfolding arc_to_ends_def
          by (simp add: e_assms(2))
        obtain r where  \<mu>r: "\<mu> c s (tail G e) = ereal r"
           using e_assms(3) Suc(5) ds False
           by (cases "\<mu> c s (tail G e)", auto)
        obtain p where
          "awalk s p (tail G e)" and
          \<mu>s: "\<mu> c s (tail G e) = ereal (awalk_cost c p)"
          using witness_path[OF \<mu>r] unfolding apath_def
          by blast
        then have pe: "awalk s (p @ [e]) v"
          using e_assms(1,2) by (auto simp: awalk_simps awlast_of_awalk)
        hence muc:"\<mu> c s v \<le> \<mu> c s (tail G e) + ereal (c e)"
        using \<mu>s min_cost_le_walk_cost[OF pe] by simp
        thus  "dist v \<ge> \<mu> c s v"  using dmuc by simp
      qed simp
    qed (simp add: Suc(6,7))
  qed
qed

lemma (in shortest_path_non_neg_cost) tail_value_check:
  fixes u :: 'a
  assumes "s \<in> verts G"
  shows "\<mu> c s s = ereal 0"
proof -
  have *: "awalk s [] s" using assms unfolding awalk_def by simp
  hence "\<mu> c s s \<le> ereal 0" using min_cost_le_walk_cost[OF *] by simp
  moreover
  have "(\<And>p. awalk s p s \<Longrightarrow> ereal(awalk_cost c p) \<ge> ereal 0)"
   using non_neg_cost pos_cost_pos_awalk_cost by auto
  hence "\<mu> c s s \<ge> ereal 0"
    unfolding \<mu>_def by (blast intro: INF_greatest)
  ultimately
  show ?thesis by simp
qed

lemma (in shortest_path_non_neg_cost) enum_not0:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "v \<noteq> s"
  (*assumes "enum v \<noteq> \<infinity>"*)
  shows "enum v \<noteq> enat 0"
proof (cases "enum v \<noteq> \<infinity>")
case True
  then obtain ku where "enum v = ku + enat 1"
    using assms just by blast
  thus ?thesis  by (induct ku) auto
qed fast

lemma (in shortest_path_non_neg_cost) dist_ne_ninf:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v \<noteq> -\<infinity>"
proof (cases "enum v = \<infinity>")
case False
  obtain n where "enat n = enum v"
    using False by force
  thus ?thesis using assms False
  proof(induct n arbitrary: v)
  case 0 thus ?case
    using enum_not0 source_val by (cases "v=s", auto)
  next
  case (Suc n)
    thus ?case
    proof (cases "v=s")
    case True
      thus ?thesis using source_val by simp
    next
    case False
      obtain e where e_assms:
        "e \<in> arcs G"
        "dist v = dist (tail G e) + ereal (c e)"
        "enum v = enum (tail G e) + enat 1"
        using just[OF Suc(3) False Suc(4)] by blast
      then have nsinf:"enum (tail G e) \<noteq> \<infinity>"
        by (metis Suc(2) enat.simps(3) enat_1 plus_enat_simps(2))
      then have ns:"enat n = enum (tail G e)"
        using e_assms(3) Suc(2) by force
      have "dist (tail G e ) \<noteq> - \<infinity>"
        by (rule Suc(1) [OF ns tail_in_verts[OF e_assms(1)] nsinf])
      thus ?thesis using e_assms(2) by simp
    qed
  qed
next
case True
  thus ?thesis using no_path[OF assms] by simp
qed

theorem (in shortest_path_non_neg_cost) correct_shortest_path:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v = \<mu> c s v"
  using no_path[OF assms(1)] dist_le_\<mu>[OF assms(1)]
    dist_ge_\<mu>[OF assms(1) _ dist_ne_ninf[OF assms(1)]
    tail_value_check[OF s_in_G] source_val enum_not0]
    by fastforce

corollary (in shortest_path_non_neg_cost_pred) correct_shortest_path_pred:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v = \<mu> c s v"
  using correct_shortest_path assms by simp

end