Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.MinimunLogic.ProofTheory.RewriteClass.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.DeepEmbedded.Parameter.
Require Logic.SeparationLogic.DeepEmbedded.SeparationEmpLanguage.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.

Class Parametric_SeparationLogic (PAR: SL_Parameter) (L: Language) {minL: MinimunLanguage L} {pL: PropositionalLanguage L} {sL: SeparationLanguage L} {s'L: SeparationEmpLanguage L} (Gamma: ProofTheory L) {AX: NormalAxiomatization L Gamma} {minAX: MinimunAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} {sGamma: SeparationLogic L Gamma} {eGamma: EmpSeparationLogic L Gamma} := {
  Parametric_DM: WEM = true -> DeMorganPropositionalLogic L Gamma;
  Parametric_GD: IC = true -> GodelDummettPropositionalLogic L Gamma;
  Parametric_C: EM = true -> ClassicalPropositionalLogic L Gamma;
  Parametric_GC: SCE = true -> GarbageCollectSeparationLogic L Gamma;
  Parametric_NE: ESE = true -> NonsplitEmpSeparationLogic L Gamma;
  Parametric_ED: ED = true -> DupEmpSeparationLogic L Gamma
}.

Section SeparationLogic.

Context {Sigma: SeparationEmpLanguage.PropositionalVariables}.

Existing Instances SeparationEmpLanguage.L SeparationEmpLanguage.minL SeparationEmpLanguage.pL SeparationEmpLanguage.sL SeparationEmpLanguage.s'L.

Context (PAR: SL_Parameter).

Inductive provable: expr -> Prop :=
| modus_ponens: forall x y, provable (x --> y) -> provable x -> provable y
| axiom1: forall x y, provable (x --> (y --> x))
| axiom2: forall x y z, provable ((x --> y --> z) --> (x --> y) --> (x --> z))
| andp_intros: forall x y, provable (x --> y --> x && y)
| andp_elim1: forall x y, provable (x && y --> x)
| andp_elim2: forall x y, provable (x && y --> y)
| orp_intros1: forall x y, provable (x --> x || y)
| orp_intros2: forall x y, provable (y --> x || y)
| orp_elim: forall x y z, provable ((x --> z) --> (y --> z) --> (x || y --> z))
| falsep_elim: forall x, provable (FF --> x)
| weak_excluded_middle: WEM = true -> forall x, provable (~~ x || ~~ ~~ x)
| impp_choice: IC = true -> forall x y, provable ((x --> y) || (y --> x))
| excluded_middle: EM = true -> forall x, provable (x || ~~ x)
| sepcon_comm: forall x y, provable (x * y --> y * x)
| sepcon_assoc: forall x y z, provable (x * (y * z) <--> (x * y) * z)
| wand_sepcon_adjoint1: forall x y z, provable (x * y --> z) -> provable (x --> (y -* z))
| wand_sepcon_adjoint2: forall x y z, provable (x --> (y -* z)) -> provable (x * y --> z)
| sepcon_emp: forall x, provable (x * emp <--> x)
| sepcon_elim1: SCE = true -> forall x y, provable (x * y --> x)
| emp_sepcon_truep_elim: ESE = true -> forall x, provable (x * TT && emp --> x)
| emp_dup: ED = true -> forall x, provable (x && emp --> x * x).

Instance G: ProofTheory SeparationEmpLanguage.L := Build_AxiomaticProofTheory provable.

Instance AX: NormalAxiomatization SeparationEmpLanguage.L G := Build_AxiomaticProofTheory_AX provable.

Instance minAX: MinimunAxiomatization SeparationEmpLanguage.L G.
Proof.
  constructor.
  + apply modus_ponens.
  + apply axiom1.
  + apply axiom2.
Qed.

Instance ipG: IntuitionisticPropositionalLogic SeparationEmpLanguage.L G.
Proof.
  constructor.
  + apply andp_intros.
  + apply andp_elim1.
  + apply andp_elim2.
  + apply orp_intros1.
  + apply orp_intros2.
  + apply orp_elim.
  + apply falsep_elim.
Qed.

Instance sG: SeparationLogic SeparationEmpLanguage.L G.
Proof.
  constructor.
  + apply sepcon_comm.
  + apply sepcon_assoc.
  + intros; split.
    - apply wand_sepcon_adjoint1.
    - apply wand_sepcon_adjoint2.
Qed.

Instance eG: EmpSeparationLogic SeparationEmpLanguage.L G.
Proof.
  constructor.
  intros.
  apply sepcon_emp.
Qed.

Instance ParG: Parametric_SeparationLogic PAR SeparationEmpLanguage.L G.
Proof.
  constructor.
  + intros; constructor.
    apply weak_excluded_middle; auto.
  + intros; constructor.
    apply impp_choice; auto.
  + intros; constructor.
    apply excluded_middle; auto.
  + intros; constructor.
    apply sepcon_elim1; auto.
  + intros; constructor.
    apply emp_sepcon_truep_elim; auto.
  + intros; constructor.
    apply emp_dup; auto.
Qed.

End SeparationLogic.


Require Import Basics Types Fibrations.
Require Import Diagram Colimit Colimit_Sigma MappingTelescope KernelPair MyLemmas MyTacs.

Local Open Scope path_scope.
Generalizable All Variables.

Context `{Funext}.

Definition transport_hfiber `(f: A -> B) `(e: b = b') `(p: f a = b)
: transport (λ b, hfiber f b) e (a; p) = (a; p @ e).
  path_induction. reflexivity.
Defined.

Definition functor_fibration_replacement `{f: X -> Y} `{f': X' -> Y} (g: X -> X')
           (e: f' o g == f)
: sig (hfiber f) → sig (hfiber f')
  := λ x, (x.1; (g x.2.1; (e x.2.1) @ x.2.2)).

Definition fibration_replacement_commute `(g: X -> X') `(f: X -> Y) (f': X' -> Y) (e: f' o g == f)
: (functor_fibration_replacement g e) o (equiv_fibration_replacement f) == (equiv_fibration_replacement f') o g.
  intros x; simpl.
  simple refine (path_sig_hfiber (f:=f') _ _ _). reflexivity.
Defined.

Definition popopo2 `(f: X -> Y) {A: Type} (y: Y) (e: (hfiber f y) <~>  A)
: {e': hfiber (KP_lift f (KP_colimit f)) y <~> T A & α o e == e' o (λ x: hfiber f y, (kp x.1; x.2))}.
  simple refine (exist _ _ _).
  - etransitivity.
    simple refine (KP_lift_hfiber (Q2 := λ y, T (hfiber f y)) _ _ _ _).
    intros; apply T_colimit.
    simple refine (functoriality_colimit_equiv _ (T_colimit _) (T_colimit _)).
    simple refine (T_diag_equiv _). exact e.
  - intros [x p].
    pose (Te := functoriality_colimit (T_diag_equiv e) (T_colimit _) (T_colimit _)).
    transitivity (Te (α (x; p))). symmetry.
    simple refine (functoriality_colimit_commute (T_diag_equiv e) _ _ false (x; p))^.
    match goal with
      | |- ?AA = _ (transitive_equiv _ _ _ ?ee1 ?ee4) ?xx =>
        change (AA = ee4 (ee1 (kp x; p))); set (e4 := equiv_fun ee4)
    end. unfold KP_lift_hfiber.
    match goal with
      | |- ?AA = e4 (_ (transitive_equiv _ _ _ ?ee1 ?ee2) ?xx) =>
        change (AA = e4 (ee2 (ee1 (kp x; p)))); set (e1 := equiv_fun ee1)
    end.
    match goal with
      | |- ?AA = e4 (_ (transitive_equiv _ _ _ ?ee2 ?ee3) ?xx) =>
        change (AA = e4 (ee3 (ee2 xx))); set (e2 := equiv_fun ee2); set (e3 := equiv_fun ee3)
    end.
    set (sl := equiv_fun (KP_slicing f (KP_colimit f) (λ y0 : Y, T_colimit (hfiber f y0)))) in *.
    symmetry. etransitivity (e4 (e3 (e2 (sl (kp x); _)))). f_ap.
    subst e1.
    etransitivity (e4 (e3 (sl (kp x); _))). f_ap.
    subst e2.
    match goal with
      | |- e4 (e3 (_; ?ppp)) = _ => set (pp := ppp)
    end.
    etransitivity (e4 (transport (λ y0 : Y, T (hfiber f y0)) pp (sl (kp x)).2)). reflexivity.
    clear e3. f_ap. clear e4.
    change (transport (λ y, T (hfiber f y)) pp (α (x; 1)) = α (x;p)).
    etransitivity.
    simple refine (transport_colimit _ (λ y, T_colimit (hfiber f y)) pp false (x; 1)).
    apply β.
Defined.

Section CechNerve.

  Context {X Y: Type} (f: X -> Y).

  Definition CechNerve_aux (n: nat) : {T: Type & T -> Y}.
    induction n.
    - exists X. exact f.
    - exists (KP IHn.2). simple refine (KP_lift _ (KP_colimit _)).
  Defined.

  Let fn := λ n, (CechNerve_aux n).2.

  Definition CechNerve : diagram mappingtelescope_graph.
    simple refine (Build_diagram _ _ _).
    - intros n. exact (CechNerve_aux n).1.
    - intros n m q; destruct q; simpl. apply kp.
  Defined.

  Definition SlicedCechNerve1 (y: Y) : diagram mappingtelescope_graph.
    simple refine (Build_diagram _ _ _).
    - intros n. exact (hfiber (fn n) y).
    - intros n m q x; destruct q; simpl in *.
      exists (kp x.1). exact x.2.
  Defined.

  Definition SlicedCechNerve_equiv1 : CechNerve ≃ (sigma_diag SlicedCechNerve1).
    simple refine (Build_diagram_equiv (Build_diagram_map _ _) _).
    - intros n; simpl. apply equiv_fibration_replacement.
    - intros n m q; destruct q; simpl in *.
      exact (fibration_replacement_commute kp (fn n) (fn n.+1) (λ _,1)).
    - intros n; simpl. apply (equiv_fibration_replacement (fn n)).
  Defined.

  Let auxT (y: Y) (n: nat) : Type   (* := T^n (hfiber f y) *)
    := (nat_rect (λ _, Type) (hfiber f y) (λ _ X, T X) n).

  Definition SlicedCechNerve2 (y: Y) : diagram mappingtelescope_graph.
    simple refine (Build_diagram _ _ _).
    - intros n; exact (auxT y n).
    - intros i j q; destruct q; simpl. apply α.
  Defined.

  Definition SlicedCechNerve_equiv2 (y: Y) : (SlicedCechNerve1 y) ≃ (SlicedCechNerve2 y).
    simple refine (equiv_mappingtelescope_diag _ _ _ _); simpl.
    apply reflexive_equiv.
    intros n e. simple refine (popopo2 _ _ _).
  Defined.

  Definition SlicedCechNerve_equiv : CechNerve ≃ (sigma_diag SlicedCechNerve2).
    etransitivity. apply SlicedCechNerve_equiv1.
    simple refine (sigma_diag_functor_equiv _ _ _).
    apply SlicedCechNerve_equiv2.
  Defined.
End CechNerve.

(*  *)


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Basic_Cons.CCC Basic_Cons.PullBack.
Require Import Ext_Cons.Comma.
Require Import Ext_Cons.Arrow.
Require Import Archetypal.Discr.Discr.
Require Import Functor.Const_Func Functor.Functor_Ops.

(** A category is locally cartesian closed if all its slices are
    cartesian closed!. *)
Section Slice_Terminal.
  Context (C : Category) (c : C).

  (** Notation for easier construction of objects of comma out of an arrow
      z : ? → c. *)
  Local Notation CA z :=
    (Build_Comma_Obj (Functor_id C) (Const_Func 1 c) _ tt z) (only parsing).

  (** Every slice category C/c has a terminal object (id c). *)
  Program Instance Slice_Terminal : (𝟙_ (Slice C c))%object :=
    {
      terminal := CA id;
      t_morph :=
        fun d =>
          {|
            CMH_left := (CMO_hom d);
            CMH_right :=
              match (CMO_trg d) as u return
                    Hom 1 u tt
              with
                tt => id
              end
          |}
    }.

  Next Obligation.
  Proof.
    apply Comma_Hom_eq_simplify.
    set (W := eq_trans (eq_sym (CMH_com f)) (CMH_com g)); cbn in W; auto.
    match goal with [|- ?A = ?B] => destruct A; destruct B; trivial end.
  Qed.

End Slice_Terminal.

Section PullBack_Slice_Prod.
  Context {C : Category} {c : C} {f g : Slice C c}
          (PB : PullBack (CMO_hom f) (CMO_hom g)).

  (** Notation for easier construction of objects of comma out of an arrow
      z : ? → c. *)
  Local Notation CA z :=
    (Build_Comma_Obj (Functor_id C) (Const_Func 1 c) _ tt z) (only parsing).

  (** Pullbacks are products in slices. *)
  Program Definition PullBack_Slice_Prod : (f × g)%object :=
    {|
      product := CA ((CMO_hom f) ∘ (pullback_morph_1 PB));
      Pi_1 :=
        {|
          CMH_left := pullback_morph_1 PB;
          CMH_right :=
            match (CMO_trg f) as u return
                  Hom 1 u tt
            with
              tt => id
            end
        |};
      Pi_2 :=
        {|
          CMH_left := pullback_morph_2 PB;
          CMH_right :=
            match (CMO_trg g) as u return
                  Hom 1 u tt
            with
              tt => id
            end
        |};
      Prod_morph_ex :=
        fun _ r1 r2 =>
          Build_Comma_Hom
            _
            _
            _
            (CA ((CMO_hom f) ∘ pullback_morph_1 PB))
            (pullback_morph_ex PB _ (CMH_left r1) (CMH_left r2) _)
            tt
            _
    |}.

  Local Obligation Tactic := idtac.

  Next Obligation.
  Proof.
    cbn; simpl_ids; apply pullback_morph_com.
  Qed.

  Next Obligation.
  Proof.
    intros p r1 r2.
    exact (eq_trans (eq_sym (CMH_com r1)) (CMH_com r2)).
  Qed.

  Next Obligation.
  Proof.
    intros p r1 r2.
    cbn.
    etransitivity; [apply (CMH_com r1)|].
    symmetry.
    etransitivity;
      [|(apply
           (
             f_equal
               (fun x => compose x (CMO_hom f))
               (
                 pullback_morph_ex_com_1
                   PB
                   _
                   (CMH_left r1)
                   (CMH_left r2)
                   (PullBack_Slice_Prod_obligation_3 p r1 r2)
               )
           )
        )
      ].
    auto.
  Qed.

  Next Obligation.
  Proof.
    intros p r1 r2.
    apply Comma_Hom_eq_simplify.
    apply pullback_morph_ex_com_1.
    match goal with [|- _ = ?A] => destruct A; trivial end.
  Qed.

  Next Obligation.
  Proof.
    intros p r1 r2.
    apply Comma_Hom_eq_simplify.
    apply pullback_morph_ex_com_2.
    match goal with [|- _ = ?A] => destruct A; trivial end.
  Qed.

  Next Obligation.
  Proof.
    intros p r1 r2 h h' H1 H2 H3 H4.
    destruct H3; destruct H4.
    set (H1' := f_equal CMH_left H1); clearbody H1'; clear H1.
    set (H2' := f_equal CMH_left H2); clearbody H2'; clear H2.
    cbn in H1', H2'.
    apply Comma_Hom_eq_simplify; cbn in *.
    {
      apply (pullback_morph_ex_unique
               PB _ (pullback_morph_1 PB ∘ CMH_left h)
               (pullback_morph_2 PB ∘ CMH_left h)); auto.
      repeat rewrite assoc_sym.
      apply (f_equal (fun x => compose _ x)).
      apply (pullback_morph_com PB).
    }
    {
      match goal with [|- ?A = ?B] => destruct A; destruct B; trivial end.
    }
  Qed.

End PullBack_Slice_Prod.

(** A product in slice category is a pullback. *)
Section Slice_Prod_PullBack.
  Context {C : Category} {c : C} {f g : Slice C c}.

  Local Notation CA z :=
    (Build_Comma_Obj (Functor_id C) (Const_Func 1 c) _ tt z) (only parsing).

  Context (PR : (f × g)%object).

  Program Definition Slice_Prod_PullBack : PullBack (CMO_hom f) (CMO_hom g) :=
    {|
      pullback := (CMO_src (@product _ _ _ PR));
      pullback_morph_1 := CMH_left (Pi_1 PR);
      pullback_morph_2 := CMH_left (Pi_2 PR);
      pullback_morph_ex :=
        fun p r1 r2 H => CMH_left (Prod_morph_ex
                                  PR (CA ((CMO_hom f) ∘ r1))
                                  (Build_Comma_Hom _ _ (CA ((CMO_hom f) ∘ r1))
                                                   f r1 tt _)
                                  (Build_Comma_Hom _ _ (CA ((CMO_hom f) ∘ r1))
                                                   g r2 tt _))
    |}.

  Local Obligation Tactic := idtac.

  Next Obligation.
  Proof.
    cbn.
    cbn_rewrite <- (CMH_com (Pi_1 PR)).
    cbn_rewrite <- (CMH_com (Pi_2 PR)).
    trivial.
  Qed.

  Next Obligation.
  Proof.
    intros p r1 r2 H.
    cbn in *.
    exact (f_equal
             CMH_left
             (Prod_morph_com_1 PR (CA ((CMO_hom f) ∘ r1))
                               (Build_Comma_Hom _ _ (CA ((CMO_hom f) ∘ r1))
                                                f r1 tt _)
                               (Build_Comma_Hom _ _ (CA ((CMO_hom f) ∘ r1))
                                                g r2 tt _))).
  Qed.

  Next Obligation.
  Proof.
    intros p r1 r2 H.
    cbn in *.
    exact (f_equal
             CMH_left
             (Prod_morph_com_2 PR (CA ((CMO_hom f) ∘ r1))
                               (Build_Comma_Hom _ _ (CA ((CMO_hom f) ∘ r1))
                                                f r1 tt _)
                               (Build_Comma_Hom _ _ (CA ((CMO_hom f) ∘ r1))
                                                g r2 tt _))).
  Qed.

  Next Obligation.
  Proof.
    intros p r1 r2 H h1 h2 H1 H2 H3 H4.
    destruct H3; destruct H4.
    evar (V1T : Type); evar (V1 : V1T).
    change h1 with
    (CMH_left
       (
         Build_Comma_Hom
           _
           _
           (CA (CMO_hom f ∘ CMH_left (Pi_1 PR) ∘ h2))
           (@product _ _ _ PR)
           h1
           tt
           V1
       )
    )%morphism.
    evar (V2T : Type); evar (V2 : V2T).
    change h2 with
    (CMH_left
       (
         Build_Comma_Hom
           _
           _
           (CA (CMO_hom f ∘ CMH_left (Pi_1 PR) ∘ h2))
           (@product _ _ _ PR)
           h2
           tt
           V2
       )
    )%morphism.
    apply f_equal.
    eapply (Prod_morph_unique
              PR (CA (CMO_hom f ∘ CMH_left (Pi_1 PR) ∘ h2)%morphism));
      eauto; apply Comma_Hom_eq_simplify; auto.
    Unshelve.
    {
      unfold V1T; clear V1T; cbn.
      set (W := f_equal (compose h1) (CMH_com (Pi_1 PR))).
      cbn in W.
      repeat rewrite assoc in W.
      set (N :=
             (eq_trans
                (id_unit_left _ _ _)
                (f_equal (fun x => compose x (CMO_hom f)) (eq_sym H1))
             )
          ).
      cbn in N.
      rewrite N.
      symmetry.
      auto.
    }
    {
      cbn in *.
      unfold V2T; clear V1 V1T V2T; cbn.
      set (W := f_equal (compose h2) (CMH_com (Pi_1 PR))).
      cbn in W.
      repeat rewrite assoc in W.
      set (N :=
             (eq_trans
                (id_unit_left _ _ _)
                (f_equal (fun x => compose x (CMO_hom f)) (eq_sym H1))
             )
          ).
      cbn in N.
      rewrite N.
      symmetry.
      rewrite H1.
      auto.
    }
  Qed.

End Slice_Prod_PullBack.

(** If a category has pullbacks then its slices have products. *)
Section Has_PullBack_Slice_Has_Prod.
  Context {C : Category} (HPB : Has_PullBacks C) (c : C).

  Definition Has_PullBack_Slice_Has_Prod :
    Has_Products (Slice C c)
    :=
      fun f g =>
        PullBack_Slice_Prod (HPB _ _ _ (CMO_hom f) (CMO_hom g))
  .

End Has_PullBack_Slice_Has_Prod.

(** If all slices of a category have products then its all pullbacks. *)
Section Slice_Has_Prod_Has_PullBack.
  Context {C : Category} (HPR : ∀ c : C, Has_Products (Slice C c)).

  Definition Slice_Has_Prod_Has_PullBack :
    Has_PullBacks C
    :=
      fun a b c f g =>
        Slice_Prod_PullBack
          (HPR
             _
             (Build_Comma_Obj (Functor_id C) (Const_Func 1 c) _ tt f)
             (Build_Comma_Obj (Functor_id C) (Const_Func 1 c) _ tt g)
          )
  .

End Slice_Has_Prod_Has_PullBack.

(** Locally Cartesian Closed Category : one in which all
    slices are cartesian closed *)
Definition LCCC (C : Category) : Type := ∀ (c : C), CCC (Slice C c).
Existing Class LCCC.


(** * LogRel.NormalForms: definition of normal and neutral forms, and properties. *)
From LogRel.AutoSubst Require Import core unscoped Ast Extra.
From LogRel Require Import Utils BasicAst Context.

(** ** Weak-head normal forms and neutrals. *)

Inductive whnf : term -> Type :=
  | whnf_tSort {s} : whnf (tSort s)
  | whnf_tProd {A B} : whnf (tProd A B)
  | whnf_tLambda {A t} : whnf (tLambda A t)
  | whnf_tNat : whnf tNat
  | whnf_tZero : whnf tZero
  | whnf_tSucc {n} : whnf (tSucc n)
  | whnf_tEmpty : whnf tEmpty
  | whnf_whne {n} : whne n -> whnf n
with whne : term -> Type :=
  | whne_tRel {v} : whne (tRel v)
  | whne_tApp {n t} : whne n -> whne (tApp n t)
  | whne_tNatElim {P hz hs n} : whne n -> whne (tNatElim P hz hs n)
  | whne_tEmptyElim {P e} : whne e -> whne (tEmptyElim P e).

#[global] Hint Constructors whne whnf : gen_typing.

Ltac inv_whne :=
  repeat lazymatch goal with
    | H : whne _ |- _ =>
    try solve [inversion H] ; block H
  end; unblock.

Lemma neSort s : whne (tSort s) -> False.
Proof.
  inversion 1.
Qed.

Lemma nePi A B : whne (tProd A B) -> False.
Proof.
  inversion 1.
Qed.

Lemma neLambda A t : whne (tLambda A t) -> False.
Proof.
  inversion 1.
Qed.

#[global] Hint Resolve neSort nePi neLambda : gen_typing.

(** ** Restricted classes of normal forms *)

Inductive isType : term -> Type :=
  | UnivType {s} : isType (tSort s)
  | ProdType { A B} : isType (tProd A B)
  | NatType : isType tNat
  | EmptyType : isType tEmpty
  | NeType {A}  : whne A -> isType A.

Inductive isPosType : term -> Type :=
  | UnivPos {s} : isPosType (tSort s)
  | NatPos : isPosType tNat
  | EmptyPos : isPosType tEmpty
  | NePos {A}  : whne A -> isPosType A.

Inductive isFun : term -> Type :=
  | LamFun {A t} : isFun (tLambda A t)
  | NeFun  {f} : whne f -> isFun f.

Definition isPosType_isType t (i : isPosType t) : isType t :=
  match i with
    | UnivPos => UnivType
    | NatPos => NatType
    | EmptyPos => EmptyType
    | NePos ne => NeType ne
  end.

Coercion isPosType_isType : isPosType >-> isType.

Definition isType_whnf t (i : isType t) : whnf t :=
  match i with
    | UnivType => whnf_tSort
    | ProdType => whnf_tProd
    | NatType => whnf_tNat
    | EmptyType => whnf_tEmpty
    | NeType ne => whnf_whne ne
  end.

Coercion isType_whnf : isType >-> whnf.

Definition isFun_whnf t (i : isFun t) : whnf t :=
  match i with
    | LamFun => whnf_tLambda
    | NeFun ne => whnf_whne ne
  end.

Coercion isFun_whnf : isFun >-> whnf.

#[global] Hint Resolve isPosType_isType isType_whnf isFun_whnf : gen_typing.


(** The purpose of this file is to show that the definition in TINI.v
    adequately captures infinite executions, without explicitly
    talking about infinite objects. Intuitively, this is a consequence
    of TINI being a 2-safety hyperproperty.

    This file is not used by the rest of the Coq development. *)

Require Import List.
Require Import Relations.

Require Import Utils.
Require Import Semantics.
Require Import TINI.

Set Implicit Arguments.

Section CoExec.

Variable S : semantics.

Definition cotrace := colist (event S).

(* [next_event s1 e s2] says that an execution starting at state [s1]
remains silent until producing some output [e] and ending in state
[s2] *)

Inductive next_event : state S -> event S -> state S -> Prop :=
| ne_base : forall s e s'
                   (STEP : step S s (E e) s'),
              next_event s e s'
| ne_step : forall s s' e s''
                   (STEP : step S s Silent s')
                   (NEXT : next_event s' e s''),
              next_event s e s''.

(* [coexec] is similar to the definition of [exec] in [TINI.v], but
considers complete (potentially infinite) executions. [coexec s t]
states that a full execution starting at state [s] produces trace
[t]. *)

CoInductive coexec (s : state S) : cotrace -> Prop :=
| ce_end : forall (SILENT : forall e s', ~ next_event s e s'), coexec s Nil
| ce_step : forall e s' t
                   (NEXT : next_event s e s')
                   (EXEC : coexec s' t),
              coexec s (Cons e t).

End CoExec.

Section Observation.

Variable S : semantics.
Let coexec := @coexec S.
Let cotrace := @cotrace S.

Context (OE : Observation S).

(* [ti_cotrace_indist] is the coinductive version of [ti_trace_indist] *)

CoInductive ti_cotrace_indist : relation cotrace :=
| ticti_nil1 : forall t2, ti_cotrace_indist Nil t2
| ticti_nil2 : forall t1, ti_cotrace_indist t1 Nil
| ticti_cons : forall e t1 t2,
    ti_cotrace_indist t1 t2 ->
    ti_cotrace_indist (Cons e t1) (Cons e t2).
Hint Constructors ti_cotrace_indist : core.

(* [contains P t l e t'] expresses that we can decompose [t = l ++ e
:: t'], where [l] is a finite list, such that [P] holds of [e] but
doesn't hold of any element of [l] *)

Inductive contains T (P : T -> Prop)
    : colist T -> T -> list T -> colist T -> Prop :=
  | c_found : forall e t,
      P e ->
      contains P (Cons e t) e nil t
  | c_later : forall e e' t t' l,
      ~(P e) ->
      contains P t e' l t' ->
      contains P (Cons e t) e' (e :: l) t'.

Hint Constructors contains : core.

(* Because of the guard conditions for cofixpoints, we must define
filter on infinite lists as a predicate. [colist_filter P t1 t2]
states that [t2] is obtained from [t1] by removing the elements that
don't satisfy [P] *)

CoInductive colist_filter T (P : T -> Prop) : colist T -> colist T -> Prop :=
| f_not_contains : forall t,
    (forall e t' l, ~contains P t e l t') ->
    colist_filter P t Nil
| f_contains : forall e t t' t'' l,
    contains P t e l t' ->
    colist_filter P t' t'' ->
    colist_filter P t (Cons e t'').

(* We can now use this filtering predicate to define what the
observation of a complete trace is *)

Definition coobserve o es es' := colist_filter (e_low o) es es'.

(* The definition of TINI for this setting is similar to the finite
case, but we state the observation of traces in terms of a predicate
instead of a function *)

Definition cotini : Prop := forall o i t t' i2 t2 t2',
  i_equiv o i i2 ->
  coexec (init_state _ i) t ->
  coexec (init_state _ i2) t2 ->
  coobserve o t t' ->
  coobserve o t2 t2' ->
  ti_cotrace_indist t' t2'.

(* In order to prove cotrace indistinguishability it
   suffices to prove it for all finite prefixes *)
Lemma ti_cotrace_indist_via_prefixes : forall (t t2 : cotrace),
  (forall p p2, list_prefix_colist p t ->
                list_prefix_colist p2 t2 ->
                ti_trace_indist p p2) ->
  ti_cotrace_indist t t2.
Proof. cofix CIH. intros.
  destruct t; destruct t2. eauto. eauto. eauto.
  - assert (J : ti_trace_indist (e :: nil) (e0 :: nil)) by (apply H; eauto).
    inv J.
    apply ticti_cons; auto.
    apply CIH; auto.
    intros.
    assert (G : ti_trace_indist (e0 :: p) (e0 :: p2)); auto.
    inv G. auto.
Qed.

(* We now prove some technical lemmas needed to relate finite prefixes
to the infinite notions we've defined *)

Lemma contains_prefix : forall T l P t (e : T) t' p,
  contains P t e l t' ->
  list_prefix_colist p t' ->
  list_prefix_colist (l ++ e :: p) t.
Proof. induction l; simpl; intros; inv H; eauto. Qed.

Lemma contains_P_e : forall T l P t (e : T) t',
  contains P t e l t' ->
  P e.
Proof. induction 1; eauto. Qed.

Lemma contains_filter_P_l :
  forall T (P : T -> Prop) (P_dec : forall e, {P e} + {~P e}),
  forall l t (e : T) t',
  contains P t e l t' ->
  filter (fun e0 => if P_dec e0 then true else false) l = nil.
Proof. induction 1; simpl. reflexivity. rewrite if_dec_right; eauto. Qed.

Lemma prefix_cofilter :
  forall (P : event S -> Prop) (P_dec : forall e, {P e} + {~P e}),
  forall p' t' t,
  list_prefix_colist p' t' ->
  colist_filter P t t' ->
  exists p, list_prefix_colist p t /\
  filter (fun e => if P_dec e then true else false) p = p'.
Proof.
  intros P P_dec p' t' t H. gdep t. induction H; intros t H0.
  - exists nil; eauto.
  - inv H0.
    destruct (IHlist_prefix_colist _ H5) as [p [? ?]].
    eexists (l0 ++  e :: p). split. eauto using contains_prefix.
    rewrite filter_app. simpl. rewrite if_dec_left. rewrite H1.
    erewrite contains_filter_P_l; [reflexivity | eassumption].
    eapply contains_P_e. eassumption.
Qed.

Hint Constructors exec : core.
Lemma next_event_exec :
  forall s e s' t s''
         (NEXT : next_event S s e s')
         (EXEC : exec s' t s''),
    exec s (e :: t) s''.
Proof. induction 1; intros; eauto. Qed.

Lemma prefix_coexec :  forall p t s,
  list_prefix_colist p t ->
  coexec s t ->
  exists s'', exec s p s''.
Proof.
  intros. gdep s. induction H; intros s EXEC. eauto using e_refl.
  inv EXEC. destruct (IHlist_prefix_colist _ EXEC0) as [s'' EXEC].
  eauto using next_event_exec.
Qed.

(* Now, we are able to prove our main result *)

Theorem tini_cotini : tini OE -> cotini.
Proof.
  unfold tini, cotini.
  intros Htini o i1 t1 t1' i2 t2 t2' Hi Hexec1 Hexec2 Hobs1 Hobs2.
  apply ti_cotrace_indist_via_prefixes. intros p1' p2' Hpre1' Hpre2'.
  destruct (prefix_cofilter (e_low_dec o) Hpre1' Hobs1) as [p1 [Hpre1 Hfil1]].
  destruct (prefix_cofilter (e_low_dec o) Hpre2' Hobs2) as [p2 [Hpre2 Hfil2]].
  destruct (prefix_coexec Hpre1 Hexec1).
  destruct (prefix_coexec Hpre2 Hexec2).
  subst. unfold observe in Htini.
  eapply Htini ; eauto.
Qed.

End Observation.


From discprob.basic Require Import base sval order monad bigop_ext nify.
From discprob.idxval Require Import fin_ival_dist fin_ival.
From discprob.prob Require Import prob countable finite stochastic_order.

Record ivdist_couplingP {A1 A2} (Is1: ivdist A1) (Is2: ivdist A2) (P: A1 → A2 → Prop) : Type :=
  mkCoupling { pc_witness :> ivdist {xy: A1 * A2 | P (fst xy) (snd xy)};
     pc_proj1: eq_ivd Is1 (x ← pc_witness; mret (fst (sval x)));
     pc_proj2: eq_ivd Is2 (x ← pc_witness; mret (snd (sval x)));
     }.
Require Import Reals Psatz Omega.

Lemma ivdist_coupling_sym {A1 A2} (Is1: ivdist A1) (Is2: ivdist A2) P
      (Ic: ivdist_couplingP Is1 Is2 P): ivdist_couplingP Is2 Is1 (λ x y, P y x).
Proof.
  destruct Ic as [Ic Hp1 Hp2].
  unshelve (eexists).
  { refine (mbind _ Ic). intros ((x&y)&HP).
    refine (mret (exist _ (y, x) _)); auto. }
  * setoid_rewrite Hp2. setoid_rewrite ivd_assoc. apply ivd_bind_congr; first by reflexivity.
    intros ((x&y)&Hpf). setoid_rewrite ivd_left_id => //=. reflexivity.
  * setoid_rewrite Hp1. setoid_rewrite ivd_assoc; apply ivd_bind_congr; first by reflexivity.
    intros ((x&y)&Hpf). setoid_rewrite ivd_left_id => //=. reflexivity.
Qed.

Lemma ivdist_coupling_eq {A} (Is1 Is2: ivdist A)
      (Ic: ivdist_couplingP Is1 Is2 (λ x y, x = y)): eq_ivd Is1 Is2.
Proof.
  destruct Ic as [Ic Hp1 Hp2].
  setoid_rewrite Hp1. setoid_rewrite Hp2.
  apply ivd_bind_congr; first by reflexivity.
  intros ((x&y)&Heq) => //=. rewrite //= in Heq; subst; reflexivity.
Qed.

Lemma ivdist_coupling_bind {A1 A2 B1 B2} (f1: A1 → ivdist B1) (f2: A2 → ivdist B2)
      Is1 Is2 P Q (Ic: ivdist_couplingP Is1 Is2 P):
  (∀ x y, P x y → ivdist_couplingP (f1 x) (f2 y) Q) →
  ivdist_couplingP (mbind f1 Is1) (mbind f2 Is2) Q.
Proof.
  intros Hfc.
  destruct Ic as [Ic Hp1 Hp2].
  unshelve (eexists).
  { refine (xy ← Ic; _). destruct xy as ((x&y)&HP).
    exact (Hfc _ _ HP).
  }
  - setoid_rewrite Hp1; setoid_rewrite ivd_assoc;
      apply ivd_bind_congr; first by reflexivity.
    intros ((x&y)&HP). setoid_rewrite ivd_left_id => //=.
    destruct (Hfc x y); auto.
  - setoid_rewrite Hp2; setoid_rewrite ivd_assoc;
      apply ivd_bind_congr; first by reflexivity.
    intros ((x&y)&HP). setoid_rewrite ivd_left_id => //=.
    destruct (Hfc x y); auto.
Qed.

Lemma ivdist_coupling_mret {A1 A2} x y (P: A1 → A2 → Prop):
  P x y →
  ivdist_couplingP (mret x) (mret y) P.
Proof.
  intros HP. exists (mret (exist _ (x, y) HP)); setoid_rewrite ivd_left_id => //=; reflexivity.
Qed.

Lemma ivdist_coupling_plus {A1 A2} p Hpf Is1 Is2 Is1' Is2' (P: A1 → A2 → Prop):
  ivdist_couplingP Is1 Is2 P →
  ivdist_couplingP Is1' Is2' P →
  ivdist_couplingP (ivdplus p Hpf Is1 Is1') (ivdplus p Hpf Is2 Is2') P.
Proof.
  intros [Ic Hproj1 Hproj2].
  intros [Ic' Hproj1' Hproj2'].
  exists (ivdplus p Hpf Ic Ic').
  - setoid_rewrite Hproj1. setoid_rewrite Hproj1'.
    symmetry; apply ivd_plus_bind.
  - setoid_rewrite Hproj2. setoid_rewrite Hproj2'.
    symmetry; apply ivd_plus_bind.
Qed.


Require Import List Arith Omega Bool.
Require Import ListUtils MapUtils.
Require Import DecidableType OrderedType OrderedTypeEx FMapList.

Import ListNotations.

Set Implicit Arguments.

Module Type TreeSig.

  Declare Module KeyT : OrderedType.
  Declare Module TagT : DecidableType.

  Parameter file  : Type.

End TreeSig.

Module Tree (TS : TreeSig).

  Import TS.

  Module Map := FMapList.Raw KeyT.

  Definition key := KeyT.t.
  Definition key_dec := KeyT.eq_dec.

  Definition inum := TagT.t.
  Definition inum_dec := TagT.eq_dec.
  Definition ieq := TagT.eq.
  Definition ieqb i1 i2 :=
    if (inum_dec i1 i2) then true else false.

  Inductive tree :=
  | TFile : inum -> file -> tree
  | TDir  : inum -> Map.t tree -> tree.

  Definition dirents := Map.t tree.

  Definition Inum (t : tree) :=
    match t with
    | TFile i _ => i
    | TDir  i _ => i
    end.

  Definition IsDir (t : tree) :=
    match t with
     | TFile _ _ => False
     | TDir _ _ => True
    end.

  Definition IsFile (t : tree) :=
    match t with
     | TFile _ _ => True
     | TDir _ _ => False
    end.

  Definition dir_file_dec : forall t, { IsDir t } + { IsFile t }.
  Proof.
    destruct t; simpl; tauto.
  Defined.

  Definition isdir_dec : forall t, { IsDir t } + { ~ IsDir t }.
  Proof.
    destruct t; simpl; tauto.
  Defined.

  Fixpoint equal (t : tree) (t' : tree) :=
    let fix subdir_eq e e' :=
        match e, e' with
        | nil, nil => true
        | (k, subt)::l, (k', subt')::l' =>
          if (key_dec k k') then equal subt subt' && subdir_eq l l'
          else false
        | _, _ => false
        end in
    match t, t' with
    | (TFile i _), (TFile i' _) => ieqb i i'
    | (TDir  i ents), (TDir i' ents') =>
        ieqb i i' && subdir_eq ents ents'
    | _, _ => false
    end.

  Fixpoint walk (path : list key) (t : tree) :=
    match path with
    | nil => Some t
    | name :: rest =>
      match t with
      | TFile _ _ => None
      | TDir _ ents =>
        match Map.find name ents with
        | None => None
        | Some subt => walk rest subt
        end
      end
    end.

  Fixpoint update (path : list key) (newt t : tree) :=
    match path with
    | nil => newt
    | name :: rest =>
      match t with
      | TFile _ _ => t
      | TDir inum ents =>
        match Map.find name ents with
        | None =>
          match rest with
          | nil => TDir inum (Map.add name newt ents)
          | _ => t
          end
        | Some subt =>
          let newsubt := update rest newt subt in
          TDir inum (Map.add name newsubt ents)
        end
      end
    end.

  Fixpoint delete (path : list key) (t : tree) :=
    match path with
    | nil => t
    | name :: rest =>
      match t with
      | TFile _ _ => t
      | TDir inum ents =>
        match Map.find name ents with
        | None => t
        | Some subt =>
          match rest with
          | nil => TDir inum (Map.remove name ents)
          | _ =>
            let newsubt := delete rest subt in
            TDir inum (Map.add name newsubt ents)
          end
        end
      end
    end.

End Tree.

Require Import String StringUtils.

Module Sig <: TreeSig.

  Module KeyT := String_as_OT.
  Module TagT := Nat_as_OT.

  Definition file := string.

End Sig.

Module TR := Tree Sig.
Import TR.

Open Scope string_scope.

Definition rt := (TDir 0 [
    ("a", (TFile 1 "AAAA")) ;
    ("b", (TFile 2 "BBBB")) ;
    ("foo", (TDir 3 [
      ("bar", (TFile 4 "bababa")) ;
      ("emp", (TDir 6 [])) ;
      ("zoo", (TFile 5 "zzzzzz"))
    ] ))
]).

Definition st := (TDir 90 [
  ("x", (TFile 91 "xxx")) ;
  ("y", (TFile 92 "yyy"))
]).

(*
Eval compute in (walk   ["foo"; "zoo"] rt).
Eval compute in (update ["foo"; "emp"; "a"] st rt).
Eval compute in (update ["b"] st rt).
Eval compute in (delete ["foo"; "bar"] rt).
Eval compute in (equal rt (delete ["foo"; "emp"] rt)).
*)


(************************************************************************)
(*         *   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)         *)
(************************************************************************)

Require Import Rbase.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Rtrigo_def.
Require Import OmegaTactic.
Local Open Scope R_scope.

Definition A1 (x:R) (N:nat) : R :=
  sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) N.

Definition B1 (x:R) (N:nat) : R :=
  sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1))
    N.

Definition C1 (x y:R) (N:nat) : R :=
  sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) N.

Definition Reste1 (x y:R) (N:nat) : R :=
  sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun l:nat =>
            (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
            x ^ (2 * S (l + k)) * ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) *
            y ^ (2 * (N - l))) (pred (N - k))) (pred N).

Definition Reste2 (x y:R) (N:nat) : R :=
  sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun l:nat =>
            (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
            x ^ (2 * S (l + k) + 1) *
            ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
            y ^ (2 * (N - l) + 1)) (pred (N - k))) (
    pred N).

Definition Reste (x y:R) (N:nat) : R := Reste2 x y N - Reste1 x y (S N).

(* Here is the main result that will be used to prove that (cos (x+y))=(cos x)(cos y)-(sin x)(sin y) *)
Theorem cos_plus_form :
 forall (x y:R) (n:nat),
   (0 < n)%nat ->
   A1 x (S n) * A1 y (S n) - B1 x n * B1 y n + Reste x y n = C1 x y (S n).
Proof.
intros.
unfold A1, B1.
rewrite
 (cauchy_finite (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k))
    (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * y ^ (2 * k)) (
    S n)).
rewrite
 (cauchy_finite
    (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1))
    (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * y ^ (2 * k + 1)) n H)
 .
unfold Reste.
replace
 (sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun l:nat =>
            (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
            x ^ (2 * S (l + k)) *
            ((-1) ^ (S n - l) / INR (fact (2 * (S n - l))) *
             y ^ (2 * (S n - l)))) (pred (S n - k))) (
    pred (S n))) with (Reste1 x y (S n)).
replace
 (sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun l:nat =>
            (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
            x ^ (2 * S (l + k) + 1) *
            ((-1) ^ (n - l) / INR (fact (2 * (n - l) + 1)) *
             y ^ (2 * (n - l) + 1))) (pred (n - k))) (
    pred n)) with (Reste2 x y n).
replace
 (sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun p:nat =>
            (-1) ^ p / INR (fact (2 * p)) * x ^ (2 * p) *
            ((-1) ^ (k - p) / INR (fact (2 * (k - p))) * y ^ (2 * (k - p))))
         k) (S n)) with
 (sum_f_R0
    (fun k:nat =>
       (-1) ^ k / INR (fact (2 * k)) *
       sum_f_R0
         (fun l:nat => C (2 * k) (2 * l) * x ^ (2 * l) * y ^ (2 * (k - l))) k)
    (S n)).
pose
 (sin_nnn :=
  fun n:nat =>
    match n with
    | O => 0
    | S p =>
        (-1) ^ S p / INR (fact (2 * S p)) *
        sum_f_R0
          (fun l:nat =>
             C (2 * S p) (S (2 * l)) * x ^ S (2 * l) * y ^ S (2 * (p - l))) p
    end).
ring_simplify.
unfold Rminus.
replace
(* (-   old ring compat *)
 (-
  sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun p:nat =>
            (-1) ^ p / INR (fact (2 * p + 1)) * x ^ (2 * p + 1) *
            ((-1) ^ (k - p) / INR (fact (2 * (k - p) + 1)) *
             y ^ (2 * (k - p) + 1))) k) n) with (sum_f_R0 sin_nnn (S n)).
rewrite <- sum_plus.
unfold C1.
apply sum_eq; intros.
induction  i as [| i Hreci].
simpl.
unfold C; simpl.
field; discrR.
unfold sin_nnn.
rewrite <- Rmult_plus_distr_l.
apply Rmult_eq_compat_l.
rewrite binomial.
pose (Wn := fun i0:nat => C (2 * S i) i0 * x ^ i0 * y ^ (2 * S i - i0)).
replace
 (sum_f_R0
    (fun l:nat => C (2 * S i) (2 * l) * x ^ (2 * l) * y ^ (2 * (S i - l)))
    (S i)) with (sum_f_R0 (fun l:nat => Wn (2 * l)%nat) (S i)).
replace
 (sum_f_R0
    (fun l:nat =>
       C (2 * S i) (S (2 * l)) * x ^ S (2 * l) * y ^ S (2 * (i - l))) i) with
 (sum_f_R0 (fun l:nat => Wn (S (2 * l))) i).
apply sum_decomposition.
apply sum_eq; intros.
unfold Wn.
apply Rmult_eq_compat_l.
replace (2 * S i - S (2 * i0))%nat with (S (2 * (i - i0))).
reflexivity.
omega.
apply sum_eq; intros.
unfold Wn.
apply Rmult_eq_compat_l.
replace (2 * S i - 2 * i0)%nat with (2 * (S i - i0))%nat.
reflexivity.
omega.
replace
 (-
  sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun p:nat =>
            (-1) ^ p / INR (fact (2 * p + 1)) * x ^ (2 * p + 1) *
            ((-1) ^ (k - p) / INR (fact (2 * (k - p) + 1)) *
             y ^ (2 * (k - p) + 1))) k) n) with
 (-1 *
  sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun p:nat =>
            (-1) ^ p / INR (fact (2 * p + 1)) * x ^ (2 * p + 1) *
            ((-1) ^ (k - p) / INR (fact (2 * (k - p) + 1)) *
             y ^ (2 * (k - p) + 1))) k) n);[idtac|ring].
rewrite scal_sum.
rewrite decomp_sum.
replace (sin_nnn 0%nat) with 0.
rewrite Rplus_0_l.
change (pred (S n)) with n.
   (* replace (pred (S n)) with n; [ idtac | reflexivity ]. *)
apply sum_eq; intros.
rewrite Rmult_comm.
unfold sin_nnn.
rewrite scal_sum.
rewrite scal_sum.
apply sum_eq; intros.
unfold Rdiv.
(*repeat rewrite Rmult_assoc.*)
(* rewrite (Rmult_comm (/ INR (fact (2 * S i)))). *)
repeat rewrite <- Rmult_assoc.
rewrite <- (Rmult_comm (/ INR (fact (2 * S i)))).
repeat rewrite <- Rmult_assoc.
replace (/ INR (fact (2 * S i)) * C (2 * S i) (S (2 * i0))) with
 (/ INR (fact (2 * i0 + 1)) * / INR (fact (2 * (i - i0) + 1))).
replace (S (2 * i0)) with (2 * i0 + 1)%nat; [ idtac | ring ].
replace (S (2 * (i - i0))) with (2 * (i - i0) + 1)%nat; [ idtac | ring ].
replace ((-1) ^ S i) with (-1 * (-1) ^ i0 * (-1) ^ (i - i0)).
ring.
simpl.
pattern i at 2; replace i with (i0 + (i - i0))%nat.
rewrite pow_add.
ring.
symmetry ; apply le_plus_minus; assumption.
unfold C.
unfold Rdiv; repeat rewrite <- Rmult_assoc.
rewrite <- Rinv_l_sym.
rewrite Rmult_1_l.
rewrite Rinv_mult_distr.
replace (S (2 * i0)) with (2 * i0 + 1)%nat;
 [ apply Rmult_eq_compat_l | ring ].
replace (2 * S i - (2 * i0 + 1))%nat with (2 * (i - i0) + 1)%nat.
reflexivity.
omega.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
reflexivity.
apply lt_O_Sn.
(* ring. *)
apply sum_eq; intros.
rewrite scal_sum.
apply sum_eq; intros.
unfold Rdiv.
repeat rewrite <- Rmult_assoc.
rewrite <- (Rmult_comm (/ INR (fact (2 * i)))).
repeat rewrite <- Rmult_assoc.
replace (/ INR (fact (2 * i)) * C (2 * i) (2 * i0)) with
 (/ INR (fact (2 * i0)) * / INR (fact (2 * (i - i0)))).
replace ((-1) ^ i) with ((-1) ^ i0 * (-1) ^ (i - i0)).
ring.
pattern i at 2; replace i with (i0 + (i - i0))%nat.
rewrite pow_add.
ring.
symmetry ; apply le_plus_minus; assumption.
unfold C.
unfold Rdiv; repeat rewrite <- Rmult_assoc.
rewrite <- Rinv_l_sym.
rewrite Rmult_1_l.
rewrite Rinv_mult_distr.
replace (2 * i - 2 * i0)%nat with (2 * (i - i0))%nat.
reflexivity.
omega.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
unfold Reste2; apply sum_eq; intros.
apply sum_eq; intros.
unfold Rdiv; ring.
unfold Reste1; apply sum_eq; intros.
apply sum_eq; intros.
unfold Rdiv; ring.
apply lt_O_Sn.
Qed.

Lemma pow_sqr : forall (x:R) (i:nat), x ^ (2 * i) = (x * x) ^ i.
Proof.
intros.
assert (H := pow_Rsqr x i).
unfold Rsqr in H; exact H.
Qed.

Lemma A1_cvg : forall x:R, Un_cv (A1 x) (cos x).
Proof.
intro.
unfold cos; destruct (exist_cos (Rsqr x)) as (x0,p).
unfold cos_in, cos_n, infinite_sum, R_dist in p.
unfold Un_cv, R_dist; intros.
destruct (p eps H) as (x1,H0).
exists x1; intros.
unfold A1.
replace
 (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) n) with
 (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * (x * x) ^ i) n).
apply H0; assumption.
apply sum_eq.
intros.
replace ((x * x) ^ i) with (x ^ (2 * i)).
reflexivity.
apply pow_sqr.
Qed.

Lemma C1_cvg : forall x y:R, Un_cv (C1 x y) (cos (x + y)).
Proof.
intros.
unfold cos.
destruct (exist_cos (Rsqr (x + y))) as (x0,p).
unfold cos_in, cos_n, infinite_sum, R_dist in p.
unfold Un_cv, R_dist; intros.
destruct (p eps H) as (x1,H0).
exists x1; intros.
unfold C1.
replace
 (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) n)
 with
 (sum_f_R0
    (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * ((x + y) * (x + y)) ^ i) n).
apply H0; assumption.
apply sum_eq.
intros.
replace (((x + y) * (x + y)) ^ i) with ((x + y) ^ (2 * i)).
reflexivity.
apply pow_sqr.
Qed.

Lemma B1_cvg : forall x:R, Un_cv (B1 x) (sin x).
Proof.
intro.
case (Req_dec x 0); intro.
rewrite H.
rewrite sin_0.
unfold B1.
unfold Un_cv; unfold R_dist; intros; exists 0%nat; intros.
replace
 (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * 0 ^ (2 * k + 1))
    n) with 0.
unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
induction  n as [| n Hrecn].
simpl; ring.
rewrite tech5; rewrite <- Hrecn.
simpl; ring.
unfold ge; apply le_O_n.
unfold sin. destruct (exist_sin (Rsqr x)) as (x0,p).
unfold sin_in, sin_n, infinite_sum, R_dist in p.
unfold Un_cv, R_dist; intros.
cut (0 < eps / Rabs x);
 [ intro
 | unfold Rdiv; apply Rmult_lt_0_compat;
    [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ] ].
destruct (p (eps / Rabs x) H1) as (x1,H2).
exists x1; intros.
unfold B1.
replace
 (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1))
    n) with
 (x *
  sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n).
replace
 (x *
  sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n -
  x * x0) with
 (x *
  (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n -
   x0)); [ idtac | ring ].
rewrite Rabs_mult.
apply Rmult_lt_reg_l with (/ Rabs x).
apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
rewrite <- Rmult_assoc, <- Rinv_l_sym, Rmult_1_l, <- (Rmult_comm eps). apply H2;
 assumption.
apply Rabs_no_R0; assumption.
rewrite scal_sum.
apply sum_eq.
intros.
rewrite pow_add.
rewrite pow_sqr.
simpl.
ring.
Qed.


From coqutil Require Import sanity Tactics.autoforward.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.ZArith.BinInt.
Require Import Coq.NArith.NArith.
Require Coq.Strings.String.

(* needed because it unfolds to Nat.leb and then typeclass search picks Nat.leb_spec
   instead of Nat.ltb_spec *)
#[global] Hint Opaque Nat.ltb : typeclass_instances.

Existing Class BoolSpec.

Lemma BoolSpec_true P Q x (H : BoolSpec P Q x) : autoforward (x = true) P.
Proof. intro; subst. inversion H; auto. Qed.

Lemma BoolSpec_false P Q x (H : BoolSpec P Q x) : autoforward (x = false) Q.
Proof. intro; subst. inversion H; auto. Qed.

#[global] Hint Resolve BoolSpec_true BoolSpec_false : typeclass_instances.

Notation EqDecider f := (forall x y, BoolSpec (x = y) (x <> y) (f x y)).

Module Nat.
  Lemma eqb_spec: EqDecider Nat.eqb.
  Proof.
    intros. destruct (x =? y) eqn: E; constructor.
    - apply Nat.eqb_eq. assumption.
    - apply Nat.eqb_neq. assumption.
  Qed.
End Nat.

Module Byte.
  #[global] Instance eqb_spec: EqDecider Byte.eqb.
  Proof.
    intros. destruct (Byte.eqb x y) eqn: E; constructor.
    - apply Byte.byte_dec_bl. assumption.
    - apply Byte.eqb_false. assumption.
  Qed.
End Byte.

Module N.
  Lemma eqb_spec: EqDecider N.eqb.
  Proof.
    intros. destruct (x =? y)%N eqn: E; constructor.
    - apply N.eqb_eq. assumption.
    - apply N.eqb_neq. assumption.
  Qed.
End N.

Module Z.
  Lemma eqb_spec: EqDecider Z.eqb.
  Proof.
    intros. destruct (x =? y)%Z eqn: E; constructor.
    - apply Z.eqb_eq. assumption.
    - apply Z.eqb_neq. assumption.
  Qed.
End Z.

Module String.
  Lemma eqb_spec: EqDecider String.eqb.
  Proof.
    intros. destruct (String.eqb x y) eqn: E; constructor.
    - apply String.eqb_eq. assumption.
    - apply String.eqb_neq. assumption.
  Qed.
End String.

#[global] Hint Resolve
     Nat.eqb_spec
     Nat.leb_spec
     Nat.ltb_spec
     Byte.eqb_spec
     N.eqb_spec
     N.leb_spec
     N.ltb_spec
     Z.eqb_spec
     Z.gtb_spec
     Z.geb_spec
     Z.leb_spec
     Z.ltb_spec
     String.eqb_spec
: typeclass_instances.

Goal forall x y, Nat.ltb x y = true -> x < y.
  intros.
  autoforward with typeclass_instances in H.
  assumption.
  all: fail "goals remaining".
Abort.