(** * Duality between C and C^op *)
(** ** Contents
- From C^op to C
 - Monics and Epis
 - Initial, Terminal, and Zero
 - Equalizers and Coequalizers
 - Kernels and Cokernels
 - Pullbacks and Pushouts
 - BinProducts and BinCoproducts
- From C to C^op
 - Monics and Epis
 - Initial, Terminal, and Zero
 - Equalizers and Coequalizers
 - Kernels and Cokernels
 - Pullbacks and Pushouts
 - BinProducts and BinCoproducts
*)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Monics.
Require Import UniMath.CategoryTheory.Epis.
Require Import UniMath.CategoryTheory.opp_precat.

Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.zero.
Require Import UniMath.CategoryTheory.limits.equalizers.
Require Import UniMath.CategoryTheory.limits.coequalizers.
Require Import UniMath.CategoryTheory.limits.kernels.
Require Import UniMath.CategoryTheory.limits.cokernels.
Require Import UniMath.CategoryTheory.limits.pushouts.
Require Import UniMath.CategoryTheory.limits.pullbacks.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.

Local Open Scope cat.

Local Notation "C '^op'" := (op_category C) (at level 3, format "C ^op") : cat.

(** * Translation of structures from C^op to C *)
Section def_opposites.

  Variable C : category.
  Let hs : has_homsets C := homset_property C.

  (** ** Monic and Epi *)

  Definition opp_isMonic {a b : C} (f : a --> b) (H : @isMonic (op_category C) _ _ f) : @isEpi C _ _ f := H.
  Opaque opp_isMonic.

  Definition opp_Monic {a b : C} (f : @Monic (op_category C) a b) : @Epi C b a :=
    @make_Epi C _ _ f (opp_isMonic f (pr2 f)).

  Definition opp_isEpi {a b : C} (f : a --> b) (H : @isEpi (C^op) _ _ f) : @isMonic C _ _ f := H.
  Opaque opp_isEpi.

  Definition opp_Epi {a b : C} (f : @Epi (C^op) a b) : @Monic C b a :=
    @make_Monic C _ _ f (opp_isEpi f (pr2 f)).

  (** ** Initial, Terminal, and Zero *)

  Definition opp_isInitial {x : C} (H : @isInitial (C^op) x) : @isTerminal C x := H.

  Definition opp_Initial (I : @Initial (C^op)) : @Terminal C :=
    @make_Terminal C _ (opp_isInitial (pr2 I)).

  Definition opp_isTerminal {x : C} (H : @isTerminal (C^op) x) : @isInitial C x := H.

  Definition opp_Terminal (T : @Terminal (C^op)) : @Initial C :=
    @make_Initial C _ (opp_isTerminal (pr2 T)).

  Lemma opp_isZero {x : C} (H : @isZero (C^op) x) : @isZero C x.
  Proof.
    use make_isZero.
    - intros a. exact (dirprod_pr2 H a).
    - intros a. exact (dirprod_pr1 H a).
  Qed.

  Definition opp_Zero (Z : @Zero (C^op)) : @Zero C := @make_Zero C _ (opp_isZero (pr2 Z)).

  (** ** Equality on ZeroArrows *)

  Lemma opp_ZeroArrowTo {x : C} (Z : @Zero (C^op)) :
    @ZeroArrowTo (C^op) Z x = @ZeroArrowFrom C (opp_Zero Z) x.
  Proof.
    apply ArrowsToZero.
  Qed.

  Lemma opp_ZeroArrowFrom {x : C} (Z : @Zero (C^op)) :
    @ZeroArrowFrom (C^op) Z x = @ZeroArrowTo C (opp_Zero Z) x.
  Proof.
    apply ArrowsFromZero.
  Qed.

  Lemma opp_ZeroArrow {x y : C} (Z : @Zero (C^op)) :
    @ZeroArrow (C^op) Z x y = @ZeroArrow C (opp_Zero Z) y x.
  Proof.
    unfold ZeroArrow.
    rewrite opp_ZeroArrowTo.
    rewrite opp_ZeroArrowFrom.
    apply idpath.
  Qed.

  Local Opaque ZeroArrow.

  (** ** Equalizers and Coequalizers *)

  Lemma opp_isEqualizer {x y z : C} (f g : (C^op)⟦y, z⟧) (e : (C^op)⟦x, y⟧) (H : e · f = e · g)
    (H' : @isEqualizer (op_category C) _ _ _ f g e H) : @isCoequalizer C _ _ _ f g e H.
  Proof.
    exact H'.
  Qed.

  Lemma opp_isCoequalizer {x y z : C} (f g : (C^op)⟦x, y⟧) (e : (C^op)⟦y, z⟧)
        (H : f · e = g · e) (H' : @isCoequalizer (C^op) _ _ _ f g e H) :
    @isEqualizer C _ _ _ f g e H.
  Proof.
    exact H'.
  Qed.

  Definition opp_Equalizer {y z : C} (f g : (C^op)⟦y, z⟧) (E : @Equalizer (op_category C) y z f g) :
    @Coequalizer C z y f g := @make_Coequalizer C _ _ _ f g (EqualizerArrow E) (EqualizerEqAr E)
                                              (opp_isEqualizer f g (EqualizerArrow E)
                                                               (EqualizerEqAr E)
                                                               (isEqualizer_Equalizer E)).

  Definition opp_Coequalizer {y z : C} (f g : (C^op)⟦y, z⟧) (E : @Coequalizer (C^op) y z f g) :
    @Equalizer C z y f g := @make_Equalizer C _ _ _ f g (CoequalizerArrow E) (CoequalizerEqAr E)
                                          (opp_isCoequalizer f g (CoequalizerArrow E)
                                                             (CoequalizerEqAr E)
                                                             (isCoequalizer_Coequalizer E)).

  Definition opp_Equalizers (E : @Equalizers (op_category C)) : @Coequalizers C.
  Proof.
    intros x y f g.
    use opp_Equalizer.
    exact (E y x f g).
  Defined.

  Definition opp_Coequalizers (E : @Coequalizers (C^op)) : @Equalizers C.
  Proof.
    intros x y f g.
    use opp_Coequalizer.
    exact (E y x f g).
  Defined.

  (** ** Kernels and Cokernels *)

  Local Lemma opp_isCokernel_eq {x y z : C^op} (f : (C^op)⟦x, y⟧) (g : C^op⟦y, z⟧) (Z : Zero (C^op))
        (H : f · g = ZeroArrow Z _ _) (Z' : Zero C) :
    (g : C⟦z, y⟧) · (f : C⟦y, x⟧) = ZeroArrow Z' _ _.
  Proof.
    cbn in *. rewrite H. rewrite opp_ZeroArrow.
    exact (ZerosArrowEq C (opp_Zero Z) Z' z x).
  Qed.

  Lemma opp_isCokernel {x y z : C^op} {f : (C^op)⟦x, y⟧} {g : C^op⟦y, z⟧} {Z : Zero (C^op)}
        {H : f · g = ZeroArrow Z _ _} (K' : isKernel (C:=op_category C) Z f g H) {Z' : Zero C} :
    isCokernel Z' (g : C⟦z, y⟧) (f : C⟦y, x⟧) (opp_isCokernel_eq f g Z H Z').
  Proof.
    set (K := make_Kernel _ _ _ _ K').
    use make_isCokernel.
    - intros w h H'.
      rewrite <- (ZerosArrowEq C (opp_Zero Z) Z' z w) in H'.
      rewrite <- opp_ZeroArrow in H'.
      use unique_exists.
      + exact (KernelIn (C:=op_category _ )Z K w h H').
      + use (KernelCommutes (C:=op_category _) Z K).
      + intros y0. apply hs.
      + cbn. intros y0 X. use (KernelInsEq (C:=op_category _) Z K). rewrite (KernelCommutes (C:=op_category _) Z K). cbn. rewrite X.
        apply idpath.
  Qed.

  Local Lemma opp_Kernel_eq {y z : C} (f : (C^op)⟦y, z⟧) (Z : Zero (C^op))
             (K : @Kernel (op_category C) Z y z f) :
    @compose C^op _ _ _ (KernelArrow K) f = ZeroArrow (opp_Zero Z) z K.
  Proof.
    cbn. rewrite <- opp_ZeroArrow. apply (KernelCompZero (C:= op_category _) Z K).
  Qed.

  Lemma opp_Kernel_isCokernel {y z : C} (f : (C^op)⟦y, z⟧) (Z : Zero (C^op))
             (K : @Kernel (C^op) Z y z f) :
    isCokernel (opp_Zero Z) f (KernelArrow K) (opp_Kernel_eq f Z K).
  Proof.
    use make_isCokernel.
    - intros w h H'. rewrite <- opp_ZeroArrow in H'.
      use unique_exists.
      + exact (KernelIn Z K w h H').
      + use (KernelCommutes Z K).
      + intros y0. apply hs.
      + cbn. intros y0 X. use (@KernelInsEq C^op). rewrite (KernelCommutes Z K). cbn. rewrite X.
        apply idpath.
  Qed.

  Definition opp_Kernel {y z : C} (f : (C^op)⟦y, z⟧) (Z : Zero (C^op))
             (K : @Kernel (C^op) Z y z f) : @Cokernel C (opp_Zero Z) z y f.
  Proof.
    use make_Cokernel.
    - exact K.
    - exact (KernelArrow K).
    - exact (opp_Kernel_eq f Z K).
    - exact (opp_Kernel_isCokernel f Z K).
  Defined.

  Lemma opp_isKernel {x y z : op_category C} {f : (C^op)⟦x, y⟧} {g : C^op⟦y, z⟧} {Z : Zero (C^op)}
        {H : f · g = ZeroArrow Z _ _} (CK' : isCokernel Z f g H) {Z' : Zero C} :
    isKernel Z' (g : C⟦z, y⟧) (f : C⟦y, x⟧) (opp_isCokernel_eq f g Z H Z').
  Proof.
    set (CK := make_Cokernel _ _ _ _ CK').
    use make_isKernel.
    intros w h H'.
    rewrite <- (ZerosArrowEq C (opp_Zero Z) Z' w x) in H'.
    rewrite <- opp_ZeroArrow in H'.
    use unique_exists.
    + exact (CokernelOut Z CK w h H').
    + use (CokernelCommutes Z CK).
    + intros y0. apply hs.
    + cbn. intros y0 X. use (CokernelOutsEq _ CK). rewrite (CokernelCommutes Z CK). cbn. rewrite X.
      apply idpath.
  Qed.

  Local Lemma opp_Cokernel_eq {y z : C} (f : (C^op)⟦y, z⟧) (Z : Zero (C^op))
             (CK : @Cokernel (C^op) Z y z f) :
    @compose (C^op) _ _ _ f (CokernelArrow CK) = ZeroArrow (opp_Zero Z) CK y.
  Proof.
    cbn. rewrite <- opp_ZeroArrow. apply (CokernelCompZero Z CK).
  Qed.

  Lemma opp_Cokernel_isKernel {y z : C} (f : (C^op)⟦y, z⟧) (Z : Zero (C^op))
             (CK : @Cokernel (C^op) Z y z f) :
    isKernel (opp_Zero Z) (CokernelArrow CK) f (opp_Cokernel_eq f Z CK).
  Proof.
    use make_isKernel.
    intros w h H'. rewrite <- opp_ZeroArrow in H'.
    use unique_exists.
    + exact (CokernelOut Z CK w h H').
    + use (CokernelCommutes Z CK).
    + intros y0. apply hs.
    + cbn. intros y0 X. use (@CokernelOutsEq C^op). rewrite (CokernelCommutes Z CK). cbn. rewrite X.
      apply idpath.
  Qed.

  Definition opp_Cokernel {y z : C} (f : (C^op)⟦y, z⟧) (Z : Zero (C^op))
             (CK : @Cokernel (C^op) Z y z f) : @Kernel C (opp_Zero Z) z y f.
  Proof.
    use make_Kernel.
    - exact CK.
    - exact (CokernelArrow CK).
    - exact (opp_Cokernel_eq f Z CK).
    - exact (opp_Cokernel_isKernel f Z CK).
  Defined.

  Definition opp_Kernels (Z : Zero (C^op)) (K : @Kernels (C^op) Z) : @Cokernels C (opp_Zero Z).
  Proof.
    intros x y f.
    use opp_Kernel.
    apply (K y x f).
  Defined.

  Definition opp_Cokernels (Z : Zero (C^op)) (CK : @Cokernels (C^op) Z) : @Kernels C (opp_Zero Z).
  Proof.
    intros x y f.
    use opp_Cokernel.
    apply (CK y x f).
  Defined.

  (** ** Pushouts and pullbacks *)

  Lemma opp_isPushout {a b c d : C} (f : (C^op)⟦a, b⟧) (g : (C^op)⟦a, c⟧)
        (in1 : (C^op)⟦b, d⟧) (in2 : (C^op)⟦c, d⟧) (H : f · in1 = g · in2)
        (iPo : @isPushout (C^op) a b c d f g in1 in2 H) : @isPullback C a b c d f g in1 in2 H.
  Proof.
    exact iPo.
  Qed.

  Lemma opp_isPullback {a b c d : C} (f : (C^op)⟦b, a⟧) (g : (C^op)⟦c, a⟧)
        (p1 : (C^op)⟦d, b⟧) (p2 : (C^op)⟦d, c⟧) (H : p1 · f = p2 · g)
        (iPb : @isPullback (C^op) a b c d f g p1 p2 H) : @isPushout C a b c d f g p1 p2 H.
  Proof.
    exact iPb.
  Qed.

  Definition opp_Pushout {a b c : C} (f : (C^op)⟦a, b⟧) (g : (C^op)⟦a, c⟧)
             (Po : @Pushout (C^op) a b c f g) : @Pullback C a b c f g.
  Proof.
    exact Po.
  Defined.

  Definition opp_Pullback {a b c : C} (f : (C^op)⟦b, a⟧) (g : (C^op)⟦c, a⟧)
             (Pb : @Pullback (C^op) a b c f g) : @Pushout C a b c f g.
  Proof.
    exact Pb.
  Defined.

  Definition opp_Pushouts (Pos : @Pushouts (C^op)) : @Pullbacks C.
  Proof.
    exact Pos.
  Defined.

  Definition opp_Pullbacks (Pbs : @Pushouts (C^op)) : @Pullbacks C.
  Proof.
    exact Pbs.
  Defined.

  (** ** BinProducts and BinCoproducts *)

  Definition opp_isBinProduct (c d p : C) (p1 : (C^op)⟦p, c⟧) (p2 : (C^op)⟦p, d⟧)
             (iBPC : @isBinProduct (C^op) c d p p1 p2) : @isBinCoproduct C c d p p1 p2 :=
    iBPC.

  Definition opp_isBinCoproduct (a b co : C) (ia : (C^op)⟦a, co⟧) (ib : (C^op)⟦b, co⟧)
             (iBCC : @isBinCoproduct (C^op) a b co ia ib) :
    @isBinProduct C a b co ia ib := iBCC.

  Definition opp_BinProduct (c d : C) (BPC : @BinProduct (C^op) c d) :
    @BinCoproduct C c d := BPC.

  Definition opp_BinCoproduct (c d : C) (BCC : @BinCoproduct (C^op) c d) :
    @BinProduct C c d := BCC.

  Definition opp_BinProducts (BP : @BinProducts (C^op)) : @BinCoproducts C := BP.

  Definition opp_BinCoproducts (BC : @BinCoproducts (C^op)) : @BinProducts C := BC.

End def_opposites.

(** * Translation of structures from C to C^op *)
Section def_opposites'.

  Variable C : category.
  Let hs : has_homsets C := homset_property C.

  (** ** Monic and Epi *)

  Definition isMonic_opp {a b : C} {f : C⟦a, b⟧} (H : @isMonic C a b f) : @isEpi (C^op) b a f := H.
  Opaque isMonic_opp.

  Definition Monic_opp {a b : C} (f : @Monic C a b) : @Epi (C^op) b a :=
    @make_Epi (C^op) b a f (isMonic_opp (pr2 f)).

  Definition isEpi_opp {a b : C} {f : C⟦a, b⟧} (H : @isEpi C a b f) : @isMonic (C^op) b a f := H.
  Opaque isEpi_opp.

  Definition Epi_opp {a b : C} (f : @Epi C a b) : @Monic (C^op) b a :=
    @make_Monic (C^op) b a f (isEpi_opp (pr2 f)).

  (** ** Initial, Terminal, and Zero *)

  Definition isInitial_opp {x : C} (H : @isInitial C x) : @isTerminal (C^op) x := H.

  Definition Initial_opp (I : @Initial C) : @Terminal (C^op) :=
    @make_Terminal (C^op) _ (isInitial_opp (pr2 I)).

  Definition isTerminal_opp {x : C} (H : @isTerminal C x) : @isInitial (C^op) x := H.

  Definition Terminal_opp (T : @Terminal C) : @Initial (C^op) :=
    @make_Initial (C^op) _ (isTerminal_opp (pr2 T)).

  Lemma isZero_opp {x : C} (H : @isZero C x) : @isZero (C^op) x.
  Proof.
    use make_isZero.
    - intros a. apply (pr2 H a).
    - intros a. apply (pr1 H a).
  Defined.

  Definition Zero_opp (T : @Zero C) : @Zero (C^op) := @make_Zero (C^op) _ (isZero_opp (pr2 T)).

  (** ** Equality on ZeroArrows *)

  Lemma ZeroArrowTo_opp {x : C} (Z : @Zero C) :
    @ZeroArrowTo C Z x = @ZeroArrowFrom (C^op) (Zero_opp Z) x.
  Proof.
    apply ArrowsToZero.
  Qed.

  Lemma ZeroArrowFrom_opp {x : C} (Z : @Zero C) :
    @ZeroArrowFrom C Z x = @ZeroArrowTo (C^op) (Zero_opp Z) x.
  Proof.
    apply ArrowsFromZero.
  Qed.

  Lemma ZeroArrow_opp {x y : C} (Z : @Zero C) :
    @ZeroArrow C Z x y = @ZeroArrow (C^op) (Zero_opp Z) y x.
  Proof.
    unfold ZeroArrow.
    rewrite ZeroArrowTo_opp.
    rewrite ZeroArrowFrom_opp.
    apply idpath.
  Qed.

  Local Opaque ZeroArrow.

  (** ** Equalizers and Coequalizers *)

  Definition isEqualizer_opp {x y z : C} (f g : C⟦y, z⟧) (e : C⟦x, y⟧) (H : e · f = e · g)
             (isE : @isEqualizer C _ _ _ f g e H) : @isCoequalizer (C^op) _ _ _ f g e H := isE.

  Definition isCoequalizer_opp {x y z : C} (f g : C⟦x, y⟧) (e : C⟦y, z⟧) (H : f · e = g · e)
             (isC : @isCoequalizer C _ _ _ f g e H) : @isEqualizer (C^op) _ _ _ f g e H := isC.

  Definition Equalizer_opp {y z : C} (f g : C⟦y, z⟧) (E : @Equalizer C y z f g) :
    @Coequalizer (C^op) z y f g := @make_Coequalizer (C^op) _ _ _ f g (EqualizerArrow E)
                                                   (EqualizerEqAr E)
                                                   (isEqualizer_opp f g (EqualizerArrow E)
                                                                    (EqualizerEqAr E)
                                                                    (isEqualizer_Equalizer E)).

  Definition Coequalizer_opp {y z : C} (f g : C⟦y, z⟧) (CE : @Coequalizer C y z f g) :
    @Equalizer (C^op) z y f g := @make_Equalizer (C^op) _ _ _ f g (CoequalizerArrow CE)
                                               (CoequalizerEqAr CE)
                                               (isCoequalizer_opp f g (CoequalizerArrow CE)
                                                                  (CoequalizerEqAr CE)
                                                                  (isCoequalizer_Coequalizer CE)).

  Definition Equalizers_opp (E : @Equalizers C) : @Coequalizers (C^op).
  Proof.
    intros x y f g.
    use Equalizer_opp.
    exact (E y x f g).
  Defined.

  Definition Coequalizers_opp (CE : @Coequalizers C) : @Equalizers (C^op).
  Proof.
    intros x y f g.
    use Coequalizer_opp.
    exact (CE y x f g).
  Defined.

  (** ** Kernels and Cokernels *)

  Local Lemma isCokernel_opp_eq {x y z : C} (f : C⟦x, y⟧) (g : C⟦y, z⟧) (Z : Zero C)
        (H : f · g = ZeroArrow Z _ _) (Z' : Zero C^op) :
    (g : C^op⟦z, y⟧) · (f : C^op⟦y, x⟧) = ZeroArrow Z' _ _.
  Proof.
    cbn in *. rewrite H. rewrite ZeroArrow_opp.
    exact (ZerosArrowEq C^op (Zero_opp Z) Z' z x).
  Qed.

  Lemma isCokernel_opp {x y z : C} {f : C⟦x, y⟧} {g : C⟦y, z⟧} {Z : Zero C}
        {H : f · g = ZeroArrow Z _ _} (K' : isKernel Z f g H) {Z' : Zero C^op} :
    isCokernel Z' (g : C^op⟦z, y⟧) (f : C^op⟦y, x⟧) (isCokernel_opp_eq f g Z H Z').
  Proof.
    set (K := make_Kernel _ _ _ _ K').
    use make_isCokernel.
    - intros w h H'. cbn in H'.
      set (XXX := (ZerosArrowEq C^op (Zero_opp Z) Z' z w)).
      use unique_exists.
      + use (KernelIn Z K w h _).
        rewrite ZeroArrow_opp.
        rewrite XXX.
        apply H'.
      + cbn. use (KernelCommutes Z K).
      + intros y0. apply (has_homsets_opp hs).
      + cbn. intros y0 X. use (KernelInsEq Z K). rewrite KernelCommutes. exact X.
  Qed.

  Local Lemma Kernel_opp_eq {y z : C} (f : C⟦y, z⟧) (Z : Zero C) (K : @Kernel C Z y z f) :
    @compose C^op _ _ _ f (KernelArrow K) = ZeroArrow (Zero_opp Z) z K.
  Proof.
    cbn. rewrite (KernelCompZero Z K). apply ZeroArrow_opp.
  Qed.

  Lemma Kernel_opp_isCokernel {y z : C} (f : C⟦y, z⟧) (Z : Zero C) (K : @Kernel C Z y z f) :
    isCokernel (Zero_opp Z) f (KernelArrow K) (Kernel_opp_eq f Z K).
  Proof.
    use make_isCokernel.
    - intros w h H'. cbn in H'.
      use unique_exists.
      + rewrite <- ZeroArrow_opp in H'. exact (KernelIn Z K w h H').
      + cbn. use KernelCommutes.
      + intros y0. apply (has_homsets_opp hs).
      + cbn. intros y0 X. use KernelInsEq. rewrite KernelCommutes. exact X.
  Qed.

  Definition Kernel_opp {y z : C} (f : C⟦y, z⟧) (Z : Zero C) (K : @Kernel C Z y z f) :
    @Cokernel (C^op) (Zero_opp Z) z y f.
  Proof.
    use make_Cokernel.
    - exact K.
    - exact (KernelArrow K).
    - exact (Kernel_opp_eq f Z K).
    - exact (Kernel_opp_isCokernel f Z K).
  Defined.

  Lemma isKernel_opp {x y z : C^op} {f : C⟦x, y⟧} {g : C⟦y, z⟧} {Z : Zero C}
        {H : f · g = ZeroArrow Z _ _} (CK' : isCokernel Z f g H) {Z' : Zero C^op} :
    isKernel Z' (g : C^op⟦z, y⟧) (f : C^op⟦y, x⟧) (isCokernel_opp_eq f g Z H Z').
  Proof.
    set (CK := make_Cokernel _ _ _ _ CK').
    use make_isKernel.
    - intros w h H'.
      rewrite <- (ZerosArrowEq C^op (Zero_opp Z) Z' w x) in H'.
      rewrite <- ZeroArrow_opp in H'.
      use unique_exists.
      + exact (CokernelOut Z CK w h H').
      + use (CokernelCommutes Z CK).
      + intros y0. apply hs.
      + cbn. intros y0 X. use (CokernelOutsEq _ CK). rewrite (CokernelCommutes Z CK). cbn. rewrite X.
        apply idpath.
  Qed.

  Local Lemma Cokernel_opp_eq {y z : C} (f : C⟦y, z⟧) (Z : Zero C) (CK : @Cokernel C Z y z f) :
    @compose C^op _ _ _ (CokernelArrow CK) f = ZeroArrow (Zero_opp Z) CK y.
  Proof.
    cbn. rewrite (CokernelCompZero Z CK). apply ZeroArrow_opp.
  Qed.

  Lemma Cokernel_opp_isKernel {y z : C} (f : C⟦y, z⟧) (Z : Zero C)
        (CK : @Cokernel C Z y z f) :
    isKernel (Zero_opp Z) (CokernelArrow CK) f (Cokernel_opp_eq f Z CK).
  Proof.
    use make_isKernel.

    - intros w h H'. cbn in H'.
      use unique_exists.
      + rewrite <- ZeroArrow_opp in H'. exact (CokernelOut Z CK w h H').
      + cbn. use CokernelCommutes.
      + intros y0. apply (has_homsets_opp hs).
      + cbn. intros y0 X. use CokernelOutsEq. rewrite CokernelCommutes. exact X.
  Qed.

  Definition Cokernel_opp {y z : C} (f : C⟦y, z⟧) (Z : Zero C) (CK : @Cokernel C Z y z f) :
    @Kernel (C^op) (Zero_opp Z) z y f.
  Proof.
    use make_Kernel.
    - exact CK.
    - exact (CokernelArrow CK).
    - exact (Cokernel_opp_eq f Z CK).
    - exact (Cokernel_opp_isKernel f Z CK).
  Defined.

  Definition Kernels_opp (Z : Zero C) (K : @Kernels C Z) : @Cokernels (C^op) (Zero_opp Z).
  Proof.
    intros x y f.
    use Kernel_opp.
    apply (K y x f).
  Defined.

  Definition Cokernels_opp (Z : Zero C) (CK : @Cokernels C Z) : @Kernels (C^op) (Zero_opp Z).
  Proof.
    intros x y f.
    use Cokernel_opp.
    apply (CK y x f).
  Defined.

  (** ** Pushouts and pullbacks *)

  Definition isPushout_opp {a b c d : C} (f : C⟦a, b⟧) (g : C⟦a, c⟧) (in1 : C⟦b, d⟧) (in2 : C⟦c, d⟧)
             (H : f · in1 = g · in2) (iPo : @isPushout C a b c d f g in1 in2 H) :
    @isPullback (C^op) a b c d f g in1 in2 H := iPo.

  Definition isPullback_opp {a b c d : C} (f : C⟦b, a⟧) (g : C⟦c, a⟧) (p1 : C⟦d, b⟧) (p2 : C⟦d, c⟧)
        (H : p1 · f = p2 · g) (iPb : @isPullback C a b c d f g p1 p2 H) :
    @isPushout (C^op) a b c d f g p1 p2 H := iPb.

  Definition Pushout_opp {a b c : C} (f : C⟦a, b⟧) (g : C⟦a, c⟧) (Po : @Pushout C a b c f g) :
    @Pullback (C^op) a b c f g := Po.

  Definition Pullback_opp {a b c : C} (f : C⟦b, a⟧) (g : C⟦c, a⟧) (Pb : @Pullback C a b c f g) :
    @Pushout (C^op) a b c f g := Pb.

  Definition Pushouts_opp (Pos : @Pushouts C) : @Pullbacks (C^op) := Pos.

  Definition Pullbacks_opp (Pbs : @Pushouts C) : @Pullbacks (C^op) := Pbs.

  (** ** BinProducts and BinCoproducts *)

  Definition isBinProduct_opp (c d p : C) (p1 : C⟦p, c⟧) (p2 : C⟦p, d⟧)
             (iBPC : @isBinProduct C c d p p1 p2) :
    @isBinCoproduct (C^op) c d p p1 p2 := iBPC.

  Definition isBinCoproduct_opp (a b co : C) (ia : C⟦a, co⟧) (ib : C⟦b, co⟧)
             (iBCC : @isBinCoproduct C a b co ia ib) :
    @isBinProduct (C^op) a b co ia ib := iBCC.

  Definition BinProduct_opp (c d : C) (iBPC : @BinProduct C c d) :
    @BinCoproduct (C^op) c d := iBPC.

  Definition BinCoproduct_opp (c d : C) (iBCC : @BinCoproduct C c d) :
    @BinProduct (C^op) c d := iBCC.

  Definition BinProducts_opp (BP : @BinProducts C) : @BinCoproducts (C^op) := BP.

  Definition BinCoproducts_opp (BC : @BinCoproducts C) : @BinProducts (C^op) := BC.

End def_opposites'.

Definition opp_zero_lifts {C:category} {X:Type} (j : X -> ob C) :
  zero_lifts C j -> zero_lifts C^op j.
Proof.
  apply hinhfun; intros [z iz]. exists z. exact (isZero_opp C iz).
Defined.


(*
    Authors: Thierry Coquand, Vincent Siles
*)
Require Import ssreflect ssrnat seq ssrbool eqtype fintype choice.

Set Implicit Arguments.

Section Language.

Variable char: finType.
Definition word := seq char.
Definition language := pred word.

End Language.

Lemma ltn_trans_tight m n p : m < n -> n < p -> m < p.-1.
Proof. elim: p n m => [|p IHp ] n m.
  by [].
move => H0. rewrite leq_eqVlt => /orP [].
  move/eqP => <-. exact: H0.
rewrite ltnS => H1. move: (IHp _ _ H0 H1) => /=.
case: p IHp H1 => [|p] IHp H1.
  by [].
by exact: ltnW.
Qed.

Lemma ltn_trans_tight' m n p : m < n -> n < p.-1 -> m < p.-1.
Proof. elim: p n m => [|p IHp ] n m.
  by [].
move => H0. rewrite leq_eqVlt => /orP [].
  move/eqP => <-. apply: leqW. by [].
move/leqW. apply: ltn_trans_tight. by apply: leqW.
Qed.

Lemma size_induction {X : Type} (f : X -> nat) (p: X ->Prop) :
( forall x, ( forall y, f y < f x -> p y) -> p x) -> forall x, p x.
Proof. intros A x. apply A. induction (f x). by [].
intros y B. apply A. intros z C. apply IHn.
move: C B. apply: ltn_trans_tight. Qed.


Require Export P05.

Theorem hoare_skip_weakest : forall Q,
  is_wp Q SKIP Q.
Proof.
  unfold is_wp. intros. split.
  - unfold hoare_triple. intros. inversion H. subst. assumption.
  - unfold hoare_triple. intros. unfold assert_implies. intros. eapply H. apply E_Skip. assumption.
Qed.

Theorem hoare_seq_weakest : forall P Q R c1 c2,
  is_wp P c1 Q ->
  is_wp Q c2 R ->
  is_wp P (c1 ;; c2) R.
Proof.
  Hint Constructors ceval.
  unfold is_wp.
  intros P Q R c1 c2 [H11 H12] [H21 H22].
  split.
  - apply hoare_seq with Q. assumption. assumption.
  - intros P' P'H. apply H12.
    unfold hoare_triple in *.
    intros.
    eapply H22.
    + intros. eauto.
    + unfold assert_implies in *. eauto.
Qed.


(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

(** * Finite sets library : conversion to old [Finite_sets] *)

Require Import Ensembles Finite_sets.
Require Import FSetInterface FSetProperties OrderedTypeEx DecidableTypeEx.

(** * Going from [FSets] with usual Leibniz equality
    to the good old [Ensembles] and [Finite_sets] theory. *)

Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U).
 Module MP:= WProperties_fun U M.
 Import M MP FM Ensembles Finite_sets.

 Definition mkEns : M.t -> Ensemble M.elt :=
   fun s x => M.In x s.

 Notation " !! " := mkEns.

 Lemma In_In : forall s x, M.In x s <-> In _ (!!s) x.
 Proof.
 unfold In; compute; auto with extcore.
 Qed.

 Lemma Subset_Included : forall s s',  s[<=]s'  <-> Included _ (!!s) (!!s').
 Proof.
 unfold Subset, Included, In, mkEns; intuition.
 Qed.

 Notation " a === b " := (Same_set M.elt a b) (at level 70, no associativity).

 Lemma Equal_Same_set : forall s s', s[=]s' <-> !!s === !!s'.
 Proof.
 intros.
 rewrite double_inclusion.
 unfold Subset, Included, Same_set, In, mkEns; intuition.
 Qed.

 Lemma empty_Empty_Set : !!M.empty === Empty_set _.
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intro; set_iff; inversion 1.
 Qed.

 Lemma Empty_Empty_set : forall s, Empty s -> !!s === Empty_set _.
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intros.
 destruct(H x H0).
 inversion H0.
 Qed.

 Lemma singleton_Singleton : forall x, !!(M.singleton x) === Singleton _ x .
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intro; set_iff; inversion 1; try constructor; auto.
 Qed.

 Lemma union_Union : forall s s', !!(union s s') === Union _ (!!s) (!!s').
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intro; set_iff; inversion 1; [ constructor 1 | constructor 2 | | ]; auto.
 Qed.

 Lemma inter_Intersection : forall s s', !!(inter s s') === Intersection _ (!!s) (!!s').
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intro; set_iff; inversion 1; try constructor; auto.
 Qed.

 Lemma add_Add : forall x s, !!(add x s) === Add _ (!!s) x.
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intro; set_iff; inversion 1; auto with sets.
 inversion H0.
 constructor 2; constructor.
 constructor 1; auto.
 Qed.

 Lemma Add_Add : forall x s s', MP.Add x s s' -> !!s' === Add _ (!!s) x.
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intros.
 red in H; rewrite H in H0.
 destruct H0.
 inversion H0.
 constructor 2; constructor.
 constructor 1; auto.
 red in H; rewrite H.
 inversion H0; auto.
 inversion H1; auto.
 Qed.

 Lemma remove_Subtract : forall x s, !!(remove x s) === Subtract _ (!!s) x.
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intro; set_iff; inversion 1; auto with sets.
 split; auto.
 contradict H1.
 inversion H1; auto.
 Qed.

 Lemma mkEns_Finite : forall s, Finite _ (!!s).
 Proof.
 intro s; pattern s; apply set_induction; clear s; intros.
 intros; replace (!!s) with (Empty_set elt); auto with sets.
 symmetry; apply Extensionality_Ensembles.
 apply Empty_Empty_set; auto.
 replace (!!s') with (Add _ (!!s) x).
 constructor 2; auto.
 symmetry; apply Extensionality_Ensembles.
 apply Add_Add; auto.
 Qed.

 Lemma mkEns_cardinal : forall s, cardinal _ (!!s) (M.cardinal s).
 Proof.
 intro s; pattern s; apply set_induction; clear s; intros.
 intros; replace (!!s) with (Empty_set elt); auto with sets.
 rewrite cardinal_1; auto with sets.
 symmetry; apply Extensionality_Ensembles.
 apply Empty_Empty_set; auto.
 replace (!!s') with (Add _ (!!s) x).
 rewrite (cardinal_2 H0 H1); auto with sets.
 symmetry; apply Extensionality_Ensembles.
 apply Add_Add; auto.
 Qed.

 (** we can even build a function from Finite Ensemble to FSet
     ... at least in Prop. *)

 Lemma Ens_to_FSet : forall e : Ensemble M.elt, Finite _ e ->
   exists s:M.t, !!s === e.
 Proof.
 induction 1.
 exists M.empty.
 apply empty_Empty_Set.
 destruct IHFinite as (s,Hs).
 exists (M.add x s).
 apply Extensionality_Ensembles in Hs.
 rewrite <- Hs.
 apply add_Add.
 Qed.

End WS_to_Finite_set.

Module S_to_Finite_set (U:UsualOrderedType)(M: Sfun U) :=
  WS_to_Finite_set U M.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrfun ssrnat eqtype seq.
From Heaps
Require Import pred prelude.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

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

Module Poset.

Section RawMixin.

Record mixin_of (T : Type) := Mixin {
  mx_leq : T -> T -> Prop;
  _ : forall x, mx_leq x x;
  _ : forall x y, mx_leq x y -> mx_leq y x -> x = y;
  _ : forall x y z, mx_leq x y -> mx_leq y z -> mx_leq x z}.

End RawMixin.

Section ClassDef.

Record class_of T := Class {mixin : mixin_of T}.

Structure type : Type := Pack {sort : Type; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack T c T.

(* produce a poset type out of the mixin *)
(* equalize m0 and m by means of a phantom *)
Definition pack (m0 : mixin_of T) :=
  fun m & phant_id m0 m => Pack (@Class T m) T.

Definition leq := mx_leq (mixin class).

End ClassDef.

Module Exports.
Coercion sort : type >-> Sortclass.
Notation poset := Poset.type.
Notation PosetMixin := Poset.Mixin.
Notation Poset T m := (@pack T _ m id).

Notation "[ 'poset' 'of' T 'for' cT ]" := (@clone T cT _ id)
  (at level 0, format "[ 'poset'  'of'  T  'for'  cT ]") : form_scope.
Notation "[ 'poset' 'of' T ]" := (@clone T _ _ id)
  (at level 0, format "[ 'poset'  'of'  T ]") : form_scope.

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

(* re-state lattice properties using the exported notation *)
Section Laws.
Variable T : poset.

Lemma poset_refl (x : T) : x <== x.
Proof. by case: T x=>S [[leq B R]]. Qed.

Lemma poset_asym (x y : T) : x <== y -> y <== x -> x = y.
Proof. by case: T x y=>S [[l R A Tr]] *; apply: (A). Qed.

Lemma poset_trans (y x z : T) : x <== y -> y <== z -> x <== z.
Proof. by case: T y x z=>S [[l R A Tr]] ? x y z; apply: (Tr). Qed.

End Laws.

Hint Resolve poset_refl.

Add Parametric Relation (T : poset) : T (@Poset.leq T)
  reflexivity proved by (@poset_refl _)
  transitivity proved by (fun x y => @poset_trans _ y x) as poset_rel.

End Exports.

End Poset.

Export Poset.Exports.

(**************************)
(* some basic definitions *)
(**************************)

Definition monotone (T1 T2 : poset) (f : T1 -> T2) :=
  forall x y, x <== y -> f x <== f y.

Section IdealDef.
Variable T : poset.

Structure ideal (P : T) := Ideal {id_val : T; id_pf : id_val <== P}.

(* Changing the type of the ideal *)

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

Definition relax (P1 P2 : T) (x : ideal P1) (pf : P1 <== P2) :=
  Ideal (relaxP pf (id_pf x)).

End IdealDef.

(***********************)
(* poset constructions *)
(***********************)

Section SubPoset.
Variables (T : poset) (s : Pred T).

Local Notation tp := {x : T | x \In s}.

Definition sub_leq (p1 p2 : tp) := sval p1 <== sval p2.

Lemma sub_refl x : sub_leq x x.
Proof. by rewrite /sub_leq. Qed.

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

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

(* no need to put canonical here, because the system won't be *)
(* able to get the proof C from the {x : T | x \In s} syntax *)
Definition subPosetMixin := PosetMixin sub_refl sub_asym sub_trans.
Definition subPoset := Eval hnf in Poset tp subPosetMixin.

End SubPoset.

(* pairing of posets *)

Section PairPoset.
Variable (A B : poset).
Local Notation tp := (A * B)%type.

Definition pair_leq (p1 p2 : tp) := p1.1 <== p2.1 /\ p1.2 <== p2.2.

Lemma pair_refl x : pair_leq x x.
Proof. by []. Qed.

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

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

Definition pairPosetMixin :=
  PosetMixin pair_refl pair_asym pair_trans.
Canonical pairPoset := Eval hnf in Poset tp pairPosetMixin.

End PairPoset.

(* functions into a poset form a poset *)

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

Definition fun_leq (p1 p2 : tp) := forall x, p1 x <== p2 x.

Lemma fun_refl x : fun_leq x x.
Proof. by []. Qed.

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

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

Definition funPosetMixin := PosetMixin fun_refl fun_asym fun_trans.
Canonical funPoset := Eval hnf in Poset tp funPosetMixin.

End FunPoset.

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

Section DFunPoset.
Variables (A : Type) (B : A -> poset).
Local Notation tp := (forall x, B x).

Definition dfun_leq (p1 p2 : tp) := forall x, p1 x <== p2 x.

Lemma dfun_refl x : dfun_leq x x.
Proof. by []. Qed.

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

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

(* no point in declaring this canonical, since it's keyed on forall *)
(* and forall is not a symbol *)
Definition dfunPosetMixin :=
  PosetMixin dfun_refl dfun_asym dfun_trans.
Definition dfunPoset := Eval hnf in Poset tp dfunPosetMixin.

End DFunPoset.

(* ideal of a poset is a poset *)

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

Definition ideal_leq (p1 p2 : ideal P) := id_val p1 <== id_val p2.

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

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

Lemma ideal_trans x y z : ideal_leq x y -> ideal_leq y z -> ideal_leq x z.
Proof. by apply: poset_trans. Qed.

Definition idealPosetMixin :=
  PosetMixin ideal_refl ideal_asym ideal_trans.
Canonical idealPoset := Eval hnf in Poset (ideal P) idealPosetMixin.

End IdealPoset.

(* Prop is a poset *)

Section PropPoset.

Definition prop_leq (p1 p2 : Prop) := p1 -> p2.

Lemma prop_refl x : prop_leq x x.
Proof. by []. Qed.

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

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

Definition propPosetMixin :=
  PosetMixin prop_refl prop_asym prop_trans.
Canonical propPoset := Eval hnf in Poset Prop propPosetMixin.

End PropPoset.

(* Pred is a poset *)

(* Can be inherited from posets of -> and Prop, but we declare a *)
(* dedicated structure to keep the infix notation of Pred. Otherwise, *)
(* poset inference turns Pred A into A -> Prop. *)

(*
Section PredPoset.
Variable A : Type.

Definition predPosetMixin : Poset.mixin_of (Pred A) :=
  funPosetMixin A propPoset.
Canonical predPoset := Eval hnf in Poset (Pred A) predPosetMixin.

End PredPoset.
*)

(*********************)
(* Complete lattices *)
(*********************)

Module Lattice.

Section RawMixin.

Variable T : poset.

Record mixin_of := Mixin {
  mx_sup : Pred T -> T;
  _ : forall (s : Pred T) x, x \In s -> x <== mx_sup s;
  _ : forall (s : Pred T) x,
        (forall y, y \In s -> y <== x) -> mx_sup s <== x}.

End RawMixin.

Section ClassDef.

Record class_of (T : Type) := Class {
  base : Poset.class_of T;
  mixin : mixin_of (Poset.Pack base T)}.

Local Coercion base : class_of >-> Poset.class_of.

Structure type : Type := Pack {sort : Type; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack T c T.

(* produce a lattice type out of the mixin *)
(* equalize m0 and m by means of a phantom *)
Definition pack b0 (m0 : mixin_of (Poset.Pack b0 T)) :=
  fun m & phant_id m0 m => Pack (@Class T b0 m) T.

Definition sup (s : Pred cT) : cT := mx_sup (mixin class) s.

Definition poset := Poset.Pack class cT.

End ClassDef.

Module Exports.
Coercion base : class_of >-> Poset.class_of.
Coercion sort : type >-> Sortclass.
Coercion poset : type >-> Poset.type.
Canonical Structure poset.

Notation lattice := Lattice.type.
Notation LatticeMixin := Lattice.Mixin.
Notation Lattice T m := (@pack T _ _ m id).

Notation "[ 'lattice' 'of' T 'for' cT ]" := (@clone T cT _ id)
  (at level 0, format "[ 'lattice'  'of'  T  'for' cT ]") : form_scope.
Notation "[ 'lattice' 'of' T ]" := (@clone T _ _ id)
  (at level 0, format "[ 'lattice'  'of'  T ]") : form_scope.

Implicit Arguments Lattice.sup [cT].
Prenex Implicits Lattice.sup.
Notation sup := Lattice.sup.

(* re-state lattice properties using the exported notation *)
Section Laws.
Variable T : lattice.

Lemma supP (s : Pred T) x : x \In s -> x <== sup s.
Proof. by case: T s x=>S [[p]][/= s H1 *]; apply: H1. Qed.

Lemma supM (s : Pred T) x : (forall y, y \In s -> y <== x) -> sup s <== x.
Proof. by case: T s x=>S [[p]][/= s H1 H2 *]; apply: (H2). Qed.

End Laws.

End Exports.

End Lattice.

Export Lattice.Exports.

(* we have greatest lower bounds too *)
Section Infimum.
Variable T : lattice.

Definition inf (s : Pred T) :=
  sup [Pred x : T | forall y, y \In s -> x <== y].

Lemma infP s : forall x, x \In s -> inf s <== x.
Proof. by move=>x H; apply: supM=>y; apply. Qed.

Lemma infM s : forall x, (forall y, y \In s -> x <== y) -> x <== inf s.
Proof. by apply: supP. Qed.

End Infimum.

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

Section Lat.
Variable T : lattice.

Definition lbot : T := sup Pred0.

Definition tarski_lfp (f : T -> T) := inf [Pred x : T | f x <== x].
Definition tarski_gfp (f : T -> T) := sup [Pred x : T | x <== f x].

Definition sup_closed (T : lattice) :=
  [Pred s : Pred T | forall d, d <=p s -> sup d \In s].

Definition sup_closure (T : lattice) (s : Pred T) :=
  [Pred p : T | forall t : Pred T, s <=p t -> t \In sup_closed T -> p \In t].

End Lat.

Implicit Arguments lbot [T].
Implicit Arguments sup_closed [T].
Implicit Arguments sup_closure [T].
Prenex Implicits sup_closed sup_closure.

Section BasicProperties.
Variable T : lattice.

Lemma sup_mono (s1 s2 : Pred T) : s1 <=p s2 -> sup s1 <== sup s2.
Proof. by move=>H; apply: supM=>y; move/H; apply: supP. Qed.

Lemma supE (s1 s2 : Pred T) : s1 =p s2 -> sup s1 = sup s2.
Proof. by move=>H; apply: poset_asym; apply: supM=>y; move/H; apply: supP. Qed.

(* Knaster-Tarski *)
Lemma tarski_lfp_fixed (f : T -> T) :
        monotone f -> f (tarski_lfp f) = tarski_lfp f.
Proof.
move=>M; suff L: f (tarski_lfp f) <== tarski_lfp f.
- by apply: poset_asym=>//; apply: infP; apply: M L.
by apply: infM=>x L; apply: poset_trans (L); apply: M; apply: infP.
Qed.

Lemma tarski_lfp_least f : forall x : T, f x = x -> tarski_lfp f <== x.
Proof. by move=>x H; apply: infP; rewrite InE /= H. Qed.

Lemma tarski_gfp_fixed (f : T -> T) :
        monotone f -> f (tarski_gfp f) = tarski_gfp f.
Proof.
move=>M; suff L: tarski_gfp f <== f (tarski_gfp f).
- by apply: poset_asym=>//; apply: supP; apply: M L.
by apply: supM=>x L; apply: poset_trans (L) _; apply: M; apply: supP.
Qed.

Lemma tarski_gfp_greatest f : forall x : T, f x = x -> x <== tarski_gfp f.
Proof. by move=>x H; apply: supP; rewrite InE /= H. Qed.

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

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

(* closure is closed *)
Lemma sup_closP (s : Pred T) : sup_closed (sup_closure s).
Proof.
move=>d H1 t H3 H4; move: (sup_clos_min H3 H4)=>{H3} H3.
by apply: H4=>x; move/H1; move/H3.
Qed.

Lemma sup_clos_idemp (s : Pred T) : sup_closed s -> sup_closure s =p s.
Proof. by move=>p; split; [apply: sup_clos_min | apply: sup_clos_sub]. Qed.

Lemma sup_clos_mono (s1 s2 : Pred T) :
        s1 <=p s2 -> sup_closure s1 <=p sup_closure s2.
Proof.
move=>H1; apply: sup_clos_min (@sup_closP s2).
by move=>t /H1; apply: sup_clos_sub.
Qed.

End BasicProperties.

(* lattice constructions *)

Section SubLattice.
Variables (T : lattice) (s : Pred T) (C : sup_closed s).
Local Notation tp := (subPoset s).

Definition sub_sup' (u : Pred tp) : T :=
  sup [Pred x : T | exists y, y \In u /\ x = sval y].

Lemma sub_supX (u : Pred tp) : sub_sup' u \In s.
Proof. by apply: C=>x [][y H][_] ->. Qed.

Definition sub_sup (u : Pred tp) : tp :=
  exist _ (sub_sup' u) (sub_supX u).

Lemma sub_supP (u : Pred tp) (x : tp) : x \In u -> x <== sub_sup u.
Proof. by move=>H; apply: supP; exists x. Qed.

Lemma sub_supM (u : Pred tp) (x : tp) :
        (forall y, y \In u -> y <== x) -> sub_sup u <== x.
Proof. by move=>H; apply: supM=>y [z][H1] ->; apply: H H1. Qed.

Definition subLatticeMixin := LatticeMixin sub_supP sub_supM.
Definition subLattice := Eval hnf in Lattice {x : T | x \In s} subLatticeMixin.

End SubLattice.

(* pairing *)

Section PairLattice.
Variables (A B : lattice).
Local Notation tp := (A * B)%type.

Definition pair_sup (s : Pred tp) : tp :=
            (sup [Pred p | exists f, p = f.1 /\ f \In s],
             sup [Pred p | exists f, p = f.2 /\ f \In s]).

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

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

Definition pairLatticeMixin := LatticeMixin pair_supP pair_supM.
Canonical pairLattice := Eval hnf in Lattice tp pairLatticeMixin.

End PairLattice.

(* functions into a latice form a lattice *)

Section FunLattice.
Variables (A : Type) (B : lattice).
Local Notation tp := (A -> B).

Definition fun_sup (s : Pred tp) : tp :=
  fun x => sup [Pred p | exists f, f \In s /\ p = f x].

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

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

Definition funLatticeMixin := LatticeMixin fun_supP fun_supM.
Canonical funLattice := Eval hnf in Lattice tp funLatticeMixin.

End FunLattice.

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

Section DFunLattice.
Variables (A : Type) (B : A -> lattice).
Local Notation tp := (dfunPoset B).

Definition dfun_sup (s : Pred tp) : tp :=
  fun x => sup [Pred p | exists f, f \In s /\ p = f x].

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

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

Definition dfunLatticeMixin := LatticeMixin dfun_supP dfun_supM.
Definition dfunLattice := Eval hnf in Lattice (forall x, B x) dfunLatticeMixin.

End DFunLattice.

(* applied sup equals the sup of applications *)

Lemma sup_appE A (B : lattice) (s : Pred (A -> B)) (x : A) :
        sup s x = sup [Pred y : B | exists f, f \In s /\ y = f x].
Proof. by []. Qed.

Lemma sup_dappE A (B : A -> lattice) (s : Pred (dfunLattice B)) (x : A) :
        sup s x = sup [Pred y : B x | exists f, f \In s /\ y = f x].
Proof. by []. Qed.

(* ideal of a lattice forms a lattice *)

Section IdealLattice.
Variables (T : lattice) (P : T).

Definition ideal_sup' (s : Pred (ideal P)) :=
  sup [Pred x | exists p, p \In s /\ id_val p = x].

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

Definition ideal_sup (s : Pred (ideal P)) := Ideal (ideal_supP' s).

Lemma ideal_supP (s : Pred (ideal P)) p :
        p \In s -> p <== ideal_sup s.
Proof. by move=>H; apply: supP; exists p. Qed.

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

Definition idealLatticeMixin := LatticeMixin ideal_supP ideal_supM.
Canonical idealLattice := Eval hnf in Lattice (ideal P) idealLatticeMixin.

End IdealLattice.

(* Prop is a lattice *)

Section PropLattice.

Definition prop_sup (s : Pred Prop) : Prop := exists p, p \In s /\ p.

Lemma prop_supP (s : Pred Prop) p : p \In s -> p <== prop_sup s.
Proof. by exists p. Qed.

Lemma prop_supM (s : Pred Prop) p :
        (forall q, q \In s -> q <== p) -> prop_sup s <== p.
Proof. by move=>H [r][]; move/H. Qed.

Definition propLatticeMixin := LatticeMixin prop_supP prop_supM.
Canonical propLattice := Eval hnf in Lattice Prop propLatticeMixin.

End PropLattice.

(*
(* Pred is a lattice *)

Section PredLattice.
Variable A : Type.

Definition predLatticeMixin := funLatticeMixin A propLattice.
Canonical predLattice := Eval hnf in Lattice (Pred A) predLatticeMixin.

End PredLattice.
*)

(* monotonicity *)

Lemma id_mono (T : poset) : monotone (@id T).
Proof. by []. Qed.

Implicit Arguments id_mono [T].
Prenex Implicits id_mono.

Lemma const_mono (T1 T2 : poset) (y : T2) : monotone (fun x : T1 => y).
Proof. by []. Qed.

Implicit Arguments const_mono [T1 T2 y].
Prenex Implicits const_mono.

Lemma comp_mono (T1 T2 T3 : poset) (f1 : T2 -> T1) (f2 : T3 -> T2) :
        monotone f1 -> monotone f2 -> monotone (f1 \o f2).
Proof. by move=>M1 M2 x y H; apply: M1; apply: M2. Qed.

Implicit Arguments comp_mono [T1 T2 T3 f1 f2].
Prenex Implicits comp_mono.

Lemma proj1_mono (T1 T2 : poset) : monotone (@fst T1 T2).
Proof. by case=>x1 x2 [y1 y2][]. Qed.

Lemma proj2_mono (T1 T2 : poset) : monotone (@snd T1 T2).
Proof. by case=>x1 x2 [y1 y2][]. Qed.

Implicit Arguments proj1_mono [T1 T2].
Implicit Arguments proj2_mono [T1 T2].
Prenex Implicits proj1_mono proj2_mono.

Lemma diag_mono (T : poset) : monotone (fun x : T => (x, x)).
Proof. by []. Qed.

Implicit Arguments diag_mono [T].
Prenex Implicits diag_mono.

Lemma app_mono A (T : poset) (x : A) : monotone (fun f : A -> T => f x).
Proof. by move=>f1 f2; apply. Qed.

Implicit Arguments app_mono [A T].
Prenex Implicits app_mono.

Lemma dapp_mono A (T : A -> poset) (x : A) :
  monotone (fun f : dfunPoset T => f x).
Proof. by move=>f1 f2; apply. Qed.

Implicit Arguments dapp_mono [A T].
Prenex Implicits dapp_mono.

Lemma prod_mono (S1 S2 T1 T2 : poset) (f1 : S1 -> T1) (f2 : S2 -> T2) :
        monotone f1 -> monotone f2 -> monotone (f1 \* f2).
Proof.
by move=>M1 M2 [x1] x2 [y1 y2][/= H1 H2]; split; [apply: M1 | apply: M2].
Qed.

Implicit Arguments prod_mono [S1 S2 T1 T2 f1 f2].
Prenex Implicits prod_mono.

(**********)
(* Chains *)
(**********)

Section Chains.
Variable T : poset.

Definition chain_axiom (s : Pred T) :=
  (exists d, d \In s) /\
  (forall x y, x \In s -> y \In s -> x <== y \/ y <== x).

Structure chain := Chain {
  pred_of :> Pred T;
  _ : chain_axiom pred_of}.

Canonical chainPredType := @mkPredType T chain pred_of.

End Chains.

Lemma chainE (T : poset) (s1 s2 : chain T) :
        s1 = s2 <-> pred_of s1 =p pred_of s2.
Proof.
split=>[->//|]; move: s1 s2=>[s1 H1][s2 H2] /= E; move: H1 H2.
suff: s1 = s2 by move=>-> H1 H2; congr Chain; apply: proof_irrelevance.
by apply: fext=>x; apply: pext; split; move/E.
Qed.

(* mapping monotone function over a chain *)

Section ImageChain.
Variables (T1 T2 : poset) (s : chain T1) (f : T1 -> T2) (M : monotone f).

Lemma image_chainP :
        chain_axiom [Pred x2 : T2 | exists x1, x2 = f x1 /\ x1 \In s].
Proof.
case: s=>p [[d H1] H2]; split=>[|x y]; first by exists (f d); exists d.
case=>x1 [->] H3 [y1][->] H4; rewrite -!toPredE /= in H3 H4.
by case: (H2 x1 y1 H3 H4)=>L; [left | right]; apply: M L.
Qed.

Definition image_chain := Chain image_chainP.

End ImageChain.

Notation "[ f '^^' s 'by' M ]" := (@image_chain _ _ s f M)
  (at level 0, format "[ f  '^^'  s  'by'  M ]") : form_scope.

(* some chain constructions *)

Section ChainId.
Variables (T : poset) (s : chain T).

Lemma id_chainE (M : monotone id) : [id ^^ s by M] = s.
Proof. by apply/chainE=>x; split; [case=>y [<-]|exists x]. Qed.

End ChainId.

Section ChainConst.
Variables (T1 T2 : poset) (y : T2).

Lemma const_chainP : chain_axiom (Pred1 y).
Proof. by split; [exists y | move=>x1 x2 ->->; left]. Qed.

Definition const_chain := Chain const_chainP.

Lemma const_chainE s : [_ ^^ s by @const_mono T1 T2 y] = const_chain.
Proof.
apply/chainE=>z1; split; first by case=>z2 [->].
by case: s=>s [[d] H1] H2 <-; exists d.
Qed.

End ChainConst.

Section ChainCompose.
Variables (T1 T2 T3 : poset) (f1 : T2 -> T1) (f2 : T3 -> T2).
Variables (s : chain T3) (M1 : monotone f1) (M2 : monotone f2).

Lemma comp_chainE :
        [f1 ^^ [f2 ^^ s by M2] by M1] = [f1 \o f2 ^^ s by comp_mono M1 M2].
Proof.
apply/chainE=>x1; split; first by case=>x2 [->][x3][->]; exists x3.
by case=>x3 [->]; exists (f2 x3); split=>//; exists x3.
Qed.

End ChainCompose.

(* projections out of a chain *)

Section ProjChain.
Variables (T1 T2 : poset) (s : chain [poset of T1 * T2]).

Definition proj1_chain := [@fst _ _ ^^ s by proj1_mono].
Definition proj2_chain := [@snd _ _ ^^ s by proj2_mono].

End ProjChain.

(* diagonal chain *)

Section DiagChain.
Variable (T : poset) (s : chain T).

Definition diag_chain := [_ ^^ s by @diag_mono T].

Lemma proj1_diagE : proj1_chain diag_chain = s.
Proof. by rewrite /proj1_chain /diag_chain comp_chainE id_chainE. Qed.

Lemma proj2_diagE : proj2_chain diag_chain = s.
Proof. by rewrite /proj2_chain /diag_chain comp_chainE id_chainE. Qed.

End DiagChain.

(* applying functions from a chain of functions *)

Section AppChain.
Variables (A : Type) (T : poset) (s : chain [poset of A -> T]).

Definition app_chain x := [_ ^^ s by app_mono x].

End AppChain.

(* ditto for dependent functions *)

Section DAppChain.
Variables (A : Type) (T : A -> poset) (s : chain (dfunPoset T)).

Definition dapp_chain x := [_ ^^ s by dapp_mono x].

End DAppChain.

(* pairing chain applications *)

Section ProdChain.
Variables (S1 S2 T1 T2 : poset) (f1 : S1 -> T1) (f2 : S2 -> T2).
Variables (M1 : monotone f1) (M2 : monotone f2).
Variable (s : chain [poset of S1 * S2]).

Definition prod_chain := [f1 \* f2 ^^ s by prod_mono M1 M2].

Lemma proj1_prodE : proj1_chain prod_chain = [f1 ^^ proj1_chain s by M1].
Proof.
rewrite /proj1_chain /prod_chain !comp_chainE !/comp /=.
by apply/chainE.
Qed.

Lemma proj2_prodE : proj2_chain prod_chain = [f2 ^^ proj2_chain s by M2].
Proof.
rewrite /proj2_chain /prod_chain !comp_chainE !/comp /=.
by apply/chainE.
Qed.

End ProdChain.

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

Module CPO.

Section RawMixin.

Record mixin_of (T : poset) := Mixin {
  mx_bot : T;
  mx_lim : chain T -> T;
  _ : forall x, mx_bot <== x;
  _ : forall (s : chain T) x, x \In s -> x <== mx_lim s;
  _ : forall (s : chain T) x,
        (forall y, y \In s -> y <== x) -> mx_lim s <== x}.

End RawMixin.

Section ClassDef.

Record class_of (T : Type) := Class {
  base : Poset.class_of T;
  mixin : mixin_of (Poset.Pack base T)}.

Local Coercion base : class_of >-> Poset.class_of.

Structure type : Type := Pack {sort; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack T c T.

Definition pack b0 (m0 : mixin_of (Poset.Pack b0 T)) :=
  fun m & phant_id m0 m => Pack (@Class T b0 m) T.

Definition poset := Poset.Pack class cT.
Definition lim (s : chain poset) : cT := mx_lim (mixin class) s.
Definition bot : cT := mx_bot (mixin class).

End ClassDef.

Module Import Exports.
Coercion base : class_of >-> Poset.class_of.
Coercion sort : type >-> Sortclass.
Coercion poset : type >-> Poset.type.
Canonical Structure poset.

Notation cpo := type.
Notation CPOMixin := Mixin.
Notation CPO T m := (@pack T _ _ m id).

Notation "[ 'cpo' 'of' T 'for' cT ]" := (@clone T cT _ idfun)
  (at level 0, format "[ 'cpo'  'of'  T  'for'  cT ]") : form_scope.
Notation "[ 'cpo' 'of' T ]" := (@clone T _ _ id)
  (at level 0, format "[ 'cpo'  'of'  T ]") : form_scope.

Implicit Arguments CPO.bot [cT].
Implicit Arguments CPO.lim [cT].
Prenex Implicits CPO.lim.
Prenex Implicits CPO.bot.
Notation lim := CPO.lim.
Notation bot := CPO.bot.

Section Laws.
Variable D : cpo.

Lemma botP (x : D) : bot <== x.
Proof. by case: D x=>S [[p]][/= b l H1 *]; apply: H1. Qed.

Lemma limP (s : chain D) x : x \In s -> x <== lim s.
Proof. by case: D s x=>S [[p]][/= b l H1 H2 *]; apply: (H2). Qed.

Lemma limM (s : chain D) x : (forall y, y \In s -> y <== x) -> lim s <== x.
Proof. by case: D s x=>S [[p]][/= b l H1 H2 H3 *]; apply: (H3). Qed.

End Laws.

End Exports.

End CPO.

Export CPO.Exports.

Hint Resolve botP.

(* common chain constructions *)

(* adding bot to a chain *)

Section LiftChain.
Variable (D : cpo) (s : chain D).

Hint Resolve botP.

Lemma lift_chainP : chain_axiom [Pred x : D | x = bot \/ x \In s].
Proof.
case: s=>p [[d H1] H2] /=; split=>[|x y]; first by exists d; right.
by case=>[->|H3][->|H4]; auto.
Qed.

Definition lift_chain := Chain lift_chainP.

End LiftChain.

(****************************)
(* common cpo constructions *)
(****************************)

(* pairs *)

Section PairCPO.
Variables (A B : cpo).
Local Notation tp := [poset of A * B].

Definition pair_bot : tp := (bot, bot).

Definition pair_lim (s : chain tp) : tp :=
  (lim (proj1_chain s), lim (proj2_chain s)).

Lemma pair_botP x : pair_leq pair_bot x.
Proof. by split; apply: botP. Qed.

Lemma pair_limP (s : chain tp) x : x \In s -> x <== pair_lim s.
Proof. by split; apply: limP; exists x. Qed.

Lemma pair_limM (s : chain tp) x :
        (forall y, y \In s -> y <== x) -> pair_lim s <== x.
Proof. by split; apply: limM=>y [z][->]; case/H. Qed.

Definition pairCPOMixin := CPOMixin pair_botP pair_limP pair_limM.
Canonical pairCPO := Eval hnf in CPO (A * B) pairCPOMixin.

End PairCPO.

(* functions *)

Section FunCPO.
Variable (A : Type) (B : cpo).
Local Notation tp := [poset of A -> B].

Definition fun_bot : tp := fun x => bot.

Definition fun_lim (s : chain tp) : tp :=
  fun x => lim (app_chain s x).

Lemma fun_botP x : fun_leq fun_bot x.
Proof. by move=>y; apply: botP. Qed.

Lemma fun_limP (s : chain tp) x : x \In s -> x <== fun_lim s.
Proof. by move=>H t; apply: limP; exists x. Qed.

Lemma fun_limM (s : chain tp) x :
        (forall y, y \In s -> y <== x) -> fun_lim s <== x.
Proof. by move=>H1 t; apply: limM=>y [f][->] H2; apply: H1. Qed.

Definition funCPOMixin := CPOMixin fun_botP fun_limP fun_limM.
Canonical funCPO := Eval hnf in CPO (A -> B) funCPOMixin.

End FunCPO.

(* dependent functions *)

Section DFunCPO.
Variable (A : Type) (B : A -> cpo).
Local Notation tp := (dfunPoset B).

Definition dfun_bot : tp := fun x => bot.

Definition dfun_lim (s : chain tp) : tp :=
  fun x => lim (dapp_chain s x).

Lemma dfun_botP x : dfun_bot <== x.
Proof. by move=>y; apply: botP. Qed.

Lemma dfun_limP (s : chain tp) x : x \In s -> x <== dfun_lim s.
Proof. by move=>H t; apply: limP; exists x. Qed.

Lemma dfun_limM (s : chain tp) x :
        (forall y, y \In s -> y <== x) -> dfun_lim s <== x.
Proof. by move=>H1 t; apply: limM=>y [f][->] H2; apply: H1. Qed.

Definition dfunCPOMixin := CPOMixin dfun_botP dfun_limP dfun_limM.
Definition dfunCPO := Eval hnf in CPO (forall x, B x) dfunCPOMixin.

End DFunCPO.

(* Prop *)

Section PropCPO.
Local Notation tp := [poset of Prop].

Definition prop_bot : tp := False.

Definition prop_lim (s : chain tp) : tp := exists p, p \In s /\ p.

Lemma prop_botP x : prop_bot <== x.
Proof. by []. Qed.

Lemma prop_limP (s : chain tp) p : p \In s -> p <== prop_lim s.
Proof. by exists p. Qed.

Lemma prop_limM (s : chain tp) p :
        (forall q, q \In s -> q <== p) -> prop_lim s <== p.
Proof. by move=>H [r][]; move/H. Qed.

Definition propCPOMixin := CPOMixin prop_botP prop_limP prop_limM.
Canonical propCPO := Eval hnf in CPO Prop propCPOMixin.

End PropCPO.

(* Pred *)

Section PredCPO.
Variable A : Type.

Definition predCPOMixin := funCPOMixin A propCPO.
Canonical predCPO := Eval hnf in CPO (Pred A) predCPOMixin.

End PredCPO.

(* every complete lattice is a cpo *)

Section LatticeCPO.
Variable A : lattice.
Local Notation tp := (Lattice.poset A).

Definition lat_bot : tp := lbot.

Definition lat_lim (s : chain tp) : tp := sup s.

Lemma lat_botP x : lat_bot <== x.
Proof. by apply: supM. Qed.

Lemma lat_limP (s : chain tp) x : x \In s -> x <== lat_lim s.
Proof. by apply: supP. Qed.

Lemma lat_limM (s : chain tp) x :
        (forall y, y \In s -> y <== x) -> lat_lim s <== x.
Proof. by apply: supM. Qed.

Definition latCPOMixin := CPOMixin lat_botP lat_limP lat_limM.
Definition latCPO := Eval hnf in CPO tp latCPOMixin.

End LatticeCPO.

(* sub-CPO's *)

(* every chain-closed subset of a cpo is a cpo *)

Section AdmissibleClosure.
Variable T : cpo.

Definition chain_closed :=
  [Pred s : Pred T |
     bot \In s /\ forall d : chain T, d <=p s -> lim d \In s].

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

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

(* admissible closure is smallest *)
Lemma chain_clos_min (s : Pred T) t :
        s <=p t -> chain_closed t -> chain_closure s <=p t.
Proof. by move=>H1 H2 p; move/(_ _ H1 H2). Qed.

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

Lemma chain_clos_idemp (s : Pred T) :
        chain_closed s -> chain_closure s =p s.
Proof.
move=>p; split; last by apply: chain_clos_sub.
by apply: chain_clos_min=>//; apply: chain_closP.
Qed.

Lemma chain_clos_mono (s1 s2 : Pred T) :
        s1 <=p s2 -> chain_closure s1 <=p chain_closure s2.
Proof.
move=>H1; apply: chain_clos_min (chain_closP s2)=>p H2.
by apply: chain_clos_sub; apply: H1.
Qed.

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

End AdmissibleClosure.

Implicit Arguments chain_closed [T].
Prenex Implicits chain_closed.

(* diagonal of an admissible set of pairs is admissible *)
Lemma chain_clos_diag (T : cpo) (s : Pred (T * T)) :
        chain_closed s -> chain_closed [Pred t : T | (t, t) \In s].
Proof.
move=>[B H1]; split=>// d H2.
rewrite InE /= -{1}(proj1_diagE d) -{2}(proj2_diagE d).
by apply: H1; case=>x1 x2 [x][[<- <-]]; apply: H2.
Qed.

Section SubCPO.
Variables (D : cpo) (s : Pred D) (C : chain_closed s).
Local Notation tp := (subPoset s).

Definition sub_bot := exist _ (@bot D) (proj1 C).

Lemma sub_botP (x : tp) : sval sub_bot <== sval x.
Proof. by apply: botP. Qed.

Lemma sval_mono : monotone (sval : tp -> D).
Proof. by move=>[x1 H1][x2 H2]; apply. Qed.

Lemma sub_limX (u : chain tp) : lim [sval ^^ u by sval_mono] \In s.
Proof. by case: C u=>P H u; apply: (H)=>t [[y]] H1 [->]. Qed.

Definition sub_lim (u : chain tp) : tp :=
  exist _ (lim [sval ^^ u by sval_mono]) (sub_limX u).

Lemma sub_limP (u : chain tp) x : x \In u -> x <== sub_lim u.
Proof. by move=>H; apply: limP; exists x. Qed.

Lemma sub_limM (u : chain tp) x :
        (forall y, y \In u -> y <== x) -> sub_lim u <== x.
Proof. by move=>H; apply: limM=>y [z][->]; apply: H. Qed.

Definition subCPOMixin := CPOMixin sub_botP sub_limP sub_limM.
Definition subCPO := Eval hnf in CPO {x : D | x \In s} subCPOMixin.

End SubCPO.

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

Lemma lim_mono (D : cpo) (s1 s2 : chain D) :
        s1 <=p s2 -> lim s1 <== lim s2.
Proof. by move=>H; apply: limM=>y; move/H; apply: limP. Qed.

Lemma limE (D : cpo) (s1 s2 : chain D) :
        s1 =p s2 -> lim s1 = lim s2.
Proof. by move=>H; apply: poset_asym; apply: lim_mono=>x; rewrite H. Qed.

Lemma lim_liftE (D : cpo) (s : chain D) :
        lim s = lim (lift_chain s).
Proof.
apply: poset_asym; apply: limM=>y H; first by apply: limP; right.
by case: H; [move=>-> | apply: limP].
Qed.

(* applied lim equals the lim of applications *)
(* ie., part of continuity of application *)
(* but is so often used, I give it a name *)

Lemma lim_appE A (D : cpo) (s : chain [cpo of A -> D]) (x : A) :
        lim s x = lim (app_chain s x).
Proof. by []. Qed.

Lemma lim_dappE A (D : A -> cpo) (s : chain (dfunCPO D)) (x : A) :
        lim s x = lim (dapp_chain s x).
Proof. by []. Qed.

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

Definition continuous :=
  exists M : monotone f,
  forall s : chain D1, f (lim s) = lim [f ^^ s by M].

Lemma cont_mono : continuous -> monotone f.
Proof. by case. Qed.

Lemma contE (s : chain D1) (C : continuous) :
       f (lim s) = lim [f ^^ s by cont_mono C].
Proof.
case: C=>M E; rewrite E; congr (lim (image_chain _ _)).
apply: proof_irrelevance.
Qed.

End Continuity.

Module Kleene.

(* just for this proof, we want that nat is a poset under <= *)
(* in other scopes, we'll use the equality as ordering *)
Section NatPoset.

Lemma nat_refl x : x <= x. Proof. by []. Qed.

Lemma nat_asym x y : x <= y -> y <= x -> x = y.
Proof. by move=>H1 H2; apply: anti_leq; rewrite H1 H2. Qed.

Lemma nat_trans x y z : x <= y -> y <= z -> x <= z.
Proof. by apply: leq_trans. Qed.

Definition natPosetMixin := PosetMixin nat_refl nat_asym nat_trans.
Canonical natPoset := Eval hnf in Poset nat natPosetMixin.

End NatPoset.

Section NatChain.

Lemma nat_chain_axiom : chain_axiom (@PredT nat).
Proof.
split=>[|x y _ _]; first by exists 0.
rewrite /Poset.leq /= [y <= x]leq_eqVlt.
by case: leqP; [left | rewrite orbT; right].
Qed.

Definition nat_chain := Chain nat_chain_axiom.

End NatChain.

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.

Lemma pow_mono : monotone pow.
Proof.
move=>m n; elim: n m=>[|n IH] m /=; first by case: m.
rewrite {1}/Poset.leq /= leq_eqVlt ltnS.
case/orP; first by move/eqP=>->.
move/IH=>{IH} H; apply: poset_trans H _.
by elim: n=>[|n IH] //=; apply: cont_mono IH.
Qed.

Definition pow_chain := [pow ^^ nat_chain by pow_mono].

Lemma reindex : pow_chain =p lift_chain [f ^^ pow_chain by cont_mono C].
Proof.
move=>x; split.
- case; case=>[|n][->] /=; first by left.
  by right; exists (pow n); split=>//; exists n.
case=>/=; first by move=>->; exists 0.
by case=>y [->][n][->]; exists n.+1.
Qed.

Definition kleene_lfp := lim pow_chain.

Lemma kleene_lfp_fixed : f kleene_lfp = kleene_lfp.
Proof. by rewrite (@contE _ _ f) lim_liftE; apply: limE; rewrite reindex. Qed.

Lemma kleene_lfp_least : forall x, f x = x -> kleene_lfp <== x.
Proof.
move=>x H; apply: limM=>y [n][->] _.
by elim: n=>[|n IH] //=; rewrite -H; apply: cont_mono IH.
Qed.

End Kleene.

Module Exports.
Notation kleene_lfp := kleene_lfp.
Notation kleene_lfp_fixed := kleene_lfp_fixed.
Notation kleene_lfp_least := kleene_lfp_least.
End Exports.

End Kleene.

Export Kleene.Exports.

(**********************************)
(* Continuity of common functions *)
(**********************************)

Lemma id_cont (D : cpo) : continuous (@id D).
Proof. by exists id_mono; move=>d; rewrite id_chainE. Qed.

Implicit Arguments id_cont [D].
Prenex Implicits id_cont.

Lemma const_cont (D1 D2 : cpo) (y : D2) : continuous (fun x : D1 => y).
Proof.
exists const_mono; move=>s; apply: poset_asym.
- by apply: limP; case: s=>[p][[d H1] H2]; exists d.
by apply: limM=>_ [x][->].
Qed.

Implicit Arguments const_cont [D1 D2 y].
Prenex Implicits const_cont.

Lemma comp_cont (D1 D2 D3 : cpo) (f1 : D2 -> D1) (f2 : D3 -> D2) :
        continuous f1 -> continuous f2 -> continuous (f1 \o f2).
Proof.
case=>M1 H1 [M2 H2]; exists (comp_mono M1 M2); move=>d.
by rewrite /= H2 H1 comp_chainE.
Qed.

Implicit Arguments comp_cont [D1 D2 D3 f1 f2].
Prenex Implicits comp_cont.

Lemma proj1_cont (D1 D2 : cpo) : continuous (@fst D1 D2).
Proof. by exists proj1_mono. Qed.

Lemma proj2_cont (D1 D2 : cpo) : continuous (@snd D1 D2).
Proof. by exists proj2_mono. Qed.

Implicit Arguments proj1_cont [D1 D2].
Implicit Arguments proj2_cont [D1 D2].
Prenex Implicits proj1_cont proj2_cont.

Lemma diag_cont (D : cpo) : continuous (fun x : D => (x, x)).
Proof.
exists diag_mono=>d; apply: poset_asym;
by split=>/=; [rewrite proj1_diagE | rewrite proj2_diagE].
Qed.

Implicit Arguments diag_cont [D].
Prenex Implicits diag_cont.

Lemma app_cont A (D : cpo) x : continuous (fun f : A -> D => f x).
Proof. by exists (app_mono x). Qed.

Lemma dapp_cont A (D : A -> cpo) x : continuous (fun f : dfunCPO D => f x).
Proof. by exists (dapp_mono x). Qed.

Implicit Arguments app_cont [A D].
Implicit Arguments dapp_cont [A D].
Prenex Implicits app_cont dapp_cont.

Lemma prod_cont (S1 S2 T1 T2 : cpo) (f1 : S1 -> T1) (f2 : S2 -> T2) :
        continuous f1 -> continuous f2 -> continuous (f1 \* f2).
Proof.
case=>M1 H1 [M2 H2]; exists (prod_mono M1 M2)=>d; apply: poset_asym;
by (split=>/=; [rewrite proj1_prodE H1 | rewrite proj2_prodE H2]).
Qed.

Implicit Arguments prod_cont [S1 S2 T1 T2 f1 f2].
Prenex Implicits prod_cont.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
(************************************************************************)

(*i $Id: NSig.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import ZArith Znumtheory.

Open Scope Z_scope.

(** * NSig *)

(** Interface of a rich structure about natural numbers.
    Specifications are written via translation to Z.
*)

Module Type NType.

 Parameter t : Type.

 Parameter to_Z : t -> Z.
 Local Notation "[ x ]" := (to_Z x).
 Parameter spec_pos: forall x, 0 <= [x].

 Parameter of_N : N -> t.
 Parameter spec_of_N: forall x, to_Z (of_N x) = Z_of_N x.
 Definition to_N n := Zabs_N (to_Z n).

 Definition eq n m := [n] = [m].
 Definition lt n m := [n] < [m].
 Definition le n m := [n] <= [m].

 Parameter compare : t -> t -> comparison.
 Parameter eq_bool : t -> t -> bool.
 Parameter max : t -> t -> t.
 Parameter min : t -> t -> t.
 Parameter zero : t.
 Parameter one : t.
 Parameter succ : t -> t.
 Parameter pred : t -> t.
 Parameter add  : t -> t -> t.
 Parameter sub : t -> t -> t.
 Parameter mul : t -> t -> t.
 Parameter square : t -> t.
 Parameter power_pos : t -> positive -> t.
 Parameter power : t -> N -> t.
 Parameter sqrt : t -> t.
 Parameter div_eucl : t -> t -> t * t.
 Parameter div : t -> t -> t.
 Parameter modulo : t -> t -> t.
 Parameter gcd : t -> t -> t.
 Parameter shiftr : t -> t -> t.
 Parameter shiftl : t -> t -> t.
 Parameter is_even : t -> bool.

 Parameter spec_compare: forall x y, compare x y = Zcompare [x] [y].
 Parameter spec_eq_bool: forall x y, eq_bool x y = Zeq_bool [x] [y].
 Parameter spec_max : forall x y, [max x y] = Zmax [x] [y].
 Parameter spec_min : forall x y, [min x y] = Zmin [x] [y].
 Parameter spec_0: [zero] = 0.
 Parameter spec_1: [one] = 1.
 Parameter spec_succ: forall n, [succ n] = [n] + 1.
 Parameter spec_add: forall x y, [add x y] = [x] + [y].
 Parameter spec_pred: forall x, [pred x] = Zmax 0 ([x] - 1).
 Parameter spec_sub: forall x y, [sub x y] = Zmax 0 ([x] - [y]).
 Parameter spec_mul: forall x y, [mul x y] = [x] * [y].
 Parameter spec_square: forall x, [square x] = [x] *  [x].
 Parameter spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n.
 Parameter spec_power: forall x n, [power x n] = [x] ^ Z_of_N n.
 Parameter spec_sqrt: forall x, [sqrt x] ^ 2 <= [x] < ([sqrt x] + 1) ^ 2.
 Parameter spec_div_eucl: forall x y,
  let (q,r) := div_eucl x y in ([q], [r]) = Zdiv_eucl [x] [y].
 Parameter spec_div: forall x y, [div x y] = [x] / [y].
 Parameter spec_modulo: forall x y, [modulo x y] = [x] mod [y].
 Parameter spec_gcd: forall a b, [gcd a b] = Zgcd [a] [b].
 Parameter spec_shiftr: forall p x, [shiftr p x] = [x] / 2^[p].
 Parameter spec_shiftl: forall p x, [shiftl p x] = [x] * 2^[p].
 Parameter spec_is_even: forall x,
  if is_even x then [x] mod 2 = 0 else [x] mod 2 = 1.

End NType.

Module Type NType_Notation (Import N:NType).
 Notation "[ x ]" := (to_Z x).
 Infix "==" := eq (at level 70).
 Notation "0" := zero.
 Infix "+" := add.
 Infix "-" := sub.
 Infix "*" := mul.
 Infix "<=" := le.
 Infix "<" := lt.
End NType_Notation.

Module Type NType' := NType <+ NType_Notation.


Require Import String Morph Var Context.
Require Setoid Morphisms.

Module Type Term.

  Parameter term : forall {V : nat}, Set.

  Parameter unit : forall {N}, morph (@var) N (@term) N.

  Parameter kleisli :
    forall {N M},
      morph (@var) N (@term) M ->
      morph (@term) N (@term) M.

  Axiom left_identity :
    forall N M (f : morph (@var) N (@term) M) V t,
      kleisli f V (unit V t) = f V t.

  Axiom right_identity :
    forall N V (t : @term (N + V)),
      kleisli unit V t = t.

  Axiom associativity :
    forall N M L
      (f : morph (@var) N (@term) M)
      (g : morph (@var) M (@term) L) V t,
      kleisli (fun V' t' => kleisli g V' (f V' t')) V t
      = kleisli g V (kleisli f V t).

  Axiom unit_extend :
    forall N V v,
      morph_extend (@unit N) V v = unit V v.

  Axiom kleisli_extend :
    forall N M (f : morph (@var) N (@term) M) V t,
      morph_extend (kleisli f) V t
      = kleisli (morph_extend f) V t.

  Axiom extensional :
    forall N M (f g : morph (@var) N (@term) M) V t,
      (forall V t, f V t = g V t) ->
      kleisli f V t = kleisli g V t.

End Term.

Module Renamings (T : Term).

  Import T.

  Definition openm a :=
    unit @ ((@openv a : morph (@var) 1 (@var) 0)).

  Definition open a := kleisli (openm a).

  Definition closem a :=
    unit @ ((@closev a : morph (@var) 0 (@var) 1)).

  Definition close a := kleisli (closem a).

  Definition wkm :=
    unit @ (@wkv : morph (@var) 0 (@var) 1).

  Definition wk := kleisli wkm.

  Fixpoint wkn {V} (t : @term 0) :=
    match V with
    | 0 => t
    | S V => wk V (@wkn V t)
    end.

  Definition bindm (u : @term 0) : morph (@var) 1 (@term) 0 :=
    fun V v =>
      match bindv v with
      | Some v => @unit 0 V v
      | None => wkn u
      end.

  Definition bind u := kleisli (@bindm u).

  Arguments openm a {V} v /.
  Arguments open a {V} !t.
  Arguments closem a {V} v /.
  Arguments close a {V} !t.
  Arguments wkm {V} v /.
  Arguments wk {V} !t.
  Arguments bindm u {V} !v.
  Arguments bind u {V} !t.

  Definition ren := @renaming (@term 0).

  Fixpoint applyv (r : ren) : morph (@var) 0 (@term) 0 :=
    match r with
    | r_id => unit
    | r_comp r s =>
      (kleisli (applyv r))
        @ (applyv s)
    | r_shift b r =>
      (@open b)
        @ (kleisli (morph_extend (applyv r)))
        @ (@wkm)
    | r_rename b r a =>
      (@open b)
        @ (kleisli (morph_extend (applyv r)))
        @ (@closem a)
    | r_subst u r a =>
      (@bind u)
        @ (kleisli (morph_extend (applyv r)))
        @ (@closem a)
    end.

  Arguments applyv !r {V} t /.

  Notation "[ r ] t" := (kleisli (@applyv (r)%ren) _ t)
    (at level 60, right associativity) : term_scope.
  Bind Scope term_scope with term.
  Open Scope term_scope.

  Lemma unit_extend_0 : forall V t,
    @unit 0 (S V) t = @unit 1 V t.
  Proof.
    intros.
    replace (@unit 0 (S V) t)
      with (morph_extend (@unit 0) V t) by reflexivity.
    rewrite unit_extend.
    reflexivity.
  Qed.

  Lemma kleisli_extend_00 : forall V f t,
    @kleisli 0 0 f (S V) t
    = @kleisli 1 1 (morph_extend f) V t.
  Proof.
    intros.
    replace (@kleisli 0 0 f (S V) t)
      with (morph_extend (@kleisli 0 0 f) V t)
      by reflexivity.
    rewrite kleisli_extend.
    reflexivity.
  Qed.

  Lemma right_identity_ext :
    forall N V (t : @term (N + V)) f,
      (forall V' v', f V' v' = unit V' v') ->
      kleisli f V t = t.
  Proof.
    intros * Heq.
    rewrite extensional with (g := unit);
      auto using right_identity.
  Qed.

  Ltac simpl_term t :=
    match t with
    | @kleisli ?N _ _ ?V (@kleisli _ ?N _ ?V _) =>
      rewrite <- associativity
    | @kleisli 0 0 _ (S _) _ =>
      rewrite kleisli_extend_00
    | @kleisli ?N _ _ ?V (@unit ?N ?V _) =>
      rewrite left_identity
    | @kleisli ?N ?N (@unit ?N) ?V _ =>
      rewrite right_identity
    | @unit 0 (S _) _ =>
      rewrite unit_extend_0
    | morph_compose _ _ _ _ => unfold morph_compose
    | morph_compose _ _ => unfold morph_compose; intros
    | @open _ _ _ => unfold open
    | @openm _ _ _ => unfold openm
    | @close _ _ _ => unfold close
    | @closem _ _ _ => unfold closem
    | @wk _ _ => unfold wk
    | @wkm _ _ => unfold wkm
    | @bind _ _ _ => unfold bind
    | @bindm _ _ _ => unfold bindm
    | kleisli _ _ ?t' =>
      simpl_term t'
    end.

  Ltac simpl_term_eq_step :=
    match goal with
    | |- ?t1 = _ => simpl_term t1; cbn
    | |- _ = ?t2 => simpl_term t2; cbn
    | |- @kleisli ?N ?M _ ?V ?t = @kleisli ?N ?M _ ?V ?t =>
      apply (extensional N M); intros; cbn
    | |- @kleisli ?N ?N _ _ ?t = ?t =>
      apply (right_identity_ext N); intros; cbn
    | |- ?t = @kleisli ?N ?N _ _ ?t =>
      symmetry; apply (right_identity_ext N); intros;
      symmetry; cbn
    | |- _ = _ =>
        progress autorewrite with rw_names rw_vars; cbn
    end.

  Ltac simpl_term_eq :=
    cbn; repeat simpl_term_eq_step; try reflexivity.

  Lemma rw_close_open a :
    forall {V} (t : @term (S V)), close a (open a t) = t.
  Proof.
    intros.
    simpl_term_eq.
  Qed.

  Lemma rw_open_close a :
    forall {V} (t : @term V), open a (close a t) = t.
  Proof.
    intros.
    simpl_term_eq.
  Qed.

  Lemma rw_bind_wk u :
    forall {V} (t : @term V), bind u (wk t) = t.
  Proof.
    intros.
    simpl_term_eq.
  Qed.

  Lemma rw_bindm_wkv u :
    forall {V} (v : @var V), bindm u (wkv v) = @unit 0 V v.
  Proof.
    intros.
    simpl_term_eq.
  Qed.

  Hint Rewrite @rw_close_open @rw_open_close @rw_bind_wk
       @rw_bindm_wkv
    : rw_renaming.

  (* identity and composition for apply *)
  Lemma rw_apply_id {V} (t : @term V) : [r_id] t = t.
  Proof. simpl_term_eq. Qed.

  Lemma rw_apply_comp r s {V} (t : @term V) :
    [r] [s] t = [r;s] t.
  Proof. simpl_term_eq. Qed.

  Hint Rewrite @rw_apply_id @rw_apply_comp : rw_renaming.

  (* Simple rewritings on applyv and shiftv (more later) *)
  Lemma rw_applyv_bound r : forall {V} (v : level V),
    @applyv r V (bound v) = @unit 0 V (bound v).
  Proof.
    intros.
    generalize dependent V.
    induction r; intros; simpl_term_eq.
    - rewrite IHr2; simpl_term_eq.
      rewrite IHr1; simpl_term_eq.
    - rewrite IHr; simpl_term_eq.
    - rewrite IHr; simpl_term_eq.
    - rewrite IHr; simpl_term_eq.
  Qed.

  Hint Rewrite @rw_applyv_bound : rw_renaming.

  (* Rewrite to do the following:
      - group balanced pairs of operations into 'ren's
      - push opens/bind right and wk/close left
      - simplify rens *)

  Lemma rw_group_rename a b {V} (t : @term V) :
    open a (close b t) = [a <- b] t.
  Proof. simpl_term_eq. Qed.

  Lemma rw_group_shift a {V} (t : @term V) :
    open a (wk t) = [^a] t.
  Proof. simpl_term_eq. Qed.

  Lemma rw_group_subst u a {V} (t : @term V) :
    bind u (close a t) = [u // a] t.
  Proof. simpl_term_eq. Qed.

  Hint Rewrite @rw_group_rename @rw_group_shift
       @rw_group_subst
    : rw_renaming.

  (* fold operations *)

  Lemma rw_fold_open a {V} (t : @term (1 + V)) :
    kleisli (@openm a) V t = open a t.
  Proof. easy. Qed.

  Lemma rw_fold_close a {V} (t : @term V) :
    kleisli (@closem a) V t = close a t.
  Proof. easy. Qed.

  Lemma rw_fold_wk {V} (t : @term V) :
    kleisli (@wkm) V t = wk t.
  Proof. easy. Qed.

  Lemma rw_fold_bind u {V} (t : @term (1 + V)) :
    kleisli (@bindm u) V t = bind u t.
  Proof. easy. Qed.

  Hint Rewrite @rw_fold_open @rw_fold_close @rw_fold_wk
       @rw_fold_bind
    : rw_renaming.

  (* wk commutes with shift *)
  Lemma rw_shift_wk b {V} (t : @term V) :
    [^b] (wk t) = wk ([^b] t).
  Proof.
    simpl_term_eq.
    rewrite swap_shiftv_wkv.
    simpl_term_eq.
  Qed.

  Hint Rewrite @rw_shift_wk : rw_renaming.

  (* wk commutes with apply.
     Somewhat harder to prove than I'd expect *)
  Lemma rw_applyv_wkv r : forall {V} (v : @var V),
      applyv r (wkv v) = wk (applyv r v).
  Proof.
    induction r; intros; cbn.
    - simpl_term_eq.
    - rewrite IHr2; simpl_term_eq.
      rewrite IHr1; simpl_term_eq.
    - simpl_term_eq.
      repeat rewrite IHr; simpl_term_eq.
      rewrite swap_shiftv_wkv.
      simpl_term_eq.
    - destruct (compare_vars a v); simpl_term_eq.
      + autorewrite with rw_renaming.
        simpl_term_eq.
      + repeat rewrite IHr.
        simpl_term_eq.
        rewrite swap_shiftv_wkv.
        simpl_term_eq.
    - destruct (compare_vars a v); simpl_term_eq.
      + autorewrite with rw_renaming.
        simpl_term_eq.
      + repeat rewrite IHr; simpl_term_eq.
  Qed.

  (* FIXME where? *)
  Lemma applyt_is_applyv :
    forall r (rn : total r) {V} (v : @var V),
      applyv r v = unit V (applyt r rn v).
  Proof.
    induction r; cbn; intuition; simpl_term_eq.
    - erewrite IHr2; simpl_term_eq.
      erewrite IHr1; simpl_term_eq.
    - erewrite IHr; simpl_term_eq.
    - erewrite IHr; simpl_term_eq.
  Qed.

  Lemma applyt_related (A : Set) (Γ Δ : @context A) :
    forall r (rl : Γ =[r]=> Δ) {V} (v : @var V),
      applyv r v = unit V (applyt r (relates_total rl) v).
  Proof.
    intros.
    rewrite applyt_is_applyv with (rn := relates_total rl).
    reflexivity.
  Qed.

  Lemma rw_apply_wk r {V} (t : @term V) :
    kleisli (@applyv r) (S V) (wk t) = wk ([r] t).
  Proof.
    simpl_term_eq.
    apply rw_applyv_wkv.
  Qed.

  Lemma rw_apply_wkn r {V} (t : @term 0) :
    [r] (@wkn V t) = @wkn V ([r] t).
  Proof.
    induction V; cbn; try easy.
    rewrite rw_apply_wk.
    rewrite IHV.
    reflexivity.
  Qed.

  Hint Rewrite @rw_applyv_wkv @rw_apply_wk @rw_apply_wkn
    : rw_renaming.

  Lemma rw_applyv_wkv_free r {a V} :
    applyv r (@free (S V) a) = wk (applyv r (@free V a)).
  Proof.
    change (@free (S V) a) with (wkv (@free V a)).
    apply rw_applyv_wkv.
  Qed.

  Hint Rewrite @rw_applyv_wkv_free : rw_renaming.

  Lemma comm_bind_apply u : forall {V} (t : @term (S V)) r,
    [r] (bind u t) = bind ([r] u) ([r] t).
  Proof.
    intros.
    simpl_term_eq.
    destruct (compare_l0 t0); simpl_term_eq;
      autorewrite with rw_renaming; simpl_term_eq.
  Qed.

  (* FIXME: maybe this should just be "names"? *)
  Lemma rw_close_shift a r {V} (t : @term V) :
    close a ([r,, ^a] t) = wk ([r] t).
  Proof.
    simpl_term_eq; autorewrite with rw_renaming; simpl_term_eq.
  Qed.
  Lemma rw_subst_open u r b {V} (t : @term (S V)) :
    [r,, u // b] (open b t) = bind u ([r] t).
  Proof. simpl_term_eq. Qed.
  Lemma rw_rename_open a b {V} (t : @term (S V)) :
    [a <- b] (open b t) = open a t.
  Proof. simpl_term_eq. Qed.
  Hint Rewrite @rw_close_shift @rw_subst_open @rw_rename_open : rw_renaming.

  (* FIXME: lots of applyt rewritings below here *)

  (* FIXME: not great, tbh *)

  (* Commuting bind with apply.
     It seems more natural to make
       bind (r u) . r  --> r . bind u
     since bind is similar to open, and open moves right.
     But that rule breaks confluence, and isn't very useful
     as bind doesn't show up in terms. So, binds move left
     instead. *)
  Lemma rw_push_bind u r {V} (t : @term (S V)) :
    [r] (bind u t) = bind ([r] u) ([r] t).
  Proof. apply comm_bind_apply. Qed.
  (* Shifts go the other way.
     This is confluent/terminating because shift doesn't simplify to apply (?) *)
  Lemma rw_push_bind_shift u r s a {V} (t : @term (S V)) :
    bind ([r,, ^a] u) ([s,, ^ a] t) =
    [^a] (bind ([r]u) ([s]t)).
  Proof.
    rewrite comm_bind_apply.
    autorewrite with rw_renaming; simpl_term_eq.
    autorewrite with rw_renaming; simpl_term_eq.
    destruct (compare_l0 t1); simpl_term_eq.
    f_equal.
    simpl_term_eq.
    autorewrite with rw_renaming; simpl_term_eq.
  Qed.
  Lemma rw_push_bind_shiftvu v a {V} (t : @term (S V)) :
    bind (@unit 0 0 (shiftv a v)) ([^a] t)
    = [^a] (bind (unit 0 v) t).
  Proof.
    replace (unit 0 (shiftv a v)) with ([^a] (unit 0 v))
      by simpl_term_eq.
    rewrite rw_push_bind_shift.
    autorewrite with rw_renaming; easy.
  Qed.

  Hint Rewrite
    @rw_push_bind @rw_push_bind_shift @rw_push_bind_shiftvu
    : rw_renaming.

  (* Morphisms. *)
  Import Setoid Morphisms.

(* FIXME: is it better to define eqr over all vars or just free ones? *)
  Definition eqr (r s : ren) : Prop :=
    forall V (v : @var V),
      applyv r v = applyv s v.

  Instance eqr_Equivalence : Equivalence eqr.
  Proof.
    split; red; unfold eqr; auto.
    intros. etransitivity; eauto.
  Qed.

  Instance mor_applyv : Proper
    (eqr ==> forall_relation (fun _ => (eq ==> eq))) applyv.
  Proof. intros r s Hrs V v v' <-. auto. Qed.

  Instance mor_kleisli : Proper
    (forall_relation (fun _ => (eq ==> eq))
    ==> forall_relation (fun _ => (eq ==> eq)))
    (@kleisli 0 0).
  Proof.
    intros r s Hrs V a b <-.
    simpl_term_eq.
    apply Hrs; reflexivity.
  Qed.

  Ltac easy_eqr :=
    repeat intro; simpl_term_eq;
    repeat
      match goal with
      | [ H : _ |- _ ] =>
        rewrite H; clear H; simpl_term_eq
      end.

  Instance mor_r_comp : Proper
    (eqr ==> eqr ==> eqr) r_comp. easy_eqr. Qed.
  Instance mor_r_shift : Proper
    (eq ==> eqr ==> eqr) r_shift. easy_eqr. Qed.
  Instance mor_r_rename : Proper
    (eq ==> eqr ==> eq ==> eqr) r_rename. easy_eqr. Qed.
  Instance mor_r_subst : Proper
    (eq ==> eqr ==> eq ==> eqr) r_subst. easy_eqr. Qed.

  Lemma rw_ren_id_comp r : eqr (r_comp r_id r) r.
  Proof. easy_eqr. Qed.
  Lemma rw_ren_comp_id r : eqr (r_comp r r_id) r.
  Proof. easy_eqr. Qed.
  Lemma rw_ren_comp_assoc r s t :
    eqr (r_comp r (r_comp s t)) (r_comp (r_comp r s) t).
  Proof. easy_eqr. Qed.
  Lemma rw_ren_under_id x :
    eqr (r_rename x r_id x) r_id.
  Proof. easy_eqr. Qed.
  Lemma rw_ren_rename_rename c b a r s :
    eqr (r_comp (r_rename c r b) (r_rename b s a))
        (r_rename c (r_comp r s) a).
  Proof. easy_eqr. Qed.
  Lemma rw_ren_rename_rename_comp l c b a r s :
    eqr (r_comp (r_comp l (r_rename c r b)) (r_rename b s a))
        (r_comp l (r_rename c (r_comp r s) a)).
  Proof. easy_eqr. Qed.
  Lemma rw_ren_rename_shift c b r s :
    eqr (r_comp (r_rename c r b) (r_shift b s))
        (r_shift c (r_comp r s)).
  Proof. easy_eqr. Qed.
   Lemma rw_ren_rename_shift_comp l c b r s :
    eqr (r_comp (r_comp l (r_rename c r b)) (r_shift b s))
        (r_comp l (r_shift c (r_comp r s))).
  Proof. easy_eqr. Qed.
  Lemma rw_ren_subst_rename u r a s b :
    eqr (r_comp (r_subst u r a) (r_rename a s b))
        (r_subst u (r_comp r s) b).
  Proof. easy_eqr. Qed.
  Lemma rw_ren_subst_rename_comp l u r a s b :
    eqr (r_comp (r_comp l (r_subst u r a)) (r_rename a s b))
        (r_comp l (r_subst u (r_comp r s) b)).
  Proof. easy_eqr. Qed.
  Lemma rw_ren_subst_shift u r a s :
    eqr (r_comp (r_subst u r a) (r_shift a s))
        (r_comp r s).
  Proof.
    repeat intro; simpl_term_eq.
    (* FIXME: this again. Should we remove free?
       Should we do this automatically?
       Should we define eqr in terms of all vars,
       not just free ones? *)
    repeat match goal with
    | |- context C [@free (S ?v) ?x] =>
    change (@free (S v) x) with (@wkv v (free x)) end.
    autorewrite with rw_renaming; simpl_term_eq.
    autorewrite with rw_renaming; simpl_term_eq.
  Qed.
  Lemma rw_ren_subst_shift_comp l u r a s :
    eqr (r_comp (r_comp l (r_subst u r a)) (r_shift a s))
        (r_comp l (r_comp r s)).
  Proof.
    repeat intro; simpl_term_eq.
    repeat match goal with
    | |- context C [@free (S ?v) ?x] =>
      change (@free (S v) x) with (@wkv v (free x)) end.
    autorewrite with rw_renaming; simpl_term_eq.
    autorewrite with rw_renaming; simpl_term_eq.
  Qed.
  Lemma rw_ren_shift_any a r s :
    eqr (r_comp (r_shift a r) s) (r_shift a (r_comp r s)).
  Proof.
    repeat intro; simpl_term_eq.
    autorewrite with rw_renaming; simpl_term_eq.
  Qed.
  Lemma rw_ren_shift_any_comp l a r s :
    eqr (r_comp (r_comp l (r_shift a r)) s)
        (r_comp l (r_shift a (r_comp r s))).
  Proof.
    repeat intro; simpl_term_eq.
    autorewrite with rw_renaming; simpl_term_eq.
  Qed.
  Lemma rw_ren_any_subst r u s x :
    eqr (r_comp r (r_subst u s x))
        (r_subst ([r] u) (r_comp r s) x).
  Proof.
    repeat intro; simpl_term_eq.
    destruct (compare_l0 t); simpl_term_eq;
      autorewrite with rw_renaming; simpl_term_eq.
  Qed.

  (* No _comp version required for any_subst *)
  (* Ensure crit pair of rw_ren_shift_any and
     rw_ren_any_subst is confluent *)
  Lemma rw_ren_shift_subst_crit a u r b :
    eqr (r_subst ([^a] u) (r_shift a r) b)
        (r_shift a (r_subst u r b)).
  Proof.
    Set Printing Implicit.
    repeat intro; simpl_term_eq.
    autorewrite with rw_renaming.
    repeat rewrite <- rw_apply_comp.
    repeat rewrite rw_apply_id.
    rewrite rw_push_bind_shift.
    repeat rewrite rw_apply_id.
    replace (bind u (@applyv r (S V) (closev b v)))
      with (@applyv (r_subst u r b) V v)
      by simpl_term_eq.
    replace (bind u (@applyv r (S (S V)) (closev b (wkv v))))
      with (@applyv (r_subst u r b) (S V) (wkv v))
      by simpl_term_eq.
    rewrite rw_applyv_wkv.
    simpl_term_eq.
  Qed.

  Hint Rewrite
    @rw_ren_id_comp
    @rw_ren_comp_id
    @rw_ren_comp_assoc
    @rw_ren_under_id
    @rw_ren_rename_rename
    @rw_ren_rename_rename_comp
    @rw_ren_rename_shift
    @rw_ren_rename_shift_comp
    @rw_ren_subst_rename
    @rw_ren_subst_rename_comp
    @rw_ren_subst_shift
    @rw_ren_subst_shift_comp
    @rw_ren_shift_any
    @rw_ren_shift_any_comp
    @rw_ren_any_subst
    @rw_ren_shift_subst_crit : rw_renaming.

  (* Commuting open and close with apply *)

  Lemma rw_push_open a r {V} (t : @term (S V)) :
    open a ([r] t) = [r,, a] (open a t).
  Proof. simpl_term_eq. Qed.
  Lemma rw_push_close a r {V} (t : @term V) :
    [r] (close a t) = close a ([r,, a] t).
  Proof.  simpl_term_eq. Qed.
  Hint Rewrite @rw_push_open @rw_push_close : rw_renaming.

  Arguments term / {V}.

  Arguments unit {N} / V t.

  Arguments kleisli {N M} f V !t /.

  Ltac names :=
    repeat progress
      (cbn; autorewrite with rw_renaming rw_vars rw_names).

  Tactic Notation "names" "in" hyp(H) :=
    repeat progress
      (cbn in H; autorewrite with rw_renaming in H).

  Lemma swap_subst_subst_distinct {x y}
        (Hd : distinct_names x y) {u v R} :
    eqr (r_subst u (r_subst v R x) y)
        (r_subst v (r_subst u R y) x).
  Proof.
    intros V p. simpl_term_eq.
    rewrite (swap_close_close Hd).
    destruct (closev y (closev x _)) as [?|[|[|?]]];
      names; simpl_term_eq.
  Qed.

End Renamings.