Generalizable All Variables.
Require Import Notations.
Require Import Categories_ch1_3.
Require Import Functors_ch1_4.
Require Import Isomorphisms_ch1_5.
Require Import ProductCategories_ch1_6_1.
Require Import InitialTerminal_ch2_2.
Require Import Subcategories_ch7_1.
Require Import NaturalTransformations_ch7_4.
Require Import NaturalIsomorphisms_ch7_5.
Require Import Coherence_ch7_8.
Require Import BinoidalCategories.
Require Import PreMonoidalCategories.
Require Import MonoidalCategories_ch7_8.

(******************************************************************************)
(* Chapter 2.8: Hom Sets and Enriched Categories                              *)
(******************************************************************************)

Class ECategory `(mn:PreMonoidalCat(bc:=bc)(C:=V)(I:=EI))(Eob:Type)(Ehom:Eob->Eob->V) :=
{ ehom               :=  Ehom where "a ~~> b" := (ehom a b)
; eob_eob            :=  Eob
; e_v                :=  mn
; eid                :   forall a,          EI~>(a~~>a)
; eid_central        :   forall a,          CentralMorphism (eid a)
; ecomp              :   forall {a b c},    (a~~>b)⊗(b~~>c) ~> (a~~>c)
; ecomp_central      :>  forall {a b c},    CentralMorphism (@ecomp a b c)
; eleft_identity     :   forall {a b  },    eid a ⋉ (a~~>b) >>> ecomp ~~ #(pmon_cancell _)
; eright_identity    :   forall {a b  },    (a~~>b) ⋊ eid b >>> ecomp ~~ #(pmon_cancelr _)
; eassociativity     :   forall {a b c d},  #(pmon_assoc _ _ (_~~>_))⁻¹ >>> ecomp ⋉ (c~~>d) >>> ecomp ~~ (a~~>b) ⋊ ecomp >>> ecomp
}.
Notation "a ~~> b" := (@ehom _ _ _ _ _ _ _ _ _ _ a b) : category_scope.
Coercion eob_eob : ECategory >-> Sortclass.

Lemma ecomp_is_functorial `{ec:ECategory}{a b c}{x}(f:EI~~{V}~~>(a~~>b))(g:EI~~{V}~~>(b~~>c)) :
   ((x ~~> a) ⋊-) \ (iso_backward (pmon_cancelr EI) >>> ((- ⋉EI) \ f >>> (((a ~~> b) ⋊-) \ g >>> ecomp))) >>> ecomp ~~
   ((x ~~> a) ⋊-) \ f >>> (ecomp >>> (#(pmon_cancelr (x ~~> b)) ⁻¹ >>> (((x ~~> b) ⋊-) \ g >>> ecomp))).

   set (@fmor_preserves_comp) as fmor_preserves_comp'.

   (* knock off the leading (x ~~> a) ⋊ f *)
   repeat setoid_rewrite <- associativity.
   set (ni_commutes (@pmon_cancelr _ _ _ _ _ _ mn) f) as qq.
   apply iso_shift_right' in qq.
   setoid_rewrite <- associativity in qq.
   apply symmetry in qq.
   apply iso_shift_left' in qq.
   apply symmetry in qq.
   simpl in qq.
   setoid_rewrite <- qq.
   clear qq.
   repeat setoid_rewrite associativity.
   repeat setoid_rewrite <- fmor_preserves_comp'.
   repeat setoid_rewrite associativity.
   apply comp_respects; try reflexivity.

   (* rewrite using the lemma *)
   assert (forall {a b c x}(g:EI~~{V}~~>(b ~~> c)),
    ((bin_second(BinoidalCat:=bc) (x ~~> a)) \ ((bin_second(BinoidalCat:=bc) (a ~~> b)) \ g))
    ~~
    (#(pmon_assoc (x ~~> a) _ _)⁻¹ >>>
     (bin_second(BinoidalCat:=bc) ((x ~~> a) ⊗ (a ~~> b))) \ g >>> #(pmon_assoc (x ~~> a) _ _))).
    symmetry.

    setoid_rewrite associativity.
    symmetry.
    apply iso_shift_right'.
    setoid_rewrite <- pmon_coherent_l.
    set (ni_commutes (pmon_assoc_ll (x0~~>a0) (a0~~>b0))) as qq.
    simpl in *.
    apply (qq _ _ g0).
   setoid_rewrite H.
   clear H.

   (* rewrite using eassociativity *)
   repeat setoid_rewrite associativity.
   set (@eassociativity _ _ _ _ _ _ _ _ _ ec x a) as qq.
   setoid_rewrite <- qq.
   clear qq.
   unfold e_v.

   (* knock off the trailing ecomp *)
   repeat setoid_rewrite <- associativity.
   apply comp_respects; try reflexivity.

   (* cancel out the adjacent assoc/cossa pair *)
   repeat setoid_rewrite associativity.
   setoid_rewrite juggle2.
   etransitivity.
   apply comp_respects; [ idtac |
   repeat setoid_rewrite <- associativity;
   etransitivity; [ idtac | apply left_identity ];
   apply comp_respects; [ idtac | reflexivity ];
   apply iso_comp1 ].
   apply reflexivity.

   (* now swap the order of ecomp⋉(b ~~> c) and ((x ~~> a) ⊗ (a ~~> b))⋊g *)
   repeat setoid_rewrite associativity.
   set (@centralmor_first) as se.
   setoid_rewrite <- se.
   clear se.

   (* and knock the trailing (x ~~> b)⋊ g off *)
   repeat setoid_rewrite <- associativity.
   apply comp_respects; try reflexivity.

   (* push the ecomp forward past the rlecnac *)
   set (ni_commutes (@pmon_cancelr _ _ _ _ _ _ mn) (@ecomp _ _ _ _ _ _ _ _ _ ec x a b)) as qq.
   symmetry in qq.
   apply iso_shift_left' in qq.
   setoid_rewrite associativity in qq.
   symmetry in qq.
   apply iso_shift_right' in qq.
   simpl in qq.
   setoid_rewrite qq.
   clear qq.

   (* and knock off the trailing ecomp *)
   apply comp_respects; try reflexivity.

   setoid_replace (iso_backward ((pmon_cancelr) ((x ~~> a) ⊗ (a ~~> b)))) with
     (iso_backward ((pmon_cancelr) ((x ~~> a) ⊗ (a ~~> b))) >>> id _).
   simpl.
   set (@iso_shift_right') as ibs.
   simpl in ibs.
   apply ibs.
   clear ibs.

   set (MacLane_ex_VII_1_1 (a~~>b) (x~~>a)) as q.
   simpl in q.
   setoid_rewrite <- q.
   clear q.
   setoid_rewrite juggle3.
   set (fmor_preserves_comp ((x ~~> a) ⋊-)) as q.
   simpl in q.
   setoid_rewrite q.
   clear q.
   setoid_rewrite iso_comp1.
   setoid_rewrite fmor_preserves_id.
   setoid_rewrite right_identity.
   apply iso_comp1.

   (* leftovers *)
   symmetry.
   apply right_identity.
   apply ecomp_central.
   Qed.

Lemma underlying_associativity `{ec:ECategory(mn:=mn)(EI:=EI)(Eob:=Eob)(Ehom:=Ehom)} :
   forall {a b : Eob} (f : EI ~~{ V }~~> a ~~> b) {c : Eob}
   (g : EI ~~{ V }~~> b ~~> c) {d : Eob} (h : EI ~~{ V }~~> c ~~> d),
   ((((#(pmon_cancelr EI) ⁻¹ >>> (f ⋉ EI >>> (a ~~> b) ⋊ g)) >>> ecomp) ⋉ EI >>> (a ~~> c) ⋊ h)) >>> ecomp ~~
   ((f ⋉ EI >>> (a ~~> b) ⋊ ((#(pmon_cancelr EI) ⁻¹ >>> (g ⋉ EI >>> (b ~~> c) ⋊ h)) >>> ecomp))) >>> ecomp.

  intros; symmetry; etransitivity;
     [ setoid_rewrite associativity; apply comp_respects;
        [ apply reflexivity | repeat setoid_rewrite associativity; apply (ecomp_is_functorial(x:=a) g h) ] | idtac ].

  repeat setoid_rewrite <- fmor_preserves_comp.
    repeat setoid_rewrite <- associativity.
    apply comp_respects; try reflexivity.
    apply comp_respects; try reflexivity.

  set (ni_commutes (@pmon_cancelr _ _ _ _ _ _ mn) f) as qq.
    apply iso_shift_right' in qq.
    symmetry in qq.
    setoid_rewrite <- associativity in qq.
    apply iso_shift_left' in qq.
    apply (fmor_respects (bin_first EI)) in qq.
    setoid_rewrite <- fmor_preserves_comp in qq.
    setoid_rewrite qq.
    clear qq.

  repeat setoid_rewrite <- fmor_preserves_comp.
    repeat setoid_rewrite associativity.
    apply comp_respects; try reflexivity.

  repeat setoid_rewrite associativity.
  set (ni_commutes (@pmon_cancelr _ _ _ _ _ _ mn) (@ecomp _ _ _ _ _ _ _ _ _ ec a b c)) as qq.
    apply iso_shift_right' in qq.
    symmetry in qq.
    setoid_rewrite <- associativity in qq.
    apply iso_shift_left' in qq.
    symmetry in qq.
    simpl in qq.
    setoid_rewrite qq.
    clear qq.

  repeat setoid_rewrite <- associativity.
    apply comp_respects; try reflexivity.

  idtac.
    set (iso_shift_left'
         (iso_backward (pmon_cancelr (a ~~> b)) ⋉ EI >>> ((a ~~> b) ⋊ g) ⋉ EI) ((a ~~> b) ⋊ g)
         ((pmon_cancelr ((a ~~> b) ⊗ (b ~~> c))))) as xx.
    symmetry.
    etransitivity; [ apply xx | apply comp_respects; try reflexivity ].
    clear xx.

  setoid_rewrite (fmor_preserves_comp (bin_first EI)).
    set (ni_commutes (@pmon_cancelr _ _ _ _ _ _ mn) ((iso_backward (pmon_cancelr (a ~~> b)) >>> (a ~~> b) ⋊ g))) as qq.
    simpl in qq.
    setoid_rewrite <- qq.
    clear qq.

  setoid_rewrite <- associativity.
    setoid_rewrite iso_comp1.
    apply left_identity.

  Qed.

Instance Underlying `(ec:ECategory(mn:=mn)(EI:=EI)(Eob:=Eob)(Ehom:=Ehom)) : Category Eob (fun a b => EI~>(a~~>b)) :=
{ id    := fun a                                  => eid a
; comp  := fun a b c g f                          => #(pmon_cancelr _)⁻¹ >>> (g ⋉ _ >>> _ ⋊ f) >>> ecomp
; eqv   := fun a b (f:EI~>(a~~>b))(g:EI~>(a~~>b)) => f ~~ g
}.
  abstract (intros; apply Build_Equivalence;
    [ unfold Reflexive
    | unfold Symmetric
    | unfold Transitive]; intros; simpl; auto).
  abstract (intros; unfold Proper; unfold respectful; intros; simpl;
  repeat apply comp_respects; try apply reflexivity;
    [ apply (fmor_respects (bin_first EI)) | idtac ]; auto;
    apply (fmor_respects (bin_second (a~~>b))); auto).
  abstract (intros;
    set (fun c d => centralmor_first(c:=c)(d:=d)(CentralMorphism:=(eid_central a))) as q;
    setoid_rewrite q;
    repeat setoid_rewrite associativity;
    setoid_rewrite eleft_identity;
    setoid_rewrite <- (ni_commutes (@pmon_cancell _ _ _ _ _ _ mn));
    setoid_rewrite <- associativity;
    set (coincide pmon_triangle) as qq;
    setoid_rewrite qq;
    simpl;
    setoid_rewrite iso_comp2;
    apply left_identity).
  abstract (intros;
    repeat setoid_rewrite associativity;
    setoid_rewrite eright_identity;
    setoid_rewrite <- (ni_commutes (@pmon_cancelr _ _ _ _ _ _ mn));
    setoid_rewrite <- associativity;
    simpl;
    setoid_rewrite iso_comp2;
    apply left_identity).
  abstract (intros;
    repeat setoid_rewrite associativity;
    apply comp_respects; try reflexivity;
    repeat setoid_rewrite <- associativity;
    apply underlying_associativity).
  Defined.
Coercion Underlying : ECategory >-> Category.

Class EFunctor
  `{mn:PreMonoidalCat(bc:=bc)(C:=V)(I:=EI)}
   {Eob1}{EHom1}(ec1:ECategory mn Eob1 EHom1)
   {Eob2}{EHom2}(ec2:ECategory mn Eob2 EHom2)
   (EFobj : Eob1 -> Eob2)
:=
{ efunc_fobj           := EFobj
; efunc                :  forall a b:Eob1, (a ~~> b) ~~{V}~~> ( (EFobj a) ~~> (EFobj b) )
; efunc_central        :  forall a b,      CentralMorphism (efunc a b)
; efunc_preserves_id   :  forall a,        eid a >>> efunc a a ~~ eid (EFobj a)
; efunc_preserves_comp :  forall a b c,    (efunc a b) ⋉ _ >>>  _ ⋊ (efunc b c) >>> ecomp ~~ ecomp >>> efunc a c
}.
Coercion efunc_fobj : EFunctor >-> Funclass.
Implicit Arguments efunc [ Ob Hom V bin_obj' bc EI mn Eob1 EHom1 ec1 Eob2 EHom2 ec2 EFobj ].

Definition efunctor_id
  `{mn:PreMonoidalCat(bc:=bc)(C:=V)(I:=EI)}
   {Eob1}{EHom1}(ec1:ECategory mn Eob1 EHom1)
   : EFunctor ec1 ec1 (fun x => x).
  refine {| efunc := fun a b => id (a ~~> b) |}.
  abstract (intros; apply Build_CentralMorphism; intros;
    setoid_rewrite fmor_preserves_id;
    setoid_rewrite right_identity;
    setoid_rewrite left_identity;
    reflexivity).
  abstract (intros; apply right_identity).
  abstract (intros;
    setoid_rewrite fmor_preserves_id;
    setoid_rewrite right_identity;
    setoid_rewrite left_identity;
    reflexivity).
  Defined.

Definition efunctor_comp
  `{mn:PreMonoidalCat(bc:=bc)(C:=V)(I:=EI)}
   {Eob1}{EHom1}(ec1:ECategory mn Eob1 EHom1)
   {Eob2}{EHom2}(ec2:ECategory mn Eob2 EHom2)
   {Eob3}{EHom3}(ec3:ECategory mn Eob3 EHom3)
   {Fobj}(F:EFunctor ec1 ec2 Fobj)
   {Gobj}(G:EFunctor ec2 ec3 Gobj)
   : EFunctor ec1 ec3 (Gobj ○ Fobj).
  refine {| efunc := fun a b => (efunc F a b) >>> (efunc G _ _) |}; intros; simpl.
  abstract (apply Build_CentralMorphism; intros;
    [ set (fun a b c d => centralmor_first(CentralMorphism:=(efunc_central(EFunctor:=F)) a b)(c:=c)(d:=d)) as fc1
    ; set (fun a b c d => centralmor_first(CentralMorphism:=(efunc_central(EFunctor:=G)) a b)(c:=c)(d:=d)) as gc1
    ; setoid_rewrite <- (fmor_preserves_comp (-⋉d))
    ; setoid_rewrite <- (fmor_preserves_comp (-⋉c))
    ; setoid_rewrite <- associativity
    ; setoid_rewrite <- fc1
    ; setoid_rewrite    associativity
    ; setoid_rewrite <- gc1
    ; reflexivity
    | set (fun a b c d => centralmor_second(CentralMorphism:=(efunc_central(EFunctor:=F)) a b)(c:=c)(d:=d)) as fc2
    ; set (fun a b c d => centralmor_second(CentralMorphism:=(efunc_central(EFunctor:=G)) a b)(c:=c)(d:=d)) as gc2
    ; setoid_rewrite <- (fmor_preserves_comp (d⋊-))
    ; setoid_rewrite <- (fmor_preserves_comp (c⋊-))
    ; setoid_rewrite <- associativity
    ; setoid_rewrite    fc2
    ; setoid_rewrite    associativity
    ; setoid_rewrite    gc2
    ; reflexivity ]).
  abstract (setoid_rewrite <- associativity;
    setoid_rewrite efunc_preserves_id;
    setoid_rewrite efunc_preserves_id;
    reflexivity).
  abstract (repeat setoid_rewrite associativity;
    set (fmor_preserves_comp (-⋉(b~~>c))) as q; setoid_rewrite <- q; clear q;
    repeat setoid_rewrite associativity;
    set (fmor_preserves_comp (((Gobj (Fobj a) ~~> Gobj (Fobj b))⋊-))) as q; setoid_rewrite <- q; clear q;
    set (fun d e => centralmor_second(c:=d)(d:=e)(CentralMorphism:=(efunc_central(EFunctor:=F) b c))) as qq;
    setoid_rewrite juggle2;
    setoid_rewrite juggle2;
    setoid_rewrite qq;
    clear qq;
    repeat setoid_rewrite associativity;
    set ((efunc_preserves_comp(EFunctor:=G)) (Fobj a) (Fobj b) (Fobj c)) as q;
    repeat setoid_rewrite associativity;
    repeat setoid_rewrite associativity in q;
    setoid_rewrite q;
    clear q;
    repeat setoid_rewrite <- associativity;
    apply comp_respects; try reflexivity;
    set ((efunc_preserves_comp(EFunctor:=F)) a b c) as q;
    apply q).
  Defined.

Instance UnderlyingFunctor `(EF:@EFunctor Ob Hom V bin_obj' bc EI mn Eob1 EHom1 ec1 Eob2 EHom2 ec2 Eobj)
  : Functor (Underlying ec1) (Underlying ec2) Eobj :=
  { fmor := fun a b (f:EI~~{V}~~>(a~~>b)) => f >>> (efunc _ a b) }.
  abstract (intros; simpl; apply comp_respects; try reflexivity; auto).
  abstract (intros; simpl; apply efunc_preserves_id).
  abstract (intros;
            simpl;
            repeat setoid_rewrite associativity;
            setoid_rewrite <- efunc_preserves_comp;
            repeat setoid_rewrite associativity;
              apply comp_respects; try reflexivity;
            set (@fmor_preserves_comp _ _ _ _ _ _ _ (bin_first EI)) as qq;
              setoid_rewrite <- qq;
              clear qq;
            repeat setoid_rewrite associativity;
              apply comp_respects; try reflexivity;
            repeat setoid_rewrite <- associativity;
              apply comp_respects; try reflexivity;
            set (@fmor_preserves_comp _ _ _ _ _ _ _ (bin_second (Eobj a ~~> Eobj b))) as qq;
              setoid_rewrite <- qq;
              repeat setoid_rewrite <- associativity;
              apply comp_respects; try reflexivity;
              clear qq;
            apply (centralmor_first(CentralMorphism:=(efunc_central a b)))).
  Defined.
  Coercion UnderlyingFunctor : EFunctor >-> Functor.

Class EBinoidalCat `(ec:ECategory)(bobj   :  ec -> ec -> ec) :=
{ ebc_first  :  forall a:ec, EFunctor ec ec (fun x => bobj x a)
; ebc_second :  forall a:ec, EFunctor ec ec (fun x => bobj a x)
; ebc_ec     := ec  (* this isn't a coercion - avoids duplicate paths *)
; ebc_bobj   := bobj
}.

Instance EBinoidalCat_is_binoidal `(ebc:EBinoidalCat(ec:=ec)) : BinoidalCat (Underlying ec) ebc_bobj.
  apply Build_BinoidalCat.
  unfold ebc_bobj; remember (fun a => UnderlyingFunctor (ebc_first a)) as f; apply f.
  unfold ebc_bobj; remember (fun a => UnderlyingFunctor (ebc_second a)) as f; apply f.
  Defined.

Coercion EBinoidalCat_is_binoidal : EBinoidalCat >-> BinoidalCat.

(* Enriched Fibrations *)
Section EFibration.

  Context `{E:ECategory}.
  Context  {Eob2}{Ehom2}{B:@ECategory Ob Hom V bin_obj' mn EI mn Eob2 Ehom2}.
  Context  {efobj}(F:EFunctor E B efobj).

  (*
   * A morphism is prone if its image factors through the image of
   * another morphism with the same codomain just in case the factor
   * is the image of a unique morphism.  One might say that it
   * "uniquely reflects factoring through morphisms with the same
   * codomain".
   *)
  Definition Prone {e:Eob}{e'}(φ:EI~~{V}~~>(e'~~>e)) :=
    forall (e'':Eob) (ψ:EI~~{V}~~>(e''~~>e)) (g:(efobj e'')~~{B}~~>(efobj e')),
       (comp(Category:=B) _ _ _ g (φ >>> (efunc F _ _))) ~~
       ψ >>> (efunc F _ _)
   ->  { χ:e''~~{E}~~>e' & ψ ~~ χ >>> φ & g ~~ comp(Category:=V) _ _ _ χ (efunc F e'' e') }.
       (* FIXME: χ must also be unique *)

  (* a functor is a Street Fibration if morphisms with codomain in its image are, up to iso, the images of prone morphisms *)

  (* Street was the first to define non-evil fibrations using isomorphisms (for cleavage_pf below) rather than equality *)
  Structure StreetCleavage (e:E)(b:B)(f:b~~{B}~~>(efobj e)) :=
  { cleavage_e'   : E
  ; cleavage_pf   : (efobj cleavage_e') ≅ b
  ; cleavage_phi  : cleavage_e' ~~{E}~~> e
  ; cleavage_cart : Prone cleavage_phi
  ; cleavage_eqv  : #cleavage_pf >>> f  ~~ comp(Category:=V) _ _ _ cleavage_phi (efunc F _ _)
  }.

  (* if V, the category enriching E and B is V-enriched, we get a functor Bop->Vint *)

  (* Every equivalence of categories is a Street fibration *)

  (* this is actually a "Street Fibration", the non-evil version of a Grothendieck Fibration *)
  Definition EFibration := forall e b f, exists cl:StreetCleavage e b f, True.

  Definition ClovenEFibration := forall e b f, StreetCleavage e b f.

  (*
   * Now, a language has polymorphic types iff its category of
   * judgments contains a second enriched category, the category of
   * Kinds, and the category of types is fibered over the category of
   * Kinds, and the weakening functor-of-fibers has a right adjoint.
   *
   * http://ncatlab.org/nlab/show/Grothendieck+fibration
   *
   * I suppose we'll need to also ask that the R-functors takes
   * Prone morphisms to Prone morphisms.
   *)
End EFibration.


(* https://www.ps.uni-saarland.de/autosubst/,
   only branch coq86-devel builds with the latest version of Coq. *)
Require Import Autosubst.Autosubst.

Module STLC.

Inductive ty : Type :=
  | TBool : ty
  | TArrow : ty -> ty -> ty.

Inductive tm : Type :=
  | tvar : var -> tm
  | tapp : tm -> tm -> tm
  | tabs : ty -> {bind tm} -> tm
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm.

Print _bind.

(* λ (x : Bool). x *)
Notation idB :=
  (tabs TBool (tvar 0)).

(* λ (x : Bool → Bool). x *)
Notation idBB :=
  (tabs (TArrow TBool TBool) (tvar 0)).

(* λ (x : (Bool → Bool) → Bool → Bool). x *)
Notation idBBBB :=
  (tabs (TArrow (TArrow TBool TBool)
                      (TArrow TBool TBool))
        (tvar 0)).

(* λ (x y : Bool). y *)
Notation k := (tabs TBool (tabs TBool (tvar 1))).

(* λ (x : Bool). if x then false else true *)
Notation notB := (tabs TBool (tif (tvar 0) tfalse ttrue)).

Instance Ids_tm : Ids tm. derive. Defined.
Instance Rename_tm : Rename tm. derive. Defined.
Instance Subst_tm : Subst tm. derive. Defined.
Instance SubstLemmas_tm : SubstLemmas tm. derive. Qed.

(* var -> tm *)
Print Ids_tm.

Compute (tapp (tvar 0) (tvar 1)).[idBB .: idB .: ids].

Print scons.
(*
(t .: σ) 0     = t
(t .: σ) (S n) = σ n
*)

(*
Print Subst_tm.
Subst_tm =
fix dummy (sigma : var -> tm) (s : tm) {struct s} : tm :=
  match s as t return (annot tm t) with
  | tvar v => sigma v
  | tapp s1 s2 => tapp s1.[sigma] s2.[sigma]
  | tabs T t => tabs T t.[up sigma]
  | ttrue => ttrue
  | tfalse => tfalse
  | tif s1 s2 s3 => tif s1.[sigma] s2.[sigma] s3.[sigma]
  end
     : Subst tm
 *)

Lemma up_unfold (σ : var -> tm) : up σ = (ids 0 .: σ >> ren (+1)).
  asimpl.
  trivial.
Qed.

Print up.
Print Rename_tm.

Lemma demo (σ : var -> tm) (u t : tm) : u.[up σ].[t.[σ] .: ids] = u.[t .: ids].[σ].
  (* asimpl. trivial. *)
  autosubst.
Qed.

Lemma rewriting_rules (σ τ θ : var -> tm) (s : tm) :
     ids >> σ = σ
  /\ σ >> ids = σ
  /\ (ids 0).[s .: σ] = s
  /\ ren (+1) >> (s .: σ) = σ
  /\ (σ >> τ) >> θ = σ >> (τ >> θ)
  /\ (s .: σ) >> τ = s.[τ] .: σ >> τ
  /\ s.[ids] = s
  /\ s.[σ].[τ] = s.[σ >> τ]
  /\ (ids 0).[σ] .: (ren (+1) >> σ) = σ
  /\ ids 0 .: ren (+1) = ids.
Proof.
  repeat split; autosubst.
Qed.

(* uses functional extensionality *)
Print subst_idX.

Lemma up_upren (ξ : var -> var) : up (ren ξ) = ren (upren ξ).
  autosubst.
Qed.

Lemma upren_unfold (xi : nat -> nat) :
               upren xi 0     = 0
  /\ forall n, upren xi (S n) = S (xi n).
  split. trivial. intro. trivial.
Qed.

(*
Print SubstLemmas.
Record SubstLemmas (term : Type) (Ids_term : Ids term)
(Rename_term : Rename term) (Subst_term : Subst term) : Prop
  := Build_SubstLemmas
  { rename_subst : forall (xi : var -> var) (s : term),
                   rename xi s = s.[ren xi];
    subst_id : forall s : term, s.[ids] = s;
    id_subst : forall (sigma : var -> term) (x : var),
               (ids x).[sigma] = sigma x;
    subst_comp : forall (sigma tau : var -> term) (s : term),
                 s.[sigma].[tau] = s.[sigma >> tau] }
*)

(* Exercise, give inductive spec for subst and prove it correct *)

Inductive substi (σ : var -> tm) : tm -> tm -> Prop :=
| s_var : forall n, substi σ (tvar n) (σ n)
| s_app : forall s s' t t',
            substi σ s s' -> substi σ t t' ->
            substi σ (tapp s t) (tapp s' t')
| s_abs : forall T t t',
            substi (up σ) t t' ->
            substi σ (tabs T t) (tabs T t')
| s_true : substi σ ttrue ttrue
| s_false : substi σ tfalse tfalse
| s_if : forall s t u s' t' u',
           substi σ s s' -> substi σ t t' -> substi σ u u' ->
           substi σ (tif s t u) (tif s' t' u').
Hint Constructors substi.

Theorem substi_correct : forall σ t t',
  subst σ t = t' <-> substi σ t t'.
Proof.
  intros. split.
  - intro. subst. generalize σ. clear σ.
           induction t; intros; asimpl; auto.
  - intro H. induction H; asimpl; congruence.
Qed.

Inductive value : tm -> Prop :=
  | v_abs : forall T t,
      value (tabs T t)
  | v_true :
      value ttrue
  | v_false :
      value tfalse.
Hint Constructors value.

Reserved Notation "t1 '⇒' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall T t12 v2,
         value v2 ->
         (tapp (tabs T t12) v2) ⇒ t12.[v2 .: ids]
  | ST_App1 : forall t1 t1' t2,
         t1 ⇒ t1' ->
         tapp t1 t2 ⇒ tapp t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ⇒ t2' ->
         tapp v1 t2 ⇒ tapp v1 t2'
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ⇒ t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ⇒ t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ⇒ t1' ->
      (tif t1 t2 t3) ⇒ (tif t1' t2 t3)

where "t1 '⇒' t2" := (step t1 t2).

Hint Constructors step.

Inductive multi {X:Type} (R: X -> X -> Prop) : X -> X -> Prop :=
  | multi_refl : forall (x : X), multi R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi R y z ->
                    multi R x z.

Notation multistep := (multi step).
Notation "t1 '⇒*' t2" := (multistep t1 t2) (at level 40).

Lemma step_example1 :
  (tapp idBB idB) ⇒* idB.
Proof.
  eapply multi_step.
  apply ST_AppAbs.
    apply v_abs.
  simpl.
  apply multi_refl.
Qed.

Lemma step_example2 :
  (tapp idBB (tapp idBB idB)) ⇒* idB.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto.
  eapply multi_step.
    apply ST_AppAbs. simpl. auto.
    simpl. apply multi_refl. Qed.

Lemma step_example3 :
  tapp (tapp idBB notB) ttrue ⇒* tfalse.
Proof.
  eapply multi_step.
    apply ST_App1. apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_IfTrue. apply multi_refl. Qed.

Lemma step_example4 :
  tapp idBB (tapp notB ttrue) ⇒* tfalse.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_IfTrue.
  eapply multi_step.
    apply ST_AppAbs. auto. simpl.
  apply multi_refl. Qed.

Tactic Notation "print_goal" :=
  match goal with |- ?x => idtac x end.

(* Tactic Notation "normalize" := *)
(*   repeat (print_goal; eapply multi_step ; *)
(*             [ (eauto 10; fail) | (instantiate; simpl)]); *)
(*   apply multi_refl. *)

Tactic Notation "normalize" :=
  repeat (print_goal; eapply multi_step ;
          [ (eauto 10; fail) | (instantiate; simpl)]);
  apply multi_refl.

Lemma step_example1' :
  (tapp idBB idB) ⇒* idB.
Proof. normalize. Qed.

Lemma step_example2' :
  (tapp idBB (tapp idBB idB)) ⇒* idB.
Proof. normalize. Qed.

Lemma step_example3' :
  tapp (tapp idBB notB) ttrue ⇒* tfalse.
Proof. normalize. Qed.

Lemma step_example4' :
  tapp idBB (tapp notB ttrue) ⇒* tfalse.
Proof. normalize. Qed.

Definition context := var -> option ty.

Definition empty : context := fun x => None.

Reserved Notation "Gamma '⊢' t '∈' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Γ x T,
      Γ x = Some T ->
      Γ ⊢ tvar x ∈ T
  | T_Abs : forall Γ T11 T12 t12,
      (Some T11 .: Γ) ⊢ t12 ∈ T12 ->
      Γ ⊢ tabs T11 t12 ∈ TArrow T11 T12
  | T_App : forall T11 T12 Γ t1 t2,
      Γ ⊢ t1 ∈ TArrow T11 T12 ->
      Γ ⊢ t2 ∈ T11 ->
      Γ ⊢ tapp t1 t2 ∈ T12
  | T_True : forall Γ,
       Γ ⊢ ttrue ∈ TBool
  | T_False : forall Γ,
       Γ ⊢ tfalse ∈ TBool
  | T_If : forall t1 t2 t3 T Γ,
       Γ ⊢ t1 ∈ TBool ->
       Γ ⊢ t2 ∈ T ->
       Γ ⊢ t3 ∈ T ->
       Γ ⊢ tif t1 t2 t3 ∈ T

where "Γ '⊢' t '∈' T" := (has_type Γ t T).

Hint Constructors has_type.

Example typing_example_1 :
  empty ⊢ tabs TBool (tvar 0) ∈ TArrow TBool TBool.
Proof.
  apply T_Abs. apply T_Var. reflexivity. Qed.

Example typing_example_1' :
  empty ⊢ tabs TBool (tvar 0) ∈ TArrow TBool TBool.
Proof. auto. Qed.

Lemma no_cycle (s : ty) (t : ty) : ~ (t = TArrow t s).
Proof.
generalize s. clear s.
induction t; intro; try discriminate. intro. inversion H.
eapply IHt1. eassumption.
Qed.

Example typing_nonexample_3 :
  ~ (exists S, exists T,
        empty ⊢
          (tabs S
             (tapp (tvar 0) (tvar 0))) ∈
          T).
Proof.
  intro.
  destruct H. destruct H. inversion H. subst. inversion H4.
  subst. inversion H3. inversion H6. subst. simpl in *. inversion H2.
  inversion H9. subst. apply no_cycle with T12 T11. congruence.
Qed.

Definition has_types (Γ : context)(σ : var -> tm) (Δ : context)
  := forall x T,  Δ x = Some T -> Γ ⊢ σ x ∈ T.

Lemma upren_typing : forall Γ σ Δ T,
                     has_types Γ (ren σ) Δ ->
                     has_types (Some T .: Γ) (ren (upren σ)) (Some T .: Δ).
Proof.
  intros * H. intros x U p.
  destruct x; simpl; eauto.
  - inversion p as [H1]. assert (tt := H x U H1). inversion tt. eauto.
Qed.

Lemma ren_typing : forall Γ σ Δ T t,
                     has_type Δ t T ->
                     has_types Γ (ren σ) Δ ->
                    has_type Γ t.[ren σ] T.
Proof.
  intros * tt. generalize Γ σ. clear Γ σ.
  induction tt; intros; asimpl; eauto.
  constructor. apply IHtt. apply upren_typing. assumption.
Qed.

(* Exercises *)

Lemma up_typing : forall Γ σ Δ T,
                    has_types Γ σ Δ ->
                    has_types (Some T .: Γ) (up σ) (Some T .: Δ).
Admitted.

Lemma substitution_preserves_typing : forall Γ Δ σ t T,
     Δ ⊢ t ∈ T ->
     has_types Γ σ Δ ->
     Γ ⊢ (t.[σ]) ∈ T.
Admitted.

Theorem preservation t t' T (tt : empty ⊢ t ∈ T) :
     t ⇒ t' ->
     empty ⊢ t' ∈ T.
Admitted.

Lemma canonical_forms_bool : forall t,
  empty ⊢ t ∈ TBool ->
  value t ->
  (t = ttrue) \/ (t = tfalse).
Admitted.

Lemma canonical_forms_fun : forall t T1 T2,
  empty ⊢ t ∈ (TArrow T1 T2) ->
  value t ->
  exists u, t = tabs T1 u.
Admitted.

Theorem progress : forall t T,
     empty ⊢ t ∈ T ->
     value t \/ exists t', t ⇒ t'.
Admitted.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** * Finite sets library *)

(** This module implements bridges (as functors) from dependent
    to/from non-dependent set signature. *)

Require Export FSetInterface.
Set Implicit Arguments.
Unset Strict Implicit.
Set Firstorder Depth 2.

(** * From non-dependent signature [S] to dependent signature [Sdep]. *)

Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.

  Definition empty : {s : t | Empty s}.
  Proof.
    exists empty; auto with set.
  Qed.

  Definition is_empty : forall s : t, {Empty s} + {~ Empty s}.
  Proof.
    intros; generalize (is_empty_1 (s:=s)) (is_empty_2 (s:=s)).
    case (is_empty s); intuition.
  Qed.

  Definition mem : forall (x : elt) (s : t), {In x s} + {~ In x s}.
  Proof.
    intros; generalize (mem_1 (s:=s) (x:=x)) (mem_2 (s:=s) (x:=x)).
    case (mem x s); intuition.
  Qed.

  Definition Add (x : elt) (s s' : t) :=
    forall y : elt, In y s' <-> E.eq x y \/ In y s.

  Definition add : forall (x : elt) (s : t), {s' : t | Add x s s'}.
  Proof.
    intros; exists (add x s); auto.
    unfold Add; intuition.
    elim (E.eq_dec x y); auto.
    intros; right.
    eapply add_3; eauto.
  Qed.

  Definition singleton :
    forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}.
  Proof.
    intros; exists (singleton x); intuition.
  Qed.

  Definition remove :
    forall (x : elt) (s : t),
    {s' : t | forall y : elt, In y s' <-> ~ E.eq x y /\ In y s}.
  Proof.
    intros; exists (remove x s); intuition.
    absurd (In x (remove x s)); auto with set.
    apply In_1 with y; auto.
    elim (E.eq_dec x y); intros; auto.
    absurd (In x (remove x s)); auto with set.
    apply In_1 with y; auto.
    eauto with set.
  Qed.

  Definition union :
    forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s \/ In x s'}.
  Proof.
    intros; exists (union s s'); intuition.
  Qed.

  Definition inter :
    forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ In x s'}.
  Proof.
    intros; exists (inter s s'); intuition; eauto with set.
  Qed.

  Definition diff :
    forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ ~ In x s'}.
  Proof.
    intros; exists (diff s s'); intuition; eauto with set.
    absurd (In x s'); eauto with set.
  Qed.

  Definition equal : forall s s' : t, {Equal s s'} + {~ Equal s s'}.
  Proof.
    intros.
    generalize (equal_1 (s:=s) (s':=s')) (equal_2 (s:=s) (s':=s')).
    case (equal s s'); intuition.
  Qed.

  Definition subset : forall s s' : t, {Subset s s'} + {~Subset s s'}.
  Proof.
    intros.
    generalize (subset_1 (s:=s) (s':=s')) (subset_2 (s:=s) (s':=s')).
    case (subset s s'); intuition.
  Qed.

  Definition elements :
    forall s : t,
    {l : list elt | sort E.lt l /\ (forall x : elt, In x s <-> InA E.eq x l)}.
   Proof.
     intros; exists (elements s); intuition.
   Defined.

  Definition fold :
    forall (A : Type) (f : elt -> A -> A) (s : t) (i : A),
    {r : A |   let (l,_) := elements s in
                  r = fold_left (fun a e => f e a) l i}.
  Proof.
  intros; exists (fold (A:=A) f s i); exact (fold_1 s i f).
  Qed.

  Definition cardinal :
      forall s : t,
      {r : nat | let (l,_) := elements s in r = length l }.
  Proof.
    intros; exists (cardinal s); exact (cardinal_1 s).
  Qed.

  Definition fdec (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x})
    (x : elt) := if Pdec x then true else false.

  Lemma compat_P_aux :
   forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}),
   compat_P E.eq P -> compat_bool E.eq (fdec Pdec).
  Proof.
    unfold compat_P, compat_bool, Proper, respectful, fdec; intros.
    generalize (E.eq_sym H0); case (Pdec x); case (Pdec y); firstorder.
  Qed.

  Hint Resolve compat_P_aux.

  Definition filter :
    forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t),
    {s' : t | compat_P E.eq P -> forall x : elt, In x s' <-> In x s /\ P x}.
  Proof.
    intros.
    exists (filter (fdec Pdec) s).
    intro H; assert (compat_bool E.eq (fdec Pdec)); auto.
    intuition.
    eauto with set.
    generalize (filter_2 H0 H1).
    unfold fdec.
    case (Pdec x); intuition.
    inversion H2.
    apply filter_3; auto.
    unfold fdec; simpl.
    case (Pdec x); intuition.
  Qed.

  Definition for_all :
    forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t),
    {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}.
  Proof.
    intros.
    generalize (for_all_1 (s:=s) (f:=fdec Pdec))
     (for_all_2 (s:=s) (f:=fdec Pdec)).
    case (for_all (fdec Pdec) s); unfold For_all; [ left | right ];
     intros.
    assert (compat_bool E.eq (fdec Pdec)); auto.
    generalize (H0 H3 Logic.eq_refl _ H2).
    unfold fdec.
    case (Pdec x); intuition.
    inversion H4.
    intuition.
    absurd (false = true); [ auto with bool | apply H; auto ].
    intro.
    unfold fdec.
    case (Pdec x); intuition.
  Qed.

  Definition exists_ :
    forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t),
    {compat_P E.eq P -> Exists P s} + {compat_P E.eq P -> ~ Exists P s}.
  Proof.
    intros.
    generalize (exists_1 (s:=s) (f:=fdec Pdec))
     (exists_2 (s:=s) (f:=fdec Pdec)).
    case (exists_ (fdec Pdec) s); unfold Exists; [ left | right ];
     intros.
    elim H0; auto; intros.
    exists x; intuition.
    generalize H4.
    unfold fdec.
    case (Pdec x); intuition.
    inversion H2.
    intuition.
    elim H2; intros.
    absurd (false = true); [ auto with bool | apply H; auto ].
    exists x; intuition.
    unfold fdec.
    case (Pdec x); intuition.
  Qed.

  Definition partition :
    forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t),
    {partition : t * t |
    let (s1, s2) := partition in
    compat_P E.eq P ->
    For_all P s1 /\
    For_all (fun x => ~ P x) s2 /\
    (forall x : elt, In x s <-> In x s1 \/ In x s2)}.
  Proof.
    intros.
    exists (partition (fdec Pdec) s).
    generalize (partition_1 s (f:=fdec Pdec)) (partition_2 s (f:=fdec Pdec)).
    case (partition (fdec Pdec) s).
    intros s1 s2; simpl.
    intros; assert (compat_bool E.eq (fdec Pdec)); auto.
    intros; assert (compat_bool E.eq (fun x => negb (fdec Pdec x))).
    generalize H2; unfold compat_bool, Proper, respectful; intuition;
     apply (f_equal negb); auto.
    intuition.
    generalize H4; unfold For_all, Equal; intuition.
    elim (H0 x); intros.
    assert (fdec Pdec x = true).
     eapply filter_2; eauto with set.
    generalize H8; unfold fdec; case (Pdec x); intuition.
    inversion H9.
    generalize H; unfold For_all, Equal; intuition.
    elim (H0 x); intros.
    cut ((fun x => negb (fdec Pdec x)) x = true).
    unfold fdec; case (Pdec x); intuition.
      change ((fun x => negb (fdec Pdec x)) x = true).
      apply (filter_2 (s:=s) (x:=x)); auto.
    set (b := fdec Pdec x) in *; generalize (Logic.eq_refl b);
     pattern b at -1; case b; unfold b;
     [ left | right ].
    elim (H4 x); intros _ B; apply B; auto with set.
    elim (H x); intros _ B; apply B; auto with set.
    apply filter_3; auto.
    rewrite H5; auto.
    eapply (filter_1 (s:=s) (x:=x) H2); elim (H4 x); intros B _; apply B;
     auto.
    eapply (filter_1 (s:=s) (x:=x) H3); elim (H x); intros B _; apply B; auto.
  Qed.

  Definition choose_aux: forall s : t,
    { x : elt | M.choose s = Some x } + { M.choose s = None }.
  Proof.
   intros.
   destruct (M.choose s); [left | right]; auto.
   exists e; auto.
  Qed.

  Definition choose : forall s : t, {x : elt | In x s} + {Empty s}.
  Proof.
   intros; destruct (choose_aux s) as [(x,Hx)|H].
   left; exists x; apply choose_1; auto.
   right; apply choose_2; auto.
  Defined.

  Lemma choose_ok1 :
   forall s x, M.choose s = Some x <-> exists H:In x s,
      choose s = inleft _ (exist (fun x => In x s) x H).
  Proof.
    intros s x.
    unfold choose; split; intros.
    destruct (choose_aux s) as [(y,Hy)|H']; try congruence.
    replace x with y in * by congruence.
    exists (choose_1 Hy); auto.
    destruct H.
    destruct (choose_aux s) as [(y,Hy)|H']; congruence.
  Qed.

  Lemma choose_ok2 :
   forall s, M.choose s = None <-> exists H:Empty s,
      choose s = inright _ H.
  Proof.
    intros s.
    unfold choose; split; intros.
    destruct (choose_aux s) as [(y,Hy)|H']; try congruence.
    exists (choose_2 H'); auto.
    destruct H.
    destruct (choose_aux s) as [(y,Hy)|H']; congruence.
  Qed.

  Lemma choose_equal : forall s s', Equal s s' ->
     match choose s, choose s' with
       | inleft (exist _ x _), inleft (exist _ x' _) => E.eq x x'
       | inright _, inright _  => True
       | _, _                        => False
     end.
  Proof.
   intros.
   generalize (@M.choose_1 s)(@M.choose_2 s)
              (@M.choose_1 s')(@M.choose_2 s')(@M.choose_3 s s')
              (choose_ok1 s)(choose_ok2 s)(choose_ok1 s')(choose_ok2 s').
   destruct (choose s) as [(x,Hx)|Hx]; destruct (choose s') as [(x',Hx')|Hx']; auto; intros.
   apply H4; auto.
   rewrite H5; exists Hx; auto.
   rewrite H7; exists Hx'; auto.
   apply Hx' with x; unfold Equal in H; rewrite <-H; auto.
   apply Hx with x'; unfold Equal in H; rewrite H; auto.
  Qed.

  Definition min_elt :
    forall s : t,
    {x : elt | In x s /\ For_all (fun y => ~ E.lt y x) s} + {Empty s}.
  Proof.
    intros;
     generalize (min_elt_1 (s:=s)) (min_elt_2 (s:=s)) (min_elt_3 (s:=s)).
    case (min_elt s); [ left | right ]; auto.
    exists e; unfold For_all; eauto.
  Qed.

  Definition max_elt :
    forall s : t,
    {x : elt | In x s /\ For_all (fun y => ~ E.lt x y) s} + {Empty s}.
  Proof.
    intros;
     generalize (max_elt_1 (s:=s)) (max_elt_2 (s:=s)) (max_elt_3 (s:=s)).
    case (max_elt s); [ left | right ]; auto.
    exists e; unfold For_all; eauto.
  Qed.

  Definition elt := elt.
  Definition t := t.

  Definition In := In.
  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
  Definition Subset s s' := forall a : elt, In a s -> In a s'.
  Definition Empty s := forall a : elt, ~ In a s.
  Definition For_all (P : elt -> Prop) (s : t) :=
    forall x : elt, In x s -> P x.
  Definition Exists (P : elt -> Prop) (s : t) :=
    exists x : elt, In x s /\ P x.

  Definition eq_In := In_1.

  Definition eq := Equal.
  Definition lt := lt.
  Definition eq_refl := eq_refl.
  Definition eq_sym := eq_sym.
  Definition eq_trans := eq_trans.
  Definition lt_trans := lt_trans.
  Definition lt_not_eq := lt_not_eq.
  Definition compare := compare.

  Module E := E.

End DepOfNodep.

(** * From dependent signature [Sdep] to non-dependent signature [S]. *)

Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
  Import M.

  Module ME := OrderedTypeFacts E.

  Definition empty : t := let (s, _) := empty in s.

  Lemma empty_1 : Empty empty.
  Proof.
    unfold empty; case M.empty; auto.
  Qed.

  Definition is_empty (s : t) : bool :=
    if is_empty s then true else false.

  Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true.
  Proof.
    intros; unfold is_empty; case (M.is_empty s); auto.
  Qed.

  Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s.
  Proof.
    intro s; unfold is_empty; case (M.is_empty s); auto.
    intros; discriminate H.
  Qed.

  Definition mem (x : elt) (s : t) : bool :=
    if mem x s then true else false.

  Lemma mem_1 : forall (s : t) (x : elt), In x s -> mem x s = true.
  Proof.
    intros; unfold mem; case (M.mem x s); auto.
  Qed.

  Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s.
  Proof.
    intros s x; unfold mem; case (M.mem x s); auto.
    intros; discriminate H.
  Qed.

  Definition eq_dec := equal.

  Definition equal (s s' : t) : bool :=
    if equal s s' then true else false.

  Lemma equal_1 : forall s s' : t, Equal s s' -> equal s s' = true.
  Proof.
    intros; unfold equal; case M.equal; intuition.
  Qed.

  Lemma equal_2 : forall s s' : t, equal s s' = true -> Equal s s'.
  Proof.
    intros s s'; unfold equal; case (M.equal s s'); intuition;
     inversion H.
  Qed.

  Definition subset (s s' : t) : bool :=
    if subset s s' then true else false.

  Lemma subset_1 : forall s s' : t, Subset s s' -> subset s s' = true.
  Proof.
    intros; unfold subset; case M.subset; intuition.
  Qed.

  Lemma subset_2 : forall s s' : t, subset s s' = true -> Subset s s'.
  Proof.
    intros s s'; unfold subset; case (M.subset s s'); intuition;
     inversion H.
  Qed.

  Definition choose (s : t) : option elt :=
    match choose s with
    | inleft (exist _ x _) => Some x
    | inright _ => None
    end.

  Lemma choose_1 : forall (s : t) (x : elt), choose s = Some x -> In x s.
  Proof.
    intros s x; unfold choose; case (M.choose s).
    simple destruct s0; intros; injection H; intros; subst; auto.
    intros; discriminate H.
  Qed.

  Lemma choose_2 : forall s : t, choose s = None -> Empty s.
  Proof.
    intro s; unfold choose; case (M.choose s); auto.
    simple destruct s0; intros; discriminate H.
  Qed.

  Lemma choose_3 : forall s s' x x',
   choose s = Some x -> choose s' = Some x' -> Equal s s' -> E.eq x x'.
  Proof.
  unfold choose; intros.
  generalize (M.choose_equal H1); clear H1.
  destruct (M.choose s) as [(?,?)|?]; destruct (M.choose s') as [(?,?)|?];
   simpl; auto; congruence.
  Qed.

  Definition elements (s : t) : list elt := let (l, _) := elements s in l.

  Lemma elements_1 : forall (s : t) (x : elt), In x s -> InA E.eq x (elements s).
  Proof.
    intros; unfold elements; case (M.elements s); firstorder.
  Qed.

  Lemma elements_2 : forall (s : t) (x : elt), InA E.eq x (elements s) -> In x s.
  Proof.
    intros s x; unfold elements; case (M.elements s); firstorder.
  Qed.

  Lemma elements_3 : forall s : t, sort E.lt (elements s).
  Proof.
    intros; unfold elements; case (M.elements s); firstorder.
  Qed.
  Hint Resolve elements_3.

  Lemma elements_3w : forall s : t, NoDupA E.eq (elements s).
  Proof. auto. Qed.

  Definition min_elt (s : t) : option elt :=
    match min_elt s with
    | inleft (exist _ x _) => Some x
    | inright _ => None
    end.

  Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s.
  Proof.
    intros s x; unfold min_elt; case (M.min_elt s).
    simple destruct s0; intros; injection H; intros; subst; intuition.
    intros; discriminate H.
  Qed.

  Lemma min_elt_2 :
   forall (s : t) (x y : elt), min_elt s = Some x -> In y s -> ~ E.lt y x.
  Proof.
    intros s x y; unfold min_elt; case (M.min_elt s).
    unfold For_all; simple destruct s0; intros; injection H; intros;
     subst; firstorder.
    intros; discriminate H.
  Qed.

  Lemma min_elt_3 : forall s : t, min_elt s = None -> Empty s.
  Proof.
    intros s; unfold min_elt; case (M.min_elt s); auto.
    simple destruct s0; intros; discriminate H.
  Qed.

  Definition max_elt (s : t) : option elt :=
    match max_elt s with
    | inleft (exist _ x _) => Some x
    | inright _ => None
    end.

  Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s.
  Proof.
    intros s x; unfold max_elt; case (M.max_elt s).
    simple destruct s0; intros; injection H; intros; subst; intuition.
    intros; discriminate H.
  Qed.

  Lemma max_elt_2 :
   forall (s : t) (x y : elt), max_elt s = Some x -> In y s -> ~ E.lt x y.
  Proof.
    intros s x y; unfold max_elt; case (M.max_elt s).
    unfold For_all; simple destruct s0; intros; injection H; intros;
     subst; firstorder.
    intros; discriminate H.
  Qed.

  Lemma max_elt_3 : forall s : t, max_elt s = None -> Empty s.
  Proof.
    intros s; unfold max_elt; case (M.max_elt s); auto.
    simple destruct s0; intros; discriminate H.
  Qed.

  Definition add (x : elt) (s : t) : t := let (s', _) := add x s in s'.

  Lemma add_1 : forall (s : t) (x y : elt), E.eq x y -> In y (add x s).
  Proof.
    intros; unfold add; case (M.add x s); unfold Add;
     firstorder.
  Qed.

  Lemma add_2 : forall (s : t) (x y : elt), In y s -> In y (add x s).
  Proof.
    intros; unfold add; case (M.add x s); unfold Add;
     firstorder.
  Qed.

  Lemma add_3 :
   forall (s : t) (x y : elt), ~ E.eq x y -> In y (add x s) -> In y s.
  Proof.
    intros s x y; unfold add; case (M.add x s); unfold Add;
     firstorder.
  Qed.

  Definition remove (x : elt) (s : t) : t := let (s', _) := remove x s in s'.

  Lemma remove_1 : forall (s : t) (x y : elt), E.eq x y -> ~ In y (remove x s).
  Proof.
    intros; unfold remove; case (M.remove x s); firstorder.
  Qed.

  Lemma remove_2 :
   forall (s : t) (x y : elt), ~ E.eq x y -> In y s -> In y (remove x s).
  Proof.
    intros; unfold remove; case (M.remove x s); firstorder.
  Qed.

  Lemma remove_3 : forall (s : t) (x y : elt), In y (remove x s) -> In y s.
  Proof.
    intros s x y; unfold remove; case (M.remove x s); firstorder.
  Qed.

  Definition singleton (x : elt) : t := let (s, _) := singleton x in s.

  Lemma singleton_1 : forall x y : elt, In y (singleton x) -> E.eq x y.
  Proof.
    intros x y; unfold singleton; case (M.singleton x); firstorder.
  Qed.

  Lemma singleton_2 : forall x y : elt, E.eq x y -> In y (singleton x).
  Proof.
    intros x y; unfold singleton; case (M.singleton x); firstorder.
  Qed.

  Definition union (s s' : t) : t := let (s'', _) := union s s' in s''.

  Lemma union_1 :
   forall (s s' : t) (x : elt), In x (union s s') -> In x s \/ In x s'.
  Proof.
    intros s s' x; unfold union; case (M.union s s'); firstorder.
  Qed.

  Lemma union_2 : forall (s s' : t) (x : elt), In x s -> In x (union s s').
  Proof.
    intros s s' x; unfold union; case (M.union s s'); firstorder.
  Qed.

  Lemma union_3 : forall (s s' : t) (x : elt), In x s' -> In x (union s s').
  Proof.
    intros s s' x; unfold union; case (M.union s s'); firstorder.
  Qed.

  Definition inter (s s' : t) : t := let (s'', _) := inter s s' in s''.

  Lemma inter_1 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s.
  Proof.
    intros s s' x; unfold inter; case (M.inter s s'); firstorder.
  Qed.

  Lemma inter_2 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s'.
  Proof.
    intros s s' x; unfold inter; case (M.inter s s'); firstorder.
  Qed.

  Lemma inter_3 :
   forall (s s' : t) (x : elt), In x s -> In x s' -> In x (inter s s').
  Proof.
    intros s s' x; unfold inter; case (M.inter s s'); firstorder.
  Qed.

  Definition diff (s s' : t) : t := let (s'', _) := diff s s' in s''.

  Lemma diff_1 : forall (s s' : t) (x : elt), In x (diff s s') -> In x s.
  Proof.
    intros s s' x; unfold diff; case (M.diff s s'); firstorder.
  Qed.

  Lemma diff_2 : forall (s s' : t) (x : elt), In x (diff s s') -> ~ In x s'.
  Proof.
    intros s s' x; unfold diff; case (M.diff s s'); firstorder.
  Qed.

  Lemma diff_3 :
   forall (s s' : t) (x : elt), In x s -> ~ In x s' -> In x (diff s s').
  Proof.
    intros s s' x; unfold diff; case (M.diff s s'); firstorder.
  Qed.

  Definition cardinal (s : t) : nat := let (f, _) := cardinal s in f.

  Lemma cardinal_1 : forall s, cardinal s = length (elements s).
  Proof.
    intros; unfold cardinal; case (M.cardinal s); unfold elements in *;
    destruct (M.elements s); auto.
  Qed.

  Definition fold (B : Type) (f : elt -> B -> B) (i : t)
    (s : B) : B := let (fold, _) := fold f i s in fold.

  Lemma fold_1 :
   forall (s : t) (A : Type) (i : A) (f : elt -> A -> A),
   fold f s i = fold_left (fun a e => f e a) (elements s) i.
  Proof.
    intros; unfold fold; case (M.fold f s i); unfold elements in *;
    destruct (M.elements s); auto.
  Qed.

  Definition f_dec :
    forall (f : elt -> bool) (x : elt), {f x = true} + {f x <> true}.
  Proof.
    intros; case (f x); auto with bool.
  Defined.

  Lemma compat_P_aux :
   forall f : elt -> bool,
   compat_bool E.eq f -> compat_P E.eq (fun x => f x = true).
  Proof.
     unfold compat_bool, compat_P, Proper, respectful, impl; intros;
      rewrite <- H1; firstorder.
  Qed.

  Hint Resolve compat_P_aux.

  Definition filter (f : elt -> bool) (s : t) : t :=
    let (s', _) := filter (P:=fun x => f x = true) (f_dec f) s in s'.

  Lemma filter_1 :
   forall (s : t) (x : elt) (f : elt -> bool),
   compat_bool E.eq f -> In x (filter f s) -> In x s.
  Proof.
    intros s x f; unfold filter; case M.filter as (x0,Hiff); intuition.
    generalize (Hiff (compat_P_aux H)); firstorder.
  Qed.

  Lemma filter_2 :
   forall (s : t) (x : elt) (f : elt -> bool),
   compat_bool E.eq f -> In x (filter f s) -> f x = true.
  Proof.
    intros s x f; unfold filter; case M.filter as (x0,Hiff); intuition.
    generalize (Hiff (compat_P_aux H)); firstorder.
  Qed.

  Lemma filter_3 :
   forall (s : t) (x : elt) (f : elt -> bool),
   compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
  Proof.
    intros s x f; unfold filter; case M.filter as (x0,Hiff); intuition.
    generalize (Hiff (compat_P_aux H)); firstorder.
  Qed.

  Definition for_all (f : elt -> bool) (s : t) : bool :=
    if for_all (P:=fun x => f x = true) (f_dec f) s
    then true
    else false.

  Lemma for_all_1 :
   forall (s : t) (f : elt -> bool),
   compat_bool E.eq f ->
   For_all (fun x => f x = true) s -> for_all f s = true.
  Proof.
    intros s f; unfold for_all; case M.for_all; intuition; elim n;
     auto.
  Qed.

  Lemma for_all_2 :
   forall (s : t) (f : elt -> bool),
   compat_bool E.eq f ->
   for_all f s = true -> For_all (fun x => f x = true) s.
  Proof.
    intros s f; unfold for_all; case M.for_all; intuition;
     inversion H0.
  Qed.

  Definition exists_ (f : elt -> bool) (s : t) : bool :=
    if exists_ (P:=fun x => f x = true) (f_dec f) s
    then true
    else false.

  Lemma exists_1 :
   forall (s : t) (f : elt -> bool),
   compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true.
  Proof.
    intros s f; unfold exists_; case M.exists_; intuition; elim n;
     auto.
  Qed.

  Lemma exists_2 :
   forall (s : t) (f : elt -> bool),
   compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s.
  Proof.
    intros s f; unfold exists_; case M.exists_; intuition;
     inversion H0.
  Qed.

  Definition partition (f : elt -> bool) (s : t) :
    t * t :=
    let (p, _) := partition (P:=fun x => f x = true) (f_dec f) s in p.

  Lemma partition_1 :
   forall (s : t) (f : elt -> bool),
   compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s).
  Proof.
    intros s f; unfold partition; case M.partition.
    intro p; case p; clear p; intros s1 s2 H C.
    generalize (H (compat_P_aux C)); clear H; intro H.
    simpl; unfold Equal; intuition.
    apply filter_3; firstorder.
    elim (H2 a); intros.
    assert (In a s).
     eapply filter_1; eauto.
    elim H3; intros; auto.
    absurd (f a = true).
    exact (H a H6).
    eapply filter_2; eauto.
  Qed.

  Lemma partition_2 :
   forall (s : t) (f : elt -> bool),
   compat_bool E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
  Proof.
    intros s f; unfold partition; case M.partition.
    intro p; case p; clear p; intros s1 s2 H C.
    generalize (H (compat_P_aux C)); clear H; intro H.
    assert (D : compat_bool E.eq (fun x => negb (f x))).
    generalize C; unfold compat_bool, Proper, respectful; intros; apply (f_equal negb);
     auto.
    simpl; unfold Equal; intuition.
    apply filter_3; firstorder.
    elim (H2 a); intros.
    assert (In a s).
     eapply filter_1; eauto.
    elim H3; intros; auto.
    absurd (f a = true).
    intro.
    generalize (filter_2 D H1).
    rewrite H7; intros H8; inversion H8.
    exact (H0 a H6).
  Qed.

  Definition elt := elt.
  Definition t := t.

  Definition In := In.
  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
  Definition Subset s s' := forall a : elt, In a s -> In a s'.
  Definition Add (x : elt) (s s' : t) :=
    forall y : elt, In y s' <-> E.eq y x \/ In y s.
  Definition Empty s := forall a : elt, ~ In a s.
  Definition For_all (P : elt -> Prop) (s : t) :=
    forall x : elt, In x s -> P x.
  Definition Exists (P : elt -> Prop) (s : t) :=
    exists x : elt, In x s /\ P x.

  Definition In_1 := eq_In.

  Definition eq := Equal.
  Definition lt := lt.
  Definition eq_refl := eq_refl.
  Definition eq_sym := eq_sym.
  Definition eq_trans := eq_trans.
  Definition lt_trans := lt_trans.
  Definition lt_not_eq := lt_not_eq.
  Definition compare := compare.

  Module E := E.

End NodepOfDep.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Coq.omega.Omega.
Require Import Reals.
Require Import Rsequence_def.
Require Import Rsequence_base_facts.
Require Import Rsequence_cv_facts.
Require Import Rsequence_rel_facts.
Require Import Rsequence_rewrite_facts.
Require Import MyRIneq MyReals Lra.
(** printing ~	~ *)
(** * Convergence of usual sequences. *)

(* Convergence of INR *)

Lemma Rseq_cv_pos_infty_INR : Rseq_cv_pos_infty INR.
Proof.
intros M ; pose (n := up (Rabs M)) ; assert (n_pos : (0 <= n)%Z).
 apply le_0_IZR ; transitivity (Rabs M).
  apply Rabs_pos.
  left ; destruct (archimed (Rabs M)) ; assumption.
 destruct (IZN _ n_pos) as [N HN] ; exists N.
 intros m m_lb ; apply Rlt_le_trans with (INR N).
 apply Rle_lt_trans with (Rabs M) ; [apply Rle_abs |].
 rewrite INR_IZR_INZ, <- HN ; destruct (archimed (Rabs M)) ; assumption.
 apply le_INR ; assumption.
Qed.

Lemma Rseq_poly_shifts_equiv : forall d k, (Rseq_poly d) ~ (Rseq_shifts (Rseq_poly d) k).
Proof.
intros d k eps eps_pos.
 assert (lemma : Rseq_cv (fun n => 1 - (1 + INR k / INR n) ^ d)%R 0).
  rewrite <- (Rplus_opp_r 1) ; apply Rseq_cv_minus_compat.
   apply Rseq_constant_cv.
   rewrite <- (pow1 d) ; apply Rseq_cv_pow_compat ; rewrite pow1.
   rewrite <- (Rplus_0_r 1) ; apply Rseq_cv_plus_compat.
    rewrite Rplus_0_r ; apply Rseq_constant_cv.
   rewrite <- (Rmult_0_r (INR k)) ; apply Rseq_cv_mult_compat.
    apply Rseq_constant_cv.
   apply Rseq_cv_pos_infty_inv_compat, Rseq_cv_pos_infty_INR.
 destruct (lemma _ eps_pos) as [N HN] ; exists (S N) ; intros n n_lb.
  transitivity (Rabs (1 - (1 + INR k / INR n) ^ d) * Rabs (Rseq_poly d n)).
   right ; rewrite <- Rabs_mult ; apply Rabs_eq_compat ;
   unfold Rseq_poly, Rseq_minus, Rseq_shift ; ring_simplify.
   rewrite Rplus_comm, Ropp_mult_distr_l_reverse, <- Rpow_mult_distr.
   apply Rplus_eq_compat_l, Ropp_eq_compat, Rpow_eq_compat.
   rewrite plus_INR ; field ; apply not_0_INR ; omega.
  apply Rmult_le_compat_r ; [apply Rabs_pos |].
  rewrite <- (Rminus_0_r (1 - _)) ; left ; apply HN ; omega.
Qed.

Lemma Rseq_poly_shift_equiv : forall d,
  (Rseq_poly d) ~ (Rseq_shift (Rseq_poly d)).
Proof.
intros d ; eapply Rseq_equiv_eq_compat, Rseq_poly_shifts_equiv.
 reflexivity.
 eapply Rseq_eq_trans.
  apply Rseq_shifts_shift.
  apply Rseq_shifts_0.
Qed.

(** Convergence of polynomials. *)

(**********)
Lemma Rseq_poly_cv : forall d, (d > 0)%nat -> Rseq_cv_pos_infty (Rseq_poly d).
Proof.
intros d H M.
assert (Hm : forall n, Rseq_poly d n >= INR n).
unfold Rseq_poly; induction H; intros n.
simpl; lra.
eapply Rge_trans with (INR n * INR n)%R.
rewrite <- tech_pow_Rmult.
apply Rmult_ge_compat_l; [apply Rle_ge; apply pos_INR|apply IHle].
destruct n; auto with real.
destruct n; auto with real.
left; rewrite <- Rmult_1_r.
apply Rmult_gt_compat_l.
apply lt_0_INR; omega.
apply lt_1_INR; omega.
destruct (IZN (up (Rmax 0 (M + 1)))) as [N Hz].
apply le_0_IZR.
destruct (archimed (Rmax 0 (M + 1))) as [Hp _].
left; eapply Rle_lt_trans; [apply RmaxLess1|eexact Hp].
exists N; intros n Hn.
eapply Rlt_le_trans with (INR n); [|apply Rge_le; apply Hm].
eapply Rlt_le_trans with (INR N); [|apply le_INR; assumption].
rewrite INR_IZR_INZ; rewrite <- Hz.
destruct (archimed (Rmax 0 (M + 1))) as [Hp _].
eapply Rlt_trans; [|eexact Hp].
eapply Rlt_le_trans with (M + 1)%R; [lra|apply RmaxLess2].
Qed.

(** Convergence of power sequences. *)

(**********)
Lemma Rseq_pow_eq_1_cv : Rseq_cv (Rseq_pow 1) 1.
Proof.
intros eps Heps.
exists 1%nat; intros n Hn.
assert (He : Rseq_pow 1 n = 1).
clear Hn; induction n; simpl; try rewrite IHn; field.
rewrite He; rewrite R_dist_eq; assumption.
Qed.

(**********)
Lemma Rseq_pow_lt_1_cv : forall r, 0 <= r < 1 -> Rseq_cv (Rseq_pow r) 0.
intros r [Hl Hr] eps Heps.
unfold R_dist; unfold Rseq_pow.
assert (exists N, forall n, (n >= N)%nat -> Rabs (r ^ n) < eps).
apply pow_lt_1_zero; [rewrite Rabs_right|]; try apply Rle_ge; assumption.
destruct H as [N H].
exists N; intros n Hn.
rewrite Rminus_0_r.
apply H; assumption.
Qed.

Lemma Rseq_pow_abs_compat : forall r, Rseq_pow (Rabs r) == Rseq_abs (Rseq_pow r).
Proof.
intros r n ; unfold Rseq_pow, Rseq_abs ; apply RPow_abs.
Qed.

Lemma Rseq_pow_lt_1_cv_strong : forall r, Rabs r < 1 -> Rseq_cv (Rseq_pow r) 0.
intros r H eps eps_pos ;
 assert (Hx : 0 <= Rabs r < 1) by (split ; [apply Rabs_pos | assumption]) ;
 destruct (Rseq_pow_lt_1_cv _ Hx _ eps_pos) as [N HN] ; exists N ; intros n n_lb.
 eapply Rle_lt_trans ; [| eapply HN ; eassumption].
  right ; unfold R_dist, Rseq_pow ; do 2 rewrite Rminus_0_r, <- RPow_abs ;
  rewrite Rabs_Rabsolu ; reflexivity.
Qed.

(**********)
Lemma Rseq_pow_gt_1_cv : forall r, r > 1 -> Rseq_cv_pos_infty (Rseq_pow r).
Proof.
intros r Hr M.
unfold Rseq_pow.
destruct (Pow_x_infinity r) with (b := (M + 1)%R) as [N HN].
rewrite Rabs_right; lra.
exists N; intros n Hn.
rewrite <- Rabs_right.
eapply Rlt_le_trans with (M + 1)%R; [lra|].
apply Rge_le; apply HN; assumption.
left; apply pow_lt; lra.
Qed.

(** Convergence of factorial. *)

(**********)
Lemma Rseq_fact_cv : Rseq_cv_pos_infty Rseq_fact.
Proof.
intros M.
assert (forall n, (INR n) <= Rseq_fact n).
unfold Rseq_fact.
intros n; apply le_INR.
destruct n.
simpl; repeat constructor.
rewrite fact_simpl.
pattern (S n) at 1; rewrite <- mult_1_r.
apply mult_le_compat_l.
induction n.
simpl; constructor.
rewrite fact_simpl; pattern 1%nat; rewrite <- mult_1_r.
apply mult_le_compat; omega.
destruct (IZN (up (Rmax 0 (M + 1)))) as [N Hz].
apply le_0_IZR.
destruct (archimed (Rmax 0 (M + 1))) as [Hp _].
left; eapply Rle_lt_trans; [apply RmaxLess1|eexact Hp].
exists N; intros n Hn.
eapply Rlt_le_trans with (INR n); [|apply H].
eapply Rlt_le_trans with (INR N); [|apply le_INR; assumption].
rewrite INR_IZR_INZ; rewrite <- Hz.
destruct (archimed (Rmax 0 (M + 1))) as [Hp _].
eapply Rlt_trans; [|eexact Hp].
eapply Rlt_le_trans with (M + 1)%R; [lra|apply RmaxLess2].
Qed.

(** * Growth comparison. *)

(**********)
Lemma Rseq_poly_little_O : forall d1 d2, (d1 < d2)%nat -> (Rseq_poly d1) = o(Rseq_poly d2).
Proof.
intros d1 d2 Hd.
intros eps Heps.
unfold Rseq_poly.
pose (k := (d2 - d1)%nat).
assert (Hk : (k > 0)%nat); [unfold k; omega|].
assert (HM : exists N, forall n, (n >= N)%nat -> /eps < Rseq_poly k n).
apply Rseq_poly_cv; assumption.
destruct HM as [N HN].
exists N; intros n Hn.
replace d2 with (d1 + k)%nat by (unfold k; omega).
rewrite pow_add; rewrite Rabs_mult.
rewrite Rmult_comm.
rewrite Rmult_assoc.
pattern (Rabs (INR n ^ d1)) at 1; rewrite <- Rmult_1_r.
apply Rmult_le_compat_l; [apply Rabs_pos|].
rewrite <- (Rinv_l eps); [|apply Rgt_not_eq; assumption].
apply Rmult_le_compat_r; [lra|].
rewrite Rabs_right; [|apply Rle_ge; apply pow_le; apply pos_INR].
left; apply HN; assumption.
Qed.

(**********)
Lemma Rseq_inv_poly_little_O : forall d1 d2, (d1 < d2)%nat -> (Rseq_inv_poly d2) = o(Rseq_inv_poly d1).
Proof.
intros d1 d2 Hd.
eapply Rseq_little_O_asymptotic.
  intros Wn Xn H; eexact H.
exists 1%nat.
eapply Rseq_little_O_eq_compat
  with (Un := fun n => / (INR (S n) ^ d2)) (Vn := fun n => (/ INR (S n) ^ d1)).
intros n; unfold Rseq_inv_poly.
replace (1 + n)%nat with (S n) by omega.
rewrite Rinv_pow; [reflexivity|auto with real].
intros n; unfold Rseq_inv_poly.
replace (1 + n)%nat with (S n) by omega.
rewrite Rinv_pow; [reflexivity|auto with real].
apply Rseq_little_O_inv_contravar.
intros eps Heps.
destruct (Rseq_poly_little_O d1 d2 Hd eps Heps) as [N HN].
exists N; intros n Hn; apply HN; omega.
intros n; apply pow_nonzero; auto with real.
intros n; apply pow_nonzero; auto with real.
Qed.

(**********)
Lemma Rseq_pow_little_O : forall r1 r2, (0 <= r1 < r2) -> (Rseq_pow r1) = o(Rseq_pow r2).
Proof.
intros r1 r2 [Hp Hr] eps Heps.
pose (k := (r1 / r2)%R).
assert (Hkl : 0 <= k).
unfold k; unfold Rdiv; replace 0 with (0 * 0)%R by field.
apply Rmult_le_compat; try apply Rle_refl; try lra.
left; apply Rinv_0_lt_compat; eapply Rle_lt_trans; eassumption.
assert (Hkr : k < 1).
unfold k; unfold Rdiv.
rewrite <- (Rinv_r r2).
apply Rmult_lt_compat_r; [|assumption].
apply Rinv_0_lt_compat; eapply Rle_lt_trans; [eexact Hp|eexact Hr].
apply Rgt_not_eq; eapply Rle_lt_trans; [eexact Hp|eexact Hr].
unfold Rseq_pow.
assert (Hk : exists N, forall n, (n >= N)%nat -> Rabs (k ^ n) < eps).
apply pow_lt_1_zero; [rewrite Rabs_right|]; try apply Rle_ge; assumption.
destruct Hk as [N HN].
exists N; intros n Hn.
replace r1 with (k * r2)%R.
assert ((k * r2) ^ n = k ^ n * r2 ^ n)%R as ->; swap 1 2.
rewrite Rabs_mult.
apply Rmult_le_compat_r; [apply Rabs_pos|].
left; apply HN; apply Hn.
clear Hn HN; induction n; simpl; try rewrite IHn; field.
unfold k; field; apply Rgt_not_eq; eapply Rle_lt_trans; [eexact Hp|eexact Hr].
Qed.

(**********)
Lemma Rseq_poly_pow_gt_1_little_O : forall d r, r > 1 -> (Rseq_poly d) = o(Rseq_pow r).
Proof.
intros d r Hr.
pose (npow := (fix F m d := match d with O => 1 | S d => m * F m d end)%nat).
(* Lack of a lemma in stdlib *)
assert (Hpow : (forall x y n, pow (x * y) n = pow x n * pow y n)%R).
intros x y n; induction n.
simpl; rewrite Rmult_1_l; reflexivity.
repeat rewrite <- tech_pow_Rmult; rewrite IHn; field.
(* end of lemma *)
assert (Ho : forall k, Rseq_poly (npow 2%nat k) = o(Rseq_pow r)).
induction k; simpl.
(* Case k = 0 *)
set (x := (r - 1)%R).
assert (Hx : x > 0); [unfold x; lra|].
assert (Hdev : forall n, (2 <= n)%nat -> (1 + x) ^ n >= 1 + INR n * x + (INR n * (INR n - 1)) * /2 * x * x).
intros n H; induction H.
simpl; right; field.
rewrite <- tech_pow_Rmult.
eapply Rge_trans.
apply Rmult_ge_compat_l; [lra|apply IHle].
repeat rewrite S_INR.
field_simplify.
unfold Rdiv; apply Rmult_ge_compat_r; [lra|].
assert (HINR : 1 < INR m); [apply lt_1_INR; omega|].
rewrite <- Rplus_0_l.
unfold Rminus; repeat rewrite Rplus_assoc.
rewrite <- Rplus_assoc.
apply Rplus_ge_compat_r.
rewrite <- Ropp_mult_distr_r_reverse.
rewrite <- Rmult_plus_distr_l.
rewrite <- (Rmult_0_l 0).
apply Rmult_ge_compat; try lra.
apply Rle_ge; apply pow_le; lra.
simpl.
pattern (INR m) at 3; rewrite <- Rmult_1_r.
rewrite <- Ropp_mult_distr_r_reverse.
rewrite <- Rmult_plus_distr_l.
rewrite <- (Rmult_0_l 0).
apply Rmult_ge_compat; try lra.
assert (Hmin : forall n, (2 <= n)%nat -> r ^ n > (INR n * (INR n - 1) * / 2 * x * x)).
intros n Hd.
replace r with (1 + x)%R by (unfold x; field).
rewrite <- Rplus_0_l.
eapply Rlt_le_trans; [|apply Rge_le; apply Hdev; assumption].
apply Rplus_lt_compat_r.
assert (HINR: 0 <= INR n); [apply pos_INR; omega|].
pattern 0; rewrite <- Rplus_0_l.
apply Rplus_lt_le_compat; [lra|].
apply Rmult_le_pos; lra.
assert (HO : (Rseq_poly 2) = O(fun n => INR n * (INR n - 1) * / 2 * x * x)%R).
unfold Rseq_poly.
exists (INR 4 * / x * / x)%R; split.
  apply Rle_ge; rewrite <- (Rmult_0_r 0).
  rewrite Rmult_assoc.
  apply Rmult_le_compat; try apply Rle_refl.
  apply pos_INR.
  left; apply Rmult_lt_0_compat; apply Rinv_0_lt_compat; assumption.
  exists 2%nat; intros n Hn.
  repeat rewrite Rabs_mult.
  repeat rewrite Rabs_right; try lra.
  simpl; field_simplify; [|apply Rgt_not_eq; assumption].
  replace ((4 * INR n ^ 2 - 4 * INR n) / 2)%R
    with (INR n * (2 * (INR n - 1)))%R by field.
  replace (INR n ^ 2 / 1)%R with (INR n * INR n)%R by field.
  apply Rmult_le_compat_l; [apply pos_INR|].
  replace 1%R with (INR 1) by reflexivity.
  rewrite <- minus_INR; [|omega].
  change 2 with (INR 2).
  rewrite <- 2mult_INR.
  apply le_INR; omega.
  replace 1%R with (INR 1) by reflexivity.
  rewrite <- minus_INR; [apply Rle_ge; apply pos_INR|omega].
  apply Rle_ge; apply pos_INR.
  apply Rle_ge; apply pow_le; apply pos_INR.
assert (HO2 : (fun n => INR n * (INR n - 1) * / 2 * x * x)%R = O(Rseq_pow r)).
  exists 1; split; [lra|].
  exists 2%nat; intros n Hn.
  rewrite Rabs_right; [rewrite Rabs_right|].
  left; rewrite Rmult_1_l; apply Hmin; assumption.
  apply Rle_ge; apply pow_le; lra.
  apply Rle_ge; left; repeat apply Rmult_lt_0_compat; try lra.
  apply lt_0_INR; omega.
  replace 1 with (INR 1) by reflexivity; rewrite <- minus_INR; [|omega].
  apply lt_0_INR; omega.
eapply Rseq_little_O_big_O_trans.
  apply (Rseq_poly_little_O 1 2); omega.
  eapply Rseq_big_O_trans.
    apply HO.
    apply HO2.
(* Case k > 0 *)
set (kk := npow 2%nat k).
rewrite plus_0_r.
replace (kk + kk)%nat
  with (2 * kk)%nat by ring.
intros eps Heps.
destruct (IHk (/ Rabs (2 ^ kk) * sqrt eps * / sqrt r))%R as [N HN].
repeat apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat; apply Rabs_pos_lt;
apply pow_nonzero; apply Rgt_not_eq; lra.
apply sqrt_lt_R0; lra.
apply Rinv_0_lt_compat; apply sqrt_lt_R0; lra.
exists (2 * N)%nat; intros n Hn.
unfold Rseq_poly; unfold Rseq_pow.
pose (m :=
  match Even.even_odd_dec n with
  | left evn => proj1_sig (Div2.even_2n n evn)
  | right odd => S (proj1_sig (Div2.odd_S2n n odd))
  end
).
assert (Hm : (n <= 2 * m /\ 2 * m <= S n)%nat).
destruct (Even.even_odd_dec n) as [Hm|Hm];
[destruct (Div2.even_2n n Hm) as [p Hp]|destruct (Div2.odd_S2n n Hm) as [p Hp]];
simpl in m; unfold Div2.double in Hp; unfold m; omega.
destruct Hm as [Hml Hmr].
apply Rle_trans with (Rabs (INR (2 * m) ^ (2 * kk))).
repeat rewrite Rabs_right.
apply pow_incr; split; [apply pos_INR|apply le_INR; assumption].
apply Rle_ge; apply pow_le; apply pos_INR.
apply Rle_ge; apply pow_le; apply pos_INR.
rewrite pow_Rsqr; rewrite mult_INR.
unfold Rsqr; repeat rewrite Hpow; repeat rewrite Rabs_mult; simpl.
eapply Rle_trans.
apply Rmult_le_compat.
replace 0 with (0 * 0)%R by field;
apply Rmult_le_compat; (apply Rle_refl || apply Rabs_pos).
replace 0 with (0 * 0)%R by field;
apply Rmult_le_compat; (apply Rle_refl || apply Rabs_pos).
change (1 + 1) with 2.
apply Rmult_le_compat_l; [apply Rabs_pos|]; apply HN; omega.
apply Rmult_le_compat_l; [apply Rabs_pos|]; apply HN; omega.
unfold Rseq_pow.
change (1 + 1) with 2.
field_simplify.
simpl; unfold Rdiv; repeat rewrite Rinv_1;
repeat rewrite Rmult_1_r.
rewrite sqrt_sqrt; [|lra].
rewrite sqrt_sqrt; [|lra].
rewrite Rmult_assoc.
apply Rmult_le_compat_l; [lra|].
pattern (/ r)%R at 1; rewrite <- Rabs_right; [|left; apply Rinv_0_lt_compat; lra].
repeat rewrite <- Rabs_mult.
rewrite <- pow_add.
repeat rewrite Rabs_right.
apply (Rmult_le_reg_l r); [lra|].
field_simplify.
unfold Rdiv; repeat rewrite Rinv_1; repeat rewrite Rmult_1_r.
rewrite tech_pow_Rmult.
apply Rle_pow; [lra|].
replace (m + m)%nat with (2 * m)%nat by ring; assumption.
apply Rgt_not_eq; lra.
apply Rle_ge; apply pow_le; lra.
replace 0 with (0 * 0)%R by field.
apply Rmult_ge_compat; try lra.
left; apply pow_lt; lra.
left; apply Rinv_0_lt_compat; lra.
split; apply Rgt_not_eq.
apply sqrt_lt_R0; lra.
apply Rabs_pos_lt; apply pow_nonzero; apply Rgt_not_eq; lra.
assert (Hp : (forall n, exists p, n < npow 2 p)%nat).
intros n.
destruct (zerop n) as [H|H].
exists 0%nat; simpl; omega.
induction H.
exists 1%nat; simpl; omega.
destruct IHle as [p Hp].
exists (S p); simpl; omega.
destruct (Hp d) as [dm Hdm].
apply Rseq_little_O_trans with (Rseq_poly (npow 2 dm)%nat).
apply Rseq_poly_little_O; assumption.
apply Ho.
Qed.

(**********)
Lemma Rseq_inv_poly_pow_lt_1_little_O : forall d r, 0 < r < 1 -> (Rseq_pow r) = o(Rseq_inv_poly d).
Proof.
intros d r [Hr1 Hr2].
eapply Rseq_little_O_asymptotic.
  intros Wn Xn H; eexact H.
exists 1%nat.
apply Rseq_little_O_eq_compat
  with (Un := fun n => / ((/ r) ^ (S n))) (Vn := fun n => (/ INR (S n) ^ d)).
intros n; unfold Rseq_pow.
replace (1 + n)%nat with (S n) by omega.
rewrite Rinv_pow; [|auto with real].
rewrite Rinv_involutive; [|auto with real].
reflexivity.
intros n; unfold Rseq_inv_poly.
replace (1 + n)%nat with (S n) by omega.
rewrite Rinv_pow; [|auto with real].
reflexivity.
apply Rseq_little_O_inv_contravar.
intros eps Heps.
destruct (Rseq_poly_pow_gt_1_little_O d (/ r)) with (eps := eps) as [N HN].
  rewrite <- Rinv_1.
  apply Rinv_lt_contravar.
  rewrite Rmult_1_r; assumption.
  assumption.
  assumption.
exists N; intros n Hn.
apply HN; omega.
intros n; apply pow_nonzero; auto with real.
intros n; apply pow_nonzero; auto with real.
Qed.

(**********)
Lemma Rseq_pow_fact_little_O : forall r, 0 <= r -> (Rseq_pow r) = o(Rseq_fact).
Proof.
assert (HO : forall n, Rseq_pow (INR n) = O(Rseq_fact)).
  intros n.
  assert (Hp: 0 <= INR n ^ n).
    apply pow_le; apply pos_INR.
  assert (Hf: / INR (fact n) > 0).
    apply Rinv_0_lt_compat.
    replace 0 with (INR 0) by reflexivity.
    apply lt_INR; apply lt_O_fact.
  exists (INR n ^ n / INR (fact n)); split.
    replace 0 with (0 * 0)%R by field.
    apply Rmult_ge_compat; try lra;
      try left; apply Hf.
  exists n; intros m Hm.
  induction Hm.
    rewrite Rabs_right; [|apply Rle_ge; apply Hp].
    rewrite Rabs_right; [|apply Rle_ge; apply pos_INR].
    right.
      unfold Rseq_pow; unfold Rseq_fact; field.
      apply Rgt_not_eq.
      replace 0 with (INR 0) by reflexivity.
      apply lt_INR; apply lt_O_fact.
    simpl; unfold Rseq_fact; rewrite fact_simpl.
    rewrite mult_INR.
    repeat rewrite Rabs_mult.
    set (K := INR n ^ n / INR (fact n)).
    replace (K * (Rabs (INR (S m)) * Rabs (INR (fact m))))
      with (Rabs (INR (S m)) * (K * (Rabs (INR (fact m)))))
      by field.
    apply Rmult_le_compat; try apply Rabs_pos.
    repeat rewrite Rabs_right; try (apply Rle_ge; apply pos_INR).
    apply le_INR; omega.
    apply IHHm.
intros r Hr.
destruct (IZN (up r)) as [d Hd].
  destruct (archimed r) as [H _].
  apply le_IZR.
  eapply Rle_trans.
    simpl; eexact Hr.
    left; eexact H.
apply Rseq_little_O_big_O_trans with (Rseq_pow (INR d)).
apply Rseq_pow_little_O; split.
  assumption.
  destruct (archimed r) as [H _].
  rewrite Hd in H.
  rewrite <- INR_IZR_INZ in H.
  exact H.
apply HO.
Qed.

(**********)
Lemma Rseq_poly_fact_little_O : forall d, Rseq_poly d = o(Rseq_fact).
Proof.
intros d.
eapply Rseq_little_O_trans.
apply Rseq_poly_pow_gt_1_little_O.
instantiate (1 := 2); lra.
apply Rseq_pow_fact_little_O; lra.
Qed.

(** * Things that don't have anything to do there... *)

(**********)
Lemma Rseq_ln_cv : Rseq_cv_pos_infty (fun n => ln (INR n)).
Proof.
intro m.
destruct (Rseq_poly_cv 1) with (M := Rabs m) as [N HN]; [omega|].
destruct (IZN(up (exp (INR N)))) as [N1 HN1].
  apply le_IZR; simpl.
  apply Rle_trans with (exp (INR N)).
    left; apply exp_pos.
  left; eapply (proj1 (archimed _)).
exists N1.
intros n Hn.
apply Rle_lt_trans with (Rabs m).
  apply RRle_abs.
apply Rlt_le_trans with (INR N).
  replace (INR N) with (INR N ^ 1) by field.
  apply (HN _ (le_refl _)).
rewrite <- ln_exp with (INR N).
left; apply ln_increasing.
  apply exp_pos.
apply Rlt_le_trans with (IZR (Z_of_nat N1)).
  rewrite <- HN1.
  apply (proj1(archimed _)).
rewrite <- INR_IZR_INZ; apply le_INR; apply Hn.
Qed.


From iVM Require Export Mixer.

Require Import Coq.Logic.ProofIrrelevance.

Unset Suggest Proof Using.

Ltac collapse p q :=
  let HH := fresh "HH" in
  assert (p = q) as HH; [ apply proof_irrelevance | destruct HH ].

Proposition mixerEq_is_eq {A} (f g: Mixer A) (H: f ≃ g) : f = g.
Proof.
  destruct f as [f f_id f_left f_right].
  destruct g as [g g_id g_left g_right].
  unfold mixerEq in H.
  cbn in H.
  assert (f = g) as HH.
  - extensionality x.
    extensionality y.
    apply H.
  - destruct HH. clear H.
    collapse f_id g_id.
    collapse f_left g_left.
    collapse f_right g_right.
    reflexivity.
Qed.

Section opp_section.

  (** This easily leads to loops. *)
  #[refine] Instance oppMixer {A} (f: Mixer A) : Mixer A :=
  {
    mixer x y := f y x;
  }.
  Proof.
    all: intros; mixer_rewrite0; reflexivity.
  Defined.

End opp_section.

Proposition opp_fstMixer {A} : oppMixer fstMixer ≃ @sndMixer A.
Proof.
  intros x y. reflexivity.
Qed.

Proposition opp_oppMixer {A} (f: Mixer A) : oppMixer (oppMixer f) ≃ f.
Proof.
  intros x y. reflexivity.
Qed.

Proposition independent_spec {A} (f g: Mixer A) :
  Independent f g <-> (f | oppMixer g).
Proof.
  split; intros H x y z; apply H.
Qed.


(*
 * Copyright (c) 2009-2011, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

(* This file contains the class of decidable equality and associated theory
    of updateable functions. *)

Require Import msl.base.

(* Class of decidable equality *)
Class EqDec (A : Type) : Type :=
  eq_dec : forall a a' : A, {a = a'} + {a <> a'}.

Instance EqDec_nat : EqDec nat := eq_nat_dec.

(* Theory of updateable functions, defined over decideable domain *)
Definition upd {A} `{EqDec A} (B : Type) (f : A -> B) (a : A) (b : B) : A -> B :=
  fun a' => if eq_dec a a' then b else f a'.
Implicit Arguments upd [A H B].

Lemma upd_eq {A} `{EqDec A} : forall B (f : A -> B) a b,
  upd f a b a = b.
Proof with auto.
  intros.
  unfold upd.
  case (eq_dec a a)...
  intro.
  destruct n...
Qed.
Implicit Arguments upd_eq [A H B].

Lemma upd_eq' {A} `{EqDec A} : forall B (f : A -> B) a b a',
  a = a' ->
  upd f a b a' = b.
Proof.
  intros. subst a'. apply upd_eq.
Qed.
Implicit Arguments upd_eq' [A H B].

Lemma upd_neq {A} `{EqDec A} : forall B (f : A -> B) a b a',
  a <> a' ->
  upd f a b a' = f a'.
Proof with auto.
  intros.
  unfold upd.
  case (eq_dec a a')...
  intros.
  subst a'.
  destruct H0...
Qed.
Implicit Arguments upd_neq [A H B].

Instance nat_eq_dec: EqDec nat.
Proof.
  repeat intro.
 destruct (lt_eq_lt_dec a a') as [[?|?]| ?]; auto;
  right; intro; subst; eapply lt_irrefl; eauto.
Defined.

Instance EqDec_prod (A: Type) (EA: EqDec A) (B: Type) (EB: EqDec B) : EqDec (A*B).
Proof.
 hnf. decide equality; try apply eq_dec.
Defined.

Instance EqDec_list (A: Type) (EA: EqDec A) : EqDec (list A).
Proof.
 hnf. apply list_eq_dec; intros; apply EA.
Defined.