(*  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/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