(*  Title:      HOL/Nominal/Examples/Standardization.thy
    Author:     Stefan Berghofer and Tobias Nipkow
    Copyright   2005, 2008 TU Muenchen
*)

section \<open>Standardization\<close>

theory Standardization
imports "HOL-Nominal.Nominal"
begin

text \<open>
The proof of the standardization theorem, as well as most of the theorems about
lambda calculus in the following sections, are taken from \<open>HOL/Lambda\<close>.
\<close>

subsection \<open>Lambda terms\<close>

atom_decl name

nominal_datatype lam =
  Var "name"
| App "lam" "lam" (infixl "\<degree>" 200)
| Lam "\<guillemotleft>name\<guillemotright>lam" ("Lam [_]._" [0, 10] 10)

instantiation lam :: size
begin

nominal_primrec size_lam
where
  "size (Var n) = 0"
| "size (t \<degree> u) = size t + size u + 1"
| "size (Lam [x].t) = size t + 1"
  apply finite_guess+
  apply (rule TrueI)+
  apply (simp add: fresh_nat)
  apply fresh_guess+
  done

instance ..

end

nominal_primrec
  subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam"  ("_[_::=_]" [300, 0, 0] 300)
where
  subst_Var: "(Var x)[y::=s] = (if x=y then s else (Var x))"
| subst_App: "(t\<^sub>1 \<degree> t\<^sub>2)[y::=s] = t\<^sub>1[y::=s] \<degree> t\<^sub>2[y::=s]"
| subst_Lam: "x \<sharp> (y, s) \<Longrightarrow> (Lam [x].t)[y::=s] = (Lam [x].(t[y::=s]))"
  apply(finite_guess)+
  apply(rule TrueI)+
  apply(simp add: abs_fresh)
  apply(fresh_guess)+
  done

lemma subst_eqvt [eqvt]:
  "(pi::name prm) \<bullet> (t[x::=u]) = (pi \<bullet> t)[(pi \<bullet> x)::=(pi \<bullet> u)]"
  by (nominal_induct t avoiding: x u rule: lam.strong_induct)
    (perm_simp add: fresh_bij)+

lemma subst_rename:
  "y \<sharp> t \<Longrightarrow> ([(y, x)] \<bullet> t)[y::=u] = t[x::=u]"
  by (nominal_induct t avoiding: x y u rule: lam.strong_induct)
    (simp_all add: fresh_atm calc_atm abs_fresh)

lemma fresh_subst:
  "(x::name) \<sharp> t \<Longrightarrow> x \<sharp> u \<Longrightarrow> x \<sharp> t[y::=u]"
  by (nominal_induct t avoiding: x y u rule: lam.strong_induct)
    (auto simp add: abs_fresh fresh_atm)

lemma fresh_subst':
  "(x::name) \<sharp> u \<Longrightarrow> x \<sharp> t[x::=u]"
  by (nominal_induct t avoiding: x u rule: lam.strong_induct)
    (auto simp add: abs_fresh fresh_atm)

lemma subst_forget: "(x::name) \<sharp> t \<Longrightarrow> t[x::=u] = t"
  by (nominal_induct t avoiding: x u rule: lam.strong_induct)
    (auto simp add: abs_fresh fresh_atm)

lemma subst_subst:
  "x \<noteq> y \<Longrightarrow> x \<sharp> v \<Longrightarrow> t[y::=v][x::=u[y::=v]] = t[x::=u][y::=v]"
  by (nominal_induct t avoiding: x y u v rule: lam.strong_induct)
    (auto simp add: fresh_subst subst_forget)

declare subst_Var [simp del]

lemma subst_eq [simp]: "(Var x)[x::=u] = u"
  by (simp add: subst_Var)

lemma subst_neq [simp]: "x \<noteq> y \<Longrightarrow> (Var x)[y::=u] = Var x"
  by (simp add: subst_Var)

inductive beta :: "lam \<Rightarrow> lam \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sub>\<beta>" 50)
  where
    beta: "x \<sharp> t \<Longrightarrow> (Lam [x].s) \<degree> t \<rightarrow>\<^sub>\<beta> s[x::=t]"
  | appL [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> s \<degree> u \<rightarrow>\<^sub>\<beta> t \<degree> u"
  | appR [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> u \<degree> s \<rightarrow>\<^sub>\<beta> u \<degree> t"
  | abs [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> (Lam [x].s) \<rightarrow>\<^sub>\<beta> (Lam [x].t)"

equivariance beta
nominal_inductive beta
  by (simp_all add: abs_fresh fresh_subst')

lemma better_beta [simp, intro!]: "(Lam [x].s) \<degree> t \<rightarrow>\<^sub>\<beta> s[x::=t]"
proof -
  obtain y::name where y: "y \<sharp> (x, s, t)"
    by (rule exists_fresh) (rule fin_supp)
  then have "y \<sharp> t" by simp
  then have "(Lam [y]. [(y, x)] \<bullet> s) \<degree> t \<rightarrow>\<^sub>\<beta> ([(y, x)] \<bullet> s)[y::=t]"
    by (rule beta)
  moreover from y have "(Lam [x].s) = (Lam [y]. [(y, x)] \<bullet> s)"
    by (auto simp add: lam.inject alpha' fresh_prod fresh_atm)
  ultimately show ?thesis using y by (simp add: subst_rename)
qed

abbreviation
  beta_reds :: "lam \<Rightarrow> lam \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sub>\<beta>\<^sup>*" 50) where
  "s \<rightarrow>\<^sub>\<beta>\<^sup>* t \<equiv> beta\<^sup>*\<^sup>* s t"

subsection \<open>Application of a term to a list of terms\<close>

abbreviation
  list_application :: "lam \<Rightarrow> lam list \<Rightarrow> lam"  (infixl "\<degree>\<degree>" 150) where
  "t \<degree>\<degree> ts \<equiv> foldl (\<degree>) t ts"

lemma apps_eq_tail_conv [iff]: "(r \<degree>\<degree> ts = s \<degree>\<degree> ts) = (r = s)"
  by (induct ts rule: rev_induct) (auto simp add: lam.inject)

lemma Var_eq_apps_conv [iff]: "(Var m = s \<degree>\<degree> ss) = (Var m = s \<and> ss = [])"
  by (induct ss arbitrary: s) auto

lemma Var_apps_eq_Var_apps_conv [iff]:
    "(Var m \<degree>\<degree> rs = Var n \<degree>\<degree> ss) = (m = n \<and> rs = ss)"
  apply (induct rs arbitrary: ss rule: rev_induct)
   apply (simp add: lam.inject)
   apply blast
  apply (induct_tac ss rule: rev_induct)
   apply (auto simp add: lam.inject)
  done

lemma App_eq_foldl_conv:
  "(r \<degree> s = t \<degree>\<degree> ts) =
    (if ts = [] then r \<degree> s = t
    else (\<exists>ss. ts = ss @ [s] \<and> r = t \<degree>\<degree> ss))"
  apply (rule_tac xs = ts in rev_exhaust)
   apply (auto simp add: lam.inject)
  done

lemma Abs_eq_apps_conv [iff]:
    "((Lam [x].r) = s \<degree>\<degree> ss) = ((Lam [x].r) = s \<and> ss = [])"
  by (induct ss rule: rev_induct) auto

lemma apps_eq_Abs_conv [iff]: "(s \<degree>\<degree> ss = (Lam [x].r)) = (s = (Lam [x].r) \<and> ss = [])"
  by (induct ss rule: rev_induct) auto

lemma Abs_App_neq_Var_apps [iff]:
    "(Lam [x].s) \<degree> t \<noteq> Var n \<degree>\<degree> ss"
  by (induct ss arbitrary: s t rule: rev_induct) (auto simp add: lam.inject)

lemma Var_apps_neq_Abs_apps [iff]:
    "Var n \<degree>\<degree> ts \<noteq> (Lam [x].r) \<degree>\<degree> ss"
  apply (induct ss arbitrary: ts rule: rev_induct)
   apply simp
  apply (induct_tac ts rule: rev_induct)
   apply (auto simp add: lam.inject)
  done

lemma ex_head_tail:
  "\<exists>ts h. t = h \<degree>\<degree> ts \<and> ((\<exists>n. h = Var n) \<or> (\<exists>x u. h = (Lam [x].u)))"
  apply (induct t rule: lam.induct)
    apply (metis foldl_Nil)
   apply (metis foldl_Cons foldl_Nil foldl_append)
  apply (metis foldl_Nil)
  done

lemma size_apps [simp]:
  "size (r \<degree>\<degree> rs) = size r + foldl (+) 0 (map size rs) + length rs"
  by (induct rs rule: rev_induct) auto

lemma lem0: "(0::nat) < k \<Longrightarrow> m \<le> n \<Longrightarrow> m < n + k"
  by simp

lemma subst_map [simp]:
    "(t \<degree>\<degree> ts)[x::=u] = t[x::=u] \<degree>\<degree> map (\<lambda>t. t[x::=u]) ts"
  by (induct ts arbitrary: t) simp_all

lemma app_last: "(t \<degree>\<degree> ts) \<degree> u = t \<degree>\<degree> (ts @ [u])"
  by simp

lemma perm_apps [eqvt]:
  "(pi::name prm) \<bullet> (t \<degree>\<degree> ts) = ((pi \<bullet> t) \<degree>\<degree> (pi \<bullet> ts))"
  by (induct ts rule: rev_induct) (auto simp add: append_eqvt)

lemma fresh_apps [simp]: "(x::name) \<sharp> (t \<degree>\<degree> ts) = (x \<sharp> t \<and> x \<sharp> ts)"
  by (induct ts rule: rev_induct)
    (auto simp add: fresh_list_append fresh_list_nil fresh_list_cons)

text \<open>A customized induction schema for \<open>\<degree>\<degree>\<close>.\<close>

lemma lem:
  assumes "\<And>n ts (z::'a::fs_name). (\<And>z. \<forall>t \<in> set ts. P z t) \<Longrightarrow> P z (Var n \<degree>\<degree> ts)"
    and "\<And>x u ts z. x \<sharp> z \<Longrightarrow> (\<And>z. P z u) \<Longrightarrow> (\<And>z. \<forall>t \<in> set ts. P z t) \<Longrightarrow> P z ((Lam [x].u) \<degree>\<degree> ts)"
  shows "size t = n \<Longrightarrow> P z t"
  apply (induct n arbitrary: t z rule: nat_less_induct)
  apply (cut_tac t = t in ex_head_tail)
  apply clarify
  apply (erule disjE)
   apply clarify
   apply (rule assms)
   apply clarify
   apply (erule allE, erule impE)
    prefer 2
    apply (erule allE, erule impE, rule refl, erule spec)
    apply simp
    apply (simp only: foldl_conv_fold add.commute fold_plus_sum_list_rev)
    apply (fastforce simp add: sum_list_map_remove1)
  apply clarify
  apply (subgoal_tac "\<exists>y::name. y \<sharp> (x, u, z)")
   prefer 2
   apply (blast intro: exists_fresh' fin_supp)
  apply (erule exE)
  apply (subgoal_tac "(Lam [x].u) = (Lam [y].([(y, x)] \<bullet> u))")
  prefer 2
  apply (auto simp add: lam.inject alpha' fresh_prod fresh_atm)[]
  apply (simp (no_asm_simp))
  apply (rule assms)
  apply (simp add: fresh_prod)
   apply (erule allE, erule impE)
    prefer 2
    apply (erule allE, erule impE, rule refl, erule spec)
   apply simp
  apply clarify
  apply (erule allE, erule impE)
   prefer 2
   apply blast
  apply simp
  apply (simp only: foldl_conv_fold add.commute fold_plus_sum_list_rev)
  apply (fastforce simp add: sum_list_map_remove1)
  done

theorem Apps_lam_induct:
  assumes "\<And>n ts (z::'a::fs_name). (\<And>z. \<forall>t \<in> set ts. P z t) \<Longrightarrow> P z (Var n \<degree>\<degree> ts)"
    and "\<And>x u ts z. x \<sharp> z \<Longrightarrow> (\<And>z. P z u) \<Longrightarrow> (\<And>z. \<forall>t \<in> set ts. P z t) \<Longrightarrow> P z ((Lam [x].u) \<degree>\<degree> ts)"
  shows "P z t"
  apply (rule_tac t = t and z = z in lem)
    prefer 3
    apply (rule refl)
    using assms apply blast+
  done

subsection \<open>Congruence rules\<close>

lemma apps_preserves_beta [simp]:
    "r \<rightarrow>\<^sub>\<beta> s \<Longrightarrow> r \<degree>\<degree> ss \<rightarrow>\<^sub>\<beta> s \<degree>\<degree> ss"
  by (induct ss rule: rev_induct) auto

lemma rtrancl_beta_Abs [intro!]:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<Longrightarrow> (Lam [x].s) \<rightarrow>\<^sub>\<beta>\<^sup>* (Lam [x].s')"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_AppL:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<Longrightarrow> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<degree> t"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_AppR:
    "t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<Longrightarrow> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s \<degree> t'"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_App [intro]:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<Longrightarrow> t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<Longrightarrow> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<degree> t'"
  by (blast intro!: rtrancl_beta_AppL rtrancl_beta_AppR intro: rtranclp_trans)

subsection \<open>Lifting an order to lists of elements\<close>

definition
  step1 :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "step1 r =
    (\<lambda>ys xs. \<exists>us z z' vs. xs = us @ z # vs \<and> r z' z \<and> ys =
      us @ z' # vs)"

lemma not_Nil_step1 [iff]: "\<not> step1 r [] xs"
  apply (unfold step1_def)
  apply blast
  done

lemma not_step1_Nil [iff]: "\<not> step1 r xs []"
  apply (unfold step1_def)
  apply blast
  done

lemma Cons_step1_Cons [iff]:
    "(step1 r (y # ys) (x # xs)) =
      (r y x \<and> xs = ys \<or> x = y \<and> step1 r ys xs)"
  apply (unfold step1_def)
  apply (rule iffI)
   apply (erule exE)
   apply (rename_tac ts)
   apply (case_tac ts)
    apply fastforce
   apply force
  apply (erule disjE)
   apply blast
  apply (blast intro: Cons_eq_appendI)
  done

lemma append_step1I:
  "step1 r ys xs \<and> vs = us \<or> ys = xs \<and> step1 r vs us
    \<Longrightarrow> step1 r (ys @ vs) (xs @ us)"
  apply (unfold step1_def)
  apply auto
   apply blast
  apply (blast intro: append_eq_appendI)
  done

lemma Cons_step1E [elim!]:
  assumes "step1 r ys (x # xs)"
    and "\<And>y. ys = y # xs \<Longrightarrow> r y x \<Longrightarrow> R"
    and "\<And>zs. ys = x # zs \<Longrightarrow> step1 r zs xs \<Longrightarrow> R"
  shows R
  using assms
  apply (cases ys)
   apply (simp add: step1_def)
  apply blast
  done

lemma Snoc_step1_SnocD:
  "step1 r (ys @ [y]) (xs @ [x])
    \<Longrightarrow> (step1 r ys xs \<and> y = x \<or> ys = xs \<and> r y x)"
  apply (unfold step1_def)
  apply (clarify del: disjCI)
  apply (rename_tac vs)
  apply (rule_tac xs = vs in rev_exhaust)
   apply force
  apply simp
  apply blast
  done

subsection \<open>Lifting beta-reduction to lists\<close>

abbreviation
  list_beta :: "lam list \<Rightarrow> lam list \<Rightarrow> bool"  (infixl "[\<rightarrow>\<^sub>\<beta>]\<^sub>1" 50) where
  "rs [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ss \<equiv> step1 beta rs ss"

lemma head_Var_reduction:
  "Var n \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> v \<Longrightarrow> \<exists>ss. rs [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ss \<and> v = Var n \<degree>\<degree> ss"
  apply (induct u \<equiv> "Var n \<degree>\<degree> rs" v arbitrary: rs set: beta)
     apply simp
    apply (rule_tac xs = rs in rev_exhaust)
     apply simp
    apply (atomize, force intro: append_step1I iff: lam.inject)
   apply (rule_tac xs = rs in rev_exhaust)
    apply simp
    apply (auto 0 3 intro: disjI2 [THEN append_step1I] simp add: lam.inject)
  done

lemma apps_betasE [case_names appL appR beta, consumes 1]:
  assumes major: "r \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> s"
    and cases: "\<And>r'. r \<rightarrow>\<^sub>\<beta> r' \<Longrightarrow> s = r' \<degree>\<degree> rs \<Longrightarrow> R"
      "\<And>rs'. rs [\<rightarrow>\<^sub>\<beta>]\<^sub>1 rs' \<Longrightarrow> s = r \<degree>\<degree> rs' \<Longrightarrow> R"
      "\<And>t u us. (x \<sharp> r \<Longrightarrow> r = (Lam [x].t) \<and> rs = u # us \<and> s = t[x::=u] \<degree>\<degree> us) \<Longrightarrow> R"
  shows R
proof -
  from major have
   "(\<exists>r'. r \<rightarrow>\<^sub>\<beta> r' \<and> s = r' \<degree>\<degree> rs) \<or>
    (\<exists>rs'. rs [\<rightarrow>\<^sub>\<beta>]\<^sub>1 rs' \<and> s = r \<degree>\<degree> rs') \<or>
    (\<exists>t u us. x \<sharp> r \<longrightarrow> r = (Lam [x].t) \<and> rs = u # us \<and> s = t[x::=u] \<degree>\<degree> us)"
    supply [[simproc del: defined_all]]
    apply (nominal_induct u \<equiv> "r \<degree>\<degree> rs" s avoiding: x r rs rule: beta.strong_induct)
    apply (simp add: App_eq_foldl_conv)
    apply (split if_split_asm)
    apply simp
    apply blast
    apply simp
    apply (rule impI)+
    apply (rule disjI2)
    apply (rule disjI2)
    apply (subgoal_tac "r = [(xa, x)] \<bullet> (Lam [x].s)")
    prefer 2
    apply (simp add: perm_fresh_fresh)
    apply (drule conjunct1)
    apply (subgoal_tac "r = (Lam [xa]. [(xa, x)] \<bullet> s)")
    prefer 2
    apply (simp add: calc_atm)
    apply (thin_tac "r = _")
    apply simp
    apply (rule exI)
    apply (rule conjI)
    apply (rule refl)
    apply (simp add: abs_fresh fresh_atm fresh_left calc_atm subst_rename)
      apply (drule App_eq_foldl_conv [THEN iffD1])
      apply (split if_split_asm)
       apply simp
       apply blast
      apply (force intro!: disjI1 [THEN append_step1I] simp add: fresh_list_append)
     apply (drule App_eq_foldl_conv [THEN iffD1])
     apply (split if_split_asm)
      apply simp
      apply blast
     apply (clarify, auto 0 3 intro!: exI intro: append_step1I)
    done
  with cases show ?thesis by blast
qed

lemma apps_preserves_betas [simp]:
    "rs [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ss \<Longrightarrow> r \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> r \<degree>\<degree> ss"
  apply (induct rs arbitrary: ss rule: rev_induct)
   apply simp
  apply simp
  apply (rule_tac xs = ss in rev_exhaust)
   apply simp
  apply simp
  apply (drule Snoc_step1_SnocD)
  apply blast
  done

subsection \<open>Standard reduction relation\<close>

text \<open>
Based on lecture notes by Ralph Matthes,
original proof idea due to Ralph Loader.
\<close>

declare listrel_mono [mono_set]

lemma listrelp_eqvt [eqvt]:
  fixes f :: "'a::pt_name \<Rightarrow> 'b::pt_name \<Rightarrow> bool"
  assumes xy: "listrelp f (x::'a::pt_name list) y"
  shows "listrelp ((pi::name prm) \<bullet> f) (pi \<bullet> x) (pi \<bullet> y)" using xy
  by induct (simp_all add: listrelp.intros perm_app [symmetric])

inductive
  sred :: "lam \<Rightarrow> lam \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sub>s" 50)
  and sredlist :: "lam list \<Rightarrow> lam list \<Rightarrow> bool"  (infixl "[\<rightarrow>\<^sub>s]" 50)
where
  "s [\<rightarrow>\<^sub>s] t \<equiv> listrelp (\<rightarrow>\<^sub>s) s t"
| Var: "rs [\<rightarrow>\<^sub>s] rs' \<Longrightarrow> Var x \<degree>\<degree> rs \<rightarrow>\<^sub>s Var x \<degree>\<degree> rs'"
| Abs: "x \<sharp> (ss, ss') \<Longrightarrow> r \<rightarrow>\<^sub>s r' \<Longrightarrow> ss [\<rightarrow>\<^sub>s] ss' \<Longrightarrow> (Lam [x].r) \<degree>\<degree> ss \<rightarrow>\<^sub>s (Lam [x].r') \<degree>\<degree> ss'"
| Beta: "x \<sharp> (s, ss, t) \<Longrightarrow> r[x::=s] \<degree>\<degree> ss \<rightarrow>\<^sub>s t \<Longrightarrow> (Lam [x].r) \<degree> s \<degree>\<degree> ss \<rightarrow>\<^sub>s t"

equivariance sred
nominal_inductive sred
  by (simp add: abs_fresh)+

lemma better_sred_Abs:
  assumes H1: "r \<rightarrow>\<^sub>s r'"
  and H2: "ss [\<rightarrow>\<^sub>s] ss'"
  shows "(Lam [x].r) \<degree>\<degree> ss \<rightarrow>\<^sub>s (Lam [x].r') \<degree>\<degree> ss'"
proof -
  obtain y::name where y: "y \<sharp> (x, r, r', ss, ss')"
    by (rule exists_fresh) (rule fin_supp)
  then have "y \<sharp> (ss, ss')" by simp
  moreover from H1 have "[(y, x)] \<bullet> (r \<rightarrow>\<^sub>s r')" by (rule perm_boolI)
  then have "([(y, x)] \<bullet> r) \<rightarrow>\<^sub>s ([(y, x)] \<bullet> r')" by (simp add: eqvts)
  ultimately have "(Lam [y]. [(y, x)] \<bullet> r) \<degree>\<degree> ss \<rightarrow>\<^sub>s (Lam [y]. [(y, x)] \<bullet> r') \<degree>\<degree> ss'" using H2
    by (rule sred.Abs)
  moreover from y have "(Lam [x].r) = (Lam [y]. [(y, x)] \<bullet> r)"
    by (auto simp add: lam.inject alpha' fresh_prod fresh_atm)
  moreover from y have "(Lam [x].r') = (Lam [y]. [(y, x)] \<bullet> r')"
    by (auto simp add: lam.inject alpha' fresh_prod fresh_atm)
  ultimately show ?thesis by simp
qed

lemma better_sred_Beta:
  assumes H: "r[x::=s] \<degree>\<degree> ss \<rightarrow>\<^sub>s t"
  shows "(Lam [x].r) \<degree> s \<degree>\<degree> ss \<rightarrow>\<^sub>s t"
proof -
  obtain y::name where y: "y \<sharp> (x, r, s, ss, t)"
    by (rule exists_fresh) (rule fin_supp)
  then have "y \<sharp> (s, ss, t)" by simp
  moreover from y H have "([(y, x)] \<bullet> r)[y::=s] \<degree>\<degree> ss \<rightarrow>\<^sub>s t"
    by (simp add: subst_rename)
  ultimately have "(Lam [y].[(y, x)] \<bullet> r) \<degree> s \<degree>\<degree> ss \<rightarrow>\<^sub>s t"
    by (rule sred.Beta)
  moreover from y have "(Lam [x].r) = (Lam [y]. [(y, x)] \<bullet> r)"
    by (auto simp add: lam.inject alpha' fresh_prod fresh_atm)
  ultimately show ?thesis by simp
qed

lemmas better_sred_intros = sred.Var better_sred_Abs better_sred_Beta

lemma refl_listrelp: "\<forall>x\<in>set xs. R x x \<Longrightarrow> listrelp R xs xs"
  by (induct xs) (auto intro: listrelp.intros)

lemma refl_sred: "t \<rightarrow>\<^sub>s t"
  by (nominal_induct t rule: Apps_lam_induct) (auto intro: refl_listrelp better_sred_intros)

lemma listrelp_conj1: "listrelp (\<lambda>x y. R x y \<and> S x y) x y \<Longrightarrow> listrelp R x y"
  by (erule listrelp.induct) (auto intro: listrelp.intros)

lemma listrelp_conj2: "listrelp (\<lambda>x y. R x y \<and> S x y) x y \<Longrightarrow> listrelp S x y"
  by (erule listrelp.induct) (auto intro: listrelp.intros)

lemma listrelp_app:
  assumes xsys: "listrelp R xs ys"
  shows "listrelp R xs' ys' \<Longrightarrow> listrelp R (xs @ xs') (ys @ ys')" using xsys
  by (induct arbitrary: xs' ys') (auto intro: listrelp.intros)

lemma lemma1:
  assumes r: "r \<rightarrow>\<^sub>s r'" and s: "s \<rightarrow>\<^sub>s s'"
  shows "r \<degree> s \<rightarrow>\<^sub>s r' \<degree> s'" using r
proof induct
  case (Var rs rs' x)
  then have "rs [\<rightarrow>\<^sub>s] rs'" by (rule listrelp_conj1)
  moreover have "[s] [\<rightarrow>\<^sub>s] [s']" by (iprover intro: s listrelp.intros)
  ultimately have "rs @ [s] [\<rightarrow>\<^sub>s] rs' @ [s']" by (rule listrelp_app)
  hence "Var x \<degree>\<degree> (rs @ [s]) \<rightarrow>\<^sub>s Var x \<degree>\<degree> (rs' @ [s'])" by (rule sred.Var)
  thus ?case by (simp only: app_last)
next
  case (Abs x ss ss' r r')
  from Abs(4) have "ss [\<rightarrow>\<^sub>s] ss'" by (rule listrelp_conj1)
  moreover have "[s] [\<rightarrow>\<^sub>s] [s']" by (iprover intro: s listrelp.intros)
  ultimately have "ss @ [s] [\<rightarrow>\<^sub>s] ss' @ [s']" by (rule listrelp_app)
  with \<open>r \<rightarrow>\<^sub>s r'\<close> have "(Lam [x].r) \<degree>\<degree> (ss @ [s]) \<rightarrow>\<^sub>s (Lam [x].r') \<degree>\<degree> (ss' @ [s'])"
    by (rule better_sred_Abs)
  thus ?case by (simp only: app_last)
next
  case (Beta x u ss t r)
  hence "r[x::=u] \<degree>\<degree> (ss @ [s]) \<rightarrow>\<^sub>s t \<degree> s'" by (simp only: app_last)
  hence "(Lam [x].r) \<degree> u \<degree>\<degree> (ss @ [s]) \<rightarrow>\<^sub>s t \<degree> s'" by (rule better_sred_Beta)
  thus ?case by (simp only: app_last)
qed

lemma lemma1':
  assumes ts: "ts [\<rightarrow>\<^sub>s] ts'"
  shows "r \<rightarrow>\<^sub>s r' \<Longrightarrow> r \<degree>\<degree> ts \<rightarrow>\<^sub>s r' \<degree>\<degree> ts'" using ts
  by (induct arbitrary: r r') (auto intro: lemma1)

lemma listrelp_betas:
  assumes ts: "listrelp (\<rightarrow>\<^sub>\<beta>\<^sup>*) ts ts'"
  shows "\<And>t t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<Longrightarrow> t \<degree>\<degree> ts \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<degree>\<degree> ts'" using ts
  by induct auto

lemma lemma2:
  assumes t: "t \<rightarrow>\<^sub>s u"
  shows "t \<rightarrow>\<^sub>\<beta>\<^sup>* u" using t
  by induct (auto dest: listrelp_conj2
    intro: listrelp_betas apps_preserves_beta converse_rtranclp_into_rtranclp)

lemma lemma3:
  assumes r: "r \<rightarrow>\<^sub>s r'"
  shows "s \<rightarrow>\<^sub>s s' \<Longrightarrow> r[x::=s] \<rightarrow>\<^sub>s r'[x::=s']" using r
proof (nominal_induct avoiding: x s s' rule: sred.strong_induct)
  case (Var rs rs' y)
  hence "map (\<lambda>t. t[x::=s]) rs [\<rightarrow>\<^sub>s] map (\<lambda>t. t[x::=s']) rs'"
    by induct (auto intro: listrelp.intros Var)
  moreover have "Var y[x::=s] \<rightarrow>\<^sub>s Var y[x::=s']"
    by (cases "y = x") (auto simp add: Var intro: refl_sred)
  ultimately show ?case by simp (rule lemma1')
next
  case (Abs y ss ss' r r')
  then have "r[x::=s] \<rightarrow>\<^sub>s r'[x::=s']" by fast
  moreover from Abs(8) \<open>s \<rightarrow>\<^sub>s s'\<close> have "map (\<lambda>t. t[x::=s]) ss [\<rightarrow>\<^sub>s] map (\<lambda>t. t[x::=s']) ss'"
    by induct (auto intro: listrelp.intros Abs)
  ultimately show ?case using Abs(6) \<open>y \<sharp> x\<close> \<open>y \<sharp> s\<close> \<open>y \<sharp> s'\<close>
    by simp (rule better_sred_Abs)
next
  case (Beta y u ss t r)
  thus ?case by (auto simp add: subst_subst fresh_atm intro: better_sred_Beta)
qed

lemma lemma4_aux:
  assumes rs: "listrelp (\<lambda>t u. t \<rightarrow>\<^sub>s u \<and> (\<forall>r. u \<rightarrow>\<^sub>\<beta> r \<longrightarrow> t \<rightarrow>\<^sub>s r)) rs rs'"
  shows "rs' [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ss \<Longrightarrow> rs [\<rightarrow>\<^sub>s] ss" using rs
proof (induct arbitrary: ss)
  case Nil
  thus ?case by cases (auto intro: listrelp.Nil)
next
  case (Cons x y xs ys)
  note Cons' = Cons
  show ?case
  proof (cases ss)
    case Nil with Cons show ?thesis by simp
  next
    case (Cons y' ys')
    hence ss: "ss = y' # ys'" by simp
    from Cons Cons' have "y \<rightarrow>\<^sub>\<beta> y' \<and> ys' = ys \<or> y' = y \<and> ys [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ys'" by simp
    hence "x # xs [\<rightarrow>\<^sub>s] y' # ys'"
    proof
      assume H: "y \<rightarrow>\<^sub>\<beta> y' \<and> ys' = ys"
      with Cons' have "x \<rightarrow>\<^sub>s y'" by blast
      moreover from Cons' have "xs [\<rightarrow>\<^sub>s] ys" by (iprover dest: listrelp_conj1)
      ultimately have "x # xs [\<rightarrow>\<^sub>s] y' # ys" by (rule listrelp.Cons)
      with H show ?thesis by simp
    next
      assume H: "y' = y \<and> ys [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ys'"
      with Cons' have "x \<rightarrow>\<^sub>s y'" by blast
      moreover from H have "xs [\<rightarrow>\<^sub>s] ys'" by (blast intro: Cons')
      ultimately show ?thesis by (rule listrelp.Cons)
    qed
    with ss show ?thesis by simp
  qed
qed

lemma lemma4:
  assumes r: "r \<rightarrow>\<^sub>s r'"
  shows "r' \<rightarrow>\<^sub>\<beta> r'' \<Longrightarrow> r \<rightarrow>\<^sub>s r''" using r
proof (nominal_induct avoiding: r'' rule: sred.strong_induct)
  case (Var rs rs' x)
  then obtain ss where rs: "rs' [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ss" and r'': "r'' = Var x \<degree>\<degree> ss"
    by (blast dest: head_Var_reduction)
  from Var(1) [simplified] rs have "rs [\<rightarrow>\<^sub>s] ss" by (rule lemma4_aux)
  hence "Var x \<degree>\<degree> rs \<rightarrow>\<^sub>s Var x \<degree>\<degree> ss" by (rule sred.Var)
  with r'' show ?case by simp
next
  case (Abs x ss ss' r r')
  from \<open>(Lam [x].r') \<degree>\<degree> ss' \<rightarrow>\<^sub>\<beta> r''\<close> show ?case
  proof (cases rule: apps_betasE [where x=x])
    case (appL s)
    then obtain r''' where s: "s = (Lam [x].r''')" and r''': "r' \<rightarrow>\<^sub>\<beta> r'''" using \<open>x \<sharp> r''\<close>
      by (cases rule: beta.strong_cases) (auto simp add: abs_fresh lam.inject alpha)
    from r''' have "r \<rightarrow>\<^sub>s r'''" by (blast intro: Abs)
    moreover from Abs have "ss [\<rightarrow>\<^sub>s] ss'" by (iprover dest: listrelp_conj1)
    ultimately have "(Lam [x].r) \<degree>\<degree> ss \<rightarrow>\<^sub>s (Lam [x].r''') \<degree>\<degree> ss'" by (rule better_sred_Abs)
    with appL s show "(Lam [x].r) \<degree>\<degree> ss \<rightarrow>\<^sub>s r''" by simp
  next
    case (appR rs')
    from Abs(6) [simplified] \<open>ss' [\<rightarrow>\<^sub>\<beta>]\<^sub>1 rs'\<close>
    have "ss [\<rightarrow>\<^sub>s] rs'" by (rule lemma4_aux)
    with \<open>r \<rightarrow>\<^sub>s r'\<close> have "(Lam [x].r) \<degree>\<degree> ss \<rightarrow>\<^sub>s (Lam [x].r') \<degree>\<degree> rs'" by (rule better_sred_Abs)
    with appR show "(Lam [x].r) \<degree>\<degree> ss \<rightarrow>\<^sub>s r''" by simp
  next
    case (beta t u' us')
    then have Lam_eq: "(Lam [x].r') = (Lam [x].t)" and ss': "ss' = u' # us'"
      and r'': "r'' = t[x::=u'] \<degree>\<degree> us'"
      by (simp_all add: abs_fresh)
    from Abs(6) ss' obtain u us where
      ss: "ss = u # us" and u: "u \<rightarrow>\<^sub>s u'" and us: "us [\<rightarrow>\<^sub>s] us'"
      by cases (auto dest!: listrelp_conj1)
    have "r[x::=u] \<rightarrow>\<^sub>s r'[x::=u']" using \<open>r \<rightarrow>\<^sub>s r'\<close> and u by (rule lemma3)
    with us have "r[x::=u] \<degree>\<degree> us \<rightarrow>\<^sub>s r'[x::=u'] \<degree>\<degree> us'" by (rule lemma1')
    hence "(Lam [x].r) \<degree> u \<degree>\<degree> us \<rightarrow>\<^sub>s r'[x::=u'] \<degree>\<degree> us'" by (rule better_sred_Beta)
    with ss r'' Lam_eq show "(Lam [x].r) \<degree>\<degree> ss \<rightarrow>\<^sub>s r''" by (simp add: lam.inject alpha)
  qed
next
  case (Beta x s ss t r)
  show ?case
    by (rule better_sred_Beta) (rule Beta)+
qed

lemma rtrancl_beta_sred:
  assumes r: "r \<rightarrow>\<^sub>\<beta>\<^sup>* r'"
  shows "r \<rightarrow>\<^sub>s r'" using r
  by induct (iprover intro: refl_sred lemma4)+

subsection \<open>Terms in normal form\<close>

lemma listsp_eqvt [eqvt]:
  assumes xs: "listsp p (xs::'a::pt_name list)"
  shows "listsp ((pi::name prm) \<bullet> p) (pi \<bullet> xs)" using xs
  apply induct
  apply simp
  apply simp
  apply (rule listsp.intros)
  apply (drule_tac pi=pi in perm_boolI)
  apply perm_simp
  apply assumption
  done

inductive NF :: "lam \<Rightarrow> bool"
where
  App: "listsp NF ts \<Longrightarrow> NF (Var x \<degree>\<degree> ts)"
| Abs: "NF t \<Longrightarrow> NF (Lam [x].t)"

equivariance NF
nominal_inductive NF
  by (simp add: abs_fresh)

lemma Abs_NF:
  assumes NF: "NF ((Lam [x].t) \<degree>\<degree> ts)"
  shows "ts = []" using NF
proof cases
  case (App us i)
  thus ?thesis by (simp add: Var_apps_neq_Abs_apps [THEN not_sym])
next
  case (Abs u)
  thus ?thesis by simp
qed

text \<open>
\<^term>\<open>NF\<close> characterizes exactly the terms that are in normal form.
\<close>

lemma NF_eq: "NF t = (\<forall>t'. \<not> t \<rightarrow>\<^sub>\<beta> t')"
proof
  assume H: "NF t"
  show "\<forall>t'. \<not> t \<rightarrow>\<^sub>\<beta> t'"
  proof
    fix t'
    from H show "\<not> t \<rightarrow>\<^sub>\<beta> t'"
    proof (nominal_induct avoiding: t' rule: NF.strong_induct)
      case (App ts t)
      show ?case
      proof
        assume "Var t \<degree>\<degree> ts \<rightarrow>\<^sub>\<beta> t'"
        then obtain rs where "ts [\<rightarrow>\<^sub>\<beta>]\<^sub>1 rs"
          by (iprover dest: head_Var_reduction)
        with App show False
          by (induct rs arbitrary: ts) (auto del: in_listspD)
      qed
    next
      case (Abs t x)
      show ?case
      proof
        assume "(Lam [x].t) \<rightarrow>\<^sub>\<beta> t'"
        then show False using Abs
          by (cases rule: beta.strong_cases) (auto simp add: abs_fresh lam.inject alpha)
      qed
    qed
  qed
next
  assume H: "\<forall>t'. \<not> t \<rightarrow>\<^sub>\<beta> t'"
  then show "NF t"
  proof (nominal_induct t rule: Apps_lam_induct)
    case (1 n ts)
    then have "\<forall>ts'. \<not> ts [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ts'"
      by (iprover intro: apps_preserves_betas)
    with 1(1) have "listsp NF ts"
      by (induct ts) (auto simp add: in_listsp_conv_set)
    then show ?case by (rule NF.App)
  next
    case (2 x u ts)
    show ?case
    proof (cases ts)
      case Nil thus ?thesis by (metis 2 NF.Abs abs foldl_Nil)
    next
      case (Cons r rs)
      have "(Lam [x].u) \<degree> r \<rightarrow>\<^sub>\<beta> u[x::=r]" ..
      then have "(Lam [x].u) \<degree> r \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> u[x::=r] \<degree>\<degree> rs"
        by (rule apps_preserves_beta)
      with Cons have "(Lam [x].u) \<degree>\<degree> ts \<rightarrow>\<^sub>\<beta> u[x::=r] \<degree>\<degree> rs"
        by simp
      with 2 show ?thesis by iprover
    qed
  qed
qed

subsection \<open>Leftmost reduction and weakly normalizing terms\<close>

inductive
  lred :: "lam \<Rightarrow> lam \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sub>l" 50)
  and lredlist :: "lam list \<Rightarrow> lam list \<Rightarrow> bool"  (infixl "[\<rightarrow>\<^sub>l]" 50)
where
  "s [\<rightarrow>\<^sub>l] t \<equiv> listrelp (\<rightarrow>\<^sub>l) s t"
| Var: "rs [\<rightarrow>\<^sub>l] rs' \<Longrightarrow> Var x \<degree>\<degree> rs \<rightarrow>\<^sub>l Var x \<degree>\<degree> rs'"
| Abs: "r \<rightarrow>\<^sub>l r' \<Longrightarrow> (Lam [x].r) \<rightarrow>\<^sub>l (Lam [x].r')"
| Beta: "r[x::=s] \<degree>\<degree> ss \<rightarrow>\<^sub>l t \<Longrightarrow> (Lam [x].r) \<degree> s \<degree>\<degree> ss \<rightarrow>\<^sub>l t"

lemma lred_imp_sred:
  assumes lred: "s \<rightarrow>\<^sub>l t"
  shows "s \<rightarrow>\<^sub>s t" using lred
proof induct
  case (Var rs rs' x)
  then have "rs [\<rightarrow>\<^sub>s] rs'"
    by induct (iprover intro: listrelp.intros)+
  then show ?case by (rule sred.Var)
next
  case (Abs r r' x)
  from \<open>r \<rightarrow>\<^sub>s r'\<close>
  have "(Lam [x].r) \<degree>\<degree> [] \<rightarrow>\<^sub>s (Lam [x].r') \<degree>\<degree> []" using listrelp.Nil
    by (rule better_sred_Abs)
  then show ?case by simp
next
  case (Beta r x s ss t)
  from \<open>r[x::=s] \<degree>\<degree> ss \<rightarrow>\<^sub>s t\<close>
  show ?case by (rule better_sred_Beta)
qed

inductive WN :: "lam \<Rightarrow> bool"
  where
    Var: "listsp WN rs \<Longrightarrow> WN (Var n \<degree>\<degree> rs)"
  | Lambda: "WN r \<Longrightarrow> WN (Lam [x].r)"
  | Beta: "WN ((r[x::=s]) \<degree>\<degree> ss) \<Longrightarrow> WN (((Lam [x].r) \<degree> s) \<degree>\<degree> ss)"

lemma listrelp_imp_listsp1:
  assumes H: "listrelp (\<lambda>x y. P x) xs ys"
  shows "listsp P xs" using H
  by induct auto

lemma listrelp_imp_listsp2:
  assumes H: "listrelp (\<lambda>x y. P y) xs ys"
  shows "listsp P ys" using H
  by induct auto

lemma lemma5:
  assumes lred: "r \<rightarrow>\<^sub>l r'"
  shows "WN r" and "NF r'" using lred
  by induct
    (iprover dest: listrelp_conj1 listrelp_conj2
     listrelp_imp_listsp1 listrelp_imp_listsp2 intro: WN.intros
     NF.intros)+

lemma lemma6:
  assumes wn: "WN r"
  shows "\<exists>r'. r \<rightarrow>\<^sub>l r'" using wn
proof induct
  case (Var rs n)
  then have "\<exists>rs'. rs [\<rightarrow>\<^sub>l] rs'"
    by induct (iprover intro: listrelp.intros)+
  then show ?case by (iprover intro: lred.Var)
qed (iprover intro: lred.intros)+

lemma lemma7:
  assumes r: "r \<rightarrow>\<^sub>s r'"
  shows "NF r' \<Longrightarrow> r \<rightarrow>\<^sub>l r'" using r
proof induct
  case (Var rs rs' x)
  from \<open>NF (Var x \<degree>\<degree> rs')\<close> have "listsp NF rs'"
    by cases simp_all
  with Var(1) have "rs [\<rightarrow>\<^sub>l] rs'"
  proof induct
    case Nil
    show ?case by (rule listrelp.Nil)
  next
    case (Cons x y xs ys)
    hence "x \<rightarrow>\<^sub>l y" and "xs [\<rightarrow>\<^sub>l] ys" by (auto del: in_listspD)
    thus ?case by (rule listrelp.Cons)
  qed
  thus ?case by (rule lred.Var)
next
  case (Abs x ss ss' r r')
  from \<open>NF ((Lam [x].r') \<degree>\<degree> ss')\<close>
  have ss': "ss' = []" by (rule Abs_NF)
  from Abs(4) have ss: "ss = []" using ss'
    by cases simp_all
  from ss' Abs have "NF (Lam [x].r')" by simp
  hence "NF r'" by (cases rule: NF.strong_cases) (auto simp add: abs_fresh lam.inject alpha)
  with Abs have "r \<rightarrow>\<^sub>l r'" by simp
  hence "(Lam [x].r) \<rightarrow>\<^sub>l (Lam [x].r')" by (rule lred.Abs)
  with ss ss' show ?case by simp
next
  case (Beta x s ss t r)
  hence "r[x::=s] \<degree>\<degree> ss \<rightarrow>\<^sub>l t" by simp
  thus ?case by (rule lred.Beta)
qed

lemma WN_eq: "WN t = (\<exists>t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t')"
proof
  assume "WN t"
  then have "\<exists>t'. t \<rightarrow>\<^sub>l t'" by (rule lemma6)
  then obtain t' where t': "t \<rightarrow>\<^sub>l t'" ..
  then have NF: "NF t'" by (rule lemma5)
  from t' have "t \<rightarrow>\<^sub>s t'" by (rule lred_imp_sred)
  then have "t \<rightarrow>\<^sub>\<beta>\<^sup>* t'" by (rule lemma2)
  with NF show "\<exists>t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'" by iprover
next
  assume "\<exists>t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'"
  then obtain t' where t': "t \<rightarrow>\<^sub>\<beta>\<^sup>* t'" and NF: "NF t'"
    by iprover
  from t' have "t \<rightarrow>\<^sub>s t'" by (rule rtrancl_beta_sred)
  then have "t \<rightarrow>\<^sub>l t'" using NF by (rule lemma7)
  then show "WN t" by (rule lemma5)
qed

end


(*  Title:       Tarski's geometry
    Author:      Tim Makarios <tjm1983 at gmail.com>, 2012
    Maintainer:  Tim Makarios <tjm1983 at gmail.com>
*)

header "Tarski's geometry"

theory Tarski
  imports Complex_Main Miscellany Metric
begin

subsection "The axioms"
text {* The axioms, and all theorems beginning with \emph{th}
  followed by a number, are based on corresponding axioms and
  theorems in \cite{schwabhauser}. *}

locale tarski_first3 =
  fixes C :: "'p \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> bool"     ("_ _ \<congruent> _ _" [99,99,99,99] 50)
  assumes A1: "\<forall>a b. a b \<congruent> b a"
  and A2: "\<forall>a b p q r s. a b \<congruent> p q \<and> a b \<congruent> r s \<longrightarrow> p q \<congruent> r s"
  and A3: "\<forall>a b c. a b \<congruent> c c \<longrightarrow> a = b"

locale tarski_first5 = tarski_first3 +
  fixes B :: "'p \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> bool"
  assumes A4: "\<forall>q a b c. \<exists>x. B q a x \<and> a x \<congruent> b c"
  and A5: "\<forall>a b c d a' b' c' d'. a \<noteq> b \<and> B a b c \<and> B a' b' c'
                                               \<and> a b \<congruent> a' b' \<and> b c \<congruent> b' c' \<and> a d \<congruent> a' d' \<and> b d \<congruent> b' d'
                                       \<longrightarrow> c d \<congruent> c' d'"

locale tarski_absolute_space = tarski_first5 +
  assumes A6: "\<forall>a b. B a b a \<longrightarrow> a = b"
  and A7: "\<forall>a b c p q. B a p c \<and> B b q c \<longrightarrow> (\<exists>x. B p x b \<and> B q x a)"
  and A11: "\<forall>X Y. (\<exists>a. \<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B a x y)
                        \<longrightarrow> (\<exists>b. \<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B x b y)"

locale tarski_absolute = tarski_absolute_space +
  assumes A8: "\<exists>a b c. \<not> B a b c \<and> \<not> B b c a \<and> \<not> B c a b"
  and A9: "\<forall>p q a b c. p \<noteq> q \<and> a p \<congruent> a q \<and> b p \<congruent> b q \<and> c p \<congruent> c q
                             \<longrightarrow> B a b c \<or> B b c a \<or> B c a b"

locale tarski_space = tarski_absolute_space +
  assumes A10: "\<forall>a b c d t. B a d t \<and> B b d c \<and> a \<noteq> d
                                    \<longrightarrow> (\<exists>x y. B a b x \<and> B a c y \<and> B x t y)"

locale tarski = tarski_absolute + tarski_space

subsection "Semimetric spaces satisfy the first three axioms"

context semimetric
begin
  definition smC :: "'p \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> bool" ("_ _ \<congruent>\<^sub>s\<^sub>m _ _" [99,99,99,99] 50)
    where [simp]: "a b \<congruent>\<^sub>s\<^sub>m c d \<equiv> dist a b = dist c d"
end

sublocale semimetric < tarski_first3 smC
proof
  from symm show "\<forall>a b. a b \<congruent>\<^sub>s\<^sub>m b a" by simp
  show "\<forall>a b p q r s. a b \<congruent>\<^sub>s\<^sub>m p q \<and> a b \<congruent>\<^sub>s\<^sub>m r s \<longrightarrow> p q \<congruent>\<^sub>s\<^sub>m r s" by simp
  show "\<forall>a b c. a b \<congruent>\<^sub>s\<^sub>m c c \<longrightarrow> a = b" by simp
qed

subsection "Some consequences of the first three axioms"

context tarski_first3
begin
  notation %invisible C ("_ _ \<equiv> _ _" [99,99,99,99] 50)
  lemma A1': "a b \<congruent> b a"
    by (simp add: A1)

  lemma A2': "\<lbrakk>a b \<congruent> p q; a b \<congruent> r s\<rbrakk> \<Longrightarrow> p q \<congruent> r s"
  proof -
    assume "a b \<congruent> p q" and "a b \<congruent> r s"
    with A2 show ?thesis by blast
  qed

  lemma A3': "a b \<congruent> c c \<Longrightarrow> a = b"
    by (simp add: A3)

  theorem th2_1: "a b \<congruent> a b"
  proof -
    from A2' [of b a a b a b] and A1' [of b a] show ?thesis by simp
  qed

  theorem th2_2: "a b \<congruent> c d \<Longrightarrow> c d \<congruent> a b"
  proof -
    assume "a b \<congruent> c d"
    with A2' [of a b c d a b] and th2_1 [of a b] show ?thesis by simp
  qed

  theorem th2_3: "\<lbrakk>a b \<congruent> c d; c d \<congruent> e f\<rbrakk> \<Longrightarrow> a b \<congruent> e f"
  proof -
    assume "a b \<congruent> c d"
    with th2_2 [of a b c d] have "c d \<congruent> a b" by simp
    assume "c d \<congruent> e f"
    with A2' [of c d a b e f] and `c d \<congruent> a b` show ?thesis by simp
  qed

  theorem th2_4: "a b \<congruent> c d \<Longrightarrow> b a \<congruent> c d"
  proof -
    assume "a b \<congruent> c d"
    with th2_3 [of b a a b c d] and A1' [of b a] show ?thesis by simp
  qed

  definition is_segment :: "'p set \<Rightarrow> bool" where
  "is_segment X \<equiv> \<exists>x y. X = {x, y}"

  definition segments :: "'p set set" where
  "segments = {X. is_segment X}"

  definition SC :: "'p set \<Rightarrow> 'p set \<Rightarrow> bool" where
  "SC X Y \<equiv> \<exists>w x y z. X = {w, x} \<and> Y = {y, z} \<and> w x \<congruent> y z"

  definition SC_rel :: "('p set \<times> 'p set) set" where
  "SC_rel = {(X, Y) | X Y. SC X Y}"

  lemma left_segment_congruence:
    assumes "{a, b} = {p, q}" and "p q \<congruent> c d"
    shows "a b \<congruent> c d"
  proof cases
    assume "a = p"
    with unordered_pair_element_equality [of a b p q] and `{a, b} = {p, q}`
      have "b = q" by simp
    with `p q \<congruent> c d` and `a = p` show ?thesis by simp
  next
    assume "a \<noteq> p"
    with `{a, b} = {p, q}` have "a = q" by auto
    with unordered_pair_element_equality [of a b q p] and `{a, b} = {p, q}`
      have "b = p" by auto
    with `p q \<congruent> c d` and `a = q` have "b a \<congruent> c d" by simp
    with th2_4 [of b a c d] show ?thesis by simp
  qed

  lemma right_segment_congruence:
    assumes "{c, d} = {p, q}" and "a b \<congruent> p q"
    shows "a b \<congruent> c d"
  proof -
    from th2_2 [of a b p q] and `a b \<congruent> p q` have "p q \<congruent> a b" by simp
    with left_segment_congruence [of c d p q a b] and `{c, d} = {p, q}`
      have "c d \<congruent> a b" by simp
    with th2_2 [of c d a b] show ?thesis by simp
  qed

  lemma C_SC_equiv: "a b \<congruent> c d = SC {a, b} {c, d}"
  proof
    assume "a b \<congruent> c d"
    with SC_def [of "{a, b}" "{c, d}"] show "SC {a, b} {c, d}" by auto
  next
    assume "SC {a, b} {c, d}"
    with SC_def [of "{a, b}" "{c, d}"]
      obtain w x y z where "{a, b} = {w, x}" and "{c, d} = {y, z}" and "w x \<congruent> y z"
        by blast
    from left_segment_congruence [of a b w x y z] and
        `{a, b} = {w, x}` and
        `w x \<congruent> y z`
      have "a b \<congruent> y z" by simp
    with right_segment_congruence [of c d y z a b] and `{c, d} = {y, z}`
      show "a b \<congruent> c d" by simp
  qed

  lemmas SC_refl = th2_1 [simplified]

  lemma SC_rel_refl: "refl_on segments SC_rel"
  proof -
    note refl_on_def [of segments SC_rel]
    moreover
    { fix Z
      assume "Z \<in> SC_rel"
      with SC_rel_def obtain X Y where "Z = (X, Y)" and "SC X Y" by auto
      from `SC X Y` and SC_def [of X Y]
        have "\<exists>w x. X = {w, x}" and "\<exists>y z. Y = {y, z}" by auto
      with is_segment_def [of X] and is_segment_def [of Y]
        have "is_segment X" and "is_segment Y" by auto
      with segments_def have "X \<in> segments" and "Y \<in> segments" by auto
      with `Z = (X, Y)` have "Z \<in> segments \<times> segments" by simp }
    hence "SC_rel \<subseteq> segments \<times> segments" by auto
    moreover
    { fix X
      assume "X \<in> segments"
      with segments_def have "is_segment X" by auto
      with is_segment_def [of X] obtain x y where "X = {x, y}" by auto
      with SC_def [of X X] and SC_refl have "SC X X" by (simp add: C_SC_equiv)
      with SC_rel_def have "(X, X) \<in> SC_rel" by simp }
    hence "\<forall>X. X \<in> segments \<longrightarrow> (X, X) \<in> SC_rel" by simp
    ultimately show ?thesis by simp
  qed

  lemma SC_sym:
    assumes "SC X Y"
    shows "SC Y X"
  proof -
    from SC_def [of X Y] and `SC X Y`
      obtain w x y z where "X = {w, x}" and "Y = {y, z}" and "w x \<congruent> y z"
        by auto
    from th2_2 [of w x y z] and `w x \<congruent> y z` have "y z \<congruent> w x" by simp
    with SC_def [of Y X] and `X = {w, x}` and `Y = {y, z}`
      show "SC Y X" by (simp add: C_SC_equiv)
  qed

  lemma SC_sym': "SC X Y = SC Y X"
  proof
    assume "SC X Y"
    with SC_sym [of X Y] show "SC Y X" by simp
  next
    assume "SC Y X"
    with SC_sym [of Y X] show "SC X Y" by simp
  qed

  lemma SC_rel_sym: "sym SC_rel"
  proof -
    { fix X Y
      assume "(X, Y) \<in> SC_rel"
      with SC_rel_def have "SC X Y" by simp
      with SC_sym' have "SC Y X" by simp
      with SC_rel_def have "(Y, X) \<in> SC_rel" by simp }
    with sym_def [of SC_rel] show ?thesis by blast
  qed

  lemma SC_trans:
    assumes "SC X Y" and "SC Y Z"
    shows "SC X Z"
  proof -
    from SC_def [of X Y] and `SC X Y`
      obtain w x y z where "X = {w, x}" and "Y = {y, z}" and "w x \<congruent> y z"
        by auto
    from SC_def [of Y Z] and `SC Y Z`
      obtain p q r s where "Y = {p, q}" and "Z = {r, s}" and "p q \<congruent> r s" by auto
    from `Y = {y, z}` and `Y = {p, q}` and `p q \<congruent> r s`
      have "y z \<congruent> r s" by (simp add: C_SC_equiv)
    with th2_3 [of w x y z r s] and `w x \<congruent> y z` have "w x \<congruent> r s" by simp
    with SC_def [of X Z] and `X = {w, x}` and `Z = {r, s}`
      show "SC X Z" by (simp add: C_SC_equiv)
  qed

  lemma SC_rel_trans: "trans SC_rel"
  proof -
    { fix X Y Z
      assume "(X, Y) \<in> SC_rel" and "(Y, Z) \<in> SC_rel"
      with SC_rel_def have "SC X Y" and "SC Y Z" by auto
      with SC_trans [of X Y Z] have "SC X Z" by simp
      with SC_rel_def have "(X, Z) \<in> SC_rel" by simp }
    with trans_def [of SC_rel] show ?thesis by blast
  qed

  lemma A3_reversed:
    assumes "a a \<congruent> b c"
    shows "b = c"
  proof -
    from `a a \<congruent> b c` have "b c \<congruent> a a" by (rule th2_2)
    thus "b = c" by (rule A3')
  qed

  lemma equiv_segments_SC_rel: "equiv segments SC_rel"
    by (simp add: equiv_def SC_rel_refl SC_rel_sym SC_rel_trans)

end

subsection "Some consequences of the first five axioms"

context tarski_first5
begin
  lemma A4': "\<exists>x. B q a x \<and> a x \<congruent> b c"
    by (simp add: A4 [simplified])

  theorem th2_8: "a a \<congruent> b b"
  proof -
    from A4' [of _ a b b] obtain x where "a x \<congruent> b b" by auto
    with A3' [of a x b] have "x = a" by simp
    with `a x \<congruent> b b` show ?thesis by simp
  qed

  definition OFS :: "['p,'p,'p,'p,'p,'p,'p,'p] \<Rightarrow> bool" where
   "OFS a b c d a' b' c' d' \<equiv>
      B a b c \<and> B a' b' c' \<and> a b \<congruent> a' b' \<and> b c \<congruent> b' c' \<and> a d \<congruent> a' d' \<and> b d \<congruent> b' d'"

  lemma A5': "\<lbrakk>OFS a b c d a' b' c' d'; a \<noteq> b\<rbrakk> \<Longrightarrow> c d \<congruent> c' d'"
  proof -
    assume "OFS a b c d a' b' c' d'" and "a \<noteq> b"
    with A5 and OFS_def show ?thesis by blast
  qed

  theorem th2_11:
    assumes hypotheses:
      "B a b c"
      "B a' b' c'"
      "a b \<congruent> a' b'"
      "b c \<congruent> b' c'"
    shows "a c \<congruent> a' c'"
  proof cases
    assume "a = b"
    with `a b \<congruent> a' b'` have "a' = b'" by (simp add: A3_reversed)
    with `b c \<congruent> b' c'` and `a = b` show ?thesis by simp
  next
    assume "a \<noteq> b"
    moreover
      note A5' [of a b c a a' b' c' a'] and
        unordered_pair_equality [of a c] and
        unordered_pair_equality [of a' c']
    moreover
      from OFS_def [of a b c a a' b' c' a'] and
          hypotheses and
          th2_8 [of a a'] and
          unordered_pair_equality [of a b] and
          unordered_pair_equality [of a' b']
        have "OFS a b c a a' b' c' a'" by (simp add: C_SC_equiv)
    ultimately show ?thesis by (simp add: C_SC_equiv)
  qed

  lemma A4_unique:
    assumes "q \<noteq> a" and "B q a x" and "a x \<congruent> b c"
    and "B q a x'" and "a x' \<congruent> b c"
    shows "x = x'"
  proof -
    from SC_sym' and SC_trans and C_SC_equiv and `a x' \<congruent> b c` and `a x \<congruent> b c`
      have "a x \<congruent> a x'" by blast
    with th2_11 [of q a x q a x'] and `B q a x` and `B q a x'` and SC_refl
      have "q x \<congruent> q x'" by simp
    with OFS_def [of q a x x q a x x'] and
        `B q a x` and
        SC_refl and
        `a x \<congruent> a x'`
      have "OFS q a x x q a x x'" by simp
    with A5' [of q a x x q a x x'] and `q \<noteq> a` have "x x \<congruent> x x'" by simp
    thus "x = x'" by (rule A3_reversed)
  qed

  theorem th2_12:
    assumes "q \<noteq> a"
    shows "\<exists>!x. B q a x \<and> a x \<congruent> b c"
    using `q \<noteq> a` and A4' and A4_unique
    by blast
end

subsection "Simple theorems about betweenness"

theorem (in tarski_first5) th3_1: "B a b b"
proof -
  from A4 [rule_format, of a b b b] obtain x where "B a b x" and "b x \<congruent> b b" by auto
  from A3 [rule_format, of b x b] and `b x \<congruent> b b` have "b = x" by simp
  with `B a b x` show "B a b b" by simp
qed

context tarski_absolute_space
begin
  lemma A6':
    assumes "B a b a"
    shows "a = b"
  proof -
    from A6 and `B a b a` show "a = b" by simp
  qed

  lemma A7':
    assumes "B a p c" and "B b q c"
    shows "\<exists>x. B p x b \<and> B q x a"
  proof -
    from A7 and `B a p c` and `B b q c` show ?thesis by blast
  qed

  lemma A11':
    assumes "\<forall> x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B a x y"
    shows "\<exists> b. \<forall> x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B x b y"
  proof -
    from assms have "\<exists> a. \<forall> x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B a x y" by (rule exI)
    thus "\<exists> b. \<forall> x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B x b y" by (rule A11 [rule_format])
  qed

  theorem th3_2:
    assumes "B a b c"
    shows "B c b a"
  proof -
    from th3_1 have "B b c c" by simp
    with A7' and `B a b c` obtain x where "B b x b" and "B c x a" by blast
    from A6' and `B b x b` have "x = b" by auto
    with `B c x a` show "B c b a" by simp
  qed

  theorem th3_4:
    assumes "B a b c" and "B b a c"
    shows "a = b"
  proof -
    from `B a b c` and `B b a c` and A7' [of a b c b a]
    obtain x where "B b x b" and "B a x a" by auto
    hence "b = x" and "a = x" by (simp_all add: A6')
    thus "a = b" by simp
  qed

  theorem th3_5_1:
    assumes "B a b d" and "B b c d"
    shows "B a b c"
  proof -
    from `B a b d` and `B b c d` and A7' [of a b d b c]
    obtain x where "B b x b" and "B c x a" by auto
    from `B b x b` have "b = x" by (rule A6')
    with `B c x a` have "B c b a" by simp
    thus "B a b c" by (rule th3_2)
  qed

  theorem th3_6_1:
    assumes "B a b c" and "B a c d"
    shows "B b c d"
  proof -
    from `B a c d` and `B a b c` and th3_2 have "B d c a" and "B c b a" by fast+
    hence "B d c b" by (rule th3_5_1)
    thus "B b c d" by (rule th3_2)
  qed

  theorem th3_7_1:
    assumes "b \<noteq> c" and "B a b c" and "B b c d"
    shows "B a c d"
  proof -
    from A4' obtain x where "B a c x" and "c x \<congruent> c d" by fast
    from `B a b c` and `B a c x` have "B b c x" by (rule th3_6_1)
    have "c d \<congruent> c d" by (rule th2_1)
    with `b \<noteq> c` and `B b c x` and `c x \<congruent> c d` and `B b c d`
    have "x = d" by (rule A4_unique)
    with `B a c x` show "B a c d" by simp
  qed

subsection "Simple theorems about congruence and betweenness"

definition (in tarski_first5) Col :: "'p \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> bool" where
  "Col a b c \<equiv> B a b c \<or> B b c a \<or> B c a b"

end


header {* \isaheader{Observable Sets of Nodes} *}

theory Observable imports "../Basic/CFG" begin

context CFG begin

inductive_set obs :: "'node \<Rightarrow> 'node set \<Rightarrow> 'node set"
for n::"'node" and S::"'node set"
where obs_elem:
  "\<lbrakk>n -as\<rightarrow>* n'; \<forall>nx \<in> set(sourcenodes as). nx \<notin> S; n' \<in> S\<rbrakk> \<Longrightarrow> n' \<in> obs n S"

lemma obsE:
  assumes "n' \<in> obs n S"
  obtains as where "n -as\<rightarrow>* n'" and "\<forall>nx \<in> set(sourcenodes as). nx \<notin> S"
  and "n' \<in> S"
proof(atomize_elim)
  from `n' \<in> obs n S`
  have "\<exists>as. n -as\<rightarrow>* n' \<and> (\<forall>nx \<in> set(sourcenodes as). nx \<notin> S) \<and> n' \<in> S"
    by(auto elim:obs.cases)
  thus "\<exists>as. n -as\<rightarrow>* n' \<and> (\<forall>nx\<in>set (sourcenodes as). nx \<notin> S) \<and> n' \<in> S" by blast
qed

lemma n_in_obs:
  assumes "valid_node n" and "n \<in> S" shows "obs n S = {n}"
proof -
  from `valid_node n` have "n -[]\<rightarrow>* n" by(rule empty_path)
  with `n \<in> S` have "n \<in> obs n S" by(fastforce elim:obs_elem simp:sourcenodes_def)
  { fix n' assume "n' \<in> obs n S"
    have "n' = n"
    proof(rule ccontr)
      assume "n' \<noteq> n"
      from `n' \<in> obs n S` obtain as where "n -as\<rightarrow>* n'"
        and "\<forall>nx \<in> set(sourcenodes as). nx \<notin> S"
        and "n' \<in> S" by(erule obsE)
      from `n -as\<rightarrow>* n'` `\<forall>nx \<in> set(sourcenodes as). nx \<notin> S` `n' \<noteq> n` `n \<in> S`
      show False
      proof(induct rule:path.induct)
        case (Cons_path n'' as n' a n)
        from `\<forall>nx\<in>set (sourcenodes (a#as)). nx \<notin> S` `sourcenode a = n`
        have "n \<notin> S" by(simp add:sourcenodes_def)
        with `n \<in> S` show False by simp
      qed simp
    qed }
  with `n \<in> obs n S` show ?thesis by fastforce
qed

lemma in_obs_valid:
  assumes "n' \<in> obs n S" shows "valid_node n" and "valid_node n'"
  using `n' \<in> obs n S`
  by(auto elim:obsE intro:path_valid_node)

lemma edge_obs_subset:
  assumes"valid_edge a" and "sourcenode a \<notin> S"
  shows "obs (targetnode a) S \<subseteq> obs (sourcenode a) S"
proof
  fix n assume "n \<in> obs (targetnode a) S"
  then obtain as where "targetnode a -as\<rightarrow>* n"
    and all:"\<forall>nx \<in> set(sourcenodes as). nx \<notin> S" and "n \<in> S" by(erule obsE)
  from `valid_edge a` `targetnode a -as\<rightarrow>* n`
  have "sourcenode a -a#as\<rightarrow>* n" by(fastforce intro:Cons_path)
  moreover
  from all `sourcenode a \<notin> S` have "\<forall>nx \<in> set(sourcenodes (a#as)). nx \<notin> S"
    by(simp add:sourcenodes_def)
  ultimately show "n \<in> obs (sourcenode a) S" using `n \<in> S`
    by(rule obs_elem)
qed

lemma path_obs_subset:
  "\<lbrakk>n -as\<rightarrow>* n'; \<forall>n' \<in> set(sourcenodes as). n' \<notin> S\<rbrakk>
  \<Longrightarrow> obs n' S \<subseteq> obs n S"
proof(induct rule:path.induct)
  case (Cons_path n'' as n' a n)
  note IH = `\<forall>n'\<in>set (sourcenodes as). n' \<notin> S \<Longrightarrow> obs n' S \<subseteq> obs n'' S`
  from `\<forall>n'\<in>set (sourcenodes (a#as)). n' \<notin> S`
  have all:"\<forall>n'\<in>set (sourcenodes as). n' \<notin> S" and "sourcenode a \<notin> S"
    by(simp_all add:sourcenodes_def)
  from IH[OF all] have "obs n' S \<subseteq> obs n'' S" .
  from `valid_edge a` `targetnode a = n''` `sourcenode a = n` `sourcenode a \<notin> S`
  have "obs n'' S \<subseteq> obs n S" by(fastforce dest:edge_obs_subset)
  with `obs n' S \<subseteq> obs n'' S` show ?case by fastforce
qed simp

lemma path_ex_obs:
  assumes "n -as\<rightarrow>* n'" and "n' \<in> S"
  obtains m where "m \<in> obs n S"
proof(atomize_elim)
  show "\<exists>m. m \<in> obs n S"
  proof(cases "\<forall>nx \<in> set(sourcenodes as). nx \<notin> S")
    case True
    with `n -as\<rightarrow>* n'` `n' \<in> S` have "n' \<in> obs n S" by -(rule obs_elem)
    thus ?thesis by fastforce
  next
    case False
    hence "\<exists>nx \<in> set(sourcenodes as). nx \<in> S" by fastforce
    then obtain nx ns ns' where "sourcenodes as = ns@nx#ns'"
      and "nx \<in> S" and "\<forall>n' \<in> set ns. n' \<notin> S"
      by(fastforce elim!:split_list_first_propE)
    from `sourcenodes as = ns@nx#ns'` obtain as' a as''
      where "ns = sourcenodes as'"
      and "as = as'@a#as''" and "sourcenode a = nx"
      by(fastforce elim:map_append_append_maps simp:sourcenodes_def)
    with `n -as\<rightarrow>* n'` have "n -as'\<rightarrow>* nx" by(fastforce dest:path_split)
    with `nx \<in> S` `\<forall>n' \<in> set ns. n' \<notin> S` `ns = sourcenodes as'` have "nx \<in> obs n S"
      by(fastforce intro:obs_elem)
    thus ?thesis by fastforce
  qed
qed

end

end


theory Exercise3p10
imports AExp
begin

(* Exercise 3.10

A stack underflow occurs when executing an ADD instruction on a stack of size less than 2.
In our semantics stack underflow leads to a term involving hd [], which is not an error or
exception — HOL does not have those concepts — but some unspecified value. Modify theory
ASM such that stack underflow is modelled by None and normal execution by Some, i.e.,
the execution functions have return type stack option. Modify all theorems and proofs
accordingly.

*)

subsection "Stack Machine"

datatype instr = LOADI val | LOAD vname | ADD

type_synonym stack = "val list"

abbreviation "hd2 xs == hd(tl xs)"
abbreviation "tl2 xs == tl(tl xs)"

text{* \noindent Abbreviations are transparent: they are unfolded after
parsing and folded back again before printing. Internally, they do not
exist.*}

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec1 (LOADI n) _ stk    = Some(n # stk)" |
"exec1 (LOAD x) s stk     = Some(s(x) # stk)"  |
"exec1  ADD _ (v1#v2#stk) = Some((v1 + v2) # stk)" |
"exec1  ADD _ _           = None"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec [] _ stk = Some(stk)" |
"exec (i#is) s stk =
  (case exec1 i s stk of
     Some stk2 \<Rightarrow> exec is s stk2 |
     None      \<Rightarrow> None)"

value "exec [LOADI 5, LOAD ''y'', ADD] <''x'' := 42, ''y'' := 43> [50]"

lemma exec_append[simp]:
  "exec (is1@is2) s stk =
     (case exec is1 s stk of
       Some stk2 \<Rightarrow> exec is2 s stk2 |
       None      \<Rightarrow> None)"
 apply(induction is1 arbitrary: stk)
  apply (auto split: option.splits)
done

subsection "Compilation"

fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x) = [LOAD x]" |
"comp (Plus e\<^sub>1 e\<^sub>2) = comp e\<^sub>1 @ comp e\<^sub>2 @ [ADD]"

value "comp (Plus (Plus (V ''x'') (N 1)) (V ''z''))"

theorem exec_comp: "exec (comp a) s stk = Some (aval a s # stk)"
apply(induction a arbitrary: stk)
apply (auto)
done

end


(*  Title:      HOL/Probability/Infinite_Product_Measure.thy
    Author:     Johannes Hölzl, TU München
*)

section {*Infinite Product Measure*}

theory Infinite_Product_Measure
  imports Probability_Measure Caratheodory Projective_Family
begin

lemma (in product_prob_space) emeasure_PiM_emb_not_empty:
  assumes X: "J \<noteq> {}" "J \<subseteq> I" "finite J" "\<forall>i\<in>J. X i \<in> sets (M i)"
  shows "emeasure (Pi\<^sub>M I M) (emb I J (Pi\<^sub>E J X)) = emeasure (Pi\<^sub>M J M) (Pi\<^sub>E J X)"
proof cases
  assume "finite I" with X show ?thesis by simp
next
  let ?\<Omega> = "\<Pi>\<^sub>E i\<in>I. space (M i)"
  let ?G = generator
  assume "\<not> finite I"
  then have I_not_empty: "I \<noteq> {}" by auto
  interpret G!: algebra ?\<Omega> generator by (rule algebra_generator) fact
  note mu_G_mono =
    G.additive_increasing[OF positive_mu_G[OF I_not_empty] additive_mu_G[OF I_not_empty],
      THEN increasingD]
  write mu_G  ("\<mu>G")

  { fix Z J assume J: "J \<noteq> {}" "finite J" "J \<subseteq> I" and Z: "Z \<in> ?G"

    from `infinite I` `finite J` obtain k where k: "k \<in> I" "k \<notin> J"
      by (metis rev_finite_subset subsetI)
    moreover from Z guess K' X' by (rule generatorE)
    moreover def K \<equiv> "insert k K'"
    moreover def X \<equiv> "emb K K' X'"
    ultimately have K: "K \<noteq> {}" "finite K" "K \<subseteq> I" "X \<in> sets (Pi\<^sub>M K M)" "Z = emb I K X"
      "K - J \<noteq> {}" "K - J \<subseteq> I" "\<mu>G Z = emeasure (Pi\<^sub>M K M) X"
      by (auto simp: subset_insertI)
    let ?M = "\<lambda>y. (\<lambda>x. merge J (K - J) (y, x)) -` emb (J \<union> K) K X \<inter> space (Pi\<^sub>M (K - J) M)"
    { fix y assume y: "y \<in> space (Pi\<^sub>M J M)"
      note * = merge_emb[OF `K \<subseteq> I` `J \<subseteq> I` y, of X]
      moreover
      have **: "?M y \<in> sets (Pi\<^sub>M (K - J) M)"
        using J K y by (intro merge_sets) auto
      ultimately
      have ***: "((\<lambda>x. merge J (I - J) (y, x)) -` Z \<inter> space (Pi\<^sub>M I M)) \<in> ?G"
        using J K by (intro generatorI) auto
      have "\<mu>G ((\<lambda>x. merge J (I - J) (y, x)) -` emb I K X \<inter> space (Pi\<^sub>M I M)) = emeasure (Pi\<^sub>M (K - J) M) (?M y)"
        unfolding * using K J by (subst mu_G_eq[OF _ _ _ **]) auto
      note * ** *** this }
    note merge_in_G = this

    have "finite (K - J)" using K by auto

    interpret J: finite_product_prob_space M J by default fact+
    interpret KmJ: finite_product_prob_space M "K - J" by default fact+

    have "\<mu>G Z = emeasure (Pi\<^sub>M (J \<union> (K - J)) M) (emb (J \<union> (K - J)) K X)"
      using K J by simp
    also have "\<dots> = (\<integral>\<^sup>+ x. emeasure (Pi\<^sub>M (K - J) M) (?M x) \<partial>Pi\<^sub>M J M)"
      using K J by (subst emeasure_fold_integral) auto
    also have "\<dots> = (\<integral>\<^sup>+ y. \<mu>G ((\<lambda>x. merge J (I - J) (y, x)) -` Z \<inter> space (Pi\<^sub>M I M)) \<partial>Pi\<^sub>M J M)"
      (is "_ = (\<integral>\<^sup>+x. \<mu>G (?MZ x) \<partial>Pi\<^sub>M J M)")
    proof (intro nn_integral_cong)
      fix x assume x: "x \<in> space (Pi\<^sub>M J M)"
      with K merge_in_G(2)[OF this]
      show "emeasure (Pi\<^sub>M (K - J) M) (?M x) = \<mu>G (?MZ x)"
        unfolding `Z = emb I K X` merge_in_G(1)[OF x] by (subst mu_G_eq) auto
    qed
    finally have fold: "\<mu>G Z = (\<integral>\<^sup>+x. \<mu>G (?MZ x) \<partial>Pi\<^sub>M J M)" .

    { fix x assume x: "x \<in> space (Pi\<^sub>M J M)"
      then have "\<mu>G (?MZ x) \<le> 1"
        unfolding merge_in_G(4)[OF x] `Z = emb I K X`
        by (intro KmJ.measure_le_1 merge_in_G(2)[OF x]) }
    note le_1 = this

    let ?q = "\<lambda>y. \<mu>G ((\<lambda>x. merge J (I - J) (y,x)) -` Z \<inter> space (Pi\<^sub>M I M))"
    have "?q \<in> borel_measurable (Pi\<^sub>M J M)"
      unfolding `Z = emb I K X` using J K merge_in_G(3)
      by (simp add: merge_in_G  mu_G_eq emeasure_fold_measurable cong: measurable_cong)
    note this fold le_1 merge_in_G(3) }
  note fold = this

  have "\<exists>\<mu>. (\<forall>s\<in>?G. \<mu> s = \<mu>G s) \<and> measure_space ?\<Omega> (sigma_sets ?\<Omega> ?G) \<mu>"
  proof (rule G.caratheodory_empty_continuous[OF positive_mu_G additive_mu_G])
    fix A assume "A \<in> ?G"
    with generatorE guess J X . note JX = this
    interpret JK: finite_product_prob_space M J by default fact+
    from JX show "\<mu>G A \<noteq> \<infinity>" by simp
  next
    fix A assume A: "range A \<subseteq> ?G" "decseq A" "(\<Inter>i. A i) = {}"
    then have "decseq (\<lambda>i. \<mu>G (A i))"
      by (auto intro!: mu_G_mono simp: decseq_def)
    moreover
    have "(INF i. \<mu>G (A i)) = 0"
    proof (rule ccontr)
      assume "(INF i. \<mu>G (A i)) \<noteq> 0" (is "?a \<noteq> 0")
      moreover have "0 \<le> ?a"
        using A positive_mu_G[OF I_not_empty] by (auto intro!: INF_greatest simp: positive_def)
      ultimately have "0 < ?a" by auto

      have "\<forall>n. \<exists>J X. J \<noteq> {} \<and> finite J \<and> J \<subseteq> I \<and> X \<in> sets (Pi\<^sub>M J M) \<and> A n = emb I J X \<and> \<mu>G (A n) = emeasure (limP J M (\<lambda>J. (Pi\<^sub>M J M))) X"
        using A by (intro allI generator_Ex) auto
      then obtain J' X' where J': "\<And>n. J' n \<noteq> {}" "\<And>n. finite (J' n)" "\<And>n. J' n \<subseteq> I" "\<And>n. X' n \<in> sets (Pi\<^sub>M (J' n) M)"
        and A': "\<And>n. A n = emb I (J' n) (X' n)"
        unfolding choice_iff by blast
      moreover def J \<equiv> "\<lambda>n. (\<Union>i\<le>n. J' i)"
      moreover def X \<equiv> "\<lambda>n. emb (J n) (J' n) (X' n)"
      ultimately have J: "\<And>n. J n \<noteq> {}" "\<And>n. finite (J n)" "\<And>n. J n \<subseteq> I" "\<And>n. X n \<in> sets (Pi\<^sub>M (J n) M)"
        by auto
      with A' have A_eq: "\<And>n. A n = emb I (J n) (X n)" "\<And>n. A n \<in> ?G"
        unfolding J_def X_def by (subst prod_emb_trans) (insert A, auto)

      have J_mono: "\<And>n m. n \<le> m \<Longrightarrow> J n \<subseteq> J m"
        unfolding J_def by force

      interpret J: finite_product_prob_space M "J i" for i by default fact+

      have a_le_1: "?a \<le> 1"
        using mu_G_spec[of "J 0" "A 0" "X 0"] J A_eq
        by (auto intro!: INF_lower2[of 0] J.measure_le_1)

      let ?M = "\<lambda>K Z y. (\<lambda>x. merge K (I - K) (y, x)) -` Z \<inter> space (Pi\<^sub>M I M)"

      { fix Z k assume Z: "range Z \<subseteq> ?G" "decseq Z" "\<forall>n. ?a / 2^k \<le> \<mu>G (Z n)"
        then have Z_sets: "\<And>n. Z n \<in> ?G" by auto
        fix J' assume J': "J' \<noteq> {}" "finite J'" "J' \<subseteq> I"
        interpret J': finite_product_prob_space M J' by default fact+

        let ?q = "\<lambda>n y. \<mu>G (?M J' (Z n) y)"
        let ?Q = "\<lambda>n. ?q n -` {?a / 2^(k+1) ..} \<inter> space (Pi\<^sub>M J' M)"
        { fix n
          have "?q n \<in> borel_measurable (Pi\<^sub>M J' M)"
            using Z J' by (intro fold(1)) auto
          then have "?Q n \<in> sets (Pi\<^sub>M J' M)"
            by (rule measurable_sets) auto }
        note Q_sets = this

        have "?a / 2^(k+1) \<le> (INF n. emeasure (Pi\<^sub>M J' M) (?Q n))"
        proof (intro INF_greatest)
          fix n
          have "?a / 2^k \<le> \<mu>G (Z n)" using Z by auto
          also have "\<dots> \<le> (\<integral>\<^sup>+ x. indicator (?Q n) x + ?a / 2^(k+1) \<partial>Pi\<^sub>M J' M)"
            unfolding fold(2)[OF J' `Z n \<in> ?G`]
          proof (intro nn_integral_mono)
            fix x assume x: "x \<in> space (Pi\<^sub>M J' M)"
            then have "?q n x \<le> 1 + 0"
              using J' Z fold(3) Z_sets by auto
            also have "\<dots> \<le> 1 + ?a / 2^(k+1)"
              using `0 < ?a` by (intro add_mono) auto
            finally have "?q n x \<le> 1 + ?a / 2^(k+1)" .
            with x show "?q n x \<le> indicator (?Q n) x + ?a / 2^(k+1)"
              by (auto split: split_indicator simp del: power_Suc)
          qed
          also have "\<dots> = emeasure (Pi\<^sub>M J' M) (?Q n) + ?a / 2^(k+1)"
            using `0 \<le> ?a` Q_sets J'.emeasure_space_1
            by (subst nn_integral_add) auto
          finally show "?a / 2^(k+1) \<le> emeasure (Pi\<^sub>M J' M) (?Q n)" using `?a \<le> 1`
            by (cases rule: ereal2_cases[of ?a "emeasure (Pi\<^sub>M J' M) (?Q n)"])
               (auto simp: field_simps)
        qed
        also have "\<dots> = emeasure (Pi\<^sub>M J' M) (\<Inter>n. ?Q n)"
        proof (intro INF_emeasure_decseq)
          show "range ?Q \<subseteq> sets (Pi\<^sub>M J' M)" using Q_sets by auto
          show "decseq ?Q"
            unfolding decseq_def
          proof (safe intro!: vimageI[OF refl])
            fix m n :: nat assume "m \<le> n"
            fix x assume x: "x \<in> space (Pi\<^sub>M J' M)"
            assume "?a / 2^(k+1) \<le> ?q n x"
            also have "?q n x \<le> ?q m x"
            proof (rule mu_G_mono)
              from fold(4)[OF J', OF Z_sets x]
              show "?M J' (Z n) x \<in> ?G" "?M J' (Z m) x \<in> ?G" by auto
              show "?M J' (Z n) x \<subseteq> ?M J' (Z m) x"
                using `decseq Z`[THEN decseqD, OF `m \<le> n`] by auto
            qed
            finally show "?a / 2^(k+1) \<le> ?q m x" .
          qed
        qed simp
        finally have "(\<Inter>n. ?Q n) \<noteq> {}"
          using `0 < ?a` `?a \<le> 1` by (cases ?a) (auto simp: divide_le_0_iff power_le_zero_eq)
        then have "\<exists>w\<in>space (Pi\<^sub>M J' M). \<forall>n. ?a / 2 ^ (k + 1) \<le> ?q n w" by auto }
      note Ex_w = this

      let ?q = "\<lambda>k n y. \<mu>G (?M (J k) (A n) y)"

      let ?P = "\<lambda>w k. w \<in> space (Pi\<^sub>M (J k) M) \<and> (\<forall>n. ?a / 2 ^ (Suc k) \<le> ?q k n w)"
      have "\<exists>w. \<forall>k. ?P (w k) k \<and> restrict (w (Suc k)) (J k) = w k"
      proof (rule dependent_nat_choice)
        have "\<forall>n. ?a / 2 ^ 0 \<le> \<mu>G (A n)" by (auto intro: INF_lower)
        from Ex_w[OF A(1,2) this J(1-3), of 0] show "\<exists>w. ?P w 0" by auto
      next
        fix w k assume Suc: "?P w k"
        show "\<exists>w'. ?P w' (Suc k) \<and> restrict w' (J k) = w"
        proof cases
          assume [simp]: "J k = J (Suc k)"
          have "?a / 2 ^ (Suc (Suc k)) \<le> ?a / 2 ^ (k + 1)"
            using `0 < ?a` `?a \<le> 1` by (cases ?a) (auto simp: field_simps)
          with Suc show ?thesis
            by (auto intro!: exI[of _ w] simp: extensional_restrict space_PiM intro: order_trans)
        next
          assume "J k \<noteq> J (Suc k)"
          with J_mono[of k "Suc k"] have "J (Suc k) - J k \<noteq> {}" (is "?D \<noteq> {}") by auto
          have "range (\<lambda>n. ?M (J k) (A n) w) \<subseteq> ?G" "decseq (\<lambda>n. ?M (J k) (A n) w)"
            "\<forall>n. ?a / 2 ^ (k + 1) \<le> \<mu>G (?M (J k) (A n) w)"
            using `decseq A` fold(4)[OF J(1-3) A_eq(2), of w k] Suc
            by (auto simp: decseq_def)
          from Ex_w[OF this `?D \<noteq> {}`] J[of "Suc k"]
          obtain w' where w': "w' \<in> space (Pi\<^sub>M ?D M)"
            "\<forall>n. ?a / 2 ^ (Suc k + 1) \<le> \<mu>G (?M ?D (?M (J k) (A n) w) w')" by auto
          let ?w = "merge (J k) ?D (w, w')"
          have [simp]: "\<And>x. merge (J k) (I - J k) (w, merge ?D (I - ?D) (w', x)) =
            merge (J (Suc k)) (I - (J (Suc k))) (?w, x)"
            using J(3)[of "Suc k"] J(3)[of k] J_mono[of k "Suc k"]
            by (auto intro!: ext split: split_merge)
          have *: "\<And>n. ?M ?D (?M (J k) (A n) w) w' = ?M (J (Suc k)) (A n) ?w"
            using w'(1) J(3)[of "Suc k"]
            by (auto simp: space_PiM split: split_merge intro!: extensional_merge_sub) force+
          show ?thesis
            using Suc w' J_mono[of k "Suc k"] unfolding *
            by (intro exI[of _ ?w])
               (auto split: split_merge intro!: extensional_merge_sub ext simp: space_PiM PiE_iff)
        qed
      qed
      then obtain w where w:
        "\<And>k. w k \<in> space (Pi\<^sub>M (J k) M)"
        "\<And>k n. ?a / 2 ^ (Suc k) \<le> ?q k n (w k)"
        "\<And>k. restrict (w (Suc k)) (J k) = w k"
        by metis

      { fix k
        from w have "?a / 2 ^ (k + 1) \<le> ?q k k (w k)" by auto
        then have "?M (J k) (A k) (w k) \<noteq> {}"
          using positive_mu_G[OF I_not_empty, unfolded positive_def] `0 < ?a` `?a \<le> 1`
          by (cases ?a) (auto simp: divide_le_0_iff power_le_zero_eq)
        then obtain x where "x \<in> ?M (J k) (A k) (w k)" by auto
        then have "merge (J k) (I - J k) (w k, x) \<in> A k" by auto
        then have "\<exists>x\<in>A k. restrict x (J k) = w k"
          using `w k \<in> space (Pi\<^sub>M (J k) M)`
          by (intro rev_bexI) (auto intro!: ext simp: extensional_def space_PiM) }
      note w_ext = this

      { fix k l i assume "k \<le> l" "i \<in> J k"
        { fix l have "w k i = w (k + l) i"
          proof (induct l)
            case (Suc l)
            from `i \<in> J k` J_mono[of k "k + l"] have "i \<in> J (k + l)" by auto
            with w(3)[of "k + l"]
            have "w (k + l) i = w (k + Suc l) i"
              by (auto simp: restrict_def fun_eq_iff split: split_if_asm)
            with Suc show ?case by simp
          qed simp }
        from this[of "l - k"] `k \<le> l` have "w l i = w k i" by simp }
      note w_mono = this

      def w' \<equiv> "\<lambda>i. if i \<in> (\<Union>k. J k) then w (LEAST k. i \<in> J k) i else if i \<in> I then (SOME x. x \<in> space (M i)) else undefined"
      { fix i k assume k: "i \<in> J k"
        have "w k i = w (LEAST k. i \<in> J k) i"
          by (intro w_mono Least_le k LeastI[of _ k])
        then have "w' i = w k i"
          unfolding w'_def using k by auto }
      note w'_eq = this
      have w'_simps1: "\<And>i. i \<notin> I \<Longrightarrow> w' i = undefined"
        using J by (auto simp: w'_def)
      have w'_simps2: "\<And>i. i \<notin> (\<Union>k. J k) \<Longrightarrow> i \<in> I \<Longrightarrow> w' i \<in> space (M i)"
        using J by (auto simp: w'_def intro!: someI_ex[OF M.not_empty[unfolded ex_in_conv[symmetric]]])
      { fix i assume "i \<in> I" then have "w' i \<in> space (M i)"
          using w(1) by (cases "i \<in> (\<Union>k. J k)") (force simp: w'_simps2 w'_eq space_PiM)+ }
      note w'_simps[simp] = w'_eq w'_simps1 w'_simps2 this

      have w': "w' \<in> space (Pi\<^sub>M I M)"
        using w(1) by (auto simp add: Pi_iff extensional_def space_PiM)

      { fix n
        have "restrict w' (J n) = w n" using w(1)[of n]
          by (auto simp add: fun_eq_iff space_PiM)
        with w_ext[of n] obtain x where "x \<in> A n" "restrict x (J n) = restrict w' (J n)"
          by auto
        then have "w' \<in> A n" unfolding A_eq using w' by (auto simp: prod_emb_def space_PiM) }
      then have "w' \<in> (\<Inter>i. A i)" by auto
      with `(\<Inter>i. A i) = {}` show False by auto
    qed
    ultimately show "(\<lambda>i. \<mu>G (A i)) ----> 0"
      using LIMSEQ_INF[of "\<lambda>i. \<mu>G (A i)"] by simp
  qed fact+
  then guess \<mu> .. note \<mu> = this
  show ?thesis
  proof (subst emeasure_extend_measure_Pair[OF PiM_def, of I M \<mu> J X])
    from assms show "(J \<noteq> {} \<or> I = {}) \<and> finite J \<and> J \<subseteq> I \<and> X \<in> (\<Pi> j\<in>J. sets (M j))"
      by (simp add: Pi_iff)
  next
    fix J X assume J: "(J \<noteq> {} \<or> I = {}) \<and> finite J \<and> J \<subseteq> I \<and> X \<in> (\<Pi> j\<in>J. sets (M j))"
    then show "emb I J (Pi\<^sub>E J X) \<in> Pow (\<Pi>\<^sub>E i\<in>I. space (M i))"
      by (auto simp: Pi_iff prod_emb_def dest: sets.sets_into_space)
    have "emb I J (Pi\<^sub>E J X) \<in> generator"
      using J `I \<noteq> {}` by (intro generatorI') (auto simp: Pi_iff)
    then have "\<mu> (emb I J (Pi\<^sub>E J X)) = \<mu>G (emb I J (Pi\<^sub>E J X))"
      using \<mu> by simp
    also have "\<dots> = (\<Prod> j\<in>J. if j \<in> J then emeasure (M j) (X j) else emeasure (M j) (space (M j)))"
      using J  `I \<noteq> {}` by (subst mu_G_spec[OF _ _ _ refl]) (auto simp: emeasure_PiM Pi_iff)
    also have "\<dots> = (\<Prod>j\<in>J \<union> {i \<in> I. emeasure (M i) (space (M i)) \<noteq> 1}.
      if j \<in> J then emeasure (M j) (X j) else emeasure (M j) (space (M j)))"
      using J `I \<noteq> {}` by (intro setprod.mono_neutral_right) (auto simp: M.emeasure_space_1)
    finally show "\<mu> (emb I J (Pi\<^sub>E J X)) = \<dots>" .
  next
    let ?F = "\<lambda>j. if j \<in> J then emeasure (M j) (X j) else emeasure (M j) (space (M j))"
    have "(\<Prod>j\<in>J \<union> {i \<in> I. emeasure (M i) (space (M i)) \<noteq> 1}. ?F j) = (\<Prod>j\<in>J. ?F j)"
      using X `I \<noteq> {}` by (intro setprod.mono_neutral_right) (auto simp: M.emeasure_space_1)
    then show "(\<Prod>j\<in>J \<union> {i \<in> I. emeasure (M i) (space (M i)) \<noteq> 1}. ?F j) =
      emeasure (Pi\<^sub>M J M) (Pi\<^sub>E J X)"
      using X by (auto simp add: emeasure_PiM)
  next
    show "positive (sets (Pi\<^sub>M I M)) \<mu>" "countably_additive (sets (Pi\<^sub>M I M)) \<mu>"
      using \<mu> unfolding sets_PiM_generator by (auto simp: measure_space_def)
  qed
qed

sublocale product_prob_space \<subseteq> P: prob_space "Pi\<^sub>M I M"
proof
  show "emeasure (Pi\<^sub>M I M) (space (Pi\<^sub>M I M)) = 1"
  proof cases
    assume "I = {}" then show ?thesis by (simp add: space_PiM_empty)
  next
    assume "I \<noteq> {}"
    then obtain i where i: "i \<in> I" by auto
    then have "emb I {i} (\<Pi>\<^sub>E i\<in>{i}. space (M i)) = (space (Pi\<^sub>M I M))"
      by (auto simp: prod_emb_def space_PiM)
    with i show ?thesis
      using emeasure_PiM_emb_not_empty[of "{i}" "\<lambda>i. space (M i)"]
      by (simp add: emeasure_PiM emeasure_space_1)
  qed
qed

lemma (in product_prob_space) emeasure_PiM_emb:
  assumes X: "J \<subseteq> I" "finite J" "\<And>i. i \<in> J \<Longrightarrow> X i \<in> sets (M i)"
  shows "emeasure (Pi\<^sub>M I M) (emb I J (Pi\<^sub>E J X)) = (\<Prod> i\<in>J. emeasure (M i) (X i))"
proof cases
  assume "J = {}"
  moreover have "emb I {} {\<lambda>x. undefined} = space (Pi\<^sub>M I M)"
    by (auto simp: space_PiM prod_emb_def)
  ultimately show ?thesis
    by (simp add: space_PiM_empty P.emeasure_space_1)
next
  assume "J \<noteq> {}" with X show ?thesis
    by (subst emeasure_PiM_emb_not_empty) (auto simp: emeasure_PiM)
qed

lemma (in product_prob_space) emeasure_PiM_Collect:
  assumes X: "J \<subseteq> I" "finite J" "\<And>i. i \<in> J \<Longrightarrow> X i \<in> sets (M i)"
  shows "emeasure (Pi\<^sub>M I M) {x\<in>space (Pi\<^sub>M I M). \<forall>i\<in>J. x i \<in> X i} = (\<Prod> i\<in>J. emeasure (M i) (X i))"
proof -
  have "{x\<in>space (Pi\<^sub>M I M). \<forall>i\<in>J. x i \<in> X i} = emb I J (Pi\<^sub>E J X)"
    unfolding prod_emb_def using assms by (auto simp: space_PiM Pi_iff)
  with emeasure_PiM_emb[OF assms] show ?thesis by simp
qed

lemma (in product_prob_space) emeasure_PiM_Collect_single:
  assumes X: "i \<in> I" "A \<in> sets (M i)"
  shows "emeasure (Pi\<^sub>M I M) {x\<in>space (Pi\<^sub>M I M). x i \<in> A} = emeasure (M i) A"
  using emeasure_PiM_Collect[of "{i}" "\<lambda>i. A"] assms
  by simp

lemma (in product_prob_space) measure_PiM_emb:
  assumes "J \<subseteq> I" "finite J" "\<And>i. i \<in> J \<Longrightarrow> X i \<in> sets (M i)"
  shows "measure (PiM I M) (emb I J (Pi\<^sub>E J X)) = (\<Prod> i\<in>J. measure (M i) (X i))"
  using emeasure_PiM_emb[OF assms]
  unfolding emeasure_eq_measure M.emeasure_eq_measure by (simp add: setprod_ereal)

lemma sets_Collect_single':
  "i \<in> I \<Longrightarrow> {x\<in>space (M i). P x} \<in> sets (M i) \<Longrightarrow> {x\<in>space (PiM I M). P (x i)} \<in> sets (PiM I M)"
  using sets_Collect_single[of i I "{x\<in>space (M i). P x}" M]
  by (simp add: space_PiM PiE_iff cong: conj_cong)

lemma (in finite_product_prob_space) finite_measure_PiM_emb:
  "(\<And>i. i \<in> I \<Longrightarrow> A i \<in> sets (M i)) \<Longrightarrow> measure (PiM I M) (Pi\<^sub>E I A) = (\<Prod>i\<in>I. measure (M i) (A i))"
  using measure_PiM_emb[of I A] finite_index prod_emb_PiE_same_index[OF sets.sets_into_space, of I A M]
  by auto

lemma (in product_prob_space) PiM_component:
  assumes "i \<in> I"
  shows "distr (PiM I M) (M i) (\<lambda>\<omega>. \<omega> i) = M i"
proof (rule measure_eqI[symmetric])
  fix A assume "A \<in> sets (M i)"
  moreover have "((\<lambda>\<omega>. \<omega> i) -` A \<inter> space (PiM I M)) = {x\<in>space (PiM I M). x i \<in> A}"
    by auto
  ultimately show "emeasure (M i) A = emeasure (distr (PiM I M) (M i) (\<lambda>\<omega>. \<omega> i)) A"
    by (auto simp: `i\<in>I` emeasure_distr measurable_component_singleton emeasure_PiM_Collect_single)
qed simp

lemma (in product_prob_space) PiM_eq:
  assumes "I \<noteq> {}"
  assumes "sets M' = sets (PiM I M)"
  assumes eq: "\<And>J F. finite J \<Longrightarrow> J \<subseteq> I \<Longrightarrow> (\<And>j. j \<in> J \<Longrightarrow> F j \<in> sets (M j)) \<Longrightarrow>
    emeasure M' (prod_emb I M J (\<Pi>\<^sub>E j\<in>J. F j)) = (\<Prod>j\<in>J. emeasure (M j) (F j))"
  shows "M' = (PiM I M)"
proof (rule measure_eqI_generator_eq[symmetric, OF Int_stable_prod_algebra prod_algebra_sets_into_space])
  show "sets (PiM I M) = sigma_sets (\<Pi>\<^sub>E i\<in>I. space (M i)) (prod_algebra I M)"
    by (rule sets_PiM)
  then show "sets M' = sigma_sets (\<Pi>\<^sub>E i\<in>I. space (M i)) (prod_algebra I M)"
    unfolding `sets M' = sets (PiM I M)` by simp

  def i \<equiv> "SOME i. i \<in> I"
  with `I \<noteq> {}` have i: "i \<in> I"
    by (auto intro: someI_ex)

  def A \<equiv> "\<lambda>n::nat. prod_emb I M {i} (\<Pi>\<^sub>E j\<in>{i}. space (M i))"
  then show "range A \<subseteq> prod_algebra I M"
    by (auto intro!: prod_algebraI i)

  have A_eq: "\<And>i. A i = space (PiM I M)"
    by (auto simp: prod_emb_def space_PiM Pi_iff A_def i)
  show "(\<Union>i. A i) = (\<Pi>\<^sub>E i\<in>I. space (M i))"
    unfolding A_eq by (auto simp: space_PiM)
  show "\<And>i. emeasure (PiM I M) (A i) \<noteq> \<infinity>"
    unfolding A_eq P.emeasure_space_1 by simp
next
  fix X assume X: "X \<in> prod_algebra I M"
  then obtain J E where X: "X = prod_emb I M J (PIE j:J. E j)"
    and J: "finite J" "J \<subseteq> I" "\<And>j. j \<in> J \<Longrightarrow> E j \<in> sets (M j)"
    by (force elim!: prod_algebraE)
  from eq[OF J] have "emeasure M' X = (\<Prod>j\<in>J. emeasure (M j) (E j))"
    by (simp add: X)
  also have "\<dots> = emeasure (PiM I M) X"
    unfolding X using J by (intro emeasure_PiM_emb[symmetric]) auto
  finally show "emeasure (PiM I M) X = emeasure M' X" ..
qed

lemma (in product_prob_space) AE_component: "i \<in> I \<Longrightarrow> AE x in M i. P x \<Longrightarrow> AE x in PiM I M. P (x i)"
  apply (rule AE_distrD[of "\<lambda>\<omega>. \<omega> i" "PiM I M" "M i" P])
  apply simp
  apply (subst PiM_component)
  apply simp_all
  done

subsection {* Sequence space *}

definition comb_seq :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> 'a)" where
  "comb_seq i \<omega> \<omega>' j = (if j < i then \<omega> j else \<omega>' (j - i))"

lemma split_comb_seq: "P (comb_seq i \<omega> \<omega>' j) \<longleftrightarrow> (j < i \<longrightarrow> P (\<omega> j)) \<and> (\<forall>k. j = i + k \<longrightarrow> P (\<omega>' k))"
  by (auto simp: comb_seq_def not_less)

lemma split_comb_seq_asm: "P (comb_seq i \<omega> \<omega>' j) \<longleftrightarrow> \<not> ((j < i \<and> \<not> P (\<omega> j)) \<or> (\<exists>k. j = i + k \<and> \<not> P (\<omega>' k)))"
  by (auto simp: comb_seq_def)

lemma measurable_comb_seq:
  "(\<lambda>(\<omega>, \<omega>'). comb_seq i \<omega> \<omega>') \<in> measurable ((\<Pi>\<^sub>M i\<in>UNIV. M) \<Otimes>\<^sub>M (\<Pi>\<^sub>M i\<in>UNIV. M)) (\<Pi>\<^sub>M i\<in>UNIV. M)"
proof (rule measurable_PiM_single)
  show "(\<lambda>(\<omega>, \<omega>'). comb_seq i \<omega> \<omega>') \<in> space ((\<Pi>\<^sub>M i\<in>UNIV. M) \<Otimes>\<^sub>M (\<Pi>\<^sub>M i\<in>UNIV. M)) \<rightarrow> (UNIV \<rightarrow>\<^sub>E space M)"
    by (auto simp: space_pair_measure space_PiM PiE_iff split: split_comb_seq)
  fix j :: nat and A assume A: "A \<in> sets M"
  then have *: "{\<omega> \<in> space ((\<Pi>\<^sub>M i\<in>UNIV. M) \<Otimes>\<^sub>M (\<Pi>\<^sub>M i\<in>UNIV. M)). case_prod (comb_seq i) \<omega> j \<in> A} =
    (if j < i then {\<omega> \<in> space (\<Pi>\<^sub>M i\<in>UNIV. M). \<omega> j \<in> A} \<times> space (\<Pi>\<^sub>M i\<in>UNIV. M)
              else space (\<Pi>\<^sub>M i\<in>UNIV. M) \<times> {\<omega> \<in> space (\<Pi>\<^sub>M i\<in>UNIV. M). \<omega> (j - i) \<in> A})"
    by (auto simp: space_PiM space_pair_measure comb_seq_def dest: sets.sets_into_space)
  show "{\<omega> \<in> space ((\<Pi>\<^sub>M i\<in>UNIV. M) \<Otimes>\<^sub>M (\<Pi>\<^sub>M i\<in>UNIV. M)). case_prod (comb_seq i) \<omega> j \<in> A} \<in> sets ((\<Pi>\<^sub>M i\<in>UNIV. M) \<Otimes>\<^sub>M (\<Pi>\<^sub>M i\<in>UNIV. M))"
    unfolding * by (auto simp: A intro!: sets_Collect_single)
qed

lemma measurable_comb_seq'[measurable (raw)]:
  assumes f: "f \<in> measurable N (\<Pi>\<^sub>M i\<in>UNIV. M)" and g: "g \<in> measurable N (\<Pi>\<^sub>M i\<in>UNIV. M)"
  shows "(\<lambda>x. comb_seq i (f x) (g x)) \<in> measurable N (\<Pi>\<^sub>M i\<in>UNIV. M)"
  using measurable_compose[OF measurable_Pair[OF f g] measurable_comb_seq] by simp

lemma comb_seq_0: "comb_seq 0 \<omega> \<omega>' = \<omega>'"
  by (auto simp add: comb_seq_def)

lemma comb_seq_Suc: "comb_seq (Suc n) \<omega> \<omega>' = comb_seq n \<omega> (case_nat (\<omega> n) \<omega>')"
  by (auto simp add: comb_seq_def not_less less_Suc_eq le_imp_diff_is_add intro!: ext split: nat.split)

lemma comb_seq_Suc_0[simp]: "comb_seq (Suc 0) \<omega> = case_nat (\<omega> 0)"
  by (intro ext) (simp add: comb_seq_Suc comb_seq_0)

lemma comb_seq_less: "i < n \<Longrightarrow> comb_seq n \<omega> \<omega>' i = \<omega> i"
  by (auto split: split_comb_seq)

lemma comb_seq_add: "comb_seq n \<omega> \<omega>' (i + n) = \<omega>' i"
  by (auto split: nat.split split_comb_seq)

lemma case_nat_comb_seq: "case_nat s' (comb_seq n \<omega> \<omega>') (i + n) = case_nat (case_nat s' \<omega> n) \<omega>' i"
  by (auto split: nat.split split_comb_seq)

lemma case_nat_comb_seq':
  "case_nat s (comb_seq i \<omega> \<omega>') = comb_seq (Suc i) (case_nat s \<omega>) \<omega>'"
  by (auto split: split_comb_seq nat.split)

locale sequence_space = product_prob_space "\<lambda>i. M" "UNIV :: nat set" for M
begin

abbreviation "S \<equiv> \<Pi>\<^sub>M i\<in>UNIV::nat set. M"

lemma infprod_in_sets[intro]:
  fixes E :: "nat \<Rightarrow> 'a set" assumes E: "\<And>i. E i \<in> sets M"
  shows "Pi UNIV E \<in> sets S"
proof -
  have "Pi UNIV E = (\<Inter>i. emb UNIV {..i} (\<Pi>\<^sub>E j\<in>{..i}. E j))"
    using E E[THEN sets.sets_into_space]
    by (auto simp: prod_emb_def Pi_iff extensional_def) blast
  with E show ?thesis by auto
qed

lemma measure_PiM_countable:
  fixes E :: "nat \<Rightarrow> 'a set" assumes E: "\<And>i. E i \<in> sets M"
  shows "(\<lambda>n. \<Prod>i\<le>n. measure M (E i)) ----> measure S (Pi UNIV E)"
proof -
  let ?E = "\<lambda>n. emb UNIV {..n} (Pi\<^sub>E {.. n} E)"
  have "\<And>n. (\<Prod>i\<le>n. measure M (E i)) = measure S (?E n)"
    using E by (simp add: measure_PiM_emb)
  moreover have "Pi UNIV E = (\<Inter>n. ?E n)"
    using E E[THEN sets.sets_into_space]
    by (auto simp: prod_emb_def extensional_def Pi_iff) blast
  moreover have "range ?E \<subseteq> sets S"
    using E by auto
  moreover have "decseq ?E"
    by (auto simp: prod_emb_def Pi_iff decseq_def)
  ultimately show ?thesis
    by (simp add: finite_Lim_measure_decseq)
qed

lemma nat_eq_diff_eq:
  fixes a b c :: nat
  shows "c \<le> b \<Longrightarrow> a = b - c \<longleftrightarrow> a + c = b"
  by auto

lemma PiM_comb_seq:
  "distr (S \<Otimes>\<^sub>M S) S (\<lambda>(\<omega>, \<omega>'). comb_seq i \<omega> \<omega>') = S" (is "?D = _")
proof (rule PiM_eq)
  let ?I = "UNIV::nat set" and ?M = "\<lambda>n. M"
  let "distr _ _ ?f" = "?D"

  fix J E assume J: "finite J" "J \<subseteq> ?I" "\<And>j. j \<in> J \<Longrightarrow> E j \<in> sets M"
  let ?X = "prod_emb ?I ?M J (\<Pi>\<^sub>E j\<in>J. E j)"
  have "\<And>j x. j \<in> J \<Longrightarrow> x \<in> E j \<Longrightarrow> x \<in> space M"
    using J(3)[THEN sets.sets_into_space] by (auto simp: space_PiM Pi_iff subset_eq)
  with J have "?f -` ?X \<inter> space (S \<Otimes>\<^sub>M S) =
    (prod_emb ?I ?M (J \<inter> {..<i}) (PIE j:J \<inter> {..<i}. E j)) \<times>
    (prod_emb ?I ?M ((op + i) -` J) (PIE j:(op + i) -` J. E (i + j)))" (is "_ = ?E \<times> ?F")
   by (auto simp: space_pair_measure space_PiM prod_emb_def all_conj_distrib PiE_iff
               split: split_comb_seq split_comb_seq_asm)
  then have "emeasure ?D ?X = emeasure (S \<Otimes>\<^sub>M S) (?E \<times> ?F)"
    by (subst emeasure_distr[OF measurable_comb_seq])
       (auto intro!: sets_PiM_I simp: split_beta' J)
  also have "\<dots> = emeasure S ?E * emeasure S ?F"
    using J by (intro P.emeasure_pair_measure_Times)  (auto intro!: sets_PiM_I finite_vimageI simp: inj_on_def)
  also have "emeasure S ?F = (\<Prod>j\<in>(op + i) -` J. emeasure M (E (i + j)))"
    using J by (intro emeasure_PiM_emb) (simp_all add: finite_vimageI inj_on_def)
  also have "\<dots> = (\<Prod>j\<in>J - (J \<inter> {..<i}). emeasure M (E j))"
    by (rule setprod.reindex_cong [of "\<lambda>x. x - i"])
       (auto simp: image_iff Bex_def not_less nat_eq_diff_eq ac_simps cong: conj_cong intro!: inj_onI)
  also have "emeasure S ?E = (\<Prod>j\<in>J \<inter> {..<i}. emeasure M (E j))"
    using J by (intro emeasure_PiM_emb) simp_all
  also have "(\<Prod>j\<in>J \<inter> {..<i}. emeasure M (E j)) * (\<Prod>j\<in>J - (J \<inter> {..<i}). emeasure M (E j)) = (\<Prod>j\<in>J. emeasure M (E j))"
    by (subst mult.commute) (auto simp: J setprod.subset_diff[symmetric])
  finally show "emeasure ?D ?X = (\<Prod>j\<in>J. emeasure M (E j))" .
qed simp_all

lemma PiM_iter:
  "distr (M \<Otimes>\<^sub>M S) S (\<lambda>(s, \<omega>). case_nat s \<omega>) = S" (is "?D = _")
proof (rule PiM_eq)
  let ?I = "UNIV::nat set" and ?M = "\<lambda>n. M"
  let "distr _ _ ?f" = "?D"

  fix J E assume J: "finite J" "J \<subseteq> ?I" "\<And>j. j \<in> J \<Longrightarrow> E j \<in> sets M"
  let ?X = "prod_emb ?I ?M J (PIE j:J. E j)"
  have "\<And>j x. j \<in> J \<Longrightarrow> x \<in> E j \<Longrightarrow> x \<in> space M"
    using J(3)[THEN sets.sets_into_space] by (auto simp: space_PiM Pi_iff subset_eq)
  with J have "?f -` ?X \<inter> space (M \<Otimes>\<^sub>M S) = (if 0 \<in> J then E 0 else space M) \<times>
    (prod_emb ?I ?M (Suc -` J) (PIE j:Suc -` J. E (Suc j)))" (is "_ = ?E \<times> ?F")
   by (auto simp: space_pair_measure space_PiM PiE_iff prod_emb_def all_conj_distrib
      split: nat.split nat.split_asm)
  then have "emeasure ?D ?X = emeasure (M \<Otimes>\<^sub>M S) (?E \<times> ?F)"
    by (subst emeasure_distr)
       (auto intro!: sets_PiM_I simp: split_beta' J)
  also have "\<dots> = emeasure M ?E * emeasure S ?F"
    using J by (intro P.emeasure_pair_measure_Times) (auto intro!: sets_PiM_I finite_vimageI)
  also have "emeasure S ?F = (\<Prod>j\<in>Suc -` J. emeasure M (E (Suc j)))"
    using J by (intro emeasure_PiM_emb) (simp_all add: finite_vimageI)
  also have "\<dots> = (\<Prod>j\<in>J - {0}. emeasure M (E j))"
    by (rule setprod.reindex_cong [of "\<lambda>x. x - 1"])
       (auto simp: image_iff Bex_def not_less nat_eq_diff_eq ac_simps cong: conj_cong intro!: inj_onI)
  also have "emeasure M ?E * (\<Prod>j\<in>J - {0}. emeasure M (E j)) = (\<Prod>j\<in>J. emeasure M (E j))"
    by (auto simp: M.emeasure_space_1 setprod.remove J)
  finally show "emeasure ?D ?X = (\<Prod>j\<in>J. emeasure M (E j))" .
qed simp_all

end

end


header "Standard semantics"

theory Eval
  imports HOLCF HOLCFUtils CPSScheme
begin

text {*
We begin by giving the standard semantics for our language. Although this is not actually used to show any results, it is helpful to see that the later algorithms ``look similar'' to the evaluation code and the relation between calls done during evaluation and calls recorded by the control flow graph.
*}

text {*
We follow the definition in Figure 3.1 and 3.2 of Shivers' dissertation, with the clarifications from Section 4.1. As explained previously, our set of values encompasses just the integers, there is no separate value for \textit{false}. Also, values and procedures are not distinguished by the type system.

Due to recursion, one variable can have more than one currently valid binding, and due to closures all bindings can possibly be accessed. A simple call stack is therefore not sufficient. Instead we have a \textit{contour counter}, which is increased in each evaluation step. It can also be thought of as a time counter. The variable environment maps tuples of variables and contour counter to values, thus allowing a variable to have more than one active binding.  A contour environment lists the currently visible binding for each binding position and is preserved when a lambda expression is turned into a closure.
*}

type_synonym contour = nat
type_synonym benv = "label \<rightharpoonup> contour"
type_synonym closure = "lambda \<times> benv"

text {*
The set of semantic values consist of the integers, closures, primitive operations and a special value @{text Stop}. This is passed as an argument to the program and represents the terminal continuation. When this value occurs in the first position of a call, the program terminates.
*}

datatype d = DI int
           | DC closure
           | DP prim
           | Stop

type_synonym venv = "var \<times> contour \<rightharpoonup> d"

text {*
The function @{text \<A>} evaluates a syntactic value into a semantic datum. Constants and primitive operations are left untouched. Variable references are resolved in two stages: First the current binding contour is fetched from the binding environment @{text \<beta>}, then the stored value is fetched from the variable environment @{text ve}. A lambda expression is bundled with the current contour environment to form a closure.
*}

fun evalV :: "val \<Rightarrow> benv \<Rightarrow> venv \<Rightarrow> d" ("\<A>")
  where "\<A> (C _ i) \<beta> ve = DI i"
  |     "\<A> (P prim) \<beta> ve = DP prim"
  |     "\<A> (R _ var) \<beta> ve =
           (case \<beta> (binder var) of
              Some l \<Rightarrow> (case ve (var,l) of Some d \<Rightarrow> d))"
  |     "\<A> (L lam) \<beta> ve = DC (lam, \<beta>)"

text {*
The answer domain of our semantics is the set of integers, lifted to obtain an additional element denoting bottom. Shivers distinguishes runtime errors from non-termination. Here, both are represented by @{text \<bottom>}.
*}

type_synonym ans = "int lift"

text {*
To be able to do case analysis on the custom datatypes @{text lambda}, @{text d}, @{text call} and @{text prim} inside a function defined with @{text fixrec}, we need continuity results for them. These are all of the same shape and proven by case analysis on the discriminator.
*}

lemma cont2cont_case_lambda [simp, cont2cont]:
  assumes "\<And>a b c. cont (\<lambda>x. f x a b c)"
  shows "cont (\<lambda>x. case_lambda (f x) l)"
using assms
by (cases l) auto

lemma cont2cont_case_d [simp, cont2cont]:
  assumes "\<And>y. cont (\<lambda>x. f1 x y)"
     and  "\<And>y. cont (\<lambda>x. f2 x y)"
     and  "\<And>y. cont (\<lambda>x. f3 x y)"
    and   "cont (\<lambda>x. f4 x)"
  shows "cont (\<lambda>x. case_d (f1 x) (f2 x) (f3 x) (f4 x) d)"
using assms
by (cases d) auto

lemma cont2cont_case_call [simp, cont2cont]:
  assumes "\<And>a b c. cont (\<lambda>x. f1 x a b c)"
     and  "\<And>a b c. cont (\<lambda>x. f2 x a b c)"
  shows "cont (\<lambda>x. case_call (f1 x) (f2 x) c)"
using assms
by (cases c) auto

lemma cont2cont_case_prim [simp, cont2cont]:
  assumes "\<And>y. cont (\<lambda>x. f1 x y)"
     and  "\<And>y z. cont (\<lambda>x. f2 x y z)"
  shows "cont (\<lambda>x. case_prim (f1 x) (f2 x) p)"
using assms
by (cases p) auto

text {*
As usual, the semantics of a functional language is given as a denotational semantics. To that end, two functions are defined here: @{text \<F>} applies a procedure to a list of arguments. Here closures are unwrapped, the primitive operations are implemented and the terminal continuation @{text Stop} is handled. @{text \<C>} evaluates a call expression, either by evaluating procedure and arguments and passing them to @{text \<F>}, or by adding the bindings of a @{text Let} expression to the environment.

Note how the contour counter is incremented before each call to @{text \<F>} or when a @{text Let} expression is evaluated.

With mutually recursive equations, such as those given here, the existence of a function satisfying these is not obvious. Therefore, the @{text fixrec} command from the @{theory HOLCF} package is used. This takes a set of equations and builds a functional from that. It mechanically proofs that this functional is continuous and thus a least fixed point exists. This is then used to define @{text \<F>} and @{text \<C>} and proof the equations given here. To use the @{theory HOLCF} setup, the continuous function arrow @{text \<rightarrow>} with application operator @{text \<cdot>} is used and our types are wrapped in @{text discr} and @{text lift} to indicate which partial order is to be used.
*}

type_synonym fstate = "(d \<times> d list \<times> venv \<times> contour)"
type_synonym cstate = "(call \<times> benv \<times> venv \<times> contour)"

fixrec   evalF :: "fstate discr \<rightarrow> ans" ("\<F>")
     and evalC :: "cstate discr \<rightarrow> ans" ("\<C>")
  where "evalF\<cdot>fstate = (case undiscr fstate of
             (DC (Lambda lab vs c, \<beta>), as, ve, b) \<Rightarrow>
               (if length vs = length as
                then let \<beta>' = \<beta> (lab \<mapsto> b);
                         ve' = map_upds ve (map (\<lambda>v.(v,b)) vs) as
                     in \<C>\<cdot>(Discr (c,\<beta>',ve',b))
                else \<bottom>)
            | (DP (Plus c),[DI a1, DI a2, cnt],ve,b) \<Rightarrow>
                     let b' = Suc b;
                         \<beta>  = [c \<mapsto> b]
                     in \<F>\<cdot>(Discr (cnt,[DI (a1 + a2)],ve,b'))
            | (DP (prim.If ct cf),[DI v, contt, contf],ve,b) \<Rightarrow>
                  (if v \<noteq> 0
                   then let b' = Suc b;
                            \<beta> = [ct \<mapsto> b]
                        in \<F>\<cdot>(Discr (contt,[],ve,b'))
                   else let b' = Suc b;
                            \<beta> = [cf \<mapsto> b]
                        in \<F>\<cdot>(Discr (contf,[],ve,b')))
            | (Stop,[DI i],_,_) \<Rightarrow> Def i
            | _ \<Rightarrow> \<bottom>
        )"
      | "\<C>\<cdot>cstate = (case undiscr cstate of
             (App lab f vs,\<beta>,ve,b) \<Rightarrow>
                 let f' = \<A> f \<beta> ve;
                     as = map (\<lambda>v. \<A> v \<beta> ve) vs;
                     b' = Suc b
                  in \<F>\<cdot>(Discr (f',as,ve,b'))
            | (Let lab ls c',\<beta>,ve,b) \<Rightarrow>
                 let b' = Suc b;
                     \<beta>' = \<beta> (lab \<mapsto> b');
                    ve' = ve ++ map_of (map (\<lambda>(v,l). ((v,b'), \<A> (L l) \<beta>' ve)) ls)
                 in \<C>\<cdot>(Discr (c',\<beta>',ve',b'))
        )"

text {*
To evaluate a full program, it is passed to @{text \<F>} with proper initializations of the other arguments. We test our semantics function against two example programs and observe that the expected value is returned.
*}

definition evalCPS :: "prog \<Rightarrow> ans" ("\<PR>")
  where "\<PR> l = (let ve = empty;
                          \<beta> = empty;
                          f = \<A> (L l) \<beta> ve
                      in  \<F>\<cdot>(Discr (f,[Stop],ve,0)))"

lemma correct_ex1: "\<PR> ex1 = Def 0"
unfolding evalCPS_def
by simp

lemma correct_ex2: "\<PR> ex2 = Def 2"
unfolding evalCPS_def
by simp

(* (The third example takes long to finish, thus is it not ran by default.)
lemma correct_ex3: "evalCPS ex3 = Def 55"
oops
unfolding evalCPS_def
by simp
*)

end


subsection\<open>Peirce\<close>

theory Peirce
  imports Types
begin

text\<open>As an example of our $\lambda\mu$ formalisation, we show show a
     $\lambda\mu$-term inhabiting Peirce's Law. The example is due to
     Parigot~\cite{DBLP:conf/lpar/Parigot92}.\<close>

text\<open>Peirce's law: $((A \rightarrow B) \rightarrow A) \rightarrow A$.\<close>

lemma "\<Gamma>, \<Delta> \<turnstile>\<^sub>T \<lambda> (A\<rightarrow>B)\<rightarrow>A: (\<mu> A:(<0>((`0) \<degree> (\<lambda> A: (\<mu> B:(<1> (`0)))))))
    : ((A\<rightarrow>B)\<rightarrow>A)\<rightarrow>A"
  by fastforce

end