Require Import Coq.Classes.Morphisms.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.Definitions.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.Properties.
Require Import Fiat.Common.BoolFacts.
Require Import Fiat.Common.
Require Import Fiat.Common.Wf.

Set Implicit Arguments.

Local Open Scope bool_scope.

Global Instance prod_fixedpoint_lattice {prestate0 prestate1}
       {fpldata0 : grammar_fixedpoint_lattice_data prestate0}
       {fpldata1 : grammar_fixedpoint_lattice_data prestate1}
  : grammar_fixedpoint_lattice_data (@state _ fpldata0 * @state _ fpldata1).
Proof.
  refine {| prestate_lt x y := ((state_le (fst x) (fst y) && state_le (snd x) (snd y))
                                  && negb (state_beq (fst x) (fst y) && state_beq (snd x) (snd y)));
            prestate_beq := Equality.prod_beq state_beq state_beq;
            preleast_upper_bound x y
            := constant (least_upper_bound (fst x) (fst y), least_upper_bound (snd x) (snd y)) |};
  try abstract (
        repeat match goal with
               | _ => progress unfold Equality.prod_beq
               | [ |- RelationClasses.Equivalence _ ]
                 => split; repeat intro
               | [ |- well_founded _ ] => fail 1
               | [ |- is_true (?R ?x ?x) ] => reflexivity
               | [ |- is_true true ] => reflexivity
               | [ |- ?R ?x ?x ] => reflexivity
               | _ => congruence
               | [ |- Proper _ _ ] => unfold Proper, respectful
               | [ |- Transitive _ ] => intros ???; cbv beta
               | _ => progress intros
               | [ H : and _ _ |- _ ] => destruct H
               | [ H : prod _ _ |- _ ] => destruct H
               | _ => progress simpl in *
               | [ H : is_true (state_beq ?x ?y) |- _ ]
                 => rewrite H in *; clear x H
               | [ H : is_true (state_beq ?x ?y) |- _ ]
                 => clear x H
               | [ |- context[(?x <= least_upper_bound ?x ?y)%fixedpoint] ]
                 => replace (x <= least_upper_bound x y)%fixedpoint
                    with true by (symmetry; apply least_upper_bound_correct_l)
               | [ |- context[(?y <= least_upper_bound ?x ?y)%fixedpoint] ]
                 => replace (y <= least_upper_bound x y)%fixedpoint
                    with true by (symmetry; apply least_upper_bound_correct_r)
               | [ H : is_true true |- _ ] => clear H
               | [ H : is_true ?x |- context[?x] ]
                 => progress replace x with true by (symmetry; exact H)
               | [ H : is_true ?x, H' : context[?x] |- _ ]
                 => progress replace x with true in H' by (symmetry; exact H)
               | [ H : context[@state_beq ?A ?B ?x ?x] |- _ ]
                 => replace (@state_beq A B x x) with true in H by (symmetry; change (is_true (@state_beq A B x x)); reflexivity)
               | [ H : is_true (?R ?x ?y), H' : is_true (?R ?y ?z) |- _ ]
                 => unique pose proof (transitivity (R := R) H H' : is_true (R x z))
               | [ H : is_true (@state_le ?A ?B ?x ?y), H' : is_true (state_le ?y ?x) |- _ ]
                 => unique pose proof (@antisymmetry _ (@state_beq A B) _ (@state_le A B) _ x y H H' : is_true (state_beq x y))
               | [ |- context[is_true (negb ?x)] ]
                 => destruct x eqn:?; simpl; fold_is_true
               | _ => progress bool_congr_setoid
               | [ |- and _ _ ] => split
               end
      ).
  { unfold flip.
    eapply well_founded_subrelation; [ | eapply well_founded_prod_relationA with (eqA := state_beq) ];
      [ .. | eapply state_gt_wf | eapply state_gt_wf ].
    { intros x y H.
      unfold prod_relationA, flip, state_le, state in *.
      revert H.
      generalize (@state_lt _ fpldata0).
      generalize (@state_lt _ fpldata1).
      generalize (@state_beq _ fpldata0).
      generalize (@state_beq _ fpldata1).
      unfold state.
      clear.
      abstract (
          repeat match goal with
                 | _ => setoid_rewrite Bool.negb_andb
                 | _ => tauto
                 | _ => congruence
                 | _ => progress destruct_head and
                 | [ H : is_true ?x, H' : context[?x] |- _ ]
                   => progress replace x with true in H' by (symmetry; exact H)
                 | _ => progress simpl in *
                 | _ => progress bool_congr_setoid
                 | _ => progress intros
                 | _ => progress destruct_head or
                 end
        ). }
    { apply prod_relationA_Proper_from_Equivalence; try exact _; [].
      unfold flip; intros ??? x y H H'; subst.
      rewrite H; assumption. } }
Defined.

Global Instance prod_fixedpoint_lattice' {prestate0 prestate1}
       {fpldata0 : grammar_fixedpoint_lattice_data prestate0}
       {fpldata1 : grammar_fixedpoint_lattice_data prestate1}
  : grammar_fixedpoint_lattice_data (lattice_for prestate0 * lattice_for prestate1)
  := prod_fixedpoint_lattice.


From mathcomp Require Import ssrnat ssrbool fintype.
Require Export prosa.behavior.all.

(** * Fully-Preemptive EDF Schedules *)

(** This module provides an alternative definition of what it means to be an
    "EDF schedule".

    Note that the "proper" way to define an EDF schedule in Prosa is to use the
    EDF priority policy defined in model.priority.edf and the notion of
    priority-compliant schedules defined in model.schedule.priority_driven, as
    well as the general notion of work-conservation provided in
    model.schedule.work_conserving, which will have the benefit of taking into
    account issues such as various readiness models (e.g., jitter) and diverse
    preemption models (e.g., limited-preemptive jobs).

    The simpler definition offered in this module is (intentionally) oblivious
    to (i.e., not compatible with) issues such as non-preemptive regions or
    self-suspensions, and does not imply anything about work-conservation. In
    other words, it implicitly assumes that pending jobs are always ready and
    at all times preemptable.

    The advantage of this alternative definition is, however, that it is
    largely self-contained and fairly simple, following primarily from first
    principles. This makes it easier to use in certain contexts such as the
    proof of optimality of EDF. *)

Section AlternativeDefinitionOfEDF.

  (** Consider any type of jobs with arrival times, costs, and deadlines ... *)
  Context {Job : JobType} `{JobCost Job} `{JobDeadline Job} `{JobArrival Job}.

  (** ... and any processor model. *)
  Context {PState: eqType}.
  Context `{ProcessorState Job PState}.

  (** We say that a schedule is _locally EDF-compliant_ at a given point in
      time [t] if the job [j] scheduled at time [t] has a deadline that is
      earlier than or equal to the deadline of any other job [j'] that could be
      scheduled at time [t] (i.e., arrives at or before time [t]) but is
      actually scheduled later in the given schedule.

      In other words, a schedule is locally EDF-compliant at time [t] if there
      is no witness of a priority inversion (= an already arrived job with an
      earlier deadline) at a later point in the schedule. *)
  Definition EDF_at (sched: schedule PState) (t: instant) :=
    forall (j: Job),
      scheduled_at sched j t ->
      forall (t': instant) (j': Job),
        t <= t' ->
        scheduled_at sched j' t' ->
        job_arrival j' <= t ->
        job_deadline j <= job_deadline j'.

  (** Based on the notion of a locally EDF-compliant schedule given by
      [EDF_at], we say that a schedule is (globally) EDF-compliant
      schedule if it is locally EDF-compliant at every point in
      time. *)
  Definition EDF_schedule (sched: schedule PState) := forall t, EDF_at sched t.

End AlternativeDefinitionOfEDF.


From Tealeaves Require Export
  Classes.Monoid
  Classes.Applicative
  Classes.Comonad
  Functors.Writer.
From Tealeaves Require
  Classes.Monad
  Classes.Kleisli.Decorated.Monad.

Export Decorated.Monad (preincr).

Import Monoid.Notations.
Import Product.Notations.

#[local] Generalizable Variables ϕ T W G A B C D F M.

Section operations.

  Context
    (W : Type)
      (T : Type -> Type)
      (F : Type -> Type).

  Class Binddt :=
    binddt :
      forall (G : Type -> Type)
        `{Fmap G} `{Pure G} `{Mult G}
        (A B : Type),
        (W * A -> G (T B)) -> F A -> G (F B).

End operations.

Definition kcompose_dtm
  {A B C}
  `{Fmap G1} `{Pure G1} `{Mult G1}
  `{Fmap G2} `{Pure G2} `{Mult G2}
  `{Binddt W T T} `{Monoid_op W} :
  (W * B -> G2 (T C)) ->
  (W * A -> G1 (T B)) ->
  (W * A -> G1 (G2 (T C))) :=
  fun g f '(w, a) => fmap G1 (binddt W T T G2 B C (preincr w g)) (f (w, a)).

#[local] Infix "⋆dtm" := kcompose_dtm (at level 60) : tealeaves_scope.

Section class.

  Context
    (W : Type)
      (T : Type -> Type)
      `{Return T}
      `{Binddt W T T}
      `{op: Monoid_op W} `{unit: Monoid_unit W}.

  Class Monad :=
    { kdtm_monoid :> Monoid W;
      kdtm_binddt0 : forall (A B : Type) `{Applicative G} (f : W * A -> G (T B)),
        binddt W T T G A B f ∘ ret T = f ∘ ret (W ×);
      kdtm_binddt1 : forall (A : Type),
        binddt W T T (fun A => A) A A (ret T ∘ extract (prod W)) = @id (T A);
      kdtm_binddt2 :
      forall (A B C : Type) `{Applicative G1} `{Applicative G2}
        (g : W * B -> G2 (T C)) (f : W * A -> G1 (T B)),
        fmap G1 (binddt W T T G2 B C g) ∘ binddt W T T G1 A B f =
          binddt W T T (G1 ∘ G2) A C (g ⋆dtm f);
      kdtm_morph : forall (G1 G2 : Type -> Type) `{morph : ApplicativeMorphism G1 G2 ϕ} `(f : W * A -> G1 (T B)),
        ϕ (T B) ∘ binddt W T T G1 A B f = binddt W T T G2 A B (ϕ (T B) ∘ f);
    }.

End class.

#[global] Arguments binddt {W}%type_scope {T}%function_scope (F)%function_scope
  {Binddt} G%function_scope {H H0 H1} {A B}%type_scope _%function_scope _.

Module Notations.

  Infix "⋆dtm" := kcompose_dtm (at level 60) : tealeaves_scope.

End Notations.

Section class.

  Context
    (W : Type)
      (T : Type -> Type)
      `{Return T}
      `{Binddt W T T}
      `{op: Monoid_op W} `{unit: Monoid_unit W}
      `{! Monoid W}.

  Lemma kcompose_dtm_incr : forall
      `{Applicative G1} `{Applicative G2}
      `(g : W * B -> G2 (T C)) `(f : W * A -> G1 (T B)) (w : W),
      (g ∘ incr w) ⋆dtm (f ∘ incr w) = (g ⋆dtm f) ∘ incr w.
  Proof.
    intros. unfold kcompose_dtm.
    ext [w' a]. unfold preincr.
    reassociate ->. rewrite incr_incr.
    reflexivity.
  Qed.

  Lemma kcompose_dtm_preincr : forall
      `{Applicative G1} `{Applicative G2}
      `(g : W * B -> G2 (T C)) `(f : W * A -> G1 (T B)) (w : W),
      (preincr w g) ⋆dtm (preincr w f) = preincr w (g ⋆dtm f).
  Proof.
    intros. unfold preincr. rewrite kcompose_dtm_incr.
    reflexivity.
  Qed.

  Context
    `{! DT.Monad.Monad W T}.

  Lemma dtm_kleisli_identity1 : forall `{Applicative G} `(f : W * A -> G (T B)),
      kcompose_dtm (G2 := fun A => A) (ret T ∘ extract (W ×)) f = f.
  Proof.
    intros. unfold kcompose_dtm.
    ext [w a]. unfold preincr.
    reassociate ->. rewrite (extract_incr).
    rewrite (kdtm_binddt1 W T).
    rewrite (fun_fmap_id G).
    reflexivity.
  Qed.

  Lemma dtm_kleisli_identity2 : forall `{Applicative G} `(g : W * A -> G (T B)),
      kcompose_dtm (G1 := fun A => A) g (ret T ∘ extract (W ×)) = g.
  Proof.
    intros. unfold kcompose_dtm.
    ext [w a]. unfold compose. cbn.
    compose near a.
    change (fmap (fun A => A) ?f) with f.
    rewrite (kdtm_binddt0 W T); auto.
    cbv. change (g ((w ● Ƶ), a) = g (w, a)).
    simpl_monoid.
    reflexivity.
  Qed.

  Lemma dtm_kleisli_assoc :
    forall `{Applicative G1} `{Applicative G2} `{Applicative G3}
      `(h : W * C -> G3 (T D)) `(g : W * B -> G2 (T C)) `(f : W * A -> G1 (T B)),
      kcompose_dtm (G1 := G1 ∘ G2) h (g ⋆dtm f) =
        kcompose_dtm (G2 := G2 ∘ G3) (h ⋆dtm g) f.
  Proof.
    intros. unfold kcompose_dtm.
    ext [w a]. cbn.
    unfold_ops @Fmap_compose.
    compose near (f (w, a)) on left.
    rewrite (fun_fmap_fmap G1).
    fequal.
    rewrite (kdtm_binddt2 W T); auto.
    fequal.
    rewrite kcompose_dtm_preincr.
    reflexivity.
  Qed.

End class.

From Tealeaves.Classes.Kleisli Require Import
  Monad
  Decorated.Functor
  Decorated.Monad
  Traversable.Functor
  Traversable.Monad
  DT.Functor.

(** * Auxiliary lemmas for constant applicative functors *)
(******************************************************************************)
Module Derived.

  Section with_kleisli.

    Context
      (T : Type -> Type)
      `{Binddt W T T}
      `{Return T}.

    #[export] Instance Fmap_Binddt : Fmap T :=
      fun (A B : Type) (f : A -> B) => binddt T (fun A => A) (ret T ∘ f ∘ extract (W ×)).
    #[export] Instance Fmapdt_Binddt: Fmapdt W T
      := fun G _ _ _ A B f => binddt T G (fmap G (ret T) ∘ f).
    #[export] Instance Bindd_Binddt: Bindd W T T
      := fun A B f => binddt T (fun A => A) f.
    #[export] Instance Bindt_Binddt: Bindt T T
      := fun G _ _ _ A B f => binddt T G (f ∘ extract (W ×)).
    #[export] Instance Bind_Binddt: Bind T T
      := fun A B f => binddt T (fun A => A) (f ∘ extract (W ×)).
    #[export] Instance Fmapd_Binddt: Fmapd W T
      := fun A B f => binddt T (fun A => A) (ret T ∘ f).
    #[export] Instance Traverse_Binddt: Traverse T
      := fun G _ _ _ A B f => binddt T G (fmap G (ret T) ∘ f ∘ extract (W ×)).

  End with_kleisli.

  Section with_monad.

    Context
      (T : Type -> Type)
        `{DT.Monad.Monad W T}.

    Lemma fmap_id : forall (A : Type),
        fmap T (@id A) = @id (T A).
    Proof.
      intros. unfold_ops @Fmap_Binddt.
      change (ret T ∘ id) with (ret T (A := A)).
      now rewrite (kdtm_binddt1 W T).
    Qed.

    Lemma fmap_fmap : forall (A B C : Type) (f : A -> B) (g : B -> C),
        fmap T g ∘ fmap T f = fmap T (g ∘ f).
    Proof.
      intros. unfold_ops @Fmap_Binddt.
      change (binddt T (fun A0 : Type => A0) (ret T ∘ g ∘ extract (prod W)))
        with (fmap (fun A => A) (binddt T (fun A0 : Type => A0) (ret T ∘ g ∘ extract (prod W)))).
      rewrite (kdtm_binddt2 W T _ _ _ (G1 := fun A => A) (G2 := fun A => A)).
      fequal.
      - now rewrite Mult_compose_identity1.
      - unfold kcompose_dtm. ext [w a].
        unfold_ops @Fmap_I.
        compose near (w, a) on left.
        do 2 reassociate <- on left.
        unfold_compose_in_compose.
        rewrite (kdtm_binddt0 W T _ _ (G := fun A => A)).
        unfold_ops @Return_writer @Monoid_unit_product.
        unfold compose; cbn.
        reflexivity.
    Qed.

    #[export] Instance: Classes.Functor.Functor T :=
      {| fun_fmap_id := fmap_id;
        fun_fmap_fmap := fmap_fmap;
      |}.

    Lemma fmap_binddt: forall (G1 : Type -> Type) (A B C : Type) `{Applicative G1}
                         (g : B -> C)
                         (f : W * A -> G1 (T B)),
        fmap G1 (fmap T g) ∘ binddt T G1 f =
          binddt T G1 (fmap G1 (fmap T g) ∘ f).
    Proof.
      intros. unfold_ops @Fmap_Binddt.
      rewrite (kdtm_binddt2 W T A B C (G1 := G1) (G2 := fun A => A)).
      fequal.
      - now rewrite Mult_compose_identity1.
      - ext [w a]. cbn. now rewrite Decorated.Monad.preincr_extract.
    Qed.

    Lemma binddt_fmap: forall (G2 : Type -> Type) (A B C : Type) `{Applicative G2}
                         (g : W * B -> G2 (T C))
                         (f : A -> B),
        binddt T G2 g ∘ fmap T f =
          binddt T G2 (fun '(w, a) => g (w, f a)).
    Proof.
      intros. unfold_ops @Fmap_Binddt.
      change (binddt T G2 g) with (fmap (fun A => A) (binddt T G2 g)).
      rewrite (kdtm_binddt2 W T A B C (G1 := fun A => A)).
      fequal. now rewrite Mult_compose_identity2.
      unfold kcompose_dtm. ext [w a].
      change (fmap (fun A => A) ?f) with f.
      unfold compose; cbn.
      compose near (f a) on left.
      rewrite (kdtm_binddt0 W T _ _ _ (G := G2)).
      cbv. change (op w unit0) with (w ● Ƶ).
      now simpl_monoid.
    Qed.

  End with_monad.

  (** ** Specifications for lesser Kleisli operations *)
  (******************************************************************************)
  Section special_cases.

    Context
      (W : Type)
        (T : Type -> Type)
        `{Return T}
        `{Binddt W T T}
        `{Applicative F}.

    (** *** Rewriting rules for special cases of <<binddt>> *)
    (******************************************************************************)
    Lemma bindt_to_binddt `(f : A -> F (T B)):
      bindt T F f = binddt T F (f ∘ extract (W ×)).
    Proof.
      reflexivity.
    Qed.

    Lemma bindd_to_binddt `(f : W * A -> T B):
      bindd T f = binddt T (fun A => A) f.
    Proof.
      reflexivity.
    Qed.

    Lemma fmapdt_to_binddt `(f : W * A -> F B):
      fmapdt T F f = binddt T F (fmap F (ret T) ∘ f).
    Proof.
      reflexivity.
    Qed.

    Lemma bind_to_binddt `(f : A -> T B):
      bind T f = binddt T (fun A => A) (f ∘ extract (W ×)).
    Proof.
      reflexivity.
    Qed.

    Lemma fmapd_to_binddt `(f : W * A -> B):
      fmapd T f = binddt T (fun A => A) (ret T ∘ f).
    Proof.
      reflexivity.
    Qed.

    Lemma fmapt_to_binddt `(f : A -> F B):
      traverse T F f = binddt T F (fmap F (ret T) ∘ f ∘ extract (W ×)).
    Proof.
      reflexivity.
    Qed.

    Lemma fmap_to_binddt `(f : A -> B):
      fmap T f = binddt T (fun A => A) (ret T ∘ f ∘ extract (W ×)).
    Proof.
      reflexivity.
    Qed.

    (** *** Rewriting rules for special cases of <<bindt>> *)
    (******************************************************************************)
    Lemma bind_to_bindt `(f : A -> T B):
      bind T f = bindt T (fun A => A) f.
    Proof.
      reflexivity.
    Qed.

    Lemma fmapt_to_bindt `(f : A -> F B):
      traverse T F f = bindt T F (fmap F (ret T) ∘ f).
    Proof.
      reflexivity.
    Qed.

    Lemma fmap_to_bindt `(f : A -> B):
      fmap T f = bindt T (fun A => A) (ret T ∘ f).
    Proof.
      reflexivity.
    Qed.

    (** *** Rewriting rules for special cases of <<bindd>> *)
    (******************************************************************************)
    Lemma bind_to_bindd `(f : A -> T B):
      bind T f = bindd T (f ∘ extract (W ×)).
    Proof.
      reflexivity.
    Qed.

    Lemma fmapd_to_bindd `(f : W * A -> B):
      fmapd T f = bindd T (ret T ∘ f).
    Proof.
      reflexivity.
    Qed.

    Lemma fmap_to_bindd `(f : A -> B):
      fmap T f = bindd T (ret T ∘ f ∘ extract (W ×)).
    Proof.
      reflexivity.
    Qed.

    (** *** Rewriting rules for special cases of <<fmapdt>> *)
    (******************************************************************************)
    Lemma fmapd_to_fmapdt `(f : W * A -> B):
      fmapd T f = fmapdt T (fun A => A) f.
    Proof.
      reflexivity.
    Qed.

    Lemma fmap_to_fmapdt `(f : A -> B):
      fmap T f = fmapdt T (fun A => A) (f ∘ extract (W ×)).
    Proof.
      reflexivity.
    Qed.

    Lemma fmapt_to_fmapdt `(f : A -> F B):
      traverse T F f = fmapdt T F (f ∘ extract (W ×)).
    Proof.
      reflexivity.
    Qed.

    (** *** Rewriting rules for special cases of <<fmapt>> *)
    (******************************************************************************)
    Lemma fmap_to_fmapt `(f : A -> B):
      fmap T f = traverse T (fun A => A) f.
    Proof.
      reflexivity.
    Qed.

    (** *** Rewriting rules for special cases of <<fmapd>> *)
    (******************************************************************************)
    Lemma fmap_to_fmapd `(f : A -> B):
      fmap T f = fmapd T (f ∘ extract (W ×)).
    Proof.
      reflexivity.
    Qed.

    (** *** Rewriting rules for special cases of <<bind>> *)
    (******************************************************************************)
    Lemma fmap_to_bind `(f : A -> B):
      fmap T f = bind T (ret T ∘ f).
    Proof.
      reflexivity.
    Qed.

  End special_cases.

  Import Kleisli.Traversable.Monad.Notations.
  Import Kleisli.DT.Functor.Notations.
  Import Kleisli.Decorated.Monad.Notations.
  Import Kleisli.Monad.Notations.
  Import Comonad.Notations.

  (** ** Special cases of Kleisli composition *)
  (******************************************************************************)
  Section kleisli_composition.

    Context
      (W : Type)
      (T : Type -> Type)
      `{DT.Monad.Monad W T}.

    (*
    d/t/m:
    000 0 no d or t or m
    001 1 no context or effect
    010 2 no context or subst
    011 3 no context
    100 4 no effect or subst
    101 5 no effect
    110 6 no subst
    111 7 everything
     *)

    (** *** Composition when <<g>> is context-agnostic *)
    (******************************************************************************)

    (** Composition when <<g>> is context-agnostic reduces to Kleisli
  composition for traversable monads. *)
    Theorem dtm_kleisli_37 {A B C} : forall
        `{Applicative G1} `{Applicative G2}
        (g : B -> G2 (T C)) (f : W * A -> G1 (T B)),
        (g ∘ extract (W ×)) ⋆dtm f = g ⋆tm f.
    Proof.
      intros. unfold kcompose_dtm.
      ext [w a]. rewrite preincr_extract.
      reflexivity.
    Qed.

    (** Composition when neither <<g>> or <<f>> is context-sensitive *)
    Lemma kcompose_dtm_33 :
      forall `{Applicative G1} `{Applicative G2}
        `(g : B -> G2 (T C)) `(f : A -> G1 (T B)),
        kcompose_dtm (G1 := G1) (G2 := G2) (g ∘ extract (W ×)) (f ∘ extract (W ×)) =
          (kcompose_tm (G1 := G1) (G2 := G2) g f) ∘ extract (W ×).
    Proof.
      intros. unfold kcompose_dtm.
      ext [w a]. rewrite preincr_extract.
      reflexivity.
    Qed.

    (** Composition when <<g>> has no applicative effect *)
    Theorem dtm_kleisli_57 {A B C} : forall
        `{Applicative G1}
        (g : W * B -> T C) (f : W * A -> G1 (T B)),
        kcompose_dtm (G2 := fun A => A) g f = g ⋆dtm f.
    Proof.
      reflexivity.
    Qed.

    (** *** Composition when <<g>> has no substitution *)
    (******************************************************************************)

    (** Composition when <<g>> has no substitution *)
    Theorem dtm_kleisli_67 {A B C} : forall
        `{Applicative G1} `{Applicative G2}
        (g : W * B -> G2 C) (f : W * A -> G1 (T B)),
        (fmap G2 (ret T) ∘ g) ⋆dtm f = (fmap G2 (ret T) ∘ g) ⋆dtm f.
    Proof.
      reflexivity.
    Qed.

    (** Composition when neither <<g>> or <<f>> perform a substitution *)
    Lemma kcompose_dtm_66 : forall
        `{Applicative G1} `{Applicative G2}
        `(g : W * B -> G2 C) `(f : W * A -> G1 B),
        (fmap G2 (ret T) ∘ g) ⋆dtm (fmap G1 (ret T) ∘ f) =
          fmap (G1 ∘ G2) (ret T) ∘ (kcompose_dt (G1 := G1) (G2 := G2) g f).
    Proof.
      intros. unfold kcompose_dtm.
      ext [w a]. unfold compose at 2.
      compose near (f (w, a)).
      rewrite (fun_fmap_fmap G1).
      rewrite (kdtm_binddt0 W T); auto.
      rewrite preincr_ret.
      unfold kcompose_dt. unfold_ops @Fmap_compose.
      do 2 reassociate <-.
      unfold_compose_in_compose.
      rewrite (fun_fmap_fmap G1).
      unfold strength.
      unfold compose; cbn.
      compose near (f (w, a)) on right.
      rewrite (fun_fmap_fmap G1).
      reflexivity.
    Qed.

    (** *** Composition when <<g>> has no applicative effect *)
    (******************************************************************************)

    (** Composition when neither <<g>> or <<f>> has an applicative effect *)
    Lemma kcompose_dtm_55 : forall
        `(g : W * B -> T C) `(f : W * A -> T B),
        kcompose_dtm (G1 := fun A => A) (G2 := fun A => A) g f =
          kcompose_dm g f.
    Proof.
      reflexivity.
    Qed.

    (** Composition when neither <<g>> or <<f>> has an applicative effect or substitution *)
    Lemma kcompose_dtm_44 : forall
        `(g : W * B -> C) `(f : W * A -> B),
        kcompose_dtm (G1 := fun A => A) (G2 := fun A => A)
          (ret T ∘ g) (ret T ∘ f) = ret T ∘ (g co⋆ f).
    Proof.
      intros. rewrite kcompose_dtm_55.
      unfold kcompose_dm.
      ext [w a].
      intros. unfold_ops @Bindd_Binddt.
      unfold compose. compose near (f (w, a)).
      rewrite (kdtm_binddt0 W T _ _ (G := fun A => A)).
      cbv. change (op w unit0) with (w ● Ƶ). now simpl_monoid.
    Qed.

    (** *** Composition when <<f>> has no applicative effect *)
    (******************************************************************************)

    (** Composition when <<f>> has no applicative effect *)
    Theorem dtm_kleisli_75 {A B C} : forall
        `{Applicative G2}
        (g : W * B -> G2 (T C)) (f : W * A -> T B),
        kcompose_dtm (G1 := fun A => A) g f = fun '(w, a) => binddt T G2 (preincr w g) (f (w, a)).
    Proof.
      reflexivity.
    Qed.

    (** Composition when <<f>> has no applicative effect, substitution, or context-sensitivity *)
    Lemma kcompose_dtm_70 : forall
        `{Applicative G}
        `(g : W * B -> G (T C)) `(f : A -> B),
        kcompose_dtm (G1 := fun A => A) (G2 := G)
          g (ret T ∘ f ∘ extract (W ×)) = g ∘ fmap (W ×) f.
    Proof.
      intros. unfold kcompose_dtm.
      ext [w a]. unfold compose.
      cbn. compose near (f a) on left.
      change (fmap (fun A => A) ?f) with f.
      rewrite (kdtm_binddt0 W T _ _ (G := G)).
      now rewrite preincr_ret.
    Qed.

    (** Composition when <<f>> is just a map *)
    Theorem dtm_kleisli_70 {A B C} : forall
        `{Applicative G2}
        (g : W * B -> G2 (T C)) (f : A -> B),
        kcompose_dtm (G1 := fun A => A) (G2 := G2) g
          (ret T ∘ f ∘ extract (W ×)) = g ∘ fmap (W ×) f.
    Proof.
      intros. unfold kcompose_dtm.
      ext [w a]. unfold compose. cbn.
      compose near (f a) on left.
      change (fmap (fun A => A) ?f) with f.
      rewrite (kdtm_binddt0 W T); auto.
      now rewrite (preincr_ret).
    Qed.

    (** Composition when <<f>> has no applicative effect or substitution *)
    Lemma kcompose_dtm_74 : forall
        `{Applicative G}
        `(g : W * B -> G (T C)) `(f : W * A -> B),
        kcompose_dtm (G1 := fun A => A) (G2 := G)
          g (ret T ∘ f) = g co⋆ f.
    Proof.
      intros. unfold kcompose_dtm.
      ext [w a]. unfold compose.
      compose near (f (w, a)).
      change (fmap (fun A => A) ?f) with f.
      rewrite (kdtm_binddt0 W T _ _ (G := G)).
      now rewrite preincr_ret.
    Qed.

    (** *** Others *)
    (******************************************************************************)

    (** Composition when <<f>> is context-agnostic *)
    Theorem dtm_kleisli_73 {A B C} : forall
        `{Applicative G1} `{Applicative G2}
        (g : W * B -> G2 (T C)) (f : A -> G1 (T B)),
        g ⋆dtm (f ∘ extract (W ×)) =
          ((fun '(w, t) => fmap G1 (binddt T G2 (preincr w g)) t) ∘ fmap (W ×) f).
    Proof.
      intros. unfold kcompose_dtm.
      ext [w a]. unfold compose. cbn.
      reflexivity.
    Qed.
    (** Composition when <<f>> has no substitution *)
    Theorem dtm_kleisli_76 {A B C} : forall
        `{Applicative G1} `{Applicative G2}
        (g : W * B -> G2 (T C)) (f : W * A -> G1 B),
        g ⋆dtm (fmap G1 (ret T) ∘ f) = g ⋆dt f.
    Proof.
      intros. unfold kcompose_dtm.
      ext [w a]. unfold kcompose_dt.
      unfold compose. cbn.
      compose near (f (w, a)).
      rewrite (fun_fmap_fmap G1).
      rewrite (fun_fmap_fmap G1).
      fequal.
      rewrite (kdtm_binddt0 W T); auto.
      now rewrite (preincr_ret).
    Qed.

  End kleisli_composition.

  (** * Lesser Kleisli typeclass instances *)
  (******************************************************************************)
  Section instances.

    Context
      (W : Type)
        (T : Type -> Type)
        `{Kleisli.DT.Monad.Monad W T}.

    (** ** Monad *)
    (******************************************************************************)
    Lemma kmon_bind0_T : forall (A B : Type) (f : A -> T B),
        bind T f ∘ ret T = f.
    Proof.
      intros. unfold_ops @Bind_Binddt.
      rewrite (kdtm_binddt0 W T _ _ _ (G := fun A => A)).
      reflexivity.
    Qed.

    Lemma kmon_bind1_T : forall A : Type,
        bind T (ret T) = @id (T A).
    Proof.
      intros. unfold_ops @Bind_Binddt.
      now rewrite (kdtm_binddt1 W T).
    Qed.

    Lemma kmon_bind2_T : forall (B C : Type) (g : B -> T C) (A : Type) (f : A -> T B),
        bind T g ∘ bind T f = bind T (g ⋆ f).
    Proof.
      intros. unfold_ops @Bind_Binddt.
      change (binddt T (fun A0 : Type => A0) (g ∘ extract (prod W)))
        with (fmap (fun A => A)
                (binddt T (fun A0 : Type => A0) (g ∘ extract (prod W)))).
      rewrite (kdtm_binddt2 W T _ _ _ (G1 := fun A => A) (G2 := fun A => A)).
      fequal.
      - now rewrite Mult_compose_identity1.
      - change_left ((g ∘ extract (prod W)) ⋆dm (f ∘ extract (W ×))).
        unfold kcompose_dm. ext [w a]. unfold compose at 2. cbn.
        rewrite preincr_extract.
        reflexivity.
    Qed.

    #[export] Instance KM_KDTM : Kleisli.Monad.Monad T :=
      {| kmon_bind0 := kmon_bind0_T;
        kmon_bind1 := kmon_bind1_T;
        kmon_bind2 := kmon_bind2_T;
      |}.

    (** ** Decorated monad *)
    (******************************************************************************)
    Lemma kmond_bindd0_T : forall (A B : Type) (f : W * A -> T B),
        bindd T f ∘ ret T = f ∘ ret (prod W).
    Proof.
      intros. unfold_ops @Bindd_Binddt.
      now rewrite (kdtm_binddt0 W T _ _ _ (G := fun A => A)).
    Qed.

    Lemma kmond_bindd1_T : forall A : Type,
        bindd T (ret T ∘ extract (prod W)) = @id (T A).
    Proof.
      intros. unfold_ops @Bindd_Binddt.
      now rewrite (kdtm_binddt1 W T).
    Qed.

    Lemma kmond_bindd2_T : forall (B C : Type) (g : W * B -> T C) (A : Type) (f : W * A -> T B),
        bindd T g ∘ bindd T f = bindd T (g ⋆dm f).
    Proof.
      intros. unfold_ops @Bindd_Binddt.
      change (binddt T ?I g) with (fmap (fun A => A) (binddt T I g)).
      rewrite (kdtm_binddt2 W T _ _ _ (G1 := fun A => A) (G2 := fun A => A)).
      fequal. now rewrite Mult_compose_identity1.
    Qed.

    #[export] Instance KDM_KDTM: Kleisli.Decorated.Monad.Monad T :=
      {| kmond_bindd0 := kmond_bindd0_T;
        kmond_bindd1 := kmond_bindd1_T;
        kmond_bindd2 := kmond_bindd2_T;
      |}.

    (** ** Traversable monad *)
    (******************************************************************************)
    Lemma ktm_bindt0_T : forall
        (A B : Type) (G : Type -> Type) (H1 : Fmap G)
        (H2 : Pure G) (H3 : Mult G),
        Applicative G ->
        forall f : A -> G (T B), bindt T G f ∘ ret T = f.
    Proof.
      intros. unfold_ops @Bindt_Binddt.
      rewrite (kdtm_binddt0 W T); auto.
    Qed.

    Lemma ktm_bindt1_T : forall A : Type,
        bindt T (fun A : Type => A) (ret T) = @id (T A).
    Proof.
      intros. unfold_ops @Bindt_Binddt.
      now rewrite (kdtm_binddt1 W T).
    Qed.

    Lemma ktm_bindt2_T : forall
        (A B C : Type) (G1 : Type -> Type) (H1 : Fmap G1)
        (H2 : Pure G1) (H3 : Mult G1),
        Applicative G1 ->
        forall (G2 : Type -> Type) (H5 : Fmap G2) (H6 : Pure G2) (H7 : Mult G2),
          Applicative G2 ->
          forall (g : B -> G2 (T C)) (f : A -> G1 (T B)),
            fmap G1 (bindt T G2 g) ∘ bindt T G1 f = bindt T (G1 ∘ G2) (g ⋆tm f).
    Proof.
      intros. unfold_ops @Bindt_Binddt.
      rewrite (kdtm_binddt2 W T); auto.
      fequal. rewrite (kcompose_dtm_33 W T).
      reflexivity.
    Qed.

    Lemma ktm_morph_T : forall
        (G1 G2 : Type -> Type) (H1 : Fmap G1) (H2 : Pure G1) (H3 : Mult G1) (H4 : Fmap G2)
        (H5 : Pure G2) (H6 : Mult G2) (ϕ : forall A : Type, G1 A -> G2 A),
        ApplicativeMorphism G1 G2 ϕ ->
        forall (A B : Type) (f : A -> G1 (T B)),
          ϕ (T B) ∘ bindt T G1 f = bindt T G2 (ϕ (T B) ∘ f).
    Proof.
      intros. unfold_ops @Bindt_Binddt.
      now rewrite (kdtm_morph W T G1 G2).
    Qed.

    #[export] Instance KTM_KDTM: Traversable.Monad.Monad T :=
      {| ktm_bindt0 := ktm_bindt0_T;
        ktm_bindt1 := ktm_bindt1_T;
        ktm_bindt2 := ktm_bindt2_T;
        ktm_morph := ktm_morph_T;
      |}.

    (** ** Decorated-traversable functor *)
    (******************************************************************************)
    Lemma kdtfun_fmapdt1_T : forall A : Type,
        fmapdt T (fun A0 : Type => A0) (extract (W ×)) = @id (T A).
    Proof.
      intros. unfold_ops @Fmapdt_Binddt.
      change (fmap (fun A => A) ?f) with f.
      now rewrite (kdtm_binddt1 W T).
    Qed.

    Lemma kdtfun_fmapdt2_T :
      forall (G1 : Type -> Type) (H0 : Fmap G1) (H1 : Pure G1) (H2 : Mult G1) (H3 : Applicative G1)
        (G2 : Type -> Type) (H4 : Fmap G2) (H5 : Pure G2) (H6 : Mult G2) (H7 : Applicative G2)
        (B C : Type) (g : W * B -> G2 C) (A : Type) (f : W * A -> G1 B),
        fmap G1 (fmapdt T G2 g) ∘ fmapdt T G1 f = fmapdt T (G1 ∘ G2) (g ⋆dt f).
    Proof.
      intros. unfold_ops @Fmapdt_Binddt.
      rewrite (kdtm_binddt2 W T); auto.
      fequal. now rewrite (kcompose_dtm_66 W T).
    Qed.

    Lemma kdtfun_morph_T :
      forall (G1 G2 : Type -> Type) (H0 : Fmap G1) (H1 : Pure G1) (H2 : Mult G1)
        (H3 : Fmap G2) (H4 : Pure G2) (H5 : Mult G2) (ϕ : forall A : Type, G1 A -> G2 A),
        ApplicativeMorphism G1 G2 ϕ ->
        forall (A B : Type) (f : W * A -> G1 B), fmapdt T G2 (ϕ B ∘ f) = ϕ (T B) ∘ fmapdt T G1 f.
    Proof.
      intros. unfold_ops @Fmapdt_Binddt.
      rewrite (kdtm_morph W T _ _ (ϕ := ϕ)).
      fequal. reassociate <-.
      unfold compose. ext [w a]. now rewrite (appmor_natural G1 G2).
    Qed.

    #[export] Instance KDT_KDTM: DT.Functor.DecoratedTraversableFunctor W T :=
      {| kdtfun_fmapdt1 := kdtfun_fmapdt1_T;
        kdtfun_fmapdt2 := kdtfun_fmapdt2_T;
        kdtfun_morph := kdtfun_morph_T;
      |}.

    (** ** Decorated functor *)
    (******************************************************************************)
    Lemma dfun_fmapd1_T : forall A : Type,
        fmapd T (extract (W ×)) = @id (T A).
    Proof.
      intros. unfold_ops @Fmapd_Binddt.
      now rewrite (kdtm_binddt1 W T).
    Qed.

    Lemma dfun_fmapd2_T : forall (A B C : Type) (g : W * B -> C) (f : W * A -> B),
        fmapd T g ∘ fmapd T f = fmapd T (g ∘ cobind (W ×) f).
    Proof.
      intros. unfold_ops @Fmapd_Binddt.
      change (binddt T (fun A0 : Type => A0) ?g) with
        (fmap (fun A => A) (binddt T (fun A0 : Type => A0) g)) at 1.
      rewrite (kdtm_binddt2 W T A B C (G1 := fun A => A) (G2 := fun A => A)).
      fequal. now rewrite Mult_compose_identity2.
      now rewrite (kcompose_dtm_44 W T).
    Qed.

    #[export] Instance KD_KDTM: Kleisli.Decorated.Functor.DecoratedFunctor W T :=
      {| dfun_fmapd1 := dfun_fmapd1_T;
        dfun_fmapd2 := dfun_fmapd2_T;
      |}.

    (** ** Traversable functor *)
    (******************************************************************************)
    Lemma trf_traverse_id_T : forall A : Type,
        traverse T (fun A0 : Type => A0) (@id A) = id.
    Proof.
      unfold_ops @Traverse_Binddt @Fmap_I.
      apply (kdtm_binddt1 W T).
    Qed.

    Lemma trf_traverse_traverse_T : forall (G1 G2 : Type -> Type) (H0 : Fmap G2) (H1 : Pure G2) (H2 : Mult G2),
        Applicative G2 ->
        forall (H4 : Fmap G1) (H5 : Pure G1) (H6 : Mult G1),
          Applicative G1 ->
          forall (B C : Type) (g : B -> G2 C) (A : Type) (f : A -> G1 B),
            fmap G1 (traverse T G2 g) ∘ traverse T G1 f =
              traverse T (G1 ∘ G2) (fmap G1 g ∘ f).
    Proof.
      intros. unfold_ops @Traverse_Binddt.
      rewrite (kdtm_binddt2 W T); auto.
      rewrite (kcompose_dtm_33 W T).
      rewrite (kcompose_tm_ret T).
      reflexivity.
    Qed.

    Lemma trf_traverse_morphism_T : forall (G1 G2 : Type -> Type) (H0 : Fmap G1) (H1 : Pure G1)
                                      (H2 : Mult G1) (H3 : Fmap G2) (H4 : Pure G2)
                                      (H5 : Mult G2) (ϕ : forall A : Type, G1 A -> G2 A),
        ApplicativeMorphism G1 G2 ϕ ->
        forall (A B : Type) (f : A -> G1 B),
          ϕ (T B) ∘ traverse T G1 f = traverse T G2 (ϕ B ∘ f).
    Proof.
      intros. unfold_ops @Traverse_Binddt.
      rewrite (kdtm_morph W T G1 G2).
      do 2 reassociate <- on left.
      fequal. unfold compose; ext x.
      inversion H8.
      rewrite appmor_natural.
      reflexivity.
    Qed.

    #[export] Instance KT_KDTM: Traversable.Functor.TraversableFunctor T :=
      {| trf_traverse_id := trf_traverse_id_T;
        trf_traverse_traverse := trf_traverse_traverse_T;
        trf_traverse_morphism := trf_traverse_morphism_T;
      |}.

    (** ** Functor *)
    (******************************************************************************)

  End instances.
  Section binddt.

    Context
      (T : Type -> Type)
      (G1 G2 : Type -> Type)
      `{DT.Monad.Monad W T}
      `{Applicative G1}
      `{Applicative G2}
      {A B C : Type}.

    (** ** <<binddt>> on the right *)
    (******************************************************************************)
    Lemma bindd_binddt: forall
        (g : W * B -> T C)
        (f : W * A -> G1 (T B)),
        fmap G1 (bindd T g) ∘ binddt T G1 f =
          binddt T G1 (fun '(w, a) => fmap G1 (bindd T (preincr w g)) (f (w, a))).
    Proof.
      intros. unfold_ops @Bindd_Binddt.
      rewrite (kdtm_binddt2 W T A B C (G1 := G1) (G2 := fun A => A)).
      fequal. now rewrite Mult_compose_identity1.
    Qed.

    Lemma fmapdt_binddt: forall
        (g : W * B -> G2 C)
        (f : W * A -> G1 (T B)),
        fmap G1 (fmapdt T G2 g) ∘ binddt T G1 f =
          binddt T (G1 ∘ G2) (fun '(w, a) => fmap G1 (fmapdt T G2 (preincr w g)) (f (w, a))).
    Proof.
      intros. unfold_ops @Fmapdt_Binddt.
      rewrite (kdtm_binddt2 W T A B C (G1 := G1) (G2 := G2)).
      reflexivity.
    Qed.

    Lemma bindt_binddt: forall
        (g : B -> G2 (T C))
        (f : W * A -> G1 (T B)),
        fmap G1 (bindt T G2 g) ∘ binddt T G1 f =
          binddt T (G1 ∘ G2) (fmap G1 (bindt T G2 g) ∘ f).
    Proof.
      intros. unfold_ops @Bindt_Binddt.
      rewrite (kdtm_binddt2 W T A B C (G1 := G1) (G2 := G2)).
      fequal. unfold kcompose_dtm. ext [w a].
      now rewrite preincr_extract.
    Qed.

    Lemma bind_binddt: forall
        (g : B -> T C)
        (f : W * A -> G1 (T B)),
        fmap G1 (bind T g) ∘ binddt T G1 f =
          binddt T G1 (fmap G1 (bind T g) ∘ f).
    Proof.
      intros. unfold_ops @Bindt_Binddt.
      unfold_ops @Bind_Binddt.
      rewrite (kdtm_binddt2 W T A B C (G1 := G1) (G2 := fun A => A)).
      fequal.
      - now rewrite Mult_compose_identity1.
      - ext [w a]. cbn. now rewrite (preincr_extract).
    Qed.

    Lemma fmapd_binddt: forall
        (g : W * B -> C)
        (f : W * A -> G1 (T B)),
        fmap G1 (fmapd T g) ∘ binddt T G1 f =
          binddt T G1 (fun '(w, a) => fmap G1 (fmapd T (preincr w g)) (f (w, a))).
    Proof.
      intros. unfold_ops @Fmapd_Binddt.
      rewrite (kdtm_binddt2 W T A B C (G1 := G1) (G2 := fun A => A)).
      fequal. now rewrite Mult_compose_identity1.
    Qed.

    Lemma fmapt_binddt: forall
        (g : B -> G2 C)
        (f : W * A -> G1 (T B)),
        fmap G1 (traverse T G2 g) ∘ binddt T G1 f =
          binddt T (G1 ∘ G2) (fmap G1 (traverse T G2 g) ∘ f).
    Proof.
      intros.
      intros. unfold_ops @Traverse_Binddt.
      rewrite (kdtm_binddt2 W T A B C (G1 := G1) (G2 := G2)).
      fequal. ext [w a]. cbn.
      now rewrite preincr_extract.
    Qed.

    (** ** <<binddt>> on the left *)
    (******************************************************************************)
    Lemma binddt_bindd: forall
        (g : W * B -> G2 (T C))
        (f : W * A -> T B),
        binddt T G2 g ∘ bindd T f =
          binddt T G2 (fun '(w, a) => binddt T G2 (preincr w g) (f (w, a))).
    Proof.
      intros. unfold_ops @Bindd_Binddt.
      change (binddt T G2 g) with (fmap (fun A => A) (binddt T G2 g)).
      rewrite (kdtm_binddt2 W T A B C (G1 := fun A => A)).
      fequal. now rewrite Mult_compose_identity2.
    Qed.

    Lemma binddt_fmapdt: forall
        (g : W * B -> G2 (T C))
        (f : W * A -> G1 B),
        fmap G1 (binddt T G2 g) ∘ fmapdt T G1 f =
          binddt T (G1 ∘ G2) (fun '(w, a) => fmap G1 (fun b => g (w, b)) (f (w, a))).
    Proof.
      intros. unfold_ops @Fmapdt_Binddt.
      rewrite (kdtm_binddt2 W T A B C).
      fequal. ext [w a]. unfold compose; cbn.
      compose near (f (w, a)) on left.
      rewrite (fun_fmap_fmap G1).
      fequal. ext b. unfold compose; cbn.
      compose near b on left.
      rewrite (kdtm_binddt0 W T); auto.
      now rewrite preincr_ret.
    Qed.

    Lemma binddt_bindt: forall
        (g : W * B -> G2 (T C))
        (f : A -> G1 (T B)),
        fmap G1 (binddt T G2 g) ∘ bindt T G1 f =
          binddt T (G1 ∘ G2) (fun '(w, a) => fmap G1 (binddt T G2 (preincr w g)) (f a)).
    Proof.
      intros. unfold_ops @Bindt_Binddt.
      now rewrite (kdtm_binddt2 W T).
    Qed.

    Lemma binddt_bind: forall
        (g : W * B -> G2 (T C))
        (f : A -> T B),
        binddt T G2 g ∘ bind T f =
          binddt T G2 (fun '(w, a) => binddt T G2 (preincr w g) (f a)).
    Proof.
      intros. unfold_ops @Bind_Binddt.
      change (binddt T G2 g) with (fmap (fun A => A) (binddt T G2 g)).
      rewrite (kdtm_binddt2 W T A B C (G1 := fun A => A)).
      fequal. now rewrite Mult_compose_identity2.
    Qed.

    Lemma binddt_fmapd: forall
        (g : W * B -> G2 (T C))
        (f : W * A -> B),
        binddt T G2 g ∘ fmapd T f =
          binddt T G2 (fun '(w, a) => g (w, f (w, a))).
    Proof.
      intros. unfold_ops @Fmapd_Binddt.
      change (binddt T G2 g) with (fmap (fun A => A) (binddt T G2 g)).
      rewrite (kdtm_binddt2 W T A B C (G1 := fun A => A)).
      fequal. now rewrite Mult_compose_identity2.
      rewrite dtm_kleisli_75; auto.
      ext [w a]. unfold compose.
      compose near (f (w, a)).
      rewrite (kdtm_binddt0 W T); auto.
      now rewrite preincr_ret.
    Qed.

    Lemma binddt_fmapt: forall
        (g : W * B -> G2 (T C))
        (f : A -> G1 B),
        fmap G1 (binddt T G2 g) ∘ traverse T G1 f =
          binddt T (G1 ∘ G2) (fun '(w, a) => fmap G1 (fun b => g (w, b)) (f a)).
    Proof.
      intros. unfold_ops @Traverse_Binddt.
      rewrite (kdtm_binddt2 W T A B C (G1 := G1)).
      fequal. unfold kcompose_dtm.
      ext [w a]. unfold compose. cbn.
      compose near (f a) on left.
      rewrite (fun_fmap_fmap G1).
      rewrite (kdtm_binddt0 W T); auto.
      rewrite preincr_ret.
      reflexivity.
    Qed.

    (*
    Lemma binddt_fmap: forall
        (g : W * B -> G2 (T C))
        (f : A -> B),
        binddt T G2 g ∘ fmap T f =
          binddt T G2 (g ∘ fmap (W ×) f).
    Proof.
      intros. unfold_ops @Fmap_Binddt.
      change (binddt T G2 g) with (fmap (fun A => A) (binddt T G2 g)).
      rewrite (kdtm_binddt2 W T A B C (G2 := G2) (G1 := fun A => A)).
      fequal. now rewrite Mult_compose_identity2.
      ext [w a]. unfold compose. cbn.
      compose near (f a) on left.
      change (fmap (fun A => A) ?f) with f.
      rewrite (kdtm_binddt0 W T); auto.
      rewrite preincr_ret.
      reflexivity.
    Qed.
     *)

  End binddt.

  (** ** <<bindd>>, <<fmapdt>>, <<bindt>> *)
  (******************************************************************************)
  Section composition_laws.

    Context
      (T : Type -> Type)
        (G1 G2 : Type -> Type)
        `{DT.Monad.Monad W T}
        `{Applicative G1}
        `{Applicative G2}
        {A B C : Type}.

    (* <<bindd_bindd>> is already given. *)
    (* bindt_bindt already given *)
    (* fmapdt_fmapdt already given *)

    Lemma bindd_fmapdt: forall
        (g : W * B -> T C)
        (f : W * A -> G1 B),
        fmap G1 (bindd T g) ∘ fmapdt T G1 f =
          binddt T G1 (fun '(w, a) => fmap G1 (g ∘ pair w) (f (w, a))).
    Proof.
      intros. unfold_ops @Bindd_Binddt.
      rewrite (binddt_fmapdt T G1 (fun A => A)).
      fequal. now rewrite Mult_compose_identity1.
    Qed.

    Lemma fmapdt_bindd: forall
        (g : W * B -> G2 C)
        (f : W * A -> T B),
        fmapdt T G2 g ∘ bindd T f =
          binddt T G2 (fun '(w, a) => fmapdt T G2 (preincr w g) (f (w, a))).
    Proof.
      intros. unfold_ops @Bindd_Binddt.
      change (fmapdt T G2 g) with (fmap (fun A => A) (fmapdt T G2 g)).
      rewrite (fmapdt_binddt T (fun A => A) G2).
      fequal. now rewrite Mult_compose_identity2.
    Qed.

    Lemma bindt_bindd: forall
        (g : B -> G2 (T C))
        (f : W * A -> T B),
        bindt T G2 g ∘ bindd T f =
          binddt T G2 (bindt T G2 g ∘ f).
    Proof.
      intros. unfold_ops @Bindt_Binddt.
      rewrite (binddt_bindd T G2).
      fequal. ext [w a].
      now rewrite (preincr_extract).
    Qed.

    Lemma bindd_bindt: forall
        (g : W * B -> T C)
        (f : A -> G1 (T B)),
        fmap G1 (bindd T g) ∘ bindt T G1 f =
          binddt T G1 (fun '(w, a) => fmap G1 (bindd T (preincr w g)) (f a)).
    Proof.
      intros. unfold_ops @Bindt_Binddt.
      rewrite (bindd_binddt T G1).
      reflexivity.
    Qed.

    Lemma fmapdt_bindt: forall
        (g : W * B -> G2 C)
        (f : A -> G1 (T B)),
        fmap G1 (fmapdt T G2 g) ∘ bindt T G1 f =
          binddt T (G1 ∘ G2) (fun '(w, a) => fmap G1 (fmapdt T G2 (preincr w g)) (f a)).
    Proof.
      intros. unfold_ops @Bindt_Binddt.
      rewrite (fmapdt_binddt T G1 G2).
      reflexivity.
    Qed.

    Lemma bindt_fmapdt: forall
        (g : B -> G2 (T C))
        (f : W * A -> G1 B),
        fmap G1 (bindt T G2 g) ∘ fmapdt T G1 f =
          binddt T (G1 ∘ G2) (fmap G1 g ∘ f).
    Proof.
      intros. unfold_ops @Bindt_Binddt.
      rewrite (binddt_fmapdt T G1 G2).
      fequal. now ext [w a].
    Qed.

    (** ** <<bindd>> on the right *)
    (******************************************************************************)
    Lemma bind_bindd: forall
        (g : B -> T C)
        (f : W * A -> T B),
        bind T g ∘ bindd T f =
          bindd T (bind T g ∘ f).
    Proof.
      intros. rewrite (bind_to_bindd W T).
      rewrite (kmond_bindd2 T).
      fequal. unfold kcompose_dm.
      ext [w a]. now rewrite (preincr_extract).
    Qed.

    Lemma fmapd_bindd: forall
        (g : W * B -> C)
        (f : W * A -> T B),
        fmapd T g ∘ bindd T f =
          bindd T (fun '(w, a) => fmapd T (preincr w g) (f (w, a))).
    Proof.
      intros. rewrite (fmapd_to_bindd W T).
      rewrite (kmond_bindd2 T).
      reflexivity.
    Qed.

    (* traverse_bindd *)
    (* fmap_bindd *)

    (** ** <<bindd>> on the left *)
    (******************************************************************************)
    Lemma bindd_bind: forall
        (g : W * B -> T C)
        (f : A -> T B),
        bindd T g ∘ bind T f =
          bindd T (fun '(w, a) => bindd T (preincr w g) (f a)).
    Proof.
      intros. rewrite (bind_to_bindd W T).
      rewrite (kmond_bindd2 T).
      reflexivity.
    Qed.

    Lemma bindd_fmapd: forall
        (g : W * B -> T C)
        (f : W * A -> B),
        bindd T g ∘ fmapd T f =
          bindd T (g co⋆ f).
    Proof.
      intros. rewrite (fmapd_to_bindd W T).
      rewrite (kmond_bindd2 T).
      fequal. ext [w a]. unfold kcompose_dm, compose.
      compose near (f (w, a)).
      rewrite (kmond_bindd0 T).
      now rewrite preincr_ret.
    Qed.

    (* bindd_traverse *)
    (* bindd_fmap *)

    (** ** <<fmapdt>> on the right *)
    (******************************************************************************)
    (* bind_fmapdt *)

    Lemma fmapd_fmapdt : forall (g : W * B -> C) (f : W * A -> G1 B),
        fmap G1 (fmapd T g) ∘ fmapdt T G1 f = fmapdt T G1 (fmap G1 g ∘ strength G1 ∘ cobind (W ×) f).
    Proof.
      introv.
      change (@Fmapd_Binddt T W _ _) with (@DT.Functor.Derived.Fmapd_Fmapdt T W _).
      rewrite (DT.Functor.Derived.fmapd_fmapdt T G1).
      reflexivity.
    Qed.

    (* traverse_fmapdt *)

    (* fmap_fmapdt *)

    (** ** <<fmapdt>> on the left *)
    (******************************************************************************)
    (* fmapdt_bind *)
    Lemma fmapdt_fmapd : forall (g : W * B -> G2 C) (f : W * A -> B),
        fmapdt T G2 g ∘ fmapd T f = fmapdt T G2 (g co⋆ f).
    Proof.
      introv.
      change (@Fmapd_Binddt T W _ _) with (@DT.Functor.Derived.Fmapd_Fmapdt T W _).
      rewrite (DT.Functor.Derived.fmapdt_fmapd T G2).
      reflexivity.
    Qed.

    (* fmapdt_traverse *)

    (* fmapdt_fmap *)

    (** ** <<bindt>> on the right *)
    (******************************************************************************)
    Lemma bind_bindt : forall (g : B -> T C) (f : A -> G1 (T B)),
        fmap G1 (bind T g) ∘ bindt T G1 f = bindt T G1 (fmap G1 (bind T g) ∘ f).
    Proof.
      introv.
      change (@Bind_Binddt T W _) with (@Derived.Bind_Bindt T _).
      rewrite (Traversable.Monad.Derived.bind_bindt T G1).
      reflexivity.
    Qed.

    Lemma fmapd_bindt : forall (g : W * B -> C) (f : A -> G1 (T B)),
        fmap G1 (fmapd T g) ∘ bindt T G1 f = binddt T G1 (fun '(w, a) => fmap G1 (fmapd T (preincr w g)) (f a)).
    Proof.
      introv.
    Abort.

    (* traverse_bindt *)
    Lemma fmap_bindt : forall (g : B -> C) (f : A -> G1 (T B)),
        fmap G1 (fmap T g) ∘ bindt T G1 f = bindt T G1 (fmap G1 (fmap T g) ∘ f).
    Proof.
      intros.
      change (@Fmap_Binddt T W H0 H) with (@Derived.Fmap_Bindt T _ _).
      rewrite (Traversable.Monad.Derived.fmap_bindt T G1).
      reflexivity.
    Qed.

    (** ** <<bindt>> on the left *)
    (******************************************************************************)
    Lemma bindt_bind : forall (g : B -> G2 (T C)) (f : A -> T B),
        bindt T G2 g ∘ bind T f = bindt T G2 (bindt T G2 g ∘ f).
    Proof.
      introv.
      change (@Bind_Binddt T W _) with (@Traversable.Monad.Derived.Bind_Bindt T _).
      rewrite (Traversable.Monad.Derived.bindt_bind T G2).
      reflexivity.
    Qed.

    (* bindt_fmapd *)
    (* bindt_traverse *)
    (* bindt_fmap *)
    Lemma bindt_fmap : forall `(g : B -> G2 (T C)) `(f : A -> B),
        bindt T G2 g ∘ fmap T f = bindt T G2 (g ∘ f).
    Proof.
      intros.
      change (@Fmap_Binddt T W H0 H) with (@Derived.Fmap_Bindt T _ _).
      rewrite (Traversable.Monad.Derived.bindt_fmap T G2).
      reflexivity.
    Qed.

    (** ** <<traverse>> on the right *)
    (******************************************************************************)
    (* bind_traverse *)
    (* fmapd_traverse *)
    (* traverse_traverse *)

    (* fmap_traverse *)

    (** ** <<traverse>> on the left *)
    (******************************************************************************)
    (* traverse_bind *)
    (* traverse_fmapd *)
    (* traverse_traverse *)

    (* traverse_fmap *)

    (** ** <<fmapd>> on the right *)
    (******************************************************************************)
    (* bind_fmapd *)
    (* fmapd_fmapd *)
    (* traverse_fmapd *)

    (* fmap_fmapd *)

    (** ** <<fmapd>> on the left *)
    (******************************************************************************)
    (* fmapd_bind *)
    (* fmapd_fmapd *)
    (* fmapd_traverse *)

    (* fmapd_fmap *)

    (** ** <<bindd>> on the right *)
    (******************************************************************************)
    Lemma fmap_bindd : forall (g : B -> C) (f : W * A -> T B),
        fmap T g ∘ bindd T f = bindd T (fmap T g ∘ f).
    Proof.
      intros.
      Set Printing All.
      change (@Fmap_Binddt T W H0 H) with (@Derived.Fmap_Bindd T _ W _).
    (* pose (Decorated.Monad.Derived.fmap_bindd T).
    reflexivity.
  Qed. *)
    Abort.

    (** ** <<bindd>> on the left *)
    (******************************************************************************)

  End composition_laws.

End Derived.

(** * Auxiliary lemmas for constant applicative functors *)
(******************************************************************************)
Section lemmas.

  Context
    (T : Type -> Type)
      `{DT.Monad.Monad W T}.

  Import Derived.

  Lemma binddt_constant_applicative1
    `{Monoid M} {B : Type}
    `(f : W * A -> const M (T B)) :
    binddt (B := B) T (const M) f =
      binddt (B := False) T (const M) (f : W * A -> const M (T False)).
  Proof.
    change_right (fmap (B := T B) (const M) (fmap T exfalso)
                    ∘ (binddt (B := False) T (const M) (f : W * A -> const M (T False)))).
    rewrite (fmap_binddt T (const M)).
    - reflexivity.
    - typeclasses eauto.
  Qed.

  Lemma binddt_constant_applicative2 (fake1 fake2 : Type) `{Monoid M}
    `(f : W * A -> const M (T B)) :
    binddt (B := fake1) T (const M)
      (f : W * A -> const M (T fake1))
    = binddt (B := fake2) T (const M)
        (f : W * A -> const M (T fake2)).
  Proof.
    intros. rewrite (binddt_constant_applicative1 (B := fake1)).
    rewrite (binddt_constant_applicative1 (B := fake2)). easy.
  Qed.

End lemmas.

(*
(** * Expressing lesser operations with <<runSchedule>> *)
(******************************************************************************)
Section derived_operations_composition.

  #[local] Generalizable Variables A B W G.

  Context
    (T : Type -> Type)
    `{DT.Monad.Monad W T}
    `{Applicative G1}
    `{Applicative G2}
    {A B C : Type}.

  Corollary bindd_to_runSchedule :
    forall (A B : Type) (t : T A)
      (f : W * A -> T B),
      bindd T f t = runSchedule T (fun A => A) f (iterate T B t).
  Proof.
    intros. rewrite bindd_to_binddt. now rewrite (binddt_to_runSchedule T).
  Qed.

  Corollary bindt_to_runSchedule :
    forall `{Applicative G} (A B : Type) (t : T A)
      (f : A -> G (T B)),
      bindt T G f t = runSchedule T G (f ∘ extract (W ×)) (iterate T B t).
  Proof.
    intros. rewrite bindt_to_binddt. now rewrite (binddt_to_runSchedule T).
  Qed.

  Corollary fmapdt_to_runSchedule  :
    forall `{Applicative G} (A B : Type) (t : T A)
      `(f : W * A -> G B),
      fmapdt T G f t = runSchedule T G (fmap G (ret T) ∘ f) (iterate T B t).
  Proof.
    intros. rewrite fmapdt_to_binddt. now rewrite (binddt_to_runSchedule T).
  Qed.

  Corollary bind_to_runSchedule :
    forall (A B : Type) (t : T A)
      (f : A -> T B),
      bind T f t = runSchedule T (fun A => A) (f ∘ extract (W ×)) (iterate T B t).
  Proof.
    intros. rewrite bind_to_binddt. now rewrite (binddt_to_runSchedule T).
  Qed.

  Corollary fmapd_to_runBatch `(f : W * A -> B) (t : T A) :
    fmapd T f t = runSchedule T (fun A => A) (ret T ∘ f) (iterate T B t).
  Proof.
    rewrite fmapd_to_binddt. now rewrite (binddt_to_runSchedule T).
  Qed.

  Corollary fmapt_to_runBatch `{Applicative G} `(f : A -> G B) (t : T A) :
    traverse T G f t = runSchedule T G (fmap G (ret T) ∘ f ∘ extract (W ×)) (iterate T B t).
  Proof.
    rewrite fmapt_to_binddt. now rewrite (binddt_to_runSchedule T).
  Qed.

  Corollary fmap_to_runBatch `(f : A -> B) (t : T A) :
    fmap T f t = runSchedule T (fun A => A) (ret T ∘ f ∘ extract (W ×)) (iterate T B t).
  Proof.
    rewrite fmap_to_binddt. now rewrite (binddt_to_runSchedule T).
  Qed.

End derived_operations_composition.
*)

(** * Batch *)
(******************************************************************************)
Section with_functor.

  Context
    (T : Type -> Type)
    `{DT.Monad.Monad W T}.

  Definition toBatchdm {A : Type} (B : Type) : T A -> @Batch (W * A) (T B) (T B) :=
    binddt T (Batch (W * A) (T B)) (batch (T B)).

End with_functor.

(** ** Expressing <<binddt>> with <<runBatch>> *)
(******************************************************************************)
Section with_monad.

  Context
    (T : Type -> Type)
    `{DT.Monad.Monad W T}.

  Import DT.Monad.Derived.

  Theorem binddt_to_runBatch :
    forall `{Applicative G} (A B : Type) (f : W * A -> G (T B)) (t : T A),
      binddt T G f t = runBatch f (toBatchdm T B t).
  Proof.
    intros.
    unfold toBatchdm.
    compose near t on right.
    rewrite (kdtm_morph W T (Batch (W * A) (T B)) G).
    now rewrite (runBatch_batch).
  Qed.

  Theorem bindd_to_runBatch :
    forall (A B : Type) (f : W * A -> T B) (t : T A),
      bindd T f t =
        runBatch (F := fun A => A) f (toBatchdm T B t).
  Proof.
    intros.
    unfold toBatchdm.
    compose near t on right.
    rewrite (kdtm_morph W T (Batch (W * A) (T B)) (fun A => A)).
    reflexivity.
  Qed.

  Theorem fmapdt_to_runBatch :
    forall `{Applicative G} (A B : Type) (f : W * A -> G B) (t : T A),
      fmapdt T G f t = runBatch f (toBatchd T B t).
  Proof.
    intros. apply (fmapdt_to_runBatch T).
  Qed.

  Theorem fmapd_to_runBatch :
    forall `{Applicative G} (A B : Type) (f : W * A -> B) (t : T A),
      fmapd T f t = runBatch f (toBatchd T B t).
  Proof.
    intros.
    change (@Fmapd_Binddt T W _ _) with
      (@Derived.Fmapd_Fmapdt T _ _).
    apply (fmapd_to_runBatch T).
  Qed.

  Theorem fmap_to_runBatch : forall (A B : Type) (f : A -> B),
      fmap T f = runBatch f ∘ toBatch T B.
  Proof.
    intros.
    change (@Fmap_Binddt T W H0 H) with (@Derived.Fmap_Fmapdt T _ _).
    change (@Traverse_Binddt T W _ _) with (@Derived.Traverse_Fmapdt T _ _).
    apply (fmap_to_runBatch T).
  Qed.

End with_monad.

Import Derived.

Section with_monad.

  Context
    (T : Type -> Type)
    `{DT.Monad.Monad W T}.

  (** *** Composition with monad operattions *)
  (******************************************************************************)
  Lemma foldMapd_ret `{Monoid M} : forall `(f : W * A -> M),
      foldMapd T f ∘ ret T = f ∘ ret (W ×).
  Proof.
    intros. unfold foldMapd. unfold_ops @Fmapdt_Binddt.
    rewrite (kdtm_binddt0 W T _ _ (G := const M)).
    reflexivity.
  Qed.

  Lemma foldMapd_binddt `{Applicative G} `{Monoid M} : forall `(g : W * B -> M) `(f : W * A -> G (T B)),
      fmap G (foldMapd T g) ∘ binddt T G f =
        foldMapd T (fun '(w, a) => fmap G (foldMapd T (preincr w g)) (f (w, a))).
  Proof.
    intros. unfold foldMapd. unfold_ops @Fmapdt_Binddt.
    rewrite (kdtm_binddt2 W T _ _ _ (G1 := G) (G2 := const M)).
    fequal.
    - unfold Fmap_compose.
      ext A' B' f'.
      enough (hyp : fmap G (fmap (const M) f') = id).
      + rewrite hyp. reflexivity.
      + ext m. rewrite <- (fun_fmap_id G).
        reflexivity.
    - ext A' B' [t1 t2]. reflexivity.
  Qed.

  Corollary foldMapd_binddt_I `{Monoid M} : forall `(g : W * B -> M) `(f : W * A -> T B),
      foldMapd T g ∘ binddt T (fun A => A) f =
        foldMapd T (fun '(w, a) => foldMapd T (preincr w g) (f (w, a))).
  Proof.
    intros. change (foldMapd T g) with (fmap (fun A => A) (foldMapd T g)).
    now rewrite (foldMapd_binddt (G := fun A => A)).
  Qed.

  (** *** Composition with lessor operations *)
  (******************************************************************************)
  Lemma foldMapd_bindd `{Monoid M} : forall `(g : W * B -> M) `(f : W * A -> T B),
      foldMapd T g ∘ bindd T f =
        foldMapd T (fun '(w, a) => foldMapd T (preincr w g) (f (w, a))).
  Proof.
    intros. unfold_ops @Bindd_Binddt.
    change (foldMapd T g) with (fmap (fun A => A) (foldMapd T g)).
    now rewrite (foldMapd_binddt (G := fun A => A)).
  Qed.

End with_monad.

Import List.ListNotations.
Import Sets.Notations.

(** * Shape and contents *)
(******************************************************************************)
Section DTM_tolist.

  Context
    (T : Type -> Type)
    `{DT.Monad.Monad W T}.

  Import DT.Monad.Derived.

  (** ** Relating <<tolistd>> and <<binddt>> / <<ret>> *)
  (******************************************************************************)
  Lemma tolistd_ret : forall (A : Type) (a : A),
      tolistd T (ret T a) = [ (Ƶ, a) ].
  Proof.
    unfold tolistd.
    intros. compose near a.
    now rewrite (foldMapd_ret T).
  Qed.

  Lemma tolistd_binddt : forall `{Applicative G} `{Monoid M} `(f : W * A -> G (T B)),
      fmap G (tolistd T) ∘ binddt T G f =
        foldMapd T (fun '(w, a) => fmap G (foldMapd T (preincr w (ret list))) (f (w, a))).
  Proof.
    intros. unfold tolistd. now rewrite (foldMapd_binddt T).
  Qed.

  (** ** Relating <<tolistd>> and lesser operations *)
  (******************************************************************************)
  Lemma tolistd_bindd : forall `{Monoid M} `(f : W * A -> T B),
      tolistd T ∘ bindd T f =
        foldMapd T (fun '(w, a) => foldMapd T (preincr w (ret list)) (f (w, a))).
  Proof.
    intros. unfold_ops @Bindd_Binddt.
    change (@tolistd T _ _ B) with (fmap (fun A => A) (@tolistd T _ _ B)).
    rewrite (tolistd_binddt (G := fun A => A)).
    reflexivity.
  Qed.

  (** ** Corollaries for the rest *)
  (******************************************************************************)
  Corollary tosetd_ret : forall (A : Type) (a : A),
      tosetd T (ret T a) = {{ (Ƶ, a) }}.
  Proof.
    intros. unfold_ops @Tosetd_Kleisli.
    compose near a.
    now rewrite (foldMapd_ret T).
  Qed.

  Corollary tolist_binddt : forall `{Applicative G} `{Monoid M} `(f : W * A -> G (T B)),
      fmap G (tolist T) ∘ binddt T G f =
        foldMapd T (fmap G (tolist T) ∘ f).
  Proof.
    intros.
    change (@Traverse_Binddt T W _ _)
      with (@Derived.Traverse_Fmapdt _ _ _).
    rewrite (tolist_to_tolistd T).
    rewrite <- (fun_fmap_fmap G).
    reassociate ->.
    rewrite tolistd_binddt.
    rewrite (foldMapd_morphism T).
    rewrite (fun_fmap_fmap G).
    fequal. unfold tolistd.
    ext [w a]. unfold compose at 1 2.
    compose near (f (w, a)) on left.
    rewrite (fun_fmap_fmap G).
    rewrite (foldMapd_morphism T).
    rewrite (foldMapd_morphism T).
    fequal. fequal.
    ext [w' b]. reflexivity.
  Qed.

  (** ** Relating <<tolist>> and lesser operations *)
  (******************************************************************************)
  Lemma tolist_bindd : forall `{Monoid M} `(f : W * A -> T B),
      tolist T ∘ bindd T f =
        foldMapd T (fun '(w, a) => foldMap T (ret list) (f (w, a))).
  Proof.
    intros.
    change (@Traverse_Binddt T W _ _)
      with (@Derived.Traverse_Fmapdt T W _).
    rewrite (tolist_to_tolistd T).
    reassociate ->. rewrite (tolistd_bindd).
    rewrite (foldMapd_morphism T).
    fequal. ext [w a].
    cbn. compose near (f (w, a)) on left.
    rewrite (foldMapd_morphism T).
    rewrite (foldMap_to_foldMapd T).
    fequal. now ext [w' a'].
  Qed.

End DTM_tolist.

Import Setlike.Functor.Notations.

(** ** Characterizing membership in list operations *)
(******************************************************************************)
Section DTM_tolist.

  Context
    (T : Type -> Type)
    `{DT.Monad.Monad W T}.

  Import Derived.

  Lemma ind_iff_in_tolistd : forall (A : Type) (a : A) (w : W) (t : T A),
      (w, a) ∈d t <-> toset list (tolistd T t) (w, a).
  Proof.
    intros. unfold tolistd.
    unfold_ops @Tosetd_Kleisli.
    compose near t on right.
    rewrite (foldMapd_morphism T (ϕ := toset list)).
    replace (@ret set (Return_set) (W * A)) with (toset (A := W * A) list ∘ ret list).
    reflexivity. ext [w' a']. solve_basic_set.
  Qed.

  Lemma in_iff_in_tolist : forall (A : Type) (a : A) (t : T A),
      (a ∈ t) <-> toset list (tolist T t) a.
  Proof.
    intros.
    change (@Traverse_Binddt T W _ _)
      with (@Derived.Traverse_Fmapdt _ _ _).
    rewrite (toset_to_tolist T).
    reflexivity.
  Qed.

End DTM_tolist.

(** * Characterizing <<∈d>> *)
(******************************************************************************)
Section section.

  Context
    (T : Type -> Type)
    `{DT.Monad.Monad W T}.

  Import Derived.

  #[local] Notation "x ∈d t" :=
    (tosetd _ t x) (at level 50) : tealeaves_scope.

  Existing Instance Toset_set.
  Existing Instance SetlikeFunctor_set.
  Lemma ind_iff_in : forall (A : Type) (a : A) (t : T A),
      a ∈ t <-> exists w, (w, a) ∈d t.
  Proof.
    intros.
    change (@Traverse_Binddt T W _ _)
      with (@Derived.Traverse_Fmapdt T _ _).
    now rewrite (ind_iff_in T).
  Qed.

  Lemma ind_ret_iff : forall {A : Type} (w : W) (a1 a2 : A),
      (w, a1) ∈d ret T a2 <-> w = Ƶ /\ a1 = a2.
  Proof.
    intros. unfold_ops @Tosetd_Kleisli.
    compose near a2 on left. rewrite (foldMapd_ret T).
    unfold compose. split.
    now inversion 1.
    inversion 1. subst. solve_basic_set.
  Qed.

  Lemma in_ret_iff : forall {A : Type} (a1 a2 : A),
      a1 ∈ ret T a2 <-> a1 = a2.
  Proof.
    intros.
    change (@Traverse_Binddt T W _ _)
      with (@Derived.Traverse_Bindt T _ _).
    now rewrite (in_ret_iff T).
  Qed.

  Lemma ind_bindd_iff1 :
    forall `(f : W * A -> T B) (t : T A) (wtotal : W) (b : B),
      (wtotal, b) ∈d bindd T f t ->
      exists (w1 w2 : W) (a : A),
        (w1, a) ∈d t /\ (w2, b) ∈d f (w1, a)
        /\ wtotal = w1 ● w2.
  Proof.
    introv hyp. unfold Tosetd_Kleisli, tosetd, compose in *.
    change (foldMapd T (ret set) (bindd T f t) (wtotal, b))
      with (((foldMapd T (ret set) ∘ bindd T f) t) (wtotal, b)) in hyp.
    rewrite (foldMapd_bindd T) in hyp.
    rewrite (foldMapd_to_runBatch T) in hyp.
    rewrite (foldMapd_to_runBatch T).
    (* HACK: We want to call "rewrite (foldMapd_to_runBatch T)" but
    this fails under the binder. The following is a kludge. *)
    cut (exists (w1 w2 : W) (a : A),
               runBatch (B := False) (F := fun _ => set (W * A))
                 (@ret set Return_set (W * A)) (toBatchd T (A:=A) False t) (w1, a) /\
                 runBatch (B := False) (F := fun _ => set (W * B)) (ret set) (toBatchd T (A:=B) False (f (w1, a))) (w2, b) /\ wtotal = w1 ● w2).
    { intro. preprocess. repeat eexists; try rewrite (foldMapd_to_runBatch T B); eauto. }
    induction (toBatchd T False t).
    - cbv in hyp. inversion hyp.
    - destruct x as [wx ax].
      cbn in hyp. destruct hyp as [hyp | hyp].
      + (* (wtotal, b) in b0 *)
        specialize (IHb0 hyp).
        destruct IHb0 as [w1 [w2 [a [IH_a_in [IH_b_in IH_sum]]]]].
        exists w1 w2 a. split; [now left | auto].
      + (* (wotal, b) in f (wx,ax) *)
        clear IHb0.
        rewrite (foldMapd_to_runBatch T) in hyp.
        assert (lemma : exists w2 : W, runBatch (B := False) (F := fun _ => set (W * B)) (ret set) (toBatchd T False (f (wx, ax))) (w2, b) /\ wtotal = wx ● w2).
        { induction (toBatchd T False (f (wx, ax))).
          - cbv in hyp. inversion hyp.
          - destruct hyp as [hyp|hyp].
            + specialize (IHb1 hyp). destruct IHb1 as [w2 [IHb1' IHb1'']].
              exists w2. split. now left. assumption.
            + destruct x as [wx2 b2]. cbv in hyp. inverts hyp.
              exists wx2. split. now right. reflexivity. }
        destruct lemma as [w2 rest].
        exists wx w2 ax. split. now right. assumption.
  Qed.

  Lemma ind_bindd_iff2 :
    forall `(f : W * A -> T B) (t : T A) (wtotal : W) (b : B),
    (exists (w1 w2 : W) (a : A),
      (w1, a) ∈d t /\ (w2, b) ∈d f (w1, a)
        /\ wtotal = w1 ● w2) ->
      (wtotal, b) ∈d bindd T f t.
  Proof.
    introv [w1 [w2 [a [a_in [b_in wsum]]]]]. subst.
    unfold tosetd, Tosetd_Kleisli, compose in *.
    compose near t.
    rewrite (foldMapd_bindd T).
    rewrite (foldMapd_to_runBatch T).
    rewrite (foldMapd_to_runBatch T) in a_in.
    rewrite (foldMapd_to_runBatch T) in b_in.
    induction (toBatchd T False t).
    - cbv in a_in. inversion a_in.
    - cbn in a_in. destruct a_in as [a_in | a_in].
      + destruct x as [wx ax].
        specialize (IHb0 a_in b_in).
        left. assumption.
      + clear IHb0. destruct x as [wx ax].
        inverts a_in. right.
        { rewrite (foldMapd_to_runBatch T).
          induction (toBatchd T False (f (w1, a))).
          - inversion b_in.
          - destruct b_in.
            + left. auto.
            + right. destruct x. unfold preincr, compose. cbn.
              inverts H2. easy.
        }
  Qed.

  Theorem ind_bindd_iff :
    forall `(f : W * A -> T B) (t : T A) (wtotal : W) (b : B),
      (wtotal, b) ∈d bindd T f t <->
      exists (w1 w2 : W) (a : A),
        (w1, a) ∈d t /\ (w2, b) ∈d f (w1, a)
        /\ wtotal = w1 ● w2.
  Proof.
    split; auto using ind_bindd_iff1, ind_bindd_iff2.
  Qed.

  Theorem ind_bind_iff :
    forall `(f : A -> T B) (t : T A) (wtotal : W) (b : B),
      (wtotal, b) ∈d bind T f t <->
      exists (w1 w2 : W) (a : A),
        (w1, a) ∈d t /\ (w2, b) ∈d f a
        /\ wtotal = w1 ● w2.
  Proof.
    intros. apply ind_bindd_iff.
  Qed.

  (** ** Characterizing <<∈>> with <<bindd>> *)
  (******************************************************************************)
  Corollary in_bindd_iff :
    forall `(f : W * A -> T B) (t : T A) (b : B),
      b ∈ bindd T f t <->
      exists (w1 : W) (a : A),
        (w1, a) ∈d t /\ b ∈ f (w1, a).
  Proof.
    intros.
    rewrite (ind_iff_in).
    setoid_rewrite ind_bindd_iff.
    setoid_rewrite (ind_iff_in).
    split; intros; preprocess; repeat eexists; eauto.
  Qed.

  Corollary in_bind_iff :
    forall `(f : A -> T B) (t : T A) (b : B),
      b ∈ bind T f t <-> exists (a : A), a ∈ t /\ b ∈ f a.
  Proof.
    change (@Traverse_Binddt T W _ _)
      with (@Derived.Traverse_Fmapdt _ _ _).
    intros. setoid_rewrite (ind_iff_in).
    setoid_rewrite (ind_bindd_iff).
    intuition.
    - preprocess. eexists; split; eauto.
    - preprocess. repeat eexists; eauto.
  Qed.

  Theorem in_fmapd_iff :
    forall `(f : W * A -> B) (t : T A) (b : B),
      b ∈ fmapd T f t <-> exists (w : W) (a : A), (w, a) ∈d t /\ f (w, a) = b.
  Proof.
    intros.
    change (@Traverse_Binddt T W _ _)
      with (@Derived.Traverse_Fmapdt _ _ _).
    rewrite (ind_iff_in).
    setoid_rewrite (ind_fmapd_iff T).
    reflexivity.
  Qed.

End section.

(** ** Respectfulness for <<bindd>> *)
(******************************************************************************)
Section bindd_respectful.

  Context
    (T : Type -> Type)
    `{Kleisli.DT.Monad.Monad W T}.

  Import Derived.

  #[local] Notation "x ∈d t" :=
    (tosetd _ t x) (at level 50) : tealeaves_scope.

  Theorem bindd_respectful :
    forall A B (t : T A) (f g : W * A -> T B),
      (forall (w : W) (a : A), (w, a) ∈d t -> f (w, a) = g (w, a))
      -> bindd T f t = bindd T g t.
  Proof.
    unfold_ops @Tosetd_Kleisli.
    unfold foldMapd in *.
    introv hyp.
    rewrite (fmapdt_constant_applicative2 T False B) in hyp.
    unfold fmapdt, Fmapdt_Binddt in hyp.
    rewrite (binddt_to_runBatch T) in hyp.
    do 2 rewrite (bindd_to_runBatch T).
    induction (toBatchdm T B t).
    - easy.
    - destruct x. do 2 rewrite runBatch_rw2.
      rewrite runBatch_rw2 in hyp.
      fequal.
      + apply IHb. intros. apply hyp.
        cbn. now left.
      + apply hyp. now right.
  Qed.

  (** *** For equalities with special cases *)
  (** Corollaries with conclusions of the form <<bindd t = f t>> for
  other <<m*>> operations *)
  (******************************************************************************)
  Corollary bindd_respectful_bind :
    forall A B (t : T A) (f : W * A -> T B) (g : A -> T B),
      (forall (w : W) (a : A), (w, a) ∈d t -> f (w, a) = g a)
      -> bindd T f t = bind T g t.
  Proof.
    introv hyp. rewrite bind_to_bindd.
    apply bindd_respectful. introv Hin.
    unfold compose. cbn. auto.
  Qed.

  Corollary bindd_respectful_fmapd :
    forall A B (t : T A) (f : W * A -> T B) (g : W * A -> B),
      (forall (w : W) (a : A), (w, a) ∈d t -> f (w, a) = ret T (g (w, a)))
      -> bindd T f t = fmapd T g t.
  Proof.
    introv hyp. rewrite fmapd_to_bindd.
    apply bindd_respectful. introv Hin.
    unfold compose. cbn. auto.
  Qed.

  Corollary bindd_respectful_fmap :
    forall A B (t : T A) (f : W * A -> T B) (g : A -> B),
      (forall (w : W) (a : A), (w, a) ∈d t -> f (w, a) = ret T (g a))
      -> bindd T f t = fmap T g t.
  Proof.
    introv hyp. rewrite fmap_to_bindd.
    apply bindd_respectful. introv Hin.
    unfold compose. cbn. auto.
  Qed.

  Corollary bindd_respectful_id :
    forall A (t : T A) (f : W * A -> T A),
      (forall (w : W) (a : A), (w, a) ∈d t -> f (w, a) = ret T a)
      -> bindd T f t = t.
  Proof.
    intros. change t with (id t) at 2.
    rewrite <- (kmond_bindd1 T).
    eapply bindd_respectful.
    unfold compose; cbn. auto.
  Qed.

End bindd_respectful.

(** ** Respectfulness for <<bind>> *)
(******************************************************************************)
Section bind_respectful.

  Context
    (T : Type -> Type)
    `{Kleisli.DT.Monad.Monad W T}.

  Import Derived.

  #[local] Notation "x ∈d t" :=
    (tosetd _ t x) (at level 50) : tealeaves_scope.

  Lemma bind_respectful :
    forall A B (t : T A) (f g : A -> T B),
      (forall (a : A), a ∈ t -> f a = g a)
      -> bind T f t = bind T g t.
  Proof.
    introv hyp. rewrite bind_to_bindd.
    apply (bindd_respectful T). introv premise. apply (ind_implies_in T) in premise.
    unfold compose; cbn. auto.
  Qed.

  (** *** For equalities with other operations *)
  (** Corollaries with conclusions of the form <<bind t = f t>> for
  other <<m*>> operations *)
  (******************************************************************************)
  Corollary bind_respectful_fmapd :
    forall A B (t : T A) (f : A -> T B) (g : W * A -> B),
      (forall (w : W) (a : A), (w, a) ∈d t -> f a = ret T (g (w, a)))
      -> bind T f t = fmapd T g t.
  Proof.
    intros. rewrite fmapd_to_bindd.
    symmetry. apply (bindd_respectful_bind T).
    introv Hin. symmetry. unfold compose; cbn.
    auto.
  Qed.

  Corollary bind_respectful_fmap :
    forall A B (t : T A) (f : A -> T B) (g : A -> B),
      (forall (a : A), a ∈ t -> f a = ret T (g a))
      -> bind T f t = fmap T g t.
  Proof.
    intros. rewrite fmap_to_bind.
    symmetry. apply bind_respectful.
    introv Hin. symmetry. unfold compose; cbn.
    auto.
  Qed.

  Corollary bind_respectful_id : forall A (t : T A) (f : A -> T A),
      (forall (a : A), a ∈ t -> f a = ret T a)
      -> bind T f t = t.
  Proof.
    intros. change t with (id t) at 2.
    rewrite <- (kmon_bind1 T).
    eapply bind_respectful.
    unfold compose; cbn. auto.
  Qed.

End bind_respectful.

(** ** Respectfulness for <<fmapd>> *)
(******************************************************************************)
Section fmapd_respectful.

  Context
    (T : Type -> Type)
    `{Kleisli.DT.Monad.Monad W T}.

  Import Derived.

  #[local] Notation "x ∈d t" :=
    (tosetd _ t x) (at level 50) : tealeaves_scope.

  Lemma fmapd_respectful :
    forall A B (t : T A) (f g : W * A -> B),
      (forall (w : W) (a : A), (w, a) ∈d t -> f (w, a) = g (w, a))
      -> fmapd T f t = fmapd T g t.
  Proof.
    introv hyp. do 2 rewrite fmapd_to_bindd.
    apply (bindd_respectful T). introv premise.
    unfold compose; cbn. fequal. auto.
  Qed.

  (** *** For equalities with other operations *)
  (** Corollaries with conclusions of the form <<fmapd t = f t>> for
  other <<m*>> operations *)
  (******************************************************************************)
  Corollary fmapd_respectful_fmap :
    forall A (t : T A) (f : W * A -> A) (g : A -> A),
      (forall (w : W) (a : A), (w, a) ∈d t -> f (w, a) = g a)
      -> fmapd T f t = fmap T g t.
  Proof.
    intros. rewrite fmap_to_fmapd.
    apply (fmapd_respectful). introv Hin.
    unfold compose; cbn; auto.
  Qed.

  Corollary fmapd_respectful_id : forall A (t : T A) (f : W * A -> A),
      (forall (w : W) (a : A), (w, a) ∈d t -> f (w, a) = a)
      -> fmapd T f t = t.
  Proof.
    intros. change t with (id t) at 2.
    rewrite <- (dfun_fmapd1 W T).
    eapply (fmapd_respectful).
    cbn. auto.
  Qed.

End fmapd_respectful.

(** ** Respectfulness for <<fmap>> *)
(******************************************************************************)
Section fmap_respectful.

  Context
    (T : Type -> Type)
    `{Kleisli.DT.Monad.Monad W T}.

  Import Derived.

  #[local] Notation "x ∈d t" :=
    (tosetd _ t x) (at level 50) : tealeaves_scope.

  Lemma fmap_respectful :
    forall A B (t : T A) (f g : A -> B),
      (forall (w : W) (a : A), (w, a) ∈d t -> f a = g a)
      -> fmap T f t = fmap T g t.
  Proof.
    introv hyp. do 2 rewrite fmap_to_fmapd.
    now apply (fmapd_respectful T).
  Qed.

  Corollary fmap_respectful_id :
    forall A (t : T A) (f : A -> A),
      (forall (w : W) (a : A), (w, a) ∈d t -> f a = a)
      -> fmap T f t = t.
  Proof.
    intros. change t with (id t) at 2.
    rewrite <- (fun_fmap_id T).
    eapply (fmap_respectful).
    auto.
  Qed.

End fmap_respectful.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C P Q I : Universe, ((wd_ P Q /\ (wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ A P /\ (wd_ A Q /\ (wd_ B P /\ (wd_ B Q /\ (wd_ C P /\ (wd_ C Q /\ (wd_ P I /\ (wd_ I Q /\ (wd_ P Q /\ (wd_ I B /\ (wd_ B C /\ (wd_ I C /\ (col_ P I Q /\ (col_ I B C /\ col_ B Q I)))))))))))))))))) -> col_ B P Q)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C P Q I : Universe, ((wd_ P I /\ (wd_ I Q /\ (wd_ P Q /\ (wd_ I B /\ (wd_ B A /\ (wd_ I A /\ (wd_ P Q /\ (wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ A P /\ (wd_ A Q /\ (wd_ B P /\ (wd_ B Q /\ (wd_ C P /\ (wd_ C Q /\ (col_ P I Q /\ (col_ I B A /\ col_ B P I)))))))))))))))))) -> col_ A P Q)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C P Q I : Universe, ((wd_ P Q /\ (wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ A P /\ (wd_ A Q /\ (wd_ B P /\ (wd_ B Q /\ (wd_ C P /\ (wd_ C Q /\ (wd_ P I /\ (wd_ I Q /\ (wd_ P Q /\ (wd_ I C /\ (wd_ C B /\ (wd_ I B /\ (col_ P I Q /\ (col_ I C B /\ col_ C P I)))))))))))))))))) -> col_ B P Q)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

 The fibrations of functors into the category of strict categories

 In this file, we prove that the displayed bicategory of functors into the category of strict categories has a
 local opcleaving, a local isocleaving, and a global cleaving.

 Contents:
 1. Local opcleaving
 2. Local isocleaving
 3. Global cleaving

 ******************************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Setcategories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.categories.CategoryOfSetCategories.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Examples.StrictCats.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.FunctorsIntoCat.

Local Open Scope cat.

(**
 1. Local opcleaving
 *)
Definition functors_into_cat_is_opcartesian_2cell
           {C₁ C₂ : bicat_of_strict_cats}
           {F₁ F₂ : C₁ --> C₂}
           {α : F₁ ==> F₂}
           {G₁ : disp_bicat_of_functors_into_cat C₁}
           {G₂ : disp_bicat_of_functors_into_cat C₂}
           {β₁ : G₁ -->[ F₁ ] G₂}
           {β₂ : G₁ -->[ F₂ ] G₂}
           (p : β₁ ==>[ α ] β₂)
  : is_opcartesian_2cell disp_bicat_of_functors_into_cat p.
Proof.
  intros H GH γ ββ.
  use iscontraprop1.
  - use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)).
    + use impred ; intro.
      apply homset_property.
    + apply disp_bicat_of_functors_into_cat.
  - simple refine (_ ,, _).
    + intro x ; cbn.
      refine (_ @ ββ x).
      refine (!_).
      etrans.
      {
        apply maponpaths.
        apply (functor_comp G₂).
      }
      refine (assoc (pr1 β₁ x) (# (pr1 G₂) (pr1 α x)) _ @ _).
      apply maponpaths_2.
      exact (p x).
    + apply functors_into_cat_disp_2cells_isaprop.
Qed.

Definition functors_into_cat_local_opcleaving
  : local_opcleaving disp_bicat_of_functors_into_cat.
Proof.
  intros C₁ C₂ G₁ G₂ F₁ F₂ α β.
  simple refine (_ ,, _ ,, functors_into_cat_is_opcartesian_2cell _).
  - exact (nat_trans_comp _ _ _ α (post_whisker β _)).
  - abstract
      (intro x ; cbn ;
       apply idpath).
Defined.

(**
 2. Local isocleaving
 *)
Definition functors_into_cat_local_iso_cleaving
  : local_iso_cleaving disp_bicat_of_functors_into_cat.
Proof.
  intros C₁ C₂ G₁ G₂ F₁ F₂ α β.
  simple refine (_ ,, _ ,, _).
  - exact (nat_trans_comp _ _ _ α (post_whisker (β^-1) _)).
  - abstract
      (intro x ;
       refine (assoc' (pr1 α x) _ _ @ _ @ id_right _) ;
       apply maponpaths ;
       refine (!(functor_comp F₂ _ _) @ _ @ functor_id F₂ _) ;
       apply maponpaths ;
       exact (nat_trans_eq_pointwise (vcomp_linv β) x)).
  - apply functors_into_cat_disp_locally_groupoid.
Defined.

(**
 3. Global cleaving
 *)
Definition functors_into_cat_nat_iso_is_cartesian_1cell
           {C₁ C₂ : bicat_of_strict_cats}
           {F : C₁ --> C₂}
           {G₁ : disp_bicat_of_functors_into_cat C₁}
           {G₂ : disp_bicat_of_functors_into_cat C₂}
           (α : G₁ -->[ F ] G₂)
           (Hα : is_nat_z_iso (pr1 α))
  : cartesian_1cell disp_bicat_of_functors_into_cat α.
Proof.
  split.
  - intros C₃ G₃ H HF.
    simple refine (_ ,, _).
    + exact (nat_trans_comp
                _ _ _
                HF
                (pre_whisker _ (nat_z_iso_inv (make_nat_z_iso _ _ α Hα)))).
    + simple refine (_ ,, _).
      * abstract
          (intro x ; cbn ;
           etrans ;
           [ apply maponpaths ;
             apply (functor_id G₂)
           | ] ;
           refine (id_right (pr1 HF x · _ · _) @ _) ;
           refine (_ @ id_right _) ;
           rewrite assoc' ;
           apply maponpaths ;
           apply Hα).
      * apply functors_into_cat_disp_locally_groupoid.
  - intros C₃ G₃ F₁ F₂ β γ δ p ℓ₁ ℓ₂.
    use iscontraprop1.
    + abstract
        (use invproofirrelevance ;
         intros φ₁ φ₂ ;
         use subtypePath ; [ intro ; apply disp_bicat_of_functors_into_cat | ] ;
         apply functors_into_cat_disp_2cells_isaprop).
    + simple refine (_ ,, _).
      * abstract
          (intro x ;
           pose (pr12 ℓ₁ x) as q₁ ;
           pose (pr12 ℓ₂ x @ !(p x) @ maponpaths (λ z, z · _) (!q₁)) as q₂ ;
           rewrite !(functor_id G₂) in q₂ ;
           pose (!(id_right (pr11 ℓ₂ x · pr1 α (pr1 F₂ x))) @ q₂) as q₃ ;
           pose (q₃ @ maponpaths (λ z, z · # (pr1 G₂) _) (id_right _) @ assoc' _ _ _) as q₄ ;
           pose (q₄ @ maponpaths (λ z, _ · z) (!(nat_trans_ax α _ _ (pr1 δ x)))) as q₅ ;
           pose (maponpaths
                   (λ z, z · nat_z_iso_inv (make_nat_z_iso _ _ _ Hα) (pr1 F₂ x))
                   q₅)
             as q₆ ;
           refine (_ @ !q₆ @ _) ;
           [ refine (_ @ assoc (pr11 ℓ₁ x) _ _) ;
             apply maponpaths ;
             refine (_ @ assoc _ _ _) ;
             refine (!(id_right _) @ _) ;
             apply maponpaths ;
             refine (!_) ;
             apply Hα
           | refine (assoc' (pr11 ℓ₂ x) _ _ @ _) ;
             refine (_ @ id_right _) ;
             apply maponpaths ;
             apply Hα ]).
      * apply functors_into_cat_disp_2cells_isaprop.
Defined.

Section CartesianIsNatIso.
  Context {C₁ C₂ : bicat_of_strict_cats}
          {F : C₁ --> C₂}
          {G₁ : disp_bicat_of_functors_into_cat C₁}
          {G₂ : disp_bicat_of_functors_into_cat C₂}
          (α : G₁ -->[ F ] G₂)
          (Hα : cartesian_1cell disp_bicat_of_functors_into_cat α).

  Local Definition functors_into_cat_cartesian_1cell_is_nat_iso_inv
                   (x : pr1 C₁)
    : (F ∙ G₂) x --> pr1 G₁ x
    := let l := pr1 Hα C₁ (F ∙ G₂) (functor_identity _) (nat_trans_id _) in
       pr1 (pr1 l) x.

  Local Lemma functors_into_cat_cartesian_1cell_is_nat_iso_is_inverse
              (x : pr1 C₁)
    : is_inverse_in_precat
        (pr1 α x)
        (functors_into_cat_cartesian_1cell_is_nat_iso_inv x).
  Proof.
    pose (l := pr1 Hα C₁ (F ∙ G₂) (functor_identity _) (nat_trans_id _)).
    split ; unfold functors_into_cat_cartesian_1cell_is_nat_iso_inv.
    - cbn.
      assert (α ==>[ nat_trans_id (functor_identity _) ▹ F] α) as p.
      {
        intro z ; cbn.
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths.
            apply (functor_id F).
          }
          apply (functor_id G₂).
        }
        apply (id_right (pr1 α z)).
      }
      simple refine (_ @ @cartesian_1cell_lift_2cell
                           _ _ _ _ _ _ _ _
                           Hα
                           C₁
                           G₁
                           (functor_identity _) (functor_identity _)
                           α α
                           (nat_trans_id _)
                           p
                           (nat_trans_comp _ _ _ α (pr1 l) ,, _)
                           (nat_trans_id _ ,, _)
                           x).
      + cbn.
        refine (!_).
        etrans.
        {
          apply maponpaths.
          apply (functor_id G₁).
        }
        apply (id_right (pr1 α x · _)).
      + simple refine (_ ,, _).
        * intro z.
          cbn.
          refine (_ @ id_right (pr1 α z)).
          refine (_ @ maponpaths (λ z, _ · z) (pr12 l z)).
          cbn.
          refine (assoc' (pr1 α z · pr11 l z) (pr1 α z) _ @ _).
          refine (assoc' _ _ _ @ _).
          apply maponpaths.
          apply assoc.
        * apply functors_into_cat_disp_locally_groupoid.
      + simple refine (_ ,, _).
        * intro z.
          cbn.
          etrans.
          {
            apply maponpaths.
            apply (functor_id G₂).
          }
          etrans.
          {
            apply (id_right (_ · pr1 α z)).
          }
          apply (id_left (pr1 α z)).
        * apply functors_into_cat_disp_locally_groupoid.
    - refine (_ @ pr12 l x) ; cbn.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        apply (functor_id G₂).
      }
      apply (id_right (pr11 l x · _)).
  Qed.

  Definition functors_into_cat_cartesian_1cell_is_nat_iso
    : is_nat_z_iso (pr1 α).
  Proof.
    intro x.
    use make_is_z_isomorphism.
    - exact (functors_into_cat_cartesian_1cell_is_nat_iso_inv x).
    - exact (functors_into_cat_cartesian_1cell_is_nat_iso_is_inverse x).
  Defined.
End CartesianIsNatIso.

Definition functors_into_cat_global_cleaving
  : global_cleaving disp_bicat_of_functors_into_cat.
Proof.
  intros C₁ C₂ G₁ F.
  refine (F ∙ G₁ ,, nat_trans_id _ ,, _).
  apply functors_into_cat_nat_iso_is_cartesian_1cell.
  intro.
  apply is_z_isomorphism_identity.
Defined.


From SPropTools Require Import logic.

(** A few surprises (actually makes sense, but still...) *)

Section SPropExamplesAndCounterExamples.

  (* As indicated in the ceps/37 there is no cumulativity *)
  Goal SProp -> Type.
  Proof.
    intro x ; exact x. Fail Qed. (* Universe inconsistency *)
    Restart.
    intro x ; exact (Box x). (* But it works if wrapped (as it should) *)
  Qed.

  (* A dependent pair of a type and a proof it's a subsingleton *)
  Record hprop := { ty : Type ; is_hprop : forall (x y : ty), x = y}.

  (* SProps should be subsingleton (definitionally) *)
  Definition sprop_to_hprop (P : SProp) : hprop.
  Proof.
    (* But trying directly, it fails (P is accepted in Type though...) *)
    exists P. intros. Fail reflexivity.
    Restart.
    (* However it works if we wrap the SProp (but that's quite unconvenient) *)
    exists (Box P); intros [?] [?];  reflexivity.
  Qed.

  (* Here the problem is more visible, P is in SProp, not in Type so the equality is not well formed *)
  Fail Check forall (P : SProp) (x y : P), x = y.

  (* The goal does not typecheck, but Coq still allows me to try to prove it ??? *)
  Goal forall (P : SProp) (x y : P), x = y. Proof. admit. Fail Admitted.
  Abort All.

End SPropExamplesAndCounterExamples.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj8synthconj4 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 (Succ lv1)) (plus lv0 (Succ lv1))).
Admitted.
QuickChick conj8synthconj4.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery32_2e489m21_16limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


From DeepWeb Require Export
     Observe2.

CoFixpoint match_event {T R} (e0 : observeE R) (r : R) (m : itree oE T)
  : itree oE T :=
  match observe m with
  | RetF x   => ret x
  | TauF m'  => Tau (match_event e0 r m')
  | VisF e k =>
    match e with
    | (||||oe) =>
      match oe in observeE Y, e0 in observeE R return (Y -> _) -> R -> _ with
      | Observe__Send, Observe__Send
      | Observe__Recv, Observe__Recv => id
      | _, _ => fun _ _ => throw "Unexpected event"
      end k r
    | _ => vis e (match_event e0 r ∘ k)
    end
  end.

Definition match_observe {T R} (e : observeE T) (r : T)
           : list (itree oE R) -> list (itree oE R) := map (match_event e r).

Variant genE : Type -> Set :=
  Gen : genE packetT.

Class Is__tE E `{genE -< E} `{nondetE -< E}
      `{failureE -< E} `{logE -< E} `{netE -< E}.
Notation tE := (genE +' nondetE +' failureE +' logE +' netE).
Instance tE_Is__tE : Is__tE tE. Defined.

CoFixpoint tester' {E R} `{Is__tE E} (others : list (itree oE R)) (m : itree oE R)
  : itree E R :=
  match observe m with
  | RetF r   => Ret r
  | TauF m'  => Tau (tester' others m')
  | VisF e k =>
    let catch (err : string) : itree E R :=
        embed Log ("Catch " ++ err ++ " with " ++ to_string (List.length others)
                            ++ " other branches ");;
        match others with
        | [] => throw err
        | other :: others' =>
          Tau (tester' others' other)
        end in
    match e with
    | (Throw err|) => catch err
    | (|ne|) =>
      match ne in nondetE Y return (Y -> _) -> _ with
      | Or =>
        fun k =>
          b <- trigger Or;;
          Tau (tester' others (k b))
      end k
    | (||de|) =>
      match de in decideE Y return (Y -> _) -> _ with
      | Decide =>
        fun k =>
          b <- trigger Or;;
          Tau (tester' (others ++ [k (negb b)]) (k b))
      end k
    | (|||le|) =>
      match le in logE Y return (Y -> _) -> _ with
      | Log str =>
        fun k =>
          embed Log ("Observer: " ++ str);;
          Tau (tester' others (k tt))
      end k
    | (||||oe) =>
      match oe in observeE Y return (Y -> _) -> _ with
      | Observe__Send =>
        fun k =>
          pkt <- trigger Gen;;
          embed Net__Send pkt;;
          Tau (tester' (match_observe Observe__Send pkt others) (k pkt))
      | Observe__Recv =>
        fun k =>
          conns <- trigger Net__Select;;
          match conns with
          | [] =>
            match others with
            | [] => Tau (tester' [] m)
            | other :: others' =>
              Tau (tester' (others' ++ [m]) other)
            end
          | c :: _ =>
            pkt <- embed Net__Recv c;;
            Tau (tester' (match_observe Observe__Recv pkt others) (k pkt))
          end
      end k
    end
  end.

Definition tester {E R} `{Is__tE E} : itree oE R -> itree E R := tester' [].


(** The groupoid quotient *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.Groupoids.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.

Require Import prelude.all.
Require Import signature.hit_signature.
Require Import algebra.one_types_polynomials.
Require Import algebra.groupoid_polynomials.

Local Open Scope cat.

(** For constant *)
Definition gquot_const
           (A : one_type)
           (X : groupoid)
  : gquot (poly_act_groupoid (C A) X) → A.
Proof.
  use gquot_rec.
  - exact (λ z, z).
  - exact (λ _ _ z, z).
  - exact (λ _, idpath _).
  - exact (λ _ _ _ _ _, idpath _).
  - apply A.
Defined.

(** For identity *)
Definition gquot_id
           (G : groupoid)
  : gquot (poly_act_groupoid I G) → poly_act I (gquot G).
Proof.
  use gquot_rec.
  - exact (gcl G).
  - exact (@gcleq G).
  - exact (ge G).
  - exact (@gconcat G).
  - apply gtrunc.
Defined.

(** For sum *)
Definition gquot_sum
           {P₁ P₂ : poly_code}
           {G : groupoid}
           (IHP₁ : gquot (poly_act_groupoid P₁ G) → poly_act P₁ (gquot G))
           (IHP₂ : gquot (poly_act_groupoid P₂ G) → poly_act P₂ (gquot G))
  : gquot (poly_act_groupoid (P₁ + P₂) G) → poly_act (P₁ + P₂) (gquot G).
Proof.
  use gquot_rec.
  - intro z.
    induction z as [z | z].
    + exact (inl (IHP₁ (gcl (poly_act_groupoid P₁ G) z))).
    + exact (inr (IHP₂ (gcl (poly_act_groupoid P₂ G) z))).
  - intros z₁ z₂ f.
    induction z₁ as [z₁ | z₁], z₂ as [z₂ | z₂].
    + exact (maponpaths (λ z, inl (IHP₁ z)) (gcleq (poly_act_groupoid P₁ G) f)).
    + exact (fromempty f).
    + exact (fromempty f).
    + exact (maponpaths (λ z, inr (IHP₂ z)) (gcleq (poly_act_groupoid P₂ G) f)).
  - intros a.
    induction a as [a | a].
    + exact (maponpaths
               (maponpaths (λ z, inl (IHP₁ z)))
               (ge (poly_act_groupoid P₁ G) a)).
    + exact (maponpaths
               (maponpaths (λ z, inr (IHP₂ z)))
               (ge (poly_act_groupoid P₂ G) a)).
  - intros z₁ z₂ z₃ g₁ g₂.
    induction z₁ as [z₁ | z₁], z₂ as [z₂ | z₂].
    + induction z₃ as [z₃ | z₃].
      * exact (maponpaths
                 (maponpaths (λ z, inl (IHP₁ z)))
                 (gconcat (poly_act_groupoid P₁ G) g₁ g₂)
                 @ maponpathscomp0 _ _ _).
      * exact (fromempty g₂).
    + exact (fromempty g₁).
    + exact (fromempty g₁).
    + induction z₃ as [z₃ | z₃].
      * exact (fromempty g₂).
      * exact (maponpaths
                 (maponpaths (λ z, inr (IHP₂ z)))
                 (gconcat (poly_act_groupoid P₂ G) g₁ g₂)
                 @ maponpathscomp0 _ _ _).
  - apply isofhlevelssncoprod.
    + exact (poly_act_hlevel P₁ (make_one_type (gquot G) (gtrunc G))).
    + exact (poly_act_hlevel P₂ (make_one_type (gquot G) (gtrunc G))).
Defined.

(** For product *)
Definition gquot_prod
           {P₁ P₂ : poly_code}
           {G : groupoid}
           (IHP₁ : gquot (poly_act_groupoid P₁ G) → poly_act P₁ (gquot G))
           (IHP₂ : gquot (poly_act_groupoid P₂ G) → poly_act P₂ (gquot G))
  : gquot (poly_act_groupoid (P₁ * P₂) G) → poly_act (P₁ * P₂) (gquot G).
Proof.
  use gquot_rec.
  - exact (λ z, IHP₁ (gcl (poly_act_groupoid P₁ G) (pr1 z))
                     ,, IHP₂ (gcl (poly_act_groupoid P₂ G) (pr2 z))).
  - exact (λ a₁ a₂ g,
           pathsdirprod
             (maponpaths
                IHP₁
                (gcleq (poly_act_groupoid P₁ G) (pr1 g)))
             (maponpaths
                IHP₂
                (gcleq (poly_act_groupoid P₂ G) (pr2 g)))).
  - exact (λ a,
           maponpaths
             (λ z, pathsdirprod (maponpaths IHP₁ z) _)
             (ge (poly_act_groupoid P₁ G) (pr1 a))
             @ maponpaths
             (λ z, pathsdirprod _ (maponpaths IHP₂ z))
             (ge (poly_act_groupoid P₂ G) (pr2 a))).
  - exact (λ a₁ a₂ a₃ g₁ g₂,
           maponpaths
             (λ z, pathsdirprod (maponpaths IHP₁ z) _)
             (gconcat (poly_act_groupoid P₁ G) (pr1 g₁) (pr1 g₂))
         @ maponpaths
             (λ z, pathsdirprod _ (maponpaths IHP₂ z))
             (gconcat (poly_act_groupoid P₂ G) (pr2 g₁) (pr2 g₂))
         @ maponpaths
             (λ z, pathsdirprod z _)
             (maponpathscomp0 _ _ _)
         @ maponpaths
             (pathsdirprod _)
             (maponpathscomp0 _ _ _)
         @ !(pathsdirprod_concat _ _ _ _)).
  - apply isofhleveldirprod.
    + exact (poly_act_hlevel P₁ (make_one_type (gquot G) (gtrunc G))).
    + exact (poly_act_hlevel P₂ (make_one_type (gquot G) (gtrunc G))).
Defined.

(** Putting it together *)
Definition gquot_poly
           {P : poly_code}
           {G : groupoid}
  : gquot (poly_act_groupoid P G) → poly_act P (gquot G).
Proof.
  induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂ ].
  - exact (gquot_const A G).
  - exact (gquot_id G).
  - exact (gquot_sum IHP₁ IHP₂).
  - exact (gquot_prod IHP₁ IHP₂).
Defined.


Require Import MiniP4.Syntax.

Open Scope string_scope.

Definition meta_t : typ :=
  (* drop flag, port number *)
  Prod Bool (Bit 8).

Definition ipv4_t : typ :=
  (* src addr, dst addr *)
  Prod (Bit 8) (Bit 8).

Definition zeros (n: nat) : exp :=
  Bits (List.repeat false n).

Definition set_out : action :=
  ActAssign "meta" (Tuple (EBool false) (Proj1 (Var "ip"))).

Definition ipv4_defns : list defn :=
  [VarDecl ipv4_t "ip" (Tuple (zeros 8) (zeros 8));
   Table "route" (Proj1 (Var "ip")) [set_out]].

Definition ipv4_cmd : cmd :=
  Seq (Extr "ip")
      (Seq (Apply "route")
           (Emit "ip")).