theory Lec16
imports Nominal
begin

atom_decl name

nominal_datatype lam =
  Var "name"
| App "lam" "lam" 
| Lam "\<guillemotleft>name\<guillemotright>lam" ("Lam [_]._")
| I "nat"
| D "lam" "lam" ("_ -- _")
| P "lam" "lam" ("_ ++ _")
| TR
| FA
| IF "lam" "lam" "lam"
| Fix "\<guillemotleft>name\<guillemotright>lam" ("Fix [_]._")
| ZE "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])"
  "(I n)[y::=s] = I n"
  "(t\<^isub>1 -- t\<^isub>2)[y::=s] = (t\<^isub>1[y::=s]) -- (t\<^isub>2[y::=s])"
  "(t\<^isub>1 ++ t\<^isub>2)[y::=s] = (t\<^isub>1[y::=s]) ++ (t\<^isub>2[y::=s])"
  "x\<sharp>(y,s) \<Longrightarrow> (Fix [x].t)[y::=s] = Fix [x].(t[y::=s])"
  "TR[y::=s] = TR"
  "FA[y::=s] = FA"
  "(IF t1 t2 t3)[y::=s] = IF (t1[y::=s]) (t2[y::=s]) (t3[y::=s])"
  "(ZE t)[y::=s] = ZE (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"
  | CDiffL "ctx" "lam"
  | CDiffR "lam" "ctx"
  | CPlusL "ctx" "lam"
  | CPlusR "lam" "ctx"
  | CIf "ctx" "lam" "lam"
  | CZe "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>)"
| "(CDiffL E t')\<lbrakk>t\<rbrakk> = (E\<lbrakk>t\<rbrakk>) -- t'"
| "(CDiffR t' E)\<lbrakk>t\<rbrakk> = t' -- (E\<lbrakk>t\<rbrakk>)"
| "(CPlusL E t')\<lbrakk>t\<rbrakk> = P (E\<lbrakk>t\<rbrakk>) t'"
| "(CPlusR t' E)\<lbrakk>t\<rbrakk> = P t' (E\<lbrakk>t\<rbrakk>)"
| "(CIf E t1 t2)\<lbrakk>t\<rbrakk> = IF (E\<lbrakk>t\<rbrakk>) t1 t2"
| "(CZe E)\<lbrakk>t\<rbrakk> = ZE (E\<lbrakk>t\<rbrakk>)"

inductive
  val :: "lam\<Rightarrow>bool" 
where
  v_Lam[intro]: "val (Lam [x].e)"
| v_Int[intro]: "val (I n)"  
| v_false[intro]: "val FA"
| v_true[intro]:  "val TR"

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>"
| m4[intro]: "<e1 -- e2, Es> \<mapsto> <e1,(CDiffL \<box> e2)#Es>"
| m5[intro]: "<I n1,(CDiffL \<box> e2)#Es> \<mapsto> <e2,(CDiffR (I n1) \<box>)#Es>"
| m6[intro]: "<I n2,(CDiffR (I n1) \<box>)#Es> \<mapsto> <I (n1 - n2),Es>"
| m4'[intro]:"<e1 ++ e2, Es> \<mapsto> <e1,(CPlusL \<box> e2)#Es>"
| m5'[intro]:"<I n1,(CPlusL \<box> e2)#Es> \<mapsto> <e2,(CPlusR (I n1) \<box>)#Es>"
| m6'[intro]:"<I n2,(CPlusR (I n1) \<box>)#Es> \<mapsto> <I (n1+n2),Es>"
| m7[intro]: "<IF e1 e2 e3,Es> \<mapsto> <e1,(CIf \<box> e2 e3)#Es>"
| m8[intro]: "<TR,(CIf \<box> e1 e2)#Es> \<mapsto> <e1,Es>"
| m9[intro]: "<FA,(CIf \<box> e1 e2)#Es> \<mapsto> <e2,Es>"
| mA[intro]: "<Fix [x].t,Es> \<mapsto> <t[x::=Fix [x].t],Es>"
| mB[intro]: "<ZE e,Es> \<mapsto> <e,(CZe \<box>)#Es>"
| mC[intro]: "<I 0,(CZe \<box>)#Es> \<mapsto> <TR,Es>"
| mD[intro]: "0 < n \<Longrightarrow> <I n,(CZe \<box>)#Es> \<mapsto> <FA,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_int[intro]: "I n \<Down> I n" 
| eval_diff[intro]: "\<lbrakk>t1 \<Down> (I n1); t2 \<Down> (I n2)\<rbrakk> \<Longrightarrow> t1 -- t2 \<Down> I (n1 - n2)"
| eval_plus[intro]: "\<lbrakk>t1 \<Down> (I n1); t2 \<Down> (I n2)\<rbrakk> \<Longrightarrow> t1 ++ t2 \<Down> I (n1 + n2)"
| 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'"
| eval_fix[intro]: "t[x::= Fix [x].t] \<Down> t' \<Longrightarrow> Fix [x].t \<Down> t'"
| eval_if1[intro]: "\<lbrakk>t1 \<Down> TR; t2 \<Down> t'\<rbrakk> \<Longrightarrow> IF t1 t2 t3 \<Down> t'"
| eval_if2[intro]: "\<lbrakk>t1 \<Down> FA; t3 \<Down> t'\<rbrakk> \<Longrightarrow> IF t1 t2 t3 \<Down> t'"
| eval_true[intro]: "TR \<Down> TR"
| eval_false[intro]:"FA \<Down> FA"
| eval_ze1[intro]:  "t \<Down> I 0 \<Longrightarrow> ZE t \<Down> TR"
| eval_ze2[intro]:  "\<lbrakk>t \<Down> I n; 0 < n\<rbrakk> \<Longrightarrow> ZE t \<Down> FA"

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_if_elim:
  assumes a: "IF t1 t2 t3 \<Down> t'"
  shows "(t1 \<Down> TR \<and> t2 \<Down> t') \<or> (t1 \<Down> FA \<and> t3 \<Down> t')"
using a
apply(cases)
apply(auto simp add: lam.inject)
done

lemma eval_ze_elim:
  assumes a: "ZE t \<Down> t'"
  shows "(t \<Down> I 0 \<and> t' = TR) \<or> (\<exists>n. t \<Down> I n \<and> 0 < n \<and> t' = FA)"
using a
apply(cases)
apply(auto simp add: lam.inject)
done

lemma eval_plus_elim:
  assumes a: "P t1 t2 \<Down> t'"
  shows "\<exists>n1 n2. t1\<Down> (I n1) \<and> t2\<Down> (I n2) \<and> t' = I (n1 + n2)"
using a by (cases) (auto simp add: lam.inject)

lemma eval_diff_elim:
  assumes a: "t1 -- t2 \<Down> t'"
  shows "\<exists>n1 n2. t1\<Down> (I n1) \<and> t2\<Down> (I n2) \<and> t' = I (n1 - n2)"
using a by (cases) (auto simp add: lam.inject)

lemma eval_int_elim:
  assumes a: "(I n) \<Down> t"
  shows "t = I n"
using a by (cases) (auto simp add: lam.inject)

lemma eval_TR_elim:
  assumes a: "TR \<Down> t"
  shows "t = TR"
using a
by (cases) (auto)

lemma eval_FA_elim:
  assumes a: "FA \<Down> t"
  shows "t = FA"
using a
by (cases) (auto)

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 m4 m5 m6 m4' m5' m6' m7 m8 m9 mA mB mC mD 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')"
| "(CDiffL E t') \<circ> E' = CDiffL (E \<circ> E') t'"
| "(CDiffR t' E) \<circ> E' = CDiffR t' (E \<circ> E')"
| "(CPlusL E t') \<circ> E' = CPlusL (E \<circ> E') t'"
| "(CPlusR t' E) \<circ> E' = CPlusR t' (E \<circ> E')"
| "(CIf E t1 t2) \<circ> E' = CIf (E \<circ> E') t1 t2"
| "(CZe E) \<circ> E' = CZe (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'"
| cbv4[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> t -- t2 \<longrightarrow>cbv t' -- t2"
| cbv5[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> t2 -- t \<longrightarrow>cbv t2 -- t'"
| cbv6[intro]: "(I n1) -- (I n2) \<longrightarrow>cbv I (n1 - n2)"
| cbv4'[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> t ++ t2 \<longrightarrow>cbv t' ++ t2"
| cbv5'[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> t2 ++ t \<longrightarrow>cbv t2 ++ t'"
| cbv6'[intro]:"(I n1) ++ (I n2) \<longrightarrow>cbv I (n1 + n2)"
| cbv7[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> IF t t1 t2 \<longrightarrow>cbv IF t' t1 t2"
| cbv8[intro]: "IF TR t1 t2 \<longrightarrow>cbv t1"
| cbv9[intro]: "IF FA t1 t2 \<longrightarrow>cbv t2"
| cbvA[intro]: "Fix [x].t \<longrightarrow>cbv t[x::=Fix [x].t]"
| cbvB[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> ZE t \<longrightarrow>cbv ZE t'"
| cbvC[intro]: "ZE (I 0) \<longrightarrow>cbv TR"
| cbvD[intro]: "0 < n \<Longrightarrow> ZE (I n) \<longrightarrow>cbv FA"


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
apply(induct) 
apply(auto simp add: ctx_compose intro: cbv_in_ctx)
done

lemma cbv_eval:
  assumes a: "t1 \<longrightarrow>cbv t2" "t2 \<Down> t3"
  shows "t1 \<Down> t3"
using a
apply(induct arbitrary: t3)
apply(auto dest!: eval_app_elim eval_ze_elim eval_diff_elim 
                  eval_int_elim eval_if_elim eval_plus_elim 
                  eval_FA_elim eval_TR_elim
                  intro: eval_val)
done

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)

text {* example *}

lemma forget: 
  assumes asm: "y\<sharp>t"
  shows "t[y::=s] = t"
  using asm 
by (nominal_induct t avoiding: y s rule: lam.strong_induct)
   (auto simp add: abs_fresh fresh_atm)

lemma forget2: 
  shows "(Lam [y].t)[y::=s] = (Lam [y].t)"
apply(rule forget)
apply(simp add: abs_fresh)
done

consts 
  x::"name"
  f::"name"

abbreviation
  MY :: "lam"
where
  "MY \<equiv> Fix [f].Lam [x].(IF (ZE (Var x)) (I 0) ((Var x) ++ (App (Var f) ((Var x) -- I 1))))"

lemma aux:
  assumes a: "t \<Down> t'" "t' = t''"
  shows "t \<Down> t''"
using a by simp

lemma
  assumes a: "x\<noteq>f"
  shows "App MY (I 1) \<Down> (I 1)"
using a
apply(auto)
apply(rule eval_app)
apply(rule eval_fix)
apply(auto simp add: abs_fresh fresh_atm fresh_nat forget2)
apply(rule eval_if2)
apply(rule eval_ze2)
apply(auto)[2]
apply(rule aux)
apply(rule eval_plus)
apply(auto)[1]
apply(rule eval_app)
apply(rule eval_fix)
apply(auto simp add: abs_fresh fresh_atm fresh_nat)
apply(rule eval_if1)
apply(rule eval_ze1)
apply(auto simp add: nat_number)
done

lemma
  assumes a: "x\<noteq>f"
  shows "<App MY (I 1),[]> \<mapsto>* <I 1,[]>"
using a
apply(auto)
apply(rule ms2)
apply(rule machine.intros)
apply(rule ms2)
apply(rule mA)
apply(auto simp add: abs_fresh fresh_atm fresh_nat forget2)
apply(rule ms2)
apply(rule machine.intros)
apply(rule val.intros)
apply(rule ms2)
apply(rule machine.intros)
apply(rule val.intros)
apply(auto simp add: abs_fresh fresh_atm fresh_nat forget2)
apply(rule ms2)
apply(rule machine.intros)
apply(rule ms2)
apply(rule machine.intros)
apply(rule ms2)
apply(rule machine.intros)
apply(auto)[1]
apply(rule ms2)
apply(rule machine.intros)
apply(rule ms2)
apply(rule machine.intros)
apply(rule ms2)
apply(rule machine.intros)
apply(rule ms2)
apply(rule machine.intros)
apply(rule ms2)
apply(rule mA)
apply(auto simp add: abs_fresh fresh_atm fresh_nat forget2)
apply(rule ms2)
apply(rule machine.intros)
apply(auto)[1]
apply(rule ms2)
apply(rule m4)
apply(rule ms2)
apply(rule machine.intros)
apply(rule ms2)
apply(rule machine.intros)
apply(rule ms2)
apply(rule machine.intros)
apply(auto)[1]
apply(auto simp add: abs_fresh fresh_atm fresh_nat forget2)
apply(rule ms2)
apply(rule machine.intros)
apply(rule ms2)
apply(rule machine.intros)
apply(rule ms2)
apply(rule machine.intros)
apply(rule ms2)
apply(rule machine.intros)
apply(rule ms2)
apply(rule machine.intros)
apply(simp add: nat_number)
apply(rule ms1)
done

lemma
  assumes a: "x\<noteq>f"
  shows "App MY (I 2) \<Down> (I 3)"
using a
apply(auto)
apply(rule eval_app)
apply(rule eval_fix)
apply(auto simp add: abs_fresh fresh_atm fresh_nat forget2)
apply(rule eval_if2)
apply(rule eval_ze2)
apply(auto simp add: nat_number)[2]
apply(rule aux)
apply(rule eval_plus)
apply(auto)[1]
apply(rule eval_app)
apply(rule eval_fix)
apply(auto simp add: abs_fresh fresh_atm fresh_nat)
apply(rule eval_if2)
apply(rule eval_ze2)
apply(auto simp add: nat_number)
apply(rule aux)
apply(rule eval_plus)
apply(auto)[1]
apply(rule eval_app)
apply(rule eval_fix)
apply(auto simp add: abs_fresh fresh_atm fresh_nat forget2)
apply(rule eval_if1)
apply(rule eval_ze1)
apply(auto simp add: nat_number)
done

end