From Coq Require Import ssreflect ssrfun ssrbool.
Require Import stdpp.tactics.
Require Import stdpp.finite.

Require Import depleted.proset.
Local Open Scope proset_scope.
Local Open Scope proset_util_scope.

Definition lower_bound `{Proset X} {R} (J : R -> X) (A : X) : Prop
  := forall r, A ⊢ J r.
Definition upper_bound `{Proset X} {R} (J : R -> X) (A : X) : Prop
  := forall r, J r ⊢ A.
Instance: Params (@lower_bound) 4 := {}.
Instance: Params (@upper_bound) 4 := {}.
Instance lower_bound_proper `{Proset X} {R}
  : Proper ((⊢) ++> (↼)) (lower_bound (X:=X) (R:=R)).
Proof.
  move=> J1 J2 D_J A1 A2 /= D_A L r.
  rewrite D_A -(D_J r) //.
Qed.
Instance lower_bound_mono `{Proset X} {R} : Monotone (lower_bound (X:=X) (R:=R)).
Proof. move=> J1 J2 D_J A L r; rewrite -(D_J r) //. Qed.
Instance lower_bound_ext `{Proset X} {R} : Extensional (lower_bound (X:=X) (R:=R)).
Proof. typeclasses eauto. Qed.
Instance lower_bound_anti `{Proset X} {R} {J : R -> X} : Antitone (lower_bound J).
Proof. typeclasses eauto. Qed.
Instance upper_bound_proper `{Proset X} {R}
  : Proper ((⊢) --> (⇀)) (upper_bound (X:=X) (R:=R)).
Proof.
  move=> J1 J2 D_J A1 A2 D_A U r.
  rewrite -D_A (D_J r) //.
Qed.
Instance upper_bound_anti `{Proset X} {R} : Antitone (upper_bound (X:=X) (R:=R)).
Proof. move=> J1 J2 /= D_J A L r; rewrite (D_J r) //. Qed.
Instance upper_bound_ext `{Proset X} {R} : Extensional (upper_bound (X:=X) (R:=R)).
Proof. typeclasses eauto. Qed.
Instance upper_bound_mono `{Proset X} {R} {J : R -> X} : Monotone (upper_bound J).
Proof. typeclasses eauto. Qed.
Instance lower_bound_proper' `{Proset X} {R}
  : Proper ((⊢) --> (⊢) ++> flip impl) (lower_bound (X:=X) (R:=R)).
Proof. move=> ? ? ? ? ? ?; by apply: lower_bound_proper. Qed.
Instance lower_bound_proper'' `{Proset X} {R}
  : Proper ((⟛) ==> (⥊)) (lower_bound (X:=X) (R:=R)).
Proof.
  apply: proper_sym_impl_iff_2 => ? ? [D ?] ? ? [D' ?] ?.
    by apply: lower_bound_proper.
Qed.
Instance upper_bound_proper' `{Proset X} {R}
  : Proper ((⊢) ++> (⊢) --> flip impl) (upper_bound (X:=X) (R:=R)).
Proof. move=> ? ? ? ? ? ?; by apply: upper_bound_proper. Qed.
Instance upper_bound_proper'' `{Proset X} {R}
  : Proper ((⟛) ==> (⥊)) (upper_bound (X:=X) (R:=R)).
Proof.
  apply: proper_sym_impl_iff_2 => ? ? [D ?] ? ? [D' ?] ?.
    by apply: upper_bound_proper.
Qed.

Definition pred_lower_bound `{Proset X} (P : X -> Prop) (A : X) : Prop
  := forall B, P B -> A ⊢ B.
Definition pred_upper_bound `{Proset X} (P : X -> Prop) (A : X) : Prop
  := forall B, P B -> B ⊢ A.
Instance: Params (@pred_lower_bound) 3 := {}.
Instance: Params (@pred_upper_bound) 3 := {}.
Instance pred_lower_bound_proper `{Proset X}
  : Proper ((⊢) --> (↼)) (pred_lower_bound (X:=X)).
Proof.
  move=> P1 P2 D_P A1 A2 /= D_A L B /D_P.
  rewrite D_A; apply: L.
Qed.
Instance pred_upper_bound_proper `{Proset X}
  : Proper ((⊢) --> (⇀)) (pred_upper_bound (X:=X)).
Proof.
  move=> P1 P2 D_P A1 A2 D_A U B /D_P ?.
  rewrite -D_A; by apply: U.
Qed.
(*
Instance pred_lower_bound_proper' `{Proset X}
  : Proper ((⊢) ++> (⊢) ++> flip impl) (pred_lower_bound (X:=X)).
Proof. move=> ? ? ? ? ? ?; by apply: pred_lower_bound_proper. Qed.
*)
Instance pred_lower_bound_proper'' `{Proset X}
  : Proper ((⟛) ==> (⥊)) (pred_lower_bound (X:=X)).
Proof.
  apply: proper_sym_impl_iff_2 => ? ? [D ?] ? ? [D' ?] ?.
    by apply: pred_lower_bound_proper.
Qed.
(*
Instance pred_upper_bound_proper' `{Proset X}
  : Proper ((⊢) ++> (⊢) --> flip impl) (pred_upper_bound (X:=X)).
Proof. move=> ? ? ? ? ? ?; by apply: pred_upper_bound_proper. Qed.
*)
Instance pred_upper_bound_proper'' `{Proset X}
  : Proper ((⟛) ==> (⥊)) (pred_upper_bound (X:=X)).
Proof.
  apply: proper_sym_impl_iff_2 => ? ? [D ?] ? ? [D' ?] ?.
    by apply: pred_upper_bound_proper.
Qed.

Definition pred_diagram `{Proset X} (P : X -> Prop) : sig P -> X
  := sval.
Arguments pred_diagram {_ _ _} P /.
Instance: Params (@pred_diagram) 3 := {}.
Lemma pred_lb_lb `{Proset X} (P : X -> Prop) (A : X)
  : pred_lower_bound P A <-> lower_bound (pred_diagram P) A.
Proof.
  split.
  - move=> L [B P_B]; auto.
  - move=> L B P_B; apply: (L (B ↾ P_B)).
Qed.
Lemma pred_ub_ub `{Proset X} (P : X -> Prop) (A : X)
  : pred_upper_bound P A <-> upper_bound (pred_diagram P) A.
Proof.
  split.
  - move=> U [B P_B]; auto.
  - move=> U B P_B; apply: (U (B ↾ P_B)).
Qed.

Definition image `{Proset X} {R} (J : R -> X) : X -> Prop
  := fun A => exists r, J r ⟛ A.
Arguments image {_ _ _ _} J _ /.
Instance: Params (@image) 4 := {}.
Instance image_proper `{Proset X} {R}
  : Proper ((⟛) ==> (⥊)) (image (X:=X) (R:=R)).
Proof.
  apply: proper_sym_impl_iff_2.
  move=> J J' E_J A A' E_A /= [r] E; exists r.
  rewrite -E_J -E_A //.
Qed.
Lemma lb_pred_lb `{Proset X} {R} (J : R -> X) (A : X)
  : lower_bound J A <-> pred_lower_bound (image J) A.
Proof.
  split.
  - move=> L B [r E]; rewrite -(proj1 E) //.
  - move=> L r; apply/L; by exists r.
Qed.
Lemma ub_pred_ub `{Proset X} {R} (J : R -> X) (A : X)
  : upper_bound J A <-> pred_upper_bound (image J) A.
Proof.
  split.
  - move=> U B [r E]; rewrite (proj2 E) //.
  - move=> U r; apply/U; by exists r.
Qed.

Definition least `{Proset X} (P : X -> Prop) (A : X) : Prop
  := P A /\ pred_lower_bound P A.
Definition greatest `{Proset X} (P : X -> Prop) (A : X) : Prop
  := P A /\ pred_upper_bound P A.
Arguments least {_ _ _} P _ /.
Arguments greatest {_ _ _} P _ /.
Instance: Params (@least) 3 := {}.
Instance: Params (@greatest) 3 := {}.
Instance least_proper `{Proset X}
  : Proper ((⥊) ==> (⟛) ==> iff) (least (X:=X)).
Proof.
  apply: proper_sym_impl_iff_2.
  - firstorder.
  - move=> ? ? /pw_harpoon' [? ? E1] ? ? E2 /= [H1 H2].
      by rewrite -> E1, E2 in H1, H2.
Qed.
Instance greatest_proper `{Proset X}
  : Proper ((⥊) ==> (⟛) ==> iff) (greatest (X:=X)).
Proof.
  apply: proper_sym_impl_iff_2.
  - firstorder.
  - move=> ? ? /pw_harpoon' [? ? E1] ? ? E2 /= [H1 H2].
      by rewrite -> E1, E2 in H1, H2.
Qed.
Lemma least_unique `{Proset X} {P : X -> Prop} {A A'}
  : least P A -> least P A' -> A ⟛ A'.
Proof. firstorder. Qed.
Lemma greatest_unique `{Proset X} {P : X -> Prop} {A A'}
  : greatest P A -> greatest P A' -> A ⟛ A'.
Proof. firstorder. Qed.
Lemma least_unique_het `{Proset X} {P P' : X -> Prop} {A A'}
  : P ⟛ P' -> least P A -> least P' A' -> A ⟛ A'.
Proof. firstorder. Qed.
Lemma greatest_unique_het `{Proset X} {P P' : X -> Prop} {A A'}
  : P ⟛ P' -> greatest P A -> greatest P' A' -> A ⟛ A'.
Proof. firstorder. Qed.

Definition glb `{Proset X} {R} (J : R -> X) : X -> Prop := greatest (lower_bound J).
Definition lub `{Proset X} {R} (J : R -> X) : X -> Prop := least (upper_bound J).
Arguments glb {_ _ _ _} J.
Arguments lub {_ _ _ _} J.
Instance: Params (@glb) 4 := {}.
Instance: Params (@lub) 4 := {}.
Instance glb_proper `{Proset X} {R}
  : Proper ((⟛) ==> (⟛) ==> iff) (glb (X:=X) (R:=R)).
Proof.
  move=> ? ? E1 ? ? E2; rewrite /glb E1; apply/(greatest_proper _ _ proper_prf _ _ E2).
Qed.
Instance lub_proper `{Proset X} {R}
  : Proper ((⟛) ==> (⟛) ==> iff) (lub (X:=X) (R:=R)).
Proof.
  move=> ? ? E1 ? ? E2; rewrite /lub E1; apply/(least_proper _ _ proper_prf _ _ E2).
Qed.

Class HasInf `{Proset X} {R} (J : R -> X) :=
  {inf : X; is_inf : glb J inf}.
Class HasSup `{Proset X} {R} (J : R -> X) :=
  {sup : X; is_sup : lub J sup}.
Hint Mode HasInf ! - - ! ! : typeclass_instances.
Hint Mode HasSup ! - - ! ! : typeclass_instances.
Arguments inf {X _ _ R} J {Has} : rename.
Arguments sup {X _ _ R} J {Has} : rename.
Arguments is_inf {X _ _ R} J {_}.
Arguments is_sup {X _ _ R} J {_}.
(* TODO Figure out what kind of black magic is necessary for rewriting under an
        inf or sup. *)
Instance: Params (@inf) 6 := {}.
Instance: Params (@sup) 6 := {}.
Notation "'Inf' x .. y , p" := (inf (fun x => .. (inf (fun y => p)) ..))
  (at level 200, x binder, right associativity,
   format "'[' 'Inf'  '/  ' x  ..  y ,  '/  ' p ']'")
  : proset_scope.
Notation "'Sup' x .. y , p" := (sup (fun x => .. (sup (fun y => p)) ..))
  (at level 200, x binder, right associativity,
   format "'[' 'Sup'  '/  ' x  ..  y ,  '/  ' p ']'")
  : proset_scope.

Definition transport_inf `{Proset X} {R} {J J' : R -> X} (E : J ⟛ J') `{!HasInf J}
  : HasInf J'
  := {| inf := inf J;
        is_inf := proj1 (glb_proper _ _ E _ _ (reflexivity _)) (is_inf J) |}.
Definition transport_sup `{Proset X} {R} {J J' : R -> X} (E : J ⟛ J') `{!HasSup J}
  : HasSup J'
  := {| sup := sup J;
        is_sup := proj1 (lub_proper _ _ E _ _ (reflexivity _)) (is_sup J) |}.

(* TODO Lots of stuff! *)
Definition inf_lb `{Proset X} {R} {J : R -> X} `{!HasInf J} : lower_bound J (inf J)
  := proj1 (is_inf J).
Definition inf_left `{Proset X} {R} {J : R -> X} `{!HasInf J} (r : R) {A}
  : J r ⊢ A -> inf J ⊢ A
  := fun D => transitivity (inf_lb r) D.
Definition inf_right `{Proset X} {R} {J : R -> X} `{!HasInf J} {A : X}
  : lower_bound J A -> A ⊢ inf J
  := proj2 (is_inf J) A.
Lemma inf_universal `{Proset X} {R} {J : R -> X} `{!HasInf J} {A : X}
  : lower_bound J A <-> A ⊢ inf J.
Proof.
  split; first by apply: inf_right.
  move=> ->; apply: inf_lb.
Qed.
Definition sup_ub `{Proset X} {R} {J : R -> X} `{!HasSup J} : upper_bound J (sup J)
  := proj1 (is_sup J).
Definition sup_left `{Proset X} {R} {J : R -> X} `{!HasSup J} {A : X}
  : upper_bound J A -> sup J ⊢ A
  := proj2 (is_sup J) A.
Definition sup_right `{Proset X} {R} {J : R -> X} `{!HasSup J} (r : R) {A}
  : A ⊢ J r -> A ⊢ sup J
  := fun D => transitivity D (sup_ub r).
Lemma sup_universal `{Proset X} {R} {J : R -> X} `{!HasSup J} {A : X}
  : upper_bound J A <-> sup J ⊢ A.
Proof.
  move=> *; split; first by apply: sup_left.
  move=> <-; apply: sup_ub.
Qed.

Notation InfsOfShape R X := (forall J : R -> X, Monotone J -> HasInf J).
Notation SupsOfShape R X := (forall J : R -> X, Monotone J -> HasSup J).
Notation DInfsOfShape R X := (forall J : R -> X, HasInf J).
Notation DSupsOfShape R X := (forall J : R -> X, HasSup J).

Lemma inf_from_discrete {R} `{Proset X} {J : R -> X}
  : HasInf (J ∘ get_discrete) -> HasInf J.
Proof. done. Defined.
Lemma sup_from_discrete {R} `{Proset X} {J : R -> X}
  : HasSup (J ∘ get_discrete) -> HasSup J.
Proof. done. Defined.
Lemma infs_from_discrete `{Proset X, Proset R}
  : InfsOfShape (discrete R) X -> DInfsOfShape R X.
Proof. move=> IOS J; exists (inf (J ∘ get_discrete)); apply: is_inf. Defined.
Lemma sups_from_discrete `{Proset X, Proset R}
  : SupsOfShape (discrete R) X -> DSupsOfShape R X.
Proof. move=> SOS J; exists (sup (J ∘ get_discrete)); apply: is_sup. Defined.

Definition einf `{Proset X} {R} `{!DInfsOfShape R X} (J : R -> X) : X := inf J.
Definition esup `{Proset X} {R} `{!DSupsOfShape R X} (J : R -> X) : X := sup J.
Arguments einf {_ _ _ _ _} J /.
Arguments esup {_ _ _ _ _} J /.
Instance: Params (@einf) 5 := {}.
Instance: Params (@esup) 5 := {}.
Notation "'EInf' x .. y , p" := (einf (fun x => .. (einf (fun y => p)) ..))
  (at level 200, x binder, right associativity,
   format "'[' 'EInf'  '/  ' x  ..  y ,  '/  ' p ']'")
  : proset_scope.
Notation "'ESup' x .. y , p" := (esup (fun x => .. (esup (fun y => p)) ..))
  (at level 200, x binder, right associativity,
   format "'[' 'ESup'  '/  ' x  ..  y ,  '/  ' p ']'")
  : proset_scope.
Instance einf_mono {R} `{Proset X, !DInfsOfShape R X}
  : Monotone (einf (X:=X) (R:=R)).
Proof. move=> A B D /=; apply: inf_right => r; by apply: inf_left. Qed.
Instance esup_mono {R} `{Proset X, !DSupsOfShape R X}
  : Monotone (esup (X:=X) (R:=R)).
Proof. move=> A B D /=; apply: sup_left => r; by apply: sup_right. Qed.

Notation InfLattice X := (forall R, DInfsOfShape R X).
Notation SupLattice X := (forall R, DSupsOfShape R X).
Class Complete (X : Type) `{Proset X, !InfLattice X, !SupLattice X}.
Hint Mode Complete ! - - - - : typeclass_instances.
Instance complete_def `{Proset X, !InfLattice X, !SupLattice X}
  : Complete X := {}.

(* This could probably follow by some abstract nonsense if we moved it *after*
   presheaf stuff... Hmm. Oh well. *)
Definition ub_diagram `{Proset X} {R} (J : R -> X) : sig (upper_bound J) -> X
  := sval.
Definition lb_diagram `{Proset X} {R} (J : R -> X) : sig (lower_bound J) -> X
  := sval.
Arguments ub_diagram _ /.
Arguments lb_diagram _ /.
Instance: Params (@ub_diagram) 4 := {}.
Instance: Params (@lb_diagram) 4 := {}.
Lemma ub_diagram_spec `{Proset X} {R} {J : R -> X} {A}
  : glb (ub_diagram J) A <-> lub J A.
Proof.
  split=> [Glb | Lub].
  - pose Has := {| is_inf := Glb |}; change A with (inf (ub_diagram J)); split.
    + move=> r; apply: inf_right => -[B UB] //=.
    + move=> B UB; by apply: (inf_left (B ↾ UB)).
  - pose Has := {| is_sup := Lub |}; change A with (sup J); split.
    + move=> [B UB]; apply: sup_left => r //=.
    + move=> B LB; apply/(LB (sup J ↾ _)); apply: sup_ub.
Qed.
Lemma lb_diagram_spec `{Proset X} {R} {J : R -> X} {A}
  : lub (lb_diagram J) A <-> glb J A.
Proof.
  split=> [Lub | Glb].
  - pose Has := {| is_sup := Lub |}; change A with (sup (lb_diagram J)); split.
    + move=> r; apply: sup_left => -[B LB] //=.
    + move=> B LB; by apply: (sup_right (B ↾ LB)).
  - pose Has := {| is_inf := Glb |}; change A with (inf J); split.
    + move=> [B LB]; apply: inf_right => r //=.
    + move=> B UB; apply: (UB (inf J ↾ _)); apply: inf_lb.
Qed.
Definition infs_sufficient `{Proset X, !InfLattice X} : SupLattice X
  := fun R J => {| sup := inf (ub_diagram J); is_sup := proj1 ub_diagram_spec (is_inf _) |}.
Definition sups_sufficient `{Proset X, !SupLattice X} : InfLattice X
  := fun R J => {| inf := sup (lb_diagram J); is_inf := proj1 lb_diagram_spec (is_sup _) |}.

Lemma inf_binder_fwd `{Proset X} {R} {J J' : R -> X} `{!DInfsOfShape R X}
  : (forall r, J r ⊢ J' r) -> inf J ⊢ inf J'.
Proof. move=> D; apply: inf_right => r; apply: inf_left; by etransitivity. Qed.
Lemma inf_binder_bwd `{Proset X} {R} {J J' : R -> X} `{!DInfsOfShape R X}
  : (forall r, flip pro_le (J' r) (J r)) -> inf J ⊢ inf J'.
Proof. apply: inf_binder_fwd. Qed.
Lemma inf_binder `{Proset X} {R} {J J' : R -> X} `{!DInfsOfShape R X}
  : (forall r, J r ⟛ J' r) -> inf J ⟛ inf J'.
Proof. move=> D; split; apply: inf_binder_fwd; firstorder. Qed.
Lemma sup_binder_fwd `{Proset X} {R} {J J' : R -> X} `{!DSupsOfShape R X}
  : (forall r, J r ⊢ J' r) -> sup J ⊢ sup J'.
Proof. move=> D; apply: sup_left => r; apply: sup_right; by etransitivity. Qed.
Lemma sup_binder_bwd `{Proset X} {R} {J J' : R -> X} `{!DSupsOfShape R X}
  : (forall r, flip pro_le (J' r) (J r)) -> sup J ⊢ sup J'.
Proof. move=> /= D; apply: sup_left => r; apply: sup_right; by etransitivity. Qed.
Lemma sup_binder `{Proset X} {R} {J J' : R -> X} `{!DSupsOfShape R X}
  : (forall r, J r ⟛ J' r) -> sup J ⟛ sup J'.
Proof. move=> D; split; apply: sup_binder_fwd; firstorder. Qed.

(*
Instance proset_rewrite' `{Proset X} : RewriteRelation (flip (pro_le (X:=X))) := {}.
*)
Instance under_proper `{PreOrder A R} : Proper (R --> R ++> impl) (Under_rel A R).
Proof. rewrite Under_relE; firstorder. Qed.
Instance under_proper' `{PreOrder A R} : Proper (R ++> R --> flip impl) (Under_rel A R).
Proof. rewrite Under_relE; firstorder. Qed.

Lemma inf_unique `{Proset X} {R} {A} {J : R -> X} `{!HasInf J}
  : glb J A <-> A ⟛ inf J.
Proof.
  split.
  - move=> Glb; apply/(greatest_unique Glb (is_inf _)).
    (* TODO Why is rewrite hanging here?! *)
  - move=> E; apply/(greatest_proper _ _ proper_prf _ _ E); apply: is_inf.
Qed.
Lemma sup_unique `{Proset X} {R} {A} {J : R -> X} `{!HasSup J}
  : lub J A <-> A ⟛ sup J.
Proof.
  split.
  - move=> Lub; apply/(least_unique Lub (is_sup _)).
    (* TODO Why is rewrite hanging here?! *)
  - move=> E; apply/(least_proper _ _ proper_prf _ _ E); apply: is_sup.
Qed.
Lemma glb_alt `{Proset X} {R} {J : R -> X} {A}
  : glb J A <-> forall `{!Proper ((⟛) ==> iff) P}, P A <-> forall `{!HasInf J}, P (inf J).
Proof.
  split.
  - move=> Glb P ?; split.
    + move=> PA ?; rewrite (greatest_unique (is_inf _) Glb) //.
    + move=> /(_ {| is_inf := Glb |}) //.
  - move=> E; apply/E => ?; apply: is_inf.
Qed.
Lemma lub_alt `{Proset X} {R} {J : R -> X} {A}
  : lub J A <-> forall `{!Proper ((⟛) ==> iff) P}, P A <-> forall `{!HasSup J}, P (sup J).
Proof.
  split.
  - move=> Lub P ?; split.
    + move=> PA ?; rewrite (least_unique (is_sup _) Lub) //.
    + move=> /(_ {| is_sup := Lub |}) //.
  - move=> E; apply/E => ?; apply: is_sup.
Qed.
Lemma instantiate_inf `{Proset X, !Proper ((⟛) ==> iff) P} {R} {J : R -> X} `{!HasInf J}
  : (forall `{Has' : !HasInf J}, P (inf J (Has:=Has'))) <-> P (inf J).
Proof. symmetry; apply: (proj1 glb_alt (is_inf J)). Qed.
Lemma instantiate_sup `{Proset X, !Proper ((⟛) ==> iff) P} {R} {J : R -> X} `{!HasSup J}
  : (forall `{Has' : !HasSup J}, P (sup J (Has:=Has'))) <-> P (sup J).
Proof. symmetry; apply: (proj1 lub_alt (is_sup J)). Qed.

(*
Definition same_inf `{Proset X} {R} {J J' : R -> X} : HasInf J -> HasInf J' -> Prop
  := fun _ _ => inf J ⟛ inf J'.
Definition same_sup `{Proset X} {R} {J J' : R -> X} : HasSup J -> HasSup J' -> Prop
  := fun _ _ => sup J ⟛ sup J'.
Arguments same_inf {_ _ _ _ _ _} _ _ /.
Arguments same_sup {_ _ _ _ _ _} _ _ /.
Instance: Params (@same_inf) 6 := {}.
Instance: Params (@same_sup) 6 := {}.
Instance same_inf_equivalence `{Proset X} {R} {J : R -> X}
  : Equivalence (same_inf (J:=J) (J':=J)).
Proof. constructor=> ? //= *; by etransitivity. Qed.
Instance same_sup_equivalence `{Proset X} {R} {J : R -> X}
  : Equivalence (same_sup (J:=J) (J':=J)).
Proof. constructor=> ? //= *; by etransitivity. Qed.
Notation inf_proof_irrel := (Proper (same_inf ==> iff)).
Notation sup_proof_irrel := (Proper (same_sup ==> iff)).
Lemma same_inf_endo_total `{Proset X} {R} {J : R -> X} (Has Has' : HasInf J)
  : same_inf Has Has'.
Proof. apply: greatest_unique; apply: is_inf. Qed.
Lemma same_sup_endo_total `{Proset X} {R} {J : R -> X} (Has Has' : HasSup J)
  : same_sup Has Has'.
Proof. apply: least_unique; apply: is_sup. Qed.

Lemma ipi_alt `{Proset X} {R} {J : R -> X} (P : HasInf J -> Prop)
  : inf_proof_irrel P <-> (forall Has, all P <-> P Has).
Proof.
  split.
  - move=> IPI Has; split=> // P_Has Has'.
    rewrite (same_inf_endo_total Has' Has) //.
  - move=> E Has Has'.
    + done. move=> All.
Qed.

Lemma instantiate_inf' `{Proset X} {R} {J : R -> X} `{!HasInf J}
  : (forall `{Has' : !HasInf J}, P (inf J (Has:=Has'))) <-> P (inf J).
Proof. symmetry; apply: (proj1 glb_alt (is_inf J)). Qed.
*)

Program Instance pw_inf {X} `{Proset Y} {R} {J : R -> X -> Y} `{!forall x, HasInf (flip J x)}
  : HasInf J
  := {| inf x := inf (flip J x) |}.
Next Obligation.
  move=> X Y ? R J ?; split=> [r | F LB] A.
  - apply: inf_lb.
  - apply: inf_right; firstorder.
Qed.
Program Instance pw_sup {X} `{Proset Y} {R} {J : R -> X -> Y} `{!forall x, HasSup (flip J x)}
  : HasSup J
  := {| sup x := sup (flip J x) |}.
Next Obligation.
  move=> X Y ? R J ?; split=> [r | F UB] A.
  - apply: sup_ub.
  - apply: sup_left; firstorder.
Qed.
Program Instance op_inf `{Proset X} {R} {J : R -> op X} `{!HasSup (get_op ∘ J)}
  : HasInf J
  := {| inf := Op (sup (get_op ∘ J)) |}.
Next Obligation.
  move=> X ? R J ?; split=> [r | A LB] /=.
  (* TODO Work out better utilities for working with op. *)
  - rewrite op_def; by apply: (sup_right r).
  - apply: sup_left; firstorder.
Qed.
Program Instance op_sup `{Proset X} {R} {J : R -> op X} `{!HasInf (get_op ∘ J)}
  : HasSup J
  := {| sup := Op (inf (get_op ∘ J)) |}.
Next Obligation.
  move=> X ? R J ?; split=> [r | A UB] /=.
  - rewrite op_def; by apply: (inf_left r).
  - apply: inf_right; firstorder.
Qed.
Lemma curry_dep {A B} {P : A * B -> Prop} : (forall p, P p) <-> (forall a b, P (a, b)).
Proof. split=> [H a b | H [a b]] //. Qed.
Lemma uncurry_dep {A B} {P : A -> B -> Prop} : (forall a b, P a b) <-> (forall p, P p.1 p.2).
Proof. split=> [H p | H a b] //; apply: (H (a, b)). Qed.
Lemma prod_lb `{Proset X, Proset Y} {R} {p} {J : R -> X * Y}
  : lower_bound J p <-> lower_bound (fst ∘ J) p.1 /\ lower_bound (snd ∘ J) p.2.
Proof. firstorder. Qed.
Lemma prod_ub `{Proset X, Proset Y} {R} {J : R -> X * Y} {p}
  : upper_bound J p <-> upper_bound (fst ∘ J) p.1 /\ upper_bound (snd ∘ J) p.2.
Proof. firstorder. Qed.
Program Instance prod_inf `{Proset X, Proset Y} {R} {J : R -> X * Y}
        `{!HasInf (fst ∘ J), !HasInf (snd ∘ J)}
  : HasInf J
  := {| inf := (inf (fst ∘ J), inf (snd ∘ J)) |}.
Next Obligation.
  move=> ? ? ? ? ? ? ? J ? ?.
  rewrite /glb /greatest /pred_upper_bound curry_dep.
  setoid_rewrite (prod_lb (J:=J)); simpl; setoid_rewrite inf_universal; firstorder.
Qed.
Program Instance prod_sup `{Proset X, Proset Y} {R} {J : R -> X * Y}
        `{!HasSup (fst ∘ J), !HasSup (snd ∘ J)}
  : HasSup J
  := {| sup := (sup (fst ∘ J), sup (snd ∘ J)) |}.
Next Obligation.
  move=> ? ? ? ? ? ? ? J ? ?.
  rewrite /lub /least /pred_lower_bound curry_dep.
  setoid_rewrite (prod_ub (J:=J)); simpl; setoid_rewrite sup_universal; firstorder.
Qed.
(*
Lemma op_lb_ub `{Proset X} {R}
*)

Notation Top X := (DInfsOfShape void X).
Notation Bot X := (DSupsOfShape void X).
Notation BinMeets X := (DInfsOfShape bool X).
Notation BinJoins X := (DSupsOfShape bool X).
Definition top (X : Type) `{Proset X, !Top X} : X :=
  inf (of_void _).
Definition bot (X : Type) `{Proset X, !Bot X} : X :=
  sup (of_void _).
Notation "⊤" := (top _) : proset_scope.
Notation "⊥" := (bot _) : proset_scope.
Notation bool_e A B := (fun b : bool => if b then A else B).
Definition meet `{Proset X, !BinMeets X} (A B : X) : X :=
  inf (bool_e A B).
Definition join `{Proset X, !BinJoins X} (A B : X) : X :=
  sup (bool_e A B).
Infix "⩕" := meet (at level 40, left associativity) : proset_scope.
Infix "⩖" := join (at level 40, left associativity) : proset_scope.
(* TODO This type could technically be less strict... *)
Definition embed_prop `{Proset X, !SupLattice X, !Top X} (P : Prop) : X := Sup H : P, ⊤.
Notation "⌜ P ⌝" := (embed_prop P) : proset_scope.
Arguments top : simpl never.
Arguments bot : simpl never.
Arguments meet : simpl never.
Arguments join : simpl never.
Arguments embed_prop : simpl never.
Instance: Params (@top) 4 := {}.
Instance: Params (@bot) 4 := {}.
Instance: Params (@meet) 4 := {}.
Instance: Params (@join) 4 := {}.
Instance: Params (@embed_prop) 5 := {}.

Lemma all_void (J : void -> Prop) : (forall v, J v) <-> True.
Proof. done. Qed.
Lemma ex_void (J : void -> Prop) : (exists v, J v) <-> False.
Proof. split=> -[] //. Qed.
Lemma all_bool (J : bool -> Prop) : (forall b, J b) <-> J true /\ J false.
Proof. split=> // -[? ?] [] //. Qed.
Lemma ex_bool (J : bool -> Prop) : (exists b, J b) <-> J true \/ J false.
Proof. split=> [[[]] |]; firstorder. Qed.
(* Hint Resolve *)

Definition top_right `{Proset X, !Top X} {A : X} : A ⊢ ⊤ :=
  inf_right (Empty_set_ind _).
Definition bot_left `{Proset X, !Bot X} {A : X} : ⊥ ⊢ A :=
  sup_left (Empty_set_ind _).
Definition meet_proj1 `{Proset X, !BinMeets X} {A B : X} : A ⩕ B ⊢ A
  := inf_lb true.
Definition meet_proj2 `{Proset X, !BinMeets X} {A B : X} : A ⩕ B ⊢ B
  := inf_lb false.
Definition meet_left1 `{Proset X, !BinMeets X} {A B C : X} : A ⊢ C -> A ⩕ B ⊢ C
  := transitivity meet_proj1.
Definition meet_left2 `{Proset X, !BinMeets X} {A B C : X} : B ⊢ C -> A ⩕ B ⊢ C
  := transitivity meet_proj2.
Definition meet_right `{Proset X, !BinMeets X} {C A B : X} (D1 : C ⊢ A) (D2 : C ⊢ B)
  : C ⊢ A ⩕ B
  := inf_right (fun b => if b as b0 return C ⊢ (if b0 then A else B) then D1 else D2).
Definition join_inj1 `{Proset X, !BinJoins X} {A B : X} : A ⊢ A ⩖ B
  := sup_ub true.
Definition join_inj2 `{Proset X, !BinJoins X} {A B : X} : B ⊢ A ⩖ B
  := sup_ub false.
Definition join_right1 `{Proset X, !BinJoins X} {C A B : X} : C ⊢ A -> C ⊢ A ⩖ B
  := fun H => transitivity H join_inj1.
Definition join_right2 `{Proset X, !BinJoins X} {C A B : X} : C ⊢ B -> C ⊢ A ⩖ B
  := fun H => transitivity H join_inj2.
Definition join_left `{Proset X, !BinJoins X} {A B C : X} (D1 : A ⊢ C) (D2 : B ⊢ C)
  : A ⩖ B ⊢ C
  := sup_left (fun b => if b as b0 return (if b0 then A else B) ⊢ C then D1 else D2).
Lemma embed_prop_left `{Proset X, !SupLattice X, !Top X} {P : Prop} {Q : X}
  : (P -> ⊤ ⊢ Q) -> ⌜ P ⌝ ⊢ Q.
Proof. move=> D; by apply: sup_left. Qed.
Lemma embed_prop_right `{Proset X, !SupLattice X, !Top X} {P : X} {Q : Prop}
  : Q -> P ⊢ ⌜ Q ⌝.
Proof. move=> *; apply: sup_right; apply: top_right. Qed.
Instance meet_bi `{Proset X, !BinMeets X} : Bimonotone (meet (X:=X)).
Proof.
  move=> A A' B B' D1 D2; apply: meet_right.
  + by apply: meet_left1.
  + by apply: meet_left2.
Qed.
Instance join_bi `{Proset X, !BinJoins X} : Bimonotone (join (X:=X)).
Proof.
  move=> A A' B B' D1 D2; apply: join_left.
  + by apply: join_right1.
  + by apply: join_right2.
Qed.
Instance embed_prop_mono `{Proset X, !SupLattice X, !Top X} : Monotone (embed_prop (X:=X)).
Proof. move=> P Q D; apply: embed_prop_left => ?; by apply embed_prop_right, D. Qed.

(* TODO Fiddle with instance resolution order or maybe make lattice operation
        classes to be certain? *)
Program Instance prop_inflattice {R} {J : R -> Prop} : HasInf J := {| inf := all J |}.
Next Obligation. firstorder. Qed.
Program Instance prop_suplattice {R} {J : R -> Prop} : HasSup J := {| sup := ex J |}.
Next Obligation. firstorder. Qed.
Program Instance prop_top : Top Prop := fun J => {| inf := True |}.
Next Obligation. firstorder contradiction. Qed.
Program Instance prop_bot : Bot Prop := fun J => {| sup := False |}.
Next Obligation. firstorder contradiction. Qed.
Program Instance prop_meet : BinMeets Prop := fun J => {| inf := J true /\ J false |}.
Next Obligation. firstorder using all_bool. Qed.
Program Instance prop_join : BinJoins Prop := fun J => {| sup := J true \/ J false |}.
Next Obligation. firstorder using ex_bool. Qed.
Lemma prop_embed_prop (P : Prop) : ⌜ P ⌝ ⟛ P.
Proof. compute; dintuition. Qed.

Class MeetSemilattice (X : Type) `{Proset X, !Top X, !BinMeets X}.
Hint Mode MeetSemilattice ! - - - - : typeclass_instances.
Instance meet_semilattice_def `{Proset X, !Top X, !BinMeets X}
  : MeetSemilattice X := {}.
Class JoinSemilattice (X : Type) `{Proset X, !Bot X, !BinJoins X}.
Hint Mode JoinSemilattice ! - - - - : typeclass_instances.
Instance join_semilattice_def `{Proset X, !Bot X, !BinJoins X}
  : JoinSemilattice X := {}.
Class Lattice (X : Type) `{Proset X, !Top X, !Bot X, !BinMeets X, !BinJoins X}.
Hint Mode Lattice ! - - - - - - : typeclass_instances.
Instance lattice_def `{Proset X, !Top X, !Bot X, !BinMeets X, !BinJoins X}
  : Lattice X := {}.

Program Definition mk_top `{Proset X} (t : X) (t_top : forall A, A ⊢ t) : Top X
  := fun J => {| inf := t |}.
Next Obligation. by compute. Qed.
Program Definition mk_bot `{Proset X} (b : X) (t_top : forall A, b ⊢ A) : Bot X
  := fun J => {| sup := b |}.
Next Obligation. by compute. Qed.
Program Definition mk_binmeets `{Proset X} (m : X -> X -> X)
        (m_meet : forall A B C, C ⊢ m A B <-> C ⊢ A /\ C ⊢ B) : BinMeets X
  := fun J => {| inf := m (J true) (J false) |}.
Next Obligation. move=>> H J. split; [by apply/all_bool/H | firstorder]. Qed.
Program Definition mk_binjoins `{Proset X} (j : X -> X -> X)
        (j_join : forall A B C, j A B ⊢ C <-> A ⊢ C /\ B ⊢ C) : BinJoins X
  := fun J => {| sup := j (J true) (J false) |}.
Next Obligation. move=>> H J. split; [by apply/all_bool/H | firstorder]. Qed.

(*
Definition mk_lattice `{Proset X} (t b : X) (m j : X -> X -> X)
        (t_top : forall A, A ⊢ t) (b_bot : forall A, b ⊢ A)
        (m_meet : forall A B C, C ⊢ m A B <-> C ⊢ A /\ C ⊢ B)
        (j_join : forall A B C, j A B ⊢ C <-> A ⊢ C /\ B ⊢ C)
  : PackedLattice X
  := PackLattice (mk_top t t_top) (mk_bot b b_bot)
                 (mk_binmeets m m_meet) (mk_binjoins j j_join).
*)

(* TODO Figure out if there's a way to get this to resolve reasonably as an instance. *)
Program Definition unbias_meets `{MeetSemilattice X, Finite R} : DInfsOfShape R X
  := fun J => {| inf := foldr meet ⊤ (map J (enum R)) |}.
Next Obligation.
  move=> X ? ? ? ? ? R ? ? J.
  rewrite /glb /greatest /pred_upper_bound /lower_bound; setoid_rewrite <- Forall_finite.
  elim: (enum R) => /= [| r rs [IH1 IH2]]; split.
  - done.
  - move=> *; apply: top_right.
  - constructor.
    + apply: meet_proj1.
    + apply: Forall_impl IH1 (fun _ => meet_left2).
  - move=> B /Forall_cons [? /IH2 ?]; by apply: meet_right.
Qed.
Program Definition unbias_joins `{JoinSemilattice X, Finite R} : DSupsOfShape R X
  := fun J => {| sup := foldr join ⊥ (map J (enum R)) |}.
Next Obligation.
  move=> X ? ? ? ? ? R ? ? J.
  rewrite /lub /least /pred_lower_bound /upper_bound; setoid_rewrite <- Forall_finite.
  elim: (enum R) => /= [| r rs [IH1 IH2]]; split.
  - done.
  - move=> *; apply: bot_left.
  - constructor.
    + apply: join_inj1.
    + apply: Forall_impl IH1 (fun _ => join_right2).
  - move=> B /Forall_cons [? /IH2 ?]; by apply: join_left.
Qed.

Class Directed (X : Type) `{Proset X} :=
  {direct `{Finite R} (J : R -> X) : X;
   direct_is_ub `{Finite R} (J : R -> X) : upper_bound J (direct J)}.
Hint Mode Directed ! - - : typeclass_instances.
Class Codirected (X : Type) `{Proset X} :=
  {codirect `{Finite R} (J : R -> X) : X;
   codirect_is_lb `{Finite R} (J : R -> X) : lower_bound J (codirect J)}.
Hint Mode Codirected ! - - : typeclass_instances.
Instance join_semilattice_directed `{JoinSemilattice X}
  : Directed X
  := let Has := @unbias_joins in
     {| direct R _ _ J := sup J; direct_is_ub R _ _ J := sup_ub |}.
Instance meet_semilattice_codirected `{MeetSemilattice X}
  : Codirected X
  := let Has := @unbias_meets in
     {| codirect R _ _ J := inf J; codirect_is_lb R _ _ J := inf_lb |}.
Program Instance op_directed `{Codirected T} : Directed (op T)
  := {| direct R _ _ J := codirect (get_op ∘ J);
        direct_is_ub R _ _ J := codirect_is_lb J |}.
Program Instance op_codirected `{Directed T} : Codirected (op T)
  := {| codirect R _ _ J := direct (get_op ∘ J);
        codirect_is_lb R _ _ J := direct_is_ub J |}.
Notation DirectedComplete X := (forall `{Proset R}, Directed R -> SupsOfShape R X).

Program Instance nat_bot : Bot nat := mk_bot 0 _.
Next Obligation. compute; dintuition. Qed.
Instance nat_binmeets : BinMeets nat := mk_binmeets min Nat.min_glb_iff.
Instance nat_binjoins : BinJoins nat := mk_binjoins max Nat.max_lub_iff.

Program Instance bool_top : Top bool := mk_top true _.
Program Instance bool_bot : Bot bool := mk_bot false _.
Program Instance bool_binmeets : BinMeets bool := mk_binmeets andb _.
Program Instance bool_binjoins : BinJoins bool := mk_binjoins orb _.
Solve All Obligations with repeat case; compute; tauto.

Class PreservesInf `{Proset X, Proset Y} {R} (F : X -> Y) (J : R -> X) :=
  preserve_inf A : glb J A -> glb (F ∘ J) (F A).
Class PreservesSup `{Proset X, Proset Y} {R} (F : X -> Y) (J : R -> X) :=
  preserve_sup A : lub J A -> lub (F ∘ J) (F A).
Hint Mode PreservesInf ! - - ! - - ! ! ! : typeclass_instances.
Hint Mode PreservesSup ! - - ! - - ! ! ! : typeclass_instances.
Lemma distrib_inf `{Proset X, Proset Y} {R} (J : R -> X)
      {F : X -> Y} `{!PreservesInf F J} `{!HasInf J, !HasInf (F ∘ J)}
  : F (Inf r, J r) ⟛ Inf r, F (J r).
Proof. apply/inf_unique/preserve_inf/is_inf. Qed.
Lemma distrib_sup `{Proset X, Proset Y} {R} (J : R -> X)
      {F : X -> Y} `{!PreservesSup F J} `{!HasSup J, !HasSup (F ∘ J)}
  : F (Sup r, J r) ⟛ Sup r, F (J r).
Proof. apply/sup_unique/preserve_sup/is_sup. Qed.
Definition preserves_inf_img `{Proset X, Proset Y} (F : X -> Y)
           {R} (J : R -> X) `{!HasInf J, !PreservesInf F J}
  : HasInf (F ∘ J)
  := {| inf := F (inf J); is_inf := preserve_inf (inf J) (is_inf J) |}.
Definition preserves_sup_img `{Proset X, Proset Y} (F : X -> Y)
           {R} (J : R -> X) `{!HasSup J, !PreservesSup F J}
  : HasSup (F ∘ J)
  := {| sup := F (sup J); is_sup := preserve_sup (sup J) (is_sup J) |}.
Lemma distrib_inf' `{Proset X, Proset Y} {R} (J : R -> X)
      {F : X -> Y} `{!PreservesInf F J} `{!HasInf J}
  : F (Inf r, J r) ⟛ @inf _ _ _ _ (fun r => F (J r)) (preserves_inf_img F J).
Proof. apply/inf_unique/preserve_inf/is_inf. Qed.
Lemma distrib_sup' `{Proset X, Proset Y} {R} (J : R -> X)
      {F : X -> Y} `{!PreservesSup F J} `{!HasSup J}
  : F (Sup r, J r) ⟛ @sup _ _ _ _ (fun r => F (J r)) (preserves_sup_img F J).
Proof. apply/sup_unique/preserve_sup/is_sup. Qed.

Lemma preserves_inf_alt `{Proset X, Proset Y} {R} {F : X -> Y} {J : R -> X}
      `{!Monotone F}
  : PreservesInf F J <-> forall `{!HasInf J}, glb (F ∘ J) (F (inf J)).
Proof.
  split.
  - move=> ? ?; apply/preserve_inf/is_inf.
  - move=> GlbF A Glb; apply: (GlbF {| is_inf := Glb |}).
Qed.
Lemma preserves_sup_alt `{Proset X, Proset Y} {R} {F : X -> Y} {J : R -> X}
      `{!Monotone F}
  : PreservesSup F J <-> forall `{!HasSup J}, lub (F ∘ J) (F (sup J)).
Proof.
  split.
  - move=> ? ?; apply/preserve_sup/is_sup.
  - move=> LubF A Lub; apply: (LubF {| is_sup := Lub |}).
Qed.
Lemma preserves_inf_alt2 `{Proset X, Proset Y} {R} {F : X -> Y} {J : R -> X}
      `{!Monotone F, !HasInf J}
  : PreservesInf F J <-> glb (F ∘ J) (F (inf J)).
Proof.
  split.
  - move=> ?; apply/preserve_inf/is_inf.
  - move=> Glb A /inf_unique E.
      by apply/(greatest_proper _ _ proper_prf); first rewrite E.
Qed.
Lemma preserves_sup_alt2 `{Proset X, Proset Y} {R} {F : X -> Y} {J : R -> X}
      `{!Monotone F, !HasSup J}
  : PreservesSup F J <-> lub (F ∘ J) (F (sup J)).
Proof.
  split.
  - move=> ?; apply/preserve_sup/is_sup.
  - move=> Lub A /sup_unique E.
      by apply/(least_proper _ _ proper_prf); first rewrite E.
Qed.
Lemma preserves_inf_alt3 `{Proset X, Proset Y} {R} {F : X -> Y} {J : R -> X}
      `{!Monotone F, !HasInf J, !HasInf (F ∘ J)}
  : PreservesInf F J <-> F (Inf r, J r) ⟛ Inf r, F (J r).
Proof. rewrite preserves_inf_alt2; apply: inf_unique. Qed.
Lemma preserves_sup_alt3 `{Proset X, Proset Y} {R} {F : X -> Y} {J : R -> X}
      `{!Monotone F, !HasSup J, !HasSup (F ∘ J)}
  : PreservesSup F J <-> F (Sup r, J r) ⟛ Sup r, F (J r).
Proof. rewrite preserves_sup_alt2; apply: sup_unique. Qed.
Lemma preserves_inf_alt4 `{Proset X, Proset Y} {R} {F : X -> Y} {J : R -> X}
      `{!Monotone F, !HasInf (F ∘ J)}
  : PreservesInf F J <-> forall `{!HasInf J}, F (Inf r, J r) ⟛ Inf r, F (J r).
Proof. rewrite preserves_inf_alt. apply: forall_proper => ?. apply: inf_unique. Qed.
Lemma preserves_sup_alt4 `{Proset X, Proset Y} {R} {F : X -> Y} {J : R -> X}
      `{!Monotone F, !HasSup (F ∘ J)}
  : PreservesSup F J <-> forall `{!HasSup J}, F (Sup r, J r) ⟛ Sup r, F (J r).
Proof. rewrite preserves_sup_alt. apply: forall_proper => ?. apply: sup_unique. Qed.

Notation PresInfsOfShape R F := (forall J, Monotone J -> PreservesInf (R:=R) F J).
Notation PresSupsOfShape R F := (forall J, Monotone J -> PreservesSup (R:=R) F J).
Notation PresDInfsOfShape R F := (forall J, PreservesInf (R:=R) F J).
Notation PresDSupsOfShape R F := (forall J, PreservesSup (R:=R) F J).
Notation Continuous F := (forall R, PresDInfsOfShape R F).
Notation Cocontinuous F := (forall R, PresDSupsOfShape R F).
Notation Lex F := (forall `{H : EqDecision R}, @Finite R H -> PresDInfsOfShape R F).
Notation Rex F := (forall `{H : EqDecision R}, @Finite R H -> PresDSupsOfShape R F).
Notation ScottContinuous F :=
  (forall `{H0 : Le R, H : @Proset R H0}, @Directed R H0 H -> PresSupsOfShape R F).

Lemma F_inf `{Proset X, Proset Y} {R} {F : X -> Y} {J : R -> X}
      `{!Monotone F, !HasInf J, !HasInf (F ∘ J)}
  : F (Inf r, J r) ⊢ Inf r, F (J r).
Proof. apply: inf_right => r; apply: mono; apply: inf_lb. Qed.
Lemma F_sup `{Proset X, Proset Y} {R} {F : X -> Y} {J : R -> X}
      `{!Monotone F, !HasSup J, !HasSup (F ∘ J)}
  : (Sup r, F (J r)) ⊢ F (Sup r, J r).
Proof. apply: sup_left => r; apply: mono; apply: sup_ub. Qed.
Lemma distrib_inf_sufficient `{Proset X, Proset Y} {R} (J : R -> X)
      {F : X -> Y} `{!Monotone F, !HasInf J, !HasInf (F ∘ J)}
  : (Inf r, F (J r)) ⊢ F (Inf r, J r) -> PreservesInf F J.
Proof. move=> Distr; apply/preserves_inf_alt3; split; [apply: F_inf | apply: Distr]. Qed.
Lemma distrib_sup_sufficient `{Proset X, Proset Y} {R} (J : R -> X)
      {F : X -> Y} `{!Monotone F, !HasSup J, !HasSup (F ∘ J)}
  : F (Sup r, J r) ⊢ (Sup r, F (J r)) -> PreservesSup F J.
Proof. move=> Distr; apply/preserves_sup_alt3; split; [apply: Distr | apply: F_sup]. Qed.

Lemma void_diagram_eta `{Proset X} (J : void -> X)
  : J ⟛ of_void _.
Proof. apply/pw_core' => -[]. Qed.
Lemma bool_diagram_eta `{Proset X} (J : bool -> X)
  : J ⟛ bool_e (J true) (J false).
Proof. apply/pw_core' => -[] //. Qed.
Lemma bool_interval `{Proset X} (J : bool -> X)
  : Monotone J <-> J false ⊢ J true.
Proof. compute. rewrite !all_bool. firstorder. Qed.
Lemma bool_interval' `{Proset X} (A B : X)
  : A ⊢ B <-> Monotone (bool_e B A).
Proof. symmetry; apply: bool_interval. Qed.
Program Instance interval_inf `{Proset X} : InfsOfShape bool X
  := fun J _ => {| inf := J false |}.
Next Obligation. move=> X ? ? J /bool_interval D; split=> [[] | A] //. Qed.
Program Instance interval_sup `{Proset X} : SupsOfShape bool X
  := fun J _ => {| sup := J true |}.
Next Obligation. move=> X ? ? J /bool_interval D; split=> [[] | A] //. Qed.
Lemma mono_as_pres_infs `{Proset X, Proset Y} {F : X -> Y}
  : Monotone F <-> PresInfsOfShape bool F.
Proof.
  split.
  - move=> ? J ?; by apply: distrib_inf_sufficient.
  - move=> Pres A B /bool_interval'; set J := bool_e B A => ?.
    change A with (inf J); rewrite distrib_inf' (inf_lb true) //.
Qed.
Lemma mono_as_pres_sups `{Proset X, Proset Y} {F : X -> Y}
  : Monotone F <-> PresSupsOfShape bool F.
Proof.
  split.
  - move=> ? J ?; by apply: distrib_sup_sufficient.
  - move=> Pres A B /bool_interval'; set J := bool_e B A => ?.
    change B with (sup J); rewrite -(proj2 (distrib_sup' _)) -(sup_ub false) //.
Qed.

(* TODO Non-on-the-nose surjectivity *)
Lemma reindex_glb `{Proset X} {R R'} (re : R -> R') `{!Surj (=) re} {J : R' -> X} {A}
  : glb J A -> glb (J ∘ re) A.
Proof.
  move=> [LB Uni]; split.
  - firstorder.
  - move=> A' LB'; apply: Uni => r'.
    case: (surj re r') => r <-; apply: LB'.
Qed.
Lemma reindex_lub `{Proset X} {R R'} (re : R -> R') `{!Surj (=) re} {J : R' -> X} {A}
  : lub J A -> lub (J ∘ re) A.
Proof.
  move=> [UB Uni]; split.
  - firstorder.
  - move=> A' UB'; apply: Uni => r'.
    case: (surj re r') => r <-; apply: UB'.
Qed.
Lemma unreindex_glb `{Proset X} {R R'} (re : R -> R') `{!Surj (=) re} {J : R' -> X} {A}
  : glb (J ∘ re) A -> glb J A.
Proof.
  move=> [LB Uni]; split.
  - move=> r'.
    case: (surj re r') => r <-; apply: LB.
  - firstorder.
Qed.
Lemma unreindex_lub `{Proset X} {R R'} (re : R -> R') `{!Surj (=) re} {J : R' -> X} {A}
  : lub (J ∘ re) A -> lub J A.
Proof.
  move=> [UB Uni]; split.
  - move=> r'.
    case: (surj re r') => r <-; apply: UB.
  - firstorder.
Qed.
Lemma reindex_inf `{Proset X} {R R'} (re : R -> R') `{!Surj (=) re} {J : R' -> X}
      `{!HasInf J, !HasInf (J ∘ re)}
  : inf J ⟛ inf (J ∘ re).
Proof. apply/inf_unique/reindex_glb/is_inf. Qed.
Lemma reindex_sup `{Proset X} {R R'} (re : R -> R') `{!Surj (=) re} {J : R' -> X}
      `{!HasSup J, !HasSup (J ∘ re)}
  : sup J ⟛ sup (J ∘ re).
Proof. apply/sup_unique/reindex_lub/is_sup. Qed.

(* A number of continuity results are over in adjunction.v, because they drop out
   for free from adjunctions that we were proving anyway. *)
Instance id_continuous `{Proset X} : Continuous (@id X).
Proof. firstorder. Qed.
Instance id_cocontinuous `{Proset X} : Cocontinuous (@id X).
Proof. firstorder. Qed.
Instance compose_preserves_inf `{Proset X, Proset Y, Proset Z'} {F : Y -> Z'} {G : X -> Y}
         {R} {J : R -> X}
         `{!Monotone F, !Monotone G, !PreservesInf G J, !PreservesInf F (G ∘ J)}
  : PreservesInf (F ∘ G) J | 0.
Proof. firstorder. Qed.
Instance compose_preserves_sup `{Proset X, Proset Y, Proset Z'} {F : Y -> Z'} {G : X -> Y}
         {R} {J : R -> X}
         `{!Monotone F, !Monotone G, !PreservesSup G J, !PreservesSup F (G ∘ J)}
  : PreservesSup (F ∘ G) J | 0.
Proof. firstorder. Qed.

(*
Instance compose_continuous `{Proset X, Proset Y, Proset Z'} {F : Y -> Z'} {G : X -> Y}
         `{!Monotone F, !Monotone G, !Continuous F, !Continuous G}
  : Continuous (F ∘ G) | 0.
Proof. typeclasses eauto. Qed.
*)
Instance precomp_pres_infs {R X X'} `{Proset Y, !DInfsOfShape R Y} {f : X' -> X}
  : PresDInfsOfShape R (fun g : X -> Y => g ∘ f).
Proof. move=> ? ?; by apply/distrib_inf_sufficient. Qed.
Instance precomp_pres_sups {R X X'} `{Proset Y, !DSupsOfShape R Y} {f : X' -> X}
  : PresDSupsOfShape R (fun g : X -> Y => g ∘ f).
Proof. move=> ? ?; by apply/distrib_sup_sufficient. Qed.
Instance eval_at_pres_infs {R X} `{Proset Y, !DInfsOfShape R Y} {x : X}
  : PresDInfsOfShape R (eval_at (Y:=Y) x).
Proof. move=> ? ?; by apply/distrib_inf_sufficient. Qed.
Instance eval_at_pres_sups {R X} `{Proset Y, !DSupsOfShape R Y} {x : X}
  : PresDSupsOfShape R (eval_at (Y:=Y) x).
Proof. move=> ? ?; by apply/distrib_sup_sufficient. Qed.

Lemma distrib_top `{Proset X, Proset Y, !Top X, !Top Y} {F : X -> Y}
      `{!PresDInfsOfShape void F}
  : F ⊤ ⟛ ⊤.
Proof. rewrite distrib_inf; by apply: (mono_core einf); apply/pw_core'. Qed.
Lemma distrib_bot `{Proset X, Proset Y, !Bot X, !Bot Y} {F : X -> Y}
      `{!PresDSupsOfShape void F}
  : F ⊥ ⟛ ⊥.
Proof. rewrite distrib_sup; by apply: (mono_core esup); apply/pw_core'. Qed.
Lemma distrib_meet `{Proset X, Proset Y, !BinMeets X, !BinMeets Y}
      {F : X -> Y} `{!PresDInfsOfShape bool F} {A B}
  : F (A ⩕ B) ⟛ F A ⩕ F B.
Proof. rewrite distrib_inf. by under inf_binder do rewrite fun_if. Qed.
Lemma distrib_join `{Proset X, Proset Y, !BinJoins X, !BinJoins Y}
      {F : X -> Y} `{!PresDSupsOfShape bool F} {A B}
  : F (A ⩖ B) ⟛ F A ⩖ F B.
Proof. rewrite distrib_sup. by under sup_binder do rewrite fun_if. Qed.
Lemma distrib_embed_prop `{Proset X, !SupLattice X, !Top X,
                           Proset Y, !SupLattice Y, !Top Y} {F : X -> Y}
      {P : Prop} `{!PresDInfsOfShape void F, !PresDSupsOfShape P F}
  : F (⌜ P ⌝) ⟛ ⌜ P ⌝.
Proof. rewrite distrib_sup. by under sup_binder do rewrite distrib_top. Qed.

Lemma F_top `{Proset X, Proset Y, !Top X, !Top Y} {F : X -> Y}
  : F ⊤ ⊢ ⊤.
Proof. apply: top_right. Qed.
Lemma F_bot `{Proset X, Proset Y, !Bot X, !Bot Y} {F : X -> Y}
  : ⊥ ⊢ F ⊥.
Proof. apply: bot_left. Qed.
Lemma F_meet `{Proset X, Proset Y, !BinMeets X, !BinMeets Y}
      {F : X -> Y} `{!Monotone F} {A B}
  : F (A ⩕ B) ⊢ F A ⩕ F B.
Proof. apply: meet_right; [rewrite meet_proj1 // | rewrite meet_proj2 //]. Qed.
Lemma F_join `{Proset X, Proset Y, !BinJoins X, !BinJoins Y}
      {F : X -> Y} `{!Monotone F} {A B}
  : F A ⩖ F B ⊢ F (A ⩖ B).
Proof. apply: join_left; [rewrite -join_inj1 // | rewrite -join_inj2 //]. Qed.
Lemma F_embed_prop `{Proset X, !SupLattice X, !Top X,
                     Proset Y, !SupLattice Y, !Top Y} {F : X -> Y}
      `{!Monotone F, !PresDInfsOfShape void F} {P}
  : ⌜ P ⌝ ⊢ F (⌜ P ⌝).
Proof.
  apply: embed_prop_left => H_P.
  rewrite /embed_prop -(sup_ub H_P) -(proj2 distrib_top) //.
Qed.

Lemma lex_alt `{MeetSemilattice X, Proset Y} (F : X -> Y) `{!Monotone F}
  : PresDInfsOfShape void F -> PresDInfsOfShape bool F -> Lex F.
Proof.
  set Has := @unbias_meets.
  move=> Base Step.
  enough (forall n, PresDInfsOfShape (fin n) F). {
    move=> R ? ? J A.
    have ? : Surj (=) (decode_fin (A:=R)) by apply/cancel_surj/decode_encode_fin.
    move=> /(reindex_glb decode_fin) /(preserve_inf (F:=F) A).
    apply: unreindex_glb.
  }
  elim=> [| n IH] J; apply/preserves_inf_alt2.
  - have ? : Surj (=) (of_void (fin 0)) by move=> x; case: (Fin.case0 (const False) x).
    rewrite reindex_inf distrib_inf'; apply/(unreindex_glb (of_void _))/is_inf.
  - split=> [? | B LB]; first by rewrite inf_lb /=.
    rewrite (_ : inf J ⟛ J Fin.F1 ⩕ inf (J ∘ FS)).
    + rewrite distrib_inf'; apply: inf_right => -[]; first by apply: LB.
      rewrite distrib_inf'; apply: inf_right => ?; apply: LB.
    + split; first apply: meet_right.
      * apply: inf_lb.
      * apply: inf_right => ?; apply: inf_lb.
      * apply: inf_right => r; elim/(Fin.caseS' (n:=n)): r => [| r].
        -- apply: meet_proj1.
        -- apply: meet_left2; apply: inf_lb.
Qed.
Lemma rex_alt `{JoinSemilattice X, Proset Y} (F : X -> Y) `{!Monotone F}
  : PresDSupsOfShape void F -> PresDSupsOfShape bool F -> Rex F.
Proof.
  set Has := @unbias_joins.
  move=> Base Step.
  enough (forall n, PresDSupsOfShape (fin n) F). {
    move=> R ? ? J A.
    have ? : Surj (=) (decode_fin (A:=R)) by apply/cancel_surj/decode_encode_fin.
    move=> /(reindex_lub decode_fin) /(preserve_sup (F:=F) A).
    apply: unreindex_lub.
  }
  elim=> [| n IH] J; apply/preserves_sup_alt2.
  - have ? : Surj (=) (of_void (fin 0)) by move=> x; case: (Fin.case0 (const False) x).
    rewrite reindex_sup distrib_sup'; apply/(unreindex_lub (of_void _))/is_sup.
  - split=> [? | B UB]; first by rewrite -sup_ub /=.
    rewrite (_ : sup J ⟛ J Fin.F1 ⩖ sup (J ∘ FS)).
    + rewrite distrib_sup'; apply: sup_left => -[]; first by apply: UB.
      rewrite distrib_sup'; apply: sup_left => ?; apply: UB.
    + split; last apply: join_left.
      * apply: sup_left => r; elim/(Fin.caseS' (n:=n)): r => [| r].
        -- apply: join_inj1.
        -- apply: join_right2; apply: sup_ub.
      * apply: sup_ub.
      * apply: sup_left => ?; apply: sup_ub.
Qed.
Lemma lex_alt' `{MeetSemilattice X, MeetSemilattice Y} (F : X -> Y) `{!Monotone F}
  : ⊤ ⊢ F ⊤ -> (forall A B, F A ⩕ F B ⊢ F (A ⩕ B)) -> Lex F.
Proof.
  move=> PresTop PresBin; apply: lex_alt => J; apply: distrib_inf_sufficient.
  - rewrite -!/(einf _) [J in einf J]void_diagram_eta
      [J in F (einf J)]void_diagram_eta.
    apply: PresTop.
  - rewrite -!/(einf _) [J in einf J]bool_diagram_eta
      [J in F (einf J)]bool_diagram_eta.
    apply: PresBin.
Qed.
Lemma rex_alt' `{JoinSemilattice X, JoinSemilattice Y} (F : X -> Y) `{!Monotone F}
  : F ⊥ ⊢ ⊥ -> (forall A B, F (A ⩖ B) ⊢ F A ⩖ F B) -> Rex F.
Proof.
  move=> PresBot PresBin; apply: rex_alt => J; apply: distrib_sup_sufficient.
  - rewrite -!/(esup _) [J in esup J]void_diagram_eta
      [J in _ ⊢ esup J]void_diagram_eta.
    apply: PresBot.
  - rewrite -!/(esup _) [J in esup J]bool_diagram_eta
      [J in _ ⊢ esup J]bool_diagram_eta.
    apply: PresBin.
Qed.

Program Instance Hom_inf `{Proset X, Proset Y} {R} {J : R -> Hom X Y}
        `{!forall x, HasInf (flip J x)}
  : HasInf J
  := {| inf := inf (ap_Hom ∘ J) ↾ _ |}.
Next Obligation.
  move=> X ? ? Y ? ? R J ? A B D /=.
  apply: inf_right => r; apply: (inf_left r) => /=; by apply: Hom_mono.
Qed.
Next Obligation.
  move=> X ? ? Y ? ? R J ? /=; split=> [r | A' LB] A /=.
  - apply: (inf_lb r).
  - apply: inf_right => r; apply: LB.
Qed.
Program Instance Hom_sup `{Proset X, Proset Y} {R} {J : R -> Hom X Y}
        `{!forall x, HasSup (flip J x)}
  : HasSup J
  := {| sup := sup (ap_Hom ∘ J) ↾ _ |}.
Next Obligation.
  move=> X ? ? Y ? ? R J ? A B D /=.
  apply: sup_left => r; apply: (sup_right r) => /=; by apply: Hom_mono.
Qed.
Next Obligation.
  move=> X ? ? Y ? ? R J ? /=; split=> [r | A' UB] A /=.
  - apply: (sup_ub r).
  - apply: sup_left => r; apply: UB.
Qed.
(* TODO Make some of the subsequent stuff more fine-grained. *)
Instance ap_Hom_complete_continuous `{Proset X, Complete Y}
  : Continuous (ap_Hom (X:=X) (Y:=Y)).
Proof. move=> ? ?; by apply/distrib_inf_sufficient. Qed.
Instance ap_Hom_complete_cocontinuous `{Proset X, Complete Y}
  : Cocontinuous (ap_Hom (X:=X) (Y:=Y)).
Proof. move=> ? ?; by apply/distrib_sup_sufficient. Qed.
(* Hmm. *)
Instance flip_functoriality {R} `{Proset Y, Proset X}
         {F : R -> Y -> X} `{!forall r, Monotone (F r)}
  : Monotone (flip F).
Proof. firstorder. Qed.
Lemma Hom_inf_ `{Proset X, Complete Y} {R} (J : R -> Hom X Y)
  : inf J ⟛ in_Hom (einf ∘ flip J).
Proof. generalize dependent X; generalize dependent Y; by compute. Qed.
Lemma Hom_sup_ `{Proset X, Complete Y} {R} (J : R -> Hom X Y)
  : sup J ⟛ in_Hom (esup ∘ flip J).
Proof. generalize dependent X; generalize dependent Y; by compute. Qed.
Instance Hom_compose_continuous `{Proset X, Proset X', Complete Y} {F : Hom X' X}
  : Continuous (fun G : Hom X Y => G ○ F).
Proof.
  move=> R J; apply: distrib_inf_sufficient.
  - move=> G G'; apply: (bi_l Hom_compose).
  - move=> A /=; apply: (mono einf) => ? //=.
Qed.
Instance Hom_compose_cocontinuous `{Proset X, Proset X', Complete Y} {F : Hom X' X}
  : Cocontinuous (fun G : Hom X Y => G ○ F).
Proof.
  move=> R J; apply: distrib_sup_sufficient.
  - move=> G G'; apply: (bi_l Hom_compose).
  - move=> A /=; apply: (mono esup) => ? //=.
Qed.
Instance Hom_eval_at_continuous `{Proset X, Proset Y, !InfLattice Y} {x : X}
  : Continuous (Hom_eval_at (Y:=Y) x).
Proof. move=> ? ?; by apply: distrib_inf_sufficient. Qed.
Instance Hom_eval_at_cocontinuous `{Proset X, Proset Y, !SupLattice Y} {x : X}
  : Cocontinuous (Hom_eval_at (Y:=Y) x).
Proof. move=> ? ?; by apply: distrib_sup_sufficient. Qed.

(* Example *)
Definition fixed_point `{Proset X} (F : X -> X) (A : X) : Prop
  := F A ⟛ A.
Definition kleene_chain `{Proset X, !Bot X} (F : X -> X) : nat -> X
  := fun n => Nat.iter n F ⊥.
Instance: Params (@kleene_chain) 4 := {}.
Lemma kleene_chain_chain `{Proset X, !Bot X} {F : X -> X} `{!Monotone F}
  : chain (kleene_chain F).
Proof. elim=> /= [| n]; [apply: bot_left | apply: mono]. Qed.
Instance kleene_chain_mono `{Proset X, !Bot X} {F : X -> X} `{!Monotone F}
  : Monotone (kleene_chain F).
Proof. apply chain_mono, kleene_chain_chain. Qed.
Theorem kleene `{Proset X, !DirectedComplete X, !Bot X} {F : X -> X}
        `{!Monotone F, !ScottContinuous F}
  : least (fixed_point F) (sup (kleene_chain F)).
Proof.
  split.
  - rewrite /fixed_point distrib_sup; split; apply: sup_left => n.
    + by apply: (sup_right (S n)).
    + apply (sup_right n), kleene_chain_chain.
  - move=> A FP; apply: sup_left; elim=> /= [| n].
    + apply: bot_left.
    + move=> D; unfold fixed_point in FP.
      rewrite -(proj1 FP); by apply: mono.
Qed.

Class ReflectsInf `{Proset X, Proset Y} {R} (F : X -> Y) (J : R -> X) :=
  reflect_inf A : lower_bound J A -> glb (F ∘ J) (F A) -> glb J A.
Hint Mode ReflectsInf ! - - ! - - ! ! ! : typeclass_instances.
Arguments reflect_inf {_ _ _ _ _ _ _} F {_ _} A.
Class ReflectsSup `{Proset X, Proset Y} {R} (F : X -> Y) (J : R -> X) :=
  reflect_sup A : upper_bound J A -> lub (F ∘ J) (F A) -> lub J A.
Hint Mode ReflectsSup ! - - ! - - ! ! ! : typeclass_instances.
Arguments reflect_sup {_ _ _ _ _ _ _} F {_ _} A.

(* Technically, "lifting" a limit is often defined as a strict version of this. *)
Class LiftsInf `{Proset X, Proset Y} {R} (F : X -> Y) (J : R -> X) :=
  {lift_inf B : glb (F ∘ J) B -> X;
   lift_inf_is_lift {B} H : F (lift_inf B H) ⟛ B;
   lift_inf_is_inf {B} H : glb J (lift_inf B H)}.
Hint Mode LiftsInf ! - - ! - - ! ! ! : typeclass_instances.
Arguments lift_inf {_ _ _ _ _ _ _} F {_ _} B.
Arguments lift_inf_is_lift {_ _ _ _ _ _ _} F {_ _ _}.
Arguments lift_inf_is_inf {_ _ _ _ _ _ _} F {_ _ _}.
Instance: Params (@lift_inf) 7 := {}.
Class LiftsSup `{Proset X, Proset Y} {R} (F : X -> Y) (J : R -> X) :=
  {lift_sup B : lub (F ∘ J) B -> X;
   lift_sup_is_lift {B} H : F (lift_sup B H) ⟛ B;
   lift_sup_is_sup {B} H : lub J (lift_sup B H)}.
Hint Mode LiftsSup ! - - ! - - ! ! ! : typeclass_instances.
Arguments lift_sup {_ _ _ _ _ _ _} F {_ _} B.
Arguments lift_sup_is_lift {_ _ _ _ _ _ _} F {_ _ _}.
Arguments lift_sup_is_sup {_ _ _ _ _ _ _} F {_ _ _}.
Instance: Params (@lift_sup) 7 := {}.

Class CreatesInf `{Proset X, Proset Y} {R} (F : X -> Y) (J : R -> X)
      `{!ReflectsInf F J, !LiftsInf F J}.
Hint Mode CreatesInf ! - - ! - - ! ! ! - - : typeclass_instances.
Instance creates_inf_def `{Proset X, Proset Y} {R} (F : X -> Y) (J : R -> X)
         `{!ReflectsInf F J, !LiftsInf F J}
  : CreatesInf F J := {}.
Class CreatesSup `{Proset X, Proset Y} {R} (F : X -> Y) (J : R -> X)
      `{!ReflectsSup F J, !LiftsSup F J}.
Hint Mode CreatesSup ! - - ! - - ! ! ! - - : typeclass_instances.
Instance creates_sup_def `{Proset X, Proset Y} {R} (F : X -> Y) (J : R -> X)
         `{!ReflectsSup F J, !LiftsSup F J}
  : CreatesSup F J := {}.

Notation ReflInfsOfShape R F := (forall J, Monotone J -> ReflectsInf (R:=R) F J).
Notation ReflSupsOfShape R F := (forall J, Monotone J -> ReflectsSup (R:=R) F J).
Notation ReflDInfsOfShape R F := (forall J, ReflectsInf (R:=R) F J).
Notation ReflDSupsOfShape R F := (forall J, ReflectsSup (R:=R) F J).
Notation ReflAllInfs F := (forall R J, ReflectsInf (R:=R) F J).
Notation ReflAllSups F := (forall R J, ReflectsSup (R:=R) F J).
Notation LiftInfsOfShape R F := (forall J, Monotone J -> LiftsInf (R:=R) F J).
Notation LiftSupsOfShape R F := (forall J, Monotone J -> LiftsSup (R:=R) F J).
Notation LiftDInfsOfShape R F := (forall J, LiftsInf (R:=R) F J).
Notation LiftDSupsOfShape R F := (forall J, LiftsSup (R:=R) F J).
Notation LiftAllInfs F := (forall R J, LiftsInf (R:=R) F J).
Notation LiftAllSups F := (forall R J, LiftsSup (R:=R) F J).
Notation CrInfsOfShape R F := (forall J, Monotone J -> CreatesInf (R:=R) F J).
Notation CrSupsOfShape R F := (forall J, Monotone J -> CreatesSup (R:=R) F J).
Notation CrDInfsOfShape R F := (forall J, CreatesInf (R:=R) F J).
Notation CrDSupsOfShape R F := (forall J, CreatesSup (R:=R) F J).
Notation CrAllInfs F := (forall R J, CreatesInf (R:=R) F J).
Notation CrAllSups F := (forall R J, CreatesSup (R:=R) F J).

(*
Lemma reflects_preserves `{Proset X, Proset Y} {F : X -> Y}
      `{!Monotone F} {R} (J : R -> X) `{!HasInf (F ∘ J), !ReflectsInf F J}
  : image F (inf (F ∘ J)) -> PreservesInf F J.
Proof.
   move=> A Glb. apply/inf_unique.
Qed.

Lemma undistrib_inf `{Proset X, Proset Y} {F : X -> Y}
      `{!Monotone F} {R} (J : R -> X) `{!HasInf J, !HasInf (F ∘ J), !ReflectsInf F J} A
  : F A ⟛ inf (F ∘ J) -> A ⟛ inf J.
Proof. move=> /inf_unique Glb. apply/inf_unique. apply: (reflect_inf A). ; apply: reflecting_reflects_inf. Qed.
Lemma reflecting_undistrib_sup `{Proset X, Proset Y} {F : X -> Y}
      `{!Monotone F, !Reflecting F} {R} (J : R -> X) `{!HasSup (F ∘ J)} A
  : F A ⟛ sup (F ∘ J) -> lub J A.
Proof. move=> /sup_unique; apply: reflecting_reflects_sup. Qed.
*)

Definition lift_hasinf `{LiftsInf X Y R F J, !HasInf (F ∘ J)} : HasInf J
  := {| inf := lift_inf F _ (is_inf (F ∘ J));
        is_inf := lift_inf_is_inf F _ |}.
Definition lift_hassup `{LiftsSup X Y R F J, !HasSup (F ∘ J)} : HasSup J
  := {| sup := lift_sup F _ (is_sup (F ∘ J));
        is_sup := lift_sup_is_sup F _ |}.
Arguments lift_hasinf {_ _ _ _ _ _ _} F J {_ _}.
Arguments lift_hassup {_ _ _ _ _ _ _} F J {_ _}.

Lemma lifts_inf_preserves_existing `{LiftsInf X Y R F J, !Monotone F, !HasInf (F ∘ J)}
  : PreservesInf F J.
Proof.
  set Has := lift_hasinf F J.
  apply/preserves_inf_alt3.
  rewrite /= lift_inf_is_lift //.
Qed.
Lemma lifts_sup_preserves_existing `{LiftsSup X Y R F J, !Monotone F, !HasSup (F ∘ J)}
  : PreservesSup F J.
Proof.
  set Has := lift_hassup F J.
  apply/preserves_sup_alt3.
  rewrite /= lift_sup_is_lift //.
Qed.

Lemma reflecting_strong_reflects_inf `{Proset X, Proset Y} {F : X -> Y}
      `{!Monotone F, !Reflecting F} {R} (J : R -> X) A
  : glb (F ∘ J) (F A) -> glb J A.
Proof.
  move=> Glb; split=> [r | A' LB].
  - apply: (reflect F); apply: (proj1 Glb).
  - apply: (reflect F); apply: (proj2 Glb) => r /=; by apply: mono.
Qed.
Lemma reflecting_strong_reflects_sup `{Proset X, Proset Y} {F : X -> Y}
      `{!Monotone F, !Reflecting F} {R} (J : R -> X) A
  : lub (F ∘ J) (F A) -> lub J A.
Proof.
  move=> Lub; split=> [r | A' UB].
  - apply: (reflect F); apply: (proj1 Lub).
  - apply: (reflect F); apply: (proj2 Lub) => r /=; by apply: mono.
Qed.
Lemma reflecting_undistrib_inf `{Proset X, Proset Y} {F : X -> Y}
      `{!Monotone F, !Reflecting F} {R} (J : R -> X) `{!HasInf (F ∘ J)} A
  : F A ⟛ inf (F ∘ J) -> glb J A.
Proof. move=> /inf_unique; apply: reflecting_strong_reflects_inf. Qed.
Lemma reflecting_undistrib_sup `{Proset X, Proset Y} {F : X -> Y}
      `{!Monotone F, !Reflecting F} {R} (J : R -> X) `{!HasSup (F ∘ J)} A
  : F A ⟛ sup (F ∘ J) -> lub J A.
Proof. move=> /sup_unique; apply: reflecting_strong_reflects_sup. Qed.
Definition reflecting_reflects_infs `{Proset X, Proset Y} {F : X -> Y}
           `{!Monotone F, !Reflecting F} : ReflAllInfs F
  := fun R J A _ => reflecting_strong_reflects_inf J A.
Definition reflecting_reflects_sups `{Proset X, Proset Y} {F : X -> Y}
           `{!Monotone F, !Reflecting F} : ReflAllSups F
  := fun R J A _ => reflecting_strong_reflects_sup J A.

Class InfClosed `{Proset X} {P : X -> Prop} {R} (J : R -> sig P) `{!HasInf (sval ∘ J)} :=
  inf_closed : P (Inf r, ` (J r)).
Class SupClosed `{Proset X} {P : X -> Prop} {R} (J : R -> sig P) `{!HasSup (sval ∘ J)} :=
  sup_closed : P (Sup r, ` (J r)).
(*
Class SupClosed `{Proset X} (P : X -> Prop) {R} (J : R -> sig P) :=
  sup_closed A : lub (sval ∘ J) A -> P A.
*)
Hint Mode InfClosed ! - - ! ! ! - : typeclass_instances.
Hint Mode SupClosed ! - - ! ! ! - : typeclass_instances.
Notation InfClosedAll P := (forall R (J : R -> sig P), InfClosed J).
Notation SupClosedAll P := (forall R (J : R -> sig P), SupClosed J).
Lemma inf_closed_of_shape `{Proset X} (P : X -> Prop) (R : Type) `{!DInfsOfShape R X}
  : (forall J : R -> X, (forall r, P (J r)) -> P (inf J)) -> forall J : R -> sig P, InfClosed J.
Proof. move=> Cl J; apply: Cl => r; apply: (proj2_sig (J r)). Qed.
Lemma sup_closed_of_shape `{Proset X} (P : X -> Prop) (R : Type) `{!DSupsOfShape R X}
  : (forall J : R -> X, (forall r, P (J r)) -> P (sup J)) -> forall J : R -> sig P, SupClosed J.
Proof. move=> Cl J; apply: Cl => r; apply: (proj2_sig (J r)). Qed.

Program Instance sig_inherit_inf `{InfClosed X P R J} : LiftsInf sval J
  := {| lift_inf B Glb := (Inf r, ` (J r)) ↾ inf_closed; |}.
Next Obligation. move=> /= > /inf_unique //. Qed.
Next Obligation. move=> /= > H; by apply: (reflecting_undistrib_inf (F:=sval)). Qed.
Program Instance sig_inherit_sup `{SupClosed X P R J} : LiftsSup sval J
  := {| lift_sup B Lub := (Sup r, ` (J r)) ↾ sup_closed; |}.
Next Obligation. move=> /= > /sup_unique //. Qed.
Next Obligation. move=> /= > H; by apply: (reflecting_undistrib_sup (F:=sval)). Qed.
Instance sig_preserves_inf `{InfClosed X P R J} : PreservesInf sval J
  := lifts_inf_preserves_existing.
Instance sig_preserves_sup `{SupClosed X P R J} : PreservesSup sval J
  := lifts_sup_preserves_existing.
(*
Instance sig_inherit_sup `{SupClosed X P R J} : LiftsSup sval J
  := {| lift_sup B Lub := B ↾ sup_closed B Lub;
        lift_sup_is_lift B Lub := reflexivity _;
        lift_sup_is_sup B Lub := reflecting_strong_reflects_sup J (B ↾ _) Lub |}.

Lemma inf_closed_existing `{Proset X} (P : X -> Prop) `{!Extensional P}
      {R} (J : R -> sig P) `{!HasInf (sval ∘ J)}
  : P (inf (sval ∘ J)) -> InfClosed P J.
Proof. move=> H_P A /inf_unique -> //. Qed.
*)

Definition sig_inf `{InfClosed X P R J} : HasInf J
  := Eval compute -[inf sval] in lift_hasinf sval J.
Definition sig_sup `{SupClosed X P R J} : HasSup J
  := Eval compute -[sup sval] in lift_hassup sval J.


(************************************************************************************)
(**                                                                                *)
(**                             The SQLEngines Library                              *)
(**                                                                                *)
(**            LRI, CNRS & Université Paris-Sud, Université Paris-Saclay            *)
(**                                                                                *)
(**                        Copyright 2016-2019 : FormalData                         *)
(**                                                                                *)
(**         Authors: Véronique Benzaken                                             *)
(**                  Évelyne Contejean                                              *)
(**                  Chantal Keller                                                 *)
(**                  Eunice-Raquel Martins                                          *)
(**                                                                                *)
(************************************************************************************)

Require Import List Bool.
Require Import BasicFacts ListFacts OrderedSet Signatures.

Set Implicit Arguments.

Module Filter.
Section Sec.

Hypothesis o : Type.
Hypothesis O : Oeset.Rcd o.
Hypothesis theta : o -> bool.
Hypothesis theta_eq : forall x y, Oeset.compare O x y = Eq -> theta x = theta y.

Hypothesis C : Cursor.Rcd O.

Definition cursor := Cursor.cursor C.

Definition visited (c : cursor) := List.filter theta (Cursor.visited c).

Definition mk_filter : (Cursor.cursor C) -> cursor := fun q => q.

Definition coherent (c : cursor) : Prop := Cursor.coherent c.

Definition collection (c : cursor) := List.filter theta (Cursor.collection c).

Lemma mk_filter_collection c x :
  Oeset.mem_bool O x (collection (mk_filter c)) = true ->
  Oeset.mem_bool O x (Cursor.collection c) = true.
Proof.
  unfold mk_filter, collection.
  rewrite Oeset.mem_bool_filter; auto.
  now rewrite andb_true_iff.
Qed.

Definition reset (c : cursor) : cursor := Cursor.reset c.

Definition next (c : cursor) : (result o * cursor)  :=
  match (Cursor.next c) with
  | (Result e, c') =>
    if theta e then (Result e, c') else (No_Result, c')
  | rc' => rc'
  end.

Definition has_next (c: cursor) : Prop := fst (next c) <> Empty_Cursor.

Definition empty_cursor : cursor := Cursor.empty_cursor C.

Definition ubound (q : cursor) : nat := Cursor.ubound q.

Lemma visited_collection :
        forall c, coherent c ->
                  forall x, Oeset.mem_bool O x (visited c) = true ->
                            Oeset.mem_bool O x (collection c) = true.
Proof.
unfold coherent, collection, visited.
intros c Hc x Hx.
rewrite Oeset.mem_filter in Hx; [ | intros; apply theta_eq; trivial].
rewrite Oeset.mem_filter; [ | intros; apply theta_eq; trivial].
destruct (theta x); [ | discriminate Hx].
apply (Cursor.visited_collection _ Hc _ Hx).
Qed.

Lemma reset_collection : forall c, collection (reset c) = collection c.
Proof.
unfold collection, reset.
intros c; rewrite Cursor.reset_collection; apply refl_equal.
Qed.

Lemma reset_visited : forall c, visited (reset c) = nil.
Proof.
unfold visited, reset.
intro c; rewrite Cursor.reset_visited; apply refl_equal.
Qed.

Lemma reset_coherent : forall c, coherent (reset c).
Proof.
unfold coherent, reset.
intro c; apply Cursor.reset_coherent.
Qed.

Lemma reset_reset : forall c, reset (reset c) = reset c.
Proof.
unfold reset.
intro c; apply Cursor.reset_reset.
Qed.

Lemma next_collection : forall c c' opt,
    coherent c -> next c = (opt, c') -> collection c' = collection c.
Proof.
unfold coherent, next, collection.
intros c c' opt Hc H.
case_eq (Cursor.next c); intros r c'' Hnc; rewrite Hnc in H.
assert (K := Cursor.next_collection _ c Hc Hnc).
destruct r as [e | | ].
- destruct (theta e); injection H; intros; subst.
  + rewrite K; apply refl_equal.
  + rewrite K; apply refl_equal.
- injection H; intros; subst; rewrite K; apply refl_equal.
- injection H; intros; subst; rewrite K; apply refl_equal.
Qed.

Lemma next_visited_Result : forall a c c',
    coherent c -> next c = (Result a, c') -> visited c' = a :: (visited c).
Proof.
unfold coherent, next, visited.
intros a c c' Hc H.
case_eq (Cursor.next c); intros r c'' Hnc; rewrite Hnc in H.
destruct r as [e | | ].
- case_eq (theta e); intro He; rewrite He in H; try discriminate H.
  injection H; intros; subst.
  rewrite (Cursor.next_visited_Result _ _ Hc Hnc); simpl; rewrite He.
  apply refl_equal.
- discriminate H.
- discriminate H.
Qed.

Lemma next_visited_No_Result : forall c c',
    coherent c -> next c = (No_Result, c') -> visited c' = visited c.
Proof.
unfold coherent, next, visited.
intros c c' Hc H.
case_eq (Cursor.next c); intros r c'' Hnc; rewrite Hnc in H.
destruct r as [e | | ].
- case_eq (theta e); intro He; rewrite He in H; try discriminate H.
  injection H; intros; subst.
  rewrite (Cursor.next_visited_Result _ _ Hc Hnc); simpl; rewrite He.
  apply refl_equal.
- injection H; intros; subst.
  rewrite (Cursor.next_visited_No_Result _ _ Hc Hnc); trivial.
- discriminate H.
Qed.

Lemma next_visited_Empty_Cursor : forall c c',
    coherent c -> next c = (Empty_Cursor, c') -> visited c' = visited c.
Proof.
unfold coherent, next, visited.
intros c c' Hc H.
case_eq (Cursor.next c); intros r c'' Hnc; rewrite Hnc in H.
destruct r as [e | | ].
- case_eq (theta e); intro He; rewrite He in H; try discriminate H.
- discriminate H.
- injection H; intros; subst.
  rewrite (Cursor.next_visited_Empty_Cursor _ _ Hc Hnc); trivial.
Qed.

Lemma next_Empty_Cursor :
  forall c, coherent c -> fst (next c) = Empty_Cursor -> fst (next (snd (next c))) = Empty_Cursor.
Proof.
unfold coherent, next.
intros c Hc.
case_eq (Cursor.next c); intros r c'' Hnc.
destruct r as [e | | ].
- case_eq (theta e); intro He; intro Abs; discriminate Abs.
- intro Abs; discriminate Abs.
- intros; simpl.
  assert (K : fst (Cursor.next (snd (Cursor.next c))) = Empty_Cursor).
  {
    apply (Cursor.next_Empty_Cursor _ c Hc).
    rewrite Hnc; trivial.
  }
  rewrite Hnc in K; simpl in K.
  case_eq (Cursor.next c''); intros r c''' Hnc''; rewrite Hnc'' in K; simpl in K; subst r; trivial.
Qed.

Lemma next_coherent : forall c, coherent c -> coherent (snd (next c)).
Proof.
unfold coherent, next.
intros c Hc.
case_eq (Cursor.next c); intros r c'' Hnc.
destruct r as [e | | ].
- case_eq (theta e); intro He.
  + assert (H := Cursor.next_coherent _ _ Hc); rewrite Hnc in H; apply H.
  + assert (H := Cursor.next_coherent _ _ Hc); rewrite Hnc in H; apply H.
- assert (H := Cursor.next_coherent _ _ Hc); rewrite Hnc in H; apply H.
- assert (H := Cursor.next_coherent _ _ Hc); rewrite Hnc in H; apply H.
Qed.

Lemma has_next_spec :
  forall c, coherent c -> ~ has_next c ->
            comparelA (Oeset.compare O) (collection c) (rev (visited c)) = Eq.
Proof.
unfold coherent, has_next, next, collection, visited.
intros c Hc.
case_eq (Cursor.next c); intros r c'' Hnc.
destruct r as [e | | ].
- case_eq (theta e); intro He.
  + intro Abs; apply False_rec; apply Abs; simpl; discriminate.
  + intro Abs; apply False_rec; apply Abs; simpl; discriminate.
- intro Abs; apply False_rec; apply Abs; simpl; discriminate.
- intros _; simpl.
  assert (H : comparelA (Oeset.compare O) (Cursor.collection c) (rev (Cursor.visited c)) = Eq).
  {
    apply Cursor.has_next_spec; [assumption | ].
    rewrite Cursor.has_next_next_neg; [ | assumption].
    rewrite Hnc; intro Abs; apply Abs; apply refl_equal.
  }
  rewrite <- filter_rev.
  revert H; generalize (Cursor.collection c) (rev (Cursor.visited c)).
  intro l1; induction l1 as [ | a1 l1]; intros [ | a2 l2] Hl; try discriminate Hl; trivial.
  simpl in Hl.
  case_eq (Oeset.compare O a1 a2); intro Ha; rewrite Ha in Hl; try discriminate Hl.
  simpl; rewrite <- (theta_eq _ _ Ha).
  case (theta a1); simpl.
  + rewrite Ha; apply IHl1; assumption.
  + apply IHl1; assumption.
Qed.

Lemma has_next_next_neg : forall c,
    coherent c -> (has_next c <-> fst (next c) <> Empty_Cursor).
Proof.
unfold coherent, has_next, next.
intros c Hc.
case_eq (Cursor.next c); intros r c'' Hnc.
destruct r as [e | | ]; [case_eq (theta e); intro He | | ]; split; exact (fun h => h).
Qed.

Lemma empty_cursor_collection : collection empty_cursor = nil.
Proof.
unfold collection, empty_cursor.
rewrite Cursor.empty_cursor_collection; apply refl_equal.
Qed.

Lemma empty_cursor_coherent : coherent empty_cursor.
Proof.
unfold coherent, empty_cursor.
apply Cursor.empty_cursor_coherent.
Qed.

Lemma empty_cursor_has_next : ~ has_next empty_cursor.
Proof.
unfold has_next, empty_cursor, next.
case_eq (Cursor.next (Cursor.empty_cursor C)); intros r c Hc.
destruct r as [e | | ].
- case (theta e).
  + assert (H := Cursor.empty_cursor_has_next C).
    rewrite Cursor.has_next_next_neg, Hc in H.
    * apply H.
    * apply Cursor.empty_cursor_coherent.
  + assert (H := Cursor.empty_cursor_has_next C).
    rewrite Cursor.has_next_next_neg, Hc in H.
    * apply False_rec; apply H; discriminate.
    * apply Cursor.empty_cursor_coherent.
- assert (H := Cursor.empty_cursor_has_next C).
  rewrite Cursor.has_next_next_neg, Hc in H.
  + apply H.
  + apply Cursor.empty_cursor_coherent.
- assert (H := Cursor.empty_cursor_has_next C).
  rewrite Cursor.has_next_next_neg, Hc in H.
  + apply H.
  + apply Cursor.empty_cursor_coherent.
Qed.

Lemma ubound_next_Empty : forall c : cursor,
                        coherent c -> fst (next c) = Empty_Cursor -> ubound (snd (next c)) <= ubound c.
Proof.
unfold coherent, next, ubound.
intros c Hc H.
case_eq (Cursor.next c); intros r c' Hnc; rewrite Hnc in H.
destruct r as [e | | ]; [destruct (theta e) | | ]; try discriminate H.
rewrite <- Hnc; apply Cursor.ubound_next_Empty; trivial.
rewrite Hnc; trivial.
Qed.

Lemma ubound_next_not_Empty : forall c : cursor,
    coherent c -> fst (next c) <> Empty_Cursor -> ubound (snd (next c)) < ubound c.
Proof.
unfold coherent, next, ubound.
intros c Hc H.
case_eq (Cursor.next c); intros r c' Hnc; rewrite Hnc in H.
refine (Lt.le_lt_trans _ _ _ _ (Cursor.ubound_next_not_Empty _ _ Hc _)).
- rewrite Hnc; destruct r as [e | | ]; [destruct (theta e) | | ]; apply le_n.
- rewrite Hnc.
  destruct r as [e | | ].
  + discriminate.
  + discriminate.
  + apply H.
Qed.

Lemma next_reset : forall c, coherent c -> reset (snd (next c)) = reset c.
Proof.
unfold coherent, next, reset.
intros c Hc.
case_eq (Cursor.next c); intros r c'' Hnc.
destruct r as [e | | ].
- case_eq (theta e); intro He; simpl.
  + rewrite <- (Cursor.next_reset _ _ Hc), Hnc; apply refl_equal.
  + rewrite <- (Cursor.next_reset _ _ Hc), Hnc; apply refl_equal.
- rewrite <- (Cursor.next_reset _ _ Hc), Hnc; apply refl_equal.
- rewrite <- (Cursor.next_reset _ _ Hc), Hnc; apply refl_equal.
Qed.

(*
Lemma ubound_reset :
  forall c, coherent c -> ubound c <= ubound (reset c).
Proof.
unfold coherent, ubound, reset.
apply Cursor.ubound_reset.
Qed.
*)

Lemma iter_filter res : forall q (f1:o -> res -> res) acc1 (f2:o -> res -> res) acc2,
    coherent q ->
    forall n, has_next (fst (iter next n q f1 acc1)) <->
              Cursor.has_next (fst (iter (@Cursor.next _ _ C) n q f2 acc2)).
Proof.
  intros q f1 acc1 f2 acc2 Hq n. unfold coherent in Hq. revert q acc1 acc2 Hq.
  induction n as [ |n IHn]; intros q acc1 acc2 Hq.
  - unfold iter, has_next, next; simpl. rewrite (Cursor.has_next_next_neg _ _ Hq).
    destruct (Cursor.next q) as [[el| | ] c']; simpl.
    * case (theta el); simpl; split; discriminate.
    * reflexivity.
    * reflexivity.
  - unfold iter in *; rewrite !nat_iter_succ_r.
    assert (Hq' := Cursor.next_coherent _ _ Hq).
    case_eq (Cursor.next q); intros r' q' Hnq; rewrite Hnq in Hq'.
    assert (Hnq' := refl_equal (next q)).
    unfold next at 2 in Hnq'; rewrite Hnq in Hnq'; rewrite Hnq'.
    destruct r' as [e' | | ].
    + case (theta e'); apply IHn; trivial.
    + apply IHn; trivial.
    + apply IHn; trivial.
Qed.

Lemma ubound_complete res :
  forall c (f:o -> res -> res) acc, coherent c -> forall p, ubound c <= p -> ~ has_next (fst (iter next p c f acc)).
Proof.
  unfold ubound.
  intros q f acc Hq p Hp; unfold coherent in Hq.
  rewrite (iter_filter q f acc f acc); auto using Cursor.ubound_complete.
Qed.

Definition build : Cursor.Rcd O.
apply (Cursor.mk_R O collection visited coherent)
  with reset next has_next empty_cursor ubound.
- apply visited_collection.
- apply reset_collection.
- apply reset_visited.
- apply reset_coherent.
- apply next_collection.
- apply next_visited_Result.
- apply next_visited_No_Result.
- apply next_visited_Empty_Cursor.
- apply next_coherent.
- apply next_Empty_Cursor.
- apply next_reset.
- apply has_next_spec.
- apply has_next_next_neg.
- apply empty_cursor_collection.
- apply empty_cursor_coherent.
- apply empty_cursor_has_next.
- apply reset_reset.
- apply ubound_next_Empty.
- apply ubound_next_not_Empty.
(* - apply ubound_reset. *)
- apply ubound_complete.
Defined.

End Sec.
End Filter.


(*interface (d) to show the difference
between SME-NI and the extended SIR-NNI*)

Require Export refine.
Require Export parser.

Definition expr2d: IA := parse
"IA [s1,s2,s3,s4] (s1) [m1,m2] [m2_,m1_] [] [s1->(m1)s2, s1->(m2)s3, s2->(m2_)s4, s3->(m1_)s4]".

(*at m1: false*)
Definition expr2d_m1_res: IA :=
 IAutomaton.hiding
  ( IAutomaton.restriction expr2d (ASet.GenActs [&"m2"]) )
  (ASet.GenActs [&"m2_"]).

Definition expr2d_m1_hid: IA :=
  IAutomaton.hiding expr2d (ASet.GenActs [&"m2",&"m2_"]).

Eval compute in RNNI_refinement expr2d_m1_res expr2d_m1_hid.

(*at m2: false*)
Definition expr2d_m2_res: IA :=
  IAutomaton.hiding
  ( IAutomaton.restriction expr2d (ASet.GenActs [&"m1"]) )
  (ASet.GenActs [&"m1_"]).

Definition expr2d_m2_hid: IA :=
  IAutomaton.hiding expr2d (ASet.GenActs [&"m1",&"m1_"]).

Eval compute in RNNI_refinement expr2d_m2_res expr2d_m2_hid.

(*at l: true*)
Definition expr2d_l_res: IA :=
 IAutomaton.hiding
 ( IAutomaton.restriction expr2d (ASet.GenActs [&"m1",&"m2"]) )
 (ASet.GenActs [&"m1_",&"m2_"]).

Definition expr2d_l_hid: IA :=
  IAutomaton.hiding expr2d (ASet.GenActs [&"m1",&"m2",&"m1_",&"m2_"]).

Eval compute in RNNI_refinement expr2d_l_res expr2d_l_hid.


Require Import Primitives Layer1 Omega.
Close Scope pred_scope.

Axiom block_size: nat.
Axiom block_size_eq: block_size = 64.

Definition valid_bitlist l := length l = block_size /\ (forall i, In i l -> i < 2).
Record bitlist :=
  {
   bits : list nat;
   valid : valid_bitlist bits
  }.

Fixpoint get_first_zero l :=
  match l with
  | nil => 0
  | hd::tl =>
    match hd with
    | O => 0
    | _ => S (get_first_zero tl)
    end
  end.

Theorem upd_valid_zero:
  forall i l,
    valid_bitlist l ->
    valid_bitlist (updN l i 0).
Proof.
  unfold valid_bitlist in *; intros; cleanup.
  rewrite updN_length; intuition.
  apply in_updN in H1; intuition; eauto.
Qed.

Theorem upd_valid_one:
  forall i l,
    valid_bitlist l ->
    valid_bitlist (updN l i 1).
Proof.
  unfold valid_bitlist in *; intros; cleanup.
  rewrite updN_length; intuition.
  apply in_updN in H1; intuition; eauto.
Qed.

Axiom value_to_bits: value -> bitlist.
Axiom bits_to_value: bitlist -> value.
Axiom value_to_bits_to_value : forall v, bits_to_value (value_to_bits v) = v.
Axiom bits_to_value_to_bits : forall l, value_to_bits (bits_to_value l) = l.
Open Scope pred_scope.

Fixpoint ptsto_bits' (dh: disk value) bits n : @pred addr addr_dec (set value) :=
  match bits with
  | nil =>
    emp
  | b::l =>
    (exists vs,
    (S n) |-> vs *
    match b with
    | 0 => [[ dh n = None ]]
    | 1 => [[ dh n = Some (fst vs) ]]
    | _ => [[ False ]]
    end) *
    ptsto_bits' dh l (S n)
  end.

Definition ptsto_bits dh bits := ptsto_bits' dh bits 0.

Definition rep (dh: disk value) : @pred addr addr_dec (set value) :=
  (exists bitmap bl,
    let bits := bits (value_to_bits bitmap) in
    0 |-> (bitmap, bl) * ptsto_bits dh bits * [[ forall i, i >= block_size -> dh i = None ]])%pred.

Definition alloc (v': value) : prog (option addr) :=
  v <- Read 0;
  let bits := bits (value_to_bits v) in
  let valid := valid (value_to_bits v) in
  let index := get_first_zero bits in

  if lt_dec index block_size then
    _ <- Write (S index) v';
    _ <- Write 0 (bits_to_value (Build_bitlist (updN bits index 1) (upd_valid_one index bits valid)));
    Ret (Some index)
  else
    Ret None.

Definition read a : prog (option value) :=
  v <- Read 0;
  let bits := bits (value_to_bits v) in
  if lt_dec a block_size then
    if addr_dec (nth a bits 0) 1 then
      h <- Read (S a);
      Ret (Some h)
    else
      Ret None
  else
    Ret None.

Definition write a v' : prog (option unit) :=
  v <- Read 0;
  let bits := bits (value_to_bits v) in
  if lt_dec a block_size then
    if addr_dec (nth a bits 0) 1 then
      _ <- Write (S a) v';
      Ret (Some tt)
    else
      Ret None
  else
    Ret None.

Definition free a : prog unit :=
  v <- Read 0;
  let bits := bits (value_to_bits v) in
  let valid := valid (value_to_bits v) in
  if lt_dec a block_size then
    if addr_dec (nth a bits 0) 1 then
      Write 0 (bits_to_value (Build_bitlist (updN bits a 0) (upd_valid_zero a bits valid)))
    else
      Ret tt
  else
    Ret tt.

Hint Extern 0 (okToUnify (rep _) (rep _)) => constructor : okToUnify.


Definition ifte (T : Set) (A B : Prop) (s : {A} + {B})
  (th el : T) := if s then th else el.

Implicit Arguments ifte.

Lemma Reflexivity_provable :
 forall (A : Set) (a : A) (s : {a = a} + {a <> a}),
 exists x : _, s = left _ x.
intros.
elim s.
intro x.
split with x; reflexivity.

intro.
 absurd (a = a); auto.

Qed.

Lemma Disequality_provable :
 forall (A : Set) (a b : A),
 a <> b -> forall s : {a = b} + {a <> b}, exists x : _, s = right _ x.
intros.
elim s.
intro.
 absurd (a = a); auto.

intro.
split with b0; reflexivity.

Qed.

Module Type ELEM.
  Parameter T : Set.
  Parameter eq_dec : forall a a' : T, {a = a'} + {a <> a'}.
End ELEM.

Module Type SET (Elt: ELEM).
  Parameter T : Set.
  Parameter empty : T.
  Parameter add : Elt.T -> T -> T.
  Parameter find : Elt.T -> T -> bool.

  (* Axioms *)

  Axiom find_empty_false : forall e : Elt.T, find e empty = false.

  Axiom find_add_true : forall (s : T) (e : Elt.T), find e (add e s) = true.

  Axiom
    find_add_false :
      forall (s : T) (e e' : Elt.T), e <> e' -> find e (add e' s) = find e s.

End SET.

Module FuncDict (E: ELEM).
  Definition T := E.T -> bool.
  Definition empty (e' : E.T) := false.
  Definition find (e' : E.T) (s : T) := s e'.
  Definition add (e : E.T) (s : T) (e' : E.T) :=
    ifte (E.eq_dec e e') true (find e' s).

  Lemma find_empty_false : forall e : E.T, find e empty = false.
    auto.
  Qed.

  Lemma find_add_true : forall (s : T) (e : E.T), find e (add e s) = true.

    intros.
    unfold find, add in |- *.
    elim (Reflexivity_provable _ _ (E.eq_dec e e)).
    intros.
     rewrite H.
    auto.

  Qed.

  Lemma find_add_false :
   forall (s : T) (e e' : E.T), e <> e' -> find e (add e' s) = find e s.
    intros.
    unfold add, find in |- *.
    cut (exists x : _, E.eq_dec e' e = right _ x).
    intros.
    elim H0.
    intros.
     rewrite H1.
    unfold ifte in |- *.
    reflexivity.

    apply Disequality_provable.
    auto.

  Qed.

End FuncDict.

Module F : SET := FuncDict.

Module Nat.
  Definition T := nat.
  Lemma eq_dec : forall a a' : T, {a = a'} + {a <> a'}.
     decide equality.
  Qed.
End Nat.

Module SetNat := F Nat.

Lemma no_zero_in_empty : SetNat.find 0 SetNat.empty = false.
apply SetNat.find_empty_false.
Qed.

(***************************************************************************)
Module Lemmas (G: SET) (E: ELEM).

  Module ESet := G E.

  Lemma commute :
   forall (S : ESet.T) (a1 a2 : E.T),
   let S1 := ESet.add a1 (ESet.add a2 S) in
   let S2 := ESet.add a2 (ESet.add a1 S) in
   forall a : E.T, ESet.find a S1 = ESet.find a S2.

    intros.
    unfold S1, S2 in |- *.
    elim (E.eq_dec a a1); elim (E.eq_dec a a2); intros H1 H2;
     try  rewrite <- H1; try  rewrite <- H2;
     repeat
      (try ( rewrite ESet.find_add_true; auto);
        try ( rewrite ESet.find_add_false; auto); auto).
  Qed.
End Lemmas.

Inductive list (A : Set) : Set :=
  | nil : list A
  | cons : A -> list A -> list A.

Module ListDict (E: ELEM).
  Definition T := list E.T.
  Definition elt := E.T.

  Definition empty := nil elt.
  Definition add (e : elt) (s : T) := cons elt e s.
  Fixpoint find (e : elt) (s : T) {struct s} : bool :=
    match s with
    | nil => false
    | cons e' s' => ifte (E.eq_dec e e') true (find e s')
    end.

  Definition find_empty_false (e : elt) := refl_equal false.

  Lemma find_add_true : forall (s : T) (e : E.T), find e (add e s) = true.
    intros.
    simpl in |- *.
    elim (Reflexivity_provable _ _ (E.eq_dec e e)).
    intros.
     rewrite H.
    auto.

  Qed.

  Lemma find_add_false :
   forall (s : T) (e e' : E.T), e <> e' -> find e (add e' s) = find e s.
    intros.
    simpl in |- *.
    elim (Disequality_provable _ _ _ H (E.eq_dec e e')).
    intros.
     rewrite H0.
    simpl in |- *.
    reflexivity.
  Qed.

End ListDict.

Module L : SET := ListDict.