theory State_Machine
  imports Main
begin

section \<open>Definitions\<close>

text \<open>Transition function\<close>
type_synonym ('q, 'a) trans =
  "'q \<times> 'a \<Rightarrow> 'q"

text \<open>simple state-machine\<close>
record ('q, 'a) state_machine =
  initial :: "'q"
  delta :: "('q, 'a) trans"

text \<open>closure of transition function\<close>
fun hat1 :: "('q, 'a) trans \<Rightarrow> ('q, 'a list) trans" where
  "hat1 t (q, [])     = q" |
  "hat1 t (q, (a#as)) = hat1 t (t (q, a), as)"

abbreviation delta_hat ::
  "('q, 'a, 'e) state_machine_scheme \<Rightarrow> ('q, 'a list) trans" where
  "delta_hat m \<equiv> hat1 (delta m)"

definition initial_in_states :: "['q set, 'q] \<Rightarrow> bool" where
  "initial_in_states st q0 \<equiv> q0 \<in> st"

definition reachable :: "('q, 'a, 'e) state_machine_scheme \<Rightarrow> 'q \<Rightarrow> bool" where
  "reachable m q \<equiv> (\<exists>w. q = delta_hat m (initial m, w))"

definition trim :: "('q, 'a, 'e) state_machine_scheme \<Rightarrow> bool" where
  "trim m \<equiv> \<forall>q. reachable m q"

section \<open>Properties\<close>

lemma delta_append[simp]:
  "hat1 t (q, u @ v) = hat1 t (hat1 t (q, u), v)"
  by (induct u arbitrary: q, auto)

lemma delta_append_1:
  "hat1 t (q, u @ [a]) = t (hat1 t (q, u), a)"
  by (induct u rule: rev_induct, simp_all)

lemma reachable_initial:
  "reachable m (initial m)"
  unfolding reachable_def
  by (rule exI[where x="[]"], simp)

lemma reachable_delta:
  assumes "reachable m q"
  shows "reachable m (delta m (q, a))"
proof -
  obtain w where "q = delta_hat m (initial m, w)"
    using assms unfolding reachable_def by (erule exE)
  then show ?thesis
    unfolding reachable_def by (intro exI[where x="w @ [a]"], simp)
qed

lemma reachable_delta_hat:
  assumes "reachable m q"
  shows "reachable m (delta_hat m (q, w))"
proof -
  obtain v where "q = delta_hat m (initial m, v)"
    using assms unfolding reachable_def by (erule exE)
  then show ?thesis
    unfolding reachable_def by (intro exI[where x="v @ w"], simp)
qed

end


theory TypedLambdaNominal
imports "HOL-Nominal.Nominal"
begin

text {*
  Provides useful definitions for reasoning
  with lambda-terms.
*}

atom_decl name

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

text {* The depth of a lambda-term. *}

nominal_primrec
  depth :: "lam \<Rightarrow> nat"
where
  "depth (Var x) = 1"
| "depth (App t1 t2) = (max (depth t1) (depth t2)) + 1"
| "depth (MkPair t1 t2) = (max (depth t1) (depth t2)) + 1"
| "depth (Unpair b t) = depth t + 1"
| "depth (Lam [a].t) = depth t + 1"
  apply(finite_guess)+
  apply(rule TrueI)+
  apply(simp add: fresh_nat)
  apply(fresh_guess)+
  done

text {*
  The free variables of a lambda-term. A complication in this
  function arises from the fact that it returns a name set, which
  is not a finitely supported type. Therefore we have to prove
  the invariant that frees always returns a finite set of names.
*}

nominal_primrec (invariant: "\<lambda>s::name set. finite s")
  frees :: "lam \<Rightarrow> name set"
where
  "frees (Var a) = {a}"
| "frees (App t1 t2) = (frees t1) \<union> (frees t2)"
| "frees (MkPair t1 t2) = (frees t1) \<union> (frees t2)"
| "frees (Unpair b t) = frees t"
| "frees (Lam [a].t) = (frees t) - {a}"
apply(finite_guess)+
apply(simp)+
apply(simp add: fresh_def)
apply(simp add: supp_of_fin_sets[OF pt_name_inst, OF at_name_inst, OF fs_at_inst[OF at_name_inst]])
apply(simp add: supp_atm)
apply(blast)
apply(fresh_guess)+
done

text {*
  We can avoid the definition of frees by
  using the build in notion of support.
*}

find_theorems "supp (_::bool)"
lemma frees_equals_support:
  shows "frees t = supp t"
by (nominal_induct t rule: lam.strong_induct)
   (simp_all add: lam.supp supp_atm supp_bool abs_supp)

text {* Parallel and single capture-avoiding substitution. *}

fun
  lookup :: "(name\<times>lam) list \<Rightarrow> name \<Rightarrow> lam"
where
  "lookup [] x        = Var x"
| "lookup ((y,e)#\<theta>) x = (if x=y then e else lookup \<theta> x)"

lemma lookup_eqvt[eqvt]:
  fixes pi::"name prm"
  and   \<theta>::"(name\<times>lam) list"
  and   X::"name"
  shows "pi\<bullet>(lookup \<theta> X) = lookup (pi\<bullet>\<theta>) (pi\<bullet>X)"
by (induct \<theta>) (auto simp add: eqvts)

nominal_primrec
  psubst :: "(name\<times>lam) list \<Rightarrow> lam \<Rightarrow> lam"  ("_<_>" [95,95] 105)
where
  "\<theta><(Var x)> = (lookup \<theta> x)"
| "\<theta><(App e\<^sub>1 e\<^sub>2)> = App (\<theta><e\<^sub>1>) (\<theta><e\<^sub>2>)"
| "\<theta><(MkPair e\<^sub>1 e\<^sub>2)> = MkPair (\<theta><e\<^sub>1>) (\<theta><e\<^sub>2>)"
| "\<theta><(Unpair b e)> = Unpair b (\<theta><e>)"
| "x\<sharp>\<theta> \<Longrightarrow> \<theta><(Lam [x].e)> = Lam [x].(\<theta><e>)"
apply(finite_guess)+
apply(rule TrueI)+
apply(simp add: abs_fresh)+
apply(fresh_guess)+
done

lemma psubst_eqvt[eqvt]:
  fixes pi::"name prm"
  and   t::"lam"
  shows "pi\<bullet>(\<theta><t>) = (pi\<bullet>\<theta>)<(pi\<bullet>t)>"
by (nominal_induct t avoiding: \<theta> rule: lam.strong_induct)
   (simp_all add: eqvts fresh_bij)

abbreviation
  subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam" ("_[_::=_]" [100,100,100] 100)
where
  "t[x::=t']  \<equiv> ([(x,t')])<t>"

lemma subst[simp]:
  shows "(Var x)[y::=t'] = (if x=y then t' else (Var x))"
  and   "(App t1 t2)[y::=t'] = App (t1[y::=t']) (t2[y::=t'])"
  and   "(MkPair t1 t2)[y::=t'] = MkPair (t1[y::=t']) (t2[y::=t'])"
  and   "(Unpair b t)[y::=t'] = Unpair b (t[y::=t'])"
  and   "x\<sharp>(y,t') \<Longrightarrow> (Lam [x].t)[y::=t'] = Lam [x].(t[y::=t'])"
by (simp_all add: fresh_list_cons fresh_list_nil)

lemma subst_supp:
  shows "supp(t1[a::=t2]) \<subseteq> (((supp(t1)-{a})\<union>supp(t2))::name set)"
apply(nominal_induct t1 avoiding: a t2 rule: lam.strong_induct)
apply(auto simp add: lam.supp supp_atm fresh_prod abs_supp supp_bool)
apply(blast)+
done

(*
text {*
  Contexts - lambda-terms with a single hole.
  Note that the lambda case in contexts does not bind a
  name, even if we introduce the notation [_]._ for CLam.
*}
nominal_datatype clam =
    Hole ("\<box>" 1000)
  | CAppL "clam" "lam"
  | CAppR "lam" "clam"
  | CMkPairL "clam" "lam"
  | CMkPairR "lam" "clam"
  | CUnpair bool clam
  | CLam "name" "clam"  ("CLam [_]._" [100,100] 100)

text {* Filling a lambda-term into a context. *}

nominal_primrec
  filling :: "clam \<Rightarrow> lam \<Rightarrow> lam" ("_\<lbrakk>_\<rbrakk>" [100,100] 100)
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>)"
| "(CMkPairL E t')\<lbrakk>t\<rbrakk> = MkPair (E\<lbrakk>t\<rbrakk>) t'"
| "(CMkPairR t' E)\<lbrakk>t\<rbrakk> = MkPair t' (E\<lbrakk>t\<rbrakk>)"
| "(CUnpair b E)\<lbrakk>t\<rbrakk> = Unpair b (E\<lbrakk>t\<rbrakk>)"
| "(CLam [x].E)\<lbrakk>t\<rbrakk> = Lam [x].(E\<lbrakk>t\<rbrakk>)"
by (rule TrueI)+

text {* Composition of two contexts *}

nominal_primrec
 clam_compose :: "clam \<Rightarrow> clam \<Rightarrow> clam" ("_ \<circ> _" [100,100] 100)
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')"
| "(CMkPairL E t') \<circ> E' = CMkPairL (E \<circ> E') t'"
| "(CMkPairR t' E) \<circ> E' = CMkPairR t' (E \<circ> E')"
| "(CUnpair b E) \<circ> E' = CUnpair b (E \<circ> E')"
| "(CLam [x].E) \<circ> E' = CLam [x].(E \<circ> E')"
by (rule TrueI)+

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

text {* Strong Normalisation proof from the Proofs and Types book *}
text {* Based on HOL/Nominal/Examples/SN.thy, extended to product types by Dominique Unruh *}

section {* Beta Reduction *}

lemma subst_rename:
  assumes a: "c\<sharp>t1"
  shows "t1[a::=t2] = ([(c,a)]\<bullet>t1)[c::=t2]"
using a
by (nominal_induct t1 avoiding: a c t2 rule: lam.strong_induct)
   (auto simp add: calc_atm fresh_atm abs_fresh perm_bool)

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

lemma fresh_fact:
  fixes a::"name"
  assumes a: "a\<sharp>t1" "a\<sharp>t2"
  shows "a\<sharp>t1[b::=t2]"
using a
by (nominal_induct t1 avoiding: a b t2 rule: lam.strong_induct)
   (auto simp add: abs_fresh fresh_atm)

lemma fresh_fact':
  fixes a::"name"
  assumes a: "a\<sharp>t2"
  shows "a\<sharp>t1[a::=t2]"
using a
by (nominal_induct t1 avoiding: a t2 rule: lam.strong_induct)
   (auto simp add: abs_fresh fresh_atm fresh_bool)

lemma subst_lemma:
  assumes a: "x\<noteq>y"
  and     b: "x\<sharp>L"
  shows "M[x::=N][y::=L] = M[y::=L][x::=N[y::=L]]"
using a b
by (nominal_induct M avoiding: x y N L rule: lam.strong_induct)
   (auto simp add: fresh_fact forget)

lemma id_subs:
  shows "t[x::=Var x] = t"
  by (nominal_induct t avoiding: x rule: lam.strong_induct)
     (simp_all add: fresh_atm)

lemma lookup_fresh:
  fixes z::"name"
  assumes "z\<sharp>\<theta>" "z\<sharp>x"
  shows "z\<sharp> lookup \<theta> x"
using assms
by (induct rule: lookup.induct) (auto simp add: fresh_list_cons)

lemma lookup_fresh':
  assumes "z\<sharp>\<theta>"
  shows "lookup \<theta> z = Var z"
using assms
by (induct rule: lookup.induct)
   (auto simp add: fresh_list_cons fresh_prod fresh_atm)

lemma psubst_subst:
  assumes h:"c\<sharp>\<theta>"
  shows "(\<theta><t>)[c::=s] = ((c,s)#\<theta>)<t>"
  using h
by (nominal_induct t avoiding: \<theta> c s rule: lam.strong_induct)
   (auto simp add: fresh_list_cons fresh_atm forget lookup_fresh lookup_fresh')

inductive
  Beta :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^sub>\<beta> _" [80,80] 80)
where
  b1[intro!]: "s1 \<longrightarrow>\<^sub>\<beta> s2 \<Longrightarrow> App s1 t \<longrightarrow>\<^sub>\<beta> App s2 t"
| b2[intro!]: "s1 \<longrightarrow>\<^sub>\<beta> s2 \<Longrightarrow> App t s1 \<longrightarrow>\<^sub>\<beta> App t s2"
| b3[intro!]: "s1 \<longrightarrow>\<^sub>\<beta> s2 \<Longrightarrow> Lam [a].s1 \<longrightarrow>\<^sub>\<beta> Lam [a].s2"
| b4[intro!]: "a\<sharp>s2 \<Longrightarrow> App (Lam [a].s1) s2\<longrightarrow>\<^sub>\<beta> (s1[a::=s2])"
| b5[intro!]: "s1 \<longrightarrow>\<^sub>\<beta> s2 \<Longrightarrow> MkPair s1 t \<longrightarrow>\<^sub>\<beta> MkPair s2 t"
| b6[intro!]: "s1 \<longrightarrow>\<^sub>\<beta> s2 \<Longrightarrow> MkPair t s1 \<longrightarrow>\<^sub>\<beta> MkPair t s2"
| b7[intro!]: "s1 \<longrightarrow>\<^sub>\<beta> s2 \<Longrightarrow> Unpair b s1 \<longrightarrow>\<^sub>\<beta> Unpair b s2"
| b8[intro!]: "Unpair True (MkPair s1 s2) \<longrightarrow>\<^sub>\<beta> s1"
| b9[intro!]: "Unpair False (MkPair s1 s2) \<longrightarrow>\<^sub>\<beta> s2"

equivariance Beta

nominal_inductive Beta
  by (simp_all add: abs_fresh fresh_fact')

lemma beta_preserves_fresh:
  fixes a::"name"
  assumes a: "t\<longrightarrow>\<^sub>\<beta> s"
  shows "a\<sharp>t \<Longrightarrow> a\<sharp>s"
using a
apply(nominal_induct t s avoiding: a rule: Beta.strong_induct)
apply(auto simp add: abs_fresh fresh_fact fresh_atm)
done

lemma beta_abs:
  assumes a: "Lam [a].t \<longrightarrow>\<^sub>\<beta> t'"
  shows "\<exists>t''. t'=Lam [a].t'' \<and> t \<longrightarrow>\<^sub>\<beta> t''"
proof -
  have "a\<sharp>Lam [a].t" by (simp add: abs_fresh)
  with a have "a\<sharp>t'" by (simp add: beta_preserves_fresh)
  with a show ?thesis
    by (cases rule: Beta.strong_cases[where a="a" and aa="a"])
       (auto simp add: lam.inject abs_fresh alpha)
qed

lemma beta_subst:
  assumes a: "M \<longrightarrow>\<^sub>\<beta> M'"
  shows "M[x::=N] \<longrightarrow>\<^sub>\<beta> M'[x::=N]"
using a
by (nominal_induct M M' avoiding: x N rule: Beta.strong_induct)
   (auto simp add: fresh_atm subst_lemma fresh_fact)

section {* types *}

nominal_datatype ty =
    TVar "nat"
  | TArr "ty" "ty" (infix "\<rightarrow>" 200)
  | TPair ty ty

lemma fresh_ty:
  fixes a :: "name"
  and   \<tau>  :: "ty"
  shows "a\<sharp>\<tau>"
by (nominal_induct \<tau> rule: ty.strong_induct)
   (auto simp add: fresh_nat)

(* valid contexts *)

inductive
  valid :: "(name\<times>ty) list \<Rightarrow> bool"
where
  v1[intro]: "valid []"
| v2[intro]: "\<lbrakk>valid \<Gamma>;a\<sharp>\<Gamma>\<rbrakk>\<Longrightarrow> valid ((a,\<sigma>)#\<Gamma>)"

equivariance valid

(* typing judgements *)

lemma fresh_context:
  fixes  \<Gamma> :: "(name\<times>ty)list"
  and    a :: "name"
  assumes a: "a\<sharp>\<Gamma>"
  shows "\<not>(\<exists>\<tau>::ty. (a,\<tau>)\<in>set \<Gamma>)"
using a
by (induct \<Gamma>)
   (auto simp add: fresh_prod fresh_list_cons fresh_atm)

inductive
  typing :: "(name\<times>ty) list\<Rightarrow>lam\<Rightarrow>ty\<Rightarrow>bool" ("_ \<turnstile> _ : _" [60,60,60] 60)
where
  t1[intro]: "\<lbrakk>valid \<Gamma>; (a,\<tau>)\<in>set \<Gamma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Var a : \<tau>"
| t2[intro]: "\<lbrakk>\<Gamma> \<turnstile> t1 : \<tau>\<rightarrow>\<sigma>; \<Gamma> \<turnstile> t2 : \<tau>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> App t1 t2 : \<sigma>"
| t3[intro]: "\<lbrakk>a\<sharp>\<Gamma>;((a,\<tau>)#\<Gamma>) \<turnstile> t : \<sigma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Lam [a].t : \<tau>\<rightarrow>\<sigma>"
| t4[intro]: "\<lbrakk>\<Gamma> \<turnstile> t1 : \<tau>; \<Gamma> \<turnstile> t2 : \<sigma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> MkPair t1 t2 : TPair \<tau> \<sigma>"
| t5[intro]: "\<Gamma> \<turnstile> t : TPair \<tau> \<sigma> \<Longrightarrow> \<Gamma> \<turnstile> Unpair True t : \<tau>"
| t6[intro]: "\<Gamma> \<turnstile> t : TPair \<tau> \<sigma> \<Longrightarrow> \<Gamma> \<turnstile> Unpair False t : \<sigma>"

equivariance typing

nominal_inductive typing
  by (simp_all add: abs_fresh fresh_ty)

subsection {* a fact about beta *}

definition "NORMAL" :: "lam \<Rightarrow> bool" where
  "NORMAL t \<equiv> \<not>(\<exists>t'. t\<longrightarrow>\<^sub>\<beta> t')"

lemma NORMAL_Var:
  shows "NORMAL (Var a)"
proof -
  { assume "\<exists>t'. (Var a) \<longrightarrow>\<^sub>\<beta> t'"
    then obtain t' where "(Var a) \<longrightarrow>\<^sub>\<beta> t'" by blast
    hence False by (cases) (auto)
  }
  thus "NORMAL (Var a)" by (auto simp add: NORMAL_def)
qed

text {* Inductive version of Strong Normalisation *}
inductive
  SN :: "lam \<Rightarrow> bool"
where
  SN_intro: "(\<And>t'. t \<longrightarrow>\<^sub>\<beta> t' \<Longrightarrow> SN t') \<Longrightarrow> SN t"

lemma SN_preserved:
  assumes a: "SN t1" "t1\<longrightarrow>\<^sub>\<beta> t2"
  shows "SN t2"
using a
by (cases) (auto)

lemma double_SN_aux:
  assumes a: "SN a"
  and b: "SN b"
  and hyp: "\<And>x z.
    \<lbrakk>\<And>y. x \<longrightarrow>\<^sub>\<beta> y \<Longrightarrow> SN y; \<And>y. x \<longrightarrow>\<^sub>\<beta> y \<Longrightarrow> P y z;
     \<And>u. z \<longrightarrow>\<^sub>\<beta> u \<Longrightarrow> SN u; \<And>u. z \<longrightarrow>\<^sub>\<beta> u \<Longrightarrow> P x u\<rbrakk> \<Longrightarrow> P x z"
  shows "P a b"
proof -
  from a
  have r: "\<And>b. SN b \<Longrightarrow> P a b"
  proof (induct a rule: SN.induct)
    case (SN_intro x)
    note SNI' = SN_intro
    have "SN b" by fact
    thus ?case
    proof (induct b rule: SN.induct)
      case (SN_intro y)
      show ?case
        apply (rule hyp)
        apply (erule SNI')
        apply (erule SNI')
        apply (rule SN.SN_intro)
        apply (erule SN_intro)+
        done
    qed
  qed
  from b show ?thesis by (rule r)
qed

lemma double_SN[consumes 2]:
  assumes a: "SN a"
  and     b: "SN b"
  and     c: "\<And>x z. \<lbrakk>\<And>y. x \<longrightarrow>\<^sub>\<beta> y \<Longrightarrow> P y z; \<And>u. z \<longrightarrow>\<^sub>\<beta> u \<Longrightarrow> P x u\<rbrakk> \<Longrightarrow> P x z"
  shows "P a b"
using a b c
apply(rule_tac double_SN_aux)
apply(assumption)+
apply(blast)
done

section {* Candidates *}

nominal_primrec
  RED :: "ty \<Rightarrow> lam set"
where
  "RED (TVar X) = {t. SN(t)}"
| "RED (\<tau>\<rightarrow>\<sigma>) =   {t. \<forall>u. (u\<in>RED \<tau> \<longrightarrow> (App t u)\<in>RED \<sigma>)}"
| "RED (TPair \<tau> \<sigma>) = {t. Unpair True t \<in> RED \<tau> \<and> Unpair False t \<in> RED \<sigma>}"
by (rule TrueI)+

text {* neutral terms *}
definition NEUT :: "lam \<Rightarrow> bool" where
  "NEUT t \<equiv> (\<exists>a. t = Var a) \<or> (\<exists>t1 t2. t = App t1 t2) \<or> (\<exists>b u. t = Unpair b u)"

(* a slight hack to get the first element of applications *)
(* this is needed to get (SN t) from SN (App t s)         *)
inductive
  FST :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<guillemotright> _" [80,80] 80)
where
  fst[intro!]:  "(App t s) \<guillemotright> t"

nominal_primrec
  fst_app_aux::"lam\<Rightarrow>lam option"
where
  "fst_app_aux (Var a)     = None"
| "fst_app_aux (App t1 t2) = Some t1"
| "fst_app_aux (Lam [x].t) = None"
| "fst_app_aux (MkPair t1 t2) = None"
| "fst_app_aux (Unpair b t) = None"
apply(finite_guess)+
apply(rule TrueI)+
apply(simp add: fresh_none)
apply(fresh_guess)+
done

definition
  fst_app_def[simp]: "fst_app t = the (fst_app_aux t)"

lemma SN_of_FST_of_App:
  assumes a: "SN (App t s)"
  shows "SN (fst_app (App t s))"
using a
proof -
  from a have "\<forall>z. (App t s \<guillemotright> z) \<longrightarrow> SN z"
    by (induct rule: SN.induct)
       (blast elim: FST.cases intro: SN_intro)
  then have "SN t" by blast
  then show "SN (fst_app (App t s))" by simp
qed

lemma SN_of_Unpair_arg:
  assumes a: "SN (Unpair True t)"
  shows "SN t"
proof -
  define u where "u \<equiv> Unpair True t"
  have "SN u" using a unfolding u_def by simp
  have u_def': "u = Unpair True t" using u_def by simp
  show "SN t"
    using `SN u` u_def' apply (induct arbitrary: t) apply (rule SN.intros) by auto
qed

section {* Candidates *}

definition "CR1" :: "ty \<Rightarrow> bool" where
  "CR1 \<tau> \<equiv> \<forall>t. (t\<in>RED \<tau> \<longrightarrow> SN t)"

definition "CR2" :: "ty \<Rightarrow> bool" where
  "CR2 \<tau> \<equiv> \<forall>t t'. (t\<in>RED \<tau> \<and> t \<longrightarrow>\<^sub>\<beta> t') \<longrightarrow> t'\<in>RED \<tau>"

definition "CR3_RED" :: "lam \<Rightarrow> ty \<Rightarrow> bool" where
  "CR3_RED t \<tau> \<equiv> \<forall>t'. t\<longrightarrow>\<^sub>\<beta> t' \<longrightarrow>  t'\<in>RED \<tau>"

definition "CR3" :: "ty \<Rightarrow> bool" where
  "CR3 \<tau> \<equiv> \<forall>t. (NEUT t \<and> CR3_RED t \<tau>) \<longrightarrow> t\<in>RED \<tau>"

definition "CR4" :: "ty \<Rightarrow> bool" where
  "CR4 \<tau> \<equiv> \<forall>t. (NEUT t \<and> NORMAL t) \<longrightarrow>t\<in>RED \<tau>"

lemma CR3_implies_CR4:
  assumes a: "CR3 \<tau>"
  shows "CR4 \<tau>"
using a by (auto simp add: CR3_def CR3_RED_def CR4_def NORMAL_def)

(* sub_induction in the arrow-type case for the next proof *)
lemma sub_induction:
  assumes a: "SN(u)"
  and     b: "u\<in>RED \<tau>"
  and     c1: "NEUT t"
  and     c2: "CR2 \<tau>"
  and     c3: "CR3 \<sigma>"
  and     c4: "CR3_RED t (\<tau>\<rightarrow>\<sigma>)"
  shows "(App t u)\<in>RED \<sigma>"
using a b
proof (induct)
  fix u
  assume as: "u\<in>RED \<tau>"
  assume ih: " \<And>u'. \<lbrakk>u \<longrightarrow>\<^sub>\<beta> u'; u' \<in> RED \<tau>\<rbrakk> \<Longrightarrow> App t u' \<in> RED \<sigma>"
  have "NEUT (App t u)" using c1 by (auto simp add: NEUT_def)
  moreover
  have "CR3_RED (App t u) \<sigma>" unfolding CR3_RED_def
  proof (intro strip)
    fix r
    assume red: "App t u \<longrightarrow>\<^sub>\<beta> r"
    moreover
    { assume "\<exists>t'. t \<longrightarrow>\<^sub>\<beta> t' \<and> r = App t' u"
      then obtain t' where a1: "t \<longrightarrow>\<^sub>\<beta> t'" and a2: "r = App t' u" by blast
      have "t'\<in>RED (\<tau>\<rightarrow>\<sigma>)" using c4 a1 by (simp add: CR3_RED_def)
      then have "App t' u\<in>RED \<sigma>" using as by simp
      then have "r\<in>RED \<sigma>" using a2 by simp
    }
    moreover
    { assume "\<exists>u'. u \<longrightarrow>\<^sub>\<beta> u' \<and> r = App t u'"
      then obtain u' where b1: "u \<longrightarrow>\<^sub>\<beta> u'" and b2: "r = App t u'" by blast
      have "u'\<in>RED \<tau>" using as b1 c2 by (auto simp add: CR2_def)
      with ih have "App t u' \<in> RED \<sigma>" using b1 by simp
      then have "r\<in>RED \<sigma>" using b2 by simp
    }
    moreover
    { assume "\<exists>x t'. t = Lam [x].t'"
      then obtain x t' where "t = Lam [x].t'" by blast
      then have "NEUT (Lam [x].t')" using c1 by simp
      then have "False" by (simp add: NEUT_def)
      then have "r\<in>RED \<sigma>" by simp
    }
    ultimately show "r \<in> RED \<sigma>" by (cases) (auto simp add: lam.inject)
  qed
  ultimately show "App t u \<in> RED \<sigma>" using c3 by (simp add: CR3_def)
qed

text {* properties of the candiadates *}
lemma RED_props:
  shows "CR1 \<tau>" and "CR2 \<tau>" and "CR3 \<tau>"
proof (nominal_induct \<tau> rule: ty.strong_induct)
  case (TVar a)
  { case 1 show "CR1 (TVar a)" by (simp add: CR1_def)
  next
    case 2 show "CR2 (TVar a)" by (auto intro: SN_preserved simp add: CR2_def)
  next
    case 3 show "CR3 (TVar a)" by (auto intro: SN_intro simp add: CR3_def CR3_RED_def)
  }
next
  case (TArr \<tau>1 \<tau>2)
  { case 1
    have ih_CR3_\<tau>1: "CR3 \<tau>1" by fact
    have ih_CR1_\<tau>2: "CR1 \<tau>2" by fact
    have "\<And>t. t \<in> RED (\<tau>1 \<rightarrow> \<tau>2) \<Longrightarrow> SN t"
    proof -
      fix t
      assume "t \<in> RED (\<tau>1 \<rightarrow> \<tau>2)"
      then have a: "\<forall>u. u \<in> RED \<tau>1 \<longrightarrow> App t u \<in> RED \<tau>2" by simp
      from ih_CR3_\<tau>1 have "CR4 \<tau>1" by (simp add: CR3_implies_CR4)
      moreover
      fix a have "NEUT (Var a)" by (force simp add: NEUT_def)
      moreover
      have "NORMAL (Var a)" by (rule NORMAL_Var)
      ultimately have "(Var a)\<in> RED \<tau>1" by (simp add: CR4_def)
      with a have "App t (Var a) \<in> RED \<tau>2" by simp
      hence "SN (App t (Var a))" using ih_CR1_\<tau>2 by (simp add: CR1_def)
      thus "SN t" by (auto dest: SN_of_FST_of_App)
    qed
    then show "CR1 (\<tau>1 \<rightarrow> \<tau>2)" unfolding CR1_def by simp
  next
    case 2
    have ih_CR2_\<tau>2: "CR2 \<tau>2" by fact
    then show "CR2 (\<tau>1 \<rightarrow> \<tau>2)" unfolding CR2_def by auto
  next
    case 3
    have ih_CR1_\<tau>1: "CR1 \<tau>1" by fact
    have ih_CR2_\<tau>1: "CR2 \<tau>1" by fact
    have ih_CR3_\<tau>2: "CR3 \<tau>2" by fact
    show "CR3 (\<tau>1 \<rightarrow> \<tau>2)" unfolding CR3_def
    proof (simp, intro strip)
      fix t u
      assume a1: "u \<in> RED \<tau>1"
      assume a2: "NEUT t \<and> CR3_RED t (\<tau>1 \<rightarrow> \<tau>2)"
      have "SN(u)" using a1 ih_CR1_\<tau>1 by (simp add: CR1_def)
      then show "(App t u)\<in>RED \<tau>2" using ih_CR2_\<tau>1 ih_CR3_\<tau>2 a1 a2 by (blast intro: sub_induction)
    qed
  }
case (TPair \<sigma> \<tau>)
  { case 1
    show ?case
    proof (unfold CR1_def, rule allI, rule impI)
      fix t assume "t \<in> RED (TPair \<sigma> \<tau>)"
      hence "Unpair True t \<in> RED \<sigma>" by simp
      hence "SN (Unpair True t)"
        using CR1_def `CR1 \<sigma>` by auto
      thus "SN t"
        by (rule SN_of_Unpair_arg)
    qed
  next
    case 2
    show ?case
    proof (unfold CR2_def, (rule allI)+, (rule impI), erule conjE)
      fix t t' assume tred: "t \<in> RED (TPair \<sigma> \<tau>)" and beta: "t \<longrightarrow>\<^sub>\<beta> t'"
      have t1beta: "Unpair True t \<longrightarrow>\<^sub>\<beta> Unpair True t'"
       and t2beta: "Unpair False t \<longrightarrow>\<^sub>\<beta> Unpair False t'"
        using beta by (simp_all add: b7 b8)
      have "Unpair True t \<in> RED \<sigma>" and "Unpair False t \<in> RED \<tau>"
        using tred by auto
      hence "Unpair True t' \<in> RED \<sigma>" and "Unpair False t' \<in> RED \<tau>"
        using CR2_def `CR2 \<sigma>` `CR2 \<tau>` t1beta t2beta by auto
      thus "t' \<in> RED (TPair \<sigma> \<tau>)" by simp
    qed
  next
    case 3
    show ?case
    proof (unfold CR3_def, rule allI, rule impI, erule conjE)
      fix t assume "NEUT t" assume "CR3_RED t (TPair \<sigma> \<tau>)"
      hence t_succ_red: "\<And>t'. t \<longrightarrow>\<^sub>\<beta> t' \<Longrightarrow> t' \<in> RED (TPair \<sigma> \<tau>)" unfolding CR3_RED_def by simp
      have "CR3_RED (Unpair True t) \<sigma>"
      proof (unfold CR3_RED_def, rule allI, rule impI)
        fix t' assume fst_t_beta: "Unpair True t \<longrightarrow>\<^sub>\<beta> t'"
        obtain u where "t' = Unpair True u" and "t \<longrightarrow>\<^sub>\<beta> u"
          apply atomize_elim using fst_t_beta apply cases
          using NEUT_def \<open>NEUT t\<close> by (auto simp: lam.inject)
        thus "t' \<in> RED \<sigma>"
          using t_succ_red by auto
      qed
      moreover have "NEUT (Unpair True t)" unfolding NEUT_def by auto
      ultimately have red_fst: "Unpair True t \<in> RED \<sigma>"
        using `CR3 \<sigma>`[unfolded CR3_def] by auto
      have "CR3_RED (Unpair False t) \<tau>"
      proof (unfold CR3_RED_def, rule allI, rule impI)
        fix t' assume snd_t_beta: "Unpair False t \<longrightarrow>\<^sub>\<beta> t'"
        obtain u where "t' = Unpair False u" and "t \<longrightarrow>\<^sub>\<beta> u"
          apply atomize_elim using snd_t_beta apply cases
          using NEUT_def \<open>NEUT t\<close> by (auto simp: lam.inject)
        thus "t' \<in> RED \<tau>"
          using t_succ_red by auto
      qed
      moreover have "NEUT (Unpair False t)" unfolding NEUT_def by auto
      ultimately have red_snd: "Unpair False t \<in> RED \<tau>"
        using `CR3 \<tau>`[unfolded CR3_def] by auto
      from red_fst red_snd show "t \<in> RED (TPair \<sigma> \<tau>)" by auto
    qed
  }
qed

text {*
  the next lemma not as simple as on paper, probably because of
  the stronger double_SN induction
*}
lemma abs_RED:
  assumes asm: "\<forall>s\<in>RED \<tau>. t[x::=s]\<in>RED \<sigma>"
  shows "Lam [x].t\<in>RED (\<tau>\<rightarrow>\<sigma>)"
proof -
  have b1: "SN t"
  proof -
    have "Var x\<in>RED \<tau>"
    proof -
      have "CR4 \<tau>" by (simp add: RED_props CR3_implies_CR4)
      moreover
      have "NEUT (Var x)" by (auto simp add: NEUT_def)
      moreover
      have "NORMAL (Var x)" by (auto elim: Beta.cases simp add: NORMAL_def)
      ultimately show "Var x\<in>RED \<tau>" by (simp add: CR4_def)
    qed
    then have "t[x::=Var x]\<in>RED \<sigma>" using asm by simp
    then have "t\<in>RED \<sigma>" by (simp add: id_subs)
    moreover
    have "CR1 \<sigma>" by (simp add: RED_props)
    ultimately show "SN t" by (simp add: CR1_def)
  qed
  show "Lam [x].t\<in>RED (\<tau>\<rightarrow>\<sigma>)"
  proof (simp, intro strip)
    fix u
    assume b2: "u\<in>RED \<tau>"
    then have b3: "SN u" using RED_props by (auto simp add: CR1_def)
    show "App (Lam [x].t) u \<in> RED \<sigma>" using b1 b3 b2 asm
    proof(induct t u rule: double_SN)
      fix t u
      assume ih1: "\<And>t'.  \<lbrakk>t \<longrightarrow>\<^sub>\<beta> t'; u\<in>RED \<tau>; \<forall>s\<in>RED \<tau>. t'[x::=s]\<in>RED \<sigma>\<rbrakk> \<Longrightarrow> App (Lam [x].t') u \<in> RED \<sigma>"
      assume ih2: "\<And>u'.  \<lbrakk>u \<longrightarrow>\<^sub>\<beta> u'; u'\<in>RED \<tau>; \<forall>s\<in>RED \<tau>. t[x::=s]\<in>RED \<sigma>\<rbrakk> \<Longrightarrow> App (Lam [x].t) u' \<in> RED \<sigma>"
      assume as1: "u \<in> RED \<tau>"
      assume as2: "\<forall>s\<in>RED \<tau>. t[x::=s]\<in>RED \<sigma>"
      have "CR3_RED (App (Lam [x].t) u) \<sigma>" unfolding CR3_RED_def
      proof(intro strip)
        fix r
        assume red: "App (Lam [x].t) u \<longrightarrow>\<^sub>\<beta> r"
        moreover
        { assume "\<exists>t'. t \<longrightarrow>\<^sub>\<beta> t' \<and> r = App (Lam [x].t') u"
          then obtain t' where a1: "t \<longrightarrow>\<^sub>\<beta> t'" and a2: "r = App (Lam [x].t') u" by blast
          have "App (Lam [x].t') u\<in>RED \<sigma>" using ih1 a1 as1 as2
            apply(auto)
            apply(drule_tac x="t'" in meta_spec)
            apply(simp)
            apply(drule meta_mp)
            prefer 2
            apply(auto)[1]
            apply(rule ballI)
            apply(drule_tac x="s" in bspec)
            apply(simp)
            apply(subgoal_tac "CR2 \<sigma>")(*A*)
            apply(unfold CR2_def)[1]
            apply(drule_tac x="t[x::=s]" in spec)
            apply(drule_tac x="t'[x::=s]" in spec)
            apply(simp add: beta_subst)
            (*A*)
            apply(simp add: RED_props)
            done
          then have "r\<in>RED \<sigma>" using a2 by simp
        }
        moreover
        { assume "\<exists>u'. u \<longrightarrow>\<^sub>\<beta> u' \<and> r = App (Lam [x].t) u'"
          then obtain u' where b1: "u \<longrightarrow>\<^sub>\<beta> u'" and b2: "r = App (Lam [x].t) u'" by blast
          have "App (Lam [x].t) u'\<in>RED \<sigma>" using ih2 b1 as1 as2
            apply(auto)
            apply(drule_tac x="u'" in meta_spec)
            apply(simp)
            apply(drule meta_mp)
            apply(subgoal_tac "CR2 \<tau>")
            apply(unfold CR2_def)[1]
            apply(drule_tac x="u" in spec)
            apply(drule_tac x="u'" in spec)
            apply(simp)
            apply(simp add: RED_props)
            apply(simp)
            done
          then have "r\<in>RED \<sigma>" using b2 by simp
        }
        moreover
        { assume "r = t[x::=u]"
          then have "r\<in>RED \<sigma>" using as1 as2 by auto
        }
        ultimately show "r \<in> RED \<sigma>"
          (* one wants to use the strong elimination principle; for this one
             has to know that x\<sharp>u *)
        apply(cases)
        apply(auto simp add: lam.inject)
        apply(drule beta_abs)
        apply(auto)[1]
        apply(auto simp add: alpha subst_rename)
        done
    qed
    moreover
    have "NEUT (App (Lam [x].t) u)" unfolding NEUT_def by (auto)
    ultimately show "App (Lam [x].t) u \<in> RED \<sigma>"  using RED_props by (simp add: CR3_def)
  qed
qed
qed

inductive reduction_len :: "lam \<Rightarrow> nat \<Rightarrow> bool" where
  "reduction_len t 0"
| "reduction_len t n \<Longrightarrow> t' \<longrightarrow>\<^sub>\<beta> t \<Longrightarrow> reduction_len t' (Suc n)"

(* definition "len_bound t n = (\<forall>i\<ge>n. \<not> reduction_len t i)" *)

inductive len_bound :: "lam \<Rightarrow> nat \<Rightarrow> bool" where
  len_bound_NORMAL[intro]: "NORMAL t \<Longrightarrow> len_bound t n"
| len_bound_succ[intro]: "(\<And>t'. t \<longrightarrow>\<^sub>\<beta> t' \<Longrightarrow> len_bound t' n) \<Longrightarrow> len_bound t (Suc n)"

lemma len_bound_0: assumes "len_bound t 0" shows "NORMAL t"
  using assms apply cases by simp

lemma mono_len_bound:
  assumes "n \<le> m"
      and "len_bound t n"
  shows "len_bound t m"
proof -
  have "len_bound t (Suc n)" if n: "len_bound t n" for n
    using n apply (induction) by auto
  thus ?thesis using assms
    by (metis dec_induct)
qed

lemma beta_finite_branch:
  "finite {t'. t \<longrightarrow>\<^sub>\<beta> t'}"
proof (nominal_induct t rule: lam.strong_induct)
case (Var n)
  have "{t'.  Var n \<longrightarrow>\<^sub>\<beta> t'} = {}"
    using NORMAL_Var NORMAL_def by auto
  thus ?case by auto
case (App t1 t2)
  have aux1: "\<And>a body. \<exists>a' body'. Lam [a].body = Lam [a'].body' \<and> a' \<sharp> t2"
  proof -
    fix a::name and body::lam
    obtain a'::name where "a' \<sharp> (t2,body)"  apply atomize_elim apply (rule exists_fresh') by (finite_guess)
    hence a't2: "a' \<sharp> t2" and a'body: "a' \<sharp> body" by auto
    define body' where "body' \<equiv> [(a, a')] \<bullet> body"
    have rename: "Lam [a].body = Lam [a'].body'"
      unfolding body'_def
      by (smt a'body alpha' lam.inject(3) perm_fresh_fresh perm_swap(1))
    show "?thesis a body"
      using a't2 rename by auto
  qed
  obtain a body where t1_lam: "t1 = Lam[a]. body \<or> \<not> (\<exists>a b. t1 = Lam[a]. b)" and "a \<sharp> t2"
    apply atomize_elim apply (nominal_induct t1 rule:"lam.strong_induct") apply (auto simp: exists_fresh' fs_name1)
    using aux1 by blast+
  let ?choices = "{App t1' t2 | t1'. t1 \<longrightarrow>\<^sub>\<beta> t1'} \<union> {App t1 t2' | t2'. t2 \<longrightarrow>\<^sub>\<beta> t2'}
                   \<union> {body[a::=t2]}"
  have "t' \<in> ?choices" if beta: "App t1 t2 \<longrightarrow>\<^sub>\<beta> t'" for t'
  using beta proof (cases)
    case (b1 s1 s2 t) thus ?thesis by (auto simp: lam.inject)
    next case b2 thus ?thesis by (auto simp: lam.inject)
    next case b3 thus ?thesis by (auto simp: lam.inject)
    next case (b4 a' s1 s2)
      hence t1:"t1 = Lam[a'].s2" and "t2 = s1" by (auto simp: lam.inject)
      with t1_lam have "t1 = Lam[a].body" by auto
      hence "Lam[a'].s2 = Lam[a].body"
        using t1 by auto
      hence "s2[a'::=s1] = body[a::=t2]"
        unfolding \<open>t2 = s1\<close>
        by (smt alpha lam.inject(3) subst_rename)
      with b4 show ?thesis by auto
    next case b5 thus ?thesis by (auto simp: lam.inject)
    next case b6 thus ?thesis by (auto simp: lam.inject)
    next case b7 thus ?thesis by (auto simp: lam.inject)
    next case b8 thus ?thesis by (auto simp: lam.inject)
    next case b9 thus ?thesis by (auto simp: lam.inject)
  qed

  hence "{t'.  App t1 t2 \<longrightarrow>\<^sub>\<beta> t'} \<subseteq> ?choices" by auto
  moreover have "finite ?choices" using App by auto
  ultimately show "finite {t'.  App t1 t2 \<longrightarrow>\<^sub>\<beta> t'}"
    using infinite_super by auto
next case (Lam a t)
  let ?choices = "{Lam [a].t' | t'. t \<longrightarrow>\<^sub>\<beta> t'}"
  have "{t'.  Lam [a].t \<longrightarrow>\<^sub>\<beta> t'} \<subseteq> ?choices"
    by (auto simp: beta_abs)
  moreover have "finite ?choices" using Lam by auto
  ultimately show ?case
    using infinite_super by auto
next case (MkPair t1 t2)
  let ?choices = "{MkPair t1' t2 | t1'. t1 \<longrightarrow>\<^sub>\<beta> t1'} \<union> {MkPair t1 t2' | t2'. t2 \<longrightarrow>\<^sub>\<beta> t2'}"
  have "{t'. MkPair t1 t2 \<longrightarrow>\<^sub>\<beta> t'} \<subseteq> ?choices"
    apply auto apply (cases rule: Beta.cases)
    by (auto simp: lam.inject)
  moreover have "finite ?choices" using MkPair by auto
  ultimately show ?case
    using infinite_super by auto
next case (Unpair b t)
  obtain t1 t2 where t_pair: "t = MkPair t1 t2 \<or> \<not> (\<exists>t1 t2. t = MkPair t1 t2)" by blast
  let ?choices = "{Unpair b t' | t'. t \<longrightarrow>\<^sub>\<beta> t'} \<union> {if b then t1 else t2}"
  have "t' \<in> ?choices" if beta: "Unpair b t \<longrightarrow>\<^sub>\<beta> t'" for t'
  using beta proof (cases)
    case (b1 s1 s2 t) thus ?thesis by (auto simp: lam.inject)
    next case b2 thus ?thesis by (auto simp: lam.inject)
    next case b3 thus ?thesis by (auto simp: lam.inject)
    next case b4 thus ?thesis by (auto simp: lam.inject)
    next case b5 thus ?thesis by (auto simp: lam.inject)
    next case b6 thus ?thesis by (auto simp: lam.inject)
    next case b7 thus ?thesis by (auto simp: lam.inject)
    next case (b8 s2)
      have b: "b = True" and t: "t = MkPair t' s2" using b8 by (auto simp: lam.inject)
      from t have "t'=t1" using t_pair by (auto simp: lam.inject)
      with b show ?thesis by auto
    next case (b9 s1)
      have b: "b = False" and t: "t = MkPair s1 t'" using b9 by (auto simp: lam.inject)
      from t have "t'=t2" using t_pair by (auto simp: lam.inject)
      with b show ?thesis by auto
  qed

  hence "{t'.  Unpair b t \<longrightarrow>\<^sub>\<beta> t'} \<subseteq> ?choices" by blast
  moreover have "finite ?choices" using Unpair by auto
  ultimately show "finite {t'.  Unpair b t \<longrightarrow>\<^sub>\<beta> t'}"
    using infinite_super by auto
qed

lemma SN_len_bound:
  assumes "SN t"
  shows "\<exists>n. len_bound t n"
using assms proof (induction)
case (SN_intro t)
  define succ where "succ \<equiv> {t'. t \<longrightarrow>\<^sub>\<beta> t'}"
  have bounded: "\<And>t'. t' \<in> succ \<Longrightarrow> \<exists>n. len_bound t' n" using SN_intro.IH succ_def by auto
  have "finite succ" using succ_def beta_finite_branch by auto
  then obtain n where "\<And>t'. t' \<in> succ \<Longrightarrow> len_bound t' n"
  proof (atomize_elim, insert bounded, induction rule:finite_induct)
  case empty show ?case by simp
  next case (insert t F)
    obtain nx where nx: "len_bound t nx" using insert.prems by auto
    obtain nF where nF: "\<And>t'. t' \<in> F \<Longrightarrow> len_bound t' nF" using insert.prems insert.IH by auto
    show ?case
      apply (rule exI[of _ "max nx nF"]) using nx nF
      apply (auto simp: max_def mono_len_bound)
      using mono_len_bound nat_le_linear by blast
  qed
  then have "len_bound t (Suc n)"
    apply (rule len_bound_succ) unfolding succ_def by simp
  thus ?case by auto
qed

lemma pair_RED:
  assumes s_RED: "s \<in> RED \<sigma>" and t_RED: "t \<in> RED \<tau>"
  shows "MkPair s t \<in> RED (TPair \<sigma> \<tau>)"
proof -
  from assms have "SN s" and "SN t"
    using CR1_def RED_props(1) by blast+
  from \<open>SN s\<close> obtain ns where ns: "len_bound s ns" apply atomize_elim by (rule SN_len_bound)
  from \<open>SN t\<close> obtain nt where nt: "len_bound t nt" apply atomize_elim by (rule SN_len_bound)
  define n where "n \<equiv> ns + nt"

  have fst_red: "Unpair True (MkPair s t) \<in> RED \<sigma>"
    using n_def[THEN meta_eq_to_obj_eq] ns nt s_RED
  proof (induction n arbitrary: ns nt s t rule:nat_less_induct)
  case (1 n)
    have "u \<in> RED \<sigma>" if beta: "Unpair True (MkPair s t) \<longrightarrow>\<^sub>\<beta> u" for u
    using beta proof cases
    case b1 thus ?thesis by auto
    next case b2 thus ?thesis by auto
    next case b3 thus ?thesis by auto
    next case b4 thus ?thesis by auto
    next case b5 thus ?thesis by auto
    next case b6 thus ?thesis by auto
    next case b9 thus ?thesis by (auto simp: lam.inject)
    next case (b8) thus ?thesis using 1 by (auto simp: lam.inject)
    next case (b7 s1 s' b)
      hence s': "MkPair s t \<longrightarrow>\<^sub>\<beta> s'" and u: "u = Unpair True s'" by (auto simp: lam.inject)
      show ?thesis
      using s' proof cases
      case b1 thus ?thesis by auto
      next case b2 thus ?thesis by auto
      next case b3 thus ?thesis by auto
      next case b4 thus ?thesis by auto
      next case b7 thus ?thesis by (auto simp: lam.inject)
      next case b8 thus ?thesis by (auto simp: lam.inject)
      next case b9 thus ?thesis by (auto simp: lam.inject)
      next case (b5 _ s'')
        hence s': "s' = MkPair s'' t" and ss'': "s \<longrightarrow>\<^sub>\<beta> s''" by (auto simp: lam.inject)
        obtain ns'' where ns'': "len_bound s'' ns''" and ns''_bound: "ns'' < ns"
          using `len_bound s ns` ss'' by (metis NORMAL_def len_bound.simps lessI)
        have s''_RED: "s'' \<in> RED \<sigma>" using ss'' "1.prems"
          using CR2_def RED_props(2) by blast
        have "Unpair True (MkPair s'' t) \<in> RED \<sigma>"
          apply (rule "1.IH"[rule_format, rotated 2])
             apply (fact ns'') apply (fact "1.prems") apply (fact s''_RED)
           by (simp_all add: "1.prems"(1) ns''_bound)
        thus ?thesis
          unfolding u s' by simp
      next case (b6 _ t'')
        hence s': "s' = MkPair s t''" and tt'': "t \<longrightarrow>\<^sub>\<beta> t''" by (auto simp: lam.inject)
        obtain nt'' where nt'': "len_bound t'' nt''" and nt''_bound: "nt'' < nt"
          using `len_bound t nt` tt'' by (metis NORMAL_def len_bound.simps lessI)
        have "Unpair True (MkPair s t'') \<in> RED \<sigma>"
          apply (rule "1.IH"[rule_format, rotated 2])
             apply (fact "1.prems") apply (fact nt'') apply (fact "1.prems")
           by (simp_all add: "1.prems"(1) nt''_bound)
        thus ?thesis
          unfolding u s' by simp
      qed
    qed
    thus ?case
      using CR3_RED_def CR3_def NEUT_def RED_props(3) by blast
  qed

  have snd_red: "Unpair False (MkPair s t) \<in> RED \<tau>"
    using n_def[THEN meta_eq_to_obj_eq] ns nt t_RED
  proof (induction n arbitrary: ns nt s t rule:nat_less_induct)
  case (1 n)
    have "u \<in> RED \<tau>" if beta: "Unpair False (MkPair s t) \<longrightarrow>\<^sub>\<beta> u" for u
    using beta proof cases
    case b1 thus ?thesis by auto
    next case b2 thus ?thesis by auto
    next case b3 thus ?thesis by auto
    next case b4 thus ?thesis by auto
    next case b5 thus ?thesis by auto
    next case b6 thus ?thesis by auto
    next case b8 thus ?thesis by (auto simp: lam.inject)
    next case b9 thus ?thesis using 1 by (auto simp: lam.inject)
    next case (b7 s1 s' b)
      hence s': "MkPair s t \<longrightarrow>\<^sub>\<beta> s'" and u: "u = Unpair False s'" by (auto simp: lam.inject)
      show ?thesis
      using s' proof cases
      case b1 thus ?thesis by auto
      next case b2 thus ?thesis by auto
      next case b3 thus ?thesis by auto
      next case b4 thus ?thesis by auto
      next case b7 thus ?thesis by (auto simp: lam.inject)
      next case b8 thus ?thesis by (auto simp: lam.inject)
      next case b9 thus ?thesis by (auto simp: lam.inject)
      next case (b5 _ s'')
        hence s': "s' = MkPair s'' t" and ss'': "s \<longrightarrow>\<^sub>\<beta> s''" by (auto simp: lam.inject)
        obtain ns'' where ns'': "len_bound s'' ns''" and ns''_bound: "ns'' < ns"
          using `len_bound s ns` ss'' by (metis NORMAL_def len_bound.simps lessI)
        have "Unpair False (MkPair s'' t) \<in> RED \<tau>"
          apply (rule "1.IH"[rule_format, rotated 2])
             apply (fact ns'') apply (fact "1.prems") apply (fact "1.prems")
           by (simp_all add: "1.prems"(1) ns''_bound)
        thus ?thesis
          unfolding u s' by simp
      next case (b6 _ t'')
        hence s': "s' = MkPair s t''" and tt'': "t \<longrightarrow>\<^sub>\<beta> t''" by (auto simp: lam.inject)
        obtain nt'' where nt'': "len_bound t'' nt''" and nt''_bound: "nt'' < nt"
          using `len_bound t nt` tt'' by (metis NORMAL_def len_bound.simps lessI)
        have t''_RED: "t'' \<in> RED \<tau>" using tt'' "1.prems"
          using CR2_def RED_props(2) by blast
        have "Unpair False (MkPair s t'') \<in> RED \<tau>"
          apply (rule "1.IH"[rule_format, rotated 2])
             apply (fact "1.prems") apply (fact nt'') apply (fact t''_RED)
           by (simp_all add: "1.prems"(1) nt''_bound)
        thus ?thesis
          unfolding u s' by simp
      qed
    qed
    thus ?case
      using CR3_RED_def CR3_def NEUT_def RED_props(3) by blast
  qed

  show "MkPair s t \<in> RED (TPair \<sigma> \<tau>)"
    using fst_red snd_red by simp
qed

abbreviation
 mapsto :: "(name\<times>lam) list \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> bool" ("_ maps _ to _" [55,55,55] 55)
where
 "\<theta> maps x to e \<equiv> (lookup \<theta> x) = e"

abbreviation
  closes :: "(name\<times>lam) list \<Rightarrow> (name\<times>ty) list \<Rightarrow> bool" ("_ closes _" [55,55] 55)
where
  "\<theta> closes \<Gamma> \<equiv> \<forall>x T. ((x,T) \<in> set \<Gamma> \<longrightarrow> (\<exists>t. \<theta> maps x to t \<and> t \<in> RED T))"

lemma all_RED:
  assumes a: "\<Gamma> \<turnstile> t : \<tau>"
  and     b: "\<theta> closes \<Gamma>"
  shows "\<theta><t> \<in> RED \<tau>"
using a b
proof(nominal_induct  avoiding: \<theta> rule: typing.strong_induct)
  case (t3 a \<Gamma> \<sigma> t \<tau> \<theta>) \<comment> \<open>lambda case\<close>
  have ih: "\<And>\<theta>. \<theta> closes ((a,\<sigma>)#\<Gamma>) \<Longrightarrow> \<theta><t> \<in> RED \<tau>" by fact
  have \<theta>_cond: "\<theta> closes \<Gamma>" by fact
  have fresh: "a\<sharp>\<Gamma>" "a\<sharp>\<theta>" by fact+
  from ih have "\<forall>s\<in>RED \<sigma>. ((a,s)#\<theta>)<t> \<in> RED \<tau>" using fresh \<theta>_cond fresh_context by simp
  then have "\<forall>s\<in>RED \<sigma>. \<theta><t>[a::=s] \<in> RED \<tau>" using fresh by (simp add: psubst_subst)
  then have "Lam [a].(\<theta><t>) \<in> RED (\<sigma> \<rightarrow> \<tau>)" by (simp only: abs_RED)
  then show "\<theta><(Lam [a].t)> \<in> RED (\<sigma> \<rightarrow> \<tau>)" using fresh by simp
next
  case (t4 \<Gamma> t1 \<tau> t2 \<sigma>) thus ?case
    using pair_RED psubst.simps(3) by presburger
qed auto

section {* identity substitution generated from a context \<Gamma> *}
fun
  "id" :: "(name\<times>ty) list \<Rightarrow> (name\<times>lam) list"
where
  "id []    = []"
| "id ((x,\<tau>)#\<Gamma>) = (x,Var x)#(id \<Gamma>)"

lemma id_maps:
  shows "(id \<Gamma>) maps a to (Var a)"
by (induct \<Gamma>) (auto)

lemma id_fresh:
  fixes a::"name"
  assumes a: "a\<sharp>\<Gamma>"
  shows "a\<sharp>(id \<Gamma>)"
using a
by (induct \<Gamma>)
   (auto simp add: fresh_list_nil fresh_list_cons)

lemma id_apply:
  shows "(id \<Gamma>)<t> = t"
by (nominal_induct t avoiding: \<Gamma> rule: lam.strong_induct)
   (auto simp add: id_maps id_fresh)

lemma id_closes:
  shows "(id \<Gamma>) closes \<Gamma>"
apply(auto)
apply(simp add: id_maps)
apply(subgoal_tac "CR3 T") \<comment> \<open>A\<close>
apply(drule CR3_implies_CR4)
apply(simp add: CR4_def)
apply(drule_tac x="Var x" in spec)
apply(force simp add: NEUT_def NORMAL_Var)
\<comment> \<open>A\<close>
apply(rule RED_props)
done

lemma typing_implies_RED:
  assumes a: "\<Gamma> \<turnstile> t : \<tau>"
  shows "t \<in> RED \<tau>"
proof -
  have "(id \<Gamma>)<t>\<in>RED \<tau>"
  proof -
    have "(id \<Gamma>) closes \<Gamma>" by (rule id_closes)
    with a show ?thesis by (rule all_RED)
  qed
  thus"t \<in> RED \<tau>" by (simp add: id_apply)
qed

lemma typing_implies_SN:
  assumes a: "\<Gamma> \<turnstile> t : \<tau>"
  shows "SN(t)"
proof -
  from a have "t \<in> RED \<tau>" by (rule typing_implies_RED)
  moreover
  have "CR1 \<tau>" by (rule RED_props)
  ultimately show "SN(t)" by (simp add: CR1_def)
qed

end


section \<open>Gale Stewart Games\<close>

text \<open>Gale Stewart Games are infinite two player games.\<close>
(* [Gale & Stewart 1953] David Gale, F. M. Stewart, Infinite games with perfect information,
   Contributions to the Theory of Games II, ed. H. W. Kuhn and A. W. Tucker,
   Annals of Mathematics Studies 28, Princeton University Press (1953), pp 245–266. *)

theory GaleStewartGames
  imports AlternatingLists MorePrefix MoreENat
begin

subsection \<open>Basic definitions and their properties.\<close>

text \<open>A GSgame G(A) is defined by a set of sequences that denote the winning games for the first
      player. Our notion of GSgames generalizes both finite and infinite games by setting a game length.
      Note that the type of n is 'enat' (extended nat): either a nonnegative integer or infinity.
      Our only requirement on GSgames is that the winning games must have the length as specified
      as the length of the game. This helps certain theorems about winning look a bit more natural.\<close>

locale GSgame =
  fixes A N
  assumes length:"\<forall>e\<in>A. llength e = 2*N"
begin

text \<open>A position is a finite sequence of valid moves.\<close>
definition "position" where
  "position (e::'a list) \<equiv> length e \<le> 2*N"

lemma position_maxlength_cannotbe_augmented:
assumes "length p = 2*N"
shows "\<not> position (p @ [m])"
 by (auto simp:position_def assms[symmetric])

text \<open>A play is a sequence of valid moves of the right length.\<close>
definition "play" where
  "play (e::'a llist) \<equiv> llength e = 2*N"

lemma plays_are_positions_conv:
  shows "play (llist_of p) \<longleftrightarrow> position p \<and> length p = 2*N"
unfolding play_def position_def by auto

lemma finite_plays_are_positions:
  assumes "play p" "lfinite p"
  shows "position (list_of p)"
using assms
unfolding play_def position_def by (cases "lfinite p";auto simp:length_list_of)

end

text \<open>We call our players Even and Odd, where Even makes the first move.
      This means that Even is to make moves on plays of even length, and Odd on the others.
      This corresponds nicely to Even making all the moves in an even position, as
      the `nth' and `lnth' functions as predefined in Isabelle's library count from 0.
      In literature the players are sometimes called I and II.\<close>

text \<open>A strategy for Even/Odd is simply a function that takes a position of even/odd length and
      returns a move. We use total functions for strategies. This means that their Isabelle-type
      determines that it is a strategy. Consequently, we do not have a definition of 'strategy'.
      Nevertheless, we will use $\sigma$ as a letter to indicate when something is a strategy.
      We can combine two strategies into one function, which gives a collective strategy that
      we will refer to as the joint strategy.\<close>

definition joint_strategy  :: "('b list \<Rightarrow> 'a) \<Rightarrow> ('b list \<Rightarrow> 'a) \<Rightarrow> ('b list \<Rightarrow> 'a)" where
  "joint_strategy \<sigma>\<^sub>e \<sigma>\<^sub>o p = (if even (length p) then \<sigma>\<^sub>e p else \<sigma>\<^sub>o p)"

text \<open>Following a strategy leads to an infinite sequence of moves.
      Note that we are not in the context of 'GSGame' where 'N' determines the length of our plays:
      we just let sequences go on ad infinitum here.
      Rather than reasoning about our own recursive definitions,
      we build this infinite sequence by reusing definitions that are already in place.
      We do this by first defining all prefixes of the infinite sequence we are interested in.
      This gives an infinite list such that the nth element is of length n.
      Note that this definition allows us to talk about how a strategy would continue if it were
      played from an arbitrary position (not necessarily one that is reached via that strategy). \<close>

definition strategy_progression where
  "strategy_progression \<sigma> p = lappend (llist_of (prefixes p)) (ltl (iterates (augment_list \<sigma>) p))"

lemma induced_play_infinite:
  "\<not> lfinite (strategy_progression \<sigma> p)"
unfolding strategy_progression_def by auto

lemma plays_from_strategy_lengths[simp]:
  "length (strategy_progression \<sigma> p $ i) = i"
proof(induct i)
  case 0
  then show ?case by(cases p;auto simp:strategy_progression_def lnth_lappend take_map ltake_lappend)
next
  case (Suc i)
  then show ?case
    by (cases "i<length p") (auto simp:strategy_progression_def lnth_lappend length_augment_list tl_prefixes_idx)
qed

lemma length_plays_from_strategy[simp]:
  "llength (strategy_progression \<sigma> p) = \<infinity>"
  unfolding strategy_progression_def by auto
lemma length_ltl_plays_from_strategy[simp]:
  "llength (ltl (strategy_progression \<sigma> p)) = \<infinity>"
  unfolding strategy_progression_def by auto

lemma plays_from_strategy_chain_Suc:
  shows "prefix (strategy_progression \<sigma> p  $  n) (strategy_progression \<sigma> p  $  Suc n)"
  unfolding strategy_progression_def
  by (auto simp:take_Suc_prefix nth_prefixes lnth_lappend nth_prefixes_is_prefix_tl
                augment_list_prefix)

lemma plays_from_strategy_chain:
  shows "n \<le> m \<Longrightarrow> prefix (strategy_progression \<sigma> p  $  n) (strategy_progression \<sigma> p  $  m)"
proof (induct "m-n" arbitrary:m n)
  case (Suc x)
  hence [simp]:"Suc (x + n) = m" by auto
  from Suc.hyps(2)
    prefix_order.trans[OF Suc.hyps(1)[of "x + n" n] plays_from_strategy_chain_Suc[of _ _ "x+n"]]
  show ?case by auto
qed auto

lemma plays_from_strategy_remains_const:
  assumes "n \<le> i"
  shows "take n (strategy_progression \<sigma> p  $  i)  =  strategy_progression \<sigma> p  $  n"
  apply(rule sym,subst prefix_same_length_eq[symmetric])
  using assms plays_from_strategy_chain[OF assms]
  by (auto intro!:prefix_takeI)

lemma infplays_augment_one[simp]:
  "strategy_progression \<sigma> (p @ [\<sigma> p]) = strategy_progression \<sigma> p"
proof(induct p)
  note defs = strategy_progression_def
  {
    case Nil
    then show ?case
      by (auto simp:defs iterates.code[of _ "[\<sigma> []]"])
  next
    case (Cons a p)
    then show ?case
      by (auto simp:defs iterates.code[of _ "a # p @ [\<sigma> (a # p)]"] lappend_llist_of_LCons)
  }
qed

lemma infplays_augment_many[simp]:
  "strategy_progression \<sigma> ((augment_list \<sigma> ^^ n) p) = strategy_progression \<sigma> p"
by(induct n,auto)

lemma infplays_augment_one_joint[simp]:
  "even (length p) \<Longrightarrow> strategy_progression (joint_strategy \<sigma>\<^sub>e \<sigma>\<^sub>o) (augment_list \<sigma>\<^sub>e p)
                     = strategy_progression (joint_strategy \<sigma>\<^sub>e \<sigma>\<^sub>o) p"
  "odd (length p)  \<Longrightarrow> strategy_progression (joint_strategy \<sigma>\<^sub>e \<sigma>\<^sub>o) (augment_list \<sigma>\<^sub>o p)
                     = strategy_progression (joint_strategy \<sigma>\<^sub>e \<sigma>\<^sub>o) p"
using infplays_augment_one[of "joint_strategy \<sigma>\<^sub>e \<sigma>\<^sub>o" p]
unfolding joint_strategy_def by auto

text \<open>Following two different strategies from a single position will lead to the same plays
      if the strategies agree on moves played after that position.
      This lemma allows us to ignore the behavior of strategies for moves that are already played. \<close>
lemma infplays_eq:
  assumes "\<And> p'. prefix p p' \<Longrightarrow> augment_list s1 p' = augment_list s2 p'"
  shows "strategy_progression s1 p = strategy_progression s2 p"
proof -
  from assms[of p] have [intro]:"s1 p = s2 p" by auto
  have "(augment_list s1 ^^ n) (augment_list s1 p) =
          (augment_list s2 ^^ n) (augment_list s2 p)" for n
    proof(induct n)
    case (Suc n)
    with assms[OF prefix_order.trans[OF _ prefix_augment]]
    show ?case by (auto)
  qed auto
  hence "strategy_progression s1 p $ n = strategy_progression s2 p $ n"
    for n (* different n *) unfolding strategy_progression_def lnth_lappend by auto
  thus ?thesis by(intro coinductive_eq_I,auto)
qed

context GSgame
begin

text \<open>By looking at the last elements of the infinite progression,
      we can get a single sequence, which we trim down to the right length.
      Since it has the right length, this always forms a play.
      We therefore name this the 'induced play'. \<close>

definition induced_play where
  "induced_play \<sigma> \<equiv> ltake (2*N) o lmap last o ltl o strategy_progression \<sigma>"

lemma induced_play_infinite_le[simp]:
  "enat x < llength (strategy_progression \<sigma> p)"
  "enat x < llength (lmap f (strategy_progression \<sigma> p))"
  "enat x < llength (ltake (2*N) (lmap f (strategy_progression \<sigma> p))) \<longleftrightarrow> x < 2*N"
using induced_play_infinite by auto

lemma induced_play_is_lprefix:
  assumes "position p"
  shows "lprefix (llist_of p) (induced_play \<sigma> p)"
proof -
  have l:"llength (llist_of p) \<le> 2 * N" using assms unfolding position_def by auto
  have "lprefix (llist_of p) (lmap last (ltl (llist_of (prefixes p))))" by auto
  hence "lprefix (llist_of p) ((lmap last o ltl o strategy_progression \<sigma>) p)"
    unfolding strategy_progression_def by(auto simp add: lmap_lappend_distrib lprefix_lappend)
  thus ?thesis unfolding induced_play_def o_def
    using lprefix_ltakeI[OF _ l] by blast
qed

lemma length_induced_play[simp]:
  "llength (induced_play s p) = 2 * N"
  unfolding induced_play_def by auto

lemma induced_play_lprefix_non_positions: (* 'opposite' of induced_play_is_lprefix *)
  assumes "length (p::'a list) \<ge> 2 * N"
  shows "induced_play \<sigma> p = ltake (2 * N) (llist_of p)"
proof(cases "N")
  case (enat nat)
  let ?p = "take (2 * nat) p"
  from assms have [intro]:"2 * N \<le> enat (length p)" by auto
  have [intro]:"2 * N \<le> enat (min (length p) (2 * nat))" unfolding enat
    by (metis assms enat min.orderI min_def numeral_eq_enat times_enat_simps(1))
  have [intro]:"enat (min (length p) (2 * nat)) = 2 * N"
    by (metis (mono_tags, lifting) assms enat min.absorb2 min_enat_simps(1)
        numeral_eq_enat times_enat_simps(1))
  have n:"2 * N \<le> llength (llist_of p)" "2 * N \<le> llength (llist_of (take (2 * nat) p))" by auto
  have pp:"position ?p"
    apply(subst position_def) (* for some reason 'unfolding' does not work here, tested in Isabelle 2021 *)
    by (metis (no_types, lifting) assms dual_order.order_iff_strict enat llength_llist_of
               llength_ltake' ltake_llist_of numeral_eq_enat take_all times_enat_simps(1))
  have lp:"lprefix (llist_of ?p) (induced_play \<sigma> ?p)" by(rule induced_play_is_lprefix[OF pp])
  (* this would make a great separate lemma, but we have a conversion between N and its nat
     to make that more involved *)
  have "ltake (2 * N) (llist_of p) = ltake (2 * N) (llist_of (take (2 * nat) p))"
    unfolding ltake_llist_of[symmetric] enat ltake_ltake numeral_eq_enat by auto
  hence eq:"induced_play \<sigma> p = induced_play \<sigma> ?p"
    unfolding induced_play_def strategy_progression_def
    by(auto simp add: lmap_lappend_distrib n[THEN ltake_lappend1])
  have "llist_of (take (2 * nat) p) = induced_play \<sigma> p"
    by(rule lprefix_llength_eq_imp_eq[OF lp[folded eq]],auto)
  then show ?thesis
     unfolding enat ltake_llist_of[symmetric] (* simp applies this one in the wrong direction *)
               numeral_eq_enat times_enat_simps(1) by metis
next
  case infinity
  hence "2 * N = \<infinity>" by (simp add: imult_is_infinity)
  then show ?thesis using assms by auto
qed

lemma infplays_augment_many_lprefix[simp]:
  shows "lprefix (llist_of ((augment_list \<sigma> ^^ n) p)) (induced_play \<sigma> p)
        = position ((augment_list \<sigma> ^^ n) p)" (is "?lhs = ?rhs")
proof
  assume ?lhs
  from lprefix_llength_le[OF this] show ?rhs unfolding induced_play_def
    by (auto simp:position_def length_augment_list) next
  assume assm:?rhs
  from induced_play_is_lprefix[OF this, of "\<sigma>"]
  show ?lhs unfolding induced_play_def by simp
qed

subsection \<open> Winning strategies \<close>

text \<open> A strategy is winning (in position p) if, no matter the moves by the other player,
       it leads to a sequence in the winning set. \<close>
definition strategy_winning_by_Even where
  "strategy_winning_by_Even \<sigma>\<^sub>e p \<equiv> (\<forall> \<sigma>\<^sub>o. induced_play (joint_strategy \<sigma>\<^sub>e \<sigma>\<^sub>o) p \<in> A)"
definition strategy_winning_by_Odd where
  "strategy_winning_by_Odd \<sigma>\<^sub>o p \<equiv> (\<forall> \<sigma>\<^sub>e. induced_play (joint_strategy \<sigma>\<^sub>e \<sigma>\<^sub>o) p \<notin> A)"

text \<open> It immediately follows that not both players can have a winning strategy. \<close>
lemma at_most_one_player_winning:
shows "\<not> (\<exists> \<sigma>\<^sub>e. strategy_winning_by_Even \<sigma>\<^sub>e p) \<or> \<not> (\<exists> \<sigma>\<^sub>o. strategy_winning_by_Odd \<sigma>\<^sub>o p)"
  unfolding strategy_winning_by_Even_def strategy_winning_by_Odd_def by auto

text \<open> If a player whose turn it is not makes any move, winning strategies remain winning.
       All of the following proofs are duplicated for Even and Odd,
       as the game is entirely symmetrical. These 'dual' theorems can be obtained
       by considering a game in which an additional first and final move are played yet ignored,
       but it is quite convenient to have both theorems at hand regardless, and the proofs are
       quite small, so we accept the code duplication. \<close>

lemma any_moves_remain_winning_Even:
  assumes "odd (length p)" "strategy_winning_by_Even \<sigma> p"
  shows "strategy_winning_by_Even \<sigma> (p @ [m])"
unfolding strategy_winning_by_Even_def proof
  fix \<sigma>\<^sub>o
  let ?s = "\<sigma>\<^sub>o(p:=m)"
  have prfx:"prefix (p @ [m]) p' \<Longrightarrow>
             p' @ [joint_strategy \<sigma> \<sigma>\<^sub>o p'] = p' @ [joint_strategy \<sigma> ?s p']"
    for p' by (auto simp: joint_strategy_def)
  from assms(2)[unfolded strategy_winning_by_Even_def,rule_format,of ?s]
       infplays_augment_one_joint(2)[OF assms(1)]
  have "induced_play (joint_strategy \<sigma> ?s) (augment_list ?s p) \<in> A"
    by (metis (mono_tags, lifting) induced_play_def comp_apply)
  thus "induced_play (joint_strategy \<sigma> \<sigma>\<^sub>o) (p @ [m]) \<in> A"
    unfolding induced_play_def o_def
    using infplays_eq[OF prfx] by auto
qed

lemma any_moves_remain_winning_Odd:
  assumes "even (length p)" "strategy_winning_by_Odd \<sigma> p"
  shows "strategy_winning_by_Odd \<sigma> (p @ [m])"
unfolding strategy_winning_by_Odd_def proof
  fix \<sigma>\<^sub>e
  let ?s = "\<sigma>\<^sub>e(p:=m)"
  have prfx:"prefix (p @ [m]) p' \<Longrightarrow>
             p' @ [joint_strategy \<sigma>\<^sub>e \<sigma> p'] = p' @ [joint_strategy ?s \<sigma> p']"
    for p' by (auto simp:joint_strategy_def)
  from assms(2)[unfolded strategy_winning_by_Odd_def,rule_format,of ?s]
       infplays_augment_one_joint(1)[OF assms(1)]
  have "induced_play (joint_strategy ?s \<sigma>) (augment_list ?s p) \<notin> A"
    by (metis (mono_tags, lifting) induced_play_def comp_apply)
  thus "induced_play (joint_strategy \<sigma>\<^sub>e \<sigma>) (p @ [m]) \<notin> A"
    unfolding induced_play_def o_def
    using infplays_eq[OF prfx] by auto
qed

text \<open> If a player does not have a winning strategy,
       a move by that player will not give it one. \<close>

lemma non_winning_moves_remains_non_winning_Even:
  assumes "even (length p)" "\<forall> \<sigma>. \<not> strategy_winning_by_Even \<sigma> p"
  shows "\<not> strategy_winning_by_Even \<sigma> (p @ [m])"
proof(rule contrapos_nn[of "\<exists> \<sigma>. strategy_winning_by_Even \<sigma> p"])
  assume a:"strategy_winning_by_Even \<sigma> (p @ [m])"
  let ?s = "\<sigma>(p:=m)"
  have prfx:"prefix (p @ [m]) p' \<Longrightarrow>
             p' @ [joint_strategy \<sigma> \<sigma>\<^sub>o p'] = p' @ [joint_strategy ?s \<sigma>\<^sub>o p']"
    for p' \<sigma>\<^sub>o by (auto simp:joint_strategy_def)
  from a infplays_eq[OF prfx]
  have "strategy_winning_by_Even ?s (p @ [m])"
    unfolding strategy_winning_by_Even_def induced_play_def by simp
  hence "strategy_winning_by_Even ?s p"
    using infplays_augment_one_joint(1)[OF assms(1)]
    unfolding strategy_winning_by_Even_def induced_play_def o_def
    by (metis fun_upd_same)
  thus "\<exists>\<sigma>. strategy_winning_by_Even \<sigma> p" by blast next
  from assms(2) show "\<not> (\<exists> \<sigma>. strategy_winning_by_Even \<sigma> p)" by meson
qed

lemma non_winning_moves_remains_non_winning_Odd:
  assumes "odd (length p)" "\<forall> \<sigma>. \<not> strategy_winning_by_Odd \<sigma> p"
  shows "\<not> strategy_winning_by_Odd \<sigma> (p @ [m])"
proof(rule contrapos_nn[of "\<exists> \<sigma>. strategy_winning_by_Odd \<sigma> p"])
  assume a:"strategy_winning_by_Odd \<sigma> (p @ [m])"
  let ?s = "\<sigma>(p:=m)"
  have prfx:"prefix (p @ [m]) p' \<Longrightarrow>
             p' @ [joint_strategy \<sigma>\<^sub>e \<sigma> p'] = p' @ [joint_strategy \<sigma>\<^sub>e ?s p']"
    for p' \<sigma>\<^sub>e by (auto simp:joint_strategy_def)
  from a infplays_eq[OF prfx]
  have "strategy_winning_by_Odd ?s (p @ [m])"
    unfolding strategy_winning_by_Odd_def induced_play_def by simp
  hence "strategy_winning_by_Odd ?s p"
    using infplays_augment_one_joint(2)[OF assms(1)]
    unfolding strategy_winning_by_Odd_def induced_play_def o_def
    by (metis fun_upd_same)
  thus "\<exists>\<sigma>. strategy_winning_by_Odd \<sigma> p" by blast next
  from assms(2) show "\<not> (\<exists> \<sigma>. strategy_winning_by_Odd \<sigma> p)" by meson
qed

text \<open> If a player whose turn it is makes a move according to its stragey,
       the new position will remain winning. \<close>

lemma winning_moves_remain_winning_Even:
  assumes "even (length p)" "strategy_winning_by_Even \<sigma> p"
  shows "strategy_winning_by_Even \<sigma> (p @ [\<sigma> p])"
using assms infplays_augment_one
unfolding induced_play_def strategy_winning_by_Even_def by auto

lemma winning_moves_remain_winning_Odd:
  assumes "odd (length p)" "strategy_winning_by_Odd \<sigma> p"
  shows "strategy_winning_by_Odd \<sigma> (p @ [\<sigma> p])"
using assms infplays_augment_one
unfolding induced_play_def strategy_winning_by_Odd_def by auto

text \<open> We speak of winning positions as those positions in which the player has a winning strategy.
       This is mainly for presentation purposes. \<close>

abbreviation winning_position_Even where
  "winning_position_Even p \<equiv> position p \<and> (\<exists> \<sigma>. strategy_winning_by_Even \<sigma> p)"
abbreviation winning_position_Odd where
  "winning_position_Odd p \<equiv> position p \<and> (\<exists> \<sigma>. strategy_winning_by_Odd \<sigma> p)"

lemma winning_position_can_remain_winning_Even:
  assumes "even (length p)" "\<forall> m. position (p @ [m])" "winning_position_Even p"
  shows "\<exists> m. winning_position_Even (p @ [m])"
using assms winning_moves_remain_winning_Even[OF assms(1)] by auto

lemma winning_position_can_remain_winning_Odd:
  assumes "odd (length p)" "\<forall> m. position (p @ [m])" "winning_position_Odd p"
  shows "\<exists> m. winning_position_Odd (p @ [m])"
using assms winning_moves_remain_winning_Odd[OF assms(1)] by auto

lemma winning_position_will_remain_winning_Even:
  assumes "odd (length p)" "position (p @ [m])" "winning_position_Even p"
  shows "winning_position_Even (p @ [m])"
using assms any_moves_remain_winning_Even[OF assms(1)] by auto

lemma winning_position_will_remain_winning_Odd:
  assumes "even (length p)" "position (p @ [m])" "winning_position_Odd p"
  shows "winning_position_Odd (p @ [m])"
using assms any_moves_remain_winning_Odd[OF assms(1)] by auto

lemma induced_play_eq:
assumes "\<forall> p'. prefix p p' \<longrightarrow> (augment_list s1) p' = (augment_list s2) p'"
shows "induced_play s1 p = induced_play s2 p"
unfolding induced_play_def by (auto simp:infplays_eq[OF assms[rule_format]])

end

end


theory Assertion_Misc
imports Assertion_Lang
begin

section \<open>Miscellaneous definitions used with the assertion language\<close>

text \<open>A type class of functions that extract used variables (similarly to vars).\<close>
class fv =
fixes fv :: "'a \<Rightarrow> var set"

text \<open>A type class of functions that extract used variables from lists.\<close>
class fvl = fv +
fixes fvl :: "'a list \<Rightarrow> var set"

instantiation expr :: fv
begin
fun fv_expr :: "expr \<Rightarrow> var set" where
"fv_expr (nil) = {}" |
"fv_expr (\<acute>v`) = {v}"
instance ..
end

instantiation pure :: fv
begin
fun fv_pure :: "pure \<Rightarrow> var set" where
"fv_pure (e1 =\<^sub>p e2) = fv e1 \<union> fv e2" |
"fv_pure (e1 \<noteq>\<^sub>p e2) =  fv e1 \<union> fv e2"
instance ..
end

instantiation pure :: fvl
begin
fun fvl_pure :: "pure_form \<Rightarrow> var set" where
  "fvl_pure pf = \<Union> (fv`(set pf))"
instance ..
end

instantiation spatial :: fv
begin
fun fv_spatial :: "spatial \<Rightarrow> var set" where
"fv_spatial (e1 \<longmapsto> e2) = fv e1 \<union> fv e2" |
"fv_spatial (ls(e1,e2)) = fv e1 \<union> fv e2"
instance ..
end

instantiation spatial :: fvl
begin
fun fvl_spatial :: "spatial_form \<Rightarrow> var set" where
  "fvl_spatial sf = \<Union> (fv`(set sf))"
instance ..
end

instantiation formula :: fv
begin
fun fv_formula :: "formula \<Rightarrow> var set" where
"fv_formula (Pure p) = fv p" |
"fv_formula (PureF pf) = fvl pf" |
"fv_formula (Spat s) = fv s" |
"fv_formula (SpatF sf) = fvl sf" |
"fv_formula (pf \<bar> sf) = fvl pf \<union> fvl sf"
instance ..
end

lemma fv_finite_expr: "finite (fv (x::expr))"
by (metis finite.simps fv_expr.elims)

lemma fv_finite_un: "\<exists>v. v \<notin> fv (x::expr) \<union> fv (y::expr)"
using fv_finite_expr Finite_Set.finite_Un Finite_Set.ex_new_if_finite infinite_UNIV_listI by metis

lemma fv_other_x: "\<And>x. \<exists>x'. x' \<notin> fv (e::expr) \<and> x' \<noteq> x"
  using fv_finite_expr fv_finite_un by (metis Un_iff fv_expr.simps(2) insertI1)

lemma fv_other_x_un: "x \<notin> fv (e1::expr) \<union> fv (e2::expr) \<Longrightarrow> \<exists>x'. x' \<notin> fv (e1::expr) \<union> fv (e2::expr) \<and> x' \<noteq> x"
proof -
assume assm: "x \<notin> fv (e1::expr) \<union> fv (e2::expr)"
have "finite (fv e1 \<union> fv e2)" using fv_finite_expr by simp
hence "\<not>finite(-(fv e1 \<union> fv e2))" by (meson finite_compl infinite_UNIV_listI)
moreover have "\<not>finite (S::string set) \<Longrightarrow> \<forall>y \<in> S. \<exists>y' \<in> S. y\<noteq>y'" for S
by (metis (no_types, hide_lams) finite.simps insertCI insert_absorb insert_is_Un subsetI subset_antisym sup_ge1)
ultimately obtain y where "y \<in> -(fv e1 \<union> fv e2)" "y\<noteq>x" using assm by auto
thus ?thesis by auto
qed

text \<open>Orthogonality property of heaps.\<close>
abbreviation "orthogonal h1 h2 \<equiv> dom h1 \<inter> dom h2 = {}"
notation orthogonal ("_ \<bottom> _" [60, 61] 61)

theorem ortho_commut: "h1 \<bottom> h2 \<longleftrightarrow> h2 \<bottom> h1" by auto
theorem ortho_distr: "h1 \<bottom> (h2++h3) \<longleftrightarrow> (h1 \<bottom> h2 \<and> h1 \<bottom> h3)" by auto

text \<open>A type class that functions that substitute a variable for another expression.\<close>
class subst =
fixes subst :: "var \<Rightarrow> expr \<Rightarrow> 'a \<Rightarrow> 'a"

text \<open>A type class that functions that substitute a variable for another expression in a list.\<close>
class substl = subst +
fixes substl :: "var \<Rightarrow> expr \<Rightarrow> 'a list \<Rightarrow> 'a list"

instantiation expr :: subst
begin
fun subst_expr :: "var \<Rightarrow> expr \<Rightarrow> expr \<Rightarrow> expr" where
"subst_expr v _ Nil = Nil" |
"subst_expr v e (\<acute>x`) = (if v=x then e else \<acute>x`)"
instance ..
end

instantiation pure :: subst
begin
fun subst_pure :: "var \<Rightarrow> expr \<Rightarrow> pure \<Rightarrow> pure" where
"subst_pure v e (e1 =\<^sub>p e2) = (subst v e e1) =\<^sub>p (subst v e e2)" |
"subst_pure v e (e1 \<noteq>\<^sub>p e2) = (subst v e e1) \<noteq>\<^sub>p (subst v e e2)"
instance ..
end

instantiation pure :: substl
begin
fun substl_pure :: "var \<Rightarrow> expr \<Rightarrow> pure_form \<Rightarrow> pure_form" where
"substl_pure v e = map (subst v e)"
instance ..
end

instantiation spatial :: subst
begin
fun subst_spatial :: "var \<Rightarrow> expr \<Rightarrow> spatial \<Rightarrow> spatial" where
"subst_spatial v e (e1 \<longmapsto> e2) = (subst v e e1) \<longmapsto> (subst v e e2)" |
"subst_spatial v e (ls(e1, e2)) = ls((subst v e e1), (subst v e e2))"
instance ..
end

instantiation spatial :: substl
begin
fun substl_spatial :: "var \<Rightarrow> expr \<Rightarrow> spatial_form \<Rightarrow> spatial_form" where
"substl_spatial v e = map (subst v e)"
instance ..
end

instantiation formula :: subst
begin
fun subst_formula :: "var \<Rightarrow> expr \<Rightarrow> formula \<Rightarrow> formula" where
"subst_formula v e (Pure p) = Pure (subst v e p)" |
"subst_formula v e (PureF pf) = PureF (substl v e pf)" |
"subst_formula v e (Spat s) = Spat (subst v e s)" |
"subst_formula v e (SpatF sf) = SpatF (substl v e sf)" |
"subst_formula v e (pf \<bar> sf) = (substl v e pf) \<bar> (substl v e sf)"
instance ..
end

lemma subst_not_free_expr[simp]: "v \<notin> fv (e::expr) \<Longrightarrow> subst v E e = e"
by (induction e) auto

lemma subst_not_eq_expr[simp]: "e\<noteq>\<acute>v` \<Longrightarrow> subst v E e = e"
by (induction e) auto

lemma subst_not_free_pure[simp]: "v \<notin> fv (p::pure) \<Longrightarrow> subst v E p = p"
by (induction p) auto

lemma subst_not_free_spatial[simp]: "v \<notin> fv (s::spatial) \<Longrightarrow> subst v E s = s"
by (induction s) auto

lemma subst_not_free_puref[simp]: "v \<notin> fvl (pf::pure_form) \<Longrightarrow> substl v E pf = pf"
by (auto simp: map_idI)

lemma subst_not_free_spatialf[simp]: "v \<notin> fvl (sf::spatial_form) \<Longrightarrow> substl v E sf = sf"
by (auto simp: map_idI)

lemma subst_not_free_formula[simp]: "x \<notin> fv (F::formula) \<Longrightarrow> subst x E F = F"
proof (induction F)
  case (PureF x)
  then show ?case using subst_not_free_puref by auto
next
  case (SpatF x)
  then show ?case using subst_not_free_spatialf by auto
next
  case (Form x1a x2a)
  then show ?case using subst_not_free_puref subst_not_free_spatialf by auto
qed simp_all

lemma subst_distinct_pure1: "subst x E P = e1=\<^sub>pe2 \<Longrightarrow> \<exists>e3 e4. P = e3=\<^sub>pe4"
using subst_pure.elims by blast

lemma subst_distinct_pure2: "subst x E P = e1\<noteq>\<^sub>pe2 \<Longrightarrow> \<exists>e3 e4. P = e3\<noteq>\<^sub>pe4"
using subst_pure.elims by blast

lemma subst_distinct_puref: "substl x E Pf = P\<and>\<^sub>p\<Pi> \<Longrightarrow> \<exists>P' \<Pi>'. Pf = P'\<and>\<^sub>p\<Pi>'"
  by auto

lemmas subst_distinct_pure = subst_distinct_pure1 subst_distinct_pure2 subst_distinct_puref

lemma subst_distinct_spat1: "subst x E S = e1\<longmapsto>e2 \<Longrightarrow> \<exists>e3 e4. S = e3\<longmapsto>e4"
using subst_spatial.elims by blast

lemma subst_distinct_spat2: "subst x E S = ls(e1,e2) \<Longrightarrow> \<exists>e3 e4. S = ls(e3,e4)"
using subst_spatial.elims by blast

lemma subst_distinct_spatf: "substl x E Sf = S*\<Sigma> \<Longrightarrow> \<exists>S' \<Sigma>'. Sf = S'*\<Sigma>'"
  by auto

lemmas subst_distinct_spat = subst_distinct_spat1 subst_distinct_spat2 subst_distinct_spatf

lemma subst_distinct_formula1: "subst x E F = PureF P \<Longrightarrow> \<exists>P'. F = PureF P'"
using subst_formula.elims by blast

lemma subst_distinct_formula2: "subst x E F = Pure P \<Longrightarrow> \<exists>P'. F = Pure P'"
using subst_formula.elims by blast

lemma subst_distinct_formula3: "subst x E F = SpatF S \<Longrightarrow> \<exists>S'. F = SpatF S'"
using subst_formula.elims by blast

lemma subst_distinct_formula4: "subst x E F = Spat S \<Longrightarrow> \<exists>S'. F = Spat S'"
using subst_formula.elims by blast

lemma subst_distinct_formula5: "subst x E F = \<Pi>\<bar>\<Sigma> \<Longrightarrow> \<exists>\<Pi>' \<Sigma>'. F = \<Pi>'\<bar>\<Sigma>'"
using subst_formula.elims by blast

lemma subst_preserve_True[simp]: "subst x E F = PureF [] \<Longrightarrow> F = PureF []"
using subst_distinct_formula1 by fastforce

lemma subst_preserve_emp[simp]: "subst x E F = SpatF [] \<Longrightarrow> F = SpatF []"
using subst_distinct_formula3 by fastforce

lemmas subst_distinct_formula = subst_distinct_formula1 subst_distinct_formula2
  subst_distinct_formula3 subst_distinct_formula4 subst_distinct_formula5
  subst_preserve_True subst_preserve_emp

lemma subst_reflexive: "\<acute>x`=E \<Longrightarrow> subst x E (e::expr) = e"
using subst_expr.elims by metis

lemma subst_fv_expr: "\<acute>x`\<noteq>E \<Longrightarrow> x \<notin> fv (subst x E (e::expr))"
  by (metis empty_iff expr.exhaust fv_expr.simps(1) fv_expr.simps(2) insert_iff
    subst_expr.simps(2) subst_not_eq_expr)

lemma subst_fv_expr_set: "\<acute>x`\<noteq>E \<Longrightarrow> fv (subst x E (e::expr)) \<supseteq> (fv e - {x})"
  using subst_fv_expr by (metis Diff_cancel Diff_subset fv_expr.simps(2) subst_not_eq_expr)

lemma subst_fv_expr_set_un:
  "\<acute>x`\<noteq>E \<Longrightarrow> fv (subst x E (e1::expr)) \<union> fv (subst x E (e2::expr)) \<supseteq> (fv e1 \<union> fv e2) - {x}"
  using subst_fv_expr_set by auto
end