Require Import ssreflect ssrbool ssrfun ssrnat eqtype seq rels.
Require Import ClassicalFacts Eqdep.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits. 

Set Automatic Coercions Import.

(**************************************************************************)
(* Programs will be modeled as predicate transformers (i.e. functions     *)
(* from predicates to predicates).                                        *)
(*                                                                        *)
(* Since we build a bit of domain theory over programs, it is important   *)
(* to consider two programs equal iff they transform equal predicates     *)
(* into equal predicates. This is necessary so that higher-order          *)
(* functions over programs cannot make unwanted distinctions.             *)
(*                                                                        *)
(* The most expedient way to achieve this indistinguishability is to      *)
(* assume propositional and functional extensionality. Other ways are     *)
(* possible too. For example, we could define our own custom equivalence  *)
(* relation over programs, and build domain theory using this relation as *)
(* equality (instead of the usual Leibniz equality). But this is          *)
(* cumbersome, so we resort to assuming the two mentioned axioms.         *)
(*                                                                        *)
(* We will use these axioms sparsely, and only for building the model     *)
(* (that is, only in this file). In future work, a more powerful          *)
(* domain-theoretic model will be built on paper, following Petersen &    *)
(* Birkedal. This will make the mentioned use of axioms obsolete.         *)
(**************************************************************************)

Axiom pext : forall p1 p2 : Prop, (p1 <-> p2) -> p1 = p2.
Axiom fext : forall A (B : A -> Type) (f1 f2 : forall x, B x), 
               (forall x, f1 x = f2 x) -> f1 = f2.

Lemma proof_irrelevance (P : Prop) (p1 p2 : P) : p1 = p2.
Proof. by apply: ext_prop_dep_proof_irrel_cic; apply: pext. Qed.

Lemma eta A (B : A -> Type) (f : forall x, B x) : f = [eta f].
Proof. by apply: fext. Qed.   

Lemma ext A (B : A -> Type) (f1 f2 : forall x, B x) : 
        f1 = f2 -> forall x, f1 x = f2 x.
Proof. by move=>->. Qed.

Lemma inj_sval A P : injective (@sval A P).
Proof.
move=>[x Hx][y Hy] /= H; move: Hx Hy; rewrite H=>*. 
congr exist; apply: proof_irrelevance.
Qed.

Lemma svalE A (P : A -> Prop) x H : sval (exist P x H) = x.
Proof. by []. Qed.

(**********)
(* Posets *)
(**********)

(* We only work with posets that have bottoms and all sups. *)
(* Technically, these are complete lattices. *)
(* But I call them posets here, for short *)

Definition non_empty T (s : Pred T) := exists d, d \In s. 

Module Poset.

Structure mixin_of (T : Type) := Mixin {
  leq : T -> T -> Prop;
  bot : T;
  sup : Pred T -> T;
  _ : forall x, leq x x; 
  _ : forall x y, leq x y -> leq y x -> x = y; 
  _ : forall x y z, leq x y -> leq y z -> leq x z; 
  _ : forall x, leq bot x;
  _ : forall (s : Pred T) x, x \In s -> leq x (sup s);
  _ : forall (s : Pred T) x, 
        (forall y, y \In s -> leq y x) -> leq (sup s) x}.

Notation class_of := mixin_of (only parsing). 
Structure type : Type := Pack {sort :> Type; _ : class_of sort; _ : Type}.
Definition class cT := let: Pack _ c _ := cT return class_of cT in c.
Definition unpack K (k : forall T (c : class_of T), K T c) cT :=
  let: Pack T c _ := cT return K _ (class cT) in k _ c.
Definition repack cT : _ -> Type -> type := let k T c p := p c in unpack k cT.
Definition pack T c := @Pack T c T.

End Poset.

Notation poset := Poset.type.
Notation PosetMixin := Poset.Mixin.
Notation Poset := Poset.pack.

Definition poset_leq T := Poset.leq (Poset.class T).

Notation "x <== y" := (poset_leq x y) (at level 70).

Definition pbot T := Poset.bot (Poset.class T).
Definition psup T := Poset.sup (Poset.class T).

Implicit Arguments pbot [T].
Implicit Arguments psup [T].

Prenex Implicits pbot psup.

(* re-state poset definitions and properties using the notation *)
Section PosetProperties.
Variable T : poset.

Lemma leq_refl (x : T) : x <== x.
Proof. by case: T x=>X [l] b s H1 *; apply: H1. Qed.

Lemma leq_asym (x y : T) : x <== y -> y <== x -> x = y.
Proof. by case: T x y=>X [l] b s H1 H2 *; apply: (H2). Qed.

Lemma leq_trans (y x z : T) : x <== y -> y <== z -> x <== z.
Proof. by case: T y x z=>X [l] b s H1 H2 H3 H4 H5 H6 R y x z; apply: (H3). Qed.

Lemma pbotM (x : T) : pbot <== x.
Proof. by case: T x=>X [l] b s H1 H2 H3 H4 *; apply: H4. Qed.

Lemma psupP (s : Pred T) x : x \In s -> x <== psup s.
Proof. by case: T s x=>X [l] b s H1 H2 H3 H4 H5 *; apply: (H5). Qed.

Lemma psupM (s : Pred T) x : (forall y, y \In s -> y <== x) -> psup s <== x.
Proof. by case: T s x=>X [l] b s H1 H2 H3 H4 H5 H6 *; apply: (H6). Qed.

Definition pchain (s : Pred T) := 
  non_empty s /\ forall x y, x \In s -> y \In s -> x <== y \/ y <== x.

Lemma psup_leq (s1 s2 : Pred T) : s1 <=p s2 -> psup s1 <== psup s2.
Proof. by move=>H; apply: psupM=>y; move/H; apply: psupP. Qed.

Lemma psup_eq (s1 s2 : Pred T) : s1 =p s2 -> psup s1 = psup s2.
Proof. by move=>H; apply: leq_asym; apply: psupM=>y; move/H; apply: psupP. Qed.

End PosetProperties.

Hint Resolve leq_refl pbotM. 

Add Parametric Relation (T : poset) : T (@poset_leq T) 
  reflexivity proved by (@leq_refl _) 
  transitivity proved by (fun x y => @leq_trans _ y x) as poset_leq_rel.

(* Some facts about complete lattices *)
Section CompleteLatticeFacts.
Variables (T : poset).

(* we have greatest lower bounds too *)
Definition pinf (s : Pred T) := 
  psup [Pred x : T | forall y, y \In s -> x <== y].

Lemma pinfP s : forall x, x \In s -> pinf s <== x.
Proof. by move=>x H; apply: psupM=>y; apply. Qed.

Lemma pinfM s : forall x, (forall y, y \In s -> x <== y) -> x <== pinf s.
Proof. by apply: psupP. Qed.

(* we can compute least and greatest fixed points *)

Definition pmonotone (f : T -> T) := 
  forall x y, x <== y -> f x <== f y.

Definition plfp (f : T -> T) := pinf [Pred x : T | f x <== x].
Definition pgfp (f : T -> T) := psup [Pred x : T | x <== f x].

(* Knaster-Tarski *) 
Lemma plfp_fixed f : pmonotone f -> f (plfp f) = plfp f.
Proof.
move=>M; suff L: f (plfp f) <== plfp f.
- by apply: leq_asym=>//; apply: pinfP; apply: M L.
by apply: pinfM=>x L; apply: leq_trans (L); apply: M; apply: pinfP.
Qed. 

Lemma plfp_least f : forall x : T, f x = x -> plfp f <== x.
Proof. by move=>x H; apply: pinfP; rewrite InE /= H. Qed.

Lemma pgfp_fixed f : pmonotone f -> f (pgfp f) = pgfp f.
Proof.
move=>M; suff L: pgfp f <== f (pgfp f).
- by apply: leq_asym=>//; apply: psupP; apply: M L.
by apply: psupM=>x L; apply: leq_trans (L) _; apply: M; apply: psupP.
Qed.

Lemma pgfp_greatest f : forall x : T, f x = x -> x <== pgfp f.
Proof. by move=>x H; apply: psupP; rewrite InE /= H. Qed.

End CompleteLatticeFacts.

Section PosetClosure.
Variable T : poset.
 
Definition pclosed := 
  [Pred s : Pred T | 
     pbot \In s /\ forall d, d <=p s -> psup d \In s].

(* admissible closure of s is the smallest closed set containing s *)
(* basically extends s to include the sups of chains *)
Definition pclosure (s : Pred T) := 
  [Pred p : T | forall t : Pred T, s <=p t -> pclosed t -> p \In t].

(* admissible closure contains s *)
Lemma pclos_sub (s : Pred T) : s <=p pclosure s.
Proof. by move=>p H1 t H2 H3; apply: H2 H1. Qed.

(* admissible closure is smallest *)
Lemma pclos_min (s : Pred T) : 
        forall t, s <=p t -> pclosed t -> pclosure s <=p t.
Proof. by move=>t H1 H2 p; move/(_ _ H1 H2). Qed.

(* admissible closure is closed *)
Lemma pclosP (s : Pred T) : pclosed (pclosure s).
Proof.
split; first by move=>t _ [].
move=>d H1 t H3 H4; move: (pclos_min H3 H4)=>{H3} H3.
by case: H4=>_; apply=>// x; move/H1; move/H3.
Qed.

Lemma pclos_idemp (s : Pred T) : pclosed s -> pclosure s =p s.
Proof.
move=>p; split; last by apply: pclos_sub.
by apply: pclos_min=>//; apply: closP.
Qed.

Lemma pclos_mono (s1 s2 : Pred T) : 
        s1 <=p s2 -> pclosure s1 <=p pclosure s2.
Proof.
move=>H1; apply: pclos_min (pclosP s2)=>p H2.
by apply: pclos_sub; apply: H1.
Qed.

End PosetClosure.

Implicit Arguments pclosed [T].

(* closed subsets of posets are posets *)
Section SubPoset. 
Variables (T : poset) (s : Pred T) (C : pclosed s).

Structure Tp := pbundle {tpval : T; _ : tpval \In s}.

Lemma tpval_inj : injective tpval.
Proof. 
case=>t1 H1 [t2 H2] /= E.
by rewrite -{t2}E in H2 *; rewrite (proof_irrelevance H1 H2).
Qed.

Let sleq (p1 p2 : Tp) := tpval p1 <== tpval p2.

Lemma sbotP : pbot \In s.
Proof. by case: C. Qed.

Let sbot : Tp := @pbundle pbot sbotP.

Let ssup' (u : Pred Tp) : T := 
      psup [Pred x : T | exists y, y \In u /\ x = tpval y]. 

Lemma ssupP (u : Pred Tp) : ssup' u \In s.
Proof. by case: C u=>_ H u; apply: H=>t [[y]] H1 [_] ->. Qed.

Let ssup (u : Pred Tp) : Tp := @pbundle (ssup' u) (ssupP u).

Lemma sub_refl x : sleq x x.
Proof. by case: x=>H /=; rewrite /sleq. Qed.

Lemma sub_asym x y : sleq x y -> sleq y x -> x = y.
Proof.
move: x y=>[x Hx][y Hy]; rewrite /sleq /= => H1 H2.
move: (leq_asym H1 H2) Hy=> <- Hy; congr pbundle.
by apply: proof_irrelevance.
Qed.

Lemma sub_trans x y z : sleq x y -> sleq y z -> sleq x z.
Proof. 
move: x y z=>[x Hx][y Hy][z Hz]; rewrite /sleq /=.
by apply: leq_trans.
Qed.

Lemma sub_botM x : sleq sbot x.
Proof. by move: x=>[x Hx]; rewrite /sleq /=. Qed.

Lemma sub_supP (u : Pred Tp) (x : Tp) : x \In u -> sleq x (ssup u).
Proof. by move=>H; apply: psupP; exists x. Qed.

Lemma sub_supM (u : Pred Tp) (x : Tp) :
        (forall y, y \In u -> sleq y x) -> sleq (ssup u) x.
Proof. by move=>H; apply: psupM=>y [z][H1] ->; apply: H H1. Qed.

Definition subPosetMixin := 
  PosetMixin sub_refl sub_asym sub_trans sub_botM sub_supP sub_supM.
Canonical Structure subPoset := Poset subPosetMixin.

End SubPoset.

(* pairs are posets *)
Section PosetPair. 
Variable (A B : poset). 
Notation tp := (A * B)%type. 

Let pleq (p1 p2 : tp) := p1.1 <== p2.1 /\ p1.2 <== p2.2.
Let pbot : tp := (pbot, pbot). 
Let psup (s : Pred tp) : tp := 
      (psup [Pred p | exists f, p = f.1 /\ f \In s], 
       psup [Pred p | exists f, p = f.2 /\ f \In s]).
    
Lemma pair_refl x : pleq x x.
Proof. by []. Qed.

Lemma pair_asym x y : pleq x y -> pleq y x -> x = y.
Proof.
move: x y=>[x1 x2][y1 y2][/= H1 H2][/= H3 H4].
by congr (_, _); apply: leq_asym.
Qed.

Lemma pair_trans x y z : pleq x y -> pleq y z -> pleq x z.
Proof. 
move: x y z=>[x1 x2][y1 y2][z1 z2][/= H1 H2][/= H3 H4]; split=>/=.
- by apply: leq_trans H3.
by apply: leq_trans H4.
Qed.

Lemma pair_botM x : pleq pbot x.
Proof. by move: x=>[x1 x2]; split; apply: pbotM. Qed.

Lemma pair_supP (s : Pred tp) (p : tp) : p \In s -> pleq p (psup s).
Proof. by move=>H; split; apply: psupP; exists p. Qed.

Lemma pair_supM (s : Pred tp) (p : tp) :
        (forall q: tp, q \In s -> pleq q p) -> pleq (psup s) p.
Proof. by move=>H; split; apply: psupM=>y [f][->]; case/H. Qed.

Definition pairPosetMixin := 
  PosetMixin pair_refl pair_asym pair_trans pair_botM pair_supP pair_supM.
Canonical Structure pairPoset := Poset pairPosetMixin.

End PosetPair. 

(*******************)
(* Parametrization *)
(*******************)

(* functions into a poset form a poset *)

Section PosetParam. 
Variable (A : Type) (B : poset).
Notation tp := (A -> B). 

Let pleq (p1 p2 : tp) := forall x, p1 x <== p2 x.
Let pbot : tp := fun x => pbot.
Let psup (s : Pred tp) : tp := 
      fun x => psup [Pred p | exists f, f \In s /\ p = f x].
    
Lemma fun_refl x : pleq x x.
Proof. by []. Qed. 

Lemma fun_asym x y : pleq x y -> pleq y x -> x = y.
Proof. 
by move=>H1 H2; apply: fext=>z; apply: leq_asym; [apply: H1 | apply: H2]. 
Qed.

Lemma fun_trans x y z : pleq x y -> pleq y z -> pleq x z.
Proof. by move=>H1 H2 t; apply: leq_trans (H2 t). Qed.

Lemma fun_botM x : pleq pbot x.
Proof. by move=>t; apply: pbotM. Qed.

Lemma fun_supP (s : Pred tp) (p : tp) : p \In s -> pleq p (psup s).
Proof. by move=>H x; apply: psupP; exists p. Qed.

Lemma fun_supM (s : Pred tp) (p : tp) :
        (forall q: tp, q \In s -> pleq q p) -> pleq (psup s) p.
Proof. by move=>H t; apply: psupM=>x [f][H1] ->; apply: H. Qed.

Definition paramPosetMixin := 
  PosetMixin fun_refl fun_asym fun_trans fun_botM fun_supP fun_supM.
Canonical Structure paramPoset := Poset paramPosetMixin.

End PosetParam.

(* psup applied equals to the psup of applications *)

Lemma psup_app A B (s : Pred (paramPoset A B)) (x : A) : 
        psup s x = psup [Pred y : B | exists f, f \In s /\ y = f x].
Proof. by []. Qed.

(* dependent functions into a poset form a poset *)

Section PosetDepParam.
Variables (A : Type) (B : A -> poset).
Notation tp := (forall x, B x).
 
Let pleq (p1 p2 : tp) := forall x, p1 x <== p2 x.
Let pbot : tp := fun x => pbot.
Let psup (s : Pred tp) : tp := 
      fun x => psup [Pred p | exists f, f \In s /\ p = f x].
    
Lemma dfun_refl x : pleq x x.
Proof. by []. Qed.

Lemma dfun_asym x y : pleq x y -> pleq y x -> x = y.
Proof.
by move=>H1 H2; apply: fext=>z; apply: leq_asym; [apply: H1 | apply: H2].
Qed.

Lemma dfun_trans x y z : pleq x y -> pleq y z -> pleq x z.
Proof. by move=>H1 H2 t; apply: leq_trans (H2 t). Qed.

Lemma dfun_botM x : pleq pbot x.
Proof. by move=>t; apply: pbotM. Qed.

Lemma dfun_supP (s : Pred tp) (p : tp) : p \In s -> pleq p (psup s).
Proof. by move=>H x; apply: psupP; exists p. Qed.

Lemma dfun_supM (s : Pred tp) (p : tp) :
       (forall q, q \In s -> pleq q p) -> pleq (psup s) p.
Proof. by move=>H t; apply: psupM=>x [f][H1] ->; apply: H. Qed.

Definition dparamPosetMixin := 
  PosetMixin dfun_refl dfun_asym dfun_trans dfun_botM dfun_supP dfun_supM.
Canonical Structure dparamPoset := Poset dparamPosetMixin.

End PosetDepParam.

(* ideal of a poset forms a poset *)

Section IdealPoset.
Variable (T : poset) (P : T). 

Definition ideal := {p : T | p <== P}.

Definition mkideal p : p <== P -> ideal := fun pf => exist _ p pf.
Definition idealpf (id : ideal) : sval id <== P := 
  let: exist p pf := id in pf. 

Let coerce (s : Pred ideal) : Pred T := 
  fun x => exists p : ideal, p \In s /\ sval p = x. 

Let psup' (s : Pred ideal) := psup (coerce s).

Lemma psup_ideal (s : Pred ideal) : psup' s <== P.
Proof. by apply: psupM=>y [[x]] H /= [_] <-. Qed.

Let pleq (p1 p2 : ideal) := sval p1 <== sval p2.
Let pbot : ideal := exist _ pbot (pbotM P).
Let psup (s : Pred ideal) : ideal := exist _ (psup' s) (@psup_ideal s).

Lemma ideal_refl x : pleq x x.
Proof. by case: x=>x H; rewrite /pleq. Qed. 

Lemma ideal_asym x y : pleq x y -> pleq y x -> x = y.
Proof.
move: x y=>[x1 H1][x2 H2]; rewrite /pleq /= => H3 H4; move: H1 H2. 
rewrite (leq_asym H3 H4)=>H1 H2.
by congr exist; apply: proof_irrelevance.
Qed.   

Lemma ideal_trans x y z : pleq x y -> pleq y z -> pleq x z.
Proof. by apply: leq_trans. Qed.

Lemma ideal_botM x : pleq pbot x.
Proof. by apply: pbotM. Qed.

Lemma ideal_supP (s : Pred ideal) (p : ideal) : 
        p \In s -> pleq p (psup s).
Proof. by move=>H; apply: psupP; exists p. Qed. 

Lemma ideal_supM (s : Pred ideal) (p : ideal) : 
        (forall q : ideal, q \In s -> pleq q p) -> pleq (psup s) p.
Proof. by move=>H; apply: psupM=>y [q][H1] <-; apply: H. Qed.

Definition idealPosetMixin := 
  PosetMixin ideal_refl ideal_asym ideal_trans ideal_botM ideal_supP ideal_supM.
Canonical Structure idealPoset := Poset idealPosetMixin.

End IdealPoset.

(* Changing the type of the ideal *)

Lemma relaxP (T : poset) (P1 P2 : T) : 
        P1 <== P2 -> forall p, p <== P1 -> p <== P2.
Proof. by move=>H1 p H2; apply: leq_trans H1. Qed. 

Definition relax (T : poset) (P1 P2 : T) : ideal P1 -> P1 <== P2 -> ideal P2 := 
  fun x pf => let: exist y qf := x in exist _ y (relaxP pf qf).

(* Prop is a poset *)

Section PosetProp.

Let pleq (p1 p2 : Prop) := p1 -> p2. 
Let pbot : Prop := False. 
Let psup (s : Pred Prop) : Prop := exists p, p \In s /\ p. 
    
Lemma prop_refl x : pleq x x.
Proof. by []. Qed.

Lemma prop_asym x y : pleq x y -> pleq y x -> x = y.
Proof. by move=>H1 H2; apply: pext. Qed.

Lemma prop_trans x y z : pleq x y -> pleq y z -> pleq x z.
Proof. by move=>H1 H2; move/H1. Qed.

Lemma prop_botM x : pleq pbot x.
Proof. by []. Qed. 

Lemma prop_supP (s : Pred Prop) (p : Prop) : p \In s -> pleq p (psup s).
Proof. by exists p. Qed.

Lemma prop_supM (s : Pred Prop) (p : Prop) :
        (forall q : Prop, q \In s -> pleq q p) -> pleq (psup s) p.
Proof. by move=>H [r][]; move/H. Qed. 
   
Definition propPosetMixin := 
  PosetMixin prop_refl prop_asym prop_trans prop_botM prop_supP prop_supM.
Canonical Structure propPoset := Poset propPosetMixin.

End PosetProp. 
 
(* Universe of all subsets is a poset *)

Section PosetPred. 
Variable A : Type.

Definition predPosetMixin : Poset.mixin_of (Pred A) := 
  @paramPosetMixin A propPoset.
Canonical Structure predPoset := Poset predPosetMixin.
End PosetPred.

(*********)
(* CPO's *)
(*********)

(* cpo's are modeled as subsets of posets closed under sups of chains *)

Module CPO.
Section CPO.
Variable D : Type.

CoInductive mixin_of : Type := Mixin {
   U : poset;
   inside : Pred U;
   (* D is isomorphic to {x : U | x \In inside} *)
   val : D -> U;
   bundle : forall x, x \In inside -> D; 
   _ : forall x, val x \In inside;
   _ : forall x (p : x \In inside), val (bundle p) = x; 
   _ : forall x (p : val x \In inside), bundle p = x;
   _ : pbot \In inside;
   _ : forall (s : Pred U), pchain s -> s <=p inside -> psup s \In inside}.
End CPO. 

Notation class_of := mixin_of (only parsing). 
Structure type : Type := Pack {sort :> Type; _ : class_of sort; _ : Type}.
Definition class cT := let: Pack _ c _ := cT return class_of cT in c.
Definition unpack K (k : forall T (c : class_of T), K T c) cT :=
  let: Pack T c _ := cT return K _ (class cT) in k _ c.
Definition repack cT : _ -> Type -> type := let k T c p := p c in unpack k cT.
Definition pack T c := @Pack T c T.

End CPO.

Notation cpo := CPO.type.
Notation CPOMixin := CPO.Mixin.
Notation CPO := CPO.pack.

Section Renaming. 
Variable D : cpo.
 
Definition univ := CPO.U (CPO.class D).
Definition inside : Pred univ := @CPO.inside _ (CPO.class D).
Definition val : D -> univ := CPO.val (CPO.class D).
Definition bundle : forall x, x \In inside -> D := @CPO.bundle _ (CPO.class D).

End Renaming. 

Implicit Arguments univ []. 
Implicit Arguments inside [].
Prenex Implicits val bundle. 

(* every CPO element can be viewed as a poset element *)

Definition cpo_to_poset D : CPO.sort D -> Poset.sort (univ D) := val.
Coercion cpo_to_poset : CPO.sort >-> Poset.sort.

(* for some reason, this doesn't extend when we prepend Pred *)
(* so valPred is not inserted as a coercion *)
Definition valPred D : Pred (CPO.sort D) -> Pred (Poset.sort (univ D)) := 
  fun p v => exists d : CPO.sort D, d \In p /\ val d = v.

Section PosetCPO.
Variable D : cpo.
Notation inside := (inside D).

Lemma val_inside x : val x \In inside.
Proof. by case: D x=>X [U] i v r H1 *; apply: H1. Qed.

Lemma val_bundle x (p : x \In inside) : val (bundle p) = x. 
Proof. by case: D x p=>X [U] i v r H1 H2 *; apply: H2. Qed.

Lemma bundle_val x (p : val x \In inside) : bundle p = x.
Proof. by case: D x p=>X [U] i v r H1 H2 H3 *; apply: H3. Qed. 

Lemma val_inj : injective (@val D).
Proof. 
move=>x y; move: (val_inside x) (val_inside y)=>H1 H2 H.
rewrite -(bundle_val H1) -(bundle_val H2); move: H1 H2.
by rewrite H => H1 H2; rewrite (proof_irrelevance H1 H2).
Qed.

Lemma valX (x : D) : val x = x.
Proof. by apply: leq_asym. Qed.

Lemma valE (x y : D) : x = y <-> (val x = val y).
Proof. by split; [move=>->| apply: val_inj]. Qed.

Lemma valP_inside (s : Pred D) : valPred s <=p inside.
Proof. by move=>x [d][H] <-; apply: val_inside. Qed.

End PosetCPO.

(* re-stating the cpo laws, using notation *)
Section CPOLaws.
Variable D : cpo.
Notation U := (univ D).
Notation inside := (inside D).

Lemma bot_inside : pbot \In inside.
Proof. by case: D=>X [U] i v r H1 H2 H3 H4 *; apply: H4. Qed.

Definition bot := bundle bot_inside.
Definition sup (s : Pred D) := psup (valPred s).

Lemma botM (x : U) : bot <== x.
Proof. by rewrite -(valX (bundle _)) val_bundle; apply: pbotM. Qed.  

Definition chain := 
  [Pred s : Pred D | non_empty s /\ 
     forall x y, x \In s -> y \In s -> x <== y \/ y <== x].

Lemma chainE (s : Pred D) : chain s <-> pchain (valPred s).
Proof.
split; case.
- move=>[d H1] H2; split; first by do 2![exists d].
  by move=>x y [x1 [H3 <-]] [y1 [H4 <-]]; apply: H2.
move=>[d H1] H2; split; first by case: H1=>d1 [H1] _; exists d1.
by move=>x y H3 H4; apply: H2; [exists x | exists y].
Qed.

Lemma psup_inside (s : Pred U) : pchain s -> s <=p inside -> psup s \In inside.
Proof. by case: D s=>X [U] i v r H1 H2 H3 H4 H5 *; apply: (H5). Qed.

Lemma sup_inside (s : Pred D) : chain s -> sup s \In inside.
Proof. 
by move=>H; apply: psup_inside; [apply/chainE | apply: valP_inside]. 
Qed.

Definition supch (s : Pred D) : chain s -> D := fun p => bundle (sup_inside p).

Lemma val_supch (s : Pred D) (p : chain s) : supch p = sup s :> U.
Proof. by rewrite -(valX (bundle _)) val_bundle. Qed.

Lemma supP (s : Pred D) x : x \In s -> x <== sup s.
Proof. by move=>H; apply: psupP; exists x. Qed.

Lemma supM (s : Pred D) x : (forall y, y \In s -> y <== x) -> sup s <== x.
Proof. by move=>H; apply: psupM=>y [d][H1] <-; apply: H. Qed.

End CPOLaws.

Implicit Arguments bot [D].
Implicit Arguments chain [D].
 
Prenex Implicits bot chain.

Hint Resolve botM.
 
Section ChainProperties.
Variable D : cpo. 

Lemma chain_eq (s1 s2 : Pred D) : s1 =p s2 -> (chain s1 <-> chain s2).
Proof.
move: s1 s2.
suff L: forall s1 s2 : Pred D, s1 =p s2 -> chain s1 -> chain s2.
- by move=>s1 s2 H; split; apply: L; rewrite H.
move=>s1 s2 H [[d H1] H2]; split; first by exists d; rewrite -H.
by move=>x y; rewrite -H; apply: H2.
Qed.

Lemma sup_eq (s1 s2 : Pred D) : s1 =p s2 -> chain s1 -> sup s1 = sup s2. 
Proof.
move: s1 s2.
have L: forall s1 s2 : Pred D, s1 =p s2 -> chain s1 -> sup s2 <== sup s1.
- by move=>s1 s2 E H1; apply: supM=>y; rewrite -E; move/supP.
move=>s1 s2 E H1; move: (H1); move/(chain_eq E)=>H2.
by apply: leq_asym; apply: L=>//; rewrite E.
Qed.

Lemma chain_bot (s : Pred D) : chain s -> chain [PredU s & Pred1 bot].
Proof.
move=>[[d H1] H2]; split=>[|x y]; first by exists bot; right.
case=>/= H3; last by case: H3=><-; auto.
case=>/= H4; last by case: H4=><-; auto.
by apply: H2.
Qed.

Lemma sup_bot (s : Pred D) : chain s -> sup s = sup [PredU s & Pred1 bot].
Proof.
move=>H; apply: leq_asym; first by apply: supM=>y H1; apply: supP; left.
by apply: supM=>y; case=>/=; [apply: supP | case=><-].
Qed.

End ChainProperties. 
 
Definition fun_image (D1 D2 : cpo) (f : D1 -> D2) (s : Pred D1) :=
  [Pred x : D2 | exists y, y \In s /\ x = f y].

Notation "f ^ s" := (fun_image f s).

Section Continuity. 
Variables (D1 D2 : cpo) (f : D1 -> D2).

Definition monotone := forall x1 x2 : D1, x1 <== x2 -> f x1 <== f x2. 

(* monotone functions preserve chains *)

Lemma mono_chain : monotone -> forall s, chain s -> chain (f ^ s).
Proof.
move=>M s [[d L] H]; split; first by exists (f d); exists d.
move=>x y [d1 [L1 ->]] [d2 [L2 ->]].
by case: (H _ _ L1 L2)=>H1; [left | right]; apply: M.
Qed.

Definition continuous := 
  forall s (p : chain s), f (supch p) = sup (f ^ s) :> univ D2.

Lemma cont_mono : continuous -> monotone.
Proof.
move=>C x1 x2 H; set s := [Pred x | x = x1 \/ x = x2].
have p : chain s.
- split; first by exists x1; left.
  by move=>x y; case=>->; case=>->; auto.
rewrite (_ : x2 = supch p).
- by rewrite C //; apply: supP; exists x1; split=>//; left.
rewrite valE (valX (supch p)) val_supch.
apply: leq_asym; first by apply: supP; right.
by apply: supM=>// y; case=>->.
Qed.

End Continuity. 

(********************************)
(* Kleene's fixed point theorem *)
(********************************)

Section Kleene.
Variables (D : cpo) (f : D -> D) (C : continuous f).

Fixpoint pow m := if m is n.+1 then f (pow n) else bot. 

Let s := [Pred x | exists n, x = pow n].

Lemma s_reindex : s =p [PredU f ^ s & Pred1 bot]. 
Proof.
move=>x; split.
- case=>[[|n] -> /=]; first by right.
  by left; exists (pow n); split=>//; exists n.
case=>/=; last by case=><-; exists 0.
by case=>d [[n]] -> ->; exists n.+1.
Qed.

Lemma s_chain : chain s.
Proof.
have L : forall n, pow n <== f (pow n).
- by elim=>[|n IH] //=; apply: cont_mono IH.
have pow_mono : forall m n, m < n -> pow m <== pow n.
- move=>m n; move: n m; elim=>[|n IH] m //=; rewrite ltnS leq_eqVlt.
  case/orP=>[|H]; first by move/eqP=>->.
  by apply: leq_trans (IH _ H) (L n).
split; first by exists (pow 0); exists 0.
move=>x y [m ->][n ->]; case: (ltngtP m n).
- by left; apply: pow_mono.
- by right; apply: pow_mono.
by move=>->; auto.
Qed.

Hint Resolve s_chain.

Definition lfp := supch s_chain.

Lemma lfp_fixed : f lfp = lfp.
Proof.
have L : chain (f ^ s) by apply: mono_chain=>//; apply: cont_mono.
rewrite valE !valX /lfp C // sup_bot // val_supch.
by apply: sup_eq; [symmetry; apply: s_reindex | apply: chain_bot].
Qed.

Lemma lfp_least : forall x, f x = x -> lfp <== x.
Proof. 
move=>x H.
suff: forall y, y \In s -> y <== x.
- by rewrite /lfp val_supch; apply: supM.
move=>y [n ->]; elim: n=>[|n IH] //=.
by rewrite -H; apply: cont_mono.
Qed.

End Kleene.

(*************)
(* Sub-CPO's *)
(*************)

(* every chain-closed subset of a poset defines a CPO *)

Section AdmissibleClosure.
Variable U : poset.

Definition closed := 
  [Pred s : Pred U | 
     pbot \In s /\ forall d, pchain d -> d <=p s -> psup d \In s].

(* admissible closure of s is the smallest closed set containing s *)
(* basically extends s to include the sups of chains *)
Definition closure (s : Pred U) := 
  [Pred p : U | forall t : Pred U, s <=p t -> closed t -> p \In t].

(* admissible closure contains s *)
Lemma clos_sub (s : Pred U) : s <=p closure s.
Proof. by move=>p H1 t H2 H3; apply: H2 H1. Qed.

(* admissible closure is smallest *)
Lemma clos_min (s : Pred U) : forall t, s <=p t -> closed t -> closure s <=p t.
Proof. by move=>t H1 H2 p; move/(_ _ H1 H2). Qed.

(* admissible closure is closed *)
Lemma closP (s : Pred U) : closed (closure s).
Proof.
split; first by move=>t _ [].
move=>d H1 H2 t H3 H4; move: (clos_min H3 H4)=>{H3} H3.
by case: H4=>_; apply=>// x; move/H2; move/H3.
Qed.

Lemma clos_idemp (s : Pred U) : closed s -> closure s =p s.
Proof.
move=>p; split; last by apply: clos_sub.
by apply: clos_min=>//; apply: closP.
Qed.

Lemma clos_mono (s1 s2 : Pred U) : s1 <=p s2 -> closure s1 <=p closure s2.
Proof.
move=>H1; apply: clos_min (closP s2)=>p H2.
by apply: clos_sub; apply: H1.
Qed.

(* intersection of admissible sets is admissible *)
Lemma closI (s1 s2 : Pred U) : 
       closed s1 -> closed s2 -> closed (PredI s1 s2).
Proof.
move=>[H1 S1][H2 S2]; split=>// d H S.  
by split; [apply: S1 | apply: S2]=>// x; case/S.
Qed.

End AdmissibleClosure.

Implicit Arguments closed [U].
Prenex Implicits closed.

(* diagonal of an admissible set of pairs is admissible *)
Lemma clos_diag (U : poset) (s : Pred (U*U)) : 
        closed s -> closed [Pred t : U | (t, t) \In s].
Proof.
move=>[B H1]; split=>// d H2 H3.
set d' := [Pred s | exists t, s = (t, t) /\ t \In d].
have [L1 L2]: d = [Pred p | exists f, p = f.1 /\ f \In d'] /\ 
              d = [Pred p | exists f, p = f.2 /\ f \In d'].
- split; apply: fext=>x; apply: pext; 
  by (split; [exists (x, x); split=>//; exists x |
              case=>t [->][z][->]]).
rewrite InE /= {1}L1 L2; apply: H1; last first.
- by move=>[t1 t2][t][[->]] ->; move/H3.
case: H2=>[[t T1]] T2; split.
- by exists (t, t); exists t.
move=>x y [t1][->] S1 [t2][->] S2.
by case: (T2 _ _ S1 S2)=>H; [left | right]; split.
Qed.

(* every cpo has a closed inside *)
Lemma clos_inside (D : cpo) : closed (inside D).
Proof. by split; [apply: bot_inside | apply: psup_inside]. Qed.

Hint Resolve clos_inside.

(* subcpos of posets *)
Section PosetSubCPOs.
Variables (U : poset) (s : Pred U) (C : closed s).

Let D := {x : U | x \In s}.
Let val : D -> U := sval.
Let bundle (x : U) (p : x \In s) : D := exist _ x p.

Lemma cval_inside x : val x \In s.
Proof. by case: x. Qed.

Lemma cval_bundle x (p : x \In s) : val (bundle p) = x.
Proof. by []. Qed.

Lemma cret_val x (p : val x \In s) : bundle p = x.
Proof. by case: x p=>x /= p1 p2; rewrite (proof_irrelevance p1 p2). Qed.

Lemma cbot_inside : pbot \In s.
Proof. by case: C. Qed.

Lemma csup_inside (t : Pred U) : pchain t -> t <=p s -> psup t \In s.
Proof. by case: C t. Qed.

Definition subCPOMixin := 
  CPOMixin cval_inside cval_bundle cret_val cbot_inside csup_inside.
Definition subCPO := CPO subCPOMixin.

End PosetSubCPOs.

(* pairs are cpo's *)
Section CPOPair. 
Variable (A B : cpo). 

Let D := (A * B)%type.
Let pinside := [Pred x | x.1 \In inside A /\ x.2 \In inside B].
Let val (x : D) := (val x.1, val x.2).
Let bundle x (p : x \In pinside) : D :=
     (bundle (proj1 p), bundle (proj2 p)).

Lemma pr_val_inside x : val x \In pinside. 
Proof. by case: x=>x1 x2; split; apply: val_inside. Qed.
 
Lemma pr_val_bundle x (p : x \In pinside) : val (bundle p) = x.
Proof. by case: x p=>x1 x2 [S1 S2]; rewrite /val /= !val_bundle. Qed.

Lemma pr_ret_val x (p : val x \In pinside) : bundle p = x.
Proof. by case: x p=>x1 x2 [S1 S2]; rewrite /bundle !bundle_val. Qed.

Lemma pr_bot_inside : pbot \In pinside.
Proof. by split; apply: bot_inside. Qed.

Lemma pr_sup_inside (t : Pred (univ A * univ B)) :  
        pchain t -> t <=p pinside -> psup t \In pinside.
Proof.
move=>H1 H2. 
have [C1 C2] : pchain [Pred p | exists f, p = f.1 /\ f \In t] /\
               pchain [Pred p | exists f, p = f.2 /\ f \In t].
- case: H1=>[[e T1]] T2; split;
  [split; first by exists e.1; exists e | 
   split; first by exists e.2; exists e];
  move=>x y [[x1 x2]][/= <-] N1 [[y1 y2]][/= <-];
  by case/(T2 _ _ N1); case; [left | right].
have [D1 D2] : 
  [Pred p | exists f, p = f.1 /\ f \In t] <=p inside A /\ 
  [Pred p | exists f, p = f.2 /\ f \In t] <=p inside B.
- by split=>x [[x1 x2]][/= <-]; case/H2.
by split; apply: psup_inside.
Qed.

Definition pairCPOMixin := 
  CPOMixin pr_val_inside pr_val_bundle 
           pr_ret_val pr_bot_inside pr_sup_inside.
Canonical Structure pairCPO := CPO pairCPOMixin.

End CPOPair.

(*******************)
(* Parametrization *)
(*******************)

(* Functions into a cpo form a cpo. *)

Section CPOParam.
Variable (A : Type) (B : cpo).

Let D := (A -> B).
Let U := paramPoset A (univ B).
Let val : D -> U := fun f x => val (f x).
Let inside : Pred U := [Pred f : U | forall x, f x \In inside B].
Let bundle (f : U) (p : f \In inside) : D := fun x => bundle (id p x).

Lemma fval_inside f : val f \In inside.
Proof. by move=>x; apply: val_inside. Qed.

Lemma fval_ret f (p : f \In inside) : val (bundle p) = f.
Proof. by apply: fext=>y; apply: val_bundle. Qed.

Lemma fret_val f (p : val f \In inside) : bundle p = f.
Proof. by apply: fext=>x; apply: bundle_val. Qed.

Lemma fbot_inside : pbot \In inside.
Proof. by move=>x; apply: bot_inside. Qed.

Lemma fsup_inside (t : Pred U) : pchain t -> t <=p inside -> psup t \In inside.
Proof.
move=>H1 H2 x; apply: psup_inside; last by move=>_ [f][H3] ->; apply: H2.
case: H1=>[[f H3]] H4; split; first by exists (f x); exists f.
move=>g1' g2' [g1] [H5] ->{g1'} [g2] [H6] ->{g2'}.
by case: (H4 g1 g2 H5 H6)=>H; [left | right]; apply: H.
Qed.

Definition paramCPOMixin := 
  CPOMixin fval_inside fval_ret fret_val fbot_inside fsup_inside.
Canonical Structure paramCPO := CPO paramCPOMixin.

End CPOParam.

(* dependent functions into a cpo form a cpo *)

Section CPODParam.
Variable (A : Type) (B : A -> cpo).

Let D := (forall x, B x).
Let U := dparamPoset (fun x => univ (B x)).
Let val : D -> U := fun f x => val (f x).
Let inside : Pred U := [Pred f : U | forall x, f x \In inside (B x)].
Let bundle (f : U) (p : f \In inside) : D := fun x => bundle (id p x).

Lemma dval_inside f : val f \In inside.
Proof. by move=>x; apply: val_inside. Qed.

Lemma dval_ret f (p : f \In inside) : val (bundle p) = f.
Proof. by apply: fext=>y; apply: val_bundle. Qed.

Lemma dret_val f (p : val f \In inside) : bundle p = f.
Proof. by apply: fext=>x; apply: bundle_val. Qed.

Lemma dbot_inside : pbot \In inside.
Proof. by move=>x; apply: bot_inside. Qed.

Lemma dsup_inside (t : Pred U) : pchain t -> t <=p inside -> psup t \In inside.
Proof.
move=>H1 H2 x; apply: psup_inside; last by move=>_ [f][H3] ->; apply: H2.
case: H1=>[[f H3]] H4; split; first by exists (f x); exists f.
move=>g1' g2' [g1] [H5] ->{g1'} [g2] [H6] ->{g2'}.
by case: (H4 g1 g2 H5 H6)=>H; [left | right]; apply: H.
Qed.

Definition dparamCPOMixin := 
  CPOMixin dval_inside dval_ret dret_val dbot_inside dsup_inside.
Definition dparamCPO := CPO dparamCPOMixin.

End CPODParam.
