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

Require Import BinPos BinNat Nnat ZArith_base ROmega ZArithRing Morphisms Zdiv.
Require Export Ndiv_def Zdiv_def.
Require ZBinary ZDivTrunc.

Local Open Scope Z_scope.

(** This file provides results about the Round-Toward-Zero Euclidean
  division [Zquotrem], whose projections are [Zquot] and [Zrem].
  Definition of this division can be found in file [Zdiv_def].

  This division and the one defined in Zdiv agree only on positive
  numbers. Otherwise, Zdiv performs Round-Toward-Bottom (a.k.a Floor).

  The current approach is compatible with the division of usual
  programming languages such as Ocaml. In addition, it has nicer
  properties with respect to opposite and other usual operations.
*)

(** * Relation between division on N and on Z. *)

Lemma Ndiv_Zquot : forall a b:N,
  Z_of_N (a/b) = (Z_of_N a ÷ Z_of_N b).
Proof.
  intros.
  destruct a; destruct b; simpl; auto.
  unfold Ndiv, Zquot; simpl; destruct Pdiv_eucl; auto.
Qed.

Lemma Nmod_Zrem : forall a b:N,
  Z_of_N (a mod b) = Zrem (Z_of_N a) (Z_of_N b).
Proof.
  intros.
  destruct a; destruct b; simpl; auto.
  unfold Nmod, Zrem; simpl; destruct Pdiv_eucl; auto.
Qed.

(** * Characterization of this euclidean division. *)

(** First, the usual equation [a=q*b+r]. Notice that [a mod 0]
   has been chosen to be [a], so this equation holds even for [b=0].
*)

Notation Z_quot_rem_eq := Z_quot_rem_eq (only parsing).

(** Then, the inequalities constraining the remainder:
    The remainder is bounded by the divisor, in term of absolute values *)

Theorem Zrem_lt : forall a b:Z, b<>0 ->
  Zabs (Zrem a b) < Zabs b.
Proof.
  destruct b as [ |b|b]; intro H; try solve [elim H;auto];
  destruct a as [ |a|a]; try solve [compute;auto]; unfold Zrem, Zquotrem;
  generalize (Pdiv_eucl_remainder a b); destruct Pdiv_eucl; simpl;
  try rewrite Zabs_Zopp; rewrite Zabs_eq; auto using Z_of_N_le_0;
  intros LT; apply (Z_of_N_lt _ _ LT).
Qed.

(** The sign of the remainder is the one of [a]. Due to the possible
   nullity of [a], a general result is to be stated in the following form:
*)

Theorem Zrem_sgn : forall a b:Z,
  0 <= Zsgn (Zrem a b) * Zsgn a.
Proof.
  destruct b as [ |b|b]; destruct a as [ |a|a]; simpl; auto with zarith;
  unfold Zrem, Zquotrem; destruct Pdiv_eucl;
  simpl; destruct n0; simpl; auto with zarith.
Qed.

(** This can also be said in a simplier way: *)

Theorem Zsgn_pos_iff : forall z, 0 <= Zsgn z <-> 0 <= z.
Proof.
 destruct z; simpl; intuition auto with zarith.
Qed.

Theorem Zrem_sgn2 : forall a b:Z,
  0 <= (Zrem a b) * a.
Proof.
  intros; rewrite <-Zsgn_pos_iff, Zsgn_Zmult; apply Zrem_sgn.
Qed.

(** Reformulation of [Zquot_lt] and [Zrem_sgn] in 2
  then 4 particular cases. *)

Theorem Zrem_lt_pos : forall a b:Z, 0<=a -> b<>0 ->
  0 <= Zrem a b < Zabs b.
Proof.
  intros.
  assert (0 <= Zrem a b).
   generalize (Zrem_sgn a b).
   destruct (Zle_lt_or_eq 0 a H).
   rewrite <- Zsgn_pos in H1; rewrite H1; romega with *.
   subst a; simpl; auto.
  generalize (Zrem_lt a b H0); romega with *.
Qed.

Theorem Zrem_lt_neg : forall a b:Z, a<=0 -> b<>0 ->
  -Zabs b < Zrem a b <= 0.
Proof.
  intros.
  assert (Zrem a b <= 0).
   generalize (Zrem_sgn a b).
   destruct (Zle_lt_or_eq a 0 H).
   rewrite <- Zsgn_neg in H1; rewrite H1; romega with *.
   subst a; simpl; auto.
  generalize (Zrem_lt a b H0); romega with *.
Qed.

Theorem Zrem_lt_pos_pos : forall a b:Z, 0<=a -> 0<b -> 0 <= Zrem a b < b.
Proof.
  intros; generalize (Zrem_lt_pos a b); romega with *.
Qed.

Theorem Zrem_lt_pos_neg : forall a b:Z, 0<=a -> b<0 -> 0 <= Zrem a b < -b.
Proof.
  intros; generalize (Zrem_lt_pos a b); romega with *.
Qed.

Theorem Zrem_lt_neg_pos : forall a b:Z, a<=0 -> 0<b -> -b < Zrem a b <= 0.
Proof.
  intros; generalize (Zrem_lt_neg a b); romega with *.
Qed.

Theorem Zrem_lt_neg_neg : forall a b:Z, a<=0 -> b<0 -> b < Zrem a b <= 0.
Proof.
  intros; generalize (Zrem_lt_neg a b); romega with *.
Qed.

(** * Division and Opposite *)

(* The precise equalities that are invalid with "historic" Zdiv. *)

Theorem Zquot_opp_l : forall a b:Z, (-a)÷b = -(a÷b).
Proof.
 destruct a; destruct b; simpl; auto;
  unfold Zquot, Zquotrem; destruct Pdiv_eucl; simpl; auto with zarith.
Qed.

Theorem Zquot_opp_r : forall a b:Z, a÷(-b) = -(a÷b).
Proof.
 destruct a; destruct b; simpl; auto;
  unfold Zquot, Zquotrem; destruct Pdiv_eucl; simpl; auto with zarith.
Qed.

Theorem Zrem_opp_l : forall a b:Z, Zrem (-a) b = -(Zrem a b).
Proof.
 destruct a; destruct b; simpl; auto;
  unfold Zrem, Zquotrem; destruct Pdiv_eucl; simpl; auto with zarith.
Qed.

Theorem Zrem_opp_r : forall a b:Z, Zrem a (-b) = Zrem a b.
Proof.
 destruct a; destruct b; simpl; auto;
  unfold Zrem, Zquotrem; destruct Pdiv_eucl; simpl; auto with zarith.
Qed.

Theorem Zquot_opp_opp : forall a b:Z, (-a)÷(-b) = a÷b.
Proof.
 destruct a; destruct b; simpl; auto;
  unfold Zquot, Zquotrem; destruct Pdiv_eucl; simpl; auto with zarith.
Qed.

Theorem Zrem_opp_opp : forall a b:Z, Zrem (-a) (-b) = -(Zrem a b).
Proof.
 destruct a; destruct b; simpl; auto;
  unfold Zrem, Zquotrem; destruct Pdiv_eucl; simpl; auto with zarith.
Qed.

(** * Unicity results *)

Definition Remainder a b r :=
  (0 <= a /\ 0 <= r < Zabs b) \/ (a <= 0 /\ -Zabs b < r <= 0).

Definition Remainder_alt a b r :=
  Zabs r < Zabs b /\ 0 <= r * a.

Lemma Remainder_equiv : forall a b r,
 Remainder a b r <-> Remainder_alt a b r.
Proof.
  unfold Remainder, Remainder_alt; intuition.
  romega with *.
  romega with *.
  rewrite <-(Zmult_opp_opp).
  apply Zmult_le_0_compat; romega.
  assert (0 <= Zsgn r * Zsgn a) by (rewrite <-Zsgn_Zmult, Zsgn_pos_iff; auto).
  destruct r; simpl Zsgn in *; romega with *.
Qed.

Theorem Zquot_mod_unique_full:
 forall a b q r, Remainder a b r ->
   a = b*q + r -> q = a÷b /\ r = Zrem a b.
Proof.
  destruct 1 as [(H,H0)|(H,H0)]; intros.
  apply Zdiv_mod_unique with b; auto.
  apply Zrem_lt_pos; auto.
  romega with *.
  rewrite <- H1; apply Z_quot_rem_eq.

  rewrite <- (Zopp_involutive a).
  rewrite Zquot_opp_l, Zrem_opp_l.
  generalize (Zdiv_mod_unique b (-q) (-a÷b) (-r) (Zrem (-a) b)).
  generalize (Zrem_lt_pos (-a) b).
  rewrite <-Z_quot_rem_eq, <-Zopp_mult_distr_r, <-Zopp_plus_distr, <-H1.
  romega with *.
Qed.

Theorem Zquot_unique_full:
 forall a b q r, Remainder a b r ->
  a = b*q + r -> q = a÷b.
Proof.
 intros; destruct (Zquot_mod_unique_full a b q r); auto.
Qed.

Theorem Zquot_unique:
 forall a b q r, 0 <= a -> 0 <= r < b ->
   a = b*q + r -> q = a÷b.
Proof. exact Z.quot_unique. Qed.

Theorem Zrem_unique_full:
 forall a b q r, Remainder a b r ->
  a = b*q + r -> r = Zrem a b.
Proof.
 intros; destruct (Zquot_mod_unique_full a b q r); auto.
Qed.

Theorem Zrem_unique:
 forall a b q r, 0 <= a -> 0 <= r < b ->
   a = b*q + r -> r = Zrem a b.
Proof. exact Z.rem_unique. Qed.

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

Lemma Zrem_0_l: forall a, Zrem 0 a = 0.
Proof.
  destruct a; simpl; auto.
Qed.

Lemma Zrem_0_r: forall a, Zrem a 0 = a.
Proof.
  destruct a; simpl; auto.
Qed.

Lemma Zquot_0_l: forall a, 0÷a = 0.
Proof.
  destruct a; simpl; auto.
Qed.

Lemma Zquot_0_r: forall a, a÷0 = 0.
Proof.
  destruct a; simpl; auto.
Qed.

Lemma Zrem_1_r: forall a, Zrem a 1 = 0.
Proof. exact Z.rem_1_r. Qed.

Lemma Zquot_1_r: forall a, a÷1 = a.
Proof. exact Z.quot_1_r. Qed.

Hint Resolve Zrem_0_l Zrem_0_r Zquot_0_l Zquot_0_r Zquot_1_r Zrem_1_r
 : zarith.

Lemma Zquot_1_l: forall a, 1 < a -> 1÷a = 0.
Proof. exact Z.quot_1_l. Qed.

Lemma Zrem_1_l: forall a, 1 < a -> Zrem 1 a = 1.
Proof. exact Z.rem_1_l. Qed.

Lemma Z_quot_same : forall a:Z, a<>0 -> a÷a = 1.
Proof. exact Z.quot_same. Qed.

Ltac zero_or_not a :=
  destruct (Z_eq_dec a 0);
  [subst; rewrite ?Zrem_0_l, ?Zquot_0_l, ?Zrem_0_r, ?Zquot_0_r;
   auto with zarith|].

Lemma Z_rem_same : forall a, Zrem a a = 0.
Proof. intros. zero_or_not a. apply Z.rem_same; auto. Qed.

Lemma Z_rem_mult : forall a b, Zrem (a*b) b = 0.
Proof. intros. zero_or_not b. apply Z.rem_mul; auto. Qed.

Lemma Z_quot_mult : forall a b:Z, b <> 0 -> (a*b)÷b = a.
Proof. exact Z.quot_mul. Qed.

(** * Order results about Zrem and Zquot *)

(* Division of positive numbers is positive. *)

Lemma Z_quot_pos: forall a b, 0 <= a -> 0 <= b -> 0 <= a÷b.
Proof. intros. zero_or_not b. apply Z.quot_pos; auto with zarith. Qed.

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

Lemma Z_quot_lt : forall a b:Z, 0 < a -> 2 <= b -> a÷b < a.
Proof. intros. apply Z.quot_lt; auto with zarith. Qed.

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

Theorem Zquot_small: forall a b, 0 <= a < b -> a÷b = 0.
Proof. exact Z.quot_small. Qed.

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

Theorem Zrem_small: forall a n, 0 <= a < n -> Zrem a n = a.
Proof. exact Z.rem_small. Qed.

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

Lemma Z_quot_monotone : forall a b c, 0<=c -> a<=b -> a÷c <= b÷c.
Proof. intros. zero_or_not c. apply Z.quot_le_mono; auto with zarith. Qed.

(** With our choice of division, rounding of (a÷b) is always done toward zero: *)

Lemma Z_mult_quot_le : forall a b:Z, 0 <= a -> 0 <= b*(a÷b) <= a.
Proof. intros. zero_or_not b. apply Z.mul_quot_le; auto with zarith. Qed.

Lemma Z_mult_quot_ge : forall a b:Z, a <= 0 -> a <= b*(a÷b) <= 0.
Proof. intros. zero_or_not b. apply Z.mul_quot_ge; auto with zarith. Qed.

(** The previous inequalities between [b*(a÷b)] and [a] are exact
    iff the modulo is zero. *)

Lemma Z_quot_exact_full : forall a b:Z, a = b*(a÷b) <-> Zrem a b = 0.
Proof. intros. zero_or_not b. intuition. apply Z.quot_exact; auto. Qed.

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

Theorem Zrem_le: forall a b, 0 <= a -> 0 <= b -> Zrem a b <= a.
Proof. intros. zero_or_not b. apply Z.rem_le; auto with zarith. Qed.

(** Some additionnal inequalities about Zdiv. *)

Theorem Zquot_le_upper_bound:
  forall a b q, 0 < b -> a <= q*b -> a÷b <= q.
Proof. intros a b q; rewrite Zmult_comm; apply Z.quot_le_upper_bound. Qed.

Theorem Zquot_lt_upper_bound:
  forall a b q, 0 <= a -> 0 < b -> a < q*b -> a÷b < q.
Proof. intros a b q; rewrite Zmult_comm; apply Z.quot_lt_upper_bound. Qed.

Theorem Zquot_le_lower_bound:
  forall a b q, 0 < b -> q*b <= a -> q <= a÷b.
Proof. intros a b q; rewrite Zmult_comm; apply Z.quot_le_lower_bound. Qed.

Theorem Zquot_sgn: forall a b,
  0 <= Zsgn (a÷b) * Zsgn a * Zsgn b.
Proof.
  destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith;
  unfold Zquot; simpl; destruct Pdiv_eucl; simpl; destruct n; simpl; auto with zarith.
Qed.

(** * Relations between usual operations and Zmod and Zdiv *)

(** First, a result that used to be always valid with Zdiv,
    but must be restricted here.
    For instance, now (9+(-5)*2) rem 2 = -1 <> 1 = 9 rem 2 *)

Lemma Z_rem_plus : forall a b c:Z,
 0 <= (a+b*c) * a ->
 Zrem (a + b * c) c = Zrem a c.
Proof. intros. zero_or_not c. apply Z.rem_add; auto with zarith. Qed.

Lemma Z_quot_plus : forall a b c:Z,
 0 <= (a+b*c) * a -> c<>0 ->
 (a + b * c) ÷ c = a ÷ c + b.
Proof. intros. apply Z.quot_add; auto with zarith. Qed.

Theorem Z_quot_plus_l: forall a b c : Z,
 0 <= (a*b+c)*c -> b<>0 ->
 b<>0 -> (a * b + c) ÷ b = a + c ÷ b.
Proof. intros. apply Z.quot_add_l; auto with zarith. Qed.

(** Cancellations. *)

Lemma Zquot_mult_cancel_r : forall a b c:Z,
 c<>0 -> (a*c)÷(b*c) = a÷b.
Proof. intros. zero_or_not b. apply Z.quot_mul_cancel_r; auto. Qed.

Lemma Zquot_mult_cancel_l : forall a b c:Z,
 c<>0 -> (c*a)÷(c*b) = a÷b.
Proof.
 intros. rewrite (Zmult_comm c b). zero_or_not b.
 rewrite (Zmult_comm b c). apply Z.quot_mul_cancel_l; auto.
Qed.

Lemma Zmult_rem_distr_l: forall a b c,
  Zrem (c*a) (c*b) = c * (Zrem a b).
Proof.
 intros. zero_or_not c. rewrite (Zmult_comm c b). zero_or_not b.
 rewrite (Zmult_comm b c). apply Z.mul_rem_distr_l; auto.
Qed.

Lemma Zmult_rem_distr_r: forall a b c,
  Zrem (a*c) (b*c) = (Zrem a b) * c.
Proof.
 intros. zero_or_not b. rewrite (Zmult_comm b c). zero_or_not c.
 rewrite (Zmult_comm c b). apply Z.mul_rem_distr_r; auto.
Qed.

(** Operations modulo. *)

Theorem Zrem_rem: forall a n, Zrem (Zrem a n) n = Zrem a n.
Proof. intros. zero_or_not n. apply Z.rem_rem; auto. Qed.

Theorem Zmult_rem: forall a b n,
 Zrem (a * b) n = Zrem (Zrem a n * Zrem b n) n.
Proof. intros. zero_or_not n. apply Z.mul_rem; auto. Qed.

(** addition and modulo

  Generally speaking, unlike with Zdiv, we don't have
       (a+b) rem n = (a rem n + b rem n) rem n
  for any a and b.
  For instance, take (8 + (-10)) rem 3 = -2 whereas
  (8 rem 3 + (-10 rem 3)) rem 3 = 1. *)

Theorem Zplus_rem: forall a b n,
 0 <= a * b ->
 Zrem (a + b) n = Zrem (Zrem a n + Zrem b n) n.
Proof. intros. zero_or_not n. apply Z.add_rem; auto. Qed.

Lemma Zplus_rem_idemp_l: forall a b n,
 0 <= a * b ->
 Zrem (Zrem a n + b) n = Zrem (a + b) n.
Proof. intros. zero_or_not n. apply Z.add_rem_idemp_l; auto. Qed.

Lemma Zplus_rem_idemp_r: forall a b n,
 0 <= a*b ->
 Zrem (b + Zrem a n) n = Zrem (b + a) n.
Proof.
 intros. zero_or_not n. apply Z.add_rem_idemp_r; auto.
 rewrite Zmult_comm; auto.
Qed.

Lemma Zmult_rem_idemp_l: forall a b n, Zrem (Zrem a n * b) n = Zrem (a * b) n.
Proof. intros. zero_or_not n. apply Z.mul_rem_idemp_l; auto. Qed.

Lemma Zmult_rem_idemp_r: forall a b n, Zrem (b * Zrem a n) n = Zrem (b * a) n.
Proof. intros. zero_or_not n. apply Z.mul_rem_idemp_r; auto. Qed.

(** Unlike with Zdiv, the following result is true without restrictions. *)

Lemma Zquot_Zquot : forall a b c, (a÷b)÷c = a÷(b*c).
Proof.
 intros. zero_or_not b. rewrite Zmult_comm. zero_or_not c.
 rewrite Zmult_comm. apply Z.quot_quot; auto.
Qed.

(** A last inequality: *)

Theorem Zquot_mult_le:
 forall a b c, 0<=a -> 0<=b -> 0<=c -> c*(a÷b) <= (c*a)÷b.
Proof. intros. zero_or_not b. apply Z.quot_mul_le; auto with zarith. Qed.

(** Zrem is related to divisibility (see more in Znumtheory) *)

Lemma Zrem_divides : forall a b,
 Zrem a b = 0 <-> exists c, a = b*c.
Proof.
 intros. zero_or_not b. firstorder.
 rewrite Z.rem_divide; trivial. split; intros (c,Hc); exists c; auto.
Qed.

(** Particular case : dividing by 2 is related with parity *)

Lemma Zquot2_odd_remainder : forall a,
 Remainder a 2 (if Zodd_bool a then Zsgn a else 0).
Proof.
 intros [ |p|p]. simpl.
 left. simpl. auto with zarith.
 left. destruct p; simpl; auto with zarith.
 right. destruct p; simpl; split; now auto with zarith.
Qed.

Lemma Zquot2_quot : forall a, Zquot2 a = a÷2.
Proof.
 intros.
 apply Zquot_unique_full with (if Zodd_bool a then Zsgn a else 0).
 apply Zquot2_odd_remainder.
 apply Zquot2_odd_eqn.
Qed.

Lemma Zrem_odd : forall a, Zrem a 2 = if Zodd_bool a then Zsgn a else 0.
Proof.
 intros. symmetry.
 apply Zrem_unique_full with (Zquot2 a).
 apply Zquot2_odd_remainder.
 apply Zquot2_odd_eqn.
Qed.

Lemma Zrem_even : forall a, Zrem a 2 = if Zeven_bool a then 0 else Zsgn a.
Proof.
 intros a. rewrite Zrem_odd, Zodd_even_bool. now destruct Zeven_bool.
Qed.

Lemma Zeven_rem : forall a, Zeven_bool a = Zeq_bool (Zrem a 2) 0.
Proof.
 intros a. rewrite Zrem_even.
 destruct a as [ |p|p]; trivial; now destruct p.
Qed.

Lemma Zodd_rem : forall a, Zodd_bool a = negb (Zeq_bool (Zrem a 2) 0).
Proof.
 intros a. rewrite Zrem_odd.
 destruct a as [ |p|p]; trivial; now destruct p.
Qed.

(** * Interaction with "historic" Zdiv *)

(** They agree at least on positive numbers: *)

Theorem Zquotrem_Zdiv_eucl_pos : forall a b:Z, 0 <= a -> 0 < b ->
  a÷b = a/b /\ Zrem a b = a mod b.
Proof.
  intros.
  apply Zdiv_mod_unique with b.
  apply Zrem_lt_pos; auto with zarith.
  rewrite Zabs_eq; auto with *; apply Z_mod_lt; auto with *.
  rewrite <- Z_div_mod_eq; auto with *.
  symmetry; apply Z_quot_rem_eq; auto with *.
Qed.

Theorem Zquot_Zdiv_pos : forall a b, 0 <= a -> 0 <= b ->
  a÷b = a/b.
Proof.
 intros a b Ha Hb.
 destruct (Zle_lt_or_eq _ _ Hb).
 generalize (Zquotrem_Zdiv_eucl_pos a b Ha H); intuition.
 subst; rewrite Zquot_0_r, Zdiv_0_r; reflexivity.
Qed.

Theorem Zrem_Zmod_pos : forall a b, 0 <= a -> 0 < b ->
  Zrem a b = a mod b.
Proof.
 intros a b Ha Hb; generalize (Zquotrem_Zdiv_eucl_pos a b Ha Hb);
 intuition.
Qed.

(** Modulos are null at the same places *)

Theorem Zrem_Zmod_zero : forall a b, b<>0 ->
 (Zrem a b = 0 <-> a mod b = 0).
Proof.
 intros.
 rewrite Zrem_divides, Zmod_divides; intuition.
Qed.


From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp Require Import bigenough cauchyreals.
Require Import extra_mathcomp extra_cauchyreals.
Require Import tactics shift bigopz arithmetics seq_defs.
Require Import c_props s_props z3seq_props a_props b_props b_over_a_props.
Require hanson.

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

Import Order.TTheory GRing.Theory Num.Theory BigEnough.

Local Open Scope ring_scope.

(******************************************************************************)
(* In this file we define the real number zeta(3) and prove that it is        *)
(* irrational. This is a constructive proof which is essentially based on the *)
(* two following 'informal' proofs:                                           *)
(* - A proof that Euler missed, an informal report, A. van der Poorten,       *)
(*   Mathematical Intelligencer, vol 1 (1979), pp 195-203                     *)
(* - An Algolib-aided Version of Apery's Proof of the Irrationality of        *)
(*   zeta(3) Bruno Salvy, 2003, Maple worksheet available online at           *)
(*   http://algo.inria.fr/libraries/autocomb/Apery2-html/apery1.html          *)
(* We however had to make explicit or more elementary some parts of the proof *)
(* to complete the formalization, see the comments below.                     *)
(* For the time being, the proof still relies on a result we did not          *)
(* formalize about the asymptotic behaviour of the sequence lcm(1,...,n).     *)
(******************************************************************************)

Ltac raise_big_enough := solve [big_enough_trans].

(* We prove that z3seq is a Cauchy sequence. *)
Lemma creal_z3seq : creal_axiom z3seq.
Proof.
rewrite /creal_axiom.
pose n_inv_seq (n : nat) := n%:Q^-1.
have [/= modulus_n_inv modulus_n_inv_P] : {asympt e : i / n_inv_seq i < e}.
  exists_big_modulus M rat => /=.
    move=> eps i lt_eps0 hMi.
    rewrite /n_inv_seq -div1r ltr_pdivr_mulr;
      last by rewrite ltr0n; raise_big_enough.
    rewrite -ltr_pdivr_mull // mulr1.
    apply: lt_trans (archi_boundP _) _; first by rewrite ger0E ltW.
    rewrite ltr_nat; raise_big_enough.
  by close.
exists_big_modulus m rat.
  move=> eps i j lt_eps_0 hmi hmj.
  wlog ltij : i j hmi hmj / (j < i)%N.
    move=> hwlog; case: (ltngtP i j); last by move ->; rewrite subrr.
    - rewrite distrC; exact/hwlog.
    - exact/hwlog.
  rewrite gtr0_norm; last exact: lt_0_Dz3seq.
  pose v (n : nat) := n%:Q ^- 2.
  have vpos (n : nat) : (0 < n)%N -> 0 < v n.
    by move=> ?; rewrite /v invr_gt0; apply: exprn_gt0; rewrite ltr0n.
  have maj : z3seq i - z3seq j <=
             - 2%:Q^-1 * \sum_(j <= k < i) (v (k + 1)%N - v k).
    rewrite Dz3seqE // big_add1 /= mulr_sumr.
    apply: ler_sum_nat => k /andP[hjk hki]; rewrite /v addn1.
    apply: z3seq_smd_maj; rewrite ltr0n; apply: leq_trans _ hjk.
    raise_big_enough.
  apply: le_lt_trans maj _; rewrite telescope_nat //.
  suff maj : v j < 2%:Q * eps.
    rewrite mulNr -mulrN opprB ltr_pdivr_mull // ltr_subl_addr.
    apply: lt_trans maj _; rewrite ltr_addl; apply: vpos; exact: ltn_trans ltij.
  have maj : v j < j%:Q^-1.
    rewrite /v -div1r ltr_pdivr_mulr; last by rewrite exprn_gt0 // ltr0n.
    by rewrite mulKf ?ltr1n // lt0r_neq0 // ltr0n.
  by apply: lt_trans maj _; apply: modulus_n_inv_P; rewrite // pmulr_rgt0.
by close.
Qed.

(* Actual definition of \zeta(3) as a Cauchy real, i.e. the equivalence class *)
(* of the sequence z3seq for Cauchy equivalence. *)
Definition z3 : creal rat_realFieldType := CReal creal_z3seq.

(* We prove that the sequences z3seq and b / a are asymptotically close. *)
Lemma z3seq_b_over_a_asympt : {asympt e : i / `|z3seq i - b_over_a_seq i| < e}.
Proof.
exists_big_modulus M rat.
  move=> eps i peps hmi /=.
  suff step1 : \sum_(0 <= i0 < Posz i + 1 :> int) `|c i i0 * s i i0| < eps * a i.
    suff -> : b_over_a_seq i =
              z3seq i + (\sum_(0 <= k < Posz i + 1 :> int) c i k * s i k) / a i.
      rewrite opprD addNKr normrN normrM normfV.
      rewrite [X in _ / X](gtr0_norm (lt_0_a _)) // ltr_pdivr_mulr ?lt_0_a //.
      exact: le_lt_trans (ler_norm_sum _ _ _) _.
    apply: canLR (mulfK _) _; rewrite ?mulrDl ?divfK ?a_neq0 //.
    rewrite mulr_sumr -big_split /=; apply: eq_bigr => j _.
    by rewrite /v /u mulrDr mulrC.
  rewrite -PoszD !eq_big_int_nat /=.
  have step2 (i0 : nat) : (0 <= i0 <= i)%N ->
    `|c i i0 * s i i0| <= c i i0 * i0%:Q / (2%:Q * i%:Q ^ 2).
    case/andP=> _ hi0; rewrite normrM [`|c i i0|]gtr0_norm ?lt_0_c //.
    rewrite -mulrA ler_pmul2l //; last exact: lt_0_c.
    apply: s_maj; rewrite // ltr0n; raise_big_enough.
  apply: (@le_lt_trans _ _ (\sum_(0 <= i0 < i + 1)
                   c i i0 * i0%:Q / (2%:Q * i%:Q ^ 2))).
    apply: ler_sum_nat => j /andP[h0j].
    rewrite addn1 ltnS => hji; exact: step2.
  apply:(@le_lt_trans _ _ ((\sum_(0 <= i0 < i + 1) c i i0) / (2%:Q * i%:Q))).
    rewrite mulr_suml; apply: ler_sum_nat => j /andP[h0j].
    rewrite addn1 ltnS => hji; rewrite -mulrA ler_pmul2l ?lt_0_c //.
    rewrite mulrA invfM mulrCA ger_pmulr; last by rewrite gtr0E mulr_gt0 ?ltr0n.
    by rewrite ler_pdivr_mulr ?ltr0n // mul1r ler_nat.
  rewrite mulrC -eq_big_int_nat /= ltr_pmul2r; last first.
    rewrite -/(a i); exact: lt_0_a.
  rewrite invfM ltr_pdivr_mulr ?ltr0n // mulrC -ltr_pdivr_mulr //.
  apply: lt_trans (archi_boundP _) _; last by rewrite ltr_nat; raise_big_enough.
  by rewrite mulr_ge0 // invr_ge0 ltW.
by close.
Qed.

(* As a corollary, b_over_a itself is also a Cauchy sequence. *)
Corollary creal_b_over_a_seq : creal_axiom b_over_a_seq.
Proof. apply: (@asympt_eq_creal _ z3); exact: z3seq_b_over_a_asympt. Qed.

(* We define the Cauchy real b_over_a, i.e. the equivalent class *)
(* of the sequence b / a for Cauchy equivalence. *)
Definition b_over_a := CReal creal_b_over_a_seq.

(* Obviously, z3 and b_over_a are the same Cauchy real. *)
Fact z3_eq_b_over_a : (z3 == b_over_a)%CR.
Proof. exact/eq_crealP/z3seq_b_over_a_asympt. Qed.

(* Using the properties of the Casoratian of a and b, we establish the *)
(* positivity of zeta3 - b n / an. *)
Lemma lt0_z3_minus_b_over_a (n : nat) :
  (2 <= n)%N -> (0%:CR < z3 - (b_over_a_seq n)%:CR)%CR.
Proof.
move=> le2n.
pose_big_enough m.
  have diff_pos1 (k l : nat) : (k < l)%N -> (1 < k)%N ->
                               0 < b_over_a_seq l - b_over_a_seq k.
    move=> ltkn lt1k; rewrite Db_over_a_casoratian //.
    rewrite (big_cat_nat _ _ _ (leqnSn _) ltkn) big_nat1 /=.
    have aux (i : nat) : 0 < 6%:Q / (i%:Q + 1) ^ 3 / (a (int.shift 1 i) * a i).
      apply: divr_gt0; first by apply: lt_0_ba_casoratian.
      apply:mulr_gt0; exact: lt_0_a.
    apply: ltr_spaddl => //;  apply: sumr_ge0 => i _; exact: ltW.
  have -> : (z3 - (b_over_a_seq n)%:CR ==
         z3 - (b_over_a_seq m)%:CR + (b_over_a_seq m - b_over_a_seq n)%:CR)%CR.
    by apply: eq_creal_ext => i /=; ring.
  rewrite z3_eq_b_over_a; apply: ltcr_spaddr.
    apply/lt_creal_cst/diff_pos1; raise_big_enough.
  by apply: (@le_crealP _ m.+1) => *; apply/ltW/diff_pos1; raise_big_enough.
by close.
Qed.

(* Again using the properties of the casoratian, we can prove that *)
(* delta n := a(n)zeta3(n) - b(n) is dominated by O(1 / a(n)^2). An easy   *)
(* constant is (a "nearby" rational number equal or greater than) 6 * zeta(3).*)
Definition Kdelta := ubound (6%:Q%:CR * z3)%CR.

(* Later in the study of sequence sigma we'll need the fact that this constant *)
(* is non zero. *)
Fact lt_0_Kdelta : 0 < Kdelta.
Proof. exact: ubound_gt0. Qed.

Lemma delta_asympt : {large : nat | forall n, (large <= n)%N ->
     ((a n)%:CR * z3 - (b n)%:CR <= (Kdelta * (1 / a n))%:CR)%CR}.
Proof.
pose_big_enough large.
exists large => n hlarge.
  apply: (@lecr_trans _ (6%:Q%:CR * z3 * (1 / a n)%:CR))%CR; last first.
    rewrite cst_crealM.
    by apply/lecr_mulf2r/divr_ge0/le_0_a; first exact: le_ubound.
  rewrite {1}z3_eq_b_over_a; apply: (@le_crealP _ n) => i leni /=.
  rewrite mul1r ler_subl_addr mulrC -ler_pdivl_mulr ?lt_0_a // mulrDl.
  rewrite -[_ / _ / _]mulrA -[_ / _]invfM -expr2 -ler_subl_addr.
  rewrite -/(b_over_a_seq n).
  have leSnSi : (n.+1 <= i.+1)%N by [].
  rewrite z3seqE mulr_sumr (big_cat_nat _ _ _ _ leSnSi) //= mulrDl ler_paddl //.
    rewrite divr_ge0 ?exprn_ge0 ?le_0_a ?sumr_ge0 // => k _.
    by rewrite divr_ge0 ?exprn_ge0 ?ler0n.
  rewrite big_add1 /= Db_over_a_casoratian; [ | raise_big_enough | exact: leni].
  rewrite mulr_suml; apply: ler_sum_nat => j /andP[hnj hji].
  rewrite -mulrSr ler_pmul2l; last by apply/divr_gt0/exprz_gt0; rewrite ltr0n.
  rewrite lef_pinv; [| apply: mulr_gt0; exact: lt_0_a..].
  by apply: ler_pmul; rewrite ?le_0_a //; apply: a_incr; lia.
by close.
Qed.

Definition Ndelta := projT1 delta_asympt.

Fact NdeltaP (n : nat) : (Ndelta <= n)%N ->
     ((a n)%:CR * z3 - (b n)%:CR <= (Kdelta * (1 / a n))%:CR)%CR.
Proof. by rewrite /Ndelta; case: delta_asympt => /= ?; exact. Qed.

(* We define an a priori real valued sequence whose properties forbid *)
(* zeta(3) to be irrational. ***)

Local Notation l := iter_lcmn.

Definition sigma (n : nat) :=
  (2%:Q%:CR * ((l n)%:Q ^ 3)%:CR * ((a n)%:CR * z3 - (b n)%:CR))%CR.

(* Sequence sigma has positive terms. *)
Lemma lt_0_sigma (n : nat) : (2 <= n)%N -> (0%CR < sigma n)%CR.
Proof.
move=> le2n; rewrite /sigma -!cst_crealM; apply: mulr_gtcr0.
  by apply/lt_creal_cst; rewrite mulr_gt0 // exprz_gt0 ?ltr0n.
suff : (0 < (a n)%:CR * (z3 - (b_over_a_seq n)%:CR))%CR.
  by rewrite mulcrDr mulcrN -cst_crealM mulrC mulfVK // a_neq0.
exact/mulr_gtcr0/lt0_z3_minus_b_over_a/le2n/lt_creal_cst/lt_0_a.
Qed.

(* This is the *statement* of the result we use without a formal *)
(* proof. It is a weak corollary of the Prime Number Theorem (pnt) but *)
(* can be obtained directly from more elementary means, see a proof in *)
(* "On the product of the primes" D. Hanson, *)
(* Canad. Math. Bull. Vol. 15(1), 1972. *)
(* A close inspection of the paper validates in particular the *)
(* hypothesis we need on K2^3. *)

(* Definition weak_pnt := exists K2 : rat, exists K3 : rat, exists N : nat, *)
(*   [/\ 0 < K2, *)
(*       0 < K3, *)
(*       K2 ^ 3 < 33%:~R & *)
(*       forall n : nat, (N <= n)%N ->  (l n)%:~R < K3 * K2 ^ n]. *)

(* In the following two sections, we work in a context which assumes *)
(* that property weak_pnt holds. *)
Section SigmaGoesToZero.

Lemma hanson : exists K2 : rat, exists K3 : rat, exists N : nat,
  [/\ 0 < K2,
      0 < K3,
      K2 ^ 3 < 33%:Q &
      forall n : nat, (N <= n)%N ->  (l n)%:Q < K3 * K2 ^ n].
Proof.
exists 3%:Q.
case: hanson.Hanson.t3 => K [Hpos H].
exists (K.+1)%:Q; exists 0%N.
rewrite !ltr0n; split => // n _; apply: le_lt_trans (H n) _.
by rewrite -exprnP -natrX -natrM ltr_nat ltn_mul2r expn_gt0 /=. (* funny: does not work without the /= *)
Qed.

Lemma sigma_goes_to_0 (eps : rat) : 0 < eps ->
  exists M : nat, forall n : nat, (M <= n)%N -> (sigma n < eps%:CR)%CR.
Proof.
move=> eps_pos.
have [K2 [K3 [large [K2pos K3pos K2_maj hanson]]]] := hanson.
pose C := 2%:Q * (K3 ^ 3) * Kdelta * Ka ^-1.
have Cpos : 0 < C.
  by rewrite !(exprz_gt0, mulr_gt0) ?invr_gt0 ?lt_0_Ka ?lt_0_Kdelta.
have heps : 0 < eps / C by apply: divr_gt0.
have hr : 0 < K2 ^ 3 / 33%:Q < 1.
  by rewrite andbC -ltr_pdivl_mulr // invrK mul1r K2_maj divr_gt0 // exprn_gt0.
have [N hN] := Gseqlt1 heps hr.
pose_big_enough M.
  exists M => n hn.
  have aux : (sigma n <
         (2%:Q * (K3 * K2 ^ n) ^ 3 * Kdelta / Ka / 33%:Q ^ n)%:CR)%CR.
    rewrite /sigma -mulcrA -3!mulrA [in X in (_ < X)%CR]cst_crealM.
    apply: ltcr_mul2l; last exact/lt_creal_cst.
    have Dn_pos : 0 < (l n)%:Q.
      rewrite -[0]/(0%:Q) ltr_nat iter_lcmn_gt0; raise_big_enough.
    rewrite [in X in (_ < X)%CR]cst_crealM.
    apply: ltcr_pmul; first exact/lt_creal_cst/exprn_gt0.
    - apply/lt_creal_cst; apply: mulr_gt0; first exact: lt_0_Kdelta.
      apply: divr_gt0; last by apply: exprn_gt0; rewrite ltr0n.
      rewrite invr_gt0; exact: lt_0_Ka.
    - apply/lt_creal_cst; rewrite ltr_expn2r //; first exact: ltW.
      apply: hanson; raise_big_enough.
    - apply: lecr_lt_trans (NdeltaP _) _; first by raise_big_enough.
      apply/lt_creal_cst; rewrite ltr_pmul2l; last exact: lt_0_Kdelta.
      apply: a_asympt; raise_big_enough.
  apply: lt_creal_trans aux _; apply/lt_creal_cst; set lhs := (X in (X < _)).
  have -> : lhs = C * (K2 ^ 3 / 33%:Q) ^ n.
    (* what an ugly script... rat_field is bad with _ ^ n *)
    rewrite {}/lhs /C [in RHS]expfzMl exprzAC -[in RHS]expfV.
    set x := _ ^ n; set y := _ ^ n; field.
    by rewrite expfz_neq0 ?intr_eq0 // lt0r_neq0 ?lt_0_Ka.
  rewrite -ltr_pdivl_mull -[X in _ < X]mulrC; last by rewrite mulrC; exact: Cpos.
  apply: hN; raise_big_enough.
by close.
Qed.

End  SigmaGoesToZero.

Section AperyConstantIsIrrational.

(* Finally, the irrationality proof of zeta(3). We do not use the standard *)
(* irrationality criterium using the denominator scale, but rather a *)
(* simpler argument based on iter_lcmn_mul_rat that works in our case. *)
Theorem zeta_3_irrational : ~ exists (r : rat), (z3 == r%:CR)%CR.
Proof.
case=> z3_rat z3_ratP; case: (denqP z3_rat) z3_ratP => d dP z3_ratP.
have heps : 0 < 1 / 2%:Q by [].
have [M MP] := sigma_goes_to_0 heps.
pose sigma_Q (n : nat) := 2%:Q * (l n)%:Q ^ 3%N * (a n * z3_rat - b n).
have sigma_QP (n : nat) : ((sigma_Q n)%:CR == sigma n)%CR.
  by rewrite /sigma z3_ratP -!cst_crealM -cst_crealB -cst_crealM.
pose_big_enough n.
  have h_pos : 0 < sigma_Q n.
    apply/lt_creal_cst; rewrite sigma_QP; apply: lt_0_sigma; raise_big_enough.
  have h_lt1 : sigma_Q n < 1 / 2%:Q.
    apply/lt_creal_cst; rewrite sigma_QP; apply: MP; raise_big_enough.
  suff : 1 <= sigma_Q n by apply/negP; rewrite -ltNge; apply: lt_trans h_lt1 _.
  suff /QintP [z zP] : sigma_Q n \is a Qint.
    by move: h_pos; rewrite zP ler1z -gtz0_ge1 ltr0z; apply.
  rewrite /sigma_Q mulrDr mulrN; apply/rpredB/Qint_l3b.
  rewrite -mulrA; apply: rpredM (rpred_int _ _) _.
  rewrite /exprz exprSr mulrACA mulrC.
  apply/rpredM/rpredM/Qint_a/rpredX/rpred_int/iter_lcmn_mul_rat.
  rewrite normr_denq dP lez_nat; raise_big_enough.
by close.
Qed.

End AperyConstantIsIrrational.

About zeta_3_irrational.
 (* Time *) Print Assumptions zeta_3_irrational.


Require Import Setoid.
Require Import Morphisms.
Require Import Coq.Program.Basics.
Require Import NArith.
Require Import ClassicalFacts.

Unset Printing Records.

From Ordinal Require Import Defs.
From Ordinal Require Import Operators.
From Ordinal Require Import Classical.

(* We say a function f enumerates a class of ordinals P if
   f x is the least element of P that is strictly above
   all f y for y < x. *)
Record enumerates (f:Ord -> Ord) (P:Ord -> Prop) : Prop :=
  Enumerates
    { enumerates_included   : forall x, P (f x);
      enumerates_monotone   : forall x y, x ≤ y -> f x ≤ f y;
      enumerates_increasing : forall x y, x < y -> f x < f y;
      enumerates_least      : forall x z, P z -> (forall y, y < x -> f y < z) -> f x ≤ z
    }.

Lemma enumerates_range (EM:excluded_middle) f :
  (forall x y, x ≤ y -> f x ≤ f y) ->
  (forall x y, x < y -> f x < f y) ->
  enumerates f (fun x => exists y, x ≈ f y).
Proof.
  intros Hmono Hinc.
  constructor; auto.
  - intro x; exists x; reflexivity.
  - intros x z [y Hy] H.
    rewrite Hy.
    destruct (classical.order_total EM x y).
    + apply Hmono; auto.
    + apply H in H0.
      rewrite <- Hy in H0.
      elim (ord_lt_irreflexive z); auto.
Qed.

Lemma enumerates_equiv_pred f P P' :
  (forall x, P x <-> P' x) ->
  enumerates f P ->
  enumerates f P'.
Proof.
  intros Hp Hf.
  constructor.
  - intro x. apply Hp. apply enumerates_included; auto.
  - eapply enumerates_monotone; eauto.
  - eapply enumerates_increasing; eauto.
  - intros x z Hz1 Hz2.
    apply (enumerates_least f P Hf); auto.
    apply Hp; auto.
Qed.

Lemma enumerates_unique_aux f g P :
  enumerates f P ->
  enumerates g P ->
  (forall x, f x ≤ g x).
Proof.
  intros Hf Hg.
  induction x using ordinal_induction.
  apply (enumerates_least f P Hf x); auto.
  apply (enumerates_included g P Hg x).
  intros y Hy.
  apply ord_le_lt_trans with (g y).
  apply H; auto.
  apply (enumerates_increasing g P Hg y x); auto.
Qed.

Theorem enumerates_unique f g P :
  enumerates f P ->
  enumerates g P ->
  (forall x, f x ≈ g x).
Proof.
  intros; split; apply enumerates_unique_aux with P; auto.
Qed.

(* If f enumeates P then f 0 is the least element of P *)
Theorem enumerates_zero f P :
  enumerates f P ->
  (forall z, P z -> f 0 ≤ z).
Proof.
  intros Henum z Hz.
  apply (enumerates_least f P Henum 0); auto.
  intros.
  rewrite ord_lt_unfold in H.
  destruct H as [[] _].
Qed.

(* If f enumeates P then f (S x) is the least element of P strictly above (f x) *)
Theorem enumerates_succ f P :
  enumerates f P ->
  (forall x z, P z -> f x < z -> f (succOrd x) <= z).
Proof.
  intros Henum x z Hz Hx.
  apply (enumerates_least f P Henum (succOrd x)); auto.
  intros y Hy.
  apply ord_le_lt_trans with (f x); auto.
  apply (enumerates_monotone f P Henum y x); auto.
  rewrite ord_lt_unfold in Hy.
  destruct Hy as [[] Hy].
  auto.
Qed.

(* Classically, we can show that if f enumerates P then
   f is surjective on P.
 *)
Theorem enumerates_surjective (EM:excluded_middle) f P:
  enumerates f P -> forall x, P x -> exists a, f a ≈ x.
Proof.
  intros Henum x Hx.
  set (Q z := f z >= x).
  destruct (classical.ord_well_ordered EM Q x) as [a [??]]; auto.
  - hnf. apply increasing_inflationary.
    apply (enumerates_increasing f P Henum).
  - exists a. unfold Q in *.
    split; auto.
    apply (enumerates_least f P Henum a); auto.
    intros y Hy.
    destruct (classical.order_total EM x (f y)); auto.
    apply H0 in H1.
    elim (ord_lt_irreflexive y).
    apply ord_lt_le_trans with a; auto.
Qed.

(* Morover, classically a monotone, increasing, surjective function onto P enumerates P.
 *)
Theorem increasing_surjective_enumerates (EM:excluded_middle) f (P:Ord -> Prop) :
  (forall x y, x ≤ y -> f x ≤ f y) ->
  (forall x y, x < y -> f x < f y) ->
  (forall x, P x -> exists a, f a ≈ x) ->
  (forall x, P (f x)) ->
  enumerates f P.
Proof.
  intros Hmono Hinc Hsurj HP.
  constructor; auto.

  intros x z Hz1 Hz2.
  destruct (Hsurj z) as [a Ha]; auto.
  rewrite <- Ha.
  destruct (classical.order_total EM x a); auto.
  apply Hz2 in H.
  elim (ord_lt_irreflexive z).
  apply ord_le_lt_trans with (f a); auto.
  apply Ha.
Qed.

Definition unbounded (P:Ord -> Prop) :=
  forall x, P x -> exists y, x < y /\ P y.

Corollary enumerates_unbounded (EM:excluded_middle) f P :
  enumerates f P -> unbounded P.
Proof.
  intros Henum x Hx.
  destruct (enumerates_surjective EM f P Henum x Hx) as [a Ha].
  exists (f (succOrd a)).
  split.
  rewrite <- Ha.
  apply enumerates_increasing with P; auto.
  apply succ_lt.
  apply enumerates_included. auto.
Qed.


Section Declaration.
    Variable n: nat.
    Hypothesis Pos_n: (gt n 0).
    Check gt.
    Definition one:= (S O).
    Definition two : nat := S one.
    Definition three: nat:=S two.
    Definition double (m:nat):=plus m m.
Section Minimal_Logic.
    Variables A B C : Prop.
    Check (A->B).
    Goal ( A -> B -> C) -> ( A -> B ) -> A -> C.
    intro H.
    intros H' HA.
    apply H.
    exact HA.
    apply H'.
    assumption.


From Hammer Require Import Hammer.

Require Import PeanoNat.

Local Open Scope nat_scope.

Notation lt_irrefl := Nat.lt_irrefl.

Hint Resolve lt_irrefl: arith.

Theorem lt_le_S n m : n < m -> S n <= m.
Proof. hammer_hook "Lt" "Lt.lt_le_S".
apply Nat.le_succ_l.
Qed.

Theorem lt_n_Sm_le n m : n < S m -> n <= m.
Proof. hammer_hook "Lt" "Lt.lt_n_Sm_le".
apply Nat.lt_succ_r.
Qed.

Theorem le_lt_n_Sm n m : n <= m -> n < S m.
Proof. hammer_hook "Lt" "Lt.le_lt_n_Sm".
apply Nat.lt_succ_r.
Qed.

Hint Immediate lt_le_S: arith.
Hint Immediate lt_n_Sm_le: arith.
Hint Immediate le_lt_n_Sm: arith.

Theorem le_not_lt n m : n <= m -> ~ m < n.
Proof. hammer_hook "Lt" "Lt.le_not_lt".
apply Nat.le_ngt.
Qed.

Theorem lt_not_le n m : n < m -> ~ m <= n.
Proof. hammer_hook "Lt" "Lt.lt_not_le".
apply Nat.lt_nge.
Qed.

Hint Immediate le_not_lt lt_not_le: arith.

Notation lt_asym := Nat.lt_asymm.

Notation lt_0_Sn := Nat.lt_0_succ.
Notation lt_n_0 := Nat.nlt_0_r.

Theorem neq_0_lt n : 0 <> n -> 0 < n.
Proof. hammer_hook "Lt" "Lt.neq_0_lt".
intros. now apply Nat.neq_0_lt_0, Nat.neq_sym.
Qed.

Theorem lt_0_neq n : 0 < n -> 0 <> n.
Proof. hammer_hook "Lt" "Lt.lt_0_neq".
intros. now apply Nat.neq_sym, Nat.neq_0_lt_0.
Qed.

Hint Resolve lt_0_Sn lt_n_0 : arith.
Hint Immediate neq_0_lt lt_0_neq: arith.

Notation lt_n_Sn := Nat.lt_succ_diag_r.
Notation lt_S := Nat.lt_lt_succ_r.

Theorem lt_n_S n m : n < m -> S n < S m.
Proof. hammer_hook "Lt" "Lt.lt_n_S".
apply Nat.succ_lt_mono.
Qed.

Theorem lt_S_n n m : S n < S m -> n < m.
Proof. hammer_hook "Lt" "Lt.lt_S_n".
apply Nat.succ_lt_mono.
Qed.

Hint Resolve lt_n_Sn lt_S lt_n_S : arith.
Hint Immediate lt_S_n : arith.

Lemma S_pred n m : m < n -> n = S (pred n).
Proof. hammer_hook "Lt" "Lt.S_pred".
intros. symmetry. now apply Nat.lt_succ_pred with m.
Qed.

Lemma lt_pred n m : S n < m -> n < pred m.
Proof. hammer_hook "Lt" "Lt.lt_pred".
apply Nat.lt_succ_lt_pred.
Qed.

Lemma lt_pred_n_n n : 0 < n -> pred n < n.
Proof. hammer_hook "Lt" "Lt.lt_pred_n_n".
intros. now apply Nat.lt_pred_l, Nat.neq_0_lt_0.
Qed.

Hint Immediate lt_pred: arith.
Hint Resolve lt_pred_n_n: arith.

Notation lt_trans := Nat.lt_trans.
Notation lt_le_trans := Nat.lt_le_trans.
Notation le_lt_trans := Nat.le_lt_trans.

Hint Resolve lt_trans lt_le_trans le_lt_trans: arith.

Notation le_lt_or_eq_iff := Nat.lt_eq_cases.

Theorem le_lt_or_eq n m : n <= m -> n < m \/ n = m.
Proof. hammer_hook "Lt" "Lt.le_lt_or_eq".
apply Nat.lt_eq_cases.
Qed.

Notation lt_le_weak := Nat.lt_le_incl.

Hint Immediate lt_le_weak: arith.

Notation le_or_lt := Nat.le_gt_cases.

Theorem nat_total_order n m : n <> m -> n < m \/ m < n.
Proof. hammer_hook "Lt" "Lt.nat_total_order".
apply Nat.lt_gt_cases.
Qed.

Notation lt_O_Sn := lt_0_Sn (only parsing).
Notation neq_O_lt := neq_0_lt (only parsing).
Notation lt_O_neq := lt_0_neq (only parsing).
Notation lt_n_O := lt_n_0 (only parsing).

Require Import Le.


Section Minimal_propositional_logic.
 Variables P Q R T : Prop.

 Theorem imp_trans : (P->Q)->(Q->R)->P->R.
 Proof.
  intros H H' p.
  apply H'.
  apply H.
  assumption.
 Qed.

 Theorem imp_trans' : (P->Q)->(Q->R)->P->R.
 Proof.
  intros H H' p; apply H'; apply H; assumption.
 Qed.

 Theorem imp_trans'' : (P->Q)->(Q->R)->P->R.
 Proof.
  auto.
 Qed.

 Theorem delta : (P->P->Q)->P->Q.
 Proof (fun (H:P->P->Q)(p:P) => H p p).

 Lemma apply_example : (Q->R->T)->(P->Q)->P->R->T.
 Proof.
  intros H H0 p.
  apply H.
  exact (H0 p).
 Qed.

 Theorem imp_dist : (P->Q->R)->(P->Q)->(P->R).
 Proof.
  intros H H' p.
  apply H.
  - assumption.
  - apply H'; assumption.
 Qed.

 Theorem K : P->Q->P.
 Proof.
  intros p q;  assumption.
 Qed.

 Section proof_of_triple_impl.
  Hypothesis H : ((P->Q)->Q)-> Q.
  Hypothesis p : P.

  Remark  R1 : (P->Q)->Q.
  Proof fun H0:P->Q => H0 p.

  Theorem triple_impl : Q.
  Proof H R1.

 End proof_of_triple_impl.

 Theorem triple_impl_one_liner : (((P->Q)->Q)->Q)->P->Q.
 Proof.
  intros H p; apply H; intro H0; apply H0; assumption.
 Qed.

 Lemma imp_dist' : (P->Q->R)->(P->Q)->(P->R).
 Proof.
  intros H H' p.
  apply H;[assumption | apply H'; assumption].
 Qed.

 Section section_assert_example.
  Hypotheses (H : P->Q)
             (H0 : Q->R)
             (H1 : (P->R)->T->Q)
             (H2 : (P->R)->T).

  Lemma assert_example : Q.
  Proof.
   assert (H3 : P -> R).
   -  intro p; apply H0; apply H; assumption.
   -  apply H1;[assumption | apply H2; assumption].
  Qed.

 Print assert_example.

 End section_assert_example.

 Lemma triple_impl2 : (((P->Q)->Q)->Q)->P->Q.
 Proof.
  auto.
 Qed.

End Minimal_propositional_logic.

Print imp_dist.

Section using_imp_dist.
 Variables (P1 P2 P3 : Prop).

 Check imp_dist P1 P2 P3.

 Check imp_dist (P1->P2) (P2->P3) (P3->P1).

End using_imp_dist.


Require Import Nat Arith.

Inductive Nat : Type := succ : Nat -> Nat |  zero : Nat.

Inductive Lst : Type := nil : Lst | cons : Nat -> Lst -> Lst.

Inductive Tree : Type := leaf : Tree | node : Nat -> Tree -> Tree -> Tree.

Inductive Pair : Type := mkpair : Nat -> Nat -> Pair
with ZLst : Type := zcons : Pair -> ZLst -> ZLst |  znil : ZLst.

Fixpoint append (append_arg0 : Lst) (append_arg1 : Lst) : Lst
           := match append_arg0, append_arg1 with
              | nil, x => x
              | cons x y, z => cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : Lst) : Lst
           := match rev_arg0 with
              | nil => nil
              | cons x y => append (rev y) (cons x nil)
              end.

Fixpoint qreva (qreva_arg0 : Lst) (qreva_arg1 : Lst) : Lst
           := match qreva_arg0, qreva_arg1 with
              | nil, x => x
              | cons z x, y => qreva x (cons z y)
              end.

Fixpoint revflat (revflat_arg0 : Tree) : Lst
           := match revflat_arg0 with
              | leaf => nil
              | node d l r => append (revflat l) (cons d (revflat r))
              end.

Fixpoint qrevaflat (qrevaflat_arg0 : Tree) (qrevaflat_arg1 : Lst) : Lst
           := match qrevaflat_arg0, qrevaflat_arg1 with
              | leaf, x => x
              | node d l r, x => qrevaflat l (cons d (qrevaflat r x))
              end.

Lemma append_assoc : forall (x y z : Lst), append (append x y) z = append x (append y z).
Proof.
  intros.
  induction x.
  - reflexivity.
  - simpl. rewrite IHx. reflexivity.
Qed.

Theorem theorem0 : forall (x : Tree) (y : Lst), eq (append (revflat x) y) (qrevaflat x y).
Proof.
  induction x.
  - reflexivity.
  - intros. simpl. rewrite append_assoc. simpl. rewrite IHx2. rewrite IHx1. reflexivity.
Qed.


Require Import Bool.

Notation "[ a ] < [ b ]" := (forall (F : a -> b), exists (y : b), forall (x : a), F x <> y).
Notation "[ a ] > [ b ]" := ([b] < [a]).
Notation "[ a ] = [ b ]" := (~([a] < [b]) /\ ~([a] > [b])).

Definition lemma1 : forall (A : Type)(B : Type)(F : A -> B)(G : A -> B), F = G -> forall (x : A), F x = G x
 := fun A B F G H x => f_equal (fun a : A -> B => a x) H.

Definition prop1 : forall (A : Type), [A] < [A -> bool] :=
  fun (A : Type) (F : A -> A -> bool) =>
    let AbP  := fun y => forall (x : A), F x <> y in
    let diag := fun x => negb (F x x) in
    ex_intro AbP diag (fun x H =>
      no_fixpoint_negb (F x x)
      (eq_sym (f_equal (fun a => a x) H))
    ).

Definition prop2 : forall (A : Type), [A] = [A] :=
  fun A =>
    let id : A -> A := (fun a => a) in
    let P : ~([A] < [A]) := (fun x =>
      match x id with
        | ex_intro _ y H => (H y) (eq_refl y)
      end
    ) in
    conj P P.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (x : natural) (lf1 : natural) : natural :=
  mult lf1 (Succ Zero).


(* Reformulation of single Diophantine equations, i.e. p = q for Diophantine polynomials, without parameters. *)

Inductive dio_op_pfree := do_add_pfree | do_mul_pfree.

(* Syntax without a constructor for parameters, variables fixed to range over nat *)

Inductive dio_polynomial_pfree : Set :=
| dp_nat_pfree : nat -> dio_polynomial_pfree (* natural number constant *)
| dp_var_pfree : nat -> dio_polynomial_pfree (* existentially quantified variable *)
| dp_comp_pfree : dio_op_pfree -> dio_polynomial_pfree -> dio_polynomial_pfree -> dio_polynomial_pfree.

Fixpoint dp_eval_pfree φ p :=
  match p with
  | dp_nat_pfree n => n
  | dp_var_pfree v => φ v
  | dp_comp_pfree do_add_pfree p q => dp_eval_pfree φ p + dp_eval_pfree φ q
  | dp_comp_pfree do_mul_pfree p q => dp_eval_pfree φ p * dp_eval_pfree φ q
  end.

Definition H10p_PROBLEM := (dio_polynomial_pfree * dio_polynomial_pfree)%type.
Definition H10p_sem e φ := dp_eval_pfree φ (fst e) = dp_eval_pfree φ (snd e).
Definition H10p (e : H10p_PROBLEM) := exists φ, H10p_sem e φ.


From Coq Require Import List.
From Coq Require Import Psatz.
From Coq Require Import ZArith.
From Coq Require Import Znumtheory.
Import ListNotations.

Local Open Scope Z.

Fixpoint egcd_aux
        (n : nat)
        (r0 a0 b0 r1 a1 b1 : Z) {struct n} : Z * Z :=
  match n with
  | 0%nat => (0, 0)
  | S n => let (q, r) := Z.div_eucl r0 r1 in
           if r =? 0 then
             (a1, b1)
           else
             egcd_aux n r1 a1 b1 r (a0 - q*a1) (b0 - q*b1)
  end.

(* returns (x, y) such that x*m + y*n = Z.gcd(x, y) *)
Definition egcd (m n : Z) : Z * Z :=
  if m =? 0 then
    (0, Z.sgn n)
  else if n =? 0 then
    (Z.sgn m, 0)
  else
    let num_steps := S (Z.to_nat (Z.log2 (Z.abs m) + Z.log2 (Z.abs n))) in
    if Z.abs m <? Z.abs n then
      let (x, y) := egcd_aux num_steps (Z.abs n) 1 0 (Z.abs m) 0 1 in
      (Z.sgn m * y, Z.sgn n * x)
    else
      let (x, y) := egcd_aux num_steps (Z.abs m) 1 0 (Z.abs n) 0 1 in
      (Z.sgn m * x, Z.sgn n * y).

Lemma egcd_aux_spec m n steps r0 a0 b0 r1 a1 b1 :
  Z.log2 r0 + Z.log2 r1 < Z.of_nat steps ->
  0 < r1 ->
  r1 <= r0 ->
  r0 = a0*m + b0*n ->
  r1 = a1*m + b1*n ->
  Z.gcd r0 r1 = Z.gcd m n ->
  let (x, y) := egcd_aux steps r0 a0 b0 r1 a1 b1 in
  x*m + y*n = Z.gcd m n.
Proof.
  revert r0 a0 b0 r1 a1 b1.
  induction steps as [|steps IH];
    intros r0 a0 b0 r1 a1 b1 enough_steps r1pos r1gt r0eq r1eq is_gcd.
  {
    cbn -[Z.add] in enough_steps.
    pose proof (Z.log2_nonneg r0).
    pose proof (Z.log2_nonneg r1).
    lia.
  }
  cbn.
  pose proof (Z_div_mod r0 r1 ltac:(lia)).
  destruct (Z.div_eucl r0 r1) as [q r].
  destruct (Z.eqb_spec r 0) as [->|?].
  - destruct H.
    rewrite Z.add_0_r in *.
    rewrite <- r1eq.
    rewrite <- is_gcd.
    rewrite H.
    rewrite Z.gcd_comm.
    now rewrite Z.gcd_mul_diag_l by lia.
  - apply IH; auto.
    + destruct H.
      destruct q; try lia; cycle 1.
      {
        pose proof (Z.mul_pos_neg r1 (Z.neg p) ltac:(lia) ltac:(lia)).
        lia.
      }
      assert (r + r1 <= r0).
      {
        enough (r1 <= r1 * Z.pos p) by lia.
        apply Z.le_mul_diag_r; lia.
      }
      assert (Z.log2 r1 + Z.log2 r < Z.log2 r0 + Z.log2 r1).
      {
        enough (Z.log2 r < Z.log2 r0) by lia.
        pose proof (Z.log2_le_mono (r*2^1) r0 ltac:(lia)).
        rewrite <- Z.shiftl_mul_pow2 in H2 by lia.
        rewrite Z.log2_shiftl in H2 by lia.
        lia.
      }
      lia.
    + lia.
    + lia.
    + rewrite !Z.mul_sub_distr_r.
      replace (a0 * m - q * a1 * m + (b0 * n - q * b1 * n))
        with (a0 * m + b0*n + (-1) * (q*(a1*m + b1*n)))
        by lia.
      rewrite <- r0eq, <-r1eq.
      lia.
    + rewrite <- is_gcd.
      rewrite (proj1 H).
      rewrite (Z.gcd_comm (r1 * q + r)).
      rewrite Z.add_comm, Z.mul_comm.
      now rewrite Z.gcd_add_mult_diag_r.
Qed.

Lemma egcd_spec m n :
  let (x, y) := egcd m n in
  m*x + n*y = Z.gcd m n.
Proof.
  unfold egcd.
  destruct (Z.eqb_spec m 0) as [->|?].
  { apply Z.sgn_abs. }
  destruct (Z.eqb_spec n 0) as [->|?].
  { rewrite Z.gcd_0_r, Z.add_0_r; apply Z.sgn_abs. }
  pose proof (Z.log2_nonneg (Z.abs m)).
  pose proof (Z.log2_nonneg (Z.abs n)).
  destruct (Z.ltb_spec (Z.abs m) (Z.abs n)).
  - unshelve epose proof (egcd_aux_spec
                            (Z.abs n) (Z.abs m)
                            (S (Z.to_nat (Z.log2 (Z.abs m) + Z.log2 (Z.abs n))))
                            (Z.abs n) 1 0
                            (Z.abs m) 0 1
                            _ _ _ _ _ _).
    + rewrite Nat2Z.inj_succ.
      rewrite Z2Nat.id by lia.
      lia.
    + lia.
    + lia.
    + lia.
    + lia.
    + lia.
    + destruct (egcd_aux _ _ _ _ _ _ _).
      rewrite !Z.mul_assoc.
      rewrite Z.gcd_abs_l, Z.gcd_comm, Z.gcd_abs_l in H2.
      rewrite !Z.sgn_abs.
      lia.
  - unshelve epose proof (egcd_aux_spec
                            (Z.abs m) (Z.abs n)
                            (S (Z.to_nat (Z.log2 (Z.abs m) + Z.log2 (Z.abs n))))
                            (Z.abs m) 1 0
                            (Z.abs n) 0 1
                            _ _ _ _ _ _).
    + rewrite Nat2Z.inj_succ.
      rewrite Z2Nat.id by lia.
      lia.
    + lia.
    + lia.
    + lia.
    + lia.
    + lia.
    + destruct (egcd_aux _ _ _ _ _ _ _).
      rewrite !Z.mul_assoc.
      rewrite Z.gcd_abs_l, Z.gcd_comm, Z.gcd_abs_l, Z.gcd_comm in H2.
      rewrite !Z.sgn_abs.
      lia.
Qed.

Lemma mul_fst_egcd a n :
  rel_prime a n ->
  a * fst (egcd a n) mod n = 1 mod n.
Proof.
  destruct (Z.eqb_spec n 0) as [->|?].
  { intros; now rewrite !Zmod_0_r. }
  intros relprime.
  pose proof (egcd_spec a n).
  destruct (egcd a n) as [x y]; cbn.
  rewrite (proj2 (Zgcd_1_rel_prime _ _) relprime) in H.
  replace (a * x) with (1  + (-y)*n) by lia.
  rewrite <- Z.add_mod_idemp_r by lia.
  now rewrite Z.mod_mul, Z.add_0_r by lia.
Qed.

Lemma egcd_divides a b :
  b <> 0 ->
  (b | a) ->
  egcd a b = (0, Z.sgn b).
Proof.
  intros b0 divides.
  unfold egcd.
  destruct (Z.eqb_spec a 0) as [->|a0]; [easy|].
  rewrite (proj2 (Z.eqb_neq _ _) b0).
  assert (Z.abs b <= Z.abs a) by (apply Zdivide_bounds; auto).
  replace (Z.abs a <? Z.abs b) with false; cycle 1.
  { now symmetry; apply Z.ltb_ge. }
  cbn.
  pose proof (Z_div_mod_full (Z.abs a) (Z.abs b) ltac:(lia)).
  destruct (Z.div_eucl (Z.abs a) (Z.abs b)) as [q r].
  rewrite (Zmod_unique_full _ _ _ _ (proj2 H0) (proj1 H0)).
  apply Z.divide_abs_l, Z.divide_abs_r in divides.
  rewrite (Zdivide_mod _ _ divides).
  cbn.
  now rewrite Z.mul_0_r, Z.mul_1_r.
Qed.


(* TCfM から圏論の定義の部分を抜き出す。 *)
(* "Type Classes for Mathematics in Type Theory" *)

(* Global Generalizable All Variables. *)

(* Set Implicit Arguments. *)

Require Import Arith.
Require Import Omega.
Require Import Relations.                   (* relation など *)
Require Import Morphisms.                   (* Proper *)

Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.ProofIrrelevance.

Section Category_Class.
  Generalizable Variables O x y.

  Class Arrows (O : Type) : Type := arrow : O -> O -> Type.
  Class Equiv A := equiv : relation A.

  Notation "A == B" := (equiv A B) (at level 55, right associativity).
  Notation "A --> B" := (arrow A B) (at level 55, right associativity).

  Class CatId O `{Arrows O} := cat_id : `(x --> x).
  Class CatComp O `{Arrows O} :=
    comp : forall {x y z}, (y --> z) -> (x --> y) -> (x --> z).

  Notation "A \o B" := (comp A B) (at level 40, left associativity).

  Class Setoid A {Ae : Equiv A} : Prop :=
    setoid_eq :> Equivalence (@equiv A Ae).
  (* これは、Operational Class である。
     Prop. Class にした場合は、unfold Setoid を split に変える。 *)

  Section setoid_morphisms.
  Context {A B} {Ae : Equiv A} {Be : Equiv B} (f : A -> B).
    Class Setoid_Morphism :=
      {
        setoidmor_a : Setoid A;
        setoidmor_b : Setoid B;
        sm_proper :> Proper (equiv ==> equiv) f
      }.
  End setoid_morphisms.

  Class Category (O : Type)
        `{!Arrows O}
        `{forall x y : O, Equiv (x --> y)}
        `{!CatId O}
        `{!CatComp O} : Prop :=
    {
      (* Setid である。 *)
      arrow_equiv :> forall x y, Setoid (x --> y);
      (* comp で繋いだ項をequivでの書換の対象にできる。 *)
      comp_proper :> forall x y z, Proper (equiv ==> equiv ==> equiv) (@comp _ _ _ x y z);
      (* comp の結合性が成立する。 *)
      comp_assoc w x y z (a : w --> x) (b : x --> y) (c : y --> z) :
        c \o (b \o a) = (c \o b) \o a;
      (* comp の単位元が存在する。 *)
      id_l `(a : x --> y) : cat_id _ \o a = a;
      id_r `(a : x --> y) : a \o cat_id _ = a;
    }.
End Category_Class.

Notation "A == B" := (equiv A B) (at level 55, right associativity).
Notation "A --> B" := (arrow A B) (at level 55, right associativity).
Notation "A \o B" := (comp A B) (at level 40, left associativity).

(* *********** *)
(* シングルトン *)
(* *********** *)
(*
対象の集合 : unit
対象（唯一） : tt
射の集合（唯一） : tt --> tt (= nat と定める)
射の例     : 0,1,2.....
射の合成   : natの加算
恒等射     : 0
 *)

Definition O0 : Type := unit.
Instance A0 : Arrows O0 := fun (x y : O0) => nat.
Instance E0 (x y : O0) : Equiv (A0 x y) := fun (m n : nat) => m = n. (* 射の等しさ *)
Instance I0 : CatId O0 := fun (_ : O0) => 0.
Instance C0 : CatComp O0 := fun (_ _ _ : O0) (m n : nat) => m + n.

Check Category O0 : Prop.
Check @Category O0 A0 E0 I0 C0 : Prop.
Program Instance SPLUS : @Category O0 A0 E0 I0 C0.
Obligation 1.                               (* Setoid (x --> y) *)
Proof.
  unfold Setoid.                            (* Equivalence equiv *)
  unfold equiv.                             (* Equivalence (E0 x y) *)
  unfold E0.                                (* Equivalence (fun m n : nat => m = n) *)
  split.
  + now unfold Reflexive.
  + now unfold Symmetric.
  + unfold Transitive.
    intros x' y' z' H1 H2.
    now rewrite H1, H2.
Qed.
Obligation 2.                               (* c \o (b \o a) = c \o b \o a *)
Proof.
  unfold comp, C0.
  (* c + (b + a) = c + b + a *)
  now apply plus_assoc.
Qed.

(* 例 *)
Check @arrow O0 A0 tt tt.                   (* 射の型 *)
Check tt --> tt.                            (* 上記の構文糖 *)
Check 1 : tt --> tt.                        (* 1 は射の例 *)
Check 0 : tt --> tt.                        (* 0 は射の例 *)

(* 射 2 と 3 の合成は 5 になる。 *)
Check comp 3 2 : tt --> tt.
Compute comp 3 2.                           (* 5 *)
Check @comp O0 A0 C0 tt tt tt 3 2 : tt --> tt.
Compute @comp O0 A0 C0 tt tt tt 3 2.        (* 5 *)

Check cat_id tt : tt --> tt.
Compute cat_id tt.                          (* 0 *)
Check @cat_id O0 A0 I0 tt : tt --> tt.
Compute @cat_id O0 A0 I0 tt.                (* 0 *)

(* ******** *)
(* 集合の圏 *)
(* ******** *)
(*
対象の集合 : Set
対象の例   : nat など
射の集合の例 : nat -> nat  など
射の例     : plus 0 (= id_nat), plus 1, plus 2,.... (関数)
射の合成   : 関数の合成
恒等射     : id_nat など

注意：対象は自然数の集合natである。0,1,2,..は対象ではない。
 *)

Definition O1 : Type := Set.
Instance A1 : Arrows O1 := fun (x y : O1) => x -> y.
Instance E1 (x y : O1) : Equiv (A1 x y) := (* x -> y *)
  fun (f g : A1 x y) => forall (a : x), f a = g a.
(*
Instance E1 (x y : O1) : Equiv (A1 x y) := (* x -> y *)
  fun (f g : A1 x y) => f = g.
*)
Instance I1 : CatId O1 := fun (a : O1) (x : a) => x.
Instance C1 : CatComp O1 :=
  fun (x y z : O1) (f : A1 y z) (g : A1 x y) (a : x) => f (g a).

Check Category O1 : Prop.
Check @Category O1 A1 E1 I1 C1 : Prop.
Program Instance SETS : @Category O1 A1 E1 I1 C1.
Obligation 1.
Proof.                                      (* Setoid (x --> y) *)
  unfold Setoid, equiv, E1.
  split.
  + now unfold Reflexive.
  + now unfold Symmetric.
  + unfold Transitive.
    intros x' y' z' H1 H2 a.
    rewrite H1.
    rewrite <- H2.
    easy.
Qed.
Obligation 2.            (* Proper (equiv ==> equiv ==> equiv) comp *)
Proof.
  unfold equiv, E1, comp, C1.
  intros yz yz' H1 xy xy' H2 a.
  rewrite <- H2.
  rewrite <- H1.
  (* yz (xy a) = yz (xy a) *)
  easy.
Qed.

(* 例 *)
Check @arrow O1 A1 nat nat.                 (* 射の型のひとつ *)
Check nat --> nat.                          (* 上記の構文糖 *)
Check plus 1 : nat --> nat.                 (* plus 1 は射の例 *)
Check plus 0 : nat --> nat.                 (* plus 0 は射の例 *)

(* 射 plus 2 と plus 3 の合成は plus 5 になる。 *)
Check comp (plus 3) (plus 2) : nat --> nat.
Compute comp (plus 3) (plus 2).             (* plus 5 *)
Check @comp O1 A1 C1 nat nat nat (plus 3) (plus 2) : nat --> nat.
Goal plus 5 = @comp O1 A1 C1 nat nat nat (plus 3) (plus 2).
Proof.
  unfold comp, C1.
  easy.
Qed.
Compute @comp O1 A1 C1 nat nat nat (plus 3) (plus 2). (* plus 5 *)

Check cat_id nat : nat --> nat.
Compute cat_id nat.                        (* id *)
Check @cat_id O1 A1 I1 nat : nat --> nat.  (* cat_id は射のひとつ *)
Goal id = @cat_id O1 A1 I1 nat.            (* cat_id は id に等しい *)
Proof.
  unfold cat_id, I1.
  easy.
Qed.
Compute @cat_id O1 A1 I1 nat.               (* id *)

(* ************* *)
(* 半順序集合の圏 *)
(* ************* *)
(*
対象の集合 : nat
対象の例   : 0,1,2,....
射の集合の例 : 0 --> 0, 0 --> 1,...
射の例     : 0≦0, 0≦1,.. (対象が決まると唯一決まる)
射の合成   : 不等号の遷移性
恒等射     : 0≦0, 1≦1,..
 *)

Definition O2 : Type := nat.
Instance A2 : Arrows O2 := fun (x y : O2) => x <= y.
Instance E2 (x y : O2) : Equiv (A2 x y) := (* x <= y *)
  fun (H1 H2 : A2 x y) => H1 = H2.
Instance I2 : CatId O2 := le_n.
Instance C2 : CatComp O2 :=
  fun (x y z : O2) H1 H2 => le_trans x y z H2 H1.

Check @Category O2 A2 E2 I2 C2 : Prop.
Program Instance LE : @Category O2 A2 E2 I2 C2.
Obligation 1.                               (* Setoid (x --> y) *)
  unfold Setoid, equiv, E2.
  split.
  + now unfold Reflexive.
  + now unfold Symmetric.
  + unfold Transitive.
    intros x' y' z' H1 H2.
    now rewrite H1, H2.
Qed.
Obligation 2.                               (* c \o (b \o a) = c \o b \o a *)
Proof.
  unfold comp, C2.
  unfold arrow, A2 in *.
  (* Nat.le_trans w y z (Nat.le_trans w x y a b) c =
     Nat.le_trans w x z a (Nat.le_trans x y z b c) *)

  (* 普段ゴールには、定理（型）が出現するはずなのに、
     証明（値）であるle_transが出てきてしまった！ *)

  (* (w <= x -> x <= y) -> y <= z -> w <= z *)
  Check Nat.le_trans w y z (Nat.le_trans w x y a b) c : w <= z.
  (* w <= x -> (x <= y -> y <= z) -> w <= z *)
  Check Nat.le_trans w x z a (Nat.le_trans x y z b c) : w <= z.

  (* 公理：型が同じ値は同じ。
     …こんなことはありえない。irrelevence は 見当違い、無関係 の意味。
     しかし、証明する定理（型）が同じなら、証明（値）は同じ。
     …といえば納得できる。つまり、定理に対する証明の一意性を公理として導入する。 *)
  Check proof_irrelevance : forall (P : Prop) (p1 p2 : P), p1 = p2.
  now apply proof_irrelevance.
Qed.
Obligation 3.
  unfold comp, C2.                          (* cat_id y \o a = a *)
  unfold arrow, A2 in *.
  (* Nat.le_trans x y y a (cat_id y) = a *)
  (* x <= y -> y <= y -> x <= y *)
  Check Nat.le_trans x y y a (cat_id y).
  now apply proof_irrelevance.
Qed.
Obligation 4.
  unfold comp, C2.                          (* a \o cat_id x = a *)
  unfold arrow, A2 in *.
  (* Nat.le_trans x x y (cat_id x) a = a *)
  (* x <= x -> x <= y -> x <= y *)
  now apply proof_irrelevance.
Qed.

(* 例 *)
Check @arrow O2 A2 3 3.                     (* 射の型のひとつ *)
Check 3 --> 3.                              (* 上記の構文糖 *)
Check 3 --> 4.                              (* 射の型のひとつ *)
Check 4 --> 5.                              (* 射の型のひとつ *)
Check 3 --> 5.                              (* 射の型のひとつ *)

Definition le33 : 3 <= 3. Proof. easy. Defined.
Definition le34 : 3 <= 4. Proof. omega. Defined.
Definition le45 : 4 <= 5. Proof. omega. Defined.
Definition le35 : 3 <= 5. Proof. omega. Defined.

Check le33 : 3 --> 3.                       (* この型の射は唯一 *)
Check le34 : 3 --> 4.                       (* この型の射は唯一 *)
Check le45 : 4 --> 5.                       (* この型の射は唯一 *)
Check le35 : 3 --> 5.                       (* この型の射は唯一 *)

(* 3≦4 と 4≦5 を 合成すると 3≦5 になる。 *)
Check comp le45 le34 : 3 --> 5.
Compute comp le45 le34.
Check @comp O2 A2 C2 3 4 5 le45 le34 : 3 --> 5.
Compute @comp O2 A2 C2 3 4 5 le45 le34.
Goal le35 = @comp O2 A2 C2 3 4 5 le45 le34.
Proof.
  unfold comp, C2.
  apply proof_irrelevance.
Qed.

Check cat_id 3  : 3 --> 3.           (* cat_id は射のひとつ *)
Compute cat_id 3.                    (* le_n 3 *)
Check @cat_id O2 A2 I2 3  : 3 --> 3. (* cat_id は射のひとつ *)
Compute @cat_id O2 A2 I2 3.                 (* le_n 3 *)
Goal le_n 3 = @cat_id O2 A2 I2 3.    (* cat_id 3 は 3≦3 に等しい。 *)
Proof.
  unfold cat_id, I2.
  easy.
Qed.

(* *********** *)
(* しりとりの圏 *)
(* *********** *)
(*
対象の集合 : ひらがな
対象の例   : こ,ぶ,た,ぬ,き,い,や,...
射の集合の例 : た --> き
射の例     : たぬき, たいやき
射の合成   : しりとりをした文字列の連結
恒等射     : こ,た,... (1文字語)
 *)

Inductive O3 : Type := こ | ぶ | た | ぬ | き | つ | ね | い | や.
Inductive A3 : Arrows O3 :=
  | single : forall A, A3 A A
  | cons : forall {A' B : O3} (A : O3) (tl : A3 A' B), A3 A B.

Check cons こ (cons ぶ (single た)) : A3 こ た.
Goal cons こ (cons ぶ (single た)) = cons こ (cons ぶ (single た)).
Proof. reflexivity. Qed.                    (* 普通に = が成り立つ。 *)

Instance E3 (x y : O3) : Equiv (A3 x y) :=
  fun (s t : A3 x y) => s = t.
Definition I3 : CatId O3 := single.
Definition C3 (x y z : O3) (t : A3 y z) (s : A3 x y) : A3 x z.
Proof.
  induction s.
  + easy.
  + now apply (cons A (IHs t)).
Defined.
Check C3 : CatComp O3.

Check @Category O3 A3 E3 I3 C3 : Prop.
Program Instance SIRI : @Category O3 A3 E3 I3 C3.
Obligation 1.                               (* Setoid (x --> y) *)
  unfold Setoid, equiv, E3.
  split.
  + now unfold Reflexive.
  + now unfold Symmetric.
  + unfold Transitive.
    intros x' y' z' H1 H2.
    now rewrite H1, H2.
Qed.
Obligation 2.                               (* c \o (b \o a) = c \o b \o a *)
Proof.
  unfold comp, C3.
  induction a; simpl.
  - easy.
  - now rewrite IHa.
Qed.
Obligation 3.                               (* cat_id y \o a = a *)
Proof.
  unfold comp, C3, cat_id, I3.
  induction a; simpl.
  - easy.
  - now rewrite IHa.
Qed.

(* 例 *)
Check @arrow O3 A3 ね こ.                   (* 射の型のひとつ *)
Check ね --> こ.                            (* 上記の構文糖衣 *)
Check こ --> こ.                            (* 射の型のひとつ *)
Check た --> き.                            (* 射の型のひとつ *)
Check き --> ね.                            (* 射の型のひとつ *)
Check た --> ね.                            (* 射の型のひとつ *)

Definition neko := cons ね (single こ).
Definition ko := single こ.
Definition koneko := cons こ (cons ね (single こ)).
Definition tanuki := cons た (cons ぬ (single き)).
Definition taiyaki := cons た (cons い (cons や (single き))).
Definition kitune := cons き (cons つ (single ね)).
Definition tanukitune := cons た (cons ぬ (cons き (cons つ (single ね)))).

Check neko    : ね --> こ.                  (* この型の射の例 *)
Check ko      : こ --> こ.                  (* この型の射の例 *)
Check koneko  : こ --> こ.                  (* この型の射の例、別の例 *)
Check tanuki  : た --> き.                  (* この型の射の例 *)
Check taiyaki : た --> き.                  (* この型の射の例、別の例 *)
Check kitune  : き --> ね.                  (* この型の射の例 *)
Check tanukitune : た --> ね.               (* この型の射の例 *)

(* たぬき と きつね を 合成すると たぬきつね になる。 *)

Check comp kitune tanuki : た --> ね.
(* Compute comp kitune tanuki. *)
Check @comp O3 A3 C3 た き ね kitune tanuki : た --> ね.
Goal tanukitune = @comp O3 A3 C3 た き ね kitune tanuki.
Compute @comp O3 A3 C3 た き ね kitune tanuki.
Proof.
  unfold comp, C3.
  easy.
Qed.

Check cat_id こ : こ --> こ.
(* Compute cat_id こ. *)
Check @cat_id O3 A3 I3 こ : こ --> こ.      (* cat_id は射のひとつ *)
Goal ko = @cat_id O3 A3 I3 こ. (* cat_id こ は single こ に等しい。 *)
Compute @cat_id O3 A3 I3 こ.                 (* single こ *)
Proof.
  unfold cat_id, I3.
  easy.
Qed.

(* こねこ は cat_id ではないことに注意してください。 *)
Compute @comp O3 A3 C3 ね こ こ ko neko.     (* ねこ と こ の連結は ねこ *)
Compute @comp O3 A3 C3 ね こ こ koneko neko. (* ねこ と こねこ の連結は ねこねこ *)

(* 始対象 *)
Section initiality.
  Generalizable Variables X.
  Context `{Category X}.

  Class InitialArrow (x : X) : Type := initial_arrow: forall y, x --> y.

  Class Initial (x : X) `{InitialArrow x}: Prop :=
    initial_arrow_unique : forall y f', initial_arrow y = f'.
End initiality.

Program Definition IA0 (x : O0) : @InitialArrow O0 A0 x := fun (y : O0) => _.
Obligation 1.
Admitted.

Program Instance ISNGL : @Initial O0 A0 tt (IA0 tt).
Obligation 1.
Proof.
  unfold initial_arrow, IA0.
  Admitted.

(* 関手 *)

Section functor_class.
  Generalizable Variables C D x y z a.

  Context `{Category C} `{Category D} (M : C -> D).

  Class Fmap : Type := fmap : forall {v w : C}, (v --> w) -> (M v --> M w).

  Class Functor `(Fmap) : Prop :=
    {
      functor_from : Category C;
      functor_to : Category D;
      functor_morphism :> forall a b : C, Setoid_Morphism (@fmap _ a b);
      preserves_id : `(fmap (cat_id _ : a --> a) = cat_id _);
      preserves_comp `(f : y --> z) `(g : x --> y) : fmap (f \o g) = fmap f \o fmap g
    }.
End functor_class.

Definition M01 (a : unit) : O1 := nat.

Check @Fmap.
Check @Fmap O0 A0 O1 A1 M01 : Type.
Check Fmap M01 : Type.

Definition f01 (x y : O0) (n : nat) := fun (x : nat) => x + n.
Definition F01 : @Fmap O0 A0 O1 A1 M01 := f01.

Check @Functor O0 A0 E0 I0 C0 O1 A1 E1 I1 C1 M01 F01.
Check Functor M01 F01.
Program Instance FUN01 : Functor M01 F01.
Obligation 1.
Proof.
  split.
  - split.                                  (* Setoid (a --> b) *)
    + unfold Reflexive.
      now unfold equiv, E0.
    + unfold Symmetric.
      now unfold equiv, E0.
    + unfold Transitive.
      unfold equiv, E0.
      intros.
      now subst.
  - split.                                  (* Setoid (M a --> M b) *)
    + unfold Reflexive.
      now unfold equiv, E1.
    + unfold Symmetric.
      now unfold equiv, E1.
    + unfold Transitive.
      unfold equiv, E1.
      intros.
      erewrite H.
      erewrite <- H0.
      easy.
  - intro x.                                (* Proper (equiv ==> equiv) (fmap M01) *)
    intros y H.
    unfold equiv, E0 in H.
    rewrite H.
    easy.
Qed.

Check Fmap M01.
Check F01.
Check @fmap O0 A0 O1 A1 M01 F01 tt tt : tt --> tt -> nat --> nat.
Check @fmap O0 A0 O1 A1 M01 F01 tt tt   1         :  nat --> nat.

Goal @fmap O0 A0 O1 A1 M01 F01 tt tt   1 = fun x => x + 1.
Proof.
  unfold fmap, M01, F01, f01.
  easy.
Qed.

Goal forall n : nat, @fmap O0 A0 O1 A1 M01 F01 tt tt   n = fun x => x + n.
Proof.
  unfold fmap, M01, F01, f01.
  easy.
Qed.

(* END *)


(* begin hide *)
(**********************************************************************)
(* Equations                                                          *)
(* Copyright (c) 2009-2021 Matthieu Sozeau <matthieu.sozeau@inria.fr> *)
(**********************************************************************)
(* This file is distributed under the terms of the                    *)
(* GNU Lesser General Public License Version 2.1                      *)
(**********************************************************************)

From Equations Require Import Equations.
From Coq Require Import List Program.Syntax Arith Lia.
Require Import List.
Import ListNotations.
(* end hide *)
(** * Well-founded recursion

  Equations provide support for well-founded recursion, potentially nested and mutual.

  Here we show a standard example of the [nubBy] function from Haskell's prelude,
  which is naturally expressed using well-founded recursion on the length of the list.
  To show this, we however use the argument that [filter f l] always returns a sublist of [l].
 *)

Equations filter_length {A} (l : list A) (f : A -> bool) : length (filter f l) <= length l :=
 filter_length [] f := le_n 0;
 filter_length (x :: xs) f with f x :=
                         { | true => le_n_S _ _ (filter_length xs f);
                           | false => le_S _ _ (filter_length xs f) }.

Section nubBy.
  Context {A} (eq : A -> A -> bool).

  (** The proof that this function is well-founded uses simply the lemma [filter_length] and
      standard arithmetic reasoning. *)
  Equations? nubBy (l : list A) : list A by wf (length l) lt :=
  nubBy []        => [];
  nubBy (x :: xs) => x :: nubBy (filter (fun y => negb (eq x y)) xs).
  Proof. simpl. auto using filter_length with arith. Defined.
End nubBy.

(** Using functional elimination, we can show standard properties of [nubBy], without having
    to repeat the well-founded induction principle *)

Lemma nubBy_length {A} (eq : A -> A -> bool) (l : list A) : length (nubBy eq l) <= length l.
Proof.
  funelim (nubBy eq l); simpl; trivial.
  rewrite filter_length in H. auto with arith.
Qed.

Lemma In_filter {A} (f : A -> bool) (l : list A) a : In a (filter f l) -> In a l /\ f a = true.
Proof.
  induction l; simpl. intros [].
  destruct (f a0) eqn:Heq.
  simpl. intuition auto. now subst a0.
  intuition auto.
Qed.

Lemma In_nubBy {A} (eq : A -> A -> bool) (l : list A) (a : A) :
  In a (nubBy eq l) -> In a l.
Proof.
  funelim (nubBy eq l).
  + trivial.
  + intros H0.
    destruct H0 as [->|H0]; auto. simpl. auto.
    specialize (H _ H0). apply In_filter in H as [Inal eqa]. right; auto.
Qed.

(** This allows to show that [nubBy] returns a list without duplicates in a few
    lines of proof. *)
Lemma nuBy_nodup {A} (eq : A -> A -> bool) (l : list A) :
  (forall x y, (eq x y = true) <-> (x = y)) -> NoDup (nubBy eq l).
Proof.
  funelim (nubBy eq l). constructor. intros Heq; specialize (H Heq).
  constructor. intros Hi. apply In_nubBy, In_filter in Hi as [_ eqaa].
  specialize (Heq x x). destruct (eq x x). discriminate.
  destruct (proj2 Heq). reflexivity. discriminate.
  auto.
Qed.

Equations ack (m n : nat) : nat by wf (m, n) (Equations.Prop.Subterm.lexprod _ _ lt lt) :=
  ack 0 0         := 1;
  ack 0 (S n)     := S (S n);
  ack (S m) 0     := ack m 1;
  ack (S m) (S n) := ack m (ack (S m) n).


Require Import Coq.Strings.String.

Inductive id : Type :=
| Id      : string -> id.

Definition beq_id id1 id2 :=
  match id1,id2 with
  | Id n1, Id n2 => if string_dec n1 n2 then true else false
  end.

Theorem beq_id_true_iff :
  forall x y : id,
  beq_id x y = true <-> x = y.
Proof.
  intros. split.
  -intros. unfold beq_id in *. destruct x. destruct y.
   destruct (string_dec s s0). +subst. auto. +inversion H.
  -intros. unfold beq_id. destruct x. destruct y.
   destruct (string_dec s s0). +auto. +inversion H. subst.
   destruct n. auto.
Qed.

Theorem false_beq_id :
  forall x y : id,
  x <> y <-> beq_id x y = false.
Proof.
  intros. split; unfold beq_id in *.
  -intros. destruct x. destruct y. destruct (string_dec s s0).
   +subst. destruct H. auto. +auto.
  -intros. destruct x. destruct y. destruct (string_dec s s0).
   +inversion H. +clear H. unfold not in *. intros. inversion H.
    contradiction.
Qed.


(************************)
(************************)
(****                ****)
(****   Categories   ****)
(****                ****)
(************************)
(************************)

Require Import Coq.Logic.ProofIrrelevance.
Require Import Main.Tactics.

#[local] Set Universe Polymorphism.

(* Metavariables for categories: `C`, `D`, `E` *)

Record category := newCategory {
  object : Type; (* Objects: `w`, `x`, `y`, `z` *)
  arrow : object -> object -> Type; (* Arrows: `f`, `g`, `h` *)
  compose {x y z} : arrow y z -> arrow x y -> arrow x z;
  id {x}: arrow x x;

  cAssoc {w x y z} (f : arrow w x) (g : arrow x y) (h : arrow y z) :
    compose h (compose g f) = compose (compose h g) f;
  cIdentLeft {x y} (f : arrow x y) : compose id f = f;
  cIdentRight {x y} (f : arrow x y) : compose f id = f;
}.

Arguments arrow {_}.
Arguments compose {_} {_} {_} {_}.
Arguments id {_} {_}.
Arguments cAssoc {_} {_} {_} {_} {_}.
Arguments cIdentLeft {_} {_} {_}.
Arguments cIdentRight {_} {_} {_}.

#[export] Hint Resolve cAssoc : main.
#[export] Hint Resolve cIdentLeft : main.
#[export] Hint Rewrite @cIdentLeft : main.
#[export] Hint Resolve cIdentRight : main.
#[export] Hint Rewrite @cIdentRight : main.

#[local] Theorem opCAssoc
  {C}
  (w x y z : object C)
  (f : arrow x w)
  (g : arrow y x)
  (h : arrow z y)
: compose (compose f g) h = compose f (compose g h).
Proof.
  search.
Qed.

#[local] Theorem opCIdentLeft {C} (x y : object C) (f : arrow y x) :
  compose f id = f.
Proof.
  search.
Qed.

#[local] Theorem opCIdentRight {C} (x y : object C) (f : arrow y x) :
  compose id f = f.
Proof.
  search.
Qed.

Definition oppositeCategory C : category := newCategory
  (object C)
  (fun x y => arrow y x)
  (fun _ _ _ f g => compose g f)
  (fun _ => id)
  opCAssoc
  opCIdentLeft
  opCIdentRight.

Theorem oppositeInvolution C : oppositeCategory (oppositeCategory C) = C.
Proof.
  unfold oppositeCategory.
  destruct C.
  f_equal; apply proof_irrelevance.
Qed.

#[export] Hint Resolve oppositeInvolution : main.


(* -*- mode: coq -*- *)
(* Time-stamp: <2014/8/22 1:34:0> *)
(*
  order.v
  - mathink : Author
 *)

(* SSReflect libraries *)
Require Import
  Ssreflect.ssreflect
  Ssreflect.ssrbool
  Ssreflect.ssrfun
  Ssreflect.eqtype.

(* Implicity *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Structure totalOrder (T: Type) :=
  Build_totalOrder
    { total_ord:> rel T;

    ord_antisymmetric: antisymmetric total_ord;
    ord_transitive: transitive total_ord;
    ord_total: total total_ord }.
Notation makeTotalOrder ord := (@Build_totalOrder _ ord _ _ _).
Lemma ord_reflexive T (ord: totalOrder T): reflexive ord.
Proof.
  move=> x.
  move: (ord_total ord x x) => /orP [] //.
Qed.

Hint Resolve ord_antisymmetric ord_transitive ord_total ord_reflexive.

Definition strict_ord  {T: eqType}(ord: totalOrder T): rel T :=
  fun x y => (ord x y) && (x != y).

Notation "ord !" := (strict_ord ord) (at level 5, left associativity).

Section Strict.

  Context {T: eqType}(ord: totalOrder T).

  Lemma sord_transitive: transitive ord!.
  Proof.
    move=> y x z /andP [Hlexy Hneqxy] /andP [Hleyz Hneqyz].
    apply/andP; split.
    - by apply ord_transitive with y.
    - apply/eqP=> Heqxz; move: Hneqxy => /eqP; apply.
        by rewrite -Heqxz in Hleyz;
        apply: ord_antisymmetric => //; apply/andP; split.
  Qed.
  Hint Resolve sord_transitive.

  Lemma sord_irrefl x:
    ~~ (ord! x x).
  Proof.
      by rewrite negb_and ord_reflexive eq_refl //=.
  Qed.

  Lemma ord_neg_sord x y:
    ~~ (ord x y) = (ord! y x).
  Proof.
    move: (ord_total ord x y) => /orP [] Hle; apply/eqP.
    - rewrite Hle /=.
      case Hle':  (ord y x); rewrite /strict_ord Hle' //=.
      have: x = y; first by apply: ord_antisymmetric=>//; apply/andP.
        by move=> ->; rewrite eq_refl.
    - rewrite /strict_ord Hle /=.
      case Hle':  (ord x y) => //=.
      + have: x = y; first by apply: ord_antisymmetric=>//; apply/andP.
          by move=> ->; rewrite eq_refl.
      + case: (x =P y) => [Heq | Hneq].
        * by rewrite Heq eq_refl /= -Hle' Heq ord_reflexive.
        * by rewrite [y==x]eq_sym; move: Hneq => /eqP ->.
  Qed.

  Lemma sord_neg_ord x y:
    ~~ (ord! x y) = (ord y x).
  Proof.
      by apply/eqP; rewrite eqb_negLR ord_neg_sord.
  Qed.

End Strict.