(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2011-2018 Sylvie Boldo
#<br />#
Copyright (C) 2011-2018 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

From Coq Require Import ZArith Zquot.

Require Import Zaux.
Require Import SpecFloatCompat.

Notation digits2_pos := digits2_pos (only parsing).
Notation Zdigits2 := Zdigits2 (only parsing).

(** Number of bits (radix 2) of a positive integer.

It serves as an upper bound on the number of digits to ensure termination.
*)

Fixpoint digits2_Pnat (n : positive) : nat :=
  match n with
  | xH => O
  | xO p => S (digits2_Pnat p)
  | xI p => S (digits2_Pnat p)
  end.

Theorem digits2_Pnat_correct :
  forall n,
  let d := digits2_Pnat n in
  (Zpower_nat 2 d <= Zpos n < Zpower_nat 2 (S d))%Z.
Proof.
intros n d. unfold d. clear.
assert (Hp: forall m, (Zpower_nat 2 (S m) = 2 * Zpower_nat 2 m)%Z) by easy.
induction n ; simpl digits2_Pnat.
rewrite Zpos_xI, 2!Hp.
omega.
rewrite (Zpos_xO n), 2!Hp.
omega.
now split.
Qed.

Section Fcore_digits.

Variable beta : radix.

Definition Zdigit n k := Z.rem (Z.quot n (Zpower beta k)) beta.

Theorem Zdigit_lt :
  forall n k,
  (k < 0)%Z ->
  Zdigit n k = Z0.
Proof.
intros n [|k|k] Hk ; try easy.
now case n.
Qed.

Theorem Zdigit_0 :
  forall k, Zdigit 0 k = Z0.
Proof.
intros k.
unfold Zdigit.
rewrite Zquot_0_l.
apply Zrem_0_l.
Qed.

Theorem Zdigit_opp :
  forall n k,
  Zdigit (-n) k = Z.opp (Zdigit n k).
Proof.
intros n k.
unfold Zdigit.
rewrite Zquot_opp_l.
apply Zrem_opp_l.
Qed.

Theorem Zdigit_ge_Zpower_pos :
  forall e n,
  (0 <= n < Zpower beta e)%Z ->
  forall k, (e <= k)%Z -> Zdigit n k = Z0.
Proof.
intros e n Hn k Hk.
unfold Zdigit.
rewrite Z.quot_small.
apply Zrem_0_l.
split.
apply Hn.
apply Z.lt_le_trans with (1 := proj2 Hn).
replace k with (e + (k - e))%Z by ring.
rewrite Zpower_plus.
rewrite <- (Zmult_1_r (beta ^ e)) at 1.
apply Zmult_le_compat_l.
apply (Zlt_le_succ 0).
apply Zpower_gt_0.
now apply Zle_minus_le_0.
apply Zlt_le_weak.
now apply Z.le_lt_trans with n.
generalize (Z.le_lt_trans _ _ _ (proj1 Hn) (proj2 Hn)).
clear.
now destruct e as [|e|e].
now apply Zle_minus_le_0.
Qed.

Theorem Zdigit_ge_Zpower :
  forall e n,
  (Z.abs n < Zpower beta e)%Z ->
  forall k, (e <= k)%Z -> Zdigit n k = Z0.
Proof.
intros e [|n|n] Hn k.
easy.
apply Zdigit_ge_Zpower_pos.
now split.
intros He.
change (Zneg n) with (Z.opp (Zpos n)).
rewrite Zdigit_opp.
rewrite Zdigit_ge_Zpower_pos with (2 := He).
apply Z.opp_0.
now split.
Qed.

Theorem Zdigit_not_0_pos :
  forall e n, (0 <= e)%Z ->
  (Zpower beta e <= n < Zpower beta (e + 1))%Z ->
  Zdigit n e <> Z0.
Proof.
intros e n He (Hn1,Hn2).
unfold Zdigit.
rewrite <- ZOdiv_mod_mult.
rewrite Z.rem_small.
intros H.
apply Zle_not_lt with (1 := Hn1).
rewrite (Z.quot_rem' n (beta ^ e)).
rewrite H, Zmult_0_r, Zplus_0_l.
apply Zrem_lt_pos_pos.
apply Z.le_trans with (2 := Hn1).
apply Zpower_ge_0.
now apply Zpower_gt_0.
split.
apply Z.le_trans with (2 := Hn1).
apply Zpower_ge_0.
replace (beta ^ e * beta)%Z with (beta ^ (e + 1))%Z.
exact Hn2.
rewrite <- (Zmult_1_r beta) at 3.
now apply (Zpower_plus beta e 1).
Qed.

Theorem Zdigit_not_0 :
  forall e n, (0 <= e)%Z ->
  (Zpower beta e <= Z.abs n < Zpower beta (e + 1))%Z ->
  Zdigit n e <> Z0.
Proof.
intros e n He Hn.
destruct (Zle_or_lt 0 n) as [Hn'|Hn'].
rewrite (Z.abs_eq _ Hn') in Hn.
now apply Zdigit_not_0_pos.
intros H.
rewrite (Zabs_non_eq n) in Hn by now apply Zlt_le_weak.
apply (Zdigit_not_0_pos _ _ He Hn).
now rewrite Zdigit_opp, H.
Qed.

Theorem Zdigit_mul_pow :
  forall n k k', (0 <= k')%Z ->
  Zdigit (n * Zpower beta k') k = Zdigit n (k - k').
Proof.
intros n k k' Hk'.
destruct (Zle_or_lt k' k) as [H|H].
revert k H.
pattern k' ; apply Zlt_0_ind with (2 := Hk').
clear k' Hk'.
intros k' IHk' Hk' k H.
unfold Zdigit.
apply (f_equal (fun x => Z.rem x beta)).
pattern k at 1 ; replace k with (k - k' + k')%Z by ring.
rewrite Zpower_plus with (2 := Hk').
apply Zquot_mult_cancel_r.
apply Zgt_not_eq.
now apply Zpower_gt_0.
now apply Zle_minus_le_0.
destruct (Zle_or_lt 0 k) as [H0|H0].
rewrite (Zdigit_lt n) by omega.
unfold Zdigit.
replace k' with (k' - k + k)%Z by ring.
rewrite Zpower_plus with (2 := H0).
rewrite Zmult_assoc, Z_quot_mult.
replace (k' - k)%Z with (k' - k - 1 + 1)%Z by ring.
rewrite Zpower_exp by omega.
rewrite Zmult_assoc.
change (Zpower beta 1) with (beta * 1)%Z.
rewrite Zmult_1_r.
apply Z_rem_mult.
apply Zgt_not_eq.
now apply Zpower_gt_0.
apply Zle_minus_le_0.
now apply Zlt_le_weak.
rewrite Zdigit_lt with (1 := H0).
apply sym_eq.
apply Zdigit_lt.
omega.
Qed.

Theorem Zdigit_div_pow :
  forall n k k', (0 <= k)%Z -> (0 <= k')%Z ->
  Zdigit (Z.quot n (Zpower beta k')) k = Zdigit n (k + k').
Proof.
intros n k k' Hk Hk'.
unfold Zdigit.
rewrite Zquot_Zquot.
rewrite Zplus_comm.
now rewrite Zpower_plus.
Qed.

Theorem Zdigit_mod_pow :
  forall n k k', (k < k')%Z ->
  Zdigit (Z.rem n (Zpower beta k')) k = Zdigit n k.
Proof.
intros n k k' Hk.
destruct (Zle_or_lt 0 k) as [H|H].
unfold Zdigit.
rewrite <- 2!ZOdiv_mod_mult.
apply (f_equal (fun x => Z.quot x (beta ^ k))).
replace k' with (k + 1 + (k' - (k + 1)))%Z by ring.
rewrite Zpower_exp by omega.
rewrite Zmult_comm.
rewrite Zpower_plus by easy.
change (Zpower beta 1) with (beta * 1)%Z.
rewrite Zmult_1_r.
apply ZOmod_mod_mult.
now rewrite 2!Zdigit_lt.
Qed.

Theorem Zdigit_mod_pow_out :
  forall n k k', (0 <= k' <= k)%Z ->
  Zdigit (Z.rem n (Zpower beta k')) k = Z0.
Proof.
intros n k k' Hk.
unfold Zdigit.
rewrite ZOdiv_small_abs.
apply Zrem_0_l.
apply Z.lt_le_trans with (Zpower beta k').
rewrite <- (Z.abs_eq (beta ^ k')) at 2 by apply Zpower_ge_0.
apply Zrem_lt.
apply Zgt_not_eq.
now apply Zpower_gt_0.
now apply Zpower_le.
Qed.

Fixpoint Zsum_digit f k :=
  match k with
  | O => Z0
  | S k => (Zsum_digit f k + f (Z_of_nat k) * Zpower beta (Z_of_nat k))%Z
  end.

Theorem Zsum_digit_digit :
  forall n k,
  Zsum_digit (Zdigit n) k = Z.rem n (Zpower beta (Z_of_nat k)).
Proof.
intros n.
induction k.
apply sym_eq.
apply Z.rem_1_r.
simpl Zsum_digit.
rewrite IHk.
unfold Zdigit.
rewrite <- ZOdiv_mod_mult.
rewrite <- (ZOmod_mod_mult n beta).
rewrite Zmult_comm.
replace (beta ^ Z_of_nat k * beta)%Z with (Zpower beta (Z_of_nat (S k))).
rewrite Zplus_comm, Zmult_comm.
apply sym_eq.
apply Z.quot_rem'.
rewrite inj_S.
rewrite <- (Zmult_1_r beta) at 3.
apply Zpower_plus.
apply Zle_0_nat.
easy.
Qed.

Theorem Zdigit_ext :
  forall n1 n2,
  (forall k, (0 <= k)%Z -> Zdigit n1 k = Zdigit n2 k) ->
  n1 = n2.
Proof.
intros n1 n2 H.
rewrite <- (ZOmod_small_abs n1 (Zpower beta (Z.max (Z.abs n1) (Z.abs n2)))).
rewrite <- (ZOmod_small_abs n2 (Zpower beta (Z.max (Z.abs n1) (Z.abs n2)))) at 2.
replace (Z.max (Z.abs n1) (Z.abs n2)) with (Z_of_nat (Z.abs_nat (Z.max (Z.abs n1) (Z.abs n2)))).
rewrite <- 2!Zsum_digit_digit.
induction (Z.abs_nat (Z.max (Z.abs n1) (Z.abs n2))).
easy.
simpl.
rewrite H, IHn.
apply refl_equal.
apply Zle_0_nat.
rewrite inj_Zabs_nat.
apply Z.abs_eq.
apply Z.le_trans with (Z.abs n1).
apply Zabs_pos.
apply Z.le_max_l.
apply Z.lt_le_trans with (Zpower beta (Z.abs n2)).
apply Zpower_gt_id.
apply Zpower_le.
apply Z.le_max_r.
apply Z.lt_le_trans with (Zpower beta (Z.abs n1)).
apply Zpower_gt_id.
apply Zpower_le.
apply Z.le_max_l.
Qed.

Theorem ZOmod_plus_pow_digit :
  forall u v n, (0 <= u * v)%Z ->
  (forall k, (0 <= k < n)%Z -> Zdigit u k = Z0 \/ Zdigit v k = Z0) ->
  Z.rem (u + v) (Zpower beta n) = (Z.rem u (Zpower beta n) + Z.rem v (Zpower beta n))%Z.
Proof.
intros u v n Huv Hd.
destruct (Zle_or_lt 0 n) as [Hn|Hn].
rewrite Zplus_rem with (1 := Huv).
apply ZOmod_small_abs.
generalize (Z.le_refl n).
pattern n at -2 ; rewrite <- Z.abs_eq with (1 := Hn).
rewrite <- (inj_Zabs_nat n).
induction (Z.abs_nat n) as [|p IHp].
now rewrite 2!Z.rem_1_r.
rewrite <- 2!Zsum_digit_digit.
simpl Zsum_digit.
rewrite inj_S.
intros Hn'.
replace (Zsum_digit (Zdigit u) p + Zdigit u (Z_of_nat p) * beta ^ Z_of_nat p +
  (Zsum_digit (Zdigit v) p + Zdigit v (Z_of_nat p) * beta ^ Z_of_nat p))%Z with
  (Zsum_digit (Zdigit u) p + Zsum_digit (Zdigit v) p +
  (Zdigit u (Z_of_nat p) + Zdigit v (Z_of_nat p)) * beta ^ Z_of_nat p)%Z by ring.
apply (Z.le_lt_trans _ _ _ (Z.abs_triangle _ _)).
replace (beta ^ Z.succ (Z_of_nat p))%Z with (beta ^ Z_of_nat p + (beta - 1) * beta ^ Z_of_nat p)%Z.
apply Zplus_lt_le_compat.
rewrite 2!Zsum_digit_digit.
apply IHp.
now apply Zle_succ_le.
rewrite Zabs_Zmult.
rewrite (Z.abs_eq (beta ^ Z_of_nat p)) by apply Zpower_ge_0.
apply Zmult_le_compat_r. 2: apply Zpower_ge_0.
apply Zlt_succ_le.
assert (forall u v, Z.abs (Zdigit u v) < Z.succ (beta -  1))%Z.
clear ; intros n k.
assert (0 < beta)%Z.
apply Z.lt_le_trans with 2%Z.
apply refl_equal.
apply Zle_bool_imp_le.
apply beta.
replace (Z.succ (beta - 1)) with (Z.abs beta).
apply Zrem_lt.
now apply Zgt_not_eq.
rewrite Z.abs_eq.
apply Zsucc_pred.
now apply Zlt_le_weak.
assert (0 <= Z_of_nat p < n)%Z.
split.
apply Zle_0_nat.
apply Z.gt_lt.
now apply Zle_succ_gt.
destruct (Hd (Z_of_nat p) H0) as [K|K] ; rewrite K.
apply H.
rewrite Zplus_0_r.
apply H.
unfold Z.succ.
ring_simplify.
rewrite Zpower_plus.
change (beta ^1)%Z with (beta * 1)%Z.
now rewrite Zmult_1_r.
apply Zle_0_nat.
easy.
destruct n as [|n|n] ; try easy.
now rewrite 3!Zrem_0_r.
Qed.

Theorem ZOdiv_plus_pow_digit :
  forall u v n, (0 <= u * v)%Z ->
  (forall k, (0 <= k < n)%Z -> Zdigit u k = Z0 \/ Zdigit v k = Z0) ->
  Z.quot (u + v) (Zpower beta n) = (Z.quot u (Zpower beta n) + Z.quot v (Zpower beta n))%Z.
Proof.
intros u v n Huv Hd.
rewrite <- (Zplus_0_r (Z.quot u (Zpower beta n) + Z.quot v (Zpower beta n))).
rewrite ZOdiv_plus with (1 := Huv).
rewrite <- ZOmod_plus_pow_digit by assumption.
apply f_equal.
destruct (Zle_or_lt 0 n) as [Hn|Hn].
apply ZOdiv_small_abs.
rewrite <- Z.abs_eq.
apply Zrem_lt.
apply Zgt_not_eq.
now apply Zpower_gt_0.
apply Zpower_ge_0.
clear -Hn.
destruct n as [|n|n] ; try easy.
apply Zquot_0_r.
Qed.

Theorem Zdigit_plus :
  forall u v, (0 <= u * v)%Z ->
  (forall k, (0 <= k)%Z -> Zdigit u k = Z0 \/ Zdigit v k = Z0) ->
  forall k,
  Zdigit (u + v) k = (Zdigit u k + Zdigit v k)%Z.
Proof.
intros u v Huv Hd k.
destruct (Zle_or_lt 0 k) as [Hk|Hk].
unfold Zdigit.
rewrite ZOdiv_plus_pow_digit with (1 := Huv).
rewrite <- (Zmult_1_r beta) at 3 5 7.
change (beta * 1)%Z with (beta ^1)%Z.
apply ZOmod_plus_pow_digit.
apply Zsame_sign_trans_weak with v.
intros Zv ; rewrite Zv.
apply Zquot_0_l.
rewrite Zmult_comm.
apply Zsame_sign_trans_weak with u.
intros Zu ; rewrite Zu.
apply Zquot_0_l.
now rewrite Zmult_comm.
apply Zsame_sign_odiv.
apply Zpower_ge_0.
apply Zsame_sign_odiv.
apply Zpower_ge_0.
intros k' (Hk1,Hk2).
rewrite 2!Zdigit_div_pow by assumption.
apply Hd.
now apply Zplus_le_0_compat.
intros k' (Hk1,Hk2).
now apply Hd.
now rewrite 3!Zdigit_lt.
Qed.

(** Left and right shifts *)

Definition Zscale n k :=
  if Zle_bool 0 k then (n * Zpower beta k)%Z else Z.quot n (Zpower beta (-k)).

Theorem Zdigit_scale :
  forall n k k', (0 <= k')%Z ->
  Zdigit (Zscale n k) k' = Zdigit n (k' - k).
Proof.
intros n k k' Hk'.
unfold Zscale.
case Zle_bool_spec ; intros Hk.
now apply Zdigit_mul_pow.
apply Zdigit_div_pow with (1 := Hk').
omega.
Qed.

Theorem Zscale_0 :
  forall k,
  Zscale 0 k = Z0.
Proof.
intros k.
unfold Zscale.
case Zle_bool.
apply Zmult_0_l.
apply Zquot_0_l.
Qed.

Theorem Zsame_sign_scale :
  forall n k,
  (0 <= n * Zscale n k)%Z.
Proof.
intros n k.
unfold Zscale.
case Zle_bool_spec ; intros Hk.
rewrite Zmult_assoc.
apply Zmult_le_0_compat.
apply Zsame_sign_imp ; apply Zlt_le_weak.
apply Zpower_ge_0.
apply Zsame_sign_odiv.
apply Zpower_ge_0.
Qed.

Theorem Zscale_mul_pow :
  forall n k k', (0 <= k)%Z ->
  Zscale (n * Zpower beta k) k' = Zscale n (k + k').
Proof.
intros n k k' Hk.
unfold Zscale.
case Zle_bool_spec ; intros Hk'.
rewrite Zle_bool_true.
rewrite <- Zmult_assoc.
apply f_equal.
now rewrite Zpower_plus.
now apply Zplus_le_0_compat.
case Zle_bool_spec ; intros Hk''.
pattern k at 1 ; replace k with (k + k' + -k')%Z by ring.
assert (0 <= -k')%Z by omega.
rewrite Zpower_plus by easy.
rewrite Zmult_assoc, Z_quot_mult.
apply refl_equal.
apply Zgt_not_eq.
now apply Zpower_gt_0.
replace (-k')%Z with (-(k+k') + k)%Z by ring.
rewrite Zpower_plus with (2 := Hk).
apply Zquot_mult_cancel_r.
apply Zgt_not_eq.
now apply Zpower_gt_0.
omega.
Qed.

Theorem Zscale_scale :
  forall n k k', (0 <= k)%Z ->
  Zscale (Zscale n k) k' = Zscale n (k + k').
Proof.
intros n k k' Hk.
unfold Zscale at 2.
rewrite Zle_bool_true with (1 := Hk).
now apply Zscale_mul_pow.
Qed.

(** Slice of an integer *)

Definition Zslice n k1 k2 :=
  if Zle_bool 0 k2 then Z.rem (Zscale n (-k1)) (Zpower beta k2) else Z0.

Theorem Zdigit_slice :
  forall n k1 k2 k, (0 <= k < k2)%Z ->
  Zdigit (Zslice n k1 k2) k = Zdigit n (k1 + k).
Proof.
intros n k1 k2 k Hk.
unfold Zslice.
rewrite Zle_bool_true.
rewrite Zdigit_mod_pow by apply Hk.
rewrite Zdigit_scale by apply Hk.
unfold Zminus.
now rewrite Z.opp_involutive, Zplus_comm.
omega.
Qed.

Theorem Zdigit_slice_out :
  forall n k1 k2 k, (k2 <= k)%Z ->
  Zdigit (Zslice n k1 k2) k = Z0.
Proof.
intros n k1 k2 k Hk.
unfold Zslice.
case Zle_bool_spec ; intros Hk2.
apply Zdigit_mod_pow_out.
now split.
apply Zdigit_0.
Qed.

Theorem Zslice_0 :
  forall k k',
  Zslice 0 k k' = Z0.
Proof.
intros k k'.
unfold Zslice.
case Zle_bool.
rewrite Zscale_0.
apply Zrem_0_l.
apply refl_equal.
Qed.

Theorem Zsame_sign_slice :
  forall n k k',
  (0 <= n * Zslice n k k')%Z.
Proof.
intros n k k'.
unfold Zslice.
case Zle_bool.
apply Zsame_sign_trans_weak with (Zscale n (-k)).
intros H ; rewrite H.
apply Zrem_0_l.
apply Zsame_sign_scale.
rewrite Zmult_comm.
apply Zrem_sgn2.
now rewrite Zmult_0_r.
Qed.

Theorem Zslice_slice :
  forall n k1 k2 k1' k2', (0 <= k1' <= k2)%Z ->
  Zslice (Zslice n k1 k2) k1' k2' = Zslice n (k1 + k1') (Z.min (k2 - k1') k2').
Proof.
intros n k1 k2 k1' k2' Hk1'.
destruct (Zle_or_lt 0 k2') as [Hk2'|Hk2'].
apply Zdigit_ext.
intros k Hk.
destruct (Zle_or_lt (Z.min (k2 - k1') k2') k) as [Hk'|Hk'].
rewrite (Zdigit_slice_out n (k1 + k1')) with (1 := Hk').
destruct (Zle_or_lt k2' k) as [Hk''|Hk''].
now apply Zdigit_slice_out.
rewrite Zdigit_slice by now split.
apply Zdigit_slice_out.
zify ; omega.
rewrite Zdigit_slice by (zify ; omega).
rewrite (Zdigit_slice n (k1 + k1')) by now split.
rewrite Zdigit_slice.
now rewrite Zplus_assoc.
zify ; omega.
unfold Zslice.
rewrite Z.min_r.
now rewrite Zle_bool_false.
omega.
Qed.

Theorem Zslice_mul_pow :
  forall n k k1 k2, (0 <= k)%Z ->
  Zslice (n * Zpower beta k) k1 k2 = Zslice n (k1 - k) k2.
Proof.
intros n k k1 k2 Hk.
unfold Zslice.
case Zle_bool_spec ; intros Hk2.
2: apply refl_equal.
rewrite Zscale_mul_pow with (1 := Hk).
now replace (- (k1 - k))%Z with (k + -k1)%Z by ring.
Qed.

Theorem Zslice_div_pow :
  forall n k k1 k2, (0 <= k)%Z -> (0 <= k1)%Z ->
  Zslice (Z.quot n (Zpower beta k)) k1 k2 = Zslice n (k1 + k) k2.
Proof.
intros n k k1 k2 Hk Hk1.
unfold Zslice.
case Zle_bool_spec ; intros Hk2.
2: apply refl_equal.
apply (f_equal (fun x => Z.rem x (beta ^ k2))).
unfold Zscale.
case Zle_bool_spec ; intros Hk1'.
replace k1 with Z0 by omega.
case Zle_bool_spec ; intros Hk'.
replace k with Z0 by omega.
simpl.
now rewrite Z.quot_1_r.
rewrite Z.opp_involutive.
apply Zmult_1_r.
rewrite Zle_bool_false by omega.
rewrite 2!Z.opp_involutive, Zplus_comm.
rewrite Zpower_plus by assumption.
apply Zquot_Zquot.
Qed.

Theorem Zslice_scale :
  forall n k k1 k2, (0 <= k1)%Z ->
  Zslice (Zscale n k) k1 k2 = Zslice n (k1 - k) k2.
Proof.
intros n k k1 k2 Hk1.
unfold Zscale.
case Zle_bool_spec; intros Hk.
now apply Zslice_mul_pow.
apply Zslice_div_pow with (2 := Hk1).
omega.
Qed.

Theorem Zslice_div_pow_scale :
  forall n k k1 k2, (0 <= k)%Z ->
  Zslice (Z.quot n (Zpower beta k)) k1 k2 = Zscale (Zslice n k (k1 + k2)) (-k1).
Proof.
intros n k k1 k2 Hk.
apply Zdigit_ext.
intros k' Hk'.
rewrite Zdigit_scale with (1 := Hk').
unfold Zminus.
rewrite (Zplus_comm k'), Z.opp_involutive.
destruct (Zle_or_lt k2 k') as [Hk2|Hk2].
rewrite Zdigit_slice_out with (1 := Hk2).
apply sym_eq.
apply Zdigit_slice_out.
now apply Zplus_le_compat_l.
rewrite Zdigit_slice by now split.
destruct (Zle_or_lt 0 (k1 + k')) as [Hk1'|Hk1'].
rewrite Zdigit_slice by omega.
rewrite Zdigit_div_pow by assumption.
apply f_equal.
ring.
now rewrite 2!Zdigit_lt.
Qed.

Theorem Zplus_slice :
  forall n k l1 l2, (0 <= l1)%Z -> (0 <= l2)%Z ->
  (Zslice n k l1 + Zscale (Zslice n (k + l1) l2) l1)%Z = Zslice n k (l1 + l2).
Proof.
intros n k1 l1 l2 Hl1 Hl2.
clear Hl1.
apply Zdigit_ext.
intros k Hk.
rewrite Zdigit_plus.
rewrite Zdigit_scale with (1 := Hk).
destruct (Zle_or_lt (l1 + l2) k) as [Hk2|Hk2].
rewrite Zdigit_slice_out with (1 := Hk2).
now rewrite 2!Zdigit_slice_out by omega.
rewrite Zdigit_slice with (1 := conj Hk Hk2).
destruct (Zle_or_lt l1 k) as [Hk1|Hk1].
rewrite Zdigit_slice_out with (1 := Hk1).
rewrite Zdigit_slice by omega.
simpl ; apply f_equal.
ring.
rewrite Zdigit_slice with (1 := conj Hk Hk1).
rewrite (Zdigit_lt _ (k - l1)) by omega.
apply Zplus_0_r.
rewrite Zmult_comm.
apply Zsame_sign_trans_weak with n.
intros H ; rewrite H.
apply Zslice_0.
rewrite Zmult_comm.
apply Zsame_sign_trans_weak with (Zslice n (k1 + l1) l2).
intros H ; rewrite H.
apply Zscale_0.
apply Zsame_sign_slice.
apply Zsame_sign_scale.
apply Zsame_sign_slice.
clear k Hk ; intros k Hk.
rewrite Zdigit_scale with (1 := Hk).
destruct (Zle_or_lt l1 k) as [Hk1|Hk1].
left.
now apply Zdigit_slice_out.
right.
apply Zdigit_lt.
omega.
Qed.

Section digits_aux.

Variable p : Z.

Fixpoint Zdigits_aux (nb pow : Z) (n : nat) { struct n } : Z :=
  match n with
  | O => nb
  | S n => if Zlt_bool p pow then nb else Zdigits_aux (nb + 1) (Zmult beta pow) n
  end.

End digits_aux.

(** Number of digits of an integer *)

Definition Zdigits n :=
  match n with
  | Z0 => Z0
  | Zneg p => Zdigits_aux (Zpos p) 1 beta (digits2_Pnat p)
  | Zpos p => Zdigits_aux n 1 beta (digits2_Pnat p)
  end.

Theorem Zdigits_correct :
  forall n,
  (Zpower beta (Zdigits n - 1) <= Z.abs n < Zpower beta (Zdigits n))%Z.
Proof.
cut (forall p, Zpower beta (Zdigits (Zpos p) - 1) <= Zpos p < Zpower beta (Zdigits (Zpos p)))%Z.
intros H [|n|n] ; try exact (H n).
now split.
intros n.
simpl.
(* *)
assert (U: (Zpos n < Zpower beta (Z_of_nat (S (digits2_Pnat n))))%Z).
apply Z.lt_le_trans with (1 := proj2 (digits2_Pnat_correct n)).
rewrite Zpower_Zpower_nat.
rewrite Zabs_nat_Z_of_nat.
induction (S (digits2_Pnat n)).
easy.
rewrite 2!(Zpower_nat_S).
apply Zmult_le_compat with (2 := IHn0).
apply Zle_bool_imp_le.
apply beta.
easy.
rewrite <- (Zabs_nat_Z_of_nat n0).
rewrite <- Zpower_Zpower_nat.
apply (Zpower_ge_0 (Build_radix 2 (refl_equal true))).
apply Zle_0_nat.
apply Zle_0_nat.
(* *)
revert U.
rewrite inj_S.
unfold Z.succ.
generalize (digits2_Pnat n).
intros u U.
pattern (radix_val beta) at 2 4 ; replace (radix_val beta) with (Zpower beta 1) by apply Zmult_1_r.
assert (V: (Zpower beta (1 - 1) <= Zpos n)%Z).
now apply (Zlt_le_succ 0).
generalize (conj V U).
clear.
generalize (Z.le_refl 1).
generalize 1%Z at 2 3 5 6 7 9 10.
(* *)
induction u.
easy.
rewrite inj_S; unfold Z.succ.
simpl Zdigits_aux.
intros v Hv U.
case Zlt_bool_spec ; intros K.
now split.
pattern (radix_val beta) at 2 5 ; replace (radix_val beta) with (Zpower beta 1) by apply Zmult_1_r.
rewrite <- Zpower_plus.
rewrite Zplus_comm.
apply IHu.
clear -Hv ; omega.
split.
now ring_simplify (1 + v - 1)%Z.
now rewrite Zplus_assoc.
easy.
apply Zle_succ_le with (1 := Hv).
Qed.

Theorem Zdigits_unique :
  forall n d,
  (Zpower beta (d - 1) <= Z.abs n < Zpower beta d)%Z ->
  Zdigits n = d.
Proof.
intros n d Hd.
assert (Hd' := Zdigits_correct n).
apply Zle_antisym.
apply (Zpower_lt_Zpower beta).
now apply Z.le_lt_trans with (Z.abs n).
apply (Zpower_lt_Zpower beta).
now apply Z.le_lt_trans with (Z.abs n).
Qed.

Theorem Zdigits_abs :
  forall n, Zdigits (Z.abs n) = Zdigits n.
Proof.
now intros [|n|n].
Qed.

Theorem Zdigits_gt_0 :
  forall n, n <> Z0 -> (0 < Zdigits n)%Z.
Proof.
intros n Zn.
rewrite <- (Zdigits_abs n).
assert (Hn: (0 < Z.abs n)%Z).
destruct n ; [|easy|easy].
now elim Zn.
destruct (Z.abs n) as [|p|p] ; try easy ; clear.
simpl.
generalize 1%Z (radix_val beta) (refl_equal Lt : (0 < 1)%Z).
induction (digits2_Pnat p).
easy.
simpl.
intros.
case Zlt_bool.
exact H.
apply IHn.
now apply Zlt_lt_succ.
Qed.

Theorem Zdigits_ge_0 :
  forall n, (0 <= Zdigits n)%Z.
Proof.
intros n.
destruct (Z.eq_dec n 0) as [H|H].
now rewrite H.
apply Zlt_le_weak.
now apply Zdigits_gt_0.
Qed.

Theorem Zdigit_out :
  forall n k, (Zdigits n <= k)%Z ->
  Zdigit n k = Z0.
Proof.
intros n k Hk.
apply Zdigit_ge_Zpower with (2 := Hk).
apply Zdigits_correct.
Qed.

Theorem Zdigit_digits :
  forall n, n <> Z0 ->
  Zdigit n (Zdigits n - 1) <> Z0.
Proof.
intros n Zn.
apply Zdigit_not_0.
apply Zlt_0_le_0_pred.
now apply Zdigits_gt_0.
ring_simplify (Zdigits n - 1 + 1)%Z.
apply Zdigits_correct.
Qed.

Theorem Zdigits_slice :
  forall n k l, (0 <= l)%Z ->
  (Zdigits (Zslice n k l) <= l)%Z.
Proof.
intros n k l Hl.
unfold Zslice.
rewrite Zle_bool_true with (1 := Hl).
destruct (Zdigits_correct (Z.rem (Zscale n (- k)) (Zpower beta l))) as (H1,H2).
apply Zpower_lt_Zpower with beta.
apply Z.le_lt_trans with (1 := H1).
rewrite <- (Z.abs_eq (beta ^ l)) at 2 by apply Zpower_ge_0.
apply Zrem_lt.
apply Zgt_not_eq.
now apply Zpower_gt_0.
Qed.

Theorem Zdigits_mult_Zpower :
  forall m e,
  m <> Z0 -> (0 <= e)%Z ->
  Zdigits (m * Zpower beta e) = (Zdigits m + e)%Z.
Proof.
intros m e Hm He.
assert (H := Zdigits_correct m).
apply Zdigits_unique.
rewrite Z.abs_mul, Z.abs_pow, (Z.abs_eq beta).
2: now apply Zlt_le_weak, radix_gt_0.
split.
replace (Zdigits m + e - 1)%Z with (Zdigits m - 1 + e)%Z by ring.
rewrite Zpower_plus with (2 := He).
apply Zmult_le_compat_r.
apply H.
apply Zpower_ge_0.
now apply Zlt_0_le_0_pred, Zdigits_gt_0.
rewrite Zpower_plus with (2 := He).
apply Zmult_lt_compat_r.
now apply Zpower_gt_0.
apply H.
now apply Zlt_le_weak, Zdigits_gt_0.
Qed.

Theorem Zdigits_Zpower :
  forall e,
  (0 <= e)%Z ->
  Zdigits (Zpower beta e) = (e + 1)%Z.
Proof.
intros e He.
rewrite <- (Zmult_1_l (Zpower beta e)).
rewrite Zdigits_mult_Zpower ; try easy.
apply Zplus_comm.
Qed.

Theorem Zdigits_le :
  forall x y,
  (0 <= x)%Z -> (x <= y)%Z ->
  (Zdigits x <= Zdigits y)%Z.
Proof.
intros x y Zx Hxy.
assert (Hx := Zdigits_correct x).
assert (Hy := Zdigits_correct y).
apply (Zpower_lt_Zpower beta).
zify ; omega.
Qed.

Theorem lt_Zdigits :
  forall x y,
  (0 <= y)%Z ->
  (Zdigits x < Zdigits y)%Z ->
  (x < y)%Z.
Proof.
intros x y Hy.
cut (y <= x -> Zdigits y <= Zdigits x)%Z. omega.
now apply Zdigits_le.
Qed.

Theorem Zpower_le_Zdigits :
  forall e x,
  (e < Zdigits x)%Z ->
  (Zpower beta e <= Z.abs x)%Z.
Proof.
intros e x Hex.
destruct (Zdigits_correct x) as [H1 H2].
apply Z.le_trans with (2 := H1).
apply Zpower_le.
clear -Hex ; omega.
Qed.

Theorem Zdigits_le_Zpower :
  forall e x,
  (Z.abs x < Zpower beta e)%Z ->
  (Zdigits x <= e)%Z.
Proof.
intros e x.
generalize (Zpower_le_Zdigits e x).
omega.
Qed.

Theorem Zpower_gt_Zdigits :
  forall e x,
  (Zdigits x <= e)%Z ->
  (Z.abs x < Zpower beta e)%Z.
Proof.
intros e x Hex.
destruct (Zdigits_correct x) as [H1 H2].
apply Z.lt_le_trans with (1 := H2).
now apply Zpower_le.
Qed.

Theorem Zdigits_gt_Zpower :
  forall e x,
  (Zpower beta e <= Z.abs x)%Z ->
  (e < Zdigits x)%Z.
Proof.
intros e x Hex.
generalize (Zpower_gt_Zdigits e x).
omega.
Qed.

(** Number of digits of a product.

This strong version is needed for proofs of division and square root
algorithms, since they involve operation remainders.
*)

Theorem Zdigits_mult_strong :
  forall x y,
  (0 <= x)%Z -> (0 <= y)%Z ->
  (Zdigits (x + y + x * y) <= Zdigits x + Zdigits y)%Z.
Proof.
intros x y Hx Hy.
apply Zdigits_le_Zpower.
rewrite Z.abs_eq.
apply Z.lt_le_trans with ((x + 1) * (y + 1))%Z.
ring_simplify.
apply Zle_lt_succ, Z.le_refl.
rewrite Zpower_plus by apply Zdigits_ge_0.
apply Zmult_le_compat.
apply Zlt_le_succ.
rewrite <- (Z.abs_eq x) at 1 by easy.
apply Zdigits_correct.
apply Zlt_le_succ.
rewrite <- (Z.abs_eq y) at 1 by easy.
apply Zdigits_correct.
clear -Hx ; omega.
clear -Hy ; omega.
change Z0 with (0 + 0 + 0)%Z.
apply Zplus_le_compat.
now apply Zplus_le_compat.
now apply Zmult_le_0_compat.
Qed.

Theorem Zdigits_mult :
  forall x y,
  (Zdigits (x * y) <= Zdigits x + Zdigits y)%Z.
Proof.
intros x y.
rewrite <- Zdigits_abs.
rewrite <- (Zdigits_abs x).
rewrite <- (Zdigits_abs y).
apply Z.le_trans with (Zdigits (Z.abs x + Z.abs y + Z.abs x * Z.abs y)).
apply Zdigits_le.
apply Zabs_pos.
rewrite Zabs_Zmult.
generalize (Zabs_pos x) (Zabs_pos y).
omega.
apply Zdigits_mult_strong ; apply Zabs_pos.
Qed.

Theorem Zdigits_mult_ge :
  forall x y,
  (x <> 0)%Z -> (y <> 0)%Z ->
  (Zdigits x + Zdigits y - 1 <= Zdigits (x * y))%Z.
Proof.
intros x y Zx Zy.
cut ((Zdigits x - 1) + (Zdigits y - 1) < Zdigits (x * y))%Z. omega.
apply Zdigits_gt_Zpower.
rewrite Zabs_Zmult.
rewrite Zpower_exp.
apply Zmult_le_compat.
apply Zpower_le_Zdigits.
apply Zlt_pred.
apply Zpower_le_Zdigits.
apply Zlt_pred.
apply Zpower_ge_0.
apply Zpower_ge_0.
generalize (Zdigits_gt_0 x). omega.
generalize (Zdigits_gt_0 y). omega.
Qed.

Theorem Zdigits_div_Zpower :
  forall m e,
  (0 <= m)%Z ->
  (0 <= e <= Zdigits m)%Z ->
  Zdigits (m / Zpower beta e) = (Zdigits m - e)%Z.
Proof.
intros m e Hm He.
assert (H := Zdigits_correct m).
apply Zdigits_unique.
destruct (Zle_lt_or_eq _ _ (proj2 He)) as [He'|He'].
  rewrite Z.abs_eq in H by easy.
  destruct H as [H1 H2].
  rewrite Z.abs_eq.
  split.
  replace (Zdigits m - e - 1)%Z with (Zdigits m - 1 - e)%Z by ring.
  rewrite Z.pow_sub_r.
  2: apply Zgt_not_eq, radix_gt_0.
  2: clear -He He' ; omega.
  apply Z_div_le with (2 := H1).
  now apply Z.lt_gt, Zpower_gt_0.
  apply Zmult_lt_reg_r with (Zpower beta e).
  now apply Zpower_gt_0.
  apply Z.le_lt_trans with m.
  rewrite Zmult_comm.
  apply Z_mult_div_ge.
  now apply Z.lt_gt, Zpower_gt_0.
  rewrite <- Zpower_plus.
  now replace (Zdigits m - e + e)%Z with (Zdigits m) by ring.
  now apply Zle_minus_le_0.
  apply He.
  apply Z_div_pos with (2 := Hm).
  now apply Z.lt_gt, Zpower_gt_0.
rewrite He'.
rewrite (Zeq_minus _ (Zdigits m)) by reflexivity.
simpl.
rewrite Zdiv_small.
easy.
split.
exact Hm.
now rewrite <- (Z.abs_eq m) at 1.
Qed.

End Fcore_digits.

(** Specialized version for computing the number of bits of an integer *)

Section Zdigits2.

Theorem Z_of_nat_S_digits2_Pnat :
  forall m : positive,
  Z_of_nat (S (digits2_Pnat m)) = Zdigits radix2 (Zpos m).
Proof.
intros m.
apply eq_sym, Zdigits_unique.
rewrite <- Zpower_nat_Z.
rewrite Nat2Z.inj_succ.
change (_ - 1)%Z with (Z.pred (Z.succ (Z.of_nat (digits2_Pnat m)))).
rewrite <- Zpred_succ.
rewrite <- Zpower_nat_Z.
apply digits2_Pnat_correct.
Qed.

Theorem Zpos_digits2_pos :
  forall m : positive,
  Zpos (digits2_pos m) = Zdigits radix2 (Zpos m).
Proof.
intros m.
rewrite <- Z_of_nat_S_digits2_Pnat.
unfold Z.of_nat.
apply f_equal.
induction m ; simpl ; try easy ;
  apply f_equal, IHm.
Qed.

Lemma Zdigits2_Zdigits :
  forall n, Zdigits2 n = Zdigits radix2 n.
Proof.
intros [|p|p] ; try easy ;
  apply Zpos_digits2_pos.
Qed.

End Zdigits2.


(** Adapted from "Elements of Set Theory" Chapter 5 **)
(** Coq coding by choukh, June 2020 **)

Require Export ZFC.Lib.Natural.

(*** EST第五章1：整数的定义，整数算术：加法，加法逆元 ***)

(* 二元函数与等价关系的相容性 *)
Definition binCompatible : set → set → set → Prop := λ R A F,
  equiv R A ∧ F: A × A ⇒ A ∧
  ∀ x y u v ∈ A, <x, u> ∈ R → <y, v> ∈ R →
  <F[<x, y>], F[<u, v>]> ∈ R.

(* 相容函数在商集上的相似函数 *)
Definition QuotionFunc : set → set → set → set := λ R A F,
  {<<[π1 p]R, [π2 p]R>, [F[<π1 p, π2 p>]]R> | p ∊ A × A}.

Lemma quotionFunc_function : ∀ R A F,
  binCompatible R A F →
  (QuotionFunc R A F): (A/R) × (A/R) ⇒ A/R.
Proof with eauto.
  intros * [Hqv [[Hf [Hdf Hrf]] Hcom]]. repeat split.
  - (* is_rel *) intros p Hp.
    apply ReplAx in Hp as [x []]. subst p. eexists...
  - (* single-valued *)
    intros x H. rewrite <- unique_existence.
    split. apply domE in H...
    intros y1 y2 Hy1 Hy2.
    apply domE in H as [y0 Hy0].
    apply ReplAx in Hy0 as [a0 [_ Heq0]].
    apply ReplAx in Hy1 as [a1 [Ha1 Heq1]].
    apply ReplAx in Hy2 as [a2 [Ha2 Heq2]].
    apply op_iff in Heq0 as [Heq0 _].
    apply op_iff in Heq1 as [Heq1 Hy1].
    apply op_iff in Heq2 as [Heq2 Hy2].
    subst x y1 y2. rewrite <- Heq2 in Heq1. clear Heq2.
    apply op_iff in Heq1 as [H1 H2].
    apply CPrdE1 in Ha1 as [a [Ha [b [Hb Ha1]]]].
    apply CPrdE1 in Ha2 as [c [Hc [d [Hd Ha2]]]].
    subst. zfc_simple.
    eapply eqvc_ident in H1...
    eapply eqvc_ident in H2...
    assert (<F[<a, b>], F[<c, d>]> ∈ R) by (apply Hcom; eauto).
    assert (Hd1: <a, b> ∈ A × A) by (apply CPrdI; eauto).
    assert (Hd2: <c, d> ∈ A × A) by (apply CPrdI; eauto).
    rewrite <- Hdf in Hd1, Hd2.
    apply func_correct in Hd1... apply func_correct in Hd2...
    apply ranI, Hrf in Hd1. apply ranI, Hrf in Hd2.
    eapply eqvc_ident...
  - (* dom F' = (A/R) × (A/R) *)
    ext Hx.
    + apply domE in Hx as [y Hp]. apply ReplAx in Hp as [a [Hp Heq]].
      apply op_iff in Heq as [Heq _]. subst x.
      apply CPrdE1 in Hp as [c [Hc [d [Hd Ha]]]].
      subst. zfc_simple. apply CPrdI; apply quotI...
    + apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]].
      apply quotE in Ha as [c [Hc Heqa]].
      apply quotE in Hb as [d [Hd Heqb]].
      eapply domI. apply ReplAx. exists <c, d>. split.
      apply CPrdI... zfc_simple. apply op_iff...
      split. rewrite Hx. apply op_iff... reflexivity.
  - (* ran F' ⊆ A/R *)
    intros y Hy. apply ranE in Hy as [].
    apply ReplAx in H as [a [Ha Heq]].
    apply cprd_is_pairs in Ha as Hap. apply op_η in Hap.
    apply op_iff in Heq as [_ Hy]. subst y. rewrite <- Hap.
    rewrite <- Hdf in Ha. apply func_correct in Ha as Hp...
    apply ranI in Hp as Hr. apply Hrf in Hr. apply quotI...
Qed.

Lemma quotionFunc_maps_onto : ∀ R A F,
  binCompatible R A F → F: A × A ⟹ A →
  (QuotionFunc R A F): (A/R) × (A/R) ⟹ A/R.
Proof with eauto.
  intros * Hc [Hf [Hdf Hrf]].
  pose proof (quotionFunc_function) as [Hf' [Hdf' Hrf']]...
  split... split... apply sub_antisym...
  intros y Hy. apply quotE in Hy as [p [Hp Heq]].
  rewrite <- Hrf in Hp. apply ranE in Hp as [x Hp].
  apply domI in Hp as Hd. rewrite Hdf in Hd.
  eapply ranI. apply ReplAx. exists x. split...
  apply op_iff. split... apply cprd_is_pairs in Hd.
  apply op_η in Hd. rewrite <- Hd.
  cut (F[x] = p). congruence. apply func_ap...
Qed.

Lemma binCompatibleE: ∀ R A F,
  binCompatible R A F →
  let F' := QuotionFunc R A F in
  ∀ x y ∈ A, F'[<[x]R, [y]R>] = [F[<x, y>]]R.
Proof with eauto.
  intros * Hc F' x Hx y Hy.
  pose proof (quotionFunc_function) as [Hf' [Hdf' Hrf']]...
  destruct Hc as [Hqv [[Hf [Hdf Hrf]] Hc]].
  assert (Hdx: [x]R ∈ A/R) by (apply quotI; auto).
  assert (Hdy: [y]R ∈ A/R) by (apply quotI; auto).
  assert (Hd: <[x]R, [y]R> ∈ (A/R) × (A/R)) by (apply CPrdI; auto).
  rewrite <- Hdf' in Hd. apply func_correct in Hd...
  apply ReplAx in Hd as [b [Hb Heq]].
  apply op_iff in Heq as [H1 H2]. unfold F'.
  rewrite <- H2. eapply eqvc_ident; swap 1 3...
  - apply Hrf. eapply ranI... apply func_correct...
    rewrite Hdf. apply CPrdE0 in Hb as []. apply CPrdI...
  - apply Hrf. eapply ranI... apply func_correct...
    rewrite Hdf. apply CPrdE0 in Hb as []. apply CPrdI...
  - apply op_iff in H1 as [H11 H12].
    apply CPrdE0 in Hb as [Hb1 Hb2].
    eapply eqvc_ident in H11...
    eapply eqvc_ident in H12...
Qed.

Theorem quotionFunc_unique: ∀ R A F,
  binCompatible R A F →
  ∃!F', F': (A/R) × (A/R) ⇒ A/R ∧
    ∀ x y ∈ A, F'[<[x]R, [y]R>] = [F[<x, y>]]R.
Proof with eauto.
  intros * Hcom. rewrite <- unique_existence. split.
  exists (QuotionFunc R A F). split.
  apply quotionFunc_function...
  apply binCompatibleE...
  intros F1 F2 [[HF1 [Hd1 Hr1]] H1] [[HF2 [Hd2 Hr2]] H2].
  apply func_ext_intro... rewrite Hd1, Hd2...
  intros x Hx. rewrite Hd1 in Hx.
  apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]].
  apply quotE in Ha as [c [Hc Haeq]].
  apply quotE in Hb as [d [Hd Hbeq]].
  pose proof (H1 c Hc d Hd) as H3.
  pose proof (H2 c Hc d Hd) as H4. simpl in *. congruence.
Qed.

Notation "A ²" := (A × A) (at level 9).

(* 整数定义和有理数定义通用的平面构造 *)
Lemma plane2E : ∀ A B, ∀x ∈ (A × B)²,
  ∃m ∈ A, ∃n ∈ B, ∃p ∈ A, ∃q ∈ B, x = <<m, n>, <p, q>>.
Proof with auto.
  intros A B x Hx.
  apply CPrdE1 in Hx as [u [Hu [v [Hv Hx]]]].
  apply CPrdE1 in Hu as [m [Hm [n [Hn Hu]]]].
  apply CPrdE1 in Hv as [p [Hp [q [Hq Hv]]]].
  exists m. split... exists n. split...
  exists p. split... exists q. split... congruence.
Qed.

Declare Scope PlaneEquiv_scope.
Open Scope PlaneEquiv_scope.

(* 平面上的等价关系 *)
Definition PlaneEq := set → set → set → set → Prop.
Definition PlaneEquiv : set → set → PlaneEq → set :=
  λ A B Eq, Rel (A × B) (A × B) (λ a b,
    let m := π1 a in let n := π2 a in
    let p := π1 b in let q := π2 b in
    Eq m n p q
  ).
Notation "~" := PlaneEquiv : PlaneEquiv_scope.
Notation "a ~ b" := (λ A B Eq, <a, b> ∈ PlaneEquiv A B Eq)
  (at level 10) : PlaneEquiv_scope.

Lemma planeEquivI : ∀ A B (Eq : PlaneEq),
  ∀m ∈ A, ∀n ∈ B, ∀p ∈ A, ∀q ∈ B,
  Eq m n p q → (<m, n> ~ <p, q>) A B Eq.
Proof with auto.
  intros A B Eq m Hm n Hn p Hp q Hq Heq.
  apply SepI. apply CPrdI; apply CPrdI... zfc_simple...
Qed.

Lemma planeEquivE1 : ∀ A B Eq, ∀ x y, (x ~ y) A B Eq →
  ∃m ∈ A, ∃n ∈ B, ∃p ∈ A, ∃q ∈ B,
  x = <m, n> ∧ y = <p, q> ∧ Eq m n p q.
Proof with auto.
  intros * Hqv. apply SepE in Hqv as [Hxy Heq].
  apply plane2E in Hxy as [m [Hm [n [Hn [p [Hp [q [Hq Hxy]]]]]]]].
  apply op_iff in Hxy as []; subst.
  zfc_simple. simpl in Heq.
  exists m. split... exists n. split...
  exists p. split... exists q. split...
Qed.

Lemma planeEquivE2 : ∀ A B Eq, ∀ m n p q,
  (<m, n> ~ <p, q>) A B Eq →
  Eq m n p q ∧ m ∈ A ∧ n ∈ B ∧ p ∈ A ∧ q ∈ B.
Proof.
  intros * Hqv. apply planeEquivE1 in Hqv
    as [a [Ha [b [Hb [c [Hc [d [Hd [H1 [H2 H3]]]]]]]]]].
  apply op_iff in H1 as [];
  apply op_iff in H2 as []; subst a b c d. auto.
Qed.

Lemma planeEquiv : ∀ A B Eq, ∀m ∈ A, ∀n ∈ B, ∀p ∈ A, ∀q ∈ B,
  (<m, n> ~ <p, q>) A B Eq ↔ Eq m n p q.
Proof with eauto.
  intros A B Eq m Hm n Hn p Hp q Hq. split; intros.
  - eapply planeEquivE2...
  - apply planeEquivI...
Qed.

Definition planeEqRefl : PlaneEq → Prop := λ Eq,
  ∀ m n, Eq m n m n.
Definition planeEqSymm : PlaneEq → Prop := λ Eq,
  ∀ m n p q, Eq m n p q → Eq p q m n.
Definition planeEqTran : set → set → PlaneEq → Prop := λ A B Eq,
  ∀m ∈ A, ∀n ∈ B, ∀p ∈ A, ∀q ∈ B, ∀r ∈ A, ∀s ∈ B,
  Eq m n p q → Eq p q r s → Eq m n r s.

Theorem planeEquiv_equiv : ∀ A B (Eq : PlaneEq),
  planeEqRefl Eq → planeEqSymm Eq → planeEqTran A B Eq →
  equiv (PlaneEquiv A B Eq) (A × B).
Proof with eauto.
  intros * Hrefl Hsymm Htran. repeat split.
  - intros x Hx. apply SepE1 in Hx...
  - intros x Hx. apply SepI. apply CPrdI...
    apply CPrdE1 in Hx as [a [Ha [b [Hb Heq]]]].
    subst x. zfc_simple...
  - intros x y Hqv. apply planeEquivE1 in Hqv
      as [m [Hm [n [Hn [p [Hp [q [Hq [Hx [Hy Heq]]]]]]]]]].
    subst. apply SepI. apply CPrdI; apply CPrdI...
    zfc_simple. simpl in *. apply Hsymm...
  - intros x y z H1 H2.
    apply planeEquivE1 in H1
      as [m [Hm [n [Hn [p [Hp [q [Hq [Hx [Hy H1]]]]]]]]]]. subst.
    apply planeEquivE1 in H2
      as [p' [_ [q' [_ [r [Hr [s [Hs [Hx [Hy H2]]]]]]]]]]. subst.
    apply op_iff in Hx as []; subst p' q'.
    apply SepI. apply CPrdI; apply CPrdI...
    zfc_simple. simpl in *. eapply Htran; revgoals...
Qed.

(* 平面上的商集 *)
Definition PlaneQuotient : set → set → PlaneEq → set := λ A B Eq,
  A × B / ~ A B Eq.

Lemma pQuotI : ∀ A B Eq, ∀m ∈ A, ∀n ∈ B,
  [<m, n>]~ A B Eq ∈ PlaneQuotient A B Eq.
Proof. intros A B Eq m Hm n Hn. apply quotI. apply CPrdI; auto. Qed.

Lemma pQuotE : ∀ A B Eq, ∀x ∈ PlaneQuotient A B Eq,
  ∃m ∈ A, ∃n ∈ B, x = [<m, n>]~ A B Eq.
Proof with auto.
  intros A B Eq x Hx. apply quotE in Hx as [p [Hx Heq1]].
  apply CPrdE1 in Hx as [a [Ha [b [Hb Heq2]]]].
  exists a. split... exists b. split... congruence.
Qed.

Lemma pQuot_ident : ∀ A B Eq,
  planeEqRefl Eq → planeEqSymm Eq → planeEqTran A B Eq →
  ∀m ∈ A, ∀n ∈ B, ∀p ∈ A, ∀q ∈ B,
  Eq m n p q ↔ [<m, n>]~ A B Eq = [<p, q>]~ A B Eq.
Proof with eauto.
  intros A B Eq Hrefl Hsymm Htran m Hm n Hn p Hp q Hq.
  split; intros Heq.
  - eapply eqvc_ident; swap 1 3. apply planeEquiv_equiv...
    apply CPrdI... apply CPrdI... apply planeEquivI...
  - cut ((<m, n> ~ <p, q>) A B Eq). intros H.
    apply planeEquiv in H...
    eapply eqvc_ident; revgoals. apply Heq.
    apply planeEquiv_equiv... apply CPrdI... apply CPrdI...
Qed.

(* 平面算术定义Helper *)
Definition PlaneF := set → set → set → set → set.
Definition PlaneArith : set → set → PlaneF → set :=
  λ A B F, Rel (A × B)² (A × B) (λ x y,
  let m := π1 (π1 x) in let n := π2 (π1 x) in
  let p := π1 (π2 x) in let q := π2 (π2 x) in
  y = F m n p q
).

Lemma planeArithE : ∀ A B F x y, <x, y> ∈ PlaneArith A B F →
  ∃m ∈ A, ∃n ∈ B, ∃p ∈ A, ∃q ∈ B,
  x = <<m, n>, <p, q>> ∧ y = F m n p q.
Proof with auto.
  intros * Hxy. apply SepE in Hxy as [Hxy Heq].
  apply CPrdE2 in Hxy as [Hx _].
  apply plane2E in Hx as [m [Hm [n [Hn [p [Hp [q [Hq Hx]]]]]]]].
  subst x. zfc_simple. simpl in Heq.
  exists m. split... exists n. split...
  exists p. split... exists q. split...
Qed.

Lemma planeArith_maps_onto : ∀ A B F,
  (∀m ∈ A, ∀n ∈ B, ∀p ∈ A, ∀q ∈ B, F m n p q ∈ A × B) →
  (∀a ∈ A, ∀b ∈ B, ∃m ∈ A, ∃n ∈ B, ∃p ∈ A, ∃q ∈ B, <a, b> = F m n p q) →
  (PlaneArith A B F): (A × B)² ⟹ A × B.
Proof with eauto.
  intros * HF1 HF2. repeat split.
  - (* is_rel *) intros x Hx.
    apply SepE in Hx as [Hx _]. apply cprd_is_pairs in Hx...
  - (* single-valued *)
    intros x H. rewrite <- unique_existence.
    split. apply domE in H...
    intros y1 y2 H1 H2.
    apply planeArithE in H1
      as [m1 [Hm1 [n1 [Hn1 [p1 [Hp1 [q1 [Hq1 [Hx1 Hy1]]]]]]]]].
    apply planeArithE in H2
      as [m2 [Hm2 [n2 [Hn2 [p2 [Hp2 [q2 [Hq2 [Hx2 Hy2]]]]]]]]].
    subst x. apply op_iff in Hx2 as [H1 H2].
    apply op_iff in H1 as [H11 H12].
    apply op_iff in H2 as [H21 H22]. congruence.
  - (* dom planeArith = A² × A² *)
    ext Hx.
    + apply domE in Hx as [y Hx]. apply SepE in Hx as [Hx _].
      apply CPrdE2 in Hx as []...
    + assert (Hx' := Hx).
      apply plane2E in Hx' as [m [Hm [n [Hn [p [Hp [q [Hq Hx']]]]]]]].
      eapply domI. apply SepI. apply CPrdI. apply Hx.
      apply HF1. apply Hm. apply Hn. apply Hp. apply Hq.
      subst x. zfc_simple. simpl. reflexivity.
  - (* ran planeArith = A² *)
    ext y Hy.
    + apply ranE in Hy as [x Hp]. apply SepE in Hp as [Hp _].
      apply CPrdE2 in Hp as []...
    + assert (Hy' := Hy).
      apply CPrdE1 in Hy' as [a [Ha [b [Hb Heq]]]].
      edestruct HF2 as [m [Hm [n [Hn [p [Hp [q [Hq]]]]]]]].
      apply Ha. apply Hb. eapply ranI. apply SepI.
      apply CPrdI... apply CPrdI; apply CPrdI.
      apply Hm. apply Hn. apply Hp. apply Hq.
      subst. zfc_simple. simpl. congruence.
Qed.

Close Scope PlaneEquiv_scope.
Declare Scope PreInt_scope.
Open Scope PreInt_scope.
Delimit Scope PreInt_scope with pz.

(* 自然数平面上的用于构造整数的等价关系 *)
Definition IntEq : PlaneEq := λ m n p q, m + q = p + n.
Notation "~" := (PlaneEquiv ω ω IntEq) : PreInt_scope.
Notation "a ~ b" := (<a, b> ∈ PlaneEquiv ω ω IntEq)
  (at level 10) : PreInt_scope.

Lemma intEqRefl : planeEqRefl IntEq.
Proof. intros m n. reflexivity. Qed.

Lemma intEqSymm : planeEqSymm IntEq.
Proof. intros m n p q Heq. symmetry. auto. Qed.

Lemma intEqTran : planeEqTran ω ω IntEq.
Proof with eauto; try repeat apply add_ran; auto.
  intros m Hm n Hn p Hp q Hq r Hr s Hs H1 H2. unfold IntEq.
  assert (m + q + (p + s) = p + n + (r + q)) by congruence.
  rewrite (add_comm (m+q)) in H...
  rewrite <- (add_assoc (p+s)) in H...
  rewrite <- (add_assoc (p+n)) in H...
  assert (p + s + m = p + n + r). {
    eapply add_cancel; revgoals; [apply H|..]...
  }
  rewrite add_assoc, add_assoc in H0...
  rewrite add_comm, (add_comm p) in H0...
  rewrite add_comm, (add_comm r)...
  eapply add_cancel; revgoals; [apply H0|..]...
Qed.

Theorem intEquiv_equiv : equiv (PlaneEquiv ω ω IntEq) ω².
Proof with eauto; try repeat apply add_ran; auto.
  apply planeEquiv_equiv.
  apply intEqRefl. apply intEqSymm. apply intEqTran.
Qed.

(** 整数 **)
Definition ℤ : set := ω²/~.

Lemma int_ident : ∀ m n p q ∈ ω,
  m + q = p + n ↔ [<m, n>]~ = [<p, q>]~.
Proof.
  intros m Hm n Hn p Hp q Hq.
  now apply (pQuot_ident ω ω IntEq intEqRefl intEqSymm intEqTran).
Qed.

Definition PreIntAdd : set :=
  PlaneArith ω ω (λ m n p q, <m + p, n + q>).
Notation "a +ᵥ b" := (PreIntAdd[<a, b>]) (at level 50) : PreInt_scope.

Lemma add_split : ∀x ∈ ω, ∃ m n ∈ ω, x = m + n.
Proof with nauto.
  intros n Hn.
  ω_induction n.
  - exists 0. split... exists 0. split... rewrite add_0_r...
  - destruct IH as [a [Ha [b [Hb Heq]]]].
    exists a. split... exists (b⁺). split. apply ω_inductive...
    rewrite add_suc... congruence.
Qed.

Lemma preIntAdd_maps_onto : PreIntAdd: (ω²)² ⟹ ω².
Proof with eauto.
  apply planeArith_maps_onto.
  - intros m Hm n Hn p Hp q Hq. apply CPrdI; apply add_ran...
  - intros a Ha b Hb.
    apply add_split in Ha as [m [Hm [p [Hp Ha]]]].
    apply add_split in Hb as [n [Hn [q [Hq Hb]]]].
    exists m. split... exists n. split...
    exists p. split... exists q. split... congruence.
Qed.

Lemma preIntAdd_m_n_p_q : ∀ m n p q ∈ ω,
  <m, n> +ᵥ <p, q> = <m + p, n + q>.
Proof with auto.
  intros m Hm n Hn p Hp q Hq.
  eapply func_ap. destruct preIntAdd_maps_onto...
  apply SepI. apply CPrdI; apply CPrdI;
    try apply CPrdI; try apply add_ran... zfc_simple...
Qed.

Lemma preIntAdd_binCompatible :
  binCompatible (PlaneEquiv ω ω IntEq) ω² PreIntAdd.
Proof with eauto.
  split. apply intEquiv_equiv. split.
  destruct preIntAdd_maps_onto as [Hf [Hd Hr]].
  split... split... rewrite Hr. apply sub_refl.
  intros x Hx y Hy u Hu v Hv H1 H2.
  apply CPrdE1 in Hx as [m [Hm [n [Hn Hxeq]]]].
  apply CPrdE1 in Hy as [p [Hp [q [Hq Hyeq]]]].
  apply CPrdE1 in Hu as [m' [Hm' [n' [Hn' Hueq]]]].
  apply CPrdE1 in Hv as [p' [Hp' [q' [Hq' Hveq]]]]. subst.
  apply planeEquiv in H1... apply planeEquiv in H2...
  rewrite preIntAdd_m_n_p_q, preIntAdd_m_n_p_q...
  apply SepI. apply CPrdI; apply CPrdI; apply add_ran...
  zfc_simple. simpl. unfold IntEq in *.
  rewrite (add_comm m), <- add_assoc, (add_comm (p+m+n')),
    <- add_assoc, <- add_assoc, add_assoc, (add_comm q');
    try repeat apply add_ran...
  rewrite (add_comm m'), <- (add_assoc (p'+m')), (add_comm (p'+m'+n)),
    <- (add_assoc q), <- (add_assoc q), (add_assoc (q+p')), (add_comm q);
    try repeat apply add_ran... congruence.
Qed.

Close Scope omega_scope.
Declare Scope Int_scope.
Open Scope Int_scope.
Delimit Scope Int_scope with z.

(** 整数加法 **)
Definition IntAdd : set :=
  QuotionFunc (PlaneEquiv ω ω IntEq) ω² PreIntAdd.
Notation "a + b" := (IntAdd[<a, b>]) : Int_scope.

Lemma intAdd_maps_onto : IntAdd: ℤ × ℤ ⟹ ℤ.
Proof.
  apply quotionFunc_maps_onto.
  apply preIntAdd_binCompatible.
  apply preIntAdd_maps_onto.
Qed.

Lemma intAdd_a_b : ∀ a b ∈ ω², [a]~ + [b]~ = [a +ᵥ b]~.
Proof.
  intros a Ha b Hb. apply binCompatibleE; auto.
  apply preIntAdd_binCompatible.
Qed.

Global Opaque IntAdd.

Lemma intAdd_m_n_p_q : ∀ m n p q ∈ ω,
  [<m, n>]~ + [<p, q>]~ = ([<m + p, n + q>]~)%ω.
Proof with auto.
  intros m Hm n Hn p Hp q Hq.
  rewrite intAdd_a_b, preIntAdd_m_n_p_q...
  apply CPrdI... apply CPrdI...
Qed.

Lemma intAdd_ran : ∀ a b ∈ ℤ, a + b ∈ ℤ.
Proof with auto.
  intros a Ha b Hb.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]]. subst a.
  apply pQuotE in Hb as [p [Hp [q [Hq Hb]]]]. subst b.
  rewrite intAdd_m_n_p_q... apply pQuotI; apply add_ran...
Qed.

Definition Int : nat → set := λ n, [<n, 0>]~.

Lemma intI : ∀ m n : nat, [<m, n>]~ ∈ ℤ.
Proof. intros. apply pQuotI; nauto. Qed.
Global Hint Immediate intI : number_hint.

Lemma int_n : ∀ n, Int n ∈ ℤ.
Proof. intros. unfold Int. nauto. Qed.
Global Hint Immediate int_n : number_hint.

Example intAdd_1_2 : Int 1 + Int 2 = Int 3.
Proof with nauto.
  unfold Int. rewrite intAdd_m_n_p_q, add_0_r...
  rewrite add_1_2. apply int_ident...
Qed.

Theorem intAdd_comm : ∀ a b ∈ ℤ, a + b = b + a.
Proof with auto.
  intros a Ha b Hb.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]]. subst a.
  apply pQuotE in Hb as [p [Hp [q [Hq Hb]]]]. subst b.
  repeat rewrite intAdd_m_n_p_q...
  rewrite (add_comm m), (add_comm q)...
Qed.

Theorem intAdd_assoc : ∀ a b c ∈ ℤ,
  (a + b) + c = a + (b + c).
Proof with auto.
  intros a Ha b Hb c Hc.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]]. subst a.
  apply pQuotE in Hb as [p [Hp [q [Hq Hb]]]]. subst b.
  apply pQuotE in Hc as [r [Hr [s [Hs Hc]]]]. subst c.
  repeat rewrite intAdd_m_n_p_q; try apply add_ran...
  repeat rewrite <- add_assoc; try repeat apply add_ran...
Qed.

Theorem intAdd_0_r : ∀a ∈ ℤ, a + Int 0 = a.
Proof with nauto.
  intros a Ha. apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]].
  subst a. unfold Int. rewrite intAdd_m_n_p_q, add_0_r, add_0_r...
Qed.

Corollary intAdd_0_l : ∀a ∈ ℤ, Int 0 + a = a.
Proof with nauto.
  intros a Ha. rewrite intAdd_comm, intAdd_0_r...
Qed.

Theorem intAddInv_exists : ∀a ∈ ℤ, ∃b ∈ ℤ, a + b = Int 0.
Proof with nauto.
  intros a Ha. apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]].
  exists ([<n, m>]~). split. apply pQuotI...
  subst a. rewrite intAdd_m_n_p_q...
  apply int_ident; try apply add_ran...
  rewrite add_0_r, add_0_l, add_comm; try apply add_ran...
Qed.

Theorem intAddInv_unique : ∀a ∈ ℤ, ∃!b, b ∈ ℤ ∧ a + b = Int 0.
Proof with auto.
  intros a Ha. rewrite <- unique_existence.
  split. apply intAddInv_exists...
  intros b b' [Hb H1] [Hb' H2].
  rewrite <- (intAdd_0_r b), <- (intAdd_0_r b')...
  rewrite <- H2 at 1. rewrite <- H1.
  rewrite <- intAdd_assoc, (intAdd_comm a), (intAdd_comm b')...
  apply intAdd_ran...
Qed.

Close Scope Int_scope.
Open Scope omega_scope.

(* 整数投射 *)
Definition PreIntProj := λ a,
  {p ∊ a | π1 p = 0 ∨ π2 p = 0}.
Definition IntProj := λ a,
  ⋃ (PreIntProj a).

Lemma preIntProjI1 : ∀ m n p ∈ ω,
  n + p = m → <p, 0> ∈ PreIntProj ([<m, n>]~).
Proof with nauto.
  intros m Hm n Hn p Hp Heq.
  apply SepI. apply eqvcI. apply planeEquivI... unfold IntEq.
  rewrite add_0_r... subst. rewrite add_comm... zfc_simple...
Qed.

Lemma preIntProjI2 : ∀ m n q ∈ ω,
  m + q = n → <0, q> ∈ PreIntProj ([<m, n>]~).
Proof with nauto.
  intros m Hm n Hn q Hq Heq.
  apply SepI. apply eqvcI. apply planeEquivI... unfold IntEq.
  rewrite add_0_l... zfc_simple...
Qed.

Lemma preIntProjE : ∀ m n ∈ ω, ∀x ∈ PreIntProj ([<m, n>]~),
  ∃ p q ∈ ω, x = <p, q> ∧ <m, n> ~ <p, q> ∧
    (p = 0 ∨ q = 0).
Proof with auto.
  intros m Hm n Hn x Hx.
  apply SepE in Hx as [Hx H0]. apply eqvcE in Hx.
  assert (Hx' := Hx). apply planeEquivE1 in Hx'
    as [m' [Hm' [n' [Hn' [p [Hp [q [Hq [H1 [H2 _]]]]]]]]]].
  apply op_iff in H1 as []; subst m' n'.
  subst x. zfc_simple. destruct H0; subst.
  exists 0. split... exists q...
  exists p. split... exists 0...
Qed.

Lemma preIntProj_unique : ∀a ∈ ℤ, ∃! p, p ∈ PreIntProj a.
Proof with neauto.
  intros a Ha.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]].
  subst a. rewrite <- unique_existence. split.
  - destruct (classic (m = n)) as [Hmn|Hmn].
    + exists <0, 0>. apply preIntProjI1... rewrite add_0_r...
    + apply nat_connected in Hmn as []...
      * apply nat_subtr' in H as [b [Hb [Heq _]]]...
        exists <0, b>. apply preIntProjI2...
      * apply nat_subtr' in H as [b [Hb [Heq _]]]...
        exists <b, 0>. apply preIntProjI1...
  - intros x1 x2 H1 H2.
    apply preIntProjE in H1 as [p1 [Hp1 [q1 [Hq1 [Hx1 [H1 []]]]]]];
    apply preIntProjE in H2 as [p2 [Hp2 [q2 [Hq2 [Hx2 [H2 []]]]]]];
      subst; auto; apply op_iff;
      apply planeEquiv in H1; apply planeEquiv in H2;
      unfold IntEq in *...
    + split... rewrite add_0_l in *... subst n.
      eapply add_cancel'; revgoals...
    + rewrite add_0_l in H1...
      rewrite add_0_r in H2... subst m.
      rewrite add_assoc, add_comm,
        add_assoc in H1; [|auto; apply add_ran..]...
      apply add_a_b_eq_a in H1...
      apply add_eq_0 in H1 as []... apply add_ran...
    + rewrite add_0_r in H1...
      rewrite add_0_l in H2... subst m.
      rewrite add_assoc, add_comm,
        add_assoc in H2; [|auto; apply add_ran..]...
      apply add_a_b_eq_a in H2...
      apply add_eq_0 in H2 as []... apply add_ran...
    + split... rewrite add_0_r in *... subst m.
      eapply add_cancel; revgoals...
Qed.

Lemma preIntProj : ∀a ∈ ℤ, ∃p, PreIntProj a = {p,}.
Proof with auto.
  intros a Ha.
  apply preIntProj_unique in Ha as [p [Hp Hu]].
  exists p. ext Hx.
  pose proof (Hu x Hx). subst...
  apply SingE in Hx. subst...
Qed.

Lemma intProj : ∀ m n ∈ ω, ∃ p q ∈ ω,
  IntProj ([<m, n>]~) = <p, q> ∧ <m, n> ~ <p, q> ∧ (p = 0 ∨ q = 0).
Proof with auto.
  intros m Hm n Hn.
  pose proof (preIntProj ([<m, n>]~)) as [x Hsg].
  apply pQuotI... assert (Hx: x ∈ {x,}) by apply SingI.
  rewrite <- Hsg in Hx. apply preIntProjE in Hx
    as [p [Hp [q [Hq [Hx [H1 H2]]]]]]...
  exists p. split... exists q. repeat split...
  rewrite <- Hx. unfold IntProj. rewrite Hsg.
  apply union_single.
Qed.

Lemma intProj_η : ∀a ∈ ℤ, a = [IntProj a]~.
Proof with auto.
  intros a Ha.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]].
  pose proof (intProj m Hm n Hn)
    as [p [Hp [q [Hq [H1 [H2 _]]]]]].
  apply planeEquiv in H2... unfold IntEq. subst a.
  rewrite H1. apply int_ident...
Qed.

Close Scope omega_scope.
Open Scope Int_scope.

(** 整数加法逆元 **)
Definition IntAddInv : set → set := λ a,
  let p := (IntProj a) in [<π2 p, π1 p>]~.
Notation "- a" := (IntAddInv a) : Int_scope.
Notation "a - b" := (a + (-b)) : Int_scope.

Lemma intAddInv : ∀ m n ∈ ω, (-[<m, n>]~) = [<n, m>]~.
Proof with eauto.
  intros m Hm n Hn.
  pose proof (intProj m Hm n Hn) as [p [Hp [q [Hq [H1 [H2 _]]]]]].
  destruct intEquiv_equiv as [_ [_ [_ Htr]]].
  ext Hx.
  - apply eqvcE in Hx. rewrite H1 in Hx. zfc_simple.
    apply eqvcI. cut (<n, m> ~ <q, p>). intros. eapply Htr...
    apply planeEquivI... unfold IntEq.
    apply planeEquiv in H2... unfold IntEq in H2.
    rewrite (add_comm n), (add_comm q)...
  - apply eqvcI. rewrite H1. zfc_simple.
    apply eqvcE in Hx. cut (<q, p> ~ <n, m>). intros. eapply Htr...
    apply planeEquivI... unfold IntEq.
    apply planeEquiv in H2... unfold IntEq in H2.
    rewrite (add_comm n), (add_comm q)...
Qed.

Global Opaque IntAddInv.

Lemma intAddInv_double : ∀a ∈ ℤ, --a = a.
Proof with auto.
  intros a Ha.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]]. subst a.
  rewrite intAddInv, intAddInv...
Qed.

Lemma intAddInv_ran : ∀a ∈ ℤ, -a ∈ ℤ.
Proof with auto.
  intros a Ha.
  apply pQuotE in Ha as [m [Hm [n [Hn Heq]]]]. subst a.
  rewrite intAddInv... apply pQuotI...
Qed.

Lemma neg_int_n : ∀ n, -Int n ∈ ℤ.
Proof with nauto.
  intros. apply intAddInv_ran...
Qed.
Global Hint Immediate neg_int_n : number_hint.

Lemma intAddInv_0 : -Int 0 = Int 0.
Proof. unfold Int. rewrite intAddInv; nauto. Qed.

Lemma intAddInv_annih : ∀a ∈ ℤ, a - a = Int 0.
Proof with nauto.
  intros a Ha.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]]. subst a.
  rewrite intAddInv, intAdd_m_n_p_q...
  apply int_ident; try apply add_ran...
  rewrite add_0_r, add_0_l, add_comm; try apply add_ran...
Qed.

Example intAdd_2_n3 : Int 2 - Int 3 = -Int 1.
Proof with nauto.
  unfold Int. rewrite intAddInv, intAddInv...
  rewrite intAdd_m_n_p_q, add_0_r, add_0_l...
  apply int_ident... rewrite (pred 1), add_suc, add_0_r, add_0_l...
Qed.


Require Coq.Vectors.Vector.
Import Vectors.VectorDef.VectorNotations.

Set Implicit Arguments.

Definition Vector_caseS'
           {A'} (Q : nat -> Type)
           (P : forall {n} (v : Vector.t A' (S n)), Q n -> Type)
           (H : forall h {n} t q, @P n (h :: t) q) {n} (v: Vector.t A' (S n))
           (q : Q n)
: P v q.
Proof.
  specialize (fun h t => H h _ t q).
  change n with (pred (S n)) in H, q |- *.
  set (Sn := S n) in *.
  pose (fun Sn (v : Vector.t A' Sn) (q : Q (pred Sn)) =>
          match Sn return Vector.t A' Sn -> Q (pred Sn) -> Type with
            | S n' => P n'
            | 0 => fun _ _ => True
          end v q) as P'.
  change (match Sn return Type with
            | 0 => True
            | _ => P' Sn v q
          end).
  change (forall h (t : match Sn with
                          | S n' => Vector.t A' n'
                          | 0 => Vector.t A' Sn
                        end),
            P' Sn (match Sn return match Sn with
                                     | S n' => Vector.t A' n'
                                     | 0 => Vector.t A' Sn
                                   end -> Vector.t A' Sn
                   with
                     | S _ => fun t => h :: t
                     | 0 => fun t => t
                   end t) q) in H.
  clearbody P'; clear P.
  clearbody Sn.
  destruct v as [|h ? t].
  { constructor. }
  { apply H. }
Defined.


(* Copyright (c) 2014, Robert Dockins *)

Require Import Domains.basics.
Require Import Domains.categories.
Require Import Domains.preord.
Require Import Domains.directed.

(** * Directed colimits and continuous functors.
 *)
Record directed_system (I:directed_preord) (C:category) :=
  DirSys
  { ds_F    : I -> ob C
  ; ds_hom : forall i j:I, i ≤ j -> ds_F i → ds_F j
  ; ds_ident : forall i (Hii:i≤i), ds_hom i i Hii ≈ id
  ; ds_compose : forall i j k (Hij:i≤j) (Hjk:j≤k) (Hik:i≤k),
                       ds_hom j k Hjk ∘ ds_hom i j Hij ≈ ds_hom i k Hik
  }.
Arguments ds_F [I] [C] _ _.
Arguments ds_hom [I] [C] _ _ _ _.
Arguments ds_ident [I] [C] _ _ _.
Arguments ds_compose [I] [C] _ _ _ _ _ _ _.

Record cocone (I:directed_preord) C (DS:directed_system I C) :=
  Cocone
  { cocone_point :> ob C
  ; cocone_spoke : forall i, ds_F DS i → cocone_point
  ; cocone_commute : forall i j (Hij:i≤j),
       cocone_spoke i ≈ cocone_spoke j ∘ ds_hom DS i j Hij
  }.
Arguments cocone [I] [C] DS.
Arguments Cocone [I] [C] DS _ _ _.
Arguments cocone_point [I] [C] [DS] _.
Arguments cocone_spoke [I] [C] [DS] _ _.
Arguments cocone_commute [I] [C] [DS] _ _ _ _.

Record directed_colimit (I:directed_preord) C (DS:directed_system I C)
  (XC:cocone DS) :=
  DirectedColimit
  { colim_univ : forall (YC:cocone DS), XC → YC
  ; colim_commute : forall (YC:cocone DS) i,
       cocone_spoke YC i ≈ colim_univ YC ∘ cocone_spoke XC i
  ; colim_uniq : forall (YC:cocone DS) (f:XC → YC),
       (forall i, cocone_spoke YC i ≈ f ∘ cocone_spoke XC i) ->
       f ≈ colim_univ YC
  }.
Arguments directed_colimit [I] [C] DS XC.
Arguments DirectedColimit [I] [C] DS XC _ _ _.
Arguments colim_univ [I] [C] [DS] [XC] _ YC.
Arguments colim_commute [I] [C] [DS] [XC] _ _ _.
Arguments colim_uniq [I] [C] [DS] [XC] _ YC f _.

Program Definition dir_sys_app I C D
  (DS:directed_system I C) (F:functor C D)
  : directed_system I D:=

  DirSys I D
    (fun i => F (ds_F DS i))
    (fun i j Hij => F·(ds_hom DS i j Hij))
    _ _.
Next Obligation.
  intros.
  apply Functor.ident.
  apply ds_ident.
Qed.
Next Obligation.
  intros.
  rewrite <- Functor.compose.
  reflexivity.
  symmetry; apply ds_compose.
Qed.
Arguments dir_sys_app [I] [C] [D] DS F.

Program Definition cocone_app I C D (DS:directed_system I C)
  (CC:cocone DS) (F:functor C D)
  : cocone (dir_sys_app DS F) :=

  Cocone (dir_sys_app DS F) (F CC) (fun i => F·cocone_spoke CC i) _.
Next Obligation.
  simpl; intros.
  rewrite <- (Functor.compose F). 2: reflexivity.
  rewrite <- (cocone_commute CC i j Hij).
  auto.
Qed.
Arguments cocone_app [I] [C] [D] [DS] CC F.

Definition continuous_functor (C D:category) (F:functor C D) :=
  forall I (DS:directed_system I C) (CC:cocone DS),
    directed_colimit DS CC ->
    directed_colimit (dir_sys_app DS F) (cocone_app CC F).
Arguments continuous_functor [C] [D] F.

(**  * Fixpoints of continuous functors.

     We can construct fixpoints of continuous endofunctors in
     any category that has an initial object and colimits of
     directed systems.

     This is essentially the categorical analogue of Kleene's
     fixpoint theorem for posets.
 *)

Require Import Arith.
Section fixpoint.
  Variable C:initialized.
  Variable F:functor C C.

  Variable colimit_cocone :
    forall (I:directed_preord) (DS:directed_system I C), cocone DS.

  Variable has_colimits :
    forall (I:directed_preord) (DS:directed_system I C),
            directed_colimit DS (colimit_cocone I DS).

  (** Iterated application of the functor [F]; the initial object
      provides the base case of the recursion.
    *)
  Fixpoint iterF (x:nat) : ob C :=
    match x with
    | O => ¡
    | S x' => F (iterF x')
    end.

  Lemma HSle0 j (Hij: S j <= O) : False.
  Proof.
    inversion Hij.
  Qed.

  (** Iterated action of the functor [F] on homs. The base case is
      provided by the universal hom associated to ¡.
   *)
  Fixpoint iter_hom (i:nat) : forall (j:nat) (Hij:i <= j), iterF i → iterF j :=
    match i as i' return forall (j:nat) (Hij:i' <= j), iterF i' → iterF j with
    | O => fun j Hij => initiate
    | S i' => fun j =>
        match j as j' return forall (Hij:S i' <= j'), iterF (S i') → iterF j' with
        | O => fun Hij => False_rect _ (HSle0 i' Hij) (* impossible case *)
        | S j' => fun Hij => F·(iter_hom i' j' (gt_S_le i' j' Hij))
        end
    end.

  Lemma iter_hom_proof_irr i : forall j H1 H2,
    iter_hom i j H1 ≈ iter_hom i j H2.
  Proof.
    induction i; simpl; intros; auto.
    destruct j.
    elimtype False. inversion H1.
    apply Functor.respects.
    apply IHi.
  Qed.

  (** The Kleene chain is a directed system. *)
  Program Definition kleene_chain : directed_system nat_dirord C :=
    DirSys nat_dirord C iterF iter_hom _ _.
  Next Obligation.
    induction i; simpl; intros.
    symmetry. apply initiate_univ.
    apply Functor.ident; auto.
  Qed.
  Next Obligation.
    induction i. simpl; intros.
    apply initiate_univ.
    intros. destruct j.
    elimtype False. inversion Hij.
    destruct k.
    elimtype False. inversion Hjk.
    simpl.
    rewrite <- (Functor.compose F _ _ _ (iter_hom j k (gt_S_le j k Hjk))).
    reflexivity. auto.
  Qed.

  (** The fixpoint we desire is the point of the colimiting cocone
      corresponding to the Kleene chain.
   *)
  Definition fixpoint := cocone_point (colimit_cocone nat_dirord kleene_chain).

  (** It is mildly interesting to note that we can construct the fixpoint
      object without the continuity assumption.

      However, if we suppose [F] _is_ a continuous functor, we can demonstrate
      that [fixpoint] forms an initial algebra and thus actually is
      the least fixpoint of [F].
    *)
  Hypothesis Fcontinuous : continuous_functor F.

  (** Because [F] is continuous, the additional application of F
      to the fixpoint colimiting cocone is a colimiting cocone
      for the [n+1] Kleene chain.
   *)
  Let BL := Fcontinuous
               nat_dirord kleene_chain
               (colimit_cocone nat_dirord kleene_chain)
               (has_colimits nat_dirord kleene_chain).

  Program Definition cocone_plus1 : cocone (dir_sys_app kleene_chain F)
    := Cocone (dir_sys_app kleene_chain F) fixpoint
      (fun i => cocone_spoke (colimit_cocone nat_dirord kleene_chain) (S i)) _.
  Next Obligation.
    simpl; intros.
    assert (Hij' : S i <= S j). auto with arith.
    rewrite (cocone_commute (colimit_cocone nat_dirord kleene_chain) (S i) (S j) Hij').
    simpl. apply cat_respects; auto.
    apply Functor.respects.
    apply iter_hom_proof_irr.
  Qed.

  (** The algebra associated with the fixpoint. *)
  Definition fixpoint_alg : alg C F
    := @Alg C F fixpoint (colim_univ BL cocone_plus1).

  (** Next we define the catamorphism by iterating the action
      of a given algebra.
    *)
  Section cata.
    Variable AG : alg C F.

    Fixpoint cata_hom' (i:nat) : iterF i → AG :=
      match i as i' return iterF i' → AG with
      | O => initiate
      | S i' => Alg.iota AG ∘ F·(cata_hom' i')
      end.

    Lemma cata_hom_iter_hom : forall (i j:nat_ord) (Hij:i≤j),
      cata_hom' i ≈ cata_hom' j ∘ (iter_hom i j Hij).
    Proof.
      induction i; intros.
      simpl. symmetry. apply initiate_univ.
      destruct j. inversion Hij.
      simpl.
      rewrite <- (cat_assoc _ _ _ _ _ (Alg.iota AG)).
      apply cat_respects; auto.
      rewrite <- (Functor.compose F).
      2: reflexivity.
      rewrite IHi; eauto.
    Qed.

    Program Definition AG_cocone : cocone kleene_chain :=
      Cocone _ _ cata_hom' cata_hom_iter_hom.

    Program Definition AG_cocone' :
      cocone (dir_sys_app kleene_chain F) :=
        Cocone _ _ (fun i => cata_hom' (S i)) _.
    Next Obligation.
      simpl; intros.
      rewrite (cata_hom_iter_hom i j Hij).
      rewrite Functor.compose.
      2: reflexivity.
      apply cat_assoc.
    Qed.

    Definition cata_hom : fixpoint → AG :=
      colim_univ (has_colimits nat_dirord kleene_chain) AG_cocone.

    Program Definition cata_alg_hom : Alg.alg_hom fixpoint_alg AG :=
      Alg.Alg_hom cata_hom _.
    Next Obligation.
      simpl.
      generalize (colim_uniq BL AG_cocone').
      intros.
      rewrite (H (cata_hom ∘ colim_univ BL cocone_plus1)).
      symmetry. apply H.

      intros. simpl.
      rewrite <- (cat_assoc _ _ _ _ _ (Alg.iota AG)).
      rewrite <- (Functor.compose F). 2: reflexivity.
      apply cat_respects; auto.
      apply Functor.respects.
      unfold cata_hom.
      apply (colim_commute (has_colimits nat_dirord kleene_chain) AG_cocone).

      intros.
      rewrite <- (cat_assoc _ _ _ _ _ cata_hom).
      rewrite <- (colim_commute BL cocone_plus1).
      unfold cata_hom.
      apply (colim_commute (has_colimits nat_dirord kleene_chain) AG_cocone (S i)).
    Qed.
  End cata.

  (**  Now we show that the catamorphims is universal and construct
       the initial algebra.
    *)
  Program Definition fixpoint_initial : Alg.initial_alg C F :=
    Alg.Initial_alg fixpoint_alg cata_alg_hom _.
  Next Obligation.
    simpl; intros.
    unfold cata_hom.
    apply (colim_uniq (has_colimits nat_dirord kleene_chain) (AG_cocone M)).
    intro i. simpl.
    induction i. simpl.
    symmetry. apply initiate_univ.
    simpl.
    rewrite IHi.
    rewrite Functor.compose. 2: reflexivity.
    rewrite (cat_assoc _ _ _ _ _ (Alg.iota M)).
    rewrite <- (Alg.hom_axiom h). simpl.
    repeat rewrite <- (cat_assoc C).
    apply cat_respects; auto.
    symmetry.
    apply (colim_commute BL cocone_plus1).
  Qed.

  (**  With the initial algebra in hand, we immediately
       get an isomorphism via standard facts about initial algebras.
    *)
  Definition fixpoint_iso :
    F fixpoint ↔ fixpoint :=

    Isomorphism C (F fixpoint) fixpoint
      (colim_univ BL cocone_plus1)
      (Alg.out _ F fixpoint_initial)
      (Alg.out_in _ F fixpoint_initial)
      (Alg.in_out _ F fixpoint_initial).

End fixpoint.

(** * Standard continuous functors.

    The identity and constant functors are continuous, as is
    the composition of two continuous functors.

    Pairing and projection functors are also continuous.
 *)

Lemma identF_continuous (C:category) : continuous_functor id(C).
Proof.
  repeat intro.
  apply (DirectedColimit (dir_sys_app DS id(C)) (cocone_app CC id(C))
    (fun YC => colim_univ X (Cocone DS
                 (cocone_point YC) (cocone_spoke YC) (cocone_commute YC)))).
  simpl; intros.
  apply (colim_commute X (Cocone DS
                 (cocone_point YC) (cocone_spoke YC) (cocone_commute YC)) i).
  intros.
  apply (colim_uniq X (Cocone DS
                 (cocone_point YC) (cocone_spoke YC) (cocone_commute YC))); auto.
Qed.

Lemma fconst_continuous (C D:category) (X:ob D) : continuous_functor (fconst C D X).
Proof.
  repeat intro.
  destruct (choose_ub_set I nil) as [j _].
  apply (DirectedColimit
    (dir_sys_app DS (fconst C D X))
    (cocone_app CC (fconst C D X))
    (fun YC => cocone_spoke YC j)); simpl; intros.
  destruct (choose_ub I i j) as [k [??]].
  rewrite (cocone_commute YC i k H). simpl.
  rewrite (cocone_commute YC j k H0). simpl.
  rewrite (cat_ident1 _ _ _ (cocone_spoke YC k)).
  rewrite (cat_ident1 _ _ _ (cocone_spoke YC k)). auto.
  rewrite (H j). symmetry. apply cat_ident1.
Qed.

Lemma composeF_continuous (C D E:category)
  (F:functor D E) (G:functor C D) :
  continuous_functor F ->
  continuous_functor G ->
  continuous_functor (F ∘ G).
Proof.
  repeat intro.
  cut (directed_colimit
    (dir_sys_app (dir_sys_app DS G) F)
    (cocone_app (cocone_app CC G) F)).
  intros.
  apply (DirectedColimit
    (dir_sys_app DS (F∘G)) (cocone_app CC (F∘G))
    (fun YC => colim_univ X2 (Cocone (dir_sys_app (dir_sys_app DS G) F)
                 (cocone_point YC) (cocone_spoke YC) (cocone_commute YC)))).
  simpl; intros.
  apply (colim_commute X2 (Cocone (dir_sys_app (dir_sys_app DS G) F)
                 (cocone_point YC) (cocone_spoke YC) (cocone_commute YC)) i).
  intros.
  apply (colim_uniq X2 (Cocone (dir_sys_app (dir_sys_app DS G) F)
                 (cocone_point YC) (cocone_spoke YC) (cocone_commute YC))); auto.
  apply X. apply X0. auto.
Qed.

Section pairF_continuous.
  Variables C D E:category.
  Variable F:functor C D.
  Variable G:functor C E.

  Section cocones.
    Variable I:directed_preord.
    Variable DS:directed_system I C.

    Program Definition cocone_fstF (YC:cocone (dir_sys_app DS (pairF F G)))
      : cocone (dir_sys_app DS F)
      := Cocone (dir_sys_app DS F)
                (obl (cocone_point YC))
                (fun i => homl (cocone_spoke YC i))
                _.
    Next Obligation.
      simpl; intros.
      destruct (cocone_commute YC i j Hij); auto.
    Qed.

    Program Definition cocone_sndF (YC:cocone (dir_sys_app DS (pairF F G)))
      : cocone (dir_sys_app DS G)
      := Cocone (dir_sys_app DS G)
                (obr (cocone_point YC))
                (fun i => homr (cocone_spoke YC i))
                _.
    Next Obligation.
      simpl; intros.
      destruct (cocone_commute YC i j Hij); auto.
    Qed.
  End cocones.

  Hypothesis HcontF : continuous_functor F.
  Hypothesis HcontG : continuous_functor G.

  Lemma pairF_continuous : continuous_functor (pairF F G).
  Proof.
    repeat intro.
    generalize (HcontF I DS CC X). intro.
    generalize (HcontG I DS CC X). intro.
    apply DirectedColimit with
      (fun YC => PROD.Hom D E
        (PROD.Ob D E (F (cocone_point CC)) (G (cocone_point CC)))
        (cocone_point YC)
        (colim_univ X0 (cocone_fstF I DS YC))
        (colim_univ X1 (cocone_sndF I DS YC))).
    simpl; intros. split; simpl.
    apply (colim_commute X0 (cocone_fstF I DS YC)).
    apply (colim_commute X1 (cocone_sndF I DS YC)).
    simpl; intros. split; simpl.
    apply (colim_uniq X0 (cocone_fstF I DS YC)).
    intro i; destruct (H i); auto.
    apply (colim_uniq X1 (cocone_sndF I DS YC)).
    intro i; destruct (H i); auto.
  Qed.
End pairF_continuous.

Section fstF_continuous.
  Variables C D:category.
  Variable I:directed_preord.
  Variable DS:directed_system I (PROD C D).
  Variable CC:cocone DS.
  Variable Hcolim : directed_colimit DS CC.

  Program Definition fstF_cocone
    (CC1 : cocone (dir_sys_app DS (fstF C D))) : cocone DS
    := Cocone DS (PROD.Ob C D (cocone_point CC1)
                                          (obr (cocone_point CC)))
                 (fun i => PROD.Hom C D _ _
                            (cocone_spoke CC1 i)
                            (homr (cocone_spoke CC i) :
                                 obr (ds_F DS i) → obr (cocone_point CC)))

                 _.
  Next Obligation.
    intros. split; simpl.
    apply (cocone_commute CC1 i).
    apply (cocone_commute CC i).
  Qed.

  Definition fstF_univ (YC : cocone (dir_sys_app DS (fstF C D))) :
    cocone_app CC (fstF C D) → YC :=
    homl (colim_univ Hcolim (fstF_cocone YC)).

  Lemma fstF_continuous' :
    directed_colimit (dir_sys_app DS (fstF C D)) (cocone_app CC (fstF C D)).
  Proof.
    apply DirectedColimit with fstF_univ.
    simpl. intros.
    destruct (colim_commute Hcolim (fstF_cocone YC) i). auto.
    intros.
    destruct (colim_uniq Hcolim (fstF_cocone YC)
      (PROD.Hom C D
         (cocone_point CC)
         (PROD.Ob _ _ (cocone_point YC) (obr (cocone_point CC)))
         f id
         )); auto.
    intros. split; simpl; auto.
    apply H.
    symmetry. apply cat_ident2.
  Qed.
End fstF_continuous.

Lemma fstF_continuous C D :
  continuous_functor (fstF C D).
Proof.
  repeat intro. apply fstF_continuous'; auto.
Qed.

Section sndF_continuous.
  Variables C D:category.
  Variable I:directed_preord.
  Variable DS:directed_system I (PROD C D).
  Variable CC:cocone DS.
  Variable Hcolim : directed_colimit DS CC.

  Program Definition sndF_cocone
    (CC1 : cocone (dir_sys_app DS (sndF C D))) : cocone DS
    := Cocone DS (PROD.Ob C D (obl (cocone_point CC))
                              (cocone_point CC1))
                 (fun i => PROD.Hom C D _ _
                            (homl (cocone_spoke CC i) :
                                 obl (ds_F DS i) → obl (cocone_point CC))
                            (cocone_spoke CC1 i))
                 _.
  Next Obligation.
    intros. split; simpl.
    apply (cocone_commute CC i).
    apply (cocone_commute CC1 i).
  Qed.

  Definition sndF_univ (YC : cocone (dir_sys_app DS (sndF C D))) :
    cocone_app CC (sndF C D) → YC :=
    homr (colim_univ Hcolim (sndF_cocone YC)).

  Lemma sndF_continuous' :
    directed_colimit (dir_sys_app DS (sndF C D)) (cocone_app CC (sndF C D)).
  Proof.
    apply DirectedColimit with sndF_univ.
    simpl. intros.
    destruct (colim_commute Hcolim (sndF_cocone YC) i). auto.
    intros.
    destruct (colim_uniq Hcolim (sndF_cocone YC)
      (PROD.Hom C D
         (cocone_point CC)
         (PROD.Ob _ _ (obl (cocone_point CC)) (cocone_point YC))
         id f)); auto.
    intros. split; simpl; auto.
    symmetry. apply cat_ident2.
    apply H.
  Qed.
End sndF_continuous.

Lemma sndF_continuous C D : continuous_functor (sndF C D).
Proof.
  repeat intro. apply sndF_continuous'; auto.
Qed.


(* Following http://adam.chlipala.net/theses/andreser.pdf chapter 3 *)
Require Import Coq.ZArith.ZArith Coq.micromega.Lia Crypto.Algebra.Nsatz.
Require Import Crypto.Util.Tactics.UniquePose Crypto.Util.Decidable.
Require Import Crypto.Util.Tuple Crypto.Util.Prod Crypto.Util.LetIn.
Require Import Crypto.Util.ListUtil Coq.Lists.List Crypto.Util.NatUtil.
Require Import QArith.QArith_base QArith.Qround Crypto.Util.QUtil.
Require Import Crypto.Algebra.Ring Crypto.Util.Decidable.Bool2Prop.
Import ListNotations. Local Open Scope Z_scope.

Definition runtime_mul := Z.mul.
Definition runtime_add := Z.add.
Declare Scope runtime_scope.
Delimit Scope runtime_scope with RT.
Infix "*" := runtime_mul : runtime_scope.
Infix "+" := runtime_add : runtime_scope.

Module Associational.
  Definition eval (p:list (Z*Z)) : Z :=
    fold_right Z.add 0%Z (map (fun t => fst t * snd t) p).

  Lemma eval_nil : eval nil = 0.
  Proof. trivial.                                             Qed.
  Lemma eval_cons p q : eval (p::q) = fst p * snd p + eval q.
  Proof. trivial.                                             Qed.
  Lemma eval_app p q: eval (p++q) = eval p + eval q.
  Proof. induction p; rewrite <-?List.app_comm_cons;
           rewrite ?eval_nil, ?eval_cons; nsatz.              Qed.

#[global]
  Hint Rewrite eval_nil eval_cons eval_app : push_eval.
  Local Ltac push := autorewrite with
      push_eval push_map push_partition push_flat_map
      push_fold_right push_nth_default cancel_pair.

  Lemma eval_map_mul (a x:Z) (p:list (Z*Z))
  : eval (List.map (fun t => (a*fst t, x*snd t)) p) = a*x*eval p.
  Proof. induction p; push; nsatz.                            Qed.
#[global]
  Hint Rewrite eval_map_mul : push_eval.

  Definition mul (p q:list (Z*Z)) : list (Z*Z) :=
    flat_map (fun t =>
      map (fun t' =>
        (fst t * fst t', (snd t * snd t')%RT))
    q) p.
  Lemma eval_mul p q : eval (mul p q) = eval p * eval q.
  Proof. induction p; cbv [mul]; push; nsatz.                 Qed.
#[global]
  Hint Rewrite eval_mul : push_eval.

  Example base10_2digit_mul (a0:Z) (a1:Z) (b0:Z) (b1:Z) :
    {ab| eval ab = eval [(10,a1);(1,a0)] * eval [(10,b1);(1,b0)]}.
    eexists ?[ab].
    (* Goal: eval ?ab = eval [(10,a1);(1,a0)] * eval [(10,b1);(1,b0)] *)
    rewrite <-eval_mul.
    (* Goal: eval ?ab = eval (mul [(10,a1);(1,a0)] [(10,b1);(1,b0)]) *)
    cbv -[runtime_mul eval].
    (* Goal: eval ?ab = eval [(100,(a1*b1));(10,a1*b0);(10,a0*b1);(1,a0*b0)]%RT *)
    trivial.                                              Defined.

  Definition split (s:Z) (p:list (Z*Z)) : list (Z*Z) * list (Z*Z)
    := let hi_lo := partition (fun t => fst t mod s =? 0) p in
       (snd hi_lo, map (fun t => (fst t / s, snd t)) (fst hi_lo)).
  Lemma eval_split s p (s_nz:s<>0) :
    eval (fst (split s p)) + s * eval (snd (split s p)) = eval p.
  Proof. cbv [split]; induction p;
    repeat match goal with
    | |- context[?a/?b] =>
      unique pose proof (Z_div_exact_full_2 a b ltac:(trivial) ltac:(trivial))
    | _ => progress push
    | _ => progress break_match
    | _ => progress nsatz                                end. Qed.

  Lemma reduction_rule a b s c (modulus_nz:s-c<>0) :
    (a + s * b) mod (s - c) = (a + c * b) mod (s - c).
  Proof. replace (a + s * b) with ((a + c*b) + b*(s-c)) by nsatz.
    rewrite Z.add_mod,Z_mod_mult,Z.add_0_r,Z.mod_mod;trivial. Qed.

  Definition reduce (s:Z) (c:list _) (p:list _) : list (Z*Z) :=
    let lo_hi := split s p in fst lo_hi ++ mul c (snd lo_hi).

  Lemma eval_reduce s c p (s_nz:s<>0) (modulus_nz:s-eval c<>0) :
    eval (reduce s c p) mod (s - eval c) = eval p mod (s - eval c).
  Proof. cbv [reduce]; push.
         rewrite <-reduction_rule, eval_split; trivial.      Qed.
#[global]
  Hint Rewrite eval_reduce : push_eval.
End Associational.

Module Positional. Section Positional.
  Context (weight : nat -> Z)
          (weight_0 : weight 0%nat = 1)
          (weight_nz : forall i, weight i <> 0).

  Definition to_associational {n:nat} (xs:tuple Z n) : list (Z*Z)
    := combine (map weight (List.seq 0 n)) (Tuple.to_list n xs).
  Definition eval {n} x := Associational.eval (@to_associational n x).
  Lemma eval_to_associational {n} x :
    Associational.eval (@to_associational n x) = eval x.
  Proof using Type. trivial.                                             Qed.

  (* SKIP over this: zeros, add_to_nth *)
  Local Ltac push := autorewrite with push_eval push_map distr_length
    push_flat_map push_fold_right push_nth_default cancel_pair natsimplify.
  Program Definition zeros n : tuple Z n
    := Tuple.from_list n (List.map (fun _ => 0) (List.seq 0 n)) _.
  Next Obligation. push; reflexivity. Qed.
  Lemma eval_zeros n : eval (zeros n) = 0.
  Proof using weight_0.
    cbv [eval Associational.eval to_associational zeros];
      rewrite Tuple.to_list_from_list.
    generalize dependent (List.seq 0 n); intro xs.
    induction xs; simpl; nsatz.                               Qed.
  Program Definition add_to_nth {n} i x : tuple Z n -> tuple Z n
    := Tuple.on_tuple (ListUtil.update_nth i (runtime_add x)) _.
  Next Obligation. apply ListUtil.length_update_nth. Defined.
  Lemma eval_add_to_nth {n} (i:nat) (H:(i<n)%nat) (x:Z) (xs:tuple Z n) :
    eval (add_to_nth i x xs) = weight i * x + eval xs.
  Proof using Type.
    cbv [eval to_associational add_to_nth Tuple.on_tuple runtime_add].
    rewrite !Tuple.to_list_from_list.
    rewrite ListUtil.combine_update_nth_r at 1.
    rewrite <-(update_nth_id i (List.combine _ _)) at 2.
    rewrite <-!(ListUtil.splice_nth_equiv_update_nth_update _ _
      (weight 0, 0)) by (push; lia); cbv [ListUtil.splice_nth id].
    repeat match goal with
           | _ => progress push
           | _ => progress break_match
           | _ => progress (apply Zminus_eq; ring_simplify)
           | _ => rewrite <-ListUtil.map_nth_default_always
           end; lia.                                          Qed.
  Hint Rewrite @eval_add_to_nth eval_zeros : push_eval.

  Fixpoint place (t:Z*Z) (i:nat) : nat * Z :=
    if dec (fst t mod weight i = 0)
    then (i, let c := fst t / weight i in (c * snd t)%RT)
    else match i with S i' => place t i' | O => (O, fst t * snd t)%RT end.
  Lemma place_in_range (t:Z*Z) (n:nat) : (fst (place t n) < S n)%nat.
  Proof using Type. induction n; cbv [place] in *; break_match; autorewrite with cancel_pair; try lia. Qed.
  Lemma weight_place t i : weight (fst (place t i)) * snd (place t i) = fst t * snd t.
  Proof using weight_0 weight_nz. induction i; cbv [place] in *; break_match; push;
    repeat match goal with |- context[?a/?b] =>
      unique pose proof (Z_div_exact_full_2 a b ltac:(auto) ltac:(auto))
           end; nsatz.                                        Qed.
  Hint Rewrite weight_place : push_eval.

  Definition from_associational n (p:list (Z*Z)) :=
    List.fold_right (fun t =>
      let p := place t (pred n) in
      add_to_nth (fst p) (snd p)    ) (zeros n) p.
  Lemma eval_from_associational {n} p (n_nz:n<>O) :
    eval (from_associational n p) = Associational.eval p.
  Proof using weight_0 weight_nz. induction p; cbv [from_associational] in *; push; try
  pose proof place_in_range a (pred n); destruct n; cbn [pred] in *; try lia; try nsatz. Qed.
  Hint Rewrite @eval_from_associational : push_eval.

  Section mulmod.
    Context (m:Z) (m_nz:m <> 0) (s:Z) (s_nz:s <> 0)
            (c:list (Z*Z)) (Hm:m = s - Associational.eval c).
    Definition mulmod {n} (a b:tuple Z n) : tuple Z n
      := let a_a := to_associational a in
         let b_a := to_associational b in
         let ab_a := Associational.mul a_a b_a in
         let abm_a := Associational.reduce s c ab_a in
         from_associational n abm_a.
    Lemma eval_mulmod {n} (H:(n<>0)%nat) (f g:tuple Z n) :
      eval (mulmod f g) mod m = (eval f * eval g) mod m.
    Proof using Hm m_nz s_nz weight_0 weight_nz. cbv [mulmod]; rewrite Hm in *; push; trivial.      Qed.
  End mulmod.
End Positional. End Positional.

Import Associational Positional.
Local Coercion Z.of_nat : nat >-> Z.
Local Coercion QArith_base.inject_Z : Z >-> Q.

Definition w (i:nat) : Z := 2^Qceiling((25+1/2)*i).

Example base_25_5_mul (f g:tuple Z 10) :
  { fg : tuple Z 10 | (eval w fg) mod (2^255-19)
                    = (eval w f * eval w g) mod (2^255-19) }.
  (* manually assign names to limbs for pretty-printing *)
  destruct f as [[[[[[[[[f9 f8]f7]f6]f5]f4]f3]f2]f1]f0].
  destruct g as [[[[[[[[[g9 g8]g7]g6]g5]g4]g3]g2]g1]g0].
  eexists ?[fg].
  erewrite <-eval_mulmod with (s:=2^255) (c:=[(1,19)])
      by (try eapply pow_ceil_mul_nat_nonzero; vm_decide).
(*   eval w ?fg mod (2 ^ 255 - 19) = *)
(*   eval w *)
(*     (mulmod w (2^255) [(1, 19)] (f9,f8,f7,f6,f5,f4,f3,f2,f1,f0) *)
(*        (g9,g8,g7,g6,g5,g4,g3,g2,g1,g0)) mod (2^255 - 19) *)
  eapply f_equal2; [|trivial]. eapply f_equal.
(*   ?fg = *)
(*   mulmod w (2 ^ 255) [(1, 19)] (f9, f8, f7, f6, f5, f4, f3, f2, f1, f0) *)
(*     (g9, g8, g7, g6, g5, g4, g3, g2, g1, g0) *)
  cbv -[runtime_mul runtime_add]; cbv [runtime_mul runtime_add].
  ring_simplify_subterms.
(* ?fg =
 (f0*g9+ f1*g8+    f2*g7+    f3*g6+    f4*g5+    f5*g4+    f6*g3+    f7*g2+    f8*g1+    f9*g0,
  f0*g8+ 2*f1*g7+  f2*g6+    2*f3*g5+  f4*g4+    2*f5*g3+  f6*g2+    2*f7*g1+  f8*g0+    38*f9*g9,
  f0*g7+ f1*g6+    f2*g5+    f3*g4+    f4*g3+    f5*g2+    f6*g1+    f7*g0+    19*f8*g9+ 19*f9*g8,
  f0*g6+ 2*f1*g5+  f2*g4+    2*f3*g3+  f4*g2+    2*f5*g1+  f6*g0+    38*f7*g9+ 19*f8*g8+ 38*f9*g7,
  f0*g5+ f1*g4+    f2*g3+    f3*g2+    f4*g1+    f5*g0+    19*f6*g9+ 19*f7*g8+ 19*f8*g7+ 19*f9*g6,
  f0*g4+ 2*f1*g3+  f2*g2+    2*f3*g1+  f4*g0+    38*f5*g9+ 19*f6*g8+ 38*f7*g7+ 19*f8*g6+ 38*f9*g5,
  f0*g3+ f1*g2+    f2*g1+    f3*g0+    19*f4*g9+ 19*f5*g8+ 19*f6*g7+ 19*f7*g6+ 19*f8*g5+ 19*f9*g4,
  f0*g2+ 2*f1*g1+  f2*g0+    38*f3*g9+ 19*f4*g8+ 38*f5*g7+ 19*f6*g6+ 38*f7*g5+ 19*f8*g4+ 38*f9*g3,
  f0*g1+ f1*g0+    19*f2*g9+ 19*f3*g8+ 19*f4*g7+ 19*f5*g6+ 19*f6*g5+ 19*f7*g4+ 19*f8*g3+ 19*f9*g2,
  f0*g0+ 38*f1*g9+ 19*f2*g8+ 38*f3*g7+ 19*f4*g6+ 38*f5*g5+ 19*f6*g4+ 38*f7*g3+ 19*f8*g2+ 38*f9*g1) *)
  trivial.
Defined.

(* Eval cbv on this one would produce an ugly term due to the use of [destruct] *)


(* Check that no constraints on inductive types disappear at subtyping *)

Module Type S.

Record A0 : Type :=  (* Type_i' *)
  i0 {X0 : Type; R0 : X0 -> X0 -> Prop}. (* X0: Type_j' *)

Variable i0' : forall X0 : Type, (X0 -> X0 -> Prop) -> A0.

End S.

Module M.

Record A0 : Type :=  (* Type_i' *)
  i0 {X0 : Type; R0 : X0 -> X0 -> Prop}. (* X0: Type_j' *)

Definition i0' := i0 : forall X0 : Type, (X0 -> X0 -> Prop) -> A0.

End M.

(* The rest of this file formalizes Burali-Forti paradox *)
(* (if the constraint between i0' and A0 is lost, the proof goes through) *)

  Inductive ACC (A : Type) (R : A -> A -> Prop) : A -> Prop :=
      ACC_intro :
        forall x : A, (forall y : A, R y x -> ACC A R y) -> ACC A R x.

  Lemma ACC_nonreflexive :
   forall (A : Type) (R : A -> A -> Prop) (x : A),
   ACC A R x -> R x x -> False.
simple induction 1; intros.
exact (H1 x0 H2 H2).
Qed.

  Definition WF (A : Type) (R : A -> A -> Prop) := forall x : A, ACC A R x.

Section Inverse_Image.

  Variables (A B : Type) (R : B -> B -> Prop) (f : A -> B).

  Definition Rof (x y : A) : Prop := R (f x) (f y).

  Remark ACC_lemma :
   forall y : B, ACC B R y -> forall x : A, y = f x -> ACC A Rof x.
    simple induction 1; intros.
    constructor; intros.
    apply (H1 (f y0)); trivial.
    elim H2 using eq_ind_r; trivial.
    Qed.

  Lemma ACC_inverse_image : forall x : A, ACC B R (f x) -> ACC A Rof x.
    intros; apply (ACC_lemma (f x)); trivial.
    Qed.

  Lemma WF_inverse_image : WF B R -> WF A Rof.
    red in |- *; intros; apply ACC_inverse_image; auto.
    Qed.

End Inverse_Image.

Section Burali_Forti_Paradox.

  Definition morphism (A : Type) (R : A -> A -> Prop)
    (B : Type) (S : B -> B -> Prop) (f : A -> B) :=
    forall x y : A, R x y -> S (f x) (f y).

  (* The hypothesis of the paradox:
     assumes there exists an universal system of notations, i.e:
      - A type A0
      - An injection i0 from relations on any type into A0
      - The proof that i0 is injective modulo morphism
   *)
  Variable A0 : Type.                     (* Type_i *)
  Variable i0 : forall X : Type, (X -> X -> Prop) -> A0. (* X: Type_j *)
  Hypothesis
    inj :
      forall (X1 : Type) (R1 : X1 -> X1 -> Prop) (X2 : Type)
        (R2 : X2 -> X2 -> Prop),
      i0 X1 R1 = i0 X2 R2 -> exists f : X1 -> X2, morphism X1 R1 X2 R2 f.

  (* Embedding of x in y: x and y are images of 2 well founded relations
     R1 and R2, the ordinal of R2 being strictly greater than that of R1.
   *)
  Record emb (x y : A0) : Prop :=
    {X1 : Type;
     R1 : X1 -> X1 -> Prop;
     eqx : x = i0 X1 R1;
     X2 : Type;
     R2 : X2 -> X2 -> Prop;
     eqy : y = i0 X2 R2;
     W2 : WF X2 R2;
     f : X1 -> X2;
     fmorph : morphism X1 R1 X2 R2 f;
     maj : X2;
     majf : forall z : X1, R2 (f z) maj}.

  Lemma emb_trans : forall x y z : A0, emb x y -> emb y z -> emb x z.
intros.
case H; intros.
case H0; intros.
generalize eqx0; clear eqx0.
elim eqy using eq_ind_r; intro.
case (inj _ _ _ _ eqx0); intros.
exists X1 R1 X3 R3 (fun x : X1 => f0 (x0 (f x))) maj0; trivial.
red in |- *; auto.
Defined.

  Lemma ACC_emb :
   forall (X : Type) (R : X -> X -> Prop) (x : X),
   ACC X R x ->
   forall (Y : Type) (S : Y -> Y -> Prop) (f : Y -> X),
   morphism Y S X R f -> (forall y : Y, R (f y) x) -> ACC A0 emb (i0 Y S).
simple induction 1; intros.
constructor; intros.
case H4; intros.
elim eqx using eq_ind_r.
case (inj X2 R2 Y S).
apply sym_eq; assumption.

intros.
apply H1 with (y := f (x1 maj)) (f := fun x : X1 => f (x1 (f0 x)));
 try red in |- *; auto.
Defined.

  (* The embedding relation is well founded *)
  Lemma WF_emb : WF A0 emb.
constructor; intros.
case H; intros.
elim eqx using eq_ind_r.
apply ACC_emb with (X := X2) (R := R2) (x := maj) (f := f); trivial.
Defined.

  (* The following definition enforces Type_j >= Type_i *)
  Definition Omega : A0 := i0 A0 emb.

Section Subsets.

  Variable a : A0.

  (* We define the type of elements of A0 smaller than a w.r.t embedding.
     The Record is in Type, but it is possible to avoid such structure. *)
  Record sub : Type :=  {witness : A0; emb_wit : emb witness a}.

  (* F is its image through i0 *)
  Definition F : A0 := i0 sub (Rof _ _ emb witness).

  (* F is embedded in Omega:
     - the witness projection is a morphism
     - a is an upper bound because emb_wit proves that witness is
       smaller than a.
   *)
  Lemma F_emb_Omega : emb F Omega.
exists sub (Rof _ _ emb witness) A0 emb witness a; trivial.
exact WF_emb.

red in |- *; trivial.

exact emb_wit.
Defined.

End Subsets.

  Definition fsub (a b : A0) (H : emb a b) (x : sub a) :
    sub b := Build_sub _ (witness _ x) (emb_trans _ _ _ (emb_wit _ x) H).

  (* F is a morphism: a < b => F(a) < F(b)
      - the morphism from F(a) to F(b) is fsub above
      - the upper bound is a, which is in F(b) since a < b
   *)
  Lemma F_morphism : morphism A0 emb A0 emb F.
red in |- *; intros.
exists
 (sub x)
   (Rof _ _ emb (witness x))
   (sub y)
   (Rof _ _ emb (witness y))
   (fsub x y H)
   (Build_sub _ x H); trivial.
apply WF_inverse_image.
exact WF_emb.

unfold morphism, Rof, fsub in |- *; simpl in |- *; intros.
trivial.

unfold Rof, fsub in |- *; simpl in |- *; intros.
apply emb_wit.
Defined.

  (* Omega is embedded in itself:
     - F is a morphism
     - Omega is an upper bound of the image of F
   *)
  Lemma Omega_refl : emb Omega Omega.
exists A0 emb A0 emb F Omega; trivial.
exact WF_emb.

exact F_morphism.

exact F_emb_Omega.
Defined.

  (* The paradox is that Omega cannot be embedded in itself, since
     the embedding relation is well founded.
   *)
  Theorem Burali_Forti : False.
apply ACC_nonreflexive with A0 emb Omega.
apply WF_emb.

exact Omega_refl.

Defined.

End Burali_Forti_Paradox.

Import M.

  (* Note: this proof uses a large elimination of A0. *)
  Lemma inj :
   forall (X1 : Type) (R1 : X1 -> X1 -> Prop) (X2 : Type)
     (R2 : X2 -> X2 -> Prop),
   i0' X1 R1 = i0' X2 R2 -> exists f : X1 -> X2, morphism X1 R1 X2 R2 f.
intros.
change
  match i0' X1 R1, i0' X2 R2 with
  | i0 x1 r1, i0 x2 r2 => exists f : _, morphism x1 r1 x2 r2 f
  end in |- *.
case H; simpl in |- *.
exists (fun x : X1 => x).
red in |- *; trivial.
Defined.

(* The following command raises 'Error: Universe Inconsistency'.
   To allow large elimination of A0, i0 must not be a large constructor.
   Hence, the constraint Type_j' < Type_i' is added, which is incompatible
   with the constraint j >= i in the paradox.
*)

  Definition Paradox : False := Burali_Forti A0 i0' inj.