(*  Title:      OpSem.thy
    Author:     Peter Gammie
*)

section \<open>Logical relations for computational adequacy\<close>
(*<*)

theory OpSem
imports
  Basis
  PCF
begin

(* FIXME

Show Sangiorgi's divergence results. Convergence should be simply the
big-step semantics.

*)
(*>*)
text\<open>

\label{sec:opsem}

We relate the denotational semantics for PCF of \S\ref{sec:densem} to
a \emph{big-step} (or \emph{natural}) operational semantics. This
follows \citet{DBLP:conf/mfps/Pitts93}.

\<close>

subsection\<open>Direct semantics using de Bruijn notation\<close>

text\<open>

\label{sec:directsem_db}

In contrast to \S\ref{sec:directsem} we must be more careful in our
treatment of \<open>\<alpha>\<close>-equivalent terms, as we would like our
operational semantics to identify of all these. To that end we adopt
de Bruijn notation, adapting the work of
\citet{DBLP:journals/jar/Nipkow01}, and show that it is suitably
equivalent to our original syntactic story.

\<close>

datatype db =
    DBVar var
  | DBApp db db
  | DBAbsN db
  | DBAbsV db
  | DBDiverge
  | DBFix db
  | DBtt
  | DBff
  | DBCond db db db
  | DBNum nat
  | DBSucc db
  | DBPred db
  | DBIsZero db

text\<open>

Nipkow et al's substitution operation is defined for arbitrary open
terms. In our case we only substitute closed terms into terms where
only the variable @{term "0"} may be free, and while we could develop
a simpler account, we retain the traditional one.

\<close>

fun
  lift :: "db \<Rightarrow> nat \<Rightarrow> db"
where
  "lift (DBVar i) k = DBVar (if i < k then i else (i + 1))"
| "lift (DBAbsN s) k = DBAbsN (lift s (k + 1))"
| "lift (DBAbsV s) k = DBAbsV (lift s (k + 1))"
| "lift (DBApp s t) k = DBApp (lift s k) (lift t k)"
| "lift (DBFix e) k = DBFix (lift e (k + 1))"
| "lift (DBCond c t e) k = DBCond (lift c k) (lift t k) (lift e k)"
| "lift (DBSucc e) k = DBSucc (lift e k)"
| "lift (DBPred e) k = DBPred (lift e k)"
| "lift (DBIsZero e) k = DBIsZero (lift e k)"
| "lift x k = x"

fun
  subst :: "db \<Rightarrow> db \<Rightarrow> var \<Rightarrow> db"  ("_<_'/_>" [300, 0, 0] 300)
where
  subst_Var: "(DBVar i)<s/k> =
      (if k < i then DBVar (i - 1) else if i = k then s else DBVar i)"
| subst_AbsN: "(DBAbsN t)<s/k> = DBAbsN (t<lift s 0 / k+1>)"
| subst_AbsV: "(DBAbsV t)<s/k> = DBAbsV (t<lift s 0 / k+1>)"
| subst_App: "(DBApp t u)<s/k> = DBApp (t<s/k>) (u<s/k>)"
| "(DBFix e)<s/k> = DBFix (e<lift s 0 / k+1>)"
| "(DBCond c t e)<s/k> = DBCond (c<s/k>) (t<s/k>) (e<s/k>)"
| "(DBSucc e)<s/k> = DBSucc (e<s/k>)"
| "(DBPred e)<s/k> = DBPred (e<s/k>)"
| "(DBIsZero e)<s/k> = DBIsZero (e<s/k>)"
| subst_Consts: "x<s/k> = x"
(*<*)

declare subst_Var [simp del]

lemma subst_eq: "(DBVar k)<u/k> = u"
  by (simp add: subst_Var)

lemma subst_gt: "i < j \<Longrightarrow> (DBVar j)<u/i> = DBVar (j - 1)"
  by (simp add: subst_Var)

lemma subst_lt: "j < i \<Longrightarrow> (DBVar j)<u/i> = DBVar j"
  by (simp add: subst_Var)

lemma lift_lift:
    "i < k + 1 \<Longrightarrow> lift (lift t i) (Suc k) = lift (lift t k) i"
  by (induct t arbitrary: i k) auto

lemma lift_subst:
    "j < i + 1 \<Longrightarrow> lift (t<s/j>) i = (lift t (i + 1))<lift s i / j>"
  by (induct t arbitrary: i j s)
     (simp_all add: diff_Suc subst_Var lift_lift split: nat.split)

lemma lift_subst_lt:
    "i < j + 1 \<Longrightarrow> lift (t<s/j>) i = (lift t i)<lift s i / j + 1>"
  by (induct t arbitrary: i j s) (auto simp: subst_Var lift_lift)

lemma subst_lift:
    "(lift t k)<s/k> = t"
  by (induct t arbitrary: k s) (simp_all add: subst_eq subst_gt subst_lt)

lemmas subst_simps [simp] =
  subst_eq
  subst_gt
  subst_lt
  lift_subst
  subst_lift

lemma subst_subst:
    "i < j + 1 \<Longrightarrow> t<lift v i/Suc j><u<v/j>/i> = t<u/i><v/j>"
  by (induct t arbitrary: i j u v)
     (simp_all add: diff_Suc subst_Var lift_lift [symmetric] lift_subst_lt
             split: nat.split)

(*>*)
text\<open>

We elide the standard lemmas about these operations.

A variable is free in a de Bruijn term in the standard way.

\<close>

fun
  freedb :: "db \<Rightarrow> var \<Rightarrow> bool"
where
  "freedb (DBVar j) k = (j = k)"
| "freedb (DBAbsN s) k = freedb s (k + 1)"
| "freedb (DBAbsV s) k = freedb s (k + 1)"
| "freedb (DBApp s t) k = (freedb s k \<or> freedb t k)"
| "freedb (DBFix e) k = freedb e (Suc k)"
| "freedb (DBCond c t e) k = (freedb c k \<or> freedb t k \<or> freedb e k)"
| "freedb (DBSucc e) k = freedb e k"
| "freedb (DBPred e) k = freedb e k "
| "freedb (DBIsZero e) k = freedb e k"
| "freedb _ _ = False"
(*<*)

lemma subst_not_free [simp]: "\<not> freedb s i \<Longrightarrow> s<t/i> = s<u/i>"
  by (induct s arbitrary: i t u) (simp_all add: subst_Var)

lemma free_lift [simp]:
  "freedb (lift t k) i \<longleftrightarrow> (i < k \<and> freedb t i \<or> k < i \<and> freedb t (i - 1))"
  by (induct t arbitrary: i k) (auto cong: conj_cong)

lemma free_subst [simp]:
  "freedb (s<t/k>) i \<longleftrightarrow> (freedb s k \<and> freedb t i \<or> freedb s (if i < k then i else i + 1))"
by (induct s arbitrary: i k t) (auto simp:  subst_Var split: nat.split)

theorem lift_subst_dummy:
  "\<not> freedb s i \<Longrightarrow> lift (s<dummy/i>) i = s"
by (induct s arbitrary: i dummy) (simp_all add: not_less_eq if_not_P)

lemma closed_lift:
  "\<forall>v. freedb e v \<longrightarrow> v < k \<Longrightarrow> lift e k = e"
by (induct e arbitrary: k) (simp; metis less_Suc_eq_0_disj nat.exhaust)+

lemma closed_subst:
  assumes "\<forall>v. freedb e v \<longrightarrow> v < k"
  shows "e<s/k> = e"
using assms
proof(induct e arbitrary: s k)
  case (DBAbsN e) then show ?case by simp (metis lessE not_less_eq)
next
  case (DBAbsV e) then show ?case by simp (metis lessE not_less_eq)
next
  case (DBFix e) then show ?case by simp (metis lessE not_less_eq)
qed simp_all

(*>*)
text\<open>Programs are closed expressions.\<close>

definition closed :: "db \<Rightarrow> bool" where
  "closed e \<equiv> \<forall>i. \<not> freedb e i"
(*<*)

lemma closed_inv:
  "closed (DBApp f x) \<longleftrightarrow> closed f \<and> closed x"
  "closed DBDiverge"
  "closed DBtt"
  "closed DBff"
  "closed (DBCond c t e) \<longleftrightarrow> closed c \<and> closed t \<and> closed e"
  "closed (DBNum n)"
  "closed (DBSucc e) \<longleftrightarrow> closed e"
  "closed (DBPred e) \<longleftrightarrow> closed e"
  "closed (DBIsZero e) \<longleftrightarrow> closed e"
  unfolding closed_def by auto

lemma closed_binders:
  "closed (DBAbsN e) \<longleftrightarrow> (\<forall>i. freedb e i \<longrightarrow> i = 0)"
  "closed (DBAbsV e) \<longleftrightarrow> (\<forall>i. freedb e i \<longrightarrow> i = 0)"
  "closed (DBFix e) \<longleftrightarrow> (\<forall>i. freedb e i \<longrightarrow> i = 0)"
  unfolding closed_def
  apply auto
  apply (case_tac i, auto)+
  done

lemmas closed_invs [iff] =
  closed_inv
  closed_binders

(*>*)
text\<open>

The direct denotational semantics is almost identical to that given in
\S\ref{sec:densem}, apart from this change in the representation of
environments.

\<close>

definition env_empty_db :: "'a Env" where
  "env_empty_db \<equiv> \<bottom>"

definition env_ext_db :: "'a \<rightarrow> 'a Env \<rightarrow> 'a Env" where
  "env_ext_db \<equiv> \<Lambda> x \<rho> v. (case v of 0 \<Rightarrow> x | Suc v' \<Rightarrow> \<rho>\<cdot>v')"
(*<*)

lemma env_ext_same_db: "env_ext_db\<cdot>x\<cdot>\<rho>\<cdot>0 = x"
  by (simp add: env_ext_db_def)

lemma env_ext_neq_db: "env_ext_db\<cdot>x\<cdot>\<rho>\<cdot>(Suc v) = \<rho>\<cdot>v"
  by (simp add: env_ext_db_def)

lemmas env_ext_db_simps [simp] =
  env_ext_same_db
  env_ext_neq_db
(*>*)
text\<open>\<close>

primrec
  evalDdb :: "db \<Rightarrow> ValD Env \<rightarrow> ValD"
where
  "evalDdb (DBVar i) = (\<Lambda> \<rho>. \<rho>\<cdot>i)"
| "evalDdb (DBApp f x) = (\<Lambda> \<rho>. appF\<cdot>(evalDdb f\<cdot>\<rho>)\<cdot>(evalDdb x\<cdot>\<rho>))"
| "evalDdb (DBAbsN e) = (\<Lambda> \<rho>. ValF\<cdot>(\<Lambda> x. evalDdb e\<cdot>(env_ext_db\<cdot>x\<cdot>\<rho>)))"
| "evalDdb (DBAbsV e) = (\<Lambda> \<rho>. ValF\<cdot>(strictify\<cdot>(\<Lambda> x. evalDdb e\<cdot>(env_ext_db\<cdot>x\<cdot>\<rho>))))"
| "evalDdb (DBDiverge) = (\<Lambda> \<rho>. \<bottom>)"
| "evalDdb (DBFix e) = (\<Lambda> \<rho>. \<mu> x. evalDdb e\<cdot>(env_ext_db\<cdot>x\<cdot>\<rho>))"
| "evalDdb (DBtt) = (\<Lambda> \<rho>. ValTT)"
| "evalDdb (DBff) = (\<Lambda> \<rho>. ValFF)"
| "evalDdb (DBCond c t e) = (\<Lambda> \<rho>. cond\<cdot>(evalDdb c\<cdot>\<rho>)\<cdot>(evalDdb t\<cdot>\<rho>)\<cdot>(evalDdb e\<cdot>\<rho>))"
| "evalDdb (DBNum n) = (\<Lambda> \<rho>. ValN\<cdot>n)"
| "evalDdb (DBSucc e) = (\<Lambda> \<rho>. succ\<cdot>(evalDdb e\<cdot>\<rho>))"
| "evalDdb (DBPred e) = (\<Lambda> \<rho>. pred\<cdot>(evalDdb e\<cdot>\<rho>))"
| "evalDdb (DBIsZero e) = (\<Lambda> \<rho>. isZero\<cdot>(evalDdb e\<cdot>\<rho>))"
(*<*)

(* This proof is trivial but Isabelle doesn't seem keen enough to
apply the induction hypothesises in the obvious ways. *)
lemma evalDdb_env_cong:
  assumes "\<forall>v. freedb e v \<longrightarrow> \<rho>\<cdot>v = \<rho>'\<cdot>v"
  shows "evalDdb e\<cdot>\<rho> = evalDdb e\<cdot>\<rho>'"
using assms
proof(induct e arbitrary: \<rho> \<rho>')
  case (DBApp e1 e2 \<rho> \<rho>')
  from DBApp.hyps[where \<rho>=\<rho> and \<rho>'=\<rho>'] DBApp.prems show ?case by simp
next
  case (DBAbsN e \<rho> \<rho>')
  { fix x
    from DBAbsN.hyps[where \<rho>="env_ext_db\<cdot>x\<cdot>\<rho>" and \<rho>'="env_ext_db\<cdot>x\<cdot>\<rho>'"] DBAbsN.prems
    have "evalDdb e\<cdot>(env_ext_db\<cdot>x\<cdot>\<rho>) = evalDdb e\<cdot>(env_ext_db\<cdot>x\<cdot>\<rho>')"
      by (simp add: env_ext_db_def split: nat.splits) }
  then show ?case by simp
next
  case (DBAbsV e \<rho> \<rho>')
  { fix x
    from DBAbsV.hyps[where \<rho>="env_ext_db\<cdot>x\<cdot>\<rho>" and \<rho>'="env_ext_db\<cdot>x\<cdot>\<rho>'"] DBAbsV.prems
    have "evalDdb e\<cdot>(env_ext_db\<cdot>x\<cdot>\<rho>) = evalDdb e\<cdot>(env_ext_db\<cdot>x\<cdot>\<rho>')"
      by (simp add: env_ext_db_def split: nat.splits) }
  then show ?case by simp
next
  case (DBFix e \<rho> \<rho>') then show ?case
    by simp (rule parallel_fix_ind, simp_all add: env_ext_db_def split: nat.splits)
next
  case (DBCond i t e \<rho> \<rho>')
  from DBCond.hyps[where \<rho>=\<rho> and \<rho>'=\<rho>'] DBCond.prems show ?case by simp
next
  case (DBSucc e \<rho> \<rho>')
  from DBSucc.hyps[where \<rho>=\<rho> and \<rho>'=\<rho>'] DBSucc.prems show ?case by simp
next
  case (DBPred e \<rho> \<rho>')
  from DBPred.hyps[where \<rho>=\<rho> and \<rho>'=\<rho>'] DBPred.prems show ?case by simp
next
  case (DBIsZero e \<rho> \<rho>')
  from DBIsZero.hyps[where \<rho>=\<rho> and \<rho>'=\<rho>'] DBIsZero.prems show ?case by simp
qed (auto simp: cfun_eq_iff)

lemma evalDdb_env_closed:
  assumes "closed e"
  shows "evalDdb e\<cdot>\<rho> = evalDdb e\<cdot>\<rho>'"
by (rule evalDdb_env_cong) (simp add: assms[unfolded closed_def])

(*>*)
text\<open>

We show that our direct semantics using de Bruijn notation coincides
with the evaluator of \S\ref{sec:directsem} by translating between the
syntaxes and showing that the evaluators yield identical results.

Firstly we show how to translate an expression using names into a
nameless term. The following function finds the first mention of a
variable in a list of variables.

\<close>

primrec index :: "var list \<Rightarrow> var \<Rightarrow> nat \<Rightarrow> nat" where
  "index [] v n = n"
| "index (h # t) v n = (if v = h then n else index t v (Suc n))"

primrec
  transdb :: "expr \<Rightarrow> var list \<Rightarrow> db"
where
  "transdb (Var i) \<Gamma> = DBVar (index \<Gamma> i 0)"
| "transdb (App t1 t2) \<Gamma> = DBApp (transdb t1 \<Gamma>) (transdb t2 \<Gamma>)"
| "transdb (AbsN v t) \<Gamma> = DBAbsN (transdb t (v # \<Gamma>))"
| "transdb (AbsV v t) \<Gamma> = DBAbsV (transdb t (v # \<Gamma>))"
| "transdb (Diverge) \<Gamma> = DBDiverge"
| "transdb (Fix v e) \<Gamma> = DBFix (transdb e (v # \<Gamma>))"
| "transdb (tt) \<Gamma> = DBtt"
| "transdb (ff) \<Gamma> = DBff"
| "transdb (Cond c t e) \<Gamma> = DBCond (transdb c \<Gamma>) (transdb t \<Gamma>) (transdb e \<Gamma>)"
| "transdb (Num n) \<Gamma> = (DBNum n)"
| "transdb (Succ e) \<Gamma> = DBSucc (transdb e \<Gamma>)"
| "transdb (Pred e) \<Gamma> = DBPred (transdb e \<Gamma>)"
| "transdb (IsZero e) \<Gamma> = DBIsZero (transdb e \<Gamma>)"

text\<open>

This semantics corresponds with the direct semantics for named
expressions.

\<close>
(*<*)
text\<open>The free variables of an expression using names.\<close>

fun
  free :: "expr \<Rightarrow> var list"
where
  "free (Var v) = [v]"
| "free (App f x) = free f @ free x"
| "free (AbsN v e) = removeAll v (free e)"
| "free (AbsV v e) = removeAll v (free e)"
| "free (Fix v e) = removeAll v (free e)"
| "free (Cond c t e) = free c @ free t @ free e"
| "free (Succ e) = free e"
| "free (Pred e) = free e"
| "free (IsZero e) = free e"
| "free _ = []"

lemma index_Suc:
  "index \<Gamma> v (Suc i) = Suc (index \<Gamma> v i)"
  by (induct \<Gamma> arbitrary: i) simp_all

lemma evalD_evalDdb_open:
  assumes "set (free e) \<subseteq> set \<Gamma>"
  assumes "\<forall>v \<in> set \<Gamma>. \<rho>'\<cdot>(index \<Gamma> v 0) = \<rho>\<cdot>v"
  shows "\<lbrakk>e\<rbrakk>\<rho> = evalDdb (transdb e \<Gamma>)\<cdot>\<rho>'"
using assms
proof(induct e arbitrary: \<Gamma> \<rho> \<rho>')
  case AbsN then show ?case
    apply (clarsimp simp: cfun_eq_iff)
    apply (subst AbsN.hyps)
    apply (auto simp: cfun_eq_iff env_ext_db_def index_Suc)
    done
next
  case AbsV then show ?case
    apply (clarsimp simp: cfun_eq_iff)
    apply (case_tac "x=\<bottom>")
     apply simp
    apply simp
    apply (subst AbsV.hyps)
    apply (auto simp: cfun_eq_iff env_ext_db_def index_Suc)
    done
next
  case Fix then show ?case
    apply (clarsimp simp: cfun_eq_iff)
    apply (rule parallel_fix_ind)
      apply simp
     apply simp
    apply simp
    apply (subst Fix.hyps)
    apply (auto simp: cfun_eq_iff env_ext_db_def index_Suc)
    done
qed auto

(*>*)
lemma evalD_evalDdb:
  assumes "free e = []"
  shows "\<lbrakk>e\<rbrakk>\<rho> = evalDdb (transdb e [])\<cdot>\<rho>"
  using assms by (simp add: evalD_evalDdb_open)

text\<open>

Conversely, all de Bruijn expressions have named equivalents.

\<close>

primrec
  transdb_inv :: "db \<Rightarrow> (var \<Rightarrow> var) \<Rightarrow> var \<Rightarrow> var \<Rightarrow> expr"
where
  "transdb_inv (DBVar i) \<Gamma> c k = Var (\<Gamma> i)"
| "transdb_inv (DBApp t1 t2) \<Gamma> c k = App (transdb_inv t1 \<Gamma> c k) (transdb_inv t2 \<Gamma> c k)"
| "transdb_inv (DBAbsN e) \<Gamma> c k = AbsN (c + k) (transdb_inv e (case_nat (c + k) \<Gamma>) c (k + 1))"
| "transdb_inv (DBAbsV e) \<Gamma> c k = AbsV (c + k) (transdb_inv e (case_nat (c + k) \<Gamma>) c (k + 1))"
| "transdb_inv (DBDiverge) \<Gamma> c k = Diverge"
| "transdb_inv (DBFix e) \<Gamma> c k = Fix (c + k) (transdb_inv e (case_nat (c + k) \<Gamma>) c (k + 1))"
| "transdb_inv (DBtt) \<Gamma> c k = tt"
| "transdb_inv (DBff) \<Gamma> c k = ff"
| "transdb_inv (DBCond i t e) \<Gamma> c k =
                     Cond (transdb_inv i \<Gamma> c k) (transdb_inv t \<Gamma> c k) (transdb_inv e \<Gamma> c k)"
| "transdb_inv (DBNum n) \<Gamma> c k = (Num n)"
| "transdb_inv (DBSucc e) \<Gamma> c k = Succ (transdb_inv e \<Gamma> c k)"
| "transdb_inv (DBPred e) \<Gamma> c k = Pred (transdb_inv e \<Gamma> c k)"
| "transdb_inv (DBIsZero e) \<Gamma> c k = IsZero (transdb_inv e \<Gamma> c k)"
(*<*)

(* FIXME These proofs are ghastly. Is there a better way to do this? *)

lemma transdb_inv_open:
  assumes "\<forall>v. freedb e v \<longrightarrow> v < c + k"
  assumes "\<forall>v. freedb e v \<longrightarrow> \<Gamma> v = (if k \<le> v then v - k else c + k - v - 1)"
  assumes "\<forall>v. freedb e v \<longrightarrow> (if k \<le> v then index \<Gamma>' (v - k) 0 = v else index \<Gamma>' (c + k - v - 1) 0 = v)"
  shows "transdb (transdb_inv e \<Gamma> c k) \<Gamma>' = e"
using assms
proof(induct e arbitrary: \<Gamma> \<Gamma>' k)
  case DBVar then show ?case by (simp split: if_splits)
next
  case (DBApp e1 e2 \<Gamma> \<Gamma>') then show ?case
    apply -
    apply (drule_tac x=k in meta_spec)+
    apply (drule_tac x=\<Gamma> in meta_spec, drule_tac x=\<Gamma>' in meta_spec)+
    apply auto
    done
next
  case (DBAbsN e \<Gamma> \<Gamma>' k) show ?case
    apply simp
    apply (rule DBAbsN.hyps)

    using DBAbsN
    apply clarsimp
    apply (case_tac v)
     apply simp
    apply simp

    using DBAbsN
    apply (clarsimp split: nat.split)

    using DBAbsN
    apply clarsimp
    apply (case_tac v)
    apply (auto simp: index_Suc)
    done
next
  case (DBAbsV e \<Gamma> \<Gamma>' k) show ?case
    apply simp
    apply (rule DBAbsV.hyps)

    using DBAbsV
    apply clarsimp
    apply (case_tac v)
     apply simp
    apply simp

    using DBAbsV
    apply (clarsimp split: nat.split)

    using DBAbsV
    apply clarsimp
    apply (case_tac v)
    apply (auto simp: index_Suc)
    done
next
  case (DBFix e \<Gamma> \<Gamma>' k) show ?case
    apply simp
    apply (rule DBFix.hyps)

    using DBFix
    apply clarsimp
    apply (case_tac v)
     apply simp
    apply simp

    using DBFix
    apply (clarsimp split: nat.split)

    using DBFix
    apply clarsimp
    apply (case_tac v)
    apply (auto simp: index_Suc)
    done
next
  case (DBCond i t e \<Gamma> \<Gamma>' k) then show ?case
    apply -
    apply (drule_tac x=k in meta_spec)+
    apply (drule_tac x=\<Gamma> in meta_spec, drule_tac x=\<Gamma>' in meta_spec)+
    apply auto
    done
qed simp_all

(*>*)
text\<open>\<close>

lemma transdb_inv:
  assumes "closed e"
  shows "transdb (transdb_inv e \<Gamma> c k) \<Gamma>' = e"
(*<*)
  using transdb_inv_open assms
  unfolding closed_def by simp

lemma closed_transdb_inv_aux:
  assumes "\<forall>v. freedb e v \<longrightarrow> v < k"
  assumes "\<forall>v. freedb e v \<longrightarrow> \<Gamma> v = k - v - 1"
  shows "i \<in> set (free (transdb_inv e \<Gamma> 0 k)) \<longleftrightarrow> (i < k \<and> freedb e (k - i - 1))"
using assms
proof(induct e arbitrary: \<Gamma> k)
  case (DBAbsN e \<Gamma> k) then show ?case
    apply -
    apply (drule_tac x="Suc k" in meta_spec)
    apply (drule_tac x="case_nat k \<Gamma>" in meta_spec)
    apply simp
    apply (subgoal_tac "\<forall>v. freedb e v \<longrightarrow> v < Suc k")
     apply (subgoal_tac "\<forall>v. freedb e v \<longrightarrow> case_nat k \<Gamma> v = k - v")
      apply rule
       apply (subgoal_tac "Suc (k - Suc i) = k - i")
        apply simp
       apply auto[1]
      apply (subgoal_tac "Suc (k - Suc i) = k - i")
       apply auto[1]
      apply auto[1]
     apply (auto split: nat.splits)[1]
    apply clarsimp
    apply (case_tac v)
     apply simp
    apply simp
    done
next
  case (DBAbsV e \<Gamma> k) then show ?case
    apply -
    apply (drule_tac x="Suc k" in meta_spec)
    apply (drule_tac x="case_nat k \<Gamma>" in meta_spec)
    apply simp
    apply (subgoal_tac "\<forall>v. freedb e v \<longrightarrow> v < Suc k")
     apply (subgoal_tac "\<forall>v. freedb e v \<longrightarrow> case_nat k \<Gamma> v = k - v")
      apply rule
       apply (subgoal_tac "Suc (k - Suc i) = k - i")
        apply simp
       apply auto[1]
      apply (subgoal_tac "Suc (k - Suc i) = k - i")
       apply auto[1]
      apply auto[1]
     apply (auto split: nat.splits)[1]
    apply clarsimp
    apply (case_tac v)
     apply simp
    apply simp
    done
next
  case (DBFix e \<Gamma> k) then show ?case
    apply -
    apply (drule_tac x="Suc k" in meta_spec)
    apply (drule_tac x="case_nat k \<Gamma>" in meta_spec)
    apply simp
    apply (subgoal_tac "\<forall>v. freedb e v \<longrightarrow> v < Suc k")
     apply (subgoal_tac "\<forall>v. freedb e v \<longrightarrow> case_nat k \<Gamma> v = k - v")
      apply rule
       apply (subgoal_tac "Suc (k - Suc i) = k - i")
        apply simp
       apply auto[1]
      apply (subgoal_tac "Suc (k - Suc i) = k - i")
       apply auto[1]
      apply auto[1]
     apply (auto split: nat.splits)[1]
    apply clarsimp
    apply (case_tac v)
     apply simp
    apply simp
    done
qed auto

lemma closed_transdb_inv:
  assumes "closed e"
  shows "free (transdb_inv e \<Gamma> 0 0) = []"
  using assms closed_transdb_inv_aux[where e=e and k=0 and \<Gamma>=\<Gamma>]
  unfolding closed_def by fastforce

(*>*)

subsection\<open>Operational Semantics\<close>

text \<open>

The evaluation relation (big-step, or natural operational
semantics). This is similar to \citet[\S6.2]{Gunter:1992},
\citet{DBLP:conf/mfps/Pitts93} and \citet[Chapter~11]{Winskel:1993}.

We firstly define the \emph{values} that expressions can evaluate to:
these are either constants or closed abstractions.

\<close>

inductive
  val :: "db \<Rightarrow> bool"
where
  v_Num[intro]: "val (DBNum n)"
| v_FF[intro]:  "val DBff"
| v_TT[intro]:  "val DBtt"
| v_AbsN[intro]: "val (DBAbsN e)"
| v_AbsV[intro]: "val (DBAbsV e)"

inductive
  evalOP :: "db \<Rightarrow> db \<Rightarrow> bool" ("_ \<Down> _" [50,50] 50)
where
  evalOP_AppN[intro]:  "\<lbrakk> P \<Down> DBAbsN M; M<Q/0> \<Down> V \<rbrakk> \<Longrightarrow> DBApp P Q \<Down> V" (* Non-strict application *)
| evalOP_AppV[intro]:  "\<lbrakk> P \<Down> DBAbsV M; Q \<Down> q; M<q/0> \<Down> V \<rbrakk> \<Longrightarrow> DBApp P Q \<Down> V" (* Strict application *)
| evalOP_AbsN[intro]:  "val (DBAbsN e) \<Longrightarrow> DBAbsN e \<Down> DBAbsN e"
| evalOP_AbsV[intro]:  "val (DBAbsV e) \<Longrightarrow> DBAbsV e \<Down> DBAbsV e"
| evalOP_Fix[intro]: "P<DBFix P/0> \<Down> V \<Longrightarrow> DBFix P \<Down> V" (* Non-strict fix *)
| evalOP_tt[intro]:  "DBtt \<Down> DBtt"
| evalOP_ff[intro]:  "DBff \<Down> DBff"
| evalOP_CondTT[intro]: "\<lbrakk> C \<Down> DBtt; T \<Down> V \<rbrakk> \<Longrightarrow> DBCond C T E \<Down> V"
| evalOP_CondFF[intro]: "\<lbrakk> C \<Down> DBff; E \<Down> V \<rbrakk> \<Longrightarrow> DBCond C T E  \<Down> V"
| evalOP_Num[intro]:  "DBNum n \<Down> DBNum n"
| evalOP_Succ[intro]: "P \<Down> DBNum n \<Longrightarrow> DBSucc P \<Down> DBNum (Suc n)"
| evalOP_Pred[intro]: "P \<Down> DBNum (Suc n) \<Longrightarrow> DBPred P \<Down> DBNum n"
| evalOP_IsZeroTT[intro]: "\<lbrakk> E \<Down> DBNum 0 \<rbrakk> \<Longrightarrow> DBIsZero E \<Down> DBtt"
| evalOP_IsZeroFF[intro]: "\<lbrakk> E \<Down> DBNum n; 0 < n \<rbrakk> \<Longrightarrow> DBIsZero E \<Down> DBff"

text\<open>

It is straightforward to show that this relation is deterministic and
sound with respect to the denotational semantics.

\<close>
(*<*)

inductive_cases evalOP_inv [elim]:
  "DBApp P Q \<Down> v"
  "DBAbsN e \<Down> v"
  "DBAbsV e \<Down> v"
  "DBFix P \<Down> v"
  "DBtt \<Down> v"
  "DBff \<Down> v"
  "DBCond C T E \<Down> v"
  "DBNum n \<Down> v"
  "DBSucc E \<Down> v"
  "DBPred E \<Down> v"
  "DBIsZero E \<Down> v"

lemma eval_val:
  assumes "val t"
  shows "t \<Down> t"
using assms by induct blast+

lemma eval_to [iff]:
  assumes "t \<Down> t'"
  shows "val t'"
using assms by induct blast+

lemma evalOP_deterministic:
  assumes "P \<Down> V"
  assumes "P \<Down> V'"
  shows "V = V'"
using assms
proof(induct arbitrary: V' rule: evalOP.induct)
  case evalOP_AppV then show ?case by (metis db.distinct(47) db.inject(4) evalOP_inv(1))
qed blast+

lemma evalOP_closed:
  assumes "P \<Down> V"
  assumes "closed P"
  shows "closed V"
using assms
apply induct
apply auto
using closed_def apply force+
done

text\<open>The denotational semantics respects substitution.\<close>

lemma evalDdb_lift [simp]:
  "evalDdb (lift s k)\<cdot>\<rho> = evalDdb s\<cdot>(\<Lambda> i. if i < k then \<rho>\<cdot>i else \<rho>\<cdot>(Suc i))"
proof(induct s arbitrary: k \<rho>)
  case DBAbsN then show ?case
    apply (clarsimp simp: cfun_eq_iff env_ext_db_def)
    apply (rule cfun_arg_cong)
    apply (auto split: nat.split simp: cfun_eq_iff)
    done
next
  case DBAbsV then show ?case
    apply (clarsimp simp: cfun_eq_iff env_ext_db_def)
    apply (case_tac "x=\<bottom>")
     apply simp
    apply (intro cfun_cong)
    apply (auto split: nat.split simp: cfun_eq_iff cong: cfun_cong)
    apply (intro cfun_cong) (* FIXME weird *)
    apply (auto split: nat.split simp: cfun_eq_iff cong: cfun_cong)
    done
next
  case (DBFix s k \<rho>) then show ?case
    apply (clarsimp simp: cfun_eq_iff env_ext_db_def)
    apply (rule parallel_fix_ind)
      apply simp
     apply simp
    apply simp
    apply (rule cfun_arg_cong)
    apply (auto split: nat.split simp: cfun_eq_iff)
    done
qed simp_all

lemma evalDdb_subst:
  "evalDdb (e<s/x>)\<cdot>\<rho> = evalDdb e\<cdot>(\<Lambda> i. if x < i then \<rho>\<cdot>(i - 1) else if i = x then evalDdb s\<cdot>\<rho> else \<rho>\<cdot>i)"
proof(induct e arbitrary: s x \<rho>)
  case (DBFix e s x \<rho>) then show ?case
    apply (simp only: evalDdb.simps subst.simps)
    apply (rule parallel_fix_ind)
    apply (auto simp: cfun_eq_iff eta_cfun env_ext_db_def split: nat.split intro!: cfun_cong)
    done
qed (auto simp: cfun_eq_iff eta_cfun env_ext_db_def split: nat.split intro!: cfun_cong)

lemma evalDdb_subst_env_ext_db:
  "evalDdb (e<s/0>)\<cdot>\<rho> = evalDdb e\<cdot>(env_ext_db\<cdot>(evalDdb s\<cdot>\<rho>)\<cdot>\<rho>)"
by (auto simp: evalDdb_subst env_ext_db_def cfun_eq_iff split: nat.split intro!: cfun_arg_cong)

lemma eval_val_not_bot:
  assumes "P \<Down> V"
  shows "evalDdb V\<cdot>\<rho> \<noteq> \<bottom>"
by (rule val.induct[OF eval_to[OF assms]], simp_all)

(*>*)
theorem evalOP_sound:
  assumes "P \<Down> V"
  shows "evalDdb P\<cdot>\<rho> = evalDdb V\<cdot>\<rho>"
(*<*)
using assms
proof(induct arbitrary: \<rho>)
  case evalOP_AppN then show ?case
    by (simp add: evalOP_AppN(4)[symmetric] evalDdb_subst_env_ext_db)
next
  case (evalOP_AppV P M Q q V \<rho>) then show ?case
    apply simp
    apply (subst evalOP_AppV(4)[symmetric])
    apply (simp add: eval_val_not_bot strictify_cancel evalDdb_subst_env_ext_db)
    done
next
  case (evalOP_Fix P V \<rho>)
  have "evalDdb V\<cdot>\<rho> = evalDdb (P<DBFix P/0>)\<cdot>\<rho>"
    using evalOP_Fix by simp
  also have "... = evalDdb P\<cdot>(\<Lambda> i. if 0 < i then \<rho>\<cdot>(i - 1) else if i = 0 then (\<mu> x. evalDdb P\<cdot>(env_ext_db\<cdot>x\<cdot>\<rho>)) else \<rho>\<cdot>i)"
    apply (simp add: evalDdb_subst)
    apply (rule cfun_arg_cong)
    apply (simp add: cfun_eq_iff)
    done
  also have "... = evalDdb (DBFix P)\<cdot>\<rho>"
    apply simp
    apply (subst (2) fix_eq)
    apply (simp add: env_ext_db_def)
    apply (rule cfun_arg_cong)
    apply (auto simp: cfun_eq_iff env_ext_db_def split: nat.split)
    done
  finally show ?case by simp
qed (simp_all add: cond_def isZero_def pred_def succ_def)

(*>*)
text\<open>

We can use soundness to conclude that POR is not definable
operationally either. We rely on @{thm [source] "transdb_inv"} to map
our de Bruijn term into the syntactic universe of
\S\ref{sec:directsem} and appeal to the results of
\S\ref{sec:por}. This takes some effort as @{typ "ValD"} contains
irrelevant junk that makes it hard to draw obvious conclusions; we use
\<open>DBCond\<close> to restrict the arguments to the putative witness.

\<close>

definition
  "isPORdb e \<equiv> closed e
    \<and> DBApp (DBApp e DBtt) DBDiverge \<Down> DBtt
    \<and> DBApp (DBApp e DBDiverge) DBtt \<Down> DBtt
    \<and> DBApp (DBApp e DBff) DBff \<Down> DBff"

(*<*)
lemma ValD_strict:
  "\<lbrakk> f\<cdot>a\<cdot>b = ValTT; f\<cdot>x\<cdot>y = ValFF \<rbrakk> \<Longrightarrow> f\<cdot>\<bottom>\<cdot>\<bottom> = \<bottom>"
using monofun_cfun[OF monofun_cfun_arg[where f=f and x="\<bottom>" and y=x], where x="\<bottom>" and y=y, simplified]
      monofun_cfun[OF monofun_cfun_arg[where f=f and x="\<bottom>" and y=a], where x="\<bottom>" and y=b, simplified]
by (cases "f\<cdot>\<bottom>\<cdot>\<bottom>") simp_all

lemma ValD_ValTT:
  "\<lbrakk> f\<cdot>\<bottom>\<cdot>ValTT = ValTT; f\<cdot>ValTT\<cdot>\<bottom> = ValTT \<rbrakk> \<Longrightarrow> f\<cdot>ValTT\<cdot>ValTT = ValTT"
using monofun_cfun[OF monofun_cfun_arg[where f=f and x="\<bottom>"], where x="ValTT" and y="ValTT"]
by (cases "f\<cdot>ValTT\<cdot>ValTT") simp_all
(*>*)

lemma POR_is_not_operationally_definable: "\<not>isPORdb e"
(*<*)
proof(rule notI)
  assume P: "isPORdb e"
  let ?porV = "ValF\<cdot>(\<Lambda> x. ValF\<cdot>(\<Lambda> y. x por y))"
  from P have "closed e
     \<and> evalDdb (DBApp (DBApp e DBtt) DBDiverge)\<cdot>\<rho> = ValTT
     \<and> evalDdb (DBApp (DBApp e DBDiverge) DBtt)\<cdot>\<rho> = ValTT
     \<and> evalDdb (DBApp (DBApp e DBff) DBff)\<cdot>\<rho> = ValFF" for \<rho>
    unfolding isPORdb_def by (force dest!: evalOP_sound[where \<rho>=\<rho>])
  then have F: "closed e
      \<and> \<lbrakk>transdb_inv (DBApp (DBApp e DBtt) DBDiverge) id 0 0\<rbrakk>\<rho> = ValTT
      \<and> \<lbrakk>transdb_inv (DBApp (DBApp e DBDiverge) DBtt) id 0 0\<rbrakk>\<rho> = ValTT
      \<and> \<lbrakk>transdb_inv (DBApp (DBApp e DBff) DBff) id 0 0\<rbrakk>\<rho> = ValFF" for \<rho>
    (* id is arbitrary here *)
    by (simp add: evalD_evalDdb transdb_inv closed_transdb_inv)
  from F have G: "appF\<cdot>(appF\<cdot>(\<lbrakk>transdb_inv e id 0 0\<rbrakk>\<rho>)\<cdot>\<bottom>)\<cdot>\<bottom> = \<bottom>" for \<rho>
    by (auto intro: ValD_strict[where f="\<Lambda> x y. appF\<cdot>(appF\<cdot>(\<lbrakk>transdb_inv e id 0 0\<rbrakk>\<rho>)\<cdot>x)\<cdot>y", simplified])
  from F have H: "appF\<cdot>(appF\<cdot>(\<lbrakk>transdb_inv e id 0 0\<rbrakk>\<rho>)\<cdot>ValTT)\<cdot>ValTT = ValTT" for \<rho>
    using ValD_ValTT[where f="\<Lambda> x y. appF\<cdot>(appF\<cdot>(\<lbrakk>transdb_inv e id 0 0\<rbrakk>\<rho>)\<cdot>x)\<cdot>y"] by simp
  let ?f = "AbsN 0 (AbsN 1 (App (App (transdb_inv e id 0 0)
                                     (Cond (Var 0) (Var 0) (Cond (Var 1) (Var 1) (Var 1))) )
                                     (Cond (Var 1) (Var 1) (Cond (Var 0) (Var 0) (Var 0))) ))"
  from F G H have "\<lbrakk>?f\<rbrakk>env_empty = ?porV"
    apply (clarsimp simp: cfun_eq_iff cond_def)
    apply (case_tac x, simp_all)
     apply (case_tac xa, simp_all)+
    done
  with POR_sat have "definable ?porV \<and> appFLv ?porV [POR_arg1_rel, POR_arg2_rel] = POR_result_rel"
    unfolding definable_def by blast
  with POR_is_not_definable show False by blast
qed
(*>*)

subsection\<open>Computational Adequacy\<close>

text\<open>

\label{sec:compad}

The lemma @{thm [source] "evalOP_sound"} tells us that the operational
semantics preserves the denotational semantics. We might also hope
that the two are somehow equivalent, but due to the junk in the
domain-theoretic model (see \S\ref{sec:pcfdefinability}) we cannot
expect this to be entirely straightforward. Here we show that the
denotational semantics is \emph{computationally adequate}, which means
that it can be used to soundly reason about contextual equivalence.

We follow \citet{DBLP:conf/mfps/Pitts93,PittsAM:relpod} by defining a
suitable logical relation between our @{typ "ValD"} domain and the set
of programs (closed terms). These are termed "formal approximation
relations" by Plotkin. The machinery of \S\ref{sec:synlr} requires us
to define a unique bottom element, which in this case is @{term "{\<bottom>} \<times>
{ P . closed P}"}. To that end we define the type of programs.

\<close>

typedef Prog = "{ P. closed P }"
  morphisms unProg mkProg by fastforce

definition
  ca_lf_rep :: "(ValD, Prog) synlf_rep"
where
  "ca_lf_rep \<equiv> \<lambda>(rm, rp).
     ({\<bottom>} \<times> UNIV)
     \<union> { (d, P) |d P.
        (\<exists>n. d = ValN\<cdot>n \<and> unProg P \<Down> DBNum n)
      \<or> (d = ValTT \<and> unProg P \<Down> DBtt)
      \<or> (d = ValFF \<and> unProg P \<Down> DBff)
      \<or> (\<exists>f M. d = ValF\<cdot>f \<and> unProg P \<Down> DBAbsN M
              \<and> (\<forall>(x, X) \<in> unsynlr (undual rm). (f\<cdot>x, mkProg (M<unProg X/0>)) \<in> unsynlr rp))
      \<or> (\<exists>f M. d = ValF\<cdot>f \<and> unProg P \<Down> DBAbsV M \<and> f\<cdot>\<bottom> = \<bottom>
              \<and> (\<forall>(x, X) \<in> unsynlr (undual rm). \<forall>V. unProg X \<Down> V
                     \<longrightarrow> (f\<cdot>x, mkProg (M<V/0>)) \<in> unsynlr rp)) }"

abbreviation ca_lr :: "(ValD, Prog) synlf" where
  "ca_lr \<equiv> \<lambda>r. mksynlr (ca_lf_rep r)"

text\<open>

Intuitively we relate domain-theoretic values to all programs that
converge to the corresponding syntatic values. If a program has a
non-@{term "\<bottom>"} denotation then we can use this relation to conclude
something about the value it (operationally) converges to.

\<close>
(*<*)

lemmas Prog_simps [iff] =
  unProg_inverse
  mkProg_inverse[simplified]

lemma bot_ca_lf_rep [intro, simp]:
  "(\<bottom>, P) \<in> ca_lf_rep r"
  unfolding ca_lf_rep_def by (simp add: split_def)

lemma synlr_cal_lr_rep [intro, simp]:
  "ca_lf_rep r \<in> synlr"
  unfolding ca_lf_rep_def
  by rule (auto intro!: adm_conj adm_disj adm_below_monic_exists
                  simp: split_def
                  dest: evalOP_deterministic)

lemma mono_ca_lr:
  "mono ca_lr"
proof
  fix x y :: "(ValD, Prog) synlr dual \<times> (ValD, Prog) synlr"
  obtain x1 x2 y1 y2 where [simp]: "x = (x1, x2)" "y = (y1, y2)"
    by (cases x, cases y)
  assume "x \<le> y"
  then have "ca_lf_rep (x1, x2) \<subseteq> ca_lf_rep (y1, y2)"
    by (simp add: ca_lf_rep_def unsynlr_leq [symmetric] dual_less_eq_iff split_def)
      fastforce
  then show "ca_lr x \<le> ca_lr y"
    by simp
qed

lemma min_inv_ca_lr:
  assumes "e\<cdot>\<bottom> = \<bottom>"
  assumes "eRSS e R' S'"
  shows "eRSS (ValD_copy_rec\<cdot>e) (dual (ca_lr (dual S', undual R'))) (ca_lr (R', S'))"
  apply simp
  unfolding ca_lf_rep_def using assms
  apply simp
  apply (rule ballI)
  apply (simp add: split_def)
  apply (elim disjE)
  apply fastforce
  apply fastforce
  apply fastforce
  apply fastforce

  (* FIXME fastforce gets lost ?? AbsN *)
  apply clarsimp
  apply (rule_tac x=M in exI)
  apply clarsimp
  apply (frule (1) bspec)
  apply simp
  apply (frule (1) bspec) back
  apply simp
  apply (frule (1) bspec) back
  apply simp

  (* FIXME fastforce gets lost ?? AbsV *)
  apply (intro disjI2)
  apply clarsimp
  apply (rule_tac x=M in exI)
  apply clarsimp
  apply (frule (1) bspec)
  apply simp
  apply (frule (1) bspec) back
  apply simp
  apply (frule (1) bspec) back
  apply bestsimp
  done

(*>*)
text\<open>\<close>

interpretation ca: DomSolSyn ca_lr ValD_copy_rec
  apply standard
     apply (rule mono_ca_lr)
    apply (rule ValD_copy_ID)
   apply simp
  apply (erule (1) min_inv_ca_lr)
  done

definition ca_lr_syn :: "ValD \<Rightarrow> db \<Rightarrow> bool" ("_ \<triangleleft> _" [80,80] 80) where
  "d \<triangleleft> P \<equiv> (d, P) \<in> { (x, unProg Y) |x Y. (x, Y) \<in> unsynlr ca.delta }"
(*<*)

lemma adm_ca_lr [intro, simp]:
  "closed P \<Longrightarrow> adm (\<lambda>x. x \<triangleleft> P)"
  unfolding ca_lr_syn_def
  by (auto simp: unProg_inject)

lemma closed_ca_lr [intro]:
  "d \<triangleleft> P \<Longrightarrow> closed P"
  apply (subst (asm) ca_lr_syn_def)
  apply (subst (asm) ca.delta_sol)
  apply simp
  apply (clarsimp simp: ca_lf_rep_def)
  apply (case_tac Y)
  apply simp
  done

lemma ca_lrI [intro, simp]:
  "closed P \<Longrightarrow> \<bottom> \<triangleleft> P"
  "\<lbrakk> P \<Down> DBtt; closed P \<rbrakk> \<Longrightarrow> ValTT \<triangleleft> P"
  "\<lbrakk> P \<Down> DBff; closed P \<rbrakk> \<Longrightarrow> ValFF \<triangleleft> P"
  "\<lbrakk> P \<Down> DBNum n; closed P \<rbrakk> \<Longrightarrow> ValN\<cdot>n \<triangleleft> P"
  apply (simp_all add: ca_lr_syn_def)
  apply (simp add: exI[where x="mkProg P"])
  apply ((subst ca.delta_sol, simp, subst ca_lf_rep_def, simp add: exI[where x="mkProg P"])+)
  done

lemma ca_lr_DBAbsNI:
  "\<lbrakk> P \<Down> DBAbsN M; closed P; \<And>x X. x \<triangleleft> X \<Longrightarrow> f\<cdot>x \<triangleleft> M<X/0> \<rbrakk> \<Longrightarrow> ValF\<cdot>f \<triangleleft> P"
  apply (simp add: ca_lr_syn_def)
  apply (subst ca.delta_sol)
  apply simp
  apply (rule exI[where x="mkProg P"])
  apply (subst ca_lf_rep_def)
  apply simp
  apply (rule disjI1)
  apply (rule exI[where x=M])
  apply force
  done

lemma ca_lr_DBAbsVI:
  "\<lbrakk> P \<Down> DBAbsV M; closed P; f\<cdot>\<bottom> = \<bottom>; \<And>x X V. \<lbrakk> x \<triangleleft> X; X \<Down> V \<rbrakk> \<Longrightarrow> f\<cdot>x \<triangleleft> M<V/0> \<rbrakk> \<Longrightarrow> ValF\<cdot>f \<triangleleft> P"
  apply (simp add: ca_lr_syn_def)
  apply (subst ca.delta_sol)
  apply simp
  apply (rule exI[where x="mkProg P"])
  apply (subst ca_lf_rep_def)
  apply simp
  apply force
  done

lemma ca_lrE:
  "\<lbrakk> d \<triangleleft> P;
     \<lbrakk> d = \<bottom>; closed P \<rbrakk> \<Longrightarrow> Q;
     \<lbrakk> d = ValTT; closed P; P \<Down> DBtt \<rbrakk> \<Longrightarrow> Q;
     \<lbrakk> d = ValFF; closed P; P \<Down> DBff \<rbrakk> \<Longrightarrow> Q;
     \<And>n. \<lbrakk> d = ValN\<cdot>n; closed P; P \<Down> DBNum n \<rbrakk> \<Longrightarrow> Q;
     \<And>f M. \<lbrakk> d = ValF\<cdot>f; closed P; P \<Down> DBAbsN M; \<And>x X. x \<triangleleft> X \<Longrightarrow> f\<cdot>x \<triangleleft> M<X/0> \<rbrakk> \<Longrightarrow> Q;
     \<And>f M. \<lbrakk> d = ValF\<cdot>f; f\<cdot>\<bottom> = \<bottom>; closed P; P \<Down> DBAbsV M; \<And>x X V. \<lbrakk> x \<triangleleft> X; X \<Down> V \<rbrakk> \<Longrightarrow> f\<cdot>x \<triangleleft> M<V/0> \<rbrakk> \<Longrightarrow> Q
   \<rbrakk> \<Longrightarrow> Q"
  apply (frule closed_ca_lr)
  apply (simp add: ca_lr_syn_def)
  apply (subst (asm) ca.delta_sol)
  apply simp
  apply (subst (asm) ca_lf_rep_def)
  apply clarsimp
  apply (case_tac Y)
  apply (elim disjE)
  apply auto

  apply (drule_tac x=f in meta_spec)
  apply (drule_tac x=M in meta_spec)
  apply simp
  apply (subgoal_tac "(\<And>x X. \<exists>Y. X = unProg Y \<and> (x, Y) \<in> unsynlr (DomSolSyn.delta ca_lr) \<Longrightarrow> \<exists>Y. M<X/0> = unProg Y \<and> (f\<cdot>x, Y) \<in> unsynlr (DomSolSyn.delta ca_lr))")
   apply blast
  apply clarsimp
  apply (rule_tac x="mkProg (M<unProg Y/0>)" in exI)
  apply auto[1]
  apply (subst mkProg_inverse)
   apply simp
  apply (frule (1) evalOP_closed)
  apply (subst (asm) closed_binders)
  apply (auto simp: closed_def
             split: nat.splits)[2]
  apply (case_tac Y)
  apply (auto simp: closed_def)[1]

  apply (drule_tac x=f in meta_spec) back
  apply (drule_tac x=M in meta_spec)
  apply simp
  apply (subgoal_tac "(\<And>x X V. \<lbrakk>\<exists>Y. X = unProg Y \<and> (x, Y) \<in> unsynlr (DomSolSyn.delta ca_lr); X \<Down> V\<rbrakk>
                      \<Longrightarrow> \<exists>Y. M<V/0> = unProg Y \<and> (f\<cdot>x, Y) \<in> unsynlr (DomSolSyn.delta ca_lr))")
   apply blast
  apply clarsimp
  apply (drule (1) bspec)
  apply clarsimp
  apply (rule_tac x="mkProg (M<V/0>)" in exI)
  apply clarsimp
  apply (subst mkProg_inverse)
   defer
   apply simp
  apply simp
  apply (drule (1) evalOP_closed)
  using closed_def closed_invs(11) evalOP_closed unProg by force

(*>*)
text\<open>

To establish this result we need a ``closing substitution'' operation.
It seems easier to define it directly in this simple-minded way than
reusing the standard substitution operation.

This is quite similar to a context-plugging (non-capturing)
substitution operation, where the ``holes'' are free variables, and
indeed we use it as such below.

\<close>

fun
  closing_subst :: "db \<Rightarrow> (var \<Rightarrow> db) \<Rightarrow> var \<Rightarrow> db"
where
  "closing_subst (DBVar i) \<Gamma> k = (if k \<le> i then \<Gamma> (i - k) else DBVar i)"
| "closing_subst (DBApp t u) \<Gamma> k = DBApp (closing_subst t \<Gamma> k) (closing_subst u \<Gamma> k)"
| "closing_subst (DBAbsN t) \<Gamma> k = DBAbsN (closing_subst t \<Gamma> (k + 1))"
| "closing_subst (DBAbsV t) \<Gamma> k = DBAbsV (closing_subst t \<Gamma> (k + 1))"
| "closing_subst (DBFix e) \<Gamma> k = DBFix (closing_subst e \<Gamma> (k + 1))"
| "closing_subst (DBCond c t e) \<Gamma> k =
            DBCond (closing_subst c \<Gamma> k) (closing_subst t \<Gamma> k) (closing_subst e \<Gamma> k)"
| "closing_subst (DBSucc e) \<Gamma> k = DBSucc (closing_subst e \<Gamma> k)"
| "closing_subst (DBPred e) \<Gamma> k = DBPred (closing_subst e \<Gamma> k)"
| "closing_subst (DBIsZero e) \<Gamma> k = DBIsZero (closing_subst e \<Gamma> k)"
| "closing_subst x \<Gamma> k = x"

text\<open>

We can show it has the expected properties when all terms in @{term
"\<Gamma>"} are closed.

\<close>

(*<*)
lemma freedb_closing_subst [iff]:
  assumes "\<forall>v. freedb e v \<and> k \<le> v \<longrightarrow> closed (\<Gamma> (v - k))"
  shows "freedb (closing_subst e \<Gamma> k) i \<longleftrightarrow> (freedb e i \<and> i < k)"
  using assms
  apply (induct e arbitrary: i k)
  using Suc_le_D
  apply (auto simp: closed_def not_less_eq diff_Suc split: nat.split)
    apply (subgoal_tac "\<forall>v. freedb e v \<and> Suc k \<le> v \<longrightarrow> (\<forall>j. \<not> freedb (\<Gamma> (v - Suc k)) j)"; use Suc_le_D in force)+
    done

lemma closed_closing_subst [intro, simp]:
  assumes "\<forall>v. freedb e v \<longrightarrow> closed (\<Gamma> v)"
  shows "closed (closing_subst e \<Gamma> 0)"
using assms freedb_closing_subst[where e=e and k=0]
unfolding closed_def by fastforce

lemma subst_closing_subst:
  assumes "\<forall>v. freedb e v \<and> k < v \<longrightarrow> closed (\<Gamma> (v - Suc k))"
  assumes "closed X"
  shows "(closing_subst e \<Gamma> (Suc k))<X/k> = closing_subst e (case_nat X \<Gamma>) k"
using assms
proof(induct e arbitrary: k)
  case DBVar then show ?case
    unfolding closed_def
    by (clarsimp simp: Suc_le_eq closed_subst) (metis Suc_diff_Suc old.nat.simps(5))
next
  case DBAbsN then show ?case
    by clarsimp (metis Suc_less_eq2 closed_def closed_lift diff_Suc_Suc)
next
  case DBAbsV then show ?case
    by clarsimp (metis Suc_less_eq2 closed_def closed_lift diff_Suc_Suc)
next
  case DBFix then show ?case
    by clarsimp (metis Suc_less_eq2 closed_def closed_lift diff_Suc_Suc)
qed (auto simp: not_less_eq split: nat.split)

lemma closing_subst_closed [intro, simp]:
  assumes "\<forall>v. freedb e v \<longrightarrow> v < k"
  shows "closing_subst e \<Gamma> k = e"
  using assms
  apply (induct e arbitrary: k)
  apply (auto simp: closed_def)
  apply (metis gr_implies_not0 nat.exhaust not_less_eq)+
  done

lemma closing_subst_evalDdb_cong:
  assumes "\<forall>v. closed (\<Gamma> v) \<and> closed (\<Gamma>' v)"
  assumes "\<forall>v. evalDdb (\<Gamma> v)\<cdot>env_empty_db = evalDdb (\<Gamma>' v)\<cdot>env_empty_db"
  shows "evalDdb (closing_subst e \<Gamma> k)\<cdot>\<rho> = evalDdb (closing_subst e \<Gamma>' k)\<cdot>\<rho>"
proof(induct e arbitrary: k \<rho>)
  case DBVar with assms show ?case
    by (simp; subst (1 2) evalDdb_env_closed[where \<rho>'=env_empty_db]; simp)
qed auto

(*>*)
text\<open>

The key lemma is shown by induction over @{term "e"} for arbitrary
environments (@{term "\<Gamma>"} and @{term "\<rho>"}):

\<close>

    apply (drule_tac x="evalDdb e2\<cdot>\<rho>" in meta_spec)
    apply (drule_tac x="closing_subst e2 \<Gamma> 0" in meta_spec)
    apply simp
    apply (erule ca_lrE) back
     apply (auto intro: ca_lr_DBAbsNI ca_lr_DBAbsVI)[6]

    apply (case_tac "evalDdb e2\<cdot>\<rho> = \<bottom>")
     apply simp
    apply (subgoal_tac "\<exists>V. closing_subst e2 \<Gamma> 0 \<Down> V")
     apply clarsimp
     apply (drule_tac x="evalDdb e2\<cdot>\<rho>" in meta_spec)
      apply (drule_tac x="closing_subst e2 \<Gamma> 0" in meta_spec)
      apply (drule_tac x="V" in meta_spec)
      apply simp
      apply (erule ca_lrE) back
       apply (auto intro: ca_lr_DBAbsNI ca_lr_DBAbsVI)[6]
    apply (erule ca_lrE)
    apply auto
    done
next
  case (DBAbsN e \<Gamma> \<rho>)
  from DBAbsN.prems show ?case
    apply simp
    apply (rule ca_lr_DBAbsNI)
      apply (rule eval_val)
      apply (rule v_AbsN)
      apply (clarsimp simp: closed_def split: nat.split)
     apply clarsimp
    apply (subst subst_closing_subst)
      apply simp
     apply blast
    apply (cut_tac \<rho>="env_ext_db\<cdot>x\<cdot>\<rho>" and \<Gamma>="case_nat X \<Gamma>" in DBAbsN.hyps)
     apply (subgoal_tac "\<forall>v. freedb e v \<longrightarrow> env_ext_db\<cdot>x\<cdot>\<rho>\<cdot>v \<triangleleft> case_nat X \<Gamma> v \<and> closed (case_nat X \<Gamma> v)")
      apply blast
     apply (auto simp: env_ext_db_def split: nat.splits)
    done
next
  case (DBAbsV e \<Gamma> \<rho>)
  from DBAbsV.prems show ?case
    apply simp
    apply (rule ca_lr_DBAbsVI)
       apply (rule eval_val)
       apply (rule v_AbsV)
      apply (clarsimp simp: closed_def split: nat.split)
     apply clarsimp
    apply (frule closed_ca_lr)
    apply (frule (1) evalOP_closed)
    apply (case_tac "x=\<bottom>")
     apply simp
      apply (rule ca_lrI)
     apply (subst subst_closing_subst)
       apply simp
      apply simp
     apply (simp add: nat.split_sels(1))
    apply simp
    apply (subst subst_closing_subst)
      apply simp
     apply blast
    apply (cut_tac \<rho>="env_ext_db\<cdot>x\<cdot>\<rho>" and \<Gamma>="case_nat V \<Gamma>" in DBAbsV.hyps)
     apply (subgoal_tac "\<forall>v. freedb e v \<longrightarrow> env_ext_db\<cdot>x\<cdot>\<rho>\<cdot>v \<triangleleft> case_nat V \<Gamma> v \<and> closed (case_nat V \<Gamma> v)")
      apply blast
     apply (auto simp: env_ext_db_def split: nat.splits)
    apply (erule ca_lrE)
         apply ((blast dest: evalOP_deterministic)+)[4]
     apply clarsimp
     apply (subgoal_tac "V = DBAbsN M")
      apply clarsimp
      apply (rule ca_lr_DBAbsNI)
      apply (rule eval_val)
      apply (auto dest: evalOP_deterministic)[4]
    apply (subgoal_tac "V = DBAbsV M")
     apply clarsimp
     apply (rule ca_lr_DBAbsVI)
     apply (auto dest: evalOP_deterministic)
    done
next
  case (DBFix e \<Gamma> \<rho>) then show ?case
    apply simp
    apply (rule fix_ind)
      apply simp_all
    apply (drule_tac x="env_ext_db\<cdot>x\<cdot>\<rho>" in meta_spec)
    apply (drule_tac x="case_nat (closing_subst (DBFix e) \<Gamma> 0) \<Gamma>" in meta_spec)
    apply (subgoal_tac "\<forall>v. freedb e v \<longrightarrow> env_ext_db\<cdot>x\<cdot>\<rho>\<cdot>v \<triangleleft> case_nat (closing_subst (DBFix e) \<Gamma> 0) \<Gamma> v \<and> closed (case_nat (closing_subst (DBFix e) \<Gamma> 0) \<Gamma> v)")
     apply clarsimp
     apply (erule ca_lrE) back
      apply auto[1]

      apply simp
      apply (rule ca_lrI)
       apply (auto simp: subst_closing_subst)[2]

      apply simp
      apply (rule ca_lrI)
       apply (auto simp: subst_closing_subst)[2]

      apply simp
      apply (rule ca_lrI)
       apply (auto simp: subst_closing_subst)[2]

      apply simp
      apply (rule ca_lr_DBAbsNI)
       apply (auto simp: subst_closing_subst)[3]

      apply simp
      apply (rule ca_lr_DBAbsVI)
       apply (auto simp: subst_closing_subst)[3]
       apply force

      apply (clarsimp simp: env_ext_db_def split: nat.split)
    done
next
  case (DBCond c t e \<Gamma> \<rho>) then show ?case
    apply (simp add: cond_def)
    apply (drule_tac x=\<rho> in meta_spec, drule_tac x=\<Gamma> in meta_spec)+
    apply simp
    apply (erule ca_lrE, auto intro: ca_lr_DBAbsNI ca_lr_DBAbsVI)+
    done
next
  case (DBSucc e \<Gamma> \<rho>) then show ?case
    apply (simp add: succ_def)
    apply (drule_tac x=\<rho> in meta_spec, drule_tac x=\<Gamma> in meta_spec)
    apply simp
    apply (erule ca_lrE, auto intro: ca_lr_DBAbsNI ca_lr_DBAbsVI)+
    done
next
  case (DBPred e \<Gamma> \<rho>) then show ?case
    apply (simp add: pred_def)
    apply (drule_tac x=\<rho> in meta_spec, drule_tac x=\<Gamma> in meta_spec)
    apply simp
    apply (erule ca_lrE, auto intro: ca_lr_DBAbsNI ca_lr_DBAbsVI split: nat.split)+
    done
next
  case (DBIsZero e \<Gamma> \<rho>) then show ?case
    apply (simp add: isZero_def)
    apply (drule_tac x=\<rho> in meta_spec, drule_tac x=\<Gamma> in meta_spec)
    apply simp
    apply (erule ca_lrE, auto intro: ca_lr_DBAbsNI ca_lr_DBAbsVI)+
    done
qed auto

(*>*)
text\<open>\<close>

lemma ca_closed:
  assumes "closed e"
  shows "evalDdb e\<cdot>env_empty_db \<triangleleft> e"
  using ca_open[where e=e and \<rho>=env_empty_db] assms
  by (simp add: closed_def)

theorem ca:
  assumes nb: "evalDdb e\<cdot>env_empty_db \<noteq> \<bottom>"
  assumes "closed e"
  shows "\<exists>V. e \<Down> V"
  using ca_closed[OF \<open>closed e\<close>] nb
  by (auto elim!: ca_lrE)

text\<open>

This last result justifies reasoning about contextual equivalence
using the denotational semantics, as we now show.

\<close>

subsubsection\<open>Contextual Equivalence\<close>

text\<open>

As we are using an un(i)typed language, we take a context @{term "C"}
to be an arbitrary term, where the free variables are the
``holes''. We substitute a closed expression @{term "e"} uniformly for
all of the free variables in @{term "C"}. If open, the term @{term
"e"} can be closed using enough @{term "AbsN"}s. This seems to be a
standard trick now, see e.g. \citet{DBLP:conf/popl/KoutavasW06}. If we
didn't have CBN (only CBV) then it might be worth showing that this is
an adequate treatment.

\<close>

definition ctxt_sub :: "db \<Rightarrow> db \<Rightarrow> db" ("(_<_>)" [300, 0] 300) where
  "C<e> \<equiv> closing_subst C (\<lambda>_. e) 0"
(*<*)

lemma ctxt_sub_closed [iff]:
  "closed e \<Longrightarrow> closed (C<e>)"
  unfolding ctxt_sub_def by simp

lemma ctxt_sub_cong:
  assumes "closed e1"
  assumes "closed e2"
  assumes "evalDdb e1\<cdot>env_empty_db = evalDdb e2\<cdot>env_empty_db"
  shows "evalDdb (C<e1>)\<cdot>env_empty_db = evalDdb (C<e2>)\<cdot>env_empty_db"
  unfolding ctxt_sub_def using assms by (auto intro: closing_subst_evalDdb_cong)

(*>*)
text\<open>

Following \citet{PittsAM:relpod} we define a relation between values
that ``have the same form''. This is weak at functional values. We
don't distinguish between strict and non-strict abstractions.

\<close>

inductive
  have_the_same_form :: "db \<Rightarrow> db \<Rightarrow> bool" ("_ \<sim> _" [50,50] 50)
where
  "DBAbsN e \<sim> DBAbsN e'"
| "DBAbsN e \<sim> DBAbsV e'"
| "DBAbsV e \<sim> DBAbsN e'"
| "DBAbsV e \<sim> DBAbsV e'"
| "DBFix e \<sim> DBFix e'"
| "DBtt \<sim> DBtt"
| "DBff \<sim> DBff"
| "DBNum n \<sim> DBNum n"
(*<*)

declare have_the_same_form.intros [intro, simp]

lemma have_the_same_form_sound:
  assumes D: "evalDdb v1\<cdot>\<rho> = evalDdb v2\<cdot>\<rho>"
  assumes "val v1"
  assumes "val v2"
  shows "v1 \<sim> v2"
  using \<open>val v1\<close> D
  apply (induct rule: val.induct)
  apply simp_all
  using \<open>val v2\<close>
  apply (induct rule: val.induct)
  apply simp_all
  using \<open>val v2\<close>
  apply (induct rule: val.induct)
  apply simp_all
  using \<open>val v2\<close>
  apply (induct rule: val.induct)
  apply simp_all
  using \<open>val v2\<close>
  apply (induct rule: val.induct)
  apply simp_all
  using \<open>val v2\<close>
  apply (induct rule: val.induct)
  apply simp_all
  done

(* FIXME could also show compatability, i.e. that the
contextually_equivalent relation is compatible with the language. *)

(*>*)
text\<open>

A program @{term "e2"} \emph{refines} the program @{term "e1"} if it
converges in context at least as often. This is a preorder on
programs.

\<close>

definition
  refines :: "db \<Rightarrow> db \<Rightarrow> bool" ("_ \<unlhd> _" [50,50] 50)
where
  "e1 \<unlhd> e2 \<equiv> \<forall>C. \<exists>V1. C<e1> \<Down> V1 \<longrightarrow> (\<exists>V2. C<e2> \<Down> V2 \<and> V1 \<sim> V2)"

text\<open>

Contextually-equivalent programs refine each other.

\<close>

definition
  contextually_equivalent :: "db \<Rightarrow> db \<Rightarrow> bool" ("_ \<approx> _")
where
  "e1 \<approx> e2 \<equiv> e1 \<unlhd> e2 \<and> e2 \<unlhd> e1"
(*<*)

lemma refinesI:
  "(\<And>C V1. C<e1> \<Down> V1 \<Longrightarrow> (\<exists>V2. C<e2> \<Down> V2 \<and> V1 \<sim> V2))
     \<Longrightarrow> e1 \<unlhd> e2"
  unfolding refines_def by blast

lemma computational_adequacy_refines:
  assumes "closed e1"
  assumes "closed e2"
  assumes e: "evalDdb e1\<cdot>env_empty_db = evalDdb e2\<cdot>env_empty_db"
  shows "e1 \<unlhd> e2"
proof(rule refinesI)
  fix C V1 assume V1: "C<e1> \<Down> V1"
  from assms have D: "evalDdb (C<e2>)\<cdot>env_empty_db = evalDdb (C<e1>)\<cdot>env_empty_db"
    by (metis ctxt_sub_cong)
  from D \<open>closed e2\<close> obtain V2 where V2: "C<e2> \<Down> V2"
    using evalOP_sound[OF V1] ca[where e="C<e2>"] eval_val_not_bot[OF V1]
    by auto
  from D V1 V2 have V1V2: "evalDdb V1\<cdot>env_empty_db = evalDdb V2\<cdot>env_empty_db"
    by (simp add: evalOP_sound)
  from V1 V2 V1V2
  show "\<exists>V2. C<e2> \<Down> V2 \<and> V1 \<sim> V2"
    by (auto simp: have_the_same_form_sound)
qed

(*>*)
text\<open>

Our ultimate theorem states that if two programs have the same
denotation then they are contextually equivalent.

\<close>

theorem computational_adequacy:
  assumes 1: "closed e1"
  assumes 2: "closed e2"
  assumes D: "evalDdb e1\<cdot>env_empty_db = evalDdb e2\<cdot>env_empty_db"
  shows "e1 \<approx> e2"
(*<*)
  using assms
  unfolding contextually_equivalent_def
  by (simp add: computational_adequacy_refines)
(*>*)

text\<open>

This gives us a sound but incomplete method for demonstrating
contextual equivalence. We expect this result is useful for showing
contextual equivalence for \emph{typed} programs as well, but leave it
to future work to demonstrate this.

See \citet[\S6.2]{Gunter:1992} for further discussion of computational
adequacy at higher types.

The reader may wonder why we did not use Nominal syntax to define our
operational semantics, following
\citet{DBLP:journals/entcs/UrbanN09}. The reason is that Nominal2 does
not support the definition of continuous functions over Nominal
syntax, which is required by the evaluators of \S\ref{sec:directsem}
and \S\ref{sec:directsem_db}. As observed above, in the setting of
traditional programming language semantics one can get by with a much
simpler notion of substitution than is needed for investigations into
\<open>\<lambda>\<close>-calculi. Clearly this does not hold of languages that
reduce ``under binders''.

The ``fast and loose reasoning is morally correct'' work of
\citet{DBLP:conf/popl/DanielssonHJG06} can be seen as a kind of
adequacy result.

\citet{DBLP:conf/tphol/BentonKV09} demonstrate a similar computational
adequacy result in Coq. However their system is only geared up for
this kind of metatheory, and not reasoning about particular programs;
its term language is combinatory.

\citet{DBLP:conf/ppdp/BentonKBH07,DBLP:conf/ppdp/BentonKBH09} have
shown that it is difficult to scale this domain-theoretic approach up
to richer languages, such as those with dynamic allocation of mutable
references, especially if these references can contain (arbitrary)
functional values.

\<close>

(*<*)

end
(*>*)


(*  Title:      HOL/HOLCF/Tutorial/New_Domain.thy
    Author:     Brian Huffman
*)

section \<open>Definitional domain package\<close>

theory New_Domain
imports HOLCF
begin

text \<open>
  UPDATE: The definitional back-end is now the default mode of the domain
  package. This file should be merged with \<open>Domain_ex.thy\<close>.
\<close>

text \<open>
  Provided that \<open>domain\<close> is the default sort, the \<open>new_domain\<close>
  package should work with any type definition supported by the old
  domain package.
\<close>

domain 'a llist = LNil | LCons (lazy 'a) (lazy "'a llist")

text \<open>
  The difference is that the new domain package is completely
  definitional, and does not generate any axioms.  The following type
  and constant definitions are not produced by the old domain package.
\<close>

thm type_definition_llist
thm llist_abs_def llist_rep_def

text \<open>
  The new domain package also adds support for indirect recursion with
  user-defined datatypes.  This definition of a tree datatype uses
  indirect recursion through the lazy list type constructor.
\<close>

domain 'a ltree = Leaf (lazy 'a) | Branch (lazy "'a ltree llist")

text \<open>
  For indirect-recursive definitions, the domain package is not able to
  generate a high-level induction rule.  (It produces a warning
  message instead.)  The low-level reach lemma (now proved as a
  theorem, no longer generated as an axiom) can be used to derive
  other induction rules.
\<close>

thm ltree.reach

text \<open>
  The definition of the take function uses map functions associated with
  each type constructor involved in the definition.  A map function
  for the lazy list type has been generated by the new domain package.
\<close>

thm ltree.take_rews
thm llist_map_def

lemma ltree_induct:
  fixes P :: "'a ltree \<Rightarrow> bool"
  assumes adm: "adm P"
  assumes bot: "P \<bottom>"
  assumes Leaf: "\<And>x. P (Leaf\<cdot>x)"
  assumes Branch: "\<And>f l. \<forall>x. P (f\<cdot>x) \<Longrightarrow> P (Branch\<cdot>(llist_map\<cdot>f\<cdot>l))"
  shows "P x"
proof -
  have "P (\<Squnion>i. ltree_take i\<cdot>x)"
  using adm
  proof (rule admD)
    fix i
    show "P (ltree_take i\<cdot>x)"
    proof (induct i arbitrary: x)
      case (0 x)
      show "P (ltree_take 0\<cdot>x)" by (simp add: bot)
    next
      case (Suc n x)
      show "P (ltree_take (Suc n)\<cdot>x)"
        apply (cases x)
        apply (simp add: bot)
        apply (simp add: Leaf)
        apply (simp add: Branch Suc)
        done
    qed
  qed (simp add: ltree.chain_take)
  thus ?thesis
    by (simp add: ltree.reach)
qed

end


(*  Title:      HOL/HOLCF/FOCUS/Fstream.thy
    Author:     David von Oheimb, TU Muenchen

FOCUS streams (with lifted elements).

TODO: integrate Fstreams.thy
*)

section {* FOCUS flat streams *}

theory Fstream
imports "~~/src/HOL/HOLCF/Library/Stream"
begin

default_sort type

type_synonym 'a fstream = "'a lift stream"

definition
  fscons        :: "'a     \<Rightarrow> 'a fstream \<rightarrow> 'a fstream" where
  "fscons a = (\<Lambda> s. Def a && s)"

definition
  fsfilter      :: "'a set \<Rightarrow> 'a fstream \<rightarrow> 'a fstream" where
  "fsfilter A = (sfilter\<cdot>(flift2 (\<lambda>x. x\<in>A)))"

abbreviation
  emptystream   :: "'a fstream"                          ("<>") where
  "<> == \<bottom>"

abbreviation
  fscons'       :: "'a \<Rightarrow> 'a fstream \<Rightarrow> 'a fstream"       ("(_~>_)"    [66,65] 65) where
  "a~>s == fscons a\<cdot>s"

abbreviation
  fsfilter'     :: "'a set \<Rightarrow> 'a fstream \<Rightarrow> 'a fstream"   ("(_'(C')_)" [64,63] 63) where
  "A(C)s == fsfilter A\<cdot>s"

notation (xsymbols)
  fscons'  ("(_\<leadsto>_)"                                                 [66,65] 65) and
  fsfilter'  ("(_\<copyright>_)"                                               [64,63] 63)

lemma Def_maximal: "a = Def d \<Longrightarrow> a\<sqsubseteq>b \<Longrightarrow> b = Def d"
by simp

section "fscons"

lemma fscons_def2: "a~>s = Def a && s"
apply (unfold fscons_def)
apply (simp)
done

lemma fstream_exhaust: "x = UU |  (? a y. x = a~> y)"
apply (simp add: fscons_def2)
apply (cut_tac stream.nchotomy)
apply (fast dest: not_Undef_is_Def [THEN iffD1])
done

lemma fstream_cases: "[| x = UU ==> P; !!a y. x = a~> y ==> P |] ==> P"
apply (cut_tac fstream_exhaust)
apply (erule disjE)
apply fast
apply fast
done

lemma fstream_exhaust_eq: "(x ~= UU) = (? a y. x = a~> y)"
apply (simp add: fscons_def2 stream_exhaust_eq)
apply (fast dest: not_Undef_is_Def [THEN iffD1] elim: DefE)
done

lemma fscons_not_empty [simp]: "a~> s ~= <>"
by (simp add: fscons_def2)

lemma fscons_inject [simp]: "(a~> s = b~> t) = (a = b &  s = t)"
by (simp add: fscons_def2)

lemma fstream_prefix: "a~> s << t ==> ? tt. t = a~> tt &  s << tt"
apply (cases t)
apply (cut_tac fscons_not_empty)
apply (fast dest: bottomI)
apply (simp add: fscons_def2)
done

lemma fstream_prefix' [simp]:
        "x << a~> z = (x = <> |  (? y. x = a~> y &  y << z))"
apply (simp add: fscons_def2 lift.distinct(2) [THEN stream_prefix'])
apply (safe)
apply (erule_tac [!] contrapos_np)
prefer 2 apply (fast elim: DefE)
apply (rule lift.exhaust)
apply (erule (1) notE)
apply (safe)
apply (drule Def_below_Def [THEN iffD1])
apply fast
done

(* ------------------------------------------------------------------------- *)

section "ft & rt"

lemmas ft_empty = stream.sel_rews (1)
lemma ft_fscons [simp]: "ft\<cdot>(m~> s) = Def m"
by (simp add: fscons_def)

lemmas rt_empty = stream.sel_rews (2)
lemma rt_fscons [simp]: "rt\<cdot>(m~> s) = s"
by (simp add: fscons_def)

lemma ft_eq [simp]: "(ft\<cdot>s = Def a) = (? t. s = a~> t)"
apply (unfold fscons_def)
apply (simp)
apply (safe)
apply (erule subst)
apply (rule exI)
apply (rule surjectiv_scons [symmetric])
apply (simp)
done

lemma surjective_fscons_lemma: "(d\<leadsto>y = x) = (ft\<cdot>x = Def d & rt\<cdot>x = y)"
by auto

lemma surjective_fscons: "ft\<cdot>x = Def d \<Longrightarrow> d\<leadsto>rt\<cdot>x = x"
by (simp add: surjective_fscons_lemma)

(* ------------------------------------------------------------------------- *)

section "take"

lemma fstream_take_Suc [simp]:
        "stream_take (Suc n)\<cdot>(a~> s) = a~> stream_take n\<cdot>s"
by (simp add: fscons_def)

(* ------------------------------------------------------------------------- *)

section "slen"

lemma slen_fscons: "#(m~> s) = eSuc (#s)"
by (simp add: fscons_def)

lemma slen_fscons_eq:
        "(enat (Suc n) < #x) = (? a y. x = a~> y & enat n < #y)"
apply (simp add: fscons_def2 slen_scons_eq)
apply (fast dest: not_Undef_is_Def [THEN iffD1] elim: DefE)
done

lemma slen_fscons_eq_rev:
        "(#x < enat (Suc (Suc n))) = (!a y. x ~= a~> y | #y < enat (Suc n))"
apply (simp add: fscons_def2 slen_scons_eq_rev)
apply (tactic {* step_tac (put_claset HOL_cs @{context} addSEs @{thms DefE}) 1 *})
apply (tactic {* step_tac (put_claset HOL_cs @{context} addSEs @{thms DefE}) 1 *})
apply (tactic {* step_tac (put_claset HOL_cs @{context} addSEs @{thms DefE}) 1 *})
apply (tactic {* step_tac (put_claset HOL_cs @{context} addSEs @{thms DefE}) 1 *})
apply (tactic {* step_tac (put_claset HOL_cs @{context} addSEs @{thms DefE}) 1 *})
apply (tactic {* step_tac (put_claset HOL_cs @{context} addSEs @{thms DefE}) 1 *})
apply (erule contrapos_np)
apply (fast dest: not_Undef_is_Def [THEN iffD1] elim: DefE)
done

lemma slen_fscons_less_eq:
        "(#(a~> y) < enat (Suc (Suc n))) = (#y < enat (Suc n))"
apply (subst slen_fscons_eq_rev)
apply (fast dest!: fscons_inject [THEN iffD1])
done

(* ------------------------------------------------------------------------- *)

section "induction"

lemma fstream_ind:
        "[| adm P; P <>; !!a s. P s ==> P (a~> s) |] ==> P x"
apply (erule stream.induct)
apply (assumption)
apply (unfold fscons_def2)
apply (fast dest: not_Undef_is_Def [THEN iffD1])
done

lemma fstream_ind2:
  "[| adm P; P UU; !!a. P (a~> UU); !!a b s. P s ==> P (a~> b~> s) |] ==> P x"
apply (erule stream_ind2)
apply (assumption)
apply (unfold fscons_def2)
apply (fast dest: not_Undef_is_Def [THEN iffD1])
apply (fast dest: not_Undef_is_Def [THEN iffD1])
done

(* ------------------------------------------------------------------------- *)

section "fsfilter"

lemma fsfilter_empty: "A(C)UU = UU"
apply (unfold fsfilter_def)
apply (rule sfilter_empty)
done

lemma fsfilter_fscons:
        "A(C)x~> xs = (if x:A then x~> (A(C)xs) else A(C)xs)"
apply (unfold fsfilter_def)
apply (simp add: fscons_def2 If_and_if)
done

lemma fsfilter_emptys: "{}(C)x = UU"
apply (rule_tac x="x" in fstream_ind)
apply (simp)
apply (rule fsfilter_empty)
apply (simp add: fsfilter_fscons)
done

lemma fsfilter_insert: "(insert a A)(C)a~> x = a~> ((insert a A)(C)x)"
by (simp add: fsfilter_fscons)

lemma fsfilter_single_in: "{a}(C)a~> x = a~> ({a}(C)x)"
by (rule fsfilter_insert)

lemma fsfilter_single_out: "b ~= a ==> {a}(C)b~> x = ({a}(C)x)"
by (simp add: fsfilter_fscons)

lemma fstream_lub_lemma1:
    "\<lbrakk>chain Y; (\<Squnion>i. Y i) = a\<leadsto>s\<rbrakk> \<Longrightarrow> \<exists>j t. Y j = a\<leadsto>t"
apply (case_tac "max_in_chain i Y")
apply  (drule (1) lub_finch1 [THEN lub_eqI, THEN sym])
apply  (force)
apply (unfold max_in_chain_def)
apply auto
apply (frule (1) chain_mono)
apply (rule_tac x="Y j" in fstream_cases)
apply  (force)
apply (drule_tac x="j" in is_ub_thelub)
apply (force)
done

lemma fstream_lub_lemma:
      "\<lbrakk>chain Y; (\<Squnion>i. Y i) = a\<leadsto>s\<rbrakk> \<Longrightarrow> (\<exists>j t. Y j = a\<leadsto>t) & (\<exists>X. chain X & (!i. ? j. Y j = a\<leadsto>X i) & (\<Squnion>i. X i) = s)"
apply (frule (1) fstream_lub_lemma1)
apply (clarsimp)
apply (rule_tac x="%i. rt\<cdot>(Y(i+j))" in exI)
apply (rule conjI)
apply  (erule chain_shift [THEN chain_monofun])
apply safe
apply  (drule_tac i="j" and j="i+j" in chain_mono)
apply   (simp)
apply  (simp)
apply  (rule_tac x="i+j" in exI)
apply  (drule fstream_prefix)
apply  (clarsimp)
apply  (subst lub_APP)
apply   (rule chainI)
apply   (fast)
apply  (erule chain_shift)
apply (subst lub_const)
apply (subst lub_range_shift)
apply  (assumption)
apply (simp)
done

end