Require Import StateMachines.Preliminaries.
Import ListNotations.

Module MACHINE.
Structure Machine := mkMachine
{ input : Set
; state : Set
; pass : state → input → state
; input_fin_cert : Finitary input
}.
Fixpoint run (m : Machine)
           (s : state m)
           (u : list (input m))
:= match u with []      => s
              | i :: u' => run m (pass m s i) u' end.
End MACHINE.

Module ACCEPTOR.
Structure Acceptor {m : MACHINE.Machine} := mkAcceptor
{ acceptant : MACHINE.state m → Prop }.
Definition acceptable {m : MACHINE.Machine}
             (a : Acceptor)
             (s : MACHINE.state m) : list (MACHINE.input m) → Prop
:= fun u => acceptant a (MACHINE.run m s u).
End ACCEPTOR.

Module TRANSDUCER.
Import MACHINE.
Structure Transducer {m : Machine} := mkTransducer
{ output : Set
; response : state m → output
; output_fin_cert : Finitary output
}.

End TRANSDUCER.

Notation Machine := MACHINE.Machine               (only parsing).
Notation mkMachine := MACHINE.mkMachine           (only parsing).
Notation input := MACHINE.input                   (only parsing).
Notation state := MACHINE.state                   (only parsing).
Notation pass := MACHINE.pass                     (only parsing).
Notation run := MACHINE.run                       (only parsing).
Notation Acceptor := ACCEPTOR.Acceptor            (only parsing).
Notation mkAcceptor := ACCEPTOR.mkAcceptor        (only parsing).
Notation acceptant := ACCEPTOR.acceptant          (only parsing).
Notation acceptable := ACCEPTOR.acceptable        (only parsing).


Require Export Db.Spec.
Require Export RecTypes.SpecTypes.

Require Import Coq.micromega.Lia.
Require Export RecTypes.SpecTypes.
Require Export RecTypes.InstTy.
Require Export RecTypes.Contraction.

(** ** Simply typed terms. *)
Inductive Tm : Set :=
  | var (i: Ix)
  | abs (τ: Ty) (t: Tm)
  | app (t₁ t₂: Tm)
  | unit
  | true
  | false
  | ite (t₁ t₂ t₃: Tm)
  | pair (t₁ t₂: Tm)
  | proj₁ (t: Tm)
  | proj₂ (t: Tm)
  | inl (t: Tm)
  | inr (t: Tm)
  | caseof (t₁ t₂ t₃: Tm)
  | fold_ (t : Tm) (* may need type parameters here *)
  | unfold_ (t : Tm)
  | seq (t₁ t₂: Tm).

Section WellScoping.

  (* Keep this in a section so that the notation for the ws type-class is only
     locally overwritten. *)
  Inductive wsTm (γ: Dom) : Tm → Prop :=
    | WsVar {i}           : γ ∋ i → ⟨ γ ⊢ var i ⟩
    | WsAbs {τ t}         : ⟨ S γ ⊢ t ⟩ → ⟨ γ ⊢ abs τ t ⟩
    | WsApp {t₁ t₂}       : ⟨ γ ⊢ t₁ ⟩ → ⟨ γ ⊢ t₂ ⟩ → ⟨ γ ⊢ app t₁ t₂ ⟩
    | WsUnit              : ⟨ γ ⊢ unit ⟩
    | WsTrue              : ⟨ γ ⊢ true ⟩
    | WsFalse             : ⟨ γ ⊢ false ⟩
    | WsIte {t₁ t₂ t₃}    : ⟨ γ ⊢ t₁ ⟩ → ⟨ γ ⊢ t₂ ⟩ →
                            ⟨ γ ⊢ t₃ ⟩ → ⟨ γ ⊢ ite t₁ t₂ t₃ ⟩
    | WsProj1 {t}         : ⟨ γ ⊢ t ⟩ → ⟨ γ ⊢ proj₁ t ⟩
    | WsProj2 {t}         : ⟨ γ ⊢ t ⟩ → ⟨ γ ⊢ proj₂ t ⟩
    | WsPair {t₁ t₂}      : ⟨ γ ⊢ t₁ ⟩ → ⟨ γ ⊢ t₂ ⟩ → ⟨ γ ⊢ pair t₁ t₂ ⟩
    | WsInj₁ {t}          : ⟨ γ ⊢ t ⟩ → ⟨ γ ⊢ inl t ⟩
    | WsInj₂ {t}          : ⟨ γ ⊢ t ⟩ → ⟨ γ ⊢ inr t ⟩
    | WsCaseof {t₁ t₂ t₃} : ⟨ γ ⊢ t₁ ⟩ → ⟨ S γ ⊢ t₂ ⟩ →
                            ⟨ S γ ⊢ t₃ ⟩ → ⟨ γ ⊢ caseof t₁ t₂ t₃ ⟩
    | WsSeq {t₁ t₂}       : ⟨ γ ⊢ t₁ ⟩ → ⟨ γ ⊢ t₂ ⟩ → ⟨ γ ⊢ seq t₁ t₂ ⟩
    | WsFold {t} : ⟨ γ ⊢ t ⟩ → ⟨ γ ⊢ fold_ t ⟩
    | WsUnfold {t} : ⟨ γ ⊢ t ⟩ → ⟨ γ ⊢ unfold_ t ⟩
  where "⟨ γ ⊢ t ⟩" := (wsTm γ t).

End WellScoping.
#[export]
Instance WsTm : Ws Tm := wsTm.

(** ** Program contexts *)

Inductive PCtx : Set :=
  | phole
  | pabs (T: Ty) (C: PCtx)
  | papp₁ (C: PCtx) (t: Tm)
  | papp₂ (t: Tm) (C: PCtx)
  | pite₁ (C: PCtx) (t₂ t₃: Tm)
  | pite₂ (t₁: Tm) (C: PCtx) (t₃: Tm)
  | pite₃ (t₁ t₂: Tm) (C: PCtx)
  | ppair₁ (C: PCtx) (t: Tm)
  | ppair₂ (t: Tm) (C: PCtx)
  | pproj₁ (C: PCtx)
  | pproj₂ (C: PCtx)
  | pinl (C: PCtx)
  | pinr (C: PCtx)
  | pcaseof₁ (C: PCtx) (t₂ t₃: Tm)
  | pcaseof₂ (t₁: Tm) (C: PCtx) (t₃: Tm)
  | pcaseof₃ (t₁ t₂: Tm) (C: PCtx)
  | pfold (C : PCtx)
  | punfold (C : PCtx)
  | pseq₁ (C: PCtx) (t: Tm)
  | pseq₂ (t: Tm) (C: PCtx).
  (* | pfixt (τ₁ τ₂: Ty) (C: PCtx). *)

Fixpoint pctx_app (t₀: Tm) (C: PCtx) {struct C} : Tm :=
  match C with
    | phole            => t₀
    | pabs T C         => abs T (pctx_app t₀ C)
    | papp₁ C t        => app (pctx_app t₀ C) t
    | papp₂ t C        => app t (pctx_app t₀ C)
    | pite₁ C t₂ t₃    => ite (pctx_app t₀ C) t₂ t₃
    | pite₂ t₁ C t₃    => ite t₁ (pctx_app t₀ C) t₃
    | pite₃ t₁ t₂ C    => ite t₁ t₂ (pctx_app t₀ C)
    | ppair₁ C t       => pair (pctx_app t₀ C) t
    | ppair₂ t C       => pair t (pctx_app t₀ C)
    | pproj₁ C         => proj₁ (pctx_app t₀ C)
    | pproj₂ C         => proj₂ (pctx_app t₀ C)
    | pinl C           => inl (pctx_app t₀ C)
    | pinr C           => inr (pctx_app t₀ C)
    | pcaseof₁ C t₁ t₂ => caseof (pctx_app t₀ C) t₁ t₂
    | pcaseof₂ t₁ C t₂ => caseof t₁ (pctx_app t₀ C) t₂
    | pcaseof₃ t₁ t₂ C => caseof t₁ t₂ (pctx_app t₀ C)
    | pfold C => fold_ (pctx_app t₀ C)
    | punfold C => unfold_ (pctx_app t₀ C)
    | pseq₁ C t        => seq (pctx_app t₀ C) t
    | pseq₂ t C        => seq t (pctx_app t₀ C)
  end.

Fixpoint pctx_cat (C₀ C: PCtx) {struct C} : PCtx :=
  match C with
    | phole            => C₀
    | pabs T C         => pabs T (pctx_cat C₀ C)
    | papp₁ C t        => papp₁ (pctx_cat C₀ C) t
    | papp₂ t C        => papp₂ t (pctx_cat C₀ C)
    | pite₁ C t₂ t₃    => pite₁ (pctx_cat C₀ C) t₂ t₃
    | pite₂ t₁ C t₃    => pite₂ t₁ (pctx_cat C₀ C) t₃
    | pite₃ t₁ t₂ C    => pite₃ t₁ t₂ (pctx_cat C₀ C)
    | ppair₁ C t       => ppair₁ (pctx_cat C₀ C) t
    | ppair₂ t C       => ppair₂ t (pctx_cat C₀ C)
    | pproj₁ C         => pproj₁ (pctx_cat C₀ C)
    | pproj₂ C         => pproj₂ (pctx_cat C₀ C)
    | pinl C           => pinl (pctx_cat C₀ C)
    | pinr C           => pinr (pctx_cat C₀ C)
    | pcaseof₁ C t₁ t₂ => pcaseof₁ (pctx_cat C₀ C) t₁ t₂
    | pcaseof₂ t₁ C t₂ => pcaseof₂ t₁ (pctx_cat C₀ C) t₂
    | pcaseof₃ t₁ t₂ C => pcaseof₃ t₁ t₂ (pctx_cat C₀ C)
    | pfold C => pfold (pctx_cat C₀ C)
    | punfold C => punfold (pctx_cat C₀ C)
    | pseq₁ C t        => pseq₁ (pctx_cat C₀ C) t
    | pseq₂ t C        => pseq₂ t (pctx_cat C₀ C)
  end.

Section Application.

  Context {Y: Type}.
  Context {vrY: Vr Y}.
  Context {wkY: Wk Y}.
  Context {vrTm: Vr Tm}.
  Context {liftYTm: Lift Y Tm}.

  Context {vrTy: Vr Ty}.
  Context {liftYTy: Lift Y Ty}.

  Fixpoint apTm (ζ: Sub Y) (t: Tm) {struct t} : Tm :=
    match t with
      | var x           => lift (ζ x)
      | abs T t₂        => abs T (apTm (ζ↑) t₂)
      | app t₁ t₂       => app (apTm ζ t₁) (apTm ζ t₂)
      | unit            => unit
      | true            => true
      | false           => false
      | ite t₁ t₂ t₃    => ite (apTm ζ t₁) (apTm ζ t₂) (apTm ζ t₃)
      | pair t₁ t₂      => pair (apTm ζ t₁) (apTm ζ t₂)
      | proj₁ t         => proj₁ (apTm ζ t)
      | proj₂ t         => proj₂ (apTm ζ t)
      | inl t           => inl (apTm ζ t)
      | inr t           => inr (apTm ζ t)
      | caseof t₁ t₂ t₃ => caseof (apTm ζ t₁) (apTm (ζ↑) t₂) (apTm (ζ↑) t₃)
      | seq t₁ t₂       => seq (apTm ζ t₁) (apTm ζ t₂)
      (* | fixt τ₁ τ₂ t    => fixt τ₁ τ₂ (apTm ζ t) *)
      | fold_ t => fold_ (apTm ζ t)
      | unfold_ t => unfold_ (apTm ζ t)
    end.

  Global Arguments apTm ζ !t.

End Application.

Ltac crushStlcSyntaxMatchH :=
  match goal with
    | [ H: S _ = S _             |- _ ] => apply eq_add_S in H

    | [ H: var _        = var _        |- _ ] => inversion H; clear H
    | [ H: abs _ _      = abs _ _      |- _ ] => inversion H; clear H
    | [ H: app _ _      = app _ _      |- _ ] => inversion H; clear H
    | [ H: pair _ _     = pair _ _     |- _ ] => inversion H; clear H
    | [ H: ite _ _ _    = ite _ _ _    |- _ ] => inversion H; clear H
    | [ H: proj₁ _      = proj₁ _      |- _ ] => inversion H; clear H
    | [ H: proj₂ _      = proj₂ _      |- _ ] => inversion H; clear H
    | [ H: inl _        = inl _        |- _ ] => inversion H; clear H
    | [ H: inr _        = inr _        |- _ ] => inversion H; clear H
    | [ H: caseof _ _ _ = caseof _ _ _ |- _ ] => inversion H; clear H
    | [ H: seq _ _      = seq _ _      |- _ ] => inversion H; clear H
    | [ H: fold_ _        = fold_ _        |- _ ] => inversion H; clear H
    | [ H: unfold_ _        = unfold_ _        |- _ ] => inversion H; clear H

    | [ H: inl _       = inr _         |- _ ] => inversion H
    | [ H: inr _       = inl _         |- _ ] => inversion H

    | [ H: unit        = abs _ _       |- _ ] => inversion H
    | [ H: true        = abs _ _       |- _ ] => inversion H
    | [ H: false       = abs _ _       |- _ ] => inversion H
    | [ H: pair _ _    = abs _ _       |- _ ] => inversion H
    | [ H: inl _       = abs _ _       |- _ ] => inversion H
    | [ H: inr _       = abs _ _       |- _ ] => inversion H
    | [ H: fold_ _       = abs _ _       |- _ ] => inversion H
    | [ H: unfold_ _       = abs _ _       |- _ ] => inversion H

    | [ |- S _          = S _          ] => f_equal
    | [ |- var _        = var _        ] => f_equal
    | [ |- abs _ _      = abs _ _      ] => f_equal
    | [ |- app _ _      = app _ _      ] => f_equal
    | [ |- fold_ _      = fold_ _      ] => f_equal
    | [ |- unfold_ _      = unfold_ _      ] => f_equal
    | [ |- unit         = unit         ] => reflexivity
    | [ |- true         = true         ] => reflexivity
    | [ |- false        = false        ] => reflexivity
    | [ |- ite _ _ _    = ite _ _ _    ] => f_equal
    | [ |- pair _ _     = pair _ _     ] => f_equal
    | [ |- proj₁ _      = proj₁ _      ] => f_equal
    | [ |- proj₂ _      = proj₂ _      ] => f_equal
    | [ |- inl _        = inl _        ] => f_equal
    | [ |- inr _        = inr _        ] => f_equal
    | [ |- caseof _ _ _ = caseof _ _ _ ] => f_equal

    | [ |- seq _ _      = seq _ _      ] => f_equal
    | [ |- context[apTm ?ξ ?t] ] =>
      change (apTm ξ t) with t[ξ]
  end.


(*********************************************************************************************************************************)
(* ReificationsAndGeneralizedArrows:                                                                                *)
(*                                                                                *)
(*   For each pair of enrichments E1 and E2, there is a bijection between the generalized arrows E1->E2 and the reifications     *)
(*   E1->E2                                                                                *)
(*                                                                                *)
(*********************************************************************************************************************************)

Generalizable All Variables.
Require Import Preamble.
Require Import General.
Require Import Categories_ch1_3.
Require Import Functors_ch1_4.
Require Import Isomorphisms_ch1_5.
Require Import ProductCategories_ch1_6_1.
Require Import OppositeCategories_ch1_6_2.
Require Import Enrichment_ch2_8.
Require Import Subcategories_ch7_1.
Require Import NaturalTransformations_ch7_4.
Require Import NaturalIsomorphisms_ch7_5.
Require Import MonoidalCategories_ch7_8.
Require Import PreMonoidalCategories.
Require Import Coherence_ch7_8.
Require Import Enrichment_ch2_8.
Require Import Enrichments.
Require Import RepresentableStructure_ch7_2.
Require Import Reification.
Require Import GeneralizedArrow.
Require Import GeneralizedArrowFromReification.
Require Import ReificationFromGeneralizedArrow.
Require Import ReificationCategory.
Require Import GeneralizedArrowCategory.

Section ReificationsEquivalentToGeneralizedArrows.

  Ltac if_transitive :=
    match goal with [ |- ?A ≃ ?B ] => refine (@if_comp _ _ _ _ _ _ _ A _ _ _ B _ _)
    end.

  Lemma roundtrip_lemma
    `{D:Category}`{E:Category}
    {Gobj}{G:Functor E D Gobj} G_full G_faithful `{C:Category}{Fobj}(F:Functor C (FullImage G) Fobj) :
    (F >>>> (ff_functor_section_functor G G_full G_faithful >>>> G)) ≃ (F >>>> FullImage_InclusionFunctor _).
    if_transitive.
      eapply if_inv.
      apply (if_associativity F (ff_functor_section_functor G _ _) G).
    if_transitive.
      apply (if_associativity F (ff_functor_section_functor G _ _) G).
      apply if_respects.
        apply if_id.
        if_transitive; [ idtac | apply if_left_identity ].
    apply (if_comp(F2:=(ff_functor_section_functor G G_full G_faithful) >>>> RestrictToImage G >>>> FullImage_InclusionFunctor _)).
    apply if_inv.
    apply (if_associativity (ff_functor_section_functor G G_full G_faithful)
      (RestrictToImage G) (FullImage_InclusionFunctor G)).
    apply if_respects.
    apply ff_functor_section_splits_niso.
    apply if_id.
    Qed.

  Definition step1_niso
    `(K:SurjectiveEnrichment) `(C:MonicEnrichment ce) (CM:MonoidalEnrichment ce) (reification : Reification K ce (enr_c_i ce))
    : reification_rstar reification ≃ (RestrictToImage reification >>>> R' K CM reification >>>> FullImage_InclusionFunctor CM).
    exists (fun c1 => homset_tensor_iso K CM reification c1).
    intros.
    simpl.
    etransitivity.
    eapply comp_respects; [ apply reflexivity | idtac ].
    apply associativity.
    apply iso_comp1_right.
    Qed.

  Lemma roundtrip_garrow_to_garrow
    `(K:SurjectiveEnrichment) `(C:MonicEnrichment ce) (CM:MonoidalEnrichment ce) (garrow : GeneralizedArrow K ce)
    : garrow ≃ garrow_from_reification K C CM (reification_from_garrow K CM garrow).
    apply if_inv.
    eapply if_comp.
    eapply if_inv.
    unfold garrow_from_reification.
    simpl.
    unfold mf_F.
    unfold garrow_functor.
    apply (if_associativity
      (RestrictToImage (reification_from_garrow K CM garrow))
      (R' K CM (reification_from_garrow K CM garrow))
      (step2_functor C)).

    apply (ffc_functor_weakly_monic _ me_full me_faithful me_conservative me_conservative).
    eapply if_comp.
    apply (if_associativity
      (RestrictToImage (reification_from_garrow K CM garrow) >>>> R' K CM (reification_from_garrow K CM garrow))
      (step2_functor C)
      me_homfunctor).

    set ((R' K CM (reification_from_garrow K CM garrow))) as f.
    unfold HomFunctor_fullimage in f.
    set (roundtrip_lemma (me_full(MonicEnrichment:=C))) as q.
    set (q (me_faithful(MonicEnrichment:=C)) _ _ _ _ f) as q'.

    eapply if_comp.
      apply (if_associativity (RestrictToImage (reification_from_garrow K CM garrow)) f (step2_functor C >>>> me_homfunctor)).
      unfold step2_functor.
      eapply if_comp.
      apply (if_respects
        (RestrictToImage (reification_from_garrow K CM garrow))
        (RestrictToImage (reification_from_garrow K CM garrow))
        _ _ (if_id _) q').

    eapply if_comp.
      eapply if_inv.
      apply (if_associativity (RestrictToImage (reification_from_garrow K CM garrow)) f (FullImage_InclusionFunctor me_homfunctor)).

    apply if_inv.
      apply (step1_niso K C CM (reification_from_garrow K CM garrow)).
      Qed.

  Lemma roundtrip_reification_to_reification
    `(K:SurjectiveEnrichment) `(C:MonicEnrichment ce) (CM:MonoidalEnrichment ce) (reification : Reification K ce (enr_c_i ce))
    : reification ≃ reification_from_garrow K CM (garrow_from_reification K C CM reification).

    simpl.
      unfold garrow_functor.

    eapply if_comp.
      apply (step1_niso K C CM reification).

    unfold garrow_monoidal.
      unfold mf_F.
      apply if_inv.
      eapply if_comp.
      apply (if_associativity (RestrictToImage reification) (R' K CM reification >>>> step2_functor C)
        (HomFunctor ce (pmon_I (enr_c_pm ce)))).
      apply if_inv.
      eapply if_comp.
      apply (if_associativity (RestrictToImage reification) (R' K CM reification)
        (FullImage_InclusionFunctor (HomFunctor ce (pmon_I (enr_c_pm ce))))).

    apply (if_respects (RestrictToImage reification) (RestrictToImage reification) _ _ (if_id _)).
      apply if_inv.
      eapply if_comp.
      apply (if_associativity  (R' K CM reification) (step2_functor C) (HomFunctor ce _)).

    set ((R' K CM reification)) as f.
      unfold HomFunctor_fullimage in f.
      set (roundtrip_lemma (me_full(MonicEnrichment:=C))) as q.
      set (q (me_faithful(MonicEnrichment:=C)) _ _ _ _ f) as q'.
      apply q'.
      Qed.

End ReificationsEquivalentToGeneralizedArrows.


Inductive type : Set :=
| atom : nat -> type
| tuple1 : type -> type
| tuple2 : type -> type -> type
| union : type -> type -> type.

Inductive type_vars : Set :=
| vatom : nat -> type_vars
| vtuple1 : type_vars -> type_vars
| vtuple2 : type_vars -> type_vars -> type_vars
| vunion : type_vars -> type_vars -> type_vars
| vunionall : type_vars -> type_vars
| vvar : nat -> type_vars.


Require Import Basics.
Require Import Types.
Require Import Diagrams.Diagram.
Require Import Diagrams.Graph.
Require Import Diagrams.Cone.
Require Import Diagrams.ConstantDiagram.

Local Open Scope path_scope.
Generalizable All Variables.

(** This file contains the definition of limits, and functoriality results on limits. *)

(** * Limits *)

(** A Limit is the extremity of a cone. *)

Class IsLimit `(D : Diagram G) (Q : Type) := {
  islimit_cone :> Cone Q D;
  islimit_unicone : UniversalCone islimit_cone;
}.

Coercion islimit_cone : IsLimit >-> Cone.

Arguments Build_IsLimit {G D Q} C H : rename.
Arguments islimit_cone {G D Q} C : rename.
Arguments islimit_unicone {G D Q} H : rename.

(** [cone_precompose_inv] is defined for convenience: it is only the inverse of [cone_precompose]. It allows to recover the map [h] from a cone [C']. *)

Definition cone_precompose_inv `{D: Diagram G} {Q X}
  (H : IsLimit D Q) (C' : Cone X D) : X -> Q
  := @equiv_inv _ _ _ (islimit_unicone H X) C'.

(** * Existence of limits *)

Record Limit `(D : Diagram G) := {
  lim : forall i, D i;
  limp : forall i j (g : G i j), D _f g (lim i) = lim j;
}.

Arguments lim {_ _}.
Arguments limp {_ _}.

Definition cone_limit `(D : Diagram G) : Cone (Limit D) D.
Proof.
  serapply Build_Cone.
  + intros i x.
    apply (lim x i).
  + intros i j g x.
    apply limp.
Defined.

Global Instance unicone_limit `(D : Diagram G)
  : UniversalCone (cone_limit D).
Proof.
  serapply Build_UniversalCone; intro Y.
  serapply isequiv_adjointify.
  { intros c y.
    serapply Build_Limit.
    { intro i.
      apply (legs c i y). }
    intros i j g.
    apply legs_comm. }
  all: intro; reflexivity.
Defined.

Global Instance islimit_limit `(D : Diagram G) : IsLimit D (Limit D)
  := Build_IsLimit (cone_limit _) _.

(** * Functoriality of limits *)

Section FunctorialityLimit.

  Context `{Funext} {G : Graph}.

  (** Limits are preserved by composition with a (diagram) equivalence. *)

  Definition islimit_precompose_equiv {D : Diagram G} `(f : Q <~> Q')
    : IsLimit D Q' -> IsLimit D Q.
  Proof.
    intros HQ.
    serapply (Build_IsLimit (cone_precompose HQ f) _).
    apply cone_precompose_equiv_universality, HQ.
  Defined.

  Definition islimit_postcompose_equiv {D1 D2 : Diagram G} (m : D1 ~d~ D2)
    {Q : Type} : IsLimit D1 Q -> IsLimit D2 Q.
  Proof.
    intros HQ.
    serapply (Build_IsLimit (cone_postcompose m HQ) _).
    apply cone_postcompose_equiv_universality, HQ.
  Defined.

  (** A diagram map [m] : [D1] => [D2] induces a map between any two limits of [D1] and [D2]. *)

  Definition functor_limit {D1 D2 : Diagram G} (m : DiagramMap D1 D2)
    {Q1 Q2} (HQ1 : IsLimit D1 Q1) (HQ2 : IsLimit D2 Q2)
    : Q1 -> Q2 := cone_precompose_inv HQ2 (cone_postcompose m HQ1).

  (** And this map commutes with diagram map. *)

  Definition functor_limit_commute {D1 D2 : Diagram G}
    (m : DiagramMap D1 D2) {Q1 Q2}
    (HQ1 : IsLimit D1 Q1) (HQ2 : IsLimit D2 Q2)
    : cone_postcompose m HQ1
      = cone_precompose HQ2 (functor_limit m HQ1 HQ2)
    := (eisretr (cone_precompose HQ2) _)^.

  (** ** Limits of equivalent diagrams *)

  (** Now we have than two equivalent diagrams have equivalent limits. *)

  Context {D1 D2 : Diagram G} (m : D1 ~d~ D2) {Q1 Q2}
    (HQ1 : IsLimit D1 Q1) (HQ2 : IsLimit D2 Q2).

  Definition functor_limit_eissect
    : Sect (functor_limit (diagram_equiv_inv m) HQ2 HQ1)
           (functor_limit m HQ1 HQ2).
  Proof.
    apply ap10.
    serapply (equiv_inj (cone_precompose HQ2) _).
    1: apply HQ2.
    etransitivity.
    2:symmetry; apply cone_precompose_identity.
    etransitivity.
    1: apply cone_precompose_comp.
    rewrite eisretr, cone_postcompose_precompose, eisretr.
    rewrite cone_postcompose_comp, diagram_inv_is_section.
    apply cone_postcompose_identity.
  Defined.

  Definition functor_limit_eisretr
    : Sect (functor_limit m HQ1 HQ2)
           (functor_limit (diagram_equiv_inv m) HQ2 HQ1).
  Proof.
    apply ap10.
    serapply (equiv_inj (cone_precompose HQ1) _).
    1: apply HQ1.
    etransitivity.
    2:symmetry; apply cone_precompose_identity.
    etransitivity.
    1: apply cone_precompose_comp.
    rewrite eisretr, cone_postcompose_precompose, eisretr.
    rewrite cone_postcompose_comp, diagram_inv_is_retraction.
    apply cone_postcompose_identity.
  Defined.

  Global Instance isequiv_functor_limit
    : IsEquiv (functor_limit m HQ1 HQ2)
    := isequiv_adjointify _ _
      functor_limit_eissect functor_limit_eisretr.

  Definition equiv_functor_limit : Q1 <~> Q2
    := Build_Equiv _ _ _ isequiv_functor_limit.

End FunctorialityLimit.

(** * Unicity of limits *)

(** A particuliar case of the functoriality result is that all limits of a diagram are equivalent (and hence equal in presence of univalence). *)

Theorem limit_unicity `{Funext} {G : Graph} {D : Diagram G} {Q1 Q2 : Type}
  (HQ1 : IsLimit D Q1) (HQ2 : IsLimit D Q2)
  : Q1 <~> Q2.
Proof.
  serapply equiv_functor_limit.
  serapply (Build_diagram_equiv (diagram_idmap D)).
Defined.

(** * Limits are right adjoint to constant diagram *)

Theorem limit_adjoint `{Funext} {G : Graph} {D : Diagram G} {C : Type}
  : (C -> Limit D) <~> DiagramMap (diagram_const C) D.
Proof.
  serapply equiv_adjointify.
  { intro f.
    serapply Build_DiagramMap.
    { intros i c.
      apply lim, f, c. }
    intros i j g x.
    apply limp. }
  { intros [f p] c.
    serapply Build_Limit.
    { intro i.
      apply f, c. }
    intros i j g.
    apply p. }
  1,2: intro; reflexivity.
Defined.


(** * ImpCEvalFun: Evaluation Function for Imp *)

(* #################################### *)
(** * Evaluation Function *)

Require Import Imp.

(** Here's a first try at an evaluation function for commands,
    omitting [WHILE]. *)

Fixpoint ceval_step1 (st : state) (c : com) : state :=
  match c with
    | SKIP =>
        st
    | l ::= a1 =>
        update st l (aeval st a1)
    | c1 ;; c2 =>
        let st' := ceval_step1 st c1 in
        ceval_step1 st' c2
    | IFB b THEN c1 ELSE c2 FI =>
        if (beval st b)
          then ceval_step1 st c1
          else ceval_step1 st c2
    | WHILE b1 DO c1 END =>
        st  (* bogus *)
  end.

(** In a traditional functional programming language like ML or
    Haskell we could write the WHILE case as follows:
<<
    | WHILE b1 DO c1 END =>
        if (beval st b1)
          then ceval_step1 st (c1;; WHILE b1 DO c1 END)
          else st
>>
    Coq doesn't accept such a definition ([Error: Cannot guess
    decreasing argument of fix]) because the function we want to
    define is not guaranteed to terminate. Indeed, the changed
    [ceval_step1] function applied to the [loop] program from [Imp.v] would
    never terminate. Since Coq is not just a functional programming
    language, but also a consistent logic, any potentially
    non-terminating function needs to be rejected. Here is an
    invalid(!) Coq program showing what would go wrong if Coq allowed
    non-terminating recursive functions:
<<
     Fixpoint loop_false (n : nat) : False := loop_false n.
>>
    That is, propositions like [False] would become
    provable (e.g. [loop_false 0] would be a proof of [False]), which
    would be a disaster for Coq's logical consistency.

    Thus, because it doesn't terminate on all inputs, the full version
    of [ceval_step1] cannot be written in Coq -- at least not
    without one additional trick... *)

(** Second try, using an extra numeric argument as a "step index" to
    ensure that evaluation always terminates. *)

Fixpoint ceval_step2 (st : state) (c : com) (i : nat) : state :=
  match i with
  | O => empty_state
  | S i' =>
    match c with
      | SKIP =>
          st
      | l ::= a1 =>
          update st l (aeval st a1)
      | c1 ;; c2 =>
          let st' := ceval_step2 st c1 i' in
          ceval_step2 st' c2 i'
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step2 st c1 i'
            else ceval_step2 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then let st' := ceval_step2 st c1 i' in
               ceval_step2 st' c i'
          else st
    end
  end.

(** _Note_: It is tempting to think that the index [i] here is
    counting the "number of steps of evaluation."  But if you look
    closely you'll see that this is not the case: for example, in the
    rule for sequencing, the same [i] is passed to both recursive
    calls.  Understanding the exact way that [i] is treated will be
    important in the proof of [ceval__ceval_step], which is given as
    an exercise below. *)

(** Third try, returning an [option state] instead of just a [state]
    so that we can distinguish between normal and abnormal
    termination. *)

Fixpoint ceval_step3 (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (update st l (aeval st a1))
      | c1 ;; c2 =>
          match (ceval_step3 st c1 i') with
          | Some st' => ceval_step3 st' c2 i'
          | None => None
          end
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step3 st c1 i'
            else ceval_step3 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then match (ceval_step3 st c1 i') with
               | Some st' => ceval_step3 st' c i'
               | None => None
               end
          else Some st
    end
  end.

(** We can improve the readability of this definition by introducing a
    bit of auxiliary notation to hide the "plumbing" involved in
    repeatedly matching against optional states. *)

Notation "'LETOPT' x <== e1 'IN' e2"
   := (match e1 with
         | Some x => e2
         | None => None
       end)
   (right associativity, at level 60).

Fixpoint ceval_step (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (update st l (aeval st a1))
      | c1 ;; c2 =>
          LETOPT st' <== ceval_step st c1 i' IN
          ceval_step st' c2 i'
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step st c1 i'
            else ceval_step st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then LETOPT st' <== ceval_step st c1 i' IN
               ceval_step st' c i'
          else Some st
    end
  end.

Definition test_ceval (st:state) (c:com) :=
  match ceval_step st c 500 with
  | None    => None
  | Some st => Some (st X, st Y, st Z)
  end.

(* Eval compute in
     (test_ceval empty_state
         (X ::= ANum 2;;
          IFB BLe (AId X) (ANum 1)
            THEN Y ::= ANum 3
            ELSE Z ::= ANum 4
          FI)).
   ====>
      Some (2, 0, 4)   *)

(** **** Exercise: 2 stars (pup_to_n)  *)
(** Write an Imp program that sums the numbers from [1] to
   [X] (inclusive: [1 + 2 + ... + X]) in the variable [Y].  Make sure
   your solution satisfies the test that follows. *)

Definition pup_to_n : com :=
  (* FILL IN HERE *) admit.

(*
Example pup_to_n_1 :
  test_ceval (update empty_state X 5) pup_to_n
  = Some (0, 15, 0).
Proof. reflexivity. Qed.
*)
(** [] *)

(** **** Exercise: 2 stars, optional (peven)  *)
(** Write a [While] program that sets [Z] to [0] if [X] is even and
    sets [Z] to [1] otherwise.  Use [ceval_test] to test your
    program. *)

(* FILL IN HERE *)
(** [] *)

(* ################################################################ *)
(** * Equivalence of Relational and Step-Indexed Evaluation *)

(** As with arithmetic and boolean expressions, we'd hope that
    the two alternative definitions of evaluation actually boil down
    to the same thing.  This section shows that this is the case.
    Make sure you understand the statements of the theorems and can
    follow the structure of the proofs. *)

Theorem ceval_step__ceval: forall c st st',
      (exists i, ceval_step st c i = Some st') ->
      c / st || st'.
Proof.
  intros c st st' H.
  inversion H as [i E].
  clear H.
  generalize dependent st'.
  generalize dependent st.
  generalize dependent c.
  induction i as [| i' ].

  Case "i = 0 -- contradictory".
    intros c st st' H. inversion H.

  Case "i = S i'".
    intros c st st' H.
    com_cases (destruct c) SCase;
           simpl in H; inversion H; subst; clear H.
      SCase "SKIP". apply E_Skip.
      SCase "::=". apply E_Ass. reflexivity.

      SCase ";;".
        destruct (ceval_step st c1 i') eqn:Heqr1.
        SSCase "Evaluation of r1 terminates normally".
          apply E_Seq with s.
            apply IHi'. rewrite Heqr1. reflexivity.
            apply IHi'. simpl in H1. assumption.
        SSCase "Otherwise -- contradiction".
          inversion H1.

      SCase "IFB".
        destruct (beval st b) eqn:Heqr.
        SSCase "r = true".
          apply E_IfTrue. rewrite Heqr. reflexivity.
          apply IHi'. assumption.
        SSCase "r = false".
          apply E_IfFalse. rewrite Heqr. reflexivity.
          apply IHi'. assumption.

      SCase "WHILE". destruct (beval st b) eqn :Heqr.
        SSCase "r = true".
         destruct (ceval_step st c i') eqn:Heqr1.
          SSSCase "r1 = Some s".
            apply E_WhileLoop with s. rewrite Heqr. reflexivity.
            apply IHi'. rewrite Heqr1. reflexivity.
            apply IHi'. simpl in H1. assumption.
          SSSCase "r1 = None".
            inversion H1.
        SSCase "r = false".
          inversion H1.
          apply E_WhileEnd.
          rewrite <- Heqr. subst. reflexivity.  Qed.

(** **** Exercise: 4 stars (ceval_step__ceval_inf)  *)
(** Write an informal proof of [ceval_step__ceval], following the
    usual template.  (The template for case analysis on an inductively
    defined value should look the same as for induction, except that
    there is no induction hypothesis.)  Make your proof communicate
    the main ideas to a human reader; do not simply transcribe the
    steps of the formal proof.

(* FILL IN HERE *)
[]
*)

Theorem ceval_step_more: forall i1 i2 st st' c,
  i1 <= i2 ->
  ceval_step st c i1 = Some st' ->
  ceval_step st c i2 = Some st'.
Proof.
induction i1 as [|i1']; intros i2 st st' c Hle Hceval.
  Case "i1 = 0".
    simpl in Hceval. inversion Hceval.
  Case "i1 = S i1'".
    destruct i2 as [|i2']. inversion Hle.
    assert (Hle': i1' <= i2') by omega.
    com_cases (destruct c) SCase.
    SCase "SKIP".
      simpl in Hceval. inversion Hceval.
      reflexivity.
    SCase "::=".
      simpl in Hceval. inversion Hceval.
      reflexivity.
    SCase ";;".
      simpl in Hceval. simpl.
      destruct (ceval_step st c1 i1') eqn:Heqst1'o.
      SSCase "st1'o = Some".
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      SSCase "st1'o = None".
        inversion Hceval.

    SCase "IFB".
      simpl in Hceval. simpl.
      destruct (beval st b); apply (IHi1' i2') in Hceval; assumption.

    SCase "WHILE".
      simpl in Hceval. simpl.
      destruct (beval st b); try assumption.
      destruct (ceval_step st c i1') eqn: Heqst1'o.
      SSCase "st1'o = Some".
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite -> Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      SSCase "i1'o = None".
        simpl in Hceval. inversion Hceval.  Qed.

(** **** Exercise: 3 stars (ceval__ceval_step)  *)
(** Finish the following proof.  You'll need [ceval_step_more] in a
    few places, as well as some basic facts about [<=] and [plus]. *)

Theorem ceval__ceval_step: forall c st st',
      c / st || st' ->
      exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st' Hce.
  ceval_cases (induction Hce) Case.
  (* FILL IN HERE *) Admitted.
(** [] *)

Theorem ceval_and_ceval_step_coincide: forall c st st',
      c / st || st'
  <-> exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st'.
  split. apply ceval__ceval_step. apply ceval_step__ceval.
Qed.

(* ####################################################### *)
(** * Determinism of Evaluation (Simpler Proof) *)

(** Here's a slicker proof showing that the evaluation relation is
    deterministic, using the fact that the relational and step-indexed
    definition of evaluation are the same. *)

Theorem ceval_deterministic' : forall c st st1 st2,
     c / st || st1  ->
     c / st || st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 He1 He2.
  apply ceval__ceval_step in He1.
  apply ceval__ceval_step in He2.
  inversion He1 as [i1 E1].
  inversion He2 as [i2 E2].
  apply ceval_step_more with (i2 := i1 + i2) in E1.
  apply ceval_step_more with (i2 := i1 + i2) in E2.
  rewrite E1 in E2. inversion E2. reflexivity.
  omega. omega.  Qed.

(** $Date: 2014-12-31 11:17:56 -0500 (Wed, 31 Dec 2014) $ *)


Inductive TreeF (A X : Type) : Type :=
| E : TreeF A X
| N : A -> TreeF A X -> X -> TreeF A X.

Arguments E {A X}.
Arguments N {A X} _ _ _.

CoInductive Tree (A : Type) : Type :=
{
  Out : TreeF A (Tree A);
}.

Arguments Out {A} _.

Fixpoint inums (n : nat) : TreeF nat (Tree nat) :=
match n with
| 0 => E
| S n' => N n' (inums n') {| Out := E |}
end.

CoFixpoint nums (n : nat) : Tree nat :=
{|
  Out := N n (inums n) (nums (S n));
|}.

Fixpoint leftmostF {A X : Type} (t : TreeF A X) : option A :=
match t with
| E => None
| N v l _ =>
        match leftmostF l with
        | None   => Some v
        | Some x => Some x
        end
end.

Definition leftmost {A : Type} (t : Tree A) : option A :=
match Out t with
| E => None
| N v l _ =>
  match leftmostF l with
  | None   => Some v
  | Some x => Some x
  end
end.

Definition leftmost' {A : Type} (t : Tree A) : option A :=
  leftmostF (Out t).

Lemma leftmost_leftmost' :
  forall {A : Type} (t : Tree A),
    leftmost t = leftmost' t.
Proof.
  destruct t as [[]]; cbn; reflexivity.
Qed.

Fixpoint mapF {A B X Y : Type} (f : A -> B) (g : X -> Y) (t : TreeF A X) {struct t} : TreeF B Y :=
match t with
| E       => E
| N x l r => N (f x) (mapF f g l) (g r)
end.

(* CoFixpoint map {A B : Type} (f : A -> B) (t : Tree A) : Tree B :=
{|
  Out :=
    match Out t with
    | E => E
    | N x l r => N (f x) (mapF f (map f) l) (map f r)
    end;
|}. *)

Fixpoint complete {A : Type} (n : nat) (x : A) (t : Tree A) : TreeF A (Tree A) :=
match n with
| 0    => E
| S n' => N x (complete n' x t) t
end.

Fail CoFixpoint complete' {A : Type} (n : nat) (x : A) : Tree A :=
{|
  Out :=
    N x
      ((fix aux (n : nat) : TreeF A (Tree A) :=
        match n with
        | 0 => E
        | S n' => N x (aux n') (complete' n x)
        end) n)
      (complete' n x);
|}.

From Typonomikon Require Import F2.

Fail Definition max (n : nat) (m : conat) : conat := max (from_nat n) m.

(* #
   Sprawdź to#. *)

(* Fixpoint max (n : nat) (m : conat) : conat :=
match n, out m with
| 0   , _ => m
| S n', S m' => S (max n' m')
 *)

(*Parameter elem : forall A : Type, A -> BTree A -> Prop.*)

(** Basic observers *)
(* Parameter isEmpty : forall A : Type, BTree A -> bool. *)

(* Parameter root : forall A : Type, BTree A -> option A. *)
(* Parameter left : forall A : Type, BTree A -> option (BTree A). *)
(* Parameter right : forall A : Type, BTree A -> option (BTree A). *)

(* Parameter unN : forall A : Type, BTree A -> option (A * BTree A * BTree A). *)

(*
CoFixpoint size {A : Type} (t : Tree A) : conat :=
{|
  out :=
    match Out t with
    | E => Z
    | N _ l r => S (size l) (size r)
    end;
|}.
*)

(* TODO: zdefiniować wincyj funkcji *)
(*
Parameter height : forall A : Type, BTree A -> nat.

Parameter rightmost : forall A : Type, BTree A -> option A.

Parameter inorder : forall A : Type, BTree A -> list A.
Parameter preorder : forall A : Type, BTree A -> list A.
Parameter postorder : forall A : Type, BTree A -> list A.

Parameter bfs_aux :
  forall A : Type, list (BTree A) -> list A -> list A.

Parameter bfs : forall A : Type, BTree A -> list A.

(** Basic operations *)
Parameter mirror' : forall A : Type, BTree A -> BTree A.

Fixpoint mirror {A : Type} (t : BTree A) : BTree A :=
match t with
| E => E
| N v l r => N v (mirror r) (mirror l)
end.

(*
From Typonomikon Require Import H2.

Lemma mirror_bijective :
  forall A : Type, bijective (@mirror A).
Proof.
  unfold bijective, injective, surjective. split.
    induction x; destruct x'; cbn; inversion 1; subst; clear H.
      reflexivity.
      rewrite (IHx1 _ H3), (IHx2 _ H2). reflexivity.
    induction b.
      exists E. cbn. reflexivity.
      destruct IHb1 as [r Hr], IHb2 as [l Hl].
        exists (N a l r). cbn. rewrite Hl, Hr. reflexivity.
Qed.
*)

Parameter iterate : forall A : Type, (A -> A) -> nat -> A -> BTree A.

Parameter index : forall A : Type, list bool -> BTree A -> option A.
Parameter nth : forall A : Type, nat -> BTree A -> option A.

Parameter take : forall A : Type, nat -> BTree A -> BTree A.
Parameter drop : forall A : Type, nat -> BTree A -> list (BTree A).
Parameter takedrop :
  forall A : Type, nat -> BTree A -> BTree A * list (BTree A).

Parameter intersperse : forall A : Type, A -> BTree A -> BTree A.

Parameter insertAtLeaf :
  forall A : Type, list bool -> BTree A -> BTree A.

(** Operacje z predykatem boolowskim. *)
Parameter any : forall A : Type, (A -> bool) -> BTree A -> bool.
Parameter all : forall A : Type, (A -> bool) -> BTree A -> bool.

Parameter find : forall A : Type, (A -> bool) -> BTree A -> option A.
Parameter findIndex :
  forall A : Type, (A -> bool) -> BTree A -> option (list bool).

Parameter count : forall A : Type, (A -> bool) -> BTree A -> nat.

Parameter takeWhile : forall A : Type, (A -> bool) -> BTree A -> BTree A.

Parameter findIndices :
  forall A : Type, (A -> bool) -> BTree A -> list (list bool).

(** Operacje z funkcją. *)
Parameter map : forall A B : Type, (A -> B) -> BTree A -> BTree B.

Parameter zipWith :
  forall A B C : Type, (A -> B -> C) -> BTree A -> BTree B -> BTree C.

Parameter unzipWith :
 forall A B C : Type, (A -> B * C) -> BTree A -> BTree B * BTree C.

(** foldy i scany *)

(** Predykaty *)

Parameter Elem : forall A : Type, A -> BTree A -> Prop.

Parameter Any : forall A : Type, (A -> Prop) -> BTree A -> Prop.
Parameter All : forall A : Type, (A -> Prop) -> BTree A -> Prop.

Parameter Dup : forall A : Type, BTree A -> Prop.

Parameter Exactly : forall A : Type, (A -> Prop) -> nat -> BTree A -> Prop.
Parameter AtLeast : forall A : Type, (A -> Prop) -> nat -> BTree A -> Prop.
Parameter AtMost : forall A : Type, (A -> Prop) -> nat -> BTree A -> Prop.

Parameter SameStructure : forall A B : Type, BTree A -> BTree B -> Prop.
Parameter SameShape : forall A B : Type, BTree A -> BTree B -> Prop.

Parameter subtree : forall A : Type, BTree A -> BTree A -> Prop.
Parameter Subterm : forall A : Type, BTree A -> BTree A -> Prop.
*)


(** Borrowed from Pierce's "Software Foundations" *)

Require Import Arith Arith.EqNat.
Require Import Omega.

Inductive id : Type :=
  Id : nat -> id.

Reserved Notation "m <<= n" (at level 70, no associativity).
Reserved Notation "m >>  n" (at level 70, no associativity).
Reserved Notation "m <<  n" (at level 70, no associativity).

Inductive le_id : id -> id -> Prop :=
  le_conv : forall n m, n <= m -> (Id n) <<= (Id m)
where "n <<= m" := (le_id n m).

Inductive lt_id : id -> id -> Prop :=
  lt_conv : forall n m, n < m -> (Id n) << (Id m)
where "n << m" := (lt_id n m).

Inductive gt_id : id -> id -> Prop :=
  gt_conv : forall n m, n > m -> (Id n) >> (Id m)
where "n >> m" := (gt_id n m).

Notation "n <<= m" := (le_id n m).
Notation "n >>  m" := (gt_id n m).
Notation "n <<  m" := (lt_id n m).

Lemma lt_eq_lt_id_dec: forall (id1 id2 : id), {id1 << id2} + {id1 = id2} + {id2 << id1}.
Proof.
  intros.
  destruct id1, id2.
  (* or intros [n] [m] *)

  remember (lt_eq_lt_dec n n0).
  destruct s. destruct s.
  - left. left. constructor. assumption.
  - left. right. rewrite e. reflexivity.
  - right. constructor. assumption.
Qed.

(**  SearchAbout nat. *)

Lemma gt_eq_gt_id_dec: forall (id1 id2 : id), {id1 >> id2} + {id1 = id2} + {id2 >> id1}.
Proof.
  intros.
  destruct id1, id2.
  remember (lt_eq_lt_dec n n0).
  destruct s. destruct s.
  - right. constructor. assumption.
  - left. right. rewrite e. reflexivity.
  - left. left. constructor. assumption.
Qed.

Lemma le_gt_id_dec : forall id1 id2 : id, {id1 <<= id2} + {id1 >> id2}.
Proof.
  intros.
  destruct id1, id2.
  remember (le_gt_dec n n0).
  destruct s.
  - left. constructor. assumption.
  - right. constructor. assumption.
Qed.

Lemma eq_dec : forall n m : nat, {n = m} + {n <> m}.
Proof.
  intros n.
  induction n. intros.
  - destruct m as [|m]. auto. auto.
  - destruct m as [|m]. auto.
    destruct (IHn m). auto. auto.
Qed.

Lemma eq_id_dec : forall id1 id2 : id, {id1 = id2} + {id1 <> id2}.
Proof.
  intros.
  destruct id1, id2.
  remember (eq_dec n n0).
  destruct s.
  - auto.
  - right. unfold not in *. intro. inversion H. contradiction.
Qed.

Lemma eq_id : forall (T:Type) x (p q:T), (if eq_id_dec x x then p else q) = p.
Proof.
  intros.
  destruct (eq_id_dec x x); tauto.
Qed.

Lemma neq_id : forall (T:Type) x y (p q:T), x <> y -> (if eq_id_dec x y then p else q) = q.
Proof.
  intros.
  destruct (eq_id_dec x y); tauto.
Qed.

Lemma lt_gt_id_false : forall id1 id2 : id, id1 >> id2 -> id2 >> id1 -> False.
Proof.
  intros.
  destruct id1, id2.
  inversion_clear H.
  inversion_clear H0.
  omega.
Qed.

Lemma le_gt_id_false : forall id1 id2 : id, id2 <<= id1 -> id2 >> id1 -> False.
Proof.
  intros.
  destruct id1, id2.
  inversion_clear H.
  inversion_clear H0.
  omega.
Qed.

Lemma le_lt_eq_id_dec : forall id1 id2 : id, id1 <<= id2 -> {id1 = id2} + {id2 >> id1}.
Proof.
  intros.
  destruct id1, id2.
  remember (le_lt_eq_dec n n0).
  destruct s.
  - inversion_clear H. auto.
  - right. constructor. auto.
  - left. rewrite e. auto.
Qed.

Lemma neq_lt_gt_id_dec : forall id1 id2 : id, id1 <> id2 -> {id1 >> id2} + {id2 >> id1}.
Proof.
  intros.
  remember (gt_eq_gt_id_dec id1 id2).
  destruct s. destruct s.
  auto.
  tauto.
  auto.
Qed.

Lemma eq_gt_id_false : forall id1 id2 : id, id1 = id2 -> id1 >> id2 -> False.
Proof.
  intros.
  destruct id1, id2.
  inversion_clear H0.
  inversion H.
  omega.
Qed.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial ssralg finset fingroup finalg.
From mathcomp Require Import matrix.
Require Import Reals Fourier.
Require Import Rssr Reals_ext log2 ssr_ext ssralg_ext tuple_prod.

Local Open Scope reals_ext_scope.

(** * Instantiation of canonical big operators with Coq reals *)

Lemma iter_Rplus n r : ssrnat.iter n (Rplus r) 0 = INR n * r.
Proof.
elim : n r => [r /= | m IHm r]; first by rewrite mul0R.
rewrite iterS IHm S_INR; field.
Qed.

Lemma iter_Rmult n p : ssrnat.iter n (Rmult p) 1 = p ^ n.
Proof. elim : n p => // n0 IH p0 /=; by rewrite IH. Qed.

Lemma morph_Ropp : {morph [eta Ropp] : x y / x + y}.
Proof. by move=> x y /=; field. Qed.

Lemma morph_plus_INR : {morph INR : x y / (x + y)%nat >-> x + y}.
Proof. move=> x y /=; by rewrite plus_INR. Qed.

Lemma morph_mult_INR : {morph INR : x y / (x * y)%nat >-> x * y}.
Proof. move=> x y /=; by rewrite mult_INR. Qed.

Lemma morph_mulRDr a : {morph [eta Rmult a] : x y / x + y}.
Proof. move=> * /=; by rewrite mulRDr. Qed.

Lemma morph_mulRDl a : {morph Rmult^~ a : x y / x + y}.
Proof. move=> x y /=; by rewrite mulRDl. Qed.

Lemma morph_exp2_plus : {morph [eta exp2] : x y / x + y >-> x * y}.
Proof. move=> ? ? /=; by rewrite -exp2_plus. Qed.

Section Abelian.

Variable op : Monoid.com_law 1.

Notation Local "'*%M'" := op (at level 0).
Notation Local "x * y" := (op x y).

Lemma mybig_index_uniq (I : eqType) (i : R) (r : seq I) (E : 'I_(size r) -> R) :
  uniq r ->
  \big[*%M/1]_i E i = \big[*%M/1]_(x <- r) oapp E i (insub (seq.index x r)).
Proof.
move=> Ur.
apply/esym.
rewrite big_tnth.
apply: eq_bigr => j _.
by rewrite index_uniq // valK.
Qed.

End Abelian.

(** Instantiation of big sums for reals *)

Canonical addR_monoid := Monoid.Law addRA add0R addR0.
Canonical addR_comoid := Monoid.ComLaw addRC.
Canonical mulR_monoid := Monoid.Law mulRA mul1R mulR1.
Canonical mulR_muloid := Monoid.MulLaw mul0R mulR0.
Canonical mulR_comoid := Monoid.ComLaw mulRC.
Canonical addR_addoid := Monoid.AddLaw mulRDl mulRDr.

Notation "\rsum_ ( i <- t ) F" := (\big[Rplus/0%R]_( i <- t) F)
  (at level 41, F at level 41, i at level 50,
    format "'[' \rsum_ ( i <- t ) '/  '  F ']'") : R_scope.
Notation "\rsum_ ( m <= i < n ) F" := (\big[Rplus/0%R]_( m <= i < n ) F)
  (at level 41, F at level 41, i, m, n at level 50,
    format "'[' \rsum_ ( m  <=  i  <  n ) '/  '  F ']'") : R_scope.
Notation "\rsum_ ( i | P ) F" := (\big[Rplus/0%R]_( i | P) F)
  (at level 41, F at level 41, i at level 50,
    format "'[' \rsum_ ( i  |  P ) '/  '  F ']'") : R_scope.
Notation "\rsum_ ( i ':' A | P ) F" := (\big[Rplus/0%R]_( i : A | P ) F)
  (at level 41, F at level 41, i, A at level 50,
           format "'[' \rsum_ ( i  ':'  A  |  P ) '/  '  F ']'") : R_scope.
Notation "\rsum_ ( i : t ) F" := (\big[Rplus/0%R]_( i : t) F)
  (at level 41, F at level 41, i at level 50,
    format "'[' \rsum_ ( i : t ) '/  '  F ']'") : R_scope.
Notation "\rsum_ ( i < n ) F" := (\big[Rplus/0%R]_( i < n ) F)
  (at level 41, F at level 41, i at level 50,
    format "'[' \rsum_ ( i < n ) '/  '  F ']'") : R_scope.
Notation "\rsum_ ( i 'in' A | P ) F" := (\big[Rplus/0%R]_( i in A | P ) F)
  (at level 41, F at level 41, i, A at level 50,
           format "'[' \rsum_ ( i  'in'  A  |  P ) '/  '  F ']'") : R_scope.
Notation "\rsum_ ( a 'in' A ) F" := (\big[Rplus/0%R]_( a in A ) F)
  (at level 41, F at level 41, a, A at level 50,
    format "'[' \rsum_ ( a  'in'  A ) '/  '  F ']'") : R_scope.

Lemma big_Rabs {A : finType} F : Rabs (\rsum_ (a : A) F a) <= \rsum_ (a : A) Rabs (F a).
Proof.
elim: (index_enum _) => [| hd tl IH].
  rewrite 2!big_nil Rabs_R0; by apply Rle_refl.
rewrite 2!big_cons.
apply (Rle_trans _ (Rabs (F hd) + Rabs (\rsum_(j <- tl) F j))); first by apply Rabs_triang.
by apply Rplus_le_compat_l.
Qed.

Lemma classify_big {T : finType} k (f : T -> 'I_k) (F : 'I_k -> R) :
  \rsum_(s : T) F (f s) = \rsum_(n : 'I_k) INR #|f @^-1: [set n]| * F n.
Proof.
transitivity (\rsum_(n<k) \rsum_(s | true && (f s == n)) F (f s)).
  by apply partition_big.
apply eq_bigr => i _ /=.
transitivity (\rsum_(s|f s == i) F i).
  by apply eq_bigr => s /eqP ->.
rewrite big_const iter_Rplus.
do 2 f_equal.
apply eq_card => j /=.
by rewrite !inE.
Qed.

(** Rle, Rlt lemmas for big sums of reals *)

Section Rcomparison_rsum.

Variable A : finType.
Variables f g : A -> R.
Variable P Q : pred A.

Lemma Rle_big_P_f_g_X (X : {set A}) : (forall i, i \in X -> P i -> f i <= g i) ->
  \rsum_(i in X | P i) f i <= \rsum_(i in X | P i) g i.
Proof.
move=> H.
elim: (index_enum _) => [| hd tl IH].
- rewrite !big_nil; by apply Rle_refl.
- rewrite !big_cons.
  set cond := _ && _; move Hcond : cond => []; subst cond => //.
  apply Rplus_le_compat => //.
  case/andP : Hcond.
  by apply H.
Qed.

Lemma Rle_big_P_f_g : (forall i, P i -> f i <= g i) ->
  \rsum_(i | P i) f i <= \rsum_(i | P i) g i.
Proof.
move=> H.
elim: (index_enum _) => [| hd tl IH].
- rewrite !big_nil; by apply Rle_refl.
- rewrite !big_cons.
  case: ifP => Hcase //.
  apply Rplus_le_compat => //.
  by apply H.
Qed.

Lemma Rlt_big_f_g_X (X : {set A}) : forall (HA: (0 < #|X|)%nat),
  (forall i, i \in X -> f i < g i) ->
  \rsum_(i in X) f i < \rsum_(i in X) g i.
Proof.
move Ha : #|X| => a.
move: a X Ha.
elim => // a IHa X Ha _ H.
move: (ltn0Sn a). rewrite -Ha card_gt0. case/set0Pn => a0 Ha0.
rewrite (@big_setD1 _ _ _ _ a0 _ f) //= (@big_setD1 _ _ _ _ a0 _ g) //=.
case: a IHa Ha => IHa Ha.
  rewrite (_ : X :\ a0 = set0); last first.
    rewrite (cardsD1 a0) Ha0 /= add1n in Ha.
    case: Ha.
    move/eqP.
    rewrite cards_eq0.
    by move/eqP.
  rewrite !big_set0 2!addR0; by apply H.
move=> HA.
apply Rplus_lt_compat.
  by apply H.
apply Ha => //.
  rewrite (cardsD1 a0) Ha0 /= add1n in HA.
  by case: HA.
move=> i Hi.
rewrite in_setD in Hi.
case/andP : Hi => Hi1 Hi2.
by apply H.
Qed.

Lemma Rle_big_P_Q_f_g : (forall i, P i -> f i <= g i) ->
  (forall i, Q i -> 0 <= g i) ->
  (forall i, P i -> Q i) ->
  \rsum_(i | P i) f i <= \rsum_(i | Q i) g i.
Proof.
move=> f_g Qg H.
elim: (index_enum _) => [| hd tl IH].
- rewrite !big_nil; by apply Rle_refl.
- rewrite !big_cons /=.
  case: ifP => Hcase.
    rewrite (H _ Hcase).
    apply Rplus_le_compat => //.
    by apply f_g.
  case: ifP => // Qhd.
  apply Rle_trans with (\big[Rplus/0]_(j <- tl | Q j) g j).
    by apply IH.
  rewrite -{1}(add0R (\big[Rplus/0]_(j <- tl | Q j) g j)).
  by apply Rplus_le_compat_r, Qg.
Qed.

Lemma Rle_big_P_true_f_g : (forall a, 0 <= g a) ->
  (forall i, i \in P -> f i <= g i) ->
  \rsum_(i in A | P i) f i <= \rsum_(i in A) g i.
Proof.
move=> K H.
elim: (index_enum _) => [| hd tl IH].
- rewrite !big_nil; by apply Rle_refl.
- rewrite !big_cons.
  case/orP : (orbN (hd \in A)) => H1.
    rewrite H1 /=.
    case: ifP => Hif.
      apply Rplus_le_compat => //.
      by apply H.
    rewrite -[X in X <= _]add0R.
    by apply Rplus_le_compat.
  rewrite (negbTE H1) /=; exact IH.
Qed.

Lemma Rle_big_f_X_Y : (forall a, 0 <= f a) ->
  (forall i, i \in P -> i \in Q) ->
  \rsum_(i in P) f i <= \rsum_(i in Q) f i.
Proof.
move=> Hf P'_P.
elim: (index_enum _) => [| hd tl IH].
- rewrite !big_nil; by apply Rle_refl.
- rewrite !big_cons.
  set cond := _ \in _; move Hcond : cond => []; subst cond => //=.
    rewrite (P'_P _ Hcond).
    by apply Rplus_le_compat_l.
  set cond := _ \in _; move Hcond2 : cond => []; subst cond => //=.
  rewrite -[X in X <= _]add0R.
  by apply Rplus_le_compat.
Qed.

Lemma Rle_big_P_Q_f_X (X : pred A) :
  (forall a, 0 <= f a) -> (forall i, P i -> Q i) ->
  \rsum_(i in X | P i) f i <= \rsum_(i in X | Q i) f i.
Proof.
move=> Hf P_Q.
elim: (index_enum _) => [| hd tl IH].
- rewrite !big_nil; by apply Rle_refl.
- rewrite !big_cons.
  set cond := _ \in _; move Hcond : cond => []; subst cond => //=.
  case: ifP => // HP.
  + case: ifP => HQ.
    * by apply Rplus_le_compat_l.
    * by rewrite (P_Q _ HP) in HQ.
  + case: ifP => // HQ.
    rewrite -[X in X <= _]add0R.
    by apply Rplus_le_compat.
Qed.

Lemma Rle_big_predU_f : (forall a, 0 <= f a) ->
  \rsum_(i in A | [predU P & Q] i) f i <=
  \rsum_(i in A | P i) f i + \rsum_(i in A | Q i) f i.
Proof.
move=> Hf.
elim: (index_enum _) => //.
- rewrite !big_nil /=; fourier.
- move=> h t IH /=.
  rewrite !big_cons /=.
  case: ifP => /=.
  + case/orP => [HP1 | HP2].
    * rewrite unfold_in in HP1.
      rewrite HP1.
      case: ifP => // HP2.
      - rewrite -addRA; apply Rplus_le_compat_l.
        eapply Rle_trans; first by apply IH.
        have : forall a b c, 0 <= c -> a + b <= a + (c + b) by move=> *; fourier.
        apply.
        by apply Hf.
      - rewrite -addRA; apply Rplus_le_compat_l.
        eapply Rle_trans; first by apply IH.
        by apply Req_le.
    * rewrite unfold_in in HP2.
      rewrite HP2.
      case: ifP => // HP1.
      - rewrite -addRA; apply Rplus_le_compat_l.
        eapply Rle_trans; first by apply IH.
        have : forall a b c, 0 <= c -> a + b <= a + (c + b) by move=> *; fourier.
        apply.
        by apply Hf.
      - rewrite -(Rplus_comm (f h + _)) -addRA; apply Rplus_le_compat_l.
        eapply Rle_trans; first by apply IH.
        by rewrite Rplus_comm; apply Req_le.
  + move/negbT.
    rewrite negb_or.
    case/andP.
    rewrite unfold_in; move/negbTE => ->.
    rewrite unfold_in; move/negbTE => ->.
    by apply IH.
Qed.

Lemma Rle_big_P_true_f : (forall i : A, 0 <= f i) ->
  \rsum_(i in A | P i) f i <= \rsum_(i in A) f i.
Proof.
move=> H.
elim: (index_enum _) => [| hd tl IH].
- rewrite !big_nil; by apply Rle_refl.
- rewrite !big_cons.
  case/orP : (orbN (P hd)) => P_hd.
  + rewrite P_hd /=.
    apply Rplus_le_compat => //; by apply Rle_refl.
  + rewrite (negbTE P_hd) inE /= -[X in X <= _]add0R; by apply Rplus_le_compat.
Qed.

End Rcomparison_rsum.

Lemma Rlt_big_0_g (A : finType) (g : A -> R) (HA : (0 < #|A|)%nat) :
  (forall i, 0 < g i) -> 0 < \rsum_(i in A) g i.
Proof.
move=> H.
rewrite (_ : \rsum_(i in A) g i = \rsum_(i in [set: A]) g i); last first.
  apply eq_bigl => x /=; by rewrite !inE.
eapply Rle_lt_trans; last first.
  apply Rlt_big_f_g_X with (f := fun x => 0) => //.
  by rewrite cardsT.
rewrite big_const_seq iter_Rplus mulR0; by apply Rle_refl.
Qed.

Lemma Rle_big_0_P_g (A : finType) (P : pred A) (g : A -> R) :
  (forall i, P i -> 0 <= g i) -> 0 <= \rsum_(i in A | P i) g i.
Proof.
move=> H.
apply Rle_trans with (\rsum_(i|(i \in A) && P i) (fun x => 0) i).
rewrite big_const iter_Rplus mulR0 /=; by apply Rle_refl.
by apply Rle_big_P_f_g.
Qed.

Lemma Rle_big_P_Q_f_X_new {A : finType} (f : A -> R) (P Q : pred A) :
  (forall a, 0 <= f a) -> (forall i, P i -> Q i) ->
  \rsum_(i | P i) f i <= \rsum_(i | Q i) f i.
Proof.
move=> Hf R_T.
eapply Rle_trans; last by apply (Rle_big_P_Q_f_X A f P Q xpredT).
by apply Req_le.
Qed.

Lemma Req_0_rmul_inv' {A : finType} (f : A -> R) (P Q : pred A) : (forall i, 0 <= f i) ->
  forall j, P j -> f j <= \rsum_(i | P i) f i.
Proof.
move=> HF j Hj.
rewrite (_ : f j = \rsum_(i | i == j) f i); last by rewrite big_pred1_eq.
apply: Rle_big_P_Q_f_X_new => //.
move=> i /eqP ?; by subst j.
Qed.

Lemma Req_0_rmul_inv {C : finType} (R : pred C) F (HF : forall a, 0 <= F a) :
  0 = \rsum_(i | R i) F i -> (forall i, R i -> 0 = F i).
Proof.
move=> abs i Hi.
case/Rle_lt_or_eq_dec : (HF i) => // Fi.
suff : False by done.
have : F i <= \rsum_(i|R i) F i.
  by apply Req_0_rmul_inv'.
rewrite -abs => ?.
fourier.
Qed.

(* old lemmas that better not be used *)
Section old.

Lemma Req_0_rmul {C : finType} (R : pred C) F:
  (forall i, R i -> 0 = F i) ->
  0 = \rsum_(i | R i) F i.
Proof.
move=> HF.
rewrite (eq_bigr (fun=> 0)); first by rewrite big_const iter_Rplus mulR0.
move=> i Ri; by rewrite -HF.
Qed.

End old.

Lemma psumR_eq0P {B : finType} (g : B -> R) (U : pred B) :
  \rsum_(i|U i) g i = 0 ->
  (forall i : B, U i -> 0 <= g i) ->
  (forall i : B, U i -> g i = 0).
Proof.
move=> H2 H1 i Hi.
suff H : g i = 0 /\ (\rsum_(j|(U j && (j != i))) g j) = 0 by case: H.
apply Rplus_eq_R0.
- apply H1 ; exact Hi.
- apply: Rle_big_0_P_g => i0 Hi0; apply H1.
  move/andP in Hi0; by apply Hi0.
- rewrite -bigD1 /=; [exact H2 | exact Hi].
Qed.

Lemma rsum_neq0 {A : finType} (P : {set A}) (g : A -> R) :
  \rsum_(t | t \in P) g t != 0 -> [exists t, (t \in P) && (g t != 0)].
Proof.
move=> H1.
apply negbNE.
rewrite negb_exists.
apply/negP => /forallP abs.
move/negP : H1; apply.
rewrite big_mkcond /=.
apply/eqP.
transitivity (\rsum_(a : A) 0); last by rewrite big_const iter_Rplus mulR0.
apply eq_bigr => a _.
case: ifP => // Hcond.
move: (abs a); by rewrite Hcond /= negbK => /eqP.
Qed.

(* TODO: factorize? *)
Lemma Rle_big_eq (B : finType) (f g : B -> R) (U : pred B) :
   (forall i : B, U i -> f i <= g i) ->
   \rsum_(i|U i) g i = \rsum_(i|U i) f i ->
   (forall i : B, U i -> g i = f i).
Proof.
move=> H1 H2 i Hi.
apply (Rplus_eq_reg_l (- (f i))).
rewrite Rplus_opp_l Rplus_comm.
move: i Hi.
apply psumR_eq0P.
- rewrite big_split /= -(big_morph _ morph_Ropp Ropp_0).
  by apply Rminus_diag_eq, H2.
- move=> i Hi.
  apply (Rplus_le_reg_l (f i)).
  rewrite addR0 subRKC; by apply H1.
Qed.

(* TODO: generalize to any bigop *)
Lemma rsum_union {C : finType} (B1 B2 B : {set C}) f :
  [disjoint B2 & B1] ->
  B = B1 :|: B2 ->
  \rsum_(b | b \in B) f b =
  \rsum_(b | b \in B1) f b + \rsum_(b | b \in B2) f b.
Proof.
move=> Hdisj ->.
rewrite (@big_setID _ _ _ _ _ B1) /= setUK setDUl setDv set0U.
suff : B2 :\: B1 = B2 by move=> ->.
by apply/setDidPl.
Qed.

(** Big sums lemmas for products *)

Section big_sums_prods.

Variables A B : finType.

Lemma pair_big_fst : forall (F : {: A * B} -> R) P Q,
  P =1 Q \o (fun x => x.1) ->
  \rsum_(i in A | Q i) \rsum_(j in B) (F (i, j)) = \rsum_(i in {: A * B} | P i) F i.
Proof.
move=> /= F Q' Q Q'Q; rewrite pair_big /=.
apply eq_big.
- case=> /= i1 i2; by rewrite inE andbC Q'Q.
- by case.
Qed.

Lemma pair_big_snd : forall (F : {: A * B} -> R) P Q,
  P =1 Q \o (fun x => x.2) ->
  \rsum_(i in A) \rsum_(j in B | Q j) (F (i, j)) = \rsum_(i in {: A * B} | P i) F i.
Proof.
move=> /= F Q' Q Q'Q; rewrite pair_big /=.
apply eq_big.
- case=> /= i1 i2; by rewrite Q'Q.
- by case.
Qed.

End big_sums_prods.

(** Switching from a sum on the domain to a sum on the image of function *)

Section sum_dom_codom.

Variable A : finType.

Lemma sum_parti (p : seq A) (X : A -> R) : forall F, uniq p ->
  \rsum_(i <- p) (F i) =
  \rsum_(r <- undup (map X p)) \big[Rplus/0]_(i <- p | X i == r) (F i).
Proof.
move Hn : (undup (map X (p))) => n.
move: n p X Hn.
elim => [p X HA F Hp | h t IH p X H F Hp].
- rewrite big_nil.
  move/undup_nil_inv : HA.
  move/map_nil_inv => ->.
  by rewrite big_nil.
- rewrite big_cons.
  have [preh [pret [H1 [H2 H3]]]] : exists preh pret,
    perm_eq p (preh ++ pret) /\ undup (map X preh) = [:: h] /\ undup (map X pret) = t.
    by apply undup_perm.
  apply trans_eq with (\big[Rplus/0]_(i <- preh ++ pret) F i).
    by apply: eq_big_perm.
  apply trans_eq with
   (\big[Rplus/0]_(i <- preh ++ pret | X i == h) F i +
   \rsum_(j <- t) \big[Rplus/0]_(i <- preh ++ pret | X i == j) F i); last first.
    f_equal.
    apply: eq_big_perm.
      by rewrite perm_eq_sym.
    apply eq_bigr => i _ /=.
    apply: eq_big_perm.
    by rewrite perm_eq_sym.
  have -> :
    \rsum_(j <- t) \big[Rplus/0]_(i <- (preh ++ pret) | X i == j) F i =
    \rsum_(j <- t) \big[Rplus/0]_(i <- pret | X i == j) F i.
    rewrite big_seq_cond.
    symmetry.
    rewrite big_seq_cond /=.
    apply eq_bigr => i Hi.
    rewrite big_cat /=.
    have -> : \big[Rplus/0]_(i0 <- preh | X i0 == i) F i0 = 0.
      transitivity (\big[Rplus/0]_(i0 <- preh | false) F i0).
      rewrite big_seq_cond.
      apply eq_bigl => /= j.
      apply/negP.
      case/andP; move=> Xj_i; move/eqP=> j_preh.
      subst i.
      have Xj_h : X j \in [:: h].
        have H4 : X j \in map X preh by apply/mapP; exists j.
        have H5 : X j \in undup (map X preh)  by rewrite mem_undup.
        by rewrite H2 in H5.
      have : uniq (h :: t).
        rewrite -H.
        apply undup_uniq.
        rewrite /= in_cons in_nil orbC /= in Xj_h.
        move/eqP : Xj_h => Xj_h.
        subst h.
        rewrite andbC /= in Hi.
        by rewrite /= Hi.
      by rewrite big_pred0.
      by rewrite add0R.
  rewrite -IH //; last first.
    have : uniq (preh ++ pret) by rewrite -(@perm_eq_uniq _ _ _ H1).
    rewrite cat_uniq.
    case/andP => _; by case/andP.
  have -> :  \big[Rplus/0]_(i <- (preh ++ pret) | X i == h) F i =
    \rsum_(i <- preh) F i.
    rewrite big_cat /=.
    have -> : \big[Rplus/0]_(i <- pret | X i == h) F i = 0.
      transitivity (\big[Rplus/0]_(i0 <- pret | false) F i0); last first.
        by rewrite big_pred0.
      rewrite big_seq_cond.
      apply eq_bigl => /= j.
      apply/negP.
      case/andP; move => j_pret; move/eqP => Xj_h.
      subst h.
      have Xj_t : X j \in t.
        have H4 : X j \in map X pret.
        apply/mapP; by exists j.
        have H5 : X j \in undup (map X pret).
        by rewrite mem_undup.
        by rewrite H3 in H5.
      have : uniq (X j :: t).
        rewrite -H.
        by apply undup_uniq.
      by rewrite /= Xj_t.
    rewrite addR0 big_seq_cond /=.
    symmetry.
    rewrite big_seq_cond /=.
    apply congr_big => //= x.
    case/orP : (orbN (x \in preh)) => Y.
    + rewrite Y /=.
      symmetry.
      have : X x \in [:: h].
        rewrite -H2 mem_undup.
        apply/mapP.
        by exists x.
      by rewrite in_cons /= in_nil orbC.
    + by rewrite (negbTE Y) andbC.
  by rewrite big_cat.
Qed.

(* NB: use finset.partition_big_imset? *)
Lemma sum_parti_finType (X : A -> R) F :
   \rsum_(i in A) (F i) =
   \rsum_(r <- undup (map X (enum A))) \big[Rplus/0]_(i in A | X i == r) (F i).
Proof.
move: (@sum_parti (enum A) X F) => /=.
rewrite enum_uniq.
move/(_ (refl_equal _)) => IH.
transitivity (\big[Rplus/0]_(i <- enum A) F i).
  apply congr_big => //.
  by rewrite enumT.
rewrite IH.
apply eq_bigr => i _.
apply congr_big => //.
by rewrite enumT.
Qed.

End sum_dom_codom.

Local Open Scope R_scope.

Section tmp.

Local Open Scope ring_scope.

(* TODO: rename? *)
Lemma rsum_rV_prod (C D : finType) n f (Q : {set 'rV_n}) :
  \rsum_(a in 'rV[C * D]_n | a \in Q) f a =
  \rsum_(a in {: 'rV[C]_n * 'rV[D]_n} | (prod_tuple a) \in Q) f (prod_tuple a).
Proof.
rewrite (reindex_onto (fun p => tuple_prod p) (fun y => prod_tuple y)) //=; last first.
  move=> i _; by rewrite prod_tupleK.
apply eq_big => /=.
  move=> t /=.
  by rewrite tuple_prodK eqxx andbC.
move=> i _; by rewrite tuple_prodK.
Qed.

(*Lemma rsum_rV_prod (A B : finType) n f P :
  \rsum_(a in 'rV[A * B]_n | P a) f a =
  \rsum_(a in {: 'rV[A]_n * 'rV[B]_n} | P (prod_tuple a)) f (prod_tuple a).
Proof.
rewrite (reindex_onto (fun p => tuple_prod p) (fun y => prod_tuple y)) //=; last first.
  move=> i _; by rewrite prod_tupleK.
apply eq_big => /=.
  move=> t /=.
  by rewrite tuple_prodK eqxx andbC.
move=> i _; by rewrite tuple_prodK.
Qed.*)

End tmp.

(*Lemma rsum_tuple_prod (A B : finType) n f P :
  \rsum_(a in {:n.-tuple (A * B)%type} | P a) f a =
  \rsum_(a in {: n.-tuple A * n.-tuple B} | P (tuple_prod.prod_tuple a)) f (tuple_prod.prod_tuple a).
Proof.
rewrite (reindex_onto (fun p => tuple_prod.tuple_prod p) (fun y => tuple_prod.prod_tuple y)) //=; last first.
  move=> i _; by rewrite tuple_prod.prod_tupleK.
apply eq_big => /=.
  move=> t /=.
  by rewrite tuple_prod.tuple_prodK eqxx andbC.
move=> i _; by rewrite tuple_prod.tuple_prodK.
Qed.

Lemma rsum_tuple_prod_set (A B : finType) n f (P : {set {:n.-tuple (A * B)}}) :
  \rsum_(a in {:n.-tuple (A * B)%type} | a \in P) f a =
  \rsum_(a in {: n.-tuple A * n.-tuple B} | (tuple_prod.prod_tuple a) \in P) f (tuple_prod.prod_tuple a).
Proof.
rewrite (reindex_onto (fun p => tuple_prod.tuple_prod p) (fun y => tuple_prod.prod_tuple y)) //=; last first.
  move=> i _; by rewrite tuple_prod.prod_tupleK.
apply eq_big => /=.
  move=> t /=.
  by rewrite tuple_prod.tuple_prodK eqxx andbC.
move=> i _; by rewrite tuple_prod.tuple_prodK.
Qed.
*)

Section big_sum_rV.

Context {A : finType}.

Local Open Scope vec_ext_scope.
Local Open Scope ring_scope.

Lemma rsum_rV_1 F G P Q :
  (forall i : 'rV[A]_1, F i = G (i ``_ ord0)) ->
  (forall i : 'rV[A]_1, P i = Q (i ``_ ord0)) ->
  \rsum_(i in 'rV[A]_1 | P i) F i = \rsum_(i in A | Q i) G i.
Proof.
move=> FG PQ.
rewrite (reindex_onto (fun i => \row_(j < 1) i) (fun p => p ``_ ord0)) /=; last first.
  move=> m Pm.
  apply/matrixP => a b; rewrite {a}(ord1 a) {b}(ord1 b); by rewrite mxE.
apply eq_big => a.
  by rewrite PQ mxE eqxx andbT.
by rewrite FG !mxE.
Qed.

End big_sum_rV.

Section big_sums_rV.

Variable A : finType.

Lemma rsum_0rV F Q :
  \rsum_( j in 'rV[A]_0 | Q j) F j = if Q (row_of_tuple [tuple]) then F (row_of_tuple [tuple]) else 0.
Proof.
rewrite -big_map /= /index_enum -enumT.
rewrite (_ : enum (matrix_finType A 1 0) = row_of_tuple ([tuple]) :: [::]).
by rewrite /= big_cons big_nil addR0.
apply eq_from_nth with (row_of_tuple [tuple]) => /=.
by rewrite size_tuple card_matrix.
move=> i.
rewrite size_tuple card_matrix expn0.
destruct i => //= _.
set xx := enum _ .
destruct xx => //.
destruct s.
apply val_inj => /=.
apply/ffunP.
case => a.
by case.
Qed.

End big_sums_rV.

Section big_sums_rV2.

Local Open Scope vec_ext_scope.
Local Open Scope ring_scope.

Variable A : finType.

Lemma big_singl_rV (p : A -> R) :
  \rsum_(i in A) p i = 1%R -> \rsum_(i in 'rV[A]_1) p (i ``_ ord0) = 1%R.
Proof.
move=> <-.
rewrite (reindex_onto (fun j => \row_(i < 1) j) (fun p => p ``_ ord0)) /=.
- apply eq_big => a; first by rewrite mxE eqxx inE.
  move=> _; by rewrite mxE.
- move=> t _; apply/matrixP => a b; by rewrite (ord1 a) (ord1 b) mxE.
Qed.

End big_sums_rV2.

Section big_sums_tuples.

Variable A : finType.

Lemma rsum_1_tuple F G P Q :
  (forall i : tuple_finType 1 A, F i = G (thead i)) ->
  (forall i : tuple_finType 1 A, P i = Q (thead i)) ->
  \rsum_(i in {: 1.-tuple A} | P i) F i = \rsum_(i in A | Q i) G i.
Proof.
move=> FG PQ.
rewrite (reindex_onto (fun i => [tuple of [:: i]]) (fun p => thead p)) /=; last first.
  case/tupleP => h t X; by rewrite theadE (tuple0 t).
apply eq_big => x //.
by rewrite (PQ [tuple x]) /= theadE eqxx andbC.
move=> X; by rewrite FG.
Qed.

(* TODO: useless? *)
Lemma rsum_0tuple F Q :
  \rsum_( j in {:0.-tuple A} | Q j) F j = if Q [tuple] then F [tuple] else 0.
Proof.
rewrite -big_map /= /index_enum -enumT (_ : enum (tuple_finType 0 A) = [tuple] :: [::]).
by rewrite /= big_cons big_nil addR0.
apply eq_from_nth with [tuple] => /=.
by rewrite size_tuple card_tuple.
move=> i.
rewrite size_tuple card_tuple expn0.
destruct i => //= _.
set xx := enum _ .
destruct xx => //.
destruct s.
apply val_inj => /=.
by destruct tval.
Qed.

Lemma big_singl_tuple (p : A -> R) :
  \rsum_(i in A) p i = 1 -> \rsum_(i in {: 1.-tuple A}) p (thead i) = 1.
Proof.
move=> <-.
rewrite (reindex_onto (fun j => [tuple of [:: j]]) (fun p => thead p)) => /=.
- apply eq_bigl => x; by rewrite theadE inE eqxx.
- by move=> i _; apply thead_tuple1.
Qed.

(*Lemma big_head_behead_P n (F : 'rV[A]_n.+1 -> R) (P1 : pred A) (P2 : pred 'rV[A]_n) :
  \rsum_(i in A | P1 i) \rsum_(j in 'rV[A]_n | P2 j) (F (row_mx (\row_(k < 1) i) j))
  =
  \rsum_(p in 'rV[A]_n.+1 | (P1 (p /_ ord0)) && (P2 (tbehead p)) ) (F p).
Proof.
symmetry.
rewrite (@partition_big _ _ _ _ _ _ (fun x : {: n.+1.-tuple A} => thead x)
  (fun x : A => P1 x)) //=.
- apply eq_bigr => i Hi.
  rewrite (reindex_onto (fun j : {: n.-tuple A} => [tuple of (i :: j)])
    (fun p => [tuple of (behead p)])) /=; last first.
    move=> j Hj.
    case/andP : Hj => Hj1 /eqP => <-.
    symmetry.
    by apply tuple_eta.
  apply congr_big => // x /=.
  rewrite !theadE eqxx /= Hi /= -andbA /=.
  set tmp := _ == x.
  have Htmp : tmp = true.
    rewrite /tmp tupleE /behead_tuple /=.
    apply/eqP => /=.
    by apply val_inj.
  rewrite Htmp andbC /=.
  f_equal.
  by apply/eqP.
move=> i; by case/andP.
Qed.

Lemma big_head_behead_P_set n (F : n.+1.-tuple A -> R) (P1 : {set A}) (P2 : {set {: n.-tuple A}}) :
  \rsum_(i in P1) \rsum_(j in P2) (F [tuple of (i :: j)])
  =
  \rsum_(p | (thead p \in P1) && (tbehead p \in P2)) (F p).
Proof.
symmetry.
rewrite (@partition_big _ _ _ _ _ _ (fun x : {: n.+1.-tuple A} => thead x)
  (fun x : A => x \in P1)) //=.
- apply eq_bigr => i Hi.
  rewrite (reindex_onto (fun j : {: n.-tuple A} => [tuple of (i :: j)])
    (fun p => [tuple of (behead p)])) /=; last first.
    move=> j Hj.
    case/andP : Hj => Hj1 /eqP => <-.
    symmetry.
    by apply tuple_eta.
  apply congr_big => // x /=.
  rewrite !theadE eqxx /= Hi /= -andbA /=.
  set tmp := _ == x.
  have Htmp : tmp = true.
    rewrite /tmp tupleE /behead_tuple /=.
    apply/eqP => /=.
    by apply val_inj.
  rewrite Htmp andbC /=.
  f_equal.
  by apply/eqP.
move=> i; by case/andP.
Qed.

Lemma big_head_behead n (F : n.+1.-tuple A -> R) :
  \rsum_(i in A) \rsum_(j in {: n.-tuple A}) (F [tuple of (i :: j)]) =
  \rsum_(p in {: n.+1.-tuple A}) (F p).
Proof. by rewrite big_head_behead_P. Qed.*)

(*Lemma big_cat_tuple m n (F : (m + n)%nat.-tuple A -> R) :
  \rsum_(i in {:m.-tuple A} ) \rsum_(j in {: n.-tuple A})
  F [tuple of (i ++ j)] = \rsum_(p in {: (m + n)%nat.-tuple A}) (F p).
Proof.
move: m n F.
elim.
- move=> m2 F /=.
  transitivity ( \rsum_(i <- [tuple] :: [::])
    \rsum_(j in tuple_finType m2 A) F [tuple of i ++ j] ).
    apply congr_big => //=.
    symmetry.
    rewrite /index_enum /=.
    rewrite Finite.EnumDef.enumDef /=.
    apply eq_from_nth with [tuple] => //=.
    by rewrite FinTuple.size_enum expn0.
    case=> //= _.
    destruct (FinTuple.enum 0 A) => //.
    by rewrite (tuple0 t).
  rewrite big_cons /= big_nil /= addR0.
  apply eq_bigr => // i _.
  f_equal.
  by apply val_inj.
- move=> m IH n F.
  symmetry.
  transitivity (\rsum_(p in tuple_finType (m + n).+1 A) F p); first by apply congr_big.
  rewrite -big_head_behead -big_head_behead.
  apply eq_bigr => i _.
  symmetry.
  move: {IH}(IH n (fun x => F [tuple of i :: x])) => <-.
  apply eq_bigr => i0 _.
  apply eq_bigr => i1 _.
  f_equal.
  by apply val_inj.
Qed.

Lemma big_cat_tuple_seq m n (F : seq A -> R) :
  \rsum_(i in {:m.-tuple A} ) \rsum_(j in {: n.-tuple A}) (F (i ++ j)) =
  \rsum_(p in {: (m + n)%nat.-tuple A}) (F p).
Proof.
move: (@big_cat_tuple m n (fun l => if size l == (m+n)%nat then F l else 0)) => IH.
set lhs := \rsum_(i in _) _ in IH.
apply trans_eq with lhs.
rewrite /lhs.
apply eq_bigr => i _.
apply eq_bigr => j _.
set test := _ == _.
have Htest : test = true by rewrite /test size_tuple eqxx.
case: ifP => // abs.
by rewrite abs in Htest.
rewrite IH.
apply eq_bigr => i _.
by rewrite size_tuple eqxx.
Qed.*)

Local Open Scope vec_ext_scope.
Local Open Scope ring_scope.

Lemma big_head_rbehead n (F : 'rV[A]_n.+1 -> R) (i : A) :
  \rsum_(j in 'rV[A]_n) (F (row_mx (\row_(k < 1) i) j)) =
  \rsum_(p in 'rV[A]_n.+1 | p ``_ ord0 == i) (F p).
Proof.
symmetry.
rewrite (reindex_onto (fun j : 'rV[A]_n => (row_mx (\row_(k < 1) i) j))
  (fun p : 'rV[A]_n.+1=> rbehead p)) /=; last first.
  move=> m Hm.
  apply/matrixP => a b; rewrite {a}(ord1 a).
  rewrite row_mx_rbehead //.
  by apply/eqP.
apply eq_bigl => /= x.
by rewrite rbehead_row_mx eqxx andbT row_mx_row_ord0 eqxx.
Qed.

(*Lemma big_behead_head n (F : n.+1.-tuple A -> R) (i : A) :
  \rsum_(j in {: n.-tuple A}) (F [tuple of (i :: j)]) =
  \rsum_(p in {: n.+1.-tuple A} | thead p == i) (F p).
Proof.
symmetry.
rewrite (reindex_onto (fun j : {: n.-tuple A} => [tuple of (i :: j)])
  (fun p => tbehead p)) /=; last first.
  move=> ij /eqP => <-; by rewrite -tuple_eta.
apply eq_bigl => /= x.
rewrite inE /= theadE eqxx /=.
apply/eqP.
rewrite tupleE /behead_tuple /=.
by apply val_inj.
Qed.*)

(* TODO: rename *)
Lemma big_head_big_behead n (F : 'rV[A]_n.+1 -> R) (j : 'rV[A]_n) :
  \rsum_(i in A ) (F (row_mx (\row_(k < 1) i) j)) =
  \rsum_(p in 'rV[A]_n.+1 | rbehead p == j) (F p).
Proof.
apply/esym.
rewrite (reindex_onto (fun p => row_mx (\row_(k < 1) p) j) (fun p => p ``_ ord0) ) /=; last first.
  move=> i /eqP <-.
  apply/matrixP => a b; rewrite {a}(ord1 a).
  by rewrite row_mx_rbehead.
apply eq_bigl => /= a.
by rewrite rbehead_row_mx eqxx /= row_mx_row_ord0 eqxx.
Qed.

(*Lemma big_head_big_behead n (F : n.+1.-tuple A -> R) (j : {:n.-tuple A}) :
  \rsum_(i in A ) (F [tuple of (i :: j)]) =
  \rsum_(p in {:n.+1.-tuple A} | behead p == j) (F p).
Proof.
symmetry.
rewrite (reindex_onto (fun p => [tuple of (p :: j)]) (fun p => thead p) ) /=; last first.
  case/tupleP => hd tl /=; move/eqP => tl_i.
  rewrite !tupleE.
  f_equal.
  by apply val_inj.
apply eq_bigl => /= a; by rewrite inE /= theadE eqxx /= eqxx.
Qed.*)

Lemma big_head_rbehead_P_set n (F : 'rV[A]_n.+1 -> R) (P1 : {set A}) (P2 : {set {: 'rV[A]_n}}) :
  \rsum_(i in P1) \rsum_(j in P2) (F (row_mx (\row_(k < 1) i) j))
  =
  \rsum_(p in 'rV[A]_n.+1 | (p ``_ ord0 \in P1) && (rbehead p \in P2)) (F p).
Proof.
apply/esym.
rewrite (@partition_big _ _ _ _ _ _ (fun x : 'rV[A]_n.+1 => x ``_ ord0)
  (fun x : A => x \in P1)) //=.
- apply eq_bigr => i Hi.
  rewrite (reindex_onto (fun j : 'rV[A]_n => row_mx (\row_(k < 1) i) j) rbehead) /=; last first.
    move=> j Hj.
    case/andP : Hj => Hj1 /eqP => <-.
    apply/matrixP => a b; rewrite {a}(ord1 a).
    by rewrite row_mx_rbehead.
  apply congr_big => // x /=.
  by rewrite rbehead_row_mx eqxx andbT row_mx_row_ord0 eqxx Hi andbT.
move=> i; by case/andP.
Qed.

Lemma big_head_behead_P n (F : 'rV[A]_n.+1 -> R) (P1 : pred A) (P2 : pred 'rV[A]_n) :
  \rsum_(i in A | P1 i) \rsum_(j in 'rV[A]_n | P2 j) (F (row_mx (\row_(k < 1) i) j))
  =
  \rsum_(p in 'rV[A]_n.+1 | (P1 (p ``_ ord0)) && (P2 (rbehead p)) ) (F p).
Proof.
symmetry.
rewrite (@partition_big _ _ _ _ _ _ (fun x : 'rV[A]_n.+1 => x ``_ ord0)
  (fun x : A => P1 x)) //=.
- apply eq_bigr => i Hi.
  rewrite (reindex_onto (fun j : 'rV[A]_n => row_mx (\row_(k < 1) i) j) rbehead) /=; last first.
    move=> j Hj.
    case/andP : Hj => Hj1 /eqP => <-.
    apply/matrixP => a b; rewrite {a}(ord1 a).
    by rewrite row_mx_rbehead.
  apply congr_big => // x /=.
  by rewrite row_mx_row_ord0 rbehead_row_mx 2!eqxx Hi !andbT.
move=> i; by case/andP.
Qed.

Lemma big_head_behead n (F : 'rV[A]_n.+1 -> R) :
  \rsum_(i in A) \rsum_(j in 'rV[A]_n) (F (row_mx (\row_(k < 1) i) j)) =
  \rsum_(p in 'rV[A]_n.+1) (F p).
Proof. by rewrite big_head_behead_P. Qed.

Lemma big_tcast n (F : n.-tuple A -> R) (P : pred {: n.-tuple A}) m
  (n_m : m = n) :
  \rsum_(p in {: n.-tuple A} | P p) (F p) =
  \rsum_(p in {: m.-tuple A} | P (tcast n_m p)) (F (tcast n_m p)).
Proof.
subst m.
apply eq_bigr => ta.
case/andP => _ H.
by rewrite tcast_id.
Qed.

Local Open Scope tuple_ext_scope.

(* TODO: remove? *)
Lemma rsum_tuple_tnth n i (f : n.+1.-tuple A -> R):
  \rsum_(t | t \in {: n.+1.-tuple A}) f t =
  \rsum_(a | a \in A) \rsum_(t | t \_ i == a) f t.
Proof.
by rewrite (partition_big (fun x : n.+1.-tuple A => x \_ i) xpredT).
Qed.

Local Close Scope tuple_ext_scope.

End big_sums_tuples.

Section sum_tuple_ffun.

Import Monoid.Theory.

Variable R : Type.
Variable times : Monoid.mul_law 0.
Notation Local "*%M" := times (at level 0).
Variable plus : Monoid.add_law 0 *%M.
Notation Local "+%M" := plus (at level 0).

Lemma sum_tuple_ffun (I J : finType) (F : {ffun I -> J} -> R)
  (G : _ -> _ -> _) (jdef : J) (idef : I) :
  \big[+%M/0]_(j : #|I|.-tuple J) G (F (Finfun j)) (nth jdef j 0)
    = \big[+%M/0]_(f : {ffun I -> J}) G (F f) (f (nth idef (enum I) 0)).
Proof.
rewrite (reindex_onto (fun y => fgraph y) (fun p => Finfun p)) //.
apply eq_big; first by case => t /=; by rewrite eqxx.
move=> i _.
f_equal.
  by destruct i.
destruct i as [ [tval Htval] ].
rewrite [fgraph _]/= -(nth_map idef jdef); last first.
  rewrite -cardE.
  apply/card_gt0P.
  by exists idef.
by rewrite -codomE codom_ffun.
Qed.

End sum_tuple_ffun.

Lemma sum_f_R0_rsum : forall k (f : nat -> R),
  sum_f_R0 f k = \rsum_(i<k.+1) f i.
Proof.
elim => [f|] /=.
  by rewrite big_ord_recl /= big_ord0 addR0.
move=> k IH f.
by rewrite big_ord_recr /= IH.
Qed.

Theorem RPascal k (a b : R) :
  (a + b) ^ k = \rsum_(i < k.+1) INR ('C(k, i))* (a ^ (k - i) * b ^ i).
Proof.
rewrite addRC Binomial.binomial sum_f_R0_rsum.
apply eq_bigr => i _.
rewrite combinaison_Coq_SSR; last by rewrite -ltnS.
rewrite -minusE; field.
Qed.

(** Rle, Rlt lemmas for big-mult of reals *)

Reserved Notation "\rmul_ ( i : A | P ) F"
  (at level 41, F at level 41, i, A at level 50,
     format "'[' \rmul_ ( i  :  A  |  P ) '/  '  F ']'").
Reserved Notation "\rmul_ ( i : t ) F"
  (at level 41, F at level 41, i at level 50, only parsing).
Reserved Notation "\rmul_ ( i 'in' A ) F"
  (at level 41, F at level 41, i, A at level 50,
    format "'[' \rmul_ ( i  'in'  A ) '/  '  F ']'").
Notation "\rmul_ ( i | P ) F" := (\big[Rmult/1%R]_( i | P) F)
  (at level 41, F at level 41, i at level 50,
    format "'[' \rmul_ ( i | P ) '/  '  F ']'") : R_scope.
Reserved Notation "\rmul_ ( i < A | P ) F"
  (at level 41, F at level 41, i, A at level 50,
     format "'[' \rmul_ ( i  <  A  |  P ) '/  '  F ']'").
Reserved Notation "\rmul_ ( i < t ) F"
  (at level 41, F at level 41, i, t at level 50,
    format "'[' \rmul_ ( i < t ) '/  '  F ']'").

Notation "\rmul_ ( i : A | P ) F" := (\big[Rmult/R1]_( i : A | P ) F): R_scope.
Notation "\rmul_ ( i : t ) F" := (\big[Rmult/R1]_( i : t ) F) : R_scope.
Notation "\rmul_ ( i 'in' A ) F" := (\big[Rmult/R1]_( i in A ) F) : R_scope.
Notation "\rmul_ ( i < A | P ) F" := (\big[Rmult/R1]_( i < A | P ) F): R_scope.
Notation "\rmul_ ( i < t ) F" := (\big[Rmult/R1]_( i < t ) F) : R_scope.

Section compare_big_mult.

Lemma Rlt_0_big_mult {A : finType} F : (forall i, 0 < F i) ->
  0 < \rmul_(i : A) F i.
Proof.
move=> H.
elim: (index_enum _) => [| hd tl IH].
rewrite big_nil; fourier.
rewrite big_cons; apply Rmult_lt_0_compat => //; by apply H.
Qed.

Lemma Rle_0_big_mult {A : finType} F : (forall i, 0 <= F i) ->
  0 <= \rmul_(i : A) F i.
Proof.
move=> H.
elim: (index_enum _) => [| hd tl IH].
rewrite big_nil; fourier.
rewrite big_cons; apply Rmult_le_pos => //; by apply H.
Qed.

Local Open Scope vec_ext_scope.
Local Open Scope ring_scope.

Lemma Rlt_0_rmul_inv {B : finType} F (HF: forall a, 0 <= F a) :
  forall n (x : 'rV[B]_n.+1),
  0 < \rmul_(i < n.+1) F (x ``_ i) -> forall i, 0 < F (x ``_ i).
Proof.
elim => [x | n IH].
  rewrite big_ord_recr /= big_ord0 mul1R => Hi i.
  suff : i = ord_max by move=> ->.
  rewrite (ord1 i).
  by apply/val_inj.
move=> x.
set t := \row_(i < n.+1) (x ``_ (lift ord0 i)).
rewrite big_ord_recl /= => H.
apply Rlt_0_Rmult_inv in H; last 2 first.
  by apply HF.
  apply Rle_0_big_mult => i; by apply HF.
case.
case=> [Hi | i Hi].
  rewrite (_ : Ordinal _ = ord0); last by apply val_inj.
  by case: H.
case: H => _ H.
have : 0 < \rmul_(i0 < n.+1) F (t ``_ i0).
  suff : \rmul_(i < n.+1) F (x ``_ (lift ord0 i)) =
    \rmul_(i0 < n.+1) F (t ``_ i0).
    by move=> <-.
  apply eq_bigr => j _.
  by rewrite mxE.
have Hi' : (i < n.+1)%nat.
  clear -Hi; by rewrite ltnS in Hi.
move/IH.
move/(_ (Ordinal Hi')).
set o1 := Ordinal _.
set o2 := Ordinal _.
suff : lift ord0 o1 = o2.
  move=> <-.
  by rewrite mxE.
by apply val_inj.
Qed.

(*
Lemma Rlt_0_rmul_inv {B : finType} F (HF: forall a, 0 <= F a) :
  forall n (x : n.+1.-tuple B),
  0 < \rmul_(i < n.+1) F (tnth x i) -> forall i, 0 < F (tnth x i).
Proof.
elim => [x | n IH].
  rewrite big_ord_recr /= big_ord0 mul1R => Hi i.
  suff : i = ord_max by move=> ->.
  rewrite (ord1 i).
  by apply/val_inj.
case/tupleP => h t.
rewrite big_ord_recl /= => H.
apply Rlt_0_Rmult_inv in H; last 2 first.
  by apply HF.
  apply Rle_0_big_mult => i; by apply HF.
case.
case=> [Hi | i Hi].
  by case: H.
case: H => _ H.
have : 0 < \rmul_(i0<n.+1) F (tnth t i0).
  suff : \rmul_(i<n.+1) F (tnth [tuple of h :: t] (lift ord0 i)) =
    \rmul_(i0<n.+1) F (tnth t i0).
    by move=> <-.
  apply eq_bigr => j _.
  f_equal.
have Ht : t = [tuple of behead (h :: t)].
  rewrite (tuple_eta t) /=.
  by apply/val_inj.
rewrite Ht /=.
rewrite tnth_behead /=.
f_equal.
by apply val_inj.
rewrite -(lift0 j).
by rewrite inord_val.
have Hi' : (i < n.+1)%nat.
  clear -Hi; by rewrite ltnS in Hi.
move/IH.
move/(_ (Ordinal Hi')).
suff : (tnth t (Ordinal Hi')) = (tnth [tuple of h :: t] (Ordinal Hi)).
  by move=> ->.
have Ht : t = [tuple of behead (h :: t)].
  rewrite (tuple_eta t) /=.
  by apply/val_inj.
rewrite Ht /= tnth_behead /=.
f_equal.
  by apply val_inj.
apply val_inj => /=; by rewrite inordK.
Qed.
*)

Lemma Rle_1_big_mult {A : finType}  f : (forall i, 1 <= f i) ->
  1 <= \rmul_(i : A) f i.
Proof.
move=> Hf.
elim: (index_enum _) => [| hd tl IH].
- rewrite big_nil; by apply Rle_refl.
- rewrite big_cons -{1}(mulR1 1%R).
  apply Rmult_le_compat => // ; fourier.
Qed.

Local Open Scope R_scope.

Lemma Rle_big_mult {A : finType} f g : (forall i, 0 <= f i <= g i) ->
  \rmul_(i : A) f i <= \rmul_(i : A) g i.
Proof.
move=> Hfg.
case/orP : (orbN [forall i, f i != 0%R]) ; last first.
- rewrite negb_forall => /existsP Hf.
  case: Hf => i0 /negPn/eqP Hi0.
  rewrite (bigD1 i0) //= Hi0 mul0R; apply Rle_0_big_mult.
  move=> i ; move: (Hfg i) => [Hi1 Hi2] ; by apply (Rle_trans _ _ _ Hi1 Hi2).
- move=> /forallP Hf.
  have Hprodf : 0 < \rmul_(i:A) f i.
    apply Rlt_0_big_mult => i.
    move: (Hf i) (Hfg i) => {Hf}Hf {Hfg}[Hf2 _].
    apply/RltP; rewrite Rlt_neqAle eq_sym Hf /=; by apply/RleP.
  apply (Rmult_le_reg_r (1 * / \rmul_(i : A) f i) _ _).
    apply Rlt_mult_inv_pos => //; fourier.
  rewrite mul1R Rinv_r; last by apply not_eq_sym, Rlt_not_eq.
  set inv_spec := fun r => if r == 0 then 0 else / r.
  rewrite (_ : / (\rmul_(a : A) f a) = inv_spec (\rmul_(a : A) f a)) ; last first.
    rewrite /inv_spec (_ : \rmul_(a : A) f a == 0 = false) //.
    apply/eqP ; by apply not_eq_sym, Rlt_not_eq.
  rewrite (@big_morph _ _ (inv_spec) R1 Rmult R1 Rmult _); last 2 first.
  - move=> a b /=.
    case/boolP : ((a != 0) && (b != 0)).
    - move=> /andP [/negbTE Ha /negbTE Hb] ; rewrite /inv_spec Ha Hb.
      move/negbT in Ha ; move/negbT in Hb.
      have : (a * b)%R == 0 = false ; last move=> ->.
      apply/negP => /eqP Habs.
        apply (Rmult_eq_compat_r (/ b)) in Habs ; move: Habs.
        rewrite -mulRA mul0R Rinv_r ?mulR1; move/eqP; by apply/negP.
      apply Rinv_mult_distr; move/eqP; by apply/negP.
    - rewrite negb_and => Hab.
      case/orP : (orbN (a != 0)) => Ha.
      - rewrite Ha /= in Hab; move/negPn/eqP in Hab; rewrite Hab mulR0 /inv_spec.
        by rewrite (_ : 0 == 0 ) // mulR0.
      - move/negPn/eqP in Ha ; rewrite Ha mul0R /inv_spec.
        by rewrite (_ : 0 == 0 ) // mul0R.
  - rewrite /inv_spec.
    have : ~~ (1 == 0).
      apply/eqP => H01; symmetry in H01; move: H01; apply Rlt_not_eq; fourier.
    move/negbTE => -> ; by rewrite Rinv_1.
  rewrite -big_split /=.
  apply Rle_1_big_mult => i.
  move/(_ i) in Hf.
  move: Hfg => /(_ i) [Hf2 Hfg].
  rewrite /inv_spec.
  move/negbTE in Hf ; rewrite Hf ; move/negbT in Hf.
  rewrite -(Rinv_r (f i)); last by move/eqP; apply/negP.
  apply Rmult_le_compat_r => //.
  rewrite -(mul1R (/ f i)).
  apply Rle_mult_inv_pos; first fourier.
  apply/RltP; rewrite Rlt_neqAle eq_sym Hf /=; by apply/RleP.
Qed.

Local Close Scope R_scope.

End compare_big_mult.

Local Open Scope vec_ext_scope.
Local Open Scope ring_scope.

Lemma log_rmul_rsum_mlog {A : finType} (f : A -> R+) : forall n (ta : 'rV[A]_n.+1),
  (forall i, 0 < f ta ``_ i) ->
  (- log (\rmul_(i < n.+1) f ta ``_ i) = \rsum_(i < n.+1) - log (f ta ``_ i))%R.
Proof.
elim => [i Hi | n IH].
  by rewrite big_ord_recl big_ord0 mulR1 big_ord_recl big_ord0 addR0.
move=> ta Hi.
rewrite big_ord_recl /= log_mult; last 2 first.
  by apply Hi.
  apply Rlt_0_big_mult => i; by apply Hi.
set tl := \row_(i < n.+1) ta ``_ (lift ord0 i).
have Htmp : forall i0 : 'I_n.+1, 0 < f tl ``_ i0.
  move=> i.
  rewrite mxE.
  by apply Hi.
move: {IH Htmp}(IH _ Htmp) => IH.
have -> : \rmul_(i < n.+1) f ta ``_ (lift ord0 i) = \rmul_(i0<n.+1) f tl ``_ i0.
  apply eq_bigr => i _.
  congr (f _).
  by rewrite /tl mxE.
rewrite Ropp_plus_distr [X in _ = X]big_ord_recl IH.
congr (_ + _)%R.
apply eq_bigr => i _.
by rewrite /tl mxE.
Qed.

(*Lemma log_rmul_rsum_mlog {A : finType} (f : A -> R+) : forall n (ta : n.+1.-tuple A),
  (forall i, 0 < f ta \_ i) ->
  - log (\rmul_(i < n.+1) f ta \_ i) = \rsum_(i < n.+1) - log (f ta \_ i).
Proof.
elim => [i Hi | n IH].
  by rewrite big_ord_recl big_ord0 mulR1 big_ord_recl big_ord0 addR0.
case/tupleP => hd tl Hi.
rewrite big_ord_recl /= log_mult; last 2 first.
  by apply Hi.
  apply Rlt_0_big_mult => i; by apply Hi.
have Htmp : forall i0 : 'I_n.+1, 0 < f tl \_ i0.
  move=> i.
  move: {Hi}(Hi (inord i.+1)) => Hi.
  set rhs := _ \_ _ in Hi.
  suff : tl \_ i = rhs by move=> ->.
  rewrite /rhs -tnth_behead /=.
  f_equal.
  by apply val_inj.
move: {IH Htmp}(IH tl Htmp) => IH.
have -> : \rmul_(i < n.+1) f [tuple of hd :: tl] \_ (lift ord0 i) = \rmul_(i0<n.+1) f tl \_ i0.
  apply eq_bigr => i _.
  f_equal.
  rewrite (_ : lift _ _ = inord i.+1); last by rewrite -lift0 inord_val.
  rewrite -tnth_behead /=.
  f_equal.
  by apply val_inj.
rewrite Ropp_plus_distr [X in _ = X]big_ord_recl IH.
f_equal.
apply eq_bigr => i _.
do 3 f_equal.
rewrite (_ : lift _ _ = inord i.+1); last by rewrite -lift0 inord_val.
rewrite -tnth_behead /=.
f_equal.
by apply val_inj.
Qed.*)

Local Close Scope tuple_ext_scope.


From Hammer Require Import Hammer.

Require Import BinInt.
Require Import Zcompare.
Require Import Zorder.
Require Import Znat.
Require Import Zmisc.
Require Import Wf_nat.
Local Open Scope Z_scope.

Lemma Z_of_nat_complete (x : Z) :
0 <= x -> exists n : nat, x = Z.of_nat n.
Proof. hammer_hook "Wf_Z" "Wf_Z.Z_of_nat_complete".
intros H. exists (Z.to_nat x). symmetry. now apply Z2Nat.id.
Qed.

Lemma Z_of_nat_complete_inf (x : Z) :
0 <= x -> {n : nat | x = Z.of_nat n}.
Proof. hammer_hook "Wf_Z" "Wf_Z.Z_of_nat_complete_inf".
intros H. exists (Z.to_nat x). symmetry. now apply Z2Nat.id.
Qed.

Lemma Z_of_nat_prop :
forall P:Z -> Prop,
(forall n:nat, P (Z.of_nat n)) -> forall x:Z, 0 <= x -> P x.
Proof. hammer_hook "Wf_Z" "Wf_Z.Z_of_nat_prop".
intros P H x Hx. now destruct (Z_of_nat_complete x Hx) as (n,->).
Qed.

Lemma Z_of_nat_set :
forall P:Z -> Set,
(forall n:nat, P (Z.of_nat n)) -> forall x:Z, 0 <= x -> P x.
Proof. hammer_hook "Wf_Z" "Wf_Z.Z_of_nat_set".
intros P H x Hx. now destruct (Z_of_nat_complete_inf x Hx) as (n,->).
Qed.

Lemma natlike_ind :
forall P:Z -> Prop,
P 0 ->
(forall x:Z, 0 <= x -> P x -> P (Z.succ x)) ->
forall x:Z, 0 <= x -> P x.
Proof. hammer_hook "Wf_Z" "Wf_Z.natlike_ind".
intros P Ho Hrec x Hx; apply Z_of_nat_prop; trivial.
induction n. exact Ho.
rewrite Nat2Z.inj_succ. apply Hrec; trivial using Nat2Z.is_nonneg.
Qed.

Lemma natlike_rec :
forall P:Z -> Set,
P 0 ->
(forall x:Z, 0 <= x -> P x -> P (Z.succ x)) ->
forall x:Z, 0 <= x -> P x.
Proof. hammer_hook "Wf_Z" "Wf_Z.natlike_rec".
intros P Ho Hrec x Hx; apply Z_of_nat_set; trivial.
induction n. exact Ho.
rewrite Nat2Z.inj_succ. apply Hrec; trivial using Nat2Z.is_nonneg.
Qed.

Section Efficient_Rec.

Let R (a b:Z) := 0 <= a /\ a < b.

Let R_wf : well_founded R.
Proof. hammer_hook "Wf_Z" "Wf_Z.Efficient_Rec.R_wf".
apply well_founded_lt_compat with Z.to_nat.
intros x y (Hx,H). apply Z2Nat.inj_lt; Z.order.
Qed.

Lemma natlike_rec2 :
forall P:Z -> Type,
P 0 ->
(forall z:Z, 0 <= z -> P z -> P (Z.succ z)) ->
forall z:Z, 0 <= z -> P z.
Proof. hammer_hook "Wf_Z" "Wf_Z.natlike_rec2".
intros P Ho Hrec.
induction z as [z IH] using (well_founded_induction_type R_wf).
destruct z; intros Hz.
- apply Ho.
- set (y:=Z.pred (Zpos p)).
assert (LE : 0 <= y) by (unfold y; now apply Z.lt_le_pred).
assert (EQ : Zpos p = Z.succ y) by (unfold y; now rewrite Z.succ_pred).
rewrite EQ. apply Hrec, IH; trivial.
split; trivial. unfold y; apply Z.lt_pred_l.
- now destruct Hz.
Qed.

Lemma natlike_rec3 :
forall P:Z -> Type,
P 0 ->
(forall z:Z, 0 < z -> P (Z.pred z) -> P z) ->
forall z:Z, 0 <= z -> P z.
Proof. hammer_hook "Wf_Z" "Wf_Z.natlike_rec3".
intros P Ho Hrec.
induction z as [z IH] using (well_founded_induction_type R_wf).
destruct z; intros Hz.
- apply Ho.
- assert (EQ : 0 <= Z.pred (Zpos p)) by now apply Z.lt_le_pred.
apply Hrec. easy. apply IH; trivial. split; trivial.
apply Z.lt_pred_l.
- now destruct Hz.
Qed.

Lemma Zlt_0_rec :
forall P:Z -> Type,
(forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> 0 <= x -> P x) ->
forall x:Z, 0 <= x -> P x.
Proof. hammer_hook "Wf_Z" "Wf_Z.Zlt_0_rec".
intros P Hrec.
induction x as [x IH] using (well_founded_induction_type R_wf).
destruct x; intros Hx.
- apply Hrec; trivial. intros y (Hy,Hy').
assert (0 < 0) by now apply Z.le_lt_trans with y.
discriminate.
- apply Hrec; trivial. intros y (Hy,Hy').
apply IH; trivial. now split.
- now destruct Hx.
Defined.

Lemma Zlt_0_ind :
forall P:Z -> Prop,
(forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> 0 <= x -> P x) ->
forall x:Z, 0 <= x -> P x.
Proof. hammer_hook "Wf_Z" "Wf_Z.Zlt_0_ind".   intros; now apply Zlt_0_rec. Qed.

Lemma Z_lt_rec :
forall P:Z -> Type,
(forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> P x) ->
forall x:Z, 0 <= x -> P x.
Proof. hammer_hook "Wf_Z" "Wf_Z.Z_lt_rec".
intros P Hrec; apply Zlt_0_rec; auto.
Qed.

Lemma Z_lt_induction :
forall P:Z -> Prop,
(forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> P x) ->
forall x:Z, 0 <= x -> P x.
Proof. hammer_hook "Wf_Z" "Wf_Z.Z_lt_induction".
intros; now apply Z_lt_rec.
Qed.

Lemma Zlt_lower_bound_rec :
forall P:Z -> Type, forall z:Z,
(forall x:Z, (forall y:Z, z <= y < x -> P y) -> z <= x -> P x) ->
forall x:Z, z <= x -> P x.
Proof. hammer_hook "Wf_Z" "Wf_Z.Zlt_lower_bound_rec".
intros P z Hrec x Hx.
rewrite <- (Z.sub_simpl_r x z). apply Z.le_0_sub in Hx.
pattern (x - z); apply Zlt_0_rec; trivial.
clear x Hx. intros x IH Hx.
apply Hrec. intros y (Hy,Hy').
rewrite <- (Z.sub_simpl_r y z). apply IH; split.
now rewrite Z.le_0_sub.
now apply Z.lt_sub_lt_add_r.
now rewrite <- (Z.add_le_mono_r 0 x z).
Qed.

Lemma Zlt_lower_bound_ind :
forall P:Z -> Prop, forall z:Z,
(forall x:Z, (forall y:Z, z <= y < x -> P y) -> z <= x -> P x) ->
forall x:Z, z <= x -> P x.
Proof. hammer_hook "Wf_Z" "Wf_Z.Zlt_lower_bound_ind".
intros; now apply Zlt_lower_bound_rec with z.
Qed.

End Efficient_Rec.


From Coq Require Import Arith Lia List.
Definition dec (X: Type) := sum X (X -> False).
Notation sig := sigT.
Notation Sig := existT.
Notation pi1 := projT1.
Notation pi2 := projT2.
Notation "'Sigma' x .. y , p" :=
  (sig (fun x => .. (sig (fun y => p)) ..))
    (at level 200, x binder, right associativity,
     format "'[' 'Sigma'  '/  ' x  ..  y ,  '/  ' p ']'")
  : type_scope.

Import ListNotations.
Notation "x 'el' A" := (In x A) (at level 70).
Notation "x 'nel' A" := (~ In x A) (at level 70).
Fixpoint nrep {X} (A: list X) : Prop :=
  match A with
  | [] => True
  | x::A => x nel A /\ nrep A
  end.
Definition injective {X Y} (f: X -> Y) :=
  forall x x', f x = f x' -> x = x'.
Fact nrep_map X Y (f: X -> Y) A :
  injective f -> nrep A -> nrep (map f A).
Proof.
  intros H1.
  induction A as [|x A IH]; cbn.
  - auto.
  - intros [H2 H3].
    split. 2:{ apply IH, H3. }
    intros (x'&H4&H5)%in_map_iff.
    apply H1 in H4 as ->.
    auto.
Qed.

(** Inductive definition *)

Inductive num : nat -> Type :=
| Zero: forall n, num (S n)
| Up: forall {n}, num n -> num (S n).

Check Zero 5.
Check Up (Zero 4).
Check Up (Up (Zero 3)).

(** Eliminator *)

Definition num_elim (p: forall n, num n -> Type)
  : (forall n, p (S n) (Zero n)) ->
    (forall n a, p n a -> p (S n) (Up a)) ->
    forall n a, p n a
  := fun e1 e2 => fix f n a :=
       match a with
       | Zero n => e1 n
       | @Up n a => e2 n a (f n a)
       end.

(** Predecessor and constructor laws *)

Definition pre'
  : forall n, num n ->
         match n return Type with
         | 0 => False
         | S n' => option (num n')
         end
  := fun n a => match a with
             | Zero _ => None
             | Up a' => Some a'
             end.

Definition pre
  : forall n, num (S n) -> option (num n)
  := fun n => pre' (S n).

Goal forall n a, pre n (Up a) = Some a.
  reflexivity.
Qed.
Goal forall n, pre n (Zero n) = None.
  reflexivity.
Qed.

Fact num_disjoint n a :
  Zero n = Up a -> False.
Proof.
  intros H % (f_equal (pre _)). cbn in H.
  change (match Some a with Some _ => False | None => True end).
  rewrite <- H. exact I.
Qed.

Fact Up_injective n (a b: num n) :
  Up a = Up b -> a = b.
Proof.
  intros H % (f_equal (pre _)). cbn in H.
  change (match Some a with Some a' => a' | None => a end = b).
  rewrite H. reflexivity.
Qed.

Definition pre_hat
  : forall n, num (S (S n)) -> num (S n)
  := fun n a => match pre' _ a with
             | None => Zero _
             | Some a => a
             end.
Goal forall n a, pre_hat n (Up a) = a.
Proof.
  reflexivity.
Qed.
Goal forall n, pre_hat n (Zero (S n)) = Zero n.
Proof.
  reflexivity.
Qed.

(** Listing *)

Fixpoint num_listing n : list (num n) :=
  match n with
  | 0 => []
  | S n' => Zero n' :: map Up (num_listing n')
  end.

Compute num_listing 0.
Compute num_listing 1.
Compute num_listing 2.

Goal forall n (a: num n), a el num_listing n.
Proof.
  induction a as [n|n a IH]; cbn.
  - left. reflexivity.
  - right. apply in_map, IH.
Qed.

Goal forall n, length (num_listing n) = n.
Proof.
  induction n as [|n IH]; cbn.
  - reflexivity.
  - f_equal. rewrite map_length. exact IH.
Qed.

Goal forall n, nrep (num_listing n).
Proof.
  induction n as [|n IH]; cbn.
  - exact I.
  - split.
    + intros (a&H&_) % in_map_iff.
      symmetry in H. apply num_disjoint in H. easy.
    + apply nrep_map. 2:exact IH. exact (Up_injective n).
Qed.

(*** Inversion operator *)

Definition num_inv
  : forall {n} (a: num n),
    match n return num n -> Type with
    | 0 => fun a =>  False
    | S n' => fun a => sum (a = Zero n') (Sigma a', a = Up a')
    end a.
Proof.
  destruct a as [n|n a].
  - left. reflexivity.
  - right. exists a. reflexivity.
Defined.

Eval cbn in fun n => num_inv (Zero n).
Eval cbn in fun n (a: num n) => num_inv (Up a).

(** Equality decider *)

Definition num_eqdec :
  forall n (a1 a2: num n), dec (a1 = a2).
Proof.
  induction a1 as [n|n a1 IH]; intros a2.
  all: destruct (num_inv a2) as [->|[a2' ->]].
  - left. reflexivity.
  - right. intros [] % num_disjoint.
  - right. intros H. symmetry in H. eapply num_disjoint, H.
  - specialize (IH a2') as [[]|H].
    + left. reflexivity.
    + right. contradict H. apply Up_injective, H.
Defined.

(** Enumerations *)

Fact num0 :
  num 0 -> False.
Proof.
  exact num_inv.
Qed.
Fact num_sum {n} :
  forall a: num (S n), (a = Zero n) + Sigma a', a = Up a'.
Proof.
  exact num_inv.
Qed.
Fact num1 :
  forall a: num 1,  a = Zero 0.
Proof.
  intros a.
  destruct (num_sum a) as [->|[a' ->]].
  - reflexivity.
  - exfalso. apply num0, a'.
Qed.
Fact num2 :
  forall a: num 2, sum (a = Zero 1) (a = Up (Zero 0)).
Proof.
  intros a.
  destruct (num_sum a) as [->|[a' ->]].
  - left. reflexivity.
  - right. f_equal.  apply num1.
Qed.

(** Predecessor *)

Definition P
  : forall n, num (S n) -> option (num n)
  := fun n a => match num_inv a with
             | inl _ => None
             | inr (Sig _ a' _) => Some a'
             end.

Goal forall n, P n (Zero n) = None.
Proof.
  reflexivity.
Qed.
Goal forall n a, P n (Up a) = Some a.
Proof.
  reflexivity.
Qed.

(** Embedding into numbers *)

Fixpoint N {n} (a: num n) : nat :=
  match a with
  | Zero n => 0
  | Up a => S (N a)
  end.

Compute N (Zero 3).
Compute N (Up (Up (Zero 3))).

Fact N_lt {n} (a: num n) :
  N a < n.
Proof.
  induction a as [n|n a IH]; cbn.
  - lia.
  - lia.
Qed.

Fact N_Up n (a: num n) :
  N (Up a) = S (N a).
Proof.
  destruct a as [n| n a]; reflexivity.
Qed.

Fact N_injective n (a b: num n) :
  N a = N b -> a = b.
Proof.
  revert n a b.
  induction a as [|n a IH];
    intros b;
    destruct (num_inv b) as [->|[a' ->]];
    cbn.
  - easy.
  - intros [=].
  - intros [=].
  - intros [= H]. f_equal. apply IH, H.
Qed.

(** Lift *)

Fixpoint lift {n} (a: num n) : num (S n) :=
  match a with
  | Zero n => Zero (S n)
  | Up a => Up (lift a)
  end.

Fact N_lift n (a: num n) :
  N (lift a) = N a.
Proof.
  induction a as [n|n a IH]; cbn.
  - reflexivity.
  - f_equal. exact IH.
Qed.

Fact lift_injective n (a b: num n) :
  lift a = lift b -> a = b.
Proof.
  intros H % (f_equal N). revert H.
  rewrite !N_lift. apply N_injective.
Qed.

(** Mapping numbers into numerals *)

Fixpoint B k n : num (S n) :=
  match k, n with
  | 0, n => Zero n
  | S k, 0 => Zero 0
  | S k, S n => Up (B k n)
  end.

Compute B 3 3.
Compute B 4 3.
Compute B 2 3.
Compute N (B 2 3).
Compute B (N (Zero 5)) 5.
Compute B (N (B 3 5)) 5.

Fact NB_eq k n :
  k <= n -> N (B k n) = k.
Proof.
  induction k as [|k IH] in n |-*; cbn.
  - easy.
  - destruct n as [|n]; cbn.
    + intros H. exfalso. lia.
    + intros H. f_equal. apply IH. lia.
Qed.

Fact BN_eq {n} (a: num (S n)) :
  B (N a) n = a.
Proof.
  induction n as [|n IH];
    destruct (num_inv a) as [->|[a' ->]];
    cbn.
  - reflexivity.
  - exfalso. contradict (num_inv a').
  - reflexivity.
  - f_equal. apply IH.
Qed.

(*** Recursive numerals *)

Fixpoint fin (n: nat) : Type :=
  match n with
  | 0 => False
  | S n' => option (fin n')
  end.

(** Bijection *)

Fixpoint num_fin {n} (a: num n) : fin n :=
  match a with
  | Zero _ => None
  | Up a => Some (num_fin a)
  end.

Fixpoint fin_num {n} (c: fin n) : num n :=
  match n, c with
  | 0, c => match c with end
  | S n', None => Zero n'
  | S n', Some c => Up (fin_num c)
  end.

Goal forall n (a: num n),
    fin_num (num_fin a) = a.
Proof.
  induction a as [n|n a IH]; cbn.
  - reflexivity.
  - f_equal. exact IH.
Qed.

Goal forall n (c: fin n),
    num_fin (fin_num c) = c.
Proof.
  induction n as [|n IH].
  - intros [].
  - intros [c|]; cbn.
    + f_equal. apply IH.
    + reflexivity.
Qed.

Compute num_fin (Up (Up (Zero 5))).
Compute fin_num (num_fin (Up (Up (Zero 5)))).

(** Direct proofs of transported theorems *)

Goal fin 0 -> False.
Proof.
  easy.
Qed.
Goal forall a: fin 1, a = None.
Proof.
  intros [a|].
  - exfalso. exact a.
  - reflexivity.
Qed.

Definition fin_num_elim (p: forall n, fin n -> Type)
  : (forall n, p (S n) None) ->
    (forall n a, p n a -> p (S n) (Some a)) ->
    forall n a, p n a
  := fun e1 e2 => fix f n :=
       match n with
       | 0 => fun a => match a with end
       | S n' => fun a => match a with
                      | None => e1 n'
                      | Some a' => e2 n' a' (f n' a')
                      end
       end.

Definition fin_num_inv
  : forall {n} (a: fin n),
    match n return fin n -> Type with
    | 0 => fun a =>  False
    | S n' => fun a => sum (a = None) (Sigma a', a = Some a')
    end a.
Proof.
  intros n.
  destruct n as [|n].
  - intros a. exact a.
  - destruct a as [a|].
    + right. exists a. reflexivity.
    + left. reflexivity.
Defined.

(** Automation sometimes scales to indexed inductive types *)

Print num_rect.

Goal forall n a, Zero n = Up a -> False.
Proof.
  Fail intros n [=].
  congruence.
Qed.

Goal forall n (a b: num n),  Up a = Up b -> a = b.
Proof.
  Fail intros n [= H].
  Fail congruence.
Abort.