(** * Samplers for finite distributions. *)

Set Implicit Arguments.
Set Contextual Implicit.

From Coq Require Import Streams Basics QArith String Lia Lqa List Reals ZArith.
Local Open Scope program_scope.
Local Open Scope string_scope.
Import ListNotations.

From ITree Require Import
  ITree ITreeFacts.
Import ITreeNotations.
Local Open Scope itree_scope.

From zar Require Import
  cotree cocwp cpo equidistribution eR itree misc order pow_2 prelude R
  tactics tcwp tcwp_facts tcwp_geometric tree uniform_Z.

Fixpoint flatten_weights_aux (weights : list Z) (acc : Z) : list Z :=
  match weights with
  | [] => []
  | w :: ws => repeat acc (Z.to_nat w) ++ flatten_weights_aux ws (Z.succ acc)
  end.

Definition flatten_weights (weights : list Z) : list Z :=
  flatten_weights_aux weights Z0.

Fixpoint flatten_weights' (weights : list Z) : list Z :=
  match weights with
  | [] => []
  | w :: ws => repeat Z0 (Z.to_nat w) ++ List.map Z.succ (flatten_weights' ws)
  end.

Lemma map_repeat_N {A B} (f : A -> B) (a : A) (n : nat) :
  List.map f (repeat a n) = repeat (f a) n.
Proof. induction n; auto; simpl; rewrite IHn; auto. Qed.

Lemma flatten_weights_aux_flatten_weights' (weights : list Z) (n : Z) :
  flatten_weights_aux weights n =
    List.map (Z.add n) (flatten_weights' weights).
Proof.
  revert n; induction weights; intro n; simpl; auto.
  rewrite IHweights.
  rewrite map_app.
  f_equal.
  - rewrite map_repeat, Z.add_0_r; auto.
  - rewrite List.map_map; f_equal; ext i; lia.
Qed.

Lemma flatten_weights_flatten_weights' (weights : list Z) :
  flatten_weights weights = flatten_weights' weights.
Proof.
  unfold flatten_weights.
  rewrite flatten_weights_aux_flatten_weights'.
  rewrite map_id; auto.
Qed.

Lemma forall_repeat {A} (a : A) (P : A -> Prop) (n : nat) :
  P a ->
  Forall P (repeat a n).
Proof. induction n; intro Ha; simpl; constructor; auto. Qed.

Lemma flatten_weights_nonnegative weights :
  Forall (fun x => 0 <= x)%Z weights ->
  Forall (fun x => 0 <= x)%Z (flatten_weights' weights).
Proof.
  induction weights; simpl; intro Hall; inv Hall.
  { constructor. }
  apply Forall_app; split.
  - apply forall_repeat; lia.
  - apply Forall_map.
    eapply Forall_impl.
    2: { apply IHweights; auto. }
    simpl; lia.
Qed.

Lemma countb_list_flatten_weights' (weights : list Z) (n : Z) :
  (0 <= n)%Z ->
  Forall (fun x => 0 <= x)%Z weights ->
  countb_list (fun x => eqb n x) (flatten_weights' weights) =
    Z.to_nat (nth (Z.to_nat n) weights Z0).
Proof.
  revert n; induction weights; intros n Hle Hall; simpl.
  { destr; auto. }
  rewrite countb_list_app.
  rewrite countb_list_map.
  unfold compose.
  simpl; destruct (Z.to_nat n) eqn:Hn; simpl.
  {rewrite countb_list_repeat.
   destruct (Z.eqb_spec n 0); subst; try lia.
   rewrite countb_list_all_false; try lia.
   inv Hall.
   eapply Forall_impl; eauto.
   apply flatten_weights_nonnegative in H2.
   eapply Forall_impl.
   2: { eauto. }
   unfold compose; intros z Hz.
   destruct (Z.eqb_spec 0 (Z.succ z)); subst; try lia; constructor. }
  rewrite countb_list_all_false; simpl.
  2: { apply forall_repeat; unfold compose.
       destruct (Z.eqb_spec n 0); subst; try lia; constructor. }
  replace (fun x : Z => (n =? Z.succ x)%Z) with (fun x : Z => (Z.pred n =? x)%Z).
  2: { ext i; destruct (Z.eqb_spec (Z.pred n) i); subst.
       - rewrite Z.succ_pred; lia.
       - destruct (Z.eqb_spec n (Z.succ i)); subst; lia. }
  inv Hall; rewrite IHweights; auto; try lia; f_equal.
  replace n0 with (Z.to_nat (Z.pred n)) by lia; auto.
Qed.

Lemma countb_list_flatten_weights (weights : list Z) (n : Z) :
  (0 <= n)%Z ->
  Forall (fun x : Z => (0 <= x)%Z) weights ->
  countb_list (fun x => eqb n x) (flatten_weights weights) =
    Z.to_nat (nth (Z.to_nat n) weights Z0).
Proof.
  intros Hn Hall; rewrite flatten_weights_flatten_weights'.
  apply countb_list_flatten_weights'; auto.
Qed.

Definition findist_btree (weights : list Z) : btree (unit + Z) :=
  reduce_btree' (list_btree (flatten_weights weights)).

Definition findist_tree_open (weights : list Z) : tree (unit + Z) :=
  btree_to_tree (findist_btree weights).

(** This generalizes uniform_tree in uniform.v, i.e., we technically
    could implement uniform_tree as a special case of this
    construction. But uniform_tree is already done so there is no
    need. *)
Definition findist_tree (weights : list Z) : tree Z :=
  let t := findist_tree_open weights in
  Fix (inl tt) is_inl (fun _ => t) (cotuple (fun _ => Leaf Z0) (@Leaf _)).

(* Eval compute in (findist_btree [2%nat; 1%nat]). *)

Lemma wf_tree_findist_tree (weights : list Z) :
  wf_tree (findist_tree weights).
Proof.
  constructor.
  - intros ?; apply wf_tree_btree_to_tree.
  - intros []; constructor.
Qed.

Lemma no_fail_findist_tree (weights : list Z) :
  no_fail' (findist_tree weights).
Proof.
  constructor.
  - intros ?; apply no_fail_btree_to_tree.
  - intros []; constructor.
Qed.

Lemma twlp_const_1_findist_tree (weights : list Z) :
  twlp (findist_tree weights) (const 1) = 1.
Proof.
  rewrite twlp_fail.
  { rewrite no_fail_twlp; eRauto.
    apply no_fail_findist_tree. }
  apply wf_tree_findist_tree.
Qed.

Definition findist_itree (weights : list Z) : itree boolE Z :=
  to_itree (findist_tree weights).

Lemma exists_pos_flatten_weights_aux_neq_nil (l : list Z) (n : Z) :
  Exists (fun w : Z => (0 < w)%Z) l ->
  flatten_weights_aux l n <> [].
Proof.
  revert n; induction l; simpl; intros n Hex HC; inv Hex;
    apply app_eq_nil in HC; destruct HC as [Ha Hl].
  - apply repeat_eq_nil in Ha; lia.
  - eapply IHl; eauto.
Qed.

Lemma btree_some_inr_findist_btree (weights : list Z) :
  Exists (fun w : Z => (0 < w)%Z) weights ->
  btree_some (is_true ∘ is_inr) (findist_btree weights).
Proof.
  intro Hex; apply btree_some_reduce_btree'.
  unfold compose, uniform_btree.
  apply btree_some_is_inr_list_btree.
  unfold flatten_weights.
  apply exists_pos_flatten_weights_aux_neq_nil; auto.
Qed.

Definition proj_inr {A B} (x : A + B) (default : B) : B :=
  match x with
  | inl _ => default
  | inr b => b
  end.

Definition list_sum_Z (l : list Z) := fold_right Z.add Z0 l.

Lemma list_sum_Z_nonnegative l :
  Forall (fun x : Z => (0 <= x)%Z) l ->
  (0 <= list_sum_Z l)%Z.
Proof.
  induction l; intro Hall; inv Hall; simpl; try lia.
  apply IHl in H2; lia.
Qed.

Lemma length_flatten_weights_aux (l : list Z) (n : Z) :
  Forall (fun x => 0 <= x)%Z l ->
  length (flatten_weights_aux l n) = Z.to_nat (list_sum_Z l).
Proof.
  revert n; induction l; intros n Hl; simpl; auto; inv Hl.
  rewrite Z2Nat.inj_add, app_length, repeat_length; auto.
  apply list_sum_Z_nonnegative; auto.
Qed.

Lemma length_flatten_weights (l : list Z) :
  Forall (fun x => 0 <= x)%Z l ->
  length (flatten_weights l) = Z.to_nat (list_sum_Z l).
Proof. intro Hl; apply length_flatten_weights_aux; auto. Qed.

Lemma exists_pos_list_sum_N l :
  Forall (fun x => 0 <= x)%Z l ->
  Exists (fun w : Z => (0 < w)%Z) l ->
  (0 < list_sum_Z l)%Z.
Proof.
  induction l; intros Hall Hex; inv Hall; inv Hex; simpl.
  - apply list_sum_Z_nonnegative in H2; lia.
  - apply IHl in H0; auto; lia.
Qed.

Lemma findist_tree_correct (weights : list Z) (n : Z) :
  (0 <= n)%Z ->
  Forall (fun x => 0 <= x)%Z weights ->
  Exists (fun w => (0 < w)%Z) weights ->
  (Z.to_nat n < length weights)%nat ->
  tcwp (findist_tree weights) (fun x : Z => if eqb n x then 1 else 0) =
    IZeR (nth (Z.to_nat n) weights Z0) / IZeR (list_sum_Z weights).
Proof.
  intros Hn Hall Hex Hlt.
  unfold tcwp; simpl.
  rewrite twlp_const_1_findist_tree; eRauto.
  unfold findist_tree.
  rewrite twp_fix_iid; auto.
  2: { apply wf_tree_btree_to_tree. }
  2: { intros []; constructor. }
  2: { unfold findist_tree_open.
       rewrite twp_btree_to_tree.
       apply btree_some_0_btree_infer_lt_1.
       - intros []; eRauto.
       - apply btree_some_impl with (P := is_true ∘ @is_inr unit Z).
         { intros [] H; inv H; auto. }
         apply btree_some_inr_findist_btree; auto. }
  unfold findist_tree_open.
  rewrite 2!twp_btree_to_tree.
  unfold findist_btree.
  rewrite 2!reduce_btree'_infer.
  replace (fun s : unit + Z =>
             if is_inl s
             then 0
             else
               twp (cotuple (fun _ : unit => Leaf 0%Z) (Leaf (A:=Z)) s)
                 (fun x : Z => if (n =? x)%Z then 1 else 0)) with
    (fun s => if is_inr s && eqb (@proj_inr unit Z s Z0) n then 1 else 0).
  2: { ext s; destruct s; simpl; auto.
       rewrite Z.eqb_sym; auto. }
  rewrite 2!perfect_btree_infer.
  2: { apply perfect_list_btree. }
  2: { apply perfect_list_btree. }
  unfold const.
  replace (fun x : unit + Z => is_inr x && eqb (proj_inr x Z0) n) with
    (cotuple (@const bool unit false) (fun x => eqb x n)).
  2: { ext s; destruct s; auto. }
  rewrite list_btree_count.
  rewrite countb_length_list_btree.
  rewrite length_flatten_weights; auto.
  set (a := INeR (countb_list (fun x : Z => eqb x n) (flatten_weights weights))).
  set (c := INeR (next_pow_2 (Z.to_nat (list_sum_Z weights)))).
  set (b := INeR (countb is_inl (list_btree (flatten_weights weights)))).
  assert (Hcnz: c <> 0).
  { unfold c; apply not_0_INeR.
    generalize (is_power_of_2_next_pow_2 (Z.to_nat (list_sum_Z weights))); intros [k Hk].
    rewrite <- Hk; apply Nat.pow_nonzero; lia. }
  assert (Hcninfty: c <> infty).
  { unfold c; apply not_infty_INeR. }
  assert (Hcbnz: c - b <> 0).
  { unfold b, c.
    apply eRlt_neq', eRlt_pos, lt_INeR.
    (* replace (fun x : unit + nat => is_inl (sum_map id (bin_index weights) x)) *)
    (*   with (@cotuple unit nat _ (const true) (const false)). *)
    (* 2: { ext x; destruct x; reflexivity. } *)
    unfold list_btree.
    (* rewrite rev_length, range_length. *)
    rewrite length_flatten_weights; auto.
    generalize (is_power_of_2_next_pow_2 (Z.to_nat (list_sum_Z weights))).
    intros [k Hk]; rewrite <- Hk.
    rewrite Nat.log2_pow2; try lia.
    replace is_inl with (@cotuple unit Z _ (const true) (const false)).
    2: { ext x; destruct x; reflexivity. }
    rewrite list_btree_aux_countb'.
    { rewrite length_flatten_weights; auto.
      assert (0 < list_sum_Z weights)%Z.
      { apply exists_pos_list_sum_N; auto. }
      assert (0 < 2^k)%nat.
      { apply pow_positive; lia. }
      lia. }
    rewrite length_flatten_weights, Hk; auto.
    apply next_pow_2_ub. }
  replace 1 with (c / c) by eRauto.
  replace (c / c - b / c) with ((c - b) / c).
  2: { rewrite eRdiv_minus_distr; auto. }
  rewrite eRdiv_cancel_r; auto; f_equal.
  - unfold a; f_equal.
    replace (fun x => eqb x n) with (fun x => eqb n x).
    2: { ext i; apply Z.eqb_sym. }
    rewrite countb_list_flatten_weights; auto.
    apply INeR_IZeR.
  - unfold c, b.
    rewrite minus_INeR.
    2: { unfold list_btree.
         rewrite length_flatten_weights; auto.
         generalize (is_power_of_2_next_pow_2 (Z.to_nat (list_sum_Z weights))).
         intros [k Hk]; rewrite <- Hk.
         rewrite Nat.log2_pow2 by lia.
         apply countb_list_btree_aux_le_pow_2. }
    f_equal.
    replace is_inl with (@cotuple unit Z _ (const true) (const false)).
    2: { ext s; destruct s; auto. }
    unfold list_btree.
    rewrite length_flatten_weights; auto.
    generalize (is_power_of_2_next_pow_2 (Z.to_nat (list_sum_Z weights))).
    intros [k Hk]; rewrite <- Hk.
    rewrite Nat.log2_pow2; try lia.
    rewrite list_btree_aux_countb'.
    { rewrite length_flatten_weights; auto.
      rewrite sub_sub_le.
      - apply INeR_IZeR.
      - rewrite Hk; apply next_pow_2_ub. }
    rewrite length_flatten_weights; auto.
    rewrite Hk; apply next_pow_2_ub.
Qed.

(* (** Extraction. *) *)
(* From Coq Require Import ExtrOcamlBasic ExtrOcamlString. *)
(* Extraction "extract/findist/findist.ml" findist_itree. *)


(* colimits are computed pointwise
Actually this is not needed for our formalization
limits/colimits of modules are computes pointwise
forget ful functors from modules to functors

Proofs for limits are very similar to proof from colimits

Proof that the pullbacks preserve lims/colims

TODO: refaire en supposant les colimites/limites dans la catégories des foncteurs
plutôt que dans la catégorie cible. Mais est-ce possible ? Comment définir la multiplication
dans ce cas (ltmult) ?
 *)

(**
It is the product of modules
Then it induces a morphism
*)
(* TODO : Faire les mêmes choses pour les limites de Modules *)
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.FunctorCategory.

Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.LModules.

(* Require Import Modules.Prelims.modules. (* for the definition of the forgetful functor *) *)
(* Require Import Modules.Prelims.LModPbCommute. (* for the definition of the iso *) *)

Local Open Scope cat.

(*
Lemma compfNat
   {C : precategory} {g : graph} {d1 d2 d3 : diagram g C}

   {f : ∏ u : vertex g, C ⟦ dob d1 u, dob d2 u ⟧}
  (fNat : ∏ (u v : vertex g) (e : edge u v), dmor d1 e · f v = f u · dmor d2 e)
   {f2 : ∏ u : vertex g, C ⟦ dob d2 u, dob d3 u ⟧}
   (fNat2 : ∏ (u v : vertex g) (e : edge u v), dmor d2 e · f2 v = f2 u · dmor d3 e)
   (f3 := fun u => f u · f2 u)
   :
   ∏ (u v : vertex g) (e : edge u v), dmor d1 e · f3 v = f3 u · dmor d3 e .
  intros u v e.
  etrans;[apply assoc|].
  etrans;[apply cancel_postcomposition; apply fNat|].
  etrans;[|apply assoc].
  etrans;[|apply cancel_precomposition; apply fNat2].
  apply pathsinv0.
  apply assoc.
Qed.
*)
(*
Lemma compColimOfArrows
   (C : precategory) (g : graph) (d1 d2 d3 : diagram g C) (CC1 : ColimCocone d1)
   (CC2 : ColimCocone d2)(CC3 : ColimCocone d3)
   (f : ∏ u : vertex g, C ⟦ dob d1 u, dob d2 u ⟧)
  (fNat : ∏ (u v : vertex g) (e : edge u v), dmor d1 e · f v = f u · dmor d2 e)
   (f2 : ∏ u : vertex g, C ⟦ dob d2 u, dob d3 u ⟧)
  (fNat2 : ∏ (u v : vertex g) (e : edge u v), dmor d2 e · f2 v = f2 u · dmor d3 e)
  (x : C) (cc : cocone d2 x) :
  colimOfArrows CC1 CC2 f fNat · colimOfArrows CC2 CC3 f2 fNat2 =
  colimOfArrows CC1 CC3 (fun z => f z · f2 z) (compfNat  fNat fNat2).
  etrans;[apply precompWithColimOfArrows|].
  cbn.
  unfold colimOfArrows.
  apply maponpaths.
  Abort.
*)
(*

  use map_on_two_paths.
  maponpaths
  apply maponpaths2.

  reflexivity.
.fNat · colimOfArrows CC2 CC3 f2 fNat2 .
  colimOfArrows CC1 CC3 (fun
  colimArrow CC1 x
    (make_cocone (λ u : vertex g, f u · coconeIn cc u)
       (preCompWithColimOfArrows_subproof CC1 CC2 f fNat x cc)).
*)
(* forget ful functor from Modules to functors *)
(* TODO déplacer ça dans LModule.v *)

Section ColimsModule.
  Context
          {C : category}
          {g : graph} (colims_g : Colims_of_shape g C)
          (lims_g : Lims_of_shape g C)
          {B:category} {R:Monad B}.
  Local Notation coFunc := (ColimsFunctorCategory_of_shape _ B _  colims_g).
  Local Notation limFunc := (LimsFunctorCategory_of_shape _ B _ lims_g).
  (* Local Notation bpFunct := *)
  (*   (BinProducts_functor_precat B C bpC hsC (M : functor _ _) (N : functor _ _)). *)

  (* Definition LModule_colim_functor : functor _ _ := *)
  (*   BinProductObject  _ bpFunct. *)
  Local Notation MOD := (category_LModule R C).
  Variable (d : diagram g MOD).
  (* TODO generalize this kind of construction : composition of a diagram and a functor
(here the forget ful functor MOD --> [B , C])
   *)
  Local Notation FORGET := (LModule_forget_functor R C).
  Local Notation d' := (  mapdiagram FORGET d : diagram g [B , C ] ).
  (* The natural candidate *)
  Local Notation F := (colim (coFunc d') : functor _ _).
  Local Notation F' := (lim (limFunc d') : functor _ _).
  (* Local Notation BP := (binproduct_functor bpC). *)

  (* Is there a lemma that state the existence of a natural transformation
  (A x B) o R --> A o R x B o R  ? *)
  (* TODO define it without nat_trans *)
  Definition LModule_colim_mult_data (x : B) : C ⟦ (R ∙ F) x, F x ⟧.
    use colimOfArrows.
    - intro v.
       exact ( lm_mult R (dob d v : LModule _ _) x).
    - intros u v e.
      cbn.
        now apply  LModule_Mor_σ.
  Defined.

  Definition LModule_lim_mult_data (x : B) : C ⟦ (R ∙ F') x, F' x ⟧.
    use limOfArrows.
    - intro v.
       exact ( lm_mult R (dob d v : LModule _ _) x).
    - intros u v e.
      cbn.
      apply pathsinv0.
       apply  LModule_Mor_σ.
  Defined.
  (*
      apply lt_mult_σ.
  (* Definition LModule_colim_mult_data  : [B, C , hsC] ⟦ (R ∙ F) , F  ⟧. *)
    apply colimArrow.
    use make_cocone.
    - intro v.
      eapply compose; revgoals.
      + apply (colimIn _ v).
      + exact ( lm_mult R (dob d v : LModule _ _) x).
    - intros u v e.
      cbn.
      (*
<<<
           σ u                in_(u x)
d u (R x) ----------> d u x -------
    |                              |
    |                              |
    |                              |
d e |                              |
    |                              |
    V                              V
d v (R x) ---------> d v x ------> colim d x
           σ v               in_(v x)

>>>
qu'on complète par propriété de [d e] en temps que morphisme de module

*)
      abstract(
      rewrite assoc;
      etrans;[
        apply cancel_postcomposition;
        now apply  LModule_Mor_σ
               |] ;
      rewrite <- assoc;
      apply cancel_precomposition;
      cbn;
      set (dpw := diagram_pointwise _ _ _);
      apply ( colimInCommutes (d := dpw))).
  Defined.
(* Local Notation σ := (lm_mult _). *)
*)

  Lemma LModule_colim_mult_is_nat_trans : is_nat_trans _ _  LModule_colim_mult_data.
  Proof.
    intros x y f.
    cbn.
    unfold LModule_colim_mult_data.
    (* par unicité de la colimite *)

    etrans; [use precompWithColimOfArrows|].
    apply pathsinv0            .
    (* etrans; [use precompWithColimOfArrows|]. *)
    apply colimArrowUnique.
    intro v.
    cbn.

    apply pathsinv0.
    etrans;[apply assoc|].
    etrans.
    {
      apply cancel_postcomposition.
      apply (nat_trans_ax (lm_mult R (dob d v : LModule _ _))).
    }

    apply pathsinv0.
    etrans;[apply assoc|].
    etrans.
    {
      apply cancel_postcomposition.
      set (CC1 := colims_g _ ).
      set (CC2 := colims_g _ ).
      eapply (colimOfArrowsIn _ _ CC1 CC2).
    }
    simpl.
    repeat rewrite <- assoc.
    apply cancel_precomposition.
    unfold ColimFunctor_mor.
    set (CC1 := colims_g _ ).
    set (CC2 := colims_g _ ).
    eapply (colimOfArrowsIn _ _ CC1 CC2).
  Qed.
  Lemma LModule_lim_mult_is_nat_trans : is_nat_trans _ _  LModule_lim_mult_data.
  Proof.
    intros x y f.
    cbn.
    unfold LModule_lim_mult_data.
    (* par unicité de la colimite *)

    etrans; [use postCompWithLimOfArrows|].
    apply pathsinv0            .
    (* etrans; [use precompWithColimOfArrows|]. *)
    apply limArrowUnique.
    intro v.
    cbn.

    (* apply pathsinv0. *)
    etrans;[|apply assoc].
    etrans; revgoals.
    {
      apply cancel_precomposition.
      apply pathsinv0.
      apply (nat_trans_ax (lm_mult R (dob d v : LModule _ _))).
    }

    apply pathsinv0.
    etrans;[|apply assoc].
    etrans; revgoals.
    {
      apply cancel_precomposition.
      unfold LimFunctor_mor.
      cbn.
      set (CC1 := lims_g _ ).
      set (CC2 :=  lims_g _ ).
      eapply pathsinv0.
      eapply (limOfArrowsOut _ _ CC1 CC2).
    }
    simpl.
    repeat rewrite  assoc.
    apply cancel_postcomposition.
    apply pathsinv0.
    (* unfold LimFunctor_mor. *)
    set (CC2 := lims_g _ ).
    set (CC1 := lims_g _ ).
    apply (limOfArrowsOut _ _ CC1 CC2).
  Qed.

  Definition LModule_colim_mult : R ∙ F ⟹ F :=
    (_ ,, LModule_colim_mult_is_nat_trans).

  Definition LModule_lim_mult : R ∙ F' ⟹ F' :=
    (_ ,, LModule_lim_mult_is_nat_trans).

  Definition LModule_colim_data : LModule_data R C :=
    (F ,, LModule_colim_mult).

  Definition LModule_lim_data : LModule_data R C :=
    (F' ,, LModule_lim_mult).

  Lemma LModule_colim_laws : LModule_laws _ LModule_colim_data.
  Proof.
    split.
    - intro x.
      cbn.
      etrans; [use precompWithColimOfArrows|].
      apply pathsinv0            .
      (* etrans; [use precompWithColimOfArrows|]. *)
      apply colimArrowUnique.
      intro u.
      cbn.
      rewrite id_right.
      rewrite assoc.
      apply pathsinv0.
      etrans;[|apply id_left].
      apply cancel_postcomposition.
      apply LModule_law1.
    - intro x.
      cbn.
      etrans; [use precompWithColimOfArrows|].
      apply pathsinv0            .
      (* etrans; [use precompWithColimOfArrows|]. *)
      apply colimArrowUnique.
      intro u.
      cbn.
      etrans; [apply assoc|].
      etrans.
      {
        apply cancel_postcomposition.
        unfold LModule_colim_mult_data.
        cbn.
        set (CC1 := colims_g _ ).
        set (CC2 := colims_g _ ).
        apply (colimOfArrowsIn _ _ CC1 CC2).
      }
      cbn.
      rewrite <- assoc.
      etrans.
      {
        apply cancel_precomposition.
        unfold LModule_colim_mult_data.
        cbn.
        set (CC1 := colims_g _ ).
        set (CC2 := colims_g _ ).
        apply (colimOfArrowsIn _ _ CC1 CC2).
      }
      cbn.
      repeat rewrite assoc.
      apply cancel_postcomposition.
      apply pathsinv0.
      apply LModule_law2.
  Qed.
  Lemma LModule_lim_laws : LModule_laws _ LModule_lim_data.
  Proof.
    split.
    - intro x.
      cbn.
      etrans; [use postCompWithLimArrow|].
      apply pathsinv0            .
      (* etrans; [use precompWithColimOfArrows|]. *)
      apply limArrowUnique.
      intro u.
      cbn.
      rewrite id_left.
      apply pathsinv0.
      etrans;[apply assoc|].
      etrans.
      {
        apply cancel_postcomposition.
        unfold LimFunctor_mor.
        cbn.
        set (CC2 := lims_g _ ).
        set (CC1 := lims_g _ ).
        apply (limOfArrowsOut _ _ CC1 CC2).
      }
      rewrite <-assoc.
      etrans;[|apply id_right].
      apply cancel_precomposition.
      apply LModule_law1.
    - intro x.
      cbn.
      etrans; [use postCompWithLimOfArrows|].
      apply pathsinv0            .
      apply limArrowUnique.
      intro u.
      cbn.
      etrans.
      {
        rewrite <- assoc.
        apply cancel_precomposition.

        unfold LModule_lim_mult_data.
        cbn.
        set (CC1 := lims_g _ ).
        set (CC2 := lims_g _ ).
        apply (limOfArrowsOut _ _ CC1 CC2).
      }
      cbn.
      etrans.
      {
        rewrite assoc.
        apply cancel_postcomposition.
        unfold LModule_lim_mult_data.
        cbn.
        set (CC2 := lims_g _ ).
        set (CC1 := lims_g _ ).
        apply (limOfArrowsOut _ _ CC1 CC2).
      }
      cbn.
      repeat rewrite <- assoc.
      apply cancel_precomposition.
      apply pathsinv0.
      apply LModule_law2.
  Qed.

  Definition LModule_colim : LModule R C := (_ ,, LModule_colim_laws).
  Definition LModule_lim : LModule R C := (_ ,, LModule_lim_laws).

  Lemma LModule_coconeIn_laws v :
    LModule_Mor_laws R
                     (T := (dob d v : LModule _ _)) (T' := LModule_colim)
      ((coconeIn (colimCocone (coFunc d')) v : nat_trans _ _) ).
  Proof.
    intro c.
    cbn.
    unfold LModule_colim_mult_data.
    set (CC1 := colims_g _ ).
    set (CC2 := colims_g _ ).
    apply (colimOfArrowsIn _ _ CC1 CC2).
  Defined.
  Lemma LModule_coneOut_laws v :
    LModule_Mor_laws R
                    (T := LModule_lim) (T' := (dob d v : LModule _ _))
      ((coneOut (limCone (limFunc d')) v : nat_trans _ _) ).
  Proof.
    intro c.
    cbn.
    unfold LModule_lim_mult_data.
    set (CC1 := lims_g _ ).
    set (CC2 := lims_g _ ).
    apply pathsinv0.
    apply (limOfArrowsOut _ _ CC1 CC2).
  Defined.

  Definition LModule_coconeIn v : MOD ⟦ dob d v, LModule_colim ⟧ :=
    _ ,, LModule_coconeIn_laws v.

  Definition LModule_coneOut v : MOD ⟦ LModule_lim, dob d v ⟧ :=
    _ ,, LModule_coneOut_laws v.

  Lemma LModule_coconeIn_commutes (u v : vertex g) (e : edge u v) :
    dmor d e · LModule_coconeIn v = LModule_coconeIn u.
  Proof.
    apply LModule_Mor_equiv.
    - exact C.
    - apply (coconeInCommutes (colimCocone (coFunc d'))).
  Defined.
  Lemma LModule_coneOut_commutes (u v : vertex g) (e : edge u v) :
      LModule_coneOut u · dmor d e = LModule_coneOut v.
  Proof.
    apply LModule_Mor_equiv.
    - exact C.
    - apply (coneOutCommutes (limCone (limFunc d'))).
  Defined.

  Definition LModule_colim_cocone : cocone d LModule_colim :=
    make_cocone LModule_coconeIn LModule_coconeIn_commutes.

  Definition LModule_lim_cone : cone d LModule_lim :=
    make_cone LModule_coneOut LModule_coneOut_commutes.

  Definition LModule_colimArrow_laws {M : LModule R C} (cc : cocone d M) :
    LModule_Mor_laws
      _ (T := LModule_colim) (T' := M)
      (colimArrow  (coFunc d') (M : functor _ _) (mapcocone FORGET d cc) : nat_trans _ _ ).
  Proof.
    intro c.
    apply pathsinv0.
    cbn.
    unfold LModule_colim_mult_data.
    cbn.
    etrans;[apply precompWithColimOfArrows|].
    apply pathsinv0.
    apply colimArrowUnique.
    intro u.
    cbn.
    etrans.
    {
      etrans;[apply assoc|].
      apply cancel_postcomposition.
      set (CC1 := colims_g _ ).
      apply (colimArrowCommutes CC1).
    }
    apply LModule_Mor_σ.
  Qed.

  Definition LModule_limArrow_laws {M : LModule R C} (cc : cone d M) :
    LModule_Mor_laws
      _ (T := M)(T' := LModule_lim)
      (limArrow  (limFunc d') (M : functor _ _) (@mapcone (category_LModule R C) _ FORGET _ d _ cc) : nat_trans _ _ ).
  Proof.
    intro c.
    cbn.
    unfold LModule_lim_mult_data.
    cbn.
    etrans;[apply postCompWithLimOfArrows|].
    apply pathsinv0.
    apply limArrowUnique.
    intro u.
    cbn.
    etrans.
    {
      rewrite <- assoc.
      apply cancel_precomposition.
      set (CC1 := lims_g _ ).
      apply (limArrowCommutes CC1).
    }
    apply pathsinv0.
    apply LModule_Mor_σ.
  Qed.

  Definition LModule_colimArrow {M : LModule R C} (cc : cocone d M) :
    LModule_Mor _ LModule_colim M := _ ,, LModule_colimArrow_laws  cc.

  Definition LModule_limArrow {M : LModule R C} (cc : cone d M) :
    LModule_Mor _ M LModule_lim := _ ,, LModule_limArrow_laws  cc.

  Lemma LModule_isColimCocone : isColimCocone _ _ LModule_colim_cocone.
    intros M cc.
    use unique_exists.
    - exact (LModule_colimArrow cc).
    - intro v.
      apply LModule_Mor_equiv;[exact C|].
      apply (colimArrowCommutes (coFunc d')).
    - intro y.
      cbn -[isaprop].
      apply  impred_isaprop.
      intro u.
      use has_homsets_LModule.
    - cbn.
      intros y h.
      apply LModule_Mor_equiv;[exact C|].
      apply (colimArrowUnique (coFunc d')).
      intro u.
      exact (  maponpaths pr1 (h u)).
  Defined.

  Lemma LModule_isLimCone : isLimCone _ _ LModule_lim_cone.
    intros M cc.
    use unique_exists.
    - exact (LModule_limArrow cc).
    - intro v.
      apply LModule_Mor_equiv;[exact C|].
      apply (limArrowCommutes (limFunc d')).
    - intro y.
      cbn -[isaprop].
      apply  impred_isaprop.
      intro u.
      use has_homsets_LModule.
    - cbn.
      intros y h.
      apply LModule_Mor_equiv;[exact C|].
      apply (limArrowUnique (limFunc d')).
      intro u.
      exact (  maponpaths pr1 (h u)).
  Defined.

  Definition LModule_ColimCocone : ColimCocone d :=
    make_ColimCocone  _ _ _  LModule_isColimCocone.

  Definition LModule_LimCone : LimCone d :=
    make_LimCone  _ _ _  LModule_isLimCone.

End ColimsModule.

Definition LModule_Colims_of_shape (C : category) {B : category}
           (R : Monad B)
           (g : graph)
           (colims_g : Colims_of_shape g C)
           (d : diagram g (category_LModule R C))
  : ColimCocone d :=
   LModule_ColimCocone   colims_g d.

Definition LModule_Lims_of_shape (C : category) {B : category}
           (R : Monad B)
           (g : graph)
           (lims_g : Lims_of_shape g C)
           (d : diagram g (category_LModule R C))
            : LimCone d :=
  LModule_LimCone  lims_g d.

Section pullback_lims.
  Context
          {D : category}
          {g : graph} (colims_g : Colims_of_shape g D)
          (lims_g : Lims_of_shape g D)
          {C:category}.
          (* (hsB : has_homsets B) *)

  Let MOD (R : Monad C) := (precategory_LModule R D).
  Let cMod (R : Monad C) := LModule_Colims_of_shape D R g colims_g.
  Let lMod (R : Monad C) := LModule_Lims_of_shape D R g lims_g.

  Context {R S : Monad C} (f : Monad_Mor R S) (M : LModule S D).
  Variable (dS : diagram g (MOD S)).
  Let dR := mapdiagram (pb_LModule_functor f) dS .

  Let cS := colim (cMod S dS).
  Let lS :=   lim (lMod S dS).
  Let cR := colim (cMod R dR).
  Let lR :=   lim (lMod R dR).

  Lemma pb_colims_eq_mult (c : C) :
    (LModule_colim_mult colims_g  dR) c = (pb_LModule_σ f cS) c.
  Proof.
    simpl.
    unfold ColimFunctor_mor, LModule_colim_mult_data.
    etrans;[|eapply pathsinv0;apply precompWithColimOfArrows].
    apply colimArrowUnique.
    intro v.
    etrans;[apply colimOfArrowsIn|].
    cbn.
    apply pathsinv0.
    apply assoc.
  Qed.
  Lemma pb_lims_eq_mult (c : C) :
    (LModule_lim_mult lims_g dR) c = (pb_LModule_σ f lS) c.
  Proof.
    simpl.
    unfold LimFunctor_mor, LModule_lim_mult_data.
    etrans;[|eapply pathsinv0;apply postCompWithLimOfArrows].
    apply limArrowUnique.
    intro v.
    etrans;[apply limOfArrowsOut|].
    cbn.
    apply assoc.
  Qed.

  Definition pb_LModule_colim_iso : iso (C := MOD R) cR (pb_LModule f cS) :=
    LModule_same_func_iso _ _ pb_colims_eq_mult (homset_property _).

  Definition pb_LModule_lim_iso : iso (C := MOD R) lR (pb_LModule f lS) :=
    LModule_same_func_iso _ _ pb_lims_eq_mult (homset_property _).
End pullback_lims.


Require Import Le Max List Bool NPeano Omega.
Require Import Cecoa.Lib Cecoa.Syntax Cecoa.CBV_cache Cecoa.Bounds Cecoa.Ordering Cecoa.QI.

Section Main.

(* Syntax *)

Variables variable function constructor : Type.
Notation value := (Syntax.value constructor).
Notation term := (Syntax.term variable function constructor).
Notation pattern := (Syntax.pattern variable constructor).
Notation rule := (Syntax.rule variable function constructor).
Variable prog : list rule.
Variable max_arity:nat.
Variable rule_default : rule.

Hypothesis prog_is_wf: wf_prog max_arity prog.

Variable variable_eq_dec : forall (x1 x2 : variable), {x1=x2}+{x1<>x2}.
Variable function_eq_dec : forall (x1 x2 : function), {x1=x2}+{x1<>x2}.
Variable constructor_eq_dec : forall (x1 x2 : constructor), {x1=x2}+{x1<>x2}.

Notation cache := (CBV_cache.cache variable function constructor).
Notation cbv := (CBV_cache.cbv variable function constructor).
Notation wf := (CBV_cache.wf variable_eq_dec function_eq_dec constructor_eq_dec rule_default
                prog max_arity).

(* PPO *)
Variable rank: function -> nat.
Variable max_rank : nat.
Hypothesis pos_max_rank : 0 < max_rank.
Hypothesis max_rank_is_max_rank : forall f, rank f <= max_rank.
Hypothesis prog_is_ppo : PPO_prog prog rank.

Definition gsp := (Bounds.gary_seven_poly variable function constructor prog max_rank).
Definition bep := (Bounds.bobby_eight_poly variable function constructor max_arity prog).

(* QI *)
Variable cs: constructor -> nat.  (* constructor size *)
Variable mcs: nat. (* max constructor size *)
Variable qic: constructor -> list nat -> nat.
Variable qif: function -> list nat -> nat.
Hypothesis prog_has_QI: valid_QI variable function constructor prog mcs qic qif cs.
Notation cache_bounded := (QI.cache_bounded variable function constructor qic qif).

Definition CBV_bound A S C :=  (* generic bound *)
  (* A : number of activations
     S : max size of an activation
     C : cache *)
  (A * activation_bound prog S + A + 1 + (max_arity * A * (1 + activation_bound prog S))) *
  (activation_bound prog S + S + cache_size C +
  (1 + max S (maxl (map (fun tv : term * value => value_size (snd tv)) C))) *
  (1 + (A * activation_bound prog S + A) + max_arity * (A * activation_bound prog S + A))) +
  cache_size C.

Definition PPO_bound S := gsp (bep S).
(* S : max size of an activation *)

Definition QI_bound (f:function) (lv: list term) :=
  (* f : active function symbol
     lv : list of its arguments *)
  (max_arity + 1) * (qif f (map (fun x=> mcs * (term_size (fapply f lv))) lv)) + 1.

Definition global_bound f lv C :=
  let S:= QI_bound f lv in
  let A:= PPO_bound S in
  CBV_bound A S C.

(********** Proofs **********)

(* All bounds are increasing *)
Lemma gary_increase: (* move to Ordering ? *)
  forall x y, x <=y -> gsp x <= gsp y.
Proof.
intros.
unfold gary_seven_poly.
apply suml_map_le.
intros.
unfold activations_at_rank_bound.
apply Mult.mult_le_compat_l.
apply pow_le_compat;trivial.
Qed.

Lemma PPO_bound_increase:
  forall x y, x <= y -> PPO_bound x <= PPO_bound y.
Proof.
intros.
unfold PPO_bound.
apply gary_increase.
apply bobby_increase.
trivial.
Qed.

Lemma activation_bound_increase:
  forall x y, x <= y -> activation_bound prog x <= activation_bound prog y.
Proof.
intros.
unfold activation_bound.
apply Mult.mult_le_compat_l.
apply Plus.plus_le_compat_l;trivial.
Qed.

Lemma CBV_bound_increase:
  forall x1 y1 x2 y2 C, x1 <= y1 -> x2 <= y2 -> CBV_bound x1 x2 C <= CBV_bound y1 y2 C.
Proof.
intros.
unfold CBV_bound.
apply Plus.plus_le_compat_r.
apply Mult.mult_le_compat;
repeat (try apply Plus.plus_le_compat; trivial; try apply Mult.mult_le_compat; trivial).
apply Nat.max_le_compat_r;trivial.
Qed.

Theorem P_criterion: forall i s p c f lv d v,
  let t :=  (fapply f lv) in
  let pi := cbv_update i s p c t d v in
  wf pi -> cache_bounded c ->
  size pi <= global_bound f lv c.
Proof.
intros i s p c f lv d v t pi well_formed cache_bound.
unfold global_bound.
assert (max_active_size pi <= QI_bound f lv).
- apply max_active_size_bound with (prog:=prog) (rule_default:=rule_default)
        (variable_eq_dec:=variable_eq_dec) (function_eq_dec :=function_eq_dec) (constructor_eq_dec:=constructor_eq_dec)
        (qic:=qic) (cs:=cs);trivial.
- apply le_trans with (m:= CBV_bound (PPO_bound (max_active_size pi)) (max_active_size pi) c).
  + assert (length (activations pi) <= PPO_bound (max_active_size pi)).
    * {
        apply le_trans with (m:=gsp (A_T variable function constructor rank pi)).
        - apply gary_seven with (variable_eq_dec:=variable_eq_dec) (function_eq_dec:=function_eq_dec)
                                (constructor_eq_dec:=constructor_eq_dec) (rule_default:=rule_default)
                                (max_arity:=max_arity);try trivial.
          apply PPO_is_compatible_prog;trivial.
        - unfold PPO_bound.
          apply gary_increase.
          apply A_T_bound with (variable_eq_dec:=variable_eq_dec) (function_eq_dec:=function_eq_dec)
                               (constructor_eq_dec:=constructor_eq_dec) (rule_default:=rule_default)
                               (max_rank:=max_rank);trivial.
      }
    * {
        apply le_trans with (m:=CBV_bound (length (activations pi)) (max_active_size pi) c).
        - apply size_bound_gen with (variable_eq_dec:=variable_eq_dec) (function_eq_dec:=function_eq_dec)
                                    (constructor_eq_dec:=constructor_eq_dec) (rule_default:=rule_default);trivial.
        - apply CBV_bound_increase;trivial.
      }
  + apply CBV_bound_increase;try trivial.
    apply PPO_bound_increase;try trivial.
Qed.

End Main.


From Cat Require Import Cat.
From Cat.Universal Require Import Initial.

Class isIndexedCoproduct
  (C : Cat) {J : Type} {A : J -> Ob C}
  (P : Ob C) (inj : forall j : J, Hom (A j) P)
  (cotuple : forall {X : Ob C} (f : forall j : J, Hom (A j) X), Hom P X)
  : Prop :=
{
  inj_cotuple :
    forall {X : Ob C} (f : forall j : J, Hom (A j) X) (j : J),
      inj j .> cotuple f == f j;
  equiv_indexedCoproduct :
    forall {X : Ob C} (h1 h2 : Hom P X),
      (forall j : J, inj j .> h1 == inj j .> h2) -> h1 == h2;
}.

#[export] Hint Mode isIndexedCoproduct ! ! ! ! ! ! : core.
#[export] Hint Mode isIndexedCoproduct ! ! ! - - - : core.

Lemma equiv_indexedCoproduct' :
  forall
    {C : Cat} {J : Type} {A : J -> Ob C}
    {P : Ob C} {inj : forall j : J, Hom (A j) P}
    {cotuple : forall {X : Ob C} (f : forall j : J, Hom (A j) X), Hom P X}
    {isIC : isIndexedCoproduct C P inj (@cotuple)}
    {X : Ob C} (h1 h2 : Hom P X),
      h1 == h2 <-> (forall j : J, inj j .> h1 == inj j .> h2).
Proof.
  split.
  - now intros Heq j; rewrite Heq.
  - now apply equiv_indexedCoproduct.
Qed.

Section isIndexedCoproduct.

Context
  {C : Cat} {J : Type} {A : J -> Ob C}
  {P : Ob C} {inj : forall j : J, Hom (A j) P}
  {cotuple : forall {X : Ob C} (f : forall j : J, Hom (A j) X), Hom P X}
  {isIC : isIndexedCoproduct C P inj (@cotuple)}
  {X : Ob C} {f : forall j : J, Hom (A j) X}.

Arguments cotuple {X} _.

#[global] Instance Proper_cotuple :
  Proper (equiv ==> equiv) (@cotuple X).
Proof.
  intros h1 h2 Heq.
  apply equiv_indexedCoproduct; intros j.
  now rewrite !inj_cotuple.
Defined.

Lemma cotuple_universal :
  forall h : Hom P X,
    cotuple f == h <-> forall j : J, f j == inj j .> h.
Proof.
  now intros; rewrite equiv_indexedCoproduct'; setoid_rewrite inj_cotuple.
Qed.

Lemma cotuple_unique :
  forall h : Hom P X,
    (forall j : J, inj j .> h == f j) -> h == cotuple f.
Proof.
  now intros; apply equiv_indexedCoproduct; setoid_rewrite inj_cotuple.
Qed.

Lemma cotuple_id :
  cotuple inj == id P.
Proof.
  now rewrite equiv_indexedCoproduct'; intros j; rewrite inj_cotuple, comp_id_r.
Qed.

Lemma cotuple_comp :
  forall {Y : Ob C} (g : Hom X Y),
    cotuple f .> g == cotuple (fun j : J => f j .> g).
Proof.
  setoid_rewrite equiv_indexedCoproduct'; intros.
  now rewrite <- comp_assoc, !inj_cotuple.
Qed.

End isIndexedCoproduct.

Ltac indexedCoproduct_simpl := repeat (
  try setoid_rewrite equiv_indexedCoproduct';
  try setoid_rewrite inj_cotuple;
  try setoid_rewrite cotuple_id;
  try setoid_rewrite cotuple_comp;
  try setoid_rewrite comp_id_l;
  try setoid_rewrite comp_id_r;
  try setoid_rewrite comp_assoc).

Lemma nullary_coproduct :
  forall
    (C : Cat) (A : Empty_set -> Ob C) (I : Ob C)
    (create : forall X : Ob C, Hom I X)
    (p : forall j : Empty_set, Hom (A j) I)
    (cotuple : forall (X : Ob C) (f : forall j : Empty_set, Hom (A j) X), Hom I X),
      isInitial C I create -> isIndexedCoproduct C I p cotuple.
Proof.
  now split; intros; [| apply equiv_initial].
Qed.

Lemma unary_coprod_exists :
  forall (C : Cat) (A : unit -> Ob C),
    isIndexedCoproduct C (A tt) (fun _ : unit => id (A tt)) (fun _ f => f tt).
Proof.
  now split; cat.
Qed.

Class HasIndexedCoproducts (C : Cat) : Type :=
{
  indexedCoproduct : forall J : Type, (J -> Ob C) -> Ob C;
  inj :
    forall (J : Type) (A : J -> Ob C) (j : J),
      Hom (A j) (indexedCoproduct J A);
  cotuple :
    forall (J : Type) (A : J -> Ob C) (X : Ob C) (f : forall j : J, Hom (A j) X),
      Hom (indexedCoproduct J A) X;
  isIndexedCoproduct_HasIndexedCoproducts' :>
    forall (J : Type) (A : J -> Ob C),
      isIndexedCoproduct C (indexedCoproduct J A) (inj J A) (cotuple J A)
}.

Arguments indexedCoproduct {C _ J} _.
Arguments inj           {C _ J A} _.
Arguments cotuple          {C _ J A X} _.

Lemma cotuple_comp' :
  forall
    {C : Cat} {hip : HasIndexedCoproducts C}
    {X : Ob C} {J : Type} {A B : J -> Ob C}
    (f : forall j : J, Hom (A j) (B j)) (g : forall j : J, Hom (B j) X),
      cotuple (fun j : J => f j .> g j)
        ==
      cotuple (fun j : J => f j .> inj j) .> cotuple g.
Proof.
  intros.
  rewrite cotuple_comp, equiv_indexedCoproduct'; intros j.
  now rewrite !inj_cotuple, comp_assoc, inj_cotuple.
Qed.


Require Import Iron.Language.SystemF2Data.Type.
Require Import Iron.Language.SystemF2Data.Exp.Relation.TypeX.
Require Import Iron.Language.SystemF2Data.Exp.Operator.LiftTX.

(* Substitution of Types in Exps *)
Fixpoint substTX (d: nat) (u: ty) (xx: exp) : exp :=
  match xx with
  |  XVar _     => xx

  |  XLAM x
  => XLAM (substTX (S d) (liftTT 1 0 u) x)

  |  XAPP x t
  => XAPP (substTX d u x)  (substTT d u t)

  |  XLam t x
  => XLam (substTT d u t)  (substTX d u x)

  |  XApp x1 x2
  => XApp (substTX d u x1) (substTX d u x2)

  |  XCon dc ts xs
  => XCon dc (map (substTT d u) ts) (map (substTX d u) xs)

  |  XCase xx alts
  => XCase (substTX d u xx) (map (substTA d u) alts)

  |  XPrim p xs
  => XPrim p (map (substTX d u) xs)

  |  XLit l    => xx
 end

with substTA (d: nat) (u: ty) (aa: alt) : alt :=
  match aa with
  |  AAlt dc xx
  => AAlt dc (substTX d u xx)
  end.

(* The data constructor of an alternative is unchanged
   by type substitution. *)
Lemma dcOfAlt_substTA
 : forall d u a
 , dcOfAlt (substTA d u a) = dcOfAlt a.
Proof.
 intros. destruct a. destruct d0. auto.
Qed.
Hint Rewrite dcOfAlt_substTA : global.

Theorem subst_type_exp_ix
 :  forall ix ds ke te x1 t1 t2 k2
 ,  get ix ke = Some k2
 -> TYPE ds ke  te x1 t1
 -> KIND (delete ix ke)  t2 k2
 -> TYPE ds (delete ix ke)     (substTE ix t2 te)
            (substTX ix t2 x1) (substTT ix t2 t1).
Proof.
 intros. gen ix ds ke te t1 t2 k2.
 induction x1 using exp_mutind with
  (PA := fun a => forall ix ds ke te t1 t2 t3 k3
      ,  get ix ke = Some k3
      -> TYPEA ds ke te a t1 t2
      -> KIND (delete ix ke) t3 k3
      -> TYPEA ds (delete ix ke)  (substTE ix t3 te) (substTA ix t3 a)
                  (substTT ix t3 t1) (substTT ix t3 t2));
  intros; simpl; inverts_type; eauto.

 - Case "XVar".
   apply TYVar.
   unfold substTE. auto.

 - Case "XLAM".
   simpl. apply TYLAM.
   rewrite delete_rewind.
   rewrite (liftTE_substTE 0 ix).
   eauto using kind_kienv_weaken.

 - Case "XAPP".
   rewrite (substTT_substTT 0 ix).
   eauto using subst_type_type_ix.
   apply TYAPP.
   + simpl. eapply (IHx1 ix) in H4; eauto.
   + simpl. eapply subst_type_type_ix; eauto.

 - Case "XLam".
   simpl.
   apply TYLam.
   + eapply subst_type_type_ix; eauto.
   + unfold substTE. rewrite map_rewind.
     rrwrite ( map (substTT ix t2) (te :> t)
             = substTE ix t2 (te :> t)).
     eapply IHx1; eauto.

 - Case "XApp".
   eapply TYApp.
   + eapply IHx1_1 in H4; eauto.
     simpl in H4. burn.
   + eapply IHx1_2 in H6; eauto.

 - Case "XCon".
   rr. simpl.
   eapply TYCon; eauto.
   + eapply subst_type_type_ix_forall2; eauto.
   + eapply Forall2_map.
     eapply Forall2_map_right' in H11.
     eapply Forall2_impl_in; eauto; intros.
     rrwrite (ix = 0 + ix).
     rewrite substTTs_substTT; rr.
     * norm. eapply H; eauto.
     * defok ds (DefData     dc tsFields tc).
       defok ds (DefDataType tc ks       dcs).
       rrwrite (length ts = length ks).
       norm.
       have (KIND ks y KStar). eauto.

 - Case "XCase".
   eapply TYCase; eauto.
   + eapply Forall_map.
     norm. eauto.
   + norm.
     have (In x (map dcOfAlt aa)).
     assert ( map dcOfAlt (map (substTA ix t2) aa)
            = map dcOfAlt aa) as HDC.
     lists. f_equal.
     extensionality x0. rr. auto.
     rewrite HDC. auto.

 - Case "XPrim".
   eapply TYPrim; eauto.
   + lets D: prim_types_closed H5. rip.
     rrwrite (substTT ix t2 t1 = t1).
     eauto.
   + have (Forall closedT tsArg)
      by (eapply prim_types_closed_args; eauto).

     have HTS: (tsArg = map (substTT ix t2) tsArg)
      by (symmetry; eauto; eapply substTT_closedT_id_list; eauto).
     rewrite HTS.
     rewrite HTS in H7.

     eapply Forall2_map.
     eapply Forall2_map_right' in H7.
     eapply Forall2_impl_in; eauto; intros.
     simpl in H6.
     snorm.
     eapply H; eauto.
     have (closedT y).
     rrwrite (substTT ix t2 y = y) in H6.
     trivial.

 - Case "XLit".
   eapply TYLit.
   destruct l; snorm.

 - Case "AAlt".
   defok ds (DefData dc tsFields tc).
   rr.
   eapply TYAlt with (tc := tc) (ks := ks) (dcs := dcs); eauto.
   eapply subst_type_type_ix_forall2; eauto.
    eapply IHx1 in H10; eauto.
    rrwrite (ix = 0 + ix).
    rewrite substTTs_substTT_map; rr.
    + unfold substTE.
      rewrite <- map_app. auto.
    + rrwrite (length tsParam = length ks).
      eauto.
Qed.

Theorem subst_type_exp
 :  forall ds ke te x1 t1 t2 k2
 ,  TYPE ds (ke :> k2) te x1 t1
 -> KIND ke  t2 k2
 -> TYPE ds ke (substTE 0 t2 te) (substTX 0 t2 x1) (substTT 0 t2 t1).
Proof.
 intros.
 rrwrite (ke = delete 0 (ke :> k2)).
 eapply subst_type_exp_ix; burn.
Qed.


(*
Copyright © 2006-2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Import CoRN.model.totalorder.QMinMax.
Require Import CoRN.reals.fast.CRAlternatingSum.
Require Import CoRN.reals.fast.CRAlternatingSum_alg.
Require Import CoRN.reals.fast.CRstreams.
Require Export CoRN.reals.fast.CRArith.
Require Import CoRN.reals.fast.CRIR.
Require Import CoRN.reals.iso_CReals.
Require Import Coq.QArith.Qpower.
Require Import CoRN.algebra.COrdFields2.
Require Import CoRN.model.ordfields.Qordfield.
Require Import CoRN.transc.PowerSeries.
Require Import CoRN.reals.fast.CRpower.
Require Import CoRN.transc.Exponential.
Require Import CoRN.transc.RealPowers.
Require Import CoRN.reals.fast.Compress.
Require Import Coq.NArith.Ndigits.
Require Import CoRN.reals.fast.ModulusDerivative.
Require Import CoRN.reals.fast.ContinuousCorrect.
Require Import CoRN.reals.fast.CRsign.
Require Import CoRN.reals.Q_in_CReals.
Require Import Coq.QArith.Qabs.
Require Import Coq.QArith.Qround.
Require Import CoRN.tactics.CornTac.
Require Import MathClasses.theory.int_pow.
Require Import MathClasses.interfaces.abstract_algebra.

(* Backwards compatibility for Hint Rewrite locality attributes *)
Set Warnings "-unsupported-attributes".

Set Implicit Arguments.

Opaque CR.
Opaque Exp.

Local Open Scope Q_scope.
Local Open Scope uc_scope.

Lemma Qpower_le_1 : forall (a : Q) (p : positive),
    0 <= a <= 1 -> 0 <= a ^ p <= 1.
Proof.
  split.
  - apply Qpower_pos, H.
  - revert p. apply Pos.peano_ind. apply H.
    intros p Hp. unfold Qpower.
    rewrite <- Pos.add_1_l, Qpower_plus_positive.
    apply (Qle_trans _ (1*Qpower_positive a p)).
    apply Qmult_le_compat_r. apply H.
    apply (Qpower_pos a p), H.
    rewrite Qmult_1_l. apply Hp.
Qed.

Lemma Qabs_Qpower : forall (a:Q) (p:positive),
    Qabs (a ^ p) == (Qabs a) ^ p.
Proof.
  intro a. apply Pos.peano_ind.
  - reflexivity.
  - intros p Hp.
    simpl. rewrite <- Pos.add_1_l.
    rewrite Qpower_plus_positive.
    rewrite Qabs_Qmult, Hp. clear Hp.
    rewrite Qpower_plus_positive. reflexivity.
Qed.

Lemma Qinv_le_compat : forall (a b : Q),
    0 < a -> a <= b -> /b <= /a.
Proof.
  intros. apply Qle_shift_inv_l. exact H.
  apply (Qmult_le_l _ _ b).
  exact (Qlt_le_trans _ a _ H H0).
  rewrite Qmult_1_r, Qmult_assoc.
  rewrite Qmult_inv_r.
  rewrite Qmult_1_l. exact H0.
  intro abs. rewrite abs in H0.
  apply (Qlt_irrefl 0).
  exact (Qlt_le_trans _ _ _ H H0).
Qed.

Lemma fact_power_2 : forall n:nat, (2^pred n <= fact n)%nat.
Proof.
  induction n.
  - apply le_refl.
  - apply (Nat.le_trans _ ((S n) * 2^pred n)).
    2: apply Nat.mul_le_mono_nonneg_l; [apply le_0_n | exact IHn].
    clear IHn. destruct n. simpl. apply le_refl.
    simpl.
    apply Nat.add_le_mono_l, Nat.add_le_mono_l, le_0_n.
Qed.

Lemma Qceiling_fact_le : forall q:Q,
    0 < q ->
    q <=
    Pos.of_nat (fact (Pos.to_nat (Pos.succ (Z.to_pos (Z.log2_up (Qceiling q))))))
               # 1.
Proof.
  intros q H.
  apply (Qle_trans _ _ _ (Qle_ceiling q)).
  assert (0 < Qceiling q)%Z.
  { rewrite Zlt_Qlt. apply (Qlt_le_trans _ _ _ H). apply Qle_ceiling. }
  revert H0. generalize (Qceiling q). intros p ppos. clear H q.
  unfold Qle; simpl.
  rewrite Z.mul_1_r, Pos.mul_1_r.
  destruct p as [|p|p].
  exfalso; inversion ppos.
  2: exfalso; inversion ppos. clear ppos.
  apply (Z.le_trans _ (2 ^ Z.log2_up p)).
  apply Z.log2_up_le_pow2. reflexivity.
  apply Z.le_refl.
  revert p. apply Pos.peano_case. discriminate.
  intro p.
  generalize (Z.log2_up (Pos.succ p))
             (Z.log2_up_pos (Pos.succ p) (Pos.lt_1_succ p)).
  clear p. intros p ppos.
  destruct p. inversion ppos.
  2: inversion ppos. clear ppos.
  unfold Z.to_pos.
  pose proof (fact_power_2 (Pos.to_nat (Pos.succ p))).
  rewrite Pos2Nat.inj_succ in H.
  unfold pred in H.
  rewrite Pos2Nat.inj_succ.
  simpl (2^p)%Z.
  rewrite <- Pos2Z.inj_pow_pos.
  apply Pos2Nat.inj_le.
  rewrite Nat2Pos.id.
  2: apply fact_neq_0.
  refine (le_trans _ _ _ _ H).
  clear H. generalize p.
  apply Pos.peano_ind.
  + apply le_refl.
  + intros. rewrite Pos2Nat.inj_succ, Pos.pow_succ_r.
    rewrite Pos2Nat.inj_mul.
    apply Nat.mul_le_mono_nonneg_l. apply le_0_n.
    exact H.
Qed.

(**
** Exponential
[exp] is implement by its alternating Taylor's series.
*)

Section ExpSeries.
Variable a:Q.

Definition expStream (px : positive*Q) : positive*Q
  := (Pos.succ (fst px), snd px * a * (1#fst px)).

Lemma expStream_fst : forall p, fst (iterate _ expStream p (1%positive, 1)) ≡ Pos.succ p.
Proof.
  apply Pos.peano_ind.
  - reflexivity.
  - intros. rewrite iterate_succ. simpl.
    rewrite H. reflexivity.
Qed.

Lemma Str_pth_expStream : forall p,
    Str_pth _ expStream p (xH,1) == (1#Pos.of_nat (fact (Pos.to_nat p)))*a^p.
Proof.
  apply Pos.peano_ind.
  - unfold Str_pth. simpl. apply Qmult_1_r.
  - intros. unfold Str_pth.
    rewrite iterate_succ. simpl.
    unfold Str_pth in H. rewrite H. clear H.
    rewrite expStream_fst. simpl.
    rewrite <- (Qmult_comm (1#Pos.succ p)), Qmult_assoc, Qmult_assoc.
    rewrite <- (Qmult_assoc ((1 # Pos.succ p) * (1 # Pos.of_nat (fact (Pos.to_nat p))))).
    apply Qmult_comp.
    + unfold Qmult, Qeq, Qnum, Qden. rewrite Z.mul_1_l.
      rewrite Z.mul_1_l.
      rewrite Pos2Nat.inj_succ.
      change (fact (S (Pos.to_nat p)))%nat
        with (S (Pos.to_nat p) * fact (Pos.to_nat p))%nat.
      rewrite Nat2Pos.inj_mul. 2: discriminate.
      2: apply fact_neq_0.
      rewrite Nat2Pos.inj_succ, Pos2Nat.id.
      reflexivity. pose proof (Pos2Nat.is_pos p).
      intro abs. rewrite abs in H. inversion H.
    + rewrite <- Pos.add_1_r.
      rewrite Qpower_plus_positive. reflexivity.
Qed.

Lemma expStream_alt : -1 <= a <= 0 -> Str_alt_decr _ expStream (xH,1).
Proof.
  intros aneg p.
  unfold Str_pth. rewrite iterate_succ.
  generalize (iterate (positive and Q) expStream p (1%positive, 1)).
  intros [n q]. unfold expStream, snd, fst. split.
  - rewrite <- Qmult_assoc.
    rewrite <- (Qmult_1_l (Qabs q)).
    rewrite Qabs_Qmult, Qmult_comm.
    apply Qmult_le_compat_r. 2: apply Qabs_nonneg.
    rewrite Qabs_Qmult.
    apply (Qle_trans _ (1 * Qabs (1#n))).
    apply Qmult_le_compat_r. 2: apply Qabs_nonneg.
    apply Qabs_Qle_condition. split.
    apply aneg. apply (Qle_trans _ 0). apply aneg. discriminate.
    rewrite Qmult_1_l. apply Pos.le_1_l.
  - destruct aneg as [_ aneg].
    rewrite <- (Qmult_comm a).
    rewrite <- Qmult_assoc, <- Qmult_assoc.
    rewrite <- (Qmult_0_l (q * ((1 # n) * q))).
    apply Qmult_le_compat_r. exact aneg.
    rewrite Qmult_comm.
    destruct q, Qnum; unfold Qle; discriminate.
Qed.

Lemma expStream_zl
  : -1 <= a <= 0
    -> Limit_zero _ expStream (xH,1)
                 (fun e:Qpos => Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ (proj1_sig e)))))).
Proof.
  (* 1/e <= Qceiling (1/e) <= 2 ^ (Z.log2_up (Qceiling (1/e)))
     and we add 1 more to get <= fact. *)
  intros aneg [e epos]; unfold proj1_sig.
  (* Replace a^k by 1 *)
  rewrite Str_pth_expStream.
  rewrite Qabs_Qmult, Qmult_comm.
  apply (Qle_trans
           _ (1 * Qabs (1 # Pos.of_nat (fact (Pos.to_nat (Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ e)))))))))).
  apply Qmult_le_compat_r. 2: apply Qabs_nonneg.
  - generalize (Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ e))))).
    intro p. rewrite Qabs_Qpower.
    apply Qpower_le_1. split. apply Qabs_nonneg.
    apply Qabs_Qle_condition. split. apply aneg.
    apply (Qle_trans _ 0). apply aneg. discriminate.
  - rewrite Qmult_1_l. clear aneg a.
    (* Replace fact k by 2^k. *)
    simpl.
    rewrite <- (Qinv_involutive e) at 2.
    assert (0 < /e) as H.
    { apply Qinv_lt_0_compat, epos. }
    apply (@Qinv_le_compat
             (/e) ((Pos.of_nat (fact (Pos.to_nat (Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ e)))))))) # 1)).
    exact H.
    apply Qceiling_fact_le, H.
Qed.

End ExpSeries.

Lemma exp_ps_correct : forall (a:Q) (p:positive) H,
    inj_Q IR (Str_pth _ (expStream a) p (xH,1))%Q
    = Exp_ps (Pos.to_nat p) (inj_Q IR a) H.
Proof.
 intros a p H.
 rewrite (inj_Q_wd _ _ _ (Str_pth_expStream a p)).
 revert p H.
 apply (Pos.peano_ind (fun p =>  ∀ (H : Dom (Exp_ps (Pos.to_nat p)) (inj_Q IR a)),
    inj_Q IR ((1 # Pos.of_nat (fact (Pos.to_nat p))) * a ^ p) =
    Exp_ps (Pos.to_nat p) (inj_Q IR a) H)).
 - intros H.
   simpl ((1 # Pos.of_nat (fact (Pos.to_nat 1))) * a ^ 1).
   rewrite (inj_Q_wd _ _ _ (one_mult _ a)).
   unfold Pos.to_nat. simpl.
   rewrite one_mult.
   setoid_replace ([1] [/] [0] [+] [1] [//] nring_fac_ap_zero IR 1) with (cr_one IR).
   rewrite one_mult.
   rewrite cg_inv_zero.
   reflexivity.
   unfold cf_div.
   rewrite one_mult.
   rewrite <- inv_one at 2.
   apply f_rcpcl_wd.
   rewrite cm_lft_unit.
   reflexivity.
 - intros p IHp H.
   rewrite Pos2Nat.inj_succ.
   stepl (([1][/](nring (S (Pos.to_nat p)))[//]nringS_ap_zero IR (Pos.to_nat p))
            [*](inj_Q IR a)[*]Exp_ps (Pos.to_nat p) (inj_Q IR a) H).
   + simpl.
     rewrite (mult_commutes IR (nexp IR (Pos.to_nat p) (inj_Q IR a [-] [0]))).
     rewrite (ax_mult_assoc IR _ _ (cr_proof IR)).
     rewrite (ax_mult_assoc IR _ _ (cr_proof IR)).
     apply mult_wd. 2: reflexivity.
     rewrite cg_inv_zero.
     rewrite <- (mult_commutes IR (inj_Q IR a)).
     rewrite <- (mult_commutes IR (inj_Q IR a)).
     rewrite <- (ax_mult_assoc IR _ _ (cr_proof IR)).
     apply mult_wd. reflexivity.
     pose proof (mult_resp_ap_zero _ _ _ (nringS_ap_zero IR (Pos.to_nat p)) (nring_fac_ap_zero IR (Pos.to_nat p)))
       as X.
     rewrite <- (mult_of_divs _ _ _ _ _ _ _ X).
     apply div_wd. apply mult_one.
     apply eq_symmetric.
     change (fact (Pos.to_nat p) + (Pos.to_nat p) * fact (Pos.to_nat p))%nat
       with (S (Pos.to_nat p)*(fact (Pos.to_nat p)))%nat.
     apply nring_comm_mult.
   + stepl (inj_Q IR ((1#(Pos.succ p))
                      *a*((1 # Pos.of_nat (fact (Pos.to_nat p))) * a ^ Pos.to_nat p))%Q).
     * apply inj_Q_wd.
       rewrite <- Pos.add_1_l at 2.
       rewrite (Qpower_plus' a 1 p).
       2: discriminate.
       simpl (a ^ 1).
       rewrite Qmult_assoc, Qmult_assoc.
       apply Qmult_comp.
       rewrite <- (Qmult_comm a), <- Qmult_assoc, Qmult_comm.
       apply Qmult_comp. 2: reflexivity.
       change (fact (S (Pos.to_nat p)))%nat
         with ((S (Pos.to_nat p)) * fact (Pos.to_nat p))%nat.
       rewrite Nat2Pos.inj_mul.
       2: discriminate. 2: apply fact_neq_0.
       replace (Pos.of_nat (S (Pos.to_nat p))) with (Pos.succ p).
       reflexivity.
       rewrite Nat2Pos.inj_succ.
       rewrite Pos2Nat.id. reflexivity.
       pose proof (Pos2Nat.is_pos p).
       intro abs. rewrite abs in H0. inversion H0.
       rewrite positive_nat_Z. reflexivity.
     * stepl (([1][/]nring (R:=IR) (S (Pos.to_nat p))[//]nringS_ap_zero IR (Pos.to_nat p))[*]inj_Q IR a[*]
            inj_Q IR ((1 # Pos.of_nat (fact (Pos.to_nat p))) * a ^ p)%Q)
       ; [apply mult_wdr; apply IHp|].
       clear IHp H.
       apply eq_symmetric.
       eapply eq_transitive;[apply inj_Q_mult|].
       eapply eq_transitive;[apply mult_wdl;apply inj_Q_mult|].
       rewrite positive_nat_Z.
       apply mult_wdl.
       apply mult_wdl.
       change (1 # Pos.succ p)%Q with (1/Pos.succ p)%Q.
       assert (A:inj_Q IR ((Pos.succ p):Q)[=]nring (S (Pos.to_nat p))).
       { stepl (inj_Q IR (nring (S (Pos.to_nat p)))).
         apply inj_Q_nring.
         apply inj_Q_wd.
         simpl.
         rewrite <- Pos.add_1_r.
         rewrite Pos2Z.inj_add, inject_Z_plus.
         apply Qplus_comp. 2: reflexivity.
         revert p. apply Pos.peano_ind.
         reflexivity. intros p IHp.
         rewrite Pos2Nat.inj_succ. simpl.
         rewrite -> IHp.
         rewrite <- Pos.add_1_r.
         rewrite Pos2Z.inj_add, inject_Z_plus.
         reflexivity. }
       assert (B:inj_Q IR (Pos.succ p:Q)[#][0]).
       { stepl (nring (R:=IR) (S (Pos.to_nat p))).
         apply nringS_ap_zero.
         apply eq_symmetric;assumption. }
       eapply eq_transitive;[apply inj_Q_div|].
       instantiate (1:=B).
       apply div_wd.
       apply inj_Q_One.
       exact A.
Qed.

Definition rational_exp_small_neg (a:Q) (p:-(1) <= a <= 0) : CR
  := translate 1 (AltSeries _ (expStream a) (xH,1%Q) _
                            (expStream_alt p) (expStream_zl p)).

Lemma rational_exp_small_neg_wd (a1 a2 : Q) (p1 : -(1) <= a1 <= 0) (p2 : -(1) <= a2 <= 0) :
  a1 == a2 → rational_exp_small_neg p1 = rational_exp_small_neg p2.
Proof.
  intros E. unfold rational_exp_small_neg.
  rewrite <- CRplus_translate.
  rewrite <- CRplus_translate.
  apply CRplus_eq_r.
  apply AltSeries_wd.
  apply Pos.peano_ind.
  - unfold Str_pth; simpl.
    rewrite E. reflexivity.
  - intros. unfold Str_pth.
    rewrite iterate_succ, iterate_succ.
    simpl.
    unfold Str_pth in H. rewrite H. clear H.
    apply Qmult_comp.
    apply Qmult_comp. reflexivity.
    exact E.
    rewrite expStream_fst, expStream_fst.
    reflexivity.
  - reflexivity.
Qed.

Lemma rational_exp_small_neg_correct : forall (a:Q) Ha,
    (@rational_exp_small_neg a Ha == IRasCR (Exp (inj_Q IR a)))%CR.
Proof.
  intros a Ha.
  unfold rational_exp_small_neg.
  rewrite <- CRplus_translate.
  setoid_replace 1%CR with
      (IRasCR
         ((λ n : nat,
                 Exp_ps n (inj_Q IR a)
                        (fun_series_inc_IR realline Exp_ps Exp_conv (inj_Q IR a) I n)) 0%nat)).
  apply: AltSeries_correct.
  intro p.
  apply exp_ps_correct.
  simpl.
  rewrite <- IR_One_as_CR.
  apply IRasCR_wd.
  rewrite mult_one.
  unfold cf_div.
  rewrite one_mult.
  rewrite <- inv_one at 1.
  apply f_rcpcl_wd.
  rewrite cm_lft_unit.
  reflexivity.
Qed.

Program Definition CRe_inv := @rational_exp_small_neg (-1) _.
Next Obligation. constructor; discriminate. Qed.

(** exp is extended to work on [[-2^n, 0]] for all n. *)

(* Faster to compress between the powers of 2, than take a big power 2^n. *)
Fixpoint CRpower_2_iter (n : nat) (x : CR) : CR :=
  match n with
  | O => x
  | S p => CRpower_N_bounded 2 (1#1) (compress (CRpower_2_iter p x))
  end.

Lemma CRpower_2_iter_wd : forall (n : nat) (x y : CR),
    (x == y)%CR -> (CRpower_2_iter n x == CRpower_2_iter n y)%CR.
Proof.
  induction n.
  - intros. exact H.
  - intros. simpl. apply Cmap_wd. reflexivity.
    rewrite compress_fun_correct, compress_fun_correct.
    apply IHn, H.
Qed.

Local Opaque compress CRpower_N_bounded.
Lemma rational_exp_neg_bounded_correct_aux (a : Q) :
  a ≤ 0 → (CRpower_N_bounded 2 (1 # 1)) (IRasCR (Exp (inj_Q IR (a / 2))))
          = IRasCR (Exp (inj_Q IR a)).
Proof.
 intros Ea.
 rewrite <- CRpower_N_bounded_correct.
 - change (CRpower_slow (IRasCR (Exp (inj_Q IR (a / 2)))) (N.to_nat 2))%CR
     with (IRasCR (Exp (inj_Q IR (a / 2)))
           * (IRasCR (Exp (inj_Q IR (a / 2))) * 1))%CR.
   rewrite CRmult_1_r.
   rewrite <- IR_mult_as_CR.
   apply IRasCR_wd.
  set (a':=inj_Q IR (a/2)).
  simpl.
  stepl (Exp (a'[+]a')); [| now apply Exp_plus].
  apply Exp_wd.
  unfold a'.
  eapply eq_transitive.
   apply eq_symmetric; apply (inj_Q_plus IR).
  apply inj_Q_wd.
  change (a / (2#1) + a / (2#1) == a). field.
 - apply leEq_imp_AbsSmall.
   + rewrite <- IR_Zero_as_CR.
     apply IR_leEq_as_CR.
     apply less_leEq; apply Exp_pos.
   + apply (@CRle_trans _ (IRasCR [1])).
     apply IR_leEq_as_CR. apply Exp_leEq_One.
     stepr (inj_Q IR 0); [| now apply (inj_Q_nring IR 0)].
     apply inj_Q_leEq.
     apply mult_cancel_leEq with (2:Q).
     constructor.
     change (a/2*2<=0).
     now replace LHS with a by (simpl; field; discriminate).
     simpl. rewrite IR_One_as_CR. apply CRle_refl.
Qed.

(** [exp] works on all nonpositive numbers. *)

(* Do not do 2^n in nat, it could make a very large unary nat. *)
Lemma rational_exp_neg_bounded_correct : forall (n:nat) (a:Q) (Ha : -1 <= a*(1#2)^n <= 0),
    (CRpower_2_iter n (rational_exp_small_neg Ha) == IRasCR (Exp (inj_Q IR a)))%CR.
Proof.
 induction n.
 - intros. simpl.
   assert (-1 <= a <= 0) as Ha_simpl.
   { simpl in Ha. rewrite Qmult_1_r in Ha. exact Ha. }
   rewrite <- (rational_exp_small_neg_correct Ha_simpl).
   apply rational_exp_small_neg_wd.
   apply Qmult_1_r.
 - intros a Ha.
   simpl.
   rewrite -> compress_correct.
   rewrite <- rational_exp_neg_bounded_correct_aux.
   apply Cmap_wd. reflexivity.
   assert (-1 <= (a/2)*(1#2)^n <= 0) as Ha_div.
   { change (S n) with (1+n)%nat in Ha.
     rewrite Nat2Z.inj_add, Qpower_plus in Ha.
     simpl in Ha. rewrite Qmult_assoc in Ha.
     exact Ha. discriminate. }
   rewrite <- (IHn _ Ha_div).
   apply CRpower_2_iter_wd, rational_exp_small_neg_wd.
   unfold Qdiv. rewrite <- Qmult_assoc.
   apply Qmult_comp. reflexivity.
   change (/2) with ((1#2)^1).
   rewrite <- Qpower_plus.
   clear IHn.
   change 1%Z with (Z.of_nat 1).
   rewrite <- (Nat2Z.inj_add 1 n).
   reflexivity. discriminate.
   destruct Ha as [_ Ha].
   apply (Qmult_le_r _ _ ((1#2)^S n)).
   apply Q.Qpower_0_lt. reflexivity.
   rewrite Qmult_0_l. exact Ha.
Qed.

(* Improve n such as -2^n <= a.
   -a <= 2^n is equivalent to Qceiling(-a) <= 2^n and then
   we can use the integer log2. *)
Lemma rational_exp_bound_power_2 : forall (a:Q),
    a <= 0 -> - inject_Z (2^Z.to_nat (Z.log2_up (Qceiling(-a)))) <= a.
Proof.
 intros [[|n|n] d] Ha; simpl.
   discriminate.
  elim Ha.
  reflexivity.
  rewrite Z2Nat.id.
  clear Ha.
  rewrite <- (Qopp_involutive (Z.neg n # d)) at 2.
  apply Qopp_le_compat.
  change (-(Z.neg n#d)) with (Zpos n # d).
  apply Q.Zle_Qle_Qceiling.
  apply Z.log2_up_le_pow2.
  2: apply Z.le_refl.
  apply Z2Nat.inj_lt. apply Z.le_refl.
  apply (Qceiling_resp_le 0). discriminate.
  apply Q.Qlt_lt_of_nat_inject_Z.
  reflexivity.
  apply Z.log2_up_nonneg.
Qed.

Lemma power_2_improve_bound_correct : forall (n:nat) (a:Q),
    a <= 0 ->
    -inject_Z (2^n) <= a ->
    -1 <= a*(1#2)^n <= 0.
Proof.
  split.
  - apply (Qmult_le_r _ _ ((2#1)^n)).
    apply Q.Qpower_0_lt. reflexivity.
    apply (Qle_trans _ a).
    rewrite Zpower_Qpower in H0.
    exact H0. apply Nat2Z.is_nonneg.
    rewrite <- Qmult_assoc, <- Qmult_power.
    setoid_replace ((1 # 2) * 2)%Q with 1%Q by reflexivity.
    rewrite Qpower_1, Qmult_1_r. apply Qle_refl.
  - rewrite <- (Qmult_0_l ((1#2)^n)).
    apply Qmult_le_compat_r. exact H.
    apply Qpower_pos. discriminate.
Qed.

Definition rational_exp_neg (a:Q) (Ha : a <= 0) : CR
  := CRpower_2_iter
       (Z.to_nat (Z.log2_up (Qceiling(-a))))
       (rational_exp_small_neg
          (power_2_improve_bound_correct _ Ha (rational_exp_bound_power_2 Ha))).

(* Some time measures on a 5000 bogomips CPU
Lemma Zneg_neg : forall p:positive, Z.neg p # 1 <= 0.
Proof. intros. discriminate. Qed.
Time Eval vm_compute in (approximate (rational_exp_neg (@Zneg_neg 100%positive))
                                     (Qpos2QposInf (1#(10 ^ 100)%positive))).
(* 1.3 secs *)
Time Eval vm_compute in (approximate (rational_exp_neg (@Zneg_neg 200%positive))
                                     (Qpos2QposInf (1#(10 ^ 200)%positive))).
(* 8 secs *)
Time Eval vm_compute in (approximate (rational_exp_neg (@Zneg_neg 300%positive))
                                     (Qpos2QposInf (1#(10 ^ 300)%positive))).
(* 23.6 secs *)
*)

Lemma rational_exp_neg_correct : forall (a:Q) Ha,
 (@rational_exp_neg a Ha == IRasCR (Exp (inj_Q IR a)))%CR.
Proof.
 intros a Ha.
 apply rational_exp_neg_bounded_correct.
Qed.

(** exp(x) is bounded below by (3^x) for x nonpositive, and hence
exp(x) is positive. *)
Lemma CRe_inv_posH : ('(1#3) <= CRe_inv)%CR.
Proof.
 unfold CRle.
 apply CRpos_nonNeg.
 CR_solve_pos (1#1)%Qpos.
Qed.

(* We parametrize the following lemmas by a lowerbound of [CRe_inv] so that
    we can easily swap lowerbounds. *)
Lemma rational_exp_neg_posH (q : Qpos) (n:nat) (a:Q) :
  -n ≤ a → a ≤ 0 → '(proj1_sig q) ≤ CRe_inv
  → '(proj1_sig q^n) ≤ IRasCR (Exp (inj_Q IR a)).
Proof.
 intros Hn Ha small.
 rewrite <- IR_inj_Q_as_CR.
 rewrite <- IR_leEq_as_CR.
 stepl (inj_Q IR (proj1_sig q) [^]n)
   by (now (apply eq_symmetric; apply inj_Q_power)).
 assert (X:[0][<]inj_Q IR (`q)).
  stepl (inj_Q IR 0); [| now apply (inj_Q_nring IR 0)].
  apply inj_Q_less.
  now destruct q.
 astepl (inj_Q IR (`q)[!](nring n)[//]X).
 unfold power.
 apply Exp_resp_leEq.
 destruct n.
 simpl (nring 0).
 rewrite cring_mult_zero_op.
  stepl (inj_Q IR 0); [| now apply (inj_Q_nring IR 0)].
  apply inj_Q_leEq.
  assumption.
 apply (fun a b => (shift_mult_leEq' _ a b _ (nringS_ap_zero IR n))).
  apply nring_pos; auto with *.
 stepr (inj_Q IR (a/(S n))).
  apply Exp_cancel_leEq.
  astepl (inj_Q IR (`q)).
  rewrite -> IR_leEq_as_CR.
  rewrite -> IR_inj_Q_as_CR.
  assert (Ha0 : -(1)<=(a/S n)<=0).
   split.
    rewrite -> Qle_minus_iff.
    replace RHS with ((a + S n)*(1/(S n))) by (simpl; field;discriminate).
    replace LHS with (0*(1/(S n))) by simpl; ring.
    apply: mult_resp_leEq_rht;simpl.
     replace RHS with (a + - (- (P_of_succ_nat n))) by simpl; ring.
     rewrite <- Qle_minus_iff.
     assumption.
    rewrite <- (Qmake_Qdiv 1 (P_of_succ_nat n)).
    discriminate.
   replace RHS with (0*(1/(S n))) by simpl; ring.
   apply: mult_resp_leEq_rht;simpl.
    assumption.
   rewrite <- (Qmake_Qdiv 1 (P_of_succ_nat n)).
   discriminate.
  rewrite <- (rational_exp_small_neg_correct Ha0).
  apply CRle_trans with CRe_inv.
   apply small.
  unfold CRe_inv.
  do 2 rewrite -> (rational_exp_small_neg_correct).
  rewrite <- IR_leEq_as_CR.
  apply Exp_resp_leEq.
  apply inj_Q_leEq.
  tauto.
 assert (X0:inj_Q IR (inject_Z (S n))[#][0]).
  stepl (inj_Q IR (nring (S n))).
   stepl (@nring IR (S n)); [| now (apply eq_symmetric; apply (inj_Q_nring IR (S n)))].
   apply (nringS_ap_zero).
  apply inj_Q_wd.
  apply nring_Q.
 stepl (inj_Q IR a[/]_[//]X0).
  apply div_wd.
   apply eq_reflexive.
  stepl (inj_Q IR (nring (S n))).
   apply inj_Q_nring.
  apply inj_Q_wd.
  apply nring_Q.
 apply eq_symmetric.
 apply inj_Q_div.
Qed.

Lemma rational_exp_neg_posH' (c : Qpos) (a : Q) :
  a ≤ 0 → '(proj1_sig c) ≤ CRe_inv
  → '(proj1_sig (Qpos_power c (-Qfloor a))) ≤ IRasCR (Exp (inj_Q IR a)).
Proof.
 intros Ha small.
 assert (X0:(0 <= -Qfloor a)%Z).
  apply Z.opp_nonneg_nonpos.
  rewrite Q.Zle_Qle.
  apply Qle_trans with a; [| assumption].
  now apply Qfloor_le.
  setoid_replace (proj1_sig (Qpos_power c (-Qfloor a)))
    with (proj1_sig c ^ Z_to_nat X0).
  apply rational_exp_neg_posH; trivial.
  rewrite <- (Z_to_nat_correct X0).
  rewrite inject_Z_opp, Qopp_involutive.
  now apply Qfloor_le.
 now rewrite <- Z_to_nat_correct.
Qed.

(* Need transparent and fast positivity to define
   exponential on positive rationals by division. *)
Lemma rational_exp_neg_pos : forall (a:Q) Ha,
 CRpos (@rational_exp_neg a Ha).
Proof.
 intros a Ha.
 exists (Qpos_power (1#3) (-Qfloor a))%Qpos. simpl.
 rewrite rational_exp_neg_correct.
 apply (rational_exp_neg_posH' (1#3)); trivial.
 apply CRe_inv_posH.
Defined.

(** exp is extended to all numbers by saying exp(x) = 1/exp(-x) when x
is positive. *)
Definition rational_exp (a:Q) : CR.
Proof.
  destruct a as [[|n|n] d].
  - exact 1%CR.
  - refine (CRinv_pos (Qpos_power (1#3) (Qceiling (n#d)))%Qpos
                      (@rational_exp_neg (Zneg n#d) _)).
    discriminate.
  - apply (@rational_exp_neg (Zneg n#d)).
    discriminate.
Defined.

(* Some time measures on a 5000 bogomips CPU
Time Eval vm_compute in (approximate (rational_exp (100#1)) (Qpos2QposInf (1#1))).
(* 1.2 secs *)

Time Eval vm_compute in (approximate (rational_exp (200#1)) (Qpos2QposInf (1#1))).
(* 7.1 secs *)

Time Eval vm_compute in (approximate (rational_exp (300#1)) (Qpos2QposInf (1#1))).
(* 21 secs *)
*)

Lemma rational_exp_pos_correct (a : Q) (Pa : 0 ≤ a) (c : Qpos) :
  ('proj1_sig c <= IRasCR (Exp (inj_Q IR (-a)%Q)))%CR →
  CRinv_pos c (IRasCR (Exp (inj_Q IR (-a)))) = IRasCR (Exp (inj_Q IR a)).
Proof.
 intros Ec.
 assert (X: (IRasCR (Exp (inj_Q IR (-a)%Q)) >< 0)%CR).
  right. exists c.
  now ring_simplify.
 rewrite (CRinvT_pos_inv c X); trivial.
 rewrite <- IR_recip_as_CR_2.
 apply IRasCR_wd.
 apply eq_symmetric.
 eapply eq_transitive;[|apply div_wd; apply eq_reflexive].
 apply Exp_inv'.
 rewrite (inj_Q_inv IR a), cg_inv_inv.
 reflexivity.
Qed.

Lemma rational_exp_correct (a : Q) :
 (rational_exp a = IRasCR (Exp (inj_Q IR a)))%CR.
Proof.
 unfold rational_exp.
 destruct a as [[|n|n] d].
 - rewrite <- IR_One_as_CR.
   apply IRasCR_wd.
   setoid_replace (inj_Q IR (0 # d)) with (cm_unit IR).
   symmetry. apply Exp_zero.
   rewrite <- inj_Q_Zero.
   apply inj_Q_wd. reflexivity.
 - rewrite rational_exp_neg_correct.
   apply (@rational_exp_pos_correct (Zpos n#d)).
   discriminate.
   apply (rational_exp_neg_posH' (1#3)).
   discriminate.
   now apply CRe_inv_posH.
 - apply rational_exp_neg_correct.
Qed.

Lemma rational_exp_square (a : Q) :
  a ≤ 0 → CRpower_N_bounded 2 (1 # 1) (rational_exp (a / 2)) = rational_exp a.
Proof.
 intros.
 rewrite 2!rational_exp_correct.
 now apply rational_exp_neg_bounded_correct_aux.
Qed.

Lemma rational_exp_opp (c : Qpos) (a : Q) :
  0 ≤ a → '(proj1_sig c) ≤ rational_exp (-a) → CRinv_pos c (rational_exp (-a)) = rational_exp a.
Proof.
  rewrite ?rational_exp_correct.
  intros. now apply rational_exp_pos_correct.
Qed.

Lemma rational_exp_lower_bound (c : Qpos) (a : Q) :
  a ≤ 0 → '(proj1_sig c) ≤ CRe_inv
  → '(proj1_sig (Qpos_power c (-Qfloor a))) ≤ rational_exp a.
Proof.
 rewrite rational_exp_correct.
 now apply rational_exp_neg_posH'.
Qed.

(**
*** e
*)
Definition CRe : CR := rational_exp 1.

Lemma CRe_correct : (CRe = IRasCR E)%CR.
Proof.
 unfold CRe.
 rewrite -> rational_exp_correct.
 apply IRasCR_wd.
 rewrite inj_Q_One.
 algebra.
Qed.

#[global]
Hint Rewrite <- CRe_correct : IRtoCR.

Opaque inj_Q.

(** [exp] is uniformly continuous below any given integer. *)
Definition exp_bound (z:Z) : Qpos :=
(match z with
 |Z0 => 1#1
 |Zpos p => Qpos_power (3#1) p
 |Zneg p => Qpos_power (1#2) p
 end)%Qpos.

Lemma exp_bound_bound : forall (z:Z) x, closer (inj_Q IR (z:Q)) x -> AbsIR (Exp x)[<=]inj_Q IR (proj1_sig (exp_bound z)).
Proof.
 intros [|z|z]; simpl; intros x Hx; apply AbsSmall_imp_AbsIR;
   (apply leEq_imp_AbsSmall;[apply less_leEq; apply Exp_pos|]).
 rewrite inj_Q_One.
 apply Exp_leEq_One.
 rewrite inj_Q_Zero in Hx.
 exact Hx.
  apply leEq_transitive with (Exp (Max x [0])).
   apply Exp_resp_leEq.
   apply lft_leEq_Max.
  stepr (Three[!](inj_Q IR (inject_Z z))[//](pos_three IR)).
   astepl (E[!](Max x [0])[//]pos_E).
   apply real_power_resp_leEq_both; try solve [IR_solve_ineq (1#1)%Qpos].
    apply rht_leEq_Max.
   apply Max_leEq; auto.
   stepl (inj_Q IR 0).
    apply inj_Q_leEq.
    simpl; auto with *.
   apply (inj_Q_nring IR 0).
  stepl (Three[!]nring (nat_of_P z)[//]pos_three IR).
   astepl (@nring IR 3 [^](nat_of_P z)).
   stepl ((inj_Q IR (3%mc:Q))[^](nat_of_P z)).
    stepl (inj_Q IR (3%mc^z)).
     apply inj_Q_wd.
     apply eq_symmetric.
     reflexivity.
    rewrite <- convert_is_POS.
    apply inj_Q_power.
   apply nexp_wd.
   apply (inj_Q_nring IR 3).
  apply power_wd.
   apply eq_reflexive.
  apply eq_symmetric.
  rewrite <- convert_is_POS.
  stepl (inj_Q IR (nring (nat_of_P z))).
   apply (inj_Q_nring).
  apply inj_Q_wd; apply nring_Q.
 stepr (Half[!](inj_Q IR (inject_Z z))[//](pos_half IR)).
  astepl (Exp [--][--]x).
  astepl ([1][/]_[//](Exp_ap_zero [--]x)).
  unfold Half.
  astepr (([1][!]inj_Q IR (z:Q)[//]pos_one _)[/]((Two[!]inj_Q IR (z:Q)[//]pos_two _))[//]power_ap_zero _ _ _).
  astepr ([1][/]((Two[!]inj_Q IR (z:Q)[//]pos_two _))[//]power_ap_zero _ _ _).
  apply recip_resp_leEq.
   apply power_pos.
  astepr (E[!][--]x[//]pos_E).
  apply real_power_resp_leEq_both; try solve [IR_solve_ineq (1#1)%Qpos].
   stepl (inj_Q IR 0).
    apply inj_Q_leEq.
    simpl; auto with *.
   apply (inj_Q_nring IR 0).
   rewrite <- cg_inv_inv.
  apply inv_resp_leEq.
  stepr (inj_Q IR ((Zneg z):Q)).
   assumption.
  astepr (inj_Q IR (-(z:Q))).
  apply inj_Q_wd.
  simpl; reflexivity.
 stepl (Half[!]nring (nat_of_P z)[//]pos_half IR).
  astepl (@Half IR [^](nat_of_P z)).
  stepl ((inj_Q IR ((1#2):Q))[^](nat_of_P z)).
   stepl (inj_Q IR ((1#2)^z)).
    apply inj_Q_wd.
    apply eq_symmetric.
    reflexivity.
   rewrite <- (convert_is_POS z).
   apply inj_Q_power.
  apply nexp_wd.
  assert (X:(inj_Q IR (2:Q))[#][0]).
   stepr (inj_Q IR 0).
    apply inj_Q_ap; discriminate.
   apply (inj_Q_nring IR 0).
  stepr ((inj_Q IR 1)[/]_[//]X).
   stepl (inj_Q IR (1/2)).
    apply inj_Q_div.
   apply inj_Q_wd.
   apply eq_symmetric; apply Qmake_Qdiv.
  apply div_wd.
  apply inj_Q_One.
  apply (inj_Q_nring IR 2).
 apply power_wd.
  apply eq_reflexive.
 apply eq_symmetric.
 rewrite <- convert_is_POS.
 stepl (inj_Q IR (nring (nat_of_P z))).
  apply (inj_Q_nring).
 apply inj_Q_wd; apply nring_Q.
Qed.

Lemma exp_bound_uc_prf : forall z:Z, is_UniformlyContinuousFunction (fun a => rational_exp (Qmin z a)) (Qscale_modulus (proj1_sig (exp_bound z))).
Proof.
 intros z.
 assert (Z:Derivative (closer (inj_Q IR (z:Q))) I Expon Expon).
  apply (Included_imp_Derivative realline I).
   Deriv.
  Included.
 apply (is_UniformlyContinuousD None (Some (z:Q)) I _ _ Z).
  intros q [] H.
  apply rational_exp_correct.
 intros x [] H.
 apply: exp_bound_bound.
 assumption.
Qed.

Definition exp_bound_uc (z:Z) :  Q_as_MetricSpace --> CR :=
Build_UniformlyContinuousFunction (@exp_bound_uc_prf z).

(** [exp] for any real number upto a given integer. *)
Definition exp_bounded (z:Z) : CR --> CR := (Cbind QPrelengthSpace (exp_bound_uc z)).

Lemma exp_bounded_correct : forall (z:Z) x, closer (inj_Q _ (z:Q)) x -> (IRasCR (Exp x)==exp_bounded z (IRasCR x))%CR.
Proof.
 intros z x Hx.
 assert (Z:Continuous (closer (inj_Q IR (z:Q))) Expon).
  apply (Included_imp_Continuous realline).
   Contin.
  Included.
 apply (fun a b c => @ContinuousCorrect _ a Expon Z b c x I); auto with *.
  constructor.
 intros q [] H.
 transitivity (exp_bound_uc z q);[|].
  change (' q)%CR with (Cunit_fun _ q).
  unfold exp_bounded.
  pose proof (Cbind_correct QPrelengthSpace (exp_bound_uc z)).
  apply ucEq_equiv in H0.
  rewrite (H0 (Cunit_fun Q_as_MetricSpace q)). clear H0.
  apply BindLaw1.
 change (rational_exp (Qmin z q) == IRasCR (Exp (inj_Q IR q)))%CR.
 rewrite -> rational_exp_correct.
 apply IRasCR_wd.
 apply Exp_wd.
 apply inj_Q_wd.
 simpl.
 rewrite <- Qle_min_r.
 apply leEq_inj_Q with IR.
 assumption.
Qed.

(** exp on all real numbers.  [exp_bounded] should be used instead when [x]
is known to be bounded by some intenger. *)
Definition exp (x:CR) : CR
  := exp_bounded (Qceiling (approximate x (Qpos2QposInf (1#1)) + (1#1))) x.
(* begin hide *)
Arguments exp : clear implicits.
(* end hide *)
Lemma exp_bound_lemma : forall x : CR, (x <= ' (approximate x (Qpos2QposInf (1 # 1)) + 1)%Q)%CR.
Proof.
 intros x.
 assert (X:=ball_approx_l x (1#1)).
 rewrite <- CRAbsSmall_ball in X.
 destruct X as [X _].
 simpl in X.
 rewrite <- CRplus_Qplus.
 apply CRle_trans with (doubleSpeed x).
  rewrite -> (doubleSpeed_Eq x); apply CRle_refl.
 intros e.
 assert (Y:=X e).
 simpl in *.
 do 2 (unfold Cap_raw in *; simpl in * ).
 apply (Qle_trans _ _ _ Y).
 ring_simplify. apply Qle_refl.
Qed.

Lemma exp_correct : forall x, (IRasCR (Exp x) = exp (IRasCR x))%CR.
Proof.
 intros x.
 unfold exp.
 apply exp_bounded_correct.
 simpl.
 apply leEq_transitive with (inj_Q IR ((approximate (IRasCR x) (Qpos2QposInf (1 # 1)) + 1)));
   [|apply inj_Q_leEq; simpl;auto with *].
 rewrite -> IR_leEq_as_CR.
 rewrite -> IR_inj_Q_as_CR.
 apply exp_bound_lemma.
Qed.
(* begin hide *)
#[global]
Hint Rewrite exp_correct : IRtoCR.
(* end hide *)
Lemma exp_bound_exp : forall (z:Z) (x:CR),
 (x <= 'z ->
  exp_bounded z x == exp x)%CR.
Proof.
 intros z x H.
 unfold exp.
 set (a:=(approximate x (Qpos2QposInf (1 # 1)) + 1)).
 rewrite <- (CRasIRasCR_id x).
 rewrite <- exp_bounded_correct.
  rewrite <- exp_bounded_correct.
   reflexivity.
  change (CRasIR x [<=] inj_Q IR (Qceiling a:Q)).
  rewrite -> IR_leEq_as_CR.
  autorewrite with IRtoCR.
  rewrite -> CRasIRasCR_id.
  apply CRle_trans with ('a)%CR.
   apply exp_bound_lemma.
  rewrite -> CRle_Qle.
  auto with *.
 change (CRasIR x [<=] inj_Q IR (z:Q)).
 rewrite -> IR_leEq_as_CR.
 autorewrite with IRtoCR.
 rewrite -> CRasIRasCR_id.
 assumption.
Qed.
(* begin hide *)
Add Morphism exp with signature (@msp_eq _) ==> (@msp_eq _) as exp_wd.
Proof.
 intros x y Hxy.
 unfold exp at 1.
 set (a :=  (approximate x (Qpos2QposInf (1 # 1)) + 1)).
 rewrite -> Hxy.
 apply exp_bound_exp.
 rewrite <- Hxy.
 apply CRle_trans with ('a)%CR.
  apply exp_bound_lemma.
 rewrite -> CRle_Qle.
 auto with *.
Qed.
(* end hide *)
Lemma exp_Qexp : forall x : Q, (exp (' x) = rational_exp x)%CR.
Proof.
 intros x.
 rewrite <- IR_inj_Q_as_CR.
 rewrite <- exp_correct.
 rewrite <- rational_exp_correct.
 reflexivity.
Qed.

#[global]
Instance: Proper ((=) ==> (=)) rational_exp.
Proof.
  intros x1 x2 E.
  rewrite <-2!exp_Qexp.
  now rewrite E.
Qed.

(* begin hide *)
#[global]
Hint Rewrite exp_Qexp : CRfast_compute.
(* end hide *)


Require Import spec.

(**
* Instantiating the parameters
*)

(**
So far, our definitions and proofs were parametric over
details like our choice of linear and angular speed,
accuracy of the timer used to delay sending of messages,
and the desired accuracy for approximating the delay values.
To actually run our program, we need to instantiate those parameters:
*)

(**
We chose some reasonable speed values that the hardware is capable of achieving.
Our proofs derive a bound of the error in the final position w.r.t the
actuation error.
*)

Definition rotSpeedRadPerSec : Qpos := QposMake 1 2.

Definition linSpeedMetresPerSec : Qpos := QposMake 1 10.

Require Import RoshaskMsg.

(**
[RoshaskMsg.delayResolutionSecInv] denotes the timing resolution of our Haskell shim,
which is currently 1 microsecond.
*)
Definition  delResSecInv :  positive := RoshaskMsg.delayResolutionSecInv.

Definition delEpsSec : Qpos := QposMake 1  delResSecInv.

Definition initDelayLin : Qpos := QposMake 1 1.

Require Import message.

Definition SwProcessInstance : Process Message (list Message):=
  @SwProcess
          rotSpeedRadPerSec
          linSpeedMetresPerSec
          delResSecInv
          delEpsSec
          initDelayLin.

(**
* Providing an instance of [RosHaskImplementable]
*)

(**
Now that we have the concrete Coq program [Process] for the software agent,
we are almost ready to extract it to Haskell.

Before that, we need to provide some implementation details specific to the
Robot Operating System.
This is accomplished by showing that the [Topic] type we used in specification ([spec])
is an instance of [RosHaskImplementable].

One has to map the topics used so far to actual topics in the Robot Operating System.
Recall that followinng ROS, agents publish and subscribe to topics, and don't directly
communicate with other agents.
Also, for each topic, we need to map its payload type to a message type recognized by
the Robot Operating System. Note that the agents receiving our messages
may be written in other langaues such as C, as is often the case foe hardware agents.

The driver for our iRobot Create received messages of type
Ros.Geometry_msgs.Vector3.
See: #
http://docs.ros.org/api/geometry_msgs/html/msg/Vector3.html#
We have already generated the Coq type for this message : [Ros.Geometry_msgs.Vector3]
See the ROSCoq wiki to find out how to generate Coq message types for types used by the
Robot Operating System.

Even though the type of linear and angular velocities were rational numbers
fr convenience in reasoning, the driver receives a [Ros.Geometry_msgs.Vector3]
which is a triple of floats. We provide functions to interconvert between Coq rationals and machine floats.
This does not make our proofs useless. Firstly, we get to choose the desired linear
and angular velocity. Above, we chose rationals which have exact representations as floats.
Also, our specification already allow for actuation errors.
*)

Extraction Language Haskell.
Require Import ExtrHaskellBasic.

Require Import RoshaskImpl.
Require Import RoshaskTypes.

Require Import Vector.
Require Import Ros.Geometry_msgs.Vector3.

Definition toVector3  (x:Q) (y:Q) : Vector3 :=
  {| _x := toRoshaskFloat x ; _y := toRoshaskFloat y; _z:= toRoshaskFloat 0|}.

Definition CQtoVector3  (pq :Cart2D Q) : Vector3 :=
          toVector3 (X pq) (Y pq).

Definition PQtoVector3  (pq :Polar2D Q) : Vector3 :=
          toVector3 (rad pq) (θ pq).

Definition fromVector3 (v: Vector3) : Q × Q :=
  (fromRoshaskFloat (_x v), fromRoshaskFloat (_y v)).

(**
Interconvert between the payload types of ROSCoq topics and
the low level types used by the robot operating system.
These types can be the same (ideally). Then interconversion functions will be identities.
*)
Definition CQfromVector3 (v: Vector3) : Cart2D Q :=
  let (x,y) := fromVector3 v in
  {| X := x; Y:= y|}.

Definition PQfromVector3 (v: Vector3) : Polar2D Q :=
  let (x,y) := fromVector3 v in
  {| rad := x; θ := y|}.

Require Import String.

(** Finally, here is the instance *)

Instance TopicRosHaskImplementable : RosHaskImplementable Topic:=
  {|

(**
All payload types map to [Vector3] of the Robot Operating System.
We say that [Vector3] is the implementation type of topics
*)

topicImplType := λ _ : Topic, Vector3;

(**
Implementation types must be an instance of [ROSMsgType].
These instances are automatically generated when a Coq type is generated for a
message type of the Robot Operating System.
*)

topicImplTypeCorrect := λ _ : Topic, Vector3.ROSMsgInstance;

(**
Interconvert between the payload types and implementation types.
These are used by the shim when sending and receiving messages.
*)

toImpl := λ t : Topic,
          match t as t0 return (topicType t0 → Vector3) with
          | VELOCITY => PQtoVector3
          | TARGETPOS => CQtoVector3
          end;

fromImpl := λ t : Topic,
            match t as t0 return (Vector3 → topicType t0) with
            | VELOCITY => PQfromVector3
            | TARGETPOS => CQfromVector3
            end;

(**
In the Robot Operating System, each topic is identified by a string.
We have to provided such strings for each of the ROSCoq topics
*)
rosQualName := λ t : Topic,
               match t with
               | VELOCITY => "/icreate_cmd_vel"%string
               | TARGETPOS => "/targetpos"%string
               end |}.
(* Ltac used to create the bove instance:
apply Build_RosHaskImplementable with  (topicImplType := fun _:Topic => ROS_Geometry_Vector3);
  [eauto with *| | |].
- intro t. destruct t; [exact PQtoVector3| exact CQtoVector3].
- intro t. destruct t; [exact PQfromVector3| exact CQfromVector3].
  Open Scope string_scope.
- intro t. destruct t; [exact "/icreate_cmd_vel" | exact "/targetpos"].
  Close Scope string_scope.
Defined.
 *)

(**
* Composing a ROSCoq software agent with the ROSCoq shim
*)

(**
The function [runSwNode] represents the ROSCoq shim which can be used to run ROSCoq software
agents ([Process]) on actual robots using the Robot Operating System.
[runSwNode] extracts to a Haskell function which uses roshask, the Haskell bindings for the
Robot Operating System. It requires that the [Topic] type of messages used by the program
be a instance of [RosHaskImplementable]
*)

Require Import MCInstances.
Require Import RoshaskNodeMonad.
Definition icreateRoshaskSwNode : Node unit :=
  let prf := decAuto (0 < Datatypes.length (fst (locTopics SWNODE)))%nat I in
  runSwNode Topic SwProcessInstance (locTopics SWNODE) prf.

(**
* Generating the Haskell file
*)

Extraction "icreateMoveToLoc.hs" icreateRoshaskSwNode.