(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: R_Ifp.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(**********************************************************)
(** Complements for the reals.Integer and fractional part *)
(*                                                        *)
(**********************************************************)

Require Import Rbase.
Require Import Omega.
Open Local Scope R_scope.

(*********************************************************)
(** *    Fractional part                                 *)
(*********************************************************)

(**********)
Definition Int_part (r:R) : Z := (up r - 1)%Z.

(**********)
Definition frac_part (r:R) : R := r - IZR (Int_part r).

(**********)
Lemma tech_up : forall (r:R) (z:Z), r < IZR z -> IZR z <= r + 1 -> z = up r.
Proof.
  intros; generalize (archimed r); intro; elim H1; intros; clear H1;
    unfold Rgt in H2; unfold Rminus in H3;
      generalize (Rplus_le_compat_l r (IZR (up r) + - r) 1 H3);
        intro; clear H3; rewrite (Rplus_comm (IZR (up r)) (- r)) in H1;
          rewrite <- (Rplus_assoc r (- r) (IZR (up r))) in H1;
            rewrite (Rplus_opp_r r) in H1; elim (Rplus_ne (IZR (up r)));
              intros a b; rewrite b in H1; clear a b; apply (single_z_r_R1 r z (up r));
                auto with zarith real.
Qed.

(**********)
Lemma up_tech :
  forall (r:R) (z:Z), IZR z <= r -> r < IZR (z + 1) -> (z + 1)%Z = up r.
Proof.
  intros; generalize (Rplus_le_compat_l 1 (IZR z) r H); intro; clear H;
    rewrite (Rplus_comm 1 (IZR z)) in H1; rewrite (Rplus_comm 1 r) in H1;
      cut (1 = IZR 1); auto with zarith real.
  intro; generalize H1; pattern 1 at 1 in |- *; rewrite H; intro; clear H H1;
    rewrite <- (plus_IZR z 1) in H2; apply (tech_up r (z + 1));
      auto with zarith real.
Qed.

(**********)
Lemma fp_R0 : frac_part 0 = 0.
Proof.
  unfold frac_part in |- *; unfold Int_part in |- *; elim (archimed 0); intros;
    unfold Rminus in |- *; elim (Rplus_ne (- IZR (up 0 - 1)));
      intros a b; rewrite b; clear a b; rewrite <- Z_R_minus;
        cut (up 0 = 1%Z).
  intro; rewrite H1;
    rewrite (Rminus_diag_eq (IZR 1) (IZR 1) (refl_equal (IZR 1)));
      apply Ropp_0.
  elim (archimed 0); intros; clear H2; unfold Rgt in H1;
    rewrite (Rminus_0_r (IZR (up 0))) in H0; generalize (lt_O_IZR (up 0) H1);
      intro; clear H1; generalize (le_IZR_R1 (up 0) H0);
        intro; clear H H0; omega.
Qed.

(**********)
Lemma for_base_fp : forall r:R, IZR (up r) - r > 0 /\ IZR (up r) - r <= 1.
Proof.
  intro; split; cut (IZR (up r) > r /\ IZR (up r) - r <= 1).
  intro; elim H; intros.
  apply (Rgt_minus (IZR (up r)) r H0).
  apply archimed.
  intro; elim H; intros.
  exact H1.
  apply archimed.
Qed.

(**********)
Lemma base_fp : forall r:R, frac_part r >= 0 /\ frac_part r < 1.
Proof.
  intro; unfold frac_part in |- *; unfold Int_part in |- *; split.
     (*sup a O*)
  cut (r - IZR (up r) >= -1).
  rewrite <- Z_R_minus; simpl in |- *; intro; unfold Rminus in |- *;
    rewrite Ropp_plus_distr; rewrite <- Rplus_assoc;
      fold (r - IZR (up r)) in |- *; fold (r - IZR (up r) - -1) in |- *;
        apply Rge_minus; auto with zarith real.
  rewrite <- Ropp_minus_distr; apply Ropp_le_ge_contravar; elim (for_base_fp r);
    auto with zarith real.
    (*inf a 1*)
  cut (r - IZR (up r) < 0).
  rewrite <- Z_R_minus; simpl in |- *; intro; unfold Rminus in |- *;
    rewrite Ropp_plus_distr; rewrite <- Rplus_assoc;
      fold (r - IZR (up r)) in |- *; rewrite Ropp_involutive;
        elim (Rplus_ne 1); intros a b; pattern 1 at 2 in |- *;
          rewrite <- a; clear a b; rewrite (Rplus_comm (r - IZR (up r)) 1);
            apply Rplus_lt_compat_l; auto with zarith real.
  elim (for_base_fp r); intros; rewrite <- Ropp_0; rewrite <- Ropp_minus_distr;
    apply Ropp_gt_lt_contravar; auto with zarith real.
Qed.

(*********************************************************)
(** *    Properties                                      *)
(*********************************************************)

(**********)
Lemma base_Int_part :
  forall r:R, IZR (Int_part r) <= r /\ IZR (Int_part r) - r > -1.
Proof.
  intro; unfold Int_part in |- *; elim (archimed r); intros.
  split; rewrite <- (Z_R_minus (up r) 1); simpl in |- *.
  generalize (Rle_minus (IZR (up r) - r) 1 H0); intro; unfold Rminus in H1;
    rewrite (Rplus_assoc (IZR (up r)) (- r) (-1)) in H1;
      rewrite (Rplus_comm (- r) (-1)) in H1;
        rewrite <- (Rplus_assoc (IZR (up r)) (-1) (- r)) in H1;
          fold (IZR (up r) - 1) in H1; fold (IZR (up r) - 1 - r) in H1;
            apply Rminus_le; auto with zarith real.
  generalize (Rplus_gt_compat_l (-1) (IZR (up r)) r H); intro;
    rewrite (Rplus_comm (-1) (IZR (up r))) in H1;
      generalize (Rplus_gt_compat_l (- r) (IZR (up r) + -1) (-1 + r) H1);
        intro; clear H H0 H1; rewrite (Rplus_comm (- r) (IZR (up r) + -1)) in H2;
          fold (IZR (up r) - 1) in H2; fold (IZR (up r) - 1 - r) in H2;
            rewrite (Rplus_comm (- r) (-1 + r)) in H2;
              rewrite (Rplus_assoc (-1) r (- r)) in H2; rewrite (Rplus_opp_r r) in H2;
                elim (Rplus_ne (-1)); intros a b; rewrite a in H2;
                  clear a b; auto with zarith real.
Qed.

(**********)
Lemma Int_part_INR : forall n:nat, Int_part (INR n) = Z_of_nat n.
Proof.
  intros n; unfold Int_part in |- *.
  cut (up (INR n) = (Z_of_nat n + Z_of_nat 1)%Z).
  intros H'; rewrite H'; simpl in |- *; ring.
  apply sym_equal; apply tech_up; auto.
  replace (Z_of_nat n + Z_of_nat 1)%Z with (Z_of_nat (S n)).
  repeat rewrite <- INR_IZR_INZ.
  apply lt_INR; auto.
  rewrite Zplus_comm; rewrite <- Znat.inj_plus; simpl in |- *; auto.
  rewrite plus_IZR; simpl in |- *; auto with real.
  repeat rewrite <- INR_IZR_INZ; auto with real.
Qed.

(**********)
Lemma fp_nat : forall r:R, frac_part r = 0 ->  exists c : Z, r = IZR c.
Proof.
  unfold frac_part in |- *; intros; split with (Int_part r);
    apply Rminus_diag_uniq; auto with zarith real.
Qed.

(**********)
Lemma R0_fp_O : forall r:R, 0 <> frac_part r -> 0 <> r.
Proof.
  red in |- *; intros; rewrite <- H0 in H; generalize fp_R0; intro;
    auto with zarith real.
Qed.

(**********)
Lemma Rminus_Int_part1 :
  forall r1 r2:R,
    frac_part r1 >= frac_part r2 ->
    Int_part (r1 - r2) = (Int_part r1 - Int_part r2)%Z.
Proof.
  intros; elim (base_fp r1); elim (base_fp r2); intros;
    generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0;
      generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4);
        intro; clear H4; rewrite Ropp_0 in H0;
          generalize (Rge_le 0 (- frac_part r2) H0); intro;
            clear H0; generalize (Rge_le (frac_part r1) 0 H2);
              intro; clear H2; generalize (Ropp_lt_gt_contravar (frac_part r2) 1 H1);
                intro; clear H1; unfold Rgt in H2;
                  generalize
                    (sum_inequa_Rle_lt 0 (frac_part r1) 1 (-1) (- frac_part r2) 0 H0 H3 H2 H4);
                    intro; elim H1; intros; clear H1; elim (Rplus_ne 1);
                      intros a b; rewrite a in H6; clear a b H5;
                        generalize (Rge_minus (frac_part r1) (frac_part r2) H);
                          intro; clear H; fold (frac_part r1 - frac_part r2) in H6;
                            generalize (Rge_le (frac_part r1 - frac_part r2) 0 H1);
                              intro; clear H1 H3 H4 H0 H2; unfold frac_part in H6, H;
                                unfold Rminus in H6, H;
                                  rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H;
                                    rewrite (Ropp_involutive (IZR (Int_part r2))) in H;
                                      rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
                                        in H;
                                        rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
                                          in H; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H;
                                            rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H;
                                              rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
                                                in H; rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H;
                                                  fold (r1 - r2) in H; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H;
                                                    generalize
                                                      (Rplus_le_compat_l (IZR (Int_part r1) - IZR (Int_part r2)) 0
                                                        (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H);
                                                      intro; clear H;
                                                        rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H0;
                                                          rewrite <-
                                                            (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
                                                              (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
                                                            in H0; unfold Rminus in H0; fold (r1 - r2) in H0;
                                                              rewrite
                                                                (Rplus_assoc (IZR (Int_part r1)) (- IZR (Int_part r2))
                                                                  (IZR (Int_part r2) + - IZR (Int_part r1))) in H0;
                                                                rewrite <-
                                                                  (Rplus_assoc (- IZR (Int_part r2)) (IZR (Int_part r2))
                                                                    (- IZR (Int_part r1))) in H0;
                                                                  rewrite (Rplus_opp_l (IZR (Int_part r2))) in H0;
                                                                    elim (Rplus_ne (- IZR (Int_part r1))); intros a b;
                                                                      rewrite b in H0; clear a b;
                                                                        elim (Rplus_ne (IZR (Int_part r1) + - IZR (Int_part r2)));
                                                                          intros a b; rewrite a in H0; clear a b;
                                                                            rewrite (Rplus_opp_r (IZR (Int_part r1))) in H0; elim (Rplus_ne (r1 - r2));
                                                                              intros a b; rewrite b in H0; clear a b;
                                                                                fold (IZR (Int_part r1) - IZR (Int_part r2)) in H0;
                                                                                rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H6;
                                                                                rewrite (Ropp_involutive (IZR (Int_part r2))) in H6;
                                                                                rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
                                                                                in H6;
                                                                                rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
                                                                                in H6; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H6;
                                                                                rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H6;
                                                                                rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
                                                                                in H6;
                                                                                rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H6;
                                                                                fold (r1 - r2) in H6; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H6;
                                                                                generalize
                                                                                (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2))
                                                                                (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 1 H6);
                                                                                intro; clear H6;
                                                                                rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H;
                                                                                rewrite <-
                                                                                (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
                                                                                (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
                                                                                in H;
                                                                                rewrite <- (Ropp_minus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H;
                                                                                rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H;
                                                                                elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H;
                                                                                clear a b; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0;
                                                                                rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H;
                                                                                cut (1 = IZR 1); auto with zarith real.
  intro; rewrite H1 in H; clear H1;
    rewrite <- (plus_IZR (Int_part r1 - Int_part r2) 1) in H;
      generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2) H0 H);
        intros; clear H H0; unfold Int_part at 1 in |- *;
          omega.
Qed.

(**********)
Lemma Rminus_Int_part2 :
  forall r1 r2:R,
    frac_part r1 < frac_part r2 ->
    Int_part (r1 - r2) = (Int_part r1 - Int_part r2 - 1)%Z.
Proof.
  intros; elim (base_fp r1); elim (base_fp r2); intros;
    generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0;
      generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4);
        intro; clear H4; rewrite Ropp_0 in H0;
          generalize (Rge_le 0 (- frac_part r2) H0); intro;
            clear H0; generalize (Rge_le (frac_part r1) 0 H2);
              intro; clear H2; generalize (Ropp_lt_gt_contravar (frac_part r2) 1 H1);
                intro; clear H1; unfold Rgt in H2;
                  generalize
                    (sum_inequa_Rle_lt 0 (frac_part r1) 1 (-1) (- frac_part r2) 0 H0 H3 H2 H4);
                    intro; elim H1; intros; clear H1; elim (Rplus_ne (-1));
                      intros a b; rewrite b in H5; clear a b H6;
                        generalize (Rlt_minus (frac_part r1) (frac_part r2) H);
                          intro; clear H; fold (frac_part r1 - frac_part r2) in H5;
                            clear H3 H4 H0 H2; unfold frac_part in H5, H1; unfold Rminus in H5, H1;
                              rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H5;
                                rewrite (Ropp_involutive (IZR (Int_part r2))) in H5;
                                  rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
                                    in H5;
                                    rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
                                      in H5; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H5;
                                        rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H5;
                                          rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
                                            in H5;
                                            rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H5;
                                              fold (r1 - r2) in H5; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H5;
                                                generalize
                                                  (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2)) (-1)
                                                    (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H5);
                                                  intro; clear H5;
                                                    rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H;
                                                      rewrite <-
                                                        (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
                                                          (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
                                                        in H; unfold Rminus in H; fold (r1 - r2) in H;
                                                          rewrite
                                                            (Rplus_assoc (IZR (Int_part r1)) (- IZR (Int_part r2))
                                                              (IZR (Int_part r2) + - IZR (Int_part r1))) in H;
                                                            rewrite <-
                                                              (Rplus_assoc (- IZR (Int_part r2)) (IZR (Int_part r2))
                                                                (- IZR (Int_part r1))) in H;
                                                              rewrite (Rplus_opp_l (IZR (Int_part r2))) in H;
                                                                elim (Rplus_ne (- IZR (Int_part r1))); intros a b;
                                                                  rewrite b in H; clear a b; rewrite (Rplus_opp_r (IZR (Int_part r1))) in H;
                                                                    elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H;
                                                                      clear a b; fold (IZR (Int_part r1) - IZR (Int_part r2)) in H;
                                                                        fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H;
                                                                          rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H1;
                                                                            rewrite (Ropp_involutive (IZR (Int_part r2))) in H1;
                                                                              rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
                                                                                in H1;
                                                                                rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
                                                                                in H1; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H1;
                                                                                rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
                                                                                rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
                                                                                in H1;
                                                                                rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
                                                                                fold (r1 - r2) in H1; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H1;
                                                                                generalize
                                                                                (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2))
                                                                                (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 0 H1);
                                                                                intro; clear H1;
                                                                                rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H0;
                                                                                rewrite <-
                                                                                (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
                                                                                (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
                                                                                in H0;
                                                                                rewrite <- (Ropp_minus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H0;
                                                                                rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H0;
                                                                                elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H0;
                                                                                clear a b; rewrite <- (Rplus_opp_l 1) in H0;
                                                                                rewrite <- (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2)) (-1) 1)
                                                                                in H0; fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H0;
                                                                                rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0;
                                                                                rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H;
                                                                                cut (1 = IZR 1); auto with zarith real.
  intro; rewrite H1 in H; rewrite H1 in H0; clear H1;
    rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H;
      rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H0;
        rewrite <- (plus_IZR (Int_part r1 - Int_part r2 - 1) 1) in H0;
          generalize (Rlt_le (IZR (Int_part r1 - Int_part r2 - 1)) (r1 - r2) H);
            intro; clear H;
              generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2 - 1) H1 H0);
                intros; clear H0 H1; unfold Int_part at 1 in |- *;
                  omega.
Qed.

(**********)
Lemma Rminus_fp1 :
  forall r1 r2:R,
    frac_part r1 >= frac_part r2 ->
    frac_part (r1 - r2) = frac_part r1 - frac_part r2.
Proof.
  intros; unfold frac_part in |- *; generalize (Rminus_Int_part1 r1 r2 H);
    intro; rewrite H0; rewrite <- (Z_R_minus (Int_part r1) (Int_part r2));
      unfold Rminus in |- *;
        rewrite (Ropp_plus_distr (IZR (Int_part r1)) (- IZR (Int_part r2)));
          rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2)));
            rewrite (Ropp_involutive (IZR (Int_part r2)));
              rewrite (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)));
                rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)));
                  rewrite <- (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2)));
                    rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)));
                      rewrite (Rplus_comm (- r2) (- IZR (Int_part r1)));
                        auto with zarith real.
Qed.

(**********)
Lemma Rminus_fp2 :
  forall r1 r2:R,
    frac_part r1 < frac_part r2 ->
    frac_part (r1 - r2) = frac_part r1 - frac_part r2 + 1.
Proof.
  intros; unfold frac_part in |- *; generalize (Rminus_Int_part2 r1 r2 H);
    intro; rewrite H0; rewrite <- (Z_R_minus (Int_part r1 - Int_part r2) 1);
      rewrite <- (Z_R_minus (Int_part r1) (Int_part r2));
        unfold Rminus in |- *;
          rewrite
            (Ropp_plus_distr (IZR (Int_part r1) + - IZR (Int_part r2)) (- IZR 1))
            ; rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2)));
              rewrite (Ropp_involutive (IZR 1));
                rewrite (Ropp_involutive (IZR (Int_part r2)));
                  rewrite (Ropp_plus_distr (IZR (Int_part r1)));
                    rewrite (Ropp_involutive (IZR (Int_part r2))); simpl in |- *;
                      rewrite <-
                        (Rplus_assoc (r1 + - r2) (- IZR (Int_part r1) + IZR (Int_part r2)) 1)
                        ; rewrite (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)));
                          rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)));
                            rewrite <- (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2)));
                              rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)));
                                rewrite (Rplus_comm (- r2) (- IZR (Int_part r1)));
                                  auto with zarith real.
Qed.

(**********)
Lemma plus_Int_part1 :
  forall r1 r2:R,
    frac_part r1 + frac_part r2 >= 1 ->
    Int_part (r1 + r2) = (Int_part r1 + Int_part r2 + 1)%Z.
Proof.
  intros; generalize (Rge_le (frac_part r1 + frac_part r2) 1 H); intro; clear H;
    elim (base_fp r1); elim (base_fp r2); intros; clear H H2;
      generalize (Rplus_lt_compat_l (frac_part r2) (frac_part r1) 1 H3);
        intro; clear H3; generalize (Rplus_lt_compat_l 1 (frac_part r2) 1 H1);
          intro; clear H1; rewrite (Rplus_comm 1 (frac_part r2)) in H2;
            generalize
              (Rlt_trans (frac_part r2 + frac_part r1) (frac_part r2 + 1) 2 H H2);
              intro; clear H H2; rewrite (Rplus_comm (frac_part r2) (frac_part r1)) in H1;
                unfold frac_part in H0, H1; unfold Rminus in H0, H1;
                  rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
                    in H1; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H1;
                      rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2)
                        in H1;
                        rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H1;
                          rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
                            in H1;
                            rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
                              rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
                                in H0; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H0;
                                  rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2)
                                    in H0;
                                    rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H0;
                                      rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
                                        in H0;
                                        rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H0;
                                          generalize
                                            (Rplus_le_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) 1
                                              (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H0);
                                            intro; clear H0;
                                              generalize
                                                (Rplus_lt_compat_l (IZR (Int_part r1) + IZR (Int_part r2))
                                                  (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 2 H1);
                                                intro; clear H1;
                                                  rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
                                                    in H;
                                                    rewrite <-
                                                      (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
                                                        (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
                                                      in H; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H;
                                                        elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H;
                                                          clear a b;
                                                            rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
                                                              in H0;
                                                              rewrite <-
                                                                (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
                                                                  (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
                                                                in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0;
                                                                  elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0;
                                                                    clear a b;
                                                                      rewrite <- (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) 1 1) in H0;
                                                                        cut (1 = IZR 1); auto with zarith real.
  intro; rewrite H1 in H0; rewrite H1 in H; clear H1;
    rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H;
      rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0;
        rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H;
          rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H0;
            rewrite <- (plus_IZR (Int_part r1 + Int_part r2 + 1) 1) in H0;
              generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2 + 1) H H0);
                intro; clear H H0; unfold Int_part at 1 in |- *; omega.
Qed.

(**********)
Lemma plus_Int_part2 :
  forall r1 r2:R,
    frac_part r1 + frac_part r2 < 1 ->
    Int_part (r1 + r2) = (Int_part r1 + Int_part r2)%Z.
Proof.
  intros; elim (base_fp r1); elim (base_fp r2); intros; clear H1 H3;
    generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0;
      generalize (Rge_le (frac_part r1) 0 H2); intro; clear H2;
        generalize (Rplus_le_compat_l (frac_part r1) 0 (frac_part r2) H1);
          intro; clear H1; elim (Rplus_ne (frac_part r1)); intros a b;
            rewrite a in H2; clear a b;
              generalize (Rle_trans 0 (frac_part r1) (frac_part r1 + frac_part r2) H0 H2);
                intro; clear H0 H2; unfold frac_part in H, H1; unfold Rminus in H, H1;
                  rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
                    in H1; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H1;
                      rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2)
                        in H1;
                        rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H1;
                          rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
                            in H1;
                            rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
                              rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
                                in H; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H;
                                  rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2) in H;
                                    rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H;
                                      rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
                                        in H;
                                        rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H;
                                          generalize
                                            (Rplus_le_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) 0
                                              (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H1);
                                            intro; clear H1;
                                              generalize
                                                (Rplus_lt_compat_l (IZR (Int_part r1) + IZR (Int_part r2))
                                                  (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 1 H);
                                                intro; clear H;
                                                  rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
                                                    in H1;
                                                    rewrite <-
                                                      (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
                                                        (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
                                                      in H1; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H1;
                                                        elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H1;
                                                          clear a b;
                                                            rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
                                                              in H0;
                                                              rewrite <-
                                                                (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
                                                                  (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
                                                                in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0;
                                                                  elim (Rplus_ne (IZR (Int_part r1) + IZR (Int_part r2)));
                                                                    intros a b; rewrite a in H0; clear a b; elim (Rplus_ne (r1 + r2));
                                                                      intros a b; rewrite b in H0; clear a b; cut (1 = IZR 1);
                                                                        auto with zarith real.
  intro; rewrite H in H1; clear H;
    rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0;
      rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H1;
        rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H1;
          generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2) H0 H1);
            intro; clear H0 H1; unfold Int_part at 1 in |- *;
              omega.
Qed.

(**********)
Lemma plus_frac_part1 :
  forall r1 r2:R,
    frac_part r1 + frac_part r2 >= 1 ->
    frac_part (r1 + r2) = frac_part r1 + frac_part r2 - 1.
Proof.
  intros; unfold frac_part in |- *; generalize (plus_Int_part1 r1 r2 H); intro;
    rewrite H0; rewrite (plus_IZR (Int_part r1 + Int_part r2) 1);
      rewrite (plus_IZR (Int_part r1) (Int_part r2)); simpl in |- *;
        unfold Rminus at 3 4 in |- *;
          rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)));
            rewrite (Rplus_comm r2 (- IZR (Int_part r2)));
              rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2);
                rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2);
                  rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)));
                    rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2)));
                      unfold Rminus in |- *;
                        rewrite
                          (Rplus_assoc (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))) (-1))
                          ; rewrite <- (Ropp_plus_distr (IZR (Int_part r1) + IZR (Int_part r2)) 1);
                            trivial with zarith real.
Qed.

(**********)
Lemma plus_frac_part2 :
  forall r1 r2:R,
    frac_part r1 + frac_part r2 < 1 ->
    frac_part (r1 + r2) = frac_part r1 + frac_part r2.
Proof.
  intros; unfold frac_part in |- *; generalize (plus_Int_part2 r1 r2 H); intro;
    rewrite H0; rewrite (plus_IZR (Int_part r1) (Int_part r2));
      unfold Rminus at 2 3 in |- *;
        rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)));
          rewrite (Rplus_comm r2 (- IZR (Int_part r2)));
            rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2);
              rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2);
                rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)));
                  rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2)));
                    unfold Rminus in |- *; trivial with zarith real.
Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype finset.
Require Import fingroup morphism.

(******************************************************************************)
(* Support for generator-and-relation presentations of groups. We provide the *)
(* syntax:                                                                    *)
(*  G \homg Grp (x_1 : ... x_n : (s_1 = t_1, ..., s_m = t_m))                 *)
(*    <=> G is generated by elements x_1, ..., x_m satisfying the relations   *)
(*        s_1 = t_1, ..., s_m = t_m, i.e., G is a homomorphic image of the    *)
(*        group generated by the x_i, subject to the relations s_j = t_j.     *)
(*  G \isog Grp (x_1 : ... x_n : (s_1 = t_1, ..., s_m = t_m))                 *)
(*    <=> G is isomorphic to the group generated by the x_i, subject to the   *)
(*        relations s_j = t_j. This is an intensional predicate (in Prop), as *)
(*        even the non-triviality of a generated group is undecidable.        *)
(* Syntax details:                                                            *)
(*  - Grp is a litteral constant.                                             *)
(*  - There must be at one generator and one relation.                        *)
(*  - A relation s_j = 1 can be abbreviated as simply s_j (a.k.a. a relator). *)
(*  - Two consecutive relations s_j = t, s_j+1 = t can be abbreviated         *)
(*    s_j = s_j+1 = t.                                                        *)
(*  - The s_j and t_j are terms built from the x_i and the standard group     *)
(*    operators *, 1, ^-1, ^+, ^-, ^, [~ u_1, ..., u_k]; no other operator or *)
(*    abbreviation may be used, as the notation is implemented using static   *)
(*    overloading.                                                            *)
(*  - This is the closest we could get to the notation used in Aschbacher,    *)
(*       Grp (x_1, ... x_n : t_1,1 = ... = t_1,k1, ..., t_m,1 = ... = t_m,km) *)
(*    under the current limitations of the Coq Notation facility.             *)
(* Semantics details:                                                         *)
(* - G \isog Grp (...) : Prop expands to the statement                        *)
(*      forall rT (H : {group rT}), (H \homg G) = (H \homg Grp (...))         *)
(*   (with rT : finGroupType).                                                *)
(* - G \homg Grp (x_1 : ... x_n : (s_1 = t_1, ..., s_m = t_m)) : bool, with   *)
(*   G : {set gT}, is convertible to the boolean expression                   *)
(*     [exists t : gT * ... gT, let: (x_1, ..., x_n) := t in                  *)
(*       (<[x_1]> <*> ... <*> <[x_n]>, (s_1, ... (s_m-1, s_m) ...))           *)
(*          == (G, (t_1, ... (t_m-1, t_m) ...))]                              *)
(*   where the tuple comparison above is convertible to the conjunction       *)
(*       [&& <[x_1]> <*> ... <*> <[x_n]> == G, s_1 == t_1, ... & s_m == t_m]  *)
(*   Thus G \homg Grp (...) can be easily exploited by destructing the tuple  *)
(*   created case/existsP, then destructing the tuple equality with case/eqP. *)
(*   Conversely it can be proved by using apply/existsP, providing the tuple  *)
(*   with a single exists (u_1, ..., u_n), then using rewrite !xpair_eqE /=   *)
(*   to expose the conjunction, and optionally using an apply/and{m+1}P view  *)
(*   to split it into subgoals (in that case, the rewrite is in principle     *)
(*   redundant, but necessary in practice because of the poor performance of  *)
(*   conversion in the Coq unifier).                                          *)
(******************************************************************************)

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

Import GroupScope.

Module Presentation.

Section Presentation.

Implicit Types gT rT : finGroupType.
Implicit Type vT : finType. (* tuple value type *)

Inductive term :=
  | Cst of nat
  | Idx
  | Inv of term
  | Exp of term & nat
  | Mul of term & term
  | Conj of term & term
  | Comm of term & term.

Fixpoint eval {gT} e t : gT :=
  match t with
  | Cst i => nth 1 e i
  | Idx => 1
  | Inv t1 => (eval e t1)^-1
  | Exp t1 n => eval e t1 ^+ n
  | Mul t1 t2 => eval e t1 * eval e t2
  | Conj t1 t2 => eval e t1 ^ eval e t2
  | Comm t1 t2 => [~ eval e t1, eval e t2]
  end.

Inductive formula := Eq2 of term & term | And of formula & formula.
Definition Eq1 s := Eq2 s Idx.
Definition Eq3 s1 s2 t := And (Eq2 s1 t) (Eq2 s2 t).

Inductive rel_type := NoRel | Rel vT of vT & vT.

Definition bool_of_rel r := if r is Rel vT v1 v2 then v1 == v2 else true.
Local Coercion bool_of_rel : rel_type >-> bool.

Definition and_rel vT (v1 v2 : vT) r :=
  if r is Rel wT w1 w2 then Rel (v1, w1) (v2, w2) else Rel v1 v2.

Fixpoint rel {gT} (e : seq gT) f r :=
  match f with
  | Eq2 s t => and_rel (eval e s) (eval e t) r
  | And f1 f2 => rel e f1 (rel e f2 r)
  end.

Inductive type := Generator of term -> type | Formula of formula.
Definition Cast p : type := p. (* syntactic scope cast *)
Local Coercion Formula : formula >-> type.

Inductive env gT := Env of {set gT} & seq gT.
Definition env1 {gT} (x : gT : finType) := Env <[x]> [:: x].

Fixpoint sat gT vT B n (s : vT -> env gT) p :=
  match p with
  | Formula f =>
    [exists v, let: Env A e := s v in and_rel A B (rel (rev e) f NoRel)]
  | Generator p' =>
    let s' v := let: Env A e := s v.1 in Env (A <*> <[v.2]>) (v.2 :: e) in
    sat B n.+1 s' (p' (Cst n))
  end.

Definition hom gT (B : {set gT}) p := sat B 1 env1 (p (Cst 0)).
Definition iso gT (B : {set gT}) p :=
  forall rT (H : {group rT}), (H \homg B) = hom H p.

End Presentation.

End Presentation.

Import Presentation.

Coercion bool_of_rel : rel_type >-> bool.
Coercion Eq1 : term >-> formula.
Coercion Formula : formula >-> type.

(* Declare (implicitly) the argument scope tags. *)
Notation "1" := Idx : group_presentation.
Arguments Scope Inv [group_presentation].
Arguments Scope Exp [group_presentation nat_scope].
Arguments Scope Mul [group_presentation group_presentation].
Arguments Scope Conj [group_presentation group_presentation].
Arguments Scope Comm [group_presentation group_presentation].
Arguments Scope Eq1 [group_presentation].
Arguments Scope Eq2 [group_presentation group_presentation].
Arguments Scope Eq3 [group_presentation group_presentation group_presentation].
Arguments Scope And [group_presentation group_presentation].
Arguments Scope Formula [group_presentation].
Arguments Scope Cast [group_presentation].

Infix "*" := Mul : group_presentation.
Infix "^+" := Exp : group_presentation.
Infix "^" := Conj : group_presentation.
Notation "x ^-1" := (Inv x) : group_presentation.
Notation "x ^- n" := (Inv (x ^+ n)) : group_presentation.
Notation "[ ~ x1 , x2 , .. , xn ]" :=
  (Comm .. (Comm x1 x2) .. xn) : group_presentation.
Notation "x = y" := (Eq2 x y) : group_presentation.
Notation "x = y = z" := (Eq3 x y z) : group_presentation.
Notation "( r1 , r2 , .. , rn )" :=
  (And .. (And r1 r2) .. rn) : group_presentation.

(* Declare (implicitly) the argument scope tags. *)
Notation "x : p" := (fun x => Cast p) : nt_group_presentation.
Arguments Scope Generator [nt_group_presentation].
Arguments Scope hom [_ group_scope nt_group_presentation].
Arguments Scope iso [_ group_scope nt_group_presentation].

Notation "x : p" := (Generator (x : p)) : group_presentation.

Notation "H \homg 'Grp' p" := (hom H p)
  (at level 70, p at level 0, format "H  \homg  'Grp'  p") : group_scope.

Notation "H \isog 'Grp' p" := (iso H p)
  (at level 70, p at level 0, format "H  \isog  'Grp'  p") : group_scope.

Notation "H \homg 'Grp' ( x : p )" := (hom H (x : p))
  (at level 70, x at level 0,
   format "'[hv' H  '/ '  \homg  'Grp'  ( x  :  p ) ']'") : group_scope.

Notation "H \isog 'Grp' ( x : p )" := (iso H (x : p))
  (at level 70, x at level 0,
   format "'[hv' H '/ '  \isog  'Grp'  ( x  :  p ) ']'") : group_scope.

Section PresentationTheory.

Implicit Types gT rT : finGroupType.

Import Presentation.

Lemma isoGrp_hom gT (G : {group gT}) p : G \isog Grp p -> G \homg Grp p.
Proof. by move <-; exact: homg_refl. Qed.

Lemma isoGrpP gT (G : {group gT}) p rT (H : {group rT}) :
  G \isog Grp p -> reflect (#|H| = #|G| /\ H \homg Grp p) (H \isog G).
Proof.
move=> isoGp; apply: (iffP idP) => [isoGH | [oH homHp]].
  by rewrite (card_isog isoGH) -isoGp isog_hom.
by rewrite isogEcard isoGp homHp /= oH.
Qed.

Lemma homGrp_trans rT gT (H : {set rT}) (G : {group gT}) p :
  H \homg G -> G \homg Grp p -> H \homg Grp p.
Proof.
case/homgP=> h <-{H}; rewrite /hom; move: {p}(p _) => p.
have evalG e t: all (mem G) e -> eval (map h e) t = h (eval e t).
  move=> Ge; apply: (@proj2 (eval e t \in G)); elim: t => /=.
  - move=> i; case: (leqP (size e) i) => [le_e_i | lt_i_e].
      by rewrite !nth_default ?size_map ?morph1.
    by rewrite (nth_map 1) // [_ \in G](allP Ge) ?mem_nth.
  - by rewrite morph1.
  - by move=> t [Gt ->]; rewrite groupV morphV.
  - by move=> t [Gt ->] n; rewrite groupX ?morphX.
  - by move=> t1 [Gt1 ->] t2 [Gt2 ->]; rewrite groupM ?morphM.
  - by move=> t1 [Gt1 ->] t2 [Gt2 ->]; rewrite groupJ ?morphJ.
  by move=> t1 [Gt1 ->] t2 [Gt2 ->]; rewrite groupR ?morphR.
have and_relE xT x1 x2 r: @and_rel xT x1 x2 r = (x1 == x2) && r :> bool.
  by case: r => //=; rewrite andbT.
have rsatG e f: all (mem G) e -> rel e f NoRel -> rel (map h e) f NoRel.
  move=> Ge; have: NoRel -> NoRel by []; move: NoRel {2 4}NoRel.
  elim: f => [x1 x2 | f1 IH1 f2 IH2] r hr IHr; last by apply: IH1; exact: IH2.
  by rewrite !and_relE !evalG //; case/andP; move/eqP->; rewrite eqxx.
set s := env1; set vT := gT : finType in s *.
set s' := env1; set vT' := rT : finType in s' *.
have (v): let: Env A e := s v in
  A \subset G -> all (mem G) e /\ exists v', s' v' = Env (h @* A) (map h e).
- rewrite /= cycle_subG andbT => Gv; rewrite morphim_cycle //.
  by split; last exists (h v).
elim: p 1%N vT vT' s s' => /= [p IHp | f] n vT vT' s s' Gs.
  apply: IHp => [[v x]] /=; case: (s v) {Gs}(Gs v) => A e /= Gs.
  rewrite join_subG cycle_subG; case/andP=> sAG Gx; rewrite Gx.
  have [//|-> [v' def_v']] := Gs; split=> //; exists (v', h x); rewrite def_v'.
  by congr (Env _ _); rewrite morphimY ?cycle_subG // morphim_cycle.
case/existsP=> v; case: (s v) {Gs}(Gs v) => /= A e Gs.
rewrite and_relE => /andP[/eqP defA rel_f].
have{Gs} [|Ge [v' def_v']] := Gs; first by rewrite defA.
apply/existsP; exists v'; rewrite def_v' and_relE defA eqxx /=.
by rewrite -map_rev rsatG ?(eq_all_r (mem_rev e)).
Qed.

Lemma eq_homGrp gT rT (G : {group gT}) (H : {group rT}) p :
  G \isog H -> (G \homg Grp p) = (H \homg Grp p).
Proof.
by rewrite isogEhom => /andP[homGH homHG]; apply/idP/idP; exact: homGrp_trans.
Qed.

Lemma isoGrp_trans gT rT (G : {group gT}) (H : {group rT}) p :
  G \isog H -> H \isog Grp p -> G \isog Grp p.
Proof. by move=> isoGH isoHp kT K; rewrite -isoHp; exact: eq_homgr. Qed.

Lemma intro_isoGrp gT (G : {group gT}) p :
    G \homg Grp p -> (forall rT (H : {group rT}), H \homg Grp p -> H \homg G) ->
  G \isog Grp p.
Proof.
move=> homGp freeG rT H.
by apply/idP/idP=> [homHp|]; [exact: homGrp_trans homGp | exact: freeG].
Qed.

End PresentationTheory.


Theorem my_first_proof : (forall A : Prop, A -> A).
Proof.
intros A. Show Proof.
intros proof_of_A. Show Proof.
exact proof_of_A. Show Proof.
Eval cbv delta in *.
Qed.


(** **** SNU 4190.310, 2016 Spring *)

(** Assignment 03 *)
(** Due: 2016/10/17 23:59 *)

(* Important:
   - Do NOT import other files.

   - You are NOT allowed to use the [admit] tactic.

   - You are NOT allowed to use the following tactics.
     [tauto], [intuition], [firstorder], [omega].

   - Just leave [exact FILL_IN_HERE] for those problems that you fail to prove.
*)

Require Import Basics.

Definition FILL_IN_HERE {T: Type} : T.  Admitted.

Fixpoint beq_nat (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => beq_nat n' m'
            end
  end.

Inductive list (X:Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.

Arguments nil {X}.
Arguments cons {X} _ _.  (* use underscore for argument position that has no name *)

Fixpoint app (X : Type) (l1 l2 : list X)
                : (list X) :=
  match l1 with
  | nil      => l2
  | cons h t => cons h (app X t l2)
  end.

Fixpoint snoc (X:Type) (l:list X) (v:X) : (list X) :=
  match l with
  | nil      => cons v nil
  | cons h t => cons h (snoc X t v)
  end.

Fixpoint rev (X:Type) (l:list X) : list X :=
  match l with
  | nil      => nil
  | cons h t => snoc X (rev X t) h
  end.

Fixpoint length (X:Type) (l:list X) : nat :=
  match l with
  | nil   => 0
  | cons h t => S (length X t)
  end.

Arguments length {X} l.
Arguments app {X} l1 l2.
Arguments rev {X} l.
Arguments snoc {X} l v.

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

Fixpoint map {X Y:Type} (f:X->Y) (l:list X)
             : (list Y) :=
  match l with
  | []     => []
  | h :: t => (f h) :: (map f t)
  end.

Inductive prod (X Y : Type) : Type :=
  pair : X -> Y -> prod X Y.

Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).

Notation "X * Y" := (prod X Y) : type_scope.

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with (x,y) => x end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with (x,y) => y end.

Fixpoint filter {X:Type} (test: X->bool) (l:list X)
                : (list X) :=
  match l with
  | []     => []
  | h :: t =>
    match test h with
    | true => h :: (filter test t)
    | false => filter test t
    end
  end.

Definition override {X: Type} (f: nat->X) (k:nat) (x:X) : nat->X:=
  fun (k':nat) => if beq_nat k k' then x else f k'.

Definition constfun {X: Type} (x: X) : nat->X :=
  fun (k:nat) => x.

Fixpoint fold {X Y:Type} (f: X->Y->Y) (l:list X) (b:Y) : Y :=
  match l with
  | nil => b
  | h :: t => f h (fold f t b)
  end.

Fixpoint index {X : Type} (n : nat)
               (l : list X) : option X :=
  match l with
  | [] => None
  | a :: l' => if beq_nat n O then Some a else index (pred n) l'
  end.

Definition prod_curry {X Y Z : Type}
  (f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y).

Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.

Definition fold_map {X Y:Type} (f : X -> Y) (l : list X) : list Y :=
  fold (fun x ly => f x :: ly) l [].

Theorem trans_lt : forall (n m o : nat),
  n < m -> m < o -> n < o.
Proof.
  unfold lt; intros; revert n H; induction H0; eauto.
Qed.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

Require Import definition.
Require Import Tactiques.
Require Import Rbase_doubles_inegalites.

Axiom B_sup_4 : 4 <= B.

Axiom msd_c :
    forall xc : Reelc,
    (forall n : Z, (n < msd xc)%Z -> (Z.abs (xc n) <= 1)%Z) /\
    (Z.abs (xc (msd xc)) > 1)%Z.

Lemma inconsistent_msd: False.
Proof.
destruct (msd_c (fun x => 0%Z)) as [_ it].
revert it; discriminate.
Qed.

Lemma intermediaire :
 forall (xc : Reelc) (m : Z),
 msd xc = m ->
 (forall n : Z, (n < m)%Z -> (Z.abs (xc n) <= 1)%Z) /\ (Z.abs (xc m) > 1)%Z.
Proof.
intros xc m a.
rewrite <- a.
apply msd_c.
Qed.

Lemma msd_c_bis :
 forall (xc : Reelc) (m : Z),
 (forall n : Z, (n < m)%Z -> (Z.abs (xc n) <= 1)%Z) /\ (Z.abs (xc m) > 1)%Z ->
 msd xc = m.
Proof.
intros xc m (H1, H2).
generalize (msd_c xc); intuition.
assert (cmp : (m < msd xc)%Z \/ m = msd xc \/ (msd xc < m)%Z).
omega.
intuition.
generalize (H0 m H); intro; omega.
generalize (H1 (msd xc) H4); intro; omega.
Qed.

Lemma msd_c_ter : forall xc : Reelc, (1 < Z.abs (xc (msd xc)))%Z.
Proof.
intros.
apply Z.gt_lt.
generalize (msd_c xc); intros (h1, h2).
generalize (h1 (Z.pred (msd xc))); auto.
Qed.

Lemma msd_c_4 : forall xc : Reelc, (IZR (Z.abs (xc (Z.pred (msd xc)))) <= 1)%R.
Proof.
intros.
RingReplace 1%R (IZR (Z.succ 0)); apply IZR_le.
simpl in |- *.
generalize (msd_c xc); intros (h1, h2).
generalize (h1 (Z.pred (msd xc))); intro.
auto with zarith.
Qed.

Lemma xc_nul :
 forall (x : R) (xc : Reelc) (n : Z),
 x = 0%R -> encadrement xc x -> xc n = 0%Z.
Proof.
intros.
generalize (H0 n); clear H0.
rewrite H.
RingReplace (0 * B_powerRZ n)%R 0%R.
intro.
apply one_IZR_lt1.
apply Rlt_2_minus_r with (IZR (xc n)).
RingReplace (-1 - IZR (xc n))%R (- (IZR (xc n) + 1))%R.
RingReplace (1 - IZR (xc n))%R (- (IZR (xc n) - 1))%R.
RingReplace (IZR (xc n) - IZR (xc n))%R (-0)%R.
apply Rlt_2_Ropp_r.
auto.
Qed.