Add LoadPath "$COQ_PROOFS" as Path.
Load unit_3_001_structured_data.

Theorem silly1 : forall (n m o p : nat),
     n = m ->
     [n;o] = [n;p] ->
     [n;o] = [m;p].
Proof.
  intros n m o p eq1 eq2.
  rewrite <- eq1.
  rewrite eq2.
  reflexivity.
Qed.

Theorem silly1' : forall (n m o p : nat),
     n = m ->
     [n;o] = [n;p] ->
     [n;o] = [m;p].
Proof.
  intros n m o p eq1 eq2.
  rewrite <- eq1.
  apply eq2.
Qed.

Theorem silly2 : forall (n m o p : nat),
     n = m ->
     (forall (q r : nat), q = r -> [q;o] = [r;p]) ->
     [n;o] = [m;p].
Proof.
  intros n m o p eq1 eq2.
  apply eq2. apply eq1. Qed.

Definition oddb (X: nat) := negb (evenb X).

Theorem silly_ex :
     (forall n, evenb n = true -> oddb (S n) = true) ->
     evenb 3 = true ->
     oddb 4 = true.
Proof.
  intros.
  apply H. apply H0.
Qed.

Theorem silly3_firsttry : forall (n : nat),
     true = beq_nat n 5 ->
     beq_nat (S (S n)) 7 = true.
Proof.
  intros n H.
  symmetry.
  simpl.
  apply H.
Qed.

(*Theorem rev_app_distr: forall (l1 l2 : natlist),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros.
  induction l1.
  - simpl. rewrite app_nil_r. reflexivity.
  - simpl. rewrite IHl1. rewrite app_assoc. reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros.
  induction l.
  - reflexivity.
  - simpl. rewrite rev_app_distr. rewrite IHl. simpl. reflexivity.
Qed.
*)

(*
To sum up, one can say apply H when H is a
hypothesis in the context or a previously
proven lemma of the form
∀x1 ..., H1 → H2 → ... → Hn and the current
goal is shape Hn (for some instantatiation of
each of the xi). After running apply H in such
 a state, you will have a subgoal for each of
H1 through Hn-1. In the special case where H
isn't an implication, your proof will be
completed.
*)

Theorem rev_exercise1 : forall (l l' : natlist),
     l = rev l' ->
     l' = rev l.
Proof.
  intros.
  symmetry.
  apply rev_injective.
  rewrite rev_involutive.
  apply H.
Qed.

Theorem rev_exercise1' : forall (l l' : natlist),
     l = rev l' ->
     l' = rev l.
Proof.
  assert (forall l: natlist, rev (rev l) = l).
  {
    intros.
    induction l.
    - reflexivity.
    - simpl. rewrite <- rev_involutive. simpl. reflexivity.
  }
  intros.
  induction l'.
  - rewrite H0. simpl. reflexivity.
  - rewrite H0. rewrite H. reflexivity.
Qed.

Example trans_eq_example : forall (a b c d e f : nat),
     [a;b] = [c;d] ->
     [c;d] = [e;f] ->
     [a;b] = [e;f].
Proof.
  intros a b c d e f eq1 eq2.
  rewrite -> eq1. rewrite -> eq2. reflexivity. Qed.

Theorem trans_eq : forall (X:Type) (n m o : X),
  n = m -> m = o -> n = o.
Proof.
  intros X n m o eq1 eq2.
  rewrite -> eq1.
  rewrite -> eq2.
  reflexivity. Qed.

Example trans_eq_example' : forall (a b c d e f : nat),
     [a;b] = [c;d] ->
     [c;d] = [e;f] ->
     [a;b] = [e;f].
Proof.
  intros a b c d e f eq1 eq2.
  apply trans_eq with (m:=[c;d]).
  apply eq1. apply eq2.
Qed.

Definition minustwo (n: nat): nat :=
  match n with
    | O => O
    | S O => O
    | S (S n') => n'
  end.

Example trans_eq_exercise : forall (n m o p : nat),
     m = (minustwo o) ->
     (n + p) = m ->
     (n + p) = (minustwo o).
Proof.
  intros.
  apply trans_eq with (m:=(minustwo o)).
  rewrite H0. apply H.
  reflexivity.
Qed.

(* Inductive definitions have two major properties:
  - The constructor S is injective. That is, if S n = S m, it must be the case that n = m.
  - The constructors O and S are disjoint. That is, O is not equal to S n for any n.
*)

Theorem S_injective : forall (n m : nat),
  S n = S m ->
  n = m.
Proof.
  intros n m H.
  inversion H.
  reflexivity.
Qed.

Theorem inversion_ex1 : forall (n m o : nat),
  [n; m] = [o; o] ->
  [n] = [m].
Proof.
  intros n m o H. inversion H. reflexivity.
Qed.

Theorem inversion_ex2 : forall (n m : nat),
  [n] = [m] ->
  n = m.
Proof.
  intros n m H. inversion H as [Hnm]. reflexivity. Qed.

Example inversion_ex3 : forall (x y z : nat) (l j : natlist),
  x :: y :: l = z :: j ->
  y :: l = x :: j ->
  x = y.
Proof.
  intros.
  inversion H.
  inversion H0.
  inversion H2.
  reflexivity.
Qed.

Theorem beq_nat_0_l : forall n,
   beq_nat 0 n = true -> n = 0.
Proof.
  intros.
  destruct n.
  - reflexivity.
  - inversion H.
  Qed.

Theorem inversion_ex4 : forall (n : nat),
  S n = O ->
  2 + 2 = 5.
Proof.
  intros n contra. inversion contra. Qed.

Example inversion_ex6 : forall
                          (x y z : nat) (l j : natlist),
  x :: y :: l = [] ->
  y :: l = z :: j ->
  x = z.
Proof.
  intros.
  inversion H.
Qed.

Theorem f_equal : forall (A B : Type) (f: A -> B) (x y: A),
  x = y -> f x = f y.
Proof. intros A B f x y eq. rewrite eq. reflexivity. Qed.

Theorem f_equal2 : forall (A1 A2 B:Type) (f:A1 -> A2 -> B)
                          (x1 y1:A1) (x2 y2:A2),
    x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2.
Proof.
  intros.
  inversion H.
  inversion H0.
  reflexivity.
Qed.

Theorem S_inj : forall (n m : nat) (b : bool),
     beq_nat (S n) (S m) = b ->
     beq_nat n m = b.
Proof.
  intros n m b H. simpl in H. apply H. Qed.

(*
In other words, apply L in H gives us a form of "forward reasoning": from L1 → L2 and a hypothesis matching L1, it produces a hypothesis matching L2. By contrast, apply L is "backward reasoning": it says that if we know L1→L2 and we are trying to prove L2, it suffices to prove L1.
*)

Theorem silly3' : forall (n : nat),
  (beq_nat n 5 = true -> beq_nat (S (S n)) 7 = true) ->
  true = beq_nat n 5 ->
  true = beq_nat (S (S n)) 7.
Proof.
  intros n eq H.
  symmetry in H. apply eq in H. symmetry in H.
  apply H. Qed.

Theorem plus_equal' : forall
                          (n m: nat) (n m: nat),
    n = m -> m + m = n + n.
Proof.
  intros.
  inversion H.
  inversion H0.
  reflexivity.
Qed.

Theorem plus_equal'' : forall
                          (n m: nat),
    S n = m -> m + m = S n + S n.
Proof.
  intros.
  inversion H.
  inversion H0.
  reflexivity.
Qed.

Module test.
Theorem rev_injective: forall (l1 l2 : natlist),
  rev l1 = rev l2 -> l1 = l2.
Proof.
  intros l1 l2 H.
  rewrite <- rev_involutive.
  rewrite <- H.
  rewrite  rev_involutive.
  reflexivity.
Qed.
End test.

(*
NOTE: Binding variables too soon can get you stuck!

Theorem plus_n_n_injective_stuck : forall n m,
     n + n = m + m ->
     n = m.
Proof.
  intros.
  induction n as [| n' IHn'].
  - inversion H. destruct m. reflexivity. inversion H1.
  - destruct m.
    + intros. inversion H.
    + intros.
      simpl in H.
      rewrite <- plus_n_Sm in H.
      rewrite <- plus_n_Sm in H.
      inversion H.
      apply IHn' in H1.
Qed.
*)

(* Big thanks to http://www.edwardzcn98yx.com/post/ec8fb64d.html) *)
Theorem plus_n_n_injective : forall n m,
     n + n = m + m ->
     n = m.
Proof.
  (* Hint: use [plus_n_Sm] *)
  intros n.
  induction n as [| n' IHn'].
  - intros. destruct m as [| m'].
    + reflexivity.
    + simpl in H. inversion H.
  - induction  m as [| m'].
    + intros. inversion H.
    + intros. simpl in H.
      Check plus_n_Sm.
      Search (S ( _ + _ ) ).
      rewrite <- plus_n_Sm in H.
      rewrite <- plus_n_Sm in H.
      (* Use injection property *)
      injection H as IHinj.
      (* Now we can apply IHn' in IHinj with specific m ( that is m') *)
      apply IHn' in IHinj.
      Search ( ?a = ?b -> S ?a = S ?b).
      (* As a backward reasoning, we could rewrite the goal with IHinj and  *)
      rewrite IHinj.
      reflexivity.
      (* As a forward reasoning, I search the existing therom and make S n' = S m' *)
      (* apply eq_S in IHinj. *)
      (* apply IHinj. *)
Qed.

Search (_ + _ = _ + _).

Theorem beq_nat_true : forall n m,
    beq_nat n m = true -> n = m.
Proof.
  intros n.
  induction n.
  - intros. destruct m. reflexivity. inversion H.
  - intros. destruct m. inversion H. apply IHn in H. rewrite H. reflexivity.
Qed.

Fixpoint double (n:nat) :=
  match n with
  | O => O
  | S n' => S (S (double n'))
  end.

Theorem double_injective_take2_FAILED : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n.
  induction n.
  - intros. induction m.
    + reflexivity.
    + inversion H.
  - intros. induction m.
    + inversion H.
    + Search (f_equal). (* n = S n' *) apply f_equal.
      apply IHn. inversion H. reflexivity. Qed.

Theorem double_injective_take2 : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m.
  (* n and m are both in the context *)
  generalize dependent n.
  (* Now n is back in the goal and we can do induction on
     m and get a sufficiently general IH. *)
  induction m as [| m'].
  - (* m = O *) simpl. intros n eq. destruct n as [| n'].
    + (* n = O *) reflexivity.
    + (* n = S n' *) inversion eq.
  - (* m = S m' *) intros n eq. destruct n as [| n'].
    + (* n = O *) inversion eq.

    + Search (f_equal). (* n = S n' *) apply f_equal.
      apply IHm'. inversion eq. reflexivity.
Qed.

Theorem nth_error_after_last: forall (n : nat) (l : natlist),
     length l = n ->
     nth_error l n = None.
Proof.
  intros n.
  induction n.
  - destruct l.
    + simpl. reflexivity.
    + intros. inversion H.
  - destruct l.
    + simpl. reflexivity.
    + intros. inversion H. simpl. rewrite H1. rewrite IHn. reflexivity. apply H1.
Qed.

Definition square n := n * n.

(*
Lemma square_mult : forall n m, square (n * m) = square n * square m.
Proof.
  intros n m.
  unfold square.
  Search (_ * _).
*)

Definition bar x :=
  match x with
  | O => 5
  | S _ => 5
  end.

Fact silly_fact_2 : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  destruct m.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

Fact silly_fact_2' : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  unfold bar.
  destruct m.
  - reflexivity.
  - reflexivity.
Qed.

Definition sillyfun (n : nat) : bool :=
  if beq_nat n 3 then false
  else if beq_nat n 5 then false
  else false.

Theorem sillyfun_false : forall (n : nat),
  sillyfun n = false.
Proof.
  intros n. unfold sillyfun.
  destruct (beq_nat n 3).
    - (* beq_nat n 3 = true *) reflexivity.
    - (* beq_nat n 3 = false *) destruct (beq_nat n 5).
      + (* beq_nat n 5 = true *) reflexivity.
      + (* beq_nat n 5 = false *) reflexivity. Qed.

(* Fixpoint split {X Y : Type} (l : list (X*Y))
               : (list X) * (list Y) :=
  match l with
  | [] => ([], [])
  | (x, y) :: t =>
      match split t with
      | (lx, ly) => (x :: lx, y :: ly)
      end
  end. *)

Definition sillyfun1 (n : nat) : bool :=
  if beq_nat n 3 then true
  else if beq_nat n 5 then true
  else false.

Theorem sillyfun1_odd : forall (n : nat),
     sillyfun1 n = true ->
     oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  destruct (beq_nat n 3) eqn:Heqe3.
  (* Now we have the same state as at the point where we got
     stuck above, except that the context contains an extra
     equality assumption, which is exactly what we need to
     make progress. *)
    - (* e3 = true *) apply beq_nat_true in Heqe3.
      rewrite -> Heqe3. reflexivity.
    - (* e3 = false *)
     (* When we come to the second equality test in the body
        of the function we are reasoning about, we can use
        eqn: again in the same way, allow us to finish the
        proof. *)
      destruct (beq_nat n 5) eqn:Heqe5.
        + (* e5 = true *)
          apply beq_nat_true in Heqe5.
          rewrite -> Heqe5. reflexivity.
        + (* e5 = false *) inversion eq. Qed.

Theorem bool_fn_applied_thrice' :
  forall (f : bool -> bool) (b : bool),
  f (f (f b)) = f b.
Proof.
  intros.
  destruct (f true) eqn:FT.
  - destruct (f false) eqn:FF.
    + destruct b.
      * rewrite FT. rewrite FT. rewrite FT. reflexivity.
      * rewrite FF. rewrite FT. rewrite FT. reflexivity.
    + destruct b.
      * rewrite FT. rewrite FT. rewrite FT. reflexivity.
      * rewrite FF. rewrite FF. rewrite FF. reflexivity.
  - destruct (f false) eqn:FF.
    + destruct b.
      * rewrite FT. rewrite FF. rewrite FT. reflexivity.
      * rewrite FF. rewrite FT. rewrite FF. reflexivity.
    + destruct b.
      * rewrite FT. rewrite FF. rewrite FF. reflexivity.
      * rewrite FF. rewrite FF. rewrite FF. reflexivity.
Qed.

Theorem bool_fn_applied_thrice :
  forall (f : bool -> bool) (b : bool),
  f (f (f b)) = f b.
Proof.
  intros.
  destruct (f true) eqn: fb.
  * destruct (f false) eqn: fb'.
    - destruct b.
      + rewrite fb. rewrite fb. rewrite fb. reflexivity.
      + rewrite fb'. rewrite fb. rewrite fb. reflexivity.
    - destruct b.
      + rewrite fb. rewrite fb. rewrite fb. reflexivity.
      + rewrite fb'. rewrite fb'. rewrite fb'. reflexivity.
  * destruct (f false) eqn: fb'.
    - destruct b.
      + rewrite fb. rewrite fb'. rewrite fb. reflexivity.
      + rewrite fb'. rewrite fb. rewrite fb'. reflexivity.
    - destruct b.
      + rewrite fb. rewrite fb'. rewrite fb'. reflexivity.
      + rewrite fb'. rewrite fb'. rewrite fb'. reflexivity.
Qed.


Require Import Bool Arith List Cpdt.CpdtTactics.
Set Implicit Arguments.
Set Asymmetric Patterns.

Inductive binop : Set := Plus | Times.

Inductive exp : Set :=
| Const : nat -> exp
| Binop : binop -> exp -> exp -> exp.

Definition binopDenote (b : binop) : nat -> nat -> nat :=
  match b with
    | Plus => plus
    | Times => mult
  end.

Fixpoint expDenote (e : exp) : nat :=
  match e with
    | Const n => n
    | Binop b e1 e2 => (binopDenote b) (expDenote e1) (expDenote e2)
  end.

Eval simpl in expDenote (Const 42).

Eval simpl in expDenote (Binop Plus (Const 2) (Const 3)).

Eval simpl in expDenote (Binop Times (Binop Times (Const 10) (Const 20)) (Const 30)).


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require real.Real.

Require Import Rbasic_fun.

(* Why3 comment *)
(* min is replaced with (Reals.Rbasic_fun.Rmin x x1) by the coq driver *)

(* Why3 goal *)
Lemma min_def :
forall (x:R) (y:R),
 ((x <= y)%R -> ((Reals.Rbasic_fun.Rmin x y) = x))
 /\ ((~ (x <= y)%R) -> ((Reals.Rbasic_fun.Rmin x y) = y)).
Proof.
intros x y.
split ; intros H.
now apply Rmin_left.
apply Rmin_right.
now apply Rlt_le, Rnot_le_lt.
Qed.

(* Why3 comment *)
(* max is replaced with (Reals.Rbasic_fun.Rmax x x1) by the coq driver *)

(* Why3 goal *)
Lemma max_def :
forall (x:R) (y:R),
 ((x <= y)%R -> ((Reals.Rbasic_fun.Rmax x y) = y))
 /\ ((~ (x <= y)%R) -> ((Reals.Rbasic_fun.Rmax x y) = x)).
Proof.
intros x y.
split ; intros H.
now apply Rmax_right.
apply Rmax_left.
now apply Rlt_le, Rnot_le_lt.
Qed.

(* Why3 goal *)
Lemma Min_r :
forall (x:R) (y:R), (y <= x)%R -> ((Reals.Rbasic_fun.Rmin x y) = y).
exact Rmin_right.
Qed.

(* Why3 goal *)
Lemma Max_l :
forall (x:R) (y:R), (y <= x)%R -> ((Reals.Rbasic_fun.Rmax x y) = x).
exact Rmax_left.
Qed.

(* Why3 goal *)
Lemma Min_comm :
forall (x:R) (y:R),
 ((Reals.Rbasic_fun.Rmin x y) = (Reals.Rbasic_fun.Rmin y x)).
exact Rmin_comm.
Qed.

(* Why3 goal *)
Lemma Max_comm :
forall (x:R) (y:R),
 ((Reals.Rbasic_fun.Rmax x y) = (Reals.Rbasic_fun.Rmax y x)).
exact Rmax_comm.
Qed.

(* Why3 goal *)
Lemma Min_assoc :
forall (x:R) (y:R) (z:R),
 ((Reals.Rbasic_fun.Rmin (Reals.Rbasic_fun.Rmin x y) z) = (Reals.Rbasic_fun.Rmin x (Reals.Rbasic_fun.Rmin y z))).
Proof.
intros x y z.
destruct (Rle_or_lt x y) as [Hxy|Hxy].
rewrite Rmin_left with (1 := Hxy).
destruct (Rle_or_lt x z) as [Hxz|Hxz].
rewrite Rmin_left with (1 := Hxz).
apply eq_sym, Rmin_left.
now apply Rmin_case.
rewrite (Rmin_right y z).
reflexivity.
apply Rlt_le.
now apply Rlt_le_trans with x.
rewrite (Rmin_right x y) by now apply Rlt_le.
apply eq_sym, Rmin_right.
apply Rlt_le.
apply Rle_lt_trans with (2 := Hxy).
apply Rmin_l.
Qed.

(* Why3 goal *)
Lemma Max_assoc :
forall (x:R) (y:R) (z:R),
 ((Reals.Rbasic_fun.Rmax (Reals.Rbasic_fun.Rmax x y) z) = (Reals.Rbasic_fun.Rmax x (Reals.Rbasic_fun.Rmax y z))).
Proof.
intros x y z.
destruct (Rle_or_lt x y) as [Hxy|Hxy].
rewrite Rmax_right with (1 := Hxy).
apply eq_sym, Rmax_right.
apply Rle_trans with (1 := Hxy).
apply Rmax_l.
rewrite (Rmax_left x y) by now apply Rlt_le.
destruct (Rle_or_lt x z) as [Hxz|Hxz].
rewrite Rmax_right with (1 := Hxz).
rewrite Rmax_right.
apply eq_sym, Rmax_right.
apply Rlt_le.
now apply Rlt_le_trans with x.
apply Rle_trans with (1 := Hxz).
apply Rmax_r.
rewrite Rmax_left.
apply eq_sym, Rmax_left.
apply Rmax_case ; now apply Rlt_le.
now apply Rlt_le.
Qed.


Theorem not_both_true_and_false : forall P : Prop,
  ~ (P /\ ~P).
Proof.
  intros P.
  unfold not.
  intros H1.
  destruct H1 as [H_left H_right].
  apply H_right in H_left.
  apply H_left.
Qed.


Require Import FormalMath.Algebra.Group.
Require Import Coq.Lists.SetoidList.
Require Import Coq.Lists.SetoidPermutation.

Section FINITE_GROUP.

  Context `{G: Group A}.

  Lemma finite_group_left_perm: forall l,
      (forall a: A, InA Ae a l) -> NoDupA Ae l ->
      forall x, PermutationA Ae l (map (x &) l).
  Proof.
    intros. pose proof gr_as_setoid. apply NoDupA_equivlistA_PermutationA; auto.
    - clear H. induction H0; simpl. 1: easy. constructor; auto.
      intro. rewrite InA_alt in H2. destruct H2 as [y [? ?]]. rewrite in_map_iff in H3.
      destruct H3 as [x1 [? ?]]. rewrite <- H3 in H2.
      assert (x & x0 = x & x1) by easy. rewrite <- eq_left in H5.
      rewrite H5 in H. apply H. apply In_InA; auto.
    - intro y. split; intro. 2: apply H. specialize (H (neg x & y)).
      rewrite InA_alt in H |- *. destruct H as [z [? ?]]. exists (x & z). split.
      * rewrite <- H. rewrite <- op_assoc.
        autorewrite with group; [easy | apply G..].
      * now apply in_map.
  Qed.

End FINITE_GROUP.


Require Import List.
Require Import EquivDec.
Module Type Remove_Correctness.

   Parameter remove : forall (X : Type) {eq : EqDec X eq} , list X -> X -> list X.

   Arguments remove [X] _ _ _ .

   Axiom remove_exclusion : forall (X : Type) {eq : EqDec X eq} (x : X) (l : list X), ~ In x (remove eq l x).

   Axiom remove_subset : forall (X : Type) {eq : EqDec X eq} (x : X) (y : X) (l : list X), x =/= y -> In x l <-> In x (remove eq l y).
End Remove_Correctness.

Module Type Remove_Spec.

  Parameter remove : forall (X : Type) {eq : EqDec X eq}, list X -> X -> list X.

  Arguments remove [X] _ _ _.

  Axiom remove_nil : forall (X : Type) {eq : EqDec X eq} (x : X), remove eq nil x = nil.

  Axiom remove_exclude : forall (X : Type) {eq : EqDec X eq} (x : X) (xs : list X), remove eq (x :: xs) x = remove eq xs x.

  Axiom remove_keep : forall (X : Type) {eq : EqDec X eq} (x y : X) (xs : list X), x =/= y -> remove eq (x :: xs) y = x :: (remove eq xs y).

End Remove_Spec.

Module Remove_Correct (P : Remove_Spec) : Remove_Correctness.

  Theorem remove_exclusion : forall (X : Type) {eq : EqDec X eq} (x : X) (l : list X), ~ In x (P.remove eq l x).
    intros.
    unfold not. (* ~ aka not defined as P -> False *)
    intros.
    (* Proof goal is to show that x being in the result of remove leads to contradiction *)
    induction l as [| y ys].
    (* Base Case *)
    rewrite P.remove_nil in H.
    simpl in H.
    assumption.
    (* Inductive Case *)
    destruct (eq x y) eqn:H1.
    (* x == y *)
    rewrite <- e in H.
    rewrite P.remove_exclude in H.
    apply IHys in H.
    assumption.
    (* x =/= y *)
    apply IHys.
    assert (P.remove eq (y :: ys) x = y :: (P.remove eq ys x)) as H2.
    apply P.remove_keep.
    assert (y =/= x) as H3.
    symmetry.
    assumption.
    assumption.
    rewrite H2 in H.
    simpl in H.
    destruct H.
    (* Case y = x *)
    assert (x === y) as H4.
    rewrite H.
    reflexivity.
    contradiction.
    (* Case In x (P.remove eq ys x) *)
    assumption.
  Qed.

   Theorem remove_subset : forall (X : Type) {eq : EqDec X eq} (x : X) (y : X) (l : list X), x =/= y -> In x l <-> In x (P.remove eq l y).
     intros.
     split.
     (* -> *)
     intros.
     induction l as [| z zs].
     (* Base Case *)
     rewrite P.remove_nil.
     assumption.
     (* Inductive Case *)
     destruct (eq y z) eqn:H1.
     (* y == z *)
     assert (P.remove eq (z :: zs) y = P.remove eq zs y) as H2.
     rewrite e.
     apply P.remove_exclude.
     rewrite H2.
     apply IHzs.
     destruct H0.
     (* z = x *)
     assert (x === y) as H3.
     assert (z === y) as H4.
     symmetry.
     assumption.
     rewrite -> H0 in H4.
     assumption.
     contradiction.
     (* In x zs *)
     assumption.
     (* y =/= z *)
     assert (P.remove eq (z :: zs) y = z :: (P.remove eq zs y)) as H2.
     apply P.remove_keep.
     symmetry.
     assumption.
     rewrite H2.
     simpl.
     simpl in H0.
     destruct H0.
     left.
     assumption.
     right.
     apply IHzs.
     assumption.
     (* <- *)
     intros.
     induction l as [| z zs].
     rewrite P.remove_nil in H0.
     assumption.
     simpl.
     destruct (eq y z) eqn:H1.
     right.
     apply IHzs.
     assert (P.remove eq (z :: zs) y = P.remove eq zs y) as H2.
     rewrite e.
     apply P.remove_exclude.
     rewrite H2 in H0.
     assumption.
     assert (P.remove eq (z :: zs) y = z :: (P.remove eq zs y)) as H2.
     apply P.remove_keep.
     symmetry.
     assumption.
     rewrite H2 in H0.
     simpl in H0.
     destruct H0.
     left.
     assumption.
     right.
     apply IHzs.
     assumption.
   Qed.

   Definition remove := P.remove.

End Remove_Correct.

Module Remove_IMPL : Remove_Spec.

  Fixpoint remove {X : Type } {eq : EqDec X eq} (l : list X) (x : X) : list X :=
    match l with
      | nil => nil
      | y :: ys => if eq x y then remove ys x else y :: (remove ys x)
    end.

  Theorem remove_nil : forall (X : Type) {eq : EqDec X eq} (x : X), remove nil x = nil.
  Proof.
    intros.
    reflexivity.
  Qed.

  Theorem remove_exclude : forall (X : Type) {eq : EqDec X eq} (x : X) (xs : list X), remove (x :: xs) x = remove xs x.
  Proof.
    intros.
    simpl.
    destruct (eq x x) eqn:H1.
    reflexivity.
    assert (x === x) as H2.
    reflexivity.
    contradiction.
   Qed.

  Theorem remove_keep : forall (X : Type) {eq : EqDec X eq} (x y : X) (xs : list X), x =/= y -> remove (x :: xs) y = x :: (remove xs y).
  Proof.
    intros.
    simpl.
    destruct (eq y x) eqn:H1.
    symmetry in H.
    contradiction.
    reflexivity.
  Qed.
End Remove_IMPL.


(* We copied and modified this file from https://github.com/roglo/coq_euler_prod_form/blob/master/Totient.v *)

Require Import Utf8 Arith.
Require Import Sorting.Permutation.
Import List List.ListNotations.

Require Import Misc.

(* gcd_and_bezout a b returns (g, (u, v)) with the property
        a * u = b * v + g
        g = gcd a b;
   requires a ≠ 0 *)

Fixpoint gcd_bezout_loop n (a b : nat) : (nat * (nat * nat)) :=
  match n with
  | 0 => (0, (0, 0)) (* should not happen *)
  | S n' =>
      match b with
      | 0 => (a, (1, 0))
      | S _ =>
          let '(g, (u, v)) := gcd_bezout_loop n' b (a mod b) in
          let w := (u * b + v * (a - a mod b)) / b in
          let k := max (v / b) (w / a) + 1 in
          (g, (k * b - v, k * a - w))
      end
  end.

Definition gcd_and_bezout a b := gcd_bezout_loop (a + b + 1) a b.

Lemma gcd_bezout_loop_enough_iter_lt : ∀ m n a b,
  a + b ≤ m
  → a + b ≤ n
  → b < a
  → gcd_bezout_loop m a b = gcd_bezout_loop n a b.
Proof.
intros * Habm Habn Hba.
revert n a b Habm Habn Hba.
induction m; intros; [ flia Habm Hba | ].
destruct n; [ flia Habn Hba | cbn ].
destruct (Nat.eq_dec b 0) as [Hbz| Hbz]; [ now subst b | ].
replace b with (S (b - 1)) at 1 2 by flia Hbz.
remember (gcd_bezout_loop m b (a mod b)) as gbm eqn:Hgbm; symmetry in Hgbm.
remember (gcd_bezout_loop n b (a mod b)) as gbn eqn:Hgbn; symmetry in Hgbn.
specialize (IHm n b (a mod b)) as H1.
assert (H : ∀ p, a + b ≤ S p → b + a mod b ≤ p). {
  intros * Habp.
  transitivity (b + (a - 1)). {
    apply Nat.add_le_mono_l.
    specialize (Nat.div_mod a b Hbz) as H2.
    apply (Nat.add_le_mono_l _ _ (b * (a / b))).
    rewrite <- H2, Nat.add_comm.
    remember (a / b) as q eqn:Hq; symmetry in Hq.
    destruct q. {
      apply Nat.div_small_iff in Hq; [ flia Hba Hq | easy ].
    }
    destruct b; [ easy | ].
    cbn; remember (b * S q); flia.
  }
  flia Habp Hba.
}
specialize (H1 (H m Habm) (H n Habn)); clear H.
assert (H : a mod b < b) by now apply Nat.mod_upper_bound.
specialize (H1 H); clear H.
now rewrite <- Hgbm, H1, Hgbn.
Qed.

Lemma gcd_bezout_loop_enough_iter_ge : ∀ m n a b,
  a + b + 1 ≤ m
  → a + b + 1 ≤ n
  → a ≤ b
  → gcd_bezout_loop m a b = gcd_bezout_loop n a b.
Proof.
intros * Habm Habn Hab.
destruct (Nat.eq_dec m 0) as [Hmz| Hmz]; [ flia Hmz Habm | ].
destruct (Nat.eq_dec n 0) as [Hnz| Hnz]; [ flia Hnz Habn | ].
replace m with (S (m - 1)) by flia Hmz.
replace n with (S (n - 1)) by flia Hnz.
cbn.
destruct (Nat.eq_dec b 0) as [Hbz| Hbz]; [ now subst b | ].
replace b with (S (b - 1)) at 1 2 by flia Hbz.
rewrite (gcd_bezout_loop_enough_iter_lt _ (n - 1)); [ easy | | | ]. {
  destruct (Nat.eq_dec a b) as [Habe| Habe]. {
    subst a.
    rewrite Nat.mod_same; [ | easy ].
    flia Habm.
  }
  rewrite Nat.mod_small; [ | flia Hab Habe ].
  flia Habm.
} {
  destruct (Nat.eq_dec a b) as [Habe| Habe]. {
    subst a.
    rewrite Nat.mod_same; [ | easy ].
    flia Habn.
  }
  rewrite Nat.mod_small; [ | flia Hab Habe ].
  flia Habn.
} {
  now apply Nat.mod_upper_bound.
}
Qed.

Lemma fst_gcd_bezout_loop_is_gcd_lt : ∀ n a b,
  a ≠ 0
  → a + b + 1 ≤ n
  → b < a
  → fst (gcd_bezout_loop n a b) = Nat.gcd a b.
Proof.
intros * Haz Hn Hba.
revert a b Haz Hn Hba.
induction n; intros; [ flia Hn | cbn ].
destruct (Nat.eq_dec b 0) as [Hbz| Hbz]. {
  subst b.
  now rewrite Nat.gcd_0_r.
}
replace b with (S (b - 1)) at 1 by flia Hbz.
remember (gcd_bezout_loop n b (a mod b)) as gb eqn:Hgb; symmetry in Hgb.
destruct gb as (g, (u, v)).
rewrite Nat.gcd_comm, <- Nat.gcd_mod; [ | easy ].
rewrite Nat.gcd_comm.
cbn.
replace g with (fst (gcd_bezout_loop n b (a mod b))) by now rewrite Hgb.
apply IHn; [ easy | | ]. {
  transitivity (a + b); [ | flia Hn ].
  rewrite <- Nat.add_assoc, Nat.add_comm.
  apply Nat.add_le_mono_r.
  apply (Nat.add_le_mono_l _ _ (b * (a / b))).
  rewrite Nat.add_assoc.
  rewrite <- Nat.div_mod; [ | easy ].
  rewrite Nat.add_comm.
  apply Nat.add_le_mono_r.
  remember (a / b) as q eqn:Hq; symmetry in Hq.
  destruct q. {
    apply Nat.div_small_iff in Hq; [ flia Hba Hq | easy ].
  }
  destruct b; [ easy | ].
  cbn; remember (b * S q); flia.
} {
  now apply Nat.mod_upper_bound.
}
Qed.

Lemma fst_gcd_bezout_loop_is_gcd_ge : ∀ n a b,
  a ≠ 0
  → a + b + 1 ≤ n
  → a ≤ b
  → fst (gcd_bezout_loop n a b) = Nat.gcd a b.
Proof.
intros * Haz Hn Hba.
rewrite (gcd_bezout_loop_enough_iter_ge _ (S n)); [ | easy | flia Hn | easy ].
destruct (Nat.eq_dec b 0) as [Hbz| Hbz]; [ subst b; flia Haz Hba | ].
cbn.
replace b with (S (b - 1)) at 1 by flia Hbz.
remember (gcd_bezout_loop n b (a mod b)) as gb eqn:Hgb; symmetry in Hgb.
destruct gb as (g, (u, v)); cbn.
replace g with (fst (gcd_bezout_loop n b (a mod b))) by now rewrite Hgb.
rewrite Nat.gcd_comm.
rewrite <- Nat.gcd_mod; [ | easy ].
rewrite Nat.gcd_comm.
apply fst_gcd_bezout_loop_is_gcd_lt; [ easy | | ]. {
  destruct (Nat.eq_dec a b) as [Habe| Habe]. {
    subst a.
    rewrite Nat.mod_same; [ | easy ].
    flia Hn.
  }
  rewrite Nat.mod_small; [ | flia Hba Habe ].
  flia Hn.
} {
  now apply Nat.mod_upper_bound.
}
Qed.

Lemma fst_gcd_bezout_loop_is_gcd : ∀ n a b,
  a ≠ 0
  → a + b + 1 ≤ n
  → fst (gcd_bezout_loop n a b) = Nat.gcd a b.
Proof.
intros * Haz Hn.
destruct (le_dec a b) as [Hab| Hab]. {
  now apply fst_gcd_bezout_loop_is_gcd_ge.
} {
  apply Nat.nle_gt in Hab.
  now apply fst_gcd_bezout_loop_is_gcd_lt.
}
Qed.

Theorem fst_gcd_and_bezout_is_gcd : ∀ a b,
  a ≠ 0
  → fst (gcd_and_bezout a b) = Nat.gcd a b.
Proof.
intros * Haz.
now apply fst_gcd_bezout_loop_is_gcd.
Qed.

Theorem gcd_bezout_loop_enough_iter : ∀ m n a b,
  a + b + 1 ≤ m
  → a + b + 1 ≤ n
  → gcd_bezout_loop m a b = gcd_bezout_loop n a b.
Proof.
intros * Habm Habn.
destruct (le_dec a b) as [Hab| Hab]. {
  now apply gcd_bezout_loop_enough_iter_ge.
} {
  apply Nat.nle_gt in Hab.
  apply gcd_bezout_loop_enough_iter_lt; [ flia Habm | flia Habn | easy ].
}
Qed.

Theorem gcd_bezout_loop_fst_0_gcd_0 : ∀ n a b g v,
  a ≠ 0
  → a + b + 1 ≤ n
  → b < a
  → gcd_bezout_loop n a b = (g, (0, v))
  → g = 0.
Proof.
intros * Haz Hn Hba Hnab.
assert (Hg : Nat.gcd a b = g). {
  replace g with (fst (gcd_bezout_loop n a b)) by now rewrite Hnab.
  now rewrite fst_gcd_bezout_loop_is_gcd.
}
revert a b g v Haz Hn Hba Hnab Hg.
induction n; intros; [ flia Hn | ].
destruct (Nat.eq_dec b 0) as [Hbz| Hbz]; [ now subst b | ].
cbn in Hnab.
replace b with (S (b - 1)) in Hnab at 1 by flia Hbz.
remember (gcd_bezout_loop n b (a mod b)) as gb eqn:Hgb; symmetry in Hgb.
destruct gb as (g', (u, v')).
injection Hnab; clear Hnab; intros H1 Hv H2; subst g' v.
rename v' into v.
apply Nat.sub_0_le in Hv.
rewrite Nat.mul_add_distr_r, Nat.mul_1_l in Hv.
rewrite <- Nat.mul_max_distr_r in Hv.
rewrite <- Nat.add_max_distr_r in Hv.
apply Nat.max_lub_iff in Hv.
destruct Hv as (Hvb, Huv).
rewrite Nat.div_div in Huv; [ | easy | easy ].
apply Nat.nlt_ge in Hvb.
exfalso; apply Hvb; clear Hvb.
rewrite Nat.mul_comm.
specialize (Nat.div_mod v b Hbz) as H1.
rewrite Nat.add_comm.
apply (Nat.add_lt_mono_r _ _ (v mod b)).
rewrite <- Nat.add_assoc, <- H1.
rewrite Nat.add_comm.
apply Nat.add_lt_mono_r.
now apply Nat.mod_upper_bound.
Qed.

Theorem gcd_bezout_loop_prop_lt : ∀ n a b g u v,
  a ≠ 0
  → a + b + 1 ≤ n
  → b < a
  → gcd_bezout_loop n a b = (g, (u, v))
  → a * u = b * v + g.
Proof.
intros * Haz Hn Hba Hnab.
assert (Hgcd : g = Nat.gcd a b). {
  apply fst_gcd_bezout_loop_is_gcd in Hn; [ | easy ].
  now rewrite Hnab in Hn; cbn in Hn.
}
rewrite (gcd_bezout_loop_enough_iter _ (S n)) in Hnab; [ | easy | flia Hn ].
revert a b g u v Haz Hn Hba Hnab Hgcd.
induction n; intros; [ flia Hn | ].
remember (S n) as sn; cbn in Hnab; subst sn.
destruct (Nat.eq_dec b 0) as [Hbz| Hbz]. {
  subst b.
  rewrite Nat.mul_0_l.
  injection Hnab; clear Hnab; intros; subst g u v.
  now rewrite Nat.mul_1_r.
}
replace b with (S (b - 1)) in Hnab at 1 by flia Hbz.
remember (gcd_bezout_loop (S n) b (a mod b)) as gb eqn:Hgb; symmetry in Hgb.
destruct gb as (g', (u', v')).
injection Hnab; clear Hnab; intros; move Hgcd at bottom; subst g u v.
rename g' into g; rename u' into u; rename v' into v.
remember ((u * b + v * (a - a mod b)) / b) as w eqn:Hw; symmetry in Hw.
remember (max (v / b) (w / a) + 1) as k eqn:Hk.
do 2 rewrite Nat.mul_sub_distr_l.
replace (a * (k * b)) with (k * a * b) by flia.
replace (b * (k * a)) with (k * a * b) by flia.
rewrite <- Nat_sub_sub_distr. 2: {
  split. 2: {
    rewrite Nat.mul_comm.
    apply Nat.mul_le_mono_r.
    apply Nat_div_lt_le_mul; [ flia Hk | ].
    destruct (Nat.lt_trichotomy (v / b) (w / a)) as [H| H]. {
      rewrite max_r in Hk; [ | now apply Nat.lt_le_incl ].
      rewrite Hk.
      apply Nat.div_lt_upper_bound; [ now rewrite Nat.add_comm | ].
      rewrite Nat.mul_add_distr_r, Nat.mul_1_l, Nat.mul_comm.
      specialize (Nat.div_mod w a Haz) as H1.
      apply (Nat.add_lt_mono_r _ _ (w mod a)).
      rewrite Nat.add_shuffle0.
      rewrite <- H1.
      apply Nat.add_lt_mono_l.
      now apply Nat.mod_upper_bound.
    } {
      assert (Huv : w / a ≤ v / b) by flia H; clear H.
      rewrite max_l in Hk; [ | easy ].
      rewrite Hk.
      apply (le_lt_trans _ (w / (w / a + 1))). {
        apply Nat.div_le_compat_l.
        split; [ flia | ].
        now apply Nat.add_le_mono_r.
      }
      apply Nat.div_lt_upper_bound; [ now rewrite Nat.add_comm | ].
      rewrite Nat.mul_add_distr_r, Nat.mul_1_l, Nat.mul_comm.
      specialize (Nat.div_mod w a Haz) as H1.
      rewrite H1 at 1.
      apply Nat.add_lt_mono_l.
      now apply Nat.mod_upper_bound.
    }
  } {
    clear k Hk.
    rewrite Nat.add_comm, Nat.div_add in Hw; [ | easy ].
    rewrite Nat.add_comm in Hw.
    destruct u. {
      apply gcd_bezout_loop_fst_0_gcd_0 in Hgb; [ | easy | | ]; cycle 1. {
        destruct (lt_dec a b) as [Hab| Hab]. {
          rewrite Nat.mod_small in Hgb; [ | easy ].
          rewrite Nat.mod_small; [ | easy ].
          now rewrite (Nat.add_comm b).
        } {
          apply Nat.nlt_ge in Hab.
          transitivity (a + b + 1); [ | easy ].
          rewrite (Nat.add_comm b).
          do 2 apply Nat.add_le_mono_r.
          now apply Nat.mod_le.
        }
      } {
        now apply Nat.mod_upper_bound.
      }
      subst g; apply Nat.le_0_l.
    }
    rewrite <- Hw.
    rewrite Nat.mul_comm; cbn.
    transitivity b; [ | remember (_ * b); flia ].
    rewrite Hgcd.
    now apply Nat_gcd_le_r.
  }
}
f_equal.
apply IHn in Hgb; [ | easy | | | ]; cycle 1. {
  transitivity (a + b); [ | flia Hn ].
  rewrite <- Nat.add_assoc, Nat.add_comm.
  apply Nat.add_le_mono_r.
  apply (Nat.add_le_mono_l _ _ (b * (a / b))).
  rewrite Nat.add_assoc.
  rewrite <- Nat.div_mod; [ | easy ].
  rewrite Nat.add_comm.
  apply Nat.add_le_mono_r.
  remember (a / b) as q eqn:Hq; symmetry in Hq.
  destruct q. {
    apply Nat.div_small_iff in Hq; [ flia Hba Hq | easy ].
  }
  destruct b; [ easy | ].
  cbn; remember (b * S q); flia.
} {
  now apply Nat.mod_upper_bound.
} {
  rewrite Nat.gcd_comm, Nat.gcd_mod; [ | easy ].
  now rewrite Nat.gcd_comm.
}
rewrite <- Hw.
rewrite <- Nat.divide_div_mul_exact; [ | easy | ]. 2: {
  exists (u + v * (a - a mod b) / b).
  rewrite Nat.mul_add_distr_r; f_equal.
  rewrite Nat.divide_div_mul_exact; [ | easy | ]. 2: {
    exists (a / b).
    rewrite (Nat.div_mod a b Hbz) at 1.
    now rewrite Nat.add_sub, Nat.mul_comm.
  }
  rewrite <- Nat.mul_assoc; f_equal.
  rewrite Nat.mul_comm.
  rewrite <- Nat.divide_div_mul_exact; [ | easy | ]. 2: {
    exists (a / b).
    rewrite (Nat.div_mod a b Hbz) at 1.
    now rewrite Nat.add_sub, Nat.mul_comm.
  }
  rewrite Nat.mul_comm.
  now rewrite Nat.div_mul.
}
rewrite (Nat.mul_comm b).
rewrite Nat.div_mul; [ | easy ].
rewrite Nat.mul_sub_distr_l, (Nat.mul_comm v).
rewrite Nat.add_sub_assoc. 2: {
  rewrite Nat.mul_comm.
  apply Nat.mul_le_mono_r.
  now apply Nat.mod_le.
}
symmetry; apply Nat.add_sub_eq_l.
symmetry; apply Nat.add_sub_eq_l.
rewrite Nat.add_assoc; f_equal.
now rewrite (Nat.mul_comm u), (Nat.mul_comm v).
Qed.

Theorem gcd_bezout_loop_prop_ge : ∀ n a b g u v,
  a ≠ 0
  → a + b + 1 ≤ n
  → a ≤ b
  → gcd_bezout_loop n a b = (g, (u, v))
  → a * u = b * v + g.
Proof.
intros * Haz Hn Hba Hbez.
assert (Hgcd : g = Nat.gcd a b). {
  specialize (fst_gcd_bezout_loop_is_gcd n a b Haz Hn) as H1.
  now rewrite Hbez in H1.
}
destruct (Nat.eq_dec b 0) as [Hbz| Hbz]; [ subst b; flia Haz Hba | ].
rewrite (gcd_bezout_loop_enough_iter _ (S n)) in Hbez; try flia Hn.
cbn - [ "/" "mod" ] in Hbez.
replace b with (S (b - 1)) in Hbez at 1 by flia Haz Hba.
remember (gcd_bezout_loop n b (a mod b)) as gb eqn:Hgb.
symmetry in Hgb.
destruct gb as (g', (u', v')).
apply gcd_bezout_loop_prop_lt in Hgb; [ | easy | | ]; cycle 1. {
  destruct (Nat.eq_dec a b) as [Hab| Hab]. {
    subst b.
    rewrite Nat.mod_same; [ flia Hn | easy ].
  }
  rewrite (Nat.add_comm b).
  rewrite Nat.mod_small; [ easy | flia Hba Hab ].
} {
  now apply Nat.mod_upper_bound.
}
injection Hbez; clear Hbez; intros; move Hgcd at bottom; subst g u v.
rename g' into g; rename u' into u; rename v' into v.
remember ((u * b + v * (a - a mod b)) / b) as w eqn:Hw; symmetry in Hw.
remember (max (v / b) (w / a) + 1) as k eqn:Hk.
do 2 rewrite Nat.mul_sub_distr_l.
replace (a * (k * b)) with (k * a * b) by flia.
replace (b * (k * a)) with (k * a * b) by flia.
rewrite <- Nat_sub_sub_distr. 2: {
  split. 2: {
    rewrite Nat.mul_comm.
    apply Nat.mul_le_mono_r.
    apply Nat_div_lt_le_mul; [ flia Hk | ].
    destruct (Nat.lt_trichotomy (v / b) (w / a)) as [H| H]. {
      rewrite max_r in Hk; [ | now apply Nat.lt_le_incl ].
      rewrite Hk.
      apply Nat.div_lt_upper_bound; [ now rewrite Nat.add_comm | ].
      rewrite Nat.mul_add_distr_r, Nat.mul_1_l, Nat.mul_comm.
      specialize (Nat.div_mod w a Haz) as H1.
      apply (Nat.add_lt_mono_r _ _ (w mod a)).
      rewrite Nat.add_shuffle0.
      rewrite <- H1.
      apply Nat.add_lt_mono_l.
      now apply Nat.mod_upper_bound.
    } {
      assert (Huv : w / a ≤ v / b) by flia H; clear H.
      rewrite max_l in Hk; [ | easy ].
      rewrite Hk.
      apply (le_lt_trans _ (w / (w / a + 1))). {
        apply Nat.div_le_compat_l.
        split; [ flia | ].
        now apply Nat.add_le_mono_r.
      }
      apply Nat.div_lt_upper_bound; [ now rewrite Nat.add_comm | ].
      rewrite Nat.mul_add_distr_r, Nat.mul_1_l, Nat.mul_comm.
      specialize (Nat.div_mod w a Haz) as H1.
      rewrite H1 at 1.
      apply Nat.add_lt_mono_l.
      now apply Nat.mod_upper_bound.
    }
  } {
    clear k Hk.
    rewrite Nat.add_comm, Nat.div_add in Hw; [ | easy ].
    rewrite Nat.add_comm in Hw.
    destruct u. {
      rewrite Nat.mul_0_r in Hgb.
      symmetry in Hgb.
      apply Nat.eq_add_0 in Hgb.
      rewrite (proj2 Hgb).
      apply Nat.le_0_l.
    }
    rewrite <- Hw.
    rewrite Nat.mul_comm; cbn.
    transitivity b; [ | remember (_ * b); flia ].
    rewrite Hgcd.
    now apply Nat_gcd_le_r.
  }
}
f_equal.
rewrite <- Hw.
rewrite <- Nat.divide_div_mul_exact; [ | easy | ]. 2: {
  exists (u + v * ((a - a mod b) / b)).
  rewrite Nat.mul_add_distr_r; f_equal.
  rewrite <- Nat.mul_assoc; f_equal.
  rewrite Nat.mul_comm.
    rewrite <- Nat.divide_div_mul_exact; [ | easy | ]. 2: {
      exists (a / b).
      rewrite (Nat.div_mod a b) at 1; [ | easy ].
      now rewrite Nat.add_sub, Nat.mul_comm.
    }
    now rewrite Nat.mul_comm, Nat.div_mul.
  }
  rewrite (Nat.mul_comm b), Nat.div_mul; [ | easy ].
  rewrite (Nat.mul_comm u), Hgb.
  rewrite Nat.mul_sub_distr_l.
  rewrite Nat.add_shuffle0, Nat.add_sub.
  rewrite Nat.add_sub_assoc. 2: {
    apply Nat.mul_le_mono_l.
    destruct (Nat.eq_dec a b) as [Hab| Hab]. {
      subst a.
      rewrite Nat.mod_same; [ apply Nat.le_0_l | easy ].
    }
    now apply Nat.mod_le.
  }
  rewrite Nat.add_comm, (Nat.mul_comm (a mod b)).
  now rewrite Nat.add_sub, Nat.mul_comm.
Qed.

Theorem gcd_and_bezout_prop : ∀ a b g u v,
  a ≠ 0
  → gcd_and_bezout a b = (g, (u, v))
  → a * u = b * v + g ∧ g = Nat.gcd a b.
Proof.
intros * Haz Hbez.
assert (Hgcd : g = Nat.gcd a b). {
  specialize (fst_gcd_and_bezout_is_gcd a b Haz) as H1.
  now rewrite Hbez in H1.
}
split; [ | easy ].
destruct (lt_dec b a) as [Hba| Hba]. {
  now apply (gcd_bezout_loop_prop_lt (a + b + 1)).
} {
  apply Nat.nlt_ge in Hba.
  now apply (gcd_bezout_loop_prop_ge (a + b + 1)).
}
Qed.

(* Nat.gcd_bezout_pos could be implemented like this *)
Theorem Nat_gcd_bezout_pos n m : 0 < n → Nat.Bezout n m (Nat.gcd n m).
Proof.
intros * Hn.
apply Nat.neq_0_lt_0 in Hn.
remember (gcd_and_bezout n m) as gb eqn:Hgb; symmetry in Hgb.
destruct gb as (g, (u, v)).
apply gcd_and_bezout_prop in Hgb; [ | easy ].
destruct Hgb as (Hnm, Hg); rewrite <- Hg.
exists u, v.
rewrite Nat.mul_comm, Nat.add_comm.
now rewrite (Nat.mul_comm v).
Qed.

(* Euler's totient function *)

Definition coprimes' n := filter (λ d, Nat.gcd n d =? 1) (seq 1 (n - 1)).
Definition φ' n := length (coprimes' n).

(* Totient function is multiplicative *)

Theorem bijection_same_length {A B} : ∀ f g (l : list A) (l' : list B),
  NoDup l
  → NoDup l'
  → (∀ a, a ∈ l → f a ∈ l')
  → (∀ b, b ∈ l' → g b ∈ l)
  → (∀ a, a ∈ l → g (f a) = a)
  → (∀ b, b ∈ l' → f (g b) = b)
  → length l = length l'.
Proof.
intros * Hnl Hnl' Hf Hg Hgf Hfg.
revert l' Hf Hg Hfg Hnl'.
induction l as [| x l]; intros. {
  destruct l' as [| y l']; [ easy | exfalso ].
  now specialize (Hg y (or_introl eq_refl)).
}
destruct l' as [| y l']. {
  exfalso.
  now specialize (Hf x (or_introl eq_refl)).
}
specialize (in_split (f x) (y :: l') (Hf x (or_introl eq_refl))) as H.
destruct H as (l1 & l2 & Hll).
rewrite Hll.
transitivity (length (f x :: l1 ++ l2)). 2: {
  cbn; do 2 rewrite app_length; cbn; flia.
}
cbn; f_equal.
apply IHl. {
    now apply NoDup_cons_iff in Hnl.
} {
  intros a Ha.
  now apply Hgf; right.
} {
  intros a Ha.
  specialize (Hf a (or_intror Ha)) as H1.
  rewrite Hll in H1.
  apply in_app_or in H1.
  apply in_or_app.
  destruct H1 as [H1| H1]; [ now left | ].
  destruct H1 as [H1| H1]; [ | now right ].
  apply (f_equal g) in H1.
  rewrite Hgf in H1; [ | now left ].
  rewrite Hgf in H1; [ | now right ].
  subst a.
  now apply NoDup_cons_iff in Hnl.
} {
  intros b Hb.
  rewrite Hll in Hg.
  specialize (Hg b) as H1.
  assert (H : b ∈ l1 ++ f x :: l2). {
    apply in_app_or in Hb.
    apply in_or_app.
    destruct Hb as [Hb| Hb]; [ now left | ].
    now right; right.
  }
  specialize (H1 H); clear H.
  destruct H1 as [H1| H1]; [ | easy ].
  subst x.
  rewrite Hfg in Hll. 2: {
    rewrite Hll.
    apply in_app_or in Hb.
    apply in_or_app.
    destruct Hb as [Hb| Hb]; [ now left | ].
    now right; right.
  }
  rewrite Hll in Hnl'.
  now apply NoDup_remove_2 in Hnl'.
} {
  intros b Hb.
  apply Hfg.
  rewrite Hll.
  apply in_app_or in Hb.
  apply in_or_app.
  destruct Hb as [Hb| Hb]; [ now left | ].
  now right; right.
} {
  rewrite Hll in Hnl'.
  now apply NoDup_remove_1 in Hnl'.
}
Qed.

Definition prod_copr_of_copr_mul m n a := (a mod m, a mod n).

Definition copr_mul_of_prod_copr (m n : nat) '((x, y) : nat * nat) :=
  let '(u, v) := snd (gcd_and_bezout m n) in
  m * n - (n * x * v + m * (n - 1) * y * u) mod (m * n).

Theorem in_coprimes'_iff : ∀ n a,
  a ∈ seq 1 (n - 1) ∧ Nat.gcd n a = 1 ↔ a ∈ coprimes' n.
Proof.
intros.
split; intros Ha. {
  apply filter_In.
  split; [ easy | ].
  now apply Nat.eqb_eq.
} {
  apply filter_In in Ha.
  split; [ easy | ].
  now apply Nat.eqb_eq.
}
Qed.

Theorem prod_copr_of_copr_mul_in_prod : ∀ m n a,
  2 ≤ m
  → 2 ≤ n
  → a ∈ coprimes' (m * n)
  → prod_copr_of_copr_mul m n a ∈
       list_prod (coprimes' m) (coprimes' n).
Proof.
intros * H2m H2n Ha.
destruct (Nat.eq_dec m 0) as [Hmz| Hmz]; [ now subst m | ].
destruct (Nat.eq_dec n 0) as [Hnz| Hnz]. {
  now subst n; rewrite Nat.mul_0_r in Ha.
}
apply in_coprimes'_iff in Ha.
destruct Ha as (Ha, Hga).
apply in_seq in Ha.
rewrite Nat.add_comm, Nat.sub_add in Ha by flia Ha.
unfold prod_copr_of_copr_mul.
apply in_prod. {
  apply in_coprimes'_iff.
  split. {
    apply in_seq.
    split. {
      remember (a mod m) as r eqn:Hr; symmetry in Hr.
      destruct r; [ | flia ].
      apply Nat.mod_divides in Hr; [ | easy ].
      destruct Hr as (k, Hk).
      rewrite Hk in Hga.
      rewrite Nat.gcd_mul_mono_l in Hga.
      apply Nat.eq_mul_1 in Hga.
      flia Hga H2m.
    } {
      rewrite Nat.add_comm, Nat.sub_add; [ | flia Hmz ].
      now apply Nat.mod_upper_bound.
    }
  } {
    rewrite Nat.gcd_comm, Nat.gcd_mod; [ | easy ].
    remember (Nat.gcd m a) as g eqn:Hg; symmetry in Hg.
    destruct g; [ now apply Nat.gcd_eq_0_l in Hg | ].
    destruct g; [ easy | exfalso ].
    replace (S (S g)) with (g + 2) in Hg by flia.
    specialize (Nat.gcd_divide_l m a) as H1.
    specialize (Nat.gcd_divide_r m a) as H2.
    rewrite Hg in H1, H2.
    destruct H1 as (k1, Hk1).
    destruct H2 as (k2, Hk2).
    rewrite Hk1, Hk2 in Hga.
    rewrite Nat.mul_shuffle0 in Hga.
    rewrite Nat.gcd_mul_mono_r in Hga.
    apply Nat.eq_mul_1 in Hga.
    flia Hga.
  }
} {
  apply in_coprimes'_iff.
  rewrite Nat.mul_comm in Hga.
  split. {
    apply in_seq.
    split. {
      remember (a mod n) as r eqn:Hr; symmetry in Hr.
      destruct r; [ | flia ].
      apply Nat.mod_divides in Hr; [ | easy ].
      destruct Hr as (k, Hk).
      rewrite Hk in Hga.
      rewrite Nat.gcd_mul_mono_l in Hga.
      apply Nat.eq_mul_1 in Hga.
      flia Hga H2n.
    } {
      rewrite Nat.add_comm, Nat.sub_add; [ | flia Hnz ].
      now apply Nat.mod_upper_bound.
    }
  } {
    rewrite Nat.gcd_comm, Nat.gcd_mod; [ | easy ].
    remember (Nat.gcd n a) as g eqn:Hg; symmetry in Hg.
    destruct g; [ now apply Nat.gcd_eq_0_l in Hg | ].
    destruct g; [ easy | exfalso ].
    replace (S (S g)) with (g + 2) in Hg by flia.
    specialize (Nat.gcd_divide_l n a) as H1.
    specialize (Nat.gcd_divide_r n a) as H2.
    rewrite Hg in H1, H2.
    destruct H1 as (k1, Hk1).
    destruct H2 as (k2, Hk2).
    rewrite Hk1, Hk2 in Hga.
    rewrite Nat.mul_shuffle0 in Hga.
    rewrite Nat.gcd_mul_mono_r in Hga.
    apply Nat.eq_mul_1 in Hga.
    flia Hga.
  }
}
Qed.

Theorem copr_mul_of_prod_copr_in_coprimes' : ∀ m n,
  2 ≤ m
  → Nat.gcd m n = 1
  → ∀ a, a ∈ list_prod (coprimes' m) (coprimes' n)
  → copr_mul_of_prod_copr m n a ∈ coprimes' (m * n).
Proof.
intros m n H2m Hmn (a, b) Hab.
destruct (Nat.eq_dec m 0) as [Hmz| Hmz]; [ now subst m | ].
destruct (Nat.eq_dec n 0) as [Hnz| Hnz]. {
  subst n; cbn in Hab.
  now rewrite List_list_prod_nil_r in Hab.
}
apply in_prod_iff in Hab.
destruct Hab as (Ha, Hb).
apply in_coprimes'_iff in Ha.
apply in_coprimes'_iff in Hb.
destruct Ha as (Ha, Hma).
destruct Hb as (Hb, Hnb).
move Hb before Ha.
apply in_seq in Ha.
apply in_seq in Hb.
replace (1 + (m - 1)) with m in Ha by flia Hmz.
replace (1 + (n - 1)) with n in Hb by flia Hnz.
unfold copr_mul_of_prod_copr.
remember (gcd_and_bezout m n) as gb eqn:Hgb.
symmetry in Hgb.
destruct gb as (g & u & v); cbn.
specialize (gcd_and_bezout_prop m n g u v Hmz Hgb) as (Hmng & Hg).
rewrite Hmn in Hg; subst g.
apply in_coprimes'_iff.
assert (Hnmz : (n * a * v + m * (n - 1) * b * u) mod (m * n) ≠ 0). {
  rewrite Nat.mod_mul_r; [ | easy | easy ].
  do 2 rewrite <- (Nat.mul_assoc m).
  rewrite Nat_mod_add_r_mul_l; [ | easy ].
  remember ((n * a * v) mod m) as p eqn:Hp; symmetry in Hp.
  destruct p. {
    apply Nat.mod_divides in Hp; [ | easy ].
    destruct Hp as (k, Hk).
    rewrite Nat.mul_shuffle0 in Hk.
    replace (n * v) with (m * u - 1) in Hk by flia Hmng.
    rewrite Nat.mul_sub_distr_r, Nat.mul_1_l in Hk.
    apply Nat.add_sub_eq_nz in Hk. 2: {
      apply Nat.neq_mul_0.
      split; [ easy | ].
      intros H; subst k; rewrite Nat.mul_0_r in Hk.
      apply Nat.sub_0_le in Hk.
      apply Nat.nlt_ge in Hk; apply Hk; clear Hk.
      replace a with (1 * a) at 1 by flia.
      apply Nat.mul_lt_mono_pos_r; [ easy | ].
      destruct u. {
        rewrite Nat.mul_0_r in Hmng; flia Hmng.
      }
      rewrite Nat.mul_succ_r.
      destruct m; [ easy | ].
      destruct m; [ flia H2m | ].
      remember (S (S m) * u); flia.
    }
    rewrite Hmng in Hk.
    rewrite Nat.mul_add_distr_r, Nat.mul_1_l in Hk.
    rewrite Nat.add_comm in Hk.
    apply Nat.add_cancel_r in Hk.
    rewrite Nat.mul_shuffle0 in Hk; rewrite <- Hk.
    rewrite Nat.mul_shuffle0 in Hk.
    replace (n * v) with (m * u - 1) in Hk by flia Hmng.
    rewrite Nat.mul_sub_distr_r, Nat.mul_1_l in Hk.
    symmetry in Hk.
    destruct (le_dec k (u * a)) as [Hku| Hku]. {
      assert (H : a = m * u * a - m * k). {
        rewrite <- Hk.
        rewrite Nat_sub_sub_distr. 2: {
          split; [ | easy ].
          destruct m; [ easy | ].
          destruct u; [ rewrite Nat.mul_0_r in Hmng; flia Hmng | cbn ].
          remember ((u + m * S u) * a); flia.
        }
        now rewrite Nat.sub_diag.
      }
      rewrite <- Nat.mul_assoc in H.
      rewrite <- Nat.mul_sub_distr_l in H.
      destruct Ha as (Ha1, Ha).
      rewrite H in Ha.
      apply Nat.nle_gt in Ha; exfalso; apply Ha.
      destruct (Nat.eq_dec (u * a) k) as [Huk| Huk]. {
        subst k.
        rewrite Nat.sub_diag, Nat.mul_0_r in H; flia H Ha1.
      }
      remember (u * a - k) as p eqn:Hp.
      destruct p. {
        rewrite Nat.mul_0_r in H; flia H Ha1.
      }
      rewrite Nat.mul_succ_r; flia.
    }
    apply Nat.nle_gt in Hku.
    apply (Nat.mul_lt_mono_pos_r m) in Hku; [ | flia Hmz ].
    rewrite (Nat.mul_comm k) in Hku.
    rewrite <- Hk in Hku.
    rewrite Nat.mul_comm, Nat.mul_assoc in Hku.
    remember (m * u * a).
    flia Hku.
  }
  flia.
}
split. {
  apply in_seq.
  split. 2: {
    rewrite (Nat.add_comm _ (m * n - 1)).
    rewrite Nat.sub_add. 2: {
      destruct m; [ flia Hmz | ].
      destruct n; [ flia Hnz | ].
      cbn; remember (m * S n); flia.
    }
    apply Nat.sub_lt; [ | now apply Nat.neq_0_lt_0 ].
    apply Nat.lt_le_incl.
    apply Nat.mod_upper_bound.
    now apply Nat.neq_mul_0.
  }
  apply Nat.le_add_le_sub_r.
  apply Nat.mod_upper_bound.
  now apply Nat.neq_mul_0.
}
remember (n * a * v + m * (n - 1) * b * u) as p eqn:Hp.
rewrite Nat_gcd_sub_diag_l. 2: {
  apply Nat.lt_le_incl.
  apply Nat.mod_upper_bound.
  now apply Nat.neq_mul_0.
}
rewrite Nat.gcd_comm.
rewrite Nat.gcd_mod; [ | now apply Nat.neq_mul_0 ].
rewrite Nat.gcd_comm.
apply Nat_gcd_1_mul_r. {
  rewrite Hp.
  rewrite Nat.gcd_comm.
  do 2 rewrite <- (Nat.mul_assoc m).
  rewrite (Nat.mul_comm m).
  rewrite Nat.gcd_add_mult_diag_r.
  rewrite <- Nat.mul_assoc.
  apply Nat_gcd_1_mul_r; [ easy | ].
  apply Nat_gcd_1_mul_r; [ easy | ].
  apply Nat.bezout_1_gcd.
  exists u, n.
  flia Hmng.
} {
  rewrite Hp.
  rewrite <- (Nat.mul_assoc n).
  rewrite (Nat.mul_comm n).
  rewrite Nat.add_comm, Nat.gcd_comm.
  rewrite Nat.gcd_add_mult_diag_r.
  do 2 rewrite <- Nat.mul_assoc.
  rewrite Nat.mul_comm.
  apply Nat_gcd_1_mul_r; [ | now rewrite Nat.gcd_comm ].
  rewrite Nat.mul_assoc.
  apply Nat_gcd_1_mul_r. 2: {
    apply Nat.bezout_1_gcd.
    apply Nat_bezout_comm; [ easy | ].
    exists m, v.
    flia Hmng.
  }
  apply Nat_gcd_1_mul_r; [ | easy ].
  rewrite Nat_gcd_sub_diag_l; [ | flia Hnz ].
  apply Nat.gcd_1_r.
}
Qed.

Theorem Nat_mul_pred_r_mod : ∀ a b,
  a ≠ 0
  → 1 ≤ b < a
  → (b * (a - 1)) mod a = a - b.
Proof.
intros n a Hmn Ha.
remember (n - a) as b.
replace a with (n - b) in * by flia Heqb Ha.
clear a Heqb; rename b into a.
assert (H : 1 ≤ a < n) by flia Ha.
clear Ha; rename H into Ha.
(* or lemma here, perhaps? *)
rewrite Nat.mul_sub_distr_r.
do 2 rewrite Nat.mul_sub_distr_l, Nat.mul_1_r.
rewrite Nat_sub_sub_assoc. 2: {
  split. {
    destruct n; [ easy | ].
    rewrite Nat.mul_succ_r; flia.
  } {
    replace n with (1 * n) at 4 by flia.
    rewrite <- Nat.mul_sub_distr_r.
    transitivity ((n - 1) * n); [ | flia ].
    apply Nat.mul_le_mono_r; flia Ha.
  }
}
rewrite <- (Nat.mod_add _ a); [ | easy ].
rewrite Nat.sub_add. 2: {
  replace n with (1 * n) at 4 by flia.
  rewrite <- Nat.mul_sub_distr_r.
  transitivity ((n - 1) * n); [ | flia ].
  apply Nat.mul_le_mono_r; flia Ha.
}
rewrite <- Nat.add_sub_swap. 2: {
  replace n with (1 * n) at 1 by flia.
  apply Nat.mul_le_mono_r; flia Hmn.
}
rewrite <- (Nat.mod_add _ 1); [ | easy ].
rewrite Nat.mul_1_l.
rewrite Nat.sub_add. 2: {
  transitivity (n * n); [ | flia ].
  replace n with (1 * n) at 1 by flia.
  apply Nat.mul_le_mono_r; flia Hmn.
}
rewrite Nat.add_comm, Nat.mod_add; [ | easy ].
now rewrite Nat.mod_small.
Qed.

Theorem coprimes'_mul_prod_coprimes' : ∀ m n,
  m ≠ 0
  → n ≠ 0
  → Nat.gcd m n = 1
  → ∀ a, a ∈ seq 1 (m * n - 1)
  → copr_mul_of_prod_copr m n (prod_copr_of_copr_mul m n a) = a.
Proof.
intros * Hmz Hnz Hgmn * Ha.
unfold copr_mul_of_prod_copr.
unfold prod_copr_of_copr_mul.
remember (gcd_and_bezout m n) as gb eqn:Hgb.
symmetry in Hgb.
destruct gb as (g & u & v); cbn.
specialize (gcd_and_bezout_prop m n g u v Hmz Hgb) as (Hmng & Hg).
rewrite Hgmn in Hg; subst g.
specialize (Nat.div_mod a m Hmz) as Ham.
specialize (Nat.div_mod a n Hnz) as Han.
remember (a / m) as qm eqn:Hqm.
remember (a / n) as qn eqn:Hqn.
replace (a mod m) with (a - m * qm) by flia Ham.
replace (a mod n) with (a - n * qn) by flia Han.
rewrite Nat.mul_sub_distr_l, Nat.mul_assoc.
rewrite (Nat.mul_shuffle0 m).
rewrite (Nat.mul_sub_distr_l _ _ m), Nat.mul_assoc.
do 3 rewrite Nat.mul_sub_distr_r.
rewrite Nat.add_sub_assoc. 2: {
  do 2 apply Nat.mul_le_mono_r.
  rewrite <- Nat.mul_assoc.
  apply Nat.mul_le_mono_l.
  subst qn.
  now apply Nat.mul_div_le.
}
assert (Hmn : m * n ≠ 0) by now apply Nat.neq_mul_0.
rewrite <- (Nat.mod_add _ (qn * (n - 1) * u)); [ | easy ].
replace (qn * (n - 1) * u * (m * n)) with (m * n * qn * (n - 1) * u) by flia.
rewrite Nat.sub_add. 2: {
  ring_simplify.
  transitivity (m * (n - 1) * u * a); [ | flia ].
  rewrite Nat.mul_shuffle0.
  rewrite (Nat.mul_shuffle0 m (n - 1)).
  rewrite (Nat.mul_shuffle0 (m * u)).
  apply Nat.mul_le_mono_r.
  rewrite (Nat.mul_shuffle0 _ u).
  apply Nat.mul_le_mono_r.
  rewrite <- Nat.mul_assoc.
  apply Nat.mul_le_mono_l.
  subst qn.
  now apply Nat.mul_div_le.
}
rewrite <- Nat.add_sub_swap. 2: {
  apply Nat.mul_le_mono_r.
  rewrite <- Nat.mul_assoc.
  apply Nat.mul_le_mono_l.
  subst qm.
  now apply Nat.mul_div_le.
}
rewrite <- (Nat.mod_add _ (qm * v)); [ | easy ].
replace (qm * v * (m * n)) with (n * m * qm * v) by flia.
rewrite Nat.sub_add. 2: {
  transitivity (n * a * v). 2: {
    remember (m * a * (n - 1) * u); flia.
  }
  apply Nat.mul_le_mono_r.
  rewrite <- Nat.mul_assoc.
  apply Nat.mul_le_mono_l.
  subst qm.
  now apply Nat.mul_div_le.
}
rewrite Nat.mul_sub_distr_l, Nat.mul_1_r.
rewrite Nat.mul_sub_distr_r.
rewrite Nat.add_sub_assoc. 2: {
  apply Nat.mul_le_mono_r.
  rewrite <- Nat.mul_assoc.
  apply Nat.mul_le_mono_l.
  destruct n; [ easy | ].
  rewrite Nat.mul_succ_r; flia.
}
rewrite (Nat.mul_shuffle0 m a u).
rewrite Hmng.
rewrite Nat.mul_add_distr_r, Nat.mul_1_l.
rewrite Nat.add_comm.
rewrite Nat.sub_add_distr.
rewrite (Nat.mul_shuffle0 n a v).
rewrite Nat.add_sub.
rewrite <- (Nat.mod_add _ a); [ | easy ].
rewrite <- Nat.add_sub_swap. 2: {
  destruct m; [ easy | ].
  destruct n; [ easy | ].
  destruct u; [ rewrite Nat.mul_comm in Hmng; cbn in Hmng; flia Hmng | ].
  rewrite (Nat.mul_shuffle0 (S m)).
  rewrite Nat.mul_shuffle0.
  cbn.
  remember ((u + (n + m * S n) * S u) * a).
  flia.
}
rewrite <- Nat.add_sub_assoc. 2: {
  destruct m; [ easy | ].
  destruct n; [ easy | ].
  rewrite Nat.mul_comm; cbn.
  remember (n + m * S n); flia.
}
replace a with (a * 1) at 3 by flia.
rewrite <- Nat.mul_sub_distr_l.
rewrite Nat.add_comm.
replace (m * a * n * u) with (a * u * (m * n)) by flia.
rewrite Nat.mod_add; [ | easy ].
apply in_seq in Ha.
replace (1 + (m * n - 1)) with (m * n) in Ha by flia Hmn.
rewrite Nat_mul_pred_r_mod; [ | easy | easy ].
rewrite Nat_sub_sub_distr. 2: {
  split; [ | easy ].
  now apply Nat.lt_le_incl.
}
now rewrite Nat.sub_diag.
Qed.

Theorem prod_coprimes'_coprimes'_mul_prod : ∀ m n,
  n ≠ 0
  → Nat.gcd m n = 1
  → ∀ x y, x < m → y < n
  → prod_copr_of_copr_mul m n
       (copr_mul_of_prod_copr m n (x, y)) = (x, y).
Proof.
intros * Hnz Hgmn * Hxm Hyn.
assert (Hmz : m ≠ 0) by flia Hxm.
move Hmz before n.
unfold copr_mul_of_prod_copr.
unfold prod_copr_of_copr_mul.
remember (gcd_and_bezout m n) as gb eqn:Hgb.
symmetry in Hgb.
destruct gb as (g & u & v); cbn.
specialize (gcd_and_bezout_prop m n g u v Hmz Hgb) as (Hmng & Hg).
rewrite Hgmn in Hg; subst g.
remember (n * x * v + m * (n - 1) * y * u) as p eqn:Hp.
f_equal. {
  rewrite Nat.mod_mul_r; [ | easy | easy ].
  rewrite Nat.sub_add_distr.
  rewrite <- (Nat.mod_add _ ((p / m) mod n)); [ | easy ].
  rewrite (Nat.mul_comm _ m).
  rewrite Nat.sub_add. 2: {
    apply Nat.le_add_le_sub_r.
    replace (m * n) with (m * (n - 1) + m). 2: {
      rewrite Nat.mul_sub_distr_l, Nat.mul_1_r.
      apply Nat.sub_add.
      destruct n; [ easy | ].
      rewrite Nat.mul_succ_r; flia.
    }
    apply Nat.add_le_mono. {
      apply Nat.mul_le_mono_l.
      rewrite Nat.sub_1_r.
      apply Nat.lt_le_pred.
      now apply Nat.mod_upper_bound.
    } {
      now apply Nat.lt_le_incl, Nat.mod_upper_bound.
    }
  }
  rewrite Hp.
  do 2 rewrite <- (Nat.mul_assoc m).
  rewrite Nat_mod_add_r_mul_l; [ | easy ].
  rewrite Nat.mul_shuffle0.
  replace (n * v) with (m * u - 1) by flia Hmng.
  rewrite Nat.mul_sub_distr_r, Nat.mul_1_l.
  rewrite <- (Nat.mod_add (m * u * x - x) x); [ | easy ].
  rewrite <- Nat.add_sub_swap. 2: {
    destruct m; [ easy | ].
    destruct u; [ now rewrite Nat.mul_0_r, Nat.add_1_r in Hmng | ].
    cbn.
    apply Nat.le_sub_le_add_l.
    rewrite Nat.sub_diag.
    apply Nat.le_0_l.
  }
  rewrite <- Nat.add_sub_assoc. 2: {
    destruct m; [ easy | ].
    rewrite Nat.mul_succ_r; flia.
  }
  replace x with (x * 1) at 3 by flia.
  rewrite <- Nat.mul_sub_distr_l.
  rewrite Nat.add_comm, <- Nat.mul_assoc.
  rewrite Nat_mod_add_r_mul_l; [ | easy ].
  rewrite <- (Nat.mod_add _ ((x * (m - 1)) mod m)); [ | easy ].
  rewrite <- Nat.add_sub_swap. 2: {
    transitivity (pred m). 2: {
      destruct n; [ easy | ].
      rewrite Nat.mul_succ_r; flia.
    }
    apply Nat.lt_le_pred.
    now apply Nat.mod_upper_bound.
  }
  remember ((x * (m - 1)) mod m) as a.
  rewrite <- Nat.add_sub_assoc. 2: {
    destruct m; [ easy | ].
    rewrite Nat.mul_succ_r; flia.
  }
  replace a with (a * 1) at 2 by flia.
  rewrite <- Nat.mul_sub_distr_l.
  rewrite Nat.add_comm.
  rewrite Nat_mod_add_r_mul_l; [ | easy ].
  subst a.
  rewrite Nat.mul_mod_idemp_l; [ | easy ].
  rewrite <- Nat.mul_assoc.
  rewrite <- Nat.pow_2_r.
  rewrite Nat_sqr_sub; [ | flia Hmz ].
  rewrite Nat.pow_1_l, Nat.mul_1_r, Nat.pow_2_r.
  rewrite <- Nat.mul_mod_idemp_r; [ | easy ].
  rewrite <- (Nat.mod_add (m * m + 1 - 2 * m) 2); [ | easy ].
  rewrite Nat.sub_add. 2: {
    destruct m; [ easy | ].
    destruct m; [ easy | ].
    cbn; remember (m * (S (S m))); flia.
  }
  rewrite Nat.add_comm, Nat.mod_add; [ | easy ].
  rewrite Nat.mul_mod_idemp_r; [ | easy ].
  rewrite Nat.mul_1_r.
  now apply Nat.mod_small.
} {
  rewrite Nat.mul_comm at 2.
  rewrite Nat.mod_mul_r; [ | easy | easy ].
  rewrite Nat.sub_add_distr.
  rewrite <- (Nat.mod_add _ ((p / n) mod m)); [ | easy ].
  rewrite (Nat.mul_comm n).
  rewrite Nat.sub_add. 2: {
    apply Nat.le_add_le_sub_r.
    replace (m * n) with (n * (m - 1) + n). 2: {
      rewrite Nat.mul_sub_distr_l, Nat.mul_1_r.
      rewrite Nat.mul_comm.
      apply Nat.sub_add.
      destruct m; [ easy | ].
      rewrite Nat.mul_succ_l; flia.
    }
    apply Nat.add_le_mono. {
      rewrite Nat.mul_comm.
      apply Nat.mul_le_mono_l.
      rewrite Nat.sub_1_r.
      apply Nat.lt_le_pred.
      now apply Nat.mod_upper_bound.
    } {
      now apply Nat.lt_le_incl, Nat.mod_upper_bound.
    }
  }
  rewrite Hp.
  rewrite Nat.add_comm.
  rewrite <- (Nat.mul_assoc n).
  rewrite Nat_mod_add_r_mul_l; [ | easy ].
  rewrite Nat.mul_shuffle0.
  rewrite (Nat.mul_shuffle0 m).
  rewrite Hmng.
  rewrite Nat.mul_add_distr_r, Nat.mul_1_l.
  rewrite Nat.mul_add_distr_r.
  do 2 rewrite <- Nat.mul_assoc.
  rewrite Nat.add_comm.
  rewrite Nat_mod_add_r_mul_l; [ | easy ].
  rewrite Nat.mul_sub_distr_r, Nat.mul_1_l.
  rewrite <- (Nat.mod_add (n * y - y) y); [ | easy ].
  rewrite <- Nat.add_sub_swap. 2: {
    destruct n; [ easy | cbn; flia ].
  }
  rewrite <- Nat.add_sub_assoc. 2: {
    rewrite Nat.mul_comm.
    destruct n; [ easy | cbn; flia ].
  }
  rewrite Nat.add_comm.
  rewrite Nat_mod_add_r_mul_l; [ | easy ].
  replace y with (y * 1) at 2 by flia.
  rewrite <- Nat.mul_sub_distr_l.
  rewrite <- (Nat.mod_add _ ((y * (n - 1)) mod n)); [ | easy ].
  rewrite <- Nat.add_sub_swap. 2: {
    transitivity (pred n). 2: {
      destruct m; [ easy | ].
      rewrite Nat.mul_succ_l; flia.
    }
    apply Nat.lt_le_pred.
    now apply Nat.mod_upper_bound.
  }
  remember ((y * (n - 1)) mod n) as a.
  rewrite <- Nat.add_sub_assoc. 2: {
    destruct n; [ easy | ].
    rewrite Nat.mul_succ_r; flia.
  }
  replace a with (a * 1) at 2 by flia.
  rewrite <- Nat.mul_sub_distr_l.
  rewrite Nat.add_comm.
  rewrite Nat.mod_add; [ | easy ].
  subst a.
  rewrite Nat.mul_mod_idemp_l; [ | easy ].
  rewrite <- Nat.mul_assoc.
  rewrite <- Nat.pow_2_r.
  rewrite Nat_sqr_sub; [ | flia Hnz ].
  rewrite Nat.pow_1_l, Nat.mul_1_r, Nat.pow_2_r.
  rewrite <- Nat.mul_mod_idemp_r; [ | easy ].
  rewrite <- (Nat.mod_add (n * n + 1 - 2 * n) 2); [ | easy ].
  rewrite Nat.sub_add. 2: {
    destruct n; [ easy | ].
    destruct n; [ easy | ].
    cbn; remember (n * (S (S n))); flia.
  }
  rewrite Nat.add_comm, Nat.mod_add; [ | easy ].
  rewrite Nat.mul_mod_idemp_r; [ | easy ].
  rewrite Nat.mul_1_r.
  now apply Nat.mod_small.
}
Qed.

Theorem φ'_multiplicative : ∀ m n,
  2 ≤ m
  → 2 ≤ n
  → Nat.gcd m n = 1
  → φ' (m * n) = φ' m * φ' n.
Proof.
intros * H2m H2n Hg.
unfold φ'.
rewrite <- prod_length.
apply
  (bijection_same_length (prod_copr_of_copr_mul m n)
     (copr_mul_of_prod_copr m n)). {
  unfold coprimes'.
  apply NoDup_filter, seq_NoDup.
} {
  apply NoDup_prod; apply NoDup_filter, seq_NoDup.
} {
  intros a Ha.
  now apply prod_copr_of_copr_mul_in_prod.
} {
  intros b Hb.
  now apply copr_mul_of_prod_copr_in_coprimes'.
} {
  intros a Ha.
  apply coprimes'_mul_prod_coprimes'; [ flia H2m | flia H2n | easy | ].
  now apply filter_In in Ha.
} {
  intros (x, y) Hxy.
  apply in_prod_iff in Hxy.
  destruct Hxy as (Hx, Hy).
  apply prod_coprimes'_coprimes'_mul_prod; [ flia H2n | easy | | ]. {
    apply filter_In in Hx.
    destruct Hx as (Hx, _).
    apply in_seq in Hx.
    flia Hx.
  } {
    apply filter_In in Hy.
    destruct Hy as (Hy, _).
    apply in_seq in Hy.
    flia Hy.
  }
}
Qed.

(* Euler's theorem *)

Require Import Primes.

Theorem different_coprimes'_all_different_multiples : ∀ n a,
  a ∈ coprimes' n
  → ∀ i j,
  i ∈ coprimes' n
  → j ∈ coprimes' n
  → i ≠ j
  → (i * a) mod n ≠ (j * a) mod n.
Proof.
(* like smaller_than_prime_all_different_multiples but more general *)
intros * Ha * Hi Hj Hij.
intros Haa; symmetry in Haa.
apply in_coprimes'_iff in Ha.
apply in_coprimes'_iff in Hi.
apply in_coprimes'_iff in Hj.
destruct Ha as (Ha, Hna).
destruct Hi as (Hi, Hni).
destruct Hj as (Hj, Hnj).
assert
  (H : ∀ i j, i ∈ seq 1 (n - 1) → j ∈ seq 1 (n - 1) → i < j →
   (j * a) mod n ≠ (i * a) mod n). {
  clear i j Hi Hj Hni Hnj Hij Haa.
  intros * Hi Hj Hilj Haa.
  apply in_seq in Hi.
  apply in_seq in Hj.
  apply Nat_mul_mod_cancel_r in Haa; [ | now rewrite Nat.gcd_comm ].
  rewrite Nat.mod_small in Haa; [ | flia Hj ].
  rewrite Nat.mod_small in Haa; [ | flia Hi ].
  flia Hilj Haa.
}
destruct (lt_dec i j) as [Hilj| Hjli]. {
  now revert Haa; apply H.
} {
  symmetry in Haa.
  assert (Hilj : j < i) by flia Hij Hjli.
  now revert Haa; apply H.
}
Qed.

Theorem coprimes'_mul_in_coprimes' : ∀ n i j,
  i ∈ coprimes' n → j ∈ coprimes' n → (i * j) mod n ∈ coprimes' n.
Proof.
intros * Hi Hj.
destruct (Nat.eq_dec n 0) as [Hnz| Hnz]; [ now subst n | ].
apply in_coprimes'_iff in Hi.
apply in_coprimes'_iff in Hj.
destruct Hi as (Hi, Hgi).
destruct Hj as (Hj, Hgj).
apply in_seq in Hi.
apply in_seq in Hj.
apply in_coprimes'_iff.
split. {
  apply in_seq.
  split. {
    remember ((i * j) mod n) as a eqn:Ha; symmetry in Ha.
    destruct a; [ | flia ].
    apply Nat.mod_divide in Ha; [ | easy ].
    apply Nat.gauss in Ha; [ | easy ].
    destruct Ha as (k, Hk).
    replace n with (1 * n) in Hgj by flia.
    subst j.
    rewrite Nat.gcd_mul_mono_r in Hgj.
    apply Nat.eq_mul_1 in Hgj.
    destruct Hgj as (H1k, Hn); subst n.
    flia Hi.
  } {
    rewrite Nat.add_comm, Nat.sub_add; [ | flia Hnz ].
    now apply Nat.mod_upper_bound.
  }
} {
  rewrite Nat.gcd_comm, Nat.gcd_mod; [ | easy ].
  now apply Nat_gcd_1_mul_r.
}
Qed.

Theorem NoDup_coprimes' : ∀ n, NoDup (coprimes' n).
Proof.
intros.
unfold coprimes'.
apply NoDup_filter, seq_NoDup.
Qed.

Theorem gcd_prod_coprimes' : ∀ n,
  Nat.gcd n (fold_left Nat.mul (coprimes' n) 1) = 1.
Proof.
intros.
assert (H : ∀ a, a ∈ coprimes' n → Nat.gcd n a = 1). {
  intros * H.
  now apply in_coprimes'_iff in H.
}
remember (coprimes' n) as l eqn:Hl; symmetry in Hl; clear Hl.
induction l as [| a l]; intros; [ apply Nat.gcd_1_r | ].
cbn; rewrite Nat.add_0_r.
rewrite fold_left_mul_from_1.
apply Nat_gcd_1_mul_r; [ now apply H; left | ].
apply IHl.
intros b Hb.
now apply H; right.
Qed.

Theorem euler_fermat_little : ∀ n a,
  n ≠ 0 → a ≠ 0 → Nat.gcd a n = 1 → a ^ φ' n ≡ 1 mod n.
Proof.
intros * Hnz Haz Hg.
(* https://wstein.org/edu/2007/spring/ent/ent-html/node19.html#sec:flittle *)
destruct (Nat.eq_dec n 1) as [Hn1| Hn1]; [ now subst n | ].
assert (Ha : a mod n ∈ coprimes' n). {
  apply in_coprimes'_iff.
  rewrite Nat.gcd_comm, Nat.gcd_mod; [ | easy ].
  rewrite Nat.gcd_comm.
  split; [ | easy ].
  apply in_seq.
  rewrite Nat.add_comm, Nat.sub_add; [ | flia Hnz ].
  split. {
    remember (a mod n) as b eqn:Hb; symmetry in Hb.
    destruct b; [ | flia ].
    apply Nat.mod_divides in Hb; [ | easy ].
    replace n with (n * 1) in Hg by flia.
    destruct Hb as (k, Hk); subst a.
    rewrite Nat.gcd_mul_mono_l in Hg.
    now apply Nat.eq_mul_1 in Hg.
  } {
    now apply Nat.mod_upper_bound.
  }
}
rewrite <- Nat_mod_pow_mod.
assert
  (H1 : ∀ i j, i ∈ coprimes' n → j ∈ coprimes' n
   → i ≠ j → (i * a) mod n ≠ (j * a) mod n). {
  intros * Hi Hj Hij.
  rewrite <- (Nat.mul_mod_idemp_r i); [ | easy ].
  rewrite <- (Nat.mul_mod_idemp_r j); [ | easy ].
  now apply different_coprimes'_all_different_multiples.
}
assert (Hcc : ∀ i, i ∈ coprimes' n → (i * a) mod n ∈ coprimes' n). {
  intros i Hi.
  rewrite <- Nat.mul_mod_idemp_r; [ | easy ].
  now apply coprimes'_mul_in_coprimes'.
}
assert
  (Hperm :
     Permutation (map (λ i, (i * a) mod n) (coprimes' n)) (coprimes' n)). {
  apply NoDup_Permutation_bis; try apply NoDup_coprimes'; cycle 1. {
    now rewrite map_length.
  } {
    intros i Hi.
    apply in_map_iff in Hi.
    destruct Hi as (j & Hji & Hj).
    rewrite <- Hji.
    rewrite <- Nat.mul_mod_idemp_r; [ | easy ].
    now apply coprimes'_mul_in_coprimes'.
  } {
    apply NoDup_map_iff with (d := 0).
    intros * Hi Hj Hnth.
    destruct (Nat.eq_dec i j) as [Heij| Heij]; [ easy | exfalso ].
    revert Hnth.
    apply H1; [ now apply nth_In | now apply nth_In | ].
    specialize (NoDup_coprimes' n) as H2.
    remember (coprimes' n) as l.
    clear - Hi Hj Heij H2.
    revert i j Hi Hj Heij.
    induction l as [| a l]; intros; [ easy | ].
    apply NoDup_cons_iff in H2.
    destruct H2 as (Ha, Hnd).
    intros H; cbn in H.
    destruct i. {
      destruct j; [ easy | ].
      subst a; apply Ha.
      cbn in Hj.
      apply Nat.succ_lt_mono in Hj.
      now apply nth_In.
    }
    destruct j. {
      subst a; apply Ha.
      cbn in Hi.
      apply Nat.succ_lt_mono in Hi.
      now apply nth_In.
    }
    cbn in Hi, Hj.
    apply Nat.succ_lt_mono in Hi.
    apply Nat.succ_lt_mono in Hj.
    apply -> Nat.succ_inj_wd_neg in Heij.
    revert H.
    now apply IHl.
  }
}
remember (λ i : nat, (i * a) mod n) as f eqn:Hf.
remember (fold_left Nat.mul (map f (coprimes' n)) 1) as x eqn:Hx.
remember (fold_left Nat.mul (coprimes' n) 1) as y eqn:Hy.
assert (Hx1 : x mod n = y mod n). {
  subst x y.
  erewrite Permutation_fold_mul; [ easy | apply Hperm ].
}
assert (Hx2 : x mod n = (y * a ^ φ' n) mod n). {
  subst x y; rewrite Hf.
  rewrite <- (map_map (λ i, i * a) (λ j, j mod n)).
  rewrite fold_left_mul_map_mod.
  now rewrite fold_left_mul_map_mul.
}
rewrite Hx2 in Hx1.
replace y with (y * 1) in Hx1 at 2 by flia.
apply Nat_mul_mod_cancel_l in Hx1. 2: {
  rewrite Hy, Nat.gcd_comm.
  apply gcd_prod_coprimes'.
}
now rewrite Nat_mod_pow_mod.
Qed.

Theorem prime_φ' : ∀ p, prime p → φ' p = p - 1.
Proof.
intros * Hp.
unfold φ'.
unfold coprimes'.
rewrite (filter_ext_in _ (λ d, true)). 2: {
  intros a Ha.
  apply Nat.eqb_eq.
  apply in_seq in Ha.
  rewrite Nat.add_comm, Nat.sub_add in Ha. 2: {
    destruct p; [ easy | flia ].
  }
  now apply eq_gcd_prime_small_1.
}
clear Hp.
destruct p; [ easy | ].
rewrite Nat.sub_succ, Nat.sub_0_r.
induction p; [ easy | ].
rewrite <- (Nat.add_1_r p).
rewrite seq_app.
rewrite filter_app.
now rewrite app_length, IHp.
Qed.

Corollary fermat_little_again : ∀ p,
  prime p → ∀ a, 1 ≤ a < p → a ^ (p - 1) mod p = 1.
Proof.
intros * Hp * Hap.
rewrite <- prime_φ'; [ | easy ].
replace 1 with (1 mod p). 2: {
  apply Nat.mod_1_l.
  now apply prime_ge_2.
}
apply euler_fermat_little; [ now intros H; subst p | flia Hap | ].
rewrite Nat.gcd_comm.
now apply eq_gcd_prime_small_1.
Qed.

(* proof of corollary above simpler than fermat_little, isn't it? *)


Require Import GeoCoq.Tarski_dev.Definitions.

Section Continuity_Defs.

Context `{Tn:Tarski_neutral_dimensionless}.

(** In this file, we introduce elementary continuity properties.
    These properties are different variant to assert that the intersection
    of line, segment and circles exists under some assumptions.
    Adding one of these properties as axiom to the Tarski_2D type class gives us
    a definition of ruler and compass geometry.
    The links between these properties are in file elementary_continuity_props.v .

    We also introduce other continuity properties.
*)

(** If there is a point P inside a circle, and Q outside then there is
    a point Z of the segment PQ which is on the circle. *)

Definition segment_circle := forall A B P Q,
  InCircle P A B ->
  OutCircle Q A B ->
  exists Z, Bet P Z Q /\ OnCircle Z A B.

(** Given a line UV which contains a point inside the circle, there is
   a point of line UV which is on the circle. *)

Definition one_point_line_circle := forall A B U V P,
  Col U V P -> U <> V -> Bet A P B ->
  exists Z, Col U V Z /\ OnCircle Z A B.

(** Given a line UV which contains a point P inside the circle, there are
  two points on line UV which belong to the circle and they are distinct if
 if P is strictly inside the circle. *)

Definition two_points_line_circle := forall A B U V P,
  Col U V P -> U <> V -> Bet A P B ->
  exists Z1 Z2, Col U V Z1 /\ OnCircle Z1 A B /\
                Col U V Z2 /\ OnCircle Z2 A B /\
                Bet Z1 P Z2 /\ (P <> B -> Z1 <> Z2).

(** Given two circles (A,B) and (C,D), if there are two points of (C,D)
 one inside and one outside (A,B) then there is a point of intersection
 of the two circles. *)

Definition circle_circle := forall A B C D P Q,
  OnCircle P C D ->
  OnCircle Q C D ->
  InCircle P A B ->
  OutCircle Q A B ->
  exists Z, OnCircle Z A B /\ OnCircle Z C D.

(** Given two circles (A,B) and (C,D),
   if there is a point of (A,B) which is inside (C,D)
  and vice-versa, then there is a point of intersection of the two circles. *)

Definition circle_circle_bis := forall A B C D P Q,
  OnCircle P C D ->
  InCircle P A B ->
  OnCircle Q A B ->
  InCircle Q C D ->
  exists Z, OnCircle Z A B /\ OnCircle Z C D.

(** A simplification of the previous statement we use in our axiom system. *)

Definition circle_circle_axiom := forall A B C D B' D',
  Cong A B' A B -> Cong C D' C D ->
  Bet A D' B -> Bet C B' D ->
  exists Z, Cong A Z A B /\ Cong C Z C D.

(** Given two circles (A,B) and (C,D), if there are two points of (C,D)
 one inside and one outside (A,B) then there are two points of intersection
 of the two circles.
 They are distinct if the inside and outside properties are strict. *)

Definition circle_circle_two := forall A B C D P Q,
  OnCircle P C D ->
  OnCircle Q C D ->
  InCircle P A B ->
  OutCircle Q A B ->
  exists Z1 Z2,
    OnCircle Z1 A B /\ OnCircle Z1 C D /\
    OnCircle Z2 A B /\ OnCircle Z2 C D /\
    (InCircleS P A B -> OutCircleS Q A B -> Z1<>Z2).

(** Proposition 22 from Euclid's Elements, Book I:
 "Out of three straight lines, which are equal to three given straight lines, to construct a triangle:
 thus it is necessary that two of the straight lines taken together in any manner
 should be greater than the remaining one."
*)

Definition euclid_s_prop_1_22 := forall A B C D E F A' B' C' D' E' F',
  SumS A B C D E' F' -> SumS A B E F C' D' -> SumS C D E F A' B' ->
  Le E F E' F' -> Le C D C' D' -> Le A B A' B' ->
  exists P Q R, Cong P Q A B /\ Cong P R C D /\ Cong Q R E F.

(*
Definition weak_cantor_s_axiom := forall (A B:nat -> Tpoint),
  (forall n, Bet (A n) (A (S n)) (B (S n)) /\ Bet (A (S n)) (B (S n)) (B n) /\ A (S n) <> B (S n)) ->
  exists X, forall n, Bet (A n) X (B n).
*)

(** Nested A B describes the fact that the sequences A and B form the end points
 of nested non-degenerate segments *)

Definition Nested (A B:nat -> Tpoint -> Prop) :=
  (forall n, exists An Bn, A n An /\ B n Bn) /\
  forall n An Am Bm Bn,
    A n An -> A (S n) Am -> B (S n) Bm -> B n Bn -> Bet An Am Bm /\ Bet Am Bm Bn /\ Am <> Bm.

Definition cantor_s_axiom := forall A B, Nested A B ->
  exists X, forall n An Bn, A n An -> B n Bn -> Bet An X Bn.

Definition dedekind_s_axiom := forall (Alpha Beta : Tpoint -> Prop),
  (exists A, forall X Y, Alpha X -> Beta Y -> Bet A X Y) ->
  (exists B, forall X Y, Alpha X -> Beta Y -> Bet X B Y).

Definition dedekind_variant := forall (Alpha Beta : Tpoint -> Prop) A C,
  Alpha A -> Beta C -> (forall P, Out A P C -> Alpha P \/ Beta P) ->
  (forall X Y, Alpha X -> Beta Y -> Bet A X Y /\ X <> Y) ->
  (exists B, forall X Y, Alpha X -> Beta Y -> Bet X B Y).

(** First-order formula *)

Inductive FOF : Prop -> Prop :=
| eq_fof : forall A B:Tpoint, FOF (A = B)
| bet_fof : forall A B C, FOF (Bet A B C)
| cong_fof : forall A B C D, FOF (Cong A B C D)
| not_fof : forall P, FOF P -> FOF (~ P)
| and_fof : forall P Q, FOF P -> FOF Q -> FOF (P /\ Q)
| or_fof : forall P Q, FOF P -> FOF Q -> FOF (P \/ Q)
| implies_fof : forall P Q, FOF P -> FOF Q -> FOF (P -> Q)
| forall_fof : forall P, (forall (A:Tpoint), FOF (P A)) -> FOF (forall A, P A)
| exists_fof : forall P, (forall (A:Tpoint), FOF (P A)) -> FOF (exists A, P A).

Definition first_order_dedekind := forall Alpha Beta,
  (forall X, FOF (Alpha X)) -> (forall Y, FOF (Beta Y)) ->
  (exists A, forall X Y, Alpha X -> Beta Y -> Bet A X Y) ->
  (exists B, forall X Y, Alpha X -> Beta Y -> Bet X B Y).

Definition archimedes_axiom := forall A B C D, A <> B -> Reach A B C D.

Definition aristotle_s_axiom := forall P Q A B C,
  ~ Col A B C -> Acute A B C ->
  exists X Y, Out B A X /\ Out B C Y /\ Per B X Y /\ Lt P Q X Y.

Definition greenberg_s_axiom := forall P Q R A B C,
  ~ Col A B C ->
  Acute A B C -> Q <> R -> Per P Q R ->
  exists S, LtA P S Q A B C /\ Out Q S R.

End Continuity_Defs.

Section Completeness.

Context `{Tn:Tarski_neutral_dimensionless}.

(** These are formalizations of Hilbert's axiom of completeness:
    "To a system of points, straight lines, and planes,
    it is impossible to add other elements in such a manner that the system thus generalized
    shall form a new geometry obeying all of the five groups of axioms.
    In other words, the elements of geometry form a system which is not susceptible of extension,
    if we regard the five groups of axioms as valid."
    Our formalizations only work respectively for 2 and 3-dimensional spaces:
    it assumes the extension to be respectively 2 and 3-dimensional
    because we have not defined the fact for two spaces to have the same dimension.
*)

Definition inj {T1 T2:Type} (f:T1->T2) := forall A B, f A = f B -> A = B.

Definition pres_bet {Tm: Tarski_neutral_dimensionless}
  (f : @Tpoint Tn -> @Tpoint Tm) := forall A B C, Bet A B C -> Bet (f A) (f B) (f C).

Definition pres_cong {Tm: Tarski_neutral_dimensionless}
  (f : @Tpoint Tn -> @Tpoint Tm) := forall A B C D, Cong A B C D -> Cong (f A) (f B) (f C) (f D).

Definition extension {Tm: Tarski_neutral_dimensionless} f := inj f /\ pres_bet f /\ pres_cong f.

Definition completeness_for_planes := forall (Tm: Tarski_neutral_dimensionless)
  (Tm2 : Tarski_neutral_dimensionless_with_decidable_point_equality Tm)
  (M : Tarski_2D Tm2)
  (f : @Tpoint Tn -> @Tpoint Tm),
  @archimedes_axiom Tm ->
  extension f ->
  forall A, exists B, f B = A.

Definition completeness_for_3d_spaces := forall (Tm: Tarski_neutral_dimensionless)
  (Tm2 : Tarski_neutral_dimensionless_with_decidable_point_equality Tm)
  (M : Tarski_3D Tm2)
  (f : @Tpoint Tn -> @Tpoint Tm),
  @archimedes_axiom Tm ->
  extension f ->
  forall A, exists B, f B = A.

(** This is a formalization of Hilbert's axiom of line completeness:
    "An extension of a set of points on a line with its order and congruence relations
    that would preserve the relations existing among the original elements
    as well as the fundamental properties of line order and congruence [of Archimedean neutral geometry]
    is impossible."
*)

Definition inj_line {T:Type} (f:Tpoint->T) P Q := forall A B, Col P Q A -> Col P Q B ->
  f A = f B -> A = B.

Definition pres_bet_line {Tm: Tarski_neutral_dimensionless}
  (f : @Tpoint Tn -> @Tpoint Tm) P Q := forall A B C, Col P Q A -> Col P Q B -> Col P Q C ->
  Bet A B C -> Bet (f A) (f B) (f C).

Definition pres_cong_line {Tm: Tarski_neutral_dimensionless}
  (f : @Tpoint Tn -> @Tpoint Tm) P Q := forall A B C D,
  Col P Q A -> Col P Q B -> Col P Q C -> Col P Q D ->
  Cong A B C D -> Cong (f A) (f B) (f C) (f D).

Definition line_extension {Tm: Tarski_neutral_dimensionless} f P Q :=
  P <> Q /\ inj_line f P Q /\ pres_bet_line f P Q /\ pres_cong_line f P Q.

Definition line_completeness := forall (Tm: Tarski_neutral_dimensionless)
  (Tm2 : Tarski_neutral_dimensionless_with_decidable_point_equality Tm)
  P Q
  (f : @Tpoint Tn -> @Tpoint Tm),
  @archimedes_axiom Tm ->
  line_extension f P Q ->
  forall A, Col (f P) (f Q) A -> exists B, Col P Q B /\ f B = A.

End Completeness.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import ZAxioms ZMulOrder ZSgnAbs NZDiv.

(** * Euclidean Division for integers, Euclid convention

    We use here the "usual" formulation of the Euclid Theorem
    [forall a b, b<>0 -> exists b q, a = b*q+r /\ 0 < r < |b| ]

    The outcome of the modulo function is hence always positive.
    This corresponds to convention "E" in the following paper:

    R. Boute, "The Euclidean definition of the functions div and mod",
    ACM Transactions on Programming Languages and Systems,
    Vol. 14, No.2, pp. 127-144, April 1992.

    See files [ZDivTrunc] and [ZDivFloor] for others conventions.

    We simply extend NZDiv with a bound for modulo that holds
    regardless of the sign of a and b. This new specification
    subsume mod_bound_pos, which nonetheless stays there for
    subtyping. Note also that ZAxiomSig now already contain
    a div and a modulo (that follow the Floor convention).
    We just ignore them here.
*)

Module Type EuclidSpec (Import A : ZAxiomsSig')(Import B : DivMod A).
 Axiom mod_always_pos : forall a b, b ~= 0 -> 0 <= B.modulo a b < abs b.
End EuclidSpec.

Module Type ZEuclid (Z:ZAxiomsSig) := NZDiv.NZDiv Z <+ EuclidSpec Z.

Module ZEuclidProp
 (Import A : ZAxiomsSig')
 (Import B : ZMulOrderProp A)
 (Import C : ZSgnAbsProp A B)
 (Import D : ZEuclid A).

 (** We put notations in a scope, to avoid warnings about
     redefinitions of notations *)
 Infix "/" := D.div : euclid.
 Infix "mod" := D.modulo : euclid.
 Local Open Scope euclid.

 Module Import Private_NZDiv := Nop <+ NZDivProp A D B.

(** Another formulation of the main equation *)

Lemma mod_eq :
 forall a b, b~=0 -> a mod b == a - b*(a/b).
Proof.
intros.
rewrite <- add_move_l.
symmetry. now apply div_mod.
Qed.

Ltac pos_or_neg a :=
 let LT := fresh "LT" in
 let LE := fresh "LE" in
 destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT].

(** Uniqueness theorems *)

Theorem div_mod_unique : forall b q1 q2 r1 r2 : t,
  0<=r1<abs b -> 0<=r2<abs b ->
  b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2.
Proof.
intros b q1 q2 r1 r2 Hr1 Hr2 EQ.
pos_or_neg b.
rewrite abs_eq in * by trivial.
apply div_mod_unique with b; trivial.
rewrite abs_neq' in * by auto using lt_le_incl.
rewrite eq_sym_iff. apply div_mod_unique with (-b); trivial.
rewrite 2 mul_opp_l.
rewrite add_move_l, sub_opp_r.
rewrite <-add_assoc.
symmetry. rewrite add_move_l, sub_opp_r.
now rewrite (add_comm r2), (add_comm r1).
Qed.

Theorem div_unique:
 forall a b q r, 0<=r<abs b -> a == b*q + r -> q == a/b.
Proof.
intros a b q r Hr EQ.
assert (Hb : b~=0).
 pos_or_neg b.
 rewrite abs_eq in Hr; intuition; order.
 rewrite <- opp_0, eq_opp_r. rewrite abs_neq' in Hr; intuition; order.
destruct (div_mod_unique b q (a/b) r (a mod b)); trivial.
now apply mod_always_pos.
now rewrite <- div_mod.
Qed.

Theorem mod_unique:
 forall a b q r, 0<=r<abs b -> a == b*q + r -> r == a mod b.
Proof.
intros a b q r Hr EQ.
assert (Hb : b~=0).
 pos_or_neg b.
 rewrite abs_eq in Hr; intuition; order.
 rewrite <- opp_0, eq_opp_r. rewrite abs_neq' in Hr; intuition; order.
destruct (div_mod_unique b q (a/b) r (a mod b)); trivial.
now apply mod_always_pos.
now rewrite <- div_mod.
Qed.

(** Sign rules *)

Lemma div_opp_r : forall a b, b~=0 -> a/(-b) == -(a/b).
Proof.
intros. symmetry.
apply div_unique with (a mod b).
rewrite abs_opp; now apply mod_always_pos.
rewrite mul_opp_opp; now apply div_mod.
Qed.

Lemma mod_opp_r : forall a b, b~=0 -> a mod (-b) == a mod b.
Proof.
intros. symmetry.
apply mod_unique with (-(a/b)).
rewrite abs_opp; now apply mod_always_pos.
rewrite mul_opp_opp; now apply div_mod.
Qed.

Lemma div_opp_l_z : forall a b, b~=0 -> a mod b == 0 ->
 (-a)/b == -(a/b).
Proof.
intros a b Hb Hab. symmetry.
apply div_unique with (-(a mod b)).
rewrite Hab, opp_0. split; [order|].
pos_or_neg b; [rewrite abs_eq | rewrite abs_neq']; order.
now rewrite mul_opp_r, <-opp_add_distr, <-div_mod.
Qed.

Lemma div_opp_l_nz : forall a b, b~=0 -> a mod b ~= 0 ->
 (-a)/b == -(a/b)-sgn b.
Proof.
intros a b Hb Hab. symmetry.
apply div_unique with (abs b -(a mod b)).
rewrite lt_sub_lt_add_l.
rewrite <- le_add_le_sub_l. nzsimpl.
rewrite <- (add_0_l (abs b)) at 2.
rewrite <- add_lt_mono_r.
destruct (mod_always_pos a b); intuition order.
rewrite <- 2 add_opp_r, mul_add_distr_l, 2 mul_opp_r.
rewrite sgn_abs.
rewrite add_shuffle2, add_opp_diag_l; nzsimpl.
rewrite <-opp_add_distr, <-div_mod; order.
Qed.

Lemma mod_opp_l_z : forall a b, b~=0 -> a mod b == 0 ->
 (-a) mod b == 0.
Proof.
intros a b Hb Hab. symmetry.
apply mod_unique with (-(a/b)).
split; [order|now rewrite abs_pos].
now rewrite <-opp_0, <-Hab, mul_opp_r, <-opp_add_distr, <-div_mod.
Qed.

Lemma mod_opp_l_nz : forall a b, b~=0 -> a mod b ~= 0 ->
 (-a) mod b == abs b - (a mod b).
Proof.
intros a b Hb Hab. symmetry.
apply mod_unique with (-(a/b)-sgn b).
rewrite lt_sub_lt_add_l.
rewrite <- le_add_le_sub_l. nzsimpl.
rewrite <- (add_0_l (abs b)) at 2.
rewrite <- add_lt_mono_r.
destruct (mod_always_pos a b); intuition order.
rewrite <- 2 add_opp_r, mul_add_distr_l, 2 mul_opp_r.
rewrite sgn_abs.
rewrite add_shuffle2, add_opp_diag_l; nzsimpl.
rewrite <-opp_add_distr, <-div_mod; order.
Qed.

Lemma div_opp_opp_z : forall a b, b~=0 -> a mod b == 0 ->
 (-a)/(-b) == a/b.
Proof.
intros. now rewrite div_opp_r, div_opp_l_z, opp_involutive.
Qed.

Lemma div_opp_opp_nz : forall a b, b~=0 -> a mod b ~= 0 ->
 (-a)/(-b) == a/b + sgn(b).
Proof.
intros. rewrite div_opp_r, div_opp_l_nz by trivial.
now rewrite opp_sub_distr, opp_involutive.
Qed.

Lemma mod_opp_opp_z : forall a b, b~=0 -> a mod b == 0 ->
 (-a) mod (-b) == 0.
Proof.
intros. now rewrite mod_opp_r, mod_opp_l_z.
Qed.

Lemma mod_opp_opp_nz : forall a b, b~=0 -> a mod b ~= 0 ->
 (-a) mod (-b) == abs b - a mod b.
Proof.
intros. now rewrite mod_opp_r, mod_opp_l_nz.
Qed.

(** A division by itself returns 1 *)

Lemma div_same : forall a, a~=0 -> a/a == 1.
Proof.
intros. symmetry. apply div_unique with 0.
split; [order|now rewrite abs_pos].
now nzsimpl.
Qed.

Lemma mod_same : forall a, a~=0 -> a mod a == 0.
Proof.
intros.
rewrite mod_eq, div_same by trivial. nzsimpl. apply sub_diag.
Qed.

(** A division of a small number by a bigger one yields zero. *)

Theorem div_small: forall a b, 0<=a<b -> a/b == 0.
Proof. exact div_small. Qed.

(** Same situation, in term of modulo: *)

Theorem mod_small: forall a b, 0<=a<b -> a mod b == a.
Proof. exact mod_small. Qed.

(** * Basic values of divisions and modulo. *)

Lemma div_0_l: forall a, a~=0 -> 0/a == 0.
Proof.
intros. pos_or_neg a. apply div_0_l; order.
apply opp_inj. rewrite <- div_opp_r, opp_0 by trivial. now apply div_0_l.
Qed.

Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0.
Proof.
intros; rewrite mod_eq, div_0_l; now nzsimpl.
Qed.

Lemma div_1_r: forall a, a/1 == a.
Proof.
intros. symmetry. apply div_unique with 0.
assert (H:=lt_0_1); rewrite abs_pos; intuition; order.
now nzsimpl.
Qed.

Lemma mod_1_r: forall a, a mod 1 == 0.
Proof.
intros. rewrite mod_eq, div_1_r; nzsimpl; auto using sub_diag.
apply neq_sym, lt_neq; apply lt_0_1.
Qed.

Lemma div_1_l: forall a, 1<a -> 1/a == 0.
Proof. exact div_1_l. Qed.

Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1.
Proof. exact mod_1_l. Qed.

Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a.
Proof.
intros. symmetry. apply div_unique with 0.
split; [order|now rewrite abs_pos].
nzsimpl; apply mul_comm.
Qed.

Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0.
Proof.
intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag.
Qed.

Theorem div_unique_exact a b q: b~=0 -> a == b*q -> q == a/b.
Proof.
 intros Hb H. rewrite H, mul_comm. symmetry. now apply div_mul.
Qed.

(** * Order results about mod and div *)

(** A modulo cannot grow beyond its starting point. *)

Theorem mod_le: forall a b, 0<=a -> b~=0 -> a mod b <= a.
Proof.
intros. pos_or_neg b. apply mod_le; order.
rewrite <- mod_opp_r by trivial. apply mod_le; order.
Qed.

Theorem div_pos : forall a b, 0<=a -> 0<b -> 0<= a/b.
Proof. exact div_pos. Qed.

Lemma div_str_pos : forall a b, 0<b<=a -> 0 < a/b.
Proof. exact div_str_pos. Qed.

Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> 0<=a<abs b).
Proof.
intros a b Hb.
split.
intros EQ.
rewrite (div_mod a b Hb), EQ; nzsimpl.
now apply mod_always_pos.
intros. pos_or_neg b.
apply div_small.
now rewrite <- (abs_eq b).
apply opp_inj; rewrite opp_0, <- div_opp_r by trivial.
apply div_small.
rewrite <- (abs_neq' b) by order. trivial.
Qed.

Lemma mod_small_iff : forall a b, b~=0 -> (a mod b == a <-> 0<=a<abs b).
Proof.
intros.
rewrite <- div_small_iff, mod_eq by trivial.
rewrite sub_move_r, <- (add_0_r a) at 1. rewrite add_cancel_l.
rewrite eq_sym_iff, eq_mul_0. tauto.
Qed.

(** As soon as the divisor is strictly greater than 1,
    the division is strictly decreasing. *)

Lemma div_lt : forall a b, 0<a -> 1<b -> a/b < a.
Proof. exact div_lt. Qed.

(** [le] is compatible with a positive division. *)

Lemma div_le_mono : forall a b c, 0<c -> a<=b -> a/c <= b/c.
Proof.
intros a b c Hc Hab.
rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ];
 [|rewrite EQ; order].
rewrite <- lt_succ_r.
rewrite (mul_lt_mono_pos_l c) by order.
nzsimpl.
rewrite (add_lt_mono_r _ _ (a mod c)).
rewrite <- div_mod by order.
apply lt_le_trans with b; trivial.
rewrite (div_mod b c) at 1 by order.
rewrite <- add_assoc, <- add_le_mono_l.
apply le_trans with (c+0).
nzsimpl; destruct (mod_always_pos b c); try order.
rewrite abs_eq in *; order.
rewrite <- add_le_mono_l. destruct (mod_always_pos a c); order.
Qed.

(** In this convention, [div] performs Rounding-Toward-Bottom
    when divisor is positive, and Rounding-Toward-Top otherwise.

    Since we cannot speak of rational values here, we express this
    fact by multiplying back by [b], and this leads to a nice
    unique statement.
*)

Lemma mul_div_le : forall a b, b~=0 -> b*(a/b) <= a.
Proof.
intros.
rewrite (div_mod a b) at 2; trivial.
rewrite <- (add_0_r (b*(a/b))) at 1.
rewrite <- add_le_mono_l.
now destruct (mod_always_pos a b).
Qed.

(** Giving a reversed bound is slightly more complex *)

Lemma mul_succ_div_gt: forall a b, 0<b -> a < b*(S (a/b)).
Proof.
intros.
nzsimpl.
rewrite (div_mod a b) at 1; try order.
rewrite <- add_lt_mono_l.
destruct (mod_always_pos a b). order.
rewrite abs_eq in *; order.
Qed.

Lemma mul_pred_div_gt: forall a b, b<0 -> a < b*(P (a/b)).
Proof.
intros a b Hb.
rewrite mul_pred_r, <- add_opp_r.
rewrite (div_mod a b) at 1; try order.
rewrite <- add_lt_mono_l.
destruct (mod_always_pos a b). order.
rewrite <- opp_pos_neg in Hb. rewrite abs_neq' in *; order.
Qed.

(** NB: The three previous properties could be used as
    specifications for [div]. *)

(** Inequality [mul_div_le] is exact iff the modulo is zero. *)

Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0).
Proof.
intros.
rewrite (div_mod a b) at 1; try order.
rewrite <- (add_0_r (b*(a/b))) at 2.
apply add_cancel_l.
Qed.

(** Some additional inequalities about div. *)

Theorem div_lt_upper_bound:
  forall a b q, 0<b -> a < b*q -> a/b < q.
Proof.
intros.
rewrite (mul_lt_mono_pos_l b) by trivial.
apply le_lt_trans with a; trivial.
apply mul_div_le; order.
Qed.

Theorem div_le_upper_bound:
  forall a b q, 0<b -> a <= b*q -> a/b <= q.
Proof.
intros.
rewrite <- (div_mul q b) by order.
apply div_le_mono; trivial. now rewrite mul_comm.
Qed.

Theorem div_le_lower_bound:
  forall a b q, 0<b -> b*q <= a -> q <= a/b.
Proof.
intros.
rewrite <- (div_mul q b) by order.
apply div_le_mono; trivial. now rewrite mul_comm.
Qed.

(** A division respects opposite monotonicity for the divisor *)

Lemma div_le_compat_l: forall p q r, 0<=p -> 0<q<=r -> p/r <= p/q.
Proof. exact div_le_compat_l. Qed.

(** * Relations between usual operations and mod and div *)

Lemma mod_add : forall a b c, c~=0 ->
 (a + b * c) mod c == a mod c.
Proof.
intros.
symmetry.
apply mod_unique with (a/c+b); trivial.
now apply mod_always_pos.
rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
now rewrite mul_comm.
Qed.

Lemma div_add : forall a b c, c~=0 ->
 (a + b * c) / c == a / c + b.
Proof.
intros.
apply (mul_cancel_l _ _ c); try order.
apply (add_cancel_r _ _ ((a+b*c) mod c)).
rewrite <- div_mod, mod_add by order.
rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
now rewrite mul_comm.
Qed.

Lemma div_add_l: forall a b c, b~=0 ->
 (a * b + c) / b == a + c / b.
Proof.
 intros a b c. rewrite (add_comm _ c), (add_comm a).
 now apply div_add.
Qed.

(** Cancellations. *)

(** With the current convention, the following isn't always true
    when [c<0]: [-3*-1 / -2*-1 = 3/2 = 1] while [-3/-2 = 2] *)

Lemma div_mul_cancel_r : forall a b c, b~=0 -> 0<c ->
 (a*c)/(b*c) == a/b.
Proof.
intros.
symmetry.
apply div_unique with ((a mod b)*c).
(* ineqs *)
rewrite abs_mul, (abs_eq c) by order.
rewrite <-(mul_0_l c), <-mul_lt_mono_pos_r, <-mul_le_mono_pos_r by trivial.
now apply mod_always_pos.
(* equation *)
rewrite (div_mod a b) at 1 by order.
rewrite mul_add_distr_r.
rewrite add_cancel_r.
rewrite <- 2 mul_assoc. now rewrite (mul_comm c).
Qed.

Lemma div_mul_cancel_l : forall a b c, b~=0 -> 0<c ->
 (c*a)/(c*b) == a/b.
Proof.
intros. rewrite !(mul_comm c); now apply div_mul_cancel_r.
Qed.

Lemma mul_mod_distr_l: forall a b c, b~=0 -> 0<c ->
  (c*a) mod (c*b) == c * (a mod b).
Proof.
intros.
rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))).
rewrite <- div_mod.
rewrite div_mul_cancel_l by trivial.
rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
apply div_mod; order.
rewrite <- neq_mul_0; intuition; order.
Qed.

Lemma mul_mod_distr_r: forall a b c, b~=0 -> 0<c ->
  (a*c) mod (b*c) == (a mod b) * c.
Proof.
 intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l.
Qed.

(** Operations modulo. *)

Theorem mod_mod: forall a n, n~=0 ->
 (a mod n) mod n == a mod n.
Proof.
intros. rewrite mod_small_iff by trivial.
now apply mod_always_pos.
Qed.

Lemma mul_mod_idemp_l : forall a b n, n~=0 ->
 ((a mod n)*b) mod n == (a*b) mod n.
Proof.
 intros a b n Hn. symmetry.
 rewrite (div_mod a n) at 1 by order.
 rewrite add_comm, (mul_comm n), (mul_comm _ b).
 rewrite mul_add_distr_l, mul_assoc.
 rewrite mod_add by trivial.
 now rewrite mul_comm.
Qed.

Lemma mul_mod_idemp_r : forall a b n, n~=0 ->
 (a*(b mod n)) mod n == (a*b) mod n.
Proof.
 intros. rewrite !(mul_comm a). now apply mul_mod_idemp_l.
Qed.

Theorem mul_mod: forall a b n, n~=0 ->
 (a * b) mod n == ((a mod n) * (b mod n)) mod n.
Proof.
 intros. now rewrite mul_mod_idemp_l, mul_mod_idemp_r.
Qed.

Lemma add_mod_idemp_l : forall a b n, n~=0 ->
 ((a mod n)+b) mod n == (a+b) mod n.
Proof.
 intros a b n Hn. symmetry.
 rewrite (div_mod a n) at 1 by order.
 rewrite <- add_assoc, add_comm, mul_comm.
 now rewrite mod_add.
Qed.

Lemma add_mod_idemp_r : forall a b n, n~=0 ->
 (a+(b mod n)) mod n == (a+b) mod n.
Proof.
 intros. rewrite !(add_comm a). now apply add_mod_idemp_l.
Qed.

Theorem add_mod: forall a b n, n~=0 ->
 (a+b) mod n == (a mod n + b mod n) mod n.
Proof.
 intros. now rewrite add_mod_idemp_l, add_mod_idemp_r.
Qed.

(** With the current convention, the following result isn't always
    true with a negative intermediate divisor. For instance
    [ 3/(-2)/(-2) = 1 <> 0 = 3 / (-2*-2) ] and
    [ 3/(-2)/2 = -1 <> 0 = 3 / (-2*2) ]. *)

Lemma div_div : forall a b c, 0<b -> c~=0 ->
 (a/b)/c == a/(b*c).
Proof.
 intros a b c Hb Hc.
 apply div_unique with (b*((a/b) mod c) + a mod b).
 (* begin 0<= ... <abs(b*c) *)
 rewrite abs_mul.
 destruct (mod_always_pos (a/b) c), (mod_always_pos a b); try order.
 split.
 apply add_nonneg_nonneg; trivial.
 apply mul_nonneg_nonneg; order.
 apply lt_le_trans with (b*((a/b) mod c) + abs b).
 now rewrite <- add_lt_mono_l.
 rewrite (abs_eq b) by order.
 now rewrite <- mul_succ_r, <- mul_le_mono_pos_l, le_succ_l.
 (* end 0<= ... < abs(b*c) *)
 rewrite (div_mod a b) at 1 by order.
 rewrite add_assoc, add_cancel_r.
 rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
 apply div_mod; order.
Qed.

(** Similarly, the following result doesn't always hold when [b<0].
    For instance [3 mod (-2*-2)) = 3] while
    [3 mod (-2) + (-2)*((3/-2) mod -2) = -1]. *)

Lemma mod_mul_r : forall a b c, 0<b -> c~=0 ->
 a mod (b*c) == a mod b + b*((a/b) mod c).
Proof.
 intros a b c Hb Hc.
 apply add_cancel_l with (b*c*(a/(b*c))).
 rewrite <- div_mod by (apply neq_mul_0; split; order).
 rewrite <- div_div by trivial.
 rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l.
 rewrite <- div_mod by order.
 apply div_mod; order.
Qed.

Lemma mod_div: forall a b, b~=0 ->
 a mod b / b == 0.
Proof.
 intros a b Hb.
 rewrite div_small_iff by assumption.
 auto using mod_always_pos.
Qed.

(** A last inequality: *)

Theorem div_mul_le:
 forall a b c, 0<=a -> 0<b -> 0<=c -> c*(a/b) <= (c*a)/b.
Proof. exact div_mul_le. Qed.

(** mod is related to divisibility *)

Lemma mod_divides : forall a b, b~=0 ->
 (a mod b == 0 <-> (b|a)).
Proof.
intros a b Hb. split.
intros Hab. exists (a/b). rewrite mul_comm.
 rewrite (div_mod a b Hb) at 1. rewrite Hab; now nzsimpl.
intros (c,Hc). rewrite Hc. now apply mod_mul.
Qed.

End ZEuclidProp.


Require Export Coq.Arith.PeanoNat.
Include Coq.Init.Nat.
Require Import Coq.Lists.List.
Import ListNotations.

Definition nat_lt_dec : forall n m : nat, {n < m} + {~ (n < m)}.
  intros n m.
  destruct (n <? m) eqn:e.
  left; apply Nat.ltb_lt; auto.
  right; intro H. assert (true = false) by (transitivity (n <? m); [symmetry; apply Nat.ltb_lt; auto | auto]); discriminate H0.
Defined.

Fixpoint list_max (default : nat) (l : list nat) {struct l}: nat :=
  match l with
  | [] => default
  | x :: xs => max x (list_max default xs)
  end.

Lemma list_max_larger : forall (x default : nat) (l : list nat),
    x = default \/ In x l -> x <= list_max default l.
Proof.
  intros x default l H.
  induction l.
  destruct H; [simpl; rewrite H; reflexivity | inversion H].
  destruct H; [|simpl in H; destruct H].
  - simpl; transitivity (list_max default l);
      [apply IHl; auto| apply Nat.le_max_r].
  - simpl; rewrite H; apply Nat.le_max_l.
  - simpl. transitivity (list_max default l); [apply IHl; auto | apply Nat.le_max_r].
Qed.

Fixpoint RemoveZeros (ns : list nat) : list nat :=
  match ns with
  | [] => []
  | n :: ns' => if n =? 0
               then RemoveZeros ns'
               else n :: RemoveZeros ns'
  end.

Lemma InRemoveZeros : forall (ns : list nat) (n : nat), In n (RemoveZeros ns) -> n <> 0 /\ In n ns.
Proof.
  intros ns n H.
  induction ns; simpl in H; [inversion H | destruct (a =? 0) eqn:e].
  specialize (IHns H); destruct IHns; split; [|right]; auto.
  destruct H. pose proof (Nat.eqb_spec a 0); destruct H0; inversion e.
  rewrite <- H; split; [| left]; auto.
  specialize (IHns H); destruct IHns; split; [|right]; auto.
Qed.

Lemma InRemoveZeros' : forall (ns : list nat) (n : nat), n <> 0 -> In n ns -> In n (RemoveZeros ns).
Proof.
  intros ns. induction ns; simpl; intros n ne nInNs.
  inversion nInNs.
  destruct nInNs.
  destruct (a =? 0) eqn:e;
    [exfalso; apply ne; rewrite Nat.eqb_eq in e; rewrite H in e; auto | left; auto].
  destruct (a =? 0); [apply IHns | right; apply IHns]; auto.
Qed.

Lemma RemoveZerosWithoutZerosInv : forall (ns : list nat), ~ In 0 ns -> RemoveZeros ns = ns.
Proof.
  intros ns H. induction ns.
  simpl. auto.
  simpl. destruct (a =? 0) eqn:e.
  rewrite Nat.eqb_eq in e; exfalso; apply H; left; auto.
  apply f_equal. apply IHns. intro Hcontra; apply H; right; auto.
Qed.

Lemma ZeroNotInRemoveZeros : forall (ns : list nat), ~In 0 (RemoveZeros ns).
Proof.
  intros ns; induction ns; simpl; auto.
  destruct (a =? 0) eqn:e ; auto.
  intro Hcontra. apply IHns. destruct Hcontra; auto.
  rewrite Nat.eqb_neq in e. exfalso; apply e; auto.
Qed.

Lemma minus_one_plus_one : forall m n : nat, m <> 0 -> m - 1 = n  -> m = n + 1.
Proof.
  intros m n H H0;
  induction m; [exfalso; apply H; auto|];
  simpl in H0; rewrite Nat.sub_0_r in H0; rewrite H0; rewrite Nat.add_comm; simpl; reflexivity.
Qed.

Theorem OneLE : forall x, x = 0 \/ 1 <= x.
Proof.
  intros x.
  destruct x. left; auto. right. apply le_n_S.  apply Nat.le_0_l.
Qed.

Theorem OneLES : forall x, 1 <= S x.
Proof.
  intros x. destruct (OneLE (S x)); auto. inversion H.
Qed.

Theorem le_minus_plus : forall n m o, m <= n -> n - m = o -> n = o + m.
Proof.
  induction n; intros m o H H0.
  inversion H. simpl in H0. rewrite Nat.add_0_r. auto.
  destruct m. rewrite Nat.sub_0_r in H0. rewrite Nat.add_0_r. auto.
  simpl in H0. pose proof (le_S_n _ _ H). specialize (IHn m o H1 H0).
  rewrite Nat.add_comm. simpl. apply f_equal. rewrite Nat.add_comm. apply IHn.
Qed.

Theorem ZeroUniqueIdent : forall {a b}, a = a + b -> b = 0.
Proof.
  intros a; induction a; intros b H; simpl.
  simpl in H; symmetry; exact H.
  simpl in H. inversion H. apply IHa; exact H1.
Qed.

Lemma OneUniqueS  :forall {a b}, S a = a + b -> b = 1.
Proof.
  intros a; induction a; intros b H; simpl.
  simpl in H; symmetry; exact H.
  inversion H. apply IHa; exact H1.
Qed.


(* Exercise 45 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

Theorem exercise_045 : ((exists x, P x) -> (forall x, Q x)) -> (forall x, P x -> Q x).
Proof.
imp_i a1.
all_i a.
imp_i a2.
all_e (forall x:D, Q x) a.
imp_e (exists x:D, P x).
hyp a1.
exi_i a.
hyp a2.
Qed.