(*  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{Plotkin77}. 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{DBLP:conf/icalp/Reynolds74}. We also adopt some of the
presentation of \citet[Chapter~11]{Winskel:1993}, 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{PittsAM:relpod}. 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[\S4]{Plotkin77} and \citet[\S6.1]{Gunter:1992}.

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

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{Plotkin:1973}.  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{Sieber:1992} and \citet{DBLP:conf/mfps/Stoughton93}.

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[\S5]{Plotkin77} 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[\S5.4]{DBLP:conf/hopl/HudakHJW07} and sundry posts to the
internet by Lennart Augustsson.) This may be difficult to do plausibly
without adding a type system.

\<close>

(*<*)

end
(*>*)


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2009-2       |
            |                October 2010  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                  April 2016  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2020         |
            |                  April 2020  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CPO
imports Infra
begin

(*****************************************************************

         1. Complete partial order (cpo)
         2. Continuity
         3. Tarski Theorem

 *****************************************************************)

definition
  directed ::  "'a::order set => bool"
  where
  directed_def : "directed X == ((X ~= {}) &
                                 (ALL x y. x : X & y : X -->
                                    (EX z. z : X & x <= z & y <= z)))"
(* 2009-1
axclass bot0 < order
consts Bot :: "'a::bot0"  (* Bottom *)

axclass
  bot < bot0
  bottom_bot : "Bot <= (x::'a::bot0)"
*)

class bot0 =
fixes Bot :: "'a::order"  ("Bot") (* Bottom *)

class bot = bot0 +
assumes bottom_bot : "Bot <= x"

(*
class Bot =
fixes Bot :: "'a::order"  (* Bottom *)

class bot = Bot +
assumes bottom_bot : "Bot <= x"
*)

(* 2009-1
axclass
  cpo < order
  complete_cpo : "(directed (X::'a::order set)) ==> X hasLUB"
*)

class cpo = order +
assumes complete_cpo : "(directed (X::'a::order set)) ==> X hasLUB"

(*** pointed cpo ***)

(*
axclass cpo_bot < cpo, bot
*)

class cpo_bot = cpo + bot

definition
  continuous  :: "('a::cpo => 'b::cpo) => bool"
  where
  continuous_def : "continuous f == ALL X.
                      directed X --> ((f ` X) hasLUB & LUB (f ` X) = f (LUB X))"
definition
  admissible  :: "('a::cpo => bool) => bool"
  where
  admissible_def : "admissible P == ALL X.
                      directed X --> (ALL x:X. P x) --> P (LUB X)"

(**********************************************************
                    small lemmas
 **********************************************************)

lemma complete_cpo_lm:
  "ALL (X::'a::cpo set). directed X --> X hasLUB"
by (simp add: complete_cpo)

(*** another definition of continuous ***)

lemma continuous_only_if: "continuous f ==>
          directed X --> (EX x. ((f x) isLUB (f ` X) & x isLUB X))"
apply (intro allI impI)
apply (insert complete_cpo_lm)
apply (drule_tac x="X" in spec)
apply (simp)
apply (insert LUB_is[of X], simp)

apply (simp add: hasLUB_def)
apply (erule exE)
apply (rule_tac x="x" in exI)

apply (simp add: continuous_def)
apply (drule_tac x="X" in spec)
apply (simp)

apply (erule conjE)
apply (simp add: LUB_iff)

apply (insert LUB_unique[of "LUB X" X])
by (simp)

lemma continuous_if:
    "ALL X. directed X --> (EX x. ((f x) isLUB (f ` X) & x isLUB X))
     ==> continuous f"
apply (simp add: continuous_def)
apply (intro allI impI)
apply (drule_tac x="X" in spec)
apply (simp)
apply (elim conjE exE)

apply (subgoal_tac "(f ` X) hasLUB", simp)
apply (simp add: LUB_iff)
apply (subgoal_tac "x = LUB X", simp)
apply (rule LUB_unique)
apply (simp)
apply (rule LUB_is)

apply (simp add: hasLUB_def)
apply (rule_tac x="x" in exI, simp)

apply (simp add: hasLUB_def)
apply (rule_tac x="f x" in exI, simp)
done

(*** iff ***)

lemma continuous_iff: "continuous f =
   (ALL X. directed X --> (EX x. ((f x) isLUB (f ` X) & x isLUB X)))"
apply (rule iffI)
apply (simp add: continuous_only_if)
apply (simp add: continuous_if)
done

(**********************************************************
             lemmas and theorems for Tarski
 **********************************************************)

(* LUB is not affected by Bot *)

lemma LUB_with_Bot:
  "((x::('a::cpo_bot)) isLUB {x. f x | x = Bot}) = (x isLUB {x. f x})"
apply (rule iffI)

apply (simp add: isLUB_def isUB_def)
apply (erule conjE)
apply (intro allI impI)
apply (rotate_tac 1)
apply (drule_tac x="y" in spec)
apply (rotate_tac -1)
apply (drule mp)
apply (intro allI)
apply (drule_tac x="ya" in spec)
apply (simp add: bottom_bot)
apply (assumption)

apply (simp add: isLUB_def isUB_def bottom_bot)
done

(************************************************************)

(* if x<=y then {x,y} is a directed set. *)
(* this is used in a proof for continuous_mono *)

lemma directed_x_y: "x <= y ==> directed {x, y}"
apply (simp add: directed_def)
apply (intro allI impI)
apply (rule_tac x="y" in exI)
by (auto)

(* the least upper bound of a set {x,y} *)
(* this is used in a proof for continuous_mono *)

lemma LUB_x_y: "[| x <= y ; z isLUB {x, y} |] ==> z = y"
apply (simp only: isUB_def isLUB_def)
apply (elim conjE)
apply (drule_tac x="y" in spec, simp)
apply (drule_tac x="y" in spec, simp)
done

(************************ continuity *****************************)

(* f is continuous --> f is monotonic *)

lemma continuous_mono: "continuous f ==> mono f"
apply (simp add: continuous_iff mono_def)
apply (intro allI impI)
apply (rename_tac A B)
apply (drule_tac x="{A,B}" in spec)
apply (simp add: directed_x_y)
apply (erule exE)
apply (erule conjE)

apply (subgoal_tac "x = B")
apply (simp add: isUB_def isLUB_def)
apply (simp add: LUB_x_y)
done

(* directed and functions *)

lemma directed_continuous:
  "[| continuous f ; directed X |] ==> directed (f ` X)"
apply (insert continuous_mono[of f])
apply (simp add: continuous_iff directed_def)
apply (drule_tac x="X" in spec)
apply (simp)
apply (intro allI impI)
apply (simp add: in_image_set)
apply (elim conjE exE)

apply (drule_tac x="ya" in spec)
apply (drule_tac x="yb" in spec)
apply (simp)
apply (elim conjE exE)

apply (rule_tac x="z" in bexI)   (* modified for 2020 *)
apply (simp add: mono_def)
apply (simp add: mono_def)
done

(* composition of continuous functions *)

lemma compo_continuous:
  "[| continuous f ; continuous g |] ==> continuous (g o f)"
apply (insert directed_continuous[of f])

apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="X" in spec)
apply (drule_tac x="f ` X" in spec)
apply (simp)
apply (elim conjE exE)
apply (rule_tac x="x" in exI)
(* Isabelle 2013  apply (simp add: image_compose) *)
apply (simp add: image_comp)

apply (subgoal_tac "xa = f x", simp)
apply (simp add: LUB_unique)
done

(*********************** Tarski continuous ****************************)

lemma Tarski_directed_lm1:
  "mono (f::('a::cpo_bot => 'a::cpo_bot)) ==> (f ^^ n) Bot <= (f ^^ (n+1)) Bot"
apply (induct_tac n)
apply (simp add: bottom_bot)
apply (simp add: mono_def)
done

lemma Tarski_directed_lm2:
  "mono (f::('a::cpo_bot => 'a::cpo_bot)) ==> (f ^^ n) Bot <= (f ^^ (n+m)) Bot"
apply (induct_tac m)
apply (simp)
apply (insert Tarski_directed_lm1[of f])
apply (rule order_trans)
apply (simp)
apply (simp)
done

lemma Tarski_directed:
  "mono (f::('a::cpo_bot => 'a::cpo_bot)) ==> directed {x. EX n. x = (f^^n) Bot}"
apply (simp add: directed_def)

apply (rule conjI)
apply (rule_tac x="Bot" in exI)
apply (rule_tac x="0" in exI)
apply (simp)

apply (intro allI impI)
apply (elim conjE exE)

apply (rename_tac x y n m)
apply (case_tac "m <= n")

apply (rule_tac x="x" in exI)
apply (rule conjI)
apply (rule_tac x="n" in exI)
apply (assumption)

apply (simp)
apply (subgoal_tac "(f ^^ m) Bot <= (f ^^ (m + (n-m))) Bot", simp)
apply (rule Tarski_directed_lm2, simp)

apply (rule_tac x="y" in exI)
apply (rule conjI)
apply (rule_tac x="m" in exI)
apply (assumption)

      (* ~ m <= n *)
apply (simp)
apply (subgoal_tac "(f ^^ n) Bot <= (f ^^ (n + (m-n))) Bot", simp)
apply (rule Tarski_directed_lm2, simp)
done

lemma Tarski_image_expand_lm:
  "f ` {x. EX n. x = (f ^^ n) Bot} = {x. EX n. x = f ((f ^^ n) Bot)}"
apply (auto simp add: image_Collect)
done

lemma Tarski_by_continuity:
  "continuous (f::('a::cpo_bot => 'a::cpo_bot)) ==>
    (EX x. f x isLUB {x. EX n. x = f((f^^n) Bot)} &
             x isLUB {x. EX n. x =   (f^^n) Bot })"
apply (insert continuous_mono[of f])
apply (simp)

apply (simp add: continuous_iff)
apply (drule_tac x="{x. EX n. x = (f ^^ n) Bot}" in spec)
apply (simp add: Tarski_directed)
apply (erule exE)
apply (rule_tac x="x" in exI)
apply (simp add: Tarski_image_expand_lm)
done

(******)

lemma Tarski_LUB_lm:
  "(EX n. (x = ((f::('a::cpo_bot => 'a::cpo_bot)) ^^ n) Bot) )
   = ((EX n. x = (f ^^ (Suc n)) Bot) | x = Bot)"
apply (rule iffI)

(* ==> *)
apply (erule exE)
apply (insert nat_zero_or_Suc)
apply (drule_tac x="n" in spec)
apply (erule disjE)
apply (simp)

apply (erule exE)
apply (rule disjI1)
apply (rule_tac x="m" in exI)
apply (simp)

(* <== *)
apply (erule disjE)
apply (erule exE)
apply (rule_tac x="Suc n" in exI)
apply (simp)
apply (rule_tac x="0" in exI)
apply (simp)
done

(******)

lemma Tarski_LUB:
  "ALL (f::('a::cpo_bot => 'a::cpo_bot)) x.
    (x::'a::cpo_bot) isLUB {x. EX n. x = f((f^^n) Bot)} =
                   x isLUB {x. EX n. x =   (f^^n) Bot }"
apply (simp add: Tarski_LUB_lm LUB_with_Bot)
done

(******)

lemma Tarski_least_lm:
  "[| mono (f::('a::cpo_bot => 'a::cpo_bot)) ; y = f y |]
   ==> (f^^n) Bot <= y"
apply (induct_tac n)
apply (simp add: bottom_bot)
apply (simp add: mono_def)
apply (drule_tac x="(f ^^ n) Bot" in spec)
apply (drule_tac x="y" in spec)
by (simp)

lemma Tarski_least:
  "[| mono (f::('a::cpo_bot => 'a::cpo_bot)) ;
      x isLUB {x. EX n. x = (f^^n) Bot } ; y = f y |]
   ==> x <= y"
apply (simp add: isLUB_def)
apply (erule conjE)
apply (drule_tac x="y" in spec)
apply (drule mp)
apply (simp add: isUB_def)
apply (intro allI impI)
apply (erule exE)
apply (simp add: Tarski_least_lm)
by (assumption)

(*-------------------*
 |       Tarski      |
 *-------------------*)

theorem Tarski_thm:
  "continuous (f::('a::cpo_bot => 'a::cpo_bot)) ==>
    f hasLFP & LFP f isLUB {x. EX n. x = (f^^n) Bot}"
apply (insert Tarski_by_continuity[of f])
apply (simp add: Tarski_LUB)
apply (erule exE)

apply (subgoal_tac "x isLFP f")        (* ...1 *)
apply (simp add: isLFP_LFP hasLFP_def)
apply (rule_tac x="x" in exI, simp)

      (* 1 *)
apply (simp add: isLFP_def)
apply (erule conjE)
apply (simp add: LUB_unique)
apply (intro allI impI)
apply (rule Tarski_least[of f])
apply (simp_all add: continuous_mono)
done

(*-------------------*
 |    Tarski LUB     |
 *-------------------*)

theorem Tarski_thm_LFP_LUB:
  "continuous (f::('a::cpo_bot => 'a::cpo_bot)) ==>
    LFP f = LUB {x. EX n. x = (f^^n) Bot}"
apply (insert Tarski_thm[of f])
apply (auto simp add: isLUB_LUB)
done

(*--------------------*
 | Tarski (existency) |
 *--------------------*)

theorem Tarski_thm_EX:
  "continuous (f::('a::cpo_bot => 'a::cpo_bot)) ==> f hasLFP"
by (simp add: Tarski_thm)

(*========================================================*
 |           Fixed Point Induction (pointed CPO)          |
 *========================================================*)

theorem cpo_fixpoint_induction:
  "[| (R::'a::cpo_bot => bool) Bot ; continuous f ; admissible R ;
     inductivefun R f |]
   ==> f hasLFP & R (LFP f)"
apply (insert Tarski_thm[of f], simp)
apply (simp add: admissible_def)
apply (drule_tac x="{x. EX n. x = (f^^n) Bot }" in spec)
apply (simp add: Tarski_directed continuous_mono)
apply (auto simp add: inductivefun_all_n)
apply (simp add: isLUB_LUB)
done

theorem cpo_fixpoint_induction_R:
  "[| (R::'a::cpo_bot => bool) Bot ; continuous f ; admissible R ;
     inductivefun R f |]
   ==> R (LFP f)"
by (simp add: cpo_fixpoint_induction)

(*----------------------------------------------------------*
 |                                                          |
 |       Fixed point induction for refinement (CPO)         |
 |                                                          |
 *----------------------------------------------------------*)

(************************************************************
         admissibility lemma for refinement for cpo
 ************************************************************)

lemma admissible_Rev_fun: "admissible (Rev_fun X)"
apply (simp add: Rev_fun_def)
apply (simp add: admissible_def)
by (auto simp add: LUB_least complete_cpo)

(*** Bot ***)

lemma Rev_fun_Bot: "Rev_fun (X::'a::bot) Bot"
by (simp add: Rev_fun_def bottom_bot)

(************************************************************
         Fixed Point Induction (CPO) for refinement
 ************************************************************)

theorem cpo_fixpoint_induction_rev:
  "[| continuous f ; f X <= X |]
   ==> LFP f <= (X::'a::cpo_bot)"
apply (insert cpo_fixpoint_induction[of "(Rev_fun X)" f])
apply (simp add: admissible_Rev_fun Rev_fun_Bot)
apply (subgoal_tac "inductivefun (Rev_fun X) f")
apply (simp add: Rev_fun_def)

      (* inductiveness *)
apply (simp add: inductivefun_def Rev_fun_def)
apply (intro allI impI)
apply (insert continuous_mono[of f])
apply (simp add: mono_def)
apply (drule_tac x="x" in spec)
apply (drule_tac x="X" in spec)
by (simp)

(*** EX version ***)

theorem cpo_fixpoint_induction_rev_EX:
  "[| continuous f ; f X <= X ; Y isLFP f |]
   ==> Y <= (X::'a::cpo_bot)"
apply (insert cpo_fixpoint_induction_rev[of f X])
by (auto simp add: isLFP_LFP)

(*****************************************************************)

end


theory Connected_Component
  imports
    Path_Tbd
begin

section \<open>Connected components induced by a vertex\<close>

thm Berge.connected_component_def

subsection \<open>@{term component_edges}\<close>

subsubsection \<open>\<close>

lemma mem_component_edgesD:
  assumes "{u, v} \<in> component_edges G C"
  shows
    "{u, v} \<in> G"
    "u \<in> C"
    "v \<in> C"
  using assms
  by (auto simp add: component_edges_def insert_commute doubleton_eq_iff)

lemma mem_component_edgesI:
  assumes "{u, v} \<in> G"
  assumes "{u, v} \<subseteq> C"
  shows "{u, v} \<in> component_edges G C"
  using assms
  by (auto simp add: component_edges_def)

lemma mem_component_edgesI_2:
  assumes "{u, v} \<in> G"
  assumes "u \<in> C"
  assumes "v \<in> C"
  shows "{u, v} \<in> component_edges G C"
  using assms
  by (intro mem_component_edgesI) simp+

lemma component_edges_subsetI:
  assumes "\<And>x y. {x, y} \<in> component_edges G C \<Longrightarrow> {x, y} \<in> S"
  shows "component_edges G C \<subseteq> S"
  using assms
  by (auto simp add: component_edges_def)

subsubsection \<open>\<close>

lemma Vs_component_edges_subset:
  shows "Vs (component_edges G C) \<subseteq> C"
  by (auto simp add: Vs_def component_edges_def)

subsection \<open>@{term "component_edges G \<circ> Berge.connected_component G"}\<close>

subsubsection \<open>\<close>

lemma mem_component_edges_connected_componentI:
  assumes "{u, v} \<in> G"
  shows "{u, v} \<in> component_edges G (Berge.connected_component G u)"
  using assms
proof (rule mem_component_edgesI_2, goal_cases)
  case 1
  show ?case
    using in_own_connected_component
    .
next
  case 2
  show ?case
    using assms
    by (auto intro: edges_are_walks)
qed

subsubsection \<open>\<close>

lemma walk_betw_connected_componentD:
  assumes "walk_betw G u p v"
  shows
    "set p \<subseteq> Berge.connected_component G u"
    "set (edges_of_path p) \<subseteq> component_edges G (Berge.connected_component G u)"
proof -
  let ?C = "Berge.connected_component G u"
  show "set p \<subseteq> ?C"
    using assms
    unfolding walk_between_nonempty_path(3)[OF assms, symmetric]
    by (intro walk_between_nonempty_path(1) path_subset_conn_comp)
  thus "set (edges_of_path p) \<subseteq> component_edges G ?C"
    using assms
    by (intro walk_between_nonempty_path(1) edges_path_subset_edges)
qed

lemma mem_connected_componentE_2:
  assumes "{u, v} \<in> G"
  assumes "x \<in> Berge.connected_component G u"
  obtains p where
    "walk_betw (component_edges G (Berge.connected_component G u)) u p x"
proof (cases "u = x")
  case True
  have "u \<in> Vs (component_edges G (Berge.connected_component G u))"
    using assms(1)
    by (intro mem_component_edges_connected_componentI edges_are_Vs)
  thus ?thesis
    by (fastforce simp add: True intro: walk_reflexive that)
next
  case False
  let ?C = "Berge.connected_component G u"
  obtain p where
    walk_betw_p: "walk_betw G u p x"
    using assms
    by (elim in_connected_component_has_path) (intro edges_are_Vs)
  hence "set (edges_of_path p) \<subseteq> component_edges G ?C"
    by (intro walk_betw_connected_componentD(2))
  moreover have "walk_betw (set (edges_of_path p)) u p x"
    using walk_betw_p False
    by (intro length_ge_2I walk_betw_in_set_edges_of_path)
  ultimately show ?thesis
    by (intro that) (rule walk_subset)
qed

section \<open>Connected components induced by an edge\<close>

definition connected_component :: "'a set set \<Rightarrow> 'a set \<Rightarrow> 'a set set" where
  "connected_component G e \<equiv> {e'. \<exists>p. path G p \<and> e \<in> set (edges_of_path p) \<and> e' \<in> set (edges_of_path p)}"

subsubsection \<open>\<close>

lemma mem_connected_componentE':
  assumes "e' \<in> connected_component G e"
  obtains p where
    "path G p \<and> e \<in> set (edges_of_path p) \<and> e' \<in> set (edges_of_path p)"
  using assms
  by (auto simp add: connected_component_def)

subsubsection \<open>\<close>

lemma mem_connected_componentE_2':
  assumes "{x, y} \<in> connected_component G {u, v}"
  obtains p where
    "walk_betw (connected_component G {u, v}) u p x"
proof (cases "u = x")
  case True
  have "x \<in> Vs (connected_component G {u, v})"
    using assms
    by (intro edges_are_Vs)
  thus ?thesis
    using True
    by (auto intro: walk_reflexive that)
next
  case False
  obtain p where p:
    "path G p"
    "{u, v} \<in> set (edges_of_path p)"
    "{x, y} \<in> set (edges_of_path p)"
    using assms
    by (auto elim: mem_connected_componentE')
  then obtain p' where
    walk_betw_p': "walk_betw G u p' x" and
    "set (edges_of_path p') \<subseteq> set (edges_of_path p)"
    by (metis tbdE set_edges_of_path_sublist_subset_2)
  hence "set (edges_of_path p') \<subseteq> connected_component G {u, v}"
    using p(1, 2)
    by (auto simp add: connected_component_def)
  moreover have "walk_betw (set (edges_of_path p')) u p' x"
    using walk_betw_p' False
    by (intro length_ge_2I walk_betw_in_set_edges_of_path)
  ultimately show ?thesis
    by (intro that) (rule walk_subset)
qed

lemma connected_component_subset_graph:
  shows "connected_component G e \<subseteq> G"
  by (auto simp add: connected_component_def intro: path_ball_edges)

lemma mem_connected_componentE_3':
  assumes "{x, y} \<in> connected_component G {u, v}"
  obtains p where
    "walk_betw G u p x"
  using assms connected_component_subset_graph
  by (fastforce elim: mem_connected_componentE_2' dest: walk_subset)

subsubsection \<open>\<close>

lemma connected_component_refl:
  assumes "{u, v} \<in> G"
  shows "{u, v} \<in> connected_component G {u, v}"
  using assms
  by (fastforce simp add: connected_component_def dest: edges_are_walks)

subsection \<open>Relation with @{term Berge.connected_component}}\<close>

lemma component_edges_connected_component_cong:
  assumes "{u, v} \<in> G"
  shows "component_edges G (Berge.connected_component G u) = connected_component G {u, v}"
proof (standard, goal_cases)
  case 1
  { fix x y
    assume assm: "{x, y} \<in> component_edges G (Berge.connected_component G u)"
    then obtain p where
      "walk_betw G u p x"
      using assms
      by
        (auto
         simp add: component_edges_def doubleton_eq_iff
         intro: edges_are_Vs in_connected_component_has_path)
    hence
      "walk_betw G v (v # p @ [y]) y \<and>
       {u, v} \<in> set (edges_of_path (v # p @ [y])) \<and>
       {x, y} \<in> set (edges_of_path (v # p @ [y]))"
      using assms assm
      by (auto simp add: insert_commute dest: mem_component_edgesD(1) walk_betw_Cons_snocI)
    hence "{x, y} \<in> connected_component G {u, v}"
      by (auto simp add: connected_component_def) }
  thus ?case
    by (auto simp add: component_edges_def)
next
  case 2
  { fix x y
    assume assm: "{x, y} \<in> connected_component G {u, v}"
    then obtain p where "walk_betw G u p x"
      by (elim mem_connected_componentE_3')
    moreover obtain p' where "walk_betw G u p' y"
      using assm
      by (auto simp add: insert_commute intro: mem_connected_componentE_3'[where ?x = y and ?y = x])
    ultimately have "{x, y} \<in> component_edges G (Berge.connected_component G u)"
      using connected_component_subset_graph assm
      by (force simp add: component_edges_def) }
  thus ?case
    by (force intro: mem_connected_componentE' v_in_edge_in_path_inj)
qed

lemma Vs_component_edges_connected_component_cong:
  assumes "{u, v} \<in> G"
  shows "Vs (component_edges G (Berge.connected_component G u)) = Berge.connected_component G u"
proof (standard, goal_cases)
  case 1
  thus ?case
    using Vs_component_edges_subset
    .
next
  case 2
  let ?C = "Berge.connected_component G u"
  { fix x
    assume assm: "x \<in> ?C"
    then obtain y where
      "{x, y} \<in> component_edges G ?C"
    proof (cases "x = u")
      case True
      thus ?thesis
        using assms
        by (auto intro: mem_component_edges_connected_componentI that)
    next
      case False
      obtain p where
        "walk_betw (component_edges G ?C) u p x"
        using assms assm
        by (elim mem_connected_componentE_2)
      thus ?thesis
        using False
        by (auto elim: walk_imp_edge_2 intro: length_ge_2I that)
    qed
    hence "x \<in> Vs (component_edges G ?C)"
      by (intro edges_are_Vs) }
  thus ?case
    by blast
qed

lemma (in graph) Vs_component_edges_connected_component_cong:
  assumes "u \<in> Vs G"
  shows "Vs (component_edges G (Berge.connected_component G u)) = Berge.connected_component G u"
  using assms
  by (auto elim: mem_VsE dest: Vs_component_edges_connected_component_cong)

end


(*  Title:       COMB
    Author:      Max Haslbeck
*)

section "COMB"

theory Comb
imports TS BIT_2comp_on2 BIT_pairwise
begin

(*  state of BIT: bool list     bit string
    state of TS: nat list       history
*)

subsection "Definition of COMB"

type_synonym CombState = "(bool list * nat list) + (nat list)"

definition COMB_init :: "nat list \<Rightarrow> (nat state, CombState) alg_on_init" where
  "COMB_init h init =
        Sum_pmf 0.8 (fst BIT init) (fst (embed (rTS h)) init)"

lemma COMB_init[simp]: "COMB_init h init =
                do {
                    (b::bool) \<leftarrow> (bernoulli_pmf 0.8);
                    (xs::bool list) \<leftarrow> Prob_Theory.bv (length init);
                    return_pmf (if b then Inl (xs, init) else Inr h)
                  }"
 apply(simp add: bind_return_pmf COMB_init_def BIT_init_def rTS_def
              bind_assoc_pmf )
 unfolding map_pmf_def Sum_pmf_def
 apply(simp add: if_distrib bind_return_pmf bind_assoc_pmf )
    apply(rule bind_pmf_cong)
     by(auto simp add: bind_return_pmf bind_assoc_pmf)

definition COMB_step :: "(nat state, CombState, nat, answer) alg_on_step" where
"COMB_step s q = (case snd s of Inl b \<Rightarrow> map_pmf (\<lambda>((a,b),c). ((a,b),Inl c)) (BIT_step (fst s, b) q)
                              | Inr b \<Rightarrow> map_pmf (\<lambda>((a,b),c). ((a,b),Inr c)) (return_pmf (TS_step_d (fst s, b) q)))"

definition "COMB h = (COMB_init h, COMB_step)"

subsection "Comb 1.6-competitive on 2 elements"

abbreviation "noc == (%x. case x of Inl (s,is) \<Rightarrow> (s,Inl is) | Inr (s,is) \<Rightarrow> (s,Inr is) )"
abbreviation "con == (%(s,is). case is of Inl is \<Rightarrow> Inl (s,is) | Inr is \<Rightarrow> Inr (s,is) )"

definition "inv_COMB s x i == (\<exists>Da Db. finite (set_pmf Da) \<and> finite (set_pmf Db) \<and>
      (map_pmf con s) = Sum_pmf 0.8 Da Db \<and> BIT_inv Da x i \<and> TS_inv Db x i)"

lemma noccon: "noc o con = id"
  apply(rule ext)
  apply(case_tac x) by(auto simp add: sum.case_eq_if)

lemma connoc: "con o noc = id"
  apply(rule ext)
  apply(case_tac x) by(auto simp add: sum.case_eq_if)

lemma obligation1': assumes "map_pmf con s = Sum_pmf (8 / 10) Da Db"
    shows "config'_rand (COMB h) s qs =
    map_pmf noc (Sum_pmf (8 / 10) (config'_rand BIT Da qs)
                     (config'_rand (embed (rTS h)) Db qs))"
proof (induct qs rule: rev_induct)
  case Nil
  have "s = map_pmf noc (map_pmf con s)"
    by(simp add: pmf.map_comp noccon)
also
  from assms have "\<dots> = map_pmf noc (Sum_pmf (8 / 10) Da Db)"
    by simp
finally
  show ?case by simp
next
  case (snoc q qs)
  show ?case apply(simp)
    apply(subst config'_rand_append)
    apply(subst snoc)
    apply(simp)
      unfolding Sum_pmf_def
      apply(simp add:
          bind_assoc_pmf bind_return_pmf COMB_def COMB_step_def)
      apply(subst config'_rand_append)
      apply(subst config'_rand_append)
      apply(simp only: map_pmf_def[where f=noc])
        apply(simp add: bind_return_pmf bind_assoc_pmf)
        apply(rule bind_pmf_cong)
          apply(simp)
         apply(simp only: set_pmf_bernoulli UNIV_bool)
          apply(auto)
            apply(simp only: map_pmf_def[where f=Inl])
            apply(simp add: bind_return_pmf bind_assoc_pmf)
            apply(rule bind_pmf_cong)
            apply(simp add: bind_return_pmf bind_assoc_pmf )
            apply(simp add:  split_def)
            apply(simp add: bind_return_pmf bind_assoc_pmf map_pmf_def)
          apply(simp only: map_pmf_def[where f=Inr])
          apply(simp add: bind_return_pmf bind_assoc_pmf)
          apply(rule bind_pmf_cong)
          apply(simp add: bind_return_pmf bind_assoc_pmf )
          apply(simp add:  split_def)
          apply(simp add: bind_return_pmf bind_assoc_pmf map_pmf_def rTS_def)
  done
qed

lemma obligation1'':
    shows "config_rand (COMB h) init qs =
    map_pmf noc (Sum_pmf (8 / 10) (config_rand BIT init qs)
                     (config_rand (embed (rTS h)) init qs))"
apply(rule obligation1')
  apply(simp add: Sum_pmf_def COMB_def map_pmf_def bind_assoc_pmf bind_return_pmf split_def COMB_init_def del: COMB_init)
  apply(rule bind_pmf_cong)
    by(auto simp add: split_def map_pmf_def bind_return_pmf bind_assoc_pmf)

lemma obligation1: assumes "map_pmf con s = Sum_pmf (8 / 10) Da Db"
    shows "map_pmf con (config'_rand (COMB []) s qs) =
    Sum_pmf (8 / 10) (config'_rand BIT Da qs)
                     (config'_rand (embed (rTS [])) Db qs)"
proof -
  from obligation1'[OF assms] have "map_pmf con (config'_rand (COMB []) s qs)
      = map_pmf con (map_pmf noc (Sum_pmf (8 / 10) (config'_rand BIT Da qs)
                     (config'_rand (embed (rTS [])) Db qs)))"
                by simp
also
  have "\<dots> = Sum_pmf (8 / 10) (config'_rand BIT Da qs)
                     (config'_rand (embed (rTS [])) Db qs)"
   apply(simp only: pmf.map_comp connoc) by simp
finally
  show ?thesis .
qed

lemma BIT_config'_fin: "finite (set_pmf s) \<Longrightarrow> finite (set_pmf (config'_rand BIT s qs))"
apply(induct qs rule: rev_induct)
  apply(simp)
  by(simp add: config'_rand_append BIT_step_def)

lemma TS_config'_fin: "finite (set_pmf s) \<Longrightarrow> finite (set_pmf (config'_rand (embed (rTS h)) s qs))"
apply(induct qs rule: rev_induct)
  apply(simp)
  by(simp add: config'_rand_append rTS_def TS_step_d_def)

lemma obligation2: assumes "map_pmf con s = Sum_pmf (8 / 10) Da Db"
    and "finite (set_pmf Da)"
    and "finite (set_pmf Db)"
  shows "T\<^sub>p_on_rand' (COMB []) s qs =
    2 / 10 * T\<^sub>p_on_rand' (embed (rTS [])) Db qs +
    8 / 10 * T\<^sub>p_on_rand' BIT Da qs"
proof (induct qs rule: rev_induct)
  case (snoc q qs)
  have P: "T\<^sub>p_on_rand' (COMB []) (config'_rand (COMB []) s qs) [q]
      = 2 / 10 * T\<^sub>p_on_rand' (embed (rTS [])) (config'_rand (embed (rTS [])) Db qs) [q] +
          8 / 10 * T\<^sub>p_on_rand' BIT (config'_rand BIT Da qs) [q]"
    apply(subst obligation1'[OF assms(1)])
    unfolding Sum_pmf_def
      apply(simp)
      apply(simp only: map_pmf_def[where f=noc])
      apply(simp add: bind_assoc_pmf )
        apply(subst E_bernoulli3)
          apply(simp) apply(simp)
          apply(simp add: set_pmf_bernoulli)
          apply(simp add: BIT_step_def COMB_def COMB_step_def split_def)
          apply(safe)
            using BIT_config'_fin[OF assms(2)] apply(simp)
            using TS_config'_fin[OF assms(3)] apply(simp)
          apply(simp)
      apply(simp only: map_pmf_def[where f=Inl])
      apply(simp only: map_pmf_def[where f=Inr])
        apply(simp add: bind_return_pmf bind_assoc_pmf COMB_def COMB_step_def)
        apply(simp add: split_def)
        apply(simp add: rTS_def map_pmf_def bind_return_pmf bind_assoc_pmf COMB_def COMB_step_def)

    done

  show ?case
    apply(simp only: T_on_rand'_append)
    apply(subst snoc)
    apply(subst P) by algebra

qed simp

lemma Combination:
  fixes bit
  assumes "qs \<in> pattern" "a \<noteq> b" "{a, b} = {x, y}" "set qs \<subseteq> {a, b}"
    and "inv_COMB s a [x,y]"
    and TS: "\<And>s h. a \<noteq> b \<Longrightarrow> {a, b} = {x, y} \<Longrightarrow> TS_inv s a [x, y] \<Longrightarrow> set qs \<subseteq> {a, b}
      \<Longrightarrow> qs \<in> pattern \<Longrightarrow>
            TS_inv (config'_rand (embed (rTS h)) s qs) (last qs) [x, y]
          \<and> T\<^sub>p_on_rand' (embed (rTS h)) s qs = ts"
    and BIT: "\<And>s. a \<noteq> b \<Longrightarrow> {a, b} = {x, y} \<Longrightarrow> BIT_inv s a [x, y] \<Longrightarrow> set qs \<subseteq> {a, b}
      \<Longrightarrow> qs \<in> pattern \<Longrightarrow>
            BIT_inv (config'_rand BIT s qs) (last qs) [x, y]
          \<and> T\<^sub>p_on_rand' BIT s qs = bit"
    and OPT_cost: "a \<noteq> b \<Longrightarrow> qs \<in> pattern \<Longrightarrow> real (T\<^sub>p [a, b] qs (OPT2 qs [a, b])) = opt"
    and absch: "qs \<in> pattern \<Longrightarrow> 0.2 * ts + 0.8 * bit \<le> 1.6 * opt"
  shows "T\<^sub>p_on_rand' (COMB []) s qs \<le> 16 / 10 * real (T\<^sub>p [a, b] qs (OPT2 qs [a, b])) \<and>
    inv_COMB (Partial_Cost_Model.config'_rand (COMB []) s qs) (last qs) [x, y]"
proof -
  let ?D = "map_pmf con s"
  from assms(5) obtain Da Db where Daf: "finite (set_pmf Da)"
      and Dbf: "finite (set_pmf Db)"
      and D: "?D = Sum_pmf 0.8 Da Db"
             and B: "BIT_inv Da a [x,y]" and T: "TS_inv Db a [x,y]"
    unfolding inv_COMB_def by auto

  let ?Da' = "config'_rand BIT Da qs"
  from BIT[OF assms(2,3) B assms(4,1) ]
    have B': "BIT_inv ?Da' (last qs) [x, y]"
    and B_cost: "T\<^sub>p_on_rand' BIT Da qs = bit" by auto

  let ?Db' = "config'_rand (embed (rTS [])) Db qs"
  (* ähnlich *)
  from TS[OF assms(2,3) T assms(4,1)]
    have T': "TS_inv ?Db' (last qs) [x, y]"
    and T_cost: "T\<^sub>p_on_rand' (embed (rTS [])) Db qs = ts" by auto

  have "T\<^sub>p_on_rand' (COMB []) s qs
        = 0.2 * T\<^sub>p_on_rand' (embed (rTS [])) Db qs
            + 0.8 * T\<^sub>p_on_rand' BIT Da qs"
         using D apply(rule obligation2) apply(fact Daf) apply(fact Dbf) done
also
  have "\<dots>  \<le> 1.6 * opt"
    by (simp only: B_cost T_cost absch[OF assms(1)])
also
  have "\<dots> = 1.6 * T\<^sub>p [a, b] qs (OPT2 qs [a, b])" by (simp add: OPT_cost[OF assms(2,1)])
finally
  have Comb_cost: "T\<^sub>p_on_rand' (COMB []) s qs \<le> 1.6 * T\<^sub>p [a, b] qs (OPT2 qs [a, b])" .

  have Comb_inv: "inv_COMB (config'_rand (COMB []) s qs) (last qs) [x, y]"
      unfolding inv_COMB_def
      apply(rule exI[where x="?Da'"])
      apply(rule exI[where x="?Db'"])
        apply(safe)
          apply(rule BIT_config'_fin[OF Daf])
          apply(rule TS_config'_fin[OF Dbf])
          apply(rule obligation1)
          apply(fact D)
          apply(fact B')
          apply(fact T') done

  from Comb_cost Comb_inv show ?thesis by simp
qed

theorem COMB_OPT2':  "(x::nat) \<noteq> y \<Longrightarrow> set \<sigma> \<subseteq> {x,y}
     \<Longrightarrow> T\<^sub>p_on_rand (COMB []) [x,y] \<sigma>  \<le> 1.6 * real (T\<^sub>p_opt [x,y] \<sigma>) + 1.6"
proof (rule Phase_partitioning_general[where P="inv_COMB"], goal_cases)
  case 4
  let ?initBIT ="(map_pmf (Pair [x, y]) (fst BIT [x, y]))"
  let ?initTS ="(map_pmf (Pair [x, y]) (fst (embed (rTS [])) [x, y]))"
  show  "inv_COMB (map_pmf (Pair [x, y]) (fst (COMB []) [x, y])) x [x, y]"
    unfolding inv_COMB_def
    apply(rule exI[where x="?initBIT"])
    apply(rule exI[where x="?initTS"])
      apply(simp only: BIT_inv_initial[OF 4(1)] )
      apply(simp add: map_pmf_def bind_return_pmf bind_assoc_pmf COMB_def)
      apply(simp add: Sum_pmf_def)
     apply(safe)
         apply(simp add: BIT_init_def)
        apply(rule bind_pmf_cong)
          apply(simp)
          apply(simp add: bind_return_pmf bind_assoc_pmf rTS_def map_pmf_def BIT_init_def)
       apply(simp add: TS_inv_def rTS_def)
      done
next
  case (5 a b qs s)
  from 5(3)
  show ?case
    proof (rule LxxE, goal_cases)
      case 4
      then show ?thesis apply(rule Combination)
        apply(fact)+
        using TS_a'' apply(simp)
        apply(fact bit_a'')
        apply(fact OPT2_A')
        apply(simp)
      done
    next
      case 1
      then show ?case
        apply(rule Combination)
        apply(fact)+
        apply(fact TS_d'')
        apply(fact bit_d')
        by auto
    next
      case 2
      then have "qs \<in> lang (seq [Atom b, Atom a, Star (Times (Atom b) (Atom a)), Atom b, Atom b])
              \<or> qs \<in> lang (seq [Atom a, Atom b, Atom a, Star (Times (Atom b) (Atom a)), Atom b, Atom b])" by auto
      then show ?case
        apply(rule disjE)
          apply(erule Combination)
            apply(fact)+
            apply(fact TS_b1'')
            apply(fact bit_b''1)
            apply(fact OPT2_B1)
            apply(simp add: ring_distribs)
         apply(erule Combination)
           apply(fact)+
           apply(fact TS_b2'')
           apply(fact bit_b''2)
           apply(fact OPT2_B2)
           apply(simp add: ring_distribs)
        done
    next
      case 3
      then have len: "length qs \<ge> 2" by(auto simp add: conc_def)
      have len2: "qs \<in> lang (seq [Atom a, Atom b, Atom a, Star (Times (Atom b) (Atom a)), Atom a])
                  \<Longrightarrow> length qs \<ge> 3" by (auto simp add: conc_def)
      from 3 have "qs \<in> lang (seq [Atom b, Atom a, Star (Times (Atom b) (Atom a)), Atom a])
              \<or> qs \<in> lang (seq [Atom a, Atom b, Atom a, Star (Times (Atom b) (Atom a)), Atom a])" by auto
      then show ?case
        apply(rule disjE)
          apply(erule Combination)
            apply(fact)+
            apply(fact TS_c1'')
            apply(fact bit_c''1)
            apply(fact OPT2_C1)
            using len apply(simp add: ring_distribs)
         apply(erule Combination)
           apply(fact)+
           apply(fact TS_c2'')
           apply(fact bit_c''2)
           apply(fact OPT2_C2)
           using len2 apply(simp add: ring_distribs conc_def)
        done
    qed
qed (simp_all)

subsection "COMB pairwise"

lemma config_rand_COMB: "config_rand (COMB h) init qs = do {
                    (b::bool) \<leftarrow> (bernoulli_pmf 0.8);
                    (b1,b2) \<leftarrow>  (config_rand BIT init qs);
                    (t1,t2) \<leftarrow>  (config_rand (embed (rTS h)) init qs);
                    return_pmf (if b then  (b1, Inl b2) else (t1, Inr t2))
                    }" (is "?LHS = ?RHS")
proof (induct qs rule: rev_induct)
  case Nil
  show ?case
  apply(simp add: BIT_init_def COMB_def rTS_def map_pmf_def bind_return_pmf bind_assoc_pmf )
  apply(rule bind_pmf_cong)
    apply(simp)
    apply(simp only: set_pmf_bernoulli)
      apply(case_tac x)
        by(simp_all)
next
  case (snoc q qs)
  show ?case apply(simp add: take_Suc_conv_app_nth)
    apply(subst config'_rand_append)
    apply(subst snoc)
      apply(simp)
      apply(simp add: bind_return_pmf bind_assoc_pmf split_def config'_rand_append)
        apply(rule bind_pmf_cong)
          apply(simp)
          apply(simp only: set_pmf_bernoulli)
            apply(case_tac x)
               by(simp_all add: COMB_def COMB_step_def rTS_def map_pmf_def split_def bind_return_pmf bind_assoc_pmf)
qed

lemma COMB_no_paid: " \<forall>((free, paid), t)\<in>set_pmf (snd (COMB []) (s, is) q). paid = []"
apply(simp add:  COMB_def COMB_step_def split_def BIT_step_def TS_step_d_def)
apply(case_tac "is")
  by(simp_all add: BIT_step_def TS_step_d_def)

lemma COMB_pairwise: "pairwise (COMB [])"
proof(rule pairwise_property_lemma, goal_cases)
  case (1 init qs x y)
  then have qsininit: "set qs \<subseteq> set init" by simp

  show "Pbefore_in x y (COMB []) qs init
        = Pbefore_in x y (COMB []) (Lxy qs {x, y}) (Lxy init {x, y})"
        unfolding Pbefore_in_def
        apply(subst config_rand_COMB)
        apply(subst config_rand_COMB)
        apply(simp only: map_pmf_def  bind_assoc_pmf)
        apply(rule bind_pmf_cong)
          apply(simp)
          apply(simp only: set_pmf_bernoulli)
          apply(case_tac xa)
            apply(simp add: split_def)
              using BIT_pairwise'[OF qsininit 1(3,4,1), unfolded Pbefore_in_def map_pmf_def]
              apply(simp add: bind_return_pmf bind_assoc_pmf)
            apply(simp add: split_def)
              using TS_pairwise'[OF 1(2,3,4,1), unfolded Pbefore_in_def map_pmf_def]
              by(simp add: bind_return_pmf bind_assoc_pmf)
next
  case (2 xa r)
  show ?case
    using COMB_no_paid
    by (metis (mono_tags) case_prod_unfold surj_pair)
qed

subsection "COMB 1.6-competitive"

lemma finite_config_TS: "finite (set_pmf (config'' (embed (rTS h)) qs init n))" (is "finite ?D")
  apply(subst config_embed)
    by(simp)

lemma COMB_has_finite_config_set: assumes [simp]: "distinct init"
      and "set qs \<subseteq> set init"
      shows "finite (set_pmf (config_rand (COMB h) init qs))"
proof -
  from finite_config_TS[where n="length qs" and qs=qs]
      finite_config_BIT[OF assms(1)]
  show ?thesis
    apply(subst obligation1'')
      by(simp add: Sum_pmf_def)
qed

theorem COMB_competitive: "\<forall>s0\<in>{x::nat list. distinct x \<and> x\<noteq>[]}.
   \<exists>b\<ge>0. \<forall>qs\<in>{x. set x \<subseteq> set s0}.
             T\<^sub>p_on_rand (COMB []) s0 qs \<le> ((8::nat)/(5::nat)) *  T\<^sub>p_opt s0 qs + b"
proof(rule factoringlemma_withconstant, goal_cases)
  case 5
  show ?case
    proof (safe, goal_cases)
      case (1 init)
      note out=this
      show ?case
        apply(rule exI[where x=2])
          apply(simp)
          proof (safe, goal_cases)
            case (1 qs a b)
            then have a: "a\<noteq>b" by simp
            have twist: "{a,b}={b, a}" by auto
            have b1: "set (Lxy qs {a, b}) \<subseteq> {a, b}" unfolding Lxy_def by auto
            with this[unfolded twist] have b2: "set (Lxy qs {b, a}) \<subseteq> {b, a}" by(auto)

            have "set (Lxy init {a, b}) = {a,b} \<inter> (set init)" apply(induct init)
                unfolding Lxy_def by(auto)
            with 1 have A: "set (Lxy init {a, b}) = {a,b}" by auto
            have "finite {a,b}" by auto
            from out have B: "distinct (Lxy init {a, b})" unfolding Lxy_def by auto
            have C: "length (Lxy init {a, b}) = 2"
              using distinct_card[OF B, unfolded A] using a by auto

            have "{xs. set xs = {a,b} \<and> distinct xs \<and> length xs =(2::nat)}
                    = { [a,b], [b,a] }"
                  apply(auto simp: a a[symmetric])
                  proof (goal_cases)
                    case (1 xs)
                    from 1(4) obtain x xs' where r:"xs=x#xs'" by (metis Suc_length_conv add_2_eq_Suc' append_Nil length_append)
                    with 1(4) have "length xs' = 1" by auto
                    then obtain y where s: "[y] = xs'" by (metis One_nat_def length_0_conv length_Suc_conv)
                    from r s have t: "[x,y] = xs" by auto
                    moreover from t 1(1) have "x=b" using doubleton_eq_iff 1(2) by fastforce
                    moreover from t 1(1) have "y=a" using doubleton_eq_iff 1(2) by fastforce
                    ultimately show ?case by auto
                  qed

            with A B C have pos: "(Lxy init {a, b}) = [a,b]
                  \<or> (Lxy init {a, b}) = [b,a]" by auto

            show ?case
              apply(cases "(Lxy init {a, b}) = [a,b]")
                apply(simp) using COMB_OPT2'[OF a b1] a apply(simp)
                using pos apply(simp) unfolding twist
              using COMB_OPT2'[OF a[symmetric] b2] by simp
          qed
    qed
next
  case 4  then show ?case using COMB_pairwise by simp
next
  case 7 then show ?case apply(subst COMB_has_finite_config_set[OF 7(1)])
        using set_take_subset apply fast by simp
qed (simp_all add: COMB_no_paid)

theorem COMB_competitive_nice: "compet_rand (COMB []) ((8::nat)/(5::nat)) {x::nat list. distinct x \<and> x\<noteq>[]}"
  unfolding compet_rand_def static_def using COMB_competitive by simp

end