Section PACO.
#[local] Hint Resolve le_join_lattice_introl le_join_lattice_intror join_lattice_le_intro bot_lattice_le_intro : core.
Context {A : Type}.
Let D : Type := ensemble A.
#[local]
Instance ensemble_isUpperSemilattice : isUpperSemilattice D :=
{ join_lattice := @E.union A
; bot_lattice := @E.empty A
; join_lattice_spec := union_join_lattice_spec
; bot_lattice_spec := empty_bot_lattice_spec
}.
Variant paco' {paco_F : D -> D} (F : D -> D) (X : D) : D :=
| mk_paco' (WITNESS : D)
(INCL : WITNESS \subseteq join_lattice X (paco_F X))
: F WITNESS \subseteq paco' F X.
#[global]
Instance ensemble_isCoLa : isCola D :=
fun Xs : ensemble D => @exist D (fun sup_Xs : D => is_supremum_of sup_Xs Xs) (E.unions Xs) (unions_is_supremum Xs).
#[projections(primitive)]
CoInductive paco (F : D -> D) (X : D) (z : A) : Prop :=
Fold_paco { unfold_paco : z \in paco' (paco_F := paco F) F X }.
Definition Paco (f : `[D -> D]) : `[D -> D] :=
@exist (D -> D) isMonotonic1 (paco (proj1_sig f)) (paco_preserves_monotonicity (proj1_sig f) (proj2_sig f)).
Proof with eauto with *.
pose (proj1_sig f) as F.
assert (claim1 : F (join_lattice bot_lattice (paco F bot_lattice)) =< paco F bot_lattice) by exact (paco_fold F bot_lattice).
assert (claim2 : paco F bot_lattice =< F (join_lattice bot_lattice (paco F bot_lattice))) by exact (paco_unfold F bot_lattice (proj2_sig f)).
assert (FIXEDPOINT : paco F bot_lattice == F (paco F bot_lattice)).
{ eapply @leProp_antisymmetry with (A_isProset := E.ensemble_isProset).
- rewrite claim2 at 1. eapply (proj2_sig f). eapply join_lattice_le_intro...
- rewrite <- claim1 at 2. eapply (proj2_sig f). eapply le_join_lattice_intror...
}
assert (IS_SUPREMUM : is_supremum_of (proj1_sig (nu f)) (postfixedpointsOf F)) by eapply nu_is_supremum_of_postfixedpointsOf.
pose proof (nu_f_is_gfpOf_f f) as [claim3 claim4]; unnw.
do 2 red in claim3. fold F in claim3.
assert (to_show : F (proj1_sig (nu f)) =< paco F bot_lattice).
{ cofix CIH. intros z z_in. econstructor. revert z z_in. apply mk_paco'.
intros z z_in. right. eapply CIH. rewrite <- claim3. exact (z_in).
}
rewrite <- claim3 in to_show. eapply @leProp_antisymmetry with (A_isProset := E.ensemble_isProset)...
Qed.
Proof with eauto with *.
intros X Y. pose (proj1_sig f) as F. split.
- intros Y_le_paco_f_X z z_in. apply Y_le_paco_f_X in z_in.
revert z z_in. change (proj1_sig (Paco f) X =< proj1_sig (Paco f) (join_lattice X Y)).
eapply paco_preserves_monotonicity; [exact (proj2_sig f) | eapply le_join_lattice_introl]...
- intros COIND. rewrite COIND at 1. change (paco F (join_lattice X Y) =< paco F X). pose (G_aux0 f X) as F'.
assert (claim1 : paco F (join_lattice X Y) =< F (join_lattice (join_lattice X Y) (paco F (join_lattice X Y)))).
{ exact (paco_unfold (proj1_sig f) (join_lattice X Y) (proj2_sig f)). }
assert (claim2 : F (join_lattice (join_lattice X Y) (paco F (join_lattice X Y))) =< F (join_lattice X (paco F (join_lattice X Y)))).
{ eapply (proj2_sig f). eapply join_lattice_le_intro.
- intros z [z_in_X | z_in_Y]; [left | right]...
- eapply le_join_lattice_intror...
}
assert (claim3 : paco F (join_lattice X Y) \in postfixedpointsOf F').
{ intros z z_in. eapply (proj2_sig f); [reflexivity | eapply claim2]... }
assert (claim4 : isMonotonic1 F').
{ eapply G_aux0_isMonotionicMap. }
set (G_f_X := proj1_sig (nu (@exist (D -> D) isMonotonic1 F' claim4))).
assert (claim5 : paco F (join_lattice X Y) =< F' (paco F (join_lattice X Y))).
{ intros z z_in. eapply (proj2_sig f); [reflexivity | eapply claim2]... }
assert (claim6 : paco F (join_lattice X Y) =< G_f_X).
{ eapply postfixedpoint_le_gfpOf... }
assert (claim7 : is_supremum_of G_f_X (postfixedpointsOf F')).
{ eapply nu_is_supremum_of_postfixedpointsOf. }
pose proof (postfixedpoint_is_gfpOf (PROSET := E.ensemble_isProset) F' G_f_X claim4 claim7) as [? ?]; s!.
assert (claim8 : G_f_X =< F (join_lattice X G_f_X)).
{ eapply eqProp_implies_leProp... }
assert (claim9 : F (join_lattice X G_f_X) =< paco F X).
{ simpl. cofix CIH. intros z z_in. econstructor. revert z z_in. eapply mk_paco'.
intros z z_in. destruct z_in as [? | ?]; simpl.
- left. exact H_inl.
- right. eapply CIH. exact (claim8 z H_inr).
}
change (paco F (E.union X Y) =< paco F X). now rewrite <- claim9, claim6.
Qed.

Corollary paco_compositionality (F : D -> D) (r : D) (r1 : D) (r2 : D) (g1 : D) (g2 : D)
(F_monotonic : isMonotonic1 F)
(g1_le_G_f_r1 : g1 =< paco F r1)
(g2_le_G_f_r2 : g2 =< paco F r2)
(r1_le : r1 =< join_lattice r g2)
(r2_le : r2 =< join_lattice r g1)
: join_lattice g1 g2 =< paco F r.