(*  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>\<open>"DBLP:conf/mfps/Pitts93"\<close>.

\<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>\<open>"DBLP:journals/jar/Nipkow01"\<close>, 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>\<open>\<open>\S6.2\<close> in "Gunter:1992"\<close>,
\<^citet>\<open>"DBLP:conf/mfps/Pitts93"\<close> and \<^citet>\<open>\<open>Chapter~11\<close> in "Winskel:1993"\<close>.

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>\<open>"DBLP:conf/mfps/Pitts93" and "PittsAM:relpod"\<close> 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>\<open>"DBLP:conf/popl/KoutavasW06"\<close>. 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>\<open>"PittsAM:relpod"\<close> 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>\<open>\<open>\S6.2\<close> in "Gunter:1992"\<close> 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>\<open>"DBLP:journals/entcs/UrbanN09"\<close>. 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>\<open>"DBLP:conf/popl/DanielssonHJG06"\<close> can be seen as a kind of
adequacy result.

\<^citet>\<open>"DBLP:conf/tphol/BentonKV09"\<close> 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>\<open>"DBLP:conf/ppdp/BentonKBH07" and "DBLP:conf/ppdp/BentonKBH09"\<close> 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: PRF_IND_CPA.thy
  Author: Andreas Lochbihler, ETH Zurich *)

subsection \<open>IND-CPA from PRF\<close>

theory PRF_IND_CPA imports
  CryptHOL.GPV_Bisim
  CryptHOL.List_Bits
  Pseudo_Random_Function
  IND_CPA
begin

text \<open>
  Formalises the construction from \cite{PetcherMorrisett2015POST}.
\<close>

declare [[simproc del: let_simp]]

type_synonym key = "bool list"
type_synonym plain = "bool list"
type_synonym cipher = "bool list * bool list"

locale otp =
  fixes f :: "key \<Rightarrow> bool list \<Rightarrow> bool list"
  and len :: nat
  assumes length_f: "\<And>xs ys. \<lbrakk> length xs = len; length ys = len \<rbrakk> \<Longrightarrow> length (f xs ys) = len"
begin

definition key_gen :: "bool list spmf"
where "key_gen = spmf_of_set (nlists UNIV len)"

definition valid_plain :: "plain \<Rightarrow> bool"
where "valid_plain plain \<longleftrightarrow> length plain = len"

definition encrypt :: "key \<Rightarrow> plain \<Rightarrow> cipher spmf"
where
  "encrypt key plain = do {
     r \<leftarrow> spmf_of_set (nlists UNIV len);
     return_spmf (r, xor_list plain (f key r))
   }"

fun decrypt :: "key \<Rightarrow> cipher \<Rightarrow> plain option"
where "decrypt key (r, c) = Some (xor_list (f key r) c)"

lemma encrypt_decrypt_correct:
  "\<lbrakk> length key = len; length plain = len \<rbrakk>
  \<Longrightarrow> encrypt key plain \<bind> (\<lambda>cipher. return_spmf (decrypt key cipher)) = return_spmf (Some plain)"
by(simp add: encrypt_def zip_map2 o_def split_def bind_eq_return_spmf length_f in_nlists_UNIV xor_list_left_commute)

interpretation ind_cpa: ind_cpa key_gen encrypt decrypt valid_plain .
interpretation "prf": "prf" key_gen f "spmf_of_set (nlists UNIV len)" .

definition prf_encrypt_oracle :: "unit \<Rightarrow> plain \<Rightarrow> (cipher \<times> unit, plain, plain) gpv"
where
  "prf_encrypt_oracle x plain = do {
     r \<leftarrow> lift_spmf (spmf_of_set (nlists UNIV len));
     Pause r (\<lambda>pad. Done ((r, xor_list plain pad), ()))
  }"

lemma interaction_bounded_by_prf_encrypt_oracle [interaction_bound]:
  "interaction_any_bounded_by (prf_encrypt_oracle \<sigma> plain) 1"
unfolding prf_encrypt_oracle_def by simp

lemma lossless_prf_encyrpt_oracle [simp]: "lossless_gpv \_top (prf_encrypt_oracle s x)"
by(simp add: prf_encrypt_oracle_def)

definition prf_adversary :: "(plain, cipher, 'state) ind_cpa.adversary \<Rightarrow> (plain, plain) prf.adversary"
where
  "prf_adversary \ = do {
     let (\1, \2) = \;
     (((p1, p2), \<sigma>), n) \<leftarrow> inline prf_encrypt_oracle \1 ();
     if valid_plain p1 \<and> valid_plain p2 then do {
       b \<leftarrow> lift_spmf coin_spmf;
       let pb = (if b then p1 else p2);
       r \<leftarrow> lift_spmf (spmf_of_set (nlists UNIV len));
       pad \<leftarrow> Pause r Done;
       let c = (r, xor_list pb pad);
       (b', _) \<leftarrow> inline prf_encrypt_oracle (\2 c \<sigma>) n;
       Done (b' = b)
     } else lift_spmf coin_spmf
  }"

theorem prf_encrypt_advantage:
  assumes "ind_cpa.ibounded_by \ q"
  and "lossless_gpv \_full (fst \)"
  and "\<And>cipher \<sigma>. lossless_gpv \_full (snd \ cipher \<sigma>)"
  shows "ind_cpa.advantage \ \<le> prf.advantage (prf_adversary \) + q / 2 ^ len"
proof -
  note [split del] = if_split
    and [cong del] = if_weak_cong
    and [simp] =
      bind_spmf_const map_spmf_bind_spmf bind_map_spmf
      exec_gpv_bind exec_gpv_inline
      rel_spmf_bind_reflI rel_spmf_reflI
  obtain \1 \2 where \: "\ = (\1, \2)" by(cases "\")
  from \<open>ind_cpa.ibounded_by _ _\<close>
  obtain q1 q2 :: nat
    where q1: "interaction_any_bounded_by \1 q1"
    and q2: "\<And>cipher \<sigma>. interaction_any_bounded_by (\2 cipher \<sigma>) q2"
    and "q1 + q2 \<le> q"
    unfolding \ by(rule ind_cpa.ibounded_byE)(auto simp add: iadd_le_enat_iff)
  from \ assms have lossless1: "lossless_gpv \_full \1"
    and lossless2: "\<And>cipher \<sigma>. lossless_gpv \_full (\2 cipher \<sigma>)" by simp_all
  have weight1: "\<And>oracle s. (\<And>s x. lossless_spmf (oracle s x))
    \<Longrightarrow> weight_spmf (exec_gpv oracle \1 s) = 1"
    by(rule lossless_weight_spmfD)(rule lossless_exec_gpv[OF lossless1], simp_all)
  have weight2: "\<And>oracle s cipher \<sigma>. (\<And>s x. lossless_spmf (oracle s x))
    \<Longrightarrow> weight_spmf (exec_gpv oracle (\2 cipher \<sigma>) s) = 1"
    by(rule lossless_weight_spmfD)(rule lossless_exec_gpv[OF lossless2], simp_all)

  let ?oracle1 = "\<lambda>key (s', s) y. map_spmf (\<lambda>((x, s'), s). (x, (), ())) (exec_gpv (prf.prf_oracle key) (prf_encrypt_oracle () y) ())"
  have bisim1: "\<And>key. rel_spmf (\<lambda>(x, _) (y, _). x = y)
          (exec_gpv (ind_cpa.encrypt_oracle key) \1 ())
          (exec_gpv (?oracle1 key) \1 ((), ()))"
    using TrueI
    by(rule exec_gpv_oracle_bisim)(auto simp add: encrypt_def prf_encrypt_oracle_def ind_cpa.encrypt_oracle_def prf.prf_oracle_def o_def)
  have bisim2: "\<And>key cipher \<sigma>. rel_spmf (\<lambda>(x, _) (y, _). x = y)
             (exec_gpv (ind_cpa.encrypt_oracle key) (\2 cipher \<sigma>) ())
             (exec_gpv (?oracle1 key) (\2 cipher \<sigma>) ((), ()))"
    using TrueI
    by(rule exec_gpv_oracle_bisim)(auto simp add: encrypt_def prf_encrypt_oracle_def ind_cpa.encrypt_oracle_def prf.prf_oracle_def o_def)

  have ind_cpa_0: "rel_spmf (=) (ind_cpa.ind_cpa \) (prf.game_0 (prf_adversary \))"
    unfolding IND_CPA.ind_cpa.ind_cpa_def \ key_gen_def Let_def prf_adversary_def Pseudo_Random_Function.prf.game_0_def
    apply(simp)
    apply(rewrite in "bind_spmf _ \<hole>" bind_commute_spmf)
    apply(rule rel_spmf_bind_reflI)
    apply(rule rel_spmf_bindI[OF bisim1])
    apply(clarsimp simp add: if_distribs bind_coin_spmf_eq_const')
    apply(auto intro: rel_spmf_bindI[OF bisim2] intro!: rel_spmf_bind_reflI simp add: encrypt_def prf.prf_oracle_def cong del: if_cong)
    done

  define rf_encrypt where "rf_encrypt = (\<lambda>s plain. bind_spmf (spmf_of_set (nlists UNIV len)) (\<lambda>r :: bool list.
    bind_spmf (prf.random_oracle s r) (\<lambda>(pad, s').
    return_spmf ((r, xor_list plain pad), s')))
  )"
  interpret rf_finite: callee_invariant_on rf_encrypt "\<lambda>s. finite (dom s)" \_full
    by unfold_locales(auto simp add: rf_encrypt_def dest: prf.finite.callee_invariant)
  have lossless_rf_encrypt [simp]: "\<And>s plain. lossless_spmf (rf_encrypt s plain)"
    by(auto simp add: rf_encrypt_def)

  define game2 where "game2 = do {
    (((p0, p1), \<sigma>), s1) \<leftarrow> exec_gpv rf_encrypt \1 Map.empty;
    if valid_plain p0 \<and> valid_plain p1 then do {
      b \<leftarrow> coin_spmf;
      let pb = (if b then p0 else p1);
      (cipher, s2) \<leftarrow> rf_encrypt s1 pb;
      (b', s3) \<leftarrow> exec_gpv rf_encrypt (\2 cipher \<sigma>) s2;
      return_spmf (b' = b)
    } else coin_spmf
  }"

  let ?oracle2 = "\<lambda>(s', s) y. map_spmf (\<lambda>((x, s'), s). (x, (), s)) (exec_gpv prf.random_oracle (prf_encrypt_oracle () y) s)"
  let ?I = "\<lambda>(x, _, s) (y, s'). x = y \<and> s = s'"
  have bisim1: "rel_spmf ?I (exec_gpv ?oracle2 \1 ((), Map.empty)) (exec_gpv rf_encrypt \1 Map.empty)"
     by(rule exec_gpv_oracle_bisim[where X="\<lambda>(_, s) s'. s = s'"])
       (auto simp add: rf_encrypt_def prf_encrypt_oracle_def intro!: rel_spmf_bind_reflI)
  have bisim2: "\<And>cipher \<sigma> s. rel_spmf ?I (exec_gpv ?oracle2 (\2 cipher \<sigma>) ((), s)) (exec_gpv rf_encrypt (\2 cipher \<sigma>) s)"
    by(rule exec_gpv_oracle_bisim[where X="\<lambda>(_, s) s'. s = s'"])
      (auto simp add: prf_encrypt_oracle_def rf_encrypt_def intro!: rel_spmf_bind_reflI)
  have game1_2 [unfolded spmf_rel_eq]: "rel_spmf (=) (prf.game_1 (prf_adversary \)) game2"
    unfolding prf.game_1_def game2_def prf_adversary_def
    by(rewrite in "if _ then \<hole> else _" rf_encrypt_def)
      (auto simp add: Let_def \ if_distribs intro!: rel_spmf_bindI[OF bisim2] rel_spmf_bind_reflI rel_spmf_bindI[OF bisim1])

  define game2_a where "game2_a = do {
    r \<leftarrow> spmf_of_set (nlists UNIV len);
    (((p0, p1), \<sigma>), s1) \<leftarrow> exec_gpv rf_encrypt \1 Map.empty;
    let bad = r \<in> dom s1;
    if valid_plain p0 \<and> valid_plain p1 then do {
      b \<leftarrow> coin_spmf;
      let pb = (if b then p0 else p1);
      (pad, s2) \<leftarrow> prf.random_oracle s1 r;
      let cipher = (r, xor_list pb pad);
      (b', s3) \<leftarrow> exec_gpv rf_encrypt (\2 cipher \<sigma>) s2;
      return_spmf (b' = b, bad)
    } else coin_spmf \<bind> (\<lambda>b. return_spmf (b, bad))
  }"
  define game2_b where "game2_b = do {
    r \<leftarrow> spmf_of_set (nlists UNIV len);
    (((p0, p1), \<sigma>), s1) \<leftarrow> exec_gpv rf_encrypt \1 Map.empty;
    let bad = r \<in> dom s1;
    if valid_plain p0 \<and> valid_plain p1 then do {
      b \<leftarrow> coin_spmf;
      let pb = (if b then p0 else p1);
      pad \<leftarrow> spmf_of_set (nlists UNIV len);
      let cipher = (r, xor_list pb pad);
      (b', s3) \<leftarrow> exec_gpv rf_encrypt (\2 cipher \<sigma>) (s1(r \<mapsto> pad));
      return_spmf (b' = b, bad)
    } else coin_spmf \<bind> (\<lambda>b. return_spmf (b, bad))
  }"

  have "game2 = do {
      r \<leftarrow> spmf_of_set (nlists UNIV len);
      (((p0, p1), \<sigma>), s1) \<leftarrow> exec_gpv rf_encrypt \1 Map.empty;
      if valid_plain p0 \<and> valid_plain p1 then do {
        b \<leftarrow> coin_spmf;
        let pb = (if b then p0 else p1);
        (pad, s2) \<leftarrow> prf.random_oracle s1 r;
        let cipher = (r, xor_list pb pad);
        (b', s3) \<leftarrow> exec_gpv rf_encrypt (\2 cipher \<sigma>) s2;
        return_spmf (b' = b)
      } else coin_spmf
    }"
    including monad_normalisation by(simp add: game2_def split_def rf_encrypt_def Let_def)
  also have "\<dots> = map_spmf fst game2_a" unfolding game2_a_def
    by(clarsimp simp add: map_spmf_conv_bind_spmf Let_def if_distribR if_distrib split_def cong: if_cong)
  finally have game2_2a: "game2 = \<dots>"  .

  have "map_spmf snd game2_a = map_spmf snd game2_b" unfolding game2_a_def game2_b_def
    by(auto simp add: o_def Let_def split_def if_distribs weight2 split: option.split intro: bind_spmf_cong[OF refl])
  moreover
  have "rel_spmf (=) (map_spmf fst (game2_a \<upharpoonleft> (snd -` {False}))) (map_spmf fst (game2_b \<upharpoonleft> (snd -` {False})))"
    unfolding game2_a_def game2_b_def
    by(clarsimp simp add: restrict_bind_spmf o_def Let_def if_distribs split_def restrict_return_spmf prf.random_oracle_def intro!: rel_spmf_bind_reflI split: option.splits)
  hence "spmf game2_a (True, False) = spmf game2_b (True, False)"
     unfolding spmf_rel_eq by(subst (1 2) spmf_map_restrict[symmetric]) simp
  ultimately
  have game2a_2b: "\<bar>spmf (map_spmf fst game2_a) True - spmf (map_spmf fst game2_b) True\<bar> \<le> spmf (map_spmf snd game2_a) True"
    by(subst (1 2) spmf_conv_measure_spmf)(rule identical_until_bad; simp add: spmf.map_id[unfolded id_def] spmf_conv_measure_spmf)

  define game2_a_bad where "game2_a_bad = do {
      r \<leftarrow> spmf_of_set (nlists UNIV len);
      (((p0, p1), \<sigma>), s1) \<leftarrow> exec_gpv rf_encrypt \1 Map.empty;
      return_spmf (r \<in> dom s1)
    }"
  have game2a_bad: "map_spmf snd game2_a = game2_a_bad"
    unfolding game2_a_def game2_a_bad_def
    by(auto intro!: bind_spmf_cong[OF refl] simp add: o_def weight2 Let_def split_def split: if_split)
  have card: "\<And>B :: bool list set. card (B \<inter> nlists UNIV len) \<le> card (nlists UNIV len :: bool list set)"
    by(rule card_mono) simp_all
  then have "spmf game2_a_bad True = \<integral>\<^sup>+ x. card (dom (snd x) \<inter> nlists UNIV len) / 2 ^ len \<partial>measure_spmf (exec_gpv rf_encrypt \1 Map.empty)"
    unfolding game2_a_bad_def
    by(rewrite bind_commute_spmf)(simp add: ennreal_spmf_bind split_def map_mem_spmf_of_set[unfolded map_spmf_conv_bind_spmf] card_nlists)
  also { fix x s
    assume *: "(x, s) \<in> set_spmf (exec_gpv rf_encrypt \1 Map.empty)"
    hence "finite (dom s)" by(rule rf_finite.exec_gpv_invariant) simp_all
    hence 1: "card (dom s \<inter> nlists UNIV len) \<le> card (dom s)" by(intro card_mono) simp_all
    moreover from q1 *
    have "card (dom s) \<le> q1 + card (dom (Map.empty :: (plain, plain) prf.dict))"
      by(rule rf_finite.interaction_bounded_by'_exec_gpv_count)
        (auto simp add: rf_encrypt_def eSuc_enat prf.random_oracle_def card_insert_if split: option.split_asm if_split)
    ultimately have "card (dom s \<inter> nlists UNIV len) \<le> q1" by(simp) }
  then have "\<dots> \<le>  \<integral>\<^sup>+ x. q1 / 2 ^ len \<partial>measure_spmf (exec_gpv rf_encrypt \1 Map.empty)"
    by(intro nn_integral_mono_AE)(clarsimp simp add: field_simps)
  also have "\<dots> \<le> q1 / 2 ^ len"
    by(simp add: measure_spmf.emeasure_eq_measure field_simps mult_left_le weight1)
  finally have game2a_bad_bound: "spmf game2_a_bad True \<le> q1 / 2 ^ len" by simp

  define rf_encrypt_bad
    where "rf_encrypt_bad = (\<lambda>secret (s :: (plain, plain) prf.dict, bad) plain. bind_spmf
     (spmf_of_set (nlists UNIV len)) (\<lambda>r.
     bind_spmf (prf.random_oracle s r) (\<lambda>(pad, s').
     return_spmf ((r, xor_list plain pad), (s', bad \<or> r = secret)))))"
  have rf_encrypt_bad_sticky [simp]: "\<And>s. callee_invariant (rf_encrypt_bad s) snd"
    by(unfold_locales)(auto simp add: rf_encrypt_bad_def)
  have lossless_rf_encrypt [simp]: "\<And>challenge s plain. lossless_spmf (rf_encrypt_bad challenge s plain)"
    by(clarsimp simp add: rf_encrypt_bad_def prf.random_oracle_def split: option.split)

  define game2_c where "game2_c = do {
    r \<leftarrow> spmf_of_set (nlists UNIV len);
    (((p0, p1), \<sigma>), s1) \<leftarrow> exec_gpv rf_encrypt \1 Map.empty;
    if valid_plain p0 \<and> valid_plain p1 then do {
      b \<leftarrow> coin_spmf;
      let pb = (if b then p0 else p1);
      pad \<leftarrow> spmf_of_set (nlists UNIV len);
      let cipher = (r, xor_list pb pad);
      (b', (s2, bad)) \<leftarrow> exec_gpv (rf_encrypt_bad r) (\2 cipher \<sigma>) (s1(r \<mapsto> pad), False);
      return_spmf (b' = b, bad)
    } else coin_spmf \<bind> (\<lambda>b. return_spmf (b, False))
  }"

  have bisim2c_bad: "\<And>cipher \<sigma> s x r. rel_spmf (\<lambda>(x, _) (y, _). x = y)
    (exec_gpv rf_encrypt (\2 cipher \<sigma>) (s(x \<mapsto> r)))
    (exec_gpv (rf_encrypt_bad x) (\2 cipher \<sigma>) (s(x \<mapsto> r), False))"
    by(rule exec_gpv_oracle_bisim[where X="\<lambda>s (s', _). s = s'"])
      (auto simp add: rf_encrypt_bad_def rf_encrypt_def intro!: rel_spmf_bind_reflI)

  have game2b_c [unfolded spmf_rel_eq]: "rel_spmf (=) (map_spmf fst game2_b) (map_spmf fst game2_c)"
    by(auto simp add: game2_b_def game2_c_def o_def split_def Let_def if_distribs intro!: rel_spmf_bind_reflI rel_spmf_bindI[OF bisim2c_bad])

  define game2_d where "game2_d = do {
    r \<leftarrow> spmf_of_set (nlists UNIV len);
    (((p0, p1), \<sigma>), s1) \<leftarrow> exec_gpv rf_encrypt \1 Map.empty;
    if valid_plain p0 \<and> valid_plain p1 then do {
      b \<leftarrow> coin_spmf;
      let pb = (if b then p0 else p1);
      pad \<leftarrow> spmf_of_set (nlists UNIV len);
      let cipher = (r, xor_list pb pad);
      (b', (s2, bad)) \<leftarrow> exec_gpv (rf_encrypt_bad r) (\2 cipher \<sigma>) (s1, False);
      return_spmf (b' = b, bad)
    } else coin_spmf \<bind> (\<lambda>b. return_spmf (b, False))
  }"

  { fix cipher \<sigma> and x :: plain and s r
    let ?I = "(\<lambda>(x, s, bad) (y, s', bad'). (bad \<longleftrightarrow> bad') \<and> (\<not> bad' \<longrightarrow> x \<longleftrightarrow> y))"
    let ?X = "\<lambda>(s, bad) (s', bad'). bad = bad' \<and> (\<forall>z. z \<noteq> x \<longrightarrow> s z = s' z)"
    have "\<And>s1 s2 x'. ?X s1 s2 \<Longrightarrow> rel_spmf (\<lambda>(a, s1') (b, s2'). snd s1' = snd s2' \<and> (\<not> snd s2' \<longrightarrow> a = b \<and> ?X s1' s2'))
       (rf_encrypt_bad x s1 x') (rf_encrypt_bad x s2 x')"
      by(case_tac "x = x'")(clarsimp simp add: rf_encrypt_bad_def prf.random_oracle_def rel_spmf_return_spmf1 rel_spmf_return_spmf2 Let_def split_def bind_UNION intro!: rel_spmf_bind_reflI split: option.split)+
    with _ _ have "rel_spmf ?I
             (exec_gpv (rf_encrypt_bad x) (\2 cipher \<sigma>) (s(x \<mapsto> r), False))
             (exec_gpv (rf_encrypt_bad x) (\2 cipher \<sigma>) (s, False))"
      by(rule exec_gpv_oracle_bisim_bad_full)(auto simp add: lossless2) }
  note bisim_bad = this
  have game2c_2d_bad [unfolded spmf_rel_eq]: "rel_spmf (=) (map_spmf snd game2_c) (map_spmf snd game2_d)"
    by(auto simp add: game2_c_def game2_d_def o_def Let_def split_def if_distribs intro!: rel_spmf_bind_reflI rel_spmf_bindI[OF bisim_bad])
  moreover
  have "rel_spmf (=) (map_spmf fst (game2_c \<upharpoonleft> (snd -` {False}))) (map_spmf fst (game2_d \<upharpoonleft> (snd -` {False})))"
    unfolding game2_c_def game2_d_def
    by(clarsimp simp add: restrict_bind_spmf o_def Let_def if_distribs split_def restrict_return_spmf intro!: rel_spmf_bind_reflI rel_spmf_bindI[OF bisim_bad])
  hence "spmf game2_c (True, False) = spmf game2_d (True, False)"
    unfolding spmf_rel_eq by(subst (1 2) spmf_map_restrict[symmetric]) simp
  ultimately have game2c_2d: "\<bar>spmf (map_spmf fst game2_c) True - spmf (map_spmf fst game2_d) True\<bar> \<le> spmf (map_spmf snd game2_c) True"
    apply(subst (1 2) spmf_conv_measure_spmf)
    apply(intro identical_until_bad)
    apply(simp_all add: spmf.map_id[unfolded id_def] spmf_conv_measure_spmf)
    done
  { fix cipher \<sigma> and challenge :: plain and s
    have "card (nlists UNIV len \<inter> (\<lambda>x. x = challenge) -` {True}) \<le> card {challenge}"
      by(rule card_mono) auto
    then have "spmf (map_spmf (snd \<circ> snd) (exec_gpv (rf_encrypt_bad challenge) (\2 cipher \<sigma>) (s, False))) True \<le> (1 / 2 ^ len) * q2"
      by(intro oi_True.interaction_bounded_by_exec_gpv_bad[OF q2])(simp_all add: rf_encrypt_bad_def o_def split_beta map_spmf_conv_bind_spmf[symmetric] spmf_map measure_spmf_of_set field_simps card_nlists)
    hence "(\<integral>\<^sup>+ x. ennreal (indicator {True} x) \<partial>measure_spmf (map_spmf (snd \<circ> snd) (exec_gpv (rf_encrypt_bad challenge) (\2 cipher \<sigma>) (s, False)))) \<le> (1 / 2 ^ len) * q2"
      by(simp only: ennreal_indicator nn_integral_indicator sets_measure_spmf sets_count_space Pow_UNIV UNIV_I emeasure_spmf_single) simp }
  then have "spmf (map_spmf snd game2_d) True \<le>
        \<integral>\<^sup>+ (r :: plain). \<integral>\<^sup>+ (((p0, p1), \<sigma>), s). (if valid_plain p0 \<and> valid_plain p1 then
             \<integral>\<^sup>+ b . \<integral>\<^sup>+ (pad :: plain). q2 / 2 ^ len \<partial>measure_spmf (spmf_of_set (nlists UNIV len)) \<partial>measure_spmf coin_spmf
              else 0)
           \<partial>measure_spmf (exec_gpv rf_encrypt \1 Map.empty) \<partial>measure_spmf (spmf_of_set (nlists UNIV len))"
      unfolding game2_d_def
      by(simp add: ennreal_spmf_bind o_def split_def Let_def if_distribs if_distrib[where f="\<lambda>x. ennreal (spmf x _)"] indicator_single_Some nn_integral_mono if_mono_cong del: nn_integral_const cong: if_cong)
  also have "\<dots> \<le> \<integral>\<^sup>+ (r :: plain). \<integral>\<^sup>+ (((p0, p1), \<sigma>), s). (if valid_plain p0 \<and> valid_plain p1 then ennreal (q2 / 2 ^ len) else q2 / 2 ^ len)
                   \<partial>measure_spmf (exec_gpv rf_encrypt \1 Map.empty) \<partial>measure_spmf (spmf_of_set (nlists UNIV len))"
    unfolding split_def
    by(intro nn_integral_mono if_mono_cong)(auto simp add: measure_spmf.emeasure_eq_measure)
  also have "\<dots> \<le> q2 / 2 ^ len" by(simp add: split_def weight1 measure_spmf.emeasure_eq_measure)
  finally have game2_d_bad: "spmf (map_spmf snd game2_d) True \<le> q2 / 2 ^ len" by simp

  define game3 where "game3 = do {
      (((p0, p1), \<sigma>), s1) \<leftarrow> exec_gpv rf_encrypt \1 Map.empty;
      if valid_plain p0 \<and> valid_plain p1 then do {
        b \<leftarrow> coin_spmf;
        let pb = (if b then p0 else p1);
        r \<leftarrow> spmf_of_set (nlists UNIV len);
        pad \<leftarrow> spmf_of_set (nlists UNIV len);
        let cipher = (r, xor_list pb pad);
        (b', s2) \<leftarrow> exec_gpv rf_encrypt (\2 cipher \<sigma>) s1;
        return_spmf (b' = b)
      } else coin_spmf
    }"
  have bisim2d_3: "\<And>cipher \<sigma> s r. rel_spmf (\<lambda>(x, _) (y, _). x = y)
             (exec_gpv (rf_encrypt_bad r) (\2 cipher \<sigma>) (s, False))
             (exec_gpv rf_encrypt (\2 cipher \<sigma>) s)"
    by(rule exec_gpv_oracle_bisim[where X="\<lambda>(s1, _) s2. s1 = s2"])(auto simp add: rf_encrypt_bad_def rf_encrypt_def intro!: rel_spmf_bind_reflI)
  have game2d_3: "rel_spmf (=) (map_spmf fst game2_d) game3"
    unfolding game2_d_def game3_def Let_def including monad_normalisation
    by(clarsimp simp add: o_def split_def if_distribs cong: if_cong intro!: rel_spmf_bind_reflI rel_spmf_bindI[OF bisim2d_3])

  have "\<bar>spmf game2 True - 1 / 2\<bar> \<le>
    \<bar>spmf (map_spmf fst game2_a) True - spmf (map_spmf fst game2_b) True\<bar> + \<bar>spmf (map_spmf fst game2_b) True - 1 / 2\<bar>"
    unfolding game2_2a by(rule abs_diff_triangle_ineq2)
  also have "\<dots> \<le> q1 / 2 ^ len + \<bar>spmf (map_spmf fst game2_b) True - 1 / 2\<bar>"
    using game2a_2b game2a_bad_bound unfolding game2a_bad by(intro add_right_mono) simp
  also have "\<bar>spmf (map_spmf fst game2_b) True - 1 / 2\<bar> \<le>
    \<bar>spmf (map_spmf fst game2_c) True - spmf (map_spmf fst game2_d) True\<bar> + \<bar>spmf (map_spmf fst game2_d) True - 1 / 2\<bar>"
    unfolding game2b_c by(rule abs_diff_triangle_ineq2)
  also (add_left_mono_trans) have "\<dots> \<le> q2 / 2 ^ len + \<bar>spmf (map_spmf fst game2_d) True - 1 / 2\<bar>"
    using game2c_2d game2_d_bad unfolding game2c_2d_bad by(intro add_right_mono) simp
  finally (add_left_mono_trans)
  have game2: "\<bar>spmf game2 True - 1 / 2\<bar> \<le> q1 / 2 ^ len + q2 / 2 ^ len +  \<bar>spmf game3 True - 1 / 2\<bar>"
    using game2d_3 by(simp add: field_simps spmf_rel_eq)

  have "game3 = do {
      (((p0, p1), \<sigma>), s1) \<leftarrow> exec_gpv rf_encrypt \1 Map.empty;
      if valid_plain p0 \<and> valid_plain p1 then do {
        b \<leftarrow> coin_spmf;
        let pb = (if b then p0 else p1);
        r \<leftarrow> spmf_of_set (nlists UNIV len);
        pad \<leftarrow> map_spmf (xor_list pb) (spmf_of_set (nlists UNIV len));
        let cipher = (r, xor_list pb pad);
        (b', s2) \<leftarrow> exec_gpv rf_encrypt (\2 cipher \<sigma>) s1;
        return_spmf (b' = b)
      } else coin_spmf
    }"
    by(simp add: valid_plain_def game3_def Let_def one_time_pad del: bind_map_spmf map_spmf_of_set_inj_on cong: bind_spmf_cong_simp if_cong split: if_split)
  also have "\<dots> = do {
       (((p0, p1), \<sigma>), s1) \<leftarrow> exec_gpv rf_encrypt \1 Map.empty;
       if valid_plain p0 \<and> valid_plain p1 then do {
         b \<leftarrow> coin_spmf;
         let pb = (if b then p0 else p1);
         r \<leftarrow> spmf_of_set (nlists UNIV len);
         pad \<leftarrow> spmf_of_set (nlists UNIV len);
         let cipher = (r, pad);
         (b', _) \<leftarrow> exec_gpv rf_encrypt (\2 cipher \<sigma>) s1;
         return_spmf (b' = b)
       } else coin_spmf
     }"
     by(simp add: game3_def Let_def valid_plain_def in_nlists_UNIV cong: bind_spmf_cong_simp if_cong split: if_split)
  also have "\<dots> = do {
      (((p0, p1), \<sigma>), s1) \<leftarrow> exec_gpv rf_encrypt \1 Map.empty;
      if valid_plain p0 \<and> valid_plain p1 then do {
        r \<leftarrow> spmf_of_set (nlists UNIV len);
        pad \<leftarrow> spmf_of_set (nlists UNIV len);
        let cipher = (r, pad);
        (b', _) \<leftarrow> exec_gpv rf_encrypt (\2 cipher \<sigma>) s1;
        map_spmf ((=) b') coin_spmf
      } else coin_spmf
    }"
    including monad_normalisation by(simp add: map_spmf_conv_bind_spmf split_def Let_def)
  also have "\<dots> = coin_spmf"
    by(simp add: map_eq_const_coin_spmf Let_def split_def weight2 weight1)
  finally have game3: "game3 = coin_spmf" .

  have "ind_cpa.advantage \ \<le> prf.advantage (prf_adversary \) + \<bar>spmf (prf.game_1 (prf_adversary \)) True - 1 / 2\<bar>"
    unfolding ind_cpa.advantage_def prf.advantage_def ind_cpa_0[unfolded spmf_rel_eq]
    by(rule abs_diff_triangle_ineq2)
  also have "\<bar>spmf (prf.game_1 (prf_adversary \)) True - 1 / 2\<bar> \<le> q1 / 2 ^ len + q2 / 2 ^ len"
    using game1_2 game2 game3 by(simp add: spmf_of_set)
  also have "\<dots> = (q1 + q2) / 2 ^ len" by(simp add: field_simps)
  also have "\<dots> \<le> q / 2 ^ len" using \<open>q1 + q2 \<le> q\<close> by(simp add: divide_right_mono)
  finally show ?thesis by(simp add: field_simps)
qed

lemma interaction_bounded_prf_adversary:
  fixes q :: nat
  assumes "ind_cpa.ibounded_by \ q"
  shows "prf.ibounded_by (prf_adversary \) (1 + q)"
proof -
  fix \<eta>
  from assms have "ind_cpa.ibounded_by \ q" by blast
  then obtain q1 q2 where q: "q1 + q2 \<le> q"
    and [interaction_bound]: "interaction_any_bounded_by (fst \) q1"
       "\<And>x \<sigma>. interaction_any_bounded_by (snd \ x \<sigma>) q2"
    unfolding ind_cpa.ibounded_by_def by(auto simp add: split_beta iadd_le_enat_iff)
  show "prf.ibounded_by (prf_adversary \) (1 + q)" using q
    apply (simp only: prf_adversary_def Let_def split_def)
    apply -
    apply interaction_bound
      apply (auto simp add: iadd_SUP_le_iff SUP_le_iff add.assoc [symmetric] one_enat_def cong del: image_cong_simp cong add: SUP_cong_simp)
    done
qed

lemma lossless_prf_adversary: "ind_cpa.lossless \ \<Longrightarrow> prf.lossless (prf_adversary \)"
by(fastforce simp add: prf_adversary_def Let_def split_def ind_cpa.lossless_def intro: lossless_inline)

end

locale otp_\<eta> =
  fixes f :: "security \<Rightarrow> key \<Rightarrow> bool list \<Rightarrow> bool list"
  and len :: "security \<Rightarrow> nat"
  assumes length_f: "\<And>\<eta> xs ys. \<lbrakk> length xs = len \<eta>; length ys = len \<eta> \<rbrakk> \<Longrightarrow> length (f \<eta> xs ys) = len \<eta>"
  and negligible_len [negligible_intros]: "negligible (\<lambda>\<eta>. 1 / 2 ^ (len \<eta>))"
begin

interpretation otp "f \<eta>" "len \<eta>" for \<eta> by(unfold_locales)(rule length_f)
interpretation ind_cpa: ind_cpa "key_gen \<eta>" "encrypt \<eta>" "decrypt \<eta>" "valid_plain \<eta>" for \<eta> .
interpretation "prf": "prf" "key_gen \<eta>" "f \<eta>" "spmf_of_set (nlists UNIV (len \<eta>))" for \<eta> .

lemma prf_encrypt_secure_for:
  assumes [negligible_intros]: "negligible (\<lambda>\<eta>. prf.advantage \<eta> (prf_adversary \<eta> (\ \<eta>)))"
  and q: "\<And>\<eta>. ind_cpa.ibounded_by (\ \<eta>) (q \<eta>)" and [negligible_intros]: "polynomial q"
  and lossless: "\<And>\<eta>. ind_cpa.lossless (\ \<eta>)"
  shows "negligible (\<lambda>\<eta>. ind_cpa.advantage \<eta> (\ \<eta>))"
proof(rule negligible_mono)
  show "negligible (\<lambda>\<eta>. prf.advantage \<eta> (prf_adversary \<eta> (\ \<eta>)) + q \<eta> / 2 ^ len \<eta>)"
    by(intro negligible_intros)
  { fix \<eta>
    from \<open>ind_cpa.ibounded_by _ _\<close> have "ind_cpa.ibounded_by (\ \<eta>) (q \<eta>)" by blast
    moreover from lossless have "ind_cpa.lossless (\ \<eta>)" by blast
    hence "lossless_gpv \_full (fst (\ \<eta>))" "\<And>cipher \<sigma>. lossless_gpv \_full (snd (\ \<eta>) cipher \<sigma>)"
      by(auto simp add: ind_cpa.lossless_def)
    ultimately have "ind_cpa.advantage \<eta> (\ \<eta>) \<le> prf.advantage \<eta> (prf_adversary \<eta> (\ \<eta>)) + q \<eta> / 2 ^ len \<eta>"
      by(rule prf_encrypt_advantage) }
  hence "eventually (\<lambda>\<eta>. \<bar>ind_cpa.advantage \<eta> (\ \<eta>)\<bar> \<le> 1 * \<bar>prf.advantage \<eta> (prf_adversary \<eta> (\ \<eta>)) + q \<eta> / 2 ^ len \<eta>\<bar>) at_top"
    by(simp add: always_eventually ind_cpa.advantage_nonneg prf.advantage_nonneg)
  then show "(\<lambda>\<eta>. ind_cpa.advantage \<eta> (\ \<eta>)) \<in> O(\<lambda>\<eta>. prf.advantage \<eta> (prf_adversary \<eta> (\ \<eta>)) + q \<eta> / 2 ^ len \<eta>)"
    by(intro bigoI[where c=1]) simp
qed

end

end