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

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

theory OpSem
imports
  Basis
  PCF "Eval_Base.Eval_Base"
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"
  apply2 (induct t arbitrary: i k) by auto

lemma lift_subst:
    "j < i + 1 \<Longrightarrow> lift (t<s/j>) i = (lift t (i + 1))<lift s i / j>"
  apply2 (induct t arbitrary: i j s)
     by (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>"
  apply2 (induct t arbitrary: i j s) by (auto simp: subst_Var lift_lift)

lemma subst_lift:
    "(lift t k)<s/k> = t"
  apply2 (induct t arbitrary: k s) by (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>"
  apply2 (induct t arbitrary: i j u v)
     by (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>"
  apply2 (induct s arbitrary: i t u) by (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))"
  apply2 (induct t arbitrary: i k) by (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))"
apply2 (induct s arbitrary: i k t) by (auto simp:  subst_Var split: nat.split)

theorem lift_subst_dummy:
  "\<not> freedb s i \<Longrightarrow> lift (s<dummy/i>) i = s"
apply2 (induct s arbitrary: i dummy) by (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"
apply2 (induct e arbitrary: k) by (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
proof2(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
proof2(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)"
  apply2 (induct \<Gamma> arbitrary: i) by 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
proof2(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
proof2(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
proof2(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 apply2 induct by blast+

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

lemma evalOP_deterministic:
  assumes "P \<Down> V"
  assumes "P \<Down> V'"
  shows "V = V'"
using assms
proof2(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
apply2 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))"
proof2(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)"
proof2(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
proof2(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
  apply2 (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
proof2(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
  apply2 (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>"
proof2(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
  apply2 (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>
     apply2 (induct rule: val.induct)
  apply simp_all
  using \<open>val v2\<close>
    apply2 (induct rule: val.induct)
  apply simp_all
  using \<open>val v2\<close>
   apply2 (induct rule: val.induct)
  apply simp_all
  using \<open>val v2\<close>
  apply2 (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/Analysis/Metric_Arith.thy
    Author:     Maximilian Schäffeler (port from HOL Light)
*)

chapter \<open>Functional Analysis\<close>

section\<^marker>\<open>tag unimportant\<close> \<open>A decision procedure for metric spaces\<close>

theory Metric_Arith
  imports HOL.Real_Vector_Spaces
begin

text\<^marker>\<open>tag unimportant\<close> \<open>
A port of the decision procedure ``Formalization of metric spaces in HOL Light''
\<^cite>\<open>"DBLP:journals/jar/Maggesi18"\<close> for the type class @{class metric_space},
with the \<open>Argo\<close> solver as backend.
\<close>

named_theorems metric_prenex
named_theorems metric_nnf
named_theorems metric_unfold
named_theorems metric_pre_arith

lemmas pre_arith_simps =
  max.bounded_iff max_less_iff_conj
  le_max_iff_disj less_max_iff_disj
  simp_thms HOL.eq_commute
declare pre_arith_simps [metric_pre_arith]

lemmas unfold_simps =
  Un_iff subset_iff disjoint_iff_not_equal
  Ball_def Bex_def
declare unfold_simps [metric_unfold]

declare HOL.nnf_simps(4) [metric_prenex]

lemma imp_prenex [metric_prenex]:
  "\<And>P Q. (\<exists>x. P x) \<longrightarrow> Q \<equiv> \<forall>x. (P x \<longrightarrow> Q)"
  "\<And>P Q. P \<longrightarrow> (\<exists>x. Q x) \<equiv> \<exists>x. (P \<longrightarrow> Q x)"
  "\<And>P Q. (\<forall>x. P x) \<longrightarrow> Q \<equiv> \<exists>x. (P x \<longrightarrow> Q)"
  "\<And>P Q. P \<longrightarrow> (\<forall>x. Q x) \<equiv> \<forall>x. (P \<longrightarrow> Q x)"
  by simp_all

lemma ex_prenex [metric_prenex]:
  "\<And>P Q. (\<exists>x. P x) \<and> Q \<equiv> \<exists>x. (P x \<and> Q)"
  "\<And>P Q. P \<and> (\<exists>x. Q x) \<equiv> \<exists>x. (P \<and> Q x)"
  "\<And>P Q. (\<exists>x. P x) \<or> Q \<equiv> \<exists>x. (P x \<or> Q)"
  "\<And>P Q. P \<or> (\<exists>x. Q x) \<equiv> \<exists>x. (P \<or> Q x)"
  "\<And>P. \<not>(\<exists>x. P x) \<equiv> \<forall>x. \<not>P x"
  by simp_all

lemma all_prenex [metric_prenex]:
  "\<And>P Q. (\<forall>x. P x) \<and> Q \<equiv> \<forall>x. (P x \<and> Q)"
  "\<And>P Q. P \<and> (\<forall>x. Q x) \<equiv> \<forall>x. (P \<and> Q x)"
  "\<And>P Q. (\<forall>x. P x) \<or> Q \<equiv> \<forall>x. (P x \<or> Q)"
  "\<And>P Q. P \<or> (\<forall>x. Q x) \<equiv> \<forall>x. (P \<or> Q x)"
  "\<And>P. \<not>(\<forall>x. P x) \<equiv> \<exists>x. \<not>P x"
  by simp_all

lemma nnf_thms [metric_nnf]:
  "(\<not> (P \<and> Q)) = (\<not> P \<or> \<not> Q)"
  "(\<not> (P \<or> Q)) = (\<not> P \<and> \<not> Q)"
  "(P \<longrightarrow> Q) = (\<not> P \<or> Q)"
  "(P = Q) \<longleftrightarrow> (P \<or> \<not> Q) \<and> (\<not> P \<or> Q)"
  "(\<not> (P = Q)) \<longleftrightarrow> (\<not> P \<or> \<not> Q) \<and> (P \<or> Q)"
  "(\<not> \<not> P) = P"
  by blast+

lemmas nnf_simps = nnf_thms linorder_not_less linorder_not_le
declare nnf_simps[metric_nnf]

lemma ball_insert: "(\<forall>x\<in>insert a B. P x) = (P a \<and> (\<forall>x\<in>B. P x))"
  by blast

lemma Sup_insert_insert:
  fixes a::real
  shows "Sup (insert a (insert b s)) = Sup (insert (max a b) s)"
  by (simp add: Sup_real_def)

lemma real_abs_dist: "\<bar>dist x y\<bar> = dist x y"
  by simp

lemma maxdist_thm [THEN HOL.eq_reflection]:
  assumes "finite s" "x \<in> s" "y \<in> s"
  defines "\<And>a. f a \<equiv> \<bar>dist x a - dist a y\<bar>"
  shows "dist x y = Sup (f ` s)"
proof -
  have "dist x y \<le> Sup (f ` s)"
  proof -
    have "finite (f ` s)"
      by (simp add: \<open>finite s\<close>)
    moreover have "\<bar>dist x y - dist y y\<bar> \<in> f ` s"
      by (metis \<open>y \<in> s\<close> f_def imageI)
    ultimately show ?thesis
      using le_cSup_finite by simp
  qed
  also have "Sup (f ` s) \<le> dist x y"
    using \<open>x \<in> s\<close> cSUP_least[of s f] abs_dist_diff_le
    unfolding f_def
    by blast
  finally show ?thesis .
qed

theorem metric_eq_thm [THEN HOL.eq_reflection]:
  "x \<in> s \<Longrightarrow> y \<in> s \<Longrightarrow> x = y \<longleftrightarrow> (\<forall>a\<in>s. dist x a = dist y a)"
  by auto

ML_file \<open>metric_arith.ML\<close>

method_setup metric = \<open>
  Scan.succeed (SIMPLE_METHOD' o Metric_Arith.metric_arith_tac)
\<close> "prove simple linear statements in metric spaces (\<forall>\<exists>\<^sub>p fragment)"

end


subsection\<open>Progress\<close>

theory Progress
  imports TypePreservation
begin

text\<open>We say that a term $t$ is in \emph{weak-head-normal} form when one of the following conditions are met:
  \begin{enumerate}
    \item $t$ is a value,
    \item there exists $\alpha$ and $v$ such that $t = \mu:\tau.[\alpha]\ v$ with $\alpha \in fcv(v)$
          whenever $\alpha = 0$.
  \end{enumerate}\<close>

fun (sequential) is_nf :: "trm \<Rightarrow> bool" where
  "is_nf (\<mu> U: (<\<beta>> v)) = (is_val v \<and> (\<beta> = 0 \<longrightarrow> 0 \<in> fmv_trm v 0))" |
  "is_nf v = is_val v"

lemma progress':
  "\<Gamma>, \<Delta> \<turnstile>\<^sub>T t : T \<Longrightarrow> lambda_closed t \<Longrightarrow> (\<forall> s. \<not>(t \<longlonglongrightarrow> s)) \<Longrightarrow> is_nf t"
  "\<Gamma>, \<Delta> \<turnstile>\<^sub>C c \<Longrightarrow> lambda_closedC c  \<Longrightarrow> (\<forall> \<beta> t. c = (<\<beta>> t) \<longrightarrow> (\<forall> d. \<not>(t \<longlonglongrightarrow> d)) \<longrightarrow> is_nf t)"
proof (induct rule: typing_trm_typing_cmd.inducts)
  case (app \<Gamma> \<Delta> t T1 T2 s)
  then show ?case
    by -(erule type_arrow_elim; force)
next
  case (activate \<Gamma> \<Delta> T c)
  then show ?case
    proof(cases c)
      case (MVar \<alpha> t)
      then show ?thesis
        using activate by (case_tac t; force)
    qed
qed force+

theorem progress:
  assumes "\<Gamma>, \<Delta> \<turnstile>\<^sub>T t : T" "lambda_closed t"
  shows   "is_nf t \<or> (\<exists> s. t \<longlonglongrightarrow> s)"
using assms by (fastforce intro: progress')

end


section \<open>LLL certification via Hermite normal forms\<close>

text \<open>In this file, we define the new certified approach and prove its soundness.\<close>

theory LLL_Certification_via_HNF
  imports
   LLL_Basis_Reduction.LLL_Certification
   Jordan_Normal_Form.DL_Rank
   HNF_Mod_Det_Soundness
begin

context LLL_with_assms
begin

lemma m_le_n: "m\<le>n"
proof -
  have "gs.lin_indpt (set (RAT fs_init))"
    using cof_vec_space.lin_indpt_list_def lin_dep by blast
  moreover have "gs.dim = n"
    by (simp add: gs.dim_is_n)
  moreover have "card (set (RAT fs_init)) = m"
    using LLL_invD(2) LLL_inv_initial_state cof_vec_space.lin_indpt_list_def distinct_card lin_dep
    by blast
  ultimately show ?thesis using gs.li_le_dim
    by (metis cof_vec_space.lin_indpt_list_def gs.fin_dim lin_dep)
qed

end

text \<open>This lemma is a generalization of the theorem named @{text "HNF_A_eq_HNF_PA"}, using
the new uniqueness statement of the HNF. We provide two versions, one
assuming the existence and the other one obtained from a sound algorithm.\<close>

lemma HNF_A_eq_HNF_PA'_exist:
  fixes A::"int mat"
  assumes A: "A \<in> carrier_mat n n" and inv_A: "invertible_mat (map_mat rat_of_int A)"
    and inv_P: "invertible_mat P" and P: "P \<in> carrier_mat n n"
    and HNF_H1: "Hermite_JNF associates res H1"
    and H1: "H1 \<in> carrier_mat n n"
    and HNF_H2: "Hermite_JNF associates res H2"
    and H2: "H2 \<in> carrier_mat n n"
    and sound_HNF1: "\<exists>P1. P1 \<in> carrier_mat n n \<and> invertible_mat P1 \<and> (P * A) = P1 * H1"
    and sound_HNF2: "\<exists>P2. P2 \<in> carrier_mat n n \<and> invertible_mat P2 \<and> A = P2 * H2"
  shows "H1 = H2"
proof -
  obtain inv_P where P_inv_P: "inverts_mat P inv_P" and inv_P_P: "inverts_mat inv_P P"
    and inv_P: "inv_P \<in> carrier_mat n n"
    using P inv_P obtain_inverse_matrix by blast
  obtain P1 where P1: "P1 \<in> carrier_mat n n" and inv_P1: "invertible_mat P1" and P1_H1: "P* A = P1 * H1"
    using sound_HNF1 by auto
  obtain P2 where P2: "P2 \<in> carrier_mat n n" and inv_P2: "invertible_mat P2" and P2_H2: "A = P2 * H2"
    using sound_HNF2 by auto
  have invertible_inv_P: "invertible_mat inv_P"
      using P_inv_P inv_P inv_P_P invertible_mat_def square_mat.simps by blast
  have P_A_P1_H1: "P * A = P1 * H1" using P1_H1 P2_H2 unfolding is_sound_HNF_def Let_def
    by (metis (mono_tags, lifting) case_prod_conv)
  hence "A = inv_P * (P1 * H1)"
    by (smt A P inv_P_P inv_P assoc_mult_mat carrier_matD(1) inverts_mat_def left_mult_one_mat)
  hence A_inv_P_P1_H1: "A = (inv_P * P1) * H1" using P P1_H1 assoc_mult_mat inv_P H1 P1 by auto
  have invertible_inv_P_P1: "invertible_mat (inv_P * P1)"
    by (rule invertible_mult_JNF[OF inv_P P1 invertible_inv_P inv_P1])
  show ?thesis
  proof (rule HNF_unique_generalized_JNF[OF A _ H1 P2 H2 A_inv_P_P1_H1 P2_H2
        inv_A invertible_inv_P_P1 inv_P2 HNF_H1 HNF_H2])
    show "inv_P * P1 \<in> carrier_mat n n"
      by (metis carrier_matD(1) carrier_matI index_mult_mat(2) inv_P
          invertible_inv_P_P1 invertible_mat_def square_mat.simps)
  qed
qed

corollary HNF_A_eq_HNF_PA':
  fixes A::"int mat"
  assumes A: "A \<in> carrier_mat n n" and inv_A: "invertible_mat (map_mat rat_of_int A)"
    and inv_P: "invertible_mat P" and P: "P \<in> carrier_mat n n"
    and sound_HNF: "is_sound_HNF HNF associates res"
    and P1_H1: "(P1,H1) = HNF (P*A)"
    and P2_H2: "(P2,H2) = HNF A"
  shows "H1 = H2"
proof -
  have H1: "H1 \<in> carrier_mat n n"
    by (smt P1_H1 A P carrier_matD index_mult_mat is_sound_HNF_def prod.sel(2) sound_HNF split_beta)
  have H2: "H2 \<in> carrier_mat n n"
    by (smt P2_H2 A carrier_matD index_mult_mat is_sound_HNF_def prod.sel(2) sound_HNF split_beta)
  have HNF_H1: "Hermite_JNF associates res H1"
    by (smt P1_H1 is_sound_HNF_def prod.sel(2) sound_HNF split_beta)
  have HNF_H2: "Hermite_JNF associates res H2"
    by (smt P2_H2 is_sound_HNF_def prod.sel(2) sound_HNF split_beta)
  have sound_HNF1: "\<exists>P1. P1 \<in> carrier_mat n n \<and> invertible_mat P1 \<and> (P * A) = P1 * H1"
    using sound_HNF P1_H1 unfolding is_sound_HNF_def Let_def
    by (metis (mono_tags, lifting) P carrier_matD(1) index_mult_mat(2) old.prod.simps(2))
  have sound_HNF2: "\<exists>P2. P2 \<in> carrier_mat n n \<and> invertible_mat P2 \<and> A = P2 * H2"
    using sound_HNF P1_H1 unfolding is_sound_HNF_def Let_def
    by (metis (mono_tags, lifting) A P2_H2 carrier_matD(1) old.prod.simps(2))
  show ?thesis
    by (rule HNF_A_eq_HNF_PA'_exist[OF A inv_A inv_P P HNF_H1 H1 HNF_H2 H2 sound_HNF1 sound_HNF2])
qed

context LLL_with_assms
begin

lemma certification_via_eq_HNF2_exist:
  assumes HNF_H1: "Hermite_JNF associates res H1"
    and H1: "H1 \<in> carrier_mat n n"
    and HNF_H2: "Hermite_JNF associates res H2"
    and H2: "H2 \<in> carrier_mat n n"
    and sound_HNF1: "\<exists>P1. P1 \<in> carrier_mat n n \<and> invertible_mat P1 \<and> (mat_of_rows n fs_init) = P1 * H1"
    and sound_HNF2: "\<exists>P2. P2 \<in> carrier_mat n n \<and> invertible_mat P2 \<and> (mat_of_rows n gs) = P2 * H2"
    and gs: "set gs \<subseteq> carrier_vec n"
    and l: "lattice_of fs_init = lattice_of gs"
    and mn: "m = n" and len_gs: "length gs = n" (*For the moment, only for square matrices*)
  shows "H1 = H2"
proof -
  have "\<exists>P \<in> carrier_mat n n. invertible_mat P \<and> mat_of_rows n fs_init = P * mat_of_rows n gs"
    by (rule eq_lattice_imp_mat_mult_invertible_rows[OF fs_init gs lin_dep len[unfolded mn] len_gs l])
  from this obtain P where P: "P \<in> carrier_mat n n" and inv_P: "invertible_mat P"
    and fs_P_gs: "mat_of_rows n fs_init = P * mat_of_rows n gs" by auto
   obtain P1 where P1: "P1 \<in> carrier_mat n n" and inv_P1: "invertible_mat P1" and P1_H1: "(mat_of_rows n fs_init) = P1 * H1"
    using sound_HNF1 by auto
  obtain P2 where P2: "P2 \<in> carrier_mat n n" and inv_P2: "invertible_mat P2" and P2_H2: "(mat_of_rows n gs) = P2 * H2"
    using sound_HNF2 by auto
  have P1_H1_2: "P * mat_of_rows n gs = P1 * H1"
    using P1_H1 fs_P_gs by auto
  have gs_carrier: "mat_of_rows n gs \<in> carrier_mat n n" by (simp add: len_gs carrier_matI)
  show ?thesis
  proof (rule HNF_A_eq_HNF_PA'_exist[OF gs_carrier _ inv_P P HNF_H1 H1 HNF_H2 H2 _ sound_HNF2])
    from inv_P obtain P' where PP': "inverts_mat P P'" and P'P: "inverts_mat P' P"
      using invertible_mat_def by blast
    let ?RAT = "of_int_hom.mat_hom :: int mat \<Rightarrow> rat mat"
    have det_RAT_fs_init: "det (?RAT (mat_of_rows n fs_init)) \<noteq> 0"
    proof (rule gs.lin_indpt_rows_imp_det_not_0)
      show "?RAT (mat_of_rows n fs_init) \<in> carrier_mat n n"
        using len map_carrier_mat mat_of_rows_carrier(1) mn by blast
      have rw: "Matrix.rows (?RAT (mat_of_rows n fs_init)) = RAT fs_init"
        by (metis cof_vec_space.lin_indpt_list_def fs_init lin_dep mat_of_rows_map rows_mat_of_rows)
      thus "gs.lin_indpt (set (Matrix.rows (?RAT (mat_of_rows n fs_init))))"
        by (insert lin_dep, simp add: cof_vec_space.lin_indpt_list_def)
      show "distinct (Matrix.rows (?RAT (mat_of_rows n fs_init)))"
        using rw cof_vec_space.lin_indpt_list_def lin_dep by auto
    qed
    hence d: "det (?RAT (mat_of_rows n fs_init)) dvd 1" using dvd_field_iff by blast
    hence inv_RAT_fs_init: "invertible_mat (?RAT (mat_of_rows n fs_init))"
      using invertible_iff_is_unit_JNF by (metis mn len map_carrier_mat mat_of_rows_carrier(1))
    have "invertible_mat (?RAT P)"
      by (metis P dvd_field_iff inv_P invertible_iff_is_unit_JNF map_carrier_mat
          not_is_unit_0 of_int_hom.hom_0 of_int_hom.hom_det)
    have "det (?RAT (mat_of_rows n fs_init)) = det (?RAT P) * det (?RAT (mat_of_rows n gs))"
      by (metis Determinant.det_mult P fs_P_gs gs_carrier of_int_hom.hom_det of_int_hom.hom_mult)
    hence "det (?RAT (mat_of_rows n gs)) \<noteq> 0" using d by auto
    thus "invertible_mat (?RAT (mat_of_rows n gs))"
      by (meson dvd_field_iff gs_carrier invertible_iff_is_unit_JNF map_carrier_mat)
    show "\<exists>P1. P1 \<in> carrier_mat n n \<and> invertible_mat P1 \<and> P * mat_of_rows n gs = P1 * H1"
      using P1 P1_H1_2 inv_P1 by blast
  qed
qed

lemma certification_via_eq_HNF2:
  assumes sound_HNF: "is_sound_HNF HNF associates res"
    and P1_H1: "(P1,H1) = HNF (mat_of_rows n fs_init)"
    and P2_H2: "(P2,H2) = HNF (mat_of_rows n gs)"
    and gs: "set gs \<subseteq> carrier_vec n"
    and l: "lattice_of fs_init = lattice_of gs"
    and mn: "m = n" and len_gs: "length gs = n" (*For the moment, only for square matrices*)
  shows "H1 = H2"
proof -
  have "\<exists>P \<in> carrier_mat n n. invertible_mat P \<and> mat_of_rows n fs_init = P * mat_of_rows n gs"
    by (rule eq_lattice_imp_mat_mult_invertible_rows[OF fs_init gs lin_dep len[unfolded mn] len_gs l])
  from this obtain P where P: "P \<in> carrier_mat n n" and inv_P: "invertible_mat P"
    and fs_P_gs: "mat_of_rows n fs_init = P * mat_of_rows n gs" by auto
  have P1_H1_2: "(P1,H1) = HNF (P * mat_of_rows n gs)" using fs_P_gs P1_H1 by auto
  have gs_carrier: "mat_of_rows n gs \<in> carrier_mat n n" by (simp add: len_gs carrier_matI)
  show ?thesis
  proof (rule HNF_A_eq_HNF_PA'[OF gs_carrier _ inv_P P sound_HNF P1_H1_2 P2_H2])
    from inv_P obtain P' where PP': "inverts_mat P P'" and P'P: "inverts_mat P' P"
      using invertible_mat_def by blast
    let ?RAT = "of_int_hom.mat_hom :: int mat \<Rightarrow> rat mat"
    have det_RAT_fs_init: "det (?RAT (mat_of_rows n fs_init)) \<noteq> 0"
    proof (rule gs.lin_indpt_rows_imp_det_not_0)
      show "?RAT (mat_of_rows n fs_init) \<in> carrier_mat n n"
        using len map_carrier_mat mat_of_rows_carrier(1) mn by blast
      have rw: "Matrix.rows (?RAT (mat_of_rows n fs_init)) = RAT fs_init"
        by (metis cof_vec_space.lin_indpt_list_def fs_init lin_dep mat_of_rows_map rows_mat_of_rows)
      thus "gs.lin_indpt (set (Matrix.rows (?RAT (mat_of_rows n fs_init))))"
        by (insert lin_dep, simp add: cof_vec_space.lin_indpt_list_def)
      show "distinct (Matrix.rows (?RAT (mat_of_rows n fs_init)))"
        using rw cof_vec_space.lin_indpt_list_def lin_dep by auto
    qed
    hence d: "det (?RAT (mat_of_rows n fs_init)) dvd 1" using dvd_field_iff by blast
    hence inv_RAT_fs_init: "invertible_mat (?RAT (mat_of_rows n fs_init))"
      using invertible_iff_is_unit_JNF by (metis mn len map_carrier_mat mat_of_rows_carrier(1))
    have "invertible_mat (?RAT P)"
      by (metis P dvd_field_iff inv_P invertible_iff_is_unit_JNF map_carrier_mat
          not_is_unit_0 of_int_hom.hom_0 of_int_hom.hom_det)
    have "det (?RAT (mat_of_rows n fs_init)) = det (?RAT P) * det (?RAT (mat_of_rows n gs))"
      by (metis Determinant.det_mult P fs_P_gs gs_carrier of_int_hom.hom_det of_int_hom.hom_mult)
    hence "det (?RAT (mat_of_rows n gs)) \<noteq> 0" using d by auto
    thus "invertible_mat (?RAT (mat_of_rows n gs))"
      by (meson dvd_field_iff gs_carrier invertible_iff_is_unit_JNF map_carrier_mat)
  qed
qed

corollary lattice_of_eq_via_HNF:
  assumes sound_HNF: "is_sound_HNF HNF associates res"
    and P1_H1: "(P1,H1) = HNF (mat_of_rows n fs_init)"
    and P2_H2: "(P2,H2) = HNF (mat_of_rows n gs)"
    and gs: "set gs \<subseteq> carrier_vec n"
    and mn: "m = n" and len_gs: "length gs = n"
  shows "(H1 = H2) \<longleftrightarrow> (lattice_of fs_init = lattice_of gs)"
  using certification_via_eq_HNF certification_via_eq_HNF2 assms by metis
end

context
begin

interpretation vec_module "TYPE(int)" n .

lemma lattice_of_eq_via_HNF_paper:
  fixes F G :: "int mat" and HNF :: "int mat \<Rightarrow> int mat"
  assumes sound_HNF': "is_sound_HNF' HNF \<A> \<R>" (* HNF is a sound algorithm *)
    and inv_F_Q: "invertible_mat (map_mat rat_of_int F)" (* invertible over Q *)
    and FG: "{F,G} \<subseteq> carrier_mat n n"
  shows "(HNF F = HNF G) \<longleftrightarrow> (lattice_of (rows F) = lattice_of (rows G))"
proof -
  define HNF'
    where "HNF' = (\<lambda>A. let H = HNF A
    in (SOME P. P \<in> carrier_mat (dim_row A) (dim_row A) \<and> invertible_mat P \<and> A = P * H, H))"
  have sound_HNF': "is_sound_HNF HNF' \<A> \<R>" by (unfold HNF'_def, rule is_sound_HNF_conv[OF sound_HNF'])
  have F_eq: "F = mat_of_rows n (rows F)" and G_eq: "G = mat_of_rows n (rows G)"
    using FG by auto
  interpret L: LLL_with_assms n n "(rows F)" "4/3"
  proof
    interpret gs: cof_vec_space n "TYPE(rat)" .
    thm gs.upper_triangular_imp_lin_indpt_rows
  let ?RAT ="map_mat rat_of_int"
    have m_rw: "(map (map_vec rat_of_int) (rows F)) = rows (?RAT F)"
      unfolding Matrix.rows_def by auto
    show "gs.lin_indpt_list (map (map_vec rat_of_int) (rows F))"
    proof -
      have det_RAT_F: "det (?RAT F) \<noteq> 0"
        by (metis inv_F_Q carrier_mat_triv invertible_iff_is_unit_JNF
            invertible_mat_def not_is_unit_0 square_mat.simps)
      have d_RAT_F: "distinct (rows (?RAT F))"
      proof (rule ccontr)
        assume "\<not> distinct (rows (?RAT F))"
        from this obtain i j
          where ij: "row (?RAT F) i = row (?RAT F) j"
            and i: "i<dim_row (?RAT F)" and j: "j<dim_row (?RAT F)"
            and i_not_j: "i\<noteq>j"
          unfolding Matrix.rows_def distinct_conv_nth by auto
        have "det (?RAT F) = 0" using ij i j i_not_j
          by (metis Determinant.det_def Determinant.det_identical_rows carrier_mat_triv)
        thus False using inv_F_Q
          by (metis carrier_mat_triv invertible_iff_is_unit_JNF invertible_mat_def
              not_is_unit_0 square_mat.simps)
      qed
      moreover have "\<not> gs.lin_dep (set (rows (?RAT F)))"
        using gs.det_not_0_imp_lin_indpt_rows[OF _ det_RAT_F] using FG by auto
      ultimately show ?thesis
        unfolding gs.lin_indpt_list_def m_rw using FG unfolding Matrix.rows_def by auto
    qed
  qed (insert FG F_eq, auto)
  show ?thesis
  proof (rule L.lattice_of_eq_via_HNF[OF sound_HNF'])
    show "(fst (HNF' F), HNF F) = HNF' (mat_of_rows n (rows F))"
      unfolding HNF'_def Let_def using F_eq by auto
    show "(fst (HNF' G), HNF G) = HNF' (mat_of_rows n (rows G))"
      unfolding HNF'_def Let_def using G_eq by auto
    show "length (rows G) = n " using FG by auto
    show "set (rows G) \<subseteq> carrier_vec n" using FG
      by (metis G_eq mat_of_rows_carrier(3) rows_carrier)
  qed (simp)
qed
end

text \<open>We define a new const similar to @{text "external_lll_solver"},
but now it only returns the reduced matrix.\<close>

consts external_lll_solver' :: "integer \<times> integer \<Rightarrow> integer list list \<Rightarrow> integer list list"

hide_type (open) Finite_Cartesian_Product.vec

text \<open>The following definition is an adaptation of @{text "reduce_basis_external"}\<close>

definition reduce_basis_external' :: "(int mat \<Rightarrow> int mat) \<Rightarrow> rat \<Rightarrow> int vec list \<Rightarrow> int vec list" where
  "reduce_basis_external' HNF \<alpha> fs = (case fs of Nil \<Rightarrow> [] | Cons f _ \<Rightarrow> (let
    rb = reduce_basis \<alpha>;
    fsi = map (map integer_of_int o list_of_vec) fs;
    n = dim_vec f;
    m = length fs;
    gsi = external_lll_solver' (map_prod integer_of_int integer_of_int (quotient_of \<alpha>)) fsi;
    gs = (map (vec_of_list o map int_of_integer) gsi) in
    if \<not> (length gs = m \<and> (\<forall> gi \<in> set gs. dim_vec gi = n)) then
      Code.abort (STR ''error in external LLL invocation: dimensions of reduced basis do not fit\<newline>input to external solver: ''
        + String.implode (show fs) + STR ''\<newline>\<newline>'') (\<lambda> _. rb fs)
     else
      let Fs = mat_of_rows n fs;
          Gs = mat_of_rows n gs;
          H1 = HNF Fs;
          H2 = HNF Gs in
           if (H1 = H2) then rb gs
          else Code.abort (STR ''the reduced matrix does not span the same lattice\<newline>f,g,P1,P2,H1,H2 are as follows\<newline>''
            + String.implode (show Fs) + STR ''\<newline>\<newline>''
            + String.implode (show Gs) + STR ''\<newline>\<newline>''
            + String.implode (show H1) + STR ''\<newline>\<newline>''
            + String.implode (show H2) + STR ''\<newline>\<newline>''
            ) (\<lambda> _. rb fs))
    )"

locale certification = LLL_with_assms +
  fixes HNF::"int mat \<Rightarrow> int mat" and associates res (*HNF operation without explicit transformation matrix*)
  assumes sound_HNF': "is_sound_HNF' HNF associates res"
begin

lemma reduce_basis_external': assumes res: "reduce_basis_external' HNF \<alpha> fs_init = fs"
  shows "reduced fs m" "LLL_invariant True m fs"
proof (atomize(full), goal_cases)
  case 1
  show ?case
  proof (cases "LLL_Impl.reduce_basis \<alpha> fs_init = fs")
    case True
    from reduce_basis[OF this] show ?thesis by simp
  next
    case False note a = False
    show ?thesis
    proof (cases fs_init)
      case Nil
      with res have "fs = []" unfolding reduce_basis_external'_def by auto
      with False Nil have False by (simp add: LLL_Impl.reduce_basis_def)
      thus ?thesis ..
    next
      case (Cons f rest)
      from Cons fs_init len have dim_fs_n: "dim_vec f = n" by auto
      let ?ext = "external_lll_solver' (map_prod integer_of_int integer_of_int (quotient_of \<alpha>))
        (map (map integer_of_int \<circ> list_of_vec) fs_init)"
      note res = res[unfolded reduce_basis_external'_def Cons Let_def list.case Code.abort_def dim_fs_n,
          folded Cons]
      define gs where "gs = map (vec_of_list o map int_of_integer) ?ext"
      define Fs where "Fs = mat_of_rows n fs_init"
      define Gs where "Gs = mat_of_rows n gs"
      define H1 where "H1 = HNF Fs"
      define H2 where "H2 = HNF Gs"
      note res = res[unfolded ext option.simps split len dim_fs_n, folded gs_def]
      from res False have not: "(\<not> (length gs = m \<and> (\<forall>gi\<in>set gs. dim_vec gi = n))) = False"
        by (auto split: if_splits)
      note res = res[unfolded this if_False]
      from not have gs: "set gs \<subseteq> carrier_vec n"
        and len_gs: "length gs = m" by auto
      show ?thesis
      proof (cases "H1 = H2")
        case True
        hence H1_eq_H2: "H1 = H2" by auto
        let ?HNF = "(\<lambda>A. let H = HNF A in (SOME P. P \<in> carrier_mat (dim_row A) (dim_row A) \<and> invertible_mat P \<and> A = P * H, H))"
        obtain P1 where P1_H1: "(P1,H1) = ?HNF Fs" by (metis H1_def)
        obtain P2 where P2_H2: "(P2,H2) = ?HNF Gs" by (metis H2_def)
        have sound_HNF: "is_sound_HNF ?HNF associates res"
          by (rule is_sound_HNF_conv[OF sound_HNF'])
        have laticce_gs_fs_init: "lattice_of gs = lattice_of fs_init"
          and gs_assms: "LLL_with_assms n m gs \<alpha>"
          by (rule certification_via_eq_HNF[OF sound_HNF P1_H1[unfolded Fs_def]
                P2_H2[unfolded Gs_def] H1_eq_H2 gs len_gs])+
        from res a True
        have gs_fs:  "LLL_Impl.reduce_basis \<alpha> gs = fs"  by (auto split:  prod.split)
        have lattice_gs_fs: "lattice_of gs = lattice_of fs"
          and "gram_schmidt_fs.reduced n (map of_int_hom.vec_hom fs) \<alpha> m"
          and "gs.lin_indpt_list (map of_int_hom.vec_hom fs)"
          and "length fs = length gs"
          using LLL_with_assms.reduce_basis gs_fs gs_assms laticce_gs_fs_init gs_assms
          using LLL_with_assms_def len_gs unfolding LLL.L_def by fast+
        from this show ?thesis
          using laticce_gs_fs_init gs_assms LLL_with_assms_def lattice_gs_fs
          unfolding LLL_invariant_def L_def by auto
      next
        case False
        then show ?thesis
          using a Fs_def Gs_def res H1_def H2_def by auto
      qed
    qed
  qed
qed
end

context LLL_with_assms
begin

text \<open>We interpret the certification context using our formalized @{text "HNF_algorithm"}\<close>

interpretation efficient_cert: certification n m fs_init \<alpha> "HNF_algorithm use_sym_mod" "range ass_function_euclidean" "\<lambda>c. range (res_int c)"
  by (unfold_locales, rule is_sound_HNF'_HNF_algorithm)

(*We get the final lemma for our algorithm. It works for any matrix, but it only applies operations
modulo determinant for non-singular matrices.*)
thm efficient_cert.reduce_basis_external'

text \<open>Same, but applying the naive HNF algorithm, moved to JNF library from the echelon form
  and Hermite normal form AFP entries\<close>

interpretation cert: certification n m fs_init \<alpha> "HNF_algorithm_from_HA use_sym_mod" "range ass_function_euclidean" "\<lambda>c. range (res_int c)"
  by (unfold_locales, rule is_sound_HNF'_HNF_algorithm_from_HA)
thm cert.reduce_basis_external'

(*Explicit versions for paper-presentation:*)
lemma RBE_HNF_algorithm_efficient:
  assumes "reduce_basis_external' (HNF_algorithm use_sym_mod) \<alpha> fs_init = fs"
  shows "gram_schmidt_fs.reduced n (map of_int_hom.vec_hom fs) \<alpha> m"
    and "LLL_invariant True m fs" using efficient_cert.reduce_basis_external' assms by blast+

lemma RBE_HNF_algorithm_naive:
  assumes "reduce_basis_external' (HNF_algorithm_from_HA use_sym_mod) \<alpha> fs_init = fs"
  shows "gram_schmidt_fs.reduced n (map of_int_hom.vec_hom fs) \<alpha> m"
    and "LLL_invariant True m fs" using cert.reduce_basis_external' assms by blast+

end

lemma external_lll_solver'_code[code]:
  "external_lll_solver' = Code.abort (STR ''require proper implementation of external_lll_solver'') (\<lambda> _. external_lll_solver')"
  by simp
end


(*
    Title:      Code_Generation_IArrays.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Exporting code to SML and Haskell\<close>

theory Code_Generation_IArrays
imports
  Examples_Gauss_Jordan_IArrays
begin

subsection\<open>Exporting code\<close>

text\<open>The following two equations are necessary to execute code. If we don't remove them from code unfold, the exported code
will not work (there exist problems with the number 1 and number 0. Those problems appear when the HMA library is imported).\<close>

lemma [code_unfold del]: "1 \<equiv> real_of_rat 1" by simp
lemma [code_unfold del]: "0 \<equiv> real_of_rat 0" by simp

definition "matrix_z2 = IArray[IArray[0,1], IArray[1,1::bit], IArray[1,0::bit]]"
definition "matrix_rat = IArray[IArray[1,0,8], IArray[5.7,22,1], IArray[41,-58/7,78::rat]]"
definition "matrix_real = IArray[IArray[0,1], IArray[1,-2::real]]"
definition "vec_rat = IArray[21,5,7::rat]"

definition "print_result_Gauss A = iarray_of_iarray_to_list_of_list (Gauss_Jordan_iarrays A)"
definition "print_rank A = rank_iarray A"
definition "print_det A = det_iarrays A"

definition "print_result_z2 = print_result_Gauss (matrix_z2)"
definition "print_result_rat = print_result_Gauss (matrix_rat)"
definition "print_result_real = print_result_Gauss (matrix_real)"

definition "print_rank_z2 = print_rank (matrix_z2)"
definition "print_rank_rat = print_rank (matrix_rat)"
definition "print_rank_real = print_rank (matrix_real)"

definition "print_det_rat = print_det (matrix_rat)"
definition "print_det_real = print_det (matrix_real)"

definition "print_inverse A = inverse_matrix_iarray A"
definition "print_inverse_real A = print_inverse (matrix_real)"
definition "print_inverse_rat A = print_inverse (matrix_rat)"

definition "print_system A b = print_result_system_iarrays (solve_iarrays A b)"
definition "print_system_rat = print_result_system_iarrays (solve_iarrays matrix_rat vec_rat)"

subsection\<open>The Mathematica bug\<close>

text\<open>Varona et al \cite{VA} detected that the commercial software \<open>Mathematica\<registered>\<close>,
in its versions 8.0, 9.0 and 9.0.1, was computing erroneously determinants of matrices
of big integers, even for small dimensions  (in their work they present an example of a
matrix of dimension \<open>14 \<times> 14\<close>). The situation is
such that even the same determinant, computed twice, produces two different and wrong results.

Here we reproduce that example. The computation of the determinant is correctly carried out by
the exported code from this formalization, in both SML and Haskell.
\<close>

definition "powersMatrix =
IArray[
IArray[10^123,0,0,0,0,0,0,0,0,0,0,0,0,0],
IArray[0,10^152,0,0,0,0,0,0,0,0,0,0,0,0],
IArray[0,0,10^185,0,0,0,0,0,0,0,0,0,0,0],
IArray[0,0,0,10^220,0,0,0,0,0,0,0,0,0,0],
IArray[0,0,0,0,10^397,0,0,0,0,0,0,0,0,0],
IArray[0,0,0,0,0,10^449,0,0,0,0,0,0,0,0],
IArray[0,0,0,0,0,0,10^503,0,0,0,0,0,0,0],
IArray[0,0,0,0,0,0,0,10^563,0,0,0,0,0,0],
IArray[0,0,0,0,0,0,0,0,10^979,0,0,0,0,0],
IArray[0,0,0,0,0,0,0,0,0,10^1059,0,0,0,0],
IArray[0,0,0,0,0,0,0,0,0,0,10^1143,0,0,0],
IArray[0,0,0,0,0,0,0,0,0,0,0,10^1229,0,0],
IArray[0,0,0,0,0,0,0,0,0,0,0,0,10^1319,0],
IArray[0,0,0,0,0,0,0,0,0,0,0,0,0,(10^1412)::rat]]"

definition "basicMatrix =
IArray[
IArray[-32, 69, 89,-60,-83,-22,-14,-58,85,56,-65,-30,-86,-9],
IArray[6, 99, 11, 57, 47,-42,-48,-65, 25, 50,-70,-3,-90, 31],
IArray[78, 38, 12, 64,-67,-4,-52,-65, 19, 71, 38,-17, 51,-3],
IArray[-93, 30, 89, 22, 13, 48,-73, 93, 11,-97,-49, 61,-25,-4],
IArray[54,-22, 54,-53,-52, 64, 19, 1, 81,-72,-11, 50, 0,-81],
IArray[65,-58, 3, 57, 19, 77, 76,-57,-80, 22, 93,-85, 67, 58],
IArray[29,-58, 47, 87, 3,-6,-81, 5, 98, 86,-98, 51,-62,-66],
IArray[93,-77, 16,-64, 48, 84, 97, 75, 89, 63, 34,-98,-94, 19],
IArray[45,-99, 3,-57, 32, 60, 74, 4, 69, 98,-40,-69,-28,-26],
IArray[-13, 51,-99,-2, 48, 71,-81,-32, 78, 27,-28,-22, 22, 94],
IArray[11, 72,-74, 86, 79,-58,-89, 80, 70, 55,-49, 51,-42, 66],
IArray[-72, 53, 49,-46, 17,-22,-48,-40,-28,-85, 88,-30, 74, 32],
IArray[-92,-22,-90, 67,-25,-28,-91,-8, 32,-41, 10, 6, 85, 21],
IArray[47,-73,-30,-60, 99, 9,-86,-70, 84, 55, 19, 69, 11,-84::rat]]"

definition "smallMatrix=
IArray[
IArray[528, 853,-547,-323, 393,-916,-11,-976, 279,-665, 906,-277, 103,-485],
IArray[878, 910,-306,-260, 575,-765,-32, 94, 254, 276,-156, 625,-8,-566],
IArray[-357, 451,-475, 327,-84, 237, 647, 505,-137, 363,-808, 332, 222,-998],
IArray[-76, 26,-778, 505, 942,-561,-350, 698,-532,-507,-78,-758, 346,-545],
IArray[-358, 18,-229,-880,-955,-346, 550,-958, 867,-541,-962, 646, 932, 168],
IArray[192, 233, 620,955,-877, 281, 357,-226,-820, 513,-882, 536,-237, 877],
IArray[-234,-71,-831, 880,-135,-249,-427, 737, 664, 298,-552,-1,-712,-691],
IArray[80, 748, 684, 332, 730,-111,-643, 102,-242,-82,-28, 585, 207,-986],
IArray[967, 1,-494, 633, 891,-907,-586, 129, 688, 150,-501,-298, 704,-68],
IArray[406,-944,-533,-827, 615, 907,-443,-350, 700,-878, 706, 1,800, 120],
IArray[33,-328,-543, 583,-443,-635,904,-745,-398,-110, 751, 660, 474, 255],
IArray[-537,-311, 829, 28, 175, 182,-930, 258,-808,-399,-43,-68,-553, 421],
IArray[-373,-447,-252,-619,-418, 764, 994,-543,-37,-845, 30,-704, 147,-534],
IArray[638,-33, 932,-335,-75,-676,-934, 239, 210, 665, 414,-803, 564,-805::rat]]"

definition "bigMatrix=(basicMatrix **i powersMatrix) + smallMatrix"

end