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

section \<open>Logical relations for definability in PCF\<close>
(*<*)

theory PCF
imports
  Basis
  Logical_Relations
begin

(*>*)
text\<open>

\label{sec:directsem}

Using this machinery we can demonstrate some classical results about
PCF \<^citep>\<open>"Plotkin77"\<close>. We diverge from the traditional treatment by
considering PCF as an untyped language and including both call-by-name
(CBN) and call-by-value (CBV) abstractions following
\<^citet>\<open>"DBLP:conf/icalp/Reynolds74"\<close>. We also adopt some of the
presentation of \<^citet>\<open>\<open>Chapter~11\<close> in "Winskel:1993"\<close>, in particular by
making the fixed point operator a binding construct.

We model the syntax of PCF as a HOL datatype, where variables have
names drawn from the naturals:

\<close>

type_synonym var = nat

datatype expr =
    Var var
  | App expr expr
  | AbsN var expr (* non-strict fns *)
  | AbsV var expr (* strict fns *)
  | Diverge ("\<Omega>")
  | Fix var expr
  | tt
  | ff
  | Cond expr expr expr
  | Num nat
  | Succ expr
  | Pred expr
  | IsZero expr

subsection\<open>Direct denotational semantics\<close>

text\<open>

\label{sec:densem}

We give this language a direct denotational semantics by interpreting
it into a domain of values.

\<close>

domain ValD =
   ValF (lazy appF :: "ValD \<rightarrow> ValD")
 | ValTT | ValFF
 | ValN (lazy "nat")

text\<open>

The \textbf{lazy} keyword means that the @{term "ValF"} constructor is
lifted, i.e. @{term "ValF\<cdot>\<bottom> \<noteq> \<bottom>"}, which further means that @{term
"ValF\<cdot>(\<Lambda> x. \<bottom>) \<noteq> \<bottom>"}.

The naturals are discretely ordered.

\<close>
(*<*)

lemma ValD_case_ID [simp]:
  "ValD_case\<cdot>ValF\<cdot>ValTT\<cdot>ValFF\<cdot>ValN = ID"
  apply (rule cfun_eqI)
  apply (case_tac x)
  apply simp_all
  done

lemma below_monic_ValF [iff]:
  "below_monic_cfun ValF"
  by (rule below_monicI) simp

lemma below_monic_ValN [iff]:
  "below_monic_cfun ValN"
  by (rule below_monicI) simp

(*>*)
text\<open>

The minimal invariant for @{typ "ValD"} is straightforward; the
function @{term "cfun_map\<cdot>f\<cdot>g\<cdot>h"} denotes @{term "g oo h oo f"}.

\<close>

fixrec
  ValD_copy_rec :: "(ValD \<rightarrow> ValD) \<rightarrow> (ValD \<rightarrow> ValD)"
where
  "ValD_copy_rec\<cdot>r\<cdot>(ValF\<cdot>f) = ValF\<cdot>(cfun_map\<cdot>r\<cdot>r\<cdot>f)"
| "ValD_copy_rec\<cdot>r\<cdot>(ValTT) = ValTT"
| "ValD_copy_rec\<cdot>r\<cdot>(ValFF) = ValFF"
| "ValD_copy_rec\<cdot>r\<cdot>(ValN\<cdot>n) = ValN\<cdot>n"
(*<*)

lemma ValD_copy_rec_strict [simp]:
  "ValD_copy_rec\<cdot>r\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp

abbreviation
  "ValD_copy \<equiv> fix\<cdot>ValD_copy_rec"

lemma ValD_copy_strict [simp]:
  "ValD_copy\<cdot>\<bottom> = \<bottom>"
  by (subst fix_eq) simp

lemma ValD_copy_ID [simp]:
  "ValD_copy = ID"
proof -
  { fix x :: ValD
    fix i :: nat
    have "ValD_take i\<cdot>(ValD_copy\<cdot>(ValD_take i\<cdot>x)) = ValD_take i\<cdot>x"
    proof (induct i arbitrary: x)
      case (Suc n) then show ?case
        by (cases x) (subst fix_eq, simp add: cfun_map_def)+
    qed simp }
  then have "\<And>x :: ValD. (\<Squnion>i. ValD_take i\<cdot>(ValD_copy\<cdot>(ValD_take i\<cdot>x))) = (\<Squnion>i. ValD_take i\<cdot>x)"
    by (blast intro: lub_eq)
  then show ?thesis by (simp add: lub_distribs ValD.lub_take cfun_eq_iff)
qed

(*>*)
text\<open>

We interpret the PCF constants in the obvious ways. ``Ill-typed'' uses
of these combinators are mapped to @{term "\<bottom>"}.

\<close>

definition cond :: "ValD \<rightarrow> ValD \<rightarrow> ValD \<rightarrow> ValD" where
  "cond \<equiv> \<Lambda> i t e. case i of ValF\<cdot>f \<Rightarrow> \<bottom> | ValTT \<Rightarrow> t | ValFF \<Rightarrow> e | ValN\<cdot>n \<Rightarrow> \<bottom>"

definition succ :: "ValD \<rightarrow> ValD" where
  "succ \<equiv> \<Lambda> (ValN\<cdot>n). ValN\<cdot>(n + 1)"

definition pred :: "ValD \<rightarrow> ValD" where
  "pred \<equiv> \<Lambda> (ValN\<cdot>n). case n of 0 \<Rightarrow> \<bottom> | Suc n \<Rightarrow> ValN\<cdot>n"

definition isZero :: "ValD \<rightarrow> ValD" where
  "isZero \<equiv> \<Lambda> (ValN\<cdot>n). if n = 0 then ValTT else ValFF"

text\<open>

We model environments simply as continuous functions from variable
names to values.

\<close>

type_synonym Var = "var"
type_synonym 'a Env = "Var \<rightarrow> 'a"

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

definition env_ext :: "Var \<rightarrow> 'a \<rightarrow> 'a Env \<rightarrow> 'a Env" where
  "env_ext \<equiv> \<Lambda> v x \<rho> v'. if v = v' then x else \<rho>\<cdot>v'"
(*<*)

lemma env_ext_same: "env_ext\<cdot>v\<cdot>x\<cdot>\<rho>\<cdot>v = x"
  by (simp add: env_ext_def)

lemma env_ext_neq: "v \<noteq> v' \<Longrightarrow> env_ext\<cdot>v\<cdot>x\<cdot>\<rho>\<cdot>v' = \<rho>\<cdot>v'"
  by (simp add: env_ext_def)

lemmas env_ext_simps[simp] = env_ext_same env_ext_neq

(*>*)
text\<open>

The semantics is given by a function defined by primitive recursion
over the syntax.

\<close>

type_synonym EnvD = "ValD Env"

primrec
  evalD :: "expr \<Rightarrow> EnvD \<rightarrow> ValD"
where
  "evalD (Var v) = (\<Lambda> \<rho>. \<rho>\<cdot>v)"
| "evalD (App f x) = (\<Lambda> \<rho>. appF\<cdot>(evalD f\<cdot>\<rho>)\<cdot>(evalD x\<cdot>\<rho>))"
| "evalD (AbsN v e) = (\<Lambda> \<rho>. ValF\<cdot>(\<Lambda> x. evalD e\<cdot>(env_ext\<cdot>v\<cdot>x\<cdot>\<rho>)))"
| "evalD (AbsV v e) = (\<Lambda> \<rho>. ValF\<cdot>(strictify\<cdot>(\<Lambda> x. evalD e\<cdot>(env_ext\<cdot>v\<cdot>x\<cdot>\<rho>))))"
| "evalD (Diverge) = (\<Lambda> \<rho>. \<bottom>)"
| "evalD (Fix v e) = (\<Lambda> \<rho>. \<mu> x. evalD e\<cdot>(env_ext\<cdot>v\<cdot>x\<cdot>\<rho>))"
| "evalD (tt) = (\<Lambda> \<rho>. ValTT)"
| "evalD (ff) = (\<Lambda> \<rho>. ValFF)"
| "evalD (Cond i t e) = (\<Lambda> \<rho>. cond\<cdot>(evalD i\<cdot>\<rho>)\<cdot>(evalD t\<cdot>\<rho>)\<cdot>(evalD e\<cdot>\<rho>))"
| "evalD (Num n) = (\<Lambda> \<rho>. ValN\<cdot>n)"
| "evalD (Succ e) = (\<Lambda> \<rho>. succ\<cdot>(evalD e\<cdot>\<rho>))"
| "evalD (Pred e) = (\<Lambda> \<rho>. pred\<cdot>(evalD e\<cdot>\<rho>))"
| "evalD (IsZero e) = (\<Lambda> \<rho>. isZero\<cdot>(evalD e\<cdot>\<rho>))"

abbreviation eval' :: "expr \<Rightarrow> ValD Env \<Rightarrow> ValD" ("\<lbrakk>_\<rbrakk>_" [0,1000] 60) where
  "eval' M \<rho> \<equiv> evalD M\<cdot>\<rho>"

subsection\<open>The Y Combinator\<close>

text\<open>

We can shown the Y combinator is the least fixed point operator using
just the minimal invariant.  In other words, @{term "fix"} is
definable in untyped PCF minus the @{term "Fix"} construct.

This is Example~3.6 from \<^citet>\<open>"PittsAM:relpod"\<close>. He attributes the
proof to Plotkin.

These two functions are \<open>\<Delta> \<equiv> \<lambda>f x. f (x x)\<close> and \<open>Y \<equiv>
\<lambda>f. (\<Delta> f) (\<Delta> f)\<close>.

Note the numbers here are names, not de Bruijn indices.

\<close>

definition Y_delta :: expr where
  "Y_delta \<equiv> AbsN 0 (AbsN 1 (App (Var 0) (App (Var 1) (Var 1))))"

definition Ycomb :: expr where
  "Ycomb \<equiv> AbsN 0 (App (App Y_delta (Var 0)) (App Y_delta (Var 0)))"

definition fixD :: "ValD \<rightarrow> ValD" where
  "fixD \<equiv> \<Lambda> (ValF\<cdot>f). fix\<cdot>f"

lemma Y: "\<lbrakk>Ycomb\<rbrakk>\<rho> = ValF\<cdot>fixD"
(*<*)
proof(rule below_antisym)
  show "ValF\<cdot>fixD \<sqsubseteq> \<lbrakk>Ycomb\<rbrakk>\<rho>"
    unfolding fixD_def Ycomb_def
    apply (clarsimp simp: cfun_below_iff eta_cfun)
    apply (case_tac x)
     apply simp_all
    apply (rule fix_least)
    by (subst Y_delta_def, simp)
next
  { fix f \<rho>
    let ?P = "\<lambda>x. x \<sqsubseteq> ID \<and> appF\<cdot>(x\<cdot>(appF\<cdot>(\<lbrakk>Y_delta\<rbrakk>\<rho>)\<cdot>(ValF\<cdot>f)))\<cdot>(appF\<cdot>(\<lbrakk>Y_delta\<rbrakk>\<rho>)\<cdot>(ValF\<cdot>f)) \<sqsubseteq> fixD\<cdot>(ValF\<cdot>f)"
    have "?P ValD_copy"
      apply (rule fix_ind)
        apply simp
       apply simp
      apply clarsimp
      apply (rule conjI)
       apply (rule cfun_belowI)
       apply (case_tac xa)
        apply simp_all
       apply (drule cfun_map_below_ID)
       apply (simp add: cfun_below_iff)
      apply (simp add: fixD_def eta_cfun)
      apply (subst Y_delta_def)
      apply (subst fix_eq)
      apply simp
      apply (rule cfun_below_ID, assumption)
      apply (rule monofun_cfun_arg)
      apply (subgoal_tac "appF\<cdot>(x\<cdot>(appF\<cdot>(\<lbrakk>Y_delta\<rbrakk>\<rho>)\<cdot>(ValF\<cdot>f)))\<cdot>(x\<cdot>(appF\<cdot>(\<lbrakk>Y_delta\<rbrakk>\<rho>)\<cdot>(ValF\<cdot>f)))
                        \<sqsubseteq> appF\<cdot>(x\<cdot>(appF\<cdot>(\<lbrakk>Y_delta\<rbrakk>\<rho>)\<cdot>(ValF\<cdot>f)))\<cdot>(appF\<cdot>(\<lbrakk>Y_delta\<rbrakk>\<rho>)\<cdot>(ValF\<cdot>f))")
       apply (erule (1) below_trans)
      apply (simp add: monofun_cfun_arg cfun_below_iff)
      done }
  then show "\<lbrakk>Ycomb\<rbrakk>\<rho> \<sqsubseteq> ValF\<cdot>fixD"
    unfolding Ycomb_def fixD_def
    apply (clarsimp simp: cfun_below_iff)
    apply (case_tac x)
    apply (subst Y_delta_def, simp)
    apply simp
    apply (subst Y_delta_def, simp)+
    done
qed

(* FIXME could also try to show uniformity, cf Gunter, Plotkin "3 Inadequate Models". *)

(*>*)

subsection\<open>Logical relations for definability\<close>

text\<open>

\label{sec:pcfdefinability}

An element of @{typ "ValD"} is definable if there is an expression
that denotes it.

\<close>

definition definable :: "ValD \<Rightarrow> bool" where
  "definable d \<equiv> \<exists>M. \<lbrakk>M\<rbrakk>env_empty = d"

text\<open>

A classical result about PCF is that while the denotational semantics
is \emph{adequate}, as we show in \S\ref{sec:opsem}, it is not
\emph{fully abstract}, i.e. it contains undefinable values (junk).

One way of showing this is to reason operationally; see, for instance,
\<^citet>\<open>\<open>\S4\<close> in "Plotkin77"\<close> and \<^citet>\<open>\<open>\S6.1\<close> in "Gunter:1992"\<close>.

Another is to use \emph{logical relations}, following
\<^citet>\<open>"Plotkin:1973"\<close>, and also
\<^citet>\<open>"Mitchell:1996" and "Sieber:1992" and "DBLP:conf/mfps/Stoughton93"\<close>.

For this purpose we define a logical relation to be a set of vectors
over @{typ "ValD"} that is closed under continuous functions of type
@{typ "ValD \<rightarrow> ValD"}. This is complicated by the @{term "ValF"} tag
and having strict function abstraction.

\<close>

definition
  logical_relation :: "('i::type \<Rightarrow> ValD) set \<Rightarrow> bool"
where
  "logical_relation R \<equiv>
     (\<forall>fs \<in> R. \<forall>xs \<in> R. (\<lambda>j. appF\<cdot>(fs j)\<cdot>(xs j)) \<in> R)
   \<and> (\<forall>fs \<in> R. \<forall>xs \<in> R. (\<lambda>j. strictify\<cdot>(appF\<cdot>(fs j))\<cdot>(xs j)) \<in> R)
   \<and> (\<forall>fs. (\<forall>xs \<in> R. (\<lambda>j. (fs j)\<cdot>(xs j)) \<in> R) \<longrightarrow> (\<lambda>j. ValF\<cdot>(fs j)) \<in> R)
   \<and> (\<forall>fs. (\<forall>xs \<in> R. (\<lambda>j. strictify\<cdot>(fs j)\<cdot>(xs j)) \<in> R) \<longrightarrow> (\<lambda>j. ValF\<cdot>(strictify\<cdot>(fs j))) \<in> R)
   \<and> (\<forall>xs \<in> R. (\<lambda>j. fixD\<cdot>(xs j)) \<in> R)
   \<and> (\<forall>cs \<in> R. \<forall>ts \<in> R. \<forall>es \<in> R. (\<lambda>j. cond\<cdot>(cs j)\<cdot>(ts j)\<cdot>(es j)) \<in> R)
   \<and> (\<forall>xs \<in> R. (\<lambda>j. succ\<cdot>(xs j)) \<in> R)
   \<and> (\<forall>xs \<in> R. (\<lambda>j. pred\<cdot>(xs j)) \<in> R)
   \<and> (\<forall>xs \<in> R. (\<lambda>j. isZero\<cdot>(xs j)) \<in> R)"
(*<*)

lemma logical_relationI:
  "\<lbrakk> \<And>fs xs. \<lbrakk> fs \<in> R; xs \<in> R \<rbrakk> \<Longrightarrow> (\<lambda>j. appF\<cdot>(fs j)\<cdot>(xs j)) \<in> R;
     \<And>fs xs. \<lbrakk> fs \<in> R; xs \<in> R \<rbrakk> \<Longrightarrow> (\<lambda>j. strictify\<cdot>(appF\<cdot>(fs j))\<cdot>(xs j)) \<in> R;
     \<And>fs. (\<And>xs. xs \<in> R \<Longrightarrow> (\<lambda>j. (fs j)\<cdot>(xs j)) \<in> R) \<Longrightarrow> (\<lambda>j. ValF\<cdot>(fs j)) \<in> R;
     \<And>fs. (\<And>xs. xs \<in> R \<Longrightarrow> (\<lambda>j. strictify\<cdot>(fs j)\<cdot>(xs j)) \<in> R) \<Longrightarrow> (\<lambda>j. ValF\<cdot>(strictify\<cdot>(fs j))) \<in> R;
     \<And>xs. xs \<in> R \<Longrightarrow> (\<lambda>j. fixD\<cdot>(xs j)) \<in> R;
     \<And>cs ts es. \<lbrakk> cs \<in> R; ts \<in> R; es \<in> R \<rbrakk> \<Longrightarrow> (\<lambda>j. cond\<cdot>(cs j)\<cdot>(ts j)\<cdot>(es j)) \<in> R;
     \<And>xs. xs \<in> R \<Longrightarrow> (\<lambda>j. succ\<cdot>(xs j)) \<in> R;
     \<And>xs. xs \<in> R \<Longrightarrow> (\<lambda>j. pred\<cdot>(xs j)) \<in> R;
     \<And>xs. xs \<in> R \<Longrightarrow> (\<lambda>j. isZero\<cdot>(xs j)) \<in> R \<rbrakk> \<Longrightarrow> logical_relation R"
  unfolding logical_relation_def by (simp add: cfcomp1)

lemma lr_l2r:
  "\<lbrakk> fs \<in> R; xs \<in> R; logical_relation R \<rbrakk> \<Longrightarrow> (\<lambda>j. appF\<cdot>(fs j)\<cdot>(xs j)) \<in> R"
  "\<lbrakk> fs \<in> R; xs \<in> R; logical_relation R \<rbrakk> \<Longrightarrow> (\<lambda>j. strictify\<cdot>(appF\<cdot>(fs j))\<cdot>(xs j)) \<in> R"
  "\<lbrakk> xs \<in> R; logical_relation R \<rbrakk> \<Longrightarrow> (\<lambda>j. fixD\<cdot>(xs j)) \<in> R"
  "\<lbrakk> cs \<in> R; ts \<in> R; es \<in> R; logical_relation R \<rbrakk> \<Longrightarrow> (\<lambda>j. cond\<cdot>(cs j)\<cdot>(ts j)\<cdot>(es j)) \<in> R"
  "\<lbrakk> xs \<in> R; logical_relation R \<rbrakk> \<Longrightarrow> (\<lambda>j. succ\<cdot>(xs j)) \<in> R"
  "\<lbrakk> xs \<in> R; logical_relation R \<rbrakk> \<Longrightarrow> (\<lambda>j. pred\<cdot>(xs j)) \<in> R"
  "\<lbrakk> xs \<in> R; logical_relation R \<rbrakk> \<Longrightarrow> (\<lambda>j. isZero\<cdot>(xs j)) \<in> R"
  unfolding logical_relation_def by blast+

lemma lr_r2l:
  "\<lbrakk> logical_relation R; \<forall>xs \<in> R. (\<lambda>j. (fs j)\<cdot>(xs j)) \<in> R \<rbrakk> \<Longrightarrow> (\<lambda>i. ValF\<cdot>(fs i)) \<in> R"
  unfolding logical_relation_def by (simp add: cfcomp1)

lemma lr_r2l_strict:
  "\<lbrakk> logical_relation R; \<forall>xs \<in> R. (\<lambda>j. strictify\<cdot>(fs j)\<cdot>(xs j)) \<in> R \<rbrakk> \<Longrightarrow> (\<lambda>i. ValF\<cdot>(strictify\<cdot>(fs i))) \<in> R"
  unfolding logical_relation_def by (simp add: cfcomp1)

(*>*)
text\<open>

In the context of PCF these relations also need to respect the
constants.

\<close>

definition
  PCF_consts_rel :: "('i::type \<Rightarrow> ValD) set \<Rightarrow> bool"
where
  "PCF_consts_rel R \<equiv>
       \<bottom> \<in> R
     \<and> (\<lambda>i. ValTT) \<in> R
     \<and> (\<lambda>i. ValFF) \<in> R
     \<and> (\<forall>n. (\<lambda>i. ValN\<cdot>n) \<in> R)"
(*<*)

lemma PCF_consts_rel_simps [simp, elim]:
  "PCF_consts_rel R \<Longrightarrow> \<bottom> \<in> R"
  "PCF_consts_rel R \<Longrightarrow> (\<lambda>i. ValTT) \<in> R"
  "PCF_consts_rel R \<Longrightarrow> (\<lambda>i. ValFF) \<in> R"
  "PCF_consts_rel R \<Longrightarrow> (\<lambda>i. ValN\<cdot>n) \<in> R"
unfolding PCF_consts_rel_def by simp_all

lemma PCF_consts_relI:
  "\<lbrakk> \<bottom> \<in> R;
     (\<lambda>i. ValTT) \<in> R;
     (\<lambda>i. ValFF) \<in> R;
     \<And>n. (\<lambda>i. ValN\<cdot>n) \<in> R \<rbrakk> \<Longrightarrow> PCF_consts_rel R"
unfolding PCF_consts_rel_def by blast

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

abbreviation
  "PCF_lr R \<equiv> adm (\<lambda>x. x \<in> R) \<and> logical_relation R \<and> PCF_consts_rel R"

text\<open>

The fundamental property of logical relations states that all PCF
expressions satisfy all PCF logical relations. This result is
essentially due to \<^citet>\<open>"Plotkin:1973"\<close>.  The proof is by a
straightforward induction on the expression @{term "M"}.

\<close>

lemma lr_fundamental:
  assumes lr: "PCF_lr R"
  assumes \<rho>: "\<forall>v. (\<lambda>i. \<rho> i\<cdot>v) \<in> R"
  shows "(\<lambda>i. \<lbrakk>M\<rbrakk>(\<rho> i)) \<in> R"
(*<*)
using \<rho>
proof(induct M arbitrary: \<rho>)
  case (Var v \<rho>) then show ?case by simp
next
  case (App e1 e2 \<rho>)
  with lr lr_l2r(1)[where fs="\<lambda>j. \<lbrakk>e1\<rbrakk>(\<rho> j)" and xs="\<lambda>j. \<lbrakk>e2\<rbrakk>(\<rho> j)"]
  show ?case by simp
next
  case (AbsN v e)
  with lr show ?case
    apply clarsimp
    apply (erule lr_r2l[where fs="\<lambda>i. \<Lambda> x. \<lbrakk>e\<rbrakk>(env_ext\<cdot>v\<cdot>x\<cdot>(\<rho> i))" and R=R, simplified])
    apply clarsimp
    apply (cut_tac \<rho>="\<lambda>j. env_ext\<cdot>v\<cdot>(xs j)\<cdot>(\<rho> j)" in AbsN.hyps)
     apply (simp add: env_ext_def)
     using AbsN(2)
     apply clarsimp
     apply (case_tac "v=va")
      apply (simp add: eta_cfun)
     apply simp
    apply simp
    done
next
  case (AbsV v e)
  with lr show ?case
    apply clarsimp
    apply (rule lr_r2l_strict[where fs="\<lambda>i. \<Lambda> x. \<lbrakk>e\<rbrakk>(env_ext\<cdot>v\<cdot>x\<cdot>(\<rho> i))", simplified])
     apply simp
    apply clarsimp
    apply (cut_tac fs="\<lambda>i. ValF\<cdot>(\<Lambda> x. \<lbrakk>e\<rbrakk>(env_ext\<cdot>v\<cdot>x\<cdot>(\<rho> i)))" and xs=xs and R=R in lr_l2r(2))
     apply simp_all
    apply (erule lr_r2l[where fs="\<lambda>i. \<Lambda> x. \<lbrakk>e\<rbrakk>(env_ext\<cdot>v\<cdot>x\<cdot>(\<rho> i))" and R=R, simplified])
    apply clarsimp
    apply (cut_tac \<rho>="\<lambda>j. env_ext\<cdot>v\<cdot>(xsa j)\<cdot>(\<rho> j)" in AbsV.hyps)
     apply (simp add: env_ext_def)
     using AbsV(2)
     apply clarsimp
     apply (case_tac "v=va")
      apply (simp add: eta_cfun)
     apply simp
    apply simp
    done
next
  case (Fix v e \<rho>) show ?case
    apply simp
    apply (subst fix_argument_promote_fun)
    apply (rule fix_ind[where F="\<Lambda> f. (\<lambda>x. (\<Lambda> xa. \<lbrakk>e\<rbrakk>(env_ext\<cdot>v\<cdot>xa\<cdot>(\<rho> x)))\<cdot>(f x))"])
      apply (simp add: lr)
     apply (simp add: lr inst_fun_pcpo[symmetric])
    apply simp
    apply (cut_tac \<rho>="\<lambda>i. env_ext\<cdot>v\<cdot>(x i)\<cdot>(\<rho> i)" in Fix.hyps)
     unfolding env_ext_def
     using Fix(2)
     apply clarsimp
     apply (case_tac "v=va")
      apply (simp add: eta_cfun)
     apply simp
    apply (simp add: cont_fun)
    done
next
  case (Cond i t e \<rho>)
  with lr lr_l2r(4)[where cs="\<lambda>j. \<lbrakk>i\<rbrakk>(\<rho> j)" and ts="\<lambda>j. \<lbrakk>t\<rbrakk>(\<rho> j)" and es="\<lambda>j. \<lbrakk>e\<rbrakk>(\<rho> j)"]
  show ?case by simp
next
  case (Succ e \<rho>)
  with lr lr_l2r(5)[where xs="\<lambda>j. \<lbrakk>e\<rbrakk>(\<rho> j)"]
  show ?case by simp
next
  case (Pred e \<rho>)
  with lr lr_l2r(6)[where xs="\<lambda>j. \<lbrakk>e\<rbrakk>(\<rho> j)"]
  show ?case by simp
next
  case (IsZero e \<rho>)
  with lr lr_l2r(7)[where xs="\<lambda>j. \<lbrakk>e\<rbrakk>(\<rho> j)"]
  show ?case by simp
next
  case Diverge with lr show ?case
    apply simp
    apply (simp add: inst_fun_pcpo[symmetric])
    done
qed (insert lr, simp_all)
(*>*)

text\<open>

We can use this result to show that there is no PCF term that maps the
vector @{term "args \<in> R"} to @{term "result \<notin> R"} for some logical
relation @{term "R"}. If we further show that there is a function
@{term "f"} in @{term "ValD"} such that @{term "f args = result"} then
we can conclude that @{term "f"} is not definable.

\<close>

abbreviation
  appFLv :: "ValD \<Rightarrow> ('i::type \<Rightarrow> ValD) list \<Rightarrow> ('i \<Rightarrow> ValD)"
where
  "appFLv f args \<equiv> (\<lambda>i. foldl (\<lambda>f x. appF\<cdot>f\<cdot>(x i)) f args)"

lemma lr_appFLv:
  assumes lr: "logical_relation R"
  assumes f: "(\<lambda>i::'i::type. f) \<in> R"
  assumes args: "set args \<subseteq> R"
  shows "appFLv f args \<in> R"
(*<*)
using args
proof(induct args rule: rev_induct)
  case Nil with f show ?case by simp
next
  case (snoc x xs) then show ?case
    using lr_l2r(1)[OF _ _ lr, where fs="\<lambda>i. (foldl (\<lambda>f x. appF\<cdot>f\<cdot>(x i)) f xs)" and xs=x]
    by simp
qed

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

corollary not_definable:
  fixes R :: "('i::type \<Rightarrow> ValD) set"
  fixes args :: "('i \<Rightarrow> ValD) list"
  fixes result :: "'i \<Rightarrow> ValD"
  assumes lr: "PCF_lr R"
  assumes args: "set args \<subseteq> R"
  assumes result: "result \<notin> R"
  shows "\<not>(\<exists>(f::ValD). definable f \<and> appFLv f args = result)"
(*<*)
proof
  assume "\<exists>f. definable f \<and> appFLv f args = result"
  then obtain f
    where df: "definable f"
      and f: "appFLv f args = result" by blast
  from df obtain M
    where Mf: "\<lbrakk>M\<rbrakk>env_empty = f"
    unfolding definable_def by blast
  with lr lr_fundamental[OF lr, where M=M and \<rho>="\<lambda>i. env_empty"]
       f args lr_appFLv[where f=f and R=R and args=args]
  have "result \<in> R" unfolding env_empty_def by (simp add: inst_fun_pcpo[symmetric])
  with result show False ..
qed
(*>*)

subsection\<open>Parallel OR is not definable\<close>

text \<open>

\label{sec:por}

We show that parallel-or is not \<open>\<lambda>\<close>-definable following
\<^citet>\<open>"Sieber:1992"\<close> and \<^citet>\<open>"DBLP:conf/mfps/Stoughton93"\<close>.

Parallel-or is similar to the familiar short-circuting or except that
if the first argument is @{term "\<bottom>"} and the second one is
@{term "ValTT"}, we get @{term "ValTT"} (and not @{term
"\<bottom>"}). It is continuous and then have included in the @{typ
"ValD"} domain.

\<close>

definition por :: "ValD \<Rightarrow> ValD \<Rightarrow> ValD" ("_ por _" [31,30] 30) where
  "x por y \<equiv>
     if x = ValTT then ValTT
       else if y = ValTT then ValTT
              else if (x = ValFF \<and> y = ValFF) then ValFF else \<bottom>"

text\<open>The defining properties of parallel-or.\<close>

lemma POR_simps [simp]:
  "(ValTT por y) = ValTT"
  "(x por ValTT) = ValTT"
  "(ValFF por ValFF) = ValFF"
  "(ValFF por \<bottom>) = \<bottom>"
  "(ValFF por ValN\<cdot>n) = \<bottom>"
  "(ValFF por ValF\<cdot>f) = \<bottom>"
  "(\<bottom> por ValFF) = \<bottom>"
  "(ValN\<cdot>n por ValFF) = \<bottom>"
  "(ValF\<cdot>f por ValFF) = \<bottom>"
  "(\<bottom> por \<bottom>) = \<bottom>"
  "(\<bottom> por ValN\<cdot>n) = \<bottom>"
  "(\<bottom> por ValF\<cdot>f) = \<bottom>"
  "(ValN\<cdot>n por \<bottom>) = \<bottom>"
  "(ValF\<cdot>f por \<bottom>) = \<bottom>"
  "(ValN\<cdot>m por ValN\<cdot>n) = \<bottom>"
  "(ValN\<cdot>n por ValF\<cdot>f) = \<bottom>"
  "(ValF\<cdot>f por ValN\<cdot>n) = \<bottom>"
  "(ValF\<cdot>f por ValF\<cdot>g) = \<bottom>"
  unfolding por_def by simp_all
(*<*)

text\<open>

We show that parallel-or is a continuous function.

\<close>

lemma POR_sym: "(x por y) = (y por x)"
  unfolding por_def by simp

lemma ValTT_below_iff [simp]: "ValTT \<sqsubseteq> x \<longleftrightarrow> x = ValTT"
  by (cases x) simp_all

lemma ValFF_below_iff [simp]: "ValFF \<sqsubseteq> x \<longleftrightarrow> x = ValFF"
  by (cases x) simp_all

lemma monofun_por: "monofun (\<lambda>x. x por y)"
  unfolding por_def
  by (rule monofunI) auto

lemma mic2mic: "max_in_chain i Y \<Longrightarrow> max_in_chain i (\<lambda>i. f (Y i))"
  unfolding max_in_chain_def by simp

lemma cont_por1: "cont (\<lambda>x. x por y)"
  apply (rule contI2[OF monofun_por])
  apply (case_tac "Lub Y")
   apply simp_all
   apply (cases y)
   apply simp_all
   apply (cases y)
   apply simp_all

   apply (frule compact_imp_max_in_chain)
    apply simp
   apply clarsimp
   apply (frule mic2mic[where f="\<lambda>x. x por y"])
   apply (subst iffD1[OF maxinch_is_thelub])
   apply simp_all
   apply (simp_all add: maxinch_is_thelub)

   apply (frule compact_imp_max_in_chain)
    apply simp
   apply clarsimp
   apply (frule mic2mic[where f="\<lambda>x. x por y"])
   apply (subst iffD1[OF maxinch_is_thelub])
   apply simp_all
   apply (simp_all add: maxinch_is_thelub)

   apply (cases y)
   apply simp_all
   done

lemma cont_por[cont2cont, simp]:
  assumes f: "cont (\<lambda>x. f x)" and g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. f x por g x)"
proof -
  have A: "\<And>f y. cont f \<Longrightarrow> cont (\<lambda>x. f x por y)"
    by (rule cont_apply) (simp_all add: cont_por1)
  from A[OF f] A[OF g] show ?thesis
    by (auto simp: cont_por1 POR_sym intro: cont_apply[OF f])
qed

(*>*)
text\<open>

We need three-element vectors.

\<close>

datatype Three = One | Two | Three

text\<open>

The standard logical relation @{term "R"} that demonstrates POR is not
definable is:
\[
  (x, y, z) \in R\ \mbox{iff}\ x = y = z \lor (x = \bot \lor y = \bot)
\]
That POR satisfies this relation can be seen from its truth table (see
below).

Note we restrict the \<open>x = y = z\<close> clause to non-function
values. Adding functions breaks the ``logical relations'' property.

\<close>

definition
  POR_base_lf_rep :: "(Three \<Rightarrow> ValD) lf_rep"
where
  "POR_base_lf_rep \<equiv> \<lambda>(mR, pR).
     { (\<lambda>i. ValTT) } \<union> { (\<lambda>i. ValFF) } \<comment> \<open>\<open>x = y = z\<close> for bools\<close>
   \<union> (\<Union>n. { (\<lambda>i. ValN\<cdot>n) }) \<comment> \<open>\<open>x = y = z\<close> for numerals\<close>
   \<union> { f . f One = \<bottom> } \<comment> \<open>\<open>x = \<bottom>\<close>\<close>
   \<union> { f . f Two = \<bottom> } \<comment> \<open>\<open>y = \<bottom>\<close>\<close>"

text\<open>

We close this relation with respect to continuous functions. This
functor yields an admissible relation for all @{term "r"} and is
monotonic.

\<close>

definition
  fn_lf_rep :: "('i::type \<Rightarrow> ValD) lf_rep"
where
  "fn_lf_rep \<equiv> \<lambda>(mR, pR). { \<lambda>i. ValF\<cdot>(fs i) |fs. \<forall>xs \<in> unlr (undual mR). (\<lambda>j. (fs j)\<cdot>(xs j)) \<in> unlr pR }"
(*<*)

lemma adm_POR_base_lf_rep:
  "adm (\<lambda>x. x \<in> POR_base_lf_rep r)"
unfolding POR_base_lf_rep_def
using adm_below_monic_exists[OF _ below_monic_fun_K[where f="ValN"], where P="\<lambda>_. True", simplified]
by (auto intro!: adm_disj simp: cont_fun)

lemma mono_POR_base_lf_rep:
  "mono POR_base_lf_rep"
unfolding POR_base_lf_rep_def by (blast intro!: monoI)

lemma adm_fn:
  shows "adm (\<lambda>x. x \<in> fn_lf_rep r)"
unfolding fn_lf_rep_def
using adm_below_monic_exists[OF _ below_monic_fun_K[where f="ValF"], where P="\<lambda>_. True", simplified]
apply (clarsimp simp: split_def)
apply (rule adm_below_monic_exists)
apply (auto simp: cont_fun below_monic_indexed)
done

(*
  by (fastforce simp: split_def intro: adm_below_monic_exists)
*)

lemma mono_fn_lf_rep:
  "mono fn_lf_rep"
proof
  fix x y :: "('a \<Rightarrow> ValD) admS dual \<times> ('a \<Rightarrow> ValD) admS"
  obtain x1 x2 y1 y2 where [simp]: "x = (x1, x2)" "y = (y1, y2)"
    by (cases x, cases y)
  assume "x \<le> y"
  then show "fn_lf_rep x \<subseteq> fn_lf_rep y"
    by (simp add: fn_lf_rep_def) (use dual_less_eq_iff less_eq_admS_def in blast)
qed

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

definition POR_lf_rep :: "(Three \<Rightarrow> ValD) lf_rep" where
  "POR_lf_rep R \<equiv> POR_base_lf_rep R \<union> fn_lf_rep R"

abbreviation "POR_lf \<equiv> \<lambda>r. mklr (POR_lf_rep r)"
(*<*)

lemma admS_POR_lf [intro, simp]:
  "POR_lf_rep r \<in> admS"
proof
  show "\<bottom> \<in> POR_lf_rep r"
    unfolding POR_lf_rep_def POR_base_lf_rep_def
    by simp
next
  show "adm (\<lambda>x. x \<in> POR_lf_rep r)"
    unfolding POR_lf_rep_def
    using adm_POR_base_lf_rep[of r] adm_fn[of r] by simp
qed

lemma mono_POR_lf:
  "mono POR_lf"
  apply (rule monoI)
  apply simp
  unfolding POR_lf_rep_def
  using mono_fn_lf_rep mono_POR_base_lf_rep
  apply (blast dest: monoD)
  done

(*>*)
text\<open>

Again it yields an admissible relation and is monotonic.

We need to show the functor respects the minimal invariant.

\<close>

lemma min_inv_POR_lf:
  assumes "eRSV e R' S'"
  shows "eRSV (ValD_copy_rec\<cdot>e) (dual (POR_lf (dual S', undual R'))) (POR_lf (R', S'))"
(*<*)
  apply clarsimp
  apply (simp add: POR_lf_rep_def)
  apply (elim disjE)
   apply (rule disjI1)
   apply (auto simp: POR_base_lf_rep_def eta_cfun cfcomp1 cfun_eq_iff)[1]
  apply (rule disjI2)
  using assms
  apply (clarsimp simp: fn_lf_rep_def eta_cfun)
  apply (simp add: cfcomp1 cfun_map_def)
  apply (rule_tac x="\<lambda>i. \<Lambda> xa. e\<cdot>(fs i\<cdot>(e\<cdot>xa))" in exI)
  apply force
  done

interpretation POR: DomSolV POR_lf ValD_copy_rec
  apply standard
    apply (rule mono_POR_lf)
   apply (rule ValD_copy_ID)
  apply (erule min_inv_POR_lf)
  done

lemma PORI [intro, simp]:
  "(\<lambda>i. ValTT) \<in> unlr POR.delta"
  "(\<lambda>i. ValFF) \<in> unlr POR.delta"
  "(\<lambda>i. ValN\<cdot>n) \<in> unlr POR.delta"
  "f One = \<bottom> \<Longrightarrow> f \<in> unlr POR.delta"
  "f Two = \<bottom> \<Longrightarrow> f \<in> unlr POR.delta"
  "\<lbrakk> \<And>xs. xs \<in> unlr POR.delta \<Longrightarrow> (\<lambda>j. (fs j)\<cdot>(xs j)) \<in> unlr POR.delta \<rbrakk> \<Longrightarrow> (\<lambda>i. ValF\<cdot>(fs i)) \<in> unlr POR.delta"
  by (subst POR.delta_sol, simp, subst POR_lf_rep_def,
      fastforce simp: POR_base_lf_rep_def fn_lf_rep_def eta_cfun cfcomp1)+

lemma PORE:
  "\<lbrakk> a \<in> unlr POR.delta;
     (a = (\<lambda>i. ValTT) \<Longrightarrow> P);
     (a = (\<lambda>i. ValFF) \<Longrightarrow> P);
     (\<And>n. a = (\<lambda>i. ValN\<cdot>n) \<Longrightarrow> P);
     (a One = \<bottom> \<Longrightarrow> P);
     (a Two = \<bottom> \<Longrightarrow> P);
     (\<And>fs. \<lbrakk> a = (\<lambda>i. ValF\<cdot>(fs i)); \<And>xs. xs \<in> unlr POR.delta \<Longrightarrow> (\<lambda>j. (fs j)\<cdot>(xs j)) \<in> unlr POR.delta \<rbrakk> \<Longrightarrow> P)
   \<rbrakk> \<Longrightarrow> P"
  apply (subst (asm) POR.delta_sol)
  apply simp
  apply (subst (asm) POR_lf_rep_def)
  apply (fastforce simp: POR_base_lf_rep_def fn_lf_rep_def eta_cfun)
  done

lemma POR_strict_appI:
  assumes "xs \<in> unlr POR.delta"
  assumes "\<And>xs. xs \<in> unlr POR.delta \<Longrightarrow> (\<lambda>j. fs j\<cdot>(xs j)) \<in> unlr POR.delta"
  shows "(\<lambda>j. strictify\<cdot>(fs j)\<cdot>(xs j)) \<in> unlr POR.delta"
using assms by - (erule PORE; simp)

lemma logical_relation_POR:
  "logical_relation (unlr POR.delta)"
  apply (rule logical_relationI)

  (* Strict application *)
  prefer 2
  apply (cut_tac fs="\<lambda>i. appF\<cdot>(fs i)" and xs=xs in POR_strict_appI)
   apply simp_all
  apply (auto elim: PORE)[1]

  (* FIXME fixD *)
  prefer 2
  apply (erule PORE)
  apply (simp_all add: fixD_def)
  apply (subst fix_argument_promote_fun)
  apply (rule_tac F="\<Lambda> f. (\<lambda>x. fs x\<cdot>(f x))" in fix_ind)
  apply (simp_all split: nat.split add: cont_fun)

  apply (auto elim: PORE simp: cond_def isZero_def pred_def succ_def eta_cfun split: nat.split)
  done

lemma PCF_consts_rel_POR:
  "PCF_consts_rel (unlr POR.delta)"
  by (rule PCF_consts_relI) simp_all

(*>*)
text\<open>

We can show that the solution satisfies the expectations of the
fundamental theorem @{thm [source] "lr_fundamental"}.

\<close>

lemma PCF_lr_POR_delta: "PCF_lr (unlr POR.delta)"
(*<*)
  using logical_relation_POR PCF_consts_rel_POR by fastforce
(*>*)
text\<open>

This is the truth-table for POR rendered as a vector: we seek a
function that simultaneously maps the two argument vectors to the
result.

\<close>

definition POR_arg1_rel where
  "POR_arg1_rel \<equiv> \<lambda>i. case i of One \<Rightarrow> ValTT | Two \<Rightarrow> \<bottom> | Three \<Rightarrow> ValFF"

definition POR_arg2_rel where
  "POR_arg2_rel \<equiv> \<lambda>i. case i of One \<Rightarrow> \<bottom> | Two \<Rightarrow> ValTT | Three \<Rightarrow> ValFF"

definition POR_result_rel where
  "POR_result_rel \<equiv> \<lambda>i. case i of One \<Rightarrow> ValTT | Two \<Rightarrow> ValTT | Three \<Rightarrow> ValFF"

lemma lr_POR_arg1_rel: "POR_arg1_rel \<in> unlr POR.delta"
  unfolding POR_arg1_rel_def by auto

lemma lr_POR_arg2_rel: "POR_arg2_rel \<in> unlr POR.delta"
  unfolding POR_arg2_rel_def by auto

lemma lr_POR_result_rel: "POR_result_rel \<notin> unlr POR.delta"
(*<*)
  unfolding POR_result_rel_def
  apply clarify
  apply (erule PORE)
  apply (auto iff: fun_eq_iff split: Three.splits)
  done

(*>*)
text\<open>

Parallel-or satisfies these tests:

\<close>

theorem POR_sat:
  "appFLv (ValF\<cdot>(\<Lambda> x. ValF\<cdot>(\<Lambda> y. x por y))) [POR_arg1_rel, POR_arg2_rel] = POR_result_rel"
  unfolding POR_arg1_rel_def POR_arg2_rel_def POR_result_rel_def
  by (simp add: fun_eq_iff split: Three.splits)

text\<open>

... but is not PCF-definable:

\<close>

theorem POR_is_not_definable:
  shows "\<not>(\<exists>f. definable f \<and> appFLv f [POR_arg1_rel, POR_arg2_rel] = POR_result_rel)"
  apply (rule not_definable[where R="unlr POR.delta"])
    using lr_POR_arg1_rel lr_POR_arg2_rel lr_POR_result_rel PCF_lr_POR_delta
    apply simp_all
  done

subsection\<open>Plotkin's existential quantifier\<close>

text\<open>

We can also show that the existential quantifier of
\<^citet>\<open>\<open>\S5\<close> in "Plotkin77"\<close> is not PCF-definable using logical relations.

Our definition is quite loose; if the argument function @{term "f"}
maps any value to @{term "ValTT"} then @{term "plotkin_exists"} yields
@{term "ValTT"}. It may be more plausible to test @{term "f"} on
numerals only.

\<close>

definition plotkin_exists :: "ValD \<Rightarrow> ValD" where
  "plotkin_exists f \<equiv>
     if (appF\<cdot>f\<cdot>\<bottom> = ValFF)
       then ValFF
       else if (\<exists>n. appF\<cdot>f\<cdot>n = ValTT) then ValTT else \<bottom>"
(*<*)

lemma plotkin_exists_simps [simp]:
  "plotkin_exists \<bottom> = \<bottom>"
  "plotkin_exists (ValF\<cdot>\<bottom>) = \<bottom>"
  "plotkin_exists (ValF\<cdot>(\<Lambda> _. ValFF)) = ValFF"
  unfolding plotkin_exists_def by simp_all

lemma monofun_pe:
  "monofun plotkin_exists"
proof(rule monofunI)
  fix f g assume fg: "(f::ValD) \<sqsubseteq> g"
  let ?goal = "plotkin_exists f \<sqsubseteq> plotkin_exists g"
  {
    assume fbot: "appF\<cdot>f\<cdot>\<bottom> = ValFF"
    with fg have "appF\<cdot>g\<cdot>\<bottom> = ValFF"
      using monofun_cfun[where f="appF\<cdot>f" and g="appF\<cdot>g" and x="\<bottom>"]
      by (simp add: monofun_cfun_arg)
    with fbot have ?goal by (simp add: plotkin_exists_def)
  }
  moreover
  {
    assume efn: "\<exists>n. appF\<cdot>f\<cdot>n = ValTT"
    then obtain n where fn: "appF\<cdot>f\<cdot>n = ValTT" by blast
    then have fbot: "appF\<cdot>f\<cdot>\<bottom> \<noteq> ValFF"
      using monofun_cfun_arg[where f="appF\<cdot>f" and x="\<bottom>" and y="n"] by fastforce
    from fg have "appF\<cdot>f\<cdot>n \<sqsubseteq> appF\<cdot>g\<cdot>n"
      using monofun_cfun_arg[OF fg, where f=appF]
      by (simp only: cfun_below_iff)
    with fn have gn: "appF\<cdot>g\<cdot>n = ValTT"
      using ValD.nchotomy[where y="appF\<cdot>g\<cdot>\<bottom>"] by simp
    then have gbot: "appF\<cdot>g\<cdot>\<bottom> \<noteq> ValFF"
      using monofun_cfun_arg[where f="appF\<cdot>g" and x="\<bottom>" and y="n"] by fastforce
    from fn gn fbot gbot have ?goal apply (unfold plotkin_exists_def) by fastforce
  }
  moreover
  {
    assume fbot: "appF\<cdot>f\<cdot>\<bottom> \<noteq> ValFF" and efn: "\<not>(\<exists>n. appF\<cdot>f\<cdot>n = ValTT)"
    then have ?goal by (simp add: plotkin_exists_def)
  }
  ultimately show ?goal unfolding plotkin_exists_def by blast
qed

(*>*)
text\<open>

We can show this function is continuous.

\<close>

lemma cont_pe [cont2cont, simp]: "cont plotkin_exists"
(*<*)
proof (rule contI2[OF monofun_pe])
  fix Y assume Y: "chain (Y :: nat \<Rightarrow> ValD)"
  let ?goal = "plotkin_exists (\<Squnion> i. Y i) \<sqsubseteq> (\<Squnion> i. plotkin_exists (Y i))"
  have peY: "chain (\<lambda>i. plotkin_exists (Y i))"
    by (rule chainI, simp add: monofunE[OF monofun_pe] chainE[OF Y])
  {
    assume "\<exists>i. appF\<cdot>(Y i)\<cdot>\<bottom> = ValFF"
    then obtain i where Yi: "appF\<cdot>(Y i)\<cdot>\<bottom> = ValFF" by blast
    have "Y i \<sqsubseteq> (\<Squnion> i. Y i)"
      using is_ub_thelub[OF Y, where x=i] by simp
    then have "appF\<cdot>(Y i)\<cdot>\<bottom> \<sqsubseteq> appF\<cdot>(\<Squnion> i. Y i)\<cdot>\<bottom>" by (fastforce intro: monofun_cfun)
    with Yi have "ValFF \<sqsubseteq> appF\<cdot>(\<Squnion> i. Y i)\<cdot>\<bottom>" by simp
    then have "appF\<cdot>(\<Squnion> i. Y i)\<cdot>\<bottom> = ValFF" using ValD.nchotomy[where y="appF\<cdot>(\<Squnion> i. Y i)\<cdot>\<bottom>"] by simp
    moreover
    from Yi have "plotkin_exists (Y i) = ValFF" by (simp add: plotkin_exists_def)
    then have "ValFF \<sqsubseteq> (\<Squnion> i. plotkin_exists (Y i))" using is_ub_thelub[OF peY, where x=i] by simp
    then have "ValFF = (\<Squnion> i. plotkin_exists (Y i))" using ValD.nchotomy[where y="\<Squnion> i. plotkin_exists (Y i)"] by simp
    ultimately have ?goal by (simp add: plotkin_exists_def)
  }
  moreover
  {
    assume "\<exists>i j. appF\<cdot>(Y i)\<cdot>j = ValTT"
    then obtain i j where Yij: "appF\<cdot>(Y i)\<cdot>j = ValTT" by blast
    from Yij have Yib: "appF\<cdot>(Y i)\<cdot>\<bottom> \<noteq> ValFF"
      using monofun_cfun_arg[where f="appF\<cdot>(Y i)" and x="\<bottom>" and y=j] by clarsimp
    moreover
    from Yij have "appF\<cdot>(Y i)\<cdot>j \<sqsubseteq> appF\<cdot>(\<Squnion> i. Y i)\<cdot>j"
      using is_ub_thelub[OF Y, where x=i] by (fastforce intro: monofun_cfun)
    with Yij have Yjlub: "appF\<cdot>(\<Squnion> i. Y i)\<cdot>j = ValTT"
      using ValD.nchotomy[where y="appF\<cdot>(\<Squnion> i. Y i)\<cdot>j"] by simp
    moreover
    from Yjlub have "appF\<cdot>(\<Squnion> i. Y i)\<cdot>\<bottom> \<noteq> ValFF"
      using monofun_cfun_arg[where f="appF\<cdot>(\<Squnion> i. Y i)" and x="\<bottom>" and y=j] by auto
    moreover
    from Yib Yij have "plotkin_exists (Y i) = ValTT" by (auto simp add: plotkin_exists_def)
    then have "ValTT \<sqsubseteq> (\<Squnion> i. plotkin_exists (Y i))" using is_ub_thelub[OF peY, where x=i] by simp
    then have "ValTT = (\<Squnion> i. plotkin_exists (Y i))" using ValD.nchotomy[where y="\<Squnion> i. plotkin_exists (Y i)"] by simp
    ultimately have ?goal by (simp add: plotkin_exists_def)
  }
  moreover
  {
    assume nFF: "\<not>(\<exists>i. appF\<cdot>(Y i)\<cdot>\<bottom> = ValFF)" and nTT: "\<not>(\<exists>i j. appF\<cdot>(Y i)\<cdot>j = ValTT)"
    with Y have ?goal
      unfolding plotkin_exists_def
      using compact_below_lub_iff[OF ValD.compacts(2)]
            compact_below_lub_iff[OF ValD.compacts(3)]
      by (simp add: contlub_cfun_arg contlub_cfun_fun)
  }
  ultimately show ?goal by blast
qed

lemma cont_pe2[cont2cont, simp]: "cont f \<Longrightarrow> cont (\<lambda>x. plotkin_exists (f x))"
  by (rule cont_apply) simp_all

(*>*)
text\<open>

Again we construct argument and result test vectors such that @{term
"plotkin_exists"} satisfies these tests but no PCF-definable term
does.

\<close>

definition PE_arg_rel where
  "PE_arg_rel \<equiv> \<lambda>i. ValF\<cdot>(case i of
        0 \<Rightarrow> (\<Lambda> _. ValFF)
      | Suc n \<Rightarrow> (\<Lambda> (ValN\<cdot>x). if x = Suc n then ValTT else \<bottom>))"

definition PE_result_rel where
  "PE_result_rel \<equiv> \<lambda>i. case i of 0 \<Rightarrow> ValFF | Suc n \<Rightarrow> ValTT"

text\<open>

Note that unlike the POR case the argument relation does not
characterise PE: we don't treat functions that return @{term "ValTT"}s
and @{term "ValFF"}s.

The Plotkin existential satisfies these tests:

\<close>

theorem pe_sat:
  "appFLv (ValF\<cdot>(\<Lambda> x. plotkin_exists x)) [PE_arg_rel] = PE_result_rel"
  unfolding PE_arg_rel_def PE_result_rel_def
  by (clarsimp simp: fun_eq_iff split: nat.splits)

text\<open>

As for POR, the difference between the two vectors is that the
argument can diverge but not the result.

\<close>

definition PE_base_lf_rep :: "(nat \<Rightarrow> ValD) lf_rep" where
  "PE_base_lf_rep \<equiv> \<lambda>(mR, pR).
     { \<bottom> }
   \<union> { (\<lambda>i. ValTT) } \<union> { (\<lambda>i. ValFF) } \<comment> \<open>\<open>x = y = z\<close> for bools\<close>
   \<union> (\<Union>n. { (\<lambda>i. ValN\<cdot>n) }) \<comment> \<open>\<open>x = y = z\<close> for numerals\<close>
   \<union> { f . f 1 = \<bottom> \<or> f 2 = \<bottom> } \<comment> \<open>Vectors that diverge on one or two.\<close>"
(*<*)

lemma adm_PE_base_lf_rep:
  "adm (\<lambda>x. x \<in> PE_base_lf_rep r)"
unfolding PE_base_lf_rep_def
using adm_below_monic_exists[OF _ below_monic_fun_K[where f=ValN], where P="\<lambda>_. True"]
by (auto intro!: adm_disj simp: cont_fun)

lemma mono_PE_base_lf_rep:
  "mono PE_base_lf_rep"
unfolding PE_base_lf_rep_def
by (blast intro!: monoI)

(*>*)
text\<open>

Again we close this under the function space, and show that it is
admissible, monotonic and respects the minimal invariant.

\<close>

definition PE_lf_rep :: "(nat \<Rightarrow> ValD) lf_rep" where
  "PE_lf_rep R \<equiv> PE_base_lf_rep R \<union> fn_lf_rep R"

abbreviation "PE_lf \<equiv> \<lambda>r. mklr (PE_lf_rep r)"
(*<*)

lemma admS_PE_lf [intro, simp]:
  "PE_lf_rep r \<in> admS"
proof
  show "\<bottom> \<in> PE_lf_rep r"
    unfolding PE_lf_rep_def PE_base_lf_rep_def
    by simp
next
  show "adm (\<lambda>x. x \<in> PE_lf_rep r)"
    unfolding PE_lf_rep_def
    using adm_PE_base_lf_rep[of r] adm_fn[of r] by simp
qed

lemma mono_PE_lf:
  "mono PE_lf"
  apply (rule monoI)
  apply simp
  unfolding PE_lf_rep_def
  using mono_fn_lf_rep mono_PE_base_lf_rep
  apply (blast dest: monoD)
  done

lemma min_inv_PE_lf:
  assumes "eRSV e R' S'"
  shows "eRSV (ValD_copy_rec\<cdot>e) (dual (PE_lf (dual S', undual R'))) (PE_lf (R', S'))"
  apply clarsimp
  apply (simp add: PE_lf_rep_def)
  apply (elim disjE)
   apply (rule disjI1)
   apply (auto simp: PE_base_lf_rep_def eta_cfun cfcomp1 cfun_eq_iff)[1]
  apply (rule disjI2)
  using assms
  apply (clarsimp simp: fn_lf_rep_def eta_cfun)
  apply (simp add: cfcomp1 cfun_map_def)
  apply (rule_tac x="\<lambda>x. \<Lambda> xa. e\<cdot>(fs x\<cdot>(e\<cdot>xa))" in exI)
  apply force
  done

interpretation PE: DomSolV PE_lf ValD_copy_rec
  apply standard
    apply (rule mono_PE_lf)
   apply (rule ValD_copy_ID)
  apply (erule min_inv_PE_lf)
  done

lemma PEI [intro, simp]:
  "\<bottom> \<in> unlr PE.delta"
  "(\<lambda>i. ValTT) \<in> unlr PE.delta"
  "(\<lambda>i. ValFF) \<in> unlr PE.delta"
  "(\<lambda>i. ValN\<cdot>n) \<in> unlr PE.delta"
  "f 1 = \<bottom> \<Longrightarrow> f \<in> unlr PE.delta"
  "f 2 = \<bottom> \<Longrightarrow> f \<in> unlr PE.delta"
  "\<lbrakk> \<And>xs. xs \<in> unlr PE.delta \<Longrightarrow> (\<lambda>j. (fs j)\<cdot>(xs j)) \<in> unlr PE.delta \<rbrakk> \<Longrightarrow> (\<lambda>i. ValF\<cdot>(fs i)) \<in> unlr PE.delta"
  by (subst PE.delta_sol, simp, subst PE_lf_rep_def,
      fastforce simp: PE_base_lf_rep_def fn_lf_rep_def eta_cfun cfcomp1)+

lemma PE_fun_constI:
  "\<lbrakk> \<And>xs. xs \<in> unlr PE.delta \<Longrightarrow> (\<lambda>j. f\<cdot>(xs j)) \<in> unlr PE.delta \<rbrakk> \<Longrightarrow> (\<lambda>i. ValF\<cdot>f) \<in> unlr PE.delta"
  using PEI(7)[where fs="\<lambda>_. f"] by simp

lemma PEE:
  "\<lbrakk> a \<in> unlr PE.delta;
     (a = \<bottom> \<Longrightarrow> P);
     (a = (\<lambda>i. ValTT) \<Longrightarrow> P);
     (a = (\<lambda>i. ValFF) \<Longrightarrow> P);
     (\<And>n. a = (\<lambda>i. ValN\<cdot>n) \<Longrightarrow> P);
     (a 1 = \<bottom> \<Longrightarrow> P);
     (a 2 = \<bottom> \<Longrightarrow> P);
     (\<And>fs. \<lbrakk> a = (\<lambda>j. ValF\<cdot>(fs j)); \<And>xs. xs \<in> unlr PE.delta \<Longrightarrow> (\<lambda>j. (fs j)\<cdot>(xs j)) \<in> unlr PE.delta \<rbrakk> \<Longrightarrow> P)
   \<rbrakk> \<Longrightarrow> P"
  apply (subst (asm) PE.delta_sol)
  apply simp
  apply (subst (asm) PE_lf_rep_def)
  apply (fastforce simp: PE_base_lf_rep_def fn_lf_rep_def eta_cfun)
  done

lemma PEE_strict_appI:
  assumes "xs \<in> unlr PE.delta"
  assumes "\<And>xs. xs \<in> unlr PE.delta \<Longrightarrow> (\<lambda>j. fs j\<cdot>(xs j)) \<in> unlr PE.delta"
  shows "(\<lambda>j. strictify\<cdot>(fs j)\<cdot>(xs j)) \<in> unlr PE.delta"
  using assms
  apply -
  apply (erule PEE)
  apply simp_all
  done

lemma logical_relation_PE:
  "logical_relation (unlr PE.delta)"
apply (rule logical_relationI)

  (* Strict application *)
  prefer 2
  apply (cut_tac fs="\<lambda>i. appF\<cdot>(fs i)" and xs=xs in PEE_strict_appI)
   apply simp_all
  apply (auto elim: PEE)[1]

  (* FIXME fixD *)
  prefer 2
  apply (erule PEE)
  apply (simp_all add: fixD_def)
  apply (subst fix_argument_promote_fun)
  apply (rule_tac F="\<Lambda> f. (\<lambda>x. fs x\<cdot>(f x))" in fix_ind)
  apply (simp_all split: nat.split add: cont_fun)

  apply (auto elim: PEE simp: cond_def isZero_def pred_def succ_def eta_cfun split: nat.split)
  done

lemma PCF_consts_rel_PE:
  "PCF_consts_rel (unlr PE.delta)"
  by (rule PCF_consts_relI) simp_all
(*>*)
text\<open>

The solution satisfies the expectations of the fundamental theorem:

\<close>

lemma PCF_lr_PE_delta: "PCF_lr (unlr PE.delta)"
(*<*)
  using logical_relation_PE PCF_consts_rel_PE by fastforce
(*>*)

lemma lr_PE_arg_rel: "PE_arg_rel \<in> unlr PE.delta"
(*<*)
  unfolding PE_arg_rel_def
  apply (rule PEI(7))
  apply (erule PEE)
   apply simp_all
  apply (case_tac n)
   apply simp
  apply (case_tac nat)
   apply simp_all
  done
(*>*)

lemma lr_PE_result_rel: "PE_result_rel \<notin> unlr PE.delta"
(*<*)
unfolding PE_result_rel_def
apply clarify
apply (erule PEE)
apply (auto iff: fun_eq_iff split: nat.splits)
done
(*>*)

theorem PE_is_not_definable: "\<not>(\<exists>f. definable f \<and> appFLv f [PE_arg_rel] = PE_result_rel)"
(*<*)
apply (rule not_definable[where R="unlr PE.delta"])
  using lr_PE_arg_rel lr_PE_result_rel PCF_lr_PE_delta
  apply simp_all
done
(*>*)

subsection\<open>Concluding remarks\<close>

text\<open>

These techniques could be used to show that Haskell's \<open>seq\<close>
operation is not PCF-definable. (It is definable for each base
``type'' separately, and requires some care on function values.) If we
added an (unlifted) product type then it should be provable that
parallel evaluation is required to support \<open>seq\<close> on these
objects (given \<open>seq\<close> on all other objects). (See
\<^citet>\<open>\<open>\S5.4\<close> in "DBLP:conf/hopl/HudakHJW07"\<close> and sundry posts to the
internet by Lennart Augustsson.) This may be difficult to do plausibly
without adding a type system.

\<close>

(*<*)

end
(*>*)


theory SM_Indep
imports
  "../Refine/SM_Finite_Reachable"
  Partial_Order_Reduction.Transition_System_Interpreted_Traces
  SM_Variables
begin

context visible_prog
begin

  fun ind :: "global_action option \<Rightarrow> global_action option \<Rightarrow> bool" where
    "ind None None \<longleftrightarrow> True"
  | "ind (Some _) None \<longleftrightarrow> False"
  | "ind None (Some _) \<longleftrightarrow> False"
  | "ind (Some (pid1,c1,a1,c1')) (Some (pid2,c2,a2,c2'))
    \<longleftrightarrow>
      pid1\<noteq>pid2
    \<and> (write_globals a1 \<inter> read_globals a2 = {})
    \<and> (write_globals a2 \<inter> read_globals a1 = {})
    \<and> (write_globals a1 \<inter> write_globals a2 = {})
    \<and> (\<not>( Some (pid1,c1,a1,c1')\<in>jsys.visible
        \<and> Some (pid2,c2,a2,c2') \<in> jsys.visible))"

  lemma ind_symmetric: "ind a b \<longleftrightarrow> ind b a"
    by (cases "(a,b)" rule: ind.cases) auto

  lemma ga_ex_swap:
    assumes PIDNE: "pid1\<noteq>pid2"
    assumes DJ:
      "write_globals a1 \<inter> read_globals a2 = {}"
      "write_globals a2 \<inter> read_globals a1 = {}"
      "write_globals a1 \<inter> write_globals a2 = {}"
    shows "ga_ex (Some (pid1,c1,a1,c1')) (ga_ex (Some (pid2,c2,a2,c2')) gc)
         = ga_ex (Some (pid2,c2,a2,c2')) (ga_ex (Some (pid1,c1,a1,c1')) gc)"
    using PIDNE
    apply (auto
      simp: ga_ex_def ga_gex_def
      simp: list_update_swap dest: ex_swap_global[OF DJ]
      split: prod.splits)
    done

  corollary ind_swap:
    "ind ga1 ga2 \<Longrightarrow> ga_ex ga2 (ga_ex ga1 gc) = ga_ex ga1 (ga_ex ga2 gc)"
    apply (cases "(ga1,ga2)" rule: ind.cases)
    apply (auto intro: ga_ex_swap)
    done

  lemma ind_en: "\<lbrakk>ind a b; a \<in> ga_en p\<rbrakk>
         \<Longrightarrow> (b \<in> ga_en (ga_ex a p)) = (b \<in> ga_en p)"
    apply (cases "(a,b)" rule: ind.cases, simp_all)
    apply (auto
      simp: ga_ex_def ga_en_def ga_gex_def ga_gen_def ex_pres_en
      split: prod.splits
      )
    done

  sublocale jsys: transition_system_traces ga_ex "\<lambda> a p. a \<in> ga_en p" ind
    apply unfold_locales
    apply (simp_all add: ind_symmetric ind_en ind_swap)
    done

  sublocale jsys: transition_system_interpreted_traces
    ga_ex "\<lambda> a p. a \<in> ga_en p" pid_interp_gc
    ind
    apply unfold_locales
    apply (case_tac "(a,b)" rule: ind.cases)
    apply (auto simp: jsys.visible_def)
    done

  end
end


(*  Title:       Show
    Author:      Christian Sternagel <c.sternagel@gmail.com>
    Author:      René Thiemann <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel <c.sternagel@gmail.com>
    Maintainer:  René Thiemann <rene.thiemann@uibk.ac.at>
*)

section \<open>Converting Arbitrary Values to Readable Strings\<close>

text \<open>
  A type class similar to Haskell's \texttt{Show} class, allowing for constant-time concatenation of
  strings using function composition.
\<close>

theory Show
imports
  Main
  Deriving.Generator_Aux
  Deriving.Derive_Manager
begin

type_synonym
  "shows" = "string \<Rightarrow> string"

\<comment> \<open>show-functions with precedence\<close>
type_synonym
  'a showsp = "nat \<Rightarrow> 'a \<Rightarrow> shows"

subsection \<open>The Show-Law\<close>

text \<open>
  The "show law", @{term "shows_prec p x (r @ s) = shows_prec p x r @ s"}, states that
  show-functions do not temper with or depend on output produced so far.
\<close>

named_theorems show_law_simps \<open>simplification rules for proving the "show law"\<close>
named_theorems show_law_intros \<open>introduction rules for proving the "show law"\<close>

definition show_law :: "'a showsp \<Rightarrow> 'a \<Rightarrow> bool"
where
  "show_law s x \<longleftrightarrow> (\<forall>p y z. s p x (y @ z) = s p x y @ z)"

lemma show_lawI:
  "(\<And>p y z. s p x (y @ z) = s p x y @ z) \<Longrightarrow> show_law s x"
  by (simp add: show_law_def)

lemma show_lawE:
  "show_law s x \<Longrightarrow> (s p x (y @ z) = s p x y @ z \<Longrightarrow> P) \<Longrightarrow> P"
  by (auto simp: show_law_def)

lemma show_lawD:
  "show_law s x \<Longrightarrow> s p x (y @ z) = s p x y @ z"
  by (blast elim: show_lawE)

class "show" =
  fixes shows_prec :: "'a showsp"
    and shows_list :: "'a list \<Rightarrow> shows"
  assumes shows_prec_append [show_law_simps]: "shows_prec p x (r @ s) = shows_prec p x r @ s" and
    shows_list_append [show_law_simps]: "shows_list xs (r @ s) = shows_list xs r @ s"
begin

abbreviation "shows x \<equiv> shows_prec 0 x"
abbreviation "show x \<equiv> shows x ''''"

end

text \<open>Convert a string to a show-function that simply prepends the string unchanged.\<close>
definition shows_string :: "string \<Rightarrow> shows"
where
  "shows_string = (@)"

lemma shows_string_append [show_law_simps]:
  "shows_string x (r @ s) = shows_string x r @ s"
  by (simp add: shows_string_def)

fun shows_sep :: "('a \<Rightarrow> shows) \<Rightarrow> shows \<Rightarrow> 'a list \<Rightarrow> shows"
where
  "shows_sep s sep [] = shows_string ''''" |
  "shows_sep s sep [x] = s x" |
  "shows_sep s sep (x#xs) = s x o sep o shows_sep s sep xs"

lemma shows_sep_append [show_law_simps]:
  assumes "\<And>r s. \<forall>x \<in> set xs. showsx x (r @ s) = showsx x r @ s"
    and "\<And>r s. sep (r @ s) = sep r @ s"
  shows "shows_sep showsx sep xs (r @ s) = shows_sep showsx sep xs r @ s"
using assms
proof (induct xs)
  case (Cons x xs) then show ?case by (cases xs) (simp_all)
qed (simp add: show_law_simps)

lemma shows_sep_map:
  "shows_sep f sep (map g xs) = shows_sep (f o g) sep xs"
  by (induct xs) (simp, case_tac xs, simp_all)

definition
  shows_list_gen :: "('a \<Rightarrow> shows) \<Rightarrow> string \<Rightarrow> string \<Rightarrow> string \<Rightarrow> string \<Rightarrow> 'a list \<Rightarrow> shows"
where
  "shows_list_gen showsx e l s r xs =
    (if xs = [] then shows_string e
    else shows_string l o shows_sep showsx (shows_string s) xs o shows_string r)"

lemma shows_list_gen_append [show_law_simps]:
  assumes "\<And>r s. \<forall>x\<in>set xs. showsx x (r @ s) = showsx x r @ s"
  shows "shows_list_gen showsx e l sep r xs (s @ t) = shows_list_gen showsx e l sep r xs s @ t"
  using assms by (cases xs) (simp_all add: shows_list_gen_def show_law_simps)

lemma shows_list_gen_map:
  "shows_list_gen f e l sep r (map g xs) = shows_list_gen (f o g) e l sep r xs"
  by (simp_all add: shows_list_gen_def shows_sep_map)

definition pshowsp_list :: "nat \<Rightarrow> shows list \<Rightarrow> shows"
where
  "pshowsp_list p xs = shows_list_gen id ''[]'' ''['' '', '' '']'' xs"

definition showsp_list :: "'a showsp \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> shows"
where
  [code del]: "showsp_list s p = pshowsp_list p o map (s 0)"

lemma showsp_list_code [code]:
  "showsp_list s p xs = shows_list_gen (s 0) ''[]'' ''['' '', '' '']'' xs"
  by (simp add: showsp_list_def pshowsp_list_def shows_list_gen_map)

lemma show_law_list [show_law_intros]:
  "(\<And>x. x \<in> set xs \<Longrightarrow> show_law s x) \<Longrightarrow> show_law (showsp_list s) xs"
  by (simp add: show_law_def showsp_list_code show_law_simps)

lemma showsp_list_append [show_law_simps]:
  "(\<And>p y z. \<forall>x \<in> set xs. s p x (y @ z) = s p x y @ z) \<Longrightarrow>
    showsp_list s p xs (y @ z) = showsp_list s p xs y @ z"
  by (simp add: show_law_simps showsp_list_def pshowsp_list_def)

subsection \<open>Show-Functions for Characters and Strings\<close>

instantiation char :: "show"
begin

definition "shows_prec p (c::char) = (#) c"
definition "shows_list (cs::string) = shows_string cs"
instance
  by standard (simp_all add: shows_prec_char_def shows_list_char_def show_law_simps)

end

definition "shows_nl = shows (CHR ''\<newline>'')"
definition "shows_space = shows (CHR '' '')"
definition "shows_paren s = shows (CHR ''('') o s o shows (CHR '')'')"
definition "shows_quote s = shows (CHR 0x27) o s o shows (CHR 0x27)"
abbreviation "apply_if b s \<equiv> (if b then s else id)" \<comment> \<open>conditional function application\<close>
text \<open>Parenthesize only if precedence is greater than @{term "0::nat"}.\<close>
definition "shows_pl (p::nat) = apply_if (p > 0) (shows (CHR ''(''))"
definition "shows_pr (p::nat) = apply_if (p > 0) (shows (CHR '')''))"

lemma
  shows_nl_append [show_law_simps]: "shows_nl (x @ y) = shows_nl x @ y" and
  shows_space_append [show_law_simps]: "shows_space (x @ y) = shows_space x @ y" and
  shows_paren_append [show_law_simps]:
    "(\<And>x y. s (x @ y) = s x @ y) \<Longrightarrow> shows_paren s (x @ y) = shows_paren s x @ y" and
  shows_quote_append [show_law_simps]:
    "(\<And>x y. s (x @ y) = s x @ y) \<Longrightarrow> shows_quote s (x @ y) = shows_quote s x @ y" and
  shows_pl_append [show_law_simps]: "shows_pl p (x @ y) = shows_pl p x @ y" and
  shows_pr_append [show_law_simps]: "shows_pr p (x @ y) = shows_pr p x @ y"
  by (simp_all add: shows_nl_def shows_space_def shows_paren_def shows_quote_def shows_pl_def shows_pr_def show_law_simps)

lemma o_append:
  "(\<And>x y. f (x @ y) = f x @ y) \<Longrightarrow> g (x @ y) = g x @ y \<Longrightarrow> (f o g) (x @ y) = (f o g) x @ y"
  by simp

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

local_setup \<open>
  Show_Generator.register_foreign_partial_and_full_showsp @{type_name "list"} 0
    @{term "pshowsp_list"}
    @{term "showsp_list"} (SOME @{thm showsp_list_def})
    @{term "map"} (SOME @{thm list.map_comp}) [true] @{thm show_law_list}
\<close>

instantiation list :: ("show") "show"
begin

definition "shows_prec (p :: nat) (xs :: 'a list) = shows_list xs"
definition "shows_list (xss :: 'a list list) = showsp_list shows_prec 0 xss"

instance
  by standard (simp_all add: show_law_simps shows_prec_list_def shows_list_list_def)

end

definition shows_lines :: "'a::show list \<Rightarrow> shows"
where
  "shows_lines = shows_sep shows shows_nl"

definition shows_many :: "'a::show list \<Rightarrow> shows"
where
  "shows_many = shows_sep shows id"

definition shows_words :: "'a::show list \<Rightarrow> shows"
where
  "shows_words = shows_sep shows shows_space"

lemma shows_lines_append [show_law_simps]:
  "shows_lines xs (r @ s) = shows_lines xs r @ s"
  by (simp add: shows_lines_def show_law_simps)

lemma shows_many_append [show_law_simps]:
  "shows_many xs (r @ s) = shows_many xs r @ s"
  by (simp add: shows_many_def show_law_simps)

lemma shows_words_append [show_law_simps]:
  "shows_words xs (r @ s) = shows_words xs r @ s"
  by (simp add: shows_words_def show_law_simps)

lemma shows_foldr_append [show_law_simps]:
  assumes "\<And>r s. \<forall>x \<in> set xs. showx x (r @ s) = showx x r @ s"
  shows "foldr showx xs (r @ s) = foldr showx xs r @ s"
  using assms by (induct xs) (simp_all)

lemma shows_sep_cong [fundef_cong]:
  assumes "xs = ys" and "\<And>x. x \<in> set ys \<Longrightarrow> f x = g x"
  shows "shows_sep f sep xs = shows_sep g sep ys"
using assms
proof (induct ys arbitrary: xs)
  case (Cons y ys)
  then show ?case by (cases ys) simp_all
qed simp

lemma shows_list_gen_cong [fundef_cong]:
  assumes "xs = ys" and "\<And>x. x \<in> set ys \<Longrightarrow> f x = g x"
  shows "shows_list_gen f e l sep r xs = shows_list_gen g e l sep r ys"
  using shows_sep_cong [of xs ys f g] assms by (cases xs) (auto simp: shows_list_gen_def)

lemma showsp_list_cong [fundef_cong]:
  "xs = ys \<Longrightarrow> p = q \<Longrightarrow>
    (\<And>p x. x \<in> set ys \<Longrightarrow> f p x = g p x) \<Longrightarrow> showsp_list f p xs = showsp_list g q ys"
  by (simp add: showsp_list_code cong: shows_list_gen_cong)

abbreviation (input) shows_cons :: "string \<Rightarrow> shows \<Rightarrow> shows" (infixr "+#+" 10)
where
  "s +#+ p \<equiv> shows_string s \<circ> p"

abbreviation (input) shows_append :: "shows \<Rightarrow> shows \<Rightarrow> shows" (infixr "+@+" 10)
where
  "s +@+ p \<equiv> s \<circ> p"

instantiation String.literal :: "show"
begin

definition shows_prec_literal :: "nat \<Rightarrow> String.literal \<Rightarrow> string \<Rightarrow> string"
  where "shows_prec p s = shows_string (String.explode s)"

definition shows_list_literal :: "String.literal list \<Rightarrow> string \<Rightarrow> string"
  where "shows_list ss = shows_string (concat (map String.explode ss))"

lemma shows_list_literal_code [code]:
  "shows_list = foldr (\<lambda>s. shows_string (String.explode s))"
proof
  fix ss
  show "shows_list ss = foldr (\<lambda>s. shows_string (String.explode s)) ss"
    by (induct ss) (simp_all add: shows_list_literal_def shows_string_def)
qed

instance by standard
  (simp_all add: shows_prec_literal_def shows_list_literal_def shows_string_def)

end

text \<open>
  Don't use Haskell's existing "Show" class for code-generation, since it is not compatible to the
  formalized class.
\<close>
code_reserved Haskell "Show"

end


(*
 * Copyright (C) 2014 NICTA
 * All rights reserved.
 *)

(* Author: David Cock - David.Cock@nicta.com.au *)

section \<open>Well-Defined Programs.\<close>

theory WellDefined imports
  Healthiness
  Sublinearity
  LoopInduction
begin

text \<open>The definition of a well-defined program collects the various notions of healthiness and
well-behavedness that we have so far established: healthiness of the strict and liberal
transformers, continuity and sublinearity of the strict transformers, and two new properties.
These are that the strict transformer always lies below the liberal one (i.e. that it is at least
as \emph{strict}, recalling the standard embedding of a predicate), and that expectation
conjunction is distributed between then in a particular manner, which will be crucial in
establishing the loop rules.\<close>

subsection \<open>Strict Implies Liberal\<close>

text \<open>This establishes the first connection between the strict and
  liberal interpretations (@{term wp} and @{term wlp}).\<close>

definition
  wp_under_wlp :: "'s prog \<Rightarrow> bool"
where
  "wp_under_wlp prog \<equiv> \<forall>P. unitary P \<longrightarrow> wp prog P \<tturnstile> wlp prog P"

lemma wp_under_wlpI[intro]:
  "\<lbrakk> \<And>P. unitary P \<Longrightarrow> wp prog P \<tturnstile> wlp prog P \<rbrakk> \<Longrightarrow> wp_under_wlp prog"
  unfolding wp_under_wlp_def by(simp)

lemma wp_under_wlpD[dest]:
  "\<lbrakk> wp_under_wlp prog; unitary P \<rbrakk> \<Longrightarrow> wp prog P \<tturnstile> wlp prog P"
  unfolding wp_under_wlp_def by(simp)

lemma wp_under_le_trans:
  "wp_under_wlp a \<Longrightarrow> le_utrans (wp a) (wlp a)"
  by(blast)

lemma wp_under_wlp_Abort:
  "wp_under_wlp Abort"
  by(rule wp_under_wlpI, unfold wp_eval, auto)

lemma wp_under_wlp_Skip:
  "wp_under_wlp Skip"
  by(rule wp_under_wlpI, unfold wp_eval, blast)

lemma wp_under_wlp_Apply:
  "wp_under_wlp (Apply f)"
  by(auto simp:wp_eval)

lemma wp_under_wlp_Seq:
  assumes h_wlp_a: "nearly_healthy (wlp a)"
      and h_wp_b:  "healthy (wp b)"
      and h_wlp_b: "nearly_healthy (wlp b)"
      and wp_u_a:  "wp_under_wlp a"
      and wp_u_b:  "wp_under_wlp b"
  shows "wp_under_wlp (a ;; b)"
proof(rule wp_under_wlpI, unfold wp_eval o_def)
  fix P::"'a \<Rightarrow> real" assume uP: "unitary P"
  with h_wp_b have "unitary (wp b P)" by(blast)
  with wp_u_a have "wp a (wp b P) \<tturnstile> wlp a (wp b P)" by(auto)
  also {
    from wp_u_b and uP have "wp b P \<tturnstile> wlp b P" by(blast)
    with h_wlp_a and h_wlp_b and h_wp_b and uP
    have "wlp a (wp b P) \<tturnstile> wlp a (wlp b P)"
      by(blast intro:nearly_healthy_monoD[OF h_wlp_a])
  }
  finally show "wp a (wp b P) \<tturnstile> wlp a (wlp b P)" .
qed

lemma wp_under_wlp_PC:
  assumes h_wp_a:  "healthy (wp a)"
      and h_wlp_a: "nearly_healthy (wlp a)"
      and h_wp_b:  "healthy (wp b)"
      and h_wlp_b: "nearly_healthy (wlp b)"
      and wp_u_a:  "wp_under_wlp a"
      and wp_u_b:  "wp_under_wlp b"
      and uP:      "unitary P"
  shows "wp_under_wlp (a \<^bsub>P\<^esub>\<oplus> b)"
proof(rule wp_under_wlpI, unfold wp_eval, rule le_funI)
  fix Q::"'a \<Rightarrow> real" and s
  assume uQ: "unitary Q"
  from uP have "P s \<le> 1" by(blast)
  hence "0 \<le> 1 - P s" by(simp)
  moreover
  from uQ and wp_u_b have "wp b Q s \<le> wlp b Q s" by(blast)
  ultimately
  have "(1 - P s) * wp b Q s \<le> (1 - P s) * wlp b Q s"
    by(blast intro:mult_left_mono)

  moreover {
    from uQ and wp_u_a have "wp a Q s \<le> wlp a Q s" by(blast)
    with uP have "P s * wp a Q s \<le> P s * wlp a Q s"
      by(blast intro:mult_left_mono)
  }

  ultimately
  show "P s * wp  a Q s + (1 - P s) * wp  b Q s \<le>
        P s * wlp a Q s + (1 - P s) * wlp b Q s"
    by(blast intro: add_mono)
qed

lemma wp_under_wlp_DC:
  assumes wp_u_a:  "wp_under_wlp a"
      and wp_u_b:  "wp_under_wlp b"
  shows "wp_under_wlp (a \<Sqinter> b)"
proof(rule wp_under_wlpI, unfold wp_eval, rule le_funI)
  fix Q::"'a \<Rightarrow> real" and s
  assume uQ: "unitary Q"

  from wp_u_a uQ have "wp a Q s \<le> wlp a Q s" by(blast)
  moreover
  from wp_u_b uQ have "wp b Q s \<le> wlp b Q s" by(blast)
  ultimately
  show "min (wp a Q s) (wp b Q s) \<le> min (wlp a Q s) (wlp b Q s)"
    by(auto)
qed

lemma wp_under_wlp_SetPC:
  assumes wp_u_f:  "\<And>s a. a \<in> supp (P s) \<Longrightarrow> wp_under_wlp (f a)"
      and nP:      "\<And>s a. a \<in> supp (P s) \<Longrightarrow> 0 \<le> P s a"
  shows "wp_under_wlp (SetPC f P)"
proof(rule wp_under_wlpI, unfold wp_eval, rule le_funI)
  fix Q::"'a \<Rightarrow> real" and s
  assume uQ: "unitary Q"

  from wp_u_f uQ nP
  show "(\<Sum>a\<in>supp (P s). P s a * wp (f a) Q s) \<le> (\<Sum>a\<in>supp (P s). P s a * wlp (f a) Q s)"
    by(auto intro!:sum_mono mult_left_mono)
qed

lemma wp_under_wlp_SetDC:
  assumes wp_u_f:  "\<And>s a. a \<in> S s \<Longrightarrow> wp_under_wlp (f a)"
      and hf:      "\<And>s a. a \<in> S s \<Longrightarrow> healthy (wp (f a))"
      and nS:      "\<And>s. S s \<noteq> {}"
  shows "wp_under_wlp (SetDC f S)"
proof(rule wp_under_wlpI, rule le_funI, unfold wp_eval)
  fix Q::"'a \<Rightarrow> real" and s
  assume uQ: "unitary Q"

  show "Inf ((\<lambda>a. wp (f a) Q s) ` S s) \<le> Inf ((\<lambda>a. wlp (f a) Q s) ` S s)"
  proof(rule cInf_mono)
    from nS show "(\<lambda>a. wlp (f a) Q s) ` S s \<noteq> {}" by(blast)

    fix x assume xin: "x \<in> (\<lambda>a. wlp (f a) Q s) ` S s"
    then obtain a where ain: "a \<in> S s" and xrw: "x = wlp (f a) Q s"
      by(blast)
    with wp_u_f uQ
    have "wp (f a) Q s \<le> wlp (f a) Q s" by(blast)
    moreover from ain have "wp (f a) Q s \<in> (\<lambda>a. wp (f a) Q s) ` S s"
      by(blast)
    ultimately show "\<exists>y\<in> (\<lambda>a. wp (f a) Q s) ` S s. y \<le> x"
      by(auto simp:xrw)

  next
    fix y assume yin: "y \<in> (\<lambda>a. wp (f a) Q s) ` S s"
    then obtain a where ain: "a \<in> S s" and yrw: "y = wp (f a) Q s"
      by(blast)
    with hf uQ have "unitary (wp (f a) Q)" by(auto)
    with yrw show "0 \<le> y" by(auto)
  qed
qed

lemma wp_under_wlp_Embed:
  "wp_under_wlp (Embed t)"
  by(rule wp_under_wlpI, unfold wp_eval, blast)

lemma wp_under_wlp_loop:
  fixes body::"'s prog"
  assumes hwp: "healthy (wp body)"
      and hwlp: "nearly_healthy (wlp body)"
      and wp_under: "wp_under_wlp body"
  shows "wp_under_wlp (do G \<longrightarrow> body od)"
proof(rule wp_under_wlpI)
  fix P::"'s expect"
  assume uP: "unitary P" hence sP: "sound P" by(auto)

  let "?X Q s" = "\<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s"
  let "?Y Q s" = "\<guillemotleft>G\<guillemotright> s * wlp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s"

  show "wp (do G \<longrightarrow> body od) P \<tturnstile> wlp (do G \<longrightarrow> body od) P"
  proof(simp add:hwp hwlp sP uP wp_Loop1 wlp_Loop1, rule gfp_exp_upperbound)
    thm lfp_loop_fp
    from hwp sP have "lfp_exp ?X = ?X (lfp_exp ?X)"
      by(rule lfp_wp_loop_unfold)
    hence "lfp_exp ?X \<tturnstile> ?X (lfp_exp ?X)" by(simp)
    also {
      from hwp uP have "wp body (lfp_exp ?X) \<tturnstile> wlp body (lfp_exp ?X)"
        by(auto intro:wp_under_wlpD[OF wp_under] lfp_loop_unitary)
      hence "?X (lfp_exp ?X) \<tturnstile> ?Y (lfp_exp ?X)"
        by(auto intro:add_mono mult_left_mono)
    }
    finally show "lfp_exp ?X \<tturnstile> ?Y (lfp_exp ?X)" .
    from hwp uP show "unitary (lfp_exp ?X)"
      by(auto intro:lfp_loop_unitary)
  qed
qed

lemma wp_under_wlp_repeat:
  "\<lbrakk> healthy (wp a); nearly_healthy (wlp a); wp_under_wlp a \<rbrakk> \<Longrightarrow>
   wp_under_wlp (repeat n a)"
  by(induct n, auto intro!:wp_under_wlp_Skip wp_under_wlp_Seq healthy_intros)

lemma wp_under_wlp_Bind:
  "\<lbrakk> \<And>s. wp_under_wlp (a (f s)) \<rbrakk> \<Longrightarrow> wp_under_wlp (Bind f a)"
  unfolding wp_under_wlp_def by(auto simp:wp_eval)

lemmas wp_under_wlp_intros =
  wp_under_wlp_Abort wp_under_wlp_Skip
  wp_under_wlp_Apply wp_under_wlp_Seq
  wp_under_wlp_PC    wp_under_wlp_DC
  wp_under_wlp_SetPC wp_under_wlp_SetDC
  wp_under_wlp_Embed wp_under_wlp_loop
  wp_under_wlp_repeat wp_under_wlp_Bind

subsection \<open>Sub-Distributivity of Conjunction\<close>

definition
  sub_distrib_pconj :: "'s prog \<Rightarrow> bool"
where
  "sub_distrib_pconj prog \<equiv>
   \<forall>P Q. unitary P \<longrightarrow> unitary Q \<longrightarrow>
         wlp prog P && wp prog Q \<tturnstile> wp prog (P && Q)"

lemma sub_distrib_pconjI[intro]:
  "\<lbrakk>\<And>P Q. \<lbrakk> unitary P; unitary Q \<rbrakk> \<Longrightarrow>  wlp prog P && wp prog Q \<tturnstile> wp prog (P && Q) \<rbrakk> \<Longrightarrow>
    sub_distrib_pconj prog"
  unfolding sub_distrib_pconj_def by(simp)

lemma sub_distrib_pconjD[dest]:
  "\<And>P Q. \<lbrakk> sub_distrib_pconj prog; unitary P; unitary Q \<rbrakk> \<Longrightarrow>
   wlp prog P && wp prog Q \<tturnstile> wp prog (P && Q)"
  unfolding sub_distrib_pconj_def by(simp)

lemma sdp_Abort:
  "sub_distrib_pconj Abort"
  by(rule sub_distrib_pconjI, unfold wp_eval, auto intro:exp_conj_rzero)

lemma sdp_Skip:
  "sub_distrib_pconj Skip"
  by(rule sub_distrib_pconjI, simp add:wp_eval)

lemma sdp_Seq:
  fixes a and b
  assumes sdp_a:   "sub_distrib_pconj a"
      and sdp_b:   "sub_distrib_pconj b"
      and h_wp_a:  "healthy (wp a)"
      and h_wp_b:  "healthy (wp b)"
      and h_wlp_b: "nearly_healthy (wlp b)"
  shows "sub_distrib_pconj (a ;; b)"
proof(rule sub_distrib_pconjI, unfold wp_eval o_def)
  fix P::"'a \<Rightarrow> real" and Q::"'a \<Rightarrow> real"
  assume uP: "unitary P" and uQ: "unitary Q"

  with h_wp_b and h_wlp_b
  have "wlp a (wlp b P) && wp a (wp b Q) \<tturnstile> wp a (wlp b P && wp b Q)"
    by(blast intro!:sub_distrib_pconjD[OF sdp_a])
  also {
    from sdp_b and uP and uQ
    have "wlp b P && wp b Q \<tturnstile> wp b (P && Q)" by(blast)
    with h_wp_a h_wp_b h_wlp_b uP uQ
    have "wp a (wlp b P && wp b Q) \<tturnstile> wp a (wp b (P && Q))"
      by(blast intro!:mono_transD[OF healthy_monoD, OF h_wp_a] unitary_sound
                      unitary_intros sound_intros)
  }
  finally show "wlp a (wlp b P) && wp a (wp b Q) \<tturnstile> wp a (wp b (P && Q))" .
qed

lemma sdp_Apply:
  "sub_distrib_pconj (Apply f)"
  by(rule sub_distrib_pconjI, simp add:wp_eval)

lemma sdp_DC:
  fixes a::"'s prog" and b
  assumes sdp_a:   "sub_distrib_pconj a"
      and sdp_b:   "sub_distrib_pconj b"
      and h_wp_a:  "healthy (wp a)"
      and h_wp_b:  "healthy (wp b)"
      and h_wlp_b: "nearly_healthy (wlp b)"
  shows "sub_distrib_pconj (a \<Sqinter> b)"
proof(rule sub_distrib_pconjI, unfold wp_eval, rule le_funI)
  fix P::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s
  assume uP: "unitary P" and uQ: "unitary Q"

  have "((\<lambda>s. min (wlp a P s) (wlp b P s)) &&
         (\<lambda>s. min (wp a Q s) (wp b Q s))) s \<le>
        min (wlp a P s .& wp a Q s) (wlp b P s .& wp b Q s)"
    unfolding exp_conj_def by(rule min_pconj)
  also {
    have "(\<lambda>s. wlp a P s .& wp a Q s) = wlp a P && wp a Q"
      by(simp add:exp_conj_def)
    also from sdp_a uP uQ have "... \<tturnstile> wp a (P && Q)"
      by(blast dest:sub_distrib_pconjD)
    finally have "wlp a P s .& wp a Q s \<le> wp a (P && Q) s"
      by(rule le_funD)
    moreover {
      have "(\<lambda>s. wlp b P s .& wp b Q s) = wlp b P && wp b Q"
        by(simp add:exp_conj_def)
    also from sdp_b uP uQ have "... \<tturnstile> wp b (P && Q)"
      by(blast)
    finally have "wlp b P s .& wp b Q s \<le> wp b (P && Q) s"
      by(rule le_funD)
    }
    ultimately
    have "min (wlp a P s .& wp a Q s) (wlp b P s .& wp b Q s) \<le>
          min (wp a (P && Q) s) (wp b (P && Q) s)" by(auto)
  }
  finally
  show "((\<lambda>s. min (wlp a P s) (wlp b P s)) &&
         (\<lambda>s. min (wp a Q s) (wp b Q s))) s \<le>
        min (wp a (P && Q) s) (wp b (P && Q) s)" .
qed

lemma sdp_PC:
  fixes a::"'s prog" and b
  assumes sdp_a:   "sub_distrib_pconj a"
      and sdp_b:   "sub_distrib_pconj b"
      and h_wp_a:  "healthy (wp a)"
      and h_wp_b:  "healthy (wp b)"
      and h_wlp_b: "nearly_healthy (wlp b)"
      and uP:      "unitary P"
  shows "sub_distrib_pconj (a \<^bsub>P\<^esub>\<oplus> b)"
proof(rule sub_distrib_pconjI, unfold wp_eval, rule le_funI)
  fix Q::"'s \<Rightarrow> real" and R::"'s \<Rightarrow> real" and s::'s
  assume uQ: "unitary Q" and uR: "unitary R"

  have nnA: "0 \<le> P s" and nnB: "P s \<le> 1"
    using uP by auto
  note nn = nnA nnB

  have "((\<lambda>s. P s * wlp a Q s + (1 - P s) * wlp b Q s) &&
         (\<lambda>s. P s *  wp a R s + (1 - P s) *  wp b R s)) s =
        ((P s * wlp a Q s + (1 - P s) * wlp b Q s) +
         (P s *  wp a R s + (1 - P s) *  wp b R s)) \<ominus> 1"
    by(simp add:exp_conj_def pconj_def)
  also have "... = P s *       (wlp a Q s + wp a R s) +
                   (1 - P s) * (wlp b Q s + wp b R s) \<ominus> 1"
    by(simp add:field_simps)
  also have "... = P s *       (wlp a Q s + wp a R s) +
                   (1 - P s) * (wlp b Q s + wp b R s) \<ominus>
                   (P s + (1 - P s))"
    by(simp)
  also have "... \<le> (P s *       (wlp a Q s + wp a R s) \<ominus> P s) +
                   ((1 - P s) * (wlp b Q s + wp b R s) \<ominus> (1 - P s))"
    by(rule tminus_add_mono)
  also have "... = (P s       * (wlp a Q s + wp a R s \<ominus> 1)) +
                   ((1 - P s) * (wlp b Q s + wp b R s \<ominus> 1))"
    by(simp add:nn tminus_left_distrib)
  also have "... = P s *       ((wlp a Q && wp a R) s) +
                   (1 - P s) * ((wlp b Q && wp b R) s)"
    by(simp add:exp_conj_def pconj_def)
  also {
    from sdp_a sdp_b uQ uR
    have "P s * (wlp a Q && wp a R) s \<le> P s * wp a (Q && R) s"
     and "(1 - P s) * (wlp b Q && wp b R) s \<le> (1 - P s) * wp b (Q && R) s"
       by (simp_all add: entailsD mult_left_mono nn sub_distrib_pconjD)
    hence "P s *       ((wlp a Q && wp a R) s) +
           (1 - P s) * ((wlp b Q && wp b R) s) \<le>
           P s * wp a (Q && R) s + (1 - P s) * wp b (Q && R) s"
      by(auto)
  }
  finally show "((\<lambda>s. P s * wlp a Q s + (1 - P s) * wlp b Q s) &&
                 (\<lambda>s. P s *  wp a R s + (1 - P s) *  wp b R s)) s \<le>
                P s * wp a (Q && R) s + (1 - P s) * wp b (Q && R) s" .
qed

lemma sdp_Embed:
  "\<lbrakk> \<And>P Q. \<lbrakk> unitary P; unitary Q \<rbrakk> \<Longrightarrow> t P && t Q \<tturnstile> t (P && Q) \<rbrakk> \<Longrightarrow>
   sub_distrib_pconj (Embed t)"
  by(auto simp:wp_eval)

lemma sdp_repeat:
  fixes a::"'s prog"
  assumes sdpa: "sub_distrib_pconj a"
      and hwp: "healthy (wp a)" and hwlp: "nearly_healthy (wlp a)"
  shows "sub_distrib_pconj (repeat n a)" (is "?X n")
proof(induct n)
  show "?X 0" by(simp add:sdp_Skip)
  fix n assume IH: "?X n"
  show "?X (Suc n)"
  proof(rule sub_distrib_pconjI, simp add:wp_eval)
    fix P::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real"
    assume uP: "unitary P" and uQ: "unitary Q"
    from assms have hwlpa: "nearly_healthy (wlp (repeat n a))"
                and hwpa:  "healthy (wp (repeat n a))"
      by(auto intro:healthy_intros)
    from uP and hwlpa have "unitary (wlp (repeat n a) P)" by(blast)
    moreover from uQ and hwpa have "unitary (wp (repeat n a) Q)" by(blast)
    ultimately
    have "wlp a (wlp (repeat n a) P) && wp a (wp (repeat n a) Q) \<tturnstile>
          wp a (wlp (repeat n a) P && wp (repeat n a) Q)"
      using sdpa by(blast)
    also {
      from hwlp have "nearly_healthy (wlp (repeat n a))" by(rule healthy_intros)
      with uP have "sound (wlp (repeat n a) P)" by(auto)
      moreover from hwp uQ have "sound (wp (repeat n a) Q)"
        by(auto intro:healthy_intros)
      ultimately have "sound (wlp (repeat n a) P && wp (repeat n a) Q)"
        by(rule exp_conj_sound)
      moreover {
        from uP uQ have "sound (P && Q)" by(auto intro:exp_conj_sound)
        with hwp have "sound (wp (repeat n a) (P && Q))"
          by(auto intro:healthy_intros)
      }
      moreover from uP uQ IH
      have "wlp (repeat n a) P && wp (repeat n a) Q \<tturnstile> wp (repeat n a) (P && Q)"
        by(blast)
      ultimately
      have "wp a (wlp (repeat n a) P && wp (repeat n a) Q) \<tturnstile>
            wp a (wp (repeat n a) (P && Q))"
        by(rule mono_transD[OF healthy_monoD, OF hwp])
    }
    finally show "wlp a (wlp (repeat n a) P) && wp a (wp (repeat n a) Q) \<tturnstile>
                  wp a (wp (repeat n a) (P && Q))" .
  qed
qed

lemma sdp_SetPC:
  fixes p::"'a \<Rightarrow> 's prog"
  assumes sdp: "\<And>s a. a \<in> supp (P s) \<Longrightarrow> sub_distrib_pconj (p a)"
      and fin: "\<And>s. finite (supp (P s))"
      and nnp: "\<And>s a. 0 \<le> P s a"
      and sub: "\<And>s. sum (P s) (supp (P s)) \<le> 1"
  shows "sub_distrib_pconj (SetPC p P)"
proof(rule sub_distrib_pconjI, simp add:wp_eval, rule le_funI)
  fix Q::"'s \<Rightarrow> real" and R::"'s \<Rightarrow> real" and s::'s
  assume uQ: "unitary Q" and uR: "unitary R"
  have "((\<lambda>s. \<Sum>a\<in>supp (P s). P s a * wlp (p a) Q s) &&
         (\<lambda>s. \<Sum>a\<in>supp (P s). P s a *  wp (p a) R s)) s =
        (\<Sum>a\<in>supp (P s). P s a * wlp (p a) Q s) + (\<Sum>a\<in>supp (P s). P s a * wp (p a) R s) \<ominus> 1"
    by(simp add:exp_conj_def pconj_def)
  also have "... = (\<Sum>a\<in>supp (P s). P s a * (wlp (p a) Q s + wp (p a) R s)) \<ominus> 1"
    by(simp add: sum.distrib field_simps)
  also from sub
  have "... \<le> (\<Sum>a\<in>supp (P s). P s a * (wlp (p a) Q s + wp (p a) R s)) \<ominus>
              (\<Sum>a\<in>supp (P s). P s a)"
    by(rule tminus_right_antimono)
  also from fin
  have "... \<le> (\<Sum>a\<in>supp (P s). P s a * (wlp (p a) Q s + wp (p a) R s) \<ominus> P s a)"
    by(rule tminus_sum_mono)
  also from nnp
  have "... = (\<Sum>a\<in>supp (P s). P s a * (wlp (p a) Q s + wp (p a) R s \<ominus> 1))"
    by(simp add:tminus_left_distrib)
  also have "... = (\<Sum>a\<in>supp (P s). P s a * (wlp (p a) Q && wp (p a) R) s)"
    by(simp add:pconj_def exp_conj_def)
  also {
    from sdp uQ uR
    have "\<And>a. a \<in> supp (P s) \<Longrightarrow> wlp (p a) Q && wp (p a) R \<tturnstile> wp (p a) (Q && R)"
      by(blast intro:sub_distrib_pconjD)
    with nnp
    have "(\<Sum>a\<in>supp (P s). P s a * (wlp (p a) Q && wp (p a) R) s) \<le>
          (\<Sum>a\<in>supp (P s). P s a * (wp (p a) (Q && R)) s)"
      by(blast intro:sum_mono mult_left_mono)
  }
  finally show "((\<lambda>s. \<Sum>a\<in>supp (P s). P s a * wlp (p a) Q s) &&
                 (\<lambda>s. \<Sum>a\<in>supp (P s). P s a * wp (p a) R s)) s \<le>
                (\<Sum>a\<in>supp (P s). P s a * wp (p a) (Q && R) s)" .
qed

lemma sdp_SetDC:
  fixes p::"'a \<Rightarrow> 's prog"
  assumes sdp: "\<And>s a. a \<in> S s \<Longrightarrow> sub_distrib_pconj (p a)"
      and hwp: "\<And>s a. a \<in> S s \<Longrightarrow> healthy (wp (p a))"
      and hwlp: "\<And>s a. a \<in> S s \<Longrightarrow> nearly_healthy (wlp (p a))"
      and ne:  "\<And>s. S s \<noteq> {}"
  shows "sub_distrib_pconj (SetDC p S)"
proof(rule sub_distrib_pconjI, rule le_funI)
  fix P::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s
  assume uP: "unitary P" and uQ: "unitary Q"

  from uP hwlp
  have "\<And>x. x \<in> (\<lambda>a. wlp (p a) P) ` S s \<Longrightarrow> unitary x" by(auto)
  hence "\<And>y. y \<in> (\<lambda>a. wlp (p a) P s) ` S s \<Longrightarrow> 0 \<le> y" by(auto)
  hence "\<And>a. a \<in> S s \<Longrightarrow> wlp (SetDC p S) P s \<le> wlp (p a) P s"
    unfolding wp_eval by(intro cInf_lower bdd_belowI, auto)
  moreover {
    from uQ hwp have "\<And>a. a \<in> S s \<Longrightarrow>  0 \<le> wp (p a) Q s" by(blast)
    hence "\<And>a. a \<in> S s \<Longrightarrow> wp (SetDC p S) Q s \<le> wp (p a) Q s"
    unfolding wp_eval by(intro cInf_lower bdd_belowI, auto)
  }
  ultimately
  have "\<And>a. a \<in> S s \<Longrightarrow> wlp (SetDC p S) P s + wp (SetDC p S) Q s \<ominus> 1 \<le>
                      wlp (p a) P s + wp (p a) Q s \<ominus> 1"
    by(auto intro:tminus_left_mono add_mono)
  also have "\<And>a. wlp (p a) P s + wp (p a) Q s \<ominus> 1 = (wlp (p a) P && wp (p a) Q) s"
    by(simp add:exp_conj_def pconj_def)
  also from sdp uP uQ
  have "\<And>a. a \<in> S s \<Longrightarrow> ... a \<le> wp (p a) (P && Q) s"
    by(blast)
  also have "\<And>a. ... a = wp (p a) (\<lambda>s. P s + Q s \<ominus> 1) s"
    by(simp add:exp_conj_def pconj_def)
  finally
  show "(wlp (SetDC p S) P && wp (SetDC p S) Q) s \<le> wp (SetDC p S) (P && Q) s"
    unfolding exp_conj_def pconj_def wp_eval
    using ne by(blast intro!:cInf_greatest)
qed

lemma sdp_Bind:
  "\<lbrakk> \<And>s. sub_distrib_pconj (p (f s)) \<rbrakk> \<Longrightarrow> sub_distrib_pconj (Bind f p)"
  unfolding sub_distrib_pconj_def wp_eval exp_conj_def pconj_def
  by(blast)

text \<open>For loops, we again appeal to our transfinite induction principle, this time taking
advantage of the simultaneous treatment of both strict and liberal transformers.\<close>
lemma sdp_loop:
  fixes body::"'s prog"
  assumes sdp_body: "sub_distrib_pconj body"
      and hwlp: "nearly_healthy (wlp body)"
      and hwp:  "healthy (wp body)"
  shows "sub_distrib_pconj (do G \<longrightarrow> body od)"
proof(rule sub_distrib_pconjI, rule loop_induct[OF hwp hwlp])
  fix P Q::"'s expect" and S::"('s trans \<times> 's trans) set"
  assume uP: "unitary P" and uQ: "unitary Q"
     and ffst: "\<forall>x\<in>S. feasible (fst x)"
     and usnd: "\<forall>x\<in>S. \<forall>Q. unitary Q \<longrightarrow> unitary (snd x Q)"
     and IH: "\<forall>x\<in>S. snd x P && fst x Q \<tturnstile> fst x (P && Q)"

  show "Inf_utrans (snd ` S) P && Sup_trans (fst ` S) Q \<tturnstile>
                  Sup_trans (fst ` S) (P && Q)"
  proof(cases)
    assume "S = {}"
    thus ?thesis
      by(simp add:Inf_trans_def Sup_trans_def Inf_utrans_def
                  Inf_exp_def Sup_exp_def exp_conj_def)
  next
    assume ne: "S \<noteq> {}"

    let "?f s" = "1 + Sup_trans (fst ` S) (P && Q) s - Inf_utrans (snd ` S) P s"

    from ne obtain t where tin: "t \<in> fst ` S" by(auto)
    from ne obtain u where uin: "u \<in> snd ` S" by(auto)

    from tin ffst uP uQ have utPQ: "unitary (t (P && Q))"
      by(auto intro:exp_conj_unitary)
    hence "\<And>s. 0 \<le> t (P && Q) s" by(auto)
    also {
      from ffst tin have le: "le_utrans t (Sup_trans (fst ` S))"
        by(auto intro:Sup_trans_upper)
      with uP uQ have "\<And>s. t (P && Q) s \<le> Sup_trans (fst ` S) (P && Q) s"
        by(auto intro:exp_conj_unitary)
    }
    finally have nn_rhs: "\<And>s. 0 \<le> Sup_trans (fst ` S) (P && Q) s" .

    have "\<And>R. Inf_utrans (snd ` S) P && R \<tturnstile> Sup_trans (fst ` S) (P && Q) \<Longrightarrow> R \<le> ?f"
    proof(rule contrapos_pp, assumption)
      fix R
      assume "\<not> R \<le> ?f"
      then obtain s where "\<not> R s \<le> ?f s" by(auto)
      hence gt: "?f s < R s" by(simp)

      from nn_rhs have g1: "1 \<le> 1 + Sup_trans (fst ` S) (P && Q) s" by(auto)
      hence "Sup_trans (fst ` S) (P && Q) s = Inf_utrans (snd ` S) P s .& ?f s"
        by(simp add:pconj_def)
      also from g1 have "... = Inf_utrans (snd ` S) P s + ?f s - 1"
        by(simp)
      also from gt have "... < Inf_utrans (snd ` S) P s + R s - 1"
        by(simp)
      also {
        with g1 have "1 \<le> Inf_utrans (snd ` S) P s + R s"
          by(simp)
        hence "Inf_utrans (snd ` S) P s + R s - 1 = Inf_utrans (snd ` S) P s .& R s"
          by(simp add:pconj_def)
      }
      finally
      have "\<not> (Inf_utrans (snd ` S) P && R) s \<le> Sup_trans (fst ` S) (P && Q) s"
        by(simp add:exp_conj_def)
      thus "\<not> Inf_utrans (snd ` S) P && R \<tturnstile> Sup_trans (fst ` S) (P && Q)"
        by(auto)
    qed

    moreover have "\<forall>t\<in>fst ` S. Inf_utrans (snd ` S) P && t Q  \<tturnstile> Sup_trans (fst ` S) (P && Q)"
    proof
      fix t assume tin: "t \<in> fst ` S"
      then obtain x where xin: "x \<in> S" and fx: "t = fst x" by(auto)

      from xin have "snd x \<in> snd ` S" by(auto)
      with uP usnd have "Inf_utrans (snd ` S) P \<tturnstile> snd x P"
        by(auto intro:le_utransD[OF Inf_utrans_lower])
      hence "Inf_utrans (snd ` S) P && fst x Q \<tturnstile> snd x P && fst x Q"
        by(auto intro:entails_frame)
      also from xin IH have "... \<tturnstile> fst x (P && Q)"
        by(auto)
      also from xin ffst exp_conj_unitary[OF uP uQ]
      have "... \<tturnstile> Sup_trans (fst ` S) (P && Q)"
        by(auto intro:le_utransD[OF Sup_trans_upper])
      finally show "Inf_utrans (snd ` S) P && t Q \<tturnstile> Sup_trans (fst ` S) (P && Q)"
        by(simp add:fx)
    qed
    ultimately have bt: "\<forall>t\<in>fst ` S. t Q \<tturnstile> ?f" by(blast)

    have "Sup_trans (fst ` S) Q = Sup_exp {t Q |t. t \<in> fst ` S}"
      by(simp add:Sup_trans_def)
    also have "... \<tturnstile> ?f"
    proof(rule Sup_exp_least)
      from bt show " \<forall>R\<in>{t Q |t. t \<in> fst ` S}. R \<tturnstile> ?f" by(blast)
      from ne obtain t where tin: "t \<in> fst ` S" by(auto)
      with ffst uQ have "unitary (t Q)" by(auto)
      hence "\<lambda>s. 0 \<tturnstile> t Q" by(auto)
      also from tin bt have "... \<tturnstile> ?f" by(auto)
      finally show "nneg (\<lambda>s. 1 + Sup_trans (fst ` S) (P && Q) s -
                          Inf_utrans (snd ` S) P s)"
        by(auto)
    qed
    finally have "Inf_utrans (snd ` S) P && Sup_trans (fst ` S) Q \<tturnstile>
                  Inf_utrans (snd ` S) P && ?f"
      by(auto intro:entails_frame)
    also from nn_rhs have "... \<tturnstile> Sup_trans (fst ` S) (P && Q)"
      by(simp add:exp_conj_def pconj_def)
    finally show ?thesis .
  qed

next
  fix P Q::"'s expect" and t u::"'s trans"
  assume uP: "unitary P" and uQ: "unitary Q"
     and ft: "feasible t"
     and uu: "\<And>Q. unitary Q \<Longrightarrow> unitary (u Q)"
     and IH: "u P && t Q \<tturnstile> t (P && Q)"
  show "wlp (body ;; Embed u \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) P &&
        wp  (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) Q \<tturnstile>
        wp  (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) (P && Q)"
  proof(rule le_funI, simp add:wp_eval exp_conj_def pconj_def)
    fix s::'s
    have "\<guillemotleft> G \<guillemotright> s * wlp body (u P) s + (1 - \<guillemotleft> G \<guillemotright> s) * P s +
          (\<guillemotleft> G \<guillemotright> s * wp body (t Q) s + (1 - \<guillemotleft> G \<guillemotright> s) * Q s) \<ominus> 1 =
          (\<guillemotleft> G \<guillemotright> s * wlp body (u P) s + \<guillemotleft> G \<guillemotright> s * wp body (t Q) s) +
           ((1 - \<guillemotleft> G \<guillemotright> s) * P s + (1 - \<guillemotleft> G \<guillemotright> s) * Q s) \<ominus> (\<guillemotleft>G\<guillemotright> s + (1 - \<guillemotleft>G\<guillemotright> s))"
      by(simp add:ac_simps)
    also have "... \<le>
          (\<guillemotleft> G \<guillemotright> s * wlp body (u P) s + \<guillemotleft> G \<guillemotright> s * wp body (t Q) s \<ominus> \<guillemotleft>G\<guillemotright> s) +
           ((1 - \<guillemotleft> G \<guillemotright> s) * P s + (1 - \<guillemotleft> G \<guillemotright> s) * Q s \<ominus> (1 - \<guillemotleft>G\<guillemotright> s))"
      by(rule tminus_add_mono)
    also have "... =
          \<guillemotleft> G \<guillemotright> s * (wlp body (u P) s + wp body (t Q) s \<ominus> 1) +
           (1 - \<guillemotleft> G \<guillemotright> s) * (P s + Q s \<ominus> 1)"
       by(simp add:tminus_left_distrib distrib_left)
    also {
      from uP uQ ft uu
      have "wlp body (u P) && wp body (t Q) \<tturnstile> wp body (u P && t Q)"
        by(auto intro:sub_distrib_pconjD[OF sdp_body])
      also from IH unitary_sound[OF uP] unitary_sound[OF uQ] ft
                   unitary_sound[OF uu[OF uP]]
      have "\<dots> \<le> wp body (t (P && Q))"
        by(blast intro!:mono_transD[OF healthy_monoD, OF hwp] exp_conj_sound)
      finally have "wlp body (u P) s + wp body (t Q) s \<ominus> 1 \<le>
                    wp body (t (\<lambda>s. P s + Q s \<ominus> 1)) s"
        by(auto simp:exp_conj_def pconj_def)
      hence "\<guillemotleft> G \<guillemotright> s * (wlp body (u P) s + wp body (t Q) s \<ominus> 1) +
             (1 - \<guillemotleft> G \<guillemotright> s) * (P s + Q s \<ominus> 1) \<le>
             \<guillemotleft> G \<guillemotright> s * wp body (t (\<lambda>s. P s + Q s \<ominus> 1)) s +
             (1 - \<guillemotleft> G \<guillemotright> s) * (P s + Q s \<ominus> 1)"
        by(auto intro:add_right_mono mult_left_mono)
    }
    finally
    show "\<guillemotleft> G \<guillemotright> s * wlp body (u P) s + (1 - \<guillemotleft> G \<guillemotright> s) * P s +
          (\<guillemotleft> G \<guillemotright> s * wp body (t Q) s + (1 - \<guillemotleft> G \<guillemotright> s) * Q s) \<ominus> 1 \<le>
          \<guillemotleft> G \<guillemotright> s * wp body (t (\<lambda>s. P s + Q s \<ominus> 1)) s +
          (1 - \<guillemotleft> G \<guillemotright> s) * (P s + Q s \<ominus> 1)" .
  qed
next
  fix P Q::"'s expect" and t t' u u'::"'s trans"
  assume "unitary P" "unitary Q"
         "equiv_trans t t'" "equiv_utrans u u'"
         "u P && t Q \<tturnstile> t (P && Q)"
  thus "u' P && t' Q \<tturnstile> t' (P && Q)"
    by(simp add:equiv_transD unitary_sound equiv_utransD exp_conj_unitary)
qed

lemmas sdp_intros =
  sdp_Abort  sdp_Skip  sdp_Apply
  sdp_Seq    sdp_DC    sdp_PC
  sdp_SetPC  sdp_SetDC sdp_Embed
  sdp_repeat sdp_Bind  sdp_loop

subsection \<open>The Well-Defined Predicate.\<close>

definition
  well_def :: "'s prog \<Rightarrow> bool"
where
  "well_def prog \<equiv> healthy (wp prog) \<and> nearly_healthy (wlp prog)
                 \<and> wp_under_wlp prog \<and> sub_distrib_pconj prog
                 \<and> sublinear (wp prog) \<and> bd_cts (wp prog)"

lemma well_defI[intro]:
  "\<lbrakk> healthy (wp prog); nearly_healthy (wlp prog);
     wp_under_wlp prog; sub_distrib_pconj prog; sublinear (wp prog);
     bd_cts (wp prog) \<rbrakk> \<Longrightarrow>
   well_def prog"
  unfolding well_def_def by(simp)

lemma well_def_wp_healthy[dest]:
  "well_def prog \<Longrightarrow> healthy (wp prog)"
  unfolding well_def_def by(simp)

lemma well_def_wlp_nearly_healthy[dest]:
  "well_def prog \<Longrightarrow> nearly_healthy (wlp prog)"
  unfolding well_def_def by(simp)

lemma well_def_wp_under[dest]:
  "well_def prog \<Longrightarrow> wp_under_wlp prog"
  unfolding well_def_def by(simp)

lemma well_def_sdp[dest]:
  "well_def prog \<Longrightarrow> sub_distrib_pconj prog"
  unfolding well_def_def by(simp)

lemma well_def_wp_sublinear[dest]:
  "well_def prog \<Longrightarrow> sublinear (wp prog)"
  unfolding well_def_def by(simp)

lemma well_def_wp_cts[dest]:
  "well_def prog \<Longrightarrow> bd_cts (wp prog)"
  unfolding well_def_def by(simp)

lemmas wd_dests =
  well_def_wp_healthy well_def_wlp_nearly_healthy
  well_def_wp_under well_def_sdp
  well_def_wp_sublinear well_def_wp_cts

lemma wd_Abort:
  "well_def Abort"
  by(blast intro:healthy_wp_Abort nearly_healthy_wlp_Abort
                 wp_under_wlp_Abort sdp_Abort sublinear_wp_Abort
                 cts_wp_Abort)

lemma wd_Skip:
  "well_def Skip"
  by(blast intro:healthy_wp_Skip nearly_healthy_wlp_Skip
                 wp_under_wlp_Skip sdp_Skip sublinear_wp_Skip
                 cts_wp_Skip)

lemma wd_Apply:
  "well_def (Apply f)"
  by(blast intro:healthy_wp_Apply nearly_healthy_wlp_Apply
                 wp_under_wlp_Apply sdp_Apply sublinear_wp_Apply
                 cts_wp_Apply)

lemma wd_Seq:
  "\<lbrakk> well_def a; well_def b \<rbrakk> \<Longrightarrow> well_def (a ;; b)"
  by(blast intro:healthy_wp_Seq nearly_healthy_wlp_Seq
                 wp_under_wlp_Seq sdp_Seq sublinear_wp_Seq
                 cts_wp_Seq)

lemma wd_PC:
  "\<lbrakk> well_def a; well_def b; unitary P \<rbrakk> \<Longrightarrow> well_def (a \<^bsub>P\<^esub>\<oplus> b)"
  by(blast intro:healthy_wp_PC nearly_healthy_wlp_PC
                 wp_under_wlp_PC sdp_PC sublinear_wp_PC
                 cts_wp_PC)

lemma wd_DC:
  "\<lbrakk> well_def a; well_def b \<rbrakk> \<Longrightarrow> well_def (a \<Sqinter> b)"
  by(blast intro:healthy_wp_DC nearly_healthy_wlp_DC
                 wp_under_wlp_DC sdp_DC sublinear_wp_DC
                 cts_wp_DC)

lemma wd_SetDC:
  "\<lbrakk> \<And>x s. x \<in> S s \<Longrightarrow> well_def (a x); \<And>s. S s \<noteq> {};
     \<And>s. finite (S s) \<rbrakk> \<Longrightarrow> well_def (SetDC a S)"
by (simp add: cts_wp_SetDC ex_in_conv healthy_intros(17) healthy_intros(18) sdp_intros(8) sublinear_intros(8) well_def_def wp_under_wlp_intros(8))

lemma wd_SetPC:
  "\<lbrakk> \<And>x s. x \<in> (supp (p s)) \<Longrightarrow> well_def (a x); \<And>s. unitary (p s); \<And>s. finite (supp (p s));
     \<And>s. sum (p s) (supp (p s)) \<le> 1 \<rbrakk> \<Longrightarrow> well_def (SetPC a p)"
  by(iprover intro!:well_defI healthy_wp_SetPC nearly_healthy_wlp_SetPC
                    wp_under_wlp_SetPC sdp_SetPC sublinear_wp_SetPC cts_wp_SetPC
             dest:wd_dests unitary_sound sound_nneg[OF unitary_sound] nnegD)

lemma wd_Embed:
  fixes t::"'s trans"
  assumes ht: "healthy t" and st: "sublinear t" and ct: "bd_cts t"
  shows "well_def (Embed t)"
proof(intro well_defI)
  from ht show "healthy (wp (Embed t))" "nearly_healthy (wlp (Embed t))"
    by(simp add:wp_def wlp_def Embed_def healthy_nearly_healthy)+
  from st show "sublinear (wp (Embed t))" by(simp add:wp_def Embed_def)
  show "wp_under_wlp (Embed t)" by(simp add:wp_under_wlp_def wp_eval)
  show "sub_distrib_pconj (Embed t)"
    by(rule sub_distrib_pconjI,
       auto intro:le_funI[OF sublinearD[OF st, where a=1 and b=1 and c=1, simplified]]
            simp:exp_conj_def pconj_def wp_def wlp_def Embed_def)
  from ct show "bd_cts (wp (Embed t))"
    by(simp add:wp_def Embed_def)
qed

lemma wd_repeat:
  "well_def a \<Longrightarrow> well_def (repeat n a)"
  by(blast intro:healthy_wp_repeat nearly_healthy_wlp_repeat
                 wp_under_wlp_repeat sdp_repeat sublinear_wp_repeat cts_wp_repeat)

lemma wd_Bind:
  "\<lbrakk> \<And>s. well_def (a (f s)) \<rbrakk> \<Longrightarrow> well_def (Bind f a)"
  by(blast intro:healthy_wp_Bind nearly_healthy_wlp_Bind
                 wp_under_wlp_Bind sdp_Bind sublinear_wp_Bind cts_wp_Bind)

lemma wd_loop:
  "well_def body \<Longrightarrow> well_def (do G \<longrightarrow> body od)"
  by(blast intro:healthy_wp_loop nearly_healthy_wlp_loop
                 wp_under_wlp_loop sdp_loop sublinear_wp_loop cts_wp_loop)

lemmas wd_intros =
  wd_Abort wd_Skip   wd_Apply
  wd_Embed wd_Seq    wd_PC
  wd_DC    wd_SetPC  wd_SetDC
  wd_Bind  wd_repeat wd_loop

end