Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
(* Require Import ReflParam.paramDirect ReflParam.indType. *)

Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

Require Import ExtLib.Structures.Monads.
Import MonadNotation.
Open Scope monad_scope.

Inductive multInd (A I : Set) (B: I-> Set) (f: A-> I) (g: forall i, B i)
  : forall i:I, B i -> Set  :=
mlind : forall a, multInd A I B f g (f a) (g (f a)).

Require Import Template.Template.

(*
Run TemplateProgram (t <- (tmQuote "Top.multIndices2NoEq.multInd" true);;
  tmPrint t).
Run TemplateProgram (tmDuplicateSq "Top.multIndices2NoEq.multInd" true).
*)

Require Import SquiggleEq.UsefulTypes.

(* Run TemplateProgram (genParamInd [] false true true "Top.multIndices2Eq.multInd"). *)

(*
Definition multInd_RR :=
(fix
 Top_multIndices2Eq_multInd_RR0 (A A₂ : Set) (A_R : A -> A₂ -> Prop)
                                (I I₂ : Set) (I_R : I -> I₂ -> Prop)
                                (B : I -> Set) (B₂ : I₂ -> Set)
                                (B_R : forall (H : I) (H0 : I₂),
                                       I_R H H0 -> B H -> B₂ H0 -> Prop)
                                (f : A -> I) (f₂ : A₂ -> I₂)
                                (f_R : forall (H : A) (H0 : A₂),
                                       A_R H H0 -> I_R (f H) (f₂ H0))
                                (g : forall i : I, B i) (g₂ : forall i₂ : I₂, B₂ i₂)
                                (g_R : forall (i : I) (i₂ : I₂) (i_R : I_R i i₂),
                                       B_R i i₂ i_R (g i) (g₂ i₂))
                                (i : I) (i₂ : I₂) (i_R : I_R i i₂)
                                (H : B i) (H0 : B₂ i₂) (H1 : B_R i i₂ i_R H H0)
                                (H2 : multInd A I B f g i H)
                                (H3 : multInd A₂ I₂ B₂ f₂ g₂ i₂ H0) {struct H2} : Prop :=
   match
     H2 in (multInd _ _ _ _ _ i0 H4)
     return (forall i_R0 : I_R i0 i₂, B_R i0 i₂ i_R0 H4 H0 -> Prop)
   with
   | mlind _ _ _ _ _ a =>
       match
         H3 in (multInd _ _ _ _ _ i₂0 H4)
         return (forall i_R0 : I_R (f a) i₂0, B_R (f a) i₂0 i_R0 (g (f a)) H4 -> Prop)
       with
       | mlind _ _ _ _ _ a₂ =>
           fun (i_R0 : I_R (f a) (f₂ a₂))
             (H4 : B_R (f a) (f₂ a₂) i_R0 (g (f a)) (g₂ (f₂ a₂))) =>
           {a_R : A_R a a₂ &
           existT
             (fun i_R1 : I_R (f a) (f₂ a₂) =>
              {_ : B_R (f a) (f₂ a₂) i_R1 (g (f a)) (g₂ (f₂ a₂)) & True})
             (f_R a a₂ a_R)
             (existT
                (fun _ : B_R (f a) (f₂ a₂) (f_R a a₂ a_R) (g (f a)) (g₂ (f₂ a₂)) => True)
                (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) Logic.I) =
           existT
             (fun i_R1 : I_R (f a) (f₂ a₂) =>
              {_ : B_R (f a) (f₂ a₂) i_R1 (g (f a)) (g₂ (f₂ a₂)) & True}) i_R0
             (existT (fun _ : B_R (f a) (f₂ a₂) i_R0 (g (f a)) (g₂ (f₂ a₂)) => True) H4
                Logic.I)}
       end
   end i_R H1).

Definition mlind_RRInv :=
(fun (A A₂ : Set) (A_R : A -> A₂ -> Prop) (I0 I₂ : Set) (I_R : I0 -> I₂ -> Prop)
   (B : I0 -> Set) (B₂ : I₂ -> Set)
   (B_R : forall (H : I0) (H0 : I₂), I_R H H0 -> B H -> B₂ H0 -> Prop)
   (f : A -> I0) (f₂ : A₂ -> I₂)
   (f_R : forall (H : A) (H0 : A₂), A_R H H0 -> I_R (f H) (f₂ H0))
   (g : forall i : I0, B i) (g₂ : forall i₂ : I₂, B₂ i₂)
   (g_R : forall (i : I0) (i₂ : I₂) (i_R : I_R i i₂), B_R i i₂ i_R (g i) (g₂ i₂))
   (a : A) (a₂ : A₂) (i_R : I_R (f a) (f₂ a₂))
   (H : B_R (f a) (f₂ a₂) i_R (g (f a)) (g₂ (f₂ a₂)))
   (sigt_R : {a_R : A_R a a₂ &
             existT
               (fun i_R0 : I_R (f a) (f₂ a₂) =>
                {_ : B_R (f a) (f₂ a₂) i_R0 (g (f a)) (g₂ (f₂ a₂)) & True})
               (f_R a a₂ a_R)
               (existT
                  (fun _ : B_R (f a) (f₂ a₂) (f_R a a₂ a_R) (g (f a)) (g₂ (f₂ a₂)) => True)
                  (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) I) =
             existT
               (fun i_R0 : I_R (f a) (f₂ a₂) =>
                {_ : B_R (f a) (f₂ a₂) i_R0 (g (f a)) (g₂ (f₂ a₂)) & True}) i_R
               (existT (fun _ : B_R (f a) (f₂ a₂) i_R (g (f a)) (g₂ (f₂ a₂)) => True) H I)})
   (retTyp_R : forall (i_R0 : I_R (f a) (f₂ a₂))
                 (H0 : B_R (f a) (f₂ a₂) i_R0 (g (f a)) (g₂ (f₂ a₂))),
               {a_R : A_R a a₂ &
               existT
                 (fun i_R1 : I_R (f a) (f₂ a₂) =>
                  {_ : B_R (f a) (f₂ a₂) i_R1 (g (f a)) (g₂ (f₂ a₂)) & True})
                 (f_R a a₂ a_R)
                 (existT
                    (fun _ : B_R (f a) (f₂ a₂) (f_R a a₂ a_R) (g (f a)) (g₂ (f₂ a₂)) => True)
                    (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) I) =
               existT
                 (fun i_R1 : I_R (f a) (f₂ a₂) =>
                  {_ : B_R (f a) (f₂ a₂) i_R1 (g (f a)) (g₂ (f₂ a₂)) & True}) i_R0
                 (existT (fun _ : B_R (f a) (f₂ a₂) i_R0 (g (f a)) (g₂ (f₂ a₂)) => True) H0
                    I)} -> Set)
   (_ : forall a_R : A_R a a₂,
        retTyp_R (f_R a a₂ a_R) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R))
          (existT
             (fun a_R0 : A_R a a₂ =>
              existT
                (fun i_R0 : I_R (f a) (f₂ a₂) =>
                 {_ : B_R (f a) (f₂ a₂) i_R0 (g (f a)) (g₂ (f₂ a₂)) & True})
                (f_R a a₂ a_R0)
                (existT
                   (fun _ : B_R (f a) (f₂ a₂) (f_R a a₂ a_R0) (g (f a)) (g₂ (f₂ a₂)) => True)
                   (g_R (f a) (f₂ a₂) (f_R a a₂ a_R0)) I) =
              existT
                (fun i_R0 : I_R (f a) (f₂ a₂) =>
                 {_ : B_R (f a) (f₂ a₂) i_R0 (g (f a)) (g₂ (f₂ a₂)) & True})
                (f_R a a₂ a_R)
                (existT
                   (fun _ : B_R (f a) (f₂ a₂) (f_R a a₂ a_R) (g (f a)) (g₂ (f₂ a₂)) => True)
                   (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) I)) a_R eq_refl)) =>
 fiat (retTyp_R i_R H sigt_R)).

Definition mlind_RR :=
(fun (A A₂ : Set) (A_R : A -> A₂ -> Prop) (I0 I₂ : Set) (I_R : I0 -> I₂ -> Prop)
   (B : I0 -> Set) (B₂ : I₂ -> Set)
   (B_R : forall (H : I0) (H0 : I₂), I_R H H0 -> B H -> B₂ H0 -> Prop)
   (f : A -> I0) (f₂ : A₂ -> I₂)
   (f_R : forall (H : A) (H0 : A₂), A_R H H0 -> I_R (f H) (f₂ H0))
   (g : forall i : I0, B i) (g₂ : forall i₂ : I₂, B₂ i₂)
   (g_R : forall (i : I0) (i₂ : I₂) (i_R : I_R i i₂), B_R i i₂ i_R (g i) (g₂ i₂))
   (a : A) (a₂ : A₂) (a_R : A_R a a₂) =>
 existT
   (fun a_R0 : A_R a a₂ =>
    existT
      (fun i_R : I_R (f a) (f₂ a₂) =>
       {_ : B_R (f a) (f₂ a₂) i_R (g (f a)) (g₂ (f₂ a₂)) & True})
      (f_R a a₂ a_R0)
      (existT (fun _ : B_R (f a) (f₂ a₂) (f_R a a₂ a_R0) (g (f a)) (g₂ (f₂ a₂)) => True)
         (g_R (f a) (f₂ a₂) (f_R a a₂ a_R0)) I) =
    existT
      (fun i_R : I_R (f a) (f₂ a₂) =>
       {_ : B_R (f a) (f₂ a₂) i_R (g (f a)) (g₂ (f₂ a₂)) & True})
      (f_R a a₂ a_R)
      (existT (fun _ : B_R (f a) (f₂ a₂) (f_R a a₂ a_R) (g (f a)) (g₂ (f₂ a₂)) => True)
         (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) I)) a_R eq_refl).

Print multInd_rect.
Print nat_rect.

*)

(*
Declare ML Module "paramcoq".
Parametricity Recursive multInd_recs.
*)

Definition multInd_recs :=
fun (A I : Set) (B : I -> Set) (f : A -> I) (g : forall i : I, B i)
  (P : forall (i : I) (b : B i), multInd A I B f g i b -> Set)
  (f0 : forall a : A, P (f a) (g (f a)) (mlind A I B f g a)) (i : I)
  (a : B i) (m : multInd A I B f g i a) =>
match m as m0 in (multInd _ _ _ _ _ i0 a0) return (P i0 a0 m0) with
| mlind _ _ _ _ _ x => f0 x
end.

(* because this inductive is constant for all constructors, it should be totally computed
in translateOneInd *)

Inductive multInd_indicesRR (A A₂ : Set) (A_R : A -> A₂ -> Prop)
(I I₂ : Set) (I_R : I -> I₂ -> Prop)
(B : I -> Set) (B₂ : I₂ -> Set)
(B_R : forall (H : I) (H0 : I₂),
                                     I_R H H0 -> B H -> B₂ H0 -> Prop)
                              (f : A -> I) (f₂ : A₂ -> I₂)
                              (f_R : forall (H : A) (H0 : A₂), A_R H H0 -> I_R (f H) (f₂ H0))
                              (g : forall i : I, B i) (g₂ : forall i₂ : I₂, B₂ i₂)
                              (g_R : forall (i : I) (i₂ : I₂) (i_R : I_R i i₂),
                                     B_R i i₂ i_R (g i) (g₂ i₂))
                              (i : I) (i₂ : I₂) (i_R : I_R i i₂) (b : B i) (b₂ : B₂ i₂)
                               (b_R : B_R i i₂ i_R b b₂)
                               (* params are just the translation of the type *) :
                               (* then we have i_RRs for all the indices *)
                               forall (i_R : I_R i i₂)
                               (b_R : B_R i i₂ i_R b b₂), Prop (* [translate Sort ] *) :=
| multInd_indicesRR_constr :
  multInd_indicesRR
    A A₂ A_R I I₂ I_R B B₂ B_R f f₂ f_R g g₂ g_R i i₂ i_R b b₂
                  b_R i_R b_R.

Definition multInd_RR (A A₂ : Set) (A_R : A -> A₂ -> Prop)
                              (I I₂ : Set) (I_R : I -> I₂ -> Prop)
                              (B : I -> Set) (B₂ : I₂ -> Set)
                              (B_R : forall (H : I) (H0 : I₂),
                                     I_R H H0 -> B H -> B₂ H0 -> Prop)
                              (f : A -> I) (f₂ : A₂ -> I₂)
                              (f_R : forall (H : A) (H0 : A₂), A_R H H0 -> I_R (f H) (f₂ H0))
                              (g : forall i : I, B i) (g₂ : forall i₂ : I₂, B₂ i₂)
                              (g_R : forall (i : I) (i₂ : I₂) (i_R : I_R i i₂),
                                     B_R i i₂ i_R (g i) (g₂ i₂))
                              (i : I) (i₂ : I₂) (i_R : I_R i i₂)
                              (H : B i) (H0 : B₂ i₂) (H1 : B_R i i₂ i_R H H0)
                              (H2 : multInd A I B f g i H)
                              (H3 : multInd A₂ I₂ B₂ f₂ g₂ i₂ H0) : Prop.
refine (
   let reT i1 i2 b1 b2 := forall (ir : I_R i1 i2) (br : B_R i1 i2 ir b1 b2), Prop in
   (match H2 in multInd _ _ _ _ _ i1 b1 return reT i1 i₂ b1 H0 with
   | mlind _ _ _ _ _ a => match
     H3 in multInd _ _ _ _ _ i2 b2 return reT (f a) i2 (g (f a)) b2 with
         | mlind _ _ _ _ _ a₂ => fun ir br =>
                  {ar : A_R a a₂ &
           multInd_indicesRR
           A A₂ A_R I I₂ I_R B B₂ B_R f f₂ f_R g g₂ g_R (*IndParams_R *)
           (* cretindices_R *) _ _  (f_R a a₂ ar) _ _ (g_R _ _ (f_R a a₂ ar))
                  ir br (* indTypeIndices_RR *)
                  }
              end
   end) i_R H1).
Defined.
SearchAbout multInd.

Definition mlind_RR  (A₁ A₂ : Set) (A_R : A₁ -> A₂ -> Prop) (I₁ I₂ : Set)
         (I_R : I₁ -> I₂ -> Prop) (B₁ : I₁ -> Set) (B₂ : I₂ -> Set)
         (B_R : forall (H : I₁) (H0 : I₂), I_R H H0 -> B₁ H -> B₂ H0 -> Prop)
         (f₁ : A₁ -> I₁) (f₂ : A₂ -> I₂)
         (f_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (f₁ H) (f₂ H0))
         (g₁ : forall i : I₁, B₁ i) (g₂ : forall i : I₂, B₂ i)
         (g_R : forall (i₁ : I₁) (i₂ : I₂) (i_R : I_R i₁ i₂), B_R i₁ i₂ i_R (g₁ i₁) (g₂ i₂))
         (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂):
       multInd_RR A₁ A₂ A_R I₁ I₂ I_R B₁ B₂ B_R f₁ f₂ f_R g₁ g₂ g_R
         (f₁ a₁) (f₂ a₂) (f_R a₁ a₂ a_R) (g₁ (f₁ a₁)) (g₂ (f₂ a₂))
         (g_R (f₁ a₁) (f₂ a₂) (f_R a₁ a₂ a_R)) (mlind A₁ I₁ B₁ f₁ g₁ a₁)
         (mlind A₂ I₂ B₂ f₂ g₂ a₂).
Proof.
  simpl. exists a_R.
  (* exact multInd_indicesRR IndParams_R ... cretIndices_R *)
   reflexivity (* constructor? *).
Defined.

Definition multIndices_recs:
forall (A₁ A₂ : Set) (A_R : A₁ -> A₂ -> Prop) (I₁ I₂ : Set)
         (I_R : I₁ -> I₂ -> Prop) (B₁ : I₁ -> Set) (B₂ : I₂ -> Set)
         (B_R : forall (H : I₁) (H0 : I₂), I_R H H0 -> B₁ H -> B₂ H0 -> Prop)
         (f₁ : A₁ -> I₁) (f₂ : A₂ -> I₂)
         (f_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (f₁ H) (f₂ H0))
         (g₁ : forall i : I₁, B₁ i) (g₂ : forall i : I₂, B₂ i)
         (g_R : forall (i₁ : I₁) (i₂ : I₂) (i_R : I_R i₁ i₂), B_R i₁ i₂ i_R (g₁ i₁) (g₂ i₂))
         (P₁ : forall (i : I₁) (b : B₁ i), multInd A₁ I₁ B₁ f₁ g₁ i b -> Set)
         (P₂ : forall (i : I₂) (b : B₂ i), multInd A₂ I₂ B₂ f₂ g₂ i b -> Set)
         (P_R : forall (i₁ : I₁) (i₂ : I₂) (i_R : I_R i₁ i₂) (b₁ : B₁ i₁)
                  (b₂ : B₂ i₂) (b_R : B_R i₁ i₂ i_R b₁ b₂)
                  (H : multInd A₁ I₁ B₁ f₁ g₁ i₁ b₁) (H0 : multInd A₂ I₂ B₂ f₂ g₂ i₂ b₂),
                multInd_RR A₁ A₂ A_R I₁ I₂ I_R B₁ B₂ B_R f₁ f₂ f_R g₁ g₂ g_R i₁ i₂ i_R b₁ b₂
                  b_R H H0 -> P₁ i₁ b₁ H -> P₂ i₂ b₂ H0 -> Set)
         (f0₁ : forall a : A₁, P₁ (f₁ a) (g₁ (f₁ a)) (mlind A₁ I₁ B₁ f₁ g₁ a))
         (f0₂ : forall a : A₂, P₂ (f₂ a) (g₂ (f₂ a)) (mlind A₂ I₂ B₂ f₂ g₂ a)),
       (forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂),
        P_R (f₁ a₁) (f₂ a₂) (f_R a₁ a₂ a_R) (g₁ (f₁ a₁)) (g₂ (f₂ a₂))
          (g_R (f₁ a₁) (f₂ a₂) (f_R a₁ a₂ a_R)) (mlind A₁ I₁ B₁ f₁ g₁ a₁)
          (mlind A₂ I₂ B₂ f₂ g₂ a₂)
          (mlind_RR A₁ A₂ A_R I₁ I₂ I_R B₁ B₂ B_R f₁ f₂ f_R g₁ g₂ g_R a₁ a₂ a_R)
          (f0₁ a₁) (f0₂ a₂)) ->
       forall (i₁ : I₁) (i₂ : I₂) (i_R : I_R i₁ i₂) (a₁ : B₁ i₁)
         (a₂ : B₂ i₂) (a_R : B_R i₁ i₂ i_R a₁ a₂) (m₁ : multInd A₁ I₁ B₁ f₁ g₁ i₁ a₁)
         (m₂ : multInd A₂ I₂ B₂ f₂ g₂ i₂ a₂)
         (m_R : multInd_RR A₁ A₂ A_R I₁ I₂ I_R B₁ B₂ B_R f₁ f₂ f_R g₁ g₂ g_R i₁ i₂ i_R a₁ a₂
                  a_R m₁ m₂),
       P_R i₁ i₂ i_R a₁ a₂ a_R m₁ m₂ m_R (multInd_recs A₁ I₁ B₁ f₁ g₁ P₁ f0₁ i₁ a₁ m₁)
         (multInd_recs A₂ I₂ B₂ f₂ g₂ P₂ f0₂ i₂ a₂ m₂).
Proof using.
  intros.
  rename a_R into b_R.
  revert m_R.
  destruct m₁.
  destruct m₂.
  intros ?.
  simpl in *.
  unfold mlind_RR in H.
  destruct m_R as [a_R peq].
  (* do the remaining in a separate C_RRinv construct? *)
  specialize (H _ _ a_R).
  destruct peq. exact H.
Defined.

(* see the exact below
  exact ( eq_rect_sigt (I_R (f₁ a) (f₂ a0))
           (fun ir : I_R (f₁ a) (f₂ a0) => B_R (f₁ a) (f₂ a0) ir (g₁ (f₁ a)) (g₂ (f₂ a0)))
           (existT (f_R a a0 a_R) (g_R (f₁ a) (f₂ a0) (f_R a a0 a_R)))
           (fun (a1 : I_R (f₁ a) (f₂ a0))
              (p : B_R (f₁ a) (f₂ a0) a1 (g₁ (f₁ a)) (g₂ (f₂ a0)))
              (e : existT (f_R a a0 a_R) (g_R (f₁ a) (f₂ a0) (f_R a a0 a_R)) = existT a1 p)
            =>
            P_R (f₁ a) (f₂ a0) a1 (g₁ (f₁ a)) (g₂ (f₂ a0)) p (mlind A₁ I₁ B₁ f₁ g₁ a)
              (mlind A₂ I₂ B₂ f₂ g₂ a0) (existT a_R e) (f0₁ a)
              (f0₂ a0)) (H _ _ a_R) i_R b_R peq).
*)


From Cat Require Export Base.

Set Implicit Arguments.

(** * Categories *)

(** ** Definitions *)

Class Cat : Type :=
{
  Ob : Type;
  Hom : Ob -> Ob -> Type;
  HomSetoid :> forall A B : Ob, Setoid (Hom A B);
  comp : forall {A B C : Ob}, Hom A B -> Hom B C -> Hom A C;
  Proper_comp :> forall A B C : Ob, Proper (equiv ==> equiv ==> equiv) (@comp A B C);
  comp_assoc :
    forall {A B C D : Ob} (f : Hom A B) (g : Hom B C) (h : Hom C D),
      comp (comp f g) h == comp f (comp g h);
  id : forall A : Ob, Hom A A;
  comp_id_l : forall {A B : Ob} (f : Hom A B), comp (id A) f == f;
  comp_id_r : forall {A B : Ob} (f : Hom A B), comp f (id B) == f;
}.

Arguments Ob _ : clear implicits.

Notation "f .> g" := (comp f g) (at level 50).

#[global] Hint Resolve comp_assoc comp_id_l comp_id_r : core.

#[global] Hint Rewrite @comp_id_l @comp_id_r @comp_assoc : cat.

Ltac cat_simpl := autorewrite with cat in *.

(** *** The identity is unique *)

Lemma id_unique_left :
  forall (C : Cat) (A : Ob C) (idA : Hom A A),
    (forall (B : Ob C) (f : Hom A B), idA .> f == f) -> idA == id A.
Proof.
  now intros; rewrite <- (H _ (id A)), comp_id_r.
Qed.

Lemma id_unique_right :
  forall (C : Cat) (B : Ob C) (idB : Hom B B),
    (forall (A : Ob C) (f : Hom A B), f .> idB == f) -> idB == id B.
Proof.
  now intros; rewrite <- (H _ (id B)), comp_id_l.
Qed.

#[global] Hint Resolve id_unique_left id_unique_right : core.

Lemma assoc_l :
  forall {C : Cat} {X Y Z W : Ob C} {f : Hom X Y} {g : Hom Y Z} {h : Hom Z W} {r : Hom X W},
    (f .> g) .> h == r -> f .> (g .> h) == r.
Proof.
  now intros; rewrite <- comp_assoc.
Qed.

Lemma unassoc_l :
  forall {C : Cat} {X Y Z W : Ob C} {f : Hom X Y} {g : Hom Y Z} {h : Hom Z W} {r : Hom X W},
    f .> (g .> h) == r -> (f .> g) .> h == r.
Proof.
  now intros; rewrite comp_assoc.
Qed.

Lemma assoc_r :
  forall {C : Cat} {X Y Z W : Ob C} {f : Hom X Y} {g : Hom Y Z} {h : Hom Z W} {l : Hom X W},
    l == (f .> g) .> h -> l == f .> (g .> h).
Proof.
  now intros; rewrite <- comp_assoc.
Qed.

Lemma unassoc_r :
  forall {C : Cat} {X Y Z W : Ob C} {f : Hom X Y} {g : Hom Y Z} {h : Hom Z W} {l : Hom X W},
    l == f .> (g .> h) -> l == (f .> g) .> h.
Proof.
  now intros; rewrite comp_assoc.
Qed.

Lemma assoc :
  forall {C : Cat} {X Y Z W : Ob C} {f f' : Hom X Y} {g g' : Hom Y Z} {h h' : Hom Z W},
    (f .> g) .> h == (f' .> g') .> h' -> f .> (g .> h) == f' .> (g' .> h').
Proof.
  now intros; rewrite <- !comp_assoc.
Qed.

Lemma unassoc :
  forall {C : Cat} {X Y Z W : Ob C} {f f' : Hom X Y} {g g' : Hom Y Z} {h h' : Hom Z W},
    f .> (g .> h) == f' .> (g' .> h') -> (f .> g) .> h == (f' .> g') .> h'.
Proof.
  now intros; rewrite !comp_assoc.
Qed.

Definition wut_l
  {U : Cat} {A B C1 C2 D : Ob U}
  (f : Hom A B) {g1 : Hom B C1} {g2 : Hom B C2} {h1 : Hom C1 D} {h2 : Hom C2 D}
  (Heq : g1 .> h1 == g2 .> h2)
  : (f .> g1) .> h1 == (f .> g2) .> h2.
Proof.
  now rewrite comp_assoc, Heq, <- comp_assoc.
Defined.

Definition wut_r
  {U : Cat} {A B1 B2 C D : Ob U}
  {f1 : Hom A B1} {f2 : Hom A B2} {g1 : Hom B1 C} {g2 : Hom B2 C}
  (h : Hom C D) (Heq : f1 .> g1 == f2 .> g2)
  : f1 .> (g1 .> h) == f2 .> (g2 .> h).
Proof.
  now rewrite <- comp_assoc, Heq, comp_assoc.
Defined.

(** ** Reflective tactic for categories *)

Inductive exp {C : Cat} : Ob C -> Ob C -> Type :=
| Id   : forall X     : Ob C, exp X X
| Var  : forall X Y   : Ob C, Hom X Y -> exp X Y
| Comp : forall X Y Z : Ob C, exp X Y -> exp Y Z -> exp X Z.

Arguments Id   {C} _.
Arguments Var  {C X Y} _.
Arguments Comp {C X Y Z} _ _.

#[global] Hint Constructors exp : core.

Fixpoint expDenote {C : Cat} {X Y : Ob C} (e : exp X Y) : Hom X Y :=
match e with
| Id X       => id X
| Var f      => f
| Comp e1 e2 => expDenote e1 .> expDenote e2
end.

Inductive HomList {C : Cat} : Ob C -> Ob C -> Type :=
| HomNil  : forall X : Ob C, HomList X X
| HomCons : forall X Y Z : Ob C, Hom X Y -> HomList Y Z -> HomList X Z.

Arguments HomNil [C] _.
Arguments HomCons [C X Y Z] _ _.

Fixpoint expDenoteHL {C : Cat} {X Y : Ob C} (l : HomList X Y) : Hom X Y :=
match l with
| HomNil X    => id X
| HomCons h t => h .> expDenoteHL t
end.

Fixpoint Happ {C : Cat} {X Y Z : Ob C} (l1 : HomList X Y) : HomList Y Z -> HomList X Z :=
match l1 with
| HomNil _    => fun l2 => l2
| HomCons h t => fun l2 => HomCons h (Happ t l2)
end.

Local Infix "+++" := (Happ) (at level 40).

Fixpoint flatten {C : Cat} {X Y : Ob C} (e : exp X Y) : HomList X Y :=
match e with
| Id X       => HomNil X
| Var f      => HomCons f (HomNil _)
| Comp e1 e2 => flatten e1 +++ flatten e2
end.

Lemma expDenoteHL_comp_app :
  forall (C : Cat) (X Y Z : Ob C) (l1 : HomList X Y) (l2 : HomList Y Z),
    expDenoteHL l1 .> expDenoteHL l2 == expDenoteHL (l1 +++ l2).
Proof.
  induction l1; cbn; intros.
  - now rewrite comp_id_l.
  - now rewrite comp_assoc, IHl1.
Qed.

Lemma expDenoteHL_flatten :
  forall (C : Cat) (X Y : Ob C) (e : exp X Y),
    expDenoteHL (flatten e) == expDenote e.
Proof.
  now induction e; cbn; rewrite <- ?expDenoteHL_comp_app, ?comp_id_r, ?IHe1, ?IHe2.
Qed.

Lemma cat_reflect :
  forall (C : Cat) (X Y : Ob C) (e1 e2 : exp X Y),
    expDenoteHL (flatten e1) ==
    expDenoteHL (flatten e2) ->
      expDenote e1 == expDenote e2.
Proof.
  now intros; rewrite !expDenoteHL_flatten in H.
Qed.

Lemma cat_expand :
  forall (C : Cat) (X Y : Ob C) (e1 e2 : exp X Y),
    expDenote e1 == expDenote e2 ->
      expDenoteHL (flatten e1) ==
      expDenoteHL (flatten e2).
Proof.
  now intros; rewrite !expDenoteHL_flatten.
Qed.

Ltac reify mor :=
match mor with
| id ?X => constr:(Id X)
| ?f .> ?g =>
  let e1 := reify f in
  let e2 := reify g in constr:(Comp e1 e2)
| ?f =>
  match type of f with
  | Hom ?X ?Y => constr:(Var f)
  | _ => fail
  end
end.

Ltac reflect_eqv H :=
match type of H with
| ?f == ?g =>
  let e1 := reify f in
  let e2 := reify g in
    change (expDenote e1 == expDenote e2) in H;
    apply cat_expand in H; cbn in H;
    rewrite ?comp_id_l, ?comp_id_r in H
end.

Ltac reflect_cat :=
match goal with
| |- ?f == ?g =>
  let e1 := reify f in
  let e2 := reify g in
    change (expDenote e1 == expDenote e2);
    apply cat_reflect; cbn; rewrite ?comp_id_l, ?comp_id_r
end.

Ltac assocr := rewrite comp_assoc.
Ltac assocl := rewrite <- comp_assoc.

Ltac assocr' := rewrite !comp_assoc.
Ltac assocl' := rewrite <- !comp_assoc.

Ltac cat := repeat (intros; my_simpl; cbn in *; eauto;
match goal with
| |- _ == _ => progress (reflect_cat; try reflexivity)
| |- ?x == ?x => reflexivity
| H : _ == _ |- _ => progress (reflect_eqv H)
| |- Equivalence _ => solve_equiv
| |- Proper _ _ => proper
| _ => cbn in *
end; eauto).

(** ** Duality and equality *)

#[export]
Instance Dual (C : Cat) : Cat :=
{|
  Ob := Ob C;
  Hom := fun A B : Ob C => Hom B A;
  HomSetoid := fun A B => @HomSetoid C B A;
  comp := fun (X Y Z : Ob C) (f : @Hom C Y X) (g : @Hom C Z Y) => comp g f;
  Proper_comp :=
    fun (X Y Z : Ob C) (f1 f2 : Hom Y X) (Hf : f1 == f2) (g1 g2 : Hom Z Y) (Hg : g1 == g2) =>
      Proper_comp Z Y X g1 g2 Hg f1 f2 Hf;
  comp_assoc :=
    fun (A B C0 D : Ob C) (f : Hom B A) (g : Hom C0 B) (h : Hom D C0) =>
      symmetry (comp_assoc h g f);
  id := @id C;
  comp_id_l := fun (A B : Ob C) (f : Hom B A) => comp_id_r f;
  comp_id_r := fun (A B : Ob C) (f : Hom B A) => comp_id_l f;
|}.

Lemma Dual_Dual :
  forall C : Cat,
    Dual (Dual C) = C.
Proof.
  intros []; cbv.
  f_equal.
  now apply ProofIrrelevance.proof_irrelevance.
Qed.

Lemma duality_principle :
  forall P : Cat -> Prop,
    (forall C : Cat, P C) -> (forall C : Cat, P (Dual C)).
Proof. easy. Qed.

(** ** Kinds of morphisms and their properties *)

Definition isEndo {C : Cat} {A B : Ob C} (f : Hom A B) : Prop :=
  A = B.
Definition isMono {C : Cat} {A B : Ob C} (f : Hom A B) : Prop :=
  forall (X : Ob C) (g h : Hom X A), g .> f == h .> f -> g == h.
Definition isEpi {C : Cat} {A B : Ob C} (f : Hom A B) : Prop :=
  forall (X : Ob C) (g h : Hom B X), f .> g == f .> h -> g == h.
Definition isBi {C : Cat} {A B : Ob C} (f : Hom A B) : Prop :=
  isMono f /\ isEpi f.
Definition isSec {C : Cat} {A B : Ob C} (f : Hom A B) : Prop :=
  exists g : Hom B A, f .> g == id A.
Definition isRet {C : Cat} {A B : Ob C} (f : Hom A B) : Prop :=
  exists g : Hom B A, g .> f == id B.
Definition isIso {C : Cat} {A B : Ob C} (f : Hom A B ) : Prop :=
  exists g : Hom B A, f .> g == id A /\ g .> f == id B.
Definition isAut {C : Cat} {A : Ob C} (f : Hom A A) : Prop :=
  isIso f.

Definition isSec' {C : Cat} {A B : Ob C} (f : Hom A B) : Type :=
  {g : Hom B A | f .> g == id A}.
Definition isRet' {C : Cat} {A B : Ob C} (f : Hom A B) : Type :=
  {g : Hom B A | g .> f == id B}.
Definition isIso' {C : Cat} {A B : Ob C} (f : Hom A B ) : Type :=
  {g : Hom B A | f .> g == id A /\ g .> f == id B}.
Definition isAut' {C : Cat} {A : Ob C} (f : Hom A A) : Type :=
  isIso' f.

#[global] Hint Unfold isEndo isMono isEpi isBi isSec isRet isIso isAut : core.

(** Constant, coconstant and zero morphisms *)

Definition isConstant {C : Cat} {A B : Ob C} (f : Hom A B) : Prop :=
  forall (X : Ob C) (h1 h2 : Hom X A), h1 .> f == h2 .> f.

Definition isCoconstant {C : Cat} {A B : Ob C} (f : Hom A B) : Prop :=
  forall (X : Ob C) (h1 h2 : Hom B X), f .> h1 == f .> h2.

Definition isZeroMor {C : Cat} {A B : Ob C} (f : Hom A B) : Prop :=
  isConstant f /\ isCoconstant f.

(** *** Duality and subsumption *)

Lemma isMono_Dual :
  forall [C : Cat] [A B : Ob C] (f : @Hom (Dual C) A B),
    @isMono (Dual C) A B f = @isEpi C B A f.
Proof. easy. Defined.

Lemma isEpi_Dual :
  forall [C : Cat] [A B : Ob C] (f : @Hom (Dual C) A B),
    @isEpi (Dual C) A B f = @isMono C B A f.
Proof. easy. Defined.

Lemma isBi_Dual :
  forall (C : Cat) (A B : Ob C) (f : @Hom (Dual C) A B),
    @isBi (Dual C) A B f <-> @isBi C B A f.
Proof.
  intros.
  unfold isBi.
  rewrite isMono_Dual, isEpi_Dual.
  now firstorder.
Qed.

Lemma isSec_Dual :
  forall [C : Cat] [A B : Ob C] (f : @Hom (Dual C) A B),
    @isSec (Dual C) A B f <-> @isRet C B A f.
Proof. easy. Defined.

Lemma isRet_Dual :
  forall [C : Cat] [A B : Ob C] (f : @Hom (Dual C) A B),
    @isRet (Dual C) A B f <-> @isSec C B A f.
Proof. easy. Defined.

Lemma isIso_Dual :
  forall [C : Cat] [A B : Ob C] (f : @Hom (Dual C) A B),
    @isIso (Dual C) A B f <-> @isIso C B A f.
Proof. now firstorder. Qed.

Lemma isAut_Dual :
  forall [C : Cat] [A : Ob C] (f : @Hom (Dual C) A A),
    @isAut (Dual C) A f <-> @isAut C A f.
Proof. now firstorder. Qed.

Lemma isIso_inv_unique :
  forall {C : Cat} {A B : Ob C} (f : Hom A B),
    isIso f <-> exists!! g : Hom B A, f .> g == id A /\ g .> f == id B.
Proof.
  unfold isIso.
  split; [| now firstorder].
  intros (g & inv1 & inv2).
  exists g.
  split; [easy |]; intros y [_ H2].
  now rewrite <- comp_id_l, <- H2, comp_assoc, inv1, comp_id_r.
Qed.

#[global] Hint Resolve
  isMono_Dual isEpi_Dual isBi_Dual isSec_Dual isRet_Dual isIso_Dual isAut_Dual
  isIso_inv_unique
  : core.

Lemma isMono_isSec :
  forall (C : Cat) (A B : Ob C) (f : Hom A B),
    isSec f -> isMono f.
Proof.
  unfold isSec, isMono.
  intros C A B f [g Hfg] X h1 h2 Heq.
  now rewrite <- comp_id_r, <- Hfg, <- comp_assoc, Heq, comp_assoc, Hfg, comp_id_r.
Qed.

Lemma isEpi_isRet :
  forall (C : Cat) (A B : Ob C) (f : Hom A B),
    isRet f -> isEpi f.
Proof.
  unfold isRet, isEpi.
  intros C A B f [g Hgf] X h1 h2 Heq.
  now rewrite <- comp_id_l, <- Hgf, comp_assoc, Heq, <- comp_assoc, Hgf, comp_id_l.
Qed.

Lemma isSec_isIso :
  forall (C : Cat) (A B : Ob C) (f : Hom A B),
    isIso f -> isSec f.
Proof.
  now unfold isIso, isSec; firstorder.
Qed.

Lemma isRet_isIso :
  forall (C : Cat) (A B : Ob C) (f : Hom A B),
    isIso f -> isRet f.
Proof.
  now unfold isIso, isRet; firstorder.
Qed.

#[global] Hint Resolve isMono_isSec isEpi_isRet isSec_isIso isRet_isIso : core.

Lemma isIso_iff_isSec_isRet :
  forall (C : Cat) (A B : Ob C) (f : Hom A B),
    isIso f <-> isSec f /\ isRet f.
Proof.
  split; [firstorder |].
  intros [[g1 H1] [g2 H2]].
  exists (g2 .> f .> g1).
  split.
  - now rewrite H2, comp_id_l, H1.
  - now rewrite 2!comp_assoc, <- (comp_assoc f g1), H1, comp_id_l, H2.
Defined.

Lemma isIso_iff_isSec_isEpi :
  forall (C : Cat) (A B : Ob C) (f : Hom A B),
    isIso f <-> isSec f /\ isEpi f.
Proof.
  split.
  - now intros; apply isIso_iff_isSec_isRet in H; intuition.
  - unfold isEpi; intros [[g Heq] H].
    exists g.
    split; [easy |].
    apply H.
    now rewrite <- comp_assoc, Heq, comp_id_l, comp_id_r.
Defined.

Lemma isIso_iff_isMono_isRet :
  forall (C : Cat) (A B : Ob C) (f : Hom A B),
    isIso f <-> isMono f /\ isRet f.
Proof.
  split.
  - now intros; apply isIso_iff_isSec_isRet in H; intuition.
  - unfold isMono; intros [H [g Heq]].
    exists g.
    split; [| easy].
    apply H.
    now rewrite comp_assoc, Heq, comp_id_l, comp_id_r.
Defined.

#[global] Hint Resolve
  isIso_iff_isSec_isRet isIso_iff_isMono_isRet isIso_iff_isSec_isEpi : core.

(** *** Characterizations in terms of hom-sets *)

Lemma isMono_char :
  forall (C : Cat) (A B : Ob C) (f : Hom A B),
    isMono f <-> forall X : Ob C, injectiveS (fun g : Hom X A => g .> f).
Proof. easy. Defined.

Lemma isEpi_char :
  forall (C : Cat) (A B : Ob C) (f : Hom A B),
    isEpi f <-> forall X : Ob C, injectiveS (fun g : Hom B X => f .> g).
Proof. easy. Defined.

#[global] Hint Resolve isMono_char isEpi_char : core.

(** *** Identity properties *)

Lemma isMono_id :
  forall (C : Cat) (X : Ob C),
    isMono (id X).
Proof.
  now intros C X Y f g Heq; rewrite !comp_id_r in Heq.
Defined.

Lemma isEpi_id :
  forall (C : Cat) (X : Ob C),
    isEpi (id X).
Proof.
  now intros C X Y f g Heq; rewrite !comp_id_l in Heq.
Defined.

Lemma isBi_id :
  forall (C : Cat) (X : Ob C),
    isBi (id X).
Proof.
  split.
  - now apply isMono_id.
  - now apply isEpi_id.
Defined.

Lemma isSec_id :
  forall (C : Cat) (X : Ob C),
    isSec (id X).
Proof.
  now intros; exists (id X); rewrite comp_id_l.
Defined.

Lemma isRet_id :
  forall (C : Cat) (X : Ob C),
    isRet (id X).
Proof.
  now intros; exists (id X); rewrite comp_id_l.
Defined.

Lemma isIso_id :
  forall (C : Cat) (X : Ob C),
    isIso (id X).
Proof.
  now intros; exists (id X); rewrite comp_id_l.
Defined.

Lemma isAut_id :
  forall (C : Cat) (X : Ob C),
    isAut (id X).
Proof.
  now apply isIso_id.
Defined.

#[global] Hint Resolve isMono_id isEpi_id isBi_id isSec_id isRet_id isIso_id isAut_id : core.

(** *** Composition properties *)

Lemma isMono_comp :
  forall (C : Cat) (X Y Z : Ob C) (f : Hom X Y) (g : Hom Y Z),
    isMono f -> isMono g -> isMono (f .> g).
Proof.
  unfold isMono; intros * Hf Hg W h1 h2 Heq.
  now apply Hf, Hg; rewrite !comp_assoc.
Defined.

Lemma isEpi_comp :
  forall (C : Cat) (X Y Z : Ob C) (f : Hom X Y) (g : Hom Y Z),
    isEpi f -> isEpi g -> isEpi (f .> g).
Proof.
  unfold isEpi; intros * Hf Hg W h1 h2 Heq.
  now apply Hg, Hf; rewrite <- !comp_assoc.
Defined.

Lemma isBi_comp :
  forall (C : Cat) (X Y Z : Ob C) (f : Hom X Y) (g : Hom Y Z),
    isBi f -> isBi g -> isBi (f .> g).
Proof.
  unfold isBi; split.
  - now apply isMono_comp.
  - now apply isEpi_comp.
Defined.

Lemma isSec_comp :
  forall (C : Cat) (X Y Z : Ob C) (f : Hom X Y) (g : Hom Y Z),
    isSec f -> isSec g -> isSec (f .> g).
Proof.
  unfold isSec; intros C X Y Z f g [h1 eq1] [h2 eq2].
  exists (h2 .> h1).
  now rewrite comp_assoc, <- (comp_assoc g h2), eq2, comp_id_l, eq1.
Defined.

Lemma isRet_comp :
  forall (C : Cat) (X Y Z : Ob C) (f : Hom X Y) (g : Hom Y Z),
    isRet f -> isRet g -> isRet (f .> g).
Proof.
  unfold isRet; intros C X Y Z f g [h1 eq1] [h2 eq2].
  exists (h2 .> h1).
  now rewrite comp_assoc, <- (comp_assoc h1 f), eq1, comp_id_l, eq2.
Defined.

Lemma isIso_comp :
  forall (C : Cat) (X Y Z : Ob C) (f : Hom X Y) (g : Hom Y Z),
    isIso f -> isIso g -> isIso (f .> g).
Proof.
  setoid_rewrite isIso_iff_isSec_isRet.
  split.
  - now apply isSec_comp.
  - now apply isRet_comp.
Defined.

Lemma isAut_comp :
  forall (C : Cat) (X : Ob C) (f : Hom X X) (g : Hom X X),
    isAut f -> isAut g -> isAut (f .> g).
Proof.
  now intros; apply isIso_comp.
Defined.

#[global] Hint Resolve
  isMono_comp isEpi_comp isBi_comp isSec_comp isRet_comp isIso_comp isAut_comp : core.

(** *** Composition properties, reverse *)

Lemma isMono_prop :
  forall (C : Cat) (X Y Z : Ob C) (f : Hom X Y) (g : Hom Y Z),
    isMono (f .> g) -> isMono f.
Proof.
  unfold isMono; intros * H W h1 h2 Heq.
  now apply H; rewrite <- !comp_assoc, Heq.
Defined.

Lemma isEpi_prop :
  forall (C : Cat) (X Y Z : Ob C) (f : Hom X Y) (g : Hom Y Z),
    isEpi (f .> g) -> isEpi g.
Proof.
  unfold isEpi; intros * H W h1 h2 Heq.
  now apply H; rewrite !comp_assoc, Heq.
Defined.

Lemma isSec_prop :
  forall (C : Cat) (X Y Z : Ob C) (f : Hom X Y) (g : Hom Y Z),
    isSec (f .> g) -> isSec f.
Proof.
  unfold isSec; intros * [h Heq].
  exists (g .> h).
  now rewrite <- Heq, comp_assoc.
Defined.

Lemma isRet_prop :
  forall (C : Cat) (X Y Z : Ob C) (f : Hom X Y) (g : Hom Y Z),
    isRet (f .> g) -> isRet g.
Proof.
  unfold isRet; intros * [h Heq].
  exists (h .> f).
  now rewrite <- Heq, comp_assoc.
Defined.

#[global] Hint Resolve isMono_prop isEpi_prop isSec_prop isRet_prop : core.

(** *** Isomorphism machinery *)

Definition isomorphic {C : Cat} (A B : Ob C) : Prop :=
  exists f : Hom A B, isIso f.

Definition uniquely_isomorphic {C : Cat} (A B : Ob C) : Prop :=
  exists!! f : Hom A B, isIso f.

Definition Iso {C : Cat} (A B : Ob C) : Type :=
  {f : Hom A B | isIso f}.

Notation "A ~ B" := (isomorphic A B) (at level 50).
Notation "A ~~ B" := (uniquely_isomorphic A B) (at level 50).

#[global] Hint Unfold isomorphic uniquely_isomorphic : core.

Ltac uniso' f :=
match goal with
| H : isIso f |- _ =>
  rewrite isIso_inv_unique in H;
  let f_inv := fresh f "_inv" in
  let f_inv_eq1 := fresh f "_inv_eq1" in
  let f_inv_eq2 := fresh f "_inv_eq2" in
  let f_inv_unique := fresh f "_inv_unique" in
  destruct H as [f_inv [[f_inv_eq1 f_inv_eq2] f_inv_unique]]
end.

Ltac iso := repeat  (intros;
match goal with
| H : _ ~~ _ |- _ => red in H
| H : _ ~ _ |- _ => red in H
| |- context [_ ~~ _] => unfold uniquely_isomorphic
| |- context [_ ~ _] => unfold isomorphic
| H : exists _ : Hom _ _, isIso _ |- _ => destruct H
| _ : isIso ?f |- _ => uniso' f
| |- isIso _ => unfold isIso
| |- exists _ : Hom _ _, _ => eexists
| |- _ /\ _ => split
| |- _ <-> _ => split
| _ => cat
end).

Lemma Dual_isomorphic :
  forall (C : Cat) (A B : Ob C),
    @isomorphic C A B <-> @isomorphic (Dual C) B A.
Proof. now iso. Defined.

Lemma Dual_uniquely_isomorphic :
  forall (C : Cat) (A B : Ob C),
    @uniquely_isomorphic C A B <-> @uniquely_isomorphic (Dual C) A B.
Proof.
  iso.
  - now apply x_inv_unique; cat; rewrite H0; iso.
  - now apply x_inv_unique; cat; rewrite H0; iso.
Qed.

Lemma unique_iso_is_iso :
  forall (C : Cat) (A B : Ob C), A ~~ B -> A ~ B.
Proof.
  unfold uniquely_isomorphic, isomorphic.
  now intros * (f & HIso & _); exists f.
Qed.

#[global] Hint Resolve Dual_isomorphic Dual_uniquely_isomorphic unique_iso_is_iso : core.

#[export]
Instance isomorphic_equiv (C : Cat) : Equivalence isomorphic.
Proof.
  split; do 2 red.
  - now intros X; exists (id X); apply isIso_id.
  - now intros X Y (f & g & eq1 & eq2); exists g, f.
  - now intros X Y Z [f f_iso] [g g_iso]; exists (f .> g); apply isIso_comp.
Defined.

(** ** The category of setoids *)

(** [SETOID] corresponds to what most category theory textbooks call Set,
    the category of sets and functions.

    We need to use setoids instead of sets, because our categories have a
    setoid of morphisms instead of a set/type.

    [SETOId] its the name of the category - the type of its objects is called
    [Setoid'], to avoid name clash with [Setoid].
*)

Class Setoid' : Type :=
{
  carrier : Type;
  setoid :> Setoid carrier
}.

Coercion carrier : Setoid' >-> Sortclass.
Coercion setoid : Setoid' >-> Setoid.

Ltac setoidob S := try intros until S;
match type of S with
| Setoid =>
  let a := fresh S "_equiv" in
  let b := fresh S "_equiv_refl" in
  let c := fresh S "_equiv_sym" in
  let d := fresh S "_equiv_trans" in destruct S as [a [b c d]];
    red in a; red in b; red in c; red in d
| Setoid' =>
  let a := fresh S "_equiv" in
  let b := fresh S "_equiv_refl" in
  let c := fresh S "_equiv_sym" in
  let d := fresh S "_equiv_trans" in destruct S as [S [a [b c d]]];
    red in a; red in b; red in c; red in d
| Ob _ => progress cbn in S; setoidob S
end.

Ltac setoidobs := intros; repeat
match goal with
| S : Setoid |- _ => setoidob S
| S : Setoid' |- _ => setoidob S
| S : Ob _ |- _ => setoidob S
end.

Class SetoidHom (X Y : Setoid') : Type :=
{
  func : X -> Y;
  Proper_func :> Proper (@equiv _ X ==> @equiv _ Y) func
}.

Arguments func [X Y] _.
Arguments Proper_func [X Y] _.

Coercion func : SetoidHom >-> Funclass.

#[refine]
#[export]
Instance Setoid_SetoidHom (X Y : Setoid') : Setoid (SetoidHom X Y) :=
{
  equiv := fun f g : SetoidHom X Y => forall x : X, f x == g x
}.
Proof. now solve_equiv. Defined.

Ltac setoidhom f := try intros until f;
match type of f with
| SetoidHom _ _ =>
  let a := fresh f "_pres_equiv" in destruct f as [f a]; repeat red in a
| Hom _ _ => progress cbn in f; setoidhom f
end.

Ltac setoidhoms := intros; repeat
match goal with
| f : SetoidHom _ _ |- _ => setoidhom f
| f : Hom _ _ |- _ => setoidhom f
end.

Ltac setoid_simpl := repeat (red || split || cbn in * || intros).
Ltac setoid_simpl' := repeat (setoid_simpl || setoidhoms || setoidobs).

Ltac setoid' := repeat
match goal with
| |- Proper _ _ => proper
| |- Equivalence _ _ => solve_equiv
| _ => setoid_simpl || cat || setoidhoms || setoidobs
end.

Ltac setoid := try (setoid'; fail).

#[refine]
#[export]
Instance SetoidComp
  (X Y Z : Setoid') (f : SetoidHom X Y) (g : SetoidHom Y Z) : SetoidHom X Z :=
{
  func := fun x : X => g (f x)
}.
Proof. now setoid. Defined.

#[refine]
#[export]
Instance SetoidId (X : Setoid') : SetoidHom X X :=
{
  func := fun x : X => x
}.
Proof. now setoid. Defined.

#[refine]
#[global]
Instance SETOID : Cat :=
{|
  Ob := Setoid';
  Hom := SetoidHom;
  HomSetoid := Setoid_SetoidHom;
  comp := SetoidComp;
  id := SetoidId
|}.
Proof.
  - intros A B C f1 f2 Hf g1 g2 Hg x; cbn in *.
    now rewrite Hf, Hg.
  - easy.
  - easy.
  - easy.
Defined.

(** * Functors *)

(** ** Covariant functor definitions *)

Class Functor (C : Cat) (D : Cat) : Type :=
{
  fob : Ob C -> Ob D;
  fmap : forall {A B : Ob C}, Hom A B -> Hom (fob A) (fob B);
  Proper_fmap :> forall A B : Ob C, Proper (equiv ==> equiv) (@fmap A B);
  fmap_comp :
    forall {A B C : Ob C} (f : Hom A B) (g : Hom B C), fmap (f .> g) == fmap f .> fmap g;
  fmap_id : forall A : Ob C, fmap (id A) == id (fob A)
}.

Arguments fob  [C D] _ _.
Arguments fmap [C D] _ [A B] _.

(** ** Kinds of functors and their properties *)

Definition full {C D : Cat} (T : Functor C D) : Prop :=
  forall (A B : Ob C) (g : Hom (fob T A) (fob T B)),
    exists f : Hom A B, fmap T f == g.

Definition faithful {C D : Cat} (T : Functor C D) : Prop :=
  forall (A B : Ob C) (f g : Hom A B),
    fmap T f == fmap T g -> f == g.

Definition iso_dense {C D : Cat} (T : Functor C D) : Prop :=
  forall Y : Ob D, exists X : Ob C, fob T X ~ Y.

Definition embedding {C D : Cat} (T : Functor C D) : Prop :=
  faithful T /\ injective (fob T).

#[global] Hint Unfold full faithful iso_dense embedding : core.

Lemma isSec_fmap :
  forall (C D : Cat) (T : Functor C D) (X Y : Ob C) (f : Hom X Y),
    isSec f -> isSec (fmap T f).
Proof.
  unfold isSec; intros * [g H].
  exists (fmap T g).
  now rewrite <- fmap_comp, H, fmap_id.
Defined.

Lemma isRet_fmap :
  forall (C D : Cat) (T : Functor C D) (X Y : Ob C) (f : Hom X Y),
    isRet f -> isRet (fmap T f).
Proof.
  unfold isRet; intros * [g H].
  exists (fmap T g).
  now rewrite <- fmap_comp, H, fmap_id.
Defined.

Lemma isIso_fmap :
  forall {C D : Cat} (T : Functor C D) {X Y : Ob C} (f : Hom X Y),
    isIso f -> isIso (fmap T f).
Proof.
  intros.
  rewrite isIso_iff_isSec_isRet in *.
  split.
  - now apply isSec_fmap.
  - now apply isRet_fmap.
Defined.

#[global] Hint Resolve isSec_fmap isRet_fmap isIso_fmap : core.

Lemma full_faithful_refl_isSec :
  forall {C D : Cat} (T : Functor C D) {X Y : Ob C} (f : Hom X Y),
    full T -> faithful T -> isSec (fmap T f) -> isSec f.
Proof.
  unfold full, faithful, isSec; intros * T_full T_faithful [Tg Tg_sec].
  destruct (T_full Y X Tg) as [g Heq].
  exists g.
  now apply T_faithful; rewrite fmap_comp, fmap_id, Heq.
Defined.

Lemma full_faithful_refl_isRet :
  forall {C D : Cat} (T : Functor C D) (X Y : Ob C) (f : Hom X Y),
    full T -> faithful T -> isRet (fmap T f) -> isRet f.
Proof.
  unfold isRet, full, faithful; intros * T_full T_faithful [Tg Tg_ret].
  destruct (T_full Y X Tg) as [g Heq].
  exists g.
  now apply T_faithful; rewrite fmap_comp, fmap_id, Heq.
Defined.

#[global] Hint Resolve full_faithful_refl_isSec full_faithful_refl_isRet : core.

Lemma isSec_fmap_conv :
  forall {C D : Cat} (T : Functor C D) {X Y : Ob C} (f : Hom X Y),
    full T -> faithful T -> isSec (fmap T f) <-> isSec f.
Proof.
  split; intros.
  - now eapply full_faithful_refl_isSec.
  - now eapply isSec_fmap.
Qed.

Lemma isRet_fmap_conv :
  forall {C D : Cat} (T : Functor C D) (X Y : Ob C) (f : Hom X Y),
    full T -> faithful T -> isRet (fmap T f) <-> isRet f.
Proof.
  split; intros.
  - now eapply full_faithful_refl_isRet.
  - now eapply isRet_fmap.
Qed.

Lemma isIso_fmap_conv :
  forall (C D : Cat) (T : Functor C D) (X Y : Ob C) (f : Hom X Y),
    full T -> faithful T -> isIso (fmap T f) <-> isIso f.
Proof.
  now intros; rewrite !isIso_iff_isSec_isRet, isSec_fmap_conv, isRet_fmap_conv.
Defined.

(** ** Identity, composition, constant and Hom functors *)

#[refine]
#[export]
Instance FunctorComp {C D E : Cat} (T : Functor C D) (S : Functor D E) : Functor C E :=
{
  fob := fun A : Ob C => fob S (fob T A);
  fmap := fun (X Y : Ob C) (f : Hom X Y) => fmap S (fmap T f)
}.
Proof.
  - now proper.
  - now intros; rewrite !fmap_comp.
  - now intros; rewrite !fmap_id.
Defined.

#[refine]
#[export]
Instance FunctorId (C : Cat) : Functor C C :=
{
  fob := fun A : Ob C => A;
  fmap := fun (X Y : Ob C) (f : Hom X Y) => f
}.
Proof.
  all: easy.
Defined.

#[refine]
#[export]
Instance ConstFunctor {D : Cat} (X : Ob D) (C : Cat) : Functor C D :=
{
  fob := fun _ => X;
  fmap := fun _ _ _ => id X
}.
Proof.
  all: easy.
Defined.

#[refine]
#[export]
Instance HomFunctor (C : Cat) (X : Ob C) : Functor C SETOID :=
{
  fob := fun Y : Ob C => {| carrier := Hom X Y; setoid := HomSetoid X Y |}
}.
Proof.
  - now intros A B f; exists (fun g => g .> f); proper.
  - now proper.
  - now cbn; intros; rewrite comp_assoc.
  - now cbn; intros; rewrite comp_id_r.
Defined.

(** ** Contravariant functors *)

Class Contravariant (C : Cat) (D : Cat) : Type :=
{
  coob : Ob C -> Ob D;
  comap : forall {X Y : Ob C}, Hom X Y -> Hom (coob Y) (coob X);
  Proper_comap :> forall X Y : Ob C, Proper (equiv ==> equiv) (@comap X Y);
  comap_comp :
    forall (X Y Z : Ob C) (f : Hom X Y) (g : Hom Y Z), comap (f .> g) == comap g .> comap f;
  comap_id : forall A : Ob C, comap (id A) == id (coob A)
}.

Arguments coob  [C D] _ _.
Arguments comap [C D] _ [X Y] _.

#[refine]
#[export]
Instance ConstContravariant {D : Cat} (X : Ob D) (C : Cat) : Contravariant C D :=
{
  coob := fun _ => X;
  comap := fun _ _ _ => id X
}.
Proof.
  all: easy.
Defined.

#[refine]
#[export]
Instance HomContravariant (C : Cat) (X : Ob C) : Contravariant C SETOID :=
{
  coob := fun Y : Ob C => {| carrier := Hom Y X; setoid := HomSetoid Y X |}
}.
Proof.
  - now intros Y Z f; exists (fun g => f .> g); proper.
  - now proper.
  - now cbn.
  - now cbn.
Defined.

(** ** Bifunctors *)

Class Bifunctor (C D E : Cat) : Type :=
{
  biob : Ob C -> Ob D -> Ob E;
  bimap :
    forall {X Y : Ob C} {X' Y' : Ob D},
      Hom X Y -> Hom X' Y' -> Hom (biob X X') (biob Y Y');
  Proper_bimap :>
    forall (X Y : Ob C) (X' Y' : Ob D),
      Proper (equiv ==> equiv ==> equiv) (@bimap X Y X' Y');
  bimap_comp :
    forall
      (X Y Z : Ob C) (X' Y' Z' : Ob D)
      (f : Hom X Y) (g : Hom Y Z) (f' : Hom X' Y') (g' : Hom Y' Z'),
        bimap (f .> g) (f' .> g') == bimap f f' .> bimap g g';
  bimap_id :
    forall (X : Ob C) (Y : Ob D),
      bimap (id X) (id Y) == id (biob X Y);
}.

Arguments biob  [C D E Bifunctor] _ _.
Arguments bimap [C D E Bifunctor X Y X' Y'] _ _.

Definition first
  {C D E : Cat} {F : Bifunctor C D E} {X Y : Ob C} {A : Ob D} (f : Hom X Y)
  : Hom (biob X A) (biob Y A) := bimap f (id A).

Definition second
  {C D E : Cat} {F : Bifunctor C D E} {A : Ob C} {X Y : Ob D} (f : Hom X Y)
  : Hom (biob A X) (biob A Y) := bimap (id A) f.

Lemma bimap_comp_l :
  forall
    {C D E : Cat} {F : Bifunctor C D E}
    {X Y Z : Ob C} {A : Ob D} (f : Hom X Y) (g : Hom Y Z),
      bimap (f .> g) (id A) == bimap f (id A) .> bimap g (id A).
Proof.
  now intros; rewrite <- bimap_comp, comp_id_l.
Defined.

Lemma bimap_comp_r :
  forall
    {C D E : Cat} {F : Bifunctor C D E}
    {A : Ob C} {X Y Z : Ob D} (f : Hom X Y) (g : Hom Y Z),
      bimap (id A) (f .> g) == bimap (id A) f .> bimap (id A) g.
Proof.
  now intros; rewrite <- bimap_comp, comp_id_l.
Defined.

#[refine]
#[export]
Instance BiComp
  {C C' D D' E : Cat} (B : Bifunctor C' D' E) (F : Functor C C') (G : Functor D D')
  : Bifunctor C D E :=
{
  biob := fun (X : Ob C) (Y : Ob D) => biob (fob F X) (fob G Y);
  bimap := fun (X Y : Ob C) (X' Y' : Ob D) (f : Hom X Y) (g : Hom X' Y') =>
    bimap (fmap F f) (fmap G g)
}.
Proof.
  - now proper.
  - now intros; rewrite !fmap_comp, !bimap_comp.
  - now intros; rewrite 2 fmap_id, bimap_id.
Defined.

#[refine]
#[export]
Instance ConstBifunctor {E : Cat} (X : Ob E) (C D : Cat) : Bifunctor C D E :=
{
  biob := fun _ _ => X;
  bimap := fun _ _ _ _ _ _ => id X
}.
Proof.
  all: easy.
Defined.

(** ** Profunctors *)

Class Profunctor (C D E : Cat) : Type :=
{
  diob : Ob C -> Ob D -> Ob E;
  dimap :
    forall {X Y : Ob C} {X' Y' : Ob D},
      Hom X Y -> Hom X' Y' -> Hom (diob Y X') (diob X Y');
  Proper_dimap :>
    forall (X Y : Ob C) (X' Y' : Ob D),
      Proper (equiv ==> equiv ==> equiv) (@dimap X Y X' Y');
  dimap_comp :
    forall
      (X Y Z : Ob C) (X' Y' Z' : Ob D)
      (f : Hom X Y) (g : Hom Y Z) (f' : Hom X' Y') (g' : Hom Y' Z'),
        dimap (f .> g) (f' .> g') == dimap g f' .> dimap f g';
  dimap_id :
    forall (X : Ob C) (Y : Ob D),
      dimap (id X) (id Y) == id (diob X Y);
}.

Arguments diob  [C D E Profunctor] _ _.
Arguments dimap [C D E Profunctor X Y X' Y'] _ _.

Lemma dimap_comp_l :
  forall
    {C D E : Cat} {F : Profunctor C D E}
    {X Y Z : Ob C} {A : Ob D} (f : Hom X Y) (g : Hom Y Z),
      dimap (f .> g) (id A) == dimap g (id A) .> dimap f (id A).
Proof.
  now intros; rewrite <- dimap_comp, comp_id_l.
Defined.

Lemma dimap_comp_r :
  forall
    {C D E : Cat} {F : Profunctor C D E}
    {A : Ob C} {X Y Z : Ob D} (f : Hom X Y) (g : Hom Y Z),
      dimap (id A) (f .> g) == dimap (id A) f .> dimap (id A) g.
Proof.
  now intros; rewrite <- dimap_comp, comp_id_l.
Defined.

Ltac profunctor_simpl := repeat (rewrite dimap_comp || rewrite dimap_id).

Ltac profunctor := repeat
match goal with
| |- context [Proper] => proper
| _ => cat; profunctor_simpl; cat
end.

#[refine]
#[export]
Instance ConstProfunctor {E : Cat} (X : Ob E) (C D : Cat) : Profunctor C D E :=
{
  diob := fun _ _ => X;
  dimap := fun _ _ _ _ _ _ => id X
}.
Proof.
  all: easy.
Defined.

#[refine]
#[export]
Instance ProComp
  {C C' D D' E : Cat} (P : Profunctor C' D' E) (F : Functor C C') (G : Functor D D')
  : Profunctor C D E :=
{
  diob := fun (X : Ob C) (Y : Ob D) => diob (fob F X) (fob G Y)
}.
Proof.
  - now intros * f g; exact (dimap (fmap F f) (fmap G g)).
  - now proper.
  - now cbn; intros; rewrite !fmap_comp, dimap_comp.
  - now cbn; intros; rewrite !fmap_id, dimap_id.
Defined.

#[refine]
#[export]
Instance HomProfunctor (C : Cat) : Profunctor C C SETOID :=
{
  diob := fun X Y : Ob C => {| carrier := Hom X Y; setoid := HomSetoid X Y |};
}.
Proof.
  - now intros * f g; exists (fun h : Hom Y X' => f .> h .> g); proper.
  - now proper.
  - now cbn; intros; rewrite !comp_assoc.
  - now cbn; intros; rewrite comp_id_l, comp_id_r.
Defined.

(** * The category of categories and functors *)

#[refine]
#[export]
Instance CATHomSetoid {C D : Cat} : Setoid (Functor C D) :=
{|
  equiv T S :=
    exists p : forall A : Ob C, fob T A = fob S A,
     forall (A B : Ob C) (f : Hom A B),
      transport (fun cod : Ob D => Hom (fob S A) cod) (p B)
        (transport (fun dom : Ob D => Hom dom (fob T B)) (p A) (fmap T f))
        =
      fmap S f
|}.
Proof.
  split; red.
  - now intros F; exists (fun _ => eq_refl); cbn.
  - intros F G [p q].
    exists (fun A => eq_sym (p A)).
    intros A B f.
    rewrite <- q; clear q.
    now destruct (p A), (p B); cbn.
  - intros F G H [p1 q1] [p2 q2].
    exists (fun X => eq_trans (p1 X) (p2 X)).
    intros A B f.
    rewrite <- q2, <- q1; clear q1 q2.
    now destruct (p2 B), (p1 B), (p2 A), (p1 A); cbn.
Defined.

#[refine]
#[export]
Instance CAT : Cat :=
{
  Ob := Cat;
  Hom := Functor;
  HomSetoid := @CATHomSetoid;
  comp := @FunctorComp;
  id := FunctorId
}.
Proof.
  - cbn; intros A B C F G [p q] H I [r s].
    unfold FunctorComp; cbn.
    unshelve esplit.
    + now intros X; destruct (p X), (r (fob F X)).
    + cbn; intros X Y f.
      rewrite <- q, <- s; clear q s.
      now destruct (p X), (p Y), (r (fob F X)), (r (fob F Y)); cbn.
  - cbn; intros A B C D F G H.
    now exists (fun X => eq_refl).
  - now intros A B F; exists (fun _ => eq_refl).
  - now intros A B F; exists (fun _ => eq_refl).
Defined.

(** We also need to define the product of two categories, as this is needed
    in many places to define two-argument functors. *)

Definition ProdCatHom {C D : Cat} (X Y : Ob C * Ob D) : Type :=
  Hom (fst X) (fst Y) * Hom (snd X) (snd Y).

#[refine]
#[export]
Instance ProdCatSetoid {C D : Cat} (X Y : Ob C * Ob D) : Setoid (ProdCatHom X Y) :=
{
  equiv := fun f g : ProdCatHom X Y => fst f == fst g /\ snd f == snd g
}.
Proof.
  now solve_equiv.
Defined.

#[refine]
#[export]
Instance CAT_product (C : Cat) (D : Cat) : Cat :=
{
  Ob := Ob C * Ob D;
  Hom := ProdCatHom;
  HomSetoid := ProdCatSetoid;
  comp := fun
    (X Y Z : Ob C * Ob D)
    (f : Hom (fst X) (fst Y) * Hom (snd X) (snd Y))
    (g : Hom (fst Y) (fst Z) * Hom (snd Y) (snd Z)) =>
      (fst f .> fst g, snd f .> snd g);
  id := fun A : Ob C * Ob D => (id (fst A), id (snd A))
}.
Proof.
  - now proper; destruct H as [-> ->], H0 as [-> ->].
  - now cbn; intros; rewrite !comp_assoc.
  - now cbn; intros; rewrite comp_id_l.
  - now cbn; intros; rewrite comp_id_r.
Defined.

(** We can turn bifunctors and profunctors into functors with product domain. *)

#[refine]
#[export]
Instance FromBifunctor
  {C D E : Cat} (F : Bifunctor C D E) : Functor (CAT_product C D) E :=
{
  fob := fun '(A, B) => biob A B;
  fmap := fun '(A1, A2) '(B1, B2) '(f1, f2) => bimap f1 f2;
}.
Proof.
  - now intros [A1 A2] [B1 B2] [f1 f2] [g1 g2] [Heq1 Heq2]; apply Proper_bimap.
  - now intros [A1 A2] [B1 B2] [C1 C2] [f1 f2] [g1 g2]; cbn in *; apply bimap_comp.
  - now intros [A1 A2]; cbn; apply bimap_id.
Defined.

#[export]
Instance FromProfunctor
  {C D E : Cat} (F : Profunctor C D E) : Functor (CAT_product (Dual C) D) E.
Proof.
  unshelve esplit.
  - now cbn; intros [A B]; apply (diob A B).
  - now intros [A1 A2] [B1 B2] [f1 f2]; cbn in *; apply (dimap f1 f2).
  - now intros [A1 A2] [B1 B2] [f1 f2] [g1 g2] [H1 H2]; apply Proper_dimap.
  - now intros [A1 A2] [B1 B2] [C1 C2] [f1 f2] [g1 g2]; cbn in *; apply dimap_comp.
  - now intros [A1 A2]; cbn; apply dimap_id.
Defined.

(** * Natural transformations *)

Class NatTrans {C D : Cat} (T S : Functor C D) : Type :=
{
  component : forall X : Ob C, Hom (fob T X) (fob S X);
  natural :
    forall [X Y : Ob C] (f : Hom X Y),
      component X .> fmap S f == fmap T f .> component Y
}.

Arguments component [C D T S] _ _.
Arguments natural   [C D T S] _ [X Y] _.

#[refine]
#[export]
Instance NatTransSetoid {C D : Cat} (F G : Functor C D) : Setoid (NatTrans F G) :=
{
  equiv := fun alfa beta : NatTrans F G =>
    forall X : Ob C, component alfa X == component beta X
}.
Proof.
  now solve_equiv.
Defined.

#[refine]
#[export]
Instance NatTransComp
  {C D : Cat} {F : Functor C D} {G : Functor C D} {H : Functor C D}
  (α : NatTrans F G) (β : NatTrans G H) : NatTrans F H :=
{
  component := fun X : Ob C => component α X .> component β X
}.
Proof.
  now intros X Y f; rewrite !comp_assoc, natural, <- comp_assoc, natural, comp_assoc.
Defined.

#[refine]
#[export]
Instance NatTransId {C D : Cat} (F : Functor C D) : NatTrans F F :=
{
  component := fun X : Ob C => id (fob F X)
}.
Proof.
  now intros; rewrite comp_id_l, comp_id_r.
Defined.

(** ** Natural isomorphisms and representable functors *)

Definition natural_isomorphism
  {C D : Cat} {F G : Functor C D} (α : NatTrans F G) : Type :=
    {β : NatTrans G F | NatTransComp α β == NatTransId F /\ NatTransComp β α == NatTransId G}.

Lemma natural_isomorphism_char' :
  forall {C D : Cat} {F G : Functor C D} (α : NatTrans F G),
    (forall X : Ob C, isIso' (component α X)) -> NatTrans G F.
Proof.
  intros C D F G α H.
  unshelve esplit.
  - exact (fun X => proj1_sig (H X)).
  - intros X Y f; cbn.
    destruct (H X) as (g1 & Hg11 & Hg12), (H Y) as (g2 & Hg21 & Hg22); cbn.
    destruct α. cbn in *.
    rewrite <- comp_id_r, <- Hg21.
    rewrite comp_assoc, <- (comp_assoc (fmap F f)).
    rewrite <- natural0.
    now rewrite <- !comp_assoc, Hg12, comp_id_l.
Defined.

Lemma natural_isomorphism_char :
  forall (C D : Cat) (F G : Functor C D) (α : NatTrans F G),
    (forall X : Ob C, isIso' (component α X)) -> natural_isomorphism α.
Proof.
  intros C D F G α H.
  split with (natural_isomorphism_char' α H).
  now split; cbn; intros X; destruct (H X).
Qed.

Lemma natural_isomorphism_char_conv :
  forall (C D : Cat) (F G : Functor C D) (α : NatTrans F G),
    natural_isomorphism α -> forall X : Ob C, isIso (component α X).
Proof.
  intros * (β & H1 & H2) X; red; cbn in *.
  now exists (component β X).
Qed.

Definition representable {C : Cat} (X : Ob C) (F : Functor C SETOID) : Type :=
  {α : NatTrans F (HomFunctor C X) & natural_isomorphism α}.

Definition corepresentable {C : Cat} (X : Ob C) (F : Functor (Dual C) SETOID) : Type :=
  {α : NatTrans F (HomFunctor (Dual C) X) & natural_isomorphism α}.

(** * Subcategories *)

#[refine]
#[export]
Instance WideSubcat (C : Cat) (P : Ob C -> Prop) : Cat :=
{
  Ob := {X : Ob C | P X};
  Hom := fun A B : {X : Ob C | P X} => @Hom C (proj1_sig A) (proj1_sig B);
  HomSetoid := fun A B => @HomSetoid C (proj1_sig A) (proj1_sig B);
  comp := fun X Y Z => @comp C (proj1_sig X) (proj1_sig Y) (proj1_sig Z);
  id := fun X => @id C (proj1_sig X);
}.
Proof. all: now cat. Defined.

#[refine]
#[export]
Instance FullSubcat
  {U : Cat} (P : forall {A B : Ob U}, Hom A B -> Prop)
  (P_id : forall A : Ob U, P (id A))
  (P_comp : forall {A B C : Ob U} {f : Hom A B} {g : Hom B C}, P f -> P g -> P (f .> g))
  : Cat :=
{
  Ob := Ob U;
  Hom := fun X Y : Ob U => {f : Hom X Y | P X Y f};
  HomSetoid := fun X Y : Ob U =>
    Setoid_kernel_equiv (HomSetoid X Y) (@proj1_sig (Hom X Y) (P X Y));
}.
Proof.
  - intros X Y Z [f Hf] [g Hg].
    exists (f .> g).
    now apply P_comp.
  - intros X Y Z [f1 Hf1] [f2 Hf2] Hf [g1 Hg1] [g2 Hg2] Hg; cbn in *.
    now rewrite Hf, Hg.
  - intros X Y Z W [f Hf] [g Hg] [h Hh]; cbn in *.
    now rewrite comp_assoc.
  - intros X.
    exists (id X).
    now apply P_id.
  - intros X Y [f Hf]; cbn.
    now rewrite comp_id_l.
  - intros X Y [f Hf]; cbn.
    now rewrite comp_id_r.
Defined.

Definition WithMono (C : Cat) : Cat :=
  FullSubcat (@isMono C) (@isMono_id C) (@isMono_comp C).

Definition WithEpi (C : Cat) : Cat :=
  FullSubcat (@isEpi C) (@isEpi_id C) (@isEpi_comp C).

Definition WithSec (C : Cat) : Cat :=
  FullSubcat (@isSec C) (@isSec_id C) (@isSec_comp C).

Definition WithRet (C : Cat) : Cat :=
  FullSubcat (@isRet C) (@isRet_id C) (@isRet_comp C).

(**
  The core of a category [C] is the groupoid that has the same objects as [C],
  but whose morphisms are only the isomorphisms of [C].
*)
Definition Core (C : Cat) : Cat :=
  FullSubcat (@isIso C) (@isIso_id C) (@isIso_comp C).


(**************************************************************************
* TLC: A library for Coq                                                  *
* Sets                                                                    *
**************************************************************************)

Set Implicit Arguments.
Generalizable Variables A B.
Require Import Coq.Classes.Morphisms. (* for [Proper] instances *)
Require Import LibTactics LibLogic LibReflect LibList
  LibOperation LibStruct LibInt LibNat
  LibEpsilon LibRelation LibMin.
Require Export LibBag.

(* ********************************************************************** *)
(** * Construction of sets as predicates *)

(* ---------------------------------------------------------------------- *)
(** ** Basic definitions *)

Definition set (A : Type) := A -> Prop.

Section Operations.
Variables (A B : Type).
Implicit Types x : A.
Implicit Types E F G : set A.

Definition set_st (P:A->Prop) : set A :=
  P.

Definition empty_impl : set A :=
  (fun _ => False).

Definition full_impl : set A :=
  (fun _ => True).

Definition single_impl x :=
  (= x).

Definition in_impl x E :=
  E x.

Definition compl_impl : set A -> set A :=
  @pred_not A. (* todo: as typeclass? *)

Definition union_impl : set A -> set A -> set A :=
  @pred_or A.

Definition inter_impl : set A -> set A -> set A :=
  @pred_and A.

Definition remove_impl : set A -> set A -> set A :=
  fun E F x => E x /\ ~ F x.

Definition incl_impl : set A -> set A -> Prop :=
  @pred_le A.

Definition disjoint_impl : set A -> set A -> Prop :=
  fun E F : set A => inter_impl E F = empty_impl.

Definition list_repr_impl (E:set A) (l:list A) :=
  No_duplicates l /\ forall x, Mem x l <-> E x.

Definition to_list (E:set A) :=
  epsilon (list_repr_impl E).

Definition to_set (xs : list A) : set A :=
  set_st (fun x => Mem x xs).

Definition list_covers_impl (E:set A) L :=
  forall x, E x -> Mem x L.

Definition finite (E:set A) :=
  exists L, list_covers_impl E L.

Definition card_impl (E:set A) : nat :=
  mmin le (fun n => exists L, list_covers_impl E L /\ n = length L).

Definition fold_impl (m:monoid_def B) (f:A->B) (E:set A) :=
  LibList.fold_right (fun x acc => monoid_oper m (f x) acc)
    (monoid_neutral m) (to_list E).

End Operations.

(* ---------------------------------------------------------------------- *)
(** ** Inhabited *)

Instance set_inhab : forall A, Inhab (set A).
Proof using. intros. apply (prove_Inhab (@empty_impl A)). Qed.

(* ---------------------------------------------------------------------- *)
(** ** Notation through typeclasses *)

Lemma in_inst : forall A, BagIn A (set A).
Proof using. constructor. exact (@in_impl A). Defined.
Hint Extern 1 (BagIn _ (set _)) => apply in_inst : typeclass_instances.
(* TODO: why is this not an instance like others ? *)

Instance empty_inst : forall A, BagEmpty (set A).
  constructor. apply (@empty_impl A). Defined.
Instance single_inst : forall A, BagSingle A (set A).
  constructor. rapply (@single_impl A). Defined.
Instance union_inst : forall A, BagUnion (set A).
  constructor. rapply (@union_impl A). Defined.
Instance inter_inst : forall A, BagInter (set A).
  constructor. rapply (@inter_impl A). Defined.
Instance remove_inst : forall A, BagRemove (set A) (set A).
  constructor. rapply (@remove_impl A). Defined.
Instance incl_inst : forall A, BagIncl (set A).
  constructor. rapply (@incl_impl A). Defined.
Instance disjoint_inst : forall A, BagDisjoint (set A).
  constructor. rapply (@disjoint_impl A). Defined.
Instance fold_inst : forall A B, BagFold B (A->B) (set A).
  constructor. rapply (@fold_impl A B). Defined.
Instance card_inst : forall A, BagCard (set A).
  constructor. rapply (@card_impl A). Defined.

Global Opaque set finite in_inst empty_inst single_inst union_inst inter_inst
  remove_inst incl_inst disjoint_inst card_inst fold_inst.

(* ---------------------------------------------------------------------- *)
(** Exposed definitions for list coverage *)

(* definitions *)

Definition list_repr A (E:set A) L :=
  No_duplicates L /\ forall x, Mem x L <-> x \in E.

Definition list_covers A (E:set A) L :=
  forall x, x \in E -> Mem x L.

(* ---------------------------------------------------------------------- *)
(** ** Notations for building sets *)

Notation "\set{ x | P }" := (@set_st _ (fun x => P))
 (at level 0, x ident, P at level 200) : set_scope.
Notation "\set{ x : A | P }" := (@set_st A (fun x => P))
 (at level 0, x ident, P at level 200) : set_scope.
Notation "\set{ x '\in' E | P }" := (@set_st _ (fun x => x \in E /\ P))
 (at level 0, x ident, P at level 200) : set_scope.

Notation "\set{= e | x '\in' E }" :=
 (@set_st _ (fun a => exists_ x \in E, a = e ))
 (at level 0, x ident, E at level 200) : set_scope.
Notation "\set{= e | x '\in' E , y ''\in' F }" :=
 (@set_st _ (fun a => exists_ x \in E, exists_ y \in F, a = e ))
 (at level 0, x ident, F at level 200) : set_scope.
Notation "\set{= e | x y '\in' E }" :=
 (@set_st _ (fun a => exists_ x y \in E, a = e ))
 (at level 0, x ident, y ident, E at level 200) : set_scope.

(* ---------------------------------------------------------------------- *)
(** Additional definitions *)

(* TODO

   map f E = \set{= f x | x in E }

   bij E F f g =
      forall x \in E, f x \in F
      forall y \in F, g x \in E
      forall x \in E, g (f x) = x
      forall y \in F, f (g y) = y

   F m i E = fold m j F
     when  bij E F f g
      and  forall x \in E,  i x = j (f x)
       or  forall y \in E,  j y = i (g y)
*)

(* ********************************************************************** *)
(** * Properties of sets *)

Section Instances.
Variables (A:Type).
Transparent set finite empty_inst single_inst single_impl in_inst
  incl_inst inter_inst union_inst card_inst fold_inst remove_inst
  disjoint_inst.
Hint Constructors Mem.

Ltac set_unf := unfold finite,
  card_inst, card_impl, card,
  to_list,
  disjoint_impl, disjoint_inst, disjoint,
  incl_inst, incl_impl,
  empty_inst, empty_impl, empty,
  single_inst, single_impl, single,
  in_inst, in_impl, is_in,
  incl_inst, incl_impl, incl,
  compl_impl, pred_not,
  inter_inst, inter_impl, inter, pred_and,
  union_inst, union_impl, union, pred_or,
  remove_inst, remove_impl, remove,
  fold_inst, fold_impl, fold in *.

(* ---------------------------------------------------------------------- *)
(** Reformulation *)

Lemma disjoint_def : forall (E F : set A),
  E \# F = (E \n F = \{}).
Proof using. auto. Qed.

(* ---------------------------------------------------------------------- *)
(** set_st and double inclusion *)

Lemma in_set_st_eq : forall (P:A->Prop) x,
  x \in set_st P = P x.
Proof using. intros. apply* prop_ext. Qed.

Lemma set_ext_eq : forall (E F : set A),
  (E = F) = (forall (x:A), x \in E <-> x \in F).
Proof using.
  intros. apply prop_ext. iff H. subst*. apply* prop_ext_1.
Qed.

Lemma set_ext : forall (E F : set A),
  (forall (x:A), x \in E <-> x \in F) -> E = F.
Proof using. intros. rewrite~ set_ext_eq. Qed.

Lemma set_st_eq : forall A (P Q : A -> Prop),
  (forall (x:A), P x <-> Q x) -> set_st P = set_st Q.
Proof using. intros. asserts_rewrite~ (P = Q). extens~. Qed.

(* ---------------------------------------------------------------------- *)
(** set_in, incl *)

Global Instance in_extens_inst : In_extens (A:=A) (T:=set A).
Proof using. constructor. intros. rewrite* set_ext_eq. Qed.

Global Instance in_empty_eq_inst : In_empty_eq (A:=A) (T:=set A).
Proof using. constructor. intros. apply* prop_ext. Qed.

Global Instance in_single_eq_inst : In_single_eq (A:=A) (T:=set A).
Proof using. constructor. intros. apply* prop_ext. Qed.

Global Instance in_union_eq_inst : In_union_eq (A:=A) (T:=set A).
Proof using. constructor. intros. set_unf. simpl. apply* prop_ext. Qed.

Global Instance in_inter_eq_inst : In_inter_eq (A:=A) (T:=set A).
Proof using. constructor. intros. set_unf. apply* prop_ext. Qed.

Global Instance in_remove_eq_inst : In_remove_eq (A:=A) (T:=set A).
Proof using. constructor. intros. set_unf. applys* prop_ext. Qed.

Global Instance incl_in_eq_inst : Incl_in_eq (A:=A) (T:=set A).
Proof using. constructor. intros. set_unf. autos*. Qed.

Global Instance disjoint_eq_inst : Disjoint_eq (T:=set A).
Proof using.
  constructor. intros. rewrite disjoint_def.
  set_unf. applys prop_ext. iff M.
    intros x. rewrite* <- (@func_same_1 _ _ x _ _ M).
    applys* prop_ext_1.
Qed.

Lemma set_isolate : forall A (E : set A) x,
  x \in E ->
  E = \{x} \u (E \- \{x}).
Proof using.
  introv H. set_unf. apply prop_ext_1. intros y. iff M.
    simpls. tests*: (y = x).
    destruct M. subst*. autos*.
Qed.

Lemma set_add_remove : forall A (E : set A) x,
  x \notin E ->
  E = (E \u \{x}) \- \{x}.
Proof using.
  introv Hx. set_unf. apply prop_ext_1. iff.
  { split. eauto. intro. subst*. }
  { tauto. }
Qed.

(* ---------------------------------------------------------------------- *)
(** repr and covers *)

Lemma list_repr_covers : forall (E:set A) L,
  list_repr E L -> list_covers E L.
Proof using. introv (ND&EQ). introv Hx. rewrite~ EQ. Qed.

Lemma list_repr_disjoint_union : forall (E F : set A) LE LF,
  E \# F ->
  list_repr E LE ->
  list_repr F LF ->
  list_repr (E \u F) (LE ++ LF).
Proof using.
  introv D (HE&QE) (HF&QF). split.
  applys~ No_duplicates_app.
    intros x ? ?. applys* @disjoint_inv x.
      typeclass. rewrite~ <- QE. rewrite~ <- QF.
    intros x. rewrite Mem_app_or_eq. rewrite in_union_eq.
      rewrite <- QE. rewrite* <- QF.
Qed.

Lemma list_repr_no_duplicates:
  forall (E : set A) xs,
  list_repr E xs ->
  No_duplicates xs.
Proof using.
  unfold list_repr. tauto.
Qed.

(* see also [list_repr_nil] further on *)

(* ---------------------------------------------------------------------- *)
(** to_list *)

Lemma list_covers_impl_to_list_repr_impl : forall A (E:set A),
  ex (list_covers_impl E) -> ex (list_repr_impl E).
Proof using.
  (* TODO: factorize this wiht later proofs *)
  introv (L&M). sets_eq L1 EQL1: (Remove_duplicates L).
  forwards~ (HN&HM&_): Remove_duplicates_spec EQL1.
  sets L2: (Filter (fun x => x \in E) L1).
  exists L2. split.
    applys* No_duplicates_Filter.
    intros x. specializes M x. rewrite <- HM in M. set_unf. iff N.
      subst L2. forwards*: Filter_Mem_inv N.
      applys* Filter_Mem.
Qed.

Lemma finite_list_repr : forall A (E:set A),
  finite E -> list_repr E (to_list E).
Proof using.
  introv FE. unfolds to_list, finite, list_repr_impl.
  spec_epsilon~ as L' (HL'&EL').
  applys~ list_covers_impl_to_list_repr_impl. splits~.
Qed.

Lemma to_list_spec : forall (E:set A) L,
  L = to_list E -> finite E -> list_repr E L.
Proof.
  introv EQ HE. unfolds. subst. forwards* (?&?): finite_list_repr HE.
Qed.

Lemma Mem_to_list:
  forall (xs : set A),
  finite xs ->
  forall x,
  Mem x (to_list xs) <-> x \in xs.
Proof.
  intros. forwards [ ? ? ]: to_list_spec xs; eauto.
Qed.

Lemma to_list_empty :
  to_list (\{}:set A) = nil.
Proof using.
  set_unf. spec_epsilon as l.
  exists (@nil A). split. constructor. iff; false_invert.
  inverts Hl. simpls. destruct~ l. false. rewrite <- H0. simple~.
Qed.

Lemma to_list_single : forall (x:A),
  to_list (\{x}) = x::nil.
Proof using.
  intros. unfold to_list. spec_epsilon as l.
    exists (x::nil). split.
      constructor*. introv M. inverts M.
      unfold single_inst, single_impl. simple~.
       iff H. inverts* H. inverts* H1. inverts* H.
  unfolds single_inst, single_impl. simpls~.
  inverts Hl as H H0. destruct (H0 x). specializes~ H2.
  destruct l.
    inverts H2.
    tests E: (x = a).
      fequals. destruct l. auto. forwards~: (proj1 (H0 a0)).
       subst. inverts H as M1 M2. false* M1.
      inverts H2. false. forwards~: (proj1 (H0 a)). false.
Qed.

(* ---------------------------------------------------------------------- *)
(** finite *)

(* introduction *)

Lemma finite_prove_covers : forall (E:set A) L,
  list_covers E L -> finite E.
Proof using. introv H. exists* L. Qed.

Lemma finite_prove_repr : forall (E:set A) L,
  list_repr E L -> finite E.
Proof using. introv (ND&EQ). exists~ L. introv Hx. rewrite~ EQ. Qed.

Lemma finite_prove_exists : forall (E:set A),
  ex (list_covers E) -> finite E.
Proof using. introv (L&H). applys* finite_prove_covers. Qed.

(* elimination *)

Definition finite_covers : forall (E:set A),
  finite E -> exists L, list_covers E L /\ card E = length L.
Proof.
  introv (L&H). sets m: (card E).
  forwards* (R&P): mmin_spec_nat m.
Qed.

Lemma finite_covers_basic : forall (E:set A),
  finite E -> exists L, list_covers E L.
Proof using. introv (L&HN). exists L. intros. applys* HN. Qed.

(* operations *)

Lemma finite_empty :
  finite (\{} : set A).
Proof using.
  intros. apply finite_prove_exists. set_unf.
  exists (@nil A). introv M. inverts M.
Qed.

Lemma finite_single : forall (a : A),
  finite \{a}.
Proof using.
  intros. apply finite_prove_exists. set_unf.
  exists (a::nil). introv M. hnf in M. subst*.
Qed.

Lemma finite_union : forall (E F : set A),
  finite E ->
  finite F ->
  finite (E \u F).
Proof using.
  introv H1 H2. apply finite_prove_exists.
  lets (L1&E1): finite_covers_basic H1.
  lets (L2&E2): finite_covers_basic H2.
  exists (L1++L2). unfolds list_covers.
  introv M.
  rewrite @in_union_eq in M; try typeclass.
  rewrite* Mem_app_or_eq.
Qed.

Lemma finite_inter : forall (E F : set A),
  finite E \/ finite F ->
  finite (E \n F).
Proof using.
  introv H. apply finite_prove_exists. destruct H.
  lets (L&EQ): finite_covers_basic H. exists L. unfold list_covers. set_unf. autos*.
  lets (L&EQ): finite_covers_basic H. exists L. unfold list_covers. set_unf. autos*.
Qed.

Lemma finite_incl : forall (E F : set A),
  E \c F ->
  finite F ->
  finite E.
Proof using.
  introv HI HF. apply finite_prove_exists.
  lets (L&EQ): finite_covers_basic HF. unfold list_covers.
  set_unf. exists* L. introv Ex. applys EQ. applys~ HI.
Qed.

Lemma finite_remove : forall (E F : set A),
  finite E ->
  finite (E \- F).
Proof using.
  introv HE. apply finite_prove_exists.
  lets (L&EQ): finite_covers_basic HE. unfold list_covers. set_unf. exists* L.
Qed.

Section One.
Lemma finite_remove_inv : forall (E F : set A),
  finite (E \- F) -> finite F -> finite E.
Proof using.
  Local Opaque remove_inst single_inst.
  introv H1 H2. lets (L1&R1): finite_covers_basic H1.
  lets (L2&R2): finite_covers_basic H2.
  applys finite_prove_covers (L1 ++ L2).
  intros y Hy. rewrite~ Mem_app_or_eq. tests: (y \in F).
    autos~.
    forwards~ M: R1 y. rewrite~ @in_remove_eq. typeclass.
Qed.
End One.

Lemma finite_remove_one_inv : forall (E : set A) x,
  finite (E \-- x) -> finite E.
Proof using.
  introv H. applys finite_remove_inv H. applys finite_single.
Qed.

(* LATER : finite_remove_inv
   finite (E \- F) -> finite F -> finite E
*)

(* The following lemma pushed here due to dependencies. *)

Lemma list_repr_nil:
  list_repr \{} (@nil A).
Proof using.
  rewrite <- to_list_empty.
  eapply to_list_spec; eauto using finite_empty.
Qed.

(* ---------------------------------------------------------------------- *)
(** card *)

(* introduction of properties on card *)

Definition card_prove_le : forall (E:set A) L,
  list_covers E L -> (card E <= length L)%nat.
Proof using.
  introv H. sets m: (card E). set_unf.
  forwards* (R&P): mmin_spec_nat m.
  simpls. applys P. exists L. splits~.
Qed.

Definition finite_repr_length : forall (E:set A),
  finite E -> exists L, list_repr E L /\ card E = length L.
Proof.
  introv H. forwards (L1&HL1&EL1): finite_covers H.
  sets L2: (Remove_duplicates L1).
  forwards~ (ND&EQ&LE): Remove_duplicates_spec L1 L2.
  sets L3: (Filter (fun x => x \in E) L2).
  asserts: (length L3 <= length L2)%nat. applys Filter_length_le.
  asserts R3: (list_repr E L3).
    split.
      applys~ No_duplicates_Filter.
      intros x. iff M.
        unfold L3 in M. lets~ (_&?): Filter_Mem_inv M.
        applys~ Filter_Mem. rewrite~ EQ.
  forwards C3: list_repr_covers R3.
  exists L3. splits*.
  forwards: card_prove_le C3. math.
Qed.

Lemma list_repr_card : forall (E:set A) (L:list A),
  list_repr E L -> card E = length L.
Proof using.
  introv HR. lets (ND&EQ): HR.
  forwards~ (L'&(ND'&HR')&EQ'): finite_repr_length E.
    applys* finite_prove_repr.
  unfold card. simpl. rewrite EQ'.
  applys~ No_duplicates_length_eq.
  intros x. rewrite EQ. rewrite* HR'.
Qed.

Definition card_prove_ge : forall (E:set A) n,
  finite E -> (forall L, list_covers E L -> (length L >= n)%nat) ->
  (card E >= n)%nat.
Proof using.
  introv H. sets m: (card E).
  forwards* (R&P): mmin_spec_nat m.
    lets (L&EL): finite_covers_basic H. exists~ (length L) L.
  simpls. introv HL. destruct R as (L&CR&ER).
  forwards~: HL L. math.
Qed.

Definition card_prove_eq : forall (E:set A) L,
  list_covers E L ->
  (forall L', list_covers E L' -> (length L' >= length L)%nat) ->
  card E = length L.
Proof using.
  introv HC HG.
  forwards~: card_prove_le HC.
  forwards~: card_prove_ge HG. applys* finite_prove_covers.
  math.
Qed.

Lemma card_is_length_to_list : forall (E:set A),
  finite E -> card E = length (to_list E).
Proof using.
  introv FE. applys list_repr_card. applys~ to_list_spec.
Qed.

(* operations *)

Global Instance card_empty_inst : Card_empty (T:=set A).
Proof using.
  constructor. rewrite card_is_length_to_list.
  lets E: to_list_empty. set_unf. rewrite E. rew_list~.
  applys finite_empty.
Qed.

Global Instance card_single_inst : Card_single (T:=set A).
Proof using.
  constructor. intros a. rewrite card_is_length_to_list.
  lets E: to_list_single a. set_unf. rewrite E. rew_list~.
  applys finite_single.
Qed.

End Instances.

Hint Resolve finite_empty finite_single finite_union
  finite_inter finite_incl finite_remove : finite.

(* ---------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
(* ** Tactics for proving set equalities and set inclusions *)

(* lemmas *)

Section Autorewrite.
Variables (A : Type).
Implicit Types x y : A.
Implicit Types E F : set A.

Lemma set_in_empty_eq : forall x, x \in (\{}:set A) = False.
Proof using.
  apply in_empty_eq.
Qed.

Lemma set_in_single_eq : forall x y, x \in (\{y}:set A) = (x = y).
Proof using.
  apply in_single_eq.
Qed.

Lemma set_in_inter_eq : forall x E F, x \in (E \n F) = (x \in E /\ x \in F).
Proof using.
  apply in_inter_eq.
Qed.

Lemma set_in_union_eq : forall x E F, x \in (E \u F) = (x \in E \/ x \in F).
Proof using.
  apply in_union_eq.
Qed.

Lemma set_in_remove_eq : forall x E F, x \in (E \- F) = (x \in E /\ ~ x \in F).
Proof using.
  apply in_remove_eq.
Qed.

Lemma set_in_extens_eq : forall E F, (E = F) = (forall x, x \in E <-> x \in F).
Proof using.
  extens. iff M.
  subst*.
  applys @in_extens_eq. typeclass. intros. extens*.
Qed.

Lemma set_incl_in_eq : forall E F, (E \c F) = (forall x, x \in E -> x \in F).
Proof using.
  apply incl_in_eq.
Qed.

Lemma set_disjoint_eq : forall E F, (E \# F) = (forall x, x \in E -> x \in F -> False).
Proof using.
  apply disjoint_eq.
Qed.

End Autorewrite.

Hint Rewrite in_set_st_eq set_in_empty_eq set_in_single_eq set_in_inter_eq set_in_union_eq
  set_in_remove_eq set_in_extens_eq set_incl_in_eq set_disjoint_eq : set_norm.

(* tactics *)

Ltac set_norm :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with set_norm).

Ltac set_specialize_hyps A x :=
  repeat match goal with H: forall _:?A, _ |- _ =>
    specializes H x
  end.

Ltac set_specialize_classic x :=
  repeat match goal with E: set _ |- _ =>
    match goal with
    | H: x \in E \/ ~ x \in E |- _ => fail 1
    | _ => lets: (classic (x \in E))
    end
  end.

Ltac set_specialize use_classic :=
  match goal with |- forall _:?A, _ =>
    let x := fresh "x" in intros x;
    set_specialize_hyps A x;
    match use_classic with
    | true => set_specialize_classic x
    | false => idtac
    end
  end.

Ltac set_prove_setup use_classic :=
  intros;
  set_norm;
  try set_specialize use_classic;
  set_norm.

Ltac set_prove_conclude :=
  solve [ intros; subst; tauto ].

Ltac set_prove :=
  set_prove_setup false; set_prove_conclude.

Ltac set_prove_classic :=
  set_prove_setup true; set_prove_conclude.

(* demos *)

Lemma inter_union_disjoint_right:
  forall A (E F G : set A),
  F \# G ->
  (E \u F) \n G = (E \n G).
Proof using.
  set_prove.
  (* intros. set_norm. set_specialize. set_norm. tauto. *)
Qed. (* demo *)

Lemma inter_union_subset_right:
  forall A (E F G : set A),
  F \c G ->
  (E \u F) \n G = (E \n G) \u F.
Proof using.
  set_prove.
Qed. (* demo *)

Lemma inter_covariant:
  forall A (E E' F F' : set A),
  E \c E' ->
  F \c F' ->
  (E \n F) \c (E' \n F').
Proof using.
  set_prove.
Qed. (* demo *)

Lemma set_decompose_inter_right :
  forall A (E F : set A),
  E = (E \n F) \u (E \- F).
Proof using.
  set_prove_classic.
Qed. (* demo *)

Lemma set_decompose_union_right :
  forall A (E F : set A),
  (E \u F) = E \u (F \- E).
Proof using.
  set_prove_classic.
Qed. (* demo *)

(* ---------------------------------------------------------------------- *)
(** card *)

Lemma card_incl_le : forall A (E F:set A),
  finite F ->
  E \c F ->
  (card E <= card F)%nat.
Proof using.
  introv FF CF. lets FE: finite_incl CF FF.
  lets (LF&RF&QF): finite_covers FF.
  rewrite QF. applys card_prove_le. introv Ex.
  applys RF. applys* @incl_inv. typeclass.
Qed.

Lemma card_union_le : forall A (E F:set A),
  finite E -> finite F ->
  card (E \u F) <= (card E + card F)%nat.
Proof using.
  introv FE FF.
  lets (LE&RE&QE): finite_covers FE.
  lets (LF&RF&QF): finite_covers FF.
  lets H: card_prove_le (E \u F) (LE++LF) __.
    unfolds list_covers. intros. apply Mem_app_or.
    rewrite in_union_eq in H. autos*.
  rew_length in H. math.
Qed.

Lemma card_disjoint_union : forall A (E F : set A),
  finite E ->
  finite F ->
  E \# F ->
  card (E \u F) = (card E + card F)%nat.
Proof using.
  introv FE FF EF.
  forwards: card_union_le FE FF.
  cuts: (card (E \u F) >= (card E + card F)%nat). math. clear H.
  forwards (L&LC&LL): finite_covers (E \u F). applys~ finite_union.
  rewrite LL. clear LL.
  sets PE: (fun x => x \in E). sets LE: (Filter PE L).
  sets PF: (fun x => x \in F). sets LF: (Filter PF L).
  forwards: card_prove_le E LE.
    unfold LE, PE. introv Ex. forwards: LC x. set_prove. applys~ Filter_Mem.
  forwards: card_prove_le F LF.
    unfold LF, PF. introv Fx. forwards: LC x. set_prove. applys~ Filter_Mem.
  forwards LEF: Filter_disjoint_predicates_length PE PF L.
    introv _ HEx HFx. unfolds PE, PF. applys* @disjoint_inv. typeclass.
  subst LE LF. math.
Qed.

Lemma card_inter_left : forall A (E F : set A),
  finite E ->
  card (E \n F) <= card E.
Proof using.
  intros. applys~ card_incl_le. set_prove.
Qed.

Lemma card_inter_right : forall A (E F : set A),
  finite F ->
  card (E \n F) <= card F.
Proof using.
  intros. rewrite inter_comm. apply~ card_inter_left.
Qed.

Lemma card_nonempty : forall A (E : set A) x,
  x \in E ->
  finite E ->
  1 <= card E.
Proof using.
  intros.
  rewrite <- (card_single x).
  applys~ card_incl_le.
  set_prove.
Qed.

Lemma card_disjoint_union_single : forall A (E : set A) x,
  finite E ->
  x \notin E ->
  (card (E \u \{x}) = card E + 1)%nat.
Proof using.
  intros.
  replace 1 with (card \{x}) by eauto using card_single.
  applys~ card_disjoint_union. applys finite_single.
  rewrite disjoint_single_r_eq. auto.
Qed.

Lemma card_diff_single:
  forall A (E : set A) x,
  finite E ->
  x \in E ->
  (card (E \-- x) = card E - 1)%nat.
Proof using.
  intros.
  assert (h1: (E \-- x) \u \{x} = E).
  { rewrite union_comm. erewrite set_isolate by eauto. reflexivity. }
  forwards h2: card_disjoint_union_single (E \-- x) x.
  { eauto with finite. }
  { unfold notin. rewrite set_in_remove_eq.
    rew_logic. right.
    eapply in_single_self. }
  rewrite h1 in h2.
  math.
Qed.

(* ---------------------------------------------------------------------- *)
(** fold *)

Lemma fold_def : forall A B (m:monoid_def B) (f:A->B) (E: set A),
  fold m f E = LibList.fold m f (to_list E).
Proof using. reflexivity. Qed.

Lemma fold_eq : forall A B (m:monoid_def B) (f:A->B) (E: set A) L,
  Monoid_commutative m ->
  list_repr E L ->
  fold m f E = LibList.fold m f L.
Proof using.
  introv HM EL. rewrite fold_def.
  forwards~ (N&EQ2): to_list_spec E. applys* finite_prove_repr.
  destruct EL as (ND&EQ1).
  applys~ LibList.fold_equiv. intros. rewrite EQ2. rewrite* EQ1.
Qed.

Lemma fold_induction:
  forall A B (m : monoid_def B) (f : A -> B) (P : B -> Prop),
  Monoid_commutative m ->
  P (monoid_neutral m) ->
  (forall x a, P x -> P (monoid_oper m (f a) x)) ->
  forall E,
  finite E ->
  P (fold m f E).
Proof using.
  introv ? Hbase Hstep Hfinite.
  assert (forall xs, P (LibList.fold m f xs)).
  { induction xs; unfold LibList.fold; simpl; eauto. }
  forwards: finite_list_repr Hfinite.
  erewrite fold_eq by eauto.
  eauto.
Qed.

Lemma fold_congruence : forall A B (m : monoid_def B) (f g : A -> B) (E : set A),
  Monoid_commutative m ->
  finite E ->
  (forall x, x \in E -> f x = g x) ->
  fold m f E = fold m g E.
Proof using.
  introv ? ? h. do 2 rewrite fold_def.
  eapply LibList.fold_congruence. intros.
  eapply h. eapply Mem_to_list; eauto.
Qed.

Lemma fold_empty : forall A B (m:monoid_def B) (f:A->B),
  fold m f (\{}:set A) = monoid_neutral m.
Proof using.
  intros. rewrite fold_def.
  rewrite to_list_empty. rewrite~ LibList.fold_nil.
Qed.

Lemma fold_single : forall A B (m:monoid_def B) (f:A->B) (x:A),
  Monoid m ->
  fold m f \{x} = f x.
Proof using.
  intros. rewrite fold_def.
  rewrite to_list_single. rewrite~ fold_cons.
  rewrite fold_nil. rewrite~ monoid_neutral_r.
Qed.

Lemma fold_union : forall A B (m:monoid_def B) (f:A->B) (E F : set A),
  Monoid_commutative m ->
  finite E ->
  finite F ->
  E \# F ->
  fold m f (E \u F) = monoid_oper m (fold m f E) (fold m f F).
Proof using.
  introv HM HE HF HD.
  rewrites (>> fold_def E).
  rewrites (>> fold_def F).
  hint finite_list_repr. forwards~ HR: list_repr_disjoint_union HD.
  rewrites~ (>> fold_eq HR).
  rewrite~ LibList.fold_app. typeclass.
Qed.

Lemma fold_isolate :
  forall A (E : set A) x,
  finite E ->
  x \in E ->
  forall B (m : monoid_def B),
  Monoid_commutative m ->
  forall (f : A -> B),
  fold m f E = monoid_oper m (f x) (fold m f (E \- \{x})).
Proof using.
  intros.
  (* Separate [E] into the singleton [\{x}] union the rest. *)
  rewrite (set_isolate E x) at 1 by eauto.
  (* Note that [f x] is the result of folding [f] over the singleton [\{x}]. *)
  erewrite <- (fold_single f x) by typeclass.
  (* Conclude. *)
  eapply fold_union; eauto using remove_disjoint with finite.
Qed.

Lemma fold_pointwise:
  forall B (m : monoid_def B) (leB : B -> B -> Prop),
  Monoid m ->
  refl leB ->
  Proper (leB ++> leB ++> leB) (monoid_oper m) ->
  forall A (E : set A),
  finite E ->
  forall (f f' : A -> B),
  (forall x, x \in E -> leB (f x) (f' x)) ->
  leB (fold m f E) (fold m f' E).
Proof using.
  intros. do 2 rewrite fold_def.
  applys~ LibList.fold_pointwise.
  intros x. forwards~ (_&EQ): finite_list_repr E. rewrite (EQ x). auto.
Qed.

(* ---------------------------------------------------------------------- *)
(** [to_set] *)

Lemma list_repr_to_set:
  forall A (xs : list A),
  No_duplicates xs ->
  list_repr (to_set xs) xs.
Proof using.
  unfold list_repr, to_set. induction 1; split.
  { econstructor. }
  { tauto. }
  { econstructor; eauto. }
  { tauto. }
Qed.

Lemma list_repr_to_set_inverse:
  forall A (E : set A) (xs : list A),
  list_repr E xs ->
  E = to_set xs.
Proof using.
  unfold list_repr, to_set. introv (_ & ?).
  generalize dependent E. generalize dependent xs.
  induction xs; introv H; rewrite set_ext_eq; intros x;
  rewrite in_set_st_eq; rewrite H; tauto.
Qed.

Lemma to_set_nil:
  forall A,
  to_set (@nil A) = \{}.
Proof using.
  intros.
  erewrite <- list_repr_to_set_inverse by eapply list_repr_nil.
  eauto.
Qed.

Lemma prefix_to_set:
  forall A (xs ys : list A),
  prefix xs ys ->
  to_set xs \c to_set ys.
Proof using.
  unfold to_set. introv (zs&?). subst.
  rewrite set_incl_in_eq. intros. rewrite in_set_st_eq in *.
  rewrite Mem_app_or_eq. tauto.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Structural properties *)

(** Rewriting tactics *)

Hint Rewrite in_set_st_eq : rew_set.
Tactic Notation "rew_set" :=
  autorewrite with rew_set.
Tactic Notation "rew_set" "in" hyp(H) :=
  autorewrite with rew_set in H.
Tactic Notation "rew_set" "in" "*" :=
  autorewrite with rew_set in *.

(* ********************************************************************** *)
(** * Additional predicates on sets *)

(* ---------------------------------------------------------------------- *)
(** ** Foreach *)

(** TODO: derive these lemmas as typeclasses in a generic way in LibBag *)

Section ForeachProp.
Variables (A : Type).
Implicit Types P Q : A -> Prop.
Implicit Types E F : set A.

Lemma foreach_empty : forall P,
  @foreach A (set A) _ P \{}.
Proof using. intros_all. false. Qed.
(* TODO: false* @in_empty. typeclass. *)

Lemma foreach_single : forall P X,
  P X -> @foreach A (set A) _ P (\{ X }).
Proof using. intros_all. rewrite in_single_eq in H0. subst*. Qed.

Lemma foreach_union : forall P E F,
  foreach P E -> foreach P F -> foreach P (E \u F).
Proof using. intros_all. destruct~ (in_union_inv H1). Qed.

Lemma foreach_union_inv : forall P E F,
  foreach P (E \u F) -> foreach P E /\ foreach P F.
Proof using.
  introv H. split; introv K.
  apply H. rewrite~ @in_union_eq. typeclass.
  apply H. rewrite~ @in_union_eq. typeclass.
Qed.

Lemma foreach_union_eq : forall P E F,
  foreach P (E \u F) = (foreach P E /\ foreach P F).
Proof using.
  intros. extens. iff.
  apply~ foreach_union_inv.
  intuition eauto using foreach_union.
Qed.

Lemma foreach_single_eq : forall P X,
  foreach P (\{X}:set A) = P X.
Proof using.
  intros. extens. iff.
  apply H. apply in_single_self.
  apply~ foreach_single.
Qed.

Lemma foreach_weaken : forall P Q E,
  foreach P E -> pred_le P Q -> foreach Q E.
Proof using. introv H L K. apply~ L. Qed.

Lemma foreach_remove_simple : forall P E F,
  foreach P E -> foreach P (E \- F).
Proof using. introv M H. applys M. rewrite in_remove_eq in H. autos*. Qed.

Lemma foreach_remove : forall P Q E F,
  foreach P E -> pred_le P (fun (x:A) => x \notin F -> Q x) -> foreach Q (E \- F).
Proof using. introv M H Px. rewrite in_remove_eq in Px. applys* H. Qed.

Lemma foreach_notin_prove : forall P x E,
  foreach P E -> ~ P x -> x \notin E.
Proof using. introv M N I. applys N. applys~ M. Qed.

End ForeachProp.

Hint Resolve foreach_empty foreach_single foreach_union.
Hint Rewrite foreach_union_eq foreach_single_eq : rew_foreach.

Tactic Notation "rew_foreach" :=
  autorewrite with rew_foreach.
Tactic Notation "rew_foreach" "in" hyp(H) :=
  autorewrite with rew_foreach in H.
Tactic Notation "rew_foreach" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_foreach).
  (* autorewrite with rew_foreach in *.  *)

Tactic Notation "rew_foreach" "~" :=
  rew_foreach; auto_tilde.
Tactic Notation "rew_foreach" "*" :=
  rew_foreach; auto_star.
Tactic Notation "rew_foreach" "~" "in" constr(H) :=
  rew_foreach in H; auto_tilde.
Tactic Notation "rew_foreach" "*" "in" constr(H) :=
  rew_foreach in H; auto_star.
Tactic Notation "rew_foreach" "~" "in" "*" :=
  rew_foreach in *; auto_tilde.
Tactic Notation "rew_foreach" "*" "in" "*" :=
  rew_foreach in *; auto_star.

(* ********************************************************************** *)
(** * Tactics *)

(* DEPRECATED, use "set_prove" when possible *)

(* ---------------------------------------------------------------------- *)
(** ** Tactics to prove equalities on unions *)

(* Documentation appears further on *)

Lemma for_set_union_assoc : forall A, assoc (union (T:=set A)).
Proof using. intros. apply union_assoc. Qed.

Lemma for_set_union_comm : forall A, comm (union (T:=set A)).
Proof using. intros. apply union_comm. Qed.

Lemma for_set_union_empty_l : forall A (E:set A), \{} \u E = E.
Proof using. intros. apply union_empty_l. Qed.

Lemma for_set_union_empty_r : forall A (E:set A), E \u \{} = E.
Proof using. intros. apply union_empty_r. Qed.

Hint Rewrite <- for_set_union_assoc : rew_permut_simpl.
Hint Rewrite for_set_union_empty_l for_set_union_empty_r : rew_permut_simpl.
Ltac rew_permut_simpl :=
  autorewrite with rew_permut_simpl; try typeclass.
Ltac rews_permut_simpl :=
  autorewrite with rew_permut_simpl in *; try typeclass.

Section PermutationTactic.
Context (A:Type).
Implicit Types l : set A.

Lemma permut_get_1 : forall l1 l2,
  (l1 \u l2) = (l1 \u l2).
Proof using. intros. auto. Qed.

Lemma permut_get_2 : forall l1 l2 l3,
  (l1 \u l2 \u l3) = (l2 \u l1 \u l3).
Proof using. intros. apply union_comm_assoc. Qed.

Lemma permut_get_3 : forall l1 l2 l3 l4,
  (l1 \u l2 \u l3 \u l4) = (l2 \u l3 \u l1 \u l4).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_2.
Qed.

Lemma permut_get_4 : forall l1 l2 l3 l4 l5,
    (l1 \u l2 \u l3 \u l4 \u l5)
  = (l2 \u l3 \u l4 \u l1 \u l5).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_3.
Qed.

Lemma permut_get_5 : forall l1 l2 l3 l4 l5 l6,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6)
  = (l2 \u l3 \u l4 \u l5 \u l1 \u l6).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_4.
Qed.

Lemma permut_get_6 : forall l1 l2 l3 l4 l5 l6 l7,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6 \u l7)
  = (l2 \u l3 \u l4 \u l5 \u l6 \u l1 \u l7).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_5.
Qed.

Lemma permut_get_7 : forall l1 l2 l3 l4 l5 l6 l7 l8,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l8)
  = (l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l1 \u l8).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_6.
Qed.

Lemma permut_get_8 : forall l1 l2 l3 l4 l5 l6 l7 l8 l9,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l8 \u l9)
  = (l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l8 \u l1 \u l9).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_7.
Qed.

Lemma permut_cancel_1 : forall l1 l2,
  (l1 \u l1 \u l2) = l1 \u l2.
Proof using. intros. rewrite union_assoc. rewrite union_self. auto. Qed.

Lemma permut_cancel_2 : forall l1 l2 l3,
  (l1 \u l2 \u l1 \u l3) = (l1 \u l2 \u l3).
Proof using.
  intros. rewrite <- (@permut_get_2 l1). apply permut_cancel_1.
Qed.

Lemma permut_cancel_3 : forall l1 l2 l3 l4,
  (l1 \u l2 \u l3 \u l1 \u l4) = (l1 \u l2 \u l3 \u l4).
Proof using.
  intros. rewrite <- (@permut_get_3 l1). apply permut_cancel_1.
Qed.

Lemma permut_cancel_4 : forall l1 l2 l3 l4 l5,
    (l1 \u l2 \u l3 \u l4 \u l1 \u l5)
  = (l1 \u l2 \u l3 \u l4 \u l5).
Proof using.
  intros. rewrite <- (@permut_get_4 l1). apply permut_cancel_1.
Qed.

Lemma permut_cancel_5 : forall l1 l2 l3 l4 l5 l6,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l1 \u l6)
  = (l1 \u l2 \u l3 \u l4 \u l5 \u l6).
Proof using.
  intros. rewrite <- (@permut_get_5 l1). apply permut_cancel_1.
Qed.

Lemma permut_tactic_setup : forall l1 l2,
   (\{} \u l1 \u \{}) = (l2 \u \{}) -> l1 = l2.
Proof using. intros. rews_permut_simpl. Qed.

Lemma permut_tactic_keep : forall l1 l2 l3 l4,
  ((l1 \u l2) \u l3) = l4 ->
  (l1 \u (l2 \u l3)) = l4.
Proof using. intros. rews_permut_simpl. Qed.

Lemma permut_tactic_simpl : forall l1 l2 l3 l4,
  (l1 \u l3) = l4 ->
  (l1 \u (l2 \u l3)) = (l2 \u l4).
Proof using. intros. subst. apply permut_get_2. Qed.

Lemma permut_tactic_trans : forall l1 l2 l3,
  l3 = l2 -> l1 = l3 -> l1 = l2.
Proof using. intros. subst~. Qed.

End PermutationTactic.

(** [permut_lemma_get n] returns the lemma [permut_get_n]
    for the given value of [n] *)

Ltac permut_lemma_get n :=
  match nat_from_number n with
  | 1%nat => constr:(permut_get_1)
  | 2%nat => constr:(permut_get_2)
  | 3%nat => constr:(permut_get_3)
  | 4%nat => constr:(permut_get_4)
  | 5%nat => constr:(permut_get_5)
  end.

(** [permut_prepare] applies to a goal of the form [permut l l']
    and sets [l] and [l'] in the form [l1 \u l2 \u .. \u \{}],
    (some of the lists [li] are put in the form [x::\{}]). *)

Ltac permut_simpl_prepare :=
   rew_permut_simpl;
   apply permut_tactic_setup;
   repeat rewrite <- union_assoc.

(* todo : doc *)

Ltac cancel_all_dup l :=
  repeat first
    [ rewrite (permut_cancel_1 l)
    | rewrite (permut_cancel_2 l)
    | rewrite (permut_cancel_3 l)
    | rewrite (permut_cancel_4 l)
    | rewrite (permut_cancel_5 l) ].

Ltac permut_index_of l lcontainer :=
  match constr:(lcontainer) with
  | l \u _ => constr:(1)
  | _ \u l \u _ => constr:(2)
  | _ \u _ \u l \u _ => constr:(3)
  | _ \u _ \u _ \u l \u _ => constr:(4)
  | _ \u _ \u _ \u _ \u l \u _ => constr:(5)
  | _ \u _ \u _ \u _ \u _ \u l \u _ => constr:(6)
  | _ \u _ \u _ \u _ \u _ \u _ \u l \u _ => constr:(7)
  | _ \u _ \u _ \u _ \u _ \u _ \u _ \u l \u _ => constr:(8)
  | _ => constr:(0) (* not found *)
  end.

(** [permut_simplify] simplifies a goal of the form
    [permut l l'] where [l] and [l'] are lists built with
    concatenation and consing, by cancelling syntactically
    equal elements *)

Ltac permut_simpl_once :=
  match goal with
  | |- (_ \u \{}) = _ => fail 1
  | |- (_ \u (?l \u ?lr)) = ?l' =>
     cancel_all_dup l;
     match permut_index_of l l' with
     | 0 => apply permut_tactic_keep
     | ?n => let F := permut_lemma_get n in
            eapply permut_tactic_trans;
            [ eapply F; try typeclass
            | apply permut_tactic_simpl ]
     end
  end.

Ltac permut_simpl :=
  permut_simpl_prepare;
  repeat permut_simpl_once;
  rew_permut_simpl;
  try apply refl_equal.

(* TODO: move demos somewhere else *)

Section DemoSetUnion.
Variables (A:Type).

Lemma demo_set_union_permut_simpl_1 :
  forall l1 l2 l3 : set A,
  (l1 \u l2 \u l3 \u l1) = (l3 \u l2 \u l1).
Proof using.
  intros.
  permut_simpl_prepare.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  rew_permut_simpl.
Qed.

Lemma demo_set_union_permut_simpl_2 :
  forall
  (x:A) l1 l2 l3,
  (l1 \u \{x} \u l3 \u l2) = (l1 \u l2 \u (\{x} \u l3)).
Proof using.
  intros.
  permut_simpl_prepare.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  rew_permut_simpl.
Qed.

Lemma demo_set_union_permut_simpl_3 : forall (x y:A) l1 l1' l2 l3,
  l1 = l1' ->
  (l1 \u (\{x} \u l2) \u \{x} \u (\{y} \u l3)) = (\{y} \u (l1' \u l2) \u (\{x} \u l3)).
Proof using.
  intros.
  permut_simpl_prepare.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  try permut_simpl_once.
  rew_permut_simpl.
Qed.

End DemoSetUnion.

(* ---------------------------------------------------------------------- *)
(** ** Tactics to prove membership *)

(* DEPRECATED: use "set_prove" when possible *)

Section InUnionGet.
Variables (A:Type).
Implicit Types l : set A.

Lemma in_union_get_1 : forall x l1 l2,
  x \in l1 -> x \in (l1 \u l2).
Proof using. intros. apply in_union_l. auto. Qed.

Lemma in_union_get_2 : forall x l1 l2 l3,
  x \in l2 -> x \in (l1 \u l2 \u l3).
Proof using. intros. apply in_union_r. apply~ in_union_get_1. Qed.

Lemma in_union_get_3 : forall x l1 l2 l3 l4,
  x \in l3 -> x \in (l1 \u l2 \u l3 \u l4).
Proof using. intros. apply in_union_r. apply~ in_union_get_2. Qed.

Lemma in_union_get_4 : forall x l1 l2 l3 l4 l5,
  x \in l4 -> x \in (l1 \u l2 \u l3 \u l4 \u l5).
Proof using. intros. apply in_union_r. apply~ in_union_get_3. Qed.

Lemma in_union_get_5 : forall x l1 l2 l3 l4 l5 l6,
  x \in l5 -> x \in (l1 \u l2 \u l3 \u l4 \u l5 \u l6).
Proof using. intros. apply in_union_r. apply~ in_union_get_4. Qed.

End InUnionGet.

Implicit Arguments in_union_get_1 [A x l1 l2].
Implicit Arguments in_union_get_2 [A x l1 l2 l3].
Implicit Arguments in_union_get_3 [A x l1 l2 l3 l4].
Implicit Arguments in_union_get_4 [A x l1 l2 l3 l4 l5].
Implicit Arguments in_union_get_5 [A x l1 l2 l3 l4 l5 l6].

Ltac in_union_get :=
  match goal with H: ?x \in ?A |- ?x \in ?B =>
  match B with context [A] =>
  let go tt := first
        [ apply (in_union_get_1 H)
        | apply (in_union_get_2 H)
        | apply (in_union_get_3 H)
        | apply (in_union_get_4 H)
        | apply (in_union_get_5 H) ] in
  first [ go tt
        | rewrite <- (for_set_union_empty_r B);
          repeat rewrite <- for_set_union_assoc;
          go tt ]
  end end.

Hint Extern 3 (_ \in _ \u _) => in_union_get.

Section InUnionExtract.
Variables (A:Type).
Implicit Types l : set A.

Lemma in_union_extract_1 : forall x l1,
  x \in (\{x} \u l1).
Proof using. intros. apply in_union_get_1. apply in_single_self. Qed.

Lemma in_union_extract_2 : forall x l1 l2,
  x \in (l1 \u \{x} \u l2).
Proof using. intros. apply in_union_get_2. apply in_single_self. Qed.

Lemma in_union_extract_3 : forall x l1 l2 l3,
  x \in (l1 \u l2 \u \{x} \u l3).
Proof using. intros. apply in_union_get_3. apply in_single_self. Qed.

Lemma in_union_extract_4 : forall x l1 l2 l3 l4,
  x \in (l1 \u l2 \u l3 \u \{x} \u l4).
Proof using. intros. apply in_union_get_4. apply in_single_self. Qed.

Lemma in_union_extract_5 : forall x l1 l2 l3 l4 l5,
  x \in (l1 \u l2 \u l3 \u l4 \u \{x} \u l5).
Proof using. intros. apply in_union_get_5. apply in_single_self. Qed.

End InUnionExtract.

Ltac in_union_extract :=
  match goal with |- ?x \in ?A =>
  match A with context [\{x}] =>
  let go tt := first
        [ apply (in_union_extract_1)
        | apply (in_union_extract_2)
        | apply (in_union_extract_3)
        | apply (in_union_extract_4)
        | apply (in_union_extract_5) ] in
  first [ go tt
        | rewrite <- (for_set_union_empty_r A);
          repeat rewrite <- for_set_union_assoc;
          go tt ]
  end end.

Hint Extern 3 (_ \in _) => in_union_extract.

(* ---------------------------------------------------------------------- *)
(** ** Tactics to invert a membership hypothesis *)

(* TODO: document and clean up *)

Section InversionsTactic.
Context (A:Type).
Implicit Types l : set A.
Implicit Types x : A.
Lemma empty_eq_single_inv_1 : forall x l1 l2,
  l1 = l2 -> x \notin l1 -> x \in l2 -> False.
Proof using. intros. subst*. Qed.
Lemma empty_eq_single_inv_2 : forall x l1 l2,
  l1 = l2 -> x \notin l2 -> x \in l1 -> False.
Proof using. intros. subst*. Qed.
Lemma notin_empty : forall x,
  x \notin (\{}:set A).
Proof using. intros. unfold notin. rewrite in_empty_eq. auto. Qed.
End InversionsTactic.
Hint Resolve notin_empty.

Ltac in_union_meta :=
  match goal with
  | |- _ \in \{_} => apply in_single_self
  | |- _ \in \{_} \u _ => apply in_union_l; apply in_single_self
  | |- _ \in _ \u _ => apply in_union_r; in_union_meta
  end.

Ltac fset_inv_core_for H :=
  let go L :=
     false L; [ apply H
              | try apply notin_empty
              | instantiate; try in_union_meta ] in
  match type of H with
  | \{} = _ => go empty_eq_single_inv_1
  | _ = \{} => go empty_eq_single_inv_2
  | _ = _ => go empty_eq_single_inv_1
  end.

Tactic Notation "fset_inv" constr(H) :=
  fset_inv_core_for H.

Ltac fset_inv_core :=
  match goal with
  | |- \{} <> _ => let H := fresh in intro H; fset_inv H
  | |- _ <> \{} => let H := fresh in intro H; fset_inv H
  | H: \{} = _ |- _ => fset_inv H
  | H: _ = \{} |- _ => fset_inv H
  end.

Tactic Notation "fset_inv" :=
  fset_inv_core.

Section InUnionInv.
Variables (A:Type).
Implicit Types l : set A.

Lemma set_in_empty_inv : forall x,
  x \in (\{}:set A) -> False.
Proof using. introv. apply notin_empty. Qed.
Lemma set_in_single_inv : forall x y : A,
  x \in (\{y}:set A) -> x = y.
Proof using. intros. rewrite @in_single_eq in H. auto. typeclass. Qed.
Lemma set_in_union_inv : forall x l1 l2,
  x \in (l1 \u l2) -> x \in l1 \/ x \in l2.
Proof using. introv H. rewrite @in_union_eq in H. auto. typeclass. Qed.

End InUnionInv.

Implicit Arguments set_in_single_inv [A x y].
Implicit Arguments set_in_union_inv [A x l1 l2].

Ltac set_in_inv_base H M :=
  match type of H with
  | _ \in \{} => false; apply (@set_in_empty_inv _ _ H)
  | _ \in \{_} =>
    generalize (set_in_single_inv H); try clear H; intro_subst
  | _ \in _ \u _ =>
    let H' := fresh "TEMP" in
    destruct (set_in_union_inv H) as [H'|H'];
    try clear H; set_in_inv_base H' M
  | _ => rename H into M
  end.

Tactic Notation "set_in" constr(H) "as" ident(M) :=
  set_in_inv_base H M.
Tactic Notation "set_in" constr(H) :=
  let M := fresh "H" in set_in H as M.

(* ---------------------------------------------------------------------- *)
(** ** Tactic to prove two sets equal by double-inclusion *)

(* DEPRECATED: use "set_prove" instead when possible *)

Tactic Notation "eq_set" :=
  let H := fresh "TEMP" in
  apply set_ext; iff H; set_in H; in_union_get.
Tactic Notation "eq_set" "*" :=
  eq_set; auto_star.

(* ---------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)

(* FUTURE

  (** Sets of sets *)

  (* todo: typeclass for bigunion and bigintersection *)

  Definition bigunion_impl A (E : set (set A)) : set A :=
    \set{ x | exists_ F \in E, x \in (F:set A) }.

  Definition biguinter_impl A (E : set (set A)) : set A :=
    \set{ x | forall_ F \in E, x \in (F:set A) }.

*)