Require Import Reals Coquelicot.Coquelicot Fourier Psatz.
Require Import filter_Rlt atan_derivative_improper_integral arcsinh.
Require Import elliptic_integral generalities agmpi rounding_big.
Require Import Interval.Tactic.
Import mathcomp.ssreflect.ssreflect.

#[export]
Hint Mode ProperFilter' - + : typeclass_instances.

Lemma ex_derive_ratio n x (intx : 0 < x < 1) :
  ex_derive (fun y => a_ n y / b_ n y) x.
Proof.
assert (0 < b_ n x).
  now destruct (ag_le n 1 x); unfold b_; psatzl R.
(* TODO: in this version you cannot load rounding_correct, because it
   leads to auto_derive taking forever here. Please report bug.*)
auto_derive.
destruct (ex_derive_ag n x (proj1 intx)) as [d1 [d2 [da [db _]]]].
repeat (split;[eapply ex_intro; eassumption| ]); psatzl R.
Qed.

(* This is equation 42 in submitted version of "distant decimals of pi" *)
Lemma is_derive_k_extra n x (intx : 0 < x < 1) :
  is_derive (k_ n) x
  (- ((/ 2 ^ n * (b_ n x) ^ 3 / (a_ n x * (w_ n x) ^ 2)) *
     Derive (fun x => a_ n x / b_ n x) x)).
Proof.
evar_last;[apply is_derive_k, intx | ].
unfold Rdiv at 3; rewrite -> !Rmult_assoc, Ropp_mult_distr_r.
apply f_equal; rewrite (is_derive_unique (w_ n) x _ (is_derive_w n x intx)).
assert (0 < b_ n x < a_ n x) by now apply b_lt_a.
assert (0 < w_ n x) by now unfold w_; rewrite diff_square; lt0.
assert (dd : Derive (fun y => a_ n y / b_ n y) x =
        (Derive (a_ n) x * b_ n x - Derive (b_ n) x * a_ n x) / (b_ n x) ^ 2).
  apply is_derive_unique; auto_derive; cycle 1.
    change (Derive (fun x => a_ n x)) with (Derive (a_ n)).
    change (Derive (fun x => b_ n x)) with (Derive (b_ n)).
    field; psatzl R.
  destruct (ex_derive_ag n x (proj1 intx)) as [d1 [d2 [da [db dap]]]].
  repeat (split;[eapply ex_intro; eassumption |]); psatzl R.
rewrite dd; clear dd; change (Derive (fun x => b_ n x)) with (Derive (b_ n)).
change (sqrt (a_ n x ^ 2 - b_ n x ^ 2)) with (w_ n x).
rewrite Rinv_div; try psatzl R.
match goal with |- ?a = _ =>
  replace a with ((- a_ n x ^ 2 * Derive (a_ n) x + a_ n x * b_ n x *
      Derive (b_ n) x + w_ n x ^ 2 *
      Derive (a_ n) x) / (a_ n x * w_ n x ^ 2)) by (field; psatzl R)
end.
rewrite (Rmult_comm (/ (a_ n x * w_ n x ^ 2))).
unfold Rdiv; rewrite -> Ropp_mult_distr_l, <- !Rmult_assoc.
apply f_equal with (f := (fun A => A * / (a_ n x * w_ n x ^ 2))).
replace (w_ n x ^ 2) with (a_ n x ^ 2 - b_ n x ^ 2); cycle 1.
  now unfold w_; rewrite sqrt_pow_2;[reflexivity | rewrite diff_square; lt0].
field; psatzl R.
Qed.

(* This is equation 43 in submitted version of "distant decimals of pi" *)
Lemma derive_ratio_a_b n :
  is_derive (fun x => a_ n x / b_ n x) (/sqrt 2)
   (- 2 * sqrt 2 * 2 ^ n * a_ n (/sqrt 2) * (w_ n (/sqrt 2)) ^ 2 /
        b_ n (/sqrt 2)).
Proof.
set (x := /sqrt 2); assert (intx : 0 < x < 1) by exact ints.
assert (0 < b_ n x /\ 0 < a_ n x).
  now destruct (ag_le n 1 x); unfold b_, a_; psatzl R.
assert (b_ n x < a_ n x) by now apply b_lt_a.
assert (0 < w_ n x) by (unfold w_; rewrite diff_square; lt0).
assert (t'' := is_derive_unique _ _ _ (is_derive_k_extra n _ intx)).
rewrite -> Derive_k in t'';[|exact ints].
apply f_equal with (f := Ropp) in t''; rewrite Ropp_involutive in t''.
apply f_equal with (f := fun u => / (/ 2 ^ n * b_ n x ^ 3 /
                         (a_ n x * w_ n x ^ 2)) * u) in t''.
rewrite <- (Rmult_assoc _ _ (Derive _ x)), Rinv_l, Rmult_1_l in t'';[| lt0].
evar_last;[apply Derive_correct, ex_derive_ratio, ints |].
apply eq_trans with (1 := eq_sym t'').
assert (0 < 1 - x ^ 2) by (rewrite <-(pow1 2), diff_square; lt0).
field_simplify; try (repeat split; try lt0).
replace (-b_ n x ^ 3 * x ^ 3 + b_ n x ^ 3 * x) with
  (/2 * b_ n x ^ 3 * / sqrt 2);[field; split; lt0 |].
replace (x ^ 3) with (x ^ 2 * x) by ring.
unfold x; rewrite -> inv_sqrt, sqrt_pow_2; psatzl R.
Qed.

(* This is equation 49 in submitted version of "distant decimals of pi" *)
Lemma a2b_over_b'_b2a_over_a'_yz n (n1 : (1 <= n)%nat) x (intx : 0 < x < 1) :
  a_ n x ^ 2 * b_ n x / Derive (b_ n) x =
  y_ n x / z_ n x * (b_ n x ^ 2 * a_ n x / Derive (a_ n) x).
Proof.
unfold y_, z_; simpl; change (fun x => b_ n x) with (b_ n); field.
assert (t := b_lt_a _ n intx).
assert (t' := compare_derive_ag n x n1 intx).
now repeat split; lt0.
Qed.

Lemma cv_ff_3_over_ff'_b :
   is_lim_seq (fun n =>
              a_ n (/sqrt 2) ^ 2 * b_ n (/sqrt 2) /
              Derive (b_ n) (/sqrt 2)) (PI / (2 * sqrt 2)).
Proof.
assert (ints := ints); set (s2 := /sqrt 2); fold s2 in ints.
  apply (is_lim_seq_ext_loc
    (fun n =>
         y_ n s2 / z_ n s2 * (b_ n s2 ^ 2 * a_ n s2 / Derive (a_ n) s2))).
  now exists 1%nat; intros n n1; symmetry; apply a2b_over_b'_b2a_over_a'_yz.
apply (is_lim_seq_mult _ _ 1 (PI / (2 * sqrt 2))); cycle 1.
    now apply cv_ff_3_over_ff'.
  now unfold is_Rbar_mult; simpl; rewrite Rmult_1_l.
assert (0 < ff s2).
  destruct (M_between 1 s2 1) as [mb1 mb2]; try lt0.
  now destruct (ag_le 1 1 s2); unfold ff; lt0.
apply (is_lim_seq_div _ _ 1 1);
  [ | | injection; exact R1_neq_R0 |
    now unfold is_Rbar_div, is_Rbar_mult; simpl; apply f_equal;
    rewrite -> Rinv_1, Rmult_1_l].
  unfold y_; apply (is_lim_seq_div _ _ (ff s2) (ff s2)); cycle 3.
        unfold is_Rbar_div, is_Rbar_mult; simpl; apply f_equal.
        now rewrite Rinv_r; [reflexivity | lt0].
      now apply is_lim_seq_fst_ag.
    now apply is_lim_seq_snd_ag.
  now injection; apply Rgt_not_eq; lt0.
rewrite is_lim_seq_Reals.
assert (int: 0 < /2 < 3 /4) by (split; interval).
assert (int' : 3 / 4 < 1) by interval.
assert (d0 : 0 < /100) by interval.
set (d := mkposreal _ d0).
assert (dl : /2 < s2 - d) by (unfold s2, d; simpl; interval).
assert (da : s2 + d < 3/4) by (unfold s2, d; simpl; interval).
intros eps e0; destruct (CVU_z _ _ int int' s2 d dl da _ e0) as [N Pn].
exists N; intros n nN; rewrite R_dist_sym; apply (Pn n s2);[lia | ].
now apply Boule_center.
Qed.

Lemma ratio_b1'_b1 :
  Derive (b_ 1) (/sqrt 2) / b_ 1 (/sqrt 2) = / sqrt 2.
Proof.
assert (ints := ints).
rewrite derive_snd_step;[|psatzl R].
unfold a_, b_; simpl; rewrite -> Derive_const, Derive_id, Rmult_0_l, Rplus_0_l.
rewrite -> sqrt_1, !Rmult_1_l.
field_simplify;[ | interval | repeat split; interval].
rewrite sqrt_pow_2;[|lt0].
replace 2 with (sqrt 2 * sqrt 2) at 1 by (rewrite sqrt_sqrt; psatzl R).
now field; lt0.
Qed.

Definition direct_sumand k :=
   if k =? 0 then 0
   else 2 ^ k * (a_ k (/sqrt 2) ^ 2 - b_ k (/sqrt 2) ^ 2).

(* This is equation 46 in submitted version of "distant decimals of pi" *)
Lemma ratio_b'_b n (n1 : (1 <= n)%nat) :
  Derive (b_ n) (/sqrt 2) / b_ n (/sqrt 2) =
  Derive (b_ 1) (/sqrt 2) / b_ 1 (/sqrt 2)  -
        sqrt 2 * sum_f_R0 direct_sumand (n - 1).
Proof.
assert (ints := ints); set (s2 := /sqrt 2); fold s2 in ints.
induction n1 as [| n n1 Ih].
  now simpl; rewrite -> Rmult_0_r, Rminus_0_r.
(* This is equation 45 in submitted version of "distant decimals of pi" *)
destruct n as [ | m]; [inversion n1 | clear n1; set (n := S m)].
replace (S m - 1)%nat with m in Ih by lia.
replace (S n - 1)%nat with (S m) by (unfold n; lia).
rewrite -> tech5; unfold direct_sumand at 2.
rewrite -> Rmult_plus_distr_l. simpl (S m =? 0); lazy iota.
unfold Rminus in Ih |- *; rewrite -> Ropp_plus_distr.
rewrite <- !(Rplus_assoc _ _ (-(sqrt 2 * (2 ^ _ * _)))), <- Ih; clear Ih.
assert (dba : b_ n s2 < a_ n s2) by now apply b_lt_a.
destruct (ag_le n 1 s2) as [agl1 agl2]; try psatzl R.
fold n; fold s2; fold (b_ n s2) in agl1, agl2; fold (a_ n s2) in agl2.
(* This is equation 44 in submitted version of "distant decimals of pi" *)
replace (- (sqrt 2 * (2 ^ n * (a_ n s2 ^ 2 + - b_ n s2 ^ 2)))) with
  (/2 * Derive (fun x => a_ n x / b_ n x) s2 * b_ n s2/ a_ n s2); cycle 1.
  rewrite (is_derive_unique _ _ _ (derive_ratio_a_b n)).
  replace (a_ n s2 ^ 2 + - b_ n s2 ^ 2) with (w_ n s2 ^ 2); cycle 1.
    now unfold w_; rewrite sqrt_pow_2;[ |rewrite diff_square; lt0].
  fold s2; field; psatzl R.
assert (dr : Derive (fun x => a_ n x / b_ n x) s2 =
          (Derive (a_ n) s2 * b_ n s2 - Derive (b_ n) s2 * a_ n s2) /
          b_ n s2 ^ 2).
  auto_derive_fun (fun x => a_ n x / b_ n x); intros adh.
  destruct (ex_derive_ag n s2 (proj1 ints)) as [d1 [d2 ps]].
  assert (exa : ex_derive (a_ n) s2) by (exists d1; tauto).
  assert (exb : ex_derive (b_ n) s2) by (exists d2; tauto).
  assert (bn0 : b_ n s2 <> 0) by psatzl R.
  rewrite (is_derive_unique _ _ _ (adh _ (conj exa (conj exb (conj bn0 I))))).
  change (fun x => a_ n x) with (a_ n); change (fun x => b_ n x) with (b_ n).
  now field.
rewrite -> dr, derive_snd_step;[|psatzl R].
rewrite -> b_step; field_simplify; try (repeat split; lt0).
rewrite -> (Rmult_assoc 2), <- sqrt_mult; try (repeat split; lt0).
field_simplify; try (repeat split; lt0); rewrite sqrt_pow_2;[ | lt0].
now change (fun x => b_ n x) with (b_ n); field; lt0.
Qed.

Definition salamin_sumand k :=
  if k =? 0 then
    0
  else 2 ^ (k - 1) * ((a_ (k - 1) (/sqrt 2)) - b_ (k - 1) (/sqrt 2)) ^ 2.

(* This is definition 47 in submitted version of "distant decimals of pi" *)
Definition salamin_formula n :=
  4 * a_ n (/sqrt 2) ^ 2 / (1 - sum_f_R0 salamin_sumand (n - 1)).

Lemma direct_sum_0 n :
  0 < /sqrt 2 - sqrt 2 * sum_f_R0 direct_sumand n.
Proof.
assert (ints := ints); assert (n1 : (1 <= S n)%nat) by lia.
assert (t := ratio_b'_b (S n) n1); revert t.
rewrite ratio_b1'_b1; simpl; rewrite Nat.sub_0_r; intros <-.
destruct (compare_derive_ag _ (/sqrt 2) n1 ints) as [cd1 cd2].
destruct (ag_le (S n) 1 (/sqrt 2)) as [agl1 agl2]; try (psatzl R).
fold (a_ (S n) (/sqrt 2)) in *.
fold (b_ (S n) (/sqrt 2)) in *.
change (fun x => b_ (S n) x) with (b_ (S n)) in cd2.
lt0.
Qed.

Lemma direct_to_salamin n :
  2 * sqrt 2 * a_ n (/sqrt 2) ^ 2 /
   (/sqrt 2 - sqrt 2 * sum_f_R0 direct_sumand (n - 1)) =
  salamin_formula n.
Proof.
assert (ints := ints).
unfold Rdiv; replace (/ (/sqrt 2 - sqrt 2 * sum_f_R0 direct_sumand (n - 1)))
 with (sqrt 2 /
          (sqrt 2 * (/sqrt 2 - sqrt 2 * sum_f_R0 direct_sumand (n - 1))));
  cycle 1.
  unfold Rdiv; rewrite -> Rinv_mult, <- Rmult_assoc.
  now rewrite -> Rinv_r, Rmult_1_l;[ | lt0].
unfold Rdiv; rewrite <- !Rmult_assoc, !(Rmult_assoc (2 * sqrt 2)).
unfold Rdiv; rewrite (Rmult_comm (a_ n (/sqrt 2) ^ 2) (sqrt 2)).
rewrite -> (Rmult_assoc _ (sqrt 2)), (Rmult_assoc (sqrt 2) (_ ^ 2)).
rewrite <- (Rmult_assoc (sqrt 2) (sqrt 2)), sqrt_sqrt;[ | lt0].
rewrite <- !Rmult_assoc; unfold salamin_formula, Rdiv.
apply (f_equal (fun x => 4 * a_ n (/sqrt 2) ^ 2 / x)).
rewrite -> Rmult_minus_distr_l, Rinv_r;[| lt0].
apply f_equal; rewrite <-Rmult_assoc, sqrt_sqrt;[|lt0].
rewrite scal_sum; apply sum_eq; intros i _.
unfold direct_sumand, salamin_sumand.
destruct i as [|i];[rewrite Rmult_0_l; easy | simpl (S i =? 0); lazy iota].
simpl (S i - 1)%nat; simpl (2 ^ (S i)).
(* This is equation 36 in submitted version of "distant decimals of pi" *)
rewrite -> Nat.sub_0_r, a_step, b_step, pow2_sqrt.
  field.
now destruct (ag_le i 1 (/sqrt 2)) as [agi1 agi2]; unfold a_, b_; lt0.
Qed.

(* This is equation 48 in submitted version of "distant decimals of pi" *)
Lemma lim_salamin : is_lim_seq salamin_formula PI.
Proof.
apply (is_lim_seq_ext_loc
  (fun n => (2 * sqrt 2) * (a_ n (/sqrt 2) ^ 2 * b_ n (/sqrt 2) /
                            Derive (b_ n) (/sqrt 2)))); cycle 1.
  replace PI with ((2 * sqrt 2) * (PI / (2 * sqrt 2))) by (field; lt0).
  apply (is_lim_seq_mult _ _ (2 * sqrt 2) (PI / (2 * sqrt 2))).
      now apply is_lim_seq_const.
    now apply cv_ff_3_over_ff'_b.
  reflexivity.
exists 1%nat; intros n n1; rewrite <- direct_to_salamin.
rewrite <- ratio_b1'_b1 at 5; rewrite <- ratio_b'_b; auto.
field.
assert (t := ints).
destruct (ag_le n 1 (/sqrt 2)) as [agl1 agl2]; try (psatzl R).
fold (a_ n (/sqrt 2)) in *.
fold (b_ n (/sqrt 2)) in *.
destruct (compare_derive_ag n _ n1 ints) as [cd1 cd2].
change (fun x => b_ n x) with (b_ n) in cd2; lt0.
Qed.

Lemma ratio_b'_b_lb n (n1:  (1 <= n)%nat) :
     /2 < Derive (b_ n) (/sqrt 2) / b_ n (/sqrt 2).
Proof.
assert (ints := ints); assert (blta := b_lt_a _ n ints).
assert (blta' := b_lt_a _ 1 ints).
destruct (compare_derive_ag n _ n1 ints) as [da0 daltdb].
assert (un0 : a_ n (/sqrt 2) <= a_ 1 (/sqrt 2)).
  now unfold a_; apply fst_ag_decrease; try lia; try lt0.
apply Rlt_le_trans with (Derive (a_ 1) (/sqrt 2) / a_ 1 (/sqrt 2)).
  rewrite derive_fst_step; unfold a_; simpl; auto.
  now rewrite -> Derive_id, Derive_const; interval.
apply Rle_trans with (Derive (a_ n) (/sqrt 2) / a_ 1 (/sqrt 2)).
  apply Rmult_le_compat_r;[lt0 | ].
  replace n with (1 + (n - 1))%nat by lia.
  now apply derive_un_growing'.
apply Rle_trans with (Derive (b_ n) (/sqrt 2) / a_ 1 (/sqrt 2)).
  now apply Rmult_le_compat_r;[lt0 | apply Rlt_le].
apply Rmult_le_compat_l;[apply Rle_trans with (2 := Rlt_le _ _ daltdb); lt0 |].
now apply Rle_Rinv; lt0.
Qed.

Lemma a_n_m_b_n_bound n : 0 < a_ (n + 1) (/sqrt 2) - b_ (n + 1) (/sqrt 2) <=
  7 * Rpower 531 (- 2 ^ n).
Proof.
split; [assert (t := b_lt_a _ (n + 1) ints); lt0 | ].
set (v := b_ _ _); assert (v0 := b_lt_a _ (n + 1) ints : 0 < v < a_ _ _).
assert (v67: v < 6 / 7).
  apply Rlt_trans with (1 := proj2 v0).
  clear -n; induction n.
    now unfold a_; simpl; interval.
  now simpl; rewrite a_step; destruct (b_lt_a _ (n + 1) ints); lt0.
replace (_ - _) with (v * (y_ (n + 1) (/sqrt 2) - 1)); cycle 1.
  now unfold y_, v; field; fold v; lt0.
assert (t := majoration_y_n_vs2 n).
eapply Rle_trans;[eapply Rmult_le_compat_r;[lt0 | eapply Rlt_le, v67] | ].
apply Rle_trans with (6/7 * (8 * Rpower 531 (- 2 ^ n))).
  now apply Rmult_le_compat_l; lt0.
now rewrite <- Rmult_assoc; apply Rmult_le_compat_r; lt0.
Qed.

Lemma salamin_sum_ub  n : sum_f_R0 salamin_sumand n < /10.
Proof.
enough (main : sum_f_R0 salamin_sumand n <
           /11 * sum_f_R0 (fun x => (/11) ^ x) (n - 1)).
  apply Rlt_le_trans with (1 := main).
  rewrite tech3;[ | lt0].
  assert (0 < (/11) ^ S ( n - 1)) by lt0.
  assert ((/11) ^ S (n - 1) < 1).
    rewrite -[X in _ < X] (pow1 (S (n - 1))).
    simpl; apply Rlt_le_trans with (1 * (/11) ^ (n - 1)).
      apply Rmult_lt_compat_r; lt0.
    now apply Rmult_le_compat_l;[lt0 | apply pow_incr; lt0].
  apply Rle_trans with (/11 * ((1 - 0) / (1 - /11))).
    apply Rmult_le_compat_l;[lt0 | ].
    apply Rmult_le_compat_r;[lt0 | ].
    now apply Rplus_le_compat_l, Ropp_le_contravar; lt0.
  now apply Req_le; field.
induction n as [ | n IHn].
  now unfold salamin_sumand; simpl; lt0.
rewrite tech5; unfold salamin_sumand at 2; simpl (S n =? 0); lazy iota.
simpl (S n - 1)%nat; rewrite Nat.sub_0_r.
destruct n as [ | n].
  simpl; unfold salamin_sumand; simpl.
  now unfold a_, b_; simpl; interval.
apply Rlt_le_trans with
 (/ 11 * sum_f_R0 (fun x => (/11) ^ x) (S n - 1) +
 2^ S n * (a_ (S n) (/sqrt 2) - b_ (S n) (/ sqrt 2)) ^ 2).
  apply Rplus_lt_compat_r; assumption.
rewrite tech5; simpl (S n - 1)%nat; rewrite Nat.sub_0_r.
rewrite (Rmult_plus_distr_l _ _ ((/11) ^ S n)).
apply Rplus_le_compat_l; replace (S n) with (n + 1)%nat by ring.
assert (tmp := a_n_m_b_n_bound n).
apply Rle_trans with (2 ^ (n + 1) * (7 * Rpower 531 (-2 ^ n)) ^ 2).
  now apply Rmult_le_compat_l;[| apply pow_incr]; lt0.
rewrite Rpow_mult_distr.
rewrite <- (Rpower_pow 2 (Rpower _ _)); try lt0.
rewrite Rpower_mult; replace (INR 2) with 2 by (simpl; ring).
replace (- 2 ^ n * 2) with (- (2 ^ (n + 1))) by now rewrite pow_add; simpl; ring.
apply Rle_trans with
  (2 ^ (n + 1) * (7 ^ 2 * Rpower 531 (-INR (2 * (n + 1))))).
  repeat apply Rmult_le_compat_l; try lt0.
  rewrite !Rpower_Ropp; apply Rinv_le_contravar.
    now unfold Rpower; lt0.
  apply Rle_Rpower; try lt0.
  rewrite mult_INR; simpl INR.
  clear; induction n as [|n IHn].
    now simpl; lt0.
  simpl Nat.add; rewrite S_INR; simpl.
  apply Rmult_le_compat_l;[lt0 | ].
  apply Rle_trans with (2 := IHn); rewrite plus_INR; simpl INR.
  now assert (t := pos_INR n); lt0.
rewrite -> Rpower_Ropp, Rpower_pow; try lt0.
rewrite -> pow_mult, (Rmult_comm (2 ^ _)), Rmult_assoc.
rewrite <- pow_inv.
rewrite <- Rpow_mult_distr.
rewrite -> Nat.add_comm, !pow_add.
rewrite <- (Rmult_assoc (7 ^ 2)), <- (Rmult_assoc (/11)).
apply Rmult_le_compat; try lt0.
now apply pow_incr; interval.
Qed.

(* This is equation 50 in submitted version of "distant decimals of pi" *)
Lemma salamin_convergence_speed n (n2 : (2 <= n)%nat) :
  Rabs (salamin_formula (n + 1) - PI) <= 68 * Rpower 531 (-2 ^ (n - 1)).
Proof.
set (s2 := /sqrt 2).
assert (n1 : (1 <= n - 1)%nat) by lia.
assert (n1' : (1 <= n + 1)%nat) by lia.
assert (ints2 : 0 < s2 < 1) by exact ints.
assert (nm1p1 : (n - 1 + 1)%nat = n) by lia.
assert (t := compare_derive_ag _ s2 n1' ints2).
assert (t' := ag_le (n + 1) 1 s2 Rlt_0_1 (proj1 ints2) (Rlt_le _ _ (proj2 ints2))).
fold (b_ (n + 1) s2) in t'; change (fun x => b_ (n + 1) x) with (b_ (n + 1)) in t.
fold (a_ (n + 1) s2) in t'.
rewrite <- direct_to_salamin; rewrite <- ratio_b1'_b1 at 2.
rewrite <- ratio_b'_b; auto.
replace (2 * sqrt 2 *
          a_ (n + 1) (/sqrt 2) ^ 2 / (Derive (b_ (n + 1)) (/sqrt 2) /
          b_ (n + 1) (/sqrt 2))) with
  (2 * sqrt 2 * (a_ (n + 1) s2 ^ 2 * b_ (n + 1) s2 /
         Derive (b_ (n + 1)) s2)) by now unfold s2 in *; field; lt0.
rewrite -> a2b_over_b'_b2a_over_a'_yz; auto.
rewrite <- (Rmult_assoc (2 * sqrt 2)), (Rmult_comm (2 * sqrt 2)).
rewrite (Rmult_assoc (y_ (n + 1) s2 / z_ (n + 1) s2)).
replace 68 with (54 + 14) by ring; rewrite (Rmult_plus_distr_r 54).
replace (y_ (n + 1) s2 / z_ (n + 1) s2) with
   (y_ (n + 1) s2 / z_ (n + 1) s2 - 1 + 1) by ring.
rewrite (Rmult_plus_distr_r _ 1).
unfold Rminus at 1; rewrite Rplus_assoc.
apply Rle_trans with (1 := Rabs_triang _ _), Rplus_le_compat; cycle 1.
  rewrite Rmult_1_l.
  apply Rle_trans with (4 * agmpi 0 * Rpower 531 (- 2 ^ (n - 1))).
    rewrite <- agmpi_ff_3_ff'.
    assert (t'' :=  bound_agmpi (n - 1) n1).
    now rewrite nm1p1 in t''; rewrite Rabs_right; lt0.
  apply Rmult_le_compat_r;[unfold Rpower; apply Rlt_le, exp_pos|].
  rewrite -> agmpi0, derive_fst_step; unfold a_, b_; simpl; auto.
  now rewrite ->Derive_const, Derive_id; interval.
replace 54 with (3 * (1 ^2 * 1 * 2) * 9) by ring; rewrite (Rmult_assoc (3 * _)).
rewrite -> (Rmult_comm (_ - _)), Rabs_mult.
apply Rmult_le_compat; try lt0.
  rewrite Rabs_mult; apply Rmult_le_compat; try lt0.
    now interval.
  rewrite Rabs_div; try lt0.
  unfold Rdiv; apply Rmult_le_compat; try lt0.
      now rewrite Rabs_right; lt0.
    rewrite Rabs_mult; rewrite !Rabs_right; try lt0.
      apply Rmult_le_compat; try lt0.
      now apply pow_incr; lt0.
    now apply Rle_ge, pow_le; lt0.
  rewrite Rabs_right; try lt0.
  rewrite -> Nat.add_comm, <- (Rinv_inv 2).
  apply Rinv_le_contravar;[lt0 |].
  apply Rle_trans with (2 := derive_un_growing' 1 n s2 ints2).
  apply Req_le; rewrite derive_fst_step; unfold a_; simpl;[|exact ints2].
  now rewrite -> Derive_const, Derive_id; field.
assert (t'' := z_gt_1 s2 _ ints2 n1').
replace (y_ (n + 1) s2 / z_ (n + 1) s2 - 1) with
  (/ z_ (n + 1) s2  *(y_ (n + 1) s2 - 1) +
       (/z_ (n + 1) s2 * (1 - z_ (n + 1) s2))); cycle 1.
  now field; apply Rgt_not_eq, Rlt_gt; lt0.
replace 9 with (1 + (1 * 8)) at 1 by ring; rewrite Rmult_plus_distr_r.
rewrite (Rmult_assoc 1).
apply Rle_trans with (1 := Rabs_triang _ _).
apply Rplus_le_compat.
  rewrite Rabs_mult; apply Rmult_le_compat; try lt0.
    rewrite Rabs_right;[ | apply Rle_ge; lt0].
    rewrite <- (Rinv_inv 1).
    now apply Rinv_le_contravar; lt0.
  rewrite Rabs_right; cycle 1.
    now assert (t3 := y_gt_1 s2 (n + 1) ints2); lt0.
  apply Rle_trans with (1 := proj2 (majoration_y_n_vs2 n)).
  replace n with (S (n - 1)) at 1 by lia.
  rewrite <- tech_pow_Rmult, Ropp_mult_distr_r, <- Rpower_mult.
  (* This part of the proof is unsatisfactory, using wrong constants. *)
  apply Rmult_le_reg_r with (Rpower (Rpower 531 2) (2 ^ ( n - 1))).
    now unfold Rpower; apply exp_pos.
  rewrite -> Rmult_assoc, <- Rpower_plus, Rplus_opp_l, Rpower_O;
  [|unfold Rpower; apply exp_pos].
  unfold Rpower at 1; rewrite <- Ropp_mult_distr_l, -> Ropp_mult_distr_r.
  rewrite <- ln_Rinv; try lt0.
  change (exp (2 ^ (n - 1) * ln (/ 531))) with (Rpower (/531) (2 ^ (n - 1))).
  rewrite Rpower_mult_distr; try (unfold Rpower; lt0).
  rewrite <- (Rpower_1 531) at 1;try lt0;  rewrite <- Rpower_Ropp; try lt0.
  rewrite <- Rpower_plus; replace (-(1) + 2) with 1 by ring.
  rewrite Rpower_1; try lt0.
  apply Rle_trans with (Rpower 531 1);[ unfold Rpower; interval | ].
  now apply Rle_Rpower; try lt0; apply pow_R1_Rle; lt0.
(* end of questionable part. *)
assert (n1'' : (1 <= n)%nat) by lia.
assert (t3 := chain_y_z_y s2 n ints n1'').
rewrite Rabs_mult; apply Rmult_le_compat; try lt0.
  rewrite Rabs_right;[|apply Rle_ge, Rlt_le, Rinv_0_lt_compat; lt0].
  now rewrite <- (Rinv_inv 1); apply Rinv_le_contravar; lt0.
rewrite -> Rabs_left1, Ropp_minus_distr; try lt0.
apply Rle_trans with (y_ n s2 - 1).
  apply Rplus_le_compat_r.
  apply Rle_trans with (1 := proj2 t3).
  assert (t4 := y_gt_1 s2 n ints2).
  now apply Rlt_le, sqrt_less; lt0.
replace n with (n - 1 + 1)%nat at 1 by lia.
apply majoration_y_n_vs2.
Qed.

(* If we want, the constants can probably be improved, as we over estimate
  b_ n with 1, when we could use 6/7 instead. *)
Lemma salamin_convergence_speed' n (n1 : (1 <= n)%nat) :
  Rabs (salamin_formula (n + 1) - PI) <=
   (132 + 384 * 2 ^ n) * Rpower 531 (-(2 ^ n)).
Proof.
assert (help1 : forall a b c, b - c = a - c + (b - a)) by now intros; ring.
rewrite (help1 (salamin_formula (n + 2))).
apply Rle_trans with (1 := Rabs_triang _ _).
replace (132 + 384 * 2 ^ n) with
   (68 + (4 * 2 * 8 + 3 * (2 * (2 ^ n * (1 ^ 2 * 64)))))
   by ring.
rewrite !(Rmult_plus_distr_r _ _ (Rpower _ _)).
assert (n2m : (n + 2 - 1 = n + 1)%nat) by lia.
assert (n1m : (n + 1 - 1 = n)%nat) by lia.
assert (n1s : (n + 1 = S n)%nat) by ring.
apply Rplus_le_compat.
  replace (n + 2)%nat with ((n + 1) + 1)%nat by ring.
  replace n with ((n + 1) - 1)%nat at 2 by lia.
  now apply salamin_convergence_speed; lia.
assert (denpos : forall n, 0 < 1 - sum_f_R0 salamin_sumand n).
  now intros m; assert (tmp := salamin_sum_ub m); lt0.
assert (denn0 : forall n, 1 - sum_f_R0 salamin_sumand n <> 0).
  now intros m; apply Rgt_not_eq, denpos.
replace (salamin_formula (n + 1) - salamin_formula (n + 2)) with
  (4 * (a_ (n + 1) (/sqrt 2) ^ 2 - a_ (n + 2) (/sqrt 2)^ 2) /(1 - sum_f_R0 salamin_sumand n) +
   4 * a_ (n + 2) (/sqrt 2) ^ 2 * (/(1 - sum_f_R0 salamin_sumand n) -
   /(1 - sum_f_R0 salamin_sumand (n + 1)))); cycle 1.
  now unfold salamin_formula; rewrite -> n2m, n1m; field; auto.
assert (n211 : (n + 2 = (n + 1) + 1)%nat) by ring.
assert (a_b_bounds := a_b_s2_bound (n + 1)); rewrite <- n211 in a_b_bounds.
assert (a_b_bounds' := a_b_s2_bound n).
assert (dp : a_ (n + 2) (/sqrt 2) < a_ (n + 1) (/sqrt 2)).
  now assert (tmp := a_decr (n + 1)); rewrite n211; lt0.
assert (diffpos : 0 < a_ (n + 1) (/sqrt 2) ^ 2 - a_ (n + 2) (/sqrt 2) ^ 2).
  now rewrite diff_square; apply Rmult_lt_0_compat;lt0.
apply Rle_trans with (1 := Rabs_triang _ _); apply Rplus_le_compat.
  assert (a_ (n + 1) (/sqrt 2) ^ 2 - a_ (n + 2) (/sqrt 2) ^ 2 <
            8 * Rpower 531 (-2 ^ n)).
  apply Rlt_le_trans with (2 := proj2 (majoration_y_n_vs2 n)).
    apply Rlt_trans with (b_ (n + 1) (/sqrt 2) * (y_ (n + 1) (/sqrt 2) - 1)).
      unfold y_, Rdiv; rewrite -> Rmult_minus_distr_l, Rmult_1_r, Rmult_comm.
      rewrite -> Rmult_assoc, Rinv_l, Rmult_1_r;[ | lt0].
      rewrite diff_square; apply Rlt_le_trans with
          (2 * (a_ (n + 1)(/sqrt 2) - a_ (n + 2)(/sqrt 2))).
        apply Rmult_lt_compat_r;[lt0 |].
        now assert (tmp1 := a_decr (n + 1)); rewrite n211; lt0.
      now replace (n + 2)%nat with (S (n + 1)) by ring; rewrite a_step; lt0.
    replace (y_ (n + 1) (/sqrt 2) - 1) with (1 * (y_ (n + 1) (/sqrt 2) - 1))
       at 2 by ring.
    apply Rmult_lt_compat_r;[ assert (tmp := y_gt_1 _ (n + 1) ints)| ]; lt0.
  rewrite Rabs_right; cycle 1.
    apply Rle_ge, Rmult_le_pos;[apply Rmult_le_pos;lt0 | ].
    now apply Rlt_le, Rinv_0_lt_compat.
  unfold Rdiv; rewrite !(Rmult_assoc 4); apply Rmult_le_compat_l;[lt0 | ].
  rewrite -> (Rmult_comm _ (/ _)), (Rmult_assoc 2).
  apply Rmult_le_compat; try lt0.
    now apply Rlt_le, Rinv_0_lt_compat; auto.
  (* TODO : investigate why interval does not work here. *)
  replace 2 with (/ / 2) by field.
  apply Rinv_le_contravar; try lt0.
  assert (tmp := salamin_sum_ub n); lt0.
rewrite -> Rabs_mult, (Rmult_assoc 3); apply Rmult_le_compat; try lt0.
  assert (tmp : 4 / 5 <= a_ (n + 2) (/sqrt 2) <= 6 / 7) by lt0.
  now interval.
replace (n + 1)%nat with (S n) by ring; rewrite tech5.
assert (help : forall a b, 1 - (a + b) = 1 - a - b) by now intros; ring.
rewrite help.
replace (/(1 - sum_f_R0 salamin_sumand n) - /(1 - sum_f_R0 salamin_sumand n -salamin_sumand (S n))) with
(-salamin_sumand (S n) /((1 - sum_f_R0 salamin_sumand n) * (1 - sum_f_R0 salamin_sumand n - salamin_sumand (S n)))); cycle 1.
  field;split;[ rewrite <- help; exact (denn0 (S n)) | auto].
unfold Rdiv; rewrite -> Rmult_comm, Rabs_mult.
rewrite -> (Rmult_assoc 2), (Rmult_assoc (2 ^ _)), (Rmult_assoc (1 ^ _)).
apply Rmult_le_compat; try lt0.
  rewrite Rabs_right; cycle 1.
    apply Rle_ge, Rlt_le, Rinv_0_lt_compat, Rmult_lt_0_compat; auto.
    now rewrite <- help; apply (denpos (S n)).
  replace 2 with (/ / 2) by field; apply Rinv_le_contravar; try lt0.
  rewrite <- help, <- tech5.
  assert (tmp := conj (salamin_sum_ub n) (salamin_sum_ub (S n))).
  assert (asp : forall k,  0 <= sum_f_R0 salamin_sumand k).
    intros; apply cond_pos_sum.
    intros m; unfold salamin_sumand; case (m =? 0); try lt0.
    now apply Rmult_le_pos;[lt0 | apply pow2_ge_0].
  assert (tmpn := conj (asp n) (asp (S n))).
  assert (0 <= sum_f_R0 salamin_sumand n <= /10 /\
          0 <= sum_f_R0 salamin_sumand (S n) <= /10) by lt0.
  (* TODO : investigate why interval does not work here. *)
  now apply Rle_trans with ((8 / 10) * (8 / 10));[ | apply Rmult_le_compat]; lt0.
unfold salamin_sumand; simpl (S n =? 0); lazy iota.
replace (S n  - 1)%nat with n by lia.
rewrite -> Rabs_Ropp, Rabs_right; cycle 1.
  now apply Rle_ge, Rmult_le_pos;[ |assert (t := b_lt_a _ n ints)];lt0.
apply Rmult_le_compat_l;[lt0 | ].
replace (a_ n (/sqrt 2) - b_ n (/sqrt 2)) with
  (b_ n (/sqrt 2) * (y_ n (/sqrt 2) - 1)); cycle 1.
  now unfold y_; field; destruct (b_lt_a _ n ints); lt0.
rewrite Rpow_mult_distr; apply Rmult_le_compat; try apply pow2_ge_0.
  now apply pow_incr; assert (t := conj (b_lt_a _ n ints) (a_decr n)); lt0.
assert (nm1 : n = ((n - 1) + 1)%nat) by lia.
replace (64 * Rpower 531 (-2 ^ n)) with
  ((8 * Rpower 531 (-2 ^ (n - 1))) ^ 2); cycle 1.
  field_simplify; simpl; rewrite -> Rmult_1_r, <- Rpower_plus.
  rewrite <- Ropp_plus_distr.
  assert (help2 : forall a, a + a = 2 * a) by now intros; ring.
  rewrite -> (help2 (2 ^ _)), tech_pow_Rmult.
  now replace (S (n - 1)) with n by lia.
apply pow_incr; rewrite -> nm1 at 1 2.
apply majoration_y_n_vs2.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e511m481_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Set Implicit Arguments.
Unset Strict Implicit.
Require Export point_cocyclicite.

Definition orthocentre (H A B C : PO) :=
  (orthogonal (vec H A) (vec B C) /\ orthogonal (vec H B) (vec A C)) /\
  orthogonal (vec H C) (vec A B).
Section Theoreme.
Parameter H A B C : PO.
Hypothesis triangle : ~ colineaire (vec A B) (vec A C).
Hypothesis H_orthocentre : orthocentre H A B C.

Lemma orthocentre_double :
 R (double (cons (vec H C) (vec H B))) (double (cons (vec A B) (vec A C))).
unfold orthocentre in H_orthocentre.
elim H_orthocentre; intros H0 H1; elim H0; intros H2 H3;
 clear H0 H_orthocentre; try exact H3.
apply
 transitive
  with
    (double
       (plus (cons (vec H C) (vec A B))
          (plus (cons (vec A B) (vec A C)) (cons (vec A C) (vec H B))))).
apply R_double.
auto.
apply
 transitive
  with
    (plus (double (cons (vec H C) (vec A B)))
       (double (plus (cons (vec A B) (vec A C)) (cons (vec A C) (vec H B))))).
auto.
apply
 transitive
  with
    (plus (double (cons (vec H C) (vec A B)))
       (plus (double (cons (vec A B) (vec A C)))
          (double (cons (vec A C) (vec H B))))).
apply compatible; auto.
apply transitive with (plus pi (plus (double (cons (vec A B) (vec A C))) pi)).
apply compatible; auto.
apply compatible; auto.
cut (orthogonal (vec A C) (vec H B)); (intros; auto).
apply transitive with (plus (plus (double (cons (vec A B) (vec A C))) pi) pi).
auto.
apply transitive with (plus (double (cons (vec A B) (vec A C))) (plus pi pi)).
auto.
apply transitive with (plus (double (cons (vec A B) (vec A C))) zero).
apply compatible; auto.
apply transitive with (plus zero (double (cons (vec A B) (vec A C)))).
auto.
auto.
Qed.

Theorem symetrique_orthocentre_cercle :
 forall H' : PO,
 R (cons (vec H' B) (vec B C)) (cons (vec B C) (vec H B)) ->
 R (cons (vec H' C) (vec B C)) (cons (vec B C) (vec H C)) ->
 sont_cocycliques A B C H'.
intros H' H0 H1; try assumption.
apply reciproque_cocyclique; auto.
cut (R (cons (vec H C) (vec H B)) (cons (vec H' B) (vec H' C))).
intros H2.
apply transitive with (double (cons (vec H C) (vec H B))); auto.
apply orthocentre_double.
apply reflexion with (vec B C); auto.
Qed.
End Theoreme.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable triangle_ : Universe -> Universe -> Universe -> Prop.
Variable tG_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable per_ : Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defrightangle_1 : (forall A B C : Universe, (exists X : Universe, (per_ A B C -> (betS_ A B X /\ (cong_ A B X B /\ (cong_ A C X C /\ B <> C)))))).
Variable defrightangle2_2 : (forall A B C X : Universe, ((betS_ A B X /\ (cong_ A B X B /\ (cong_ A C X C /\ B <> C))) -> per_ A B C)).
Variable lemma_betweennotequal_3 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_inequalitysymmetric_4 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_layoff_5 : (forall A B C D : Universe, (exists X : Universe, ((A <> B /\ C <> D) -> (out_ A B X /\ cong_ A X C D)))).
Variable lemma_8_3_6 : (forall A B C D : Universe, ((per_ A B C /\ out_ B C D) -> per_ A B D)).
Variable lemma_8_2_7 : (forall A B C : Universe, (per_ A B C -> per_ C B A)).
Variable lemma_rightangleNC_8 : (forall A B C : Universe, (per_ A B C -> ~(col_ A B C))).
Variable lemma_collinearorder_9 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable deftriangle_10 : (forall A B C : Universe, (triangle_ A B C -> ~(col_ A B C))).
Variable deftriangle2_11 : (forall A B C : Universe, (~(col_ A B C) -> triangle_ A B C)).
Variable proposition_20_12 : (forall A B C : Universe, (triangle_ A B C -> tG_ B A A C B C)).
Variable lemma_TGflip_13 : (forall A B C Xa Xb Xc : Universe, (tG_ A Xa B Xb C Xc -> (tG_ Xa A B Xb C Xc /\ tG_ A Xa B Xb Xc C))).
Variable lemma_TGsymmetric_14 : (forall A B C Xa Xb Xc : Universe, (tG_ A Xa B Xb C Xc -> tG_ B Xb A Xa C Xc)).
Variable proposition_22_15 : (forall A B C E F Xa Xb Xc : Universe, (exists X Y : Universe, ((tG_ A Xa B Xb C Xc /\ (tG_ A Xa C Xc B Xb /\ (tG_ B Xb C Xc A Xa /\ F <> E))) -> (cong_ F X B Xb /\ (cong_ F Y A Xa /\ (cong_ X Y C Xc /\ (out_ F E X /\ triangle_ F X Y))))))).
Variable lemma_ray4_1_16 : (forall A B E : Universe, ((betS_ A E B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_2_17 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_3_18 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Variable lemma_congruencetransitive_19 : (forall A B C D E F : Universe, ((cong_ A B C D /\ cong_ C D E F) -> cong_ A B E F)).
Variable lemma_layoffunique_20 : (forall A B C D : Universe, ((out_ A B C /\ (out_ A B D /\ cong_ A C A D)) -> C = D)).
Variable defcollinear_21 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_22 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_23 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_24 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_25 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_26 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_27 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_congruencesymmetric_28 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable lemma_congruenceflip_29 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ B A D C /\ (cong_ B A C D /\ cong_ A B D C)))).
Variable lemma_doublereverse_30 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ D C B A /\ cong_ B A D C))).
Variable axiom_5_line_31 : (forall A B C D E F G H : Universe, ((betS_ A B C /\ (betS_ E F G /\ (cong_ B C F G /\ (cong_ A D E H /\ (cong_ B D F H /\ cong_ A B E F))))) -> cong_ D C H G)).
Variable axiom_nocollapse_32 : (forall A B C D : Universe, ((A <> B /\ cong_ A B C D) -> C <> D)).
Variable lemma_10_12_33 : (forall A B C H : Universe, ((per_ A B C /\ (per_ A B H /\ cong_ B C B H)) -> cong_ A C A H)).
Variable cn_congruencereflexive_34 : (forall A B : Universe, cong_ A B A B).
Variable defequalangles_35 : (forall A B C Ca Cb Cc : Universe, (exists U V Su Sv : Universe, (congA_ A B C Ca Cb Cc -> (out_ B A U /\ (out_ B C V /\ (out_ Cb Ca Su /\ (out_ Cb Cc Sv /\ (cong_ B U Cb Su /\ (cong_ B V Cb Sv /\ (cong_ U V Su Sv /\ ~(col_ A B C))))))))))).
Variable defequalangles2_36 : (forall A B C Ca Cb Cc U V Su Sv : Universe, ((out_ B A U /\ (out_ B C V /\ (out_ Cb Ca Su /\ (out_ Cb Cc Sv /\ (cong_ B U Cb Su /\ (cong_ B V Cb Sv /\ (cong_ U V Su Sv /\ ~(col_ A B C)))))))) -> congA_ A B C Ca Cb Cc)).
Variable lemma_equalanglesreflexive_37 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C A B C)).
Variable lemma_equalanglestransitive_38 : (forall A B C D E F P Q R : Universe, ((congA_ A B C D E F /\ congA_ D E F P Q R) -> congA_ A B C P Q R)).
Variable lemma_equalanglessymmetric_39 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> congA_ Xa Xb Xc A B C)).

Theorem lemma_Euclid4_40 : (forall A B C Xa Xb Xc : Universe, ((per_ A B C /\ per_ Xa Xb Xc) -> congA_ A B C Xa Xb Xc)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* Deprecated - this is an unnecessarily complex approach that
   mixes nested-datatypes with De Bruijn indices
*)

(* Formalization of the Simply Typed Lambda Calculus using nested datatypes *)
Section STLC.

(* Goal: Progress and Preservation *)

Require Import Coq.Program.Equality.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.funind.Recdef.

Ltac inv H := dependent destruction H.

(* Terms *)
(*
  The term representation in the STLC (Simply Typed Lambda Calculus)
  depends on how variables are encoded.

  1. variable-as-string

  The most readable format represents variables as strings, e.g. [λx, f x].
  The problem of this representation is that ⍺-equivalent terms are distinct,
  e.g. [λx, x] ≠ [λy, y].

  2. de-bruijn-indices

  To avoid this issue we can encode variables as natural numbers, called
  de bruijn indices, where a variable [n] refers to the n-th lambda on a path
  from the variable occurrence to the root of the term-tree
  (read more: https://en.wikipedia.org/wiki/De_Bruijn_index).
  e.g. both [λx, x] and [λy, y] are represented as [λ 0] in this format.

  Another caveat is that, in both representations, we cannot restrict
  variables occurring out of scope,
  e.g. [λ 0 7] has a free variable [7] that is not bound to any λ in the term.

  3. nested-datatypes

  Nested Datatypes together with de bruijn indices allow us to staticly restrict
  what range of free variables is allowed.

  [tm V] is our datatype for terms where free variables are of type [V].
  - [var v] is a term [tm V] when [v] is of type [V] (free variable occurrence)
  - [e1 e2] is a term [tm V] provided that both [e1] and [e2] are terms [tm V]
  - [λ e] is a term [tm V] if [e] is a term [tm (option V)]

  The trick is in the 3rd case (abstraction)
  where the [e] (body of the lambda) can only have variables that are either
  [None] or [Some v] where [v] is of type [V].

  [None] refers to the variable occurrence bound by the current lambda,
  whereas a true free variable occurrence of [v] of type [V] under a lambda
  needs to be wrapped with [Some].

  In other words:
  [None] represents the variable [0] in de bruijn's format,
  while [Some] on a variable [v] acts like a successor function.

  Notation:
    [^V]    means  [option V]
    [V ↑ 0] means  [V]
    [V ↑ 1] means  [^V]
    [V ↑ 2] means  [^^V]
    ...
 *)

Notation "V ↑ n" := (iter Type n option V) (at level 5, left associativity) : type_scope.
Notation "^ V" := (option V) (at level 4, right associativity) : type_scope.

(* [tm V] represents a term with free variables of type [V] *)
Inductive tm (V : Type) :=
| tm_var : V -> tm V
| tm_app : tm V -> tm V -> tm V
| tm_abs : tm ^V -> tm V
.
Hint Constructors tm : core.
Arguments tm_var {V}.
Arguments tm_app {V}.
Arguments tm_abs {V}.

(* [var_n n] creates the n-th de bruijn index -
  which is [Some] applied n-times to [None] *)
Fixpoint var_n {V : Type} (n : nat) : V ↑ 1 ↑ n :=
  match n with
  | 0 => None
  | S n => Some (var_n n)
  end.

(* Important:
  Please note that the return type of [var_n] is [V ↑ 1 ↑ n] which is
  [option V] wrapped n-times with [option], so: [option^n (option V)].

  Notice that it's like wrapping [V] with [option] (1+n)-times,
  so it should be equivalent to wrapping it (n+1)-times as 1+n = n+1, right?

  Well it's equivalent but we cannot state equality of terms of different types:
    let v1 = [Some^n None : V ↑ n ↑ 1]
    let v2 = [Some^n None : V ↑ 1 ↑ n]
    We cannot say [v1 = v2] because their types does not match!
    The type of [=] is [A -> A -> Prop]
    and coq cannot normalize both types to the same type

  The choice between [V ↑ 1 ↑ n] and [V ↑ n ↑ 1] seems irrelevant now as both
  types are valid return types for [var_n],
  but it is crucial to pick one that is compatible with functions in the
  following sections.
  Compatible - meaning that coq can agree that types normalize to the same type.
 *)

Declare Custom Entry stlc.
Notation "<{ e }>" := e (at level 1, e custom stlc at level 99).
Notation "( x )" := x (in custom stlc, x at level 99).
Notation "{ x }" := x (in custom stlc at level 0, x constr).
Notation "x" := x (in custom stlc at level 0, x constr at level 0).
Notation tm_var_n n := (tm_var (var_n n)).
Notation "0" := (tm_var_n 0) (in custom stlc at level 0).
Notation "1" := (tm_var_n 1) (in custom stlc at level 0).
Notation "2" := (tm_var_n 2) (in custom stlc at level 0).
Notation "3" := (tm_var_n 3) (in custom stlc at level 0).
Notation "4" := (tm_var_n 4) (in custom stlc at level 0).
Notation "'var' V" := (tm_var V) (in custom stlc at level 1, left associativity).
Notation "x y" := (tm_app x y) (in custom stlc at level 1, left associativity).
Notation "'λ' e" :=
  (tm_abs e) (in custom stlc at level 90,
               e custom stlc at level 99,
               left associativity).

(* Closed terms *)
(*
  Term [tm V] can only have free variables of type [V].
  So terms [tm False] cannot have free variables.
  The [tm False] type prevents us from creating open terms
  as the type [False] is uninhabited.

  Instead of [False] we create an explicit empty type called [Void].
*)

Inductive Void : Type := .
Definition term := tm Void.

(* Closed terms - Examples *)

Example tm_id : term :=
  <{ λ 0 }>.             (* λx, x *)
Example tm_ω  : term :=
  <{ λ 0 0 }>.           (* λx, x x *)
Example tm_Ω  : term :=
  <{ (λ 0 0) (λ 0 0) }>. (* (λx, x x)(λx, x x) *)

Example tm_ω_without_notation :
  tm_abs (tm_app (tm_var None) (tm_var None)) = tm_ω.
Proof. reflexivity. Qed.

(* Failed attempt to create open terms *)
(* These definitions simply does not type check *)
Fail Example ex_tm_var : term :=
  <{ 0 }>.
Fail Example ex_tm_abs : term :=
  <{ λ 1 }>.

(* Value *)
(*
  Let us first consider call-by-value evaluation strategy that only computes
  closed terms (we'll show how to do a full normalization later)

  So any lambda abstraction is a value in our language.
 *)

Inductive val : term -> Prop :=
| val_abs : forall e, val <{ λ e }>
.
Hint Constructors val : core.

(* To define an evaluation relation we first need a substition operation
   and for that we need lifting... *)

(* Lift *)
(*
  Consider a term [e] which can contain free variables: 0, 1, 2, ... k, ...

  1) We need a lift operation (↑) that increments each free variable in a term
    e.g. so that [ ↑ <{ 0 (λ 0 1) }> = <{ 1 (λ 0 2) }> ]
                             ^ not a free variable! so it's still 0

  2) To implement (↑) we need a more general version called [lift n k],
    which adds [n] to every free variable at or above [k] level.
    e.g.
      lift n 0 <{ 0 }> = <{ n }>
      lift n 1 <{ 0 }> = <{ 0 }>
      lift n 1 <{ 1 }> = <{ n+1 }>
      lift n 1 <{ 2 }> = <{ n+2 }>

      lift n 0 <{ λ 0 }> = <{ λ 0 }>
      lift n 1 <{ λ 0 }> = <{ λ 0 }>
      lift n 1 <{ λ 1 }> = <{ λ 1 }>
      lift n 1 <{ λ 2 }> = <{ λ n+2 }>

  Learn more in http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.447.5355&rep=rep1&type=pdf
 *)

(* apply [Some] [n]-times *)
Fixpoint lift_var_n {V : Type} (n : nat) : V -> V ↑ n :=
  match n with
  | 0 => fun v => v
  | S n => fun v => Some (lift_var_n n v)
  end.

(* [lift_var n k v]: increase variable [v] by [n] when it's at least [k]

  Idea:
    if [v = Some^k (       v')]
    then [  Some^k (Some^n v')]  : skip k-levels, the rest lift n-times
    else [v]
 *)
Fixpoint lift_var {V : Type}
  (n k : nat) : V ↑ k -> V ↑ n ↑ k.
destruct k; intro v;
[ (* k=0 *) exact (lift_var_n n v) (* lift [v] n-times *)
| (* k>0 *) destruct v;
  [ (* v=Some *) exact (Some (lift_var V n k i))
  | (* v=None *) exact None
  ]
].
Defined.

Fixpoint lift {V : Type}
  (n k : nat) (e : tm V ↑ k) : tm V ↑ n ↑ k :=
  match e with
  | <{ var v }> => tm_var (lift_var n k v)
  | <{ e1 e2 }> => tm_app (lift n k e1) (lift n k e2)
  | <{ λ e   }> => tm_abs (lift n (S k) e)
  end.

Notation "↑ e" := (lift 1 0 e) (at level 70).

Example lift_examples : forall {V : Type} lift_7,
  lift_7 = @lift (V ↑ 2) 7 ->
  lift_7 0 <{   0 }> = tm_var_n 7 /\
  lift_7 1 <{   0 }> = <{ 0 }> /\
  lift_7 1 <{   1 }> = tm_var_n (7+1) /\
  lift_7 1 <{   2 }> = tm_var_n (7+2) /\
  lift_7 0 <{ λ 0 }> = <{ λ 0 }> /\
  lift_7 1 <{ λ 0 }> = <{ λ 0 }> /\
  lift_7 1 <{ λ 1 }> = <{ λ 1 }> /\
  lift_7 1 <{ λ 2 }> = <{ λ {tm_var_n (7+2)} }>.
Proof. intros; repeat split; subst; reflexivity. Qed.

Example lift_ex0 : forall {V : Type} (t : tm V ↑ 3),
   t = <{ 0 (λ 0 1 2) }> ->
  ↑t = <{ 1 (λ 0 2 3) }>.
Proof. intros; subst; reflexivity. Qed.

Example lift_ex1 : forall {V : Type} (t : tm V ↑ 3),
  t = <{ 1 0 2 }> ->
  lift 2 1 t = <{ 3 0 4 }>.
Proof. intros; subst; reflexivity. Qed.

Example lift_ex2 : forall {V : Type} (t : tm V ↑ 3),
  t = <{ 0 (λ 0 1 2) }> ->
  lift 2 1 t = <{ 0 (λ 0 1 4) }>.
Proof. intros; subst; reflexivity. Qed.

(* Substitution *)
(*
  Goal: [tm_subst n e e'] replaces variables [n] appearing in [e] with [e']
  Notation: e [n := e'] 'substitute n for e' in e'

  First implement [tm_subst_var n v e']
  that is a substitution when [e = var v]:
    if [v = Some^n None]: return [e'] lifted n-times
    otherwise: return [e] as nothing can be substituted
 *)
Fixpoint tm_subst_var
  {V : Type} (n : nat) : V ↑ 1 ↑ n -> tm V -> tm V ↑ n.
destruct n; intros [v | ] e';
[ (* n=0 v=Some *) exact (tm_var v)                (* leave this variable alone *)
| (* n=0 v=None *) exact e'                        (* substitute here! *)
| (* n>0 v=Some *) exact (↑ tm_subst_var _ _ v e') (* subst recursively, then lift *)
| (* n>0 v=None *) exact (tm_var None)             (* leave this variable alone *)
].
Defined.

(*
  Did you notice the type [V ↑ 1 ↑ n]? We've seen it before in the [var_n].

  Try changing the type in [var_n] to [V ↑ n ↑ 1] and see where coq complains.
  Can you fix the broken lemma without reverting the change in [var_n]?
 *)

Fixpoint tm_subst
  {V : Type} (n : nat) (e : tm V ↑ 1 ↑ n) (e' : tm V) : tm V ↑ n :=
  match e with
  | <{ var v }> => tm_subst_var n v e'
  | <{ e1 e2 }> => tm_app (tm_subst n e1 e') (tm_subst n e2 e')
  | <{ λ e   }> => tm_abs (tm_subst (S n) e e')
  end.

Notation "e [ n := e' ]" := (tm_subst n e e')
  (in custom stlc at level 0,
    e custom stlc,
    e' custom stlc at level 99,
    n constr at level 0).

Example subst_ex_1 :
  <{ (0 0) [0 := tm_ω] }> = tm_Ω.
Proof. reflexivity. Qed.

Example subst_ex_2 : forall (e : term),
  <{ (λ 1 0) [0 := e] }> = <{ λ {↑ e} 0 }>.
Proof. intros; reflexivity. Qed.

Example subst_ex_3 :
  <{ (1 0) [0 := {↑ tm_id}] }> = <{ 0 {↑ tm_id} }>.
Proof. intros; reflexivity. Qed.

Example subst_ex_4 :
  <{ (1 0) [S 0 := tm_id] }> = <{ {↑ tm_id} 0 }>.
Proof. intros; reflexivity. Qed.

(* Evaluation *)
(*
  Finally we have all pieces to define the evaluation relation.

  [step_redex] reduces a redex [<{ (λ e) e' }>]
    by substituting [0] in the body [e] for the term [e']

  [step_app1] reduces the function of an application [<{ e1 e }>]

  [step_app2] reduces the argument of an application [<{ v e1 }>]
    when the function is already a value
 *)

Reserved Notation "e1 '-->' e2" (at level 40).
Inductive step : term -> term -> Prop :=
| step_redex : forall e e',
    <{ (λ e) e' }> --> <{ e [0 := e'] }>
| step_app1 : forall e1 e2 e,
    e1 --> e2 ->
    <{ e1 e }> --> <{ e2 e }>
| step_app2 : forall e1 e2 v,
    val v ->
    e1 --> e2 ->
    <{ v e1 }> --> <{ v e2 }>
where "e1 '-->' e2" := (step e1 e2).
Hint Constructors step : core.

Remark tm_ω_value : ~ exists e, tm_ω --> e.
Proof. unfold tm_ω. intros [e H]. inv H. Qed.

Remark tm_Ω_reduces_to_itself : tm_Ω --> tm_Ω.
Proof. intros. unfold tm_Ω. constructor. Qed.

(* Now we want to define the typing relation *)
(*
  We start by defining the datatype for types:
  - We need one basic type: the unit.
    Note that we could pick any atomic type, like [Int] or [Bool].
  - and we need an arrow - the function type
 *)

(* Types *)

Inductive ty :=
| ty_unit : ty            (* unit is a type *)
| ty_arr : ty -> ty -> ty (* A -> B is a type when A and B are types *)
.
Hint Constructors ty : core.

Notation "A -> B" := (ty_arr A B) (in custom stlc at level 50, right associativity).

(* Context *)
(*
  For the typing relation we need a context Γ that remembers a type for each
  free variable.

  For the nested-datatypes format it's convinient to represent the context as
  a function of type [V -> ty] so a mapping from free variable to its type.

  So the empty context [·] is of type [Void -> ty]
    with the only reasonable implementation
 *)

Definition ctx V := V -> ty.

Definition emp : ctx Void := fun no => match no with end.
Notation "·" := emp.

Definition ctx_cons {V : Type} (Γ : ctx V) (A : ty) : ctx ^V :=
  fun V' =>
    match V' with
    | None => A
    | Some V => Γ V
    end.
Notation "Γ , A" := (ctx_cons Γ A) (at level 100, A custom stlc at level 0).

(* Typing relation *)

Reserved Notation "Γ '|-' A ':' T"
  (at level 101, A custom stlc, T custom stlc at level 0).
Inductive has_type : forall {V}, ctx V -> tm V -> ty -> Prop :=
| var_has_type : forall {V} Γ (x : V) A,
    Γ x = A ->
    Γ |- var x : A
| abs_has_type : forall {V} Γ A B (e : tm ^V),
    Γ, A |- e : B ->
    Γ |- λ e : (A -> B)
| app_has_type : forall {V} (Γ : ctx V) B A e1 e2,
    Γ |- e1 : (A -> B) ->
    Γ |- e2 : A ->
    Γ |- e1 e2 : B
where "Γ '|-' A ':' T" := (has_type Γ A T).
Hint Constructors has_type : core.

Remark tm_id_typeable : forall (A:ty),
  · |- tm_id : (A -> A).
Proof. unfold tm_id; auto. Qed.

Remark ty_not_equi_recursive : forall A B,
  A = ty_arr A B ->
  False.
Proof.
  induction A; intros.
  - discriminate H.
  - injection H; intros; subst.
    eapply IHA1. eassumption.
Qed.

Remark tm_ω_not_typeable :
  ~ exists T, · |- tm_ω : T.
Proof.
  unfold tm_ω.
  intros [T H].
  dependent destruction H.
  dependent destruction H.
  fold · in *.
  assert (A = ty_arr A B) by (inv H; inv H0; assumption).
  eapply ty_not_equi_recursive. eassumption.
Qed.

(* Typing is not deterministic for Curry-style terms *)

Definition typing_deterministic := forall V (Γ : ctx V) e t1 t2,
  Γ |- e : t1 ->
  Γ |- e : t2 ->
  t1 = t2.

Lemma typing_is_not_deterministic : ~ typing_deterministic.
Proof.
  unfold typing_deterministic; intro H.
  set (T1 := <{ ty_unit -> ty_unit }>).
  set (T2 := <{ T1 -> T1 }>).
  assert (H1: · |- tm_id : T1) by apply tm_id_typeable.
  assert (H2: · |- tm_id : T2) by apply tm_id_typeable.
  cut (T1 = T2). intro H0; discriminate H0.
  eapply H; eauto.
Qed.

Lemma val_arr_inversion : forall v A B,
  val v ->
  · |- v : (A -> B) ->
  exists e', v = <{ λ e' }>.
Proof.
  intros.
  inv H0; try inv H.
  exists e. reflexivity.
Qed.

(* Our first main theorem: Progress - well-typed terms never get 'stuck'
  if the term [e] type-checks then it's either a value or it makes a step
 *)
Theorem progress : forall e A,
  · |- e : A ->
  val e \/ exists e', e --> e'.
Proof with try solve [right; eexists; constructor; eauto | left; constructor].
  intros e A H.
  dependent induction H; fold · in *... (* lambda case solved already: value *)
  - contradiction. (* variable case is impossible as the terms are closed *)
  - assert (val e1 \/ (exists e', e1 --> e')) by auto; clear IHhas_type1.
    assert (val e2 \/ (exists e', e2 --> e')) by auto; clear IHhas_type2.
    destruct H1 as [H1 | [e' H1]]...
    destruct H2 as [H2 | [e' H2]]...
    apply (val_arr_inversion _ A B) in H1 as [e' H1]; auto.
    subst... (* we have a redex *)
Qed.

(* The second theorem we want to prove is called Preservation,
  but before we can formalize it we need:
  - additional context operations
  - Weakening lemma
  - Substitution lemma
 *)

(* [drop n k Γ] is a counterpart for the [lift] operation,
  but it changes the context while [lift] changes the term

  Idea:
    [ drop n k (Γ, Bn .. B1, Ak .. A1) = (Γ, Ak .. A1) ]
 *)

Fixpoint drop_n {V : Type} (n : nat) :
  ctx V ↑ n ->
  ctx V     :=
    match n with
    | 0 => fun (ctx : ctx V) => ctx
    | S n => fun (ctx : ctx V ↑ n ↑ 1) => drop_n n (fun v => ctx (Some v))
    end.

Fixpoint drop {V : Type} (n k : nat) :
  ctx V ↑ n ↑ k ->
  ctx V     ↑ k :=
    match k with
    | 0   => fun ctx => drop_n n ctx
    | S k => fun ctx => fun v =>
      match v with
      | None   => ctx None
      | Some i => drop _ _ (fun v => ctx (Some v)) i
      end
    end.

(* Weakening

  Goal:
    Γ'          , Ak .. A1 |-          e : A ->
    Γ', Bn .. B1, Ak .. A1 |- lift n k e : A

  Idea:
    Instead of adding Ak..A1 and Bn..B1 types to the context Γ'
    let Γ := Γ', Bn .. B1, Ak .. A1
    and reformulate theorem so that we drop Bn .. B1 from Γ.

  Goal equivalent:
    drop n k Γ |- e : A ->
    Γ |- lift n k e : A
 *)

Lemma weakening_var : forall V k n (Γ : ctx V ↑ n ↑ k) A v,
  drop n k Γ |- var v : A ->
  Γ |- var {lift_var n k v} : A.
Proof with cbn in *.
  intros; induction k...
  + induction n; auto...
    constructor.
    apply IHn in H; clear IHn.
    inv H. reflexivity.
  + destruct v.
    - constructor.
      set (G := fun v => Γ (Some v)).
      specialize IHk with (Γ := G) (v := i).
      cut (G |- var {lift_var n k i} : A).
      * intros H0. inv H0. reflexivity.
      * apply IHk. clear IHk. subst G.
        inv H. auto.
    - inv H. auto.
Qed.

Lemma drop_cons : forall V n k (Γ : ctx V ↑ n ↑ k) A e B,
  (drop n    k   Γ), A  |- e : B ->
   drop n (S k) (Γ , A) |- e : B.
Proof.
  intros. induction H; eauto.
Qed.

Theorem weakening : forall V k e n (Γ : ctx V ↑ n ↑ k) A,
  drop n k Γ |- e : A ->
  Γ |- {lift n k e} : A.
Proof with cbn in *.
  dependent induction e; intros; inv H...
  - apply weakening_var. auto.
  - eauto.
  - constructor.
    apply drop_cons in H.
    apply IHe in H; auto.
Qed.

Notation "Γ \ n" := (drop 1 n Γ) (at level 5).

Theorem Weakening : forall V e (Γ : ctx ^V) A,
  Γ \ 0 |-    e  : A ->
  Γ     |- {↑ e} : A.
Proof.
  intros. apply weakening in H. assumption.
  Qed.

(* Substitution Lemma - closed terms

  Goal:
    ·, B, Cn .. C1 |- e           : A ->
    ·              |- e'          : B ->
    ·   , Cn .. C1 |- e [n := e'] : A

  Idea:
    Again, remove instead of adding:
      - Γ \ n  removes the n-th type from the context Γ
      - Γ[n]   gets    the n-th type from the context Γ

  Goal equivalent:
    Γ     |- e           : A ->
    ·     |- e'          : Γ[n] ->
    Γ \ n |- e [n := e'] : A
*)

Notation "Γ [ n ]" := (Γ (var_n n))
  (in custom stlc at level 0,
    n constr at level 0).

Lemma substitution_lemma_for_closed : forall n
  (e : tm  Void ↑ 1 ↑ n)
  (Γ : ctx Void ↑ 1 ↑ n)
  (e': term) A,
    Γ     |- e           : A    ->
    ·     |- e'          : Γ[n] ->
    Γ \ n |- e [n := e'] : A.
Proof with cbn in *.
  intros. dependent induction e; inv H...
  - induction n...
    + destruct v; auto.
      (* additional steps for closed lemma *)
      assert (· = (fun v : Void => Γ (Some v)))
        by (apply functional_extensionality; intros; contradiction).
      rewrite <- H. assumption.
    + destruct v.
      * apply Weakening.
        apply IHn.
        assumption.
      * constructor. reflexivity.
  - eauto.
  - constructor.
    cut ((Γ, A) \ (S n) |- e [S n := e'] : B).
    + intro... inv H1; rewrite <- x; eauto.
    + apply IHe; auto.
Qed.

(* Preservation *)

Theorem preservation : forall e e',
  e --> e' -> forall A,
  · |- e  : A ->
  · |- e' : A.
Proof.
  intros e e' Hstep.
  induction Hstep; intros A He; inv He; fold · in *.
  - inv He1. fold · in *.
    set (H := substitution_lemma_for_closed 0 e (·, A) e' B).
    apply H in He1; auto.
  - apply IHHstep in He1.
    econstructor; eauto.
  - apply IHHstep in He2.
    econstructor; eauto.
  Qed.

(* Full normalization *)
(*
  Previously we discussed call-by-value evaluation relation [-->] where
  we did not evaluate terms under binders (here: just lambdas).

  It is worth seeing that the definitions we've seen so far are general enough
  to prove stronger versions of Progress and Preservation
  that are not restriced to closed terms.

  We aim to define the full normalization relation [-->n] and since the relation
  is different, so are the values.

  [nval e] says that the term [e] of type [tm V] (so it can have free variables)
  is a value. Values can take one of two forms:
    - [x e1 .. en] is a value when [x] is a variable and [e1] .. [en] are values
    - [λ e] is a value when [e] is a value
 *)
Inductive nval : forall {V}, tm V -> Prop :=
| nval_var : forall V (v : V),
    nval <{ var v }>
| nval_app_var : forall V e (v : V),
    nval e ->
    nval <{ (var v) e }>
| nval_app : forall V (e1 e2 e : tm V),
    nval <{ e1 e2 }> ->
    nval e ->
    nval <{ e1 e2 e }>
| nval_abs : forall V (e : tm ^V),
    nval e ->
    nval <{ λ e }>
.
Hint Constructors nval : core.

Reserved Notation "t1 '-->n' t2" (at level 40).
Inductive norm : forall {V}, tm V -> tm V -> Prop :=
| norm_redex : forall V e (e' : tm V),
    <{ (λ e) e' }> -->n <{ e [0 := e'] }>
| norm_app1 : forall V (e1 e2 e : tm V),
    e1 -->n e2 ->
    <{ e1 e }> -->n <{ e2 e }>
| norm_app2 : forall V (e1 e2 v : tm V),
    nval v ->
    e1 -->n e2 ->
    <{ v e1 }> -->n <{ v e2 }>
| norm_abs : forall V (e1 e2 : tm ^V),
    e1 -->n e2 ->
    <{ λ e1 }> -->n <{ λ e2 }>
where "t1 '-->n' t2" := (norm t1 t2).
Hint Constructors norm : core.

Lemma nval_no_steps : forall V (e : tm V),
  nval e ->
  ~ exists e', e -->n e'.
Proof with eauto.
  intros V e Hval [e' H].
  induction Hval; inv H...
  inv H...
  Qed.

(* Substitution Lemma - open terms

  Goal:
    Γ', B, Cn .. C1 |- e           : A ->
    Γ'              |- e'          : B ->
    Γ'   , Cn .. C1 |- e [n := e'] : A

  Idea:
    Again, remove instead of adding:
      - Γ \ n  removes the n-th type from the context Γ
      - Γ[n]   gets    the n-th type from the context Γ
      - drop (S n) 0 Γ removes first n+1 types from Γ

  Goal equivalent:
    Γ              |- e           : A ->
    drop (S n) 0 Γ |- e'          : Γ[n] ->
    Γ \ n          |- e [n := e'] : A
*)

Lemma substitution_lemma : forall V n
  (e : tm  V ↑ 1 ↑ n)
  (Γ : ctx V ↑ 1 ↑ n)
  (e': tm V) A,
    Γ                |- e           : A ->
    (drop n 0 Γ) \ 0 |- e'          : Γ[n] ->
    Γ \ n            |- e [n := e'] : A.
Proof with cbn in *.
  intros. dependent induction e; inv H...
  - induction n...
    + destruct v; auto.
    + destruct v.
      * apply Weakening.
        apply IHn.
        assumption.
      * constructor. reflexivity.
  - eauto.
  - constructor.
    cut ((Γ, A) \ (S n) |- e [S n := e'] : B).
    + intro... inv H1; rewrite <- x; eauto.
    + apply IHe; auto.
Qed.

Theorem open_preservation : forall V (e e' : tm V),
  e -->n e' -> forall Γ A,
  Γ |- e  : A ->
  Γ |- e' : A.
Proof.
  intros V e e' Hstep.
  induction Hstep; intros Γ t0 He; inv He; try (econstructor; eauto).
  - inv He1.
    set (H := substitution_lemma _ 0 e (Γ, A) e' B).
    apply H in He1; auto.
  Qed.

Theorem open_progress : forall V Γ (e : tm V) A,
  Γ |- e : A ->
  nval e \/ exists e', e -->n e'.
Proof with try solve [right; eexists; eauto | left; auto].
  intros V Γ e A H.
  dependent induction H...
  - destruct IHhas_type  as [H0 | [e' H0]]...
  - destruct IHhas_type1 as [H1 | [e' H1]]... (* e1 makes a step *)
    destruct IHhas_type2 as [H2 | [e' H2]]... (* e2 makes a step *)
    destruct H1... (* either an app value [x e1 .. en] or redex *)
Qed.

End STLC.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path.
From mathcomp Require Import choice fintype bigop finset fingroup morphism.
From mathcomp Require Import automorphism quotient action gseries.

(******************************************************************************)
(* This files establishes Jordan-Holder theorems for finite groups. These     *)
(* theorems state the uniqueness up to permutation and isomorphism for the    *)
(* series of quotient built from the successive elements of any composition   *)
(* series of the same group. These quotients are also called factors of the   *)
(* composition series. To avoid the heavy use of highly polymorphic lists     *)
(* describing these quotient series, we introduce sections.                   *)
(* This library defines:                                                      *)
(*         (G1 / G2)%sec == alias for the pair (G1, G2) of groups in the same *)
(*                          finGroupType, coerced to the actual quotient group*)
(*                          group G1 / G2. We call this pseudo-quotient a     *)
(*                          section of G1 and G2.                             *)
(*    section_isog s1 s2 == s1 and s2 respectively coerce to isomorphic       *)
(*                          quotient groups.                                  *)
(*        section_repr s == canonical representative of the isomorphism class *)
(*                          of the section s.                                 *)
(*         mksrepr G1 G2 == canonical representative of the isomorphism class *)
(*                          of (G1 / G2)%sec.                                 *)
(*         mkfactors G s == if s is [:: s1, s2, ..., sn], constructs the list *)
(*                     [:: mksrepr G s1, mksrepr s1 s2, ..., mksrepr sn-1 sn] *)
(*             comps G s == s is a composition series for G i.e. s is a       *)
(*                          decreasing sequence of subgroups of G             *)
(*                          in which two adjacent elements are maxnormal one  *)
(*                          in the other and the last element of s is 1.      *)
(* Given aT and rT two finGroupTypes, (D : {group rT}), (A : {group aT}) and  *)
(* (to : groupAction A D) an external action.                                 *)
(*        maxainv to B C == C is a maximal proper normal subgroup of B        *)
(*                          invariant by (the external action of A via) to.   *)
(*          asimple to B == the maximal proper normal subgroup of B invariant *)
(*                          by the external action to is trivial.             *)
(*         acomps to G s == s is a composition series for G invariant by to,  *)
(*                          i.e. s is a decreasing sequence of subgroups of G *)
(*                          in which two adjacent elements are maximally      *)
(*                          invariant by to one in the other and the          *)
(*                          last element of s is 1.                           *)
(* We prove two versions of the result:                                       *)
(*    - JordanHolderUniqueness establishes the uniqueness up to permutation   *)
(*       and isomorphism of the lists of factors in composition series of a   *)
(*       given group.                                                         *)
(*    - StrongJordanHolderUniqueness extends the result to composition series *)
(*       invariant by an external group action.                               *)
(* See also "The Rooster and the Butterflies", proceedings of Calculemus 2013,*)
(* by Assia Mahboubi.                                                         *)
(******************************************************************************)

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

Declare Scope section_scope.

Import GroupScope.

Inductive section (gT : finGroupType) := GSection of {group gT} * {group gT}.

Delimit Scope section_scope with sec.
Bind Scope section_scope with section.

Definition mkSec (gT : finGroupType) (G1 G2 : {group gT}) := GSection (G1, G2).

Infix "/" := mkSec : section_scope.

Coercion pair_of_section gT (s : section gT) := let: GSection u := s in u.

Coercion quotient_of_section gT (s : section gT) : GroupSet.sort _ := s.1 / s.2.

Coercion section_group gT (s : section gT) : {group (coset_of s.2)} :=
  Eval hnf in [group of s].

Section Sections.

Variables (gT : finGroupType).
Implicit Types (G : {group gT}) (s : section gT).

Canonical section_subType := Eval hnf in [newType for @pair_of_section gT].
Definition section_eqMixin := Eval hnf in [eqMixin of section gT by <:].
Canonical section_eqType := Eval hnf in EqType (section gT) section_eqMixin.
Definition section_choiceMixin := [choiceMixin of section gT by <:].
Canonical section_choiceType :=
  Eval hnf in ChoiceType (section gT) section_choiceMixin.
Definition section_countMixin := [countMixin of section gT by <:].
Canonical section_countType :=
  Eval hnf in CountType (section gT) section_countMixin.
Canonical section_subCountType := Eval hnf in [subCountType of section gT].
Definition section_finMixin := [finMixin of section gT by <:].
Canonical section_finType := Eval hnf in FinType (section gT) section_finMixin.
Canonical section_subFinType := Eval hnf in [subFinType of section gT].
Canonical section_group.

(* Isomorphic sections *)

Definition section_isog := [rel x y : section gT | x \isog y].

(* A witness of the isomorphism class of a section *)
Definition section_repr s := odflt (1 / 1)%sec (pick (section_isog ^~ s)).

Definition mksrepr G1 G2 := section_repr (mkSec G1 G2).

Lemma section_reprP s : section_repr s \isog s.
Proof.
by rewrite /section_repr; case: pickP => //= /(_ s); rewrite isog_refl.
Qed.

Lemma section_repr_isog s1 s2 :
  s1 \isog s2 -> section_repr s1 = section_repr s2.
Proof.
by move=> iso12; congr (odflt _ _); apply: eq_pick => s; apply: isog_transr.
Qed.

Definition mkfactors (G : {group gT}) (s : seq {group gT}) :=
  map section_repr (pairmap (@mkSec _) G s).

End Sections.

Section CompositionSeries.

Variable gT : finGroupType.
Local Notation gTg := {group gT}.
Implicit Types (G : gTg) (s : seq gTg).

Local Notation compo := [rel x y : {set gT} | maxnormal y x x].

Definition comps G s := ((last G s) == 1%G) && compo.-series G s.

Lemma compsP G s :
  reflect (last G s = 1%G /\  path [rel x y : gTg | maxnormal y x x] G s)
          (comps G s).
Proof. by apply: (iffP andP) => [] [/eqP]. Qed.

Lemma trivg_comps G s : comps G s -> (G :==: 1) = (s == [::]).
Proof.
case/andP=> ls cs; apply/eqP/eqP=> [G1 | s1]; last first.
  by rewrite s1 /= in ls; apply/eqP.
by case: s {ls} cs => //= H s /andP[/maxgroupp]; rewrite G1 /proper sub1G andbF.
Qed.

Lemma comps_cons G H s : comps G (H :: s) -> comps H s.
Proof. by case/andP => /= ls /andP[_]; rewrite /comps ls. Qed.

Lemma simple_compsP G s : comps G s -> reflect (s = [:: 1%G]) (simple G).
Proof.
move=> cs; apply: (iffP idP) => [|s1]; last first.
  by rewrite s1 /comps eqxx /= andbT -simple_maxnormal in cs.
case: s cs => [/trivg_comps/eqP-> | H s]; first by case/simpleP; rewrite eqxx.
rewrite [comps _ _]andbCA /= => /andP[/maxgroupp maxH /trivg_comps/esym nil_s].
rewrite simple_maxnormal => /maxgroupP[_ simG].
have H1: H = 1%G by apply/val_inj/simG; rewrite // sub1G.
by move: nil_s; rewrite H1 eqxx => /eqP->.
Qed.

Lemma exists_comps (G : gTg) : exists s, comps G s.
Proof.
elim: {G} #|G| {1 3}G (leqnn #|G|) => [G | n IHn G cG].
  by rewrite leqNgt cardG_gt0.
have [sG | nsG] := boolP (simple G).
  by exists [:: 1%G]; rewrite /comps eqxx /=  -simple_maxnormal andbT.
have [-> | ntG] := eqVneq G 1%G; first by exists [::]; rewrite /comps eqxx.
have [N maxN] := ex_maxnormal_ntrivg ntG.
have [|s /andP[ls cs]] := IHn N.
  by rewrite -ltnS (leq_trans _ cG) // proper_card // (maxnormal_proper maxN).
by exists (N :: s); apply/and3P.
Qed.

(******************************************************************************)
(* The factors associated to two composition series of the same group are     *)
(* the same up to isomorphism and permutation                                 *)
(******************************************************************************)

Lemma JordanHolderUniqueness (G : gTg) (s1 s2 : seq gTg) :
  comps G s1 -> comps G s2 -> perm_eq (mkfactors G s1) (mkfactors G s2).
Proof.
have [n] := ubnP #|G|; elim: n G => // n Hi G in s1 s2 * => /ltnSE-cG cs1 cs2.
have [G1 | ntG] := boolP (G :==: 1).
  have -> : s1 = [::] by apply/eqP; rewrite -(trivg_comps cs1).
  have -> : s2 = [::] by apply/eqP; rewrite -(trivg_comps cs2).
  by rewrite /= perm_refl.
have [sG | nsG] := boolP (simple G).
  by rewrite (simple_compsP cs1 sG) (simple_compsP cs2 sG) perm_refl.
case es1: s1 cs1 => [|N1 st1] cs1.
  by move: (trivg_comps cs1); rewrite eqxx; move/negP:ntG.
case es2: s2 cs2 => [|N2 st2] cs2 {s1 es1}.
  by move: (trivg_comps cs2); rewrite eqxx; move/negP:ntG.
case/andP: cs1 => /= lst1; case/andP=> maxN_1 pst1.
case/andP: cs2 => /= lst2; case/andP=> maxN_2 pst2.
have cN1 : #|N1| < n.
  by rewrite (leq_trans _ cG) ?proper_card ?(maxnormal_proper maxN_1).
have cN2 : #|N2| < n.
  by rewrite (leq_trans _ cG) ?proper_card ?(maxnormal_proper maxN_2).
case: (N1 =P N2) {s2 es2} => [eN12 |].
  by rewrite eN12 /= perm_cons Hi // /comps ?lst2 //= -eN12 lst1.
move/eqP; rewrite -val_eqE /=; move/eqP=> neN12.
have nN1G : N1 <| G by apply: maxnormal_normal.
have nN2G : N2 <| G by apply: maxnormal_normal.
pose N := (N1 :&: N2)%G.
have nNG : N <| G.
  by rewrite /normal subIset ?(normal_sub nN1G) //= normsI ?normal_norm.
have iso1 : (G / N1)%G \isog (N2 / N)%G.
  rewrite isog_sym /= -(maxnormalM maxN_1 maxN_2) //.
  rewrite (@normC _ N1 N2) ?(subset_trans (normal_sub nN1G)) ?normal_norm //.
  by rewrite weak_second_isog ?(subset_trans (normal_sub nN2G)) ?normal_norm.
have iso2 : (G / N2)%G \isog (N1 / N)%G.
  rewrite isog_sym /= -(maxnormalM maxN_1 maxN_2) // setIC.
  by rewrite weak_second_isog ?(subset_trans (normal_sub nN1G)) ?normal_norm.
have [sN /andP[lsN csN]] := exists_comps N.
have i1 : perm_eq (mksrepr G N1 :: mkfactors N1 st1)
                  [:: mksrepr G N1, mksrepr N1 N & mkfactors N sN].
  rewrite perm_cons -[mksrepr _ _ :: _]/(mkfactors N1 [:: N & sN]).
  apply: Hi=> //; rewrite /comps ?lst1 //= lsN csN andbT /=.
  rewrite -quotient_simple.
    by rewrite -(isog_simple iso2) quotient_simple.
  by rewrite (normalS (subsetIl N1 N2) (normal_sub nN1G)).
have i2 : perm_eq (mksrepr G N2 :: mkfactors N2 st2)
                  [:: mksrepr G N2, mksrepr N2 N & mkfactors N sN].
  rewrite perm_cons -[mksrepr _ _ :: _]/(mkfactors N2 [:: N & sN]).
  apply: Hi=> //; rewrite /comps ?lst2 //= lsN csN andbT /=.
  rewrite -quotient_simple.
    by rewrite -(isog_simple iso1) quotient_simple.
  by rewrite (normalS (subsetIr N1 N2) (normal_sub nN2G)).
pose fG1 := [:: mksrepr G N1, mksrepr N1 N & mkfactors N sN].
pose fG2 := [:: mksrepr G N2, mksrepr N2 N & mkfactors N sN].
have i3 : perm_eq fG1 fG2.
  rewrite (@perm_catCA _ [::_] [::_]) /mksrepr.
  rewrite (@section_repr_isog _ (mkSec _ _) (mkSec _ _) iso1).
  rewrite -(@section_repr_isog _ (mkSec _ _) (mkSec _ _) iso2).
  exact: perm_refl.
apply: (perm_trans i1); apply: (perm_trans i3); rewrite perm_sym.
by apply: perm_trans i2; apply: perm_refl.
Qed.

End CompositionSeries.

(******************************************************************************)
(* Helper lemmas for group actions.                                           *)
(******************************************************************************)

Section MoreGroupAction.

Variables (aT rT : finGroupType).
Variables (A : {group aT}) (D : {group rT}).
Variable to : groupAction A D.

Lemma gactsP (G : {set rT}) : reflect {acts A, on G | to} [acts A, on G | to].
Proof.
apply: (iffP idP) => [nGA x|nGA]; first exact: acts_act.
apply/subsetP=> a Aa /[!inE]; rewrite Aa.
by  apply/subsetP=> x; rewrite inE nGA.
Qed.

Lemma gactsM (N1 N2 : {set rT}) :
    N1 \subset D -> N2 \subset D ->
  [acts A, on N1 | to] -> [acts A, on N2 | to] -> [acts A, on N1 * N2 | to].
Proof.
move=> sN1D sN2D aAN1 aAN2; apply/gactsP=> x Ax y.
apply/idP/idP; case/mulsgP=> y1 y2 N1y1 N2y2 e.
  move: (actKin to Ax y); rewrite e; move<-.
  rewrite gactM ?groupV ?(subsetP sN1D y1) ?(subsetP sN2D) //.
  by apply: mem_mulg; rewrite ?(gactsP _ aAN1) ?(gactsP _ aAN2) // groupV.
rewrite e gactM // ?(subsetP sN1D y1) ?(subsetP sN2D) //.
by apply: mem_mulg; rewrite ?(gactsP _ aAN1) // ?(gactsP _ aAN2).
Qed.

Lemma gactsI (N1 N2 : {set rT}) :
  [acts A, on N1 | to] -> [acts A, on N2 | to] -> [acts A, on N1 :&: N2 | to].
Proof.
move=> aAN1 aAN2.
apply/subsetP=> x Ax; rewrite !inE Ax /=; apply/subsetP=> y Ny /[1!inE].
case/setIP: Ny=> N1y N2y; rewrite inE ?astabs_act  ?N1y ?N2y //.
- by move/subsetP: aAN2; move/(_ x Ax).
- by move/subsetP: aAN1; move/(_ x Ax).
Qed.

Lemma gastabsP (S : {set rT}) (a : aT) :
  a \in A -> reflect (forall x, (to x a \in S) = (x \in S)) (a \in 'N(S | to)).
Proof.
move=> Aa; apply: (iffP idP) => [nSa x|nSa]; first exact: astabs_act.
by rewrite !inE Aa; apply/subsetP=> x; rewrite inE nSa.
Qed.

End MoreGroupAction.

(******************************************************************************)
(* Helper lemmas for quotient actions.                                        *)
(******************************************************************************)

Section MoreQuotientAction.

Variables (aT rT : finGroupType).
Variables (A : {group aT})(D : {group rT}).
Variable to : groupAction A D.

Lemma qact_dom_doms (H : {group rT}) : H \subset D -> qact_dom to H \subset A.
Proof.
by move=> sHD; apply/subsetP=> x; rewrite qact_domE // inE; case/andP.
Qed.

Lemma acts_qact_doms (H : {group rT}) :
  H \subset D -> [acts A, on H | to] -> qact_dom to H :=: A.
Proof.
move=> sHD aH; apply/eqP; rewrite eqEsubset; apply/andP.
split; first exact: qact_dom_doms.
apply/subsetP=> x Ax; rewrite qact_domE //; apply/gastabsP=> //.
by move/gactsP: aH; move/(_ x Ax).
Qed.

Lemma qacts_cosetpre (H : {group rT}) (K' : {group coset_of H}) :
    H \subset D -> [acts A, on H | to] ->
    [acts qact_dom to H, on K' | to / H] ->
  [acts A, on coset H @*^-1 K' | to].
Proof.
move=> sHD aH aK'; apply/subsetP=> x Ax; move: (Ax) (subsetP aK').
rewrite -{1}(acts_qact_doms sHD aH) => qdx; move/(_ x qdx) => nx.
rewrite !inE Ax; apply/subsetP=> y; case/morphpreP=> Ny /= K'Hy /[1!inE].
apply/morphpreP; split; first by rewrite acts_qact_dom_norm.
by move/gastabsP: nx; move/(_  qdx (coset H y)); rewrite K'Hy qactE.
Qed.

Lemma qacts_coset (H K : {group rT}) :
    H \subset D -> [acts A, on K | to] ->
  [acts qact_dom to H, on (coset H) @* K | to / H].
Proof.
move=> sHD aK.
apply/subsetP=> x qdx; rewrite inE qdx inE; apply/subsetP=> y.
case/morphimP=> z Nz Kz /= e; rewrite e inE qactE // imset_f // inE.
move/gactsP: aK; move/(_ x (subsetP (qact_dom_doms sHD) _ qdx) z); rewrite Kz.
move->; move/acts_act: (acts_qact_dom to H); move/(_ x qdx z).
by rewrite Nz andbT.
Qed.

End MoreQuotientAction.

Section StableCompositionSeries.

Variables (aT rT : finGroupType).
Variables (D : {group rT})(A : {group aT}).
Variable to : groupAction A D.

Definition maxainv (B C : {set rT}) :=
  [max C of H |
    [&& (H <| B), ~~ (B \subset H) & [acts A, on H | to]]].

Section MaxAinvProps.

Variables K N : {group rT}.

Lemma maxainv_norm : maxainv K N -> N <| K.
Proof. by move/maxgroupp; case/andP. Qed.

Lemma maxainv_proper : maxainv K N -> N \proper K.
Proof.
by move/maxgroupp; case/andP; rewrite properE; move/normal_sub->; case/andP.
Qed.

Lemma maxainv_sub : maxainv K N -> N \subset K.
Proof. by move=> h; apply: proper_sub; apply: maxainv_proper. Qed.

Lemma maxainv_ainvar : maxainv K N -> A \subset 'N(N | to).
Proof. by move/maxgroupp; case/and3P. Qed.

Lemma maxainvS : maxainv K N -> N \subset K.
Proof. by move=> pNN; rewrite proper_sub // maxainv_proper. Qed.

Lemma maxainv_exists : K :!=: 1 -> {N : {group rT} | maxainv K N}.
Proof.
move=> nt; apply: ex_maxgroup. exists [1 rT]%G.
rewrite /= normal1 subG1 nt /=.
apply/subsetP=> a Da; rewrite !inE Da /= sub1set !inE.
by rewrite /= -actmE // morph1 eqxx.
Qed.

End MaxAinvProps.

Lemma maxainvM (G H K : {group rT}) :
    H \subset D -> K \subset D -> maxainv G H -> maxainv G K ->
  H :<>: K -> H * K = G.
Proof.
move: H K => N1 N2 sN1D sN2D pmN1 pmN2 neN12.
have cN12 : commute N1 N2.
  apply: normC; apply: (subset_trans (maxainv_sub pmN1)).
  by rewrite normal_norm ?maxainv_norm.
wlog nsN21 : G N1 N2 sN1D sN2D pmN1 pmN2 neN12 cN12/ ~~(N1 \subset N2).
  move/eqP: (neN12); rewrite eqEsubset negb_and; case/orP=> ns; first by apply.
  by rewrite cN12; apply=> //; apply: sym_not_eq.
have nP : N1 * N2 <| G by rewrite normalM ?maxainv_norm.
have sN2P : N2 \subset N1 * N2 by rewrite mulg_subr ?group1.
case/maxgroupP: (pmN1); case/andP=> nN1G pN1G mN1.
case/maxgroupP: (pmN2); case/andP=> nN2G pN2G mN2.
case/andP: pN1G=> nsGN1 ha1; case/andP: pN2G=> nsGN2 ha2.
case e : (G \subset N1 * N2).
  by apply/eqP; rewrite eqEsubset e mulG_subG !normal_sub.
have: N1 <*> N2 = N2 by apply: mN2; rewrite /= ?comm_joingE // nP e /= gactsM.
by rewrite comm_joingE // => h; move: nsN21; rewrite -h mulg_subl.
Qed.

Definition asimple (K : {set rT}) := maxainv K 1.

Implicit Types (H K : {group rT}) (s : seq {group rT}).

Lemma asimpleP K :
  reflect [/\ K :!=: 1
            & forall H, H <| K -> [acts A, on H | to] -> H :=: 1 \/ H :=: K]
          (asimple K).
Proof.
apply: (iffP idP).
  case/maxgroupP; rewrite normal1 /=; case/andP=> nsK1 aK H1.
  rewrite eqEsubset negb_and nsK1 /=; split => // H nHK ha.
  case eHK : (H :==: K); first by right; apply/eqP.
  left; apply: H1; rewrite ?sub1G // nHK; move/negbT: eHK.
  by rewrite eqEsubset negb_and normal_sub //=; move->.
case=> ntK h; apply/maxgroupP; split.
  move: ntK; rewrite eqEsubset sub1G andbT normal1; move->.
  apply/subsetP=> a Da; rewrite !inE Da /= sub1set !inE.
  by rewrite /= -actmE // morph1 eqxx.
move=> H /andP[nHK /andP[nsKH ha]] _.
case: (h _ nHK ha)=> // /eqP; rewrite eqEsubset.
by rewrite (negbTE nsKH) andbF.
Qed.

Definition acomps K s :=
  ((last K s) == 1%G) && path [rel x y : {group rT} | maxainv x y] K s.

Lemma acompsP K s :
  reflect (last K s = 1%G /\  path [rel x y : {group rT} | maxainv x y] K s)
          (acomps K s).
Proof. by apply: (iffP andP); case; move/eqP. Qed.

Lemma trivg_acomps K s : acomps K s -> (K :==: 1) = (s == [::]).
Proof.
case/andP=> ls cs; apply/eqP/eqP; last first.
  by move=> se; rewrite se /= in ls; apply/eqP.
move=> G1; case: s ls cs => // H s _ /=; case/andP; case/maxgroupP.
by rewrite G1 sub1G andbF.
Qed.

Lemma acomps_cons K H s : acomps K (H :: s) -> acomps H s.
Proof. by case/andP => /= ls; case/andP=> _ p; rewrite /acomps ls. Qed.

Lemma asimple_acompsP K s : acomps K s -> reflect (s = [:: 1%G]) (asimple K).
Proof.
move=> cs; apply: (iffP idP); last first.
  by move=> se; move: cs; rewrite se /=; case/andP=> /=; rewrite andbT.
case: s cs.
  by rewrite /acomps /= andbT; move/eqP->; case/asimpleP; rewrite eqxx.
move=> H s cs sG; apply/eqP.
rewrite eqseq_cons -(trivg_acomps (acomps_cons cs)) andbC andbb.
case/acompsP: cs => /= ls; case/andP=> mH ps.
case/maxgroupP: sG; case/and3P => _ ntG _ ->; rewrite ?sub1G //.
rewrite (maxainv_norm mH); case/andP: (maxainv_proper mH)=> _ ->.
exact: (maxainv_ainvar mH).
Qed.

Lemma exists_acomps K : exists s, acomps K s.
Proof.
elim: {K} #|K| {1 3}K (leqnn #|K|) => [K | n Hi K cK].
  by rewrite leqNgt cardG_gt0.
case/orP: (orbN (asimple K)) => [sK | nsK].
  by exists [:: (1%G : {group rT})]; rewrite /acomps eqxx /= andbT.
case/orP: (orbN (K :==: 1))=> [tK | ntK].
  by exists (Nil _); rewrite /acomps /= andbT.
case: (maxainv_exists ntK)=> N pmN.
have cN: #|N| <= n.
  by rewrite -ltnS (leq_trans _ cK) // proper_card // (maxainv_proper pmN).
case: (Hi _ cN)=> s; case/andP=> lasts ps; exists [:: N & s]; rewrite /acomps.
by rewrite last_cons lasts /= pmN.
Qed.

End StableCompositionSeries.

Arguments maxainv {aT rT D%G A%G} to%gact B%g C%g.
Arguments asimple {aT rT D%G A%G} to%gact K%g.

Section StrongJordanHolder.

Section AuxiliaryLemmas.

Variables aT rT : finGroupType.
Variables (A : {group aT}) (D : {group rT}) (to : groupAction A D).

Lemma maxainv_asimple_quo (G H : {group rT}) :
   H \subset D -> maxainv to G H -> asimple (to / H) (G / H).
Proof.
move=> sHD /maxgroupP[/and3P[nHG pHG aH] Hmax].
apply/asimpleP; split; first by rewrite -subG1 quotient_sub1 ?normal_norm.
move=> K' nK'Q aK'.
have: (K' \proper (G / H)) || (G / H == K').
  by rewrite properE eqEsubset andbC (normal_sub nK'Q) !andbT orbC orbN.
case/orP=> [ pHQ | eQH]; last by right; apply sym_eq; apply/eqP.
left; pose K := ((coset H) @*^-1 K')%G.
have eK'I : K' \subset (coset H) @* 'N(H).
  by rewrite (subset_trans (normal_sub nK'Q)) ?morphimS ?normal_norm.
have eKK' : K' :=: K / H by rewrite /(K / H) morphpreK //=.
suff eKH : K :=: H by rewrite -trivg_quotient eKK' eKH.
have sHK : H \subset K by rewrite -ker_coset kerE morphpreS // sub1set group1.
apply: Hmax => //; apply/and3P; split; last exact: qacts_cosetpre.
  by rewrite -(quotientGK nHG) cosetpre_normal.
by move: (proper_subn pHQ); rewrite sub_morphim_pre ?normal_norm.
Qed.

Lemma asimple_quo_maxainv (G H : {group rT}) :
    H \subset D -> G \subset D -> [acts A, on G | to] -> [acts A, on H | to] ->
    H <| G -> asimple (to / H) (G / H) ->
  maxainv to G H.
Proof.
move=> sHD sGD aG aH nHG /asimpleP[ntQ maxQ]; apply/maxgroupP; split.
  by rewrite nHG -quotient_sub1 ?normal_norm // subG1 ntQ.
move=> K /and3P[nKG nsGK aK] sHK.
pose K' := (K / H)%G.
have K'dQ : K' <| (G / H)%G by apply: morphim_normal.
have nKH : H <| K by rewrite (normalS _ _ nHG) // normal_sub.
have: K' :=: 1%G \/ K' :=: (G / H).
  apply: (maxQ K' K'dQ) => /=.
  apply/subsetP=> x Adx. rewrite inE Adx /= inE. apply/subsetP=> y.
  rewrite quotientE; case/morphimP=> z Nz Kz ->; rewrite /= !inE qactE //.
  have ntoyx :  to z x \in 'N(H) by  rewrite (acts_qact_dom_norm Adx).
  apply/morphimP; exists (to z x) => //.
  suff h: qact_dom to H \subset A.
    by rewrite astabs_act // (subsetP aK) //; apply: (subsetP h).
  by apply/subsetP=> t; rewrite qact_domE // inE; case/andP.
case=> [|/quotient_injG /[!inE]/(_ nKH nHG) c]; last by rewrite c subxx in nsGK.
rewrite /= -trivg_quotient => tK'; apply: (congr1 (@gval _)); move: tK'.
by apply: (@quotient_injG _ H); rewrite ?inE /= ?normal_refl.
Qed.

Lemma asimpleI (N1 N2 : {group rT}) :
    N2 \subset 'N(N1) -> N1 \subset D ->
    [acts A, on N1 | to] -> [acts A, on N2 | to] ->
    asimple (to / N1) (N2 / N1) ->
  asimple (to / (N2 :&: N1)) (N2 / (N2 :&: N1)).
Proof.
move=> nN21 sN1D aN1 aN2 /asimpleP[ntQ1 max1].
have [f1 [f1e f1ker f1pre f1im]] := restrmP (coset_morphism N1) nN21.
have hf2' : N2 \subset 'N(N2 :&: N1) by apply: normsI => //; rewrite normG.
have hf2'' : 'ker (coset (N2 :&: N1)) \subset 'ker f1.
  by rewrite f1ker !ker_coset.
pose f2 := factm_morphism  hf2'' hf2'.
apply/asimpleP; split.
   rewrite /= setIC; apply/negP; move: (second_isog nN21); move/isog_eq1->.
   by apply/negP.
move=> H nHQ2 aH; pose K := f2 @* H.
have nKQ1 : K <| N2 / N1.
  rewrite (_ : N2 / N1 = f2 @* (N2 / (N2 :&: N1))) ?morphim_normal //.
  by rewrite morphim_factm f1im.
have sqA : qact_dom to N1 \subset A.
  by apply/subsetP=> t; rewrite qact_domE // inE; case/andP.
have nNN2 : (N2 :&: N1) <| N2.
  by rewrite /normal subsetIl; apply: normsI => //; apply: normG.
have aKQ1 : [acts qact_dom to N1, on K | to / N1].
  pose H':= coset (N2 :&: N1)@*^-1 H.
  have eHH' : H :=: H' / (N2 :&: N1) by rewrite cosetpreK.
  have -> : K :=: f1 @* H' by rewrite /K eHH' morphim_factm.
  have sH'N2 : H' \subset N2.
    rewrite /H' eHH' quotientGK ?normal_cosetpre //=.
    by rewrite sub_cosetpre_quo ?normal_sub.
  have -> : f1 @* H' = coset N1 @* H' by rewrite f1im //=.
  apply: qacts_coset => //; apply: qacts_cosetpre => //; last exact: gactsI.
  by apply: (subset_trans (subsetIr _ _)).
have injf2 : 'injm f2.
  by rewrite ker_factm f1ker /= ker_coset /= subG1 /= -quotientE trivg_quotient.
have iHK : H \isog K.
  apply/isogP; pose f3 := restrm_morphism (normal_sub nHQ2) f2.
  by exists f3; rewrite 1?injm_restrm // morphim_restrm setIid.
case: (max1 _ nKQ1 aKQ1).
  by move/eqP; rewrite -(isog_eq1 iHK); move/eqP->; left.
move=> he /=; right; apply/eqP; rewrite eqEcard normal_sub //=.
move: (second_isog nN21); rewrite setIC; move/card_isog->; rewrite -he.
by move/card_isog: iHK=> <-; rewrite leqnn.
Qed.

End AuxiliaryLemmas.

Variables (aT rT : finGroupType).
Variables (A : {group aT}) (D : {group rT}) (to : groupAction A D).

(******************************************************************************)
(* The factors associated to two A-stable composition series of the same      *)
(* group are the same up to isomorphism and permutation                       *)
(******************************************************************************)

Lemma StrongJordanHolderUniqueness (G : {group rT}) (s1 s2 : seq {group rT}) :
    G \subset D -> acomps to G s1 -> acomps to G s2 ->
  perm_eq (mkfactors G s1) (mkfactors G s2).
Proof.
have [n] := ubnP #|G|; elim: n G => // n Hi G in s1 s2 * => cG hsD cs1 cs2.
case/orP: (orbN (G :==: 1)) => [tG | ntG].
  have -> : s1 = [::] by apply/eqP; rewrite -(trivg_acomps cs1).
  have -> : s2 = [::] by apply/eqP; rewrite -(trivg_acomps cs2).
  by rewrite /= perm_refl.
case/orP: (orbN (asimple to G))=> [sG | nsG].
  have -> : s1 = [:: 1%G ] by apply/(asimple_acompsP cs1).
  have -> : s2 = [:: 1%G ] by apply/(asimple_acompsP cs2).
  by rewrite /= perm_refl.
case es1: s1 cs1 => [|N1 st1] cs1.
  by move: (trivg_comps cs1); rewrite eqxx; move/negP:ntG.
case es2: s2 cs2 => [|N2 st2] cs2 {s1 es1}.
  by move: (trivg_comps cs2); rewrite eqxx; move/negP:ntG.
case/andP: cs1 => /= lst1; case/andP=> maxN_1 pst1.
case/andP: cs2 => /= lst2; case/andP=> maxN_2 pst2.
have sN1D : N1 \subset D.
  by apply: subset_trans hsD; apply: maxainv_sub maxN_1.
have sN2D : N2 \subset D.
  by apply: subset_trans hsD; apply: maxainv_sub maxN_2.
have cN1 : #|N1| < n.
  by rewrite -ltnS (leq_trans _ cG) ?ltnS ?proper_card ?(maxainv_proper maxN_1).
have cN2 : #|N2| < n.
  by rewrite -ltnS (leq_trans _ cG) ?ltnS ?proper_card ?(maxainv_proper maxN_2).
case: (N1 =P N2) {s2 es2} => [eN12 |].
  by rewrite eN12 /= perm_cons Hi // /acomps ?lst2 //= -eN12 lst1.
move/eqP; rewrite -val_eqE /=; move/eqP=> neN12.
have nN1G : N1 <| G by apply: (maxainv_norm maxN_1).
have nN2G : N2 <| G by apply: (maxainv_norm maxN_2).
pose N := (N1 :&: N2)%G.
have nNG : N <| G.
  by rewrite /normal subIset ?(normal_sub nN1G) //= normsI ?normal_norm.
have iso1 : (G / N1)%G \isog (N2 / N)%G.
  rewrite isog_sym /= -(maxainvM _ _ maxN_1 maxN_2) //.
  rewrite (@normC _ N1 N2) ?(subset_trans (normal_sub nN1G)) ?normal_norm //.
  by rewrite weak_second_isog ?(subset_trans (normal_sub nN2G)) ?normal_norm.
have iso2 : (G / N2)%G \isog (N1 / N)%G.
  rewrite isog_sym /= -(maxainvM _ _ maxN_1 maxN_2) // setIC.
  by rewrite weak_second_isog ?(subset_trans (normal_sub nN1G)) ?normal_norm.
case: (exists_acomps to N)=> sN; case/andP=> lsN csN.
have aN1 : [acts A, on N1 | to].
  by case/maxgroupP: maxN_1; case/and3P.
have aN2 : [acts A, on N2 | to].
  by case/maxgroupP: maxN_2; case/and3P.
have nNN1 : N <| N1.
  by apply: (normalS _ _ nNG); rewrite ?subsetIl ?normal_sub.
have nNN2 : N <| N2.
  by apply: (normalS _ _ nNG); rewrite ?subsetIr ?normal_sub.
have aN : [ acts A, on N1 :&: N2 | to].
  apply/subsetP=> x Ax; rewrite !inE Ax /=; apply/subsetP=> y Ny; rewrite inE.
  case/setIP: Ny=> N1y N2y. rewrite inE ?astabs_act  ?N1y ?N2y //.
    by move/subsetP: aN2; move/(_ x Ax).
  by move/subsetP: aN1; move/(_ x Ax).
have i1 : perm_eq (mksrepr G N1 :: mkfactors N1 st1)
                  [:: mksrepr G N1, mksrepr N1 N & mkfactors N sN].
  rewrite perm_cons -[mksrepr _ _ :: _]/(mkfactors N1 [:: N & sN]).
  apply: Hi=> //; rewrite /acomps ?lst1 //= lsN csN andbT /=.
  apply: asimple_quo_maxainv=> //; first by apply: subIset; rewrite sN1D.
  apply: asimpleI => //.
    by apply: subset_trans (normal_norm nN2G); apply: normal_sub.
  rewrite -quotientMidl (maxainvM _ _ maxN_2) //.
    by apply: maxainv_asimple_quo.
  by move=> e; apply: neN12.
have i2 : perm_eq (mksrepr G N2 :: mkfactors N2 st2)
                  [:: mksrepr G N2, mksrepr N2 N & mkfactors N sN].
  rewrite perm_cons -[mksrepr _ _ :: _]/(mkfactors N2 [:: N & sN]).
  apply: Hi=> //; rewrite /acomps ?lst2 //= lsN csN andbT /=.
  apply: asimple_quo_maxainv=> //; first by apply: subIset; rewrite sN1D.
  have e : N1 :&: N2 :=: N2 :&: N1 by rewrite setIC.
  rewrite (group_inj (setIC N1 N2)); apply: asimpleI => //.
    by apply: subset_trans (normal_norm nN1G); apply: normal_sub.
  rewrite -quotientMidl (maxainvM _ _ maxN_1) //.
  exact: maxainv_asimple_quo.
pose fG1 := [:: mksrepr G N1, mksrepr N1 N & mkfactors N sN].
pose fG2 := [:: mksrepr G N2, mksrepr N2 N & mkfactors N sN].
have i3 : perm_eq fG1 fG2.
  rewrite (@perm_catCA _ [::_] [::_]) /mksrepr.
  rewrite (@section_repr_isog _ (mkSec _ _) (mkSec _ _) iso1).
  rewrite -(@section_repr_isog _ (mkSec _ _) (mkSec _ _) iso2).
  exact: perm_refl.
apply: (perm_trans i1); apply: (perm_trans i3); rewrite perm_sym.
by apply: perm_trans i2; apply: perm_refl.
Qed.

End StrongJordanHolder.