(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.transc.RealPowers.
Require Export CoRN.transc.TrigMon.
Require Export CoRN.ftc.StrongIVT.

(** printing ArcSin %\ensuremath{\arcsin}% *)
(** printing ArcCos %\ensuremath{\arccos}% *)
(** printing ArcTan %\ensuremath{\arctan}% *)

(**
* Inverse Trigonometric Functions

** Definitions

We will now define arcsine, arccosine and arctangent as indefinite
integrals and prove their main properties.  We begin by proving that
the appropriate indefinite integrals can be defined, then prove the
main properties of the function.

Arccosine is defined in terms of arcsine by the relation
[ArcCos(x)=Pi[/]Two-ArcSin(x)].

*** Arcsine
*)

Opaque Sine Cosine Expon Logarithm.

Lemma ArcSin_def_lemma : Continuous (olor [--][1] [1]) (( [-C-][1]{-}FId{^}2) {!} [-C-] [--] ([1] [/]TwoNZ)).
Proof.
 split.
  unfold FPower in |- *.
  apply included_FComp.
   apply included_FMult.
    Included.
   apply included_FComp.
    Included.
   intros; apply Log_domain.
   inversion_clear X.
   simpl in |- *; apply shift_less_minus; astepl (x[^]2).
   astepr (OneR[^]2).
   apply AbsIR_less_square.
   simpl in |- *; unfold ABSIR in |- *; apply Max_less; auto.
   apply inv_cancel_less; astepr x; auto.
  intros; apply Exp_domain.
 intros a b Hab H.
 apply continuous_I_power.
   Contin.
  Contin.
 split.
  Included.
 simpl in H.
 set (c := Max (AbsIR a) (AbsIR b)) in *.
 cut ([0] [<=] c); intros.
  2: unfold c in |- *; apply leEq_transitive with (AbsIR a);
    [ apply AbsIR_nonneg | apply lft_leEq_Max ].
 elim (H _ (compact_inc_lft _ _ Hab)); intros.
 elim (H _ (compact_inc_rht _ _ Hab)); intros.
 assert (H1 : c [<] [1]).
  unfold c in |- *.
  apply Max_less; simpl in |- *; unfold ABSIR in |- *; apply Max_less; auto; apply inv_cancel_less.
   astepr a; auto. astepr b; auto.
  assert (Hc : [--]c [<=] c). apply leEq_transitive with ZeroR; auto.
  astepr ( [--]ZeroR); apply inv_resp_leEq; auto.
 cut (included (Compact Hab) (Compact Hc)). intro H2.
  exists ([1][-]c[^]2).
   apply shift_less_minus.
   astepl (c[^]2); astepr (OneR[^]2).
   apply nexp_resp_less; auto.
  intros y H3 Hy.
  astepr ([1][-]y[^]2).
  apply minus_resp_leEq_both.
   apply leEq_reflexive.
  apply AbsIR_leEq_square.
  elim (H2 _ H3); intros.
  simpl in |- *; unfold ABSIR in |- *; apply Max_leEq; auto.
  astepr ( [--] [--]c); apply inv_resp_leEq; auto.
 intros x H2.
 inversion_clear H2; unfold c in |- *; split.
  astepr ( [--] [--]x); apply inv_resp_leEq.
  apply leEq_transitive with ( [--]a).
   apply inv_resp_leEq; auto.
  eapply leEq_transitive; [ apply inv_leEq_AbsIR | apply lft_leEq_Max ].
 apply leEq_transitive with b; auto.
 eapply leEq_transitive; [ apply leEq_AbsIR | apply rht_leEq_Max ].
Qed.

Lemma ArcSin_def_zero : olor [--][1] [1] [0].
Proof.
 split.
  astepr ( [--]ZeroR); apply inv_resp_less; apply pos_one.
 apply pos_one.
Qed.

Definition ArcSin := ( [-S-]ArcSin_def_lemma) _ ArcSin_def_zero.

Lemma ArcSin_domain : forall x, [--][1] [<] x -> x [<] [1] -> Dom ArcSin x.
Proof.
 intros; split; auto.
Qed.

Lemma Continuous_ArcSin : Continuous (olor [--][1] [1]) ArcSin.
Proof.
 unfold ArcSin in |- *; apply Continuous_prim.
Qed.

Lemma Derivative_ArcSin : forall H,
 Derivative (olor [--][1] [1]) H ArcSin (( [-C-][1]{-}FId{^}2) {!} [-C-] [--] ([1] [/]TwoNZ)).
Proof.
 intros; unfold ArcSin in |- *.
 apply FTC1.
Qed.

#[global]
Hint Resolve Derivative_ArcSin: derivate.
#[global]
Hint Resolve Continuous_ArcSin: continuous.

(**
*** Arccosine
*)

Definition ArcCos := [-C-] (Pi [/]TwoNZ) {-}ArcSin.

Lemma ArcCos_domain : forall x : IR, [--][1] [<] x -> x [<] [1] -> Dom ArcCos x.
Proof.
 intros; repeat split; auto.
Qed.

Lemma Continuous_ArcCos : Continuous (olor [--][1] [1]) ArcCos.
Proof.
 unfold ArcCos in |- *; Contin.
Qed.

Lemma Derivative_ArcCos : forall H,
 Derivative (olor [--][1] [1]) H ArcCos {--} (( [-C-][1]{-}FId{^}2) {!} [-C-] [--] ([1] [/]TwoNZ)).
Proof.
 intros; unfold ArcCos in |- *.
 apply Derivative_wdr with ( [-C-][0]{-} ( [-C-][1]{-}FId{^}2) {!} [-C-] [--] ([1] [/]TwoNZ)).
  2: Deriv.
 apply eq_imp_Feq.
   apply included_FMinus.
    Included.
   apply Continuous_imp_inc; apply ArcSin_def_lemma.
  apply included_FInv.
  apply Continuous_imp_inc; apply ArcSin_def_lemma.
 intros.
 astepl (Part _ _ (ProjIR1 Hx) [-]Part _ _ (ProjIR2 Hx)).
 astepl ([0][-]Part _ _ (ProjIR2 Hx)).
 astepl ( [--] (Part _ _ (ProjIR2 Hx))).
 Step_final ( [--] ((( [-C-][1]{-}FId{^}2) {!} [-C-] [--] ([1] [/]TwoNZ)) x Hx')).
Qed.

(**
*** Arctangent
*)

Lemma ArcTan_def_lemma : Continuous realline {1/} ( [-C-][1]{+}FId{^}2).
Proof.
 apply Continuous_recip.
  Contin.
 red in |- *; intros.
 split.
  Included.
 exists OneR.
  apply pos_one.
 intros; simpl in |- *.
 eapply leEq_transitive.
  2: apply leEq_AbsIR.
 apply shift_leEq_plus'.
 astepl ZeroR; astepr (y[^]2).
 apply sqr_nonneg.
Qed.

Definition ArcTang := ( [-S-]ArcTan_def_lemma) [0] I.

Lemma ArcTan_domain : forall x : IR, Dom ArcTang x.
Proof.
 intros; simpl in |- *; auto.
Qed.

Definition ArcTan (x : IR) := ArcTang x I.

Lemma Continuous_ArcTan : Continuous realline ArcTang.
Proof.
 unfold ArcTang in |- *; Contin.
Qed.

Lemma Derivative_ArcTan : forall H, Derivative realline H ArcTang {1/} ( [-C-][1]{+}FId{^}2).
Proof.
 intros; unfold ArcTang in |- *; apply FTC1.
Qed.

Lemma ArcTan_wd : forall x y, x[=]y -> ArcTan x [=] ArcTan y.
Proof.
 intros.
 refine (pfwdef _ _ _ _ _ _ _).
 assumption.
Qed.

#[global]
Hint Resolve ArcTan_wd: algebra.
#[global]
Hint Resolve Derivative_ArcCos Derivative_ArcTan: derivate.
#[global]
Hint Resolve Continuous_ArcCos Continuous_ArcTan: continuous.

Section Inverses.

(**
** Composition properties

We now prove that this functions are in fact inverses to the corresponding trigonometric functions.

*** Sine and Arcsine
*)

Lemma maps_Sin : maps_compacts_into (olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ)) (olor [--][1] [1]) Sine.
Proof.
 intros a b Hab H.
 set (min := Min (Sin a) [--] ([1] [/]TwoNZ)) in *.
 set (max := Max (Sin b) ([1] [/]TwoNZ)) in *.
 cut (min [<] max). intro H0.
  exists min; exists max; exists H0.
  elim (H _ (compact_inc_lft _ _ Hab)); intros Ha1 Ha2.
  elim (H _ (compact_inc_rht _ _ Hab)); intros Hb1 Hb2.
  split.
   intros x H1.
   unfold min, max in H1; inversion_clear H1; split.
    apply less_leEq_trans with min.
     unfold min in |- *; apply less_Min.
      apply inv_cancel_less; astepr OneR.
      eapply leEq_less_trans.
       apply inv_leEq_AbsIR.
      apply Abs_Sin_less_One; auto.
     apply inv_resp_less; apply (half_lt1 IR).
    auto.
   eapply leEq_less_trans.
    apply H3.
   apply Max_less.
    eapply leEq_less_trans.
     apply leEq_AbsIR.
    apply Abs_Sin_less_One; auto.
   apply (half_lt1 IR).
  intros x Hx H1.
  apply compact_wd with (Sin x).
   2: simpl in |- *; algebra.
  unfold min, max in |- *; inversion_clear H1.
  split.
   eapply leEq_transitive; [ apply Min_leEq_lft | apply Sin_resp_leEq; auto ].
    apply less_leEq; auto.
   apply less_leEq; apply leEq_less_trans with b; auto.
  eapply leEq_transitive.
   2: apply lft_leEq_Max.
  apply Sin_resp_leEq; auto.
   apply leEq_transitive with a; auto; apply less_leEq; auto.
  apply less_leEq; auto.
 unfold min, max in |- *; apply less_transitive_unfolded with ZeroR.
  eapply leEq_less_trans.
   apply Min_leEq_rht.
  astepr ( [--][0]:IR); apply inv_resp_less; apply (pos_half IR).
 eapply less_leEq_trans; [ apply (pos_half IR) | apply rht_leEq_Max ].
Qed.

Lemma ArcSin_Sin_inv : Feq (olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ)) (ArcSin[o]Sine) FId.
Proof.
 set (HPi1 := pos_HalfPi) in *.
 set (HPi2 := neg_invHalfPi) in *.
 set (H := invHalfPi_less_HalfPi:proper (olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ))) in *.
 apply Feq_criterium with H ( [-C-][1]:PartIR) ZeroR.
    assert (H0 : Derivative _ H Sine Cosine).
     apply Included_imp_Derivative with realline I; Deriv.
    assert (H1 : [--][1] [<] OneR).
     set (H' := pos_one IR) in *; apply less_transitive_unfolded with ZeroR; auto.
     astepr ( [--]ZeroR); apply inv_resp_less; auto.
    set (H2 := Derivative_ArcSin H1) in *.
    eapply Derivative_wdr.
     2: apply (Derivative_comp _ _ _ _ _ _ _ _ maps_Sin H0 H2).
    apply eq_imp_Feq.
      apply included_FMult.
       apply included_FComp.
        Included.
       intros.
       unfold FPower in |- *.
       cut (Dom ( [-C-] [--] ([1] [/]TwoNZ) {*} (Logarithm[o] [-C-][1]{-}FId{^}2)) (Part _ _ Hx)). intro H3.
        exists H3; apply Exp_domain.
       split.
        auto.
       exists (I, I).
       apply Log_domain.
       astepr ([1][-]Sine x Hx[^]2).
       astepl (OneR[-][1]).
       unfold cg_minus in |- *; apply plus_resp_less_lft.
       apply inv_resp_less.
       astepr (OneR[^]2); apply AbsIR_less_square.
       apply less_wdl with (AbsIR (Sin x)).
        inversion_clear X; apply Abs_Sin_less_One; auto.
       apply AbsIR_wd; simpl in |- *; algebra.
      split.
     split.
    intros x H3 Hx Hx'.
    astepr OneR.
    cut ([0] [<] [1][-]Sin x[^]2). intro H4.
     apply eq_transitive_unfolded with (([1][-]Sin x[^]2) [!] [--] ([1] [/]TwoNZ) [//]H4[*]Cos x).
      unfold power, FPower in |- *.
      unfold FPower in Hx.
      astepl (Part _ _ (ProjIR1 Hx) [*]Part _ _ (ProjIR2 Hx)).
      apply mult_wd.
       2: simpl in |- *; algebra.
      elim Hx; clear Hx; intros Hx Hx1.
      astepl (Part _ _ Hx); clear Hx1.
      astepl (Part _ _ (ProjT2 Hx)).
      elim Hx; clear Hx; intros Hx1 Hx2.
      astepl (Part _ _ Hx2).
      astepl (Part _ _ (ProjT2 Hx2)).
      simpl in |- *; apply pfwdef.
      elim Hx2; intros Hx3 Hx4.
      astepl (Part _ _ Hx3).
      clear Hx4 Hx2.
      astepl ( [--] ([1] [/]TwoNZ) [*]Part _ _ (ProjIR2 Hx3)).
      elim Hx3; clear Hx3; intros Hx2 Hx3.
      astepl ( [--] ([1] [/]TwoNZ) [*]Part _ _ Hx3).
      apply mult_wdr.
      astepl (Part _ _ (ProjT2 Hx3)).
      unfold Log in |- *; apply pfwdef.
      elim Hx3; intros Hx4 Hx5.
      astepl (Part _ _ Hx4).
      astepl (Part _ _ (ProjIR1 Hx4) [-]Part _ _ (ProjIR2 Hx4)).
      elim Hx4; clear Hx5 Hx4 Hx3 Hx2; intros Hx2 Hx3.
      astepl (Part _ _ Hx2[-]Part _ _ Hx3).
      apply cg_minus_wd.
       algebra.
      simpl in |- *; algebra.
     unfold RealPowers.power in |- *.
     astepl (Exp [--] ([1] [/]TwoNZ[*]Log _ H4) [*]Cos x).
     astepl (([1][/] _[//]Exp_ap_zero ([1] [/]TwoNZ[*]Log _ H4)) [*]Cos x).
     astepr (Exp ([1] [/]TwoNZ[*]Log _ H4) [/] _[//]Exp_ap_zero ([1] [/]TwoNZ[*]Log _ H4)).
     rstepl (Cos x[/] _[//]Exp_ap_zero ([1] [/]TwoNZ[*]Log _ H4)).
     apply div_wd.
      2: algebra.
     astepr (Exp (Log _ H4[*][1] [/]TwoNZ)).
     assert (H5 : [0] [<] Cos x). inversion_clear H3; apply Cos_pos; auto.
      astepl (Exp (Log _ H5)).
     apply Exp_wd.
     rstepl ((Log _ H5[+]Log _ H5) [/]TwoNZ).
     rstepr (Log _ H4 [/]TwoNZ).
     apply div_wd.
      2: algebra.
     astepl (Log _ (mult_resp_pos _ _ _ H5 H5)).
     astepl (Log _ (pos_square _ _ (pos_ap_zero _ _ H5))).
     apply Log_wd.
     astepr (Cos x[^]2[+]Sin x[^]2[-]Sin x[^]2); rational.
    astepl (OneR[-][1]).
    unfold cg_minus in |- *.  apply plus_resp_less_lft.
    apply inv_resp_less.
    astepr (OneR[^]2); apply AbsIR_less_square.
    inversion_clear H3; apply Abs_Sin_less_One; auto.
   Deriv.
  split; auto.
 intros; simpl in |- *; apply Integral_empty.
 astepl (Sin [0]); simpl in |- *; algebra.
Qed.

Opaque ArcSin.

Lemma ArcSin_Sin : forall x, [--] (Pi [/]TwoNZ) [<] x -> x [<] Pi [/]TwoNZ -> forall H, ArcSin (Sin x) H [=] x.
Proof.
 intros.
 unfold Sin in |- *.
 astepr (FId x I).
 cut (Dom (ArcSin[o]Sine) x). intro H2.
  apply eq_transitive_unfolded with ((ArcSin[o]Sine) x H2).
   simpl in |- *; algebra.
  apply Feq_imp_eq with (olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ)).
   apply ArcSin_Sin_inv.
  split; auto.
 exists I; auto.
Qed.

Lemma ArcSin_range : forall x Hx, [--] (Pi [/]TwoNZ) [<] ArcSin x Hx and ArcSin x Hx [<] Pi [/]TwoNZ.
Proof.
 intros.
 Transparent ArcSin.
 cut {y : IR | olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ) y | forall Hy, Sine y Hy [=] x}.
  intros H; elim H; clear H; intros y H H0.
  elim H; clear H; intros H1 H2.
  assert (H : Sin y [=] x). simpl in |- *; algebra.
   assert (H3 : Dom ArcSin (Sin y)). apply dom_wd with x; algebra.
   split.
   astepr (ArcSin _ H3).
   apply less_wdr with y; auto.
   apply eq_symmetric_unfolded; apply ArcSin_Sin; auto.
  astepl (ArcSin _ H3).
  apply less_wdl with y; auto.
  apply eq_symmetric_unfolded; apply ArcSin_Sin; auto.
 elim Hx; intros H H0.
 set (H1 := less_leEq _ _ _ invHalfPi_less_HalfPi) in *.
 cut (Continuous_I H1 Sine). intro H2.
  apply IVT'_I with H1 H2; auto.
     PiSolve.
    intros x0 y H3 H4 H5 Hx0 Hy.
    2: astepl (Sine [--] (Pi [/]TwoNZ) I); astepl (Sin [--] (Pi [/]TwoNZ));
      astepl ( [--] (Sin (Pi [/]TwoNZ))); astepl ( [--]OneR); auto.
   2: astepr (Sine (Pi [/]TwoNZ) I); astepr (Sin (Pi [/]TwoNZ)); astepr OneR; auto.
  2: apply included_imp_Continuous with realline; Contin.
 apply less_wdl with (Sin x0).
  2: simpl in |- *; algebra.
 apply less_wdr with (Sin y).
  2: simpl in |- *; algebra.
 inversion_clear H3; inversion_clear H4; apply Sin_resp_less; auto.
Qed.

Lemma Sin_ArcSin : forall (x : IR) Hx, x [=] Sin (ArcSin x Hx).
Proof.
 intros.
 set (y := Sin (ArcSin x Hx)) in *.
 cut (Dom ArcSin y). intro H.
  cut (ArcSin x Hx [=] ArcSin y H). intro H0.
   2: unfold y in |- *; inversion_clear H.
   2: apply eq_symmetric_unfolded.
   Transparent ArcSin.
   simpl in H0.
   unfold y in H0.
   cut (Continuous_I (Min_leEq_Max x y)
     (( [-C-][1]{-}FId{^}2) {!} [-C-] [--] ([1] [/]TwoNZ))). intro H1.
    cut (Integral H1 [=] [0]). intro H2.
     clear H0.
     elim H; intros H0 H3.
     elim Hx; clear H; intros H H4.
     apply Integral_eq_zero with (contF := H1) (x := x).
        exact (pair (Min_leEq_lft x y) (lft_leEq_Max x y)).
       unfold FPower in |- *; intros.
       astepr (Part _ _ (ProjT2 Hx0)).
       apply less_wdr with (Exp (Part _ _ (ProjT1 Hx0))).
        apply Exp_pos.
       simpl in |- *; algebra.
      unfold FPower in |- *; intros.
      apply less_leEq; astepr (Part _ _ (ProjT2 Hx0)).
      apply less_wdr with (Exp (Part _ _ (ProjT1 Hx0))).
       apply Exp_pos.
      simpl in |- *; algebra.
     auto.
    apply eq_transitive_unfolded with (ArcSin y H[-]ArcSin x Hx).
     rstepl (ArcSin x Hx[+]Integral H1[-]ArcSin x Hx).
     apply cg_minus_wd; [ simpl in |- * | algebra ].
     apply eq_symmetric_unfolded; apply Integral_plus_Integral with (Min3_leEq_Max3 [0] y x).
     apply included_imp_Continuous with (olor [--][1] [1]).
      exact ArcSin_def_lemma.
     apply included3_interval; auto.
     split.
      astepr ( [--]ZeroR); apply inv_resp_less; apply pos_one.
     apply pos_one.
    apply x_minus_x; simpl in |- *; algebra.
   apply included_imp_Continuous with (olor [--][1] [1]).
    exact ArcSin_def_lemma.
   apply included_interval; auto.
  elim (ArcSin_range x Hx); intros; apply ArcSin_Sin; auto.
 elim (ArcSin_range x Hx); intros; apply ArcSin_domain.
  unfold y in |- *.
  astepr ( [--] [--] (Sin (ArcSin x Hx))); astepr ( [--] (Sin [--] (ArcSin x Hx)));
    apply inv_resp_less.
  apply Sin_less_One.
  apply Cos_pos.
   apply inv_resp_less; auto.
  astepr ( [--] [--] (Pi [/]TwoNZ)); apply inv_resp_less; auto.
 unfold y in |- *; apply Sin_less_One.
 apply Cos_pos; auto.
Qed.

Lemma Sin_ArcSin_inv : Feq (olor [--][1] [1]) (Sine[o]ArcSin) FId.
Proof.
 apply eq_imp_Feq.
   apply included_FComp.
    Included.
   intros; apply sin_domain.
  Included.
 intros x H Hx Hx'.
 elim Hx; intros x0 H0.
 astepr x; astepl (Part _ _ (ProjT2 Hx)); astepl (Part _ _ H0).
  apply eq_transitive_unfolded with (Sin (ArcSin x x0)).
   simpl in |- *; algebra.
  apply eq_symmetric_unfolded; apply Sin_ArcSin.
 algebra.
Qed.

Lemma ArcSin_resp_leEq : forall x y,
 [--][1] [<] x -> x [<=] y -> y [<] [1] -> forall Hx Hy, ArcSin x Hx [<=] ArcSin y Hy.
Proof.
 intros x y H H0 H1 Hx Hy.
 assert (H2 : [--][1] [<] OneR).
  apply less_transitive_unfolded with ZeroR; [ astepr ( [--]ZeroR); apply inv_resp_less | idtac ];
    apply pos_one.
 apply Derivative_imp_resp_leEq
   with (olor [--][1] [1]) H2 (( [-C-][1]{-}FId{^}2) {!} [-C-] [--] ([1] [/]TwoNZ)); Deriv.
 intros; apply leEq_glb; intro z; intros.
 elim Hy0; intros.
 apply leEq_wdr with (Exp (( [-C-] [--] ([1] [/]TwoNZ) {*} (Logarithm[o] [-C-][1]{-}FId{^}2)) z x0)).
  apply less_leEq; apply Exp_pos.
 simpl in |- *; algebra.
Qed.

(**
*** Cosine and Arcosine
*)

Lemma ArcCos_Cos : forall x, [0] [<] x -> x [<] Pi -> forall H, ArcCos (Cos x) H [=] x.
Proof.
 intros x H H0 H1.
 assert (H2 : Dom ArcCos (Sin (Pi [/]TwoNZ[-]x))).
  apply dom_wd with (Cos x); algebra.
 astepl (Part _ _ H2).
 unfold ArcCos in |- *.
 astepl (Pi [/]TwoNZ[-]Part _ _ (ProjIR2 H2)).
 rstepr (Pi [/]TwoNZ[-] (Pi [/]TwoNZ[-]x)).
 apply cg_minus_wd.
  algebra.
 apply ArcSin_Sin.
  apply shift_less_minus; apply shift_plus_less'.
  rstepr Pi; auto.
 apply shift_minus_less; apply shift_less_plus'.
 astepl ZeroR; auto.
Qed.

Lemma Cos_ArcCos : forall (x : IR) Hx, x [=] Cos (ArcCos x Hx).
Proof.
 intros.
 unfold ArcCos in |- *.
 astepr (Cos (Pi [/]TwoNZ[-]ArcSin x (ProjIR2 Hx))).
 astepr (Sin (ArcSin x (ProjIR2 Hx))).
 apply Sin_ArcSin.
Qed.

Lemma ArcCos_Cos_inv : Feq (olor [0] Pi) (ArcCos[o]Cosine) FId.
Proof.
 apply eq_imp_Feq.
   apply included_FComp.
    Included.
   intros.
   apply ArcCos_domain.
    apply less_wdr with (Cos x).
     2: simpl in |- *; algebra.
    apply inv_cancel_less.
    astepr OneR.
    eapply leEq_less_trans.
     apply inv_leEq_AbsIR.
    inversion_clear X; apply Abs_Cos_less_One; auto.
   apply less_wdl with (Cos x).
    2: simpl in |- *; algebra.
   eapply leEq_less_trans.
    apply leEq_AbsIR.
   inversion_clear X; apply Abs_Cos_less_One; auto.
  Included.
 intros.
 astepl (Part _ _ (ProjT2 Hx)); astepr x.
 cut (Dom ArcCos (Cos x)). intro H0.
  apply eq_transitive_unfolded with (ArcCos (Cos x) H0).
   apply pfwdef; simpl in |- *; algebra.
  inversion_clear X; apply ArcCos_Cos; auto.
 inversion_clear Hx.
 apply dom_wd with (Cosine x x0); auto.
 simpl in |- *; algebra.
Qed.

Lemma Cos_ArcCos_inv : Feq (olor [--][1] [1]) (Cosine[o]ArcCos) FId.
Proof.
 apply eq_imp_Feq.
   apply included_FComp.
    unfold ArcCos in |- *; Included.
   intros; apply cos_domain.
  Included.
 intros.
 inversion_clear Hx.
 astepr x; astepl (Part _ _ (ProjT2 Hx)); astepl (Part _ _ X0).
 apply eq_transitive_unfolded with (Cos (ArcCos x x0)).
  simpl in |- *; algebra.
 apply eq_symmetric_unfolded; apply Cos_ArcCos.
Qed.

Lemma ArcCos_resp_leEq : forall x y,
 [--][1] [<] x -> x [<=] y -> y [<] [1] -> forall Hx Hy, ArcCos y Hy [<=] ArcCos x Hx.
Proof.
 intros.
 Opaque ArcSin.
 simpl in |- *; unfold cg_minus in |- *; apply plus_resp_leEq_lft.
 apply inv_resp_leEq; apply ArcSin_resp_leEq; auto.
Qed.

(**
*** Tangent and Arctangent
*)

Lemma maps_Tan : maps_compacts_into (olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ)) realline Tang.
Proof.
 intros a b Hab H.
 elim (H _ (compact_inc_lft _ _ Hab)); intros Ha1 Ha2.
 elim (H _ (compact_inc_rht _ _ Hab)); intros Hb1 Hb2.
 cut (Dom Tang b). cut (Dom Tang a). intros H0 H1.
  set (min := Min (Tan a H0) [0]) in *.
   set (max := Max (Tan b H1) [1]) in *.
   cut (min [<] max). intro H2.
    exists min; exists max; exists H2.
    split.
     Included.
    intros x Hx H3.
    fold (Tan x Hx) in |- *.
    unfold min, max in |- *; inversion_clear H3.
    split.
     eapply leEq_transitive; [ apply Min_leEq_lft | apply Tan_resp_leEq; auto ].
     apply leEq_less_trans with b; auto.
    eapply leEq_transitive.
     2: apply lft_leEq_Max.
    apply Tan_resp_leEq; auto.
    apply less_leEq_trans with a; auto.
   unfold min, max in |- *.
   eapply leEq_less_trans.
    apply Min_leEq_rht.
   eapply less_leEq_trans; [ apply pos_one | apply rht_leEq_Max ].
  split.
   apply sin_domain.
  split.
   apply cos_domain.
  intros; apply ap_wdl with (Cos a).
   apply Greater_imp_ap; apply Cos_pos; auto.
  simpl in |- *; algebra.
 split.
  apply sin_domain.
 split.
  apply cos_domain.
 intros; apply ap_wdl with (Cos b).
  apply Greater_imp_ap; apply Cos_pos; auto.
 simpl in |- *; algebra.
Qed.

Lemma ArcTan_Tan_inv : Feq (olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ)) (ArcTang[o]Tang) FId.
Proof.
 set (HPi1 := pos_HalfPi) in *.
 set (HPi2 := neg_invHalfPi) in *.
 set (H := invHalfPi_less_HalfPi) in *.
 apply Feq_criterium with H ( [-C-][1]:PartIR) ZeroR.
    set (H0 := Derivative_Tan_2 H) in *.
    set (H2 := Derivative_ArcTan I) in *.
    Derivative_Help.
     apply eq_imp_Feq.
       apply included_FMult.
        apply included_FComp.
         Included.
        intros.
        split.
         repeat split.
        intros.
        astepl ([1][+]Tang x Hx[^]2).
        apply pos_ap_zero.
        astepl (ZeroR[+][0]); apply plus_resp_less_leEq.
         apply pos_one.
        apply sqr_nonneg.
       Included.
      Included.
     intros.
     astepr OneR.
     astepl (Part _ _ (ProjIR1 Hx) [*]Part _ _ (ProjIR2 Hx)).
     elim Hx; intros H3 H4.
     astepl (Part _ _ H3[*]Part _ _ H4).
     astepl (Part _ _ (ProjT2 H3) [*] (Part _ _ (ProjIR1 H4) [+]Part _ _ (ProjIR2 H4))).
     elim H3; intros x0 H5; elim H4; intros H6 H7.
     astepl (Part _ _ H5[*] (Part _ _ H6[+]Part _ _ H7)).
     astepl (Part _ _ H5[*] ([1][+]Tang x H7[^]2)).
     simpl in |- *; rational.
    apply Derivative_comp with realline I.
      apply maps_Tan.
     Deriv.
    Deriv.
   Deriv.
  split; auto.
 intros.
 astepr ZeroR.
 inversion_clear Hx.
 Opaque Tang.
 simpl in |- *.
 apply Integral_empty.
 algebra.
Qed.

Transparent Tang.
Opaque ArcTang.

Lemma ArcTan_Tan : forall x, [--] (Pi [/]TwoNZ) [<] x -> x [<] Pi [/]TwoNZ -> forall H, ArcTan (Tan x H) [=] x.
Proof.
 intros.
 unfold Tan, ArcTan in |- *.
 astepr (FId x I).
 cut (Dom (ArcTang[o]Tang) x). intro H2.
  apply eq_transitive_unfolded with ((ArcTang[o]Tang) x H2).
   simpl in |- *; algebra.
  apply Feq_imp_eq with (olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ)).
   apply ArcTan_Tan_inv.
  split; auto.
 exists H; apply I.
Qed.

Lemma Tan_ilim : forall x, {y : IR | olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ) y | forall Hy, x [<=] Tan y Hy}.
Proof.
 intros.
 set (aux_val := sqrt _ (less_leEq _ _ _ (pos_two IR)) [/]TwoNZ) in *.
 assert (H : [0] [<] aux_val).
  unfold aux_val in |- *.
  apply shift_less_div; [ apply pos_two | apply power_cancel_less with 2 ].
   apply sqrt_nonneg.
  astepl (ZeroR[^]2); astepl ZeroR; astepr (Two:IR); apply pos_two.
 assert (H0 : sqrt _ (less_leEq _ _ _ (pos_two _)) [#] [0]).
  apply mult_cancel_ap_zero_lft with (OneR [/]TwoNZ).
  eapply ap_wdl_unfolded; [ apply pos_ap_zero; apply H | unfold aux_val in |- *; rational ].
 assert (H1 : aux_val [=] ([1][/] _[//]H0)).
  unfold aux_val in |- *.
  apply eq_div; astepr (Two:IR); Step_final (sqrt _ (less_leEq _ _ _ (pos_two _)) [^]2).
 assert (H2 : aux_val [<] [1]).
  apply power_cancel_less with 2.
   apply less_leEq; apply pos_one.
  unfold aux_val in |- *; rstepl ((sqrt _ (less_leEq _ _ _ (pos_two IR)) [^]2) [/]FourNZ); astepr OneR.
  apply shift_div_less; [ apply pos_four | astepl (Two:IR); astepr (Four:IR) ]; apply two_less_four.
 elim (less_cotransitive_unfolded _ _ _ H2 x); intros.
  2: exists (Pi [/]FourNZ); repeat split; PiSolve.
  2: intro; astepr OneR; apply less_leEq; auto.
 assert (H3 : Two[*]x [#] [0]).
  apply mult_resp_ap_zero.
   apply two_ap_zero.
  apply pos_ap_zero; apply less_transitive_unfolded with aux_val; auto.
 assert (H4 : Dom ArcCos ([1][/] _[//]H3)).
  repeat split.
   apply less_transitive_unfolded with ZeroR; [ astepr ( [--]ZeroR); apply inv_resp_less; apply pos_one
     | apply recip_resp_pos ].
   apply mult_resp_pos; [ apply pos_two | apply less_transitive_unfolded with aux_val; auto ].
  apply shift_div_less.
   apply mult_resp_pos; [ apply pos_two | apply less_transitive_unfolded with aux_val; auto ].
  astepr (Two[*]x); apply less_transitive_unfolded with (Two[*]aux_val).
   2: apply mult_resp_less_lft; auto; apply pos_two.
  unfold aux_val in |- *; rstepr (sqrt _ (less_leEq _ _ _ (pos_two _))).
  apply power_cancel_less with 2.
   apply sqrt_nonneg.
  astepl OneR; astepr (Two:IR); apply one_less_two.
 assert (H5 : Pi [/]FourNZ [<=] ArcCos _ H4).
  assert (H5 : Dom ArcCos aux_val).
   repeat split; auto; unfold aux_val in |- *.
   apply less_transitive_unfolded with ZeroR; auto; astepr ( [--]ZeroR);
     apply inv_resp_less; apply pos_one.
  apply leEq_wdl with (ArcCos _ H5).
   2: assert (H6 : Dom ArcCos (Cos (Pi [/]FourNZ))).
    2: apply dom_wd with aux_val; auto.
    2: Step_final ([1][/] _[//]H0).
   2: apply eq_transitive_unfolded with (ArcCos _ H6).
    3: apply ArcCos_Cos; PiSolve.
   2: apply pfwdef; unfold aux_val in |- *.
   2: Step_final ([1][/] _[//]H0).
  apply ArcCos_resp_leEq.
    apply less_transitive_unfolded with ZeroR.
     astepr ( [--]ZeroR); apply inv_resp_less; apply pos_one.
    apply recip_resp_pos; apply mult_resp_pos; try apply pos_two;
      apply less_transitive_unfolded with aux_val; auto.
   apply shift_div_leEq.
    apply mult_resp_pos; [ apply pos_two | apply less_transitive_unfolded with aux_val; auto ].
   apply leEq_wdl with (aux_val[*] (Two[*]aux_val)).
    repeat apply mult_resp_leEq_lft; apply less_leEq; auto; apply pos_two.
   unfold aux_val in |- *.
   rstepl ((sqrt _ (less_leEq _ _ _ (pos_two _)) [^]2) [/]TwoNZ).
   Step_final ((Two:IR) [/]TwoNZ).
  auto.
 exists (ArcCos _ H4).
  Opaque iprop.
  unfold ArcCos in |- *; simpl in |- *.
  Transparent iprop.
  elim H4; intros H6' H7; elim H7; intros.
  apply iprop_wd with (Pi [/]TwoNZ[-]ArcSin _ H7).
   2: algebra.
  elim (ArcSin_range _ H7); intros; split.
   apply shift_less_minus; apply shift_plus_less'.
   rstepr Pi; apply less_transitive_unfolded with (Pi [/]TwoNZ); PiSolve.
  apply shift_minus_less; apply shift_less_plus'.
  astepl ZeroR.
  assert (H6 : Dom ArcSin (Sin [0])).
   apply dom_wd with ZeroR; [ split | algebra ]; [ astepr ( [--]ZeroR); apply inv_resp_less | idtac ];
     apply pos_one.
  apply less_wdl with (ArcSin _ H6).
   2: apply ArcSin_Sin; PiSolve.
  apply leEq_not_eq.
   apply ArcSin_resp_leEq; auto.
    astepr ZeroR; astepr ( [--]ZeroR); apply inv_resp_less; apply pos_one.
   astepl ZeroR; apply less_leEq; apply recip_resp_pos.
   apply mult_resp_pos; [ apply pos_two | apply less_transitive_unfolded with aux_val; auto ].
  apply pfstrx with Sine I I.
  apply ap_wdl_unfolded with ZeroR.
   apply ap_wdr_unfolded with ([1][/] _[//]H3).
    apply ap_symmetric_unfolded; apply pos_ap_zero; apply recip_resp_pos.
    apply mult_resp_pos; [ apply pos_two | apply less_transitive_unfolded with aux_val; auto ].
   apply eq_transitive_unfolded with (Sin (ArcSin _ H7)); [ apply Sin_ArcSin | simpl in |- *; algebra ].
  apply eq_transitive_unfolded with (Sin (ArcSin _ H6));
    [ astepl (Sin [0]); apply Sin_ArcSin | simpl in |- *; algebra ].
 intros; unfold Tan, Tang in |- *.
 assert (H6 : Cos (ArcCos _ H4) [#] [0]).
  eapply ap_wdl_unfolded.
   2: apply Cos_ArcCos.
  apply recip_ap_zero; auto.
 apply leEq_wdr with (Sin (ArcCos _ H4) [/] _[//]H6).
  2: simpl in |- *; algebra.
 apply shift_leEq_div.
  Opaque Cos.
  unfold ArcCos in |- *; simpl in |- *.
  astepr (Sin (ArcSin _ (ProjIR2 H4))).
  eapply less_wdr.
   2: apply Sin_ArcSin.
  apply recip_resp_pos; apply mult_resp_pos;
    [ apply pos_two | apply less_transitive_unfolded with aux_val; auto ].
 apply leEq_wdl with (x[*] ([1][/] _[//]H3)).
  2: apply mult_wdr; apply Cos_ArcCos.
 rstepl (OneR [/]TwoNZ).
 apply leEq_transitive with ([1][/] _[//]H0).
  apply recip_resp_leEq.
   astepl (ZeroR[*]Two); apply shift_mult_less with (two_ap_zero IR); auto; apply pos_two.
  apply power_cancel_leEq with 2; auto.
   apply less_leEq; apply pos_two.
  astepl (Two:IR); rstepr (Four:IR); apply less_leEq; apply two_less_four.
 astepl (Sin (Pi [/]FourNZ)); apply Sin_resp_leEq.
   PiSolve.
  astepl (Pi [/]TwoNZ[-]ArcSin _ (ProjIR2 H4)).
  apply shift_minus_leEq; apply shift_leEq_plus'; astepl ZeroR.
  assert (H7 : Dom ArcSin (Sin [0])).
   apply dom_wd with ZeroR; [ split | algebra ]; [ astepr ( [--]ZeroR); apply inv_resp_less | idtac ];
     apply pos_one.
  apply leEq_wdl with (ArcSin _ H7).
   2: apply ArcSin_Sin; PiSolve.
  apply ArcSin_resp_leEq.
    astepr ZeroR; astepr ( [--]ZeroR); apply inv_resp_less; apply pos_one.
   astepl ZeroR; apply less_leEq; apply recip_resp_pos.
   apply mult_resp_pos; [ apply pos_two | apply less_transitive_unfolded with aux_val; auto ].
  apply shift_div_less.
   apply mult_resp_pos; [ apply pos_two | apply less_transitive_unfolded with aux_val; auto ].
  astepr (Two[*]x); apply less_transitive_unfolded with (Two[*]aux_val).
   2: apply mult_resp_less_lft; auto; apply pos_two.
  unfold aux_val in |- *; rstepr (sqrt _ (less_leEq _ _ _ (pos_two _))).
  apply power_cancel_less with 2.
   apply sqrt_nonneg.
  astepl OneR; astepr (Two:IR); apply one_less_two.
 auto.
Qed.

Opaque Min.
Transparent Cos.

Section ArcTan_Range.

Variable x : IR.

(* begin hide *)
Let min := proj1_sig2T _ _ _ (Tan_ilim x).
Let max := proj1_sig2T _ _ _ (Tan_ilim [--]x).

Let min1 : [--] (Pi [/]TwoNZ) [<] min.
Proof.
 elim (proj2a_sig2T _ _ _ (Tan_ilim x)); auto.
Qed.

Let min2 : min [<] Pi [/]TwoNZ.
Proof.
 elim (proj2a_sig2T _ _ _ (Tan_ilim x)); auto.
Qed.

Let min3 : Dom Tang min.
Proof.
 split.
  apply sin_domain.
 split.
  apply cos_domain.
 intro; apply ap_wdl_unfolded with (Cos min).
  2: simpl in |- *; algebra.
 apply pos_ap_zero; apply Cos_pos.
  apply min1.
 apply min2.
Qed.

Let min4 : x [<=] Tan min min3 := proj2b_sig2T _ _ _ (Tan_ilim x) min3.

Let max1 : [--] (Pi [/]TwoNZ) [<] max.
Proof.
 elim (proj2a_sig2T _ _ _ (Tan_ilim [--]x)); auto.
Qed.

Let max2 : max [<] Pi [/]TwoNZ.
Proof.
 elim (proj2a_sig2T _ _ _ (Tan_ilim [--]x)); auto.
Qed.

Let max3 : Dom Tang max.
Proof.
 split.
  apply sin_domain.
 split.
  apply cos_domain.
 intro; apply ap_wdl_unfolded with (Cos max).
  2: simpl in |- *; algebra.
 apply pos_ap_zero; apply Cos_pos.
  apply max1.
 apply max2.
Qed.

Let max4 : [--]x [<=] Tan max max3 := proj2b_sig2T _ _ _ (Tan_ilim [--]x) max3.

Let min5 : Dom Tang [--]min.
Proof.
 split.
  apply sin_domain.
 split.
  apply cos_domain.
 intro; apply ap_wdl_unfolded with (Cos [--]min).
  2: simpl in |- *; algebra.
 astepl (Cos min).
 apply pos_ap_zero; apply Cos_pos.
  apply min1.
 apply min2.
Qed.

Let min6 : Tan [--]min min5 [<=] [--]x.
Proof.
 astepl ( [--] (Tan _ min3)); apply inv_resp_leEq.
 apply min4.
Qed.

Let max5 : Dom Tang [--]max.
Proof.
 split.
  apply sin_domain.
 split.
  apply cos_domain.
 intro; apply ap_wdl_unfolded with (Cos [--]max).
  2: simpl in |- *; algebra.
 astepl (Cos max).
 apply pos_ap_zero; apply Cos_pos.
  apply max1.
 apply max2.
Qed.

Let max6 : Tan [--]max max5 [<=] x.
Proof.
 astepl ( [--] (Tan _ max3)); astepr ( [--] [--]x); apply inv_resp_leEq.
 apply max4.
Qed.

Let a :=
  ( [--] (Pi [/]TwoNZ) [+]
   Min [--] (Pi [/]FourNZ) (Min (Min min [--]min) (Min max [--]max))) [/]TwoNZ.

Let a1 : [--] (Pi [/]TwoNZ) [<] a.
Proof.
 unfold a in |- *; clear a.
 apply shift_less_div.
  apply pos_two.
 apply shift_less_plus'; rstepl ( [--] (Pi [/]TwoNZ)).
 repeat apply less_Min.
     PiSolve.
    apply min1.
   apply inv_resp_less; apply min2.
  apply max1.
 apply inv_resp_less; apply max2.
Qed.

Let a2 : a [<] min.
Proof.
 unfold a in |- *.
 apply shift_div_less.
  apply pos_two.
 apply shift_plus_less'.
 eapply leEq_less_trans.
  apply Min_leEq_rht.
 eapply leEq_less_trans.
  apply Min_leEq_lft.
 eapply leEq_less_trans.
  apply Min_leEq_lft.
 apply shift_less_minus; apply shift_plus_less'.
 rstepr min; apply min1.
Qed.

Let a3 : a [<] [--]min.
Proof.
 unfold a in |- *.
 apply shift_div_less.
  apply pos_two.
 apply shift_plus_less'.
 eapply leEq_less_trans.
  apply Min_leEq_rht.
 eapply leEq_less_trans.
  apply Min_leEq_lft.
 eapply leEq_less_trans.
  apply Min_leEq_rht.
 apply shift_less_minus; apply shift_plus_less'.
 rstepr ( [--]min); apply inv_resp_less; apply min2.
Qed.

Let a4 : a [<] max.
Proof.
 unfold a in |- *.
 apply shift_div_less.
  apply pos_two.
 apply shift_plus_less'.
 eapply leEq_less_trans.
  apply Min_leEq_rht.
 eapply leEq_less_trans.
  apply Min_leEq_rht.
 eapply leEq_less_trans.
  apply Min_leEq_lft.
 apply shift_less_minus; apply shift_plus_less'.
 rstepr max; apply max1.
Qed.

Let a5 : a [<] [--]max.
Proof.
 unfold a in |- *.
 apply shift_div_less.
  apply pos_two.
 apply shift_plus_less'.
 eapply leEq_less_trans.
  apply Min_leEq_rht.
 eapply leEq_less_trans.
  apply Min_leEq_rht.
 eapply leEq_less_trans.
  apply Min_leEq_rht.
 apply shift_less_minus; apply shift_plus_less'.
 rstepr ( [--]max); apply inv_resp_less; apply max2.
Qed.

Let b :=
  (Pi [/]TwoNZ[+]Max (Pi [/]FourNZ) (Max (Max min [--]min) (Max max [--]max)))
  [/]TwoNZ.

Let b1 : b [<] Pi [/]TwoNZ.
Proof.
 unfold b in |- *.
 apply shift_div_less.
  apply pos_two.
 apply shift_plus_less'; rstepr (Pi [/]TwoNZ).
 repeat apply Max_less.
     PiSolve.
    apply min2.
   astepr ( [--] [--] (Pi [/]TwoNZ)); apply inv_resp_less; apply min1.
  apply max2.
 astepr ( [--] [--] (Pi [/]TwoNZ)); apply inv_resp_less; apply max1.
Qed.

Let b2 : min [<] b.
Proof.
 unfold b in |- *.
 apply shift_less_div.
  apply pos_two.
 apply shift_less_plus'.
 eapply less_leEq_trans.
  2: apply rht_leEq_Max.
 eapply less_leEq_trans.
  2: apply lft_leEq_Max.
 eapply less_leEq_trans.
  2: apply lft_leEq_Max.
 apply shift_minus_less; apply shift_less_plus'.
 rstepl min; apply min2.
Qed.

Let b3 : [--]min [<] b.
Proof.
 unfold b in |- *.
 apply shift_less_div.
  apply pos_two.
 apply shift_less_plus'.
 eapply less_leEq_trans.
  2: apply rht_leEq_Max.
 eapply less_leEq_trans.
  2: apply lft_leEq_Max.
 eapply less_leEq_trans.
  2: apply rht_leEq_Max.
 apply shift_minus_less; apply shift_less_plus'.
 rstepl ( [--]min); astepr ( [--] [--] (Pi [/]TwoNZ)); apply inv_resp_less; apply min1.
Qed.

Let b4 : max [<] b.
Proof.
 unfold b in |- *.
 apply shift_less_div.
  apply pos_two.
 apply shift_less_plus'.
 eapply less_leEq_trans.
  2: apply rht_leEq_Max.
 eapply less_leEq_trans.
  2: apply rht_leEq_Max.
 eapply less_leEq_trans.
  2: apply lft_leEq_Max.
 apply shift_minus_less; apply shift_less_plus'.
 rstepl max; apply max2.
Qed.

Let b5 : [--]max [<] b.
Proof.
 unfold b in |- *.
 apply shift_less_div.
  apply pos_two.
 apply shift_less_plus'.
 eapply less_leEq_trans.
  2: apply rht_leEq_Max.
 eapply less_leEq_trans.
  2: apply rht_leEq_Max.
 eapply less_leEq_trans.
  2: apply rht_leEq_Max.
 apply shift_minus_less; apply shift_less_plus'.
 rstepl ( [--]max); astepr ( [--] [--] (Pi [/]TwoNZ)); apply inv_resp_less; apply max1.
Qed.

Let ab : a [<] b.
Proof.
 apply less_transitive_unfolded with min; [ apply a2 | apply b2 ].
Qed.

Lemma ArcTan_range_lemma :
  {y : IR | olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ) y |
  forall Hy, Tang y Hy [=] x}.
Proof.
 assert (H : Continuous (olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ)) Tang).
  eapply Derivative_imp_Continuous; apply (Derivative_Tan_1 invHalfPi_less_HalfPi).
 assert (H0 : Continuous_I (less_leEq _ _ _ ab) Tang).
  eapply included_imp_Continuous; [ apply H | apply compact_included ].
   split; [ apply a1 | apply less_transitive_unfolded with b; [ apply ab | apply b1 ] ].
  split; [ apply less_transitive_unfolded with a; [ apply a1 | apply ab ] | apply b1 ].
 elim IVT'_I with (contF := H0) (z := x).
     intros y H1 H2; exists y; auto.
     inversion_clear H1; split.
      apply less_transitive_unfolded with a; auto; apply a1.
     apply less_transitive_unfolded with b; auto; apply b1.
    apply ab.
   intros x0 y H1 H2 H3 Hx Hy.
   fold (Tan x0 Hx) in |- *; fold (Tan y Hy) in |- *.
   inversion_clear H1; inversion_clear H2; apply Tan_resp_less; auto.
    apply less_leEq_trans with a; auto; apply a1.
   apply leEq_less_trans with b; auto; apply b1.
  fold (Tan a (contin_imp_inc _ _ _ _ H0 _ (compact_inc_lft _ _ _))) in |- *.
  apply less_leEq_trans with (Tan [--]max max5).
   apply Tan_resp_less.
     apply a1.
    apply less_transitive_unfolded with b; [ apply b5 | apply b1 ].
   apply a5.
  apply max6.
 fold (Tan b (contin_imp_inc _ _ _ _ H0 _ (compact_inc_rht _ _ _))) in |- *.
 apply leEq_less_trans with (Tan min min3).
  apply min4.
 apply Tan_resp_less.
   apply min1.
  apply b1.
 apply b2.
Qed.
(* end hide *)

Lemma ArcTan_range : [--] (Pi [/]TwoNZ) [<] ArcTan x and ArcTan x [<] Pi [/]TwoNZ.
Proof.
 intros.
 Transparent ArcTang.
 elim ArcTan_range_lemma; intros y H H0.
 elim H; intros.
 cut (Dom Tang y). intro H1.
  assert (H2 : Tan y H1 [=] x). unfold Tan in |- *; algebra.
   split.
   apply less_wdr with y; auto.
   apply eq_symmetric_unfolded; eapply eq_transitive_unfolded.
    2: apply ArcTan_Tan with (H := H1); auto.
   unfold ArcTan in |- *; algebra.
  apply less_wdl with y; auto.
  apply eq_symmetric_unfolded; eapply eq_transitive_unfolded.
   2: apply ArcTan_Tan with (H := H1); auto.
  unfold ArcTan in |- *; algebra.
 repeat split.
 intro; apply Greater_imp_ap.
 apply less_wdr with (Cos y); [ apply Cos_pos; auto | simpl in |- *; algebra ].
Qed.

End ArcTan_Range.

Lemma Tan_ArcTan : forall (x : IR) Hx, x [=] Tan (ArcTan x) Hx.
Proof.
 intros.
 set (y := Tan (ArcTan x) Hx) in *.
 assert (H : ArcTan x [=] ArcTan y).
  unfold y in |- *; apply eq_symmetric_unfolded; elim ArcTan_range with x;
    intros; apply ArcTan_Tan; auto.
 Transparent ArcTang.
 cut (Continuous_I (Min_leEq_Max x y) {1/} ( [-C-][1]{+}FId{^}2)). intro H0.
  cut (Integral H0 [=] [0]). intro H1.
   elim Hx; intros H2 H3.
   apply Integral_eq_zero with (contF := H0) (x := x).
      exact (pair (Min_leEq_lft x y) (lft_leEq_Max x y)).
     intros.
     simpl in |- *; apply recip_resp_pos.
     astepl (ZeroR[+][0]); apply plus_resp_less_leEq.
      apply pos_one.
     astepr (x[^]2); apply sqr_nonneg.
    intros x0 H4 Hx0; simpl in |- *.
    apply less_leEq; apply recip_resp_pos.
    astepl (ZeroR[+][0]); apply plus_resp_less_leEq.
     apply pos_one.
    astepr (x0[^]2); apply sqr_nonneg.
   auto.
  apply eq_transitive_unfolded with (ArcTan y[-]ArcTan x).
   rstepl (ArcTan x[+]Integral H0[-]ArcTan x).
   apply cg_minus_wd; [ simpl in |- * | algebra ].
   apply eq_symmetric_unfolded; unfold ArcTan in |- *; simpl in |- *.
   apply Integral_plus_Integral with (Min3_leEq_Max3 [0] y x).
   apply included_imp_Continuous with realline.
    exact ArcTan_def_lemma.
   apply included3_interval; split.
  apply x_minus_x; simpl in |- *; algebra.
 apply included_imp_Continuous with realline.
  exact ArcTan_def_lemma.
 apply included_interval; split.
Qed.

Lemma Tan_ArcTan_inv : Feq realline (Tang[o]ArcTang) FId.
Proof.
 apply eq_imp_Feq.
   apply included_FComp.
    Included.
   intros; split.
    auto.
   split.
    auto.
   intros.
   apply ap_wdl with (Cos (ArcTan x)).
    Opaque ArcTang.
    2: unfold ArcTan in |- *; simpl in |- *; algebra.
   elim ArcTan_range with x; intros.
   apply pos_ap_zero; apply Cos_pos; auto.
  Included.
 intros; inversion_clear Hx.
 astepr x; astepl (Part _ _ (ProjT2 Hx)); astepl (Part _ _ X0).
 cut (Dom Tang (ArcTan x)); intros.
  apply eq_transitive_unfolded with (Tan (ArcTan x) X1).
   unfold Tan, ArcTan in |- *; algebra.
  apply eq_symmetric_unfolded; apply Tan_ArcTan.
 apply dom_wd with (ArcTang x x0); auto.
 unfold ArcTan in |- *; algebra.
Qed.

End Inverses.


(* monae: Monadic equational reasoning in Coq                                 *)
(* Copyright (C) 2020 monae authors, license: LGPL-2.1-or-later               *)
From mathcomp Require Import all_ssreflect.
From mathcomp Require boolp.
Require Import monae_lib hierarchy monad_lib fail_lib state_lib.

(******************************************************************************)
(*                           Tree relabeling                                  *)
(*                                                                            *)
(* see Sect. 9 of J. Gibbons, R. Hinze, Just do it: simple monadic equational *)
(* reasoning, ICFP 2011                                                       *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope monae_scope.

Section Tree.
Variable A : Type.

Inductive Tree := Tip (a : A) | Bin of Tree & Tree.

Fixpoint foldt B (f : A -> B) (g : B * B -> B) (t : Tree) : B :=
  match t with
  | Tip a => f a
  | Bin t u => g (foldt f g t, foldt f g u)
  end.

Section foldt_universal.
Variables (B : Type) (h : Tree -> B) (f : A -> B) (g : B * B -> B).
Hypothesis H1 : h \o Tip = f.
Hypothesis H2 : h \o uncurry Bin = g \o (fun x => (h x.1, h x.2)).
Lemma foldt_universal : h = foldt f g.
Proof.
rewrite boolp.funeqE; elim => [a|]; first by rewrite -H1.
by move=> t1 IH1 t2 IH2 /=; rewrite -IH1 -IH2 -(uncurryE Bin) -compE H2.
Qed.
End foldt_universal.

Definition size_Tree (t : Tree) := foldt (const 1) uaddn t.

Lemma size_Tree_Bin : size_Tree \o uncurry Bin = uaddn \o size_Tree^`2.
Proof. by rewrite boolp.funeqE; case. Qed.

Fixpoint labels (t : Tree) : seq A :=
  match t with
  | Tip a => [:: a]
  | Bin t u => labels t ++ labels u
  end.

End Tree.
Arguments Tip {A}.
Arguments Bin {A}.

Section tree_relabelling.

Variable Symbol : eqType. (* TODO: ideally, we would like a generic type here with a succ function *)
Variable M : failFreshMonad Symbol.
Variable q : pred (seq Symbol * seq Symbol).
Hypothesis promotable_q : promotable (@distinct _ M) q.

Local Open Scope mprog.

Definition relabel : Tree Symbol -> M (Tree Symbol) :=
  foldt (M # Tip \o const fresh) (fmap (uncurry Bin) \o mpair).

Let drTip {A} : A -> M _ := (M # wrap) \o const fresh.
Let drBin {N : failMonad} : (N _ * N _ -> N _) :=
  (fmap ucat) \o bassert q \o mpair.

(* extracting the distinct symbol list *)
Definition dlabels {N : failMonad} : Tree Symbol -> N (seq Symbol) :=
  foldt (Ret \o wrap) drBin.

Lemma dlabelsC t u (m : _ -> _ -> M (seq Symbol * seq Symbol)%type) :
  dlabels t >>= (fun x => relabel u >>= fun x0 => m x0 x) =
  relabel u >>= (fun x0 => dlabels t >>= fun x => m x0 x).
Proof.
elim: t u m => [a u /= m|t1 H1 t2 H2 u m].
  rewrite /dlabels /= bindretf.
  by under [in RHS]eq_bind do rewrite bindretf.
rewrite (_ : dlabels _ = drBin (dlabels t1, dlabels t2)) //.
rewrite [in RHS]/drBin [in RHS]/bassert 2!compE ![in RHS]bindA.
transitivity (do x0 <- relabel u;
  (do x <- dlabels t1;
   do x <- (do x1 <- (do y <- dlabels t2; Ret (x, y));
            (do x <- assert q x1; (Ret \o ucat) x));
   m x0 x))%Do; last first.
  bind_ext => u'; rewrite bind_fmap bindA; bind_ext => sS.
  rewrite 4!bindA; bind_ext => x; rewrite 2!bindretf !bindA.
  by under eq_bind do rewrite bindretf.
rewrite -H1.
rewrite [in LHS]/drBin bind_fmap [in LHS]/bassert /= ![in LHS]bindA.
bind_ext => s.
rewrite !bindA.
transitivity (do x0 <- relabel u;
  (do x <- dlabels t2; (do x <-
    (do x1 <- Ret (s, x); (do x3 <- assert q x1; Ret (ucat x3)));
    m x0 x)))%Do; last by bind_ext => y2; rewrite bindA.
rewrite -H2.
bind_ext => s'.
rewrite !bindretf.
rewrite assertE.
rewrite bindA.
transitivity (guard (q (s, s')) >>
  (do x1 <- (Ret \o ucat) (s, s'); relabel u >>= (m^~ x1)))%Do.
  bind_ext; case; by rewrite 2!bindretf.
rewrite guardsC; last exact: failfresh_bindmfail.
rewrite !bindA !bindretf !bindA.
bind_ext => u'.
rewrite bindA guardsC; last exact: failfresh_bindmfail.
by rewrite bindA bindretf.
Qed.

(* see gibbons2011icfp Sect. 9.3 *)
Lemma join_and_pairs :
  (Join \o (M # mpair) \o mpair) \o ((fmap dlabels) \o relabel)^`2 =
  (mpair \o Join^`2) \o             ((fmap dlabels) \o relabel)^`2.
Proof.
rewrite boolp.funeqE => -[x1 x2].
rewrite 3!compE.
rewrite joinE.
rewrite fmapE.
rewrite 2![in RHS]compE.
rewrite [in RHS]/mpair.
rewrite [in LHS]/mpair.
move H : (fmap dlabels) => h.
rewrite /=.
rewrite 2![in RHS]joinE.
rewrite 3!bindA.
rewrite -H.
rewrite !fmapE.
rewrite 3!bindA.
bind_ext => {}x1.
rewrite 2!bindretf 2!bindA.
under eq_bind do rewrite 3!bindretf.
rewrite -dlabelsC.
bind_ext => ?.
rewrite /=.
rewrite bindA.
by under [in RHS]eq_bind do rewrite bindretf.
Qed.

(* first property of Sect. 9.3 *)
Lemma dlabels_relabel_is_fold : relabel >=> dlabels = foldt drTip drBin.
Proof.
apply foldt_universal.
  (* relabel >=> dlabels \o Tip = drTip *)
  rewrite kleisli_def -3!compA.
  rewrite (_ : relabel \o Tip = (M # Tip) \o const fresh) //.
  rewrite (compA (fmap dlabels)) -functor_o.
  rewrite (_ : dlabels \o Tip = ret _ \o wrap) //.
  rewrite functor_o.
  by rewrite compA (compA Join) joinMret compidf.
(* relabel >=> dlabels \o Bin = drBin \o _ *)
rewrite [in LHS]kleisli_def -(compA _ relabel).
rewrite (_ : _ \o _ Bin =
    (fmap (uncurry Bin)) \o mpair \o relabel^`2); last first.
  by rewrite boolp.funeqE; case.
rewrite -(compA (fmap (uncurry Bin))) -compA (compA (fmap dlabels)) -functor_o.
rewrite (_ : _ \o _ Bin =
    (fmap ucat) \o bassert q \o mpair \o dlabels^`2); last first.
  by rewrite boolp.funeqE; case.
transitivity ((fmap ucat) \o Join \o (fmap (bassert q \o mpair)) \o mpair \o
    (fmap dlabels \o relabel)^`2).
  rewrite [in RHS]natural -3![in RHS]compA; congr (_ \o _).
  rewrite -[in RHS]naturality_mpair 2![RHS]compA; congr (_ \o _).
  by rewrite -[X in _ = X \o _]functor_o -[RHS]functor_o -compA.
rewrite -(compA (fmap ucat)) [X in Join \o X]functor_o (compA Join).
rewrite commutativity_of_assertions. (* first non-trivial step *)
rewrite -(compA _ Join) (compA _ (bassert q)).
rewrite -(compA _ _ mpair) -(compA _ (_ \o mpair)).
by rewrite join_and_pairs. (* second non-trivial step *)
Qed.

(* second property of Sect. 9.3 *)
Lemma symbols_size_is_fold :
  symbols \o (@size_Tree Symbol) = foldt drTip drBin.
Proof.
apply foldt_universal.
  by rewrite -compA (_ : @size_Tree Symbol \o _ = const 1) // symbols_prop1.
pose p := @distinct _ M.
transitivity (bassert p \o symbols \o @size_Tree Symbol \o uncurry Bin
  : (_ -> M _)).
  by rewrite bassert_symbols.
transitivity ((bassert p) \o symbols \o uaddn \o (@size_Tree Symbol)^`2
  : (_ -> M _)).
  by rewrite -[in LHS]compA -[in RHS]compA size_Tree_Bin.
transitivity (bassert p \o (fmap ucat) \o mpair \o (symbols \o (@size_Tree Symbol))^`2
  : (_ -> M _)).
  rewrite -2!compA (compA symbols) symbols_prop2.
  by rewrite -(compA (_ \o mpair)) (compA (bassert p)).
transitivity ((fmap ucat) \o bassert q \o mpair \o (bassert p \o symbols \o (@size_Tree Symbol))^`2
  : (_ -> M _)).
  (* assert p distributes over concatenation *)
  by rewrite (promote_assert_sufficient_condition (@failfresh_bindmfail _ M) promotable_q).
transitivity ((fmap ucat) \o bassert q \o mpair \o (symbols \o (@size_Tree Symbol))^`2
  : (_ -> M _)).
  by rewrite bassert_symbols.
by [].
Qed.

(* main claim *)
Lemma dlabels_relabel_never_fails :
  relabel >=> dlabels = symbols \o @size_Tree Symbol.
Proof. by rewrite dlabels_relabel_is_fold symbols_size_is_fold. Qed.

End tree_relabelling.


Require Import CFML.CFLib.
Require Import ssreflect.
Open Scope Z_scope.

(** Utilities *)

Class IsEvar {A : Type} (x: A) :=
  MkIsEvar : True.

Hint Extern 0 (IsEvar ?x) =>
  (is_evar x; exact I) : typeclass_instances.

Class IsNotEvar {A : Type} (x: A) :=
  MkIsNotEvar : True.

Hint Extern 0 (IsNotEvar ?x) =>
  (tryif is_evar x then fail else exact I) : typeclass_instances.

Class Unify {A : Type} (x y : A) :=
  MkUnify : x = y.

Instance Unify_refl: forall A (x : A),
  Unify x x.
Proof. reflexivity. Qed.

(********************************************************************)

(* Iterated (+) *)
Definition big_add (l : list int) : int :=
  List.fold_left Z.add l 0.

Definition big_add_acc (l : list int) (acc : int) : int :=
  List.fold_left Z.add l acc.

(* Boilerplate equations *)
Lemma big_add_nil:
  big_add nil = 0.
Proof. reflexivity. Qed.

Lemma big_add_cons: forall x l,
  big_add (x :: l) = big_add_acc l x.
Proof. intros. reflexivity. Qed.

Lemma big_add_acc_nil acc:
  big_add_acc nil acc = acc.
Proof. reflexivity. Qed.

Lemma big_add_acc_cons x l acc:
  big_add_acc (x :: l) acc = big_add_acc l (acc + x).
Proof. reflexivity. Qed.

(* Lemmas *)
Lemma big_add_of_acc: forall l acc,
  big_add_acc l acc = big_add l + acc.
Proof.
  induction l; intros;
  rewrite ?big_add_nil ?big_add_acc_nil ?big_add_cons ?big_add_acc_cons.
  - math.
  - rewrite (IHl (acc + a)) (IHl a). math.
Qed.

Lemma big_add_app: forall l1 l2,
  big_add (l1 ++ l2) = big_add l1 + big_add l2.
Proof.
  induction l1; intros; rew_list; rewrite ?big_add_nil ?big_add_cons.
  - math.
  - rewrite !big_add_of_acc IHl1. math.
Qed.

Lemma big_add_snoc: forall l x,
  big_add (l & x) = big_add l + x.
Proof.
  intros. now rewrite big_add_app big_add_cons big_add_acc_nil.
Qed.

(* Iterated (-) *)
Definition big_sub (x : int) (l : list int) : int :=
  List.fold_left Z.sub l x.

(* Boilerplate equations *)
Lemma big_sub_nil x:
  big_sub x nil = x.
Proof. reflexivity. Qed.

Lemma big_sub_cons x y l:
  big_sub x (y :: l) = big_sub (x - y) l.
Proof. reflexivity. Qed.

(* Lemmas *)
Lemma big_sub_big_add: forall l x,
  big_sub x l = x - big_add l.
Proof.
  induction l; intros;
  rewrite ?big_sub_nil ?big_add_nil ?big_sub_cons ?big_add_cons.
  - now rewrite Z.sub_0_r.
  - rewrite !IHl (big_add_of_acc _ a). math.
Qed.

(********************************************************************)

Class Snoc {A} (l : list A) (x : A) (l' : list A) :=
  MkSnoc : l' = l & x.

Hint Mode Snoc - ! - - : typeclass_instances.

Instance Snoc_nil: forall A (x:A),
  Snoc nil x (x :: nil).
Proof. reflexivity. Qed.

Instance Snoc_cons: forall A (l l': list A) (x y: A),
  Snoc l x l' ->
  Snoc (y :: l) x (y :: l').
Proof. introv ->. reflexivity. Qed.

(********************************************************************)

Class AddIntList (l : list int) (c : int) :=
  MkAddIntList : c = big_add l.

Class AddIntListAcc (l : list int) (acc c : int) :=
  MkAddIntListAcc : c = big_add_acc l acc.

Hint Mode AddIntList ! - : typeclass_instances.
Hint Mode AddIntListAcc ! - - : typeclass_instances.

Instance AddIntList_nil:
  AddIntList nil 0.
Proof. reflexivity. Qed.

Instance AddIntList_cons: forall x l c,
  AddIntListAcc l x c ->
  AddIntList (x :: l) c.
Proof.
  introv ->. unfold AddIntList, AddIntListAcc.
  simpl. now rewrite big_add_cons.
Qed.

Instance AddIntListAcc_nil: forall acc,
  AddIntListAcc nil acc acc.
Proof. reflexivity. Qed.

Instance AddIntListAcc_cons: forall x l acc c,
  AddIntListAcc l (acc + x) c ->
  AddIntListAcc (x :: l) acc c.
Proof. introv ->. reflexivity. Qed.

Goal True.
  eassert (AddIntList (0 :: 1 :: 2 :: 3 :: nil) _).
  typeclasses eauto.
Abort.

Class SubIntList (x : int) (l : list int) (y : int) :=
  MkSubIntList : y = big_sub x l.

Hint Mode SubIntList - ! - : typeclass_instances.

Instance SubIntList_nil: forall x,
  SubIntList x nil x.
Proof. reflexivity. Qed.

Instance SubIntList_cons: forall x y l z,
  SubIntList (x - y) l z ->
  SubIntList x (y :: l) z.
Proof. introv ->. reflexivity. Qed.

Goal True.
  eassert (SubIntList 42 (0 :: 1 :: 2 :: nil) _).
  typeclasses eauto.
Abort.

(********************************************************************)
(* Refine credits marker *)

(* Roundabout way of creating a *really* opaque constant.

   (this is required because [refine] (and sometimes [apply]) seem to ignore
    opacity as specified by Opaque, which would make [xapp]/[xapply] ignore our
    marker).
*)
Lemma credits_refine_def :
  { credits_refine | forall (c : int), credits_refine c = c }.
Proof. exists (fun (x:int) => x). eauto. Qed.

Definition credits_refine := proj1_sig credits_refine_def.

Notation " ⟨ c ⟩ " := (credits_refine c) (format "⟨ c ⟩").
Hint Opaque credits_refine : typeclass_instances.
Global Opaque credits_refine.

Lemma credits_refine_eq c:
  ⟨ c ⟩ = c.
Proof. apply (proj2_sig credits_refine_def). Qed.

(**********************************************************)
(* Hack: it seems we can get into trouble if we do not manually instantiate
   credits expressions of the form "\$ ?c x" into a lambda.

   See https://github.com/coq/coq/issues/6643
 *)

Class CreditsPreprocessEta (c1 c2 : int) :=
  MkCreditsPreprocessEta : c1 = c2.

Hint Extern 0 (CreditsPreprocessEta ⟨?c1 _⟩ ?c2) =>
  (is_evar c1;
   let cf := fresh in
   pose (cf := c1);
   unshelve instantiate (1 := _) in (Value of cf);
   [ refine (fun _ => _); shelve | hnf ];
   clear cf;
   reflexivity) : typeclass_instances.

Instance CreditsPreprocessEta_default: forall c,
  CreditsPreprocessEta c c | 100.
Proof. reflexivity. Qed.

(* Preprocess all credits in a heap expression *)

Class HeapPreprocessCredits (h1 h2 : hprop) :=
  MkHeapPreprocessCredits : h1 = h2.

Class HeapPreprocessCredits' (h1 h2 : hprop) :=
  MkHeapPreprocessCredits' : HeapPreprocessCredits h1 h2.

Instance HeapPreprocessCredits_of': forall h1 h2,
  HeapPreprocessCredits' h1 h2 ->
  HeapPreprocessCredits h1 h2.
Proof. eauto. Qed.

Hint Mode HeapPreprocessCredits' ! - : typeclass_instances.

Instance HeapPreprocessCredits'_star: forall h1 h1' h2 h2',
  HeapPreprocessCredits h1 h1' ->
  HeapPreprocessCredits h2 h2' ->
  HeapPreprocessCredits' (h1 \* h2) (h1' \* h2').
Proof.
  intros. unfold HeapPreprocessCredits', HeapPreprocessCredits in *.
  now subst.
Qed.

Instance HeapPreprocessCredits'_credits: forall c c',
  CreditsPreprocessEta c c' ->
  HeapPreprocessCredits' (\$ c) (\$ c').
Proof.
  intros.
  unfold CreditsPreprocessEta,
    HeapPreprocessCredits', HeapPreprocessCredits in *. now subst.
Qed.

Instance HeapPreprocessCredits_default: forall h,
  HeapPreprocessCredits h h | 100.
Proof. intros. now unfold HeapPreprocessCredits. Qed.

(**********************************************************)
(* Star: Like "\*" but cleans up \[] *)

Class Star (h1 h2 h3 : hprop) :=
  MkStar : h1 \* h2 = h3.

Class Star'l (h1 h2 h3 : hprop) :=
  MkStar'l : Star h1 h2 h3.

Class Star'r (h1 h2 h3 : hprop) :=
  MkStar'r : Star h1 h2 h3.

Instance Star_of'l: forall h1 h2 h3,
  Star'l h1 h2 h3 ->
  Star h1 h2 h3.
Proof. eauto. Qed.

Instance Star_of'r: forall h1 h2 h3,
  Star'r h1 h2 h3 ->
  Star h1 h2 h3.
Proof. eauto. Qed.

Hint Mode Star'l ! - - : typeclass_instances.
Hint Mode Star'r - ! - : typeclass_instances.

Instance Star'_emp_l: forall h, Star'l \[] h h.
Proof. intros. apply star_neutral_l. Qed.

Instance Star'_emp_r: forall h, Star'r h \[] h.
Proof. intros. apply star_neutral_r. Qed.

Instance Star_default: forall h1 h2, Star h1 h2 (h1 \* h2) | 2.
Proof. reflexivity. Qed.

(**********************************************************)
(* CleanupEmp: removes the \[] in a heap by recursively applying Star *)

Class CleanupEmp (h1 h2 : hprop) :=
  MkCleanupEmp : h1 = h2.

Class CleanupEmp' (h1 h2 : hprop) :=
  MkCleanupEmp' : CleanupEmp h1 h2.

Instance CleanupEmp_of': forall h1 h2,
  CleanupEmp' h1 h2 ->
  CleanupEmp h1 h2.
Proof. eauto. Qed.

Hint Mode CleanupEmp' ! - : typeclass_instances.

Instance CleanupEmp'_star: forall h1 h1' h2 h2' h1h2',
  CleanupEmp h1 h1' ->
  CleanupEmp h2 h2' ->
  Star h1' h2' h1h2' ->
  CleanupEmp' (h1 \* h2) h1h2'.
Proof. introv -> -> ->. now unfold CleanupEmp. Qed.

Instance CleanupEmp_default: forall h,
  CleanupEmp h h | 10.
Proof. reflexivity. Qed.

Goal forall H1 H2, exists H3,
  H1 ==> H2 \* H3 ->
  \[] \* (H1 \* \[])  ==> H2 \* \[] \* H3.
Proof.
  intros. eexists. intros HH1.
  assert (L: forall h1 h1' h2 h2',
    CleanupEmp h1 h1' ->
    CleanupEmp h2 h2' ->
    h1' ==> h2' ->
    h1 ==> h2).
  { introv -> ->. eauto. }
  eapply L; [ once (typeclasses eauto) .. |].
  apply HH1.
Abort.

(**********************************************************)
(* Concat: typeclass-level list concatenation.
   NB: must only be called on fully concrete lists. *)

Class Concat {A} (l1 l2 l3 : list A) :=
  MkApp : l1 ++ l2 = l3.

Instance Concat_nil: forall A (l: list A), Concat nil l l.
Proof. intros. reflexivity. Qed.

Instance Concat_cons: forall A x (l1 l2 l3: list A),
  Concat l1 l2 l3 ->
  Concat (x :: l1) l2 (x :: l3).
Proof. intros. unfold Concat in *. subst. reflexivity. Qed.

(**********************************************************)
(* GetCredits: gets the list of credits sub-expressions *)

(* Iterated \$ *)
Definition heap_is_credits_list (l : list int) : hprop :=
  \$ big_add l.

Notation "\$* l" := (heap_is_credits_list l) (at level 40).

Lemma credits_list_nil: \$* nil = \[].
Proof. unfold heap_is_credits_list. now rewrite big_add_nil credits_zero_eq. Qed.

Lemma credits_list_cons x l: \$* (x :: l) = \$ x \* \$* l.
Proof.
  unfold heap_is_credits_list.
  now rewrite big_add_cons big_add_of_acc credits_split_eq star_comm.
Qed.

Lemma credits_list_app l1 l2:
  \$* (l1 ++ l2) = \$* l1 \* \$* l2.
Proof.
  unfold heap_is_credits_list.
  now rewrite big_add_app credits_split_eq.
Qed.

(*****************)

Class GetCredits (h1 h2 : hprop) (l : list int) :=
  MkGetCredits : h1 = h2 \* heap_is_credits_list l.

Class GetCredits' (h1 h2 : hprop) (l : list int) :=
  MkGetCredits' : GetCredits h1 h2 l.

Instance GetCredits_of': forall h1 h2 l,
  GetCredits' h1 h2 l ->
  GetCredits h1 h2 l.
Proof. eauto. Qed.

Hint Mode GetCredits' ! - - : typeclass_instances.

Instance GetCredits'_star: forall h1 h1' h2 h2' h1h2' l1 l2 l1l2,
  GetCredits h1 h1' l1 ->
  GetCredits h2 h2' l2 ->
  Star h1' h2' h1h2' ->
  Concat l1 l2 l1l2 ->
  GetCredits' (h1 \* h2) h1h2' l1l2.
Proof.
  intros. unfold GetCredits', GetCredits, Star, Concat in *.
  subst. rewrite credits_list_app.
  rewrite <-!star_assoc. fequal.
  rewrite star_comm -star_assoc. fequal.
  now rewrite star_comm.
Qed.

Instance GetCredits'_credits: forall c,
  GetCredits' (\$ c) \[] (c :: nil).
Proof.
  intros. unfold GetCredits', GetCredits.
  now rewrite star_neutral_l credits_list_cons credits_list_nil
    star_neutral_r.
Qed.

Instance GetCredits_no_credits: forall h,
  GetCredits h h nil
| 100.
Proof.
  intros. unfold GetCredits. now rewrite credits_list_nil star_neutral_r.
Qed.

Goal forall H1 H2 H3 a b c, exists H d,
  (H1 \* \$* (b :: nil) ==> (H2 \* H \* H3) \* \$* (a :: d :: c :: nil)) ->
  \$ b \* H1 ==> H2 \* H \* (\$ a \* \$ d \* (H3 \* \$ c)).
Proof.
  intros. do 2 eexists. intros.
  asserts L: (forall h1 h1' h2 h2' l1 l2,
    GetCredits h1 h1' l1 ->
    GetCredits h2 h2' l2 ->
    h1' \* \$* l1 ==> h2' \* \$* l2 ->
    h1 ==> h2).
  { intros. unfold GetCredits in *. now subst. }
  eapply L. typeclasses eauto. typeclasses eauto.
  eassumption.
Abort.

(**********************************************************)
(* GetCreditsExpr: gets the first number of credits that matches [c].

   NB: initially [c] can be an evar (in which case it gets unified with the evar
   found in [h1]), or not (in which case the search succeeds iff a corresponding
   number of credits is found). *)

Class GetCreditsExpr (h1 : hprop) (c : int) (h2 : hprop) :=
  MkGetCreditExpr : h1 = h2 \* \$ c.

Hint Mode GetCreditsExpr ! - - : typeclass_instances.

Instance GetCreditsExpr_star_l: forall h1 h2 h1' h1'h2 c,
  GetCreditsExpr h1 c h1' ->
  Star h1' h2 h1'h2 ->
  GetCreditsExpr (h1 \* h2) c h1'h2
| 2.
Proof.
  intros. unfold GetCreditsExpr, Star in *. subst.
  rewrite <-star_assoc, (star_comm (\$ c)), star_assoc.
  reflexivity.
Qed.

Instance GetCreditsExpr_star_r: forall h1 h2 h2' h1h2' c,
  GetCreditsExpr h2 c h2' ->
  Star h1 h2' h1h2' ->
  GetCreditsExpr (h1 \* h2) c h1h2'
| 3 (* search left first *).
Proof.
  intros. unfold GetCreditsExpr, Star in *. subst.
  rewrite star_assoc. reflexivity.
Qed.

Instance GetCreditsExpr_evars: forall c1 c2,
  IsEvar c1 ->
  IsEvar c2 ->
  Unify c1 c2 ->
  GetCreditsExpr (\$ c1) c2 \[].
Proof.
  introv ? ? ->. unfold GetCreditsExpr in *. subst.
  now rewrite star_neutral_l.
Qed.

(* This is a bit coarse grained, but we want to support querying for ⟨?x⟩ with
   ⟨_⟩ for example, *and* if there is a ?x, we do not want to instantiate it
   with ⟨_⟩... *)
Instance GetCreditsExpr_notevar: forall c1 c2,
  IsNotEvar c1 ->
  Unify c1 c2 ->
  GetCreditsExpr (\$ c1) c2 \[].
Proof.
  introv ? ->. unfold GetCreditsExpr in *. subst. now rewrite star_neutral_l.
Qed.

Goal forall H1 H2 H3 a b c, exists H d,
  \$b \* H1 ==> (H2 \* H \* \$a \* H3 \* \$c) \* \$⟨d⟩ ->
  \$b \* H1 ==> (H2 \* H \* \$⟨d⟩ \* H3 \* \$c) \* \$a ->
  \$ b \* H1 ==> H2 \* H \* (\$ a \* \$ ⟨d⟩ \* (H3 \* \$ c)).
Proof.
  intros. do 2 eexists. intros HH1 HH2.
  asserts L: (forall c h1 h2 h2',
    GetCreditsExpr h2 c h2' ->
    h1 ==> h2' \* \$ c ->
    h1 ==> h2).
  { intros. unfold GetCreditsExpr in *. now subst. }
  dup.
  { eapply (L ⟨_⟩). typeclasses eauto. apply HH1. }
  dup.
  { eapply (L a). typeclasses eauto. apply HH2. }
  rewrite credits_refine_eq.
  eapply (L ⟨_⟩). Fail typeclasses eauto.
Abort.

(**********************************************************)

Class HasSingleCreditsExpr (h h' : hprop) (c : int) :=
  MkHasSingleCreditsExpr : h = h' \* \$ c.

Lemma HasSingleCreditsExpr_of_GetCredits: forall h h' cs c,
  GetCredits h h' cs ->
  cs = c :: nil ->
  HasSingleCreditsExpr h h' c.
Proof.
  intros. unfold GetCredits, HasSingleCreditsExpr in *.
  subst. now rewrite credits_list_cons credits_list_nil star_neutral_r.
Qed.

(* FUTURE: could that be expressed as a "Hint Committed" in the future?
   (when these get implemented). *)
Hint Extern 0 (HasSingleCreditsExpr ?h ?h' ?c) =>
  (eapply HasSingleCreditsExpr_of_GetCredits;
   [ once (typeclasses eauto) | reflexivity ]) : typeclass_instances.

Class HasNoCredits (h : hprop) :=
  MkHasNoCredits : True.

Lemma HasNoCredits_of_GetCredits: forall h h' cs,
  GetCredits h h' cs ->
  cs = nil ->
  HasNoCredits h.
Proof. intros. exact I. Qed.

(* FUTURE: use Hint Committed? *)
Hint Extern 0 (HasNoCredits ?h) =>
  (eapply HasNoCredits_of_GetCredits;
   [ once (typeclasses eauto) | reflexivity ]) : typeclass_instances.

(**********************************************************)

Lemma GCGC_eq_GC:
  \GC \* \GC = \GC.
Proof.
  unfold heap_is_gc, heap_is_star.
  apply fun_ext_1. intros h.
  apply prop_ext. split.
  - intros (h1 & h2 & (? & [HH1 ?]) & (? & [HH2 ?]) & ?). unpack. split.
    + subst. apply~ heap_affine_union.
    + subst. exists (HH1 \* HH2). unfold heap_is_star. do 2 eexists. eauto.
  - intros (? & [HH ?]). exists h heap_empty. repeat split; eauto.
    + apply heap_affine_empty.
    + exists \[]. unfold heap_is_empty. eauto.
Qed.

Class HasGC (h : hprop) :=
  MkHasGC : h = h \* \GC.

Class HasGC' (h : hprop) :=
  MkHasGC' : HasGC h.

Instance HasGC_of': forall h,
  HasGC' h ->
  HasGC h.
Proof. eauto. Qed.

Hint Mode HasGC' ! : typeclass_instances.

Instance HasGC'_star_l: forall h1 h2,
  HasGC h1 ->
  HasGC' (h1 \* h2).
Proof.
  introv ->. unfold HasGC', HasGC.
  now rewrite <-!star_assoc, (star_comm _ \GC), (star_assoc \GC), GCGC_eq_GC.
Qed.

Instance HasGC'_star_r: forall h1 h2,
  HasGC h2 ->
  HasGC' (h1 \* h2).
Proof.
  introv ->. unfold HasGC', HasGC.
  now rewrite <-!star_assoc, GCGC_eq_GC.
Qed.

Instance HasGC'_GC:
  HasGC' \GC.
Proof. unfold HasGC', HasGC. now rewrite GCGC_eq_GC. Qed.

Instance HasGC_evar: forall h h',
  IsEvar h ->
  Unify h (\GC \* h') ->
  HasGC h.
Proof.
  introv _ ->. unfold HasGC.
  now rewrite <-star_assoc, (star_comm _ \GC), (star_assoc \GC), GCGC_eq_GC.
Qed.

(**********************************************************)
(* CreditsHeap: credits list -> hprop *)

Class CreditsHeap (l : list int) (h : hprop) :=
  MkCreditsHeap : h = \$* l.

Hint Mode CreditsHeap ! - : typeclass_instances.

Instance CreditsHeap_nil:
  CreditsHeap nil \[].
Proof. unfold CreditsHeap. now rewrite credits_list_nil. Qed.

Instance CreditsHeap_cons: forall x l h xh,
  CreditsHeap l h ->
  Star (\$ x) h xh ->
  CreditsHeap (x :: l) xh.
Proof.
  introv -> <-. unfold CreditsHeap. now rewrite credits_list_cons.
Qed.

(**********************************************************)
(* Extract a \GC from a hprop *)

Class RemoveGC (h h' : hprop) :=
  MkRemoveGC : h = h' \* \GC.

Hint Mode RemoveGC ! - : typeclass_instances.

Instance RemoveGC_GC:
  RemoveGC \GC \[].
Proof. unfold RemoveGC. now rewrite star_neutral_l. Qed.

Instance RemoveGC_star: forall h1 h1' h2 h2' h1h2',
  RemoveGC h1 h1' ->
  RemoveGC h2 h2' ->
  Star h1' h2' h1h2' ->
  RemoveGC (h1 \* h2) h1h2'.
Proof.
  introv -> -> <-. unfold RemoveGC.
  now rewrite <-!star_assoc, (star_comm _ \GC), (star_assoc \GC), GCGC_eq_GC.
Qed.

Instance RemoveGC_star_l: forall h1 h1' h2 h1h2',
  RemoveGC h1 h1' ->
  Star h1' h2 h1h2' ->
  RemoveGC (h1 \* h2) h1h2'
| 20.
Proof.
  introv -> <-. unfold RemoveGC.
  now rewrite <-!star_assoc, (star_comm _ \GC).
Qed.

Instance RemoveGC_star_r: forall h1 h2 h2' h1h2',
  RemoveGC h2 h2' ->
  Star h1 h2' h1h2' ->
  RemoveGC (h1 \* h2) h1h2'
| 20.
Proof.
  introv -> <-. unfold RemoveGC.
  now rewrite <-!star_assoc, (star_comm _ \GC).
Qed.

(**********************************************************)

Definition big_opp (l: list int): list int :=
  List.map Z.opp l.

Lemma big_opp_cancel_credits: forall l,
  \[] ==> \$* l \* \$* (big_opp l).
Proof.
  induction l; rewrite //= ?credits_list_nil ?credits_list_cons.
  { hsimpl. }
  { hchange IHl.
    rewrite -!star_assoc (star_assoc (\$ a)) (star_comm (\$ a)) -star_assoc.
    apply star_cancel.
    rewrite star_assoc credits_join_eq Z.add_opp_diag_r credits_zero_eq.
    rewrite star_comm. apply pred_incl_refl. }
Qed.

Class OppIntList (l1 l2 : list int) :=
  MkOppIntList : l2 = big_opp l1.

Hint Mode OppIntList ! - : typeclass_instances.

Instance OppIntList_nil:
  OppIntList nil nil.
Proof. reflexivity. Qed.

Instance OppIntList_cons: forall x l l',
  OppIntList l l' ->
  OppIntList (x :: l) (-x :: l').
Proof. introv ->. reflexivity. Qed.

Lemma move_credits_r2l : forall h1 h2 h2' cs cs' hcs,
  GetCredits h2 h2' cs ->
  OppIntList cs cs' ->
  CreditsHeap cs' hcs ->
  h1 \* hcs ==> h2' ->
  h1 ==> h2.
Proof.
  introv -> -> -> HH.
  hchange (big_opp_cancel_credits cs).
  hchange HH. hsimpl.
Qed.

Ltac credr2l :=
  eapply move_credits_r2l; [ once (typeclasses eauto) .. |].