Theory Pattern

Up to index of Isabelle/HOL/HOL-Nominal/Examples

theory Pattern
imports Nominal

header {* Simply-typed lambda-calculus with let and tuple patterns *}

theory Pattern
imports Nominal
begin


no_syntax
"_Map" :: "maplets => 'a ~=> 'b" ("(1[_])")


atom_decl name

nominal_datatype ty =
Atom nat
| Arrow ty ty (infixr "->" 200)
| TupleT ty ty (infixr "⊗" 210)


lemma fresh_type [simp]: "(a::name) \<sharp> (T::ty)"
by (induct T rule: ty.induct) (simp_all add: fresh_nat)

lemma supp_type [simp]: "supp (T::ty) = ({} :: name set)"
by (induct T rule: ty.induct) (simp_all add: ty.supp supp_nat)

lemma perm_type: "(pi::name prm) • (T::ty) = T"
by (induct T rule: ty.induct) (simp_all add: perm_nat_def)

nominal_datatype trm =
Var name
| Tuple trm trm ("(1'⟨_,/ _'⟩)")
| Abs ty "«name»trm"
| App trm trm (infixl "·" 200)
| Let ty trm btrm
and btrm =
Base trm
| Bind ty "«name»btrm"


abbreviation
Abs_syn :: "name => ty => trm => trm" ("(3λ_:_./ _)" [0, 0, 10] 10)
where
"λx:T. t ≡ Abs T x t"


datatype pat =
PVar name ty
| PTuple pat pat ("(1'⟨⟨_,/ _'⟩⟩)")


(* FIXME: The following should be done automatically by the nominal package *)
overloading pat_perm "perm :: name prm => pat => pat" (unchecked)
begin


primrec pat_perm
where
"pat_perm pi (PVar x ty) = PVar (pi • x) (pi • ty)"
| "pat_perm pi ⟨⟨p, q⟩⟩ = ⟨⟨pat_perm pi p, pat_perm pi q⟩⟩"


end

declare pat_perm.simps [eqvt]

lemma supp_PVar [simp]: "((supp (PVar x T))::name set) = supp x"
by (simp add: supp_def perm_fresh_fresh)

lemma supp_PTuple [simp]: "((supp ⟨⟨p, q⟩⟩)::name set) = supp p ∪ supp q"
by (simp add: supp_def Collect_disj_eq del: disj_not1)

instance pat :: pt_name
proof intro_classes
case goal1
show ?case by (induct x) simp_all
next
case goal2
show ?case by (induct x) (simp_all add: pt_name2)
next
case goal3
then show ?case by (induct x) (simp_all add: pt_name3)
qed

instance pat :: fs_name
proof intro_classes
case goal1
show ?case by (induct x) (simp_all add: fin_supp)
qed

(* the following function cannot be defined using nominal_primrec, *)
(* since variable parameters are currently not allowed. *)
primrec abs_pat :: "pat => btrm => btrm" ("(3λ[_]./ _)" [0, 10] 10)
where
"(λ[PVar x T]. t) = Bind T x t"
| "(λ[⟨⟨p, q⟩⟩]. t) = (λ[p]. λ[q]. t)"


lemma abs_pat_eqvt [eqvt]:
"(pi :: name prm) • (λ[p]. t) = (λ[pi • p]. (pi • t))"

by (induct p arbitrary: t) simp_all

lemma abs_pat_fresh [simp]:
"(x::name) \<sharp> (λ[p]. t) = (x ∈ supp p ∨ x \<sharp> t)"

by (induct p arbitrary: t) (simp_all add: abs_fresh supp_atm)

lemma abs_pat_alpha:
assumes fresh: "((pi::name prm) • supp p::name set) \<sharp>* t"
and pi: "set pi ⊆ supp p × pi • supp p"
shows "(λ[p]. t) = (λ[pi • p]. pi • t)"

proof -
note pt_name_inst at_name_inst pi
moreover have "(supp p::name set) \<sharp>* (λ[p]. t)"
by (simp add: fresh_star_def)
moreover from fresh
have "(pi • supp p::name set) \<sharp>* (λ[p]. t)"
by (simp add: fresh_star_def)
ultimately have "pi • (λ[p]. t) = (λ[p]. t)"
by (rule pt_freshs_freshs)
then show ?thesis by (simp add: eqvts)
qed

primrec pat_vars :: "pat => name list"
where
"pat_vars (PVar x T) = [x]"
| "pat_vars ⟨⟨p, q⟩⟩ = pat_vars q @ pat_vars p"


lemma pat_vars_eqvt [eqvt]:
"(pi :: name prm) • (pat_vars p) = pat_vars (pi • p)"

by (induct p rule: pat.induct) (simp_all add: eqvts)

lemma set_pat_vars_supp: "set (pat_vars p) = supp p"
by (induct p) (auto simp add: supp_atm)

lemma distinct_eqvt [eqvt]:
"(pi :: name prm) • (distinct (xs::name list)) = distinct (pi • xs)"

by (induct xs) (simp_all add: eqvts)

primrec pat_type :: "pat => ty"
where
"pat_type (PVar x T) = T"
| "pat_type ⟨⟨p, q⟩⟩ = pat_type p ⊗ pat_type q"


lemma pat_type_eqvt [eqvt]:
"(pi :: name prm) • (pat_type p) = pat_type (pi • p)"

by (induct p) simp_all

lemma pat_type_perm_eq: "pat_type ((pi :: name prm) • p) = pat_type p"
by (induct p) (simp_all add: perm_type)

types ctx = "(name × ty) list"

inductive
ptyping :: "pat => ty => ctx => bool" ("\<turnstile> _ : _ => _" [60, 60, 60] 60)
where
PVar: "\<turnstile> PVar x T : T => [(x, T)]"
| PTuple: "\<turnstile> p : T => Δ1 ==> \<turnstile> q : U => Δ2 ==> \<turnstile> ⟨⟨p, q⟩⟩ : T ⊗ U => Δ2 @ Δ1"


lemma pat_vars_ptyping:
assumes "\<turnstile> p : T => Δ"
shows "pat_vars p = map fst Δ"
using assms
by induct simp_all

inductive
valid :: "ctx => bool"
where
Nil [intro!]: "valid []"
| Cons [intro!]: "valid Γ ==> x \<sharp> Γ ==> valid ((x, T) # Γ)"


inductive_cases validE[elim!]: "valid ((x, T) # Γ)"

lemma fresh_ctxt_set_eq: "((x::name) \<sharp> (Γ::ctx)) = (x ∉ fst ` set Γ)"
by (induct Γ) (auto simp add: fresh_list_nil fresh_list_cons fresh_prod fresh_atm)

lemma valid_distinct: "valid Γ = distinct (map fst Γ)"
by (induct Γ) (auto simp add: fresh_ctxt_set_eq [symmetric])

abbreviation
"sub_ctx" :: "ctx => ctx => bool" ("_ \<sqsubseteq> _")
where
1 \<sqsubseteq> Γ2 ≡ ∀x. x ∈ set Γ1 --> x ∈ set Γ2"


abbreviation
Let_syn :: "pat => trm => trm => trm" ("(LET (_ =/ _)/ IN (_))" 10)
where
"LET p = t IN u ≡ Let (pat_type p) t (λ[p]. Base u)"


inductive typing :: "ctx => trm => ty => bool" ("_ \<turnstile> _ : _" [60, 60, 60] 60)
where
Var [intro]: "valid Γ ==> (x, T) ∈ set Γ ==> Γ \<turnstile> Var x : T"
| Tuple [intro]: "Γ \<turnstile> t : T ==> Γ \<turnstile> u : U ==> Γ \<turnstile> ⟨t, u⟩ : T ⊗ U"
| Abs [intro]: "(x, T) # Γ \<turnstile> t : U ==> Γ \<turnstile> (λx:T. t) : T -> U"
| App [intro]: "Γ \<turnstile> t : T -> U ==> Γ \<turnstile> u : T ==> Γ \<turnstile> t · u : U"
| Let: "((supp p)::name set) \<sharp>* t ==>
Γ \<turnstile> t : T ==> \<turnstile> p : T => Δ ==> Δ @ Γ \<turnstile> u : U ==>
Γ \<turnstile> (LET p = t IN u) : U"


equivariance ptyping

equivariance valid

equivariance typing

lemma valid_typing:
assumes "Γ \<turnstile> t : T"
shows "valid Γ"
using assms
by induct auto

lemma pat_var:
assumes "\<turnstile> p : T => Δ"
shows "(supp p::name set) = supp Δ"
using assms
by induct (auto simp add: supp_list_nil supp_list_cons supp_prod supp_list_append)

lemma valid_app_fresh:
assumes "valid (Δ @ Γ)" and "(x::name) ∈ supp Δ"
shows "x \<sharp> Γ"
using assms
by (induct Δ)
(auto simp add: supp_list_nil supp_list_cons supp_prod supp_atm fresh_list_append)


lemma pat_freshs:
assumes "\<turnstile> p : T => Δ"
shows "(supp p::name set) \<sharp>* c = (supp Δ::name set) \<sharp>* c"
using assms
by (auto simp add: fresh_star_def pat_var)

lemma valid_app_mono:
assumes "valid (Δ @ Γ1)" and "(supp Δ::name set) \<sharp>* Γ2" and "valid Γ2" and 1 \<sqsubseteq> Γ2"
shows "valid (Δ @ Γ2)"
using assms
by (induct Δ)
(auto simp add: supp_list_cons fresh_star_Un_elim supp_prod
fresh_list_append supp_atm fresh_star_insert_elim fresh_star_empty_elim)


nominal_inductive2 typing
avoids
Abs: "{x}"
| Let: "(supp p)::name set"

by (auto simp add: fresh_star_def abs_fresh fin_supp pat_var
dest!: valid_typing valid_app_fresh)


lemma better_T_Let [intro]:
assumes t: "Γ \<turnstile> t : T" and p: "\<turnstile> p : T => Δ" and u: "Δ @ Γ \<turnstile> u : U"
shows "Γ \<turnstile> (LET p = t IN u) : U"

proof -
obtain pi::"name prm" where pi: "(pi • (supp p::name set)) \<sharp>* (t, Base u, Γ)"
and pi': "set pi ⊆ supp p × (pi • supp p)"

by (rule at_set_avoiding [OF at_name_inst fin_supp fin_supp])
from p u have p_fresh: "(supp p::name set) \<sharp>* Γ"
by (auto simp add: fresh_star_def pat_var dest!: valid_typing valid_app_fresh)
from pi have p_fresh': "(pi • (supp p::name set)) \<sharp>* Γ"
by (simp add: fresh_star_prod_elim)
from pi have p_fresh'': "(pi • (supp p::name set)) \<sharp>* Base u"
by (simp add: fresh_star_prod_elim)
from pi have "(supp (pi • p)::name set) \<sharp>* t"
by (simp add: fresh_star_prod_elim eqvts)
moreover note t
moreover from p have "pi • (\<turnstile> p : T => Δ)" by (rule perm_boolI)
then have "\<turnstile> (pi • p) : T => (pi • Δ)" by (simp add: eqvts perm_type)
moreover from u have "pi • (Δ @ Γ \<turnstile> u : U)" by (rule perm_boolI)
with pt_freshs_freshs [OF pt_name_inst at_name_inst pi' p_fresh p_fresh']
have "(pi • Δ) @ Γ \<turnstile> (pi • u) : U" by (simp add: eqvts perm_type)
ultimately have "Γ \<turnstile> (LET (pi • p) = t IN (pi • u)) : U"
by (rule Let)
then show ?thesis by (simp add: abs_pat_alpha [OF p_fresh'' pi'] pat_type_perm_eq)
qed

lemma weakening:
assumes 1 \<turnstile> t : T" and "valid Γ2" and 1 \<sqsubseteq> Γ2"
shows 2 \<turnstile> t : T"
using assms
apply (nominal_induct Γ1 t T avoiding: Γ2 rule: typing.strong_induct)
apply auto
apply (drule_tac x="(x, T) # Γ2" in meta_spec)
apply (auto intro: valid_typing)
apply (drule_tac x=2" in meta_spec)
apply (drule_tac x="Δ @ Γ2" in meta_spec)
apply (auto intro: valid_typing)
apply (rule typing.Let)
apply assumption+
apply (drule meta_mp)
apply (rule valid_app_mono)
apply (rule valid_typing)
apply assumption
apply (auto simp add: pat_freshs)
done

inductive
match :: "pat => trm => (name × trm) list => bool" ("\<turnstile> _ \<rhd> _ => _" [50, 50, 50] 50)
where
PVar: "\<turnstile> PVar x T \<rhd> t => [(x, t)]"
| PProd: "\<turnstile> p \<rhd> t => ϑ ==> \<turnstile> q \<rhd> u => ϑ' ==> \<turnstile> ⟨⟨p, q⟩⟩ \<rhd> ⟨t, u⟩ => ϑ @ ϑ'"


fun
lookup :: "(name × trm) list => name => trm"
where
"lookup [] x = Var x"
| "lookup ((y, e) # ϑ) x = (if x = y then e else lookup ϑ x)"


lemma lookup_eqvt[eqvt]:
fixes pi :: "name prm"
and ϑ :: "(name × trm) list"
and X :: "name"
shows "pi • (lookup ϑ X) = lookup (pi • ϑ) (pi • X)"

by (induct ϑ) (auto simp add: eqvts)

nominal_primrec
psubst :: "(name × trm) list => trm => trm" ("_(|_|))," [95,0] 210)
and psubstb :: "(name × trm) list => btrm => btrm" ("_(|_|)),b" [95,0] 210)
where
"ϑ(|Var x|)), = (lookup ϑ x)"
| "ϑ(|t · u|)), = ϑ(|t|)), · ϑ(|u|)),"
| "ϑ(|⟨t, u⟩|)), = ⟨ϑ(|t|)),, ϑ(|u|)),⟩"
| "ϑ(|Let T t u|)), = Let T (ϑ(|t|)),) (ϑ(|u|)),b)"
| "x \<sharp> ϑ ==> ϑ(|λx:T. t|)), = (λx:T. ϑ(|t|)),)"
| "ϑ(|Base t|)),b = Base (ϑ(|t|)),)"
| "x \<sharp> ϑ ==> ϑ(|Bind T x t|)),b = Bind T x (ϑ(|t|)),b)"

apply finite_guess+
apply (simp add: abs_fresh | fresh_guess)+
done

lemma lookup_fresh:
"x = y --> x ∈ set (map fst ϑ) ==> ∀(y, t)∈set ϑ. x \<sharp> t ==> x \<sharp> lookup ϑ y"

apply (induct ϑ)
apply (simp_all add: split_paired_all fresh_atm)
apply (case_tac "x = y")
apply (auto simp add: fresh_atm)
done

lemma psubst_fresh:
assumes "x ∈ set (map fst ϑ)" and "∀(y, t)∈set ϑ. x \<sharp> t"
shows "x \<sharp> ϑ(|t|))," and "x \<sharp> ϑ(|t'|)),b"
using assms
apply (nominal_induct t and t' avoiding: ϑ rule: trm_btrm.strong_inducts)
apply simp
apply (rule lookup_fresh)
apply (rule impI)
apply (simp_all add: abs_fresh)
done

lemma psubst_eqvt[eqvt]:
fixes pi :: "name prm"
shows "pi • (ϑ(|t|)),) = (pi • ϑ)(|pi • t|)),"
and "pi • (ϑ(|t'|)),b) = (pi • ϑ)(|pi • t'|)),b"

by (nominal_induct t and t' avoiding: ϑ rule: trm_btrm.strong_inducts)
(simp_all add: eqvts fresh_bij)


abbreviation
subst :: "trm => name => trm => trm" ("_[_\<mapsto>_]" [100,0,0] 100)
where
"t[x\<mapsto>t'] ≡ [(x,t')](|t|)),"


abbreviation
substb :: "btrm => name => trm => btrm" ("_[_\<mapsto>_]b" [100,0,0] 100)
where
"t[x\<mapsto>t']b ≡ [(x,t')](|t|)),b"


lemma lookup_forget:
"(supp (map fst ϑ)::name set) \<sharp>* x ==> lookup ϑ x = Var x"

by (induct ϑ) (auto simp add: split_paired_all fresh_star_def fresh_atm supp_list_cons supp_atm)

lemma supp_fst: "(x::name) ∈ supp (map fst (ϑ::(name × trm) list)) ==> x ∈ supp ϑ"
by (induct ϑ) (auto simp add: supp_list_nil supp_list_cons supp_prod)

lemma psubst_forget:
"(supp (map fst ϑ)::name set) \<sharp>* t ==> ϑ(|t|)), = t"
"(supp (map fst ϑ)::name set) \<sharp>* t' ==> ϑ(|t'|)),b = t'"

apply (nominal_induct t and t' avoiding: ϑ rule: trm_btrm.strong_inducts)
apply (auto simp add: fresh_star_def lookup_forget abs_fresh)
apply (drule_tac x=ϑ in meta_spec)
apply (drule meta_mp)
apply (rule ballI)
apply (drule_tac x=x in bspec)
apply assumption
apply (drule supp_fst)
apply (auto simp add: fresh_def)
apply (drule_tac x=ϑ in meta_spec)
apply (drule meta_mp)
apply (rule ballI)
apply (drule_tac x=x in bspec)
apply assumption
apply (drule supp_fst)
apply (auto simp add: fresh_def)
done

lemma psubst_nil: "[](|t|)), = t" "[](|t'|)),b = t'"
by (induct t and t' rule: trm_btrm.inducts) (simp_all add: fresh_list_nil)

lemma psubst_cons:
assumes "(supp (map fst ϑ)::name set) \<sharp>* u"
shows "((x, u) # ϑ)(|t|)), = ϑ(|t[x\<mapsto>u]|))," and "((x, u) # ϑ)(|t'|)),b = ϑ(|t'[x\<mapsto>u]b|)),b"

using assms
by (nominal_induct t and t' avoiding: x u ϑ rule: trm_btrm.strong_inducts)
(simp_all add: fresh_list_nil fresh_list_cons psubst_forget)


lemma psubst_append:
"(supp (map fst (ϑ1 @ ϑ2))::name set) \<sharp>* map snd (ϑ1 @ ϑ2) ==> (ϑ1 @ ϑ2)(|t|)), = ϑ2(|ϑ1(|t|)),|)),"

by (induct ϑ1 arbitrary: t)
(simp_all add: psubst_nil split_paired_all supp_list_cons psubst_cons fresh_star_def
fresh_list_cons fresh_list_append supp_list_append)


lemma abs_pat_psubst [simp]:
"(supp p::name set) \<sharp>* ϑ ==> ϑ(|λ[p]. t|)),b = (λ[p]. ϑ(|t|)),b)"

by (induct p arbitrary: t) (auto simp add: fresh_star_def supp_atm)

lemma valid_insert:
assumes "valid (Δ @ [(x, T)] @ Γ)"
shows "valid (Δ @ Γ)"
using assms
by (induct Δ)
(auto simp add: fresh_list_append fresh_list_cons)


lemma fresh_set:
shows "y \<sharp> xs = (∀x∈set xs. y \<sharp> x)"

by (induct xs) (simp_all add: fresh_list_nil fresh_list_cons)

lemma context_unique:
assumes "valid Γ"
and "(x, T) ∈ set Γ"
and "(x, U) ∈ set Γ"
shows "T = U"
using assms
by induct (auto simp add: fresh_set fresh_prod fresh_atm)

lemma subst_type_aux:
assumes a: "Δ @ [(x, U)] @ Γ \<turnstile> t : T"
and b: "Γ \<turnstile> u : U"
shows "Δ @ Γ \<turnstile> t[x\<mapsto>u] : T"
using a b
proof (nominal_induct Γ'"Δ @ [(x, U)] @ Γ" t T avoiding: x u Δ rule: typing.strong_induct)
case (Var y T x u Δ)
from `valid (Δ @ [(x, U)] @ Γ)`
have valid: "valid (Δ @ Γ)" by (rule valid_insert)
show "Δ @ Γ \<turnstile> Var y[x\<mapsto>u] : T"
proof cases
assume eq: "x = y"
from Var eq have "T = U" by (auto intro: context_unique)
with Var eq valid show "Δ @ Γ \<turnstile> Var y[x\<mapsto>u] : T" by (auto intro: weakening)
next
assume ineq: "x ≠ y"
from Var ineq have "(y, T) ∈ set (Δ @ Γ)" by simp
then show "Δ @ Γ \<turnstile> Var y[x\<mapsto>u] : T" using ineq valid by auto
qed
next
case (Tuple t1 T1 t2 T2)
from refl `Γ \<turnstile> u : U`
have "Δ @ Γ \<turnstile> t1[x\<mapsto>u] : T1" by (rule Tuple)
moreover from refl `Γ \<turnstile> u : U`
have "Δ @ Γ \<turnstile> t2[x\<mapsto>u] : T2" by (rule Tuple)
ultimately have "Δ @ Γ \<turnstile> ⟨t1[x\<mapsto>u], t2[x\<mapsto>u]⟩ : T1 ⊗ T2" ..
then show ?case by simp
next
case (Let p t T Δ' s S)
from refl `Γ \<turnstile> u : U`
have "Δ @ Γ \<turnstile> t[x\<mapsto>u] : T" by (rule Let)
moreover note `\<turnstile> p : T => Δ'`
moreover have "Δ' @ (Δ @ [(x, U)] @ Γ) = (Δ' @ Δ) @ [(x, U)] @ Γ" by simp
then have "(Δ' @ Δ) @ Γ \<turnstile> s[x\<mapsto>u] : S" using `Γ \<turnstile> u : U` by (rule Let)
then have "Δ' @ Δ @ Γ \<turnstile> s[x\<mapsto>u] : S" by simp
ultimately have "Δ @ Γ \<turnstile> (LET p = t[x\<mapsto>u] IN s[x\<mapsto>u]) : S"
by (rule better_T_Let)
moreover from Let have "(supp p::name set) \<sharp>* [(x, u)]"
by (simp add: fresh_star_def fresh_list_nil fresh_list_cons)
ultimately show ?case by simp
next
case (Abs y T t S)
have "(y, T) # Δ @ [(x, U)] @ Γ = ((y, T) # Δ) @ [(x, U)] @ Γ"
by simp
then have "((y, T) # Δ) @ Γ \<turnstile> t[x\<mapsto>u] : S" using `Γ \<turnstile> u : U` by (rule Abs)
then have "(y, T) # Δ @ Γ \<turnstile> t[x\<mapsto>u] : S" by simp
then have "Δ @ Γ \<turnstile> (λy:T. t[x\<mapsto>u]) : T -> S"
by (rule typing.Abs)
moreover from Abs have "y \<sharp> [(x, u)]"
by (simp add: fresh_list_nil fresh_list_cons)
ultimately show ?case by simp
next
case (App t1 T S t2)
from refl `Γ \<turnstile> u : U`
have "Δ @ Γ \<turnstile> t1[x\<mapsto>u] : T -> S" by (rule App)
moreover from refl `Γ \<turnstile> u : U`
have "Δ @ Γ \<turnstile> t2[x\<mapsto>u] : T" by (rule App)
ultimately have "Δ @ Γ \<turnstile> (t1[x\<mapsto>u]) · (t2[x\<mapsto>u]) : S"
by (rule typing.App)
then show ?case by simp
qed

lemmas subst_type = subst_type_aux [of "[]", simplified]

lemma match_supp_fst:
assumes "\<turnstile> p \<rhd> u => ϑ" shows "(supp (map fst ϑ)::name set) = supp p"
using assms
by induct (simp_all add: supp_list_nil supp_list_cons supp_list_append)

lemma match_supp_snd:
assumes "\<turnstile> p \<rhd> u => ϑ" shows "(supp (map snd ϑ)::name set) = supp u"
using assms
by induct (simp_all add: supp_list_nil supp_list_cons supp_list_append trm.supp)

lemma match_fresh: "\<turnstile> p \<rhd> u => ϑ ==> (supp p::name set) \<sharp>* u ==>
(supp (map fst ϑ)::name set) \<sharp>* map snd ϑ"

by (simp add: fresh_star_def fresh_def match_supp_fst match_supp_snd)

lemma match_type_aux:
assumes "\<turnstile> p : U => Δ"
and 2 \<turnstile> u : U"
and 1 @ Δ @ Γ2 \<turnstile> t : T"
and "\<turnstile> p \<rhd> u => ϑ"
and "(supp p::name set) \<sharp>* u"
shows 1 @ Γ2 \<turnstile> ϑ(|t|)), : T"
using assms
proof (induct arbitrary: Γ1 Γ2 t u T ϑ)
case (PVar x U)
from 1 @ [(x, U)] @ Γ2 \<turnstile> t : T` 2 \<turnstile> u : U`
have 1 @ Γ2 \<turnstile> t[x\<mapsto>u] : T" by (rule subst_type_aux)
moreover from `\<turnstile> PVar x U \<rhd> u => ϑ` have "ϑ = [(x, u)]"
by cases simp_all
ultimately show ?case by simp
next
case (PTuple p S Δ1 q U Δ2)
from `\<turnstile> ⟨⟨p, q⟩⟩ \<rhd> u => ϑ` obtain u1 u2 ϑ1 ϑ2
where u: "u = ⟨u1, u2⟩" and ϑ: "ϑ = ϑ1 @ ϑ2"
and p: "\<turnstile> p \<rhd> u1 => ϑ1" and q: "\<turnstile> q \<rhd> u2 => ϑ2"

by cases simp_all
with PTuple have 2 \<turnstile> ⟨u1, u2⟩ : S ⊗ U" by simp
then obtain u1: 2 \<turnstile> u1 : S" and u2: 2 \<turnstile> u2 : U"
by cases (simp_all add: ty.inject trm.inject)
note u1
moreover from 1 @ (Δ2 @ Δ1) @ Γ2 \<turnstile> t : T`
have "(Γ1 @ Δ2) @ Δ1 @ Γ2 \<turnstile> t : T" by simp
moreover note p
moreover from `supp ⟨⟨p, q⟩⟩ \<sharp>* u` and u
have "(supp p::name set) \<sharp>* u1" by (simp add: fresh_star_def)
ultimately have ϑ1: "(Γ1 @ Δ2) @ Γ2 \<turnstile> ϑ1(|t|)), : T"
by (rule PTuple)
note u2
moreover from ϑ1
have 1 @ Δ2 @ Γ2 \<turnstile> ϑ1(|t|)), : T" by simp
moreover note q
moreover from `supp ⟨⟨p, q⟩⟩ \<sharp>* u` and u
have "(supp q::name set) \<sharp>* u2" by (simp add: fresh_star_def)
ultimately have 1 @ Γ2 \<turnstile> ϑ2(|ϑ1(|t|)),|)), : T"
by (rule PTuple)
moreover from `\<turnstile> ⟨⟨p, q⟩⟩ \<rhd> u => ϑ` `supp ⟨⟨p, q⟩⟩ \<sharp>* u`
have "(supp (map fst ϑ)::name set) \<sharp>* map snd ϑ"
by (rule match_fresh)
ultimately show ?case using ϑ by (simp add: psubst_append)
qed

lemmas match_type = match_type_aux [where Γ1="[]", simplified]

inductive eval :: "trm => trm => bool" ("_ \<longmapsto> _" [60,60] 60)
where
TupleL: "t \<longmapsto> t' ==> ⟨t, u⟩ \<longmapsto> ⟨t', u⟩"
| TupleR: "u \<longmapsto> u' ==> ⟨t, u⟩ \<longmapsto> ⟨t, u'⟩"
| Abs: "t \<longmapsto> t' ==> (λx:T. t) \<longmapsto> (λx:T. t')"
| AppL: "t \<longmapsto> t' ==> t · u \<longmapsto> t' · u"
| AppR: "u \<longmapsto> u' ==> t · u \<longmapsto> t · u'"
| Beta: "x \<sharp> u ==> (λx:T. t) · u \<longmapsto> t[x\<mapsto>u]"
| Let: "((supp p)::name set) \<sharp>* t ==> distinct (pat_vars p) ==>
\<turnstile> p \<rhd> t => ϑ ==> (LET p = t IN u) \<longmapsto> ϑ(|u|)),"


equivariance match

equivariance eval

lemma match_vars:
assumes "\<turnstile> p \<rhd> t => ϑ" and "x ∈ supp p"
shows "x ∈ set (map fst ϑ)"
using assms
by induct (auto simp add: supp_atm)

lemma match_fresh_mono:
assumes "\<turnstile> p \<rhd> t => ϑ" and "(x::name) \<sharp> t"
shows "∀(y, t)∈set ϑ. x \<sharp> t"
using assms
by induct auto

nominal_inductive2 eval
avoids
Abs: "{x}"
| Beta: "{x}"
| Let: "(supp p)::name set"

apply (simp_all add: fresh_star_def abs_fresh fin_supp)
apply (rule psubst_fresh)
apply simp
apply simp
apply (rule ballI)
apply (rule psubst_fresh)
apply (rule match_vars)
apply assumption+
apply (rule match_fresh_mono)
apply auto
done

lemma typing_case_Abs:
assumes ty: "Γ \<turnstile> (λx:T. t) : S"
and fresh: "x \<sharp> Γ"
and R: "!!U. S = T -> U ==> (x, T) # Γ \<turnstile> t : U ==> P"
shows P
using ty
proof cases
case (Abs x' T' t' U)
obtain y::name where y: "y \<sharp> (x, Γ, λx':T'. t')"
by (rule exists_fresh) (auto intro: fin_supp)
from `(λx:T. t) = (λx':T'. t')` [symmetric]
have x: "x \<sharp> (λx':T'. t')" by (simp add: abs_fresh)
have x': "x' \<sharp> (λx':T'. t')" by (simp add: abs_fresh)
from `(x', T') # Γ \<turnstile> t' : U` have x'': "x' \<sharp> Γ"
by (auto dest: valid_typing)
have "(λx:T. t) = (λx':T'. t')" by fact
also from x x' y have "… = [(x, y)] • [(x', y)] • (λx':T'. t')"
by (simp only: perm_fresh_fresh fresh_prod)
also have "… = (λx:T'. [(x, y)] • [(x', y)] • t')"
by (simp add: swap_simps perm_fresh_fresh)
finally have "(λx:T. t) = (λx:T'. [(x, y)] • [(x', y)] • t')" .
then have T: "T = T'" and t: "[(x, y)] • [(x', y)] • t' = t"
by (simp_all add: trm.inject alpha)
from Abs T have "S = T -> U" by simp
moreover from `(x', T') # Γ \<turnstile> t' : U`
have "[(x, y)] • [(x', y)] • ((x', T') # Γ \<turnstile> t' : U)"
by (simp add: perm_bool)
with T t y x'' fresh have "(x, T) # Γ \<turnstile> t : U"
by (simp add: eqvts swap_simps perm_fresh_fresh fresh_prod)
ultimately show ?thesis by (rule R)
qed simp_all

nominal_primrec ty_size :: "ty => nat"
where
"ty_size (Atom n) = 0"
| "ty_size (T -> U) = ty_size T + ty_size U + 1"
| "ty_size (T ⊗ U) = ty_size T + ty_size U + 1"

by (rule TrueI)+

lemma bind_tuple_ineq:
"ty_size (pat_type p) < ty_size U ==> Bind U x t ≠ (λ[p]. u)"

by (induct p arbitrary: U x t u) (auto simp add: btrm.inject)

lemma valid_appD: assumes "valid (Γ @ Δ)"
shows "valid Γ" "valid Δ"
using assms
by (induct Γ'"Γ @ Δ" arbitrary: Γ Δ)
(auto simp add: Cons_eq_append_conv fresh_list_append)


lemma valid_app_freshs: assumes "valid (Γ @ Δ)"
shows "(supp Γ::name set) \<sharp>* Δ" "(supp Δ::name set) \<sharp>* Γ"
using assms
by (induct Γ'"Γ @ Δ" arbitrary: Γ Δ)
(auto simp add: Cons_eq_append_conv fresh_star_def
fresh_list_nil fresh_list_cons supp_list_nil supp_list_cons fresh_list_append
supp_prod fresh_prod supp_atm fresh_atm
dest: notE [OF iffD1 [OF fresh_def [THEN meta_eq_to_obj_eq]]])


lemma perm_mem_left: "(x::name) ∈ ((pi::name prm) • A) ==> (rev pi • x) ∈ A"
by (drule perm_boolI [of _ "rev pi"]) (simp add: eqvts perm_pi_simp)

lemma perm_mem_right: "(rev (pi::name prm) • (x::name)) ∈ A ==> x ∈ (pi • A)"
by (drule perm_boolI [of _ pi]) (simp add: eqvts perm_pi_simp)

lemma perm_cases:
assumes pi: "set pi ⊆ A × A"
shows "((pi::name prm) • B) ⊆ A ∪ B"

proof
fix x assume "x ∈ pi • B"
then show "x ∈ A ∪ B" using pi
apply (induct pi arbitrary: x B rule: rev_induct)
apply simp
apply (simp add: split_paired_all supp_eqvt)
apply (drule perm_mem_left)
apply (simp add: calc_atm split: split_if_asm)
apply (auto dest: perm_mem_right)
done
qed

lemma abs_pat_alpha':
assumes eq: "(λ[p]. t) = (λ[q]. u)"
and ty: "pat_type p = pat_type q"
and pv: "distinct (pat_vars p)"
and qv: "distinct (pat_vars q)"
shows "∃pi::name prm. p = pi • q ∧ t = pi • u ∧
set pi ⊆ (supp p ∪ supp q) × (supp p ∪ supp q)"

using assms
proof (induct p arbitrary: q t u Δ)
case (PVar x T)
note PVar' = this
show ?case
proof (cases q)
case (PVar x' T')
with `(λ[PVar x T]. t) = (λ[q]. u)`
have "x = x' ∧ t = u ∨ x ≠ x' ∧ t = [(x, x')] • u ∧ x \<sharp> u"
by (simp add: btrm.inject alpha)
then show ?thesis
proof
assume "x = x' ∧ t = u"
with PVar PVar' have "PVar x T = ([]::name prm) • q ∧
t = ([]::name prm) • u ∧
set ([]::name prm) ⊆ (supp (PVar x T) ∪ supp q) ×
(supp (PVar x T) ∪ supp q)"
by simp
then show ?thesis ..
next
assume "x ≠ x' ∧ t = [(x, x')] • u ∧ x \<sharp> u"
with PVar PVar' have "PVar x T = [(x, x')] • q ∧
t = [(x, x')] • u ∧
set [(x, x')] ⊆ (supp (PVar x T) ∪ supp q) ×
(supp (PVar x T) ∪ supp q)"

by (simp add: perm_swap swap_simps supp_atm perm_type)
then show ?thesis ..
qed
next
case (PTuple p1 p2)
with PVar have "ty_size (pat_type p1) < ty_size T" by simp
then have "Bind T x t ≠ (λ[p1]. λ[p2]. u)"
by (rule bind_tuple_ineq)
moreover from PTuple PVar
have "Bind T x t = (λ[p1]. λ[p2]. u)" by simp
ultimately show ?thesis ..
qed
next
case (PTuple p1 p2)
note PTuple' = this
show ?case
proof (cases q)
case (PVar x T)
with PTuple have "ty_size (pat_type p1) < ty_size T" by auto
then have "Bind T x u ≠ (λ[p1]. λ[p2]. t)"
by (rule bind_tuple_ineq)
moreover from PTuple PVar
have "Bind T x u = (λ[p1]. λ[p2]. t)" by simp
ultimately show ?thesis ..
next
case (PTuple p1' p2')
with PTuple' have "(λ[p1]. λ[p2]. t) = (λ[p1']. λ[p2']. u)" by simp
moreover from PTuple PTuple' have "pat_type p1 = pat_type p1'"
by (simp add: ty.inject)
moreover from PTuple' have "distinct (pat_vars p1)" by simp
moreover from PTuple PTuple' have "distinct (pat_vars p1')" by simp
ultimately have "∃pi::name prm. p1 = pi • p1' ∧
(λ[p2]. t) = pi • (λ[p2']. u) ∧
set pi ⊆ (supp p1 ∪ supp p1') × (supp p1 ∪ supp p1')"

by (rule PTuple')
then obtain pi::"name prm" where
"p1 = pi • p1'" "(λ[p2]. t) = pi • (λ[p2']. u)" and
pi: "set pi ⊆ (supp p1 ∪ supp p1') × (supp p1 ∪ supp p1')"
by auto
from `(λ[p2]. t) = pi • (λ[p2']. u)`
have "(λ[p2]. t) = (λ[pi • p2']. pi • u)"
by (simp add: eqvts)
moreover from PTuple PTuple' have "pat_type p2 = pat_type (pi • p2')"
by (simp add: ty.inject pat_type_perm_eq)
moreover from PTuple' have "distinct (pat_vars p2)" by simp
moreover from PTuple PTuple' have "distinct (pat_vars (pi • p2'))"
by (simp add: pat_vars_eqvt [symmetric] distinct_eqvt [symmetric])
ultimately have "∃pi'::name prm. p2 = pi' • pi • p2' ∧
t = pi' • pi • u ∧
set pi' ⊆ (supp p2 ∪ supp (pi • p2')) × (supp p2 ∪ supp (pi • p2'))"

by (rule PTuple')
then obtain pi'::"name prm" where
"p2 = pi' • pi • p2'" "t = pi' • pi • u" and
pi': "set pi' ⊆ (supp p2 ∪ supp (pi • p2')) ×
(supp p2 ∪ supp (pi • p2'))"
by auto
from PTuple PTuple' have "pi • distinct (pat_vars ⟨⟨p1', p2'⟩⟩)" by simp
then have "distinct (pat_vars ⟨⟨pi • p1', pi • p2'⟩⟩)" by (simp only: eqvts)
with `p1 = pi • p1'` PTuple'
have fresh: "(supp p2 ∪ supp (pi • p2') :: name set) \<sharp>* p1"
by (auto simp add: set_pat_vars_supp fresh_star_def fresh_def eqvts)
from `p1 = pi • p1'` have "pi' • (p1 = pi • p1')" by (rule perm_boolI)
with pt_freshs_freshs [OF pt_name_inst at_name_inst pi' fresh fresh]
have "p1 = pi' • pi • p1'" by (simp add: eqvts)
with `p2 = pi' • pi • p2'` have "⟨⟨p1, p2⟩⟩ = (pi' @ pi) • ⟨⟨p1', p2'⟩⟩"
by (simp add: pt_name2)
moreover
have "((supp p2 ∪ (pi • supp p2')) × (supp p2 ∪ (pi • supp p2'))::(name × name) set) ⊆
(supp p2 ∪ (supp p1 ∪ supp p1' ∪ supp p2')) × (supp p2 ∪ (supp p1 ∪ supp p1' ∪ supp p2'))"

by (rule subset_refl Sigma_mono Un_mono perm_cases [OF pi])+
with pi' have "set pi' ⊆ …" by (simp add: supp_eqvt [symmetric])
with pi have "set (pi' @ pi) ⊆ (supp ⟨⟨p1, p2⟩⟩ ∪ supp ⟨⟨p1', p2'⟩⟩) ×
(supp ⟨⟨p1, p2⟩⟩ ∪ supp ⟨⟨p1', p2'⟩⟩)"

by (simp add: Sigma_Un_distrib1 Sigma_Un_distrib2 Un_ac) blast
moreover note `t = pi' • pi • u`
ultimately have "⟨⟨p1, p2⟩⟩ = (pi' @ pi) • q ∧ t = (pi' @ pi) • u ∧
set (pi' @ pi) ⊆ (supp ⟨⟨p1, p2⟩⟩ ∪ supp q) ×
(supp ⟨⟨p1, p2⟩⟩ ∪ supp q)"
using PTuple
by (simp add: pt_name2)
then show ?thesis ..
qed
qed

lemma typing_case_Let:
assumes ty: "Γ \<turnstile> (LET p = t IN u) : U"
and fresh: "(supp p::name set) \<sharp>* Γ"
and distinct: "distinct (pat_vars p)"
and R: "!!T Δ. Γ \<turnstile> t : T ==> \<turnstile> p : T => Δ ==> Δ @ Γ \<turnstile> u : U ==> P"
shows P
using ty
proof cases
case (Let p' t' T Δ u')
then have "(supp Δ::name set) \<sharp>* Γ"
by (auto intro: valid_typing valid_app_freshs)
with Let have "(supp p'::name set) \<sharp>* Γ"
by (simp add: pat_var)
with fresh have fresh': "(supp p ∪ supp p' :: name set) \<sharp>* Γ"
by (auto simp add: fresh_star_def)
from Let have "(λ[p]. Base u) = (λ[p']. Base u')"
by (simp add: trm.inject)
moreover from Let have "pat_type p = pat_type p'"
by (simp add: trm.inject)
moreover note distinct
moreover from `Δ @ Γ \<turnstile> u' : U` have "valid (Δ @ Γ)"
by (rule valid_typing)
then have "valid Δ" by (rule valid_appD)
with `\<turnstile> p' : T => Δ` have "distinct (pat_vars p')"
by (simp add: valid_distinct pat_vars_ptyping)
ultimately have "∃pi::name prm. p = pi • p' ∧ Base u = pi • Base u' ∧
set pi ⊆ (supp p ∪ supp p') × (supp p ∪ supp p')"

by (rule abs_pat_alpha')
then obtain pi::"name prm" where pi: "p = pi • p'" "u = pi • u'"
and pi': "set pi ⊆ (supp p ∪ supp p') × (supp p ∪ supp p')"

by (auto simp add: btrm.inject)
from Let have "Γ \<turnstile> t : T" by (simp add: trm.inject)
moreover from `\<turnstile> p' : T => Δ` have "\<turnstile> (pi • p') : (pi • T) => (pi • Δ)"
by (simp add: ptyping.eqvt)
with pi have "\<turnstile> p : T => (pi • Δ)" by (simp add: perm_type)
moreover from Let
have "(pi • Δ) @ (pi • Γ) \<turnstile> (pi • u') : (pi • U)"
by (simp add: append_eqvt [symmetric] typing.eqvt)
with pi have "(pi • Δ) @ Γ \<turnstile> u : U"
by (simp add: perm_type pt_freshs_freshs
[OF pt_name_inst at_name_inst pi' fresh' fresh'])

ultimately show ?thesis by (rule R)
qed simp_all

lemma preservation:
assumes "t \<longmapsto> t'" and "Γ \<turnstile> t : T"
shows "Γ \<turnstile> t' : T"
using assms
proof (nominal_induct avoiding: Γ T rule: eval.strong_induct)
case (TupleL t t' u)
from `Γ \<turnstile> ⟨t, u⟩ : T` obtain T1 T2
where "T = T1 ⊗ T2" "Γ \<turnstile> t : T1" "Γ \<turnstile> u : T2"

by cases (simp_all add: trm.inject)
from `Γ \<turnstile> t : T1` have "Γ \<turnstile> t' : T1" by (rule TupleL)
then have "Γ \<turnstile> ⟨t', u⟩ : T1 ⊗ T2" using `Γ \<turnstile> u : T2`
by (rule Tuple)
with `T = T1 ⊗ T2` show ?case by simp
next
case (TupleR u u' t)
from `Γ \<turnstile> ⟨t, u⟩ : T` obtain T1 T2
where "T = T1 ⊗ T2" "Γ \<turnstile> t : T1" "Γ \<turnstile> u : T2"

by cases (simp_all add: trm.inject)
from `Γ \<turnstile> u : T2` have "Γ \<turnstile> u' : T2" by (rule TupleR)
with `Γ \<turnstile> t : T1` have "Γ \<turnstile> ⟨t, u'⟩ : T1 ⊗ T2"
by (rule Tuple)
with `T = T1 ⊗ T2` show ?case by simp
next
case (Abs t t' x S)
from `Γ \<turnstile> (λx:S. t) : T` `x \<sharp> Γ` obtain U where
T: "T = S -> U" and U: "(x, S) # Γ \<turnstile> t : U"

by (rule typing_case_Abs)
from U have "(x, S) # Γ \<turnstile> t' : U" by (rule Abs)
then have "Γ \<turnstile> (λx:S. t') : S -> U"
by (rule typing.Abs)
with T show ?case by simp
next
case (Beta x u S t)
from `Γ \<turnstile> (λx:S. t) · u : T` `x \<sharp> Γ`
obtain "(x, S) # Γ \<turnstile> t : T" and "Γ \<turnstile> u : S"
by cases (auto simp add: trm.inject ty.inject elim: typing_case_Abs)
then show ?case by (rule subst_type)
next
case (Let p t ϑ u)
from `Γ \<turnstile> (LET p = t IN u) : T` `supp p \<sharp>* Γ` `distinct (pat_vars p)`
obtain U Δ where "\<turnstile> p : U => Δ" "Γ \<turnstile> t : U" "Δ @ Γ \<turnstile> u : T"
by (rule typing_case_Let)
then show ?case using `\<turnstile> p \<rhd> t => ϑ` `supp p \<sharp>* t`
by (rule match_type)
next
case (AppL t t' u)
from `Γ \<turnstile> t · u : T` obtain U where
t: "Γ \<turnstile> t : U -> T" and u: "Γ \<turnstile> u : U"

by cases (auto simp add: trm.inject)
from t have "Γ \<turnstile> t' : U -> T" by (rule AppL)
then show ?case using u by (rule typing.App)
next
case (AppR u u' t)
from `Γ \<turnstile> t · u : T` obtain U where
t: "Γ \<turnstile> t : U -> T" and u: "Γ \<turnstile> u : U"

by cases (auto simp add: trm.inject)
from u have "Γ \<turnstile> u' : U" by (rule AppR)
with t show ?case by (rule typing.App)
qed

end