(* Banach-Tarski paradox. *)

Require Import Utf8.
Require Import Reals Psatz.

Require Import MiscReals.

Definition atan' x y :=
  if Req_dec y 0 then Rsign x * PI / 2 else atan (x / y).

Definition asin x := atan' x (√ (1 - x²)).
Definition acos x := PI / 2 - asin x.

Definition angle_of_sin_cos s c :=
  if Rlt_dec s 0 then
    if Rlt_dec c 0 then 2 * PI - acos c else asin s + 2 * PI
  else
    if Rlt_dec c 0 then acos c else asin s.

Theorem cos_atan : ∀ x, cos (atan x) = 1 / √ (1 + x²).
Proof.
intros.
assert (Hs : √ (1 + x²) ≠ 0).
 intros H.
 specialize (Rle_0_sqr x) as Hs.
 apply sqrt_eq_0 in H; lra.

 assert (Hca : ∀ x, 0 < cos (atan x)).
  intros y.
  specialize (atan_bound y) as (Hlta, Halt).
  apply cos_gt_0; [ lra | easy ].

  apply Rmult_eq_reg_r with (r := √ (1 + x²)); [ | easy ].
  rewrite <- Rinv_div, Rinv_l; [ | easy ].
  remember (atan x) as y eqn:Hy.
  assert (Hx : x = tan y) by (now subst y; rewrite atan_right_inv).
  subst x.
  specialize (Hca (tan y)); rewrite <- Hy in Hca.
  unfold tan.
  rewrite Rsqr_div; [ | lra ].
  replace (cos y) with (√ (cos y)²) at 1 by (apply sqrt_Rsqr; lra).
  rewrite <- sqrt_mult_alt; [ | apply Rle_0_sqr ].
  rewrite Rmult_plus_distr_l, Rmult_1_r.
  rewrite Rmult_div_r; [ | intros H; apply Rsqr_eq_0 in H; lra ].
  rewrite Rplus_comm, sin2_cos2.
  apply sqrt_1.
Qed.

Theorem sin_atan : ∀ x, sin (atan x) = x / √ (1 + x²).
Proof.
intros.
unfold Rdiv.
rewrite Rinv_div, <- cos_atan.
remember (atan x) as y eqn:Hy.
assert (Hx : x = tan y) by (now subst y; rewrite atan_right_inv).
subst x; unfold tan.
rewrite <- Rmult_div.
unfold Rdiv; rewrite Rmult_assoc.
rewrite Rinv_r; [ lra | ].
intros H; rewrite Hy in H.
rewrite cos_atan in H.
unfold Rdiv in H.
apply Rmult_integral in H.
destruct H; [ lra | ].
apply Rinv_neq_0_compat in H; [ easy | ].
clear H; intros H.
apply sqrt_eq_0 in H.
 enough (Ht : 0 ≤ (tan y)²) by lra.
 apply Rle_0_sqr.

 replace 1 with (1 ^ 2) by lra.
 rewrite <- Rsqr_pow2.
 apply nonneg_plus_sqr.
Qed.

Theorem sin_cos_asin : ∀ x,
  -1 ≤ x ≤ 1
  → sin (asin x) = x ∧ cos (asin x) = √ (1 - x²).
Proof.
intros * Hx.
unfold asin.
unfold atan'.
destruct (Req_dec (√ (1 - x²)) 0) as [Hsx| Hsx].
 rewrite Hsx.
 unfold Rsign, Rsignp.
 destruct (Req_dec x 0) as [Hxz| Hxz].
  rewrite Hxz in Hsx.
  rewrite Rsqr_0, Rminus_0_r, sqrt_1 in Hsx; lra.

  destruct (Rle_dec 0 x) as [Hxp| Hxn].
   rewrite Rmult_1_l.
   rewrite sin_PI2, cos_PI2.
   split; [ | easy ].
   symmetry.
   apply sqrt_diff_sqr_eq_0; [ lra | now rewrite Rsqr_1 ].

   unfold IZR at 1 3; rewrite <- INR_IPR; simpl.

   rewrite <- Ropp_mult_distr_l, Rmult_1_l, Ropp_div.
   rewrite sin_neg, cos_neg.
   rewrite sin_PI2, cos_PI2.
   split; [ | easy ].
   rewrite <- Ropp_involutive.
   f_equal; symmetry.
   apply sqrt_diff_sqr_eq_0; [ lra | ].
   now rewrite Rsqr_1, <- Rsqr_neg.

 assert (Hx' : -1 < x < 1).
  apply Rabs_lt, Rnot_le_lt.
  intros Ha; apply Hsx; clear Hsx.
  apply Rsqr_inj; [ apply sqrt_pos | lra | ].
  rewrite Rsqr_0; unfold Rabs in Ha.
  destruct (Rcase_abs x) as [Hc| Hc].
   assert (x = -1) by lra; subst x.

   unfold IZR; rewrite <- INR_IPR; simpl.

   rewrite <- Rsqr_neg, Rsqr_1, Rminus_diag_eq; [ | easy ].
   now rewrite sqrt_0, Rsqr_0.

   assert (x = 1) by lra; subst x.
   rewrite Rsqr_1, Rminus_diag_eq; [ | easy ].
   now rewrite sqrt_0, Rsqr_0.

  clear Hx; rename Hx' into Hx; move Hx before x.
  remember (x / √ (1 - x²)) as y eqn:Hy.
  rewrite sin_atan, cos_atan.
  destruct (Req_dec x 0) as [Hxz| Hxz].
   subst x; rewrite Rdiv_0_l in Hy; subst y.
   split; [ now rewrite Rdiv_0_l | ].
   now rewrite Rsqr_0, Rplus_0_r, Rminus_0_r, sqrt_1, Rdiv_1_r.

   assert (H1x : 0 < 1 - x²).
    replace 1 with 1² by apply Rsqr_1.
    rewrite <- Rsqr_plus_minus.
    apply Rmult_lt_0_compat; lra.

    assert (Hsp : 0 < √ (1 - x²)).
     apply Rsqr_incrst_0; [ | lra | apply sqrt_pos ].
     rewrite Rsqr_sqrt; [ now rewrite Rsqr_0 | lra ].

     assert (Hyz : y ≠ 0).
      intros H; apply Hxz; subst y.
      apply Rmult_eq_compat_r with (r := √ (1 - x²)) in H.
      unfold Rdiv in H; rewrite Rmult_assoc, Rmult_0_l in H.
      rewrite Rinv_l in H; lra.

      assert (Hxy : 0 ≤ x * y).
       subst y; unfold Rdiv; rewrite <- Rmult_assoc.
       rewrite fold_Rsqr.
       apply Rmult_le_pos; [ apply Rle_0_sqr | ].
       apply Rmult_le_reg_r with (r := √ (1 - x²)); [ lra | ].
       rewrite Rmult_0_l, Rinv_l; lra.

       apply (f_equal Rsqr) in Hy.
       rewrite Rsqr_div in Hy; [ | lra ].
       rewrite Rsqr_sqrt in Hy; [ | lra ].
       apply Rmult_eq_compat_r with (r := 1 - x²) in Hy.
       unfold Rdiv in Hy; rewrite Rmult_assoc in Hy.
       rewrite Rinv_l in Hy; [ rewrite Rmult_1_r in Hy | lra ].
       rewrite Rmult_minus_distr_l, Rmult_1_r in Hy.
       assert (H : y² = x² * (1 + y²)) by lra.
       apply Rmult_eq_compat_r with (r := / (1 + y²)) in H.
       rewrite Rmult_assoc in H.
       assert (H1y : 0 < 1 + y²).
        apply Rplus_lt_le_0_compat; [ lra | apply Rle_0_sqr ].

        assert (Hsy : 0 < √ (1 + y²)).
         apply Rsqr_incrst_0; [ | lra | apply sqrt_pos ].
         rewrite Rsqr_sqrt; [ now rewrite Rsqr_0 | lra ].

         rewrite Rinv_r in H; [ | lra ].
         replace (/ (1 + y²)) with (/ √ (1 + y²))² in H.
          rewrite <- Rsqr_mult in H.
          rewrite Rmult_1_r in H.
          apply Rsqr_eq in H.
          split.
           destruct H as [H| H]; [ easy | exfalso ].
           apply Ropp_eq_compat in H.
           rewrite Ropp_involutive in H.
           rewrite <- H in Hxy.
           rewrite <- Ropp_mult_distr_l in Hxy.
           rewrite Rmult_comm, <- Rmult_assoc, fold_Rsqr in Hxy.
           replace 0 with (-0) in Hxy by apply Ropp_0.
           apply Ropp_le_cancel in Hxy.
           apply Rmult_le_compat_r with (r := √ (1 + y²)) in Hxy; [ | lra ].
           rewrite Rmult_assoc, Rmult_0_l in Hxy.
           rewrite Rinv_l in Hxy; [ | lra ].
           rewrite Rmult_1_r in Hxy.
           apply Rle_not_lt in Hxy; apply Hxy.
           now apply Rlt_0_sqr.

           apply Rmult_eq_reg_r with (r := √ (1 + y²)); [ | lra ].
           rewrite <- Rinv_div.
           rewrite Rinv_l; [ | lra ].
           symmetry.
           rewrite <- sqrt_mult; [ | lra | lra ].
           rewrite Rmult_plus_distr_l, Rmult_1_r.
           rewrite Rmult_minus_distr_r, Rmult_1_l.
           rewrite Rmult_comm, Hy.
           now rewrite Rminus_plus, sqrt_1.

          rewrite Rsqr_inv; [ | lra ].
          rewrite Rsqr_sqrt; [ easy | lra ].
Qed.

Theorem cos_sin_acos : ∀ x,
  -1 ≤ x ≤ 1
  → cos (acos x) = x ∧ sin (acos x) = √ (1 - x²).
Proof.
intros * Hx.
unfold acos.
rewrite cos_minus, sin_minus.
rewrite cos_PI2, sin_PI2.
do 2 rewrite Rmult_0_l, Rmult_1_l.
rewrite Rplus_0_l, Rminus_0_r.
now apply sin_cos_asin.
Qed.

Theorem sin_asin : ∀ x, -1 ≤ x ≤ 1 → sin (asin x) = x.
Proof.
intros * Hx.
now apply sin_cos_asin.
Qed.

Theorem sin_acos : ∀ x, -1 ≤ x ≤ 1 → sin (acos x) = √ (1 - x²).
Proof.
intros * Hx.
now apply cos_sin_acos.
Qed.

Theorem cos_asin : ∀ x, -1 ≤ x ≤ 1 → cos (asin x) = √ (1 - x²).
Proof.
intros * Hx.
now apply sin_cos_asin.
Qed.

Theorem cos_acos : ∀ x, -1 ≤ x ≤ 1 → cos (acos x) = x.
Proof.
intros * Hx.
unfold acos; rewrite cos_shift.
now apply sin_asin.
Qed.

Theorem sin_Zperiod : ∀ x k, sin (x + 2 * IZR k * PI) = sin x.
Proof.
intros.
destruct k as [| k| k].
 now rewrite Rmult_0_r, Rmult_0_l, Rplus_0_r.

 set (t := 2); unfold IZR; rewrite <- INR_IPR.

 now simpl; rewrite sin_period.

 set (t := 2); unfold IZR; rewrite <- INR_IPR.

 simpl; rewrite <- Ropp_mult_distr_r, <- Ropp_mult_distr_l, fold_Rminus.
 rewrite <- sin_period with (k := Pos.to_nat k).
 now rewrite Rminus_plus.
Qed.

Theorem cos_Zperiod : ∀ x k, cos (x + 2 * IZR k * PI) = cos x.
Proof.
intros.
destruct k as [| k| k].
 now rewrite Rmult_0_r, Rmult_0_l, Rplus_0_r.

 set (t := 2); unfold IZR; rewrite <- INR_IPR.

 now simpl; rewrite cos_period.

 set (t := 2); unfold IZR; rewrite <- INR_IPR.

 simpl; rewrite <- Ropp_mult_distr_r, <- Ropp_mult_distr_l, fold_Rminus.
 rewrite <- cos_period with (k := Pos.to_nat k).
 now rewrite Rminus_plus.
Qed.

Theorem sin_nPI : ∀ n, sin (INR n * PI) = 0.
Proof.
intros.
induction n; [ rewrite Rmult_0_l; apply sin_0 | ].
rewrite S_INR, Rmult_plus_distr_r, Rmult_1_l, neg_sin; lra.
Qed.

Theorem cos_nPI : ∀ n, cos (INR n * PI) = (-1) ^ n.
Proof.
intros.
induction n; [ now rewrite Rmult_0_l, cos_0 | ].
rewrite S_INR, Rmult_plus_distr_r, Rmult_1_l, neg_cos, IHn.
simpl; lra.
Qed.

Theorem sin_ZPI : ∀ z, sin (IZR z * PI) = 0.
Proof.
intros.
destruct z as [| z| z]; simpl; [ now rewrite Rmult_0_l, sin_0 | | ].

 unfold IZR; rewrite <- INR_IPR.

 now rewrite sin_nPI.

 unfold IZR; rewrite <- INR_IPR.

 rewrite <- Ropp_mult_distr_l.
 rewrite sin_neg, sin_nPI; lra.
Qed.

Theorem cos_ZPI : ∀ z, cos (IZR z * PI) = (-1) ^ Z.abs_nat z.
Proof.
intros.
destruct z as [| z| z]; simpl; [ now rewrite Rmult_0_l, cos_0 | | ].

 unfold IZR; rewrite <- INR_IPR.

 now rewrite cos_nPI.

 unfold IZR; rewrite <- INR_IPR.

 rewrite <- Ropp_mult_distr_l.
 now rewrite cos_neg, cos_nPI.
Qed.

Theorem tan_period : ∀ x k, cos x ≠ 0 → tan (x + INR k * PI) = tan x.
Proof.
intros * Hcz.
destruct (eq_nat_dec (k mod 2) 0) as [Hk| Hk].
 apply Nat.mod_divides in Hk; [ | easy ].
 destruct Hk as (c, Hc); subst k.
 rewrite mult_INR; simpl.
 unfold tan.
 now rewrite sin_period, cos_period.

 destruct k; [ easy | ].
 rewrite S_INR.
 rewrite Rmult_plus_distr_r.
 rewrite Rmult_1_l, <- Rplus_assoc.
 unfold tan.
 rewrite neg_sin, neg_cos.
 rewrite sin_plus, cos_plus.
 rewrite sin_nPI, cos_nPI.
 do 2 rewrite Rmult_0_r.
 rewrite Rplus_0_r, Rminus_0_r.
 do 2 rewrite Ropp_mult_distr_r.
 rewrite Rdiv_mult_simpl_r; [ easy | easy | ].
 clear; induction k; simpl; lra.
Qed.

Theorem tan_Zperiod : ∀ x k, cos x ≠ 0 → tan (x + IZR k * PI) = tan x.
Proof.
intros * Hcz.
destruct (Z.eq_dec (k mod 2) 0) as [Hk| Hk].
 apply Zdiv.Zmod_divides in Hk; [ | easy ].
 destruct Hk as (c, Hc); subst k.
 rewrite mult_IZR; simpl.
 unfold tan.
 now rewrite sin_Zperiod, cos_Zperiod.
 destruct k as [| k| k]; [ easy | | ].
  now unfold IZR; rewrite <- INR_IPR; apply tan_period.
  unfold IZR; rewrite <- INR_IPR.
  simpl; rewrite <- Ropp_mult_distr_l, fold_Rminus.
  rewrite <- tan_period with (k := Pos.to_nat k).
   now rewrite Rminus_plus.

   rewrite cos_minus.
   rewrite cos_nPI, sin_nPI, Rmult_0_r, Rplus_0_r.
   intros H.
   apply Rmult_integral in H.
   destruct H as [H| H]; [ easy | ].
   apply pow_nonzero in H; [ easy | lra ].

Qed.

Theorem tan_ZPI : ∀ k, tan (IZR k * PI) = 0.
Proof.
intros.
assert (Hc : cos 0 ≠ 0) by (rewrite cos_0; lra).
specialize (tan_Zperiod 0 k Hc) as H.
now rewrite Rplus_0_l, tan_0 in H.
Qed.

Theorem neg_cos_atan_tan : ∀ x,
  cos x < 0
  → atan (tan x) = x - IZR ((x + PI / 2) // PI) * PI.
Proof.
intros * Hc.
unfold atan.
destruct (pre_atan (tan x)) as (y & Hy & Hyx).
remember ((x + PI / 2) rmod PI - PI / 2) as z eqn:Hz.
assert (Htz : tan z = tan x).
 subst z.
 unfold Rmod, Rediv_mod, snd.
 destruct (Rcase_abs PI) as [HP| HP]; [ lra | ].
 remember (IZR (Int_part ((x + PI / 2) / PI)) * PI) as t eqn:Ht.
 replace (x + PI / 2 - t - PI / 2) with (x - t) by lra.
 rewrite tan_minus; [ | lra | | | ].
  subst t; rewrite tan_ZPI.
  now rewrite Rminus_0_r, Rmult_0_r, Rplus_0_r, Rdiv_1_r.

  subst t.
  rewrite cos_ZPI.
  apply pow_nonzero; lra.

  subst t.
  rewrite cos_minus.
  rewrite cos_ZPI, sin_ZPI.
  rewrite Rmult_0_r, Rplus_0_r.
  intros H.
  apply Rmult_integral in H.
  destruct H as [H| H]; [ lra | ].
  apply pow_nonzero in H; lra.

  subst t.
  rewrite tan_ZPI, Rmult_0_r, Rplus_0_r; lra.

 assert (Hzi : - PI / 2 < z < PI / 2).
  rewrite Hz.
  assert (HPP : 0 < PI) by lra.
  specialize (Rmod_interv (x + PI / 2) PI HPP) as H.
  split; [ | lra ].
  enough ((x + PI / 2) rmod PI ≠ 0) by lra.
  intros Hm.
  unfold Rmod, Rediv_mod, snd in Hm.
  destruct (Rcase_abs PI) as [HPQ| HPQ]; [ lra | ].
  fold (Int_part ((x + PI / 2) / PI)) in Hm.
  apply Rminus_diag_uniq in Hm.
  remember (Int_part ((x + PI / 2) / PI)) as k.
  assert (x = IZR k * PI - PI / 2) by lra.
  rewrite H0 in Hc.
  rewrite cos_minus in Hc.
  rewrite cos_ZPI, sin_ZPI in Hc.
  rewrite Rmult_0_l, Rplus_0_r in Hc.
  rewrite cos_PI2, Rmult_0_r in Hc; lra.

  rewrite <- Htz in Hyx.
  specialize (tan_is_inj y z Hy Hzi Hyx) as H.
  move H at top; subst z.
  rewrite Rmod_from_ediv in Hz; lra.
Qed.

Theorem pos_cos_atan_tan : ∀ x,
  0 < cos x
  → atan (tan x) = x - IZR ((x + PI / 2) // PI) * PI.
Proof.
intros * Hc.
assert (Hcp : cos (x + PI) < 0) by (rewrite neg_cos; lra).
specialize (neg_cos_atan_tan (x + PI) Hcp) as H.
assert (Hcz : cos x ≠ 0) by lra.
specialize (tan_period x 1 Hcz) as Ht.
simpl (INR _) in Ht.
rewrite Rmult_1_l in Ht.
rewrite Rplus_shuffle0 in H.
rewrite Rediv_add_1 in H; [ | apply PI_neq0 ].
rewrite plus_IZR in H.
simpl (IZR _) in H.
rewrite Ht in H; lra.
Qed.

Theorem atan_tan : ∀ x,
  cos x ≠ 0
  → atan (tan x) = x - IZR ((x + PI / 2) // PI) * PI.
Proof.
intros * Hxz.
destruct (Rlt_dec (cos x) 0) as [Hx| Hx].
 now apply neg_cos_atan_tan.

 apply pos_cos_atan_tan; lra.
Qed.

Theorem asin_sin : ∀ x,
  asin (sin x) = Rsignp (cos x) * atan' (sin x) (cos x).
Proof.
intros.
unfold asin, atan'.
rewrite <- cos2.
rewrite sqrt_Rsqr_abs.
destruct (Req_dec (cos x) 0) as [Haz| Haz].
 rewrite Haz, Rabs_R0.
 rewrite Rsignp_of_pos; [ | lra ].
 destruct (Req_dec 0 0); lra.

 destruct (Req_dec (Rabs (cos x))) as [Hab| Hab].
  now apply Rabs_eq_0 in Hab.

  unfold Rabs.
  destruct (Rcase_abs (cos x)) as [Ha| Ha].
   unfold Rdiv.
   rewrite Rsignp_of_neg; [ | easy ].
   destruct (Rle_dec 0 (cos x)); [ lra | ].
   rewrite <- Ropp_inv_permute; [ | lra ].
   rewrite <- Ropp_mult_distr_r.
   rewrite fold_Rdiv.
   fold (tan x); rewrite atan_opp; lra.

   rewrite Rsignp_of_pos; lra.
Qed.

Theorem cos_plus_PI2 : ∀ x, cos (x + PI / 2) = - sin x.
Proof.
intros.
rewrite cos_plus, cos_PI2, sin_PI2; lra.
Qed.

Theorem asin_cos : ∀ x,
  asin (cos x) =
   if Req_dec (sin x) 0 then Rsign (cos x) * PI / 2
   else - Rsign (sin x) * atan (tan (x + PI / 2)).
Proof.
intros.
rewrite cos_sin, asin_sin.
rewrite Rplus_comm.
unfold atan'.
fold (tan (x + PI / 2)).
rewrite cos_plus_PI2.
unfold Rsignp.
destruct (Req_dec (- sin x) 0) as [H1| H1].
 rewrite H1.
 apply (f_equal Ropp) in H1.
 rewrite Ropp_involutive, Ropp_0 in H1.
 rewrite H1.
 destruct (Rle_dec 0 0) as [H| H]; [ clear H | lra ].
 destruct (Req_dec 0 0); lra.

 destruct (Req_dec (sin x) 0) as [Hs| Hs]; [ lra | clear H1 ].
 destruct (Rle_dec 0 (- sin x)) as [H1| H1].
  rewrite Rsign_of_neg; lra.
  rewrite Rsign_of_pos; lra.
Qed.

Theorem acos_cos : ∀ x, acos (cos x) = PI / 2 - asin (cos x).
Proof. easy. Qed.

Theorem nonneg_sin_interv : ∀ x, 0 ≤ sin x → x rmod (2 * PI) ≤ PI.
Proof.
intros * Hs.
apply Rnot_lt_le; intros Hx.
apply Rle_not_lt in Hs; apply Hs; clear Hs.
enough (H : sin (x rmod (2 * PI)) < 0).
 rewrite Rmod_from_ediv in H.
 unfold Rminus in H.
 rewrite Ropp_mult_distr_l in H.
 rewrite <- opp_IZR in H.
 rewrite Rmult_comm, Rmult_shuffle0 in H.
 now rewrite sin_Zperiod in H.

 apply sin_lt_0; [ easy | ].
 assert (HP : 0 < 2 * PI) by (specialize PI_RGT_0; lra).
 specialize (Rmod_interv x (2 * PI) HP) as H; lra.
Qed.

Theorem pos_sin_interv : ∀ x, 0 < sin x → x rmod (2 * PI) < PI.
Proof.
intros * Hs.
apply Rnot_le_lt; intros Hx.
apply Rlt_not_le in Hs; apply Hs; clear Hs.
enough (H : sin (x rmod (2 * PI)) ≤ 0).
 rewrite Rmod_from_ediv in H.
 unfold Rminus in H.
 rewrite Ropp_mult_distr_l in H.
 rewrite <- opp_IZR in H.
 rewrite Rmult_comm, Rmult_shuffle0 in H.
 now rewrite sin_Zperiod in H.

 apply sin_le_0; [ easy | ].
 assert (HP : 0 < 2 * PI) by (specialize PI_RGT_0; lra).
 specialize (Rmod_interv x (2 * PI) HP) as H; lra.
Qed.

Theorem neg_sin_interv : ∀ x, sin x < 0 → PI < x rmod (2 * PI).
Proof.
intros * Hs.
apply Rnot_le_lt; intros Hx.
apply Rlt_not_le in Hs; apply Hs; clear Hs.
enough (H : 0 ≤ sin (x rmod (2 * PI))).
 rewrite Rmod_from_ediv in H.
 unfold Rminus in H.
 rewrite Ropp_mult_distr_l in H.
 rewrite <- opp_IZR in H.
 rewrite Rmult_comm, Rmult_shuffle0 in H.
 now rewrite sin_Zperiod in H.

 apply sin_ge_0; [ | easy ].
 assert (HP : 0 < 2 * PI) by (specialize PI_RGT_0; lra).
 specialize (Rmod_interv x (2 * PI) HP) as H; lra.
Qed.

Theorem pos_cos_interv : ∀ x,
  0 < cos x
  → x rmod (2 * PI) < PI / 2 ∨ 3 * PI / 2 < x rmod (2 * PI) .
Proof.
intros * Hc.
destruct (Rlt_dec (x rmod (2 * PI)) (PI / 2)) as [Hx| Hx]; [ now left | ].
right.
apply Rlt_not_le in Hc.
apply Rnot_lt_le in Hx.
apply Rnot_le_lt; intros H.
apply Hc; clear Hc.
rewrite Rmod_from_ediv in Hx, H.
remember (x // (2 * PI)) as k eqn:Hk.
rewrite <- cos_Zperiod with (k := (- k)%Z).
apply cos_le_0; rewrite opp_IZR; lra.
Qed.

Theorem neg_cos_interv : ∀ x,
  cos x < 0
  → PI / 2 < x rmod (2 * PI) < 3 * PI / 2.
Proof.
intros * Hc.
split.
 apply Rnot_le_lt; intros Hx.
 apply Rlt_not_le in Hc; apply Hc; clear Hc.
 enough (H : 0 ≤ cos (x rmod (2 * PI))).
  rewrite Rmod_from_ediv in H.
  unfold Rminus in H.
  rewrite Ropp_mult_distr_l in H.
  rewrite <- opp_IZR in H.
  rewrite Rmult_comm, Rmult_shuffle0 in H.
  now rewrite cos_Zperiod in H.

  apply cos_ge_0; [ | easy ].
  assert (HP : - (PI / 2) ≤ 0) by (specialize PI_RGT_0; lra).
  eapply Rle_trans; [ apply HP | ].
  apply Rmod_interv.
  specialize PI_RGT_0; lra.

 apply Rnot_le_lt; intros Hx.
 apply Rlt_not_le in Hc; apply Hc; clear Hc.
 enough (H : 0 ≤ cos (x rmod (2 * PI))).
  rewrite Rmod_from_ediv in H.
  unfold Rminus in H.
  rewrite Ropp_mult_distr_l in H.
  rewrite <- opp_IZR in H.
  rewrite Rmult_comm, Rmult_shuffle0 in H.
  now rewrite cos_Zperiod in H.

  apply cos_ge_0_3PI2; [ lra | ].
  apply Rlt_le, Rmod_interv.
  specialize PI_RGT_0; lra.
Qed.

Theorem neg_sin_neg_cos_2PI_acos_cos : ∀ x,
  sin x < 0
  → cos x < 0
  → 2 * PI - acos (cos x) = x rmod (2 * PI).
Proof.
intros * Hs Hc.
specialize PI_RGT_0 as HPI_GT_0.
specialize PI_neq0 as HPI_NZ.
rewrite acos_cos, asin_cos.
destruct (Req_dec (sin x) 0) as [| H]; [ lra | clear H ].
rewrite <- Ropp_mult_distr_l, Rminus_opp.
rewrite Rsign_of_neg; [ | easy ].

set (t := 2); unfold IZR; rewrite <- INR_IPR.

rewrite <- Ropp_mult_distr_l, Rmult_1_l.
rewrite fold_Rminus.
rewrite atan_tan; [ | rewrite cos_plus_PI2; lra ].

subst t.

progress replace (x + PI / 2 + PI / 2) with (x + PI) by lra.
rewrite Rediv_add_1; [ | apply PI_neq0 ].
rewrite Rmod_from_ediv.
rewrite plus_IZR; simpl (IZR 1).
remember (IZR (x // PI)) as e eqn:He.
replace ( 2 * PI - (PI / 2 - (x + PI / 2 - (e + 1) * PI))) with
  (x - (e - 1) * PI) by lra; subst e.
rewrite <- Rmult_assoc.
f_equal; f_equal.
enough (IZR (x // PI) = 2 * IZR (x // (2 * PI)) + 1) by lra.
apply neg_sin_interv in Hs.
apply neg_cos_interv in Hc.
rewrite Rmod_from_ediv in Hs, Hc.
remember (x // (2 * PI)) as k eqn:Hk.
replace (IZR k * (2 * PI)) with (2 * IZR k * PI) in Hs, Hc by lra.
assert (Hp : PI < x - 2 * IZR k * PI < 3 * PI / 2) by lra.
clear Hs Hc.
rewrite Rediv_mul_r in Hk.
destruct (Rcase_abs (2 * PI)) as [HP| HP]; [ lra | clear HP ].
rewrite Z.add_0_r in Hk.
unfold Rediv, fst, Rediv_mod.
destruct (Rcase_abs PI) as [HP| HP]; [ lra | clear HP ].
rewrite Rmult_comm in Hk.
rewrite <- Rdiv_div in Hk; [ | lra | lra ].
remember (x / PI) as y eqn:Hy.
apply Rmult_eq_compat_r with (r := PI) in Hy.
rewrite Rmult_div_same in Hy; [ | lra ].
subst x; rename y into x.
enough (IZR (Int_part x) = IZR 2 * IZR k + IZR 1) by lra.
rewrite <- mult_IZR, <- plus_IZR; f_equal.
apply Int_part_interv.
do 3 rewrite plus_IZR; rewrite mult_IZR; simpl.
rewrite <- Rmult_minus_distr_r in Hp.
destruct Hp as (H1, H2).
replace PI with (1 * PI) in H1 at 1 by lra.
apply Rmult_lt_reg_r in H1; [ | lra ].
replace (3 * PI / 2) with ((3 / 2) * PI) in H2 by lra.
apply Rmult_lt_reg_r in H2; lra.
Qed.

Theorem neg_sin_pos_cos_asin_sin_2PI : ∀ x,
  sin x < 0
  → 0 ≤ cos x
  → asin (sin x) + 2 * PI = x rmod (2 * PI).
Proof.
intros * Hs Hc.
specialize PI_RGT_0 as HPI_GT_0.
specialize PI_neq0 as HPI_NZ.
destruct (Rlt_dec (sin x) 0) as [H| ]; [ clear H | lra ].
destruct (Rlt_dec (cos x) 0) as [| H]; [ lra | clear H ].
rewrite asin_sin.
rewrite Rsignp_of_pos; [ rewrite Rmult_1_l | easy ].
unfold atan'.
destruct (Req_dec (cos x) 0) as [Hcz| Hcz].
 rewrite Rsign_of_neg; [ | easy ].

 set (t := 2); unfold IZR; rewrite <- INR_IPR.

 rewrite <- Ropp_mult_distr_l, Rmult_1_l.
 apply cos_eq_0_0 in Hcz.
 destruct Hcz as (k, Hx).
 apply neg_sin_interv in Hs.
 destruct (Bool.bool_dec (Z.even k) true) as [Hk| Hk].
  exfalso.
  apply Zeven_bool_iff, Zeven_ex_iff in Hk.
  destruct Hk as (m, Hm).
  rewrite Hm in Hx; rewrite Hx in Hs.
  rewrite mult_IZR in Hs; simpl in Hs.
  replace (2 * IZR m * PI) with (IZR m * (2 * PI)) in Hs by lra.
  rewrite Rplus_comm in Hs.
  rewrite Rmod_add_Z in Hs; [ | lra ].
  rewrite Rmod_small in Hs; lra.

  rewrite <- Z.negb_odd in Hk.
  apply Bool.not_true_iff_false in Hk.
  apply Bool.negb_false_iff in Hk.
  apply Zodd_bool_iff, Zodd_ex_iff in Hk.
  destruct Hk as (m, Hm).
  rewrite Hx, Hm.
  rewrite plus_IZR, mult_IZR; simpl.
  progress replace ((2 * IZR m + 1) * PI + PI / 2) with
    (3 * PI / 2 + IZR m * (2 * PI)) by lra.

  subst t.

  rewrite Rmod_add_Z; [ | lra ].
  rewrite Rmod_small; lra.

 fold (tan x).
 rewrite atan_tan; [ | easy ].
 assert (H : 0 < cos x) by lra.
 clear Hc Hcz; rename H into Hc.
 apply neg_sin_interv in Hs.
 apply pos_cos_interv in Hc.
 destruct Hc as [Hc| Hc]; [ lra | clear Hs ].
 remember (IZR ((x + PI / 2) // PI) * PI) as u eqn:Hu.
 replace (x - u + 2 * PI) with (x + PI / 2 - u + 3 * PI / 2) by lra.
 subst u; rewrite <- Rmod_from_ediv.
 rewrite Rplus_comm; symmetry.
 unfold Rmod, snd, Rediv_mod.
 destruct (Rcase_abs (2 * PI)) as [| H]; [ lra | clear H ].
 destruct (Rcase_abs PI) as [| H]; [ lra | clear H ].
 remember (IZR (Int_part ((x + PI / 2) / PI)) * PI) as u eqn:Hu.
 replace (3 * PI / 2 + (x + PI / 2 - u)) with (x - (u - 2 * PI)) by lra.
 subst u; unfold Rminus.
 f_equal; rewrite fold_Rminus.
 apply Ropp_eq_compat.
 rewrite <- Rmult_minus_distr_r.
 replace 2 with (IZR 2) at 4 by easy.
 rewrite <- minus_IZR.
 rewrite <- Rmult_assoc.
 f_equal.
 replace ((x + PI / 2) / PI) with ((2 * x + PI) / (2 * PI)).
  rewrite Rdiv_plus_distr.
  rewrite Rdiv_mult_simpl_l; [ | lra | lra ].
  replace PI with (1 * PI) at 3 by lra.
  rewrite Rdiv_mult_simpl_r; [ | lra | lra ].
  unfold Rmod, snd, Rediv_mod in Hc.
  destruct (Rcase_abs (2 * PI)) as [| H]; [ lra | clear H ].
  replace (2 * PI) with (PI * 2) in Hc at 1 by lra.
  replace (2 * PI) with (PI * 2) by lra.
  rewrite <- Rdiv_div in Hc; [ | lra | lra ].
  rewrite <- Rdiv_div; [ | lra | lra ].
  remember (x / PI) as y eqn:Hy.
  replace x with (y * PI) in Hc by (subst y; rewrite Rmult_div_same; lra).
  clear x Hy; rename y into x.
  replace (3 * PI / 2) with ((3 / 2) * PI) in Hc by lra.
  rewrite <- Rmult_assoc in Hc.
  rewrite <- Rmult_minus_distr_r in Hc.
  apply Rmult_lt_reg_r in Hc; [ | easy ].
  replace x with ((x / 2) * 2) in Hc at 1 by lra.
  rewrite <- Rmult_minus_distr_r in Hc.
  fold (frac_part (x / 2)) in Hc.
  remember (x / 2) as y eqn:Hy.
  replace x with (2 * y) by lra.
  clear x Hy; rename y into x.
  assert (Hx34 : 3 / 4 < frac_part x) by lra; clear Hc.
  destruct (Rlt_dec (frac_part (2 * x)) (1 / 2)) as [Hx12| Hx12].
   exfalso.
   rewrite frac_part_double in Hx12.
   destruct (Rlt_dec (frac_part x) (1 / 2)); lra.

   assert (H : frac_part (1 / 2) = 1 / 2) by (apply frac_part_small; lra).
   rewrite plus_Int_part1; [ clear H | lra ].
   rewrite frac_part_double in Hx12; rewrite Int_part_double.
   destruct (Rlt_dec (frac_part x) (1 / 2)) as [| H]; [ lra | clear H ].
   replace 2 with (IZR 2) at 1 by lra.
   rewrite <- mult_IZR; f_equal.
   enough (Int_part (1 / 2) = 0%Z) by lia.
   apply Int_part_small; lra.

  do 2 rewrite Rdiv_plus_distr.
  rewrite Rdiv_mult_simpl_l; [ | lra | lra ].
  f_equal.
  rewrite Rdiv_div; [ easy | lra | lra ].
Qed.

Theorem pos_sin_neg_cos_acos_cos : ∀ x,
  0 ≤ sin x
  → cos x < 0
  → acos (cos x) = x rmod (2 * PI).
Proof.
intros * Hs Hc.
specialize PI_RGT_0 as HPI_GT_0.
specialize PI_neq0 as HPI_NZ.
rewrite acos_cos, asin_cos.
destruct (Req_dec (sin x) 0) as [Hsz| Hsnz].
 specialize (sin_eq_0_0 _ Hsz) as (k, Hk); subst x.
 rewrite cos_ZPI.
 destruct (Bool.bool_dec (Z.even k) true) as [Hk| Hk].
  apply Zeven_bool_iff, Zeven_ex_iff in Hk.
  destruct Hk as (m, Hm).
  rewrite Hm; rewrite Zabs2Nat.inj_mul.
  simpl (Z.abs_nat 2); unfold Pos.to_nat; simpl (Pos.iter_op _ _ _).
  rewrite pow_1_even; rewrite Rsign_of_pos; [ | lra ].
  rewrite Rmult_1_l, mult_IZR; simpl (IZR 2).
  rewrite Rmult_shuffle0, Rmult_comm.
  rewrite Rmod_mul_same; lra.

  rewrite <- Z.negb_odd in Hk.
  apply Bool.not_true_iff_false in Hk.
  apply Bool.negb_false_iff in Hk.
  apply Zodd_bool_iff, Zodd_ex_iff in Hk.
  destruct Hk as (m, Hk).
  rewrite Hk at 1.
  rewrite pow_1_abs_nat_odd.
  rewrite Rsign_of_neg; [ | lra ].
  rewrite Z.add_comm, Z.mul_comm in Hk.
  rewrite Hk, plus_IZR, mult_IZR; simpl.
  rewrite Rmult_plus_distr_r, Rmult_1_l, Rmult_assoc.
  rewrite Rmod_add_Z; [ | lra ].
  rewrite Rmod_small; lra.

 assert (H : 0 < sin x) by lra; clear Hs Hsnz; rename H into Hs.
 move Hs after Hc.

 rewrite <- Ropp_mult_distr_l.
 rewrite Rminus_opp.

 rewrite Rsign_of_pos; [ | easy ].

 rewrite Rmult_1_l.

 rewrite atan_tan; [ | rewrite cos_plus_PI2; lra ].
 replace (x + PI / 2 + PI / 2) with (x + PI) by lra.
 rewrite Rediv_add_1; [ | apply PI_neq0 ].
 rewrite Rmod_from_ediv.
 rewrite plus_IZR; simpl (IZR 1).
 remember (IZR (x // PI)) as e eqn:He.

 replace (PI / 2 + (x + PI / 2 - (e + 1) * PI)) with (x - e * PI) by lra.

 subst e.
 rewrite <- Rmult_assoc.
 f_equal; f_equal.
 apply pos_sin_interv in Hs.
 apply neg_cos_interv in Hc.
 rewrite Rmod_from_ediv in Hs, Hc.
 remember (x // (2 * PI)) as k eqn:Hk.
 replace (IZR k * (2 * PI)) with (2 * IZR k * PI) in Hs, Hc by lra.
 assert (Hp : PI / 2 < x - 2 * IZR k * PI < PI) by lra.
 clear Hs Hc.
 rewrite Rediv_mul_r in Hk.
 destruct (Rcase_abs (2 * PI)) as [HP| HP]; [ lra | clear HP ].
 rewrite Z.add_0_r in Hk.
 unfold Rediv, fst, Rediv_mod.
 destruct (Rcase_abs PI) as [HP| HP]; [ lra | clear HP ].
 rewrite Rmult_comm in Hk.
 rewrite <- Rdiv_div in Hk; [ | lra | lra ].
 remember (x / PI) as y eqn:Hy.
 apply Rmult_eq_compat_r with (r := PI) in Hy.
 rewrite Rmult_div_same in Hy; [ | lra ].
 subst x; rename y into x.
 enough (IZR (Int_part x) = IZR 2 * IZR k) by lra.
 rewrite <- mult_IZR; f_equal.
 apply Int_part_interv.
 rewrite plus_IZR; rewrite mult_IZR; simpl.
 rewrite <- Rmult_minus_distr_r in Hp.
 destruct Hp as (H1, H2).
 replace (PI / 2) with (1 / 2 * PI) in H1 at 1 by lra.
 apply Rmult_lt_reg_r in H1; [ | lra ].
 replace PI with (1 * PI) in H2 at 2 by lra.
 apply Rmult_lt_reg_r in H2; lra.
Qed.

Theorem pos_sin_pos_cos_asin_sin : ∀ x,
  0 ≤ sin x
  → 0 ≤ cos x
  → asin (sin x) = x rmod (2 * PI).
Proof.
intros * Hs Hc.
specialize PI_RGT_0 as HPI_GT_0.
specialize PI_neq0 as HPI_NZ.
rewrite asin_sin.
rewrite Rsignp_of_pos; [ rewrite Rmult_1_l | easy ].
unfold atan'.
destruct (Req_dec (cos x) 0) as [Hcz| Hcz].
 destruct (Req_dec (sin x) 0) as [Hsz| Hsz].
  specialize (sin2_cos2 x) as H.
  rewrite Hsz, Hcz, Rsqr_0 in H; lra.

  assert (H : 0 < sin x) by lra; clear Hs Hsz; rename H into Hs.
  move Hs after Hc.
  rewrite Rsign_of_pos; [ | easy ].
  rewrite Rmult_1_l.
  apply cos_eq_0_0 in Hcz.
  destruct Hcz as (k, Hx).
  apply pos_sin_interv in Hs.
  destruct (Bool.bool_dec (Z.even k) true) as [Hk| Hk].
   apply Zeven_bool_iff, Zeven_ex_iff in Hk.
   destruct Hk as (m, Hm).
   rewrite Rplus_comm in Hx.
   rewrite Hm in Hx; rewrite Hx.
   rewrite mult_IZR; simpl.
   replace (2 * IZR m * PI) with (IZR m * (2 * PI)) by lra.
   rewrite Rmod_add_Z; [ | lra ].
   rewrite Rmod_small; lra.

   rewrite <- Z.negb_odd in Hk.
   apply Bool.not_true_iff_false in Hk.
   apply Bool.negb_false_iff in Hk.
   apply Zodd_bool_iff, Zodd_ex_iff in Hk.
   destruct Hk as (m, Hm).
   rewrite Rplus_comm in Hx.
   rewrite Z.add_comm in Hm.
   rewrite Hx, Hm in Hs.
   rewrite plus_IZR, mult_IZR in Hs; simpl in Hs.
   rewrite Rmult_plus_distr_r, Rmult_1_l in Hs.
   replace (2 * IZR m * PI) with (IZR m * (2 * PI)) in Hs by lra.
   rewrite <- Rplus_assoc in Hs.
   rewrite Rmod_add_Z in Hs; [ | lra ].
   rewrite Rmod_small in Hs; lra.

  fold (tan x).
  rewrite atan_tan; [ | easy ].
  assert (H : 0 < cos x) by lra.
  clear Hc Hcz; rename H into Hc.
  move Hc before Hs.
  apply nonneg_sin_interv in Hs.
  apply pos_cos_interv in Hc.
  destruct Hc as [Hc| Hc]; [ clear Hs | lra ].
  unfold Rediv, Rmod, fst, snd, Rediv_mod.
  destruct (Rcase_abs (2 * PI)) as [| H]; [ lra | clear H ].
  destruct (Rcase_abs PI) as [| H]; [ lra | clear H ].
  f_equal.
  replace ((x + PI / 2) / PI) with ((2 * x + PI) / (2 * PI)).
   rewrite Rdiv_plus_distr.
   rewrite Rdiv_mult_simpl_l; [ | lra | lra ].
   replace PI with (1 * PI) at 2 by lra.
   rewrite Rdiv_mult_simpl_r; [ | lra | lra ].
   unfold Rmod, snd, Rediv_mod in Hc.
   destruct (Rcase_abs (2 * PI)) as [| H]; [ lra | clear H ].
   replace (2 * PI) with (PI * 2) in Hc at 1 by lra.
   replace (2 * PI) with (PI * 2) by lra.
   rewrite <- Rdiv_div in Hc; [ | lra | lra ].
   rewrite <- Rdiv_div; [ | lra | lra ].
   remember (x / PI) as y eqn:Hy.
   replace x with (y * PI) in Hc by (subst y; rewrite Rmult_div_same; lra).
   clear x Hy; rename y into x.
   replace (PI / 2) with ((1 / 2) * PI) in Hc by lra.
   rewrite <- Rmult_assoc in Hc.
   rewrite <- Rmult_minus_distr_r in Hc.
   apply Rmult_lt_reg_r in Hc; [ | easy ].
   replace x with ((x / 2) * 2) in Hc at 1 by lra.
   rewrite <- Rmult_minus_distr_r in Hc.
   fold (frac_part (x / 2)) in Hc.
   remember (x / 2) as y eqn:Hy.
   replace x with (2 * y) by lra.
   clear x Hy; rename y into x.
   rewrite <- Rmult_assoc, Rmult_shuffle0; f_equal.
   replace 2 with (IZR 2) at 3 by lra.
   rewrite <- mult_IZR; f_equal.
   assert (Hx : frac_part x < 1 / 4) by lra; clear Hc.
   destruct (Rlt_dec (frac_part (2 * x)) (1 / 2)) as [Hx12| Hx12].
    rewrite plus_Int_part2.
     rewrite Z.add_comm.
     rewrite Int_part_small; [ | lra ].
     rewrite Z.add_0_l.
     rewrite Int_part_double.
     destruct (Rlt_dec (frac_part x) (1 / 2)); [ lia | lra ].

     rewrite Rplus_comm, frac_part_small; lra.
     rewrite frac_part_double in Hx12.

    apply Rnot_lt_le in Hx12.
    destruct (Rlt_dec (frac_part x) (1 / 2)); lra.

   do 2 rewrite Rdiv_plus_distr.
   rewrite Rdiv_mult_simpl_l; [ | lra | lra ].
   f_equal.
   rewrite Rdiv_div; [ easy | lra | lra ].
Qed.

Theorem angle_of_sin_cos_inv : ∀ x,
  angle_of_sin_cos (sin x) (cos x) = x rmod (2 * PI).
Proof.
intros.
unfold angle_of_sin_cos.
destruct (Rlt_dec (sin x) 0) as [Hs| Hs].
 destruct (Rlt_dec (cos x) 0) as [Hc| Hc].
  now apply neg_sin_neg_cos_2PI_acos_cos.

  apply Rnot_lt_le in Hc.
  now apply neg_sin_pos_cos_asin_sin_2PI.

 apply Rnot_lt_le in Hs.
 destruct (Rlt_dec (cos x) 0) as [Hc| Hc].
  now apply pos_sin_neg_cos_acos_cos.

  apply Rnot_lt_le in Hc.
  now apply pos_sin_pos_cos_asin_sin.
Qed.

Theorem pre_sin_bound : ∀ s c, s² + c² = 1 → -1 ≤ s ≤ 1.
Proof.
intros s c Hsc.
assert (H : s² ≤ 1).
 enough (H : s² + 0 ≤ 1) by lra.
 rewrite <- Hsc.
 apply Rplus_le_compat_l, Rle_0_sqr.

 rewrite <- Rsqr_1 in H.
 apply Rsqr_le_abs_0 in H.
 rewrite Rabs_R1 in H.
 now apply Rabs_le in H.
Qed.

Theorem pre_cos_bound : ∀ s c, s² + c² = 1 → -1 ≤ c ≤ 1.
Proof.
intros s c Hsc.
rewrite Rplus_comm in Hsc.
now apply pre_sin_bound in Hsc.
Qed.

Theorem sin_angle_of_sin_cos : ∀ s c,
  s² + c² = 1
  → sin (angle_of_sin_cos s c) = s.
Proof.
intros * Hsc.
unfold angle_of_sin_cos.
destruct (Rlt_dec s 0) as [Hs| Hs].
 destruct (Rlt_dec c 0) as [Hc| Hc].
  rewrite sin_minus.
  rewrite cos_2PI, sin_2PI, Rmult_1_l, Rmult_0_l, Rminus_0_l.
  rewrite sin_acos; [ | now apply pre_cos_bound in Hsc ].
  replace (1 - c²) with s² by lra.
  rewrite Rsqr_neg, <- Ropp_involutive; f_equal.
  rewrite sqrt_Rsqr; [ easy | lra ].

  rewrite sin_plus.
  rewrite cos_2PI, sin_2PI, Rmult_1_r, Rmult_0_r, Rplus_0_r.
  rewrite sin_asin; [ easy | now apply pre_sin_bound in Hsc ].

 destruct (Rlt_dec c 0) as [Hc| Hc].
  rewrite sin_acos; [ | now apply pre_cos_bound in Hsc ].
  replace (1 - c²) with s² by lra.
  rewrite sqrt_Rsqr; [ easy | lra ].

  rewrite sin_asin; [ easy | now apply pre_sin_bound in Hsc ].
Qed.

Theorem cos_angle_of_sin_cos : ∀ s c,
  s² + c² = 1
  → cos (angle_of_sin_cos s c) = c.
Proof.
intros * Hsc.
unfold angle_of_sin_cos.
destruct (Rlt_dec s 0) as [Hs| Hs].
 destruct (Rlt_dec c 0) as [Hc| Hc].
  rewrite cos_minus.
  rewrite cos_2PI, sin_2PI, Rmult_1_l, Rmult_0_l, Rplus_0_r.
  apply cos_acos.
  now apply pre_cos_bound in Hsc.

  rewrite cos_plus.
  rewrite cos_2PI, sin_2PI, Rmult_1_r, Rmult_0_r, Rminus_0_r.
  rewrite cos_asin; [ | now apply pre_sin_bound in Hsc ].
  replace (1 - s²) with c² by lra.
  apply Rnot_lt_le in Hc.
  now rewrite sqrt_Rsqr.

 destruct (Rlt_dec c 0) as [Hc| Hc].
  rewrite cos_acos; [ easy | ].
  now apply pre_cos_bound in Hsc.

  rewrite cos_asin; [ | now apply pre_sin_bound in Hsc ].
  replace (1 - s²) with c² by lra.
  apply Rnot_lt_le in Hc.
  now rewrite sqrt_Rsqr.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export Setoid_dup1.

Set Implicit Arguments.
Unset Strict Implicit.

(***  COMPOSITION OPERATOR  ***)

Section composition_to_operator'.

Variables (A : Type) (H : A -> A -> Setoid')
  (Cfun : forall a b c : A, H a b -> H b c -> H a c).

Definition Congl_law' :=
  forall (a b c : A) (f g : H b c) (h : H a b),
  f =_S' g -> Cfun h f =_S' Cfun h g.

Definition Congr_law' :=
  forall (a b c : A) (f g : H a b) (h : H b c),
  f =_S' g -> Cfun f h =_S' Cfun g h.

Definition Cong_law' :=
  forall (a b c : A) (f f' : H a b) (g g' : H b c),
  f =_S' f' -> g =_S' g' -> Cfun f g =_S' Cfun f' g'.

Hypothesis pcgl : Congl_law'.
Hypothesis pcgr : Congr_law'.

Variable a b c : A.

Definition Build_Comp' :=
  Build_Map2' (pcgl (a:=a) (b:=b) (c:=c)) (pcgr (a:=a) (b:=b) (c:=c)).

End composition_to_operator'.

(***  CATEGORY  ***)

Section cat'.

Variables (Ob' : Type) (Hom' : Ob' -> Ob' -> Setoid').

Variable
  Op_comp' : forall a b c : Ob', Map2' (Hom' a b) (Hom' b c) (Hom' a c).

Definition Cat_comp' (a b c : Ob') (f : Hom' a b) (g : Hom' b c) :=
  Op_comp' a b c f g.

Definition Assoc_law' :=
  forall (a b c d : Ob') (f : Hom' a b) (g : Hom' b c) (h : Hom' c d),
  Cat_comp' f (Cat_comp' g h) =_S' Cat_comp' (Cat_comp' f g) h.

Variable Id' : forall a : Ob', Hom' a a.

Definition Idl_law' :=
  forall (a b : Ob') (f : Hom' a b), Cat_comp' (Id' _) f =_S' f.

Definition Idr_law' :=
  forall (a b : Ob') (f : Hom' b a), f =_S' Cat_comp' f (Id' _).

End cat'.

Structure Category' : Type :=
  {Ob' :> Type;
   Hom' : Ob' -> Ob' -> Setoid';
   Op_comp' : forall a b c : Ob', Map2' (Hom' a b) (Hom' b c) (Hom' a c);
   Id' : forall a : Ob', Hom' a a;
   Prf_ass' : Assoc_law' Op_comp';
   Prf_idl' : Idl_law' Op_comp' Id';
   Prf_idr' : Idr_law' Op_comp' Id'}.

Definition Comp' (C : Category') := Cat_comp' (Op_comp' (c:=C)).

Infix "o'" := Comp' (at level 20, right associativity).


Require Export ZArith.
Require Export List.
Require Export Arith.
Require Export Zwf.
Require Export Relations.
Require Export Inverse_Image.
Require Export Transitive_Closure.
Require Export Zdiv.

Open Scope nat_scope.

(* we need to add an object in the abstract tree structure to
   represent the neutral element. *)

Inductive bin : Set :=
 | node: bin -> bin ->  bin
 | leaf: nat ->  bin
 | neutral: bin .

(* flattening is unchanged. *)

Fixpoint flatten_aux (t fin : bin) {struct t} : bin :=
 match t with
  | node t1 t2 => flatten_aux t1 (flatten_aux t2 fin)
  | x => node x fin
 end.

Fixpoint flatten (t : bin) : bin :=
 match t with node t1 t2 => flatten_aux t1 (flatten t2) | x => x end.

(* Here is a function that removes the neutral elements from a flat tree
   This needs to be done in two steps because of the right-most subtree.*)

Fixpoint remove_neutral1 (t : bin) : bin :=
 match t with
   leaf n => leaf n
  | neutral => neutral
  | node neutral t' => remove_neutral1 t'
  | node t t' => node t (remove_neutral1 t')
 end.

Fixpoint remove_neutral2 (t : bin) : bin :=
 match t with
   leaf n => leaf n
  | neutral => neutral
  | node t neutral => t
  | node t1 t2 => node t1 (remove_neutral2 t2)
 end.

Definition remove_neutral (t : bin) := remove_neutral2 (remove_neutral1 t).

Section assoc_eq.
Variables
   (A : Set) (f : A -> A ->  A) (zero_A : A)
   (assoc : forall (x y z : A),  f x (f y z) = f (f x y) z)
   (zero_left : forall (x : A),  f zero_A x = x)
   (zero_right : forall (x : A),  f x zero_A = x).

(* The function bin_A can now be simplified. the neutral element will be used
   as the default value for nth. *)
Fixpoint bin_A (l : list A) (t : bin) {struct t} : A :=
 match t with
   node t1 t2 => f (bin_A l t1) (bin_A l t2)
  | leaf n => nth n l zero_A
  | neutral => zero_A
 end.

(* all theorems are simplified accordingly. *)

Theorem flatten_aux_valid_A:
 forall (l : list A) (t t' : bin),
  f (bin_A l t) (bin_A l t') = bin_A l (flatten_aux t t').
Proof.
intros l t; elim t; simpl; auto.
intros t1 IHt1 t2 IHt2 t'; rewrite <- IHt1; rewrite <- IHt2.
symmetry; apply assoc.
Qed.

Theorem flatten_valid_A:
 forall (l : list A) (t : bin),  bin_A l t = bin_A l (flatten t).
Proof.
intros l t; elim t; simpl; trivial.
intros t1 IHt1 t2 IHt2; rewrite <- flatten_aux_valid_A; now rewrite <- IHt2.
Qed.

Theorem flatten_valid_A_2:
 forall (t t' : bin) (l : list A),
 bin_A l (flatten t) = bin_A l (flatten t') ->  bin_A l t = bin_A l t'.
Proof.
intros t t' l Heq.
rewrite (flatten_valid_A l t); now rewrite (flatten_valid_A l t').
Qed.

Theorem remove_neutral1_valid_A:
 forall (l : list A) (t : bin),  bin_A l (remove_neutral1 t) = bin_A l t.
Proof.
intros l t; elim t; auto.
intros t1; case t1; simpl.
- intros t1' t1'' IHt1 t2 IHt2; rewrite IHt2; trivial.
- intros n IHt1 t2 IHt2; rewrite IHt2; trivial.
- intros IHt1 t2 IHt2; rewrite zero_left; trivial.
Qed.

Theorem remove_neutral2_valid_A:
 forall (l : list A) (t : bin),  bin_A l (remove_neutral2 t) = bin_A l t.
Proof.
intros l t; elim t; auto.
intros t1 IHt1 t2; case t2; simpl.
- intros t2' t2'' IHt2; rewrite IHt2; trivial.
- auto.
- intros IHt2; rewrite zero_right; trivial.
Qed.

Theorem remove_neutral_equal:
 forall (t t' : bin) (l : list A),
 bin_A l (remove_neutral t) = bin_A l (remove_neutral t') ->
  bin_A l t = bin_A l t'.
Proof.
unfold remove_neutral; intros t t' l.
repeat rewrite remove_neutral2_valid_A.
repeat rewrite remove_neutral1_valid_A.
trivial.
Qed.

End assoc_eq.

Ltac term_list f l zero v := match v with
                              | f ?X1 ?X2 => let l1 := term_list f l zero X2 in
                                             term_list f l1 zero X1
                              | zero => l
                              | ?X1 => constr:(cons X1 l) end.

Ltac compute_rank l n v := match l with
                       | cons ?X1 ?X2 =>
                         let tl := constr:(X2) in
                           match constr:(X1 = v) with
                           | ?X1 = ?X1 => n
                           | _ => compute_rank tl (S n) v
                            end
                       end.

Ltac
model_aux l f zero v := match v with
                         | f ?X1 ?X2 => let r1 := model_aux l f zero X1 with
                                            r2 := model_aux l f zero X2 in
                                        constr:(node r1 r2)
                         | zero => constr:(neutral)
                         | ?X1 => let n := compute_rank l 0 X1 in
                                  constr:(leaf n)
                         end.

Ltac model_A A f zero v := let l := term_list f (nil (A:=A)) zero v in
                           let t := model_aux l f zero v in
                           constr:(bin_A A f zero l t).

(* At the end of the tactic, we also remove the zero. *)
Ltac assoc_eq A f zero assoc_thm neutral_left_thm neutral_right_thm :=
match goal with
| |- @eq A ?X1 ?X2 =>
let term1 := model_A A f zero X1 with
    term2 := model_A A f zero X2 in
(change (term1 = term2); apply flatten_valid_A_2 with ( 1 := assoc_thm );
  apply remove_neutral_equal
       with ( 1 := neutral_left_thm ) ( 2 := neutral_right_thm ); auto) end.

Theorem reflection_test3:
 forall (x y z t u : Z),  (x * (((y * z) *1 )* (t * u)) = (x * (1 * y)) * (z * (t * u)) * 1)%Z.
Proof.
intros; assoc_eq Z Zmult 1%Z Zmult_assoc Zmult_1_l Zmult_1_r.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_lessthancongruence2.
Require Export GeoCoq.Elements.OriginalProofs.lemma_ray4.
Require Export GeoCoq.Elements.OriginalProofs.lemma_layoffunique.
Require Export GeoCoq.Elements.OriginalProofs.lemma_trichotomy2.
Require Export GeoCoq.Elements.OriginalProofs.lemma_outerconnectivity.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_lessthanadditive :
   forall A B C D E F,
   Lt A B C D -> BetS A B E -> BetS C D F -> Cong B E D F ->
   Lt A E C F.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists b, (BetS C b D /\ Cong C b A B)) by (conclude_def Lt );destruct Tf as [b];spliter.
assert (Cong A B C b) by (conclude lemma_congruencesymmetric).
assert (neq C b) by (forward_using lemma_betweennotequal).
assert (neq b C) by (conclude lemma_inequalitysymmetric).
assert (neq B E) by (forward_using lemma_betweennotequal).
let Tf:=fresh in
assert (Tf:exists e, (BetS C b e /\ Cong b e B E)) by (conclude lemma_extension);destruct Tf as [e];spliter.
assert (Cong B E b e) by (conclude lemma_congruencesymmetric).
assert (Cong A E C e) by (conclude cn_sumofparts).
assert (Cong e D e D) by (conclude cn_congruencereflexive).
assert (BetS e b C) by (conclude axiom_betweennesssymmetry).
assert (BetS C b F) by (conclude lemma_3_6b).
assert (~ BetS b F e).
 {
 intro.
 assert (Cong b F b F) by (conclude cn_congruencereflexive).
 assert (Lt b F b e) by (conclude_def Lt ).
 assert (Cong F D F D) by (conclude cn_congruencereflexive).
 assert (BetS b D F) by (conclude lemma_3_6a).
 assert (BetS F D b) by (conclude axiom_betweennesssymmetry).
 assert (Lt F D F b) by (conclude_def Lt ).
 assert (Cong F b b F) by (conclude cn_equalityreverse).
 assert (Lt F D b F) by (conclude lemma_lessthancongruence).
 assert (Cong F D D F) by (conclude cn_equalityreverse).
 assert (Lt D F b F) by (conclude lemma_lessthancongruence2).
 assert (Cong b e D F) by (conclude lemma_congruencetransitive).
 assert (Cong D F b e) by (conclude lemma_congruencesymmetric).
 assert (Lt b e b F) by (conclude lemma_lessthancongruence2).
 let Tf:=fresh in
 assert (Tf:exists q, (BetS b q F /\ Cong b q b e)) by (conclude_def Lt );destruct Tf as [q];spliter.
 assert (neq b q) by (forward_using lemma_betweennotequal).
 assert (neq b F) by (forward_using lemma_betweennotequal).
 assert (Out b F q) by (conclude lemma_ray4).
 assert (Out b F e) by (conclude lemma_ray4).
 assert (eq q e) by (conclude lemma_layoffunique).
 assert (BetS b e F) by (conclude cn_equalitysub).
 assert (BetS F e F) by (conclude lemma_3_6a).
 assert (~ BetS F e F) by (conclude axiom_betweennessidentity).
 contradict.
 }
assert (~ eq F e).
 {
 intro.
 assert (Cong b F B E) by (conclude cn_equalitysub).
 assert (BetS b D F) by (conclude lemma_3_6a).
 assert (BetS F D b) by (conclude axiom_betweennesssymmetry).
 assert (Cong F D F D) by (conclude cn_congruencereflexive).
 assert (Lt F D F b) by (conclude_def Lt ).
 assert (Cong F b b F) by (conclude cn_equalityreverse).
 assert (Lt F D b F) by (conclude lemma_lessthancongruence).
 assert (Cong D F B E) by (conclude lemma_congruencesymmetric).
 assert (Cong F D B E) by (forward_using lemma_congruenceflip).
 assert (Lt B E b F) by (conclude lemma_lessthancongruence2).
 assert (Cong b F b e) by (conclude lemma_congruencetransitive).
 assert (Lt B E b e) by (conclude lemma_lessthancongruence).
 assert (Lt B E B E) by (conclude lemma_lessthancongruence).
 assert (~ Lt B E B E) by (conclude lemma_trichotomy2).
 contradict.
 }
assert (~ ~ BetS b e F).
 {
 intro.
 assert (eq F e) by (conclude lemma_outerconnectivity).
 contradict.
 }
assert (BetS C e F) by (conclude lemma_3_7a).
assert (Cong A E C e) by (conclude cn_sumofparts).
assert (Cong C e A E) by (conclude lemma_congruencesymmetric).
assert (Lt A E C F) by (conclude_def Lt ).
close.
Qed.

End Euclid.


Require Import ct00.
(* ct00 contains the original conjecture. *)

Require Import ct16.
(* ct16 contains all necessary divide-and-conquer tactics *)

Require Import ct02 ct06 ct20.
(* ct02 ct06 ct20 contains the following lemmas that are solved by the automated
 * system, CoqHammer:
 * - sort_prog_base
 * - sort_prog_one
 * - sort_prog_pair
 *)

Fixpoint merge l1 l2 :=
  let fix merge_aux l2 :=
  match l1, l2 with
  | [], _ => l2
  | _, [] => l1
  | a1::l1', a2::l2' =>
      if (le_lt_dec a1 a2) then a1 :: merge l1' l2 else a2 :: merge_aux l2'
  end
  in merge_aux l2.

Lemma psort_prog :
  forall (l : list nat), {l' : list nat | sorted l' /\ permutation l' l}.
Proof.
div_conq_pair.
- apply sort_prog_base.
- apply sort_prog_one.
- intros; destruct (le_lt_dec a1 a2).
  + exists [a1; a2]; split; repeat constructor; auto.
  + exists [a2; a1]; split; repeat constructor; apply Nat.lt_le_incl; auto.
- intros; destruct H,H0,a,a0;
  eapply sort_prog_pair. apply H1. auto. apply H. auto.
Defined.

(*---------------------------------Extraction---------------------------------*)

Require Extraction.
Require Import ExtrOcamlBasic.
Require Import ExtrOcamlNatInt.
(* Suppose all the packages above are embedded in some trans *)

Extraction Language OCaml.
Set Extraction AccessOpaque.

Extraction "extraction/psort.ml" psort_prog.

(*----------------------------------------------------------------------------*)


From mathcomp Require Import all_ssreflect.

Definition onext n (x: 'I_n): 'I_n.
  move: x => [i Hi].
  suff: (if i.+1 < n then i.+1 else 0) < n; first exact: Ordinal.
  case: ifP => // _.
  by apply: (@leq_ltn_trans i 0 n).
Defined.

Definition injectiveb {aT: finType} {rT: eqType} (f: aT -> rT): bool :=
  uniq (map f (enum aT)).

Lemma injectiveP (aT: finType) (rT: eqType) (f: aT -> rT): reflect (injective f) (injectiveb f).
  rewrite /injectiveb /injective.
  apply: (iffP idP).
  - give_up.
  - give_up.
Admitted.

Lemma gauss_ex: forall n, (\sum_(i < n) i).*2 = n * n.-1.
  elim => // [|n IH].
  - by rewrite big_ord0.
  - rewrite big_ord_recr /= doubleD {}IH.
    case: n => //= n.
    by rewrite -muln2; ring.
Qed.

Lemma sum_odd1: forall n, \sum_(i < n) (2*i + 1) = n^2.
  elim => // [|n IH].
  - by rewrite big_ord0.
  - by rewrite big_ord_recr /= {}IH; ring.
Qed.

Lemma sum_exp: forall x n, 0 < x -> x ^ n.+1 - 1 = (x - 1) * \sum_(i < n.+1) x ^ i.
  case => //= x n _.
  rewrite big_ord_recr /= [in RHS]subn1 succnK mulnDr.
  elim: n => [|n IH].
  - by rewrite big_ord0 expn1 expn0 subn1 succnK; ring.
  - rewrite big_ord_recr expnSr /=.
    have <-: x.+1 ^ n.+1 - 1 + 1 = x.+1 ^ n.+1.
    -- rewrite subn1 addn1.
       apply: prednK.
       rewrite expn_gt0.
       by apply/orP; left.
    rewrite {}IH.
    set s := \sum_(i < n) x.+1 ^ i.
    rewrite !mulnDl !mulnDr mul1n subn1.
    have <-: forall a b, a + b = (a + b.+1).-1.
    -- elim => //= a IHa b.
       rewrite -addn1 -addnAC {}IHa addn1.
       apply: prednK.
       apply: (@leq_ltn_trans a) => //=.
       rewrite -{1}(addn0 a).
       exact: ltn_add2l.
    by ring.
Qed.

Lemma bound_space: forall n, \sum_(i < n) i ^ 2 <= n ^ 3.
  move=> n.
  have <-: \sum_(i < n) n ^ 2 = n ^ 3.
  - rewrite big_const_ord [RHS]expnS.
    elim: {1 3}n => //= m ->.
    by rewrite -[in m.+1]addn1 mulnDl; ring.
  have: n <= n => //.
  elim: {-2 12}n => [|m IH m_ltn_n].
  - by rewrite !big_ord0.
  - have m_leq_n: m <= n.
    by rewrite leq_eqVlt; apply/orP; right.
    have IH0 := IH m_leq_n.
    rewrite !big_ord_recr /=.
    rewrite (@leq_trans (\sum_(i < m) n ^ 2 + m ^2)) //.
    -- by rewrite leq_add2r.
    -- by rewrite leq_add2l leq_sqr.
Qed.

Section cex.
  Variable op2 : nat -> nat -> nat.
  Hypothesis op2n0 : right_id 0 op2.
  Hypothesis op20n : left_id 0 op2.
  Hypothesis op2A : associative op2.
  Hypothesis op2add : forall x y, op2 x y = x + y.

  Canonical Structure op2Mon : Monoid.law 0 :=
    Monoid.Law op2A op20n op2n0.

  Lemma ex_op2 : \big[op2/0]_(i < 3) i = 3.
    by rewrite !big_ord_recr big_ord0 /= !op2add.
  Qed.
End cex.


Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrbool eqtype ssrnat seq fintype ssrfun tuple div finset ssralg zmodp.
From Bits
     Require Import bits ssrextra.tuple.
Require Import spec.

(** * Cardinal through binary population count  *)

(* TODO: add ref. to Hacker's delight *)
(* TODO: document the algorithm *)

Definition pop_table {n}(k: nat) := mkseq (fun i => fromNat (n := n) (count_mem true (fromNat (n := k) i))) (2^k).

Definition pop_elem {n}(k: nat)(bs: BITS n)(i: nat): BITS n
  := let x := andB (shrBn bs (i * k)) (decB (shlBn #1 k)) in
     nth (zero n) (pop_table k) (toNat x).

Fixpoint popAux {n}(k: nat)(bs: BITS n)(i: nat): BITS n :=
  match i with
  | 0 => zero n
  | i'.+1 => addB (pop_elem k bs i') (popAux k bs i')
  end.

Definition cardinal {n}(k: nat)(bs: BITS n): BITS n
  := popAux k bs (n %/ k).

Lemma count_tcast:
  forall n m (bs: BITS n) (H: n = m), count_mem true (tcast H bs) = count_mem true bs.
Proof.
  move=> n m bs H.
  by case: m / H.
Qed.

(* TODO: passing the associative/commutative proofs by hand is an
         annoyance. That's something to ponder.. *)

Lemma pop_elem_repr:
  forall n k i (bs: BITS n)
         (q: n = i.+1 * k + (n - i.+1 * k))
         (q': i.+1 * k = i * k + k),
    i.+1 * k <= n ->
        pop_elem k bs i = #(count_mem true (high k (tcast q' (low (i.+1 * k) (tcast q bs))))).
Proof.
  move=> n k i bs q q' leq_Sik.
  have le_k: k < n.+1.
    rewrite (leq_ltn_trans (n := i.+1 * k)) //.
    by rewrite -[i.+1]addn1 mulnDl mul1n -{1}[k]add0n leq_add2r.
  have H: n = k + (n - k).
    by rewrite subnKC.
  have H': k + (n - k) = n by rewrite -H.
  rewrite /pop_elem /pop_table.
  rewrite makeOnes=> //.
  set bs' := andB (shrBn bs (i * k)) (tcast H' (zero (n - k) ## ones k)).
  have toNat_bounded: toNat bs' < 2 ^ k.
    have ltn_ones: toNat (n := n) (tcast H' (zero (n - k) ## ones k)) < 2 ^ k.
      rewrite toNat_tcast toNatCat toNat_zero toNat_ones mul0n add0n
              -(ltn_add2r 1) !addn1 prednK // expn_gt0.
      by auto with arith.
    by rewrite (leq_ltn_trans (n := toNat (n := n) (tcast H' (zero (n - k) ## ones k)))) //
              -leB_nat leB_andB.
  rewrite nth_mkseq=> //.

  have ->: high k (tcast q' (low (i.+1 * k) (tcast q bs)))
         = low k (tcast H (andB (shrBn bs (i * k)) (tcast H' (zero (n - k) ## ones k)))).
    apply allBitsEq=> i0 ltn_i0_k.
    have ltn_i0_n: i0 < n.
      apply (leq_trans (n := i.+1 * k))=> //.
      apply (leq_trans (n := k))=> //.
      have {1}->: k = 1 * k by auto with arith.
      by rewrite leq_mul2r orbT.
    rewrite getBit_low ltn_i0_k getBit_high !getBit_tcast getBit_low.
    have ->: i0 + i * k < i.+1 * k.
      by rewrite -[i.+1]add1n mulnDl ltn_add2r mul1n.
    rewrite getBit_tcast getBit_liftBinOp=> //.
    rewrite getBit_tcast getBit_catB ltn_i0_k getBit_ones=> //.
    rewrite andbT getBit_shrBn addnC //.
    rewrite addnC (leq_trans (n := i * k + k)) //.
    rewrite ltn_add2l ltn_i0_k //.
    have {2}->: k = 1 * k by auto with arith.
    by rewrite -mulnDl addn1.

  have ->: fromNat (n := k) (toNat (n := n) bs')
         = low k (fromNat (n := k + (n - k)) (toNat (n := n) bs')).
    by rewrite low_fromNat.
  have ->: fromNat (n := k + (n - k)) (toNat (n := n) bs')
         = tcast H (fromNat (n := n) (toNat (n := n) bs')).
    apply allBitsEq=> i0 le_i0.
    rewrite getBit_tcast.
    by case: (k + (n - k)) / H.
  by rewrite toNatK.
Qed.

Lemma pop_rec:
  forall n k i (bs: BITS n)
         (q: n = i * k + (n - i * k)),
    i * k <= n -> k > 0 ->
        popAux k bs i = #(count_mem true (low (i * k) (tcast q bs))).
Proof.
  move=> n k i.
  move: i n.
  elim=> [|i IHi] n bs q le_i k_gtz.
  + (* i ~ 0 *)
    by rewrite fromNat0.
  + (* i ~ i.+1 *)
    rewrite /popAux -/popAux.
    have ltn_i2k: i * k < n.
      rewrite (leq_trans (n := i.+1 * k)) // ltn_mul2r -ltnS.
      have ->: i < i.+1 by auto with arith.
      have ->: 1 < k.+1 by auto with arith.
      by rewrite /=.
    have leq_i2k: i * k <= n.
      by rewrite ltnW.

    rewrite IHi=> //.
    rewrite subnKC //.

    move=> Hcast0.
    rewrite pop_elem_repr=> //.
    rewrite -addn1 mulnDl.
    auto with arith.
    move=> Hcast1.
    have Hcast2: i * k + k = i.+1 * k by auto with arith.
    have {2}->: low (i.+1 * k) (tcast q bs)
    = tcast Hcast2 ((high k (tcast Hcast1 (low (i.+1 * k) (tcast q bs))) ##
      low (i * k) (tcast Hcast0 bs))).
      apply allBitsEq=> i0 le_i0.
      rewrite getBit_low le_i0 !getBit_tcast getBit_catB.
      case H: (i0 < i * k).
      + (* i0 < i * k *)
        by rewrite getBit_low H getBit_tcast.
      + (* i0 >= i * k *)
        rewrite getBit_high getBit_tcast getBit_low getBit_tcast subnK.
        rewrite le_i0 //.
        by rewrite leqNgt H //.
    by rewrite count_tcast count_cat fromNat_addBn addnC.
Qed.

Lemma cardinal_repr:
  forall n k (bs: BITS n) E,
    k %| n -> k > 0 -> repr bs E ->
        cardinal k bs = #(#|E|).
Proof.
  move=> n k bs E div_k_n gtz_k HE.
  have Hcast1: n = n %/ k * k.
    by rewrite divnK=> //.
  rewrite /cardinal pop_rec=> //.
  rewrite -Hcast1.
  rewrite subnKC //.
  move=> Hcast0.
  have ->: low (n %/ k * k) (tcast Hcast0 bs) = tcast Hcast1 bs.
    apply allBitsEq=> i le_i.
    by rewrite getBit_low le_i !getBit_tcast.
  rewrite count_tcast.
  by have ->: count_mem true bs = #|E| by apply count_repr.
  by rewrite -Hcast1.
Qed.


(** * RIS.positive_regexp : regular expressions that do not contain the empty word. *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import tools algebra language regexp systems.

Section s.
  Context {X : Set}.
  Context {decX : decidable_set X}.

  Notation Regexp := (@regexp X).

  Fixpoint positive e : Regexp :=
    match e with
    | e_zero | e_un => zero
    | ⟪x⟫ => ⟪x⟫
    | e_add e f => positive e ∪ positive f
    | e_prod e f => positive e · f ∪ e · positive f
    | e_star e => positive e · e ⋆
    end.

  Lemma positive_lang e u : ⟦positive e⟧ u <-> ⟦e⟧ u /\ u <> [].
  Proof.
    revert u;cut (⟦positive e⟧ ≃ (fun u => ⟦e⟧ u /\ u <> []));[intros h u;rewrite (h u);tauto|].
    induction e;simpl.
    - intro u;simpl;tauto.
    - intro u;split;[intro I;exfalso;apply I|intros (->&I);apply I;reflexivity].
    - rewrite IHe1,IHe2;intro u;unfold join,joinLang;tauto.
    - rewrite IHe1,IHe2;clear IHe1 IHe2.
      intro u;split.
      + intros [Iu|Iu].
        * destruct Iu as (u1&u2&->&(I1&N)&I2).
          split;[exists u1,u2;tauto|].
          intro E;apply N;apply app_eq_nil in E;tauto.
        * destruct Iu as (u1&u2&->&I1&I2&N).
          split;[exists u1,u2;tauto|].
          intro E;apply N;apply app_eq_nil in E;tauto.
      + intros ((u1&u2&->&I1&I2)&N).
        destruct_eqX u1 (@nil X);subst.
        * simpl in N;right;exists [],u2;tauto.
        * left;exists u1,u2;tauto.
    - rewrite IHe;clear IHe;intro u;split.
      + intros (u1&u2&->&(I1&N)&n&I2);split.
        * exists (S n),u1,u2;tauto.
        * intro E;apply N;apply app_eq_nil in E;tauto.
      + intros ((n&In)&N);revert u In N;induction n.
        * intros ? -> F;exfalso;apply F;reflexivity.
        * intros u (u1&u2&->&I1&IH) N.
          destruct_eqX u1 (@nil X);subst.
          -- simpl in *;apply IHn;assumption.
          -- exists u1,u2;split;[reflexivity|split;[tauto|]].
             exists n;assumption.
    - intro u;split.
      + intros ->;split;[reflexivity|intro E;discriminate].
      + tauto.
  Qed.

  Lemma positive_KA e f : e=KA f -> positive e =KA positive f.
  Proof.
    repeat rewrite CompletenessKA.
    intros E u;repeat rewrite positive_lang.
    rewrite (E u);reflexivity.
  Qed.

  Lemma positive_KA_inf e f : e<=KA f -> positive e <=KA positive f.
  Proof. unfold ax_inf;apply positive_KA. Qed.

  Lemma positive_inf e : positive e <=KA e.
  Proof. apply CompletenessKA_inf;simpl;intro u;rewrite positive_lang;tauto. Qed.

  Lemma positive_star e : positive e ⋆ =KA e ⋆.
  Proof.
    apply antisymmetry.
    - apply proper_star_inf,positive_inf.
    - apply CompletenessKA_inf;intros u (n&In).
      revert u In;induction n;intro u.
      + intros -> ;exists 0;reflexivity.
      + intros (u1&u2&->&I1&I2).
        destruct_eqX u1 (@nil X);subst.
        * simpl;apply IHn;assumption.
        * apply IHn in I2 as (m&Im).
          exists (S m),u1,u2;rewrite positive_lang;tauto.
  Qed.

End s.


(* comp := fun f g x => g (f x) と 定義する版 *)
(**
シングルトン
対象の型  unit
対象の例  tt（のみ）
射の型    Hom := ∀a b : unit, nat
射の型    Hom tt tt  (= nat)
射の例    1, 2

集合の圏
対象の型  Set
対象の例  nat（のみ）
射の型    Hom := ∀A B : Set, A -> B
射の型    Hom nat nat  (= nat -> nat)
射の例    plus 1, plus 2

半順序集合の圏
対象の型  nat
対象の例  3,4
射の型    Hom := ∀m n : nat, m ≦ n
射の型    Hom 3 4    (= 3 ≦ 4)
射の例    le3_4

しりとりの圏
対象の型  Hira
対象の例  こ,ぶ,た
射の型    (Inductive な定義)
射の例    こ ぶ た

型の圏
対象の型  Type
対象の例  nat
射の型    Hom := ∀A B : Type, A -> B
射の型    Hom nat nat  (= nat -> nat)
射の例    plus 1, plus 2  (項)

論理式の圏
対象の型  Prop
対象の例  1=2,2=1
射の型    Hom := ∀A B : Prop, A -> B
射の型    Hom (1=2) (2=1)
射の例    1=2 -> 2=1    (演繹、証明図）
*)

Require Import Omega.
Require Import Coq.Logic.ProofIrrelevance.
(* Axiom proof_irrelevance : forall (P : Prop) (p1 p2 : P), p1 = p2. *)

Set Implicit Arguments.

Generalizable Variables Obj.

Class Category `(Hom : Obj -> Obj -> Set) : Type :=
  {
    Hom := Hom;
    Obj := Obj;
    id              : forall {A : Obj}, Hom A A;
    comp            : forall {A B C : Obj}, Hom A B -> Hom B C -> Hom A C;
    left_identity   : forall {A B : Obj} {f : Hom A B}, comp id f = f;
    right_identity  : forall {A B : Obj} {f : Hom A B}, comp f id = f;
    associativity   : forall {A B C D : Obj} {f : Hom A B} {g : Hom B C} {h : Hom C D},
        comp f (comp g h) = comp (comp f g) h
  }.

Notation "A ~{ Cat }~> B" := (@Hom _ _ Cat A B) (at level 51, left associativity).
Notation "A ~> B" := (Hom A B) (at level 51, left associativity).
Notation "f \o g" := (comp g f) (at level 51, left associativity).
Notation "f \{ Cat }o g" := (@comp _ _ Cat _ _ _ g f) (at level 51, left associativity).
Notation "f \; g" := (comp f g) (at level 51, left associativity).
Notation "f \{ Cat }; g" := (@comp _ _ Cat _ _ _ f g) (at level 51, left associativity).

(* *********** *)
(* シングルトン *)
(* *********** *)
Definition Hom0 (A B : unit) : Set := nat.
Program Instance SPLUS : @Category unit Hom0 :=
  {|
    id _ := 0;
    comp _ _ _:= fun m n => n + m           (* 関手が成り立つように (n + m) + x *)
  |}.
Obligation 3.
Proof.
  now apply plus_assoc_reverse.
Qed.

Program Instance SMULT : @Category unit Hom0 :=
  {|
    id _ := 1;
    comp _ _ _:= fun m n => n * m
  |}.
Obligation 1.
Proof.
  now apply Nat.mul_1_r.
Qed.
Obligation 3.
Proof.
  now apply mult_assoc_reverse.
Qed.

(* 例 *)
Check Hom : unit -> unit -> Set.
Check comp 2 3 : Hom tt tt.
Check 2 \; 3 : tt ~> tt.
Check 2 \{SPLUS}; 3 : tt ~{SPLUS}~> tt.
Check 2 \{SMULT}; 3 : tt ~{SMULT}~> tt.
Compute (3 \{SPLUS}; 2).                    (* 3 + 2 = 5 *)
Compute (3 \{SMULT}; 2).                    (* 3 * 2 = 6 *)

(* ******** *)
(* 集合の圏 *)
(* ******** *)
Definition Hom1 (A B : Set) : Set := A -> B.
Program Instance SETS : @Category Set Hom1 :=
  {|
    id _ := fun x => x;
    comp _ _ _ := fun f g x => g (f x)
  |}.

(* 例 *)
Check Hom : Set -> Set -> Set.
Check comp (mult 2) (mult 3) : Hom nat nat.
Check (plus 2) \; (mult 3) : nat ~> nat.
Check (plus 2) \; (mult 3) : nat ~{SETS}~> nat.
Check (mult 3) \o (plus 2) : nat ~> nat.
Check (mult 3) \o (plus 2) : nat ~{SETS}~> nat.
Compute ((mult 3) \o (plus 2)) 1.           (* 3 * (2 + 1) *)

(* 関手 *)
Require Import Coq.Logic.FunctionalExtensionality.

Generalizable Variables Obja Homa Objb Homb.

Class Functor `(Ca : @Category Obja Homa) `(Cb : @Category Objb Homb) : Type :=
  {
    a : Obja;
    b : Objb;
    fobj : Obja -> Objb;
    fmor : Homa a a -> Homb b b;
    fmor_comp : forall (m n : a ~{Ca}~> a), fmor m \; fmor n = fmor (m \; n)
  }.

Definition Fobj (a : unit) : Set := nat.
Check Fobj tt : Set.
Compute Fobj tt.                            (* nat *)

Definition Fmor (n : tt ~{SPLUS}~> tt) : nat ~{SETS}~> nat := fun x => n + x.
Check (Fmor 1) \; (Fmor 2) : nat ~{SETS}~> nat.
Compute (Fmor 1) \; (Fmor 2).               (* fun x => x + 3 *)

Program Instance F : Functor SPLUS SETS :=
  {|
    a := tt;
    b := nat;
    fobj := Fobj;
    fmor := Fmor
  |}.
Obligation 1.
Proof.
  unfold Fmor.
  simpl.
  Check @functional_extensionality_dep.
  Check functional_extensionality_dep
        (fun x : nat => n + (m + x)) (fun x : nat => m + n + x).
  eapply functional_extensionality_dep.
  intro x.
  now rewrite plus_assoc.
Qed.

(*
Goal forall (m n : tt ~{SPLUS}~> tt), Fmor m \; Fmor n = Fmor (m \; n).
Proof.
  intros m n.
  unfold Fmor.
  simpl.
  Check @functional_extensionality_dep.
  Check functional_extensionality_dep
        (fun x : nat => n + (m + x)) (fun x : nat => m + n + x).
  eapply functional_extensionality_dep.
  intro x.
  now rewrite plus_assoc.
Qed.
*)

(* この方向の関手は、一般的には定義できない。 *)
Definition G (f : nat ~{SETS}~> nat) : tt ~{SPLUS}~> tt := f 0.
Check (G (plus 1)) \; (G (plus 2)) : tt ~{SPLUS}~> tt.
Compute (G (plus 1)) \; (G (plus 2)).       (* 3 *)

Goal forall (f g : nat ~{SETS}~> nat), G f \; G g = G (f \; g).
Proof.
  intros f g.
  unfold G.
  simpl.
Admitted.

(* ************* *)
(* 半順序集合の圏 *)
(* ************* *)
Definition Hom21 (m n : nat) : Set := m <= n.
Definition id21 (n : nat) : Hom21 n n.
Proof.
  unfold Hom21. easy.                        (* omega でなく *)
Defined.
Definition comp21 {m n p} H1 H2 := le_trans m n p H1 H2.

Program Instance P_LE : @Category nat Hom21 :=
  {|
    id := id21;
    comp nat  _ _ := comp21
  |}.
Obligation 1.
Proof.
  unfold Hom21 in *.
  now apply proof_irrelevance.
Qed.
Obligation 2.
Proof.
  unfold Hom21 in *.
  now apply proof_irrelevance.
Qed.
Obligation 3.
Proof.
  unfold Hom21 in *.
  now apply proof_irrelevance.
Qed.

Definition Hom22 (m n : nat) : Set := n <= m.
Definition id22 (n : nat) : Hom22 n n.
Proof.
  unfold Hom22. easy.                        (* omega でなく *)
Defined.
Definition comp22 {m n p} H1 H2 := le_trans p n m H2 H1.

Program Instance P_GE : @Category nat Hom22 :=
  {|
    id := id22;
    comp nat  _ _ := comp22
  |}.
Obligation 1.
Proof.
  unfold Hom22 in *.
  now apply proof_irrelevance.
Qed.
Obligation 2.
Proof.
  unfold Hom22 in *.
  now apply proof_irrelevance.
Qed.
Obligation 3.
Proof.
  unfold Hom22 in *.
  now apply proof_irrelevance.
Qed.

(* 例 *)
Definition le34 : 3 ~{P_LE}~> 4. Proof. unfold Hom, Hom21. omega. Defined.
Definition le45 : 4 ~{P_LE}~> 5. Proof. unfold Hom, Hom21. omega. Defined.
Check le34 \; le45 : 3 ~> 5.
Check le34 \; le45 : 3 ~{P_LE}~> 5.

Definition ge43 : 4 ~{P_GE}~> 3. Proof. unfold Hom, Hom22. omega. Defined.
Definition ge54 : 5 ~{P_GE}~> 4. Proof. unfold Hom, Hom22. omega. Defined.
Check ge54 \; ge43 : 5 ~> 3.
Check ge54 \; ge43 : 5 ~{P_GE}~> 3.

(* 関手もどき。compの引数が逆転するので、関手の規則を満たしていない。 *)
Definition F2 {m n : nat} (f : m ~{P_LE}~> n) : n ~{P_GE}~> m.
Proof.
  unfold Hom, Hom21, Hom22 in *.
  easy.
Defined.
Check F2 le34 : 4 ~{P_GE}~> 3.
Goal forall (m n p : nat) (f : m ~{P_LE}~> n) (g : n ~{P_LE}~> p),
    F2 g \; F2 f = F2 (f \; g).
Proof.
  intros.
  unfold Hom, Hom21, Hom22 in *.
  now apply proof_irrelevance.
Qed.

Definition G2 {m n : nat} (f : m ~{P_GE}~> n) : n ~{P_LE}~> m.
Proof.
  unfold Hom, Hom21, Hom22 in *.
  easy.
Defined.
Goal forall (m n p : nat) (f : m ~{P_GE}~> n) (g : n ~{P_GE}~> p),
    G2 g \; G2 f = G2 (f \; g).
Proof.
  intros.
  unfold Hom, Hom21, Hom22 in *.
  now apply proof_irrelevance.
Qed.

(* *********** *)
(* しりとりの圏 *)
(* *********** *)
Inductive Hira : Set := こ | ぶ | た | ぬ | き | つ | ね.
Inductive Hom3 : Hira -> Hira -> Set :=
  | single : forall A, Hom3 A A
  | cons : forall {A' B : Hira} (A : Hira) (tl : Hom3 A' B), Hom3 A B.

Definition comp3 {A B C : Hira} (f : Hom3 A B) (g : Hom3 B C) : Hom3 A C.
Proof.
  intros.
  induction f.
  + easy.
  + Check (cons A (IHf g)).
    now apply (cons A (IHf g)).
Defined.

Program Instance SIRI : @Category Hira Hom3 :=
  {|
    id := single;
    comp _ _ _ := comp3
  |}.
Obligation 2.
  intros.
  induction f.
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHf.
    reflexivity.
Qed.
Obligation 3.
Proof.
  induction f.
  + easy.
  + simpl.
    now rewrite IHf.
Qed.

(* 例 *)
Definition こぶた := cons こ (cons ぶ (single た)) : Hom こ た.
Definition たぬき := cons た (cons ぬ (single き)) : Hom た き.
Check comp こぶた たぬき : Hom こ き.
Compute comp こぶた たぬき.        (* こ ぶ た ぬ き : Home こ き *)
Check こぶた \; たぬき  : こ ~> き.
Check こぶた \; たぬき : こ ~{SIRI}~> き.

(* END *)


(******************************************************************************)
(**)
(******************************************************************************)
(* Let R : ringType and M : lmodType R                                        *)
(******************************************************************************)
(* R\lmod^n     ==                                                            *)
(* ringIBNType  == a record consisting of a ringType 'sort' and a proof that  *)
(*                 forall n m : nat,                                          *)
(*                  lmodIsomType R\lmod^n R\lmod^m -> n == m                  *)
(*                 R : ringIBN coerces to ringType                            *)
(* Every commutative ring satisfies the IBN condition so (R : comRingType)    *)
(* coerces to ringIBNType via cRingToRingIBN                                  *)
(* cRingToRingIBN R == given R : comRingType, this is a ringIBNType           *)
(******************************************************************************)
(* Let R : ringIBNType, and let M : fdFreeLmodType R                          *)
(******************************************************************************)
(* steinitz_exchange M == proof that all bases of M have the same size        *)
(* invariant_dimension M == proof that all bases of M have the same size      *)
(* \dim(M) == the unique basis number of M                                    *)
(* dim_of_oplus == proof \dim(A \oplus B) = \dim(A) + \dim(B)                 *)
(* dim_of_bigoplus == proof \dim(\bigoplus_F I) = \sum_(f : F)\dim(I f)       *)
(* rank_nullity f == proof that \dim(A) = \dim(\ker(f)) + \dim(\im(f))        *)
(******************************************************************************)

From Coq.Logic Require Import ProofIrrelevance FunctionalExtensionality.
Require Import Coq.Init.Datatypes.
From mathcomp Require Import ssreflect ssrfun eqtype seq fintype bigop.

Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
  From mathcomp Require Import ssrbool ssrnat.
Set Warnings "parsing".

Set Warnings "-ambiguous-paths". (* Some weird bug in ssralg throws out coercion warnings*)
  From mathcomp Require Import ssralg.
Set Warnings "ambiguous-paths".

Set Implicit Arguments.
Unset Strict Implicit.

Require Import Modules Linears FiniteSupport lmodLC DirectSum Basis FreeModules RingIBN.

Open Scope lmod_scope.
Open Scope ring_scope.

Section FieldResult.
  Variable (K : fieldType).

  Section ExchangeLemma.
    Variable (M : lmodType K) (B : lmodSetType M).
    Lemma eqZero_eqElem (C : FSType K B) (b : B) : (C b != 0) -> lmodLCSumsTo C 0 ->
      lmodLCSumsTo (((-1/(C b)) <*:> C) <+> (unitFSType b 1)) (B b).
      move=>X S; move:(lmodLC.add_sumsTo (lmodLC.scale_sumsTo (-1/(C b)) S) (lmodLC.unit_sumsTo b 1)); clear S=>S.
      destruct S as [s [U [H S]]].
      refine(ex_intro _ s (ex_intro _ U (ex_intro _ H _))).
      by rewrite scaler0 add0r scale1r in S.
    Qed.
  End ExchangeLemma.

  Section ExchangeLemma.
    Variable (M : lmodType K) (F : lmodFinSetType M).
    Section Lemmas.
      Definition seq_li (s : seq F) := forall (C : lmodLCType F), hasSupport C s ->  lmodLC.li C.
      Definition seq_span (s : seq F) := forall m : M, exists C : lmodLCType F, hasSupport C s /\ lmodLC.sumsTo C m.

      Lemma seq_li_cons a (s : seq F) : seq_li (a::s) -> seq_li s.
      Proof. rewrite /seq_li/hasSupport=>H C B X.
        refine (H C _ X)=>b.
        rewrite in_cons=>Y.
        by rewrite (B b Y) orbT.
      Qed.

      Lemma seq_li_cons_span_false a (s : seq F) : (a \notin s) -> seq_li (a::s) -> seq_span s -> false.
      Proof. rewrite /seq_li/seq_span=>U H S.
        destruct (S (F a)) as [C SP]; clear S.
        destruct(SP) as [SP1 SP2]; clear SP.
        move:(lmodLC.add_sumsTo SP2 (lmodLC.unit_sumsTo a (-1%R)))=>G.
        rewrite scaleN1r addrN in G.
        have HS :hasSupport (C <+> unitFSType a (-1)) (a::s).
          move=>/=b B.
          case(b == a) as []eqn:E.
          by move/eqP in E; destruct E; rewrite in_cons eq_refl orTb.
          by rewrite addr0 in B; rewrite in_cons (SP1 _ B) orbT.
        move:(H (C <+> unitFSType a (-1)) HS G); clear H.
        rewrite fsFun.eqFSFun/==>H.
        move:(equal_f H a).
        rewrite eq_refl.
        case(C a == 0) as []eqn:E.
        by move/eqP in E; rewrite E (rwP eqP) subr_eq0 eq_sym oner_eq0.
        by move/negbT in E; rewrite (SP1 _ E)/= in U.
      Qed.
    End Lemmas.

    Open Scope nat_scope.
    Lemma steinitz_exchange (s1 s2 : seq F) (U1 : uniq s1) (U2 : uniq s2)
        (L : seq_li s1) (S : seq_span s2)  :
        (size s1 <= size s2) /\
        exists (s2' : seq F),
            subseq s2' s2  /\
            size s2' + size s1 == size s2 /\
            seq_span (s1 ++ s2').
    Proof.
      move:s2 U2 S.
      induction s1=>s2 U2 S; split=>//. (* induction and split creates 4 cases, the first of the base cases is solved trivially*)
        refine(ex_intro _ s2 _)=>/=.
        by rewrite subseq_refl addn0 eq_refl. (* solve second base case *)

        case(size (a :: s1) <= size s2) as []eqn:E=>//. (* solve by bool case, true case is solved trivially*)
        simpl in U1;move/andP in U1.
        move:(IHs1 (proj2 U1) (seq_li_cons L) s2 U2 S)=>N; destruct N as [N1 N2].
        move/negbT in E; simpl in E.
        rewrite -leqNgt in E.
        move:(eqn_leq (size s1) (size s2)).
        rewrite E N1/==>H.
        move/eqP in H.
        destruct N2 as [s2' [X [Y Z]]].
        destruct s2'. (* induct on size of s2' *)
        by rewrite cats0 in Z; apply (seq_li_cons_span_false (proj1 U1) L Z). (* size zero case solved *)
        rewrite H/=eq_sym in Y.
        move/eqP in Y.
        clear E H N1.
        induction (size s2); [by rewrite addn0 in Y|]; (* size nonzero case solved *)
        rewrite addSn in Y; inversion Y; rewrite addSnnS in IHn; apply(IHn H0).

        simpl in U1;move/andP in U1.
        destruct (IHs1 (proj2 U1) (seq_li_cons L) s2 U2 S) as [SIZE [s2' [SUBSEQ [SUBSIZE SUBSPAN]]]].

        case(a \in s2') as []eqn:E.
          move:(lmodLC.in_cat E)=>E2.
          destruct E2 as [e1 [e2 E2]].
          refine(ex_intro _ (e1 ++ e2) _).
          split. move:(cat_subseq (subseq_refl e1) (suffix_subseq [::a] e2))=>H.
          by rewrite -E2 in H; rewrite (subseq_trans H SUBSEQ).
          split. move/eqP in SUBSIZE.
          move:(f_equal size E2).
          rewrite /= size_cat/=size_cat/==>W.
          by rewrite -SUBSIZE W addnS addnS addSnnS addnS .
          move=>m.
          destruct(SUBSPAN m) as [C H].
          refine(ex_intro _ C _).
          split; [|apply (proj2 H)]=>b X.
          move: ((proj1 H) _ X); clear H.
          rewrite E2 -(cat1s a s1) !mem_cat=>H.
          move/orP in H; destruct H as [H|H].
          by rewrite H orbT.
          move/orP in H; destruct H as [H|H].
          by rewrite H orbT.
          move/orP in H; destruct H as [H|H].
          by rewrite H orTb.
          by rewrite H !orbT.

          destruct (SUBSPAN (F a)) as [C [D1 D2]].
          move: (D1 a);clear D1=>D1.
          apply (lmodLC.sumToElem_sumToZero) in D2.
          have Y:hasSupport (C <+> unitFSType (R:=K) (B:=F) a (-1)) (a :: s1).
          move=>b X.
          simpl in X.
          case(b == a) as []eqn:Eba. by move/eqP in Eba; rewrite Eba in_cons eq_refl orTb.
          rewrite Eba addr0 in X.
          destruct (S (F b)).
          move/(L _ _) in D2.
        admit.
    Admitted.
  End ExchangeLemma.

  Variable (M : lmodType K) (F : lmodFinSetType M).
  Export ringIBN.
  Theorem Fields_IBN : ringIBN.axiom K.
  Proof.
    rewrite IBN_equiv_equal_basis_nums=>V B1 B2.
  Admitted.
End FieldResult.