theory Lec16
imports Nominal
begin

atom_decl name

nominal_datatype lam =
  Var "name"
| App "lam" "lam" 
| Lam "\<guillemotleft>name\<guillemotright>lam" ("Lam [_]._")

consts subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam"  ("_[_::=_]" [100,100] 100)

nominal_primrec
  "(Var x)[y::=s] = (if x=y then s else (Var x))"
  "(App t\<^isub>1 t\<^isub>2)[y::=s] = App (t\<^isub>1[y::=s]) (t\<^isub>2[y::=s])"
  "x\<sharp>(y,s) \<Longrightarrow> (Lam [x].t)[y::=s] = Lam [x].(t[y::=s])"
apply(finite_guess)+
apply(rule TrueI)+
apply(simp add: abs_fresh)
apply(fresh_guess)+
done

datatype ctx = 
    Hole ("\<box>")  
  | CAppL "ctx" "lam"
  | CAppR "lam" "ctx"

fun
  filling :: "ctx \<Rightarrow> lam \<Rightarrow> lam" ("_\<lbrakk>_\<rbrakk>")
where
  "\<box>\<lbrakk>t\<rbrakk> = t"
| "(CAppL E t')\<lbrakk>t\<rbrakk> = App (E\<lbrakk>t\<rbrakk>) t'"
| "(CAppR t' E)\<lbrakk>t\<rbrakk> = App t' (E\<lbrakk>t\<rbrakk>)"

inductive
  val :: "lam\<Rightarrow>bool" 
where
  v_Lam[intro]: "val (Lam [x].e)"

inductive
  machine :: "lam\<Rightarrow>ctx list\<Rightarrow>lam\<Rightarrow>ctx list\<Rightarrow>bool" ("<_,_> \<mapsto> <_,_>")
where
  m1[intro]: "<App e1 e2, Es> \<mapsto> <e1,(CAppL \<box> e2)#Es>"
| m2[intro]: "val v \<Longrightarrow> <v,(CAppL \<box> e2)#Es> \<mapsto> <e2,(CAppR v \<box>)#Es>"
| m3[intro]: "val v \<Longrightarrow> <v,(CAppR (Lam [y].e) \<box>)#Es> \<mapsto> <e[y::=v],Es>"

inductive 
  "machine_star" :: "lam\<Rightarrow>ctx list\<Rightarrow>lam\<Rightarrow>ctx list\<Rightarrow>bool" ("<_,_> \<mapsto>* <_,_>")
where
  ms1[intro]: "<e,Es> \<mapsto>* <e,Es>"
| ms2[intro]: "\<lbrakk><e1,Es1> \<mapsto> <e2,Es2>; <e2,Es2> \<mapsto>* <e3,Es3>\<rbrakk> \<Longrightarrow> <e1,Es1> \<mapsto>* <e3,Es3>"

lemma ms3[intro,trans]:
  assumes a: "<e1,Es1> \<mapsto>* <e2,Es2>" "<e2,Es2> \<mapsto>* <e3,Es3>"
  shows "<e1,Es1> \<mapsto>* <e3,Es3>"
using a by (induct) (auto) 

lemma ms4[intro]:
  assumes a: "<e1,Es1> \<mapsto> <e2,Es2>" 
  shows "<e1,Es1> \<mapsto>* <e2,Es2>"
using a
by (rule ms2) (rule ms1)

inductive
  eval :: "lam\<Rightarrow>lam\<Rightarrow>bool" ("_ \<Down> _") 
where
  eval_lam[intro]: "Lam [x].t \<Down> Lam [x].t"
| eval_app[intro]: "\<lbrakk>t1\<Down> Lam [x].t; t2\<Down> t2'; t[x::=t2']\<Down> t'\<rbrakk> \<Longrightarrow> App t1 t2 \<Down> t'"

lemma eval_app_elim:
  assumes a: "App t1 t2 \<Down> t'"
  shows "\<exists>x t t2'. t1\<Down> Lam [x].t \<and> t2\<Down> t2' \<and> t[x::=t2']\<Down> t'"
using a by (cases) (auto simp add: lam.inject)

lemma eval_to:
  assumes a: "t \<Down> t'"
  shows "val t'"
using a by (induct) (auto)

lemma eval_val:
  assumes a: "val t"
  shows "t \<Down> t"
using a by (induct) (auto)

theorem
  assumes a: "t \<Down> t'"
  shows "<t,Es> \<mapsto>* <t',Es>"
using a
apply(induct arbitrary: Es)
apply(metis eval_to m1 ms1 m2 ms2 m3 ms3 ms4 v_Lam)+
done

fun 
 ctx_compose :: "ctx \<Rightarrow> ctx \<Rightarrow> ctx" ("_ \<circ> _")
where
  "\<box> \<circ> E' = E'"
| "(CAppL E t') \<circ> E' = CAppL (E \<circ> E') t'"
| "(CAppR t' E) \<circ> E' = CAppR t' (E \<circ> E')"


lemma ctx_compose:
  shows "(E1 \<circ> E2)\<lbrakk>t\<rbrakk> = E1\<lbrakk>E2\<lbrakk>t\<rbrakk>\<rbrakk>"
by (induct E1 rule: ctx.induct) (auto)

fun
  ctx_composes :: "ctx list \<Rightarrow> ctx" ("_\<down>")
where
    "[]\<down> = \<box>"
  | "(E#Es)\<down> = (Es\<down>) \<circ> E"

inductive
  cbv :: "lam\<Rightarrow>lam\<Rightarrow>bool" ("_ \<longrightarrow>cbv _") 
where
  cbv1[intro]: "val v \<Longrightarrow> App (Lam [x].t) v \<longrightarrow>cbv t[x::=v]"
| cbv2[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> App t t2 \<longrightarrow>cbv App t' t2"
| cbv3[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> App t2 t \<longrightarrow>cbv App t2 t'"

inductive 
  "cbv_star" :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>cbv* _")
where
  cbvs1[intro]: "e \<longrightarrow>cbv* e"
| cbvs2[intro]: "e \<longrightarrow>cbv e' \<Longrightarrow> e \<longrightarrow>cbv* e'"
| cbvs3[intro,trans]: "\<lbrakk>e1\<longrightarrow>cbv* e2; e2 \<longrightarrow>cbv* e3\<rbrakk> \<Longrightarrow> e1 \<longrightarrow>cbv* e3"

lemma cbv_in_ctx:
  assumes a: "t \<longrightarrow>cbv t'"
  shows "E\<lbrakk>t\<rbrakk> \<longrightarrow>cbv E\<lbrakk>t'\<rbrakk>"
using a 
by (induct E) (auto)

lemma machine_implies_cbv_star:
  assumes a: "<e,Es> \<mapsto> <e',Es'>"
  shows "(Es\<down>)\<lbrakk>e\<rbrakk> \<longrightarrow>cbv* (Es'\<down>)\<lbrakk>e'\<rbrakk>"
using a
by (induct) 
   (auto simp add: ctx_compose intro: cbv_in_ctx)

lemma cbv_eval:
  assumes a: "t1 \<longrightarrow>cbv t2" "t2 \<Down> t3"
  shows "t1 \<Down> t3"
using a
by (induct arbitrary: t3)
   (auto dest!: eval_app_elim intro: eval_val)

lemma cbv_star_eval:
  assumes a: "t1 \<longrightarrow>cbv* t2" "t2 \<Down> t3"
  shows "t1 \<Down> t3"
using a
by (induct) (auto simp add: cbv_eval)

lemma machine_implies_eval:
  assumes a: "<t1,Es> \<mapsto> <t2,Es'>" 
  and     b: "(Es'\<down>)\<lbrakk>t2\<rbrakk> \<Down> t3"
  shows "(Es\<down>)\<lbrakk>t1\<rbrakk> \<Down> t3"
proof -
  from a have "(Es\<down>)\<lbrakk>t1\<rbrakk> \<longrightarrow>cbv* (Es'\<down>)\<lbrakk>t2\<rbrakk>" by (rule machine_implies_cbv_star)
  moreover 
  have "(Es'\<down>)\<lbrakk>t2\<rbrakk> \<Down> t3" by fact
  ultimately show "(Es\<down>)\<lbrakk>t1\<rbrakk> \<Down> t3" by (rule cbv_star_eval)
qed

lemma machine_star_implies_eval:
  assumes a: "<t1,Es> \<mapsto>* <t2,[]>" "val t2" 
  shows "(Es\<down>)\<lbrakk>t1\<rbrakk> \<Down> t2"
using a
by (induct t1 Es t2 Es'\<equiv>"[]::ctx list")
   (auto simp add: eval_val machine_implies_eval)

theorem
  assumes a: "<t1,[]> \<mapsto>* <t2,[]>" "val t2" 
  shows "t1 \<Down> t2"
using a by (auto dest: machine_star_implies_eval)

 

end