(*<*)
theory Lecture7
imports Main LaTeXsugar OptionalSugar
begin
(*>*)

section "Case study: the simply typed lambda calculus"

text{*

We formalize an operational semantics for the simply typed lambda
calculus in the evaluation context
style~\cite{felleisen92:_seq_control,wright94:_type_soundness} and
prove type safety.

We use a relatively new approach for representing variables called
``locally
nameless''~\cite{Chargueraud:2006uq,Gordon:1994kx,Pollack:1994vn}.  In
the locally nameless approach, bound variables are represented with de
Bruijn indices whereas free variables are represented with
symbols. This approach enjoys the benefits of the de Bruijn indices
($\alpha$-equivalent terms are syntactically identical) while avoiding
much of the complication (normally caused by representing free
variables with de Bruijn indices). Separate functions are used to
substitution for free and bound variables.

*}

subsection "Syntax of the simply typed lambda calculus"

datatype ty = IntT | BoolT | ArrowT ty ty (infixr "\<rightarrow>" 200)

datatype const = IntC int | BoolC bool | Succ | IsZero

datatype expr = 
    BVar nat | FVar nat | Const const
  | Lam ty expr ("\<lambda>:_. _" [52,52] 51)
  | App expr expr

text{* Free variables *}

consts FV :: "expr \<Rightarrow> nat set"
primrec
  "FV (BVar i) = {}"
  "FV (FVar x) = {x}"
  "FV (Const c) = {}"
  "FV (\<lambda>:\<sigma>. e) = FV e"
  "FV (App e1 e2) = FV e1 \<union> FV e2"

lemma finite_FV: "finite (FV e)" apply (induct e) by auto

text{* Substitution for free variables *}

consts fsubst :: "nat \<Rightarrow> expr \<Rightarrow> expr \<Rightarrow> expr" ("[_\<rightarrow>_]_" [54,54,54] 53)
primrec
  "[z\<rightarrow>e](BVar i) = BVar i"
  "[z\<rightarrow>e](FVar x) = (if z = x then e else (FVar x))"
  "[z\<rightarrow>e](Const c) = Const c"
  "[z\<rightarrow>e](\<lambda>:\<sigma>. e') = (\<lambda>:\<sigma>. [z\<rightarrow>e]e')"
  "[z\<rightarrow>e](App e1 e2) = App ([z\<rightarrow>e]e1) ([z\<rightarrow>e]e2)"

text{* Substitution for bound variables *}

consts bsubst :: "nat \<Rightarrow> expr \<Rightarrow> expr \<Rightarrow> expr" ("{_\<rightarrow>_}_" [54,54,54] 53)
primrec
  "{k\<rightarrow>e}(BVar i) = (if k = i then e else (BVar i))"
  "{k\<rightarrow>e}(FVar x) = FVar x"
  "{k\<rightarrow>e}(Const c) = Const c"
  "{k\<rightarrow>e}(\<lambda>:\<sigma>. e') = (\<lambda>:\<sigma>. {Suc k\<rightarrow>e}e')"
  "{k\<rightarrow>e}(App e1 e2) = App ({k\<rightarrow>e}e1) ({k\<rightarrow>e}e2)"


subsection "Operational semantics with evaluation contexts"

text{* A utility function for casting an arbitrary expression
    to an integer. *}

consts to_int :: "expr \<Rightarrow> int option"
primrec
  "to_int (BVar x) = None"
  "to_int (FVar x) = None"
  "to_int (Const c) = 
         (case c of
            IntC n \<Rightarrow> Some n
          | BoolC b \<Rightarrow> None
          | Succ \<Rightarrow> None
          | IsZero \<Rightarrow> None)"
  "to_int (Lam \<tau> e) = None"
  "to_int (App e1 e2) = None"

text{* The $\delta$ function evaluates the primitive operators. *}

consts delta :: "const \<Rightarrow> expr \<Rightarrow> expr option" ("\<delta>")
primrec
  "delta (IntC n) e = None"
  "delta (BoolC b) e = None"
  "delta Succ e =
     (case to_int e of
         None \<Rightarrow> None
       | Some n \<Rightarrow> Some (Const (IntC (n + 1))))"
  "delta IsZero e =
     (case to_int e of
         None \<Rightarrow> None
       | Some n \<Rightarrow> Some (Const (BoolC (n = 0))))"

text{* Evaluation reduces expressions to values.
  The following is the definition of which
  expressions are values. *}

consts Values :: "expr \<Rightarrow> bool"
primrec
  "Values (BVar i) = True"
  "Values (FVar x) = True"
  "Values (Const c) = True"
  "Values (\<lambda>:\<sigma>. e) = True"
  "Values (App e1 e2) = False"

text{* The call-by-value notion of reduction 
  is defined as follows. *}

inductive reduces :: "expr \<Rightarrow> expr \<Rightarrow> bool" (infixl "-\<rightarrow>" 51)
where
  Beta: "Values v \<Longrightarrow> App (\<lambda>:\<tau>. e) v -\<rightarrow> {0\<rightarrow>v}e" |
  Delta: "\<lbrakk> \<delta> c v = Some v'; Values v \<rbrakk> \<Longrightarrow> App (Const c) v -\<rightarrow> v'"

constdefs redex :: "expr \<Rightarrow> bool"
  "redex r \<equiv> (\<exists> r'. r -\<rightarrow> r')"

text{* We use contexts to specify where reduction
  can take place within an expression. *}

datatype ctx = Hole | AppL ctx expr | AppR expr ctx

inductive_set wf_ctx :: "ctx set"
where
  WFHole: "Hole \<in> wf_ctx" |
  WFAppL: "E \<in> wf_ctx \<Longrightarrow> AppL E e \<in> wf_ctx" |
  WFAppR: "\<lbrakk> Values v; E \<in> wf_ctx \<rbrakk> \<Longrightarrow> AppR v E \<in> wf_ctx"

consts fill :: "ctx \<Rightarrow> expr \<Rightarrow> expr"     ("_[_]" [82,82] 81)
primrec
  "Hole[e] = e"
  "(AppL E e2)[e] = App (E[e]) e2"
  "(AppR e1 E)[e] = App e1 (E[e])"

inductive eval_step :: "expr \<Rightarrow> expr \<Rightarrow> bool" (infixl "\<longmapsto>" 51)
where
  Step: "\<lbrakk> E \<in> wf_ctx; r -\<rightarrow> r' \<rbrakk> \<Longrightarrow> E[r] \<longmapsto> E[r']"

subsection "Creating fresh variables"

constdefs max :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  "max x y \<equiv> (if x < y then y else x)"
declare max_def[simp]

interpretation AC_max: ACe ["max" "0::nat"]
  by unfold_locales (auto intro: add_assoc add_commute)

constdefs setmax :: "nat set \<Rightarrow> nat"
  "setmax S \<equiv> fold max (\<lambda> x. x) 0 S"

lemma max_ge: "finite L \<Longrightarrow> \<forall> x \<in> L. x \<le> setmax L"
  apply (induct rule: finite_induct)
  apply simp
  apply clarify
  apply (case_tac "xa = x")
proof -
  fix x and F::"nat set" and xa
  assume fF: "finite F" and xF: "x \<notin> F" and xax: "xa = x"
  from fF xF have mc: "setmax (insert x F) = max x (setmax F)"
    apply (simp only: setmax_def)
    apply (rule AC_max.fold_insert)
    apply auto done
  with xax show "xa \<le> setmax (insert x F)"
    apply clarify by simp
next
  fix x and F::"nat set" and xa
  assume fF: "finite F" and xF: "x \<notin> F" 
    and axF: "\<forall>x\<in>F. x \<le> setmax F"
    and xsxF: "xa \<in> insert x F"
    and xax: "xa \<noteq> x"
  from xax xsxF have xaF: "xa \<in> F" by auto
  with axF have xasF: "xa \<le> setmax F" by blast
  from fF xF have mc: "setmax (insert x F) = max x (setmax F)"
    apply (simp only: setmax_def)
    apply (rule AC_max.fold_insert)
    apply auto done
  with xasF show "xa \<le> setmax (insert x F)" by auto
qed

lemma max_is_fresh[simp]:
  assumes F: "finite L" shows "Suc (setmax L) \<notin> L"
proof
  assume ssl: "Suc (setmax L) \<in> L"
  with F max_ge have "Suc (setmax L) \<le> setmax L" by blast
  thus "False" by simp
qed

lemma greaterthan_max_is_fresh[simp]:
  assumes F: "finite L" and I: "setmax L < i"
  shows "i \<notin> L"
proof
  assume ssl: "i \<in> L"
  with F max_ge have "i \<le> setmax L" by blast
  with I show "False" by simp
qed
    
subsection "Well-typed expressions"

types env = "nat \<Rightarrow> ty option"

constdefs remove_bind :: "env \<Rightarrow> nat \<Rightarrow> env \<Rightarrow> bool" ("_ - _ \<subset> _" [50,50,50] 49)
  "\<Gamma> - z \<subset> \<Gamma>' \<equiv> \<forall> x \<tau>. x \<noteq> z \<and> \<Gamma> x = Some \<tau> \<longrightarrow> \<Gamma>' x = Some \<tau>"

constdefs finite_env :: "env \<Rightarrow> bool"
  "finite_env \<Gamma> \<equiv> finite (dom \<Gamma>)"
declare finite_env_def[simp]

consts TypeOf :: "const \<Rightarrow> ty"
primrec
  "TypeOf (IntC n) = IntT"
  "TypeOf (BoolC b) = BoolT"
  "TypeOf Succ = IntT \<rightarrow> IntT"
  "TypeOf IsZero = IntT \<rightarrow> BoolT"

inductive wte :: "env \<Rightarrow> [expr,ty] \<Rightarrow> bool" ("_ \<turnstile> _ : _" [52,52,52] 51)
where
  wte_var: "\<Gamma> x = Some \<tau> \<Longrightarrow> \<Gamma> \<turnstile> FVar x : \<tau>" |
  wte_const: "\<Gamma> \<turnstile> Const c : TypeOf c" |
  wte_abs: "\<lbrakk> finite L; dom \<Gamma> \<subseteq> L;
             \<forall> x. x \<notin> L \<longrightarrow> \<Gamma>(x\<mapsto>\<sigma>) \<turnstile> {0\<rightarrow>FVar x}e : \<tau> \<rbrakk>
            \<Longrightarrow> \<Gamma> \<turnstile> (\<lambda>:\<sigma>. e) : \<sigma> \<rightarrow> \<tau>" |
  wte_app: "\<lbrakk> \<Gamma> \<turnstile> e1 : \<sigma> \<rightarrow> \<tau>; \<Gamma> \<turnstile> e2 : \<sigma> \<rbrakk>
            \<Longrightarrow> \<Gamma> \<turnstile> App e1 e2 : \<tau>"

subsection "Properties of substitution"

lemma bsubst_cross[rule_format]:
  "\<forall> i j u v. i \<noteq> j \<and>  {i\<rightarrow>u}({j\<rightarrow>v}t) = {j\<rightarrow>v}t \<longrightarrow> {i\<rightarrow>u}t = t"
  apply (induct t)
  apply force
  apply force
  apply force
  apply clarify 
    apply (erule_tac x="Suc i" in allE)
    apply (erule_tac x="Suc j" in allE)
    apply (erule_tac x=u in allE)
    apply (erule_tac x=v in allE)
    apply simp 
  apply clarify 
    apply (erule_tac x="i" in allE)
    apply (erule_tac x="i" in allE)
    apply (erule_tac x="j" in allE)
    apply (erule_tac x="j" in allE)
    apply simp apply blast
  done

lemma bsubst_wt:
  "\<lbrakk> \<Gamma> \<turnstile> e : \<tau>; finite_env \<Gamma> \<rbrakk> \<Longrightarrow> \<forall> k e'. {k\<rightarrow>e'}e = e"
  apply (induct rule: wte.induct)
  apply force
  apply force
  apply clarify apply simp
    apply (erule_tac x="Suc (setmax L)" in allE)
    apply (erule impE)
    apply (rule max_is_fresh) apply simp 
    apply (erule conjE)+
    apply (erule_tac x="Suc k" in allE)
    apply (erule_tac x="e'" in allE)
    apply (rule bsubst_cross) apply blast
  apply force
  done

lemma subst_permute_impl[rule_format]:
  "\<forall> j x z \<Gamma> \<tau> e'. x \<noteq> z \<and> \<Gamma> \<turnstile> e' : \<tau> \<and> finite_env \<Gamma>
   \<longrightarrow> [z\<rightarrow>e']({j\<rightarrow>FVar x}e) = {j\<rightarrow> FVar x}([z\<rightarrow>e']e)"
  apply (induct e)
  apply force
  apply simp apply clarify
    apply (frule bsubst_wt) 
    apply simp
    apply (erule_tac x="j" in allE)
    apply (erule_tac x="FVar x" in allE)
    apply simp
  apply simp
  apply simp apply clarify apply blast
  apply simp apply clarify 
    apply (erule_tac x="j" in allE)
    apply (erule_tac x="j" in allE)
    apply (erule_tac x="x" in allE)
    apply (erule_tac x="x" in allE)
    apply (erule_tac x="z" in allE)
    apply (erule_tac x="z" in allE)
    apply (erule_tac x="\<Gamma>" in allE)
    apply (erule_tac x="\<Gamma>" in allE)
    apply blast
  done

lemma subst_permute:
  "\<lbrakk> x \<noteq> z; \<Gamma> \<turnstile> e' : \<tau>; finite_env \<Gamma> \<rbrakk>
   \<Longrightarrow> {j\<rightarrow> FVar x}([z\<rightarrow>e']e) = [z\<rightarrow>e']({j\<rightarrow>FVar x}e)"
  using subst_permute_impl[of x z \<Gamma> e' \<tau> j e] by simp

lemma decompose_subst[rule_format]:
  "\<forall> u x i. x \<notin> FV e \<longrightarrow> {i\<rightarrow>u}e = [x\<rightarrow>u]({i\<rightarrow>FVar x}e)"
  apply (induct e) 
  apply force
  apply force
  apply force
  apply clarify
    apply (erule_tac x=u in allE)
    apply (erule_tac x=x in allE)
    apply (erule_tac x="Suc i" in allE)
    apply simp
  apply force 
  done

subsection "Properties of environments and rule induction"

constdefs subseteq :: "env \<Rightarrow> env \<Rightarrow> bool" (infixl "\<subseteq>" 80)
  "\<Gamma> \<subseteq> \<Gamma>' \<equiv> \<forall> x \<tau>. \<Gamma> x = Some \<tau> \<longrightarrow> \<Gamma>' x = Some \<tau>"

lemma env_weakening:
  "\<Gamma> \<turnstile> e : \<tau> \<Longrightarrow> \<forall> \<Gamma>'. \<Gamma> \<subseteq> \<Gamma>' \<and> finite_env \<Gamma>' \<longrightarrow> \<Gamma>' \<turnstile> e : \<tau>"
  apply (induct rule: wte.induct)
  using subseteq_def wte_var apply blast
  using wte_const apply blast
  prefer 2 using wte_app apply blast 
  apply (rule allI) apply (rule impI)
proof -
  fix L::"nat set" and \<Gamma>::env and \<sigma> \<tau> e \<Gamma>'
  assume fL: "finite L" and GL: "dom \<Gamma> \<subseteq> L"
    and IH: "\<forall>x. x \<notin> L \<longrightarrow> 
    (\<Gamma>(x\<mapsto>\<sigma>) \<turnstile> {0\<rightarrow>FVar x}e : \<tau> \<and>
    (\<forall>\<Gamma>'.  \<Gamma>(x\<mapsto>\<sigma>) \<subseteq> \<Gamma>' \<and> finite_env \<Gamma>' \<longrightarrow> \<Gamma>' \<turnstile> {0\<rightarrow>FVar x}e : \<tau>))"
    and GGP: "\<Gamma> \<subseteq> \<Gamma>' \<and> finite_env \<Gamma>'"
  let ?L = "L \<union> dom \<Gamma>'"
  from GGP have "finite (dom \<Gamma>')" by auto
  with fL have fL2: "finite ?L" by auto
  { fix x assume xL: "x \<notin> ?L"
    from GGP have xGxGP: "\<Gamma>(x\<mapsto>\<sigma>) \<subseteq>  \<Gamma>'(x\<mapsto>\<sigma>)" using subseteq_def by auto
    from GGP have fGP: "finite_env (\<Gamma>'(x\<mapsto>\<sigma>))" by auto
    from xL fGP IH xGxGP have "\<Gamma>'(x\<mapsto>\<sigma>) \<turnstile> {0\<rightarrow>FVar x}e : \<tau>" by blast
  } hence X: "\<forall> x. x \<notin> ?L \<longrightarrow> \<Gamma>'(x\<mapsto>\<sigma>) \<turnstile> {0\<rightarrow>FVar x}e : \<tau>" by blast
  have dGL: "dom \<Gamma>' \<subseteq> ?L" by auto
  from fL2 dGL X show "\<Gamma>' \<turnstile> (\<lambda>:\<sigma>. e) : \<sigma> \<rightarrow> \<tau>" by (rule wte_abs)
qed

subsection "The substition lemma"

lemma substitution:
  "\<lbrakk> \<Gamma> \<turnstile> e1 : \<tau>; \<Gamma> x = Some \<sigma>; finite_env \<Gamma> \<rbrakk> \<Longrightarrow>
  (\<forall> \<Gamma>'. finite_env \<Gamma>' \<and> \<Gamma> - x \<subset> \<Gamma>' \<and> \<Gamma>' \<turnstile> e2 : \<sigma> \<longrightarrow> 
   \<Gamma>' \<turnstile> [x\<rightarrow>e2]e1 : \<tau>)"
  (is "\<lbrakk> \<Gamma> \<turnstile> e1 : \<tau>; \<Gamma> x = Some \<sigma>; finite_env \<Gamma> \<rbrakk> \<Longrightarrow> ?P \<Gamma> e1 \<tau> x \<sigma>")
  apply (induct rule : wte.induct)
  apply (case_tac "x = xa") apply simp
    apply clarify apply (simp only: remove_bind_def) 
    apply (erule_tac x=xa in allE) apply simp apply (rule wte_var) apply assumption
  using wte_const apply force
  prefer 2 apply clarify apply simp apply (rule wte_app) apply blast apply blast
proof clarify
  fix L::"nat set" and \<Gamma>::env and \<sigma>'::ty and \<tau> e \<Gamma>'
  assume fL: "finite L" and "dom \<Gamma> \<subseteq> L"
    and IH: "\<forall>xa. xa \<notin> L \<longrightarrow>
               (\<Gamma>(xa \<mapsto> \<sigma>') \<turnstile> {0\<rightarrow>FVar xa}e : \<tau> \<and>
                ((\<Gamma>(xa \<mapsto> \<sigma>')) x = Some \<sigma> \<longrightarrow>
                 finite_env (\<Gamma>(xa \<mapsto> \<sigma>')) \<longrightarrow>
                   (?P (\<Gamma>(xa \<mapsto> \<sigma>')) ({0\<rightarrow>FVar xa}e) \<tau> x \<sigma>)))"
    and xG: " \<Gamma> x = Some \<sigma>" and fG: "finite_env \<Gamma>" 
    and fGP: "finite_env \<Gamma>'" 
    and GxG: "\<Gamma> - x \<subset> \<Gamma>'" and wte2: "\<Gamma>' \<turnstile> e2 : \<sigma>"
  let ?L = "insert x (L \<union> dom \<Gamma> \<union> dom \<Gamma>')"
  show "\<Gamma>' \<turnstile> [x\<rightarrow>e2](\<lambda>:\<sigma>'. e) : \<sigma>' \<rightarrow> \<tau>"
  proof simp
    show "\<Gamma>' \<turnstile> (\<lambda>:\<sigma>'. [x\<rightarrow>e2]e) : \<sigma>' \<rightarrow> \<tau>"
    proof (rule wte_abs[of "?L"])
      from fL fG fGP show "finite ?L" by auto
    next
      show "dom \<Gamma>' \<subseteq> ?L" by auto
    next
      show "\<forall>xa. xa \<notin> ?L \<longrightarrow> \<Gamma>'(xa \<mapsto> \<sigma>') \<turnstile> {0\<rightarrow>FVar xa}([x\<rightarrow>e2]e) : \<tau>"
      proof (rule allI, rule impI)
        fix x' assume xL: "x' \<notin> ?L"
        let ?GP = "\<Gamma>'(x'\<mapsto>\<sigma>')"

        from xL fGP wte2  
        have wte2b: "?GP \<turnstile> e2 : \<sigma>" using subseteq_def env_weakening by force

        from xG xL wte2b fG fGP GxG IH
        have wte: "?GP \<turnstile> [x\<rightarrow>e2]({0\<rightarrow>FVar x'}e) : \<tau>" 
	  using remove_bind_def by auto

        from xL wte2b fGP
	have "{0\<rightarrow>FVar x'}([x\<rightarrow>e2]e) = [x\<rightarrow>e2]({0\<rightarrow>FVar x'}e)"
          using subst_permute by auto

        with wte xL show "?GP \<turnstile> {0\<rightarrow>FVar x'}([x\<rightarrow>e2]e) : \<tau>" by auto
      qed
    qed
  qed
qed


subsection "Inversion rules and canonical forms"

text{*

  We use Isabelle's \textbf{inductive-cases} form
  to generate inversion rules for expressions with
  certain types, such as integers and functions.
  These rules are called ``inversion'' rules 
  because they let you use the inductive definitions in
  reverse, going from the conclusions to the premises. 

*}

inductive_cases wte_int_inv: "empty \<turnstile> e : IntT"

text{*

\noindent From the above, Isabelle generates

{\scriptsize
\begin{equation}
@{thm [mode=Rule] wte_int_inv[no_vars]} \notag
\end{equation}
}

*}

inductive_cases wte_fun_inv: "empty \<turnstile> e : \<sigma> \<rightarrow> \<tau>"

text{*

\noindent and Isabelle generates 

{\scriptsize
\begin{equation}
@{thm [mode=Rule] wte_fun_inv[no_vars]} \notag
\end{equation}
}
*}

text{*

  The following canonical forms lemmas describe what kinds
  of \emph{values} have certain types. For example, the only
  value that has type \textit{IntT} is an integer constant.
  The canonical forms lemmas are needed to prove subject reduction.

*}

lemma canonical_form_int:
  assumes eint: "empty \<turnstile> e : IntT" and ve: "Values e" 
  shows "\<exists> n. e = Const (IntC n)"
  using eint apply (rule wte_int_inv) 
  using ve apply auto apply (case_tac c) by auto

lemma canonical_form_fun:
  assumes wtf: "empty \<turnstile> v : \<sigma> \<rightarrow> \<tau>" and v: "Values v"
  shows "(\<exists> e. v = \<lambda>:\<sigma>. e) \<or> (\<exists> c. v = Const c)"
  using wtf apply (rule wte_fun_inv) using v by auto


subsection "Subject reduction"

  
lemma delta_typability:
  assumes tc: "TypeOf c = \<tau>' \<rightarrow> \<tau>" and vt: "empty \<turnstile> v : \<tau>'" and vv: "Values v"
  shows "\<exists> v'. \<delta> c v = Some v' \<and> empty \<turnstile> v' : \<tau>"
  using tc vt vv apply (cases c) apply simp apply simp
proof -
  assume tc: "TypeOf c = \<tau>' \<rightarrow> \<tau>" and vt: "empty \<turnstile> v : \<tau>'"
    and vv: "Values v" and c: "c = Succ"
  from c tc have st: "\<tau>' = IntT \<and> \<tau> = IntT" by simp
  from st vt vv obtain n where v: "v = Const (IntC n)"
    apply simp using canonical_form_int by blast
  let ?VP = "Const (IntC (n + 1))"
  have wtvp: "empty \<turnstile> ?VP : IntT"
    using wte_const[of empty "IntC (n + 1)"] by auto
  from c v have d: "\<delta> c v = Some ?VP" by simp
  from d wtvp st show ?thesis by simp
next
  assume tc: "TypeOf c = \<tau>' \<rightarrow> \<tau>" and vt: "empty \<turnstile> v : \<tau>'"
    and vv: "Values v" and c: "c = IsZero"
  from c tc have st: "\<tau>' = IntT \<and> \<tau> = BoolT" by simp 
  from st vt vv obtain n where v: "v = Const (IntC n)"
    apply simp using canonical_form_int by blast
  let ?VP = "Const (BoolC (n = 0))" 
  have wtvp: "empty \<turnstile> ?VP : BoolT"
    using wte_const[of empty "BoolC (n = 0)"] by auto
  from c v have d: "\<delta> c v = Some ?VP" by simp
  from d wtvp st show ?thesis by simp
qed

lemma subject_reduction:
  assumes wte: "\<Gamma> \<turnstile> e : \<tau>" and g: "\<Gamma> = empty" and red: "e -\<rightarrow> e'"
  shows "empty \<turnstile> e' : \<tau>"
  using wte g red
  apply (cases rule: wte.cases)
  apply simp_all
  apply (cases rule: reduces.cases) apply simp+
  apply (cases rule: reduces.cases) apply simp+
  apply clarify
proof -
  -- "Beta"
  fix \<Gamma>::env and \<sigma> \<tau>' e1 e2
  assume wte1: "empty \<turnstile> e1 : \<sigma> \<rightarrow> \<tau>"
    and wte2: "empty \<turnstile> e2 : \<sigma>"
    and red: "App e1 e2 -\<rightarrow> e'"
  -- "Would be cleaner to use an inductive cases for the above 'red'"
  from red show "empty \<turnstile> e' : \<tau>"
  proof (cases rule: reduces.cases)
    fix v \<tau>'' b assume a: "App e1 e2 = App (\<lambda>:\<tau>''. b) v" 
      and ep: "e' = {0\<rightarrow>v}b"
      and vv: "Values v"
    have fe: "finite {}" by simp
    have xL: "(0::nat) \<notin> {}" by simp
    from wte1 fe a xL obtain L 
      where fL: "finite L"
	and wtb: "\<forall>x. x \<notin> L \<longrightarrow> [x \<mapsto> \<sigma>] \<turnstile> {0\<rightarrow>FVar x}b : \<tau>"
      apply (cases rule: wte.cases) by auto      
    let ?X = "Suc (max (setmax L) (setmax (FV b)))"
    have xgel: "setmax L < ?X" by auto
    have xgeb: "setmax (FV b) < ?X" by auto

    -- "Set up for and apply the substitution lemma"
    from fL xgel have xL: "?X \<notin> L" by (rule greaterthan_max_is_fresh)
    with wtb have wtb2: "[?X \<mapsto> \<sigma>] \<turnstile> {0\<rightarrow>FVar ?X}b : \<tau>" by blast
    have gxs: "[?X \<mapsto> \<sigma>] ?X = Some \<sigma>" by simp
    have fg: "finite_env [?X \<mapsto> \<sigma>]" by simp
    have fgp: "finite_env empty" by simp
    have gxgp: "[?X \<mapsto> \<sigma>] - ?X \<subset> empty" by (simp add: remove_bind_def)
    from wtb2 gxs fg fgp gxgp wte2
    have wtb: "empty \<turnstile> [?X\<rightarrow>e2]({0\<rightarrow>FVar ?X}b) : \<tau>"
      using substitution by blast

    -- "Use the substitution decomposition lemma"
    have finb: "finite (FV b)" by (rule finite_FV)
    from finb xgeb have xb: "?X \<notin> FV b" by (rule greaterthan_max_is_fresh)
    from xb have "{0\<rightarrow>e2}b = [?X\<rightarrow>e2]({0\<rightarrow>FVar ?X}b)" 
      by (rule decompose_subst)
    with wtb a ep show "empty \<turnstile> e' : \<tau>" by simp

  next -- "Delta"
    fix c v v'
    assume a: "App e1 e2 = App (Const c) v"
      and ep: "e' = v'"
      and d: "\<delta> c v = Some v'" and vv: "Values v"
    from wte1 a have tc: "TypeOf c = \<sigma> \<rightarrow> \<tau>"
      apply (cases rule: wte.cases) by auto
    from a tc wte2 vv obtain v'' where dd: "\<delta> c v = Some v''" 
      and wtvp: "empty \<turnstile> v'' : \<tau>" using delta_typability by blast 
    from wtvp a ep d dd show "empty \<turnstile> e' : \<tau>" by simp
  qed
qed

subsection "Decomposition"

inductive welltyped_ctx :: "env  \<Rightarrow> ctx \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _ : _\<Rightarrow>_" [52,52,52,52] 51)
where
 WTHole: "\<Gamma> \<turnstile> Hole : \<tau> \<Rightarrow> \<tau>" |
 WTAppL: "\<lbrakk> \<Gamma> \<turnstile> E : \<sigma> \<Rightarrow> (\<rho> \<rightarrow> \<tau>); \<Gamma> \<turnstile> e : \<rho> \<rbrakk>
  \<Longrightarrow> \<Gamma> \<turnstile> AppL E e : \<sigma> \<Rightarrow> \<tau>" |
 WTAppR: "\<lbrakk> \<Gamma> \<turnstile> e : \<rho> \<rightarrow> \<tau>; \<Gamma> \<turnstile> E : \<sigma> \<Rightarrow> \<rho> \<rbrakk>
  \<Longrightarrow> \<Gamma> \<turnstile> AppR e E : \<sigma> \<Rightarrow> \<tau>"

lemma welltyped_decomposition:
  "\<Gamma> \<turnstile> e : \<tau> \<Longrightarrow> 
  \<Gamma> = empty \<longrightarrow> Values e \<or> (\<exists> \<sigma> E r. e = E[r] \<and> \<Gamma> \<turnstile> E : \<sigma> \<Rightarrow> \<tau> \<and> E \<in> wf_ctx
                            \<and> \<Gamma> \<turnstile> r : \<sigma> \<and> redex r)"
  (is "\<Gamma> \<turnstile> e : \<tau> \<Longrightarrow> ?P \<Gamma> e \<tau>")
  apply (induct rule: wte.induct)
  apply simp apply simp apply simp apply (rule impI) 
proof -
  fix \<Gamma> e1 \<sigma> \<tau> e2
  assume wte1: "\<Gamma> \<turnstile> e1 : \<sigma> \<rightarrow> \<tau>" and IH1: "?P \<Gamma> e1 (\<sigma>\<rightarrow>\<tau>)"
    and wte2: "\<Gamma> \<turnstile> e2 : \<sigma>" and IH2: "?P \<Gamma> e2 \<sigma>" and g: "\<Gamma> = empty"
  show "Values (App e1 e2) \<or>
          (\<exists>\<sigma> E r. App e1 e2 = E[r] \<and> \<Gamma> \<turnstile> E : \<sigma>\<Rightarrow>\<tau> \<and> E \<in> wf_ctx \<and> \<Gamma> \<turnstile> r : \<sigma> \<and> redex r)"
  proof (cases "Values e1")
    assume ve1: "Values e1"
    show "?thesis"
    proof (cases "Values e2")
      assume ve2: "Values e2"
      have h: "App e1 e2 = Hole[App e1 e2]" by simp
      have wth: "empty \<turnstile> Hole : \<tau>\<Rightarrow>\<tau>" by (rule WTHole)
      from wte1 wte2 g have wta: "empty \<turnstile> App e1 e2 : \<tau>" 
        apply simp by (rule wte_app)

      from wte1 ve1 g have "(\<exists> e. e1 = \<lambda>:\<sigma>. e) \<or> (\<exists> c. e1 = Const c)"
	apply simp apply (rule canonical_form_fun) by auto
      moreover { assume x: "\<exists> e. e1 = \<lambda>:\<sigma>. e"
	-- "Beta"
	from x obtain b where e1: "e1 = \<lambda>:\<sigma>. b" by blast
	from e1 ve2 have "App e1 e2 -\<rightarrow> {0\<rightarrow>e2}b" apply simp by (rule Beta)
	hence r: "redex (App e1 e2)" using redex_def by blast
	have wfh: "Hole \<in> wf_ctx" by (rule WFHole)
	from h wth wfh wta r g have "?thesis" by blast 
      } moreover { assume x: "\<exists> c. e1 = Const c"
	  -- "Delta"
	from x obtain c where e1: "e1 = Const c" by blast
	from wte1 e1 have tc: "TypeOf c = \<sigma> \<rightarrow> \<tau>"
	  apply (cases rule: wte.cases) by auto
	from tc wte2 ve2 g obtain v'' where dd: "\<delta> c e2 = Some v''" 
	  using delta_typability by blast 
	from dd ve2 e1 have "App e1 e2 -\<rightarrow> v''" apply simp by (rule Delta)
	hence r: "redex (App e1 e2)" using redex_def by blast
	have wfh: "Hole \<in> wf_ctx" by (rule WFHole)
	with h wth wfh wta r g have "?thesis" by blast
      } ultimately show ?thesis by blast
    next
      assume ve2: "\<not> Values e2"
      from ve2 IH2 g obtain \<sigma>' and E::ctx and r where e2: "e2 = E[r]"
	and wtE: "\<Gamma> \<turnstile> E : \<sigma>'\<Rightarrow>\<sigma>" and wfE: "E \<in> wf_ctx"
	and wtr: "\<Gamma> \<turnstile> r : \<sigma>'" and rr: "redex r"
	by blast
      from e2 have "App e1 e2 = (AppR e1 E)[r]" by simp
      moreover from wte1 wtE g have "empty \<turnstile> AppR e1 E : \<sigma>' \<Rightarrow> \<tau>" 
	apply simp apply (rule WTAppR) apply auto done
      moreover from ve1 wfE have "AppR e1 E \<in> wf_ctx" by (rule WFAppR)
      moreover note wtr rr g
      ultimately show ?thesis by blast
    qed
  next
    assume ve1: "\<not> Values e1"
    from ve1 IH1 g obtain \<sigma>' and E::ctx and r where e1: "e1 = E[r]"
      and wtE: "\<Gamma> \<turnstile> E : \<sigma>'\<Rightarrow>\<sigma>\<rightarrow>\<tau>" and wfE: "E \<in> wf_ctx" 
      and wtr: "\<Gamma> \<turnstile> r : \<sigma>'" and rr: "redex r"
      by blast
    from e1 have "App e1 e2 = (AppL E e2)[r]" by simp
    moreover from wtE wte2 g have "empty \<turnstile> AppL E e2 : \<sigma>' \<Rightarrow> \<tau>" 
      apply simp apply (rule WTAppL) apply auto done
    moreover from wfE have "AppL E e2 \<in> wf_ctx" by (rule WFAppL)
    moreover note wtr rr g
    ultimately show ?thesis by blast
  qed
qed

lemma welltyped_expr_ctx_impl:
  "\<Gamma> \<turnstile> e : \<tau> \<Longrightarrow> \<forall> E r. e = E[r]
   \<longrightarrow> (\<exists> \<sigma>. \<Gamma> \<turnstile> E : \<sigma> \<Rightarrow> \<tau> \<and> \<Gamma> \<turnstile> r : \<sigma>)" 
  apply (induct rule: wte.induct)
  apply clarify
    apply (rule_tac x="\<tau>" in exI)
    apply (case_tac E)
    using wte_var WTHole apply force
    apply simp apply simp
  apply clarify
    apply (rule_tac x="TypeOf c" in exI)
    apply (case_tac E) using wte_const WTHole apply force 
    apply simp apply simp
  apply clarify
    apply (case_tac E) 
    apply (rule_tac x="\<sigma>\<rightarrow>\<tau>" in exI)
    apply simp using wte_abs WTHole apply force
    apply simp apply simp
  apply clarify
    apply (case_tac E)
    apply (rule_tac x="\<tau>" in exI) using wte_app WTHole apply force
    apply (erule_tac x=ctx in allE)
    apply (erule_tac x=ctx in allE)
    apply (erule_tac x=r in allE)
    apply (erule_tac x=r in allE)
    apply simp using WTAppL apply blast
    apply (erule_tac x=ctx in allE)
    apply (erule_tac x=ctx in allE)
    apply (erule_tac x=r in allE)
    apply (erule_tac x=r in allE)
    apply simp using WTAppR apply blast
  done

lemma welltyped_expr_ctx:
  "\<Gamma> \<turnstile> E[r] : \<tau> \<Longrightarrow> \<exists> \<sigma>. \<Gamma> \<turnstile> E : \<sigma> \<Rightarrow> \<tau> \<and> \<Gamma> \<turnstile> r : \<sigma>"
  using welltyped_expr_ctx_impl by simp

lemma fill_ctx_welltyped[rule_format]:
  "\<Gamma> \<turnstile> E : \<sigma> \<Rightarrow> \<tau> \<Longrightarrow> \<forall> r. \<Gamma> \<turnstile> r : \<sigma> \<longrightarrow> \<Gamma> \<turnstile> E[r] : \<tau>"
  apply (induct rule: welltyped_ctx.induct) 
  apply simp
  using wte_app apply force
  using wte_app apply force
  done

subsection "Progress and preservation"

lemma progress:
  assumes wte: "empty \<turnstile> e : \<tau>"
  shows "Values e \<or> (\<exists> e'. e \<longmapsto> e')"
proof -
  show ?thesis
  proof (cases "Values e")
    assume "Values e" thus ?thesis by simp
  next assume "\<not> Values e"
    with wte have x: "\<exists> \<sigma> E r. e = E[r] \<and> empty \<turnstile> E : \<sigma> \<Rightarrow> \<tau> \<and> E \<in> wf_ctx 
         \<and> empty \<turnstile> r : \<sigma>  \<and> redex r" 
      using welltyped_decomposition[of empty e \<tau>] by simp
    from x obtain \<sigma> and E::ctx and r where eE: "e = E[r]" 
      and wtc: "empty \<turnstile> E : \<sigma> \<Rightarrow> \<tau>" 
      and wfE: "E \<in> wf_ctx" and wtr: "empty \<turnstile> r : \<sigma>" and rr: "redex r" 
      by blast
    from rr obtain r' where red: "r -\<rightarrow> r'" using redex_def by blast 
    from wfE red have "E[r] \<longmapsto> E[r']" by (rule Step)
    with eE show ?thesis by blast
  qed 
qed

lemma preservation:
  assumes s: "e \<longmapsto> e'"
  and wte: "empty \<turnstile> e : \<tau>"
  shows "empty \<turnstile> e' : \<tau>"
using s
proof (cases rule: eval_step.cases)
  fix E::ctx and r r'
  assume a: "e = E[r]" and ep: "e' = E[r']"
    and wfE: "E \<in> wf_ctx" and rr: "r -\<rightarrow> r'"
  from a wte obtain \<sigma> where wtc: "empty \<turnstile> E : \<sigma> \<Rightarrow> \<tau>" 
    and wtr: "empty \<turnstile> r : \<sigma>" using welltyped_expr_ctx by blast
  from wtr rr
  have wtrp: "empty \<turnstile> r' : \<sigma>" using subject_reduction by blast
  from wtc wtrp have "empty \<turnstile> E[r'] : \<tau>" by (rule fill_ctx_welltyped)
  with a ep show ?thesis by simp
qed

subsection "Type safety"

constdefs finished :: "expr \<Rightarrow> bool"
  "finished e \<equiv> \<not>(\<exists> e'. e \<longmapsto> e')"

inductive
  ref_tran_cl :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)"   ("(_^*)" [1000] 999)
  for r :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
where
    ref_tran_cl_refl [intro!, Pure.intro!, simp]: "(r^*) a a"
  | ref_tran_cl_into_ref_tran_cl [Pure.intro]: 
     "(r^*) a b  ==> r b c ==> (r^*) a c"

abbreviation eval_step_ref_tran_cl :: "expr \<Rightarrow> expr \<Rightarrow> bool" (infixl "\<longmapsto>\<^sup>*" 51)
where
  "e \<longmapsto>\<^sup>* e' \<equiv> (eval_step^*) e e'"

theorem type_safety:
  assumes et: "empty \<turnstile> e : \<tau>"
  and ee: "e \<longmapsto>\<^sup>* e'"
  shows "empty \<turnstile> e' : \<tau> \<and> (Values e' \<or> \<not> (finished e'))"
  using ee et 
proof (induct rule: ref_tran_cl.induct)
  fix a assume wta: "empty \<turnstile> a : \<tau>" 
  from wta have "Values a \<or> (\<exists> e'. a \<longmapsto> e')" by (rule progress)
  with wta show "empty \<turnstile> a : \<tau> \<and> (Values a \<or> \<not> (finished a))"
    using finished_def by auto 
next
  fix a b c
  assume IH: "empty \<turnstile> a : \<tau> \<Longrightarrow> empty \<turnstile> b : \<tau> \<and> (Values b \<or> \<not>(finished b))"
    and bc: "b \<longmapsto> c" and wta: "empty \<turnstile> a : \<tau>"
  from wta IH have wtb: "empty \<turnstile> b : \<tau>" by simp
  from bc wtb have wtc: "empty \<turnstile> c : \<tau>" by (rule preservation)
  from wtc have "Values c \<or> (\<exists> e'. c \<longmapsto> e')" by (rule progress)
  with wtc show "empty \<turnstile> c : \<tau> \<and> (Values c \<or> \<not> (finished c))"
    using finished_def by auto 
qed


(*<*)
end
(*>*)