diff options
Diffstat (limited to 'theories/Numbers')
78 files changed, 25643 insertions, 0 deletions
diff --git a/theories/Numbers/AltBinNotations.v b/theories/Numbers/AltBinNotations.v new file mode 100644 index 0000000000..c7e3999691 --- /dev/null +++ b/theories/Numbers/AltBinNotations.v @@ -0,0 +1,69 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** * Alternative Binary Numeral Notations *) + +(** Faster but less safe parsers and printers of [positive], [N], [Z]. *) + +(** By default, literals in types [positive], [N], [Z] are parsed and + printed via the [Numeral Notation] command, by conversion from/to + the [Decimal.int] representation. When working with numbers with + thousands of digits and more, conversion from/to [Decimal.int] can + become significantly slow. If that becomes a problem for your + development, this file provides some alternative [Numeral + Notation] commmands that use [Z] as bridge type. To enable these + commands, just be sure to [Require] this file after other files + defining numeral notations. + + Note: up to Coq 8.8, literals in types [positive], [N], [Z] were + parsed and printed using a native ML library of arbitrary + precision integers named bigint.ml. From 8.9, the default is to + parse and print using a Coq library converting sequences of + digits, hence reducing the amount of ML code to trust. But this + method is slower. This file then gives access to the legacy + method, trading efficiency against a larger ML trust base relying + on bigint.ml. *) + +Require Import BinNums. + +(** [positive] *) + +Definition pos_of_z z := + match z with + | Zpos p => Some p + | _ => None + end. + +Definition pos_to_z p := Zpos p. + +Numeral Notation positive pos_of_z pos_to_z : positive_scope. + +(** [N] *) + +Definition n_of_z z := + match z with + | Z0 => Some N0 + | Zpos p => Some (Npos p) + | Zneg _ => None + end. + +Definition n_to_z n := + match n with + | N0 => Z0 + | Npos p => Zpos p + end. + +Numeral Notation N n_of_z n_to_z : N_scope. + +(** [Z] *) + +Definition z_of_z (z:Z) := z. + +Numeral Notation Z z_of_z z_of_z : Z_scope. diff --git a/theories/Numbers/BinNums.v b/theories/Numbers/BinNums.v new file mode 100644 index 0000000000..247827597a --- /dev/null +++ b/theories/Numbers/BinNums.v @@ -0,0 +1,76 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** * Binary Numerical Datatypes *) + +Set Implicit Arguments. + +(** [positive] is a datatype representing the strictly positive integers + in a binary way. Starting from 1 (represented by [xH]), one can + add a new least significant digit via [xO] (digit 0) or [xI] (digit 1). + Numbers in [positive] will also be denoted using a decimal notation; + e.g. [6%positive] will abbreviate [xO (xI xH)] *) + +Inductive positive : Set := + | xI : positive -> positive + | xO : positive -> positive + | xH : positive. + +Declare Scope positive_scope. +Delimit Scope positive_scope with positive. +Bind Scope positive_scope with positive. +Arguments xO _%positive. +Arguments xI _%positive. + +Register positive as num.pos.type. +Register xI as num.pos.xI. +Register xO as num.pos.xO. +Register xH as num.pos.xH. + +(** [N] is a datatype representing natural numbers in a binary way, + by extending the [positive] datatype with a zero. + Numbers in [N] will also be denoted using a decimal notation; + e.g. [6%N] will abbreviate [Npos (xO (xI xH))] *) + +Inductive N : Set := + | N0 : N + | Npos : positive -> N. + +Declare Scope N_scope. +Delimit Scope N_scope with N. +Bind Scope N_scope with N. +Arguments Npos _%positive. + +Register N as num.N.type. +Register N0 as num.N.N0. +Register Npos as num.N.Npos. + +(** [Z] is a datatype representing the integers in a binary way. + An integer is either zero or a strictly positive number + (coded as a [positive]) or a strictly negative number + (whose opposite is stored as a [positive] value). + Numbers in [Z] will also be denoted using a decimal notation; + e.g. [(-6)%Z] will abbreviate [Zneg (xO (xI xH))] *) + +Inductive Z : Set := + | Z0 : Z + | Zpos : positive -> Z + | Zneg : positive -> Z. + +Declare Scope Z_scope. +Delimit Scope Z_scope with Z. +Bind Scope Z_scope with Z. +Arguments Zpos _%positive. +Arguments Zneg _%positive. + +Register Z as num.Z.type. +Register Z0 as num.Z.Z0. +Register Zpos as num.Z.Zpos. +Register Zneg as num.Z.Zneg. diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v new file mode 100644 index 0000000000..9f718cba65 --- /dev/null +++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v @@ -0,0 +1,432 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(** * Signature and specification of a bounded integer structure *) + +(** This file specifies how to represent [Z/nZ] when [n=2^d], + [d] being the number of digits of these bounded integers. *) + +Set Implicit Arguments. + +Require Import ZArith. +Require Import Znumtheory. +Require Import Zpow_facts. +Require Import DoubleType. + +Local Open Scope Z_scope. + +(** First, a description via an operator record and a spec record. *) + +Module ZnZ. + + #[universes(template)] + Class Ops (t:Type) := MkOps { + + (* Conversion functions with Z *) + digits : positive; + zdigits: t; + to_Z : t -> Z; + of_pos : positive -> N * t; (* Euclidean division by [2^digits] *) + head0 : t -> t; (* number of digits 0 in front of the number *) + tail0 : t -> t; (* number of digits 0 at the bottom of the number *) + + (* Basic numbers *) + zero : t; + one : t; + minus_one : t; (* [2^digits-1], which is equivalent to [-1] *) + + (* Comparison *) + compare : t -> t -> comparison; + eq0 : t -> bool; + + (* Basic arithmetic operations *) + opp_c : t -> carry t; + opp : t -> t; + opp_carry : t -> t; (* the carry is known to be -1 *) + + succ_c : t -> carry t; + add_c : t -> t -> carry t; + add_carry_c : t -> t -> carry t; + succ : t -> t; + add : t -> t -> t; + add_carry : t -> t -> t; + + pred_c : t -> carry t; + sub_c : t -> t -> carry t; + sub_carry_c : t -> t -> carry t; + pred : t -> t; + sub : t -> t -> t; + sub_carry : t -> t -> t; + + mul_c : t -> t -> zn2z t; + mul : t -> t -> t; + square_c : t -> zn2z t; + + (* Special divisions operations *) + div21 : t -> t -> t -> t*t; + div_gt : t -> t -> t * t; (* specialized version of [div] *) + div : t -> t -> t * t; + + modulo_gt : t -> t -> t; (* specialized version of [mod] *) + modulo : t -> t -> t; + + gcd_gt : t -> t -> t; (* specialized version of [gcd] *) + gcd : t -> t -> t; + (* [add_mul_div p i j] is a combination of the [(digits-p)] + low bits of [i] above the [p] high bits of [j]: + [add_mul_div p i j = i*2^p+j/2^(digits-p)] *) + add_mul_div : t -> t -> t -> t; + (* [pos_mod p i] is [i mod 2^p] *) + pos_mod : t -> t -> t; + + is_even : t -> bool; + (* square root *) + sqrt2 : t -> t -> t * carry t; + sqrt : t -> t; + (* bitwise operations *) + lor : t -> t -> t; + land : t -> t -> t; + lxor : t -> t -> t }. + + Section Specs. + Context {t : Type}{ops : Ops t}. + + Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). + + Let wB := base digits. + + Notation "[+| c |]" := + (interp_carry 1 wB to_Z c) (at level 0, c at level 99). + + Notation "[-| c |]" := + (interp_carry (-1) wB to_Z c) (at level 0, c at level 99). + + Notation "[|| x ||]" := + (zn2z_to_Z wB to_Z x) (at level 0, x at level 99). + + Class Specs := MkSpecs { + + (* Conversion functions with Z *) + spec_to_Z : forall x, 0 <= [| x |] < wB; + spec_of_pos : forall p, + Zpos p = (Z.of_N (fst (of_pos p)))*wB + [|(snd (of_pos p))|]; + spec_zdigits : [| zdigits |] = Zpos digits; + spec_more_than_1_digit: 1 < Zpos digits; + + (* Basic numbers *) + spec_0 : [|zero|] = 0; + spec_1 : [|one|] = 1; + spec_m1 : [|minus_one|] = wB - 1; + + (* Comparison *) + spec_compare : forall x y, compare x y = ([|x|] ?= [|y|]); + (* NB: the spec of [eq0] is deliberately partial, + see DoubleCyclic where [eq0 x = true <-> x = W0] *) + spec_eq0 : forall x, eq0 x = true -> [|x|] = 0; + (* Basic arithmetic operations *) + spec_opp_c : forall x, [-|opp_c x|] = -[|x|]; + spec_opp : forall x, [|opp x|] = (-[|x|]) mod wB; + spec_opp_carry : forall x, [|opp_carry x|] = wB - [|x|] - 1; + + spec_succ_c : forall x, [+|succ_c x|] = [|x|] + 1; + spec_add_c : forall x y, [+|add_c x y|] = [|x|] + [|y|]; + spec_add_carry_c : forall x y, [+|add_carry_c x y|] = [|x|] + [|y|] + 1; + spec_succ : forall x, [|succ x|] = ([|x|] + 1) mod wB; + spec_add : forall x y, [|add x y|] = ([|x|] + [|y|]) mod wB; + spec_add_carry : + forall x y, [|add_carry x y|] = ([|x|] + [|y|] + 1) mod wB; + + spec_pred_c : forall x, [-|pred_c x|] = [|x|] - 1; + spec_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|]; + spec_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|] - [|y|] - 1; + spec_pred : forall x, [|pred x|] = ([|x|] - 1) mod wB; + spec_sub : forall x y, [|sub x y|] = ([|x|] - [|y|]) mod wB; + spec_sub_carry : + forall x y, [|sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB; + + spec_mul_c : forall x y, [|| mul_c x y ||] = [|x|] * [|y|]; + spec_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wB; + spec_square_c : forall x, [|| square_c x||] = [|x|] * [|x|]; + + (* Special divisions operations *) + spec_div21 : forall a1 a2 b, + wB/2 <= [|b|] -> + [|a1|] < [|b|] -> + let (q,r) := div21 a1 a2 b in + [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]; + spec_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> + let (q,r) := div_gt a b in + [|a|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]; + spec_div : forall a b, 0 < [|b|] -> + let (q,r) := div a b in + [|a|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]; + + spec_modulo_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> + [|modulo_gt a b|] = [|a|] mod [|b|]; + spec_modulo : forall a b, 0 < [|b|] -> + [|modulo a b|] = [|a|] mod [|b|]; + + spec_gcd_gt : forall a b, [|a|] > [|b|] -> + Zis_gcd [|a|] [|b|] [|gcd_gt a b|]; + spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|]; + + + (* shift operations *) + spec_head00: forall x, [|x|] = 0 -> [|head0 x|] = Zpos digits; + spec_head0 : forall x, 0 < [|x|] -> + wB/ 2 <= 2 ^ ([|head0 x|]) * [|x|] < wB; + spec_tail00: forall x, [|x|] = 0 -> [|tail0 x|] = Zpos digits; + spec_tail0 : forall x, 0 < [|x|] -> + exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|tail0 x|]) ; + spec_add_mul_div : forall x y p, + [|p|] <= Zpos digits -> + [| add_mul_div p x y |] = + ([|x|] * (2 ^ [|p|]) + + [|y|] / (2 ^ ((Zpos digits) - [|p|]))) mod wB; + spec_pos_mod : forall w p, + [|pos_mod p w|] = [|w|] mod (2 ^ [|p|]); + (* sqrt *) + spec_is_even : forall x, + if is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1; + spec_sqrt2 : forall x y, + wB/ 4 <= [|x|] -> + let (s,r) := sqrt2 x y in + [||WW x y||] = [|s|] ^ 2 + [+|r|] /\ + [+|r|] <= 2 * [|s|]; + spec_sqrt : forall x, + [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2; + spec_lor : forall x y, [|lor x y|] = Z.lor [|x|] [|y|]; + spec_land : forall x y, [|land x y|] = Z.land [|x|] [|y|]; + spec_lxor : forall x y, [|lxor x y|] = Z.lxor [|x|] [|y|] + }. + + End Specs. + + Arguments Specs {t} ops. + + (** Generic construction of double words *) + + Section WW. + + Context {t : Type}{ops : Ops t}{specs : Specs ops}. + + Let wB := base digits. + + Definition WO' (eq0:t->bool) zero h := + if eq0 h then W0 else WW h zero. + + Definition WO := Eval lazy beta delta [WO'] in + let eq0 := ZnZ.eq0 in + let zero := ZnZ.zero in + WO' eq0 zero. + + Definition OW' (eq0:t->bool) zero l := + if eq0 l then W0 else WW zero l. + + Definition OW := Eval lazy beta delta [OW'] in + let eq0 := ZnZ.eq0 in + let zero := ZnZ.zero in + OW' eq0 zero. + + Definition WW' (eq0:t->bool) zero h l := + if eq0 h then OW' eq0 zero l else WW h l. + + Definition WW := Eval lazy beta delta [WW' OW'] in + let eq0 := ZnZ.eq0 in + let zero := ZnZ.zero in + WW' eq0 zero. + + Lemma spec_WO : forall h, + zn2z_to_Z wB to_Z (WO h) = (to_Z h)*wB. + Proof. + unfold zn2z_to_Z, WO; simpl; intros. + case_eq (eq0 h); intros. + rewrite (spec_eq0 _ H); auto. + rewrite spec_0; auto with zarith. + Qed. + + Lemma spec_OW : forall l, + zn2z_to_Z wB to_Z (OW l) = to_Z l. + Proof. + unfold zn2z_to_Z, OW; simpl; intros. + case_eq (eq0 l); intros. + rewrite (spec_eq0 _ H); auto. + rewrite spec_0; auto with zarith. + Qed. + + Lemma spec_WW : forall h l, + zn2z_to_Z wB to_Z (WW h l) = (to_Z h)*wB + to_Z l. + Proof. + unfold WW; simpl; intros. + case_eq (eq0 h); intros. + rewrite (spec_eq0 _ H); auto. + fold (OW l). + rewrite spec_OW; auto. + simpl; auto. + Qed. + + End WW. + + (** Injecting [Z] numbers into a cyclic structure *) + + Section Of_Z. + + Context {t : Type}{ops : Ops t}{specs : Specs ops}. + + Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). + + Theorem of_pos_correct: + forall p, Zpos p < base digits -> [|(snd (of_pos p))|] = Zpos p. + Proof. + intros p Hp. + generalize (spec_of_pos p). + case (of_pos p); intros n w1; simpl. + case n; auto with zarith. + intros p1 Hp1; contradict Hp; apply Z.le_ngt. + replace (base digits) with (1 * base digits + 0) by ring. + rewrite Hp1. + apply Z.add_le_mono. + apply Z.mul_le_mono_nonneg; auto with zarith. + case p1; simpl; intros; red; simpl; intros; discriminate. + unfold base; auto with zarith. + case (spec_to_Z w1); auto with zarith. + Qed. + + Definition of_Z z := + match z with + | Zpos p => snd (of_pos p) + | _ => zero + end. + + Theorem of_Z_correct: + forall p, 0 <= p < base digits -> [|of_Z p|] = p. + Proof. + intros p; case p; simpl; try rewrite spec_0; auto. + intros; rewrite of_pos_correct; auto with zarith. + intros p1 (H1, _); contradict H1; apply Z.lt_nge; red; simpl; auto. + Qed. + + End Of_Z. + +End ZnZ. + +(** A modular specification grouping the earlier records. *) + +Module Type CyclicType. + Parameter t : Type. + Declare Instance ops : ZnZ.Ops t. + Declare Instance specs : ZnZ.Specs ops. +End CyclicType. + + +(** A Cyclic structure can be seen as a ring *) + +Module CyclicRing (Import Cyclic : CyclicType). + +Local Notation "[| x |]" := (ZnZ.to_Z x) (at level 0, x at level 99). + +Definition eq (n m : t) := [| n |] = [| m |]. + +Local Infix "==" := eq (at level 70). +Local Notation "0" := ZnZ.zero. +Local Notation "1" := ZnZ.one. +Local Infix "+" := ZnZ.add. +Local Infix "-" := ZnZ.sub. +Local Notation "- x" := (ZnZ.opp x). +Local Infix "*" := ZnZ.mul. +Local Notation wB := (base ZnZ.digits). + +Hint Rewrite ZnZ.spec_0 ZnZ.spec_1 ZnZ.spec_add ZnZ.spec_mul + ZnZ.spec_opp ZnZ.spec_sub + : cyclic. + +Ltac zify := unfold eq in *; autorewrite with cyclic. + +Lemma add_0_l : forall x, 0 + x == x. +Proof. +intros. zify. rewrite Z.add_0_l. +apply Zmod_small. apply ZnZ.spec_to_Z. +Qed. + +Lemma add_comm : forall x y, x + y == y + x. +Proof. +intros. zify. now rewrite Z.add_comm. +Qed. + +Lemma add_assoc : forall x y z, x + (y + z) == x + y + z. +Proof. +intros. zify. now rewrite Zplus_mod_idemp_r, Zplus_mod_idemp_l, Z.add_assoc. +Qed. + +Lemma mul_1_l : forall x, 1 * x == x. +Proof. +intros. zify. rewrite Z.mul_1_l. +apply Zmod_small. apply ZnZ.spec_to_Z. +Qed. + +Lemma mul_comm : forall x y, x * y == y * x. +Proof. +intros. zify. now rewrite Z.mul_comm. +Qed. + +Lemma mul_assoc : forall x y z, x * (y * z) == x * y * z. +Proof. +intros. zify. now rewrite Zmult_mod_idemp_r, Zmult_mod_idemp_l, Z.mul_assoc. +Qed. + +Lemma mul_add_distr_r : forall x y z, (x+y)*z == x*z + y*z. +Proof. +intros. zify. now rewrite <- Zplus_mod, Zmult_mod_idemp_l, Z.mul_add_distr_r. +Qed. + +Lemma add_opp_r : forall x y, x + - y == x-y. +Proof. +intros. zify. rewrite <- Zminus_mod_idemp_r. unfold Z.sub. +destruct (Z.eq_dec ([|y|] mod wB) 0) as [EQ|NEQ]. +rewrite Z_mod_zero_opp_full, EQ, 2 Z.add_0_r; auto. +rewrite Z_mod_nz_opp_full by auto. +rewrite <- Zplus_mod_idemp_r, <- Zminus_mod_idemp_l. +rewrite Z_mod_same_full. simpl. now rewrite Zplus_mod_idemp_r. +Qed. + +Lemma add_opp_diag_r : forall x, x + - x == 0. +Proof. +intros. red. rewrite add_opp_r. zify. now rewrite Z.sub_diag, Zmod_0_l. +Qed. + +Lemma CyclicRing : ring_theory 0 1 ZnZ.add ZnZ.mul ZnZ.sub ZnZ.opp eq. +Proof. +constructor. +exact add_0_l. exact add_comm. exact add_assoc. +exact mul_1_l. exact mul_comm. exact mul_assoc. +exact mul_add_distr_r. +symmetry. apply add_opp_r. +exact add_opp_diag_r. +Qed. + +Definition eqb x y := + match ZnZ.compare x y with Eq => true | _ => false end. + +Lemma eqb_eq : forall x y, eqb x y = true <-> x == y. +Proof. + intros. unfold eqb, eq. + rewrite ZnZ.spec_compare. + case Z.compare_spec; intuition; try discriminate. +Qed. + +Lemma eqb_correct : forall x y, eqb x y = true -> x==y. +Proof. now apply eqb_eq. Qed. + +End CyclicRing. diff --git a/theories/Numbers/Cyclic/Abstract/DoubleType.v b/theories/Numbers/Cyclic/Abstract/DoubleType.v new file mode 100644 index 0000000000..9547a642df --- /dev/null +++ b/theories/Numbers/Cyclic/Abstract/DoubleType.v @@ -0,0 +1,73 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +Set Implicit Arguments. + +Require Import BinInt. +Local Open Scope Z_scope. + +Definition base digits := Z.pow 2 (Zpos digits). +Arguments base digits: simpl never. + +Section Carry. + + Variable A : Type. + + #[universes(template)] + Variant carry := + | C0 : A -> carry + | C1 : A -> carry. + + Definition interp_carry (sign:Z)(B:Z)(interp:A -> Z) c := + match c with + | C0 x => interp x + | C1 x => sign*B + interp x + end. + +End Carry. + +Section Zn2Z. + + Variable znz : Type. + + (** From a type [znz] representing a cyclic structure Z/nZ, + we produce a representation of Z/2nZ by pairs of elements of [znz] + (plus a special case for zero). High half of the new number comes + first. + *) + + #[universes(template)] + Variant zn2z := + | W0 : zn2z + | WW : znz -> znz -> zn2z. + + Definition zn2z_to_Z (wB:Z) (w_to_Z:znz->Z) (x:zn2z) := + match x with + | W0 => 0 + | WW xh xl => w_to_Z xh * wB + w_to_Z xl + end. + +End Zn2Z. + +Arguments W0 {znz}. + +(** From a cyclic representation [w], we iterate the [zn2z] construct + [n] times, gaining the type of binary trees of depth at most [n], + whose leafs are either W0 (if depth < n) or elements of w + (if depth = n). +*) + +Fixpoint word (w:Type) (n:nat) : Type := + match n with + | O => w + | S n => zn2z (word w n) + end. diff --git a/theories/Numbers/Cyclic/Abstract/NZCyclic.v b/theories/Numbers/Cyclic/Abstract/NZCyclic.v new file mode 100644 index 0000000000..64935ffe1a --- /dev/null +++ b/theories/Numbers/Cyclic/Abstract/NZCyclic.v @@ -0,0 +1,221 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Export NZAxioms. +Require Import ZArith. +Require Import Zpow_facts. +Require Import DoubleType. +Require Import CyclicAxioms. + +(** * From [CyclicType] to [NZAxiomsSig] *) + +(** A [Z/nZ] representation given by a module type [CyclicType] + implements [NZAxiomsSig], e.g. the common properties between + N and Z with no ordering. Notice that the [n] in [Z/nZ] is + a power of 2. +*) + +Module NZCyclicAxiomsMod (Import Cyclic : CyclicType) <: NZAxiomsSig. + +Local Open Scope Z_scope. + +Local Notation wB := (base ZnZ.digits). + +Local Notation "[| x |]" := (ZnZ.to_Z x) (at level 0, x at level 99). + +Definition eq (n m : t) := [| n |] = [| m |]. +Definition zero := ZnZ.zero. +Definition one := ZnZ.one. +Definition two := ZnZ.succ ZnZ.one. +Definition succ := ZnZ.succ. +Definition pred := ZnZ.pred. +Definition add := ZnZ.add. +Definition sub := ZnZ.sub. +Definition mul := ZnZ.mul. + +Local Infix "==" := eq (at level 70). +Local Notation "0" := zero. +Local Notation S := succ. +Local Notation P := pred. +Local Infix "+" := add. +Local Infix "-" := sub. +Local Infix "*" := mul. + +Hint Rewrite ZnZ.spec_0 ZnZ.spec_1 ZnZ.spec_succ ZnZ.spec_pred + ZnZ.spec_add ZnZ.spec_mul ZnZ.spec_sub : cyclic. +Ltac zify := + unfold eq, zero, one, two, succ, pred, add, sub, mul in *; + autorewrite with cyclic. +Ltac zcongruence := repeat red; intros; zify; congruence. + +Instance eq_equiv : Equivalence eq. +Proof. +unfold eq. firstorder. +Qed. + +Local Obligation Tactic := zcongruence. + +Program Instance succ_wd : Proper (eq ==> eq) succ. +Program Instance pred_wd : Proper (eq ==> eq) pred. +Program Instance add_wd : Proper (eq ==> eq ==> eq) add. +Program Instance sub_wd : Proper (eq ==> eq ==> eq) sub. +Program Instance mul_wd : Proper (eq ==> eq ==> eq) mul. + +Theorem gt_wB_1 : 1 < wB. +Proof. +unfold base. apply Zpower_gt_1; unfold Z.lt; auto with zarith. +Qed. + +Theorem gt_wB_0 : 0 < wB. +Proof. +pose proof gt_wB_1; auto with zarith. +Qed. + +Lemma one_mod_wB : 1 mod wB = 1. +Proof. +rewrite Zmod_small. reflexivity. split. auto with zarith. apply gt_wB_1. +Qed. + +Lemma succ_mod_wB : forall n : Z, (n + 1) mod wB = ((n mod wB) + 1) mod wB. +Proof. +intro n. rewrite <- one_mod_wB at 2. now rewrite <- Zplus_mod. +Qed. + +Lemma pred_mod_wB : forall n : Z, (n - 1) mod wB = ((n mod wB) - 1) mod wB. +Proof. +intro n. rewrite <- one_mod_wB at 2. now rewrite Zminus_mod. +Qed. + +Lemma NZ_to_Z_mod : forall n, [| n |] mod wB = [| n |]. +Proof. +intro n; rewrite Zmod_small. reflexivity. apply ZnZ.spec_to_Z. +Qed. + +Theorem pred_succ : forall n, P (S n) == n. +Proof. +intro n. zify. +rewrite <- pred_mod_wB. +replace ([| n |] + 1 - 1)%Z with [| n |] by ring. apply NZ_to_Z_mod. +Qed. + +Theorem one_succ : one == succ zero. +Proof. +zify; simpl Z.add. now rewrite one_mod_wB. +Qed. + +Theorem two_succ : two == succ one. +Proof. +reflexivity. +Qed. + +Section Induction. + +Variable A : t -> Prop. +Hypothesis A_wd : Proper (eq ==> iff) A. +Hypothesis A0 : A 0. +Hypothesis AS : forall n, A n <-> A (S n). + (* Below, we use only -> direction *) + +Let B (n : Z) := A (ZnZ.of_Z n). + +Lemma B0 : B 0. +Proof. +unfold B. apply A0. +Qed. + +Lemma BS : forall n : Z, 0 <= n -> n < wB - 1 -> B n -> B (n + 1). +Proof. +intros n H1 H2 H3. +unfold B in *. apply AS in H3. +setoid_replace (ZnZ.of_Z (n + 1)) with (S (ZnZ.of_Z n)). assumption. +zify. +rewrite 2 ZnZ.of_Z_correct; auto with zarith. +symmetry; apply Zmod_small; auto with zarith. +Qed. + +Theorem Zbounded_induction : + (forall Q : Z -> Prop, forall b : Z, + Q 0 -> + (forall n, 0 <= n -> n < b - 1 -> Q n -> Q (n + 1)) -> + forall n, 0 <= n -> n < b -> Q n)%Z. +Proof. +intros Q b Q0 QS. +set (Q' := fun n => (n < b /\ Q n) \/ (b <= n)). +assert (H : forall n, 0 <= n -> Q' n). +apply natlike_rec2; unfold Q'. +destruct (Z.le_gt_cases b 0) as [H | H]. now right. left; now split. +intros n H IH. destruct IH as [[IH1 IH2] | IH]. +destruct (Z.le_gt_cases (b - 1) n) as [H1 | H1]. +right; auto with zarith. +left. split; [auto with zarith | now apply (QS n)]. +right; auto with zarith. +unfold Q' in *; intros n H1 H2. destruct (H n H1) as [[H3 H4] | H3]. +assumption. now apply Z.le_ngt in H3. +Qed. + +Lemma B_holds : forall n : Z, 0 <= n < wB -> B n. +Proof. +intros n [H1 H2]. +apply Zbounded_induction with wB. +apply B0. apply BS. assumption. assumption. +Qed. + +Theorem bi_induction : forall n, A n. +Proof. +intro n. setoid_replace n with (ZnZ.of_Z (ZnZ.to_Z n)). +apply B_holds. apply ZnZ.spec_to_Z. +red. symmetry. apply ZnZ.of_Z_correct. +apply ZnZ.spec_to_Z. +Qed. + +End Induction. + +Theorem add_0_l : forall n, 0 + n == n. +Proof. +intro n. zify. +rewrite Z.add_0_l. apply Zmod_small. apply ZnZ.spec_to_Z. +Qed. + +Theorem add_succ_l : forall n m, (S n) + m == S (n + m). +Proof. +intros n m. zify. +rewrite succ_mod_wB. repeat rewrite Zplus_mod_idemp_l; try apply gt_wB_0. +rewrite <- (Z.add_assoc ([| n |] mod wB) 1 [| m |]). rewrite Zplus_mod_idemp_l. +rewrite (Z.add_comm 1 [| m |]); now rewrite Z.add_assoc. +Qed. + +Theorem sub_0_r : forall n, n - 0 == n. +Proof. +intro n. zify. rewrite Z.sub_0_r. apply NZ_to_Z_mod. +Qed. + +Theorem sub_succ_r : forall n m, n - (S m) == P (n - m). +Proof. +intros n m. zify. rewrite Zminus_mod_idemp_r, Zminus_mod_idemp_l. +now replace ([|n|] - ([|m|] + 1))%Z with ([|n|] - [|m|] - 1)%Z + by ring. +Qed. + +Theorem mul_0_l : forall n, 0 * n == 0. +Proof. +intro n. now zify. +Qed. + +Theorem mul_succ_l : forall n m, (S n) * m == n * m + m. +Proof. +intros n m. zify. rewrite Zplus_mod_idemp_l, Zmult_mod_idemp_l. +now rewrite Z.mul_add_distr_r, Z.mul_1_l. +Qed. + +Definition t := t. + +End NZCyclicAxiomsMod. diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v new file mode 100644 index 0000000000..4b0bda3d44 --- /dev/null +++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v @@ -0,0 +1,2543 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** This library has been deprecated since Coq version 8.10. *) + +(** * Int31 numbers defines indeed a cyclic structure : Z/(2^31)Z *) + +(** +Author: Arnaud Spiwack (+ Pierre Letouzey) +*) + +Require Import List. +Require Import Min. +Require Export Int31. +Require Import Znumtheory. +Require Import Zgcd_alt. +Require Import Zpow_facts. +Require Import CyclicAxioms. +Require Import Lia. + +Local Open Scope nat_scope. +Local Open Scope int31_scope. + +Local Hint Resolve Z.lt_gt Z.div_pos : zarith. + +Section Basics. + + (** * Basic results about [iszero], [shiftl], [shiftr] *) + + Lemma iszero_eq0 : forall x, iszero x = true -> x=0. + Proof. + destruct x; simpl; intros. + repeat + match goal with H:(if ?d then _ else _) = true |- _ => + destruct d; try discriminate + end. + reflexivity. + Qed. + + Lemma iszero_not_eq0 : forall x, iszero x = false -> x<>0. + Proof. + intros x H Eq; rewrite Eq in H; simpl in *; discriminate. + Qed. + + Lemma sneakl_shiftr : forall x, + x = sneakl (firstr x) (shiftr x). + Proof. + destruct x; simpl; auto. + Qed. + + Lemma sneakr_shiftl : forall x, + x = sneakr (firstl x) (shiftl x). + Proof. + destruct x; simpl; auto. + Qed. + + Lemma twice_zero : forall x, + twice x = 0 <-> twice_plus_one x = 1. + Proof. + destruct x; simpl in *; split; + intro H; injection H; intros; subst; auto. + Qed. + + Lemma twice_or_twice_plus_one : forall x, + x = twice (shiftr x) \/ x = twice_plus_one (shiftr x). + Proof. + intros; case_eq (firstr x); intros. + destruct x; simpl in *; rewrite H; auto. + destruct x; simpl in *; rewrite H; auto. + Qed. + + + + (** * Iterated shift to the right *) + + Definition nshiftr x := nat_rect _ x (fun _ => shiftr). + + Lemma nshiftr_S : + forall n x, nshiftr x (S n) = shiftr (nshiftr x n). + Proof. + reflexivity. + Qed. + + Lemma nshiftr_S_tail : + forall n x, nshiftr x (S n) = nshiftr (shiftr x) n. + Proof. + intros n; elim n; simpl; auto. + intros; now f_equal. + Qed. + + Lemma nshiftr_n_0 : forall n, nshiftr 0 n = 0. + Proof. + induction n; simpl; auto. + rewrite IHn; auto. + Qed. + + Lemma nshiftr_size : forall x, nshiftr x size = 0. + Proof. + destruct x; simpl; auto. + Qed. + + Lemma nshiftr_above_size : forall k x, size<=k -> + nshiftr x k = 0. + Proof. + intros. + replace k with ((k-size)+size)%nat by omega. + induction (k-size)%nat; auto. + rewrite nshiftr_size; auto. + simpl; rewrite IHn; auto. + Qed. + + (** * Iterated shift to the left *) + + Definition nshiftl x := nat_rect _ x (fun _ => shiftl). + + Lemma nshiftl_S : + forall n x, nshiftl x (S n) = shiftl (nshiftl x n). + Proof. + reflexivity. + Qed. + + Lemma nshiftl_S_tail : + forall n x, nshiftl x (S n) = nshiftl (shiftl x) n. + Proof. + intros n; elim n; simpl; intros; now f_equal. + Qed. + + Lemma nshiftl_n_0 : forall n, nshiftl 0 n = 0. + Proof. + induction n; simpl; auto. + rewrite IHn; auto. + Qed. + + Lemma nshiftl_size : forall x, nshiftl x size = 0. + Proof. + destruct x; simpl; auto. + Qed. + + Lemma nshiftl_above_size : forall k x, size<=k -> + nshiftl x k = 0. + Proof. + intros. + replace k with ((k-size)+size)%nat by omega. + induction (k-size)%nat; auto. + rewrite nshiftl_size; auto. + simpl; rewrite IHn; auto. + Qed. + + Lemma firstr_firstl : + forall x, firstr x = firstl (nshiftl x (pred size)). + Proof. + destruct x; simpl; auto. + Qed. + + Lemma firstl_firstr : + forall x, firstl x = firstr (nshiftr x (pred size)). + Proof. + destruct x; simpl; auto. + Qed. + + (** More advanced results about [nshiftr] *) + + Lemma nshiftr_predsize_0_firstl : forall x, + nshiftr x (pred size) = 0 -> firstl x = D0. + Proof. + destruct x; compute; intros H; injection H; intros; subst; auto. + Qed. + + Lemma nshiftr_0_propagates : forall n p x, n <= p -> + nshiftr x n = 0 -> nshiftr x p = 0. + Proof. + intros. + replace p with ((p-n)+n)%nat by omega. + induction (p-n)%nat. + simpl; auto. + simpl; rewrite IHn0; auto. + Qed. + + Lemma nshiftr_0_firstl : forall n x, n < size -> + nshiftr x n = 0 -> firstl x = D0. + Proof. + intros. + apply nshiftr_predsize_0_firstl. + apply nshiftr_0_propagates with n; auto; omega. + Qed. + + (** * Some induction principles over [int31] *) + + (** Not used for the moment. Are they really useful ? *) + + Lemma int31_ind_sneakl : forall P : int31->Prop, + P 0 -> + (forall x d, P x -> P (sneakl d x)) -> + forall x, P x. + Proof. + intros. + assert (forall n, n<=size -> P (nshiftr x (size - n))). + induction n; intros. + rewrite nshiftr_size; auto. + rewrite sneakl_shiftr. + apply H0. + change (P (nshiftr x (S (size - S n)))). + replace (S (size - S n))%nat with (size - n)%nat by omega. + apply IHn; omega. + change x with (nshiftr x (size-size)); auto. + Qed. + + Lemma int31_ind_twice : forall P : int31->Prop, + P 0 -> + (forall x, P x -> P (twice x)) -> + (forall x, P x -> P (twice_plus_one x)) -> + forall x, P x. + Proof. + induction x using int31_ind_sneakl; auto. + destruct d; auto. + Qed. + + + (** * Some generic results about [recr] *) + + Section Recr. + + (** [recr] satisfies the fixpoint equation used for its definition. *) + + Variable (A:Type)(case0:A)(caserec:digits->int31->A->A). + + Lemma recr_aux_eqn : forall n x, iszero x = false -> + recr_aux (S n) A case0 caserec x = + caserec (firstr x) (shiftr x) (recr_aux n A case0 caserec (shiftr x)). + Proof. + intros; simpl; rewrite H; auto. + Qed. + + Lemma recr_aux_converges : + forall n p x, n <= size -> n <= p -> + recr_aux n A case0 caserec (nshiftr x (size - n)) = + recr_aux p A case0 caserec (nshiftr x (size - n)). + Proof. + induction n. + simpl minus; intros. + rewrite nshiftr_size; destruct p; simpl; auto. + intros. + destruct p. + inversion H0. + unfold recr_aux; fold recr_aux. + destruct (iszero (nshiftr x (size - S n))); auto. + f_equal. + change (shiftr (nshiftr x (size - S n))) with (nshiftr x (S (size - S n))). + replace (S (size - S n))%nat with (size - n)%nat by omega. + apply IHn; auto with arith. + Qed. + + Lemma recr_eqn : forall x, iszero x = false -> + recr A case0 caserec x = + caserec (firstr x) (shiftr x) (recr A case0 caserec (shiftr x)). + Proof. + intros. + unfold recr. + change x with (nshiftr x (size - size)). + rewrite (recr_aux_converges size (S size)); auto with arith. + rewrite recr_aux_eqn; auto. + Qed. + + (** [recr] is usually equivalent to a variant [recrbis] + written without [iszero] check. *) + + Fixpoint recrbis_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A) + (i:int31) : A := + match n with + | O => case0 + | S next => + let si := shiftr i in + caserec (firstr i) si (recrbis_aux next A case0 caserec si) + end. + + Definition recrbis := recrbis_aux size. + + Hypothesis case0_caserec : caserec D0 0 case0 = case0. + + Lemma recrbis_aux_equiv : forall n x, + recrbis_aux n A case0 caserec x = recr_aux n A case0 caserec x. + Proof. + induction n; simpl; auto; intros. + case_eq (iszero x); intros; [ | f_equal; auto ]. + rewrite (iszero_eq0 _ H); simpl; auto. + replace (recrbis_aux n A case0 caserec 0) with case0; auto. + clear H IHn; induction n; simpl; congruence. + Qed. + + Lemma recrbis_equiv : forall x, + recrbis A case0 caserec x = recr A case0 caserec x. + Proof. + intros; apply recrbis_aux_equiv; auto. + Qed. + + End Recr. + + (** * Incrementation *) + + Section Incr. + + (** Variant of [incr] via [recrbis] *) + + Let Incr (b : digits) (si rec : int31) := + match b with + | D0 => sneakl D1 si + | D1 => sneakl D0 rec + end. + + Definition incrbis_aux n x := recrbis_aux n _ In Incr x. + + Lemma incrbis_aux_equiv : forall x, incrbis_aux size x = incr x. + Proof. + unfold incr, recr, incrbis_aux; fold Incr; intros. + apply recrbis_aux_equiv; auto. + Qed. + + (** Recursive equations satisfied by [incr] *) + + Lemma incr_eqn1 : + forall x, firstr x = D0 -> incr x = twice_plus_one (shiftr x). + Proof. + intros. + case_eq (iszero x); intros. + rewrite (iszero_eq0 _ H0); simpl; auto. + unfold incr; rewrite recr_eqn; fold incr; auto. + rewrite H; auto. + Qed. + + Lemma incr_eqn2 : + forall x, firstr x = D1 -> incr x = twice (incr (shiftr x)). + Proof. + intros. + case_eq (iszero x); intros. + rewrite (iszero_eq0 _ H0) in H; simpl in H; discriminate. + unfold incr; rewrite recr_eqn; fold incr; auto. + rewrite H; auto. + Qed. + + Lemma incr_twice : forall x, incr (twice x) = twice_plus_one x. + Proof. + intros. + rewrite incr_eqn1; destruct x; simpl; auto. + Qed. + + Lemma incr_twice_plus_one_firstl : + forall x, firstl x = D0 -> incr (twice_plus_one x) = twice (incr x). + Proof. + intros. + rewrite incr_eqn2; [ | destruct x; simpl; auto ]. + f_equal; f_equal. + destruct x; simpl in *; rewrite H; auto. + Qed. + + (** The previous result is actually true even without the + constraint on [firstl], but this is harder to prove + (see later). *) + + End Incr. + + (** * Conversion to [Z] : the [phi] function *) + + Section Phi. + + (** Variant of [phi] via [recrbis] *) + + Let Phi := fun b (_:int31) => + match b with D0 => Z.double | D1 => Z.succ_double end. + + Definition phibis_aux n x := recrbis_aux n _ Z0 Phi x. + + Lemma phibis_aux_equiv : forall x, phibis_aux size x = phi x. + Proof. + unfold phi, recr, phibis_aux; fold Phi; intros. + apply recrbis_aux_equiv; auto. + Qed. + + (** Recursive equations satisfied by [phi] *) + + Lemma phi_eqn1 : forall x, firstr x = D0 -> + phi x = Z.double (phi (shiftr x)). + Proof. + intros. + case_eq (iszero x); intros. + rewrite (iszero_eq0 _ H0); simpl; auto. + intros; unfold phi; rewrite recr_eqn; fold phi; auto. + rewrite H; auto. + Qed. + + Lemma phi_eqn2 : forall x, firstr x = D1 -> + phi x = Z.succ_double (phi (shiftr x)). + Proof. + intros. + case_eq (iszero x); intros. + rewrite (iszero_eq0 _ H0) in H; simpl in H; discriminate. + intros; unfold phi; rewrite recr_eqn; fold phi; auto. + rewrite H; auto. + Qed. + + Lemma phi_twice_firstl : forall x, firstl x = D0 -> + phi (twice x) = Z.double (phi x). + Proof. + intros. + rewrite phi_eqn1; auto; [ | destruct x; auto ]. + f_equal; f_equal. + destruct x; simpl in *; rewrite H; auto. + Qed. + + Lemma phi_twice_plus_one_firstl : forall x, firstl x = D0 -> + phi (twice_plus_one x) = Z.succ_double (phi x). + Proof. + intros. + rewrite phi_eqn2; auto; [ | destruct x; auto ]. + f_equal; f_equal. + destruct x; simpl in *; rewrite H; auto. + Qed. + + End Phi. + + (** [phi x] is positive and lower than [2^31] *) + + Lemma phibis_aux_pos : forall n x, (0 <= phibis_aux n x)%Z. + Proof. + induction n. + simpl; unfold phibis_aux; simpl; auto with zarith. + intros. + unfold phibis_aux, recrbis_aux; fold recrbis_aux; + fold (phibis_aux n (shiftr x)). + destruct (firstr x). + specialize IHn with (shiftr x); rewrite Z.double_spec; omega. + specialize IHn with (shiftr x); rewrite Z.succ_double_spec; omega. + Qed. + + Lemma phibis_aux_bounded : + forall n x, n <= size -> + (phibis_aux n (nshiftr x (size-n)) < 2 ^ (Z.of_nat n))%Z. + Proof. + induction n. + simpl minus; unfold phibis_aux; simpl; auto with zarith. + intros. + unfold phibis_aux, recrbis_aux; fold recrbis_aux; + fold (phibis_aux n (shiftr (nshiftr x (size - S n)))). + assert (shiftr (nshiftr x (size - S n)) = nshiftr x (size-n)). + replace (size - n)%nat with (S (size - (S n))) by omega. + simpl; auto. + rewrite H0. + assert (H1 : n <= size) by omega. + specialize (IHn x H1). + set (y:=phibis_aux n (nshiftr x (size - n))) in *. + rewrite Nat2Z.inj_succ, Z.pow_succ_r; auto with zarith. + case_eq (firstr (nshiftr x (size - S n))); intros. + rewrite Z.double_spec; auto with zarith. + rewrite Z.succ_double_spec; auto with zarith. + Qed. + + Lemma phi_nonneg : forall x, (0 <= phi x)%Z. + Proof. + intros. + rewrite <- phibis_aux_equiv. + apply phibis_aux_pos. + Qed. + + Hint Resolve phi_nonneg : zarith. + + Lemma phi_bounded : forall x, (0 <= phi x < 2 ^ (Z.of_nat size))%Z. + Proof. + intros. split; [auto with zarith|]. + rewrite <- phibis_aux_equiv. + change x with (nshiftr x (size-size)). + apply phibis_aux_bounded; auto. + Qed. + + Lemma phibis_aux_lowerbound : + forall n x, firstr (nshiftr x n) = D1 -> + (2 ^ Z.of_nat n <= phibis_aux (S n) x)%Z. + Proof. + induction n. + intros. + unfold nshiftr in H; simpl in *. + unfold phibis_aux, recrbis_aux. + rewrite H, Z.succ_double_spec; omega. + + intros. + remember (S n) as m. + unfold phibis_aux, recrbis_aux; fold recrbis_aux; + fold (phibis_aux m (shiftr x)). + subst m. + rewrite Nat2Z.inj_succ, Z.pow_succ_r; auto with zarith. + assert (2^(Z.of_nat n) <= phibis_aux (S n) (shiftr x))%Z. + apply IHn. + rewrite <- nshiftr_S_tail; auto. + destruct (firstr x). + change (Z.double (phibis_aux (S n) (shiftr x))) with + (2*(phibis_aux (S n) (shiftr x)))%Z. + omega. + rewrite Z.succ_double_spec; omega. + Qed. + + Lemma phi_lowerbound : + forall x, firstl x = D1 -> (2^(Z.of_nat (pred size)) <= phi x)%Z. + Proof. + intros. + generalize (phibis_aux_lowerbound (pred size) x). + rewrite <- firstl_firstr. + change (S (pred size)) with size; auto. + rewrite phibis_aux_equiv; auto. + Qed. + + (** * Equivalence modulo [2^n] *) + + Section EqShiftL. + + (** After killing [n] bits at the left, are the numbers equal ?*) + + Definition EqShiftL n x y := + nshiftl x n = nshiftl y n. + + Lemma EqShiftL_zero : forall x y, EqShiftL O x y <-> x = y. + Proof. + unfold EqShiftL; intros; unfold nshiftl; simpl; split; auto. + Qed. + + Lemma EqShiftL_size : forall k x y, size<=k -> EqShiftL k x y. + Proof. + red; intros; rewrite 2 nshiftl_above_size; auto. + Qed. + + Lemma EqShiftL_le : forall k k' x y, k <= k' -> + EqShiftL k x y -> EqShiftL k' x y. + Proof. + unfold EqShiftL; intros. + replace k' with ((k'-k)+k)%nat by omega. + remember (k'-k)%nat as n. + clear Heqn H k'. + induction n; simpl; auto. + f_equal; auto. + Qed. + + Lemma EqShiftL_firstr : forall k x y, k < size -> + EqShiftL k x y -> firstr x = firstr y. + Proof. + intros. + rewrite 2 firstr_firstl. + f_equal. + apply EqShiftL_le with k; auto. + unfold size. + auto with arith. + Qed. + + Lemma EqShiftL_twice : forall k x y, + EqShiftL k (twice x) (twice y) <-> EqShiftL (S k) x y. + Proof. + intros; unfold EqShiftL. + rewrite 2 nshiftl_S_tail; split; auto. + Qed. + + (** * From int31 to list of digits. *) + + (** Lower (=rightmost) bits comes first. *) + + Definition i2l := recrbis _ nil (fun d _ rec => d::rec). + + Lemma i2l_length : forall x, length (i2l x) = size. + Proof. + intros; reflexivity. + Qed. + + Fixpoint lshiftl l x := + match l with + | nil => x + | d::l => sneakl d (lshiftl l x) + end. + + Definition l2i l := lshiftl l On. + + Lemma l2i_i2l : forall x, l2i (i2l x) = x. + Proof. + destruct x; compute; auto. + Qed. + + Lemma i2l_sneakr : forall x d, + i2l (sneakr d x) = tail (i2l x) ++ d::nil. + Proof. + destruct x; compute; auto. + Qed. + + Lemma i2l_sneakl : forall x d, + i2l (sneakl d x) = d :: removelast (i2l x). + Proof. + destruct x; compute; auto. + Qed. + + Lemma i2l_l2i : forall l, length l = size -> + i2l (l2i l) = l. + Proof. + repeat (destruct l as [ |? l]; [intros; discriminate | ]). + destruct l; [ | intros; discriminate]. + intros _; compute; auto. + Qed. + + Fixpoint cstlist (A:Type)(a:A) n := + match n with + | O => nil + | S n => a::cstlist _ a n + end. + + Lemma i2l_nshiftl : forall n x, n<=size -> + i2l (nshiftl x n) = cstlist _ D0 n ++ firstn (size-n) (i2l x). + Proof. + induction n. + intros. + assert (firstn (size-0) (i2l x) = i2l x). + rewrite <- minus_n_O, <- (i2l_length x). + induction (i2l x); simpl; f_equal; auto. + rewrite H0; clear H0. + reflexivity. + + intros. + rewrite nshiftl_S. + unfold shiftl; rewrite i2l_sneakl. + simpl cstlist. + rewrite <- app_comm_cons; f_equal. + rewrite IHn; [ | omega]. + rewrite removelast_app. + apply f_equal. + replace (size-n)%nat with (S (size - S n))%nat by omega. + rewrite removelast_firstn; auto. + rewrite i2l_length; omega. + generalize (firstn_length (size-n) (i2l x)). + rewrite i2l_length. + intros H0 H1. rewrite H1 in H0. + rewrite min_l in H0 by omega. + simpl length in H0. + omega. + Qed. + + (** [i2l] can be used to define a relation equivalent to [EqShiftL] *) + + Lemma EqShiftL_i2l : forall k x y, + EqShiftL k x y <-> firstn (size-k) (i2l x) = firstn (size-k) (i2l y). + Proof. + intros. + destruct (le_lt_dec size k) as [Hle|Hlt]. + split; intros. + replace (size-k)%nat with O by omega. + unfold firstn; auto. + apply EqShiftL_size; auto. + + unfold EqShiftL. + assert (k <= size) by omega. + split; intros. + assert (i2l (nshiftl x k) = i2l (nshiftl y k)) by (f_equal; auto). + rewrite 2 i2l_nshiftl in H1; auto. + eapply app_inv_head; eauto. + assert (i2l (nshiftl x k) = i2l (nshiftl y k)). + rewrite 2 i2l_nshiftl; auto. + f_equal; auto. + rewrite <- (l2i_i2l (nshiftl x k)), <- (l2i_i2l (nshiftl y k)). + f_equal; auto. + Qed. + + (** This equivalence allows proving easily the following delicate + result *) + + Lemma EqShiftL_twice_plus_one : forall k x y, + EqShiftL k (twice_plus_one x) (twice_plus_one y) <-> EqShiftL (S k) x y. + Proof. + intros. + destruct (le_lt_dec size k) as [Hle|Hlt]. + split; intros; apply EqShiftL_size; auto. + + rewrite 2 EqShiftL_i2l. + unfold twice_plus_one. + rewrite 2 i2l_sneakl. + replace (size-k)%nat with (S (size - S k))%nat by omega. + remember (size - S k)%nat as n. + remember (i2l x) as lx. + remember (i2l y) as ly. + simpl. + rewrite 2 firstn_removelast. + split; intros. + injection H; auto. + f_equal; auto. + subst ly n; rewrite i2l_length; omega. + subst lx n; rewrite i2l_length; omega. + Qed. + + Lemma EqShiftL_shiftr : forall k x y, EqShiftL k x y -> + EqShiftL (S k) (shiftr x) (shiftr y). + Proof. + intros. + destruct (le_lt_dec size (S k)) as [Hle|Hlt]. + apply EqShiftL_size; auto. + case_eq (firstr x); intros. + rewrite <- EqShiftL_twice. + unfold twice; rewrite <- H0. + rewrite <- sneakl_shiftr. + rewrite (EqShiftL_firstr k x y); auto. + rewrite <- sneakl_shiftr; auto. + omega. + rewrite <- EqShiftL_twice_plus_one. + unfold twice_plus_one; rewrite <- H0. + rewrite <- sneakl_shiftr. + rewrite (EqShiftL_firstr k x y); auto. + rewrite <- sneakl_shiftr; auto. + omega. + Qed. + + Lemma EqShiftL_incrbis : forall n k x y, n<=size -> + (n+k=S size)%nat -> + EqShiftL k x y -> + EqShiftL k (incrbis_aux n x) (incrbis_aux n y). + Proof. + induction n; simpl; intros. + red; auto. + destruct (eq_nat_dec k size). + subst k; apply EqShiftL_size; auto. + unfold incrbis_aux; simpl; + fold (incrbis_aux n (shiftr x)); fold (incrbis_aux n (shiftr y)). + + rewrite (EqShiftL_firstr k x y); auto; try omega. + case_eq (firstr y); intros. + rewrite EqShiftL_twice_plus_one. + apply EqShiftL_shiftr; auto. + + rewrite EqShiftL_twice. + apply IHn; try omega. + apply EqShiftL_shiftr; auto. + Qed. + + Lemma EqShiftL_incr : forall x y, + EqShiftL 1 x y -> EqShiftL 1 (incr x) (incr y). + Proof. + intros. + rewrite <- 2 incrbis_aux_equiv. + apply EqShiftL_incrbis; auto. + Qed. + + End EqShiftL. + + (** * More equations about [incr] *) + + Lemma incr_twice_plus_one : + forall x, incr (twice_plus_one x) = twice (incr x). + Proof. + intros. + rewrite incr_eqn2; [ | destruct x; simpl; auto]. + apply EqShiftL_incr. + red; destruct x; simpl; auto. + Qed. + + Lemma incr_firstr : forall x, firstr (incr x) <> firstr x. + Proof. + intros. + case_eq (firstr x); intros. + rewrite incr_eqn1; auto. + destruct (shiftr x); simpl; discriminate. + rewrite incr_eqn2; auto. + destruct (incr (shiftr x)); simpl; discriminate. + Qed. + + Lemma incr_inv : forall x y, + incr x = twice_plus_one y -> x = twice y. + Proof. + intros. + case_eq (iszero x); intros. + rewrite (iszero_eq0 _ H0) in *; simpl in *. + change (incr 0) with 1 in H. + symmetry; rewrite twice_zero; auto. + case_eq (firstr x); intros. + rewrite incr_eqn1 in H; auto. + clear H0; destruct x; destruct y; simpl in *. + injection H; intros; subst; auto. + elim (incr_firstr x). + rewrite H1, H; destruct y; simpl; auto. + Qed. + + (** * Conversion from [Z] : the [phi_inv] function *) + + (** First, recursive equations *) + + Lemma phi_inv_double_plus_one : forall z, + phi_inv (Z.succ_double z) = twice_plus_one (phi_inv z). + Proof. + destruct z; simpl; auto. + induction p; simpl. + rewrite 2 incr_twice; auto. + rewrite incr_twice, incr_twice_plus_one. + f_equal. + apply incr_inv; auto. + auto. + Qed. + + Lemma phi_inv_double : forall z, + phi_inv (Z.double z) = twice (phi_inv z). + Proof. + destruct z; simpl; auto. + rewrite incr_twice_plus_one; auto. + Qed. + + Lemma phi_inv_incr : forall z, + phi_inv (Z.succ z) = incr (phi_inv z). + Proof. + destruct z. + simpl; auto. + simpl; auto. + induction p; simpl; auto. + rewrite <- Pos.add_1_r, IHp, incr_twice_plus_one; auto. + rewrite incr_twice; auto. + simpl; auto. + destruct p; simpl; auto. + rewrite incr_twice; auto. + f_equal. + rewrite incr_twice_plus_one; auto. + induction p; simpl; auto. + rewrite incr_twice; auto. + f_equal. + rewrite incr_twice_plus_one; auto. + Qed. + + (** [phi_inv o inv], the always-exact and easy-to-prove trip : + from int31 to Z and then back to int31. *) + + Lemma phi_inv_phi_aux : + forall n x, n <= size -> + phi_inv (phibis_aux n (nshiftr x (size-n))) = + nshiftr x (size-n). + Proof. + induction n. + intros; simpl minus. + rewrite nshiftr_size; auto. + intros. + unfold phibis_aux, recrbis_aux; fold recrbis_aux; + fold (phibis_aux n (shiftr (nshiftr x (size-S n)))). + assert (shiftr (nshiftr x (size - S n)) = nshiftr x (size-n)). + replace (size - n)%nat with (S (size - (S n))); auto; omega. + rewrite H0. + case_eq (firstr (nshiftr x (size - S n))); intros. + + rewrite phi_inv_double. + rewrite IHn by omega. + rewrite <- H0. + remember (nshiftr x (size - S n)) as y. + destruct y; simpl in H1; rewrite H1; auto. + + rewrite phi_inv_double_plus_one. + rewrite IHn by omega. + rewrite <- H0. + remember (nshiftr x (size - S n)) as y. + destruct y; simpl in H1; rewrite H1; auto. + Qed. + + Lemma phi_inv_phi : forall x, phi_inv (phi x) = x. + Proof. + intros. + rewrite <- phibis_aux_equiv. + replace x with (nshiftr x (size - size)) by auto. + apply phi_inv_phi_aux; auto. + Qed. + + (** The other composition [phi o phi_inv] is harder to prove correct. + In particular, an overflow can happen, so a modulo is needed. + For the moment, we proceed via several steps, the first one + being a detour to [positive_to_in31]. *) + + (** * [positive_to_int31] *) + + (** A variant of [p2i] with [twice] and [twice_plus_one] instead of + [2*i] and [2*i+1] *) + + Fixpoint p2ibis n p : (N*int31)%type := + match n with + | O => (Npos p, On) + | S n => match p with + | xO p => let (r,i) := p2ibis n p in (r, twice i) + | xI p => let (r,i) := p2ibis n p in (r, twice_plus_one i) + | xH => (N0, In) + end + end. + + Lemma p2ibis_bounded : forall n p, + nshiftr (snd (p2ibis n p)) n = 0. + Proof. + induction n. + simpl; intros; auto. + simpl p2ibis; intros. + destruct p; simpl snd. + + specialize IHn with p. + destruct (p2ibis n p). simpl @snd in *. + rewrite nshiftr_S_tail. + destruct (le_lt_dec size n) as [Hle|Hlt]. + rewrite nshiftr_above_size; auto. + assert (H:=nshiftr_0_firstl _ _ Hlt IHn). + replace (shiftr (twice_plus_one i)) with i; auto. + destruct i; simpl in *. rewrite H; auto. + + specialize IHn with p. + destruct (p2ibis n p); simpl @snd in *. + rewrite nshiftr_S_tail. + destruct (le_lt_dec size n) as [Hle|Hlt]. + rewrite nshiftr_above_size; auto. + assert (H:=nshiftr_0_firstl _ _ Hlt IHn). + replace (shiftr (twice i)) with i; auto. + destruct i; simpl in *; rewrite H; auto. + + rewrite nshiftr_S_tail; auto. + replace (shiftr In) with 0; auto. + apply nshiftr_n_0. + Qed. + + Local Open Scope Z_scope. + + Lemma p2ibis_spec : forall n p, (n<=size)%nat -> + Zpos p = (Z.of_N (fst (p2ibis n p)))*2^(Z.of_nat n) + + phi (snd (p2ibis n p)). + Proof. + induction n; intros. + simpl; rewrite Pos.mul_1_r; auto. + replace (2^(Z.of_nat (S n)))%Z with (2*2^(Z.of_nat n))%Z by + (rewrite <- Z.pow_succ_r, <- Zpos_P_of_succ_nat; + auto with zarith). + rewrite (Z.mul_comm 2). + assert (n<=size)%nat by omega. + destruct p; simpl; [ | | auto]; + specialize (IHn p H0); + generalize (p2ibis_bounded n p); + destruct (p2ibis n p) as (r,i); simpl in *; intros. + + change (Zpos p~1) with (2*Zpos p + 1)%Z. + rewrite phi_twice_plus_one_firstl, Z.succ_double_spec. + rewrite IHn; ring. + apply (nshiftr_0_firstl n); auto; try omega. + + change (Zpos p~0) with (2*Zpos p)%Z. + rewrite phi_twice_firstl. + change (Z.double (phi i)) with (2*(phi i))%Z. + rewrite IHn; ring. + apply (nshiftr_0_firstl n); auto; try omega. + Qed. + + (** We now prove that this [p2ibis] is related to [phi_inv_positive] *) + + Lemma phi_inv_positive_p2ibis : forall n p, (n<=size)%nat -> + EqShiftL (size-n) (phi_inv_positive p) (snd (p2ibis n p)). + Proof. + induction n. + intros. + apply EqShiftL_size; auto. + intros. + simpl p2ibis; destruct p; [ | | red; auto]; + specialize IHn with p; + destruct (p2ibis n p); simpl @snd in *; simpl phi_inv_positive; + rewrite ?EqShiftL_twice_plus_one, ?EqShiftL_twice; + replace (S (size - S n))%nat with (size - n)%nat by omega; + apply IHn; omega. + Qed. + + (** This gives the expected result about [phi o phi_inv], at least + for the positive case. *) + + Lemma phi_phi_inv_positive : forall p, + phi (phi_inv_positive p) = (Zpos p) mod (2^(Z.of_nat size)). + Proof. + intros. + replace (phi_inv_positive p) with (snd (p2ibis size p)). + rewrite (p2ibis_spec size p) by auto. + rewrite Z.add_comm, Z_mod_plus. + symmetry; apply Zmod_small. + apply phi_bounded. + auto with zarith. + symmetry. + rewrite <- EqShiftL_zero. + apply (phi_inv_positive_p2ibis size p); auto. + Qed. + + (** Moreover, [p2ibis] is also related with [p2i] and hence with + [positive_to_int31]. *) + + Lemma double_twice_firstl : forall x, firstl x = D0 -> + (Twon*x = twice x)%int31. + Proof. + intros. + unfold mul31. + rewrite <- Z.double_spec, <- phi_twice_firstl, phi_inv_phi; auto. + Qed. + + Lemma double_twice_plus_one_firstl : forall x, firstl x = D0 -> + (Twon*x+In = twice_plus_one x)%int31. + Proof. + intros. + rewrite double_twice_firstl; auto. + unfold add31. + rewrite phi_twice_firstl, <- Z.succ_double_spec, + <- phi_twice_plus_one_firstl, phi_inv_phi; auto. + Qed. + + Lemma p2i_p2ibis : forall n p, (n<=size)%nat -> + p2i n p = p2ibis n p. + Proof. + induction n; simpl; auto; intros. + destruct p; auto; specialize IHn with p; + generalize (p2ibis_bounded n p); + rewrite IHn; try omega; destruct (p2ibis n p); simpl; intros; + f_equal; auto. + apply double_twice_plus_one_firstl. + apply (nshiftr_0_firstl n); auto; omega. + apply double_twice_firstl. + apply (nshiftr_0_firstl n); auto; omega. + Qed. + + Lemma positive_to_int31_phi_inv_positive : forall p, + snd (positive_to_int31 p) = phi_inv_positive p. + Proof. + intros; unfold positive_to_int31. + rewrite p2i_p2ibis; auto. + symmetry. + rewrite <- EqShiftL_zero. + apply (phi_inv_positive_p2ibis size); auto. + Qed. + + Lemma positive_to_int31_spec : forall p, + Zpos p = (Z.of_N (fst (positive_to_int31 p)))*2^(Z.of_nat size) + + phi (snd (positive_to_int31 p)). + Proof. + unfold positive_to_int31. + intros; rewrite p2i_p2ibis; auto. + apply p2ibis_spec; auto. + Qed. + + (** Thanks to the result about [phi o phi_inv_positive], we can + now establish easily the most general results about + [phi o twice] and so one. *) + + Lemma phi_twice : forall x, + phi (twice x) = (Z.double (phi x)) mod 2^(Z.of_nat size). + Proof. + intros. + pattern x at 1; rewrite <- (phi_inv_phi x). + rewrite <- phi_inv_double. + assert (0 <= Z.double (phi x)). + rewrite Z.double_spec; generalize (phi_bounded x); omega. + destruct (Z.double (phi x)). + simpl; auto. + apply phi_phi_inv_positive. + compute in H; elim H; auto. + Qed. + + Lemma phi_twice_plus_one : forall x, + phi (twice_plus_one x) = (Z.succ_double (phi x)) mod 2^(Z.of_nat size). + Proof. + intros. + pattern x at 1; rewrite <- (phi_inv_phi x). + rewrite <- phi_inv_double_plus_one. + assert (0 <= Z.succ_double (phi x)). + rewrite Z.succ_double_spec; generalize (phi_bounded x); omega. + destruct (Z.succ_double (phi x)). + simpl; auto. + apply phi_phi_inv_positive. + compute in H; elim H; auto. + Qed. + + Lemma phi_incr : forall x, + phi (incr x) = (Z.succ (phi x)) mod 2^(Z.of_nat size). + Proof. + intros. + pattern x at 1; rewrite <- (phi_inv_phi x). + rewrite <- phi_inv_incr. + assert (0 <= Z.succ (phi x)). + change (Z.succ (phi x)) with ((phi x)+1)%Z; + generalize (phi_bounded x); omega. + destruct (Z.succ (phi x)). + simpl; auto. + apply phi_phi_inv_positive. + compute in H; elim H; auto. + Qed. + + (** With the previous results, we can deal with [phi o phi_inv] even + in the negative case *) + + Lemma phi_phi_inv_negative : + forall p, phi (incr (complement_negative p)) = (Zneg p) mod 2^(Z.of_nat size). + Proof. + induction p. + + simpl complement_negative. + rewrite phi_incr in IHp. + rewrite incr_twice, phi_twice_plus_one. + remember (phi (complement_negative p)) as q. + rewrite Z.succ_double_spec. + replace (2*q+1) with (2*(Z.succ q)-1) by omega. + rewrite <- Zminus_mod_idemp_l, <- Zmult_mod_idemp_r, IHp. + rewrite Zmult_mod_idemp_r, Zminus_mod_idemp_l; auto with zarith. + + simpl complement_negative. + rewrite incr_twice_plus_one, phi_twice. + remember (phi (incr (complement_negative p))) as q. + rewrite Z.double_spec, IHp, Zmult_mod_idemp_r; auto with zarith. + + simpl; auto. + Qed. + + Lemma phi_phi_inv : + forall z, phi (phi_inv z) = z mod 2 ^ (Z.of_nat size). + Proof. + destruct z. + simpl; auto. + apply phi_phi_inv_positive. + apply phi_phi_inv_negative. + Qed. + +End Basics. + +Instance int31_ops : ZnZ.Ops int31 := +{ + digits := 31%positive; (* number of digits *) + zdigits := 31; (* number of digits *) + to_Z := phi; (* conversion to Z *) + of_pos := positive_to_int31; (* positive -> N*int31 : p => N,i + where p = N*2^31+phi i *) + head0 := head031; (* number of head 0 *) + tail0 := tail031; (* number of tail 0 *) + zero := 0; + one := 1; + minus_one := Tn; (* 2^31 - 1 *) + compare := compare31; + eq0 := fun i => match i ?= 0 with Eq => true | _ => false end; + opp_c := fun i => 0 -c i; + opp := opp31; + opp_carry := fun i => 0-i-1; + succ_c := fun i => i +c 1; + add_c := add31c; + add_carry_c := add31carryc; + succ := fun i => i + 1; + add := add31; + add_carry := fun i j => i + j + 1; + pred_c := fun i => i -c 1; + sub_c := sub31c; + sub_carry_c := sub31carryc; + pred := fun i => i - 1; + sub := sub31; + sub_carry := fun i j => i - j - 1; + mul_c := mul31c; + mul := mul31; + square_c := fun x => x *c x; + div21 := div3121; + div_gt := div31; (* this is supposed to be the special case of + division a/b where a > b *) + div := div31; + modulo_gt := fun i j => let (_,r) := i/j in r; + modulo := fun i j => let (_,r) := i/j in r; + gcd_gt := gcd31; + gcd := gcd31; + add_mul_div := addmuldiv31; + pos_mod := (* modulo 2^p *) + fun p i => + match p ?= 31 with + | Lt => addmuldiv31 p 0 (addmuldiv31 (31-p) i 0) + | _ => i + end; + is_even := + fun i => let (_,r) := i/2 in + match r ?= 0 with Eq => true | _ => false end; + sqrt2 := sqrt312; + sqrt := sqrt31; + lor := lor31; + land := land31; + lxor := lxor31 +}. + +Section Int31_Specs. + + Local Open Scope Z_scope. + + Notation "[| x |]" := (phi x) (at level 0, x at level 99). + + Local Notation wB := (2 ^ (Z.of_nat size)). + + Lemma wB_pos : wB > 0. + Proof. + auto with zarith. + Qed. + + Notation "[+| c |]" := + (interp_carry 1 wB phi c) (at level 0, c at level 99). + + Notation "[-| c |]" := + (interp_carry (-1) wB phi c) (at level 0, c at level 99). + + Notation "[|| x ||]" := + (zn2z_to_Z wB phi x) (at level 0, x at level 99). + + Lemma spec_zdigits : [| 31 |] = 31. + Proof. + reflexivity. + Qed. + + Lemma spec_more_than_1_digit: 1 < 31. + Proof. + auto with zarith. + Qed. + + Lemma spec_0 : [| 0 |] = 0. + Proof. + reflexivity. + Qed. + + Lemma spec_1 : [| 1 |] = 1. + Proof. + reflexivity. + Qed. + + Lemma spec_m1 : [| Tn |] = wB - 1. + Proof. + reflexivity. + Qed. + + Lemma spec_compare : forall x y, + (x ?= y)%int31 = ([|x|] ?= [|y|]). + Proof. reflexivity. Qed. + + (** Addition *) + + Lemma spec_add_c : forall x y, [+|add31c x y|] = [|x|] + [|y|]. + Proof. + intros; unfold add31c, add31, interp_carry; rewrite phi_phi_inv. + generalize (phi_bounded x)(phi_bounded y); intros. + set (X:=[|x|]) in *; set (Y:=[|y|]) in *; clearbody X Y. + + assert ((X+Y) mod wB ?= X+Y <> Eq -> [+|C1 (phi_inv (X+Y))|] = X+Y). + unfold interp_carry; rewrite phi_phi_inv, Z.compare_eq_iff; intros. + destruct (Z_lt_le_dec (X+Y) wB). + contradict H1; auto using Zmod_small with zarith. + rewrite <- (Z_mod_plus_full (X+Y) (-1) wB). + rewrite Zmod_small; lia. + + generalize (Z.compare_eq ((X+Y) mod wB) (X+Y)); intros Heq. + destruct Z.compare; intros; + [ rewrite phi_phi_inv; auto | now apply H1 | now apply H1]. + Qed. + + Lemma spec_succ_c : forall x, [+|add31c x 1|] = [|x|] + 1. + Proof. + intros; apply spec_add_c. + Qed. + + Lemma spec_add_carry_c : forall x y, [+|add31carryc x y|] = [|x|] + [|y|] + 1. + Proof. + intros. + unfold add31carryc, interp_carry; rewrite phi_phi_inv. + generalize (phi_bounded x)(phi_bounded y); intros. + set (X:=[|x|]) in *; set (Y:=[|y|]) in *; clearbody X Y. + + assert ((X+Y+1) mod wB ?= X+Y+1 <> Eq -> [+|C1 (phi_inv (X+Y+1))|] = X+Y+1). + unfold interp_carry; rewrite phi_phi_inv, Z.compare_eq_iff; intros. + destruct (Z_lt_le_dec (X+Y+1) wB). + contradict H1; auto using Zmod_small with zarith. + rewrite <- (Z_mod_plus_full (X+Y+1) (-1) wB). + rewrite Zmod_small; lia. + + generalize (Z.compare_eq ((X+Y+1) mod wB) (X+Y+1)); intros Heq. + destruct Z.compare; intros; + [ rewrite phi_phi_inv; auto | now apply H1 | now apply H1]. + Qed. + + Lemma spec_add : forall x y, [|x+y|] = ([|x|] + [|y|]) mod wB. + Proof. + intros; apply phi_phi_inv. + Qed. + + Lemma spec_add_carry : + forall x y, [|x+y+1|] = ([|x|] + [|y|] + 1) mod wB. + Proof. + unfold add31; intros. + repeat rewrite phi_phi_inv. + apply Zplus_mod_idemp_l. + Qed. + + Lemma spec_succ : forall x, [|x+1|] = ([|x|] + 1) mod wB. + Proof. + intros; rewrite <- spec_1; apply spec_add. + Qed. + + (** Substraction *) + + Lemma spec_sub_c : forall x y, [-|sub31c x y|] = [|x|] - [|y|]. + Proof. + unfold sub31c, sub31, interp_carry; intros. + rewrite phi_phi_inv. + generalize (phi_bounded x)(phi_bounded y); intros. + set (X:=[|x|]) in *; set (Y:=[|y|]) in *; clearbody X Y. + + assert ((X-Y) mod wB ?= X-Y <> Eq -> [-|C1 (phi_inv (X-Y))|] = X-Y). + unfold interp_carry; rewrite phi_phi_inv, Z.compare_eq_iff; intros. + destruct (Z_lt_le_dec (X-Y) 0). + rewrite <- (Z_mod_plus_full (X-Y) 1 wB). + rewrite Zmod_small; lia. + contradict H1; apply Zmod_small; lia. + + generalize (Z.compare_eq ((X-Y) mod wB) (X-Y)); intros Heq. + destruct Z.compare; intros; + [ rewrite phi_phi_inv; auto | now apply H1 | now apply H1]. + Qed. + + Lemma spec_sub_carry_c : forall x y, [-|sub31carryc x y|] = [|x|] - [|y|] - 1. + Proof. + unfold sub31carryc, sub31, interp_carry; intros. + rewrite phi_phi_inv. + generalize (phi_bounded x)(phi_bounded y); intros. + set (X:=[|x|]) in *; set (Y:=[|y|]) in *; clearbody X Y. + + assert ((X-Y-1) mod wB ?= X-Y-1 <> Eq -> [-|C1 (phi_inv (X-Y-1))|] = X-Y-1). + unfold interp_carry; rewrite phi_phi_inv, Z.compare_eq_iff; intros. + destruct (Z_lt_le_dec (X-Y-1) 0). + rewrite <- (Z_mod_plus_full (X-Y-1) 1 wB). + rewrite Zmod_small; lia. + contradict H1; apply Zmod_small; lia. + + generalize (Z.compare_eq ((X-Y-1) mod wB) (X-Y-1)); intros Heq. + destruct Z.compare; intros; + [ rewrite phi_phi_inv; auto | now apply H1 | now apply H1]. + Qed. + + Lemma spec_sub : forall x y, [|x-y|] = ([|x|] - [|y|]) mod wB. + Proof. + intros; apply phi_phi_inv. + Qed. + + Lemma spec_sub_carry : + forall x y, [|x-y-1|] = ([|x|] - [|y|] - 1) mod wB. + Proof. + unfold sub31; intros. + repeat rewrite phi_phi_inv. + apply Zminus_mod_idemp_l. + Qed. + + Lemma spec_opp_c : forall x, [-|sub31c 0 x|] = -[|x|]. + Proof. + intros; apply spec_sub_c. + Qed. + + Lemma spec_opp : forall x, [|0 - x|] = (-[|x|]) mod wB. + Proof. + intros; apply phi_phi_inv. + Qed. + + Lemma spec_opp_carry : forall x, [|0 - x - 1|] = wB - [|x|] - 1. + Proof. + unfold sub31; intros. + repeat rewrite phi_phi_inv. + change [|1|] with 1; change [|0|] with 0. + rewrite <- (Z_mod_plus_full (0-[|x|]) 1 wB). + rewrite Zminus_mod_idemp_l. + rewrite Zmod_small; generalize (phi_bounded x); lia. + Qed. + + Lemma spec_pred_c : forall x, [-|sub31c x 1|] = [|x|] - 1. + Proof. + intros; apply spec_sub_c. + Qed. + + Lemma spec_pred : forall x, [|x-1|] = ([|x|] - 1) mod wB. + Proof. + intros; apply spec_sub. + Qed. + + (** Multiplication *) + + Lemma phi2_phi_inv2 : forall x, [||phi_inv2 x||] = x mod (wB^2). + Proof. + assert (forall z, (z / wB) mod wB * wB + z mod wB = z mod wB ^ 2). + intros. + assert ((z/wB) mod wB = z/wB - (z/wB/wB)*wB). + rewrite (Z_div_mod_eq (z/wB) wB wB_pos) at 2; ring. + assert (z mod wB = z - (z/wB)*wB). + rewrite (Z_div_mod_eq z wB wB_pos) at 2; ring. + rewrite H. + rewrite H0 at 1. + ring_simplify. + rewrite Zdiv_Zdiv; auto with zarith. + rewrite (Z_div_mod_eq z (wB*wB)) at 2; auto with zarith. + change (wB*wB) with (wB^2); ring. + + unfold phi_inv2. + destruct x; unfold zn2z_to_Z; rewrite ?phi_phi_inv; + change base with wB; auto. + Qed. + + Lemma spec_mul_c : forall x y, [|| mul31c x y ||] = [|x|] * [|y|]. + Proof. + unfold mul31c; intros. + rewrite phi2_phi_inv2. + apply Zmod_small. + generalize (phi_bounded x)(phi_bounded y); intros. + change (wB^2) with (wB * wB). + auto using Z.mul_lt_mono_nonneg with zarith. + Qed. + + Lemma spec_mul : forall x y, [|x*y|] = ([|x|] * [|y|]) mod wB. + Proof. + intros; apply phi_phi_inv. + Qed. + + Lemma spec_square_c : forall x, [|| mul31c x x ||] = [|x|] * [|x|]. + Proof. + intros; apply spec_mul_c. + Qed. + + (** Division *) + + Lemma spec_div21 : forall a1 a2 b, + wB/2 <= [|b|] -> + [|a1|] < [|b|] -> + let (q,r) := div3121 a1 a2 b in + [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + Proof. + unfold div3121; intros. + generalize (phi_bounded a1)(phi_bounded a2)(phi_bounded b); intros. + assert ([|b|]>0) by (auto with zarith). + generalize (Z_div_mod (phi2 a1 a2) [|b|] H4) (Z_div_pos (phi2 a1 a2) [|b|] H4). + unfold Z.div; destruct (Z.div_eucl (phi2 a1 a2) [|b|]). + rewrite ?phi_phi_inv. + destruct 1; intros. + unfold phi2 in *. + change base with wB; change base with wB in H5. + change (Z.pow_pos 2 31) with wB; change (Z.pow_pos 2 31) with wB in H. + rewrite H5, Z.mul_comm. + replace (z0 mod wB) with z0 by (symmetry; apply Zmod_small; omega). + replace (z mod wB) with z; auto with zarith. + symmetry; apply Zmod_small. + split. + apply H7; change base with wB; auto with zarith. + apply Z.mul_lt_mono_pos_r with [|b|]; [omega| ]. + rewrite Z.mul_comm. + apply Z.le_lt_trans with ([|b|]*z+z0); [omega| ]. + rewrite <- H5. + apply Z.le_lt_trans with ([|a1|]*wB+(wB-1)); [omega | ]. + replace ([|a1|]*wB+(wB-1)) with (wB*([|a1|]+1)-1) by ring. + assert (wB*([|a1|]+1) <= wB*[|b|]); try omega. + apply Z.mul_le_mono_nonneg; omega. + Qed. + + Lemma spec_div : forall a b, 0 < [|b|] -> + let (q,r) := div31 a b in + [|a|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + Proof. + unfold div31; intros. + assert ([|b|]>0) by (auto with zarith). + generalize (Z_div_mod [|a|] [|b|] H0) (Z_div_pos [|a|] [|b|] H0). + unfold Z.div; destruct (Z.div_eucl [|a|] [|b|]). + rewrite ?phi_phi_inv. + destruct 1; intros. + rewrite H1, Z.mul_comm. + generalize (phi_bounded a)(phi_bounded b); intros. + replace (z0 mod wB) with z0 by (symmetry; apply Zmod_small; omega). + replace (z mod wB) with z; auto with zarith. + symmetry; apply Zmod_small. + split; auto with zarith. + apply Z.le_lt_trans with [|a|]; auto with zarith. + rewrite H1. + apply Z.le_trans with ([|b|]*z); try omega. + rewrite <- (Z.mul_1_l z) at 1. + apply Z.mul_le_mono_nonneg; auto with zarith. + Qed. + + Lemma spec_mod : forall a b, 0 < [|b|] -> + [|let (_,r) := (a/b)%int31 in r|] = [|a|] mod [|b|]. + Proof. + unfold div31; intros. + assert ([|b|]>0) by (auto with zarith). + unfold Z.modulo. + generalize (Z_div_mod [|a|] [|b|] H0). + destruct (Z.div_eucl [|a|] [|b|]). + rewrite ?phi_phi_inv. + destruct 1; intros. + generalize (phi_bounded b); intros. + apply Zmod_small; omega. + Qed. + + Lemma phi_gcd : forall i j, + [|gcd31 i j|] = Zgcdn (2*size) [|j|] [|i|]. + Proof. + unfold gcd31. + induction (2*size)%nat; intros. + reflexivity. + simpl euler. + unfold compare31. + change [|On|] with 0. + generalize (phi_bounded j)(phi_bounded i); intros. + case_eq [|j|]; intros. + simpl; intros. + generalize (Zabs_spec [|i|]); omega. + simpl. rewrite IHn, H1; f_equal. + rewrite spec_mod, H1; auto. + rewrite H1; compute; auto. + rewrite H1 in H; destruct H as [H _]; compute in H; elim H; auto. + Qed. + + Lemma spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd31 a b|]. + Proof. + intros. + rewrite phi_gcd. + apply Zis_gcd_sym. + apply Zgcdn_is_gcd. + unfold Zgcd_bound. + generalize (phi_bounded b). + destruct [|b|]. + unfold size; auto with zarith. + intros (_,H). + cut (Pos.size_nat p <= size)%nat; [ omega | rewrite <- Zpower2_Psize; auto]. + intros (H,_); compute in H; elim H; auto. + Qed. + + Lemma iter_int31_iter_nat : forall A f i a, + iter_int31 i A f a = iter_nat (Z.abs_nat [|i|]) A f a. + Proof. + intros. + unfold iter_int31. + rewrite <- recrbis_equiv; auto; unfold recrbis. + rewrite <- phibis_aux_equiv. + + revert i a; induction size. + simpl; auto. + simpl; intros. + case_eq (firstr i); intros H; rewrite 2 IHn; + unfold phibis_aux; simpl; rewrite ?H; fold (phibis_aux n (shiftr i)); + generalize (phibis_aux_pos n (shiftr i)); intros; + set (z := phibis_aux n (shiftr i)) in *; clearbody z; + rewrite <- nat_rect_plus. + + f_equal. + rewrite Z.double_spec, <- Z.add_diag. + symmetry; apply Zabs2Nat.inj_add; auto with zarith. + + change (iter_nat (S (Z.abs_nat z) + (Z.abs_nat z))%nat A f a = + iter_nat (Z.abs_nat (Z.succ_double z)) A f a); f_equal. + rewrite Z.succ_double_spec, <- Z.add_diag. + rewrite Zabs2Nat.inj_add; auto with zarith. + rewrite Zabs2Nat.inj_add; auto with zarith. + change (Z.abs_nat 1) with 1%nat; omega. + Qed. + + Fixpoint addmuldiv31_alt n i j := + match n with + | O => i + | S n => addmuldiv31_alt n (sneakl (firstl j) i) (shiftl j) + end. + + Lemma addmuldiv31_equiv : forall p x y, + addmuldiv31 p x y = addmuldiv31_alt (Z.abs_nat [|p|]) x y. + Proof. + intros. + unfold addmuldiv31. + rewrite iter_int31_iter_nat. + set (n:=Z.abs_nat [|p|]); clearbody n; clear p. + revert x y; induction n. + simpl; auto. + intros. + simpl addmuldiv31_alt. + replace (S n) with (n+1)%nat by (rewrite plus_comm; auto). + rewrite nat_rect_plus; simpl; auto. + Qed. + + Lemma spec_add_mul_div : forall x y p, [|p|] <= Zpos 31 -> + [| addmuldiv31 p x y |] = + ([|x|] * (2 ^ [|p|]) + [|y|] / (2 ^ ((Zpos 31) - [|p|]))) mod wB. + Proof. + intros. + rewrite addmuldiv31_equiv. + assert ([|p|] = Z.of_nat (Z.abs_nat [|p|])). + rewrite Zabs2Nat.id_abs; symmetry; apply Z.abs_eq. + destruct (phi_bounded p); auto. + rewrite H0; rewrite H0 in H; clear H0; rewrite Zabs2Nat.id. + set (n := Z.abs_nat [|p|]) in *; clearbody n. + assert (n <= 31)%nat. + rewrite Nat2Z.inj_le; auto with zarith. + clear p H; revert x y. + + induction n. + simpl Z.of_nat; intros. + rewrite Z.mul_1_r. + replace ([|y|] / 2^(31-0)) with 0. + rewrite Z.add_0_r. + symmetry; apply Zmod_small; apply phi_bounded. + symmetry; apply Zdiv_small; apply phi_bounded. + + simpl addmuldiv31_alt; intros. + rewrite IHn; [ | omega ]. + case_eq (firstl y); intros. + + rewrite phi_twice, Z.double_spec. + rewrite phi_twice_firstl; auto. + change (Z.double [|y|]) with (2*[|y|]). + rewrite Nat2Z.inj_succ, Z.pow_succ_r; auto with zarith. + rewrite Zplus_mod; rewrite Zmult_mod_idemp_l; rewrite <- Zplus_mod. + f_equal. + f_equal. + ring. + replace (31-Z.of_nat n) with (Z.succ(31-Z.succ(Z.of_nat n))) by ring. + rewrite Z.pow_succ_r, <- Zdiv_Zdiv; auto with zarith. + rewrite Z.mul_comm, Z_div_mult; auto with zarith. + + rewrite phi_twice_plus_one, Z.succ_double_spec. + rewrite phi_twice; auto. + change (Z.double [|y|]) with (2*[|y|]). + rewrite Nat2Z.inj_succ, Z.pow_succ_r; auto with zarith. + rewrite Zplus_mod; rewrite Zmult_mod_idemp_l; rewrite <- Zplus_mod. + rewrite Z.mul_add_distr_r, Z.mul_1_l, <- Z.add_assoc. + f_equal. + f_equal. + ring. + assert ((2*[|y|]) mod wB = 2*[|y|] - wB). + clear - H. symmetry. apply Zmod_unique with 1; [ | ring ]. + generalize (phi_lowerbound _ H) (phi_bounded y). + set (wB' := 2^Z.of_nat (pred size)). + replace wB with (2*wB'); [ omega | ]. + unfold wB'. rewrite <- Z.pow_succ_r, <- Nat2Z.inj_succ by (auto with zarith). + f_equal. + rewrite H1. + replace wB with (2^(Z.of_nat n)*2^(31-Z.of_nat n)) by + (rewrite <- Zpower_exp; auto with zarith; f_equal; unfold size; ring). + unfold Z.sub; rewrite <- Z.mul_opp_l. + rewrite Z_div_plus; auto with zarith. + ring_simplify. + replace (31+-Z.of_nat n) with (Z.succ(31-Z.succ(Z.of_nat n))) by ring. + rewrite Z.pow_succ_r, <- Zdiv_Zdiv; auto with zarith. + rewrite Z.mul_comm, Z_div_mult; auto with zarith. + Qed. + + Lemma shift_unshift_mod_2 : forall n p a, 0 <= p <= n -> + ((a * 2 ^ (n - p)) mod (2^n) / 2 ^ (n - p)) mod (2^n) = + a mod 2 ^ p. + Proof. + intros. + rewrite Zmod_small. + rewrite Zmod_eq by (auto with zarith). + unfold Z.sub at 1. + rewrite Z_div_plus_full_l + by (cut (0 < 2^(n-p)); auto with zarith). + assert (2^n = 2^(n-p)*2^p). + rewrite <- Zpower_exp by (auto with zarith). + replace (n-p+p) with n; auto with zarith. + rewrite H0. + rewrite <- Zdiv_Zdiv, Z_div_mult by (auto with zarith). + rewrite (Z.mul_comm (2^(n-p))), Z.mul_assoc. + rewrite <- Z.mul_opp_l. + rewrite Z_div_mult by (auto with zarith). + symmetry; apply Zmod_eq; auto with zarith. + + remember (a * 2 ^ (n - p)) as b. + destruct (Z_mod_lt b (2^n)); auto with zarith. + split. + apply Z_div_pos; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + apply Z.lt_le_trans with (2^n); auto with zarith. + rewrite <- (Z.mul_1_r (2^n)) at 1. + apply Z.mul_le_mono_nonneg; auto with zarith. + cut (0 < 2 ^ (n-p)); auto with zarith. + Qed. + + Lemma spec_pos_mod : forall w p, + [|ZnZ.pos_mod p w|] = [|w|] mod (2 ^ [|p|]). + Proof. + unfold int31_ops, ZnZ.pos_mod, compare31. + change [|31|] with 31%Z. + assert (forall w p, 31<=p -> [|w|] = [|w|] mod 2^p). + intros. + generalize (phi_bounded w). + symmetry; apply Zmod_small. + split; auto with zarith. + apply Z.lt_le_trans with wB; auto with zarith. + apply Zpower_le_monotone; auto with zarith. + intros. + case_eq ([|p|] ?= 31); intros; + [ apply H; rewrite (Z.compare_eq _ _ H0); auto with zarith | | + apply H; change ([|p|]>31)%Z in H0; auto with zarith ]. + change ([|p|]<31) in H0. + rewrite spec_add_mul_div by auto with zarith. + change [|0|] with 0%Z; rewrite Z.mul_0_l, Z.add_0_l. + generalize (phi_bounded p)(phi_bounded w); intros. + assert (31-[|p|]<wB). + apply Z.le_lt_trans with 31%Z; auto with zarith. + compute; auto. + assert ([|31-p|]=31-[|p|]). + unfold sub31; rewrite phi_phi_inv. + change [|31|] with 31%Z. + apply Zmod_small; auto with zarith. + rewrite spec_add_mul_div by (rewrite H4; auto with zarith). + change [|0|] with 0%Z; rewrite Zdiv_0_l, Z.add_0_r. + rewrite H4. + apply shift_unshift_mod_2; simpl; auto with zarith. + Qed. + + + (** Shift operations *) + + Lemma spec_head00: forall x, [|x|] = 0 -> [|head031 x|] = Zpos 31. + Proof. + intros. + generalize (phi_inv_phi x). + rewrite H; simpl phi_inv. + intros H'; rewrite <- H'. + simpl; auto. + Qed. + + Fixpoint head031_alt n x := + match n with + | O => 0%nat + | S n => match firstl x with + | D0 => S (head031_alt n (shiftl x)) + | D1 => 0%nat + end + end. + + Lemma head031_equiv : + forall x, [|head031 x|] = Z.of_nat (head031_alt size x). + Proof. + intros. + case_eq (iszero x); intros. + rewrite (iszero_eq0 _ H). + simpl; auto. + + unfold head031, recl. + change On with (phi_inv (Z.of_nat (31-size))). + replace (head031_alt size x) with + (head031_alt size x + (31 - size))%nat by auto. + assert (size <= 31)%nat by auto with arith. + + revert x H; induction size; intros. + simpl; auto. + unfold recl_aux; fold recl_aux. + unfold head031_alt; fold head031_alt. + rewrite H. + assert ([|phi_inv (Z.of_nat (31-S n))|] = Z.of_nat (31 - S n)). + rewrite phi_phi_inv. + apply Zmod_small. + split. + change 0 with (Z.of_nat O); apply inj_le; omega. + apply Z.le_lt_trans with (Z.of_nat 31). + apply inj_le; omega. + compute; auto. + case_eq (firstl x); intros; auto. + rewrite plus_Sn_m, plus_n_Sm. + replace (S (31 - S n)) with (31 - n)%nat by omega. + rewrite <- IHn; [ | omega | ]. + f_equal; f_equal. + unfold add31. + rewrite H1. + f_equal. + change [|In|] with 1. + replace (31-n)%nat with (S (31 - S n))%nat by omega. + rewrite Nat2Z.inj_succ; ring. + + clear - H H2. + rewrite (sneakr_shiftl x) in H. + rewrite H2 in H. + case_eq (iszero (shiftl x)); intros; auto. + rewrite (iszero_eq0 _ H0) in H; discriminate. + Qed. + + Lemma phi_nz : forall x, 0 < [|x|] <-> x <> 0%int31. + Proof. + split; intros. + red; intro; subst x; discriminate. + assert ([|x|]<>0%Z). + contradict H. + rewrite <- (phi_inv_phi x); rewrite H; auto. + generalize (phi_bounded x); auto with zarith. + Qed. + + Lemma spec_head0 : forall x, 0 < [|x|] -> + wB/ 2 <= 2 ^ ([|head031 x|]) * [|x|] < wB. + Proof. + intros. + rewrite head031_equiv. + assert (nshiftl x size = 0%int31). + apply nshiftl_size. + revert x H H0. + unfold size at 2 5. + induction size. + simpl Z.of_nat. + intros. + compute in H0; rewrite H0 in H; discriminate. + + intros. + simpl head031_alt. + case_eq (firstl x); intros. + rewrite (Nat2Z.inj_succ (head031_alt n (shiftl x))), Z.pow_succ_r; auto with zarith. + rewrite <- Z.mul_assoc, Z.mul_comm, <- Z.mul_assoc, <-(Z.mul_comm 2). + rewrite <- Z.double_spec, <- (phi_twice_firstl _ H1). + apply IHn. + + rewrite phi_nz; rewrite phi_nz in H; contradict H. + change twice with shiftl in H. + rewrite (sneakr_shiftl x), H1, H; auto. + + rewrite <- nshiftl_S_tail; auto. + + change (2^(Z.of_nat 0)) with 1; rewrite Z.mul_1_l. + generalize (phi_bounded x); unfold size; split; auto with zarith. + change (2^(Z.of_nat 31)/2) with (2^(Z.of_nat (pred size))). + apply phi_lowerbound; auto. + Qed. + + Lemma spec_tail00: forall x, [|x|] = 0 -> [|tail031 x|] = Zpos 31. + Proof. + intros. + generalize (phi_inv_phi x). + rewrite H; simpl phi_inv. + intros H'; rewrite <- H'. + simpl; auto. + Qed. + + Fixpoint tail031_alt n x := + match n with + | O => 0%nat + | S n => match firstr x with + | D0 => S (tail031_alt n (shiftr x)) + | D1 => 0%nat + end + end. + + Lemma tail031_equiv : + forall x, [|tail031 x|] = Z.of_nat (tail031_alt size x). + Proof. + intros. + case_eq (iszero x); intros. + rewrite (iszero_eq0 _ H). + simpl; auto. + + unfold tail031, recr. + change On with (phi_inv (Z.of_nat (31-size))). + replace (tail031_alt size x) with + (tail031_alt size x + (31 - size))%nat by auto. + assert (size <= 31)%nat by auto with arith. + + revert x H; induction size; intros. + simpl; auto. + unfold recr_aux; fold recr_aux. + unfold tail031_alt; fold tail031_alt. + rewrite H. + assert ([|phi_inv (Z.of_nat (31-S n))|] = Z.of_nat (31 - S n)). + rewrite phi_phi_inv. + apply Zmod_small. + split. + change 0 with (Z.of_nat O); apply inj_le; omega. + apply Z.le_lt_trans with (Z.of_nat 31). + apply inj_le; omega. + compute; auto. + case_eq (firstr x); intros; auto. + rewrite plus_Sn_m, plus_n_Sm. + replace (S (31 - S n)) with (31 - n)%nat by omega. + rewrite <- IHn; [ | omega | ]. + f_equal; f_equal. + unfold add31. + rewrite H1. + f_equal. + change [|In|] with 1. + replace (31-n)%nat with (S (31 - S n))%nat by omega. + rewrite Nat2Z.inj_succ; ring. + + clear - H H2. + rewrite (sneakl_shiftr x) in H. + rewrite H2 in H. + case_eq (iszero (shiftr x)); intros; auto. + rewrite (iszero_eq0 _ H0) in H; discriminate. + Qed. + + Lemma spec_tail0 : forall x, 0 < [|x|] -> + exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|tail031 x|]). + Proof. + intros. + rewrite tail031_equiv. + assert (nshiftr x size = 0%int31). + apply nshiftr_size. + revert x H H0. + induction size. + simpl Z.of_nat. + intros. + compute in H0; rewrite H0 in H; discriminate. + + intros. + simpl tail031_alt. + case_eq (firstr x); intros. + rewrite (Nat2Z.inj_succ (tail031_alt n (shiftr x))), Z.pow_succ_r; auto with zarith. + destruct (IHn (shiftr x)) as (y & Hy1 & Hy2). + + rewrite phi_nz; rewrite phi_nz in H; contradict H. + rewrite (sneakl_shiftr x), H1, H; auto. + + rewrite <- nshiftr_S_tail; auto. + + exists y; split; auto. + rewrite phi_eqn1; auto. + rewrite Z.double_spec, Hy2; ring. + + exists [|shiftr x|]. + split. + generalize (phi_bounded (shiftr x)); auto with zarith. + rewrite phi_eqn2; auto. + rewrite Z.succ_double_spec; simpl; ring. + Qed. + + (* Sqrt *) + + (* Direct transcription of an old proof + of a fortran program in boyer-moore *) + + Lemma quotient_by_2 a: a - 1 <= (a/2) + (a/2). + Proof. + case (Z_mod_lt a 2); auto with zarith. + intros H1; rewrite Zmod_eq_full; auto with zarith. + Qed. + + Lemma sqrt_main_trick j k: 0 <= j -> 0 <= k -> + (j * k) + j <= ((j + k)/2 + 1) ^ 2. + Proof. + intros Hj; generalize Hj k; pattern j; apply natlike_ind; + auto; clear k j Hj. + intros _ k Hk; repeat rewrite Z.add_0_l. + apply Z.mul_nonneg_nonneg; generalize (Z_div_pos k 2); auto with zarith. + intros j Hj Hrec _ k Hk; pattern k; apply natlike_ind; auto; clear k Hk. + rewrite Z.mul_0_r, Z.add_0_r, Z.add_0_l. + generalize (sqr_pos (Z.succ j / 2)) (quotient_by_2 (Z.succ j)); + unfold Z.succ. + rewrite Z.pow_2_r, Z.mul_add_distr_r; repeat rewrite Z.mul_add_distr_l. + auto with zarith. + intros k Hk _. + replace ((Z.succ j + Z.succ k) / 2) with ((j + k)/2 + 1). + generalize (Hrec Hj k Hk) (quotient_by_2 (j + k)). + unfold Z.succ; repeat rewrite Z.pow_2_r; + repeat rewrite Z.mul_add_distr_r; repeat rewrite Z.mul_add_distr_l. + repeat rewrite Z.mul_1_l; repeat rewrite Z.mul_1_r. + auto with zarith. + rewrite Z.add_comm, <- Z_div_plus_full_l; auto with zarith. + apply f_equal2 with (f := Z.div); auto with zarith. + Qed. + + Lemma sqrt_main i j: 0 <= i -> 0 < j -> i < ((j + (i/j))/2 + 1) ^ 2. + Proof. + intros Hi Hj. + assert (Hij: 0 <= i/j) by (apply Z_div_pos; auto with zarith). + apply Z.lt_le_trans with (2 := sqrt_main_trick _ _ (Z.lt_le_incl _ _ Hj) Hij). + pattern i at 1; rewrite (Z_div_mod_eq i j); case (Z_mod_lt i j); auto with zarith. + Qed. + + Lemma sqrt_init i: 1 < i -> i < (i/2 + 1) ^ 2. + Proof. + intros Hi. + assert (H1: 0 <= i - 2) by auto with zarith. + assert (H2: 1 <= (i / 2) ^ 2); auto with zarith. + replace i with (1* 2 + (i - 2)); auto with zarith. + rewrite Z.pow_2_r, Z_div_plus_full_l; auto with zarith. + generalize (sqr_pos ((i - 2)/ 2)) (Z_div_pos (i - 2) 2). + rewrite Z.mul_add_distr_r; repeat rewrite Z.mul_add_distr_l. + auto with zarith. + generalize (quotient_by_2 i). + rewrite Z.pow_2_r in H2 |- *; + repeat (rewrite Z.mul_add_distr_r || + rewrite Z.mul_add_distr_l || + rewrite Z.mul_1_l || rewrite Z.mul_1_r). + auto with zarith. + Qed. + + Lemma sqrt_test_true i j: 0 <= i -> 0 < j -> i/j >= j -> j ^ 2 <= i. + Proof. + intros Hi Hj Hd; rewrite Z.pow_2_r. + apply Z.le_trans with (j * (i/j)); auto with zarith. + apply Z_mult_div_ge; auto with zarith. + Qed. + + Lemma sqrt_test_false i j: 0 <= i -> 0 < j -> i/j < j -> (j + (i/j))/2 < j. + Proof. + intros Hi Hj H; case (Z.le_gt_cases j ((j + (i/j))/2)); auto. + intros H1; contradict H; apply Z.le_ngt. + assert (2 * j <= j + (i/j)); auto with zarith. + apply Z.le_trans with (2 * ((j + (i/j))/2)); auto with zarith. + apply Z_mult_div_ge; auto with zarith. + Qed. + + Lemma sqrt31_step_def rec i j: + sqrt31_step rec i j = + match (fst (i/j) ?= j)%int31 with + Lt => rec i (fst ((j + fst(i/j))/2))%int31 + | _ => j + end. + Proof. + unfold sqrt31_step; case div31; intros. + simpl; case compare31; auto. + Qed. + + Lemma div31_phi i j: 0 < [|j|] -> [|fst (i/j)%int31|] = [|i|]/[|j|]. + intros Hj; generalize (spec_div i j Hj). + case div31; intros q r; simpl @fst. + intros (H1,H2); apply Zdiv_unique with [|r|]; auto with zarith. + rewrite H1; ring. + Qed. + + Lemma sqrt31_step_correct rec i j: + 0 < [|i|] -> 0 < [|j|] -> [|i|] < ([|j|] + 1) ^ 2 -> + 2 * [|j|] < wB -> + (forall j1 : int31, + 0 < [|j1|] < [|j|] -> [|i|] < ([|j1|] + 1) ^ 2 -> + [|rec i j1|] ^ 2 <= [|i|] < ([|rec i j1|] + 1) ^ 2) -> + [|sqrt31_step rec i j|] ^ 2 <= [|i|] < ([|sqrt31_step rec i j|] + 1) ^ 2. + Proof. + assert (Hp2: 0 < [|2|]) by exact (eq_refl Lt). + intros Hi Hj Hij H31 Hrec; rewrite sqrt31_step_def. + rewrite spec_compare, div31_phi; auto. + case Z.compare_spec; auto; intros Hc; + try (split; auto; apply sqrt_test_true; auto with zarith; fail). + assert (E : [|(j + fst (i / j)%int31)|] = [|j|] + [|i|] / [|j|]). + { rewrite spec_add, div31_phi; auto using Z.mod_small with zarith. } + apply Hrec; rewrite !div31_phi, E; auto using sqrt_main with zarith. + split; try apply sqrt_test_false; auto with zarith. + apply Z.le_succ_l in Hj. change (1 <= [|j|]) in Hj. + Z.le_elim Hj. + - replace ([|j|] + [|i|]/[|j|]) with + (1 * 2 + (([|j|] - 2) + [|i|] / [|j|])) by ring. + rewrite Z_div_plus_full_l; auto with zarith. + assert (0 <= [|i|]/ [|j|]) by auto with zarith. + assert (0 <= ([|j|] - 2 + [|i|] / [|j|]) / [|2|]); auto with zarith. + - rewrite <- Hj, Zdiv_1_r. + replace (1 + [|i|]) with (1 * 2 + ([|i|] - 1)) by ring. + rewrite Z_div_plus_full_l; auto with zarith. + assert (0 <= ([|i|] - 1) /2) by auto with zarith. + change ([|2|]) with 2; auto with zarith. + Qed. + + Lemma iter31_sqrt_correct n rec i j: 0 < [|i|] -> 0 < [|j|] -> + [|i|] < ([|j|] + 1) ^ 2 -> 2 * [|j|] < 2 ^ (Z.of_nat size) -> + (forall j1, 0 < [|j1|] -> 2^(Z.of_nat n) + [|j1|] <= [|j|] -> + [|i|] < ([|j1|] + 1) ^ 2 -> 2 * [|j1|] < 2 ^ (Z.of_nat size) -> + [|rec i j1|] ^ 2 <= [|i|] < ([|rec i j1|] + 1) ^ 2) -> + [|iter31_sqrt n rec i j|] ^ 2 <= [|i|] < ([|iter31_sqrt n rec i j|] + 1) ^ 2. + Proof. + revert rec i j; elim n; unfold iter31_sqrt; fold iter31_sqrt; clear n. + intros rec i j Hi Hj Hij H31 Hrec; apply sqrt31_step_correct; auto with zarith. + intros; apply Hrec; auto with zarith. + rewrite Z.pow_0_r; auto with zarith. + intros n Hrec rec i j Hi Hj Hij H31 HHrec. + apply sqrt31_step_correct; auto. + intros j1 Hj1 Hjp1; apply Hrec; auto with zarith. + intros j2 Hj2 H2j2 Hjp2 Hj31; apply Hrec; auto with zarith. + intros j3 Hj3 Hpj3. + apply HHrec; auto. + rewrite Nat2Z.inj_succ, Z.pow_succ_r. + apply Z.le_trans with (2 ^Z.of_nat n + [|j2|]); auto with zarith. + apply Nat2Z.is_nonneg. + Qed. + + Lemma spec_sqrt : forall x, + [|sqrt31 x|] ^ 2 <= [|x|] < ([|sqrt31 x|] + 1) ^ 2. + Proof. + intros i; unfold sqrt31. + rewrite spec_compare. case Z.compare_spec; change [|1|] with 1; + intros Hi; auto with zarith. + repeat rewrite Z.pow_2_r; auto with zarith. + apply iter31_sqrt_correct; auto with zarith. + rewrite div31_phi; change ([|2|]) with 2; auto with zarith. + replace ([|i|]) with (1 * 2 + ([|i|] - 2))%Z; try ring. + assert (0 <= ([|i|] - 2)/2)%Z by (apply Z_div_pos; auto with zarith). + rewrite Z_div_plus_full_l; auto with zarith. + rewrite div31_phi; change ([|2|]) with 2; auto with zarith. + apply sqrt_init; auto. + rewrite div31_phi; change ([|2|]) with 2; auto with zarith. + apply Z.le_lt_trans with ([|i|]). + apply Z_mult_div_ge; auto with zarith. + case (phi_bounded i); auto. + intros j2 H1 H2; contradict H2; apply Z.lt_nge. + rewrite div31_phi; change ([|2|]) with 2; auto with zarith. + apply Z.le_lt_trans with ([|i|]); auto with zarith. + assert (0 <= [|i|]/2)%Z by (apply Z_div_pos; auto with zarith). + apply Z.le_trans with (2 * ([|i|]/2)); auto with zarith. + apply Z_mult_div_ge; auto with zarith. + case (phi_bounded i); unfold size; auto with zarith. + change [|0|] with 0; auto with zarith. + case (phi_bounded i); repeat rewrite Z.pow_2_r; auto with zarith. + Qed. + + Lemma sqrt312_step_def rec ih il j: + sqrt312_step rec ih il j = + match (ih ?= j)%int31 with + Eq => j + | Gt => j + | _ => + match (fst (div3121 ih il j) ?= j)%int31 with + Lt => let m := match j +c fst (div3121 ih il j) with + C0 m1 => fst (m1/2)%int31 + | C1 m1 => (fst (m1/2) + v30)%int31 + end in rec ih il m + | _ => j + end + end. + Proof. + unfold sqrt312_step; case div3121; intros. + simpl; case compare31; auto. + Qed. + + Lemma sqrt312_lower_bound ih il j: + phi2 ih il < ([|j|] + 1) ^ 2 -> [|ih|] <= [|j|]. + Proof. + intros H1. + case (phi_bounded j); intros Hbj _. + case (phi_bounded il); intros Hbil _. + case (phi_bounded ih); intros Hbih Hbih1. + assert ([|ih|] < [|j|] + 1); auto with zarith. + apply Z.square_lt_simpl_nonneg; auto with zarith. + rewrite <- ?Z.pow_2_r; apply Z.le_lt_trans with (2 := H1). + apply Z.le_trans with ([|ih|] * wB). + - rewrite ? Z.pow_2_r; auto with zarith. + - unfold phi2. change base with wB; auto with zarith. + Qed. + + Lemma div312_phi ih il j: (2^30 <= [|j|] -> [|ih|] < [|j|] -> + [|fst (div3121 ih il j)|] = phi2 ih il/[|j|])%Z. + Proof. + intros Hj Hj1. + generalize (spec_div21 ih il j Hj Hj1). + case div3121; intros q r (Hq, Hr). + apply Zdiv_unique with (phi r); auto with zarith. + simpl @fst; apply eq_trans with (1 := Hq); ring. + Qed. + + Lemma sqrt312_step_correct rec ih il j: + 2 ^ 29 <= [|ih|] -> 0 < [|j|] -> phi2 ih il < ([|j|] + 1) ^ 2 -> + (forall j1, 0 < [|j1|] < [|j|] -> phi2 ih il < ([|j1|] + 1) ^ 2 -> + [|rec ih il j1|] ^ 2 <= phi2 ih il < ([|rec ih il j1|] + 1) ^ 2) -> + [|sqrt312_step rec ih il j|] ^ 2 <= phi2 ih il + < ([|sqrt312_step rec ih il j|] + 1) ^ 2. + Proof. + assert (Hp2: (0 < [|2|])%Z) by exact (eq_refl Lt). + intros Hih Hj Hij Hrec; rewrite sqrt312_step_def. + assert (H1: ([|ih|] <= [|j|])) by (apply sqrt312_lower_bound with il; auto). + case (phi_bounded ih); intros Hih1 _. + case (phi_bounded il); intros Hil1 _. + case (phi_bounded j); intros _ Hj1. + assert (Hp3: (0 < phi2 ih il)). + { unfold phi2; apply Z.lt_le_trans with ([|ih|] * base); auto with zarith. + apply Z.mul_pos_pos; auto with zarith. + apply Z.lt_le_trans with (2:= Hih); auto with zarith. } + rewrite spec_compare. case Z.compare_spec; intros Hc1. + - split; auto. + apply sqrt_test_true; auto. + + unfold phi2, base; auto with zarith. + + unfold phi2; rewrite Hc1. + assert (0 <= [|il|]/[|j|]) by (apply Z_div_pos; auto with zarith). + rewrite Z.mul_comm, Z_div_plus_full_l; auto with zarith. + change base with wB. auto with zarith. + - case (Z.le_gt_cases (2 ^ 30) [|j|]); intros Hjj. + + rewrite spec_compare; case Z.compare_spec; + rewrite div312_phi; auto; intros Hc; + try (split; auto; apply sqrt_test_true; auto with zarith; fail). + apply Hrec. + * assert (Hf1: 0 <= phi2 ih il/ [|j|]) by auto with zarith. + apply Z.le_succ_l in Hj. change (1 <= [|j|]) in Hj. + Z.le_elim Hj; + [ | contradict Hc; apply Z.le_ngt; + rewrite <- Hj, Zdiv_1_r; auto with zarith ]. + assert (Hf3: 0 < ([|j|] + phi2 ih il / [|j|]) / 2). + { replace ([|j|] + phi2 ih il/ [|j|]) with + (1 * 2 + (([|j|] - 2) + phi2 ih il / [|j|])); try ring. + rewrite Z_div_plus_full_l; auto with zarith. + assert (0 <= ([|j|] - 2 + phi2 ih il / [|j|]) / 2) ; + auto with zarith. } + assert (Hf4: ([|j|] + phi2 ih il / [|j|]) / 2 < [|j|]). + { apply sqrt_test_false; auto with zarith. } + generalize (spec_add_c j (fst (div3121 ih il j))). + unfold interp_carry; case add31c; intros r; + rewrite div312_phi; auto with zarith. + { rewrite div31_phi; change [|2|] with 2; auto with zarith. + intros HH; rewrite HH; clear HH; auto with zarith. } + { rewrite spec_add, div31_phi; change [|2|] with 2; auto. + rewrite Z.mul_1_l; intros HH. + rewrite Z.add_comm, <- Z_div_plus_full_l; auto with zarith. + change (phi v30 * 2) with (2 ^ Z.of_nat size). + rewrite HH, Zmod_small; auto with zarith. } + * replace (phi _) with (([|j|] + (phi2 ih il)/([|j|]))/2); + [ apply sqrt_main; auto with zarith | ]. + generalize (spec_add_c j (fst (div3121 ih il j))). + unfold interp_carry; case add31c; intros r; + rewrite div312_phi; auto with zarith. + { rewrite div31_phi; auto with zarith. + intros HH; rewrite HH; auto with zarith. } + { intros HH; rewrite <- HH. + change (1 * 2 ^ Z.of_nat size) with (phi (v30) * 2). + rewrite Z_div_plus_full_l; auto with zarith. + rewrite Z.add_comm. + rewrite spec_add, Zmod_small. + - rewrite div31_phi; auto. + - split; auto with zarith. + + case (phi_bounded (fst (r/2)%int31)); + case (phi_bounded v30); auto with zarith. + + rewrite div31_phi; change (phi 2) with 2; auto. + change (2 ^Z.of_nat size) with (base/2 + phi v30). + assert (phi r / 2 < base/2); auto with zarith. + apply Z.mul_lt_mono_pos_r with 2; auto with zarith. + change (base/2 * 2) with base. + apply Z.le_lt_trans with (phi r). + * rewrite Z.mul_comm; apply Z_mult_div_ge; auto with zarith. + * case (phi_bounded r); auto with zarith. } + + contradict Hij; apply Z.le_ngt. + assert ((1 + [|j|]) <= 2 ^ 30); auto with zarith. + apply Z.le_trans with ((2 ^ 30) * (2 ^ 30)); auto with zarith. + * assert (0 <= 1 + [|j|]); auto with zarith. + apply Z.mul_le_mono_nonneg; auto with zarith. + * change ((2 ^ 30) * (2 ^ 30)) with ((2 ^ 29) * base). + apply Z.le_trans with ([|ih|] * base); + change wB with base in *; auto with zarith. + unfold phi2, base; auto with zarith. + - split; auto. + apply sqrt_test_true; auto. + + unfold phi2, base; auto with zarith. + + apply Z.le_ge; apply Z.le_trans with (([|j|] * base)/[|j|]). + * rewrite Z.mul_comm, Z_div_mult; auto with zarith. + * apply Z.ge_le; apply Z_div_ge; auto with zarith. + Qed. + + Lemma iter312_sqrt_correct n rec ih il j: + 2^29 <= [|ih|] -> 0 < [|j|] -> phi2 ih il < ([|j|] + 1) ^ 2 -> + (forall j1, 0 < [|j1|] -> 2^(Z.of_nat n) + [|j1|] <= [|j|] -> + phi2 ih il < ([|j1|] + 1) ^ 2 -> + [|rec ih il j1|] ^ 2 <= phi2 ih il < ([|rec ih il j1|] + 1) ^ 2) -> + [|iter312_sqrt n rec ih il j|] ^ 2 <= phi2 ih il + < ([|iter312_sqrt n rec ih il j|] + 1) ^ 2. + Proof. + revert rec ih il j; elim n; unfold iter312_sqrt; fold iter312_sqrt; clear n. + intros rec ih il j Hi Hj Hij Hrec; apply sqrt312_step_correct; auto with zarith. + intros; apply Hrec; auto with zarith. + rewrite Z.pow_0_r; auto with zarith. + intros n Hrec rec ih il j Hi Hj Hij HHrec. + apply sqrt312_step_correct; auto. + intros j1 Hj1 Hjp1; apply Hrec; auto with zarith. + intros j2 Hj2 H2j2 Hjp2; apply Hrec; auto with zarith. + intros j3 Hj3 Hpj3. + apply HHrec; auto. + rewrite Nat2Z.inj_succ, Z.pow_succ_r. + apply Z.le_trans with (2 ^Z.of_nat n + [|j2|]); auto with zarith. + apply Nat2Z.is_nonneg. + Qed. + + (* Avoid expanding [iter312_sqrt] before variables in the context. *) + Strategy 1 [iter312_sqrt]. + + Lemma spec_sqrt2 : forall x y, + wB/ 4 <= [|x|] -> + let (s,r) := sqrt312 x y in + [||WW x y||] = [|s|] ^ 2 + [+|r|] /\ + [+|r|] <= 2 * [|s|]. + Proof. + intros ih il Hih; unfold sqrt312. + change [||WW ih il||] with (phi2 ih il). + assert (Hbin: forall s, s * s + 2* s + 1 = (s + 1) ^ 2) by + (intros s; ring). + assert (Hb: 0 <= base) by (red; intros HH; discriminate). + assert (Hi2: phi2 ih il < (phi Tn + 1) ^ 2). + { change ((phi Tn + 1) ^ 2) with (2^62). + apply Z.le_lt_trans with ((2^31 -1) * base + (2^31 - 1)); auto with zarith. + 2: simpl; unfold Z.pow_pos; simpl; auto with zarith. + case (phi_bounded ih); case (phi_bounded il); intros H1 H2 H3 H4. + unfold base, Z.pow, Z.pow_pos in H2,H4; simpl in H2,H4. + unfold phi2. cbn [Z.pow Z.pow_pos Pos.iter]. auto with zarith. } + case (iter312_sqrt_correct 31 (fun _ _ j => j) ih il Tn); auto with zarith. + change [|Tn|] with 2147483647; auto with zarith. + intros j1 _ HH; contradict HH. + apply Z.lt_nge. + change [|Tn|] with 2147483647; auto with zarith. + change (2 ^ Z.of_nat 31) with 2147483648; auto with zarith. + case (phi_bounded j1); auto with zarith. + set (s := iter312_sqrt 31 (fun _ _ j : int31 => j) ih il Tn). + intros Hs1 Hs2. + generalize (spec_mul_c s s); case mul31c. + simpl zn2z_to_Z; intros HH. + assert ([|s|] = 0). + { symmetry in HH. rewrite Z.mul_eq_0 in HH. destruct HH; auto. } + contradict Hs2; apply Z.le_ngt; rewrite H. + change ((0 + 1) ^ 2) with 1. + apply Z.le_trans with (2 ^ Z.of_nat size / 4 * base). + simpl; auto with zarith. + apply Z.le_trans with ([|ih|] * base); auto with zarith. + unfold phi2; case (phi_bounded il); auto with zarith. + intros ih1 il1. + change [||WW ih1 il1||] with (phi2 ih1 il1). + intros Hihl1. + generalize (spec_sub_c il il1). + case sub31c; intros il2 Hil2. + rewrite spec_compare; case Z.compare_spec. + unfold interp_carry in *. + intros H1; split. + rewrite Z.pow_2_r, <- Hihl1. + unfold phi2; ring[Hil2 H1]. + replace [|il2|] with (phi2 ih il - phi2 ih1 il1). + rewrite Hihl1. + rewrite <-Hbin in Hs2; auto with zarith. + unfold phi2; rewrite H1, Hil2; ring. + unfold interp_carry. + intros H1; contradict Hs1. + apply Z.lt_nge; rewrite Z.pow_2_r, <-Hihl1. + unfold phi2. + case (phi_bounded il); intros _ H2. + apply Z.lt_le_trans with (([|ih|] + 1) * base + 0). + rewrite Z.mul_add_distr_r, Z.add_0_r; auto with zarith. + case (phi_bounded il1); intros H3 _. + apply Z.add_le_mono; auto with zarith. + unfold interp_carry in *; change (1 * 2 ^ Z.of_nat size) with base. + rewrite Z.pow_2_r, <- Hihl1, Hil2. + intros H1. + rewrite <- Z.le_succ_l, <- Z.add_1_r in H1. + Z.le_elim H1. + contradict Hs2; apply Z.le_ngt. + replace (([|s|] + 1) ^ 2) with (phi2 ih1 il1 + 2 * [|s|] + 1). + unfold phi2. + case (phi_bounded il); intros Hpil _. + assert (Hl1l: [|il1|] <= [|il|]). + { case (phi_bounded il2); rewrite Hil2; auto with zarith. } + assert ([|ih1|] * base + 2 * [|s|] + 1 <= [|ih|] * base); auto with zarith. + case (phi_bounded s); change (2 ^ Z.of_nat size) with base; intros _ Hps. + case (phi_bounded ih1); intros Hpih1 _; auto with zarith. + apply Z.le_trans with (([|ih1|] + 2) * base); auto with zarith. + rewrite Z.mul_add_distr_r. + assert (2 * [|s|] + 1 <= 2 * base); auto with zarith. + rewrite Hihl1, Hbin; auto. + split. + unfold phi2; rewrite <- H1; ring. + replace (base + ([|il|] - [|il1|])) with (phi2 ih il - ([|s|] * [|s|])). + rewrite <-Hbin in Hs2; auto with zarith. + rewrite <- Hihl1; unfold phi2; rewrite <- H1; ring. + unfold interp_carry in Hil2 |- *. + unfold interp_carry; change (1 * 2 ^ Z.of_nat size) with base. + assert (Hsih: [|ih - 1|] = [|ih|] - 1). + { rewrite spec_sub, Zmod_small; auto; change [|1|] with 1. + case (phi_bounded ih); intros H1 H2. + generalize Hih; change (2 ^ Z.of_nat size / 4) with 536870912. + split; auto with zarith. } + rewrite spec_compare; case Z.compare_spec. + rewrite Hsih. + intros H1; split. + rewrite Z.pow_2_r, <- Hihl1. + unfold phi2; rewrite <-H1. + transitivity ([|ih|] * base + [|il1|] + ([|il|] - [|il1|])). + ring. + rewrite <-Hil2. + change (2 ^ Z.of_nat size) with base; ring. + replace [|il2|] with (phi2 ih il - phi2 ih1 il1). + rewrite Hihl1. + rewrite <-Hbin in Hs2; auto with zarith. + unfold phi2. + rewrite <-H1. + ring_simplify. + transitivity (base + ([|il|] - [|il1|])). + ring. + rewrite <-Hil2. + change (2 ^ Z.of_nat size) with base; ring. + rewrite Hsih; intros H1. + assert (He: [|ih|] = [|ih1|]). + { apply Z.le_antisymm; auto with zarith. + case (Z.le_gt_cases [|ih1|] [|ih|]); auto; intros H2. + contradict Hs1; apply Z.lt_nge; rewrite Z.pow_2_r, <-Hihl1. + unfold phi2. + case (phi_bounded il); change (2 ^ Z.of_nat size) with base; + intros _ Hpil1. + apply Z.lt_le_trans with (([|ih|] + 1) * base). + rewrite Z.mul_add_distr_r, Z.mul_1_l; auto with zarith. + case (phi_bounded il1); intros Hpil2 _. + apply Z.le_trans with (([|ih1|]) * base); auto with zarith. } + rewrite Z.pow_2_r, <-Hihl1; unfold phi2; rewrite <-He. + contradict Hs1; apply Z.lt_nge; rewrite Z.pow_2_r, <-Hihl1. + unfold phi2; rewrite He. + assert (phi il - phi il1 < 0); auto with zarith. + rewrite <-Hil2. + case (phi_bounded il2); auto with zarith. + intros H1. + rewrite Z.pow_2_r, <-Hihl1. + assert (H2 : [|ih1|]+2 <= [|ih|]); auto with zarith. + Z.le_elim H2. + contradict Hs2; apply Z.le_ngt. + replace (([|s|] + 1) ^ 2) with (phi2 ih1 il1 + 2 * [|s|] + 1). + unfold phi2. + assert ([|ih1|] * base + 2 * phi s + 1 <= [|ih|] * base + ([|il|] - [|il1|])); + auto with zarith. + rewrite <-Hil2. + change (-1 * 2 ^ Z.of_nat size) with (-base). + case (phi_bounded il2); intros Hpil2 _. + apply Z.le_trans with ([|ih|] * base + - base); auto with zarith. + case (phi_bounded s); change (2 ^ Z.of_nat size) with base; intros _ Hps. + assert (2 * [|s|] + 1 <= 2 * base); auto with zarith. + apply Z.le_trans with ([|ih1|] * base + 2 * base); auto with zarith. + assert (Hi: ([|ih1|] + 3) * base <= [|ih|] * base); auto with zarith. + rewrite Z.mul_add_distr_r in Hi; auto with zarith. + rewrite Hihl1, Hbin; auto. + unfold phi2; rewrite <-H2. + split. + replace [|il|] with (([|il|] - [|il1|]) + [|il1|]); try ring. + rewrite <-Hil2. + change (-1 * 2 ^ Z.of_nat size) with (-base); ring. + replace (base + [|il2|]) with (phi2 ih il - phi2 ih1 il1). + rewrite Hihl1. + rewrite <-Hbin in Hs2; auto with zarith. + unfold phi2; rewrite <-H2. + replace [|il|] with (([|il|] - [|il1|]) + [|il1|]); try ring. + rewrite <-Hil2. + change (-1 * 2 ^ Z.of_nat size) with (-base); ring. +Qed. + + (** [iszero] *) + + Lemma spec_eq0 : forall x, ZnZ.eq0 x = true -> [|x|] = 0. + Proof. + clear; unfold ZnZ.eq0, int31_ops. + unfold compare31; intros. + change [|0|] with 0 in H. + apply Z.compare_eq. + now destruct ([|x|] ?= 0). + Qed. + + (* Even *) + + Lemma spec_is_even : forall x, + if ZnZ.is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1. + Proof. + unfold ZnZ.is_even, int31_ops; intros. + generalize (spec_div x 2). + destruct (x/2)%int31 as (q,r); intros. + unfold compare31. + change [|2|] with 2 in H. + change [|0|] with 0. + destruct H; auto with zarith. + replace ([|x|] mod 2) with [|r|]. + destruct H; auto with zarith. + case Z.compare_spec; auto with zarith. + apply Zmod_unique with [|q|]; auto with zarith. + Qed. + + (* Bitwise *) + + Lemma log2_phi_bounded x : Z.log2 [|x|] < Z.of_nat size. + Proof. + destruct (phi_bounded x) as (H,H'). + Z.le_elim H. + - now apply Z.log2_lt_pow2. + - now rewrite <- H. + Qed. + + Lemma spec_lor x y : [| ZnZ.lor x y |] = Z.lor [|x|] [|y|]. + Proof. + unfold ZnZ.lor,int31_ops. unfold lor31. + rewrite phi_phi_inv. + apply Z.mod_small; split; trivial. + - apply Z.lor_nonneg; split; apply phi_bounded. + - apply Z.log2_lt_cancel. rewrite Z.log2_pow2 by easy. + rewrite Z.log2_lor; try apply phi_bounded. + apply Z.max_lub_lt; apply log2_phi_bounded. + Qed. + + Lemma spec_land x y : [| ZnZ.land x y |] = Z.land [|x|] [|y|]. + Proof. + unfold ZnZ.land, int31_ops. unfold land31. + rewrite phi_phi_inv. + apply Z.mod_small; split; trivial. + - apply Z.land_nonneg; left; apply phi_bounded. + - apply Z.log2_lt_cancel. rewrite Z.log2_pow2 by easy. + eapply Z.le_lt_trans. + apply Z.log2_land; try apply phi_bounded. + apply Z.min_lt_iff; left; apply log2_phi_bounded. + Qed. + + Lemma spec_lxor x y : [| ZnZ.lxor x y |] = Z.lxor [|x|] [|y|]. + Proof. + unfold ZnZ.lxor, int31_ops. unfold lxor31. + rewrite phi_phi_inv. + apply Z.mod_small; split; trivial. + - apply Z.lxor_nonneg; split; intros; apply phi_bounded. + - apply Z.log2_lt_cancel. rewrite Z.log2_pow2 by easy. + eapply Z.le_lt_trans. + apply Z.log2_lxor; try apply phi_bounded. + apply Z.max_lub_lt; apply log2_phi_bounded. + Qed. + + Global Instance int31_specs : ZnZ.Specs int31_ops := { + spec_to_Z := phi_bounded; + spec_of_pos := positive_to_int31_spec; + spec_zdigits := spec_zdigits; + spec_more_than_1_digit := spec_more_than_1_digit; + spec_0 := spec_0; + spec_1 := spec_1; + spec_m1 := spec_m1; + spec_compare := spec_compare; + spec_eq0 := spec_eq0; + spec_opp_c := spec_opp_c; + spec_opp := spec_opp; + spec_opp_carry := spec_opp_carry; + spec_succ_c := spec_succ_c; + spec_add_c := spec_add_c; + spec_add_carry_c := spec_add_carry_c; + spec_succ := spec_succ; + spec_add := spec_add; + spec_add_carry := spec_add_carry; + spec_pred_c := spec_pred_c; + spec_sub_c := spec_sub_c; + spec_sub_carry_c := spec_sub_carry_c; + spec_pred := spec_pred; + spec_sub := spec_sub; + spec_sub_carry := spec_sub_carry; + spec_mul_c := spec_mul_c; + spec_mul := spec_mul; + spec_square_c := spec_square_c; + spec_div21 := spec_div21; + spec_div_gt := fun a b _ => spec_div a b; + spec_div := spec_div; + spec_modulo_gt := fun a b _ => spec_mod a b; + spec_modulo := spec_mod; + spec_gcd_gt := fun a b _ => spec_gcd a b; + spec_gcd := spec_gcd; + spec_head00 := spec_head00; + spec_head0 := spec_head0; + spec_tail00 := spec_tail00; + spec_tail0 := spec_tail0; + spec_add_mul_div := spec_add_mul_div; + spec_pos_mod := spec_pos_mod; + spec_is_even := spec_is_even; + spec_sqrt2 := spec_sqrt2; + spec_sqrt := spec_sqrt; + spec_lor := spec_lor; + spec_land := spec_land; + spec_lxor := spec_lxor }. + +End Int31_Specs. + + +Module Int31Cyclic <: CyclicType. + Definition t := int31. + Definition ops := int31_ops. + Definition specs := int31_specs. +End Int31Cyclic. diff --git a/theories/Numbers/Cyclic/Int31/Int31.v b/theories/Numbers/Cyclic/Int31/Int31.v new file mode 100644 index 0000000000..b9185c9ca0 --- /dev/null +++ b/theories/Numbers/Cyclic/Int31/Int31.v @@ -0,0 +1,480 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(** This library has been deprecated since Coq version 8.10. *) + +Require Import NaryFunctions. +Require Import Wf_nat. +Require Export ZArith. +Require Export DoubleType. + +Local Unset Elimination Schemes. + +(** * 31-bit integers *) + +(** This file contains basic definitions of a 31-bit integer + arithmetic. In fact it is more general than that. The only reason + for this use of 31 is the underlying mechanism for hardware-efficient + computations by A. Spiwack. Apart from this, a switch to, say, + 63-bit integers is now just a matter of replacing every occurrences + of 31 by 63. This is actually made possible by the use of + dependently-typed n-ary constructions for the inductive type + [int31], its constructor [I31] and any pattern matching on it. + If you modify this file, please preserve this genericity. *) + +Definition size := 31%nat. + +(** Digits *) + +Inductive digits : Type := D0 | D1. + +(** The type of 31-bit integers *) + +(** The type [int31] has a unique constructor [I31] that expects + 31 arguments of type [digits]. *) + +Definition digits31 t := Eval compute in nfun digits size t. + +Inductive int31 : Type := I31 : digits31 int31. + +Scheme int31_ind := Induction for int31 Sort Prop. +Scheme int31_rec := Induction for int31 Sort Set. +Scheme int31_rect := Induction for int31 Sort Type. + +Declare Scope int31_scope. +Delimit Scope int31_scope with int31. +Bind Scope int31_scope with int31. +Local Open Scope int31_scope. + +(** * Constants *) + +(** Zero is [I31 D0 ... D0] *) +Definition On : int31 := Eval compute in napply_cst _ _ D0 size I31. + +(** One is [I31 D0 ... D0 D1] *) +Definition In : int31 := Eval compute in (napply_cst _ _ D0 (size-1) I31) D1. + +(** The biggest integer is [I31 D1 ... D1], corresponding to [(2^size)-1] *) +Definition Tn : int31 := Eval compute in napply_cst _ _ D1 size I31. + +(** Two is [I31 D0 ... D0 D1 D0] *) +Definition Twon : int31 := Eval compute in (napply_cst _ _ D0 (size-2) I31) D1 D0. + +(** * Bits manipulation *) + + +(** [sneakr b x] shifts [x] to the right by one bit. + Rightmost digit is lost while leftmost digit becomes [b]. + Pseudo-code is + [ match x with (I31 d0 ... dN) => I31 b d0 ... d(N-1) end ] +*) + +Definition sneakr : digits -> int31 -> int31 := Eval compute in + fun b => int31_rect _ (napply_except_last _ _ (size-1) (I31 b)). + +(** [sneakl b x] shifts [x] to the left by one bit. + Leftmost digit is lost while rightmost digit becomes [b]. + Pseudo-code is + [ match x with (I31 d0 ... dN) => I31 d1 ... dN b end ] +*) + +Definition sneakl : digits -> int31 -> int31 := Eval compute in + fun b => int31_rect _ (fun _ => napply_then_last _ _ b (size-1) I31). + + +(** [shiftl], [shiftr], [twice] and [twice_plus_one] are direct + consequences of [sneakl] and [sneakr]. *) + +Definition shiftl := sneakl D0. +Definition shiftr := sneakr D0. +Definition twice := sneakl D0. +Definition twice_plus_one := sneakl D1. + +(** [firstl x] returns the leftmost digit of number [x]. + Pseudo-code is [ match x with (I31 d0 ... dN) => d0 end ] *) + +Definition firstl : int31 -> digits := Eval compute in + int31_rect _ (fun d => napply_discard _ _ d (size-1)). + +(** [firstr x] returns the rightmost digit of number [x]. + Pseudo-code is [ match x with (I31 d0 ... dN) => dN end ] *) + +Definition firstr : int31 -> digits := Eval compute in + int31_rect _ (napply_discard _ _ (fun d=>d) (size-1)). + +(** [iszero x] is true iff [x = I31 D0 ... D0]. Pseudo-code is + [ match x with (I31 D0 ... D0) => true | _ => false end ] *) + +Definition iszero : int31 -> bool := Eval compute in + let f d b := match d with D0 => b | D1 => false end + in int31_rect _ (nfold_bis _ _ f true size). + +(* NB: DO NOT transform the above match in a nicer (if then else). + It seems to work, but later "unfold iszero" takes forever. *) + + +(** [base] is [2^31], obtained via iterations of [Z.double]. + It can also be seen as the smallest b > 0 s.t. phi_inv b = 0 + (see below) *) + +Definition base := Eval compute in + iter_nat size Z Z.double 1%Z. + +(** * Recursors *) + +Fixpoint recl_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A) + (i:int31) : A := + match n with + | O => case0 + | S next => + if iszero i then + case0 + else + let si := shiftl i in + caserec (firstl i) si (recl_aux next A case0 caserec si) + end. + +Fixpoint recr_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A) + (i:int31) : A := + match n with + | O => case0 + | S next => + if iszero i then + case0 + else + let si := shiftr i in + caserec (firstr i) si (recr_aux next A case0 caserec si) + end. + +Definition recl := recl_aux size. +Definition recr := recr_aux size. + +(** * Conversions *) + +(** From int31 to Z, we simply iterates [Z.double] or [Z.succ_double]. *) + +Definition phi : int31 -> Z := + recr Z (0%Z) + (fun b _ => match b with D0 => Z.double | D1 => Z.succ_double end). + +(** From positive to int31. An abstract definition could be : + [ phi_inv (2n) = 2*(phi_inv n) /\ + phi_inv 2n+1 = 2*(phi_inv n) + 1 ] *) + +Fixpoint phi_inv_positive p := + match p with + | xI q => twice_plus_one (phi_inv_positive q) + | xO q => twice (phi_inv_positive q) + | xH => In + end. + +(** The negative part : 2-complement *) + +Fixpoint complement_negative p := + match p with + | xI q => twice (complement_negative q) + | xO q => twice_plus_one (complement_negative q) + | xH => twice Tn + end. + +(** A simple incrementation function *) + +Definition incr : int31 -> int31 := + recr int31 In + (fun b si rec => match b with + | D0 => sneakl D1 si + | D1 => sneakl D0 rec end). + +(** We can now define the conversion from Z to int31. *) + +Definition phi_inv : Z -> int31 := fun n => + match n with + | Z0 => On + | Zpos p => phi_inv_positive p + | Zneg p => incr (complement_negative p) + end. + +(** [phi_inv_nonneg] returns [None] if the [Z] is negative; this matches the old behavior of parsing int31 numerals *) +Definition phi_inv_nonneg : Z -> option int31 := fun n => + match n with + | Zneg _ => None + | _ => Some (phi_inv n) + end. + +(** [phi_inv2] is similar to [phi_inv] but returns a double word + [zn2z int31] *) + +Definition phi_inv2 n := + match n with + | Z0 => W0 + | _ => WW (phi_inv (n/base)%Z) (phi_inv n) + end. + +(** [phi2] is similar to [phi] but takes a double word (two args) *) + +Definition phi2 nh nl := + ((phi nh)*base+(phi nl))%Z. + +(** * Addition *) + +(** Addition modulo [2^31] *) + +Definition add31 (n m : int31) := phi_inv ((phi n)+(phi m)). +Notation "n + m" := (add31 n m) : int31_scope. + +(** Addition with carry (the result is thus exact) *) + +(* spiwack : when executed in non-compiled*) +(* mode, (phi n)+(phi m) is computed twice*) +(* it may be considered to optimize it *) + +Definition add31c (n m : int31) := + let npm := n+m in + match (phi npm ?= (phi n)+(phi m))%Z with + | Eq => C0 npm + | _ => C1 npm + end. +Notation "n '+c' m" := (add31c n m) (at level 50, no associativity) : int31_scope. + +(** Addition plus one with carry (the result is thus exact) *) + +Definition add31carryc (n m : int31) := + let npmpone_exact := ((phi n)+(phi m)+1)%Z in + let npmpone := phi_inv npmpone_exact in + match (phi npmpone ?= npmpone_exact)%Z with + | Eq => C0 npmpone + | _ => C1 npmpone + end. + +(** * Substraction *) + +(** Subtraction modulo [2^31] *) + +Definition sub31 (n m : int31) := phi_inv ((phi n)-(phi m)). +Notation "n - m" := (sub31 n m) : int31_scope. + +(** Subtraction with carry (thus exact) *) + +Definition sub31c (n m : int31) := + let nmm := n-m in + match (phi nmm ?= (phi n)-(phi m))%Z with + | Eq => C0 nmm + | _ => C1 nmm + end. +Notation "n '-c' m" := (sub31c n m) (at level 50, no associativity) : int31_scope. + +(** subtraction minus one with carry (thus exact) *) + +Definition sub31carryc (n m : int31) := + let nmmmone_exact := ((phi n)-(phi m)-1)%Z in + let nmmmone := phi_inv nmmmone_exact in + match (phi nmmmone ?= nmmmone_exact)%Z with + | Eq => C0 nmmmone + | _ => C1 nmmmone + end. + +(** Opposite *) + +Definition opp31 x := On - x. +Notation "- x" := (opp31 x) : int31_scope. + +(** Multiplication *) + +(** multiplication modulo [2^31] *) + +Definition mul31 (n m : int31) := phi_inv ((phi n)*(phi m)). +Notation "n * m" := (mul31 n m) : int31_scope. + +(** multiplication with double word result (thus exact) *) + +Definition mul31c (n m : int31) := phi_inv2 ((phi n)*(phi m)). +Notation "n '*c' m" := (mul31c n m) (at level 40, no associativity) : int31_scope. + + +(** * Division *) + +(** Division of a double size word modulo [2^31] *) + +Definition div3121 (nh nl m : int31) := + let (q,r) := Z.div_eucl (phi2 nh nl) (phi m) in + (phi_inv q, phi_inv r). + +(** Division modulo [2^31] *) + +Definition div31 (n m : int31) := + let (q,r) := Z.div_eucl (phi n) (phi m) in + (phi_inv q, phi_inv r). +Notation "n / m" := (div31 n m) : int31_scope. + + +(** * Unsigned comparison *) + +Definition compare31 (n m : int31) := ((phi n)?=(phi m))%Z. +Notation "n ?= m" := (compare31 n m) (at level 70, no associativity) : int31_scope. + +Definition eqb31 (n m : int31) := + match n ?= m with Eq => true | _ => false end. + + +(** Computing the [i]-th iterate of a function: + [iter_int31 i A f = f^i] *) + +Definition iter_int31 i A f := + recr (A->A) (fun x => x) + (fun b si rec => match b with + | D0 => fun x => rec (rec x) + | D1 => fun x => f (rec (rec x)) + end) + i. + +(** Combining the [(31-p)] low bits of [i] above the [p] high bits of [j]: + [addmuldiv31 p i j = i*2^p+j/2^(31-p)] (modulo [2^31]) *) + +Definition addmuldiv31 p i j := + let (res, _ ) := + iter_int31 p (int31*int31) + (fun ij => let (i,j) := ij in (sneakl (firstl j) i, shiftl j)) + (i,j) + in + res. + +(** Bitwise operations *) + +Definition lor31 n m := phi_inv (Z.lor (phi n) (phi m)). +Definition land31 n m := phi_inv (Z.land (phi n) (phi m)). +Definition lxor31 n m := phi_inv (Z.lxor (phi n) (phi m)). + +Definition lnot31 n := lxor31 Tn n. +Definition ldiff31 n m := land31 n (lnot31 m). + +Fixpoint euler (guard:nat) (i j:int31) {struct guard} := + match guard with + | O => In + | S p => match j ?= On with + | Eq => i + | _ => euler p j (let (_, r ) := i/j in r) + end + end. + +Definition gcd31 (i j:int31) := euler (2*size)%nat i j. + +(** Square root functions using newton iteration + we use a very naive upper-bound on the iteration + 2^31 instead of the usual 31. +**) + + + +Definition sqrt31_step (rec: int31 -> int31 -> int31) (i j: int31) := +Eval lazy delta [Twon] in + let (quo,_) := i/j in + match quo ?= j with + Lt => rec i (fst ((j + quo)/Twon)) + | _ => j + end. + +Fixpoint iter31_sqrt (n: nat) (rec: int31 -> int31 -> int31) + (i j: int31) {struct n} : int31 := + sqrt31_step + (match n with + O => rec + | S n => (iter31_sqrt n (iter31_sqrt n rec)) + end) i j. + +Definition sqrt31 i := +Eval lazy delta [On In Twon] in + match compare31 In i with + Gt => On + | Eq => In + | Lt => iter31_sqrt 31 (fun i j => j) i (fst (i/Twon)) + end. + +Definition v30 := Eval compute in (addmuldiv31 (phi_inv (Z.of_nat size - 1)) In On). + +Definition sqrt312_step (rec: int31 -> int31 -> int31 -> int31) + (ih il j: int31) := +Eval lazy delta [Twon v30] in + match ih ?= j with Eq => j | Gt => j | _ => + let (quo,_) := div3121 ih il j in + match quo ?= j with + Lt => let m := match j +c quo with + C0 m1 => fst (m1/Twon) + | C1 m1 => fst (m1/Twon) + v30 + end in rec ih il m + | _ => j + end end. + +Fixpoint iter312_sqrt (n: nat) + (rec: int31 -> int31 -> int31 -> int31) + (ih il j: int31) {struct n} : int31 := + sqrt312_step + (match n with + O => rec + | S n => (iter312_sqrt n (iter312_sqrt n rec)) + end) ih il j. + +Definition sqrt312 ih il := +Eval lazy delta [On In] in + let s := iter312_sqrt 31 (fun ih il j => j) ih il Tn in + match s *c s with + W0 => (On, C0 On) (* impossible *) + | WW ih1 il1 => + match il -c il1 with + C0 il2 => + match ih ?= ih1 with + Gt => (s, C1 il2) + | _ => (s, C0 il2) + end + | C1 il2 => + match (ih - In) ?= ih1 with (* we could parametrize ih - 1 *) + Gt => (s, C1 il2) + | _ => (s, C0 il2) + end + end + end. + + +Fixpoint p2i n p : (N*int31)%type := + match n with + | O => (Npos p, On) + | S n => match p with + | xO p => let (r,i) := p2i n p in (r, Twon*i) + | xI p => let (r,i) := p2i n p in (r, Twon*i+In) + | xH => (N0, In) + end + end. + +Definition positive_to_int31 (p:positive) := p2i size p. + +(** Constant 31 converted into type int31. + It is used as default answer for numbers of zeros + in [head0] and [tail0] *) + +Definition T31 : int31 := Eval compute in phi_inv (Z.of_nat size). + +Definition head031 (i:int31) := + recl _ (fun _ => T31) + (fun b si rec n => match b with + | D0 => rec (add31 n In) + | D1 => n + end) + i On. + +Definition tail031 (i:int31) := + recr _ (fun _ => T31) + (fun b si rec n => match b with + | D0 => rec (add31 n In) + | D1 => n + end) + i On. + +Numeral Notation int31 phi_inv_nonneg phi : int31_scope. diff --git a/theories/Numbers/Cyclic/Int31/Ring31.v b/theories/Numbers/Cyclic/Int31/Ring31.v new file mode 100644 index 0000000000..eb47141cab --- /dev/null +++ b/theories/Numbers/Cyclic/Int31/Ring31.v @@ -0,0 +1,105 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** This library has been deprecated since Coq version 8.10. *) + +(** * Int31 numbers defines Z/(2^31)Z, and can hence be equipped + with a ring structure and a ring tactic *) + +Require Import Int31 Cyclic31 CyclicAxioms. + +Local Open Scope int31_scope. + +(** Detection of constants *) + +Local Open Scope list_scope. + +Ltac isInt31cst_lst l := + match l with + | nil => constr:(true) + | ?t::?l => match t with + | D1 => isInt31cst_lst l + | D0 => isInt31cst_lst l + | _ => constr:(false) + end + | _ => constr:(false) + end. + +Ltac isInt31cst t := + match t with + | I31 ?i0 ?i1 ?i2 ?i3 ?i4 ?i5 ?i6 ?i7 ?i8 ?i9 ?i10 + ?i11 ?i12 ?i13 ?i14 ?i15 ?i16 ?i17 ?i18 ?i19 ?i20 + ?i21 ?i22 ?i23 ?i24 ?i25 ?i26 ?i27 ?i28 ?i29 ?i30 => + let l := + constr:(i0::i1::i2::i3::i4::i5::i6::i7::i8::i9::i10 + ::i11::i12::i13::i14::i15::i16::i17::i18::i19::i20 + ::i21::i22::i23::i24::i25::i26::i27::i28::i29::i30::nil) + in isInt31cst_lst l + | Int31.On => constr:(true) + | Int31.In => constr:(true) + | Int31.Tn => constr:(true) + | Int31.Twon => constr:(true) + | _ => constr:(false) + end. + +Ltac Int31cst t := + match isInt31cst t with + | true => constr:(t) + | false => constr:(NotConstant) + end. + +(** The generic ring structure inferred from the Cyclic structure *) + +Module Int31ring := CyclicRing Int31Cyclic. + +(** Unlike in the generic [CyclicRing], we can use Leibniz here. *) + +Lemma Int31_canonic : forall x y, phi x = phi y -> x = y. +Proof. + intros x y EQ. + now rewrite <- (phi_inv_phi x), <- (phi_inv_phi y), EQ. +Qed. + +Lemma ring_theory_switch_eq : + forall A (R R':A->A->Prop) zero one add mul sub opp, + (forall x y : A, R x y -> R' x y) -> + ring_theory zero one add mul sub opp R -> + ring_theory zero one add mul sub opp R'. +Proof. +intros A R R' zero one add mul sub opp Impl Ring. +constructor; intros; apply Impl; apply Ring. +Qed. + +Lemma Int31Ring : ring_theory 0 1 add31 mul31 sub31 opp31 Logic.eq. +Proof. +exact (ring_theory_switch_eq _ _ _ _ _ _ _ _ _ Int31_canonic Int31ring.CyclicRing). +Qed. + +Lemma eqb31_eq : forall x y, eqb31 x y = true <-> x=y. +Proof. +unfold eqb31. intros x y. +rewrite Cyclic31.spec_compare. case Z.compare_spec. +intuition. apply Int31_canonic; auto. +intuition; subst; auto with zarith; try discriminate. +intuition; subst; auto with zarith; try discriminate. +Qed. + +Lemma eqb31_correct : forall x y, eqb31 x y = true -> x=y. +Proof. now apply eqb31_eq. Qed. + +Add Ring Int31Ring : Int31Ring + (decidable eqb31_correct, + constants [Int31cst]). + +Section TestRing. +Let test : forall x y, 1 + x*y + x*x + 1 = 1*1 + 1 + y*x + 1*x*x. +intros. ring. +Qed. +End TestRing. diff --git a/theories/Numbers/Cyclic/Int63/Cyclic63.v b/theories/Numbers/Cyclic/Int63/Cyclic63.v new file mode 100644 index 0000000000..3b431d5b47 --- /dev/null +++ b/theories/Numbers/Cyclic/Int63/Cyclic63.v @@ -0,0 +1,330 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2018 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** * Int63 numbers defines indeed a cyclic structure : Z/(2^31)Z *) + +(** +Author: Arnaud Spiwack (+ Pierre Letouzey) +*) +Require Import CyclicAxioms. +Require Export ZArith. +Require Export Int63. +Import Zpow_facts. +Import Utf8. +Import Lia. + +Local Open Scope int63_scope. +(** {2 Operators } **) + +Definition Pdigits := Eval compute in P_of_succ_nat (size - 1). + +Fixpoint positive_to_int_rec (n:nat) (p:positive) := + match n, p with + | O, _ => (Npos p, 0) + | S n, xH => (0%N, 1) + | S n, xO p => + let (N,i) := positive_to_int_rec n p in + (N, i << 1) + | S n, xI p => + let (N,i) := positive_to_int_rec n p in + (N, (i << 1) + 1) + end. + +Definition positive_to_int := positive_to_int_rec size. + +Definition mulc_WW x y := + let (h, l) := mulc x y in + if is_zero h then + if is_zero l then W0 + else WW h l + else WW h l. +Notation "n '*c' m" := (mulc_WW n m) (at level 40, no associativity) : int63_scope. + +Definition pos_mod p x := + if p <= digits then + let p := digits - p in + (x << p) >> p + else x. + +Notation pos_mod_int := pos_mod. + +Import ZnZ. + +Instance int_ops : ZnZ.Ops int := +{| + digits := Pdigits; (* number of digits *) + zdigits := Int63.digits; (* number of digits *) + to_Z := Int63.to_Z; (* conversion to Z *) + of_pos := positive_to_int; (* positive -> N*int63 : p => N,i + where p = N*2^31+phi i *) + head0 := Int63.head0; (* number of head 0 *) + tail0 := Int63.tail0; (* number of tail 0 *) + zero := 0; + one := 1; + minus_one := Int63.max_int; + compare := Int63.compare; + eq0 := Int63.is_zero; + opp_c := Int63.oppc; + opp := Int63.opp; + opp_carry := Int63.oppcarry; + succ_c := Int63.succc; + add_c := Int63.addc; + add_carry_c := Int63.addcarryc; + succ := Int63.succ; + add := Int63.add; + add_carry := Int63.addcarry; + pred_c := Int63.predc; + sub_c := Int63.subc; + sub_carry_c := Int63.subcarryc; + pred := Int63.pred; + sub := Int63.sub; + sub_carry := Int63.subcarry; + mul_c := mulc_WW; + mul := Int63.mul; + square_c := fun x => mulc_WW x x; + div21 := diveucl_21; + div_gt := diveucl; (* this is supposed to be the special case of + division a/b where a > b *) + div := diveucl; + modulo_gt := Int63.mod; + modulo := Int63.mod; + gcd_gt := Int63.gcd; + gcd := Int63.gcd; + add_mul_div := Int63.addmuldiv; + pos_mod := pos_mod_int; + is_even := Int63.is_even; + sqrt2 := Int63.sqrt2; + sqrt := Int63.sqrt; + ZnZ.lor := Int63.lor; + ZnZ.land := Int63.land; + ZnZ.lxor := Int63.lxor +|}. + +Local Open Scope Z_scope. + +Lemma is_zero_spec_aux : forall x : int, is_zero x = true -> [|x|] = 0%Z. +Proof. + intros x;rewrite is_zero_spec;intros H;rewrite H;trivial. +Qed. + +Lemma positive_to_int_spec : + forall p : positive, + Zpos p = + Z_of_N (fst (positive_to_int p)) * wB + to_Z (snd (positive_to_int p)). +Proof. + assert (H: (wB <= wB) -> forall p : positive, + Zpos p = Z_of_N (fst (positive_to_int p)) * wB + [|snd (positive_to_int p)|] /\ + [|snd (positive_to_int p)|] < wB). + 2: intros p; case (H (Z.le_refl wB) p); auto. + unfold positive_to_int, wB at 1 3 4. + elim size. + intros _ p; simpl; + rewrite to_Z_0, Pmult_1_r; split; auto with zarith; apply refl_equal. + intros n; rewrite inj_S; unfold Z.succ; rewrite Zpower_exp, Z.pow_1_r; auto with zarith. + intros IH Hle p. + assert (F1: 2 ^ Z_of_nat n <= wB); auto with zarith. + assert (0 <= 2 ^ Z_of_nat n); auto with zarith. + case p; simpl. + intros p1. + generalize (IH F1 p1); case positive_to_int_rec; simpl. + intros n1 i (H1,H2). + rewrite Zpos_xI, H1. + replace [|i << 1 + 1|] with ([|i|] * 2 + 1). + split; auto with zarith; ring. + rewrite add_spec, lsl_spec, Zplus_mod_idemp_l, to_Z_1, Z.pow_1_r, Zmod_small; auto. + case (to_Z_bounded i); split; auto with zarith. + intros p1. + generalize (IH F1 p1); case positive_to_int_rec; simpl. + intros n1 i (H1,H2). + rewrite Zpos_xO, H1. + replace [|i << 1|] with ([|i|] * 2). + split; auto with zarith; ring. + rewrite lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small; auto. + case (to_Z_bounded i); split; auto with zarith. + rewrite to_Z_1; assert (0 < 2^ Z_of_nat n); auto with zarith. +Qed. + +Lemma mulc_WW_spec : + forall x y,[|| x *c y ||] = [|x|] * [|y|]. +Proof. + intros x y;unfold mulc_WW. + generalize (mulc_spec x y);destruct (mulc x y);simpl;intros Heq;rewrite Heq. + case_eq (is_zero i);intros;trivial. + apply is_zero_spec in H;rewrite H, to_Z_0. + case_eq (is_zero i0);intros;trivial. + apply is_zero_spec in H0;rewrite H0, to_Z_0, Zmult_comm;trivial. +Qed. + +Lemma squarec_spec : + forall x, + [||x *c x||] = [|x|] * [|x|]. +Proof (fun x => mulc_WW_spec x x). + +Lemma diveucl_spec_aux : forall a b, 0 < [|b|] -> + let (q,r) := diveucl a b in + [|a|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. +Proof. + intros a b H;assert (W:= diveucl_spec a b). + assert ([|b|]>0) by (auto with zarith). + generalize (Z_div_mod [|a|] [|b|] H0). + destruct (diveucl a b);destruct (Z.div_eucl [|a|] [|b|]). + inversion W;rewrite Zmult_comm;trivial. +Qed. + +Lemma diveucl_21_spec_aux : forall a1 a2 b, + wB/2 <= [|b|] -> + [|a1|] < [|b|] -> + let (q,r) := diveucl_21 a1 a2 b in + [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. +Proof. + intros a1 a2 b H1 H2;assert (W:= diveucl_21_spec a1 a2 b). + assert (W1:= to_Z_bounded a1). + assert ([|b|]>0) by (auto with zarith). + generalize (Z_div_mod ([|a1|]*wB+[|a2|]) [|b|] H). + destruct (diveucl_21 a1 a2 b);destruct (Z.div_eucl ([|a1|]*wB+[|a2|]) [|b|]). + inversion W;rewrite (Zmult_comm [|b|]);trivial. +Qed. + +Lemma shift_unshift_mod_2 : forall n p a, 0 <= p <= n -> + ((a * 2 ^ (n - p)) mod (2^n) / 2 ^ (n - p)) mod (2^n) = + a mod 2 ^ p. + Proof. + intros n p a H. + rewrite Zmod_small. + - rewrite Zmod_eq by auto with zarith. + unfold Zminus at 1. + rewrite Zdiv.Z_div_plus_full_l by auto with zarith. + replace (2 ^ n) with (2 ^ (n - p) * 2 ^ p) by (rewrite <- Zpower_exp; [ f_equal | | ]; lia). + rewrite <- Zdiv_Zdiv, Z_div_mult by auto with zarith. + rewrite (Zmult_comm (2^(n-p))), Zmult_assoc. + rewrite Zopp_mult_distr_l. + rewrite Z_div_mult by auto with zarith. + symmetry; apply Zmod_eq; auto with zarith. + - remember (a * 2 ^ (n - p)) as b. + destruct (Z_mod_lt b (2^n)); auto with zarith. + split. + apply Z_div_pos; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + apply Z.lt_le_trans with (2^n); auto with zarith. + generalize (pow2_pos (n - p)); nia. + Qed. + +Lemma div_le_0 : forall p x, 0 <= x -> 0 <= x / 2 ^ p. + Proof. + intros p x Hle;destruct (Z_le_gt_dec 0 p). + apply Zdiv_le_lower_bound;auto with zarith. + replace (2^p) with 0. + destruct x;compute;intro;discriminate. + destruct p;trivial;discriminate. + Qed. + +Lemma div_lt : forall p x y, 0 <= x < y -> x / 2^p < y. + Proof. + intros p x y H;destruct (Z_le_gt_dec 0 p). + apply Zdiv_lt_upper_bound;auto with zarith. + apply Z.lt_le_trans with y;auto with zarith. + rewrite <- (Zmult_1_r y);apply Zmult_le_compat;auto with zarith. + assert (0 < 2^p);auto with zarith. + replace (2^p) with 0. + destruct x;change (0<y);auto with zarith. + destruct p;trivial;discriminate. + Qed. + +Lemma P (A B C: Prop) : + A → (B → C) → (A → B) → C. +Proof. tauto. Qed. + +Lemma shift_unshift_mod_3: + forall n p a : Z, + 0 <= p <= n -> + (a * 2 ^ (n - p)) mod 2 ^ n / 2 ^ (n - p) = a mod 2 ^ p. +Proof. + intros;rewrite <- (shift_unshift_mod_2 n p a);[ | auto with zarith]. + symmetry;apply Zmod_small. + generalize (a * 2 ^ (n - p));intros w. + generalize (2 ^ (n - p)) (pow2_pos (n - p)); intros x; apply P. lia. intros hx. + generalize (2 ^ n) (pow2_pos n); intros y; apply P. lia. intros hy. + elim_div. intros q r. apply P. lia. + elim_div. intros z t. refine (P _ _ _ _ _). lia. + intros [ ? [ ht | ] ]; [ | lia ]; subst w. + intros [ ? [ hr | ] ]; [ | lia ]; subst t. + nia. +Qed. + +Lemma pos_mod_spec w p : φ(pos_mod p w) = φ(w) mod (2 ^ φ(p)). +Proof. + simpl. unfold pos_mod_int. + assert (W:=to_Z_bounded p);assert (W':=to_Z_bounded Int63.digits);assert (W'' := to_Z_bounded w). + case lebP; intros hle. + 2: { + symmetry; apply Zmod_small. + assert (2 ^ [|Int63.digits|] < 2 ^ [|p|]); [ apply Zpower_lt_monotone; auto with zarith | ]. + change wB with (2 ^ [|Int63.digits|]) in *; auto with zarith. } + rewrite <- (shift_unshift_mod_3 [|Int63.digits|] [|p|] [|w|]) by auto with zarith. + replace ([|Int63.digits|] - [|p|]) with [|Int63.digits - p|] by (rewrite sub_spec, Zmod_small; auto with zarith). + rewrite lsr_spec, lsl_spec; reflexivity. +Qed. + +(** {2 Specification and proof} **) +Global Instance int_specs : ZnZ.Specs int_ops := { + spec_to_Z := to_Z_bounded; + spec_of_pos := positive_to_int_spec; + spec_zdigits := refl_equal _; + spec_more_than_1_digit:= refl_equal _; + spec_0 := to_Z_0; + spec_1 := to_Z_1; + spec_m1 := refl_equal _; + spec_compare := compare_spec; + spec_eq0 := is_zero_spec_aux; + spec_opp_c := oppc_spec; + spec_opp := opp_spec; + spec_opp_carry := oppcarry_spec; + spec_succ_c := succc_spec; + spec_add_c := addc_spec; + spec_add_carry_c := addcarryc_spec; + spec_succ := succ_spec; + spec_add := add_spec; + spec_add_carry := addcarry_spec; + spec_pred_c := predc_spec; + spec_sub_c := subc_spec; + spec_sub_carry_c := subcarryc_spec; + spec_pred := pred_spec; + spec_sub := sub_spec; + spec_sub_carry := subcarry_spec; + spec_mul_c := mulc_WW_spec; + spec_mul := mul_spec; + spec_square_c := squarec_spec; + spec_div21 := diveucl_21_spec_aux; + spec_div_gt := fun a b _ => diveucl_spec_aux a b; + spec_div := diveucl_spec_aux; + spec_modulo_gt := fun a b _ _ => mod_spec a b; + spec_modulo := fun a b _ => mod_spec a b; + spec_gcd_gt := fun a b _ => gcd_spec a b; + spec_gcd := gcd_spec; + spec_head00 := head00_spec; + spec_head0 := head0_spec; + spec_tail00 := tail00_spec; + spec_tail0 := tail0_spec; + spec_add_mul_div := addmuldiv_spec; + spec_pos_mod := pos_mod_spec; + spec_is_even := is_even_spec; + spec_sqrt2 := sqrt2_spec; + spec_sqrt := sqrt_spec; + spec_land := land_spec'; + spec_lor := lor_spec'; + spec_lxor := lxor_spec' }. + + + +Module Int63Cyclic <: CyclicType. + Definition t := int. + Definition ops := int_ops. + Definition specs := int_specs. +End Int63Cyclic. diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v new file mode 100644 index 0000000000..eac26add03 --- /dev/null +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -0,0 +1,1918 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +Require Import Utf8. +Require Export DoubleType. +Require Import Lia. +Require Import Zpow_facts. +Require Import Zgcd_alt. +Import Znumtheory. + +Register bool as kernel.ind_bool. +Register prod as kernel.ind_pair. +Register carry as kernel.ind_carry. +Register comparison as kernel.ind_cmp. + +Definition size := 63%nat. + +Primitive int := #int63_type. +Register int as num.int63.type. +Declare Scope int63_scope. +Definition id_int : int -> int := fun x => x. +Declare ML Module "int63_syntax_plugin". + +Delimit Scope int63_scope with int63. +Bind Scope int63_scope with int. + +(* Logical operations *) +Primitive lsl := #int63_lsl. +Infix "<<" := lsl (at level 30, no associativity) : int63_scope. + +Primitive lsr := #int63_lsr. +Infix ">>" := lsr (at level 30, no associativity) : int63_scope. + +Primitive land := #int63_land. +Infix "land" := land (at level 40, left associativity) : int63_scope. + +Primitive lor := #int63_lor. +Infix "lor" := lor (at level 40, left associativity) : int63_scope. + +Primitive lxor := #int63_lxor. +Infix "lxor" := lxor (at level 40, left associativity) : int63_scope. + +(* Arithmetic modulo operations *) +Primitive add := #int63_add. +Notation "n + m" := (add n m) : int63_scope. + +Primitive sub := #int63_sub. +Notation "n - m" := (sub n m) : int63_scope. + +Primitive mul := #int63_mul. +Notation "n * m" := (mul n m) : int63_scope. + +Primitive mulc := #int63_mulc. + +Primitive div := #int63_div. +Notation "n / m" := (div n m) : int63_scope. + +Primitive mod := #int63_mod. +Notation "n '\%' m" := (mod n m) (at level 40, left associativity) : int63_scope. + +(* Comparisons *) +Primitive eqb := #int63_eq. +Notation "m '==' n" := (eqb m n) (at level 70, no associativity) : int63_scope. + +Primitive ltb := #int63_lt. +Notation "m < n" := (ltb m n) : int63_scope. + +Primitive leb := #int63_le. +Notation "m <= n" := (leb m n) : int63_scope. +Notation "m ≤ n" := (leb m n) (at level 70, no associativity) : int63_scope. + +Local Open Scope int63_scope. + +(** The number of digits as a int *) +Definition digits := 63. + +(** The bigger int *) +Definition max_int := Eval vm_compute in 0 - 1. +Register Inline max_int. + +(** Access to the nth digits *) +Definition get_digit x p := (0 < (x land (1 << p))). + +Definition set_digit x p (b:bool) := + if if 0 <= p then p < digits else false then + if b then x lor (1 << p) + else x land (max_int lxor (1 << p)) + else x. + +(** Equality to 0 *) +Definition is_zero (i:int) := i == 0. +Register Inline is_zero. + +(** Parity *) +Definition is_even (i:int) := is_zero (i land 1). +Register Inline is_even. + +(** Bit *) + +Definition bit i n := negb (is_zero ((i >> n) << (digits - 1))). +(* Register bit as PrimInline. *) + +(** Extra modulo operations *) +Definition opp (i:int) := 0 - i. +Register Inline opp. +Notation "- x" := (opp x) : int63_scope. + +Definition oppcarry i := max_int - i. +Register Inline oppcarry. + +Definition succ i := i + 1. +Register Inline succ. + +Definition pred i := i - 1. +Register Inline pred. + +Definition addcarry i j := i + j + 1. +Register Inline addcarry. + +Definition subcarry i j := i - j - 1. +Register Inline subcarry. + +(** Exact arithmetic operations *) + +Definition addc_def x y := + let r := x + y in + if r < x then C1 r else C0 r. +(* the same but direct implementation for effeciancy *) +Primitive addc := #int63_addc. +Notation "n '+c' m" := (addc n m) (at level 50, no associativity) : int63_scope. + +Definition addcarryc_def x y := + let r := addcarry x y in + if r <= x then C1 r else C0 r. +(* the same but direct implementation for effeciancy *) +Primitive addcarryc := #int63_addcarryc. + +Definition subc_def x y := + if y <= x then C0 (x - y) else C1 (x - y). +(* the same but direct implementation for effeciancy *) +Primitive subc := #int63_subc. +Notation "n '-c' m" := (subc n m) (at level 50, no associativity) : int63_scope. + +Definition subcarryc_def x y := + if y < x then C0 (x - y - 1) else C1 (x - y - 1). +(* the same but direct implementation for effeciancy *) +Primitive subcarryc := #int63_subcarryc. + +Definition diveucl_def x y := (x/y, x\%y). +(* the same but direct implementation for effeciancy *) +Primitive diveucl := #int63_diveucl. + +Primitive diveucl_21 := #int63_div21. + +Definition addmuldiv_def p x y := + (x << p) lor (y >> (digits - p)). +Primitive addmuldiv := #int63_addmuldiv. + +Definition oppc (i:int) := 0 -c i. +Register Inline oppc. + +Definition succc i := i +c 1. +Register Inline succc. + +Definition predc i := i -c 1. +Register Inline predc. + +(** Comparison *) +Definition compare_def x y := + if x < y then Lt + else if (x == y) then Eq else Gt. + +Primitive compare := #int63_compare. +Notation "n ?= m" := (compare n m) (at level 70, no associativity) : int63_scope. + +Import Bool ZArith. +(** Translation to Z *) +Fixpoint to_Z_rec (n:nat) (i:int) := + match n with + | O => 0%Z + | S n => + (if is_even i then Z.double else Zdouble_plus_one) (to_Z_rec n (i >> 1)) + end. + +Definition to_Z := to_Z_rec size. + +Fixpoint of_pos_rec (n:nat) (p:positive) := + match n, p with + | O, _ => 0 + | S n, xH => 1 + | S n, xO p => (of_pos_rec n p) << 1 + | S n, xI p => (of_pos_rec n p) << 1 lor 1 + end. + +Definition of_pos := of_pos_rec size. + +Definition of_Z z := + match z with + | Zpos p => of_pos p + | Z0 => 0 + | Zneg p => - (of_pos p) + end. + +Notation "[| x |]" := (to_Z x) (at level 0, x at level 99) : int63_scope. + +Definition wB := (2 ^ (Z.of_nat size))%Z. + +Lemma to_Z_rec_bounded size : forall x, (0 <= to_Z_rec size x < 2 ^ Z.of_nat size)%Z. +Proof. + elim size. simpl; auto with zarith. + intros n ih x; rewrite inj_S; simpl; assert (W := ih (x >> 1)%int63). + rewrite Z.pow_succ_r; auto with zarith. + destruct (is_even x). + rewrite Zdouble_mult; auto with zarith. + rewrite Zdouble_plus_one_mult; auto with zarith. +Qed. + +Corollary to_Z_bounded : forall x, (0 <= [| x |] < wB)%Z. +Proof. apply to_Z_rec_bounded. Qed. + +(* =================================================== *) +Local Open Scope Z_scope. +(* General arithmetic results *) +Lemma Z_lt_div2 x y : x < 2 * y -> x / 2 < y. +Proof. apply Z.div_lt_upper_bound; reflexivity. Qed. + +Theorem Zmod_le_first a b : 0 <= a -> 0 < b -> 0 <= a mod b <= a. +Proof. + intros ha hb; case (Z_mod_lt a b); [ auto with zarith | ]; intros p q; apply (conj p). + case (Z.le_gt_cases b a). lia. + intros hlt; rewrite Zmod_small; lia. +Qed. + +Theorem Zmod_distr: forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a -> + (2 ^a * r + t) mod (2 ^ b) = (2 ^a * r) mod (2 ^ b) + t. +Proof. + intros a b r t (H1, H2) H3 (H4, H5). + assert (t < 2 ^ b). + apply Z.lt_le_trans with (1:= H5); auto with zarith. + apply Zpower_le_monotone; auto with zarith. + rewrite Zplus_mod; auto with zarith. + rewrite -> Zmod_small with (a := t); auto with zarith. + apply Zmod_small; auto with zarith. + split; auto with zarith. + assert (0 <= 2 ^a * r); auto with zarith. + apply Z.add_nonneg_nonneg; auto with zarith. + match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; + auto with zarith. + pattern (2 ^ b) at 2; replace (2 ^ b) with ((2 ^ b - 2 ^a) + 2 ^ a); + try ring. + apply Z.add_le_lt_mono; auto with zarith. + replace b with ((b - a) + a); try ring. + rewrite Zpower_exp; auto with zarith. + pattern (2 ^a) at 4; rewrite <- (Z.mul_1_l (2 ^a)); + try rewrite <- Z.mul_sub_distr_r. + rewrite (Z.mul_comm (2 ^(b - a))); rewrite Zmult_mod_distr_l; + auto with zarith. + rewrite (Z.mul_comm (2 ^a)); apply Z.mul_le_mono_nonneg_r; auto with zarith. + match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end. + apply Z.lt_gt; auto with zarith. + auto with zarith. +Qed. + +(* Results about pow2 *) +Lemma pow2_pos n : 0 <= n → 2 ^ n > 0. +Proof. intros h; apply Z.lt_gt, Zpower_gt_0; lia. Qed. + +Lemma pow2_nz n : 0 <= n → 2 ^ n ≠ 0. +Proof. intros h; generalize (pow2_pos _ h); lia. Qed. + +Hint Resolve pow2_pos pow2_nz : zarith. + +(* =================================================== *) + +(** Trivial lemmas without axiom *) + +Lemma wB_diff_0 : wB <> 0. +Proof. exact (fun x => let 'eq_refl := x in idProp). Qed. + +Lemma wB_pos : 0 < wB. +Proof. reflexivity. Qed. + +Lemma to_Z_0 : [|0|] = 0. +Proof. reflexivity. Qed. + +Lemma to_Z_1 : [|1|] = 1. +Proof. reflexivity. Qed. + +(* Notations *) +Local Open Scope Z_scope. + +Notation "[+| c |]" := + (interp_carry 1 wB to_Z c) (at level 0, c at level 99) : int63_scope. + +Notation "[-| c |]" := + (interp_carry (-1) wB to_Z c) (at level 0, c at level 99) : int63_scope. + +Notation "[|| x ||]" := + (zn2z_to_Z wB to_Z x) (at level 0, x at level 99) : int63_scope. + +(* Bijection : int63 <-> Bvector size *) + +Axiom of_to_Z : forall x, of_Z [| x |] = x. + +Notation "'φ' x" := [| x |] (at level 0) : int63_scope. + +Lemma can_inj {rT aT} {f: aT -> rT} {g: rT -> aT} (K: forall a, g (f a) = a) {a a'} (e: f a = f a') : a = a'. +Proof. generalize (K a) (K a'). congruence. Qed. + +Lemma to_Z_inj x y : φ x = φ y → x = y. +Proof. exact (λ e, can_inj of_to_Z e). Qed. + +(** Specification of logical operations *) +Local Open Scope Z_scope. +Axiom lsl_spec : forall x p, [| x << p |] = [| x |] * 2 ^ [| p |] mod wB. + +Axiom lsr_spec : forall x p, [|x >> p|] = [|x|] / 2 ^ [|p|]. + +Axiom land_spec: forall x y i , bit (x land y) i = bit x i && bit y i. + +Axiom lor_spec: forall x y i, bit (x lor y) i = bit x i || bit y i. + +Axiom lxor_spec: forall x y i, bit (x lxor y) i = xorb (bit x i) (bit y i). + +(** Specification of basic opetations *) + +(* Arithmetic modulo operations *) + +(* Remarque : les axiomes seraient plus simple si on utilise of_Z a la place : + exemple : add_spec : forall x y, of_Z (x + y) = of_Z x + of_Z y. *) + +Axiom add_spec : forall x y, [|x + y|] = ([|x|] + [|y|]) mod wB. + +Axiom sub_spec : forall x y, [|x - y|] = ([|x|] - [|y|]) mod wB. + +Axiom mul_spec : forall x y, [| x * y |] = [|x|] * [|y|] mod wB. + +Axiom mulc_spec : forall x y, [|x|] * [|y|] = [|fst (mulc x y)|] * wB + [|snd (mulc x y)|]. + +Axiom div_spec : forall x y, [|x / y|] = [|x|] / [|y|]. + +Axiom mod_spec : forall x y, [|x \% y|] = [|x|] mod [|y|]. + +(* Comparisons *) +Axiom eqb_correct : forall i j, (i == j)%int63 = true -> i = j. + +Axiom eqb_refl : forall x, (x == x)%int63 = true. + +Axiom ltb_spec : forall x y, (x < y)%int63 = true <-> [|x|] < [|y|]. + +Axiom leb_spec : forall x y, (x <= y)%int63 = true <-> [|x|] <= [|y|]. + +(** Exotic operations *) + +(** I should add the definition (like for compare) *) +Primitive head0 := #int63_head0. +Primitive tail0 := #int63_tail0. + +(** Axioms on operations which are just short cut *) + +Axiom compare_def_spec : forall x y, compare x y = compare_def x y. + +Axiom head0_spec : forall x, 0 < [|x|] -> + wB/ 2 <= 2 ^ ([|head0 x|]) * [|x|] < wB. + +Axiom tail0_spec : forall x, 0 < [|x|] -> + (exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|tail0 x|]))%Z. + +Axiom addc_def_spec : forall x y, (x +c y)%int63 = addc_def x y. + +Axiom addcarryc_def_spec : forall x y, addcarryc x y = addcarryc_def x y. + +Axiom subc_def_spec : forall x y, (x -c y)%int63 = subc_def x y. + +Axiom subcarryc_def_spec : forall x y, subcarryc x y = subcarryc_def x y. + +Axiom diveucl_def_spec : forall x y, diveucl x y = diveucl_def x y. + +Axiom diveucl_21_spec : forall a1 a2 b, + let (q,r) := diveucl_21 a1 a2 b in + ([|q|],[|r|]) = Z.div_eucl ([|a1|] * wB + [|a2|]) [|b|]. + +Axiom addmuldiv_def_spec : forall p x y, + addmuldiv p x y = addmuldiv_def p x y. + +(** Square root functions using newton iteration **) +Local Open Scope int63_scope. + +Definition sqrt_step (rec: int -> int -> int) (i j: int) := + let quo := i / j in + if quo < j then rec i ((j + quo) >> 1) + else j. + +Definition iter_sqrt := + Eval lazy beta delta [sqrt_step] in + fix iter_sqrt (n: nat) (rec: int -> int -> int) + (i j: int) {struct n} : int := + sqrt_step + (fun i j => match n with + O => rec i j + | S n => (iter_sqrt n (iter_sqrt n rec)) i j + end) i j. + +Definition sqrt i := + match compare 1 i with + Gt => 0 + | Eq => 1 + | Lt => iter_sqrt size (fun i j => j) i (i >> 1) + end. + +Definition high_bit := 1 << (digits - 1). + +Definition sqrt2_step (rec: int -> int -> int -> int) + (ih il j: int) := + if ih < j then + let (quo,_) := diveucl_21 ih il j in + if quo < j then + match j +c quo with + | C0 m1 => rec ih il (m1 >> 1) + | C1 m1 => rec ih il ((m1 >> 1) + high_bit) + end + else j + else j. + +Definition iter2_sqrt := + Eval lazy beta delta [sqrt2_step] in + fix iter2_sqrt (n: nat) + (rec: int -> int -> int -> int) + (ih il j: int) {struct n} : int := + sqrt2_step + (fun ih il j => + match n with + | O => rec ih il j + | S n => (iter2_sqrt n (iter2_sqrt n rec)) ih il j + end) ih il j. + +Definition sqrt2 ih il := + let s := iter2_sqrt size (fun ih il j => j) ih il max_int in + let (ih1, il1) := mulc s s in + match il -c il1 with + | C0 il2 => + if ih1 < ih then (s, C1 il2) else (s, C0 il2) + | C1 il2 => + if ih1 < (ih - 1) then (s, C1 il2) else (s, C0 il2) + end. + +(** Gcd **) +Fixpoint gcd_rec (guard:nat) (i j:int) {struct guard} := + match guard with + | O => 1 + | S p => if j == 0 then i else gcd_rec p j (i \% j) + end. + +Definition gcd := gcd_rec (2*size). + +(** equality *) +Lemma eqb_complete : forall x y, x = y -> (x == y) = true. +Proof. + intros x y H; rewrite -> H, eqb_refl;trivial. +Qed. + +Lemma eqb_spec : forall x y, (x == y) = true <-> x = y. +Proof. + split;auto using eqb_correct, eqb_complete. +Qed. + +Lemma eqb_false_spec : forall x y, (x == y) = false <-> x <> y. +Proof. + intros;rewrite <- not_true_iff_false, eqb_spec;split;trivial. +Qed. + +Lemma eqb_false_complete : forall x y, x <> y -> (x == y) = false. +Proof. + intros x y;rewrite eqb_false_spec;trivial. +Qed. + +Lemma eqb_false_correct : forall x y, (x == y) = false -> x <> y. +Proof. + intros x y;rewrite eqb_false_spec;trivial. +Qed. + +Definition eqs (i j : int) : {i = j} + { i <> j } := + (if i == j as b return ((b = true -> i = j) -> (b = false -> i <> j) -> {i=j} + {i <> j} ) + then fun (Heq : true = true -> i = j) _ => left _ (Heq (eq_refl true)) + else fun _ (Hdiff : false = false -> i <> j) => right _ (Hdiff (eq_refl false))) + (eqb_correct i j) + (eqb_false_correct i j). + +Lemma eq_dec : forall i j:int, i = j \/ i <> j. +Proof. + intros i j;destruct (eqs i j);auto. +Qed. + +(* Extra function on equality *) + +Definition cast i j := + (if i == j as b return ((b = true -> i = j) -> option (forall P : int -> Type, P i -> P j)) + then fun Heq : true = true -> i = j => + Some + (fun (P : int -> Type) (Hi : P i) => + match Heq (eq_refl true) in (_ = y) return (P y) with + | eq_refl => Hi + end) + else fun _ : false = true -> i = j => None) (eqb_correct i j). + +Lemma cast_refl : forall i, cast i i = Some (fun P H => H). +Proof. + unfold cast;intros. + generalize (eqb_correct i i). + rewrite eqb_refl;intros. + rewrite (Eqdep_dec.eq_proofs_unicity eq_dec (e (eq_refl true)) (eq_refl i));trivial. +Qed. + +Lemma cast_diff : forall i j, i == j = false -> cast i j = None. +Proof. + intros;unfold cast;intros; generalize (eqb_correct i j). + rewrite H;trivial. +Qed. + +Definition eqo i j := + (if i == j as b return ((b = true -> i = j) -> option (i=j)) + then fun Heq : true = true -> i = j => + Some (Heq (eq_refl true)) + else fun _ : false = true -> i = j => None) (eqb_correct i j). + +Lemma eqo_refl : forall i, eqo i i = Some (eq_refl i). +Proof. + unfold eqo;intros. + generalize (eqb_correct i i). + rewrite eqb_refl;intros. + rewrite (Eqdep_dec.eq_proofs_unicity eq_dec (e (eq_refl true)) (eq_refl i));trivial. +Qed. + +Lemma eqo_diff : forall i j, i == j = false -> eqo i j = None. +Proof. + unfold eqo;intros; generalize (eqb_correct i j). + rewrite H;trivial. +Qed. + +(** Comparison *) + +Lemma eqbP x y : reflect ([| x |] = [| y |]) (x == y). +Proof. apply iff_reflect; rewrite eqb_spec; split; [ apply to_Z_inj | apply f_equal ]. Qed. + +Lemma ltbP x y : reflect ([| x |] < [| y |])%Z (x < y). +Proof. apply iff_reflect; symmetry; apply ltb_spec. Qed. + +Lemma lebP x y : reflect ([| x |] <= [| y |])%Z (x ≤ y). +Proof. apply iff_reflect; symmetry; apply leb_spec. Qed. + +Lemma compare_spec x y : compare x y = ([|x|] ?= [|y|])%Z. +Proof. + rewrite compare_def_spec; unfold compare_def. + case ltbP; [ auto using Z.compare_lt_iff | intros hge ]. + case eqbP; [ now symmetry; apply Z.compare_eq_iff | intros hne ]. + symmetry; apply Z.compare_gt_iff; lia. +Qed. + +Lemma is_zero_spec x : is_zero x = true <-> x = 0%int63. +Proof. apply eqb_spec. Qed. + +Lemma diveucl_spec x y : + let (q,r) := diveucl x y in + ([| q |], [| r |]) = Z.div_eucl [| x |] [| y |]. +Proof. + rewrite diveucl_def_spec; unfold diveucl_def; rewrite div_spec, mod_spec; unfold Z.div, Zmod. + destruct (Z.div_eucl [| x |] [| y |]); trivial. +Qed. + +Local Open Scope Z_scope. +(** Addition *) +Lemma addc_spec x y : [+| x +c y |] = [| x |] + [| y |]. +Proof. + rewrite addc_def_spec; unfold addc_def, interp_carry. + pose proof (to_Z_bounded x); pose proof (to_Z_bounded y). + case ltbP; rewrite add_spec. + case (Z_lt_ge_dec ([| x |] + [| y |]) wB). + intros k; rewrite Zmod_small; lia. + intros hge; rewrite <- (Zmod_unique _ _ 1 ([| x |] + [| y |] - wB)); lia. + case (Z_lt_ge_dec ([| x |] + [| y |]) wB). + intros k; rewrite Zmod_small; lia. + intros hge; rewrite <- (Zmod_unique _ _ 1 ([| x |] + [| y |] - wB)); lia. +Qed. + +Lemma succ_spec x : [| succ x |] = ([| x |] + 1) mod wB. +Proof. apply add_spec. Qed. + +Lemma succc_spec x : [+| succc x |] = [| x |] + 1. +Proof. apply addc_spec. Qed. + +Lemma addcarry_spec x y : [| addcarry x y |] = ([| x |] + [| y |] + 1) mod wB. +Proof. unfold addcarry; rewrite -> !add_spec, Zplus_mod_idemp_l; trivial. Qed. + +Lemma addcarryc_spec x y : [+| addcarryc x y |] = [| x |] + [| y |] + 1. +Proof. + rewrite addcarryc_def_spec; unfold addcarryc_def, interp_carry. + pose proof (to_Z_bounded x); pose proof (to_Z_bounded y). + case lebP; rewrite addcarry_spec. + case (Z_lt_ge_dec ([| x |] + [| y |] + 1) wB). + intros hlt; rewrite Zmod_small; lia. + intros hge; rewrite <- (Zmod_unique _ _ 1 ([| x |] + [| y |] + 1 - wB)); lia. + case (Z_lt_ge_dec ([| x |] + [| y |] + 1) wB). + intros hlt; rewrite Zmod_small; lia. + intros hge; rewrite <- (Zmod_unique _ _ 1 ([| x |] + [| y |] + 1 - wB)); lia. +Qed. + +(** Subtraction *) +Lemma subc_spec x y : [-| x -c y |] = [| x |] - [| y |]. +Proof. + rewrite subc_def_spec; unfold subc_def; unfold interp_carry. + pose proof (to_Z_bounded x); pose proof (to_Z_bounded y). + case lebP. + intros hle; rewrite sub_spec, Z.mod_small; lia. + intros hgt; rewrite sub_spec, <- (Zmod_unique _ wB (-1) ([| x |] - [| y |] + wB)); lia. +Qed. + +Lemma pred_spec x : [| pred x |] = ([| x |] - 1) mod wB. +Proof. apply sub_spec. Qed. + +Lemma predc_spec x : [-| predc x |] = [| x |] - 1. +Proof. apply subc_spec. Qed. + +Lemma oppc_spec x : [-| oppc x |] = - [| x |]. +Proof. unfold oppc; rewrite -> subc_spec, to_Z_0; trivial. Qed. + +Lemma opp_spec x : [|- x |] = - [| x |] mod wB. +Proof. unfold opp; rewrite -> sub_spec, to_Z_0; trivial. Qed. + +Lemma oppcarry_spec x : [| oppcarry x |] = wB - [| x |] - 1. +Proof. + unfold oppcarry; rewrite sub_spec. + rewrite <- Zminus_plus_distr, Zplus_comm, Zminus_plus_distr. + apply Zmod_small. + generalize (to_Z_bounded x); auto with zarith. +Qed. + +Lemma subcarry_spec x y : [| subcarry x y |] = ([| x |] - [| y |] - 1) mod wB. +Proof. unfold subcarry; rewrite !sub_spec, Zminus_mod_idemp_l; trivial. Qed. + +Lemma subcarryc_spec x y : [-| subcarryc x y |] = [| x |] - [| y |] - 1. +Proof. + rewrite subcarryc_def_spec; unfold subcarryc_def, interp_carry; fold (subcarry x y). + pose proof (to_Z_bounded x); pose proof (to_Z_bounded y). + case ltbP; rewrite subcarry_spec. + intros hlt; rewrite Zmod_small; lia. + intros hge; rewrite <- (Zmod_unique _ _ (-1) ([| x |] - [| y |] - 1 + wB)); lia. +Qed. + +(** GCD *) +Lemma to_Z_gcd : forall i j, [| gcd i j |] = Zgcdn (2 * size) [| j |] [| i |]. +Proof. + unfold gcd. + elim (2*size)%nat. reflexivity. + intros n ih i j; simpl. + pose proof (to_Z_bounded j) as hj; pose proof (to_Z_bounded i). + case eqbP; rewrite to_Z_0. + intros ->; rewrite Z.abs_eq; lia. + intros hne; rewrite ih; clear ih. + rewrite <- mod_spec. + revert hj hne; case [| j |]; intros; lia. +Qed. + +Lemma gcd_spec a b : Zis_gcd [| a |] [| b |] [| gcd a b |]. +Proof. + rewrite to_Z_gcd. + apply Zis_gcd_sym. + apply Zgcdn_is_gcd. + unfold Zgcd_bound. + generalize (to_Z_bounded b). + destruct [|b|]. + unfold size; auto with zarith. + intros (_,H). + cut (Psize p <= size)%nat; [ lia | rewrite <- Zpower2_Psize; auto]. + intros (H,_); compute in H; elim H; auto. +Qed. + +(** Head0, Tail0 *) +Lemma head00_spec x : [| x |] = 0 -> [| head0 x |] = [| digits |]. +Proof. now intros h; rewrite (to_Z_inj _ 0 h). Qed. + +Lemma tail00_spec x : [| x |] = 0 -> [|tail0 x|] = [|digits|]. +Proof. now intros h; rewrite (to_Z_inj _ 0 h). Qed. + +Infix "≡" := (eqm wB) (at level 80) : int63_scope. + +Lemma eqm_mod x y : x mod wB ≡ y mod wB → x ≡ y. +Proof. + intros h. + eapply (eqm_trans). + apply eqm_sym; apply Zmod_eqm. + apply (eqm_trans _ _ _ _ h). + apply Zmod_eqm. +Qed. + +Lemma eqm_sub x y : x ≡ y → x - y ≡ 0. +Proof. intros h; unfold eqm; rewrite Zminus_mod, h, Z.sub_diag; reflexivity. Qed. + +Lemma eqmE x y : x ≡ y → ∃ k, x - y = k * wB. +Proof. + intros h. + exact (Zmod_divide (x - y) wB (λ e, let 'eq_refl := e in I) (eqm_sub _ _ h)). +Qed. + +Lemma eqm_subE x y : x ≡ y ↔ x - y ≡ 0. +Proof. + split. apply eqm_sub. + intros h; case (eqmE _ _ h); clear h; intros q h. + assert (y = x - q * wB) by lia. + clear h; subst y. + unfold eqm; rewrite Zminus_mod, Z_mod_mult, Z.sub_0_r, Zmod_mod; reflexivity. +Qed. + +Lemma int_eqm x y : x = y → φ x ≡ φ y. +Proof. unfold eqm; intros ->; reflexivity. Qed. + +Lemma eqmI x y : φ x ≡ φ y → x = y. +Proof. + unfold eqm. + repeat rewrite Zmod_small by apply to_Z_bounded. + apply to_Z_inj. +Qed. + +(* ADD *) +Lemma add_assoc x y z: (x + (y + z) = (x + y) + z)%int63. +Proof. + apply to_Z_inj; rewrite !add_spec. + rewrite -> Zplus_mod_idemp_l, Zplus_mod_idemp_r, Zplus_assoc; auto. +Qed. + +Lemma add_comm x y: (x + y = y + x)%int63. +Proof. + apply to_Z_inj; rewrite -> !add_spec, Zplus_comm; auto. +Qed. + +Lemma add_le_r m n: + if (n <= m + n)%int63 then ([|m|] + [|n|] < wB)%Z else (wB <= [|m|] + [|n|])%Z. +Proof. + case (to_Z_bounded m); intros H1m H2m. + case (to_Z_bounded n); intros H1n H2n. + case (Zle_or_lt wB ([|m|] + [|n|])); intros H. + assert (H1: ([| m + n |] = [|m|] + [|n|] - wB)%Z). + rewrite add_spec. + replace (([|m|] + [|n|]) mod wB)%Z with (((([|m|] + [|n|]) - wB) + wB) mod wB)%Z. + rewrite -> Zplus_mod, Z_mod_same_full, Zplus_0_r, !Zmod_small; auto with zarith. + rewrite !Zmod_small; auto with zarith. + apply f_equal2 with (f := Zmod); auto with zarith. + case_eq (n <= m + n)%int63; auto. + rewrite leb_spec, H1; auto with zarith. + assert (H1: ([| m + n |] = [|m|] + [|n|])%Z). + rewrite add_spec, Zmod_small; auto with zarith. + replace (n <= m + n)%int63 with true; auto. + apply sym_equal; rewrite leb_spec, H1; auto with zarith. +Qed. + +Lemma add_cancel_l x y z : (x + y = x + z)%int63 -> y = z. +Proof. + intros h; apply int_eqm in h; rewrite !add_spec in h; apply eqm_mod, eqm_sub in h. + replace (_ + _ - _) with (φ(y) - φ(z)) in h by lia. + rewrite <- eqm_subE in h. + apply eqmI, h. +Qed. + +Lemma add_cancel_r x y z : (y + x = z + x)%int63 -> y = z. +Proof. + rewrite !(fun t => add_comm t x); intros Hl; apply (add_cancel_l x); auto. +Qed. + +Coercion b2i (b: bool) : int := if b then 1%int63 else 0%int63. + +(* LSR *) +Lemma lsr0 i : 0 >> i = 0%int63. +Proof. apply to_Z_inj; rewrite lsr_spec; reflexivity. Qed. + +Lemma lsr_0_r i: i >> 0 = i. +Proof. apply to_Z_inj; rewrite lsr_spec, Zdiv_1_r; exact eq_refl. Qed. + +Lemma lsr_1 n : 1 >> n = (n == 0). +Proof. + case eqbP. + intros h; rewrite (to_Z_inj _ _ h), lsr_0_r; reflexivity. + intros Hn. + assert (H1n : (1 >> n = 0)%int63); auto. + apply to_Z_inj; rewrite lsr_spec. + apply Zdiv_small; rewrite to_Z_1; split; auto with zarith. + change 1%Z with (2^0)%Z. + apply Zpower_lt_monotone; split; auto with zarith. + rewrite to_Z_0 in Hn. + generalize (to_Z_bounded n). + lia. +Qed. + +Lemma lsr_add i m n: ((i >> m) >> n = if n <= m + n then i >> (m + n) else 0)%int63. +Proof. + case (to_Z_bounded m); intros H1m H2m. + case (to_Z_bounded n); intros H1n H2n. + case (to_Z_bounded i); intros H1i H2i. + generalize (add_le_r m n); case (n <= m + n)%int63; intros H. + apply to_Z_inj; rewrite -> !lsr_spec, Zdiv_Zdiv, <- Zpower_exp; auto with zarith. + rewrite add_spec, Zmod_small; auto with zarith. + apply to_Z_inj; rewrite -> !lsr_spec, Zdiv_Zdiv, <- Zpower_exp; auto with zarith. + apply Zdiv_small. split; [ auto with zarith | ]. + eapply Z.lt_le_trans; [ | apply Zpower2_le_lin ]; auto with zarith. +Qed. + +Lemma lsr_add_distr x y n: (x + y) << n = ((x << n) + (y << n))%int63. +Proof. + apply to_Z_inj. + rewrite -> add_spec, !lsl_spec, add_spec. + rewrite -> Zmult_mod_idemp_l, <-Zplus_mod. + apply f_equal2 with (f := Zmod); auto with zarith. +Qed. + +(* LSL *) +Lemma lsl0 i: 0 << i = 0%int63. +Proof. + apply to_Z_inj. + generalize (lsl_spec 0 i). + rewrite to_Z_0, Zmult_0_l, Zmod_0_l; auto. +Qed. + +Lemma lsl0_r i : i << 0 = i. +Proof. + apply to_Z_inj. + rewrite -> lsl_spec, to_Z_0, Z.mul_1_r. + apply Zmod_small; apply (to_Z_bounded i). +Qed. + +Lemma lsl_add_distr x y n: (x + y) << n = ((x << n) + (y << n))%int63. +Proof. + apply to_Z_inj; rewrite -> !lsl_spec, !add_spec, Zmult_mod_idemp_l. + rewrite -> !lsl_spec, <-Zplus_mod. + apply f_equal2 with (f := Zmod); auto with zarith. +Qed. + +Lemma lsr_M_r x i (H: (digits <= i = true)%int63) : x >> i = 0%int63. +Proof. + apply to_Z_inj. + rewrite lsr_spec, to_Z_0. + case (to_Z_bounded x); intros H1x H2x. + case (to_Z_bounded digits); intros H1d H2d. + rewrite -> leb_spec in H. + apply Zdiv_small; split; [ auto | ]. + apply (Z.lt_le_trans _ _ _ H2x). + unfold wB; change (Z_of_nat size) with [|digits|]. + apply Zpower_le_monotone; auto with zarith. +Qed. + +(* BIT *) +Lemma bit_0_spec i: [|bit i 0|] = [|i|] mod 2. +Proof. + unfold bit, is_zero. rewrite lsr_0_r. + assert (Hbi: ([|i|] mod 2 < 2)%Z). + apply Z_mod_lt; auto with zarith. + case (to_Z_bounded i); intros H1i H2i. + case (Zmod_le_first [|i|] 2); auto with zarith; intros H3i H4i. + assert (H2b: (0 < 2 ^ [|digits - 1|])%Z). + apply Zpower_gt_0; auto with zarith. + case (to_Z_bounded (digits -1)); auto with zarith. + assert (H: [|i << (digits -1)|] = ([|i|] mod 2 * 2^ [|digits -1|])%Z). + rewrite lsl_spec. + rewrite -> (Z_div_mod_eq [|i|] 2) at 1; auto with zarith. + rewrite -> Zmult_plus_distr_l, <-Zplus_mod_idemp_l. + rewrite -> (Zmult_comm 2), <-Zmult_assoc. + replace (2 * 2 ^ [|digits - 1|])%Z with wB; auto. + rewrite Z_mod_mult, Zplus_0_l; apply Zmod_small. + split; auto with zarith. + replace wB with (2 * 2 ^ [|digits -1|])%Z; auto. + apply Zmult_lt_compat_r; auto with zarith. + case (Zle_lt_or_eq 0 ([|i|] mod 2)); auto with zarith; intros Hi. + 2: generalize H; rewrite <-Hi, Zmult_0_l. + 2: replace 0%Z with [|0|]; auto. + 2: now case eqbP. + generalize H; replace ([|i|] mod 2) with 1%Z; auto with zarith. + rewrite Zmult_1_l. + intros H1. + assert (H2: [|i << (digits - 1)|] <> [|0|]). + replace [|0|] with 0%Z; auto with zarith. + now case eqbP. +Qed. + +Lemma bit_split i : ( i = (i >> 1 ) << 1 + bit i 0)%int63. +Proof. + apply to_Z_inj. + rewrite -> add_spec, lsl_spec, lsr_spec, bit_0_spec, Zplus_mod_idemp_l. + replace (2 ^ [|1|]) with 2%Z; auto with zarith. + rewrite -> Zmult_comm, <-Z_div_mod_eq; auto with zarith. + rewrite Zmod_small; auto; case (to_Z_bounded i); auto. +Qed. + +Lemma bit_lsr x i j : + (bit (x >> i) j = if j <= i + j then bit x (i + j) else false)%int63. +Proof. + unfold bit; rewrite lsr_add; case (_ ≤ _); auto. +Qed. + +Lemma bit_b2i (b: bool) i : bit b i = (i == 0) && b. +Proof. + case b; unfold bit; simpl b2i. + rewrite lsr_1; case (i == 0); auto. + rewrite lsr0, lsl0, andb_false_r; auto. +Qed. + +Lemma bit_1 n : bit 1 n = (n == 0). +Proof. + unfold bit; rewrite lsr_1. + case (_ == _); simpl; auto. +Qed. + +Local Hint Resolve Z.lt_gt Z.div_pos : zarith. + +Lemma to_Z_split x : [|x|] = [|(x >> 1)|] * 2 + [|bit x 0|]. +Proof. + case (to_Z_bounded x); intros H1x H2x. + case (to_Z_bounded (bit x 0)); intros H1b H2b. + assert (F1: 0 <= [|x >> 1|] < wB/2). + rewrite -> lsr_spec, to_Z_1, Z.pow_1_r. split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + rewrite -> (bit_split x) at 1. + rewrite -> add_spec, Zmod_small, lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small; + split; auto with zarith. + change wB with ((wB/2)*2); auto with zarith. + rewrite -> lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small; auto with zarith. + change wB with ((wB/2)*2); auto with zarith. + rewrite -> lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small; auto with zarith. + 2: change wB with ((wB/2)*2); auto with zarith. + change wB with (((wB/2 - 1) * 2 + 1) + 1). + assert ([|bit x 0|] <= 1); auto with zarith. + case bit; discriminate. +Qed. + +Lemma bit_M i n (H: (digits <= n = true)%int63): bit i n = false. +Proof. unfold bit; rewrite lsr_M_r; auto. Qed. + +Lemma bit_half i n (H: (n < digits = true)%int63) : bit (i>>1) n = bit i (n+1). +Proof. + unfold bit. + rewrite lsr_add. + case_eq (n <= (1 + n))%int63. + replace (1+n)%int63 with (n+1)%int63; [auto|idtac]. + apply to_Z_inj; rewrite !add_spec, Zplus_comm; auto. + intros H1; assert (H2: n = max_int). + 2: generalize H; rewrite H2; discriminate. + case (to_Z_bounded n); intros H1n H2n. + case (Zle_lt_or_eq [|n|] (wB - 1)); auto with zarith; + intros H2; apply to_Z_inj; auto. + generalize (add_le_r 1 n); rewrite H1. + change [|max_int|] with (wB - 1)%Z. + replace [|1|] with 1%Z; auto with zarith. +Qed. + +Lemma bit_ext i j : (forall n, bit i n = bit j n) -> i = j. +Proof. + case (to_Z_bounded j); case (to_Z_bounded i). + unfold wB; revert i j; elim size. + simpl; intros i j ???? _; apply to_Z_inj; lia. + intros n ih i j. + rewrite Nat2Z.inj_succ, Z.pow_succ_r by auto with zarith. + intros hi1 hi2 hj1 hj2 hext. + rewrite (bit_split i), (bit_split j), hext. + do 2 f_equal; apply ih; clear ih. + 1, 3: apply to_Z_bounded. + 1, 2: rewrite lsr_spec; auto using Z_lt_div2. + intros b. + case (Zle_or_lt [|digits|] [|b|]). + rewrite <- leb_spec; intros; rewrite !bit_M; auto. + rewrite <- ltb_spec; intros; rewrite !bit_half; auto. +Qed. + +Lemma bit_lsl x i j : bit (x << i) j = +(if (j < i) || (digits <= j) then false else bit x (j - i))%int63. +Proof. + assert (F1: 1 >= 0) by discriminate. + case_eq (digits <= j)%int63; intros H. + rewrite orb_true_r, bit_M; auto. + set (d := [|digits|]). + case (Zle_or_lt d [|j|]); intros H1. + case (leb_spec digits j); rewrite H; auto with zarith. + intros _ HH; generalize (HH H1); discriminate. + clear H. + generalize (ltb_spec j i); case ltb; intros H2; unfold bit; simpl. + assert (F2: ([|j|] < [|i|])%Z) by (case H2; auto); clear H2. + replace (is_zero (((x << i) >> j) << (digits - 1))) with true; auto. + case (to_Z_bounded j); intros H1j H2j. + apply sym_equal; rewrite is_zero_spec; apply to_Z_inj. + rewrite lsl_spec, lsr_spec, lsl_spec. + replace wB with (2^d); auto. + pattern d at 1; replace d with ((d - ([|j|] + 1)) + ([|j|] + 1))%Z by ring. + rewrite Zpower_exp; auto with zarith. + replace [|i|] with (([|i|] - ([|j|] + 1)) + ([|j|] + 1))%Z by ring. + rewrite -> Zpower_exp, Zmult_assoc; auto with zarith. + rewrite Zmult_mod_distr_r. + rewrite -> Zplus_comm, Zpower_exp, !Zmult_assoc; auto with zarith. + rewrite -> Z_div_mult_full; auto with zarith. + rewrite <-Zmult_assoc, <-Zpower_exp; auto with zarith. + replace (1 + [|digits - 1|])%Z with d; auto with zarith. + rewrite Z_mod_mult; auto. + case H2; intros _ H3; case (Zle_or_lt [|i|] [|j|]); intros F2. + 2: generalize (H3 F2); discriminate. + clear H2 H3. + apply f_equal with (f := negb). + apply f_equal with (f := is_zero). + apply to_Z_inj. + rewrite -> !lsl_spec, !lsr_spec, !lsl_spec. + pattern wB at 2 3; replace wB with (2^(1+ [|digits - 1|])); auto. + rewrite -> Zpower_exp, Z.pow_1_r; auto with zarith. + rewrite !Zmult_mod_distr_r. + apply f_equal2 with (f := Zmult); auto. + replace wB with (2^ d); auto with zarith. + replace d with ((d - [|i|]) + [|i|])%Z by ring. + case (to_Z_bounded i); intros H1i H2i. + rewrite Zpower_exp; auto with zarith. + rewrite Zmult_mod_distr_r. + case (to_Z_bounded j); intros H1j H2j. + replace [|j - i|] with ([|j|] - [|i|])%Z. + 2: rewrite sub_spec, Zmod_small; auto with zarith. + set (d1 := (d - [|i|])%Z). + set (d2 := ([|j|] - [|i|])%Z). + pattern [|j|] at 1; + replace [|j|] with (d2 + [|i|])%Z. + 2: unfold d2; ring. + rewrite -> Zpower_exp; auto with zarith. + rewrite -> Zdiv_mult_cancel_r. + 2: generalize (Zpower2_lt_lin [| i |] H1i); auto with zarith. + rewrite -> (Z_div_mod_eq [|x|] (2^d1)) at 2; auto with zarith. + pattern d1 at 2; + replace d1 with (d2 + (1+ (d - [|j|] - 1)))%Z + by (unfold d1, d2; ring). + rewrite Zpower_exp; auto with zarith. + rewrite <-Zmult_assoc, Zmult_comm. + rewrite Zdiv.Z_div_plus_full_l; auto with zarith. + rewrite Zpower_exp, Z.pow_1_r; auto with zarith. + rewrite <-Zplus_mod_idemp_l. + rewrite <-!Zmult_assoc, Zmult_comm, Z_mod_mult, Zplus_0_l; auto. +Qed. + +(* LOR *) +Lemma lor_lsr i1 i2 i: (i1 lor i2) >> i = (i1 >> i) lor (i2 >> i). +Proof. + apply bit_ext; intros n. + rewrite -> lor_spec, !bit_lsr, lor_spec. + case (_ <= _)%int63; auto. +Qed. + +Lemma lor_le x y : (y <= x lor y)%int63 = true. +Proof. + generalize x y (to_Z_bounded x) (to_Z_bounded y); clear x y. + unfold wB; elim size. + replace (2^Z_of_nat 0) with 1%Z; auto with zarith. + intros x y Hx Hy; replace x with 0%int63. + replace y with 0%int63; auto. + apply to_Z_inj; rewrite to_Z_0; auto with zarith. + apply to_Z_inj; rewrite to_Z_0; auto with zarith. + intros n IH x y; rewrite inj_S. + unfold Z.succ; rewrite -> Zpower_exp, Z.pow_1_r; auto with zarith. + intros Hx Hy. + rewrite leb_spec. + rewrite -> (to_Z_split y) at 1; rewrite (to_Z_split (x lor y)). + assert ([|y>>1|] <= [|(x lor y) >> 1|]). + rewrite -> lor_lsr, <-leb_spec; apply IH. + rewrite -> lsr_spec, to_Z_1, Z.pow_1_r; split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + rewrite -> lsr_spec, to_Z_1, Z.pow_1_r; split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + assert ([|bit y 0|] <= [|bit (x lor y) 0|]); auto with zarith. + rewrite lor_spec; do 2 case bit; try discriminate. +Qed. + +Lemma bit_0 n : bit 0 n = false. +Proof. unfold bit; rewrite lsr0; auto. Qed. + +Lemma bit_add_or x y: + (forall n, bit x n = true -> bit y n = true -> False) <-> (x + y)%int63= x lor y. +Proof. + generalize x y (to_Z_bounded x) (to_Z_bounded y); clear x y. + unfold wB; elim size. + replace (2^Z_of_nat 0) with 1%Z; auto with zarith. + intros x y Hx Hy; replace x with 0%int63. + replace y with 0%int63. + split; auto; intros _ n; rewrite !bit_0; discriminate. + apply to_Z_inj; rewrite to_Z_0; auto with zarith. + apply to_Z_inj; rewrite to_Z_0; auto with zarith. + intros n IH x y; rewrite inj_S. + unfold Z.succ; rewrite Zpower_exp, Z.pow_1_r; auto with zarith. + intros Hx Hy. + split. + intros Hn. + assert (F1: ((x >> 1) + (y >> 1))%int63 = (x >> 1) lor (y >> 1)). + apply IH. + rewrite lsr_spec, Z.pow_1_r; split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + rewrite lsr_spec, Z.pow_1_r; split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + intros m H1 H2. + case_eq (digits <= m)%int63; [idtac | rewrite <- not_true_iff_false]; + intros Heq. + rewrite bit_M in H1; auto; discriminate. + rewrite leb_spec in Heq. + apply (Hn (m + 1)%int63); + rewrite <-bit_half; auto; rewrite ltb_spec; auto with zarith. + rewrite (bit_split (x lor y)), lor_lsr, <- F1, lor_spec. + replace (b2i (bit x 0 || bit y 0)) with (bit x 0 + bit y 0)%int63. + 2: generalize (Hn 0%int63); do 2 case bit; auto; intros [ ]; auto. + rewrite lsl_add_distr. + rewrite (bit_split x) at 1; rewrite (bit_split y) at 1. + rewrite <-!add_assoc; apply f_equal2 with (f := add); auto. + rewrite add_comm, <-!add_assoc; apply f_equal2 with (f := add); auto. + rewrite add_comm; auto. + intros Heq. + generalize (add_le_r x y); rewrite Heq, lor_le; intro Hb. + generalize Heq; rewrite (bit_split x) at 1; rewrite (bit_split y )at 1; clear Heq. + rewrite (fun y => add_comm y (bit x 0)), <-!add_assoc, add_comm, + <-!add_assoc, (add_comm (bit y 0)), add_assoc, <-lsr_add_distr. + rewrite (bit_split (x lor y)), lor_spec. + intros Heq. + assert (F: (bit x 0 + bit y 0)%int63 = (bit x 0 || bit y 0)). + assert (F1: (2 | wB)) by (apply Zpower_divide; apply refl_equal). + assert (F2: 0 < wB) by (apply refl_equal). + assert (F3: [|bit x 0 + bit y 0|] mod 2 = [|bit x 0 || bit y 0|] mod 2). + apply trans_equal with (([|(x>>1 + y>>1) << 1|] + [|bit x 0 + bit y 0|]) mod 2). + rewrite lsl_spec, Zplus_mod, <-Zmod_div_mod; auto with zarith. + rewrite Z.pow_1_r, Z_mod_mult, Zplus_0_l, Zmod_mod; auto with zarith. + rewrite (Zmod_div_mod 2 wB), <-add_spec, Heq; auto with zarith. + rewrite add_spec, <-Zmod_div_mod; auto with zarith. + rewrite lsl_spec, Zplus_mod, <-Zmod_div_mod; auto with zarith. + rewrite Z.pow_1_r, Z_mod_mult, Zplus_0_l, Zmod_mod; auto with zarith. + generalize F3; do 2 case bit; try discriminate; auto. + case (IH (x >> 1) (y >> 1)). + rewrite lsr_spec, to_Z_1, Z.pow_1_r; split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + rewrite lsr_spec, to_Z_1, Z.pow_1_r; split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + intros _ HH m; case (to_Z_bounded m); intros H1m H2m. + case_eq (digits <= m)%int63. + intros Hlm; rewrite bit_M; auto; discriminate. + rewrite <- not_true_iff_false, leb_spec; intros Hlm. + case (Zle_lt_or_eq 0 [|m|]); auto; intros Hm. + replace m with ((m -1) + 1)%int63. + rewrite <-(bit_half x), <-(bit_half y); auto with zarith. + apply HH. + rewrite <-lor_lsr. + assert (0 <= [|bit (x lor y) 0|] <= 1) by (case bit; split; discriminate). + rewrite F in Heq; generalize (add_cancel_r _ _ _ Heq). + intros Heq1; apply to_Z_inj. + generalize (f_equal to_Z Heq1); rewrite lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small. + rewrite lsl_spec, to_Z_1, Z.pow_1_r, Zmod_small; auto with zarith. + case (to_Z_bounded (x lor y)); intros H1xy H2xy. + rewrite lsr_spec, to_Z_1, Z.pow_1_r; auto with zarith. + change wB with ((wB/2)*2); split; auto with zarith. + assert ([|x lor y|] / 2 < wB / 2); auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + split. + case (to_Z_bounded (x >> 1 + y >> 1)); auto with zarith. + rewrite add_spec. + apply Z.le_lt_trans with (([|x >> 1|] + [|y >> 1|]) * 2); auto with zarith. + case (Zmod_le_first ([|x >> 1|] + [|y >> 1|]) wB); auto with zarith. + case (to_Z_bounded (x >> 1)); case (to_Z_bounded (y >> 1)); auto with zarith. + generalize Hb; rewrite (to_Z_split x) at 1; rewrite (to_Z_split y) at 1. + case (to_Z_bounded (bit x 0)); case (to_Z_bounded (bit y 0)); auto with zarith. + rewrite ltb_spec, sub_spec, to_Z_1, Zmod_small; auto with zarith. + rewrite ltb_spec, sub_spec, to_Z_1, Zmod_small; auto with zarith. + apply to_Z_inj. + rewrite add_spec, sub_spec, Zplus_mod_idemp_l, to_Z_1, Zmod_small; auto with zarith. + pose proof (to_Z_inj 0 _ Hm); clear Hm; subst m. + intros hx hy; revert F; rewrite hx, hy; intros F. generalize (f_equal to_Z F). vm_compute. lia. +Qed. + +Lemma addmuldiv_spec x y p : + [| p |] <= [| digits |] -> + [| addmuldiv p x y |] = ([| x |] * (2 ^ [| p |]) + [| y |] / (2 ^ ([| digits |] - [| p |]))) mod wB. +Proof. + intros H. + assert (Fp := to_Z_bounded p); assert (Fd := to_Z_bounded digits). + rewrite addmuldiv_def_spec; unfold addmuldiv_def. + case (bit_add_or (x << p) (y >> (digits - p))); intros HH _. + rewrite <-HH, add_spec, lsl_spec, lsr_spec, Zplus_mod_idemp_l, sub_spec. + rewrite (fun x y => Zmod_small (x - y)); auto with zarith. + intros n; rewrite -> bit_lsl, bit_lsr. + generalize (add_le_r (digits - p) n). + case (_ ≤ _); try discriminate. + rewrite -> sub_spec, Zmod_small; auto with zarith; intros H1. + case_eq (n < p)%int63; try discriminate. + rewrite <- not_true_iff_false, ltb_spec; intros H2. + case (_ ≤ _); try discriminate. + intros _; rewrite bit_M; try discriminate. + rewrite -> leb_spec, add_spec, Zmod_small, sub_spec, Zmod_small; auto with zarith. + rewrite -> sub_spec, Zmod_small; auto with zarith. +Qed. + +(* is_even *) +Lemma is_even_bit i : is_even i = negb (bit i 0). +Proof. + unfold is_even. + replace (i land 1) with (b2i (bit i 0)). + case bit; auto. + apply bit_ext; intros n. + rewrite bit_b2i, land_spec, bit_1. + generalize (eqb_spec n 0). + case (n == 0); auto. + intros(H,_); rewrite andb_true_r, H; auto. + rewrite andb_false_r; auto. +Qed. + +Lemma is_even_spec x : if is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1. +Proof. +rewrite is_even_bit. +generalize (bit_0_spec x); case bit; simpl; auto. +Qed. + +Lemma is_even_0 : is_even 0 = true. +Proof. apply refl_equal. Qed. + +Lemma is_even_lsl_1 i : is_even (i << 1) = true. +Proof. + rewrite is_even_bit, bit_lsl; auto. +Qed. + +(* Sqrt *) + + (* Direct transcription of an old proof + of a fortran program in boyer-moore *) + +Ltac elim_div := + unfold Z.div, Z.modulo; + match goal with + | H : context[ Z.div_eucl ?X ?Y ] |- _ => + generalize dependent H; generalize (Z_div_mod_full X Y) ; case (Z.div_eucl X Y) + | |- context[ Z.div_eucl ?X ?Y ] => + generalize (Z_div_mod_full X Y) ; case (Z.div_eucl X Y) + end; unfold Remainder. + +Lemma quotient_by_2 a: a - 1 <= (a/2) + (a/2). +Proof. + case (Z_mod_lt a 2); auto with zarith. + intros H1; rewrite Zmod_eq_full; auto with zarith. +Qed. + +Lemma sqrt_main_trick j k: 0 <= j -> 0 <= k -> + (j * k) + j <= ((j + k)/2 + 1) ^ 2. +Proof. + intros Hj; generalize Hj k; pattern j; apply natlike_ind; + auto; clear k j Hj. + intros _ k Hk; repeat rewrite Zplus_0_l. + apply Zmult_le_0_compat; generalize (Z_div_pos k 2); auto with zarith. + intros j Hj Hrec _ k Hk; pattern k; apply natlike_ind; auto; clear k Hk. + rewrite -> Zmult_0_r, Zplus_0_r, Zplus_0_l. + generalize (sqr_pos (Z.succ j / 2)) (quotient_by_2 (Z.succ j)); + unfold Z.succ. + rewrite Z.pow_2_r, Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. + auto with zarith. + intros k Hk _. + replace ((Z.succ j + Z.succ k) / 2) with ((j + k)/2 + 1). + generalize (Hrec Hj k Hk) (quotient_by_2 (j + k)). + unfold Z.succ; repeat rewrite Z.pow_2_r; + repeat rewrite Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. + repeat rewrite Zmult_1_l; repeat rewrite Zmult_1_r. + auto with zarith. + rewrite -> Zplus_comm, <- Z_div_plus_full_l; auto with zarith. + apply f_equal2; auto with zarith. +Qed. + +Lemma sqrt_main i j: 0 <= i -> 0 < j -> i < ((j + (i/j))/2 + 1) ^ 2. +Proof. + intros Hi Hj. + assert (Hij: 0 <= i/j) by (apply Z_div_pos; auto with zarith). + refine (Z.lt_le_trans _ _ _ _ (sqrt_main_trick _ _ (Zlt_le_weak _ _ Hj) Hij)). + pattern i at 1; rewrite -> (Z_div_mod_eq i j); case (Z_mod_lt i j); auto with zarith. +Qed. + +Lemma sqrt_test_false i j: 0 <= i -> 0 < j -> i/j < j -> (j + (i/j))/2 < j. +Proof. + intros Hi Hj; elim_div; intros q r [ ? hr ]; [ lia | subst i ]. + elim_div; intros a b [ h [ hb | ] ]; lia. +Qed. + +Lemma sqrt_test_true i j: 0 <= i -> 0 < j -> i/j >= j -> j ^ 2 <= i. +Proof. + intros Hi Hj Hd; rewrite Z.pow_2_r. + apply Z.le_trans with (j * (i/j)); auto with zarith. + apply Z_mult_div_ge; auto with zarith. +Qed. + +Lemma sqrt_step_correct rec i j: + 0 < [|i|] -> 0 < [|j|] -> [|i|] < ([|j|] + 1) ^ 2 -> + 2 * [|j|] < wB -> + (forall j1 : int, + 0 < [|j1|] < [|j|] -> [|i|] < ([|j1|] + 1) ^ 2 -> + [|rec i j1|] ^ 2 <= [|i|] < ([|rec i j1|] + 1) ^ 2) -> + [|sqrt_step rec i j|] ^ 2 <= [|i|] < ([|sqrt_step rec i j|] + 1) ^ 2. +Proof. + assert (Hp2: 0 < [|2|]) by exact (refl_equal Lt). + intros Hi Hj Hij H31 Hrec. + unfold sqrt_step. + case ltbP; rewrite div_spec. + - intros hlt. + assert ([| j + i / j|] = [|j|] + [|i|]/[|j|]) as hj. + rewrite add_spec, Zmod_small;rewrite div_spec; auto with zarith. + apply Hrec; rewrite lsr_spec, hj, to_Z_1; change (2 ^ 1) with 2. + + split; [ | apply sqrt_test_false;auto with zarith]. + replace ([|j|] + [|i|]/[|j|]) with (1 * 2 + (([|j|] - 2) + [|i|] / [|j|])) by ring. + rewrite Z_div_plus_full_l; auto with zarith. + assert (0 <= [|i|]/ [|j|]) by (apply Z_div_pos; auto with zarith). + assert (0 <= ([|j|] - 2 + [|i|] / [|j|]) / 2) ; auto with zarith. + apply Z.div_pos; [ | lia ]. + case (Zle_lt_or_eq 1 [|j|]); auto with zarith; intros Hj1. + rewrite <- Hj1, Zdiv_1_r; lia. + + apply sqrt_main;auto with zarith. + - split;[apply sqrt_test_true | ];auto with zarith. +Qed. + +Lemma iter_sqrt_correct n rec i j: 0 < [|i|] -> 0 < [|j|] -> + [|i|] < ([|j|] + 1) ^ 2 -> 2 * [|j|] < wB -> + (forall j1, 0 < [|j1|] -> 2^(Z_of_nat n) + [|j1|] <= [|j|] -> + [|i|] < ([|j1|] + 1) ^ 2 -> 2 * [|j1|] < wB -> + [|rec i j1|] ^ 2 <= [|i|] < ([|rec i j1|] + 1) ^ 2) -> + [|iter_sqrt n rec i j|] ^ 2 <= [|i|] < ([|iter_sqrt n rec i j|] + 1) ^ 2. +Proof. + revert rec i j; elim n; unfold iter_sqrt; fold iter_sqrt; clear n. + intros rec i j Hi Hj Hij H31 Hrec; apply sqrt_step_correct; auto with zarith. + intros; apply Hrec; auto with zarith. + rewrite Zpower_0_r; auto with zarith. + intros n Hrec rec i j Hi Hj Hij H31 HHrec. + apply sqrt_step_correct; auto. + intros j1 Hj1 Hjp1; apply Hrec; auto with zarith. + intros j2 Hj2 H2j2 Hjp2 Hj31; apply Hrec; auto with zarith. + intros j3 Hj3 Hpj3. + apply HHrec; auto. + rewrite -> inj_S, Z.pow_succ_r. + apply Z.le_trans with (2 ^Z_of_nat n + [|j2|]); auto with zarith. + apply Zle_0_nat. +Qed. + +Lemma sqrt_init i: 1 < i -> i < (i/2 + 1) ^ 2. +Proof. + intros Hi. + assert (H1: 0 <= i - 2) by auto with zarith. + assert (H2: 1 <= (i / 2) ^ 2); auto with zarith. + replace i with (1* 2 + (i - 2)); auto with zarith. + rewrite Z.pow_2_r, Z_div_plus_full_l; auto with zarith. + generalize (sqr_pos ((i - 2)/ 2)) (Z_div_pos (i - 2) 2). + rewrite Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. + auto with zarith. + generalize (quotient_by_2 i). + rewrite -> Z.pow_2_r in H2 |- *; + repeat (rewrite Zmult_plus_distr_l || + rewrite Zmult_plus_distr_r || + rewrite Zmult_1_l || rewrite Zmult_1_r). + auto with zarith. +Qed. + +Lemma sqrt_spec : forall x, + [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2. +Proof. + intros i; unfold sqrt. + rewrite compare_spec. case Z.compare_spec; rewrite to_Z_1; + intros Hi; auto with zarith. + repeat rewrite Z.pow_2_r; auto with zarith. + apply iter_sqrt_correct; auto with zarith; + rewrite lsr_spec, to_Z_1; change (2^1) with 2; auto with zarith. + replace [|i|] with (1 * 2 + ([|i|] - 2))%Z; try ring. + assert (0 <= ([|i|] - 2)/2)%Z by (apply Z_div_pos; auto with zarith). + rewrite Z_div_plus_full_l; auto with zarith. + apply sqrt_init; auto. + assert (W:= Z_mult_div_ge [|i|] 2);assert (W':= to_Z_bounded i);auto with zarith. + intros j2 H1 H2; contradict H2; apply Zlt_not_le. + fold wB;assert (W:=to_Z_bounded i). + apply Z.le_lt_trans with ([|i|]); auto with zarith. + assert (0 <= [|i|]/2)%Z by (apply Z_div_pos; auto with zarith). + apply Z.le_trans with (2 * ([|i|]/2)); auto with zarith. + apply Z_mult_div_ge; auto with zarith. + case (to_Z_bounded i); repeat rewrite Z.pow_2_r; auto with zarith. +Qed. + +(* sqrt2 *) +Lemma sqrt2_step_def rec ih il j: + sqrt2_step rec ih il j = + if (ih < j)%int63 then + let quo := fst (diveucl_21 ih il j) in + if (quo < j)%int63 then + let m := + match j +c quo with + | C0 m1 => m1 >> 1 + | C1 m1 => (m1 >> 1 + 1 << (digits -1))%int63 + end in + rec ih il m + else j + else j. +Proof. + unfold sqrt2_step; case diveucl_21; intros;simpl. + case (j +c i);trivial. +Qed. + +Lemma sqrt2_lower_bound ih il j: + [|| WW ih il||] < ([|j|] + 1) ^ 2 -> [|ih|] <= [|j|]. +Proof. + intros H1. + case (to_Z_bounded j); intros Hbj _. + case (to_Z_bounded il); intros Hbil _. + case (to_Z_bounded ih); intros Hbih Hbih1. + assert (([|ih|] < [|j|] + 1)%Z); auto with zarith. + apply Zlt_square_simpl; auto with zarith. + simpl zn2z_to_Z in H1. + repeat rewrite <-Z.pow_2_r. + refine (Z.le_lt_trans _ _ _ _ H1). + apply Z.le_trans with ([|ih|] * wB)%Z;try rewrite Z.pow_2_r; auto with zarith. +Qed. + +Lemma div2_phi ih il j: + [|fst (diveucl_21 ih il j)|] = [|| WW ih il||] /[|j|]. +Proof. + generalize (diveucl_21_spec ih il j). + case diveucl_21; intros q r Heq. + simpl zn2z_to_Z;unfold Z.div;rewrite <- Heq;trivial. +Qed. + +Lemma sqrt2_step_correct rec ih il j: + 2 ^ (Z_of_nat (size - 2)) <= [|ih|] -> + 0 < [|j|] -> [|| WW ih il||] < ([|j|] + 1) ^ 2 -> + (forall j1, 0 < [|j1|] < [|j|] -> [|| WW ih il||] < ([|j1|] + 1) ^ 2 -> + [|rec ih il j1|] ^ 2 <= [||WW ih il||] < ([|rec ih il j1|] + 1) ^ 2) -> + [|sqrt2_step rec ih il j|] ^ 2 <= [||WW ih il ||] + < ([|sqrt2_step rec ih il j|] + 1) ^ 2. +Proof. + assert (Hp2: (0 < [|2|])%Z) by exact (refl_equal Lt). + intros Hih Hj Hij Hrec; rewrite sqrt2_step_def. + assert (H1: ([|ih|] <= [|j|])%Z) by (apply sqrt2_lower_bound with il; auto). + case (to_Z_bounded ih); intros Hih1 _. + case (to_Z_bounded il); intros Hil1 _. + case (to_Z_bounded j); intros _ Hj1. + assert (Hp3: (0 < [||WW ih il||])). + simpl zn2z_to_Z;apply Z.lt_le_trans with ([|ih|] * wB)%Z; auto with zarith. + apply Zmult_lt_0_compat; auto with zarith. + refine (Z.lt_le_trans _ _ _ _ Hih); auto with zarith. + cbv zeta. + case_eq (ih < j)%int63;intros Heq. + rewrite -> ltb_spec in Heq. + 2: rewrite <-not_true_iff_false, ltb_spec in Heq. + 2: split; auto. + 2: apply sqrt_test_true; auto with zarith. + 2: unfold zn2z_to_Z; replace [|ih|] with [|j|]; auto with zarith. + 2: assert (0 <= [|il|]/[|j|]) by (apply Z_div_pos; auto with zarith). + 2: rewrite Zmult_comm, Z_div_plus_full_l; unfold base; auto with zarith. + case (Zle_or_lt (2^(Z_of_nat size -1)) [|j|]); intros Hjj. + case_eq (fst (diveucl_21 ih il j) < j)%int63;intros Heq0. + 2: rewrite <-not_true_iff_false, ltb_spec, div2_phi in Heq0. + 2: split; auto; apply sqrt_test_true; auto with zarith. + rewrite -> ltb_spec, div2_phi in Heq0. + match goal with |- context[rec _ _ ?X] => + set (u := X) + end. + assert (H: [|u|] = ([|j|] + ([||WW ih il||])/([|j|]))/2). + unfold u; generalize (addc_spec j (fst (diveucl_21 ih il j))); + case addc;unfold interp_carry;rewrite div2_phi;simpl zn2z_to_Z. + intros i H;rewrite lsr_spec, H;trivial. + intros i H;rewrite <- H. + case (to_Z_bounded i); intros H1i H2i. + rewrite -> add_spec, Zmod_small, lsr_spec. + change (1 * wB) with ([|(1 << (digits -1))|] * 2)%Z. + rewrite Z_div_plus_full_l; auto with zarith. + change wB with (2 * (wB/2))%Z; auto. + replace [|(1 << (digits - 1))|] with (wB/2); auto. + rewrite lsr_spec; auto. + replace (2^[|1|]) with 2%Z; auto. + split; auto with zarith. + assert ([|i|]/2 < wB/2); auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + apply Hrec; rewrite H; clear u H. + assert (Hf1: 0 <= [||WW ih il||]/ [|j|]) by (apply Z_div_pos; auto with zarith). + case (Zle_lt_or_eq 1 ([|j|])); auto with zarith; intros Hf2. + 2: contradict Heq0; apply Zle_not_lt; rewrite <- Hf2, Zdiv_1_r; auto with zarith. + split. + replace ([|j|] + [||WW ih il||]/ [|j|])%Z with + (1 * 2 + (([|j|] - 2) + [||WW ih il||] / [|j|])) by lia. + rewrite Z_div_plus_full_l; auto with zarith. + assert (0 <= ([|j|] - 2 + [||WW ih il||] / [|j|]) / 2) ; auto with zarith. + apply sqrt_test_false; auto with zarith. + apply sqrt_main; auto with zarith. + contradict Hij; apply Zle_not_lt. + assert ((1 + [|j|]) <= 2 ^ (Z_of_nat size - 1)); auto with zarith. + apply Z.le_trans with ((2 ^ (Z_of_nat size - 1)) ^2); auto with zarith. + assert (0 <= 1 + [|j|]); auto with zarith. + apply Zmult_le_compat; auto with zarith. + change ((2 ^ (Z_of_nat size - 1))^2) with (2 ^ (Z_of_nat size - 2) * wB). + apply Z.le_trans with ([|ih|] * wB); auto with zarith. + unfold zn2z_to_Z, wB; auto with zarith. +Qed. + +Lemma iter2_sqrt_correct n rec ih il j: + 2^(Z_of_nat (size - 2)) <= [|ih|] -> 0 < [|j|] -> [||WW ih il||] < ([|j|] + 1) ^ 2 -> + (forall j1, 0 < [|j1|] -> 2^(Z_of_nat n) + [|j1|] <= [|j|] -> + [||WW ih il||] < ([|j1|] + 1) ^ 2 -> + [|rec ih il j1|] ^ 2 <= [||WW ih il||] < ([|rec ih il j1|] + 1) ^ 2) -> + [|iter2_sqrt n rec ih il j|] ^ 2 <= [||WW ih il||] + < ([|iter2_sqrt n rec ih il j|] + 1) ^ 2. +Proof. + revert rec ih il j; elim n; unfold iter2_sqrt; fold iter2_sqrt; clear n. + intros rec ih il j Hi Hj Hij Hrec; apply sqrt2_step_correct; auto with zarith. + intros; apply Hrec; auto with zarith. + rewrite Zpower_0_r; auto with zarith. + intros n Hrec rec ih il j Hi Hj Hij HHrec. + apply sqrt2_step_correct; auto. + intros j1 Hj1 Hjp1; apply Hrec; auto with zarith. + intros j2 Hj2 H2j2 Hjp2; apply Hrec; auto with zarith. + intros j3 Hj3 Hpj3. + apply HHrec; auto. + rewrite -> inj_S, Z.pow_succ_r. + apply Z.le_trans with (2 ^Z_of_nat n + [|j2|])%Z; auto with zarith. + apply Zle_0_nat. +Qed. + +Lemma sqrt2_spec : forall x y, + wB/ 4 <= [|x|] -> + let (s,r) := sqrt2 x y in + [||WW x y||] = [|s|] ^ 2 + [+|r|] /\ + [+|r|] <= 2 * [|s|]. + Proof. + intros ih il Hih; unfold sqrt2. + change [||WW ih il||] with ([||WW ih il||]). + assert (Hbin: forall s, s * s + 2* s + 1 = (s + 1) ^ 2) by + (intros s; ring). + assert (Hb: 0 <= wB) by (red; intros HH; discriminate). + assert (Hi2: [||WW ih il ||] < ([|max_int|] + 1) ^ 2). + apply Z.le_lt_trans with ((wB - 1) * wB + (wB - 1)); auto with zarith. + 2: apply refl_equal. + case (to_Z_bounded ih); case (to_Z_bounded il); intros H1 H2 H3 H4. + unfold zn2z_to_Z; auto with zarith. + case (iter2_sqrt_correct size (fun _ _ j => j) ih il max_int); auto with zarith. + apply refl_equal. + intros j1 _ HH; contradict HH. + apply Zlt_not_le. + case (to_Z_bounded j1); auto with zarith. + change (2 ^ Z_of_nat size) with ([|max_int|]+1)%Z; auto with zarith. + set (s := iter2_sqrt size (fun _ _ j : int=> j) ih il max_int). + intros Hs1 Hs2. + generalize (mulc_spec s s); case mulc. + simpl fst; simpl snd; intros ih1 il1 Hihl1. + generalize (subc_spec il il1). + case subc; intros il2 Hil2. + simpl interp_carry in Hil2. + case_eq (ih1 < ih)%int63; [idtac | rewrite <- not_true_iff_false]; + rewrite ltb_spec; intros Heq. + unfold interp_carry; rewrite Zmult_1_l. + rewrite -> Z.pow_2_r, Hihl1, Hil2. + case (Zle_lt_or_eq ([|ih1|] + 1) ([|ih|])); auto with zarith. + intros H2; contradict Hs2; apply Zle_not_lt. + replace (([|s|] + 1) ^ 2) with ([||WW ih1 il1||] + 2 * [|s|] + 1). + unfold zn2z_to_Z. + case (to_Z_bounded il); intros Hpil _. + assert (Hl1l: [|il1|] <= [|il|]). + case (to_Z_bounded il2); rewrite Hil2; auto with zarith. + assert ([|ih1|] * wB + 2 * [|s|] + 1 <= [|ih|] * wB); auto with zarith. + case (to_Z_bounded s); intros _ Hps. + case (to_Z_bounded ih1); intros Hpih1 _; auto with zarith. + apply Z.le_trans with (([|ih1|] + 2) * wB); auto with zarith. + rewrite Zmult_plus_distr_l. + assert (2 * [|s|] + 1 <= 2 * wB); auto with zarith. + unfold zn2z_to_Z; rewrite <-Hihl1, Hbin; auto. + intros H2; split. + unfold zn2z_to_Z; rewrite <- H2; ring. + replace (wB + ([|il|] - [|il1|])) with ([||WW ih il||] - ([|s|] * [|s|])). + rewrite <-Hbin in Hs2; auto with zarith. + rewrite Hihl1; unfold zn2z_to_Z; rewrite <- H2; ring. + unfold interp_carry. + case (Zle_lt_or_eq [|ih|] [|ih1|]); auto with zarith; intros H. + contradict Hs1. + apply Zlt_not_le; rewrite Z.pow_2_r, Hihl1. + unfold zn2z_to_Z. + case (to_Z_bounded il); intros _ H2. + apply Z.lt_le_trans with (([|ih|] + 1) * wB + 0). + rewrite Zmult_plus_distr_l, Zplus_0_r; auto with zarith. + case (to_Z_bounded il1); intros H3 _. + apply Zplus_le_compat; auto with zarith. + split. + rewrite Z.pow_2_r, Hihl1. + unfold zn2z_to_Z; ring[Hil2 H]. + replace [|il2|] with ([||WW ih il||] - [||WW ih1 il1||]). + unfold zn2z_to_Z at 2; rewrite <-Hihl1. + rewrite <-Hbin in Hs2; auto with zarith. + unfold zn2z_to_Z; rewrite H, Hil2; ring. + unfold interp_carry in Hil2 |- *. + assert (Hsih: [|ih - 1|] = [|ih|] - 1). + rewrite sub_spec, Zmod_small; auto; replace [|1|] with 1; auto. + case (to_Z_bounded ih); intros H1 H2. + split; auto with zarith. + apply Z.le_trans with (wB/4 - 1); auto with zarith. + case_eq (ih1 < ih - 1)%int63; [idtac | rewrite <- not_true_iff_false]; + rewrite ltb_spec, Hsih; intros Heq. + rewrite Z.pow_2_r, Hihl1. + case (Zle_lt_or_eq ([|ih1|] + 2) [|ih|]); auto with zarith. + intros H2; contradict Hs2; apply Zle_not_lt. + replace (([|s|] + 1) ^ 2) with ([||WW ih1 il1||] + 2 * [|s|] + 1). + unfold zn2z_to_Z. + assert ([|ih1|] * wB + 2 * [|s|] + 1 <= [|ih|] * wB + ([|il|] - [|il1|])); + auto with zarith. + rewrite <-Hil2. + case (to_Z_bounded il2); intros Hpil2 _. + apply Z.le_trans with ([|ih|] * wB + - wB); auto with zarith. + case (to_Z_bounded s); intros _ Hps. + assert (2 * [|s|] + 1 <= 2 * wB); auto with zarith. + apply Z.le_trans with ([|ih1|] * wB + 2 * wB); auto with zarith. + assert (Hi: ([|ih1|] + 3) * wB <= [|ih|] * wB); auto with zarith. + rewrite Zmult_plus_distr_l in Hi; auto with zarith. + unfold zn2z_to_Z; rewrite <-Hihl1, Hbin; auto. + intros H2; unfold zn2z_to_Z; rewrite <-H2. + split. + replace [|il|] with (([|il|] - [|il1|]) + [|il1|]); try ring. + rewrite <-Hil2; ring. + replace (1 * wB + [|il2|]) with ([||WW ih il||] - [||WW ih1 il1||]). + unfold zn2z_to_Z at 2; rewrite <-Hihl1. + rewrite <-Hbin in Hs2; auto with zarith. + unfold zn2z_to_Z; rewrite <-H2. + replace [|il|] with (([|il|] - [|il1|]) + [|il1|]); try ring. + rewrite <-Hil2; ring. + case (Zle_lt_or_eq ([|ih|] - 1) ([|ih1|])); auto with zarith; intros H1. + assert (He: [|ih|] = [|ih1|]). + apply Zle_antisym; auto with zarith. + case (Zle_or_lt [|ih1|] [|ih|]); auto; intros H2. + contradict Hs1; apply Zlt_not_le; rewrite Z.pow_2_r, Hihl1. + unfold zn2z_to_Z. + case (to_Z_bounded il); intros _ Hpil1. + apply Z.lt_le_trans with (([|ih|] + 1) * wB). + rewrite Zmult_plus_distr_l, Zmult_1_l; auto with zarith. + case (to_Z_bounded il1); intros Hpil2 _. + apply Z.le_trans with (([|ih1|]) * wB); auto with zarith. + contradict Hs1; apply Zlt_not_le; rewrite Z.pow_2_r, Hihl1. + unfold zn2z_to_Z; rewrite He. + assert ([|il|] - [|il1|] < 0); auto with zarith. + rewrite <-Hil2. + case (to_Z_bounded il2); auto with zarith. + split. + rewrite Z.pow_2_r, Hihl1. + unfold zn2z_to_Z; rewrite <-H1. + apply trans_equal with ([|ih|] * wB + [|il1|] + ([|il|] - [|il1|])). + ring. + rewrite <-Hil2; ring. + replace [|il2|] with ([||WW ih il||] - [||WW ih1 il1||]). + unfold zn2z_to_Z at 2; rewrite <- Hihl1. + rewrite <-Hbin in Hs2; auto with zarith. + unfold zn2z_to_Z. + rewrite <-H1. + ring_simplify. + apply trans_equal with (wB + ([|il|] - [|il1|])). + ring. + rewrite <-Hil2; ring. +Qed. + +(* of_pos *) +Lemma of_pos_rec_spec (k: nat) : + (k <= size)%nat → + ∀ p, φ(of_pos_rec k p) = Zpos p mod 2 ^ Z.of_nat k. +Proof. + elim k; clear k. + intros _ p; simpl; rewrite to_Z_0, Zmod_1_r; reflexivity. + intros n ih hn. + assert (n <= size)%nat as hn' by lia. + specialize (ih hn'). + intros [ p | p | ]. + 3: { + rewrite Zmod_small. reflexivity. + split. lia. + apply Zpower_gt_1; lia. + } + - simpl. + destruct (bit_add_or (of_pos_rec n p << 1) 1) as (H1, _). + rewrite <- H1;clear H1. + 2: { + intros i; rewrite bit_lsl, bit_1. + case eqbP. + + intros h; apply to_Z_inj in h; subst. exact (λ e _, diff_false_true e). + + exact (λ _ _, diff_false_true). + } + rewrite add_spec, lsl_spec, ih, to_Z_1; clear ih. + rewrite Z.pow_pos_fold, Zpos_P_of_succ_nat. + change (Zpos p~1) with (2 ^ 1 * Zpos p + 1)%Z. + rewrite Zmod_distr by lia. + rewrite Zpower_Zsucc by auto with zarith. + rewrite Zplus_mod_idemp_l. + rewrite Zmod_small. + rewrite Zmult_mod_distr_l; lia. + set (a := Z.of_nat n). + set (b := Zpos p). + change (2 ^ 1) with 2. + pose proof (pow2_pos a (Nat2Z.is_nonneg _)). + elim_div; intros x y [ ? ha]. lia. + destruct ha as [ ha | ]. 2: lia. + split. lia. + apply Z.lt_le_trans with (2 ^ (a + 1)). + 2: apply Z.pow_le_mono_r; subst a; lia. + fold (Z.succ a); rewrite Z.pow_succ_r. lia. + subst a; lia. + - simpl. rewrite lsl_spec, ih, to_Z_1, Zmod_small. + rewrite Z.pow_pos_fold, Zpos_P_of_succ_nat, Zpower_Zsucc by lia. + change (Zpos p~0) with (2 ^ 1 * Zpos p)%Z. + rewrite Z.mul_mod_distr_l; auto with zarith. + set (a := Z.of_nat n). + set (b := Zpos p). + change (2 ^ 1) with 2. + pose proof (pow2_pos a (Nat2Z.is_nonneg _)). + elim_div; intros x y [ ? ha]. lia. + destruct ha as [ ha | ]. 2: lia. + split. lia. + apply Z.lt_le_trans with (2 ^ (a + 1)). + 2: apply Z.pow_le_mono_r; subst a; lia. + fold (Z.succ a); rewrite Z.pow_succ_r. lia. + subst a; lia. +Qed. + +Lemma is_int n : + 0 <= n < 2 ^ φ digits → + n = φ (of_Z n). +Proof. + destruct n. reflexivity. 2: lia. + intros [_ h]. simpl. + unfold of_pos. rewrite of_pos_rec_spec by lia. + symmetry; apply Z.mod_small. split. lia. exact h. +Qed. + +Lemma of_Z_spec n : [| of_Z n |] = n mod wB. +Proof. + destruct n. reflexivity. + { now simpl; unfold of_pos; rewrite of_pos_rec_spec by lia. } + simpl; unfold of_pos; rewrite opp_spec. + rewrite of_pos_rec_spec; [ |auto]; fold wB. + now rewrite <-(Z.sub_0_l), Zminus_mod_idemp_r. +Qed. + +(* General lemmas *) +Lemma negbE a b : a = negb b → negb a = b. +Proof. intros ->; apply negb_involutive. Qed. + +Lemma Z_oddE a : Z.odd a = (a mod 2 =? 1)%Z. +Proof. rewrite Zmod_odd; case Z.odd; reflexivity. Qed. + +Lemma Z_evenE a : Z.even a = (a mod 2 =? 0)%Z. +Proof. rewrite Zmod_even; case Z.even; reflexivity. Qed. + +(* is_zero *) +Lemma is_zeroE n : is_zero n = Z.eqb (φ n) 0. +Proof. + case Z.eqb_spec. + - intros h; apply (to_Z_inj n 0) in h; subst n; reflexivity. + - generalize (proj1 (is_zero_spec n)). + case is_zero; auto; intros ->; auto; destruct 1; reflexivity. +Qed. + +(* bit *) +Lemma bitE i j : bit i j = Z.testbit φ(i) φ(j). +Proof. + apply negbE; rewrite is_zeroE, lsl_spec, lsr_spec. + generalize (φ i) (to_Z_bounded i) (φ j) (to_Z_bounded j); clear i j; + intros i [hi hi'] j [hj hj']. + rewrite Z.testbit_eqb by auto; rewrite <- Z_oddE, Z.negb_odd, Z_evenE. + remember (i / 2 ^ j) as k. + change wB with (2 * 2 ^ φ (digits - 1)). + unfold Z.modulo at 2. + generalize (Z_div_mod_full k 2 (λ k, let 'eq_refl := k in I)); unfold Remainder. + destruct Z.div_eucl as [ p q ]; intros [hk [ hq | ]]. 2: lia. + rewrite hk. + remember φ (digits - 1) as m. + replace ((_ + _) * _) with (q * 2 ^ m + p * (2 * 2 ^ m)) by ring. + rewrite Z_mod_plus by (subst m; reflexivity). + assert (q = 0 ∨ q = 1) as D by lia. + destruct D; subst; reflexivity. +Qed. + +(* land, lor, lxor *) +Lemma lt_pow_lt_log d k n : + 0 < d <= n → + 0 <= k < 2 ^ d → + Z.log2 k < n. +Proof. + intros [hd hdn] [hk hkd]. + assert (k = 0 ∨ 0 < k) as D by lia. + clear hk; destruct D as [ hk | hk ]. + - subst k; simpl; lia. + - apply Z.log2_lt_pow2. lia. + eapply Z.lt_le_trans. eassumption. + apply Z.pow_le_mono_r; lia. +Qed. + +Lemma land_spec' x y : φ (x land y) = Z.land φ(x) φ(y). +Proof. + apply Z.bits_inj'; intros n hn. + destruct (to_Z_bounded (x land y)) as [ hxy hxy' ]. + destruct (to_Z_bounded x) as [ hx hx' ]. + destruct (to_Z_bounded y) as [ hy hy' ]. + case (Z_lt_le_dec n (φ digits)); intros hd. + 2: { + rewrite !Z.bits_above_log2; auto. + - apply Z.land_nonneg; auto. + - eapply Z.le_lt_trans. + apply Z.log2_land; assumption. + apply Z.min_lt_iff. + left. apply (lt_pow_lt_log φ digits). exact (conj eq_refl hd). + split; assumption. + - apply (lt_pow_lt_log φ digits). exact (conj eq_refl hd). + split; assumption. + } + rewrite (is_int n). + rewrite Z.land_spec, <- !bitE, land_spec; reflexivity. + apply (conj hn). + apply (Z.lt_trans _ _ _ hd). + apply Zpower2_lt_lin. lia. +Qed. + +Lemma lor_spec' x y : φ (x lor y) = Z.lor φ(x) φ(y). +Proof. + apply Z.bits_inj'; intros n hn. + destruct (to_Z_bounded (x lor y)) as [ hxy hxy' ]. + destruct (to_Z_bounded x) as [ hx hx' ]. + destruct (to_Z_bounded y) as [ hy hy' ]. + case (Z_lt_le_dec n (φ digits)); intros hd. + 2: { + rewrite !Z.bits_above_log2; auto. + - apply Z.lor_nonneg; auto. + - rewrite Z.log2_lor by assumption. + apply Z.max_lub_lt; apply (lt_pow_lt_log φ digits); split; assumption || reflexivity. + - apply (lt_pow_lt_log φ digits); split; assumption || reflexivity. + } + rewrite (is_int n). + rewrite Z.lor_spec, <- !bitE, lor_spec; reflexivity. + apply (conj hn). + apply (Z.lt_trans _ _ _ hd). + apply Zpower2_lt_lin. lia. +Qed. + +Lemma lxor_spec' x y : φ (x lxor y) = Z.lxor φ(x) φ(y). +Proof. + apply Z.bits_inj'; intros n hn. + destruct (to_Z_bounded (x lxor y)) as [ hxy hxy' ]. + destruct (to_Z_bounded x) as [ hx hx' ]. + destruct (to_Z_bounded y) as [ hy hy' ]. + case (Z_lt_le_dec n (φ digits)); intros hd. + 2: { + rewrite !Z.bits_above_log2; auto. + - apply Z.lxor_nonneg; split; auto. + - eapply Z.le_lt_trans. + apply Z.log2_lxor; assumption. + apply Z.max_lub_lt; apply (lt_pow_lt_log φ digits); split; assumption || reflexivity. + - apply (lt_pow_lt_log φ digits); split; assumption || reflexivity. + } + rewrite (is_int n). + rewrite Z.lxor_spec, <- !bitE, lxor_spec; reflexivity. + apply (conj hn). + apply (Z.lt_trans _ _ _ hd). + apply Zpower2_lt_lin. lia. +Qed. + +Lemma landC i j : i land j = j land i. +Proof. + apply bit_ext; intros n. + rewrite !land_spec, andb_comm; auto. +Qed. + +Lemma landA i j k : i land (j land k) = i land j land k. +Proof. + apply bit_ext; intros n. + rewrite !land_spec, andb_assoc; auto. +Qed. + +Lemma land0 i : 0 land i = 0%int63. +Proof. + apply bit_ext; intros n. + rewrite land_spec, bit_0; auto. +Qed. + +Lemma land0_r i : i land 0 = 0%int63. +Proof. rewrite landC; exact (land0 i). Qed. + +Lemma lorC i j : i lor j = j lor i. +Proof. + apply bit_ext; intros n. + rewrite !lor_spec, orb_comm; auto. +Qed. + +Lemma lorA i j k : i lor (j lor k) = i lor j lor k. +Proof. + apply bit_ext; intros n. + rewrite !lor_spec, orb_assoc; auto. +Qed. + +Lemma lor0 i : 0 lor i = i. +Proof. + apply bit_ext; intros n. + rewrite lor_spec, bit_0; auto. +Qed. + +Lemma lor0_r i : i lor 0 = i. +Proof. rewrite lorC; exact (lor0 i). Qed. + +Lemma lxorC i j : i lxor j = j lxor i. +Proof. + apply bit_ext; intros n. + rewrite !lxor_spec, xorb_comm; auto. +Qed. + +Lemma lxorA i j k : i lxor (j lxor k) = i lxor j lxor k. +Proof. + apply bit_ext; intros n. + rewrite !lxor_spec, xorb_assoc; auto. +Qed. + +Lemma lxor0 i : 0 lxor i = i. +Proof. + apply bit_ext; intros n. + rewrite lxor_spec, bit_0, xorb_false_l; auto. +Qed. + +Lemma lxor0_r i : i lxor 0 = i. +Proof. rewrite lxorC; exact (lxor0 i). Qed. diff --git a/theories/Numbers/Cyclic/Int63/Ring63.v b/theories/Numbers/Cyclic/Int63/Ring63.v new file mode 100644 index 0000000000..d230435378 --- /dev/null +++ b/theories/Numbers/Cyclic/Int63/Ring63.v @@ -0,0 +1,65 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2018 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** * Int63 numbers defines Z/(2^63)Z, and can hence be equipped + with a ring structure and a ring tactic *) + +Require Import Cyclic63 CyclicAxioms. + +Local Open Scope int63_scope. + +(** Detection of constants *) + +Ltac isInt63cst t := + match eval lazy delta [add] in (t + 1)%int63 with + | add _ _ => constr:(false) + | _ => constr:(true) + end. + +Ltac Int63cst t := + match eval lazy delta [add] in (t + 1)%int63 with + | add _ _ => constr:(NotConstant) + | _ => constr:(t) + end. + +(** The generic ring structure inferred from the Cyclic structure *) + +Module Int63ring := CyclicRing Int63Cyclic. + +(** Unlike in the generic [CyclicRing], we can use Leibniz here. *) + +Lemma Int63_canonic : forall x y, to_Z x = to_Z y -> x = y. +Proof to_Z_inj. + +Lemma ring_theory_switch_eq : + forall A (R R':A->A->Prop) zero one add mul sub opp, + (forall x y : A, R x y -> R' x y) -> + ring_theory zero one add mul sub opp R -> + ring_theory zero one add mul sub opp R'. +Proof. +intros A R R' zero one add mul sub opp Impl Ring. +constructor; intros; apply Impl; apply Ring. +Qed. + +Lemma Int63Ring : ring_theory 0 1 add mul sub opp Logic.eq. +Proof. +exact (ring_theory_switch_eq _ _ _ _ _ _ _ _ _ Int63_canonic Int63ring.CyclicRing). +Qed. + +Lemma eq31_correct : forall x y, eqb x y = true -> x=y. +Proof. now apply eqb_spec. Qed. + +Add Ring Int63Ring : Int63Ring + (decidable eq31_correct, + constants [Int63cst]). + +Section TestRing. +Let test : forall x y, 1 + x*y + x*x + 1 = 1*1 + 1 + y*x + 1*x*x. +intros. ring. +Qed. +End TestRing. diff --git a/theories/Numbers/Cyclic/ZModulo/ZModulo.v b/theories/Numbers/Cyclic/ZModulo/ZModulo.v new file mode 100644 index 0000000000..4bcd22543f --- /dev/null +++ b/theories/Numbers/Cyclic/ZModulo/ZModulo.v @@ -0,0 +1,967 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** * Type [Z] viewed modulo a particular constant corresponds to [Z/nZ] + as defined abstractly in CyclicAxioms. *) + +(** Even if the construction provided here is not reused for building + the efficient arbitrary precision numbers, it provides a simple + implementation of CyclicAxioms, hence ensuring its coherence. *) + +Set Implicit Arguments. + +Require Import Bool. +Require Import ZArith. +Require Import Znumtheory. +Require Import Zpow_facts. +Require Import DoubleType. +Require Import CyclicAxioms. + +Local Open Scope Z_scope. + +Section ZModulo. + + Variable digits : positive. + Hypothesis digits_ne_1 : digits <> 1%positive. + + Definition wB := base digits. + + Definition t := Z. + Definition zdigits := Zpos digits. + Definition to_Z x := x mod wB. + + Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). + + Notation "[+| c |]" := + (interp_carry 1 wB to_Z c) (at level 0, c at level 99). + + Notation "[-| c |]" := + (interp_carry (-1) wB to_Z c) (at level 0, c at level 99). + + Notation "[|| x ||]" := + (zn2z_to_Z wB to_Z x) (at level 0, x at level 99). + + Lemma spec_more_than_1_digit: 1 < Zpos digits. + Proof. + generalize digits_ne_1; destruct digits; red; auto. + destruct 1; auto. + Qed. + Let digits_gt_1 := spec_more_than_1_digit. + + Lemma wB_pos : wB > 0. + Proof. + apply Z.lt_gt. + unfold wB, base; auto with zarith. + Qed. + Hint Resolve wB_pos : core. + + Lemma spec_to_Z_1 : forall x, 0 <= [|x|]. + Proof. + unfold to_Z; intros; destruct (Z_mod_lt x wB wB_pos); auto. + Qed. + + Lemma spec_to_Z_2 : forall x, [|x|] < wB. + Proof. + unfold to_Z; intros; destruct (Z_mod_lt x wB wB_pos); auto. + Qed. + Hint Resolve spec_to_Z_1 spec_to_Z_2 : core. + + Lemma spec_to_Z : forall x, 0 <= [|x|] < wB. + Proof. + auto. + Qed. + + Definition of_pos x := + let (q,r) := Z.pos_div_eucl x wB in (N_of_Z q, r). + + Lemma spec_of_pos : forall p, + Zpos p = (Z.of_N (fst (of_pos p)))*wB + [|(snd (of_pos p))|]. + Proof. + intros; unfold of_pos; simpl. + generalize (Z_div_mod_POS wB wB_pos p). + destruct (Z.pos_div_eucl p wB); simpl; destruct 1. + unfold to_Z; rewrite Zmod_small; auto. + assert (0 <= z). + replace z with (Zpos p / wB) by + (symmetry; apply Zdiv_unique with z0; auto). + apply Z_div_pos; auto with zarith. + replace (Z.of_N (N_of_Z z)) with z by + (destruct z; simpl; auto; elim H1; auto). + rewrite Z.mul_comm; auto. + Qed. + + Lemma spec_zdigits : [|zdigits|] = Zpos digits. + Proof. + unfold to_Z, zdigits. + apply Zmod_small. + unfold wB, base. + split; auto with zarith. + apply Zpower2_lt_lin; auto with zarith. + Qed. + + Definition zero := 0. + Definition one := 1. + Definition minus_one := wB - 1. + + Lemma spec_0 : [|zero|] = 0. + Proof. + unfold to_Z, zero. + apply Zmod_small; generalize wB_pos; auto with zarith. + Qed. + + Lemma spec_1 : [|one|] = 1. + Proof. + unfold to_Z, one. + apply Zmod_small; split; auto with zarith. + unfold wB, base. + apply Z.lt_trans with (Zpos digits); auto. + apply Zpower2_lt_lin; auto with zarith. + Qed. + + Lemma spec_Bm1 : [|minus_one|] = wB - 1. + Proof. + unfold to_Z, minus_one. + apply Zmod_small; split; auto with zarith. + unfold wB, base. + cut (1 <= 2 ^ Zpos digits); auto with zarith. + apply Z.le_trans with (Zpos digits); auto with zarith. + apply Zpower2_le_lin; auto with zarith. + Qed. + + Definition compare x y := Z.compare [|x|] [|y|]. + + Lemma spec_compare : forall x y, + compare x y = Z.compare [|x|] [|y|]. + Proof. reflexivity. Qed. + + Definition eq0 x := + match [|x|] with Z0 => true | _ => false end. + + Lemma spec_eq0 : forall x, eq0 x = true -> [|x|] = 0. + Proof. + unfold eq0; intros; now destruct [|x|]. + Qed. + + Definition opp_c x := + if eq0 x then C0 0 else C1 (- x). + Definition opp x := - x. + Definition opp_carry x := - x - 1. + + Lemma spec_opp_c : forall x, [-|opp_c x|] = -[|x|]. + Proof. + intros; unfold opp_c, to_Z; auto. + case_eq (eq0 x); intros; unfold interp_carry. + fold [|x|]; rewrite (spec_eq0 x H); auto. + assert (x mod wB <> 0). + unfold eq0, to_Z in H. + intro H0; rewrite H0 in H; discriminate. + rewrite Z_mod_nz_opp_full; auto with zarith. + Qed. + + Lemma spec_opp : forall x, [|opp x|] = (-[|x|]) mod wB. + Proof. + intros; unfold opp, to_Z; auto. + change ((- x) mod wB = (0 - (x mod wB)) mod wB). + rewrite Zminus_mod_idemp_r; simpl; auto. + Qed. + + Lemma spec_opp_carry : forall x, [|opp_carry x|] = wB - [|x|] - 1. + Proof. + intros; unfold opp_carry, to_Z; auto. + replace (- x - 1) with (- 1 - x) by omega. + rewrite <- Zminus_mod_idemp_r. + replace ( -1 - x mod wB) with (0 + ( -1 - x mod wB)) by omega. + rewrite <- (Z_mod_same_full wB). + rewrite Zplus_mod_idemp_l. + replace (wB + (-1 - x mod wB)) with (wB - x mod wB -1) by omega. + apply Zmod_small. + generalize (Z_mod_lt x wB wB_pos); omega. + Qed. + + Definition succ_c x := + let y := Z.succ x in + if eq0 y then C1 0 else C0 y. + + Definition add_c x y := + let z := [|x|] + [|y|] in + if Z_lt_le_dec z wB then C0 z else C1 (z-wB). + + Definition add_carry_c x y := + let z := [|x|]+[|y|]+1 in + if Z_lt_le_dec z wB then C0 z else C1 (z-wB). + + Definition succ := Z.succ. + Definition add := Z.add. + Definition add_carry x y := x + y + 1. + + Lemma Zmod_equal : + forall x y z, z>0 -> (x-y) mod z = 0 -> x mod z = y mod z. + Proof. + intros. + generalize (Z_div_mod_eq (x-y) z H); rewrite H0, Z.add_0_r. + remember ((x-y)/z) as k. + rewrite Z.sub_move_r, Z.add_comm, Z.mul_comm. intros ->. + now apply Z_mod_plus. + Qed. + + Lemma spec_succ_c : forall x, [+|succ_c x|] = [|x|] + 1. + Proof. + intros; unfold succ_c, to_Z, Z.succ. + case_eq (eq0 (x+1)); intros; unfold interp_carry. + + rewrite Z.mul_1_l. + replace (wB + 0 mod wB) with wB by auto with zarith. + symmetry. rewrite Z.add_move_r. + assert ((x+1) mod wB = 0) by (apply spec_eq0; auto). + replace (wB-1) with ((wB-1) mod wB) by + (apply Zmod_small; generalize wB_pos; omega). + rewrite <- Zminus_mod_idemp_l; rewrite Z_mod_same; simpl; auto. + apply Zmod_equal; auto. + + assert ((x+1) mod wB <> 0). + unfold eq0, to_Z in *; now destruct ((x+1) mod wB). + assert (x mod wB + 1 <> wB). + contradict H0. + rewrite Z.add_move_r in H0; simpl in H0. + rewrite <- Zplus_mod_idemp_l; rewrite H0. + replace (wB-1+1) with wB; auto with zarith; apply Z_mod_same; auto. + rewrite <- Zplus_mod_idemp_l. + apply Zmod_small. + generalize (Z_mod_lt x wB wB_pos); omega. + Qed. + + Lemma spec_add_c : forall x y, [+|add_c x y|] = [|x|] + [|y|]. + Proof. + intros; unfold add_c, to_Z, interp_carry. + destruct Z_lt_le_dec. + apply Zmod_small; + generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. + rewrite Z.mul_1_l, Z.add_comm, Z.add_move_r. + apply Zmod_small; + generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. + Qed. + + Lemma spec_add_carry_c : forall x y, [+|add_carry_c x y|] = [|x|] + [|y|] + 1. + Proof. + intros; unfold add_carry_c, to_Z, interp_carry. + destruct Z_lt_le_dec. + apply Zmod_small; + generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. + rewrite Z.mul_1_l, Z.add_comm, Z.add_move_r. + apply Zmod_small; + generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. + Qed. + + Lemma spec_succ : forall x, [|succ x|] = ([|x|] + 1) mod wB. + Proof. + intros; unfold succ, to_Z, Z.succ. + symmetry; apply Zplus_mod_idemp_l. + Qed. + + Lemma spec_add : forall x y, [|add x y|] = ([|x|] + [|y|]) mod wB. + Proof. + intros; unfold add, to_Z; apply Zplus_mod. + Qed. + + Lemma spec_add_carry : + forall x y, [|add_carry x y|] = ([|x|] + [|y|] + 1) mod wB. + Proof. + intros; unfold add_carry, to_Z. + rewrite <- Zplus_mod_idemp_l. + rewrite (Zplus_mod x y). + rewrite Zplus_mod_idemp_l; auto. + Qed. + + Definition pred_c x := + if eq0 x then C1 (wB-1) else C0 (x-1). + + Definition sub_c x y := + let z := [|x|]-[|y|] in + if Z_lt_le_dec z 0 then C1 (wB+z) else C0 z. + + Definition sub_carry_c x y := + let z := [|x|]-[|y|]-1 in + if Z_lt_le_dec z 0 then C1 (wB+z) else C0 z. + + Definition pred := Z.pred. + Definition sub := Z.sub. + Definition sub_carry x y := x - y - 1. + + Lemma spec_pred_c : forall x, [-|pred_c x|] = [|x|] - 1. + Proof. + intros; unfold pred_c, to_Z, interp_carry. + case_eq (eq0 x); intros. + fold [|x|]; rewrite spec_eq0; auto. + replace ((wB-1) mod wB) with (wB-1); auto with zarith. + symmetry; apply Zmod_small; generalize wB_pos; omega. + + assert (x mod wB <> 0). + unfold eq0, to_Z in *; now destruct (x mod wB). + rewrite <- Zminus_mod_idemp_l. + apply Zmod_small. + generalize (Z_mod_lt x wB wB_pos); omega. + Qed. + + Lemma spec_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|]. + Proof. + intros; unfold sub_c, to_Z, interp_carry. + destruct Z_lt_le_dec. + replace ((wB + (x mod wB - y mod wB)) mod wB) with + (wB + (x mod wB - y mod wB)). + omega. + symmetry; apply Zmod_small. + generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. + + apply Zmod_small. + generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. + Qed. + + Lemma spec_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|] - [|y|] - 1. + Proof. + intros; unfold sub_carry_c, to_Z, interp_carry. + destruct Z_lt_le_dec. + replace ((wB + (x mod wB - y mod wB - 1)) mod wB) with + (wB + (x mod wB - y mod wB -1)). + omega. + symmetry; apply Zmod_small. + generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. + + apply Zmod_small. + generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. + Qed. + + Lemma spec_pred : forall x, [|pred x|] = ([|x|] - 1) mod wB. + Proof. + intros; unfold pred, to_Z, Z.pred. + rewrite <- Zplus_mod_idemp_l; auto. + Qed. + + Lemma spec_sub : forall x y, [|sub x y|] = ([|x|] - [|y|]) mod wB. + Proof. + intros; unfold sub, to_Z; apply Zminus_mod. + Qed. + + Lemma spec_sub_carry : + forall x y, [|sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB. + Proof. + intros; unfold sub_carry, to_Z. + rewrite <- Zminus_mod_idemp_l. + rewrite (Zminus_mod x y). + rewrite Zminus_mod_idemp_l. + auto. + Qed. + + Definition mul_c x y := + let (h,l) := Z.div_eucl ([|x|]*[|y|]) wB in + if eq0 h then if eq0 l then W0 else WW h l else WW h l. + + Definition mul := Z.mul. + + Definition square_c x := mul_c x x. + + Lemma spec_mul_c : forall x y, [|| mul_c x y ||] = [|x|] * [|y|]. + Proof. + intros; unfold mul_c, zn2z_to_Z. + assert (Z.div_eucl ([|x|]*[|y|]) wB = (([|x|]*[|y|])/wB,([|x|]*[|y|]) mod wB)). + unfold Z.modulo, Z.div; destruct Z.div_eucl; auto. + generalize (Z_div_mod ([|x|]*[|y|]) wB wB_pos); destruct Z.div_eucl as (h,l). + destruct 1; injection H as ? ?. + rewrite H0. + assert ([|l|] = l). + apply Zmod_small; auto. + assert ([|h|] = h). + apply Zmod_small. + subst h. + split. + apply Z_div_pos; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + apply Z.mul_lt_mono_nonneg; auto with zarith. + clear H H0 H1 H2. + case_eq (eq0 h); simpl; intros. + case_eq (eq0 l); simpl; intros. + rewrite <- H3, <- H4, (spec_eq0 h), (spec_eq0 l); auto with zarith. + rewrite H3, H4; auto with zarith. + rewrite H3, H4; auto with zarith. + Qed. + + Lemma spec_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wB. + Proof. + intros; unfold mul, to_Z; apply Zmult_mod. + Qed. + + Lemma spec_square_c : forall x, [|| square_c x||] = [|x|] * [|x|]. + Proof. + intros x; exact (spec_mul_c x x). + Qed. + + Definition div x y := Z.div_eucl [|x|] [|y|]. + + Lemma spec_div : forall a b, 0 < [|b|] -> + let (q,r) := div a b in + [|a|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + Proof. + intros; unfold div. + assert ([|b|]>0) by auto with zarith. + assert (Z.div_eucl [|a|] [|b|] = ([|a|]/[|b|], [|a|] mod [|b|])). + unfold Z.modulo, Z.div; destruct Z.div_eucl; auto. + generalize (Z_div_mod [|a|] [|b|] H0). + destruct Z.div_eucl as (q,r); destruct 1; intros. + injection H1 as ? ?. + assert ([|r|]=r). + apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|]; + auto with zarith. + assert ([|q|]=q). + apply Zmod_small. + subst q. + split. + apply Z_div_pos; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + apply Z.lt_le_trans with (wB*1). + rewrite Z.mul_1_r; auto with zarith. + apply Z.mul_le_mono_nonneg; generalize wB_pos; auto with zarith. + rewrite H5, H6; rewrite Z.mul_comm; auto with zarith. + Qed. + + Definition div_gt := div. + + Lemma spec_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> + let (q,r) := div_gt a b in + [|a|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + Proof. + intros. + apply spec_div; auto. + Qed. + + Definition modulo x y := [|x|] mod [|y|]. + Definition modulo_gt x y := [|x|] mod [|y|]. + + Lemma spec_modulo : forall a b, 0 < [|b|] -> + [|modulo a b|] = [|a|] mod [|b|]. + Proof. + intros; unfold modulo. + apply Zmod_small. + assert ([|b|]>0) by auto with zarith. + generalize (Z_mod_lt [|a|] [|b|] H0) (Z_mod_lt b wB wB_pos). + fold [|b|]; omega. + Qed. + + Lemma spec_modulo_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> + [|modulo_gt a b|] = [|a|] mod [|b|]. + Proof. + intros; apply spec_modulo; auto. + Qed. + + Definition gcd x y := Z.gcd [|x|] [|y|]. + Definition gcd_gt x y := Z.gcd [|x|] [|y|]. + + Lemma Zgcd_bound : forall a b, 0<=a -> 0<=b -> Z.gcd a b <= Z.max a b. + Proof. + intros. + generalize (Zgcd_is_gcd a b); inversion_clear 1. + destruct H2 as (q,H2); destruct H3 as (q',H3); clear H4. + assert (H4:=Z.gcd_nonneg a b). + destruct (Z.eq_dec (Z.gcd a b) 0) as [->|Hneq]. + generalize (Zmax_spec a b); omega. + assert (0 <= q). + apply Z.mul_le_mono_pos_r with (Z.gcd a b); auto with zarith. + destruct (Z.eq_dec q 0). + + subst q; simpl in *; subst a; simpl; auto. + generalize (Zmax_spec 0 b) (Zabs_spec b); omega. + + apply Z.le_trans with a. + rewrite H2 at 2. + rewrite <- (Z.mul_1_l (Z.gcd a b)) at 1. + apply Z.mul_le_mono_nonneg; auto with zarith. + generalize (Zmax_spec a b); omega. + Qed. + + Lemma spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|]. + Proof. + intros; unfold gcd. + generalize (Z_mod_lt a wB wB_pos)(Z_mod_lt b wB wB_pos); intros. + fold [|a|] in *; fold [|b|] in *. + replace ([|Z.gcd [|a|] [|b|]|]) with (Z.gcd [|a|] [|b|]). + apply Zgcd_is_gcd. + symmetry; apply Zmod_small. + split. + apply Z.gcd_nonneg. + apply Z.le_lt_trans with (Z.max [|a|] [|b|]). + apply Zgcd_bound; auto with zarith. + generalize (Zmax_spec [|a|] [|b|]); omega. + Qed. + + Lemma spec_gcd_gt : forall a b, [|a|] > [|b|] -> + Zis_gcd [|a|] [|b|] [|gcd_gt a b|]. + Proof. + intros. apply spec_gcd; auto. + Qed. + + Definition div21 a1 a2 b := + Z.div_eucl ([|a1|]*wB+[|a2|]) [|b|]. + + Lemma spec_div21 : forall a1 a2 b, + wB/2 <= [|b|] -> + [|a1|] < [|b|] -> + let (q,r) := div21 a1 a2 b in + [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + Proof. + intros; unfold div21. + generalize (Z_mod_lt a1 wB wB_pos); fold [|a1|]; intros. + generalize (Z_mod_lt a2 wB wB_pos); fold [|a2|]; intros. + assert ([|b|]>0) by auto with zarith. + remember ([|a1|]*wB+[|a2|]) as a. + assert (Z.div_eucl a [|b|] = (a/[|b|], a mod [|b|])). + unfold Z.modulo, Z.div; destruct Z.div_eucl; auto. + generalize (Z_div_mod a [|b|] H3). + destruct Z.div_eucl as (q,r); destruct 1; intros. + injection H4 as ? ?. + assert ([|r|]=r). + apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|]; + auto with zarith. + assert ([|q|]=q). + apply Zmod_small. + subst q. + split. + apply Z_div_pos; auto with zarith. + subst a; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + subst a. + replace (wB*[|b|]) with (([|b|]-1)*wB + wB) by ring. + apply Z.lt_le_trans with ([|a1|]*wB+wB); auto with zarith. + rewrite H8, H9; rewrite Z.mul_comm; auto with zarith. + Qed. + + Definition add_mul_div p x y := + ([|x|] * (2 ^ [|p|]) + [|y|] / (2 ^ ((Zpos digits) - [|p|]))). + Lemma spec_add_mul_div : forall x y p, + [|p|] <= Zpos digits -> + [| add_mul_div p x y |] = + ([|x|] * (2 ^ [|p|]) + + [|y|] / (2 ^ ((Zpos digits) - [|p|]))) mod wB. + Proof. + intros; unfold add_mul_div; auto. + Qed. + + Definition pos_mod p w := [|w|] mod (2 ^ [|p|]). + Lemma spec_pos_mod : forall w p, + [|pos_mod p w|] = [|w|] mod (2 ^ [|p|]). + Proof. + intros; unfold pos_mod. + apply Zmod_small. + generalize (Z_mod_lt [|w|] (2 ^ [|p|])); intros. + split. + destruct H; auto using Z.lt_gt with zarith. + apply Z.le_lt_trans with [|w|]; auto with zarith. + apply Zmod_le; auto with zarith. + Qed. + + Definition is_even x := + if Z.eq_dec ([|x|] mod 2) 0 then true else false. + + Lemma spec_is_even : forall x, + if is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1. + Proof. + intros; unfold is_even; destruct Z.eq_dec; auto. + generalize (Z_mod_lt [|x|] 2); omega. + Qed. + + Definition sqrt x := Z.sqrt [|x|]. + Lemma spec_sqrt : forall x, + [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2. + Proof. + intros. + unfold sqrt. + repeat rewrite Z.pow_2_r. + replace [|Z.sqrt [|x|]|] with (Z.sqrt [|x|]). + apply Z.sqrt_spec; auto with zarith. + symmetry; apply Zmod_small. + split. apply Z.sqrt_nonneg; auto. + apply Z.le_lt_trans with [|x|]; auto. + apply Z.sqrt_le_lin; auto. + Qed. + + Definition sqrt2 x y := + let z := [|x|]*wB+[|y|] in + match z with + | Z0 => (0, C0 0) + | Zpos p => + let (s,r) := Z.sqrtrem (Zpos p) in + (s, if Z_lt_le_dec r wB then C0 r else C1 (r-wB)) + | Zneg _ => (0, C0 0) + end. + + Lemma spec_sqrt2 : forall x y, + wB/ 4 <= [|x|] -> + let (s,r) := sqrt2 x y in + [||WW x y||] = [|s|] ^ 2 + [+|r|] /\ + [+|r|] <= 2 * [|s|]. + Proof. + intros; unfold sqrt2. + simpl zn2z_to_Z. + remember ([|x|]*wB+[|y|]) as z. + destruct z. + auto with zarith. + generalize (Z.sqrtrem_spec (Zpos p)). + destruct Z.sqrtrem as (s,r); intros [U V]; auto with zarith. + assert (s < wB). + destruct (Z_lt_le_dec s wB); auto. + assert (wB * wB <= Zpos p). + rewrite U. + apply Z.le_trans with (s*s); try omega. + apply Z.mul_le_mono_nonneg; generalize wB_pos; auto with zarith. + assert (Zpos p < wB*wB). + rewrite Heqz. + replace (wB*wB) with ((wB-1)*wB+wB) by ring. + apply Z.add_le_lt_mono; auto with zarith. + apply Z.mul_le_mono_nonneg; auto with zarith. + generalize (spec_to_Z x); auto with zarith. + generalize wB_pos; auto with zarith. + omega. + replace [|s|] with s by (symmetry; apply Zmod_small; auto with zarith). + destruct Z_lt_le_dec; unfold interp_carry. + replace [|r|] with r by (symmetry; apply Zmod_small; auto with zarith). + rewrite Z.pow_2_r; auto with zarith. + replace [|r-wB|] with (r-wB) by (symmetry; apply Zmod_small; auto with zarith). + rewrite Z.pow_2_r; omega. + + assert (0<=Zneg p). + rewrite Heqz; generalize wB_pos; auto with zarith. + compute in H0; elim H0; auto. + Qed. + + Lemma two_p_power2 : forall x, x>=0 -> two_p x = 2 ^ x. + Proof. + intros. + unfold two_p. + destruct x; simpl; auto. + apply two_power_pos_correct. + Qed. + + Definition head0 x := match [|x|] with + | Z0 => zdigits + | Zpos p => zdigits - log_inf p - 1 + | _ => 0 + end. + + Lemma spec_head00: forall x, [|x|] = 0 -> [|head0 x|] = Zpos digits. + Proof. + unfold head0; intros. + rewrite H; simpl. + apply spec_zdigits. + Qed. + + Lemma log_inf_bounded : forall x p, Zpos x < 2^p -> log_inf x < p. + Proof. + induction x; simpl; intros. + + assert (0 < p) by (destruct p; compute; auto with zarith; discriminate). + cut (log_inf x < p - 1); [omega| ]. + apply IHx. + change (Zpos x~1) with (2*(Zpos x)+1) in H. + replace p with (Z.succ (p-1)) in H; auto with zarith. + rewrite Z.pow_succ_r in H; auto with zarith. + + assert (0 < p) by (destruct p; compute; auto with zarith; discriminate). + cut (log_inf x < p - 1); [omega| ]. + apply IHx. + change (Zpos x~0) with (2*(Zpos x)) in H. + replace p with (Z.succ (p-1)) in H; auto with zarith. + rewrite Z.pow_succ_r in H; auto with zarith. + + simpl; intros; destruct p; compute; auto with zarith. + Qed. + + + Lemma spec_head0 : forall x, 0 < [|x|] -> + wB/ 2 <= 2 ^ ([|head0 x|]) * [|x|] < wB. + Proof. + intros; unfold head0. + generalize (spec_to_Z x). + destruct [|x|]; try discriminate. + intros. + destruct (log_inf_correct p). + rewrite 2 two_p_power2 in H2; auto with zarith. + assert (0 <= zdigits - log_inf p - 1 < wB). + split. + cut (log_inf p < zdigits); try omega. + unfold zdigits. + unfold wB, base in *. + apply log_inf_bounded; auto with zarith. + apply Z.lt_trans with zdigits. + omega. + unfold zdigits, wB, base; apply Zpower2_lt_lin; auto with zarith. + + unfold to_Z; rewrite (Zmod_small _ _ H3). + destruct H2. + split. + apply Z.le_trans with (2^(zdigits - log_inf p - 1)*(2^log_inf p)). + apply Zdiv_le_upper_bound; auto with zarith. + rewrite <- Zpower_exp; auto with zarith. + rewrite Z.mul_comm; rewrite <- Z.pow_succ_r; auto with zarith. + replace (Z.succ (zdigits - log_inf p -1 +log_inf p)) with zdigits + by ring. + unfold wB, base, zdigits; auto with zarith. + apply Z.mul_le_mono_nonneg; auto with zarith. + + apply Z.lt_le_trans + with (2^(zdigits - log_inf p - 1)*(2^(Z.succ (log_inf p)))). + apply Z.mul_lt_mono_pos_l; auto with zarith. + rewrite <- Zpower_exp; auto with zarith. + replace (zdigits - log_inf p -1 +Z.succ (log_inf p)) with zdigits + by ring. + unfold wB, base, zdigits; auto with zarith. + Qed. + + Fixpoint Ptail p := match p with + | xO p => (Ptail p)+1 + | _ => 0 + end. + + Lemma Ptail_pos : forall p, 0 <= Ptail p. + Proof. + induction p; simpl; auto with zarith. + Qed. + Hint Resolve Ptail_pos : core. + + Lemma Ptail_bounded : forall p d, Zpos p < 2^(Zpos d) -> Ptail p < Zpos d. + Proof. + induction p; try (compute; auto; fail). + intros; simpl. + assert (d <> xH). + intro; subst. + compute in H; destruct p; discriminate. + assert (Z.succ (Zpos (Pos.pred d)) = Zpos d). + simpl; f_equal. + rewrite Pos.add_1_r. + destruct (Pos.succ_pred_or d); auto. + rewrite H1 in H0; elim H0; auto. + assert (Ptail p < Zpos (Pos.pred d)). + apply IHp. + apply Z.mul_lt_mono_pos_r with 2; auto with zarith. + rewrite (Z.mul_comm (Zpos p)). + change (2 * Zpos p) with (Zpos p~0). + rewrite Z.mul_comm. + rewrite <- Z.pow_succ_r; auto with zarith. + rewrite H1; auto. + rewrite <- H1; omega. + Qed. + + Definition tail0 x := + match [|x|] with + | Z0 => zdigits + | Zpos p => Ptail p + | Zneg _ => 0 + end. + + Lemma spec_tail00: forall x, [|x|] = 0 -> [|tail0 x|] = Zpos digits. + Proof. + unfold tail0; intros. + rewrite H; simpl. + apply spec_zdigits. + Qed. + + Lemma spec_tail0 : forall x, 0 < [|x|] -> + exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|tail0 x|]). + Proof. + intros; unfold tail0. + generalize (spec_to_Z x). + destruct [|x|]; try discriminate; intros. + assert ([|Ptail p|] = Ptail p). + apply Zmod_small. + split; auto. + unfold wB, base in *. + apply Z.lt_trans with (Zpos digits). + apply Ptail_bounded; auto with zarith. + apply Zpower2_lt_lin; auto with zarith. + rewrite H1. + + clear; induction p. + exists (Zpos p); simpl; rewrite Pos.mul_1_r; auto with zarith. + destruct IHp as (y & Yp & Ye). + exists y. + split; auto. + change (Zpos p~0) with (2*Zpos p). + rewrite Ye. + change (Ptail p~0) with (Z.succ (Ptail p)). + rewrite Z.pow_succ_r; auto; ring. + + exists 0; simpl; auto with zarith. + Qed. + + Definition lor := Z.lor. + Definition land := Z.land. + Definition lxor := Z.lxor. + + Lemma spec_lor x y : [|lor x y|] = Z.lor [|x|] [|y|]. + Proof. + unfold lor, to_Z. + apply Z.bits_inj'; intros n Hn. rewrite Z.lor_spec. + unfold wB, base. + destruct (Z.le_gt_cases (Z.pos digits) n). + - rewrite !Z.mod_pow2_bits_high; auto with zarith. + - rewrite !Z.mod_pow2_bits_low, Z.lor_spec; auto with zarith. + Qed. + + Lemma spec_land x y : [|land x y|] = Z.land [|x|] [|y|]. + Proof. + unfold land, to_Z. + apply Z.bits_inj'; intros n Hn. rewrite Z.land_spec. + unfold wB, base. + destruct (Z.le_gt_cases (Z.pos digits) n). + - rewrite !Z.mod_pow2_bits_high; auto with zarith. + - rewrite !Z.mod_pow2_bits_low, Z.land_spec; auto with zarith. + Qed. + + Lemma spec_lxor x y : [|lxor x y|] = Z.lxor [|x|] [|y|]. + Proof. + unfold lxor, to_Z. + apply Z.bits_inj'; intros n Hn. rewrite Z.lxor_spec. + unfold wB, base. + destruct (Z.le_gt_cases (Z.pos digits) n). + - rewrite !Z.mod_pow2_bits_high; auto with zarith. + - rewrite !Z.mod_pow2_bits_low, Z.lxor_spec; auto with zarith. + Qed. + + (** Let's now group everything in two records *) + + Instance zmod_ops : ZnZ.Ops Z := ZnZ.MkOps + (digits : positive) + (zdigits: t) + (to_Z : t -> Z) + (of_pos : positive -> N * t) + (head0 : t -> t) + (tail0 : t -> t) + + (zero : t) + (one : t) + (minus_one : t) + + (compare : t -> t -> comparison) + (eq0 : t -> bool) + + (opp_c : t -> carry t) + (opp : t -> t) + (opp_carry : t -> t) + + (succ_c : t -> carry t) + (add_c : t -> t -> carry t) + (add_carry_c : t -> t -> carry t) + (succ : t -> t) + (add : t -> t -> t) + (add_carry : t -> t -> t) + + (pred_c : t -> carry t) + (sub_c : t -> t -> carry t) + (sub_carry_c : t -> t -> carry t) + (pred : t -> t) + (sub : t -> t -> t) + (sub_carry : t -> t -> t) + + (mul_c : t -> t -> zn2z t) + (mul : t -> t -> t) + (square_c : t -> zn2z t) + + (div21 : t -> t -> t -> t*t) + (div_gt : t -> t -> t * t) + (div : t -> t -> t * t) + + (modulo_gt : t -> t -> t) + (modulo : t -> t -> t) + + (gcd_gt : t -> t -> t) + (gcd : t -> t -> t) + (add_mul_div : t -> t -> t -> t) + (pos_mod : t -> t -> t) + + (is_even : t -> bool) + (sqrt2 : t -> t -> t * carry t) + (sqrt : t -> t) + (lor : t -> t -> t) + (land : t -> t -> t) + (lxor : t -> t -> t). + + Instance zmod_specs : ZnZ.Specs zmod_ops := ZnZ.MkSpecs + spec_to_Z + spec_of_pos + spec_zdigits + spec_more_than_1_digit + + spec_0 + spec_1 + spec_Bm1 + + spec_compare + spec_eq0 + + spec_opp_c + spec_opp + spec_opp_carry + + spec_succ_c + spec_add_c + spec_add_carry_c + spec_succ + spec_add + spec_add_carry + + spec_pred_c + spec_sub_c + spec_sub_carry_c + spec_pred + spec_sub + spec_sub_carry + + spec_mul_c + spec_mul + spec_square_c + + spec_div21 + spec_div_gt + spec_div + + spec_modulo_gt + spec_modulo + + spec_gcd_gt + spec_gcd + + spec_head00 + spec_head0 + spec_tail00 + spec_tail0 + + spec_add_mul_div + spec_pos_mod + + spec_is_even + spec_sqrt2 + spec_sqrt + spec_lor + spec_land + spec_lxor. + +End ZModulo. + +(** A modular version of the previous construction. *) + +Module Type PositiveNotOne. + Parameter p : positive. + Axiom not_one : p <> 1%positive. +End PositiveNotOne. + +Module ZModuloCyclicType (P:PositiveNotOne) <: CyclicType. + Definition t := Z. + Instance ops : ZnZ.Ops t := zmod_ops P.p. + Instance specs : ZnZ.Specs ops := zmod_specs P.not_one. +End ZModuloCyclicType. diff --git a/theories/Numbers/DecimalFacts.v b/theories/Numbers/DecimalFacts.v new file mode 100644 index 0000000000..0f49052777 --- /dev/null +++ b/theories/Numbers/DecimalFacts.v @@ -0,0 +1,143 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** * DecimalFacts : some facts about Decimal numbers *) + +Require Import Decimal. + +Lemma uint_dec (d d' : uint) : { d = d' } + { d <> d' }. +Proof. + decide equality. +Defined. + +Lemma rev_revapp d d' : + rev (revapp d d') = revapp d' d. +Proof. + revert d'. induction d; simpl; intros; now rewrite ?IHd. +Qed. + +Lemma rev_rev d : rev (rev d) = d. +Proof. + apply rev_revapp. +Qed. + +(** Normalization on little-endian numbers *) + +Fixpoint nztail d := + match d with + | Nil => Nil + | D0 d => match nztail d with Nil => Nil | d' => D0 d' end + | D1 d => D1 (nztail d) + | D2 d => D2 (nztail d) + | D3 d => D3 (nztail d) + | D4 d => D4 (nztail d) + | D5 d => D5 (nztail d) + | D6 d => D6 (nztail d) + | D7 d => D7 (nztail d) + | D8 d => D8 (nztail d) + | D9 d => D9 (nztail d) + end. + +Definition lnorm d := + match nztail d with + | Nil => zero + | d => d + end. + +Lemma nzhead_revapp_0 d d' : nztail d = Nil -> + nzhead (revapp d d') = nzhead d'. +Proof. + revert d'. induction d; intros d' [=]; simpl; trivial. + destruct (nztail d); now rewrite IHd. +Qed. + +Lemma nzhead_revapp d d' : nztail d <> Nil -> + nzhead (revapp d d') = revapp (nztail d) d'. +Proof. + revert d'. + induction d; intros d' H; simpl in *; + try destruct (nztail d) eqn:E; + (now rewrite ?nzhead_revapp_0) || (now rewrite IHd). +Qed. + +Lemma nzhead_rev d : nztail d <> Nil -> + nzhead (rev d) = rev (nztail d). +Proof. + apply nzhead_revapp. +Qed. + +Lemma rev_nztail_rev d : + rev (nztail (rev d)) = nzhead d. +Proof. + destruct (uint_dec (nztail (rev d)) Nil) as [H|H]. + - rewrite H. unfold rev; simpl. + rewrite <- (rev_rev d). symmetry. + now apply nzhead_revapp_0. + - now rewrite <- nzhead_rev, rev_rev. +Qed. + +Lemma revapp_nil_inv d d' : revapp d d' = Nil -> d = Nil /\ d' = Nil. +Proof. + revert d'. + induction d; simpl; intros d' H; auto; now apply IHd in H. +Qed. + +Lemma rev_nil_inv d : rev d = Nil -> d = Nil. +Proof. + apply revapp_nil_inv. +Qed. + +Lemma rev_lnorm_rev d : + rev (lnorm (rev d)) = unorm d. +Proof. + unfold unorm, lnorm. + rewrite <- rev_nztail_rev. + destruct nztail; simpl; trivial; + destruct rev eqn:E; trivial; now apply rev_nil_inv in E. +Qed. + +Lemma nzhead_nonzero d d' : nzhead d <> D0 d'. +Proof. + induction d; easy. +Qed. + +Lemma unorm_0 d : unorm d = zero <-> nzhead d = Nil. +Proof. + unfold unorm. split. + - generalize (nzhead_nonzero d). + destruct nzhead; intros H [=]; trivial. now destruct (H u). + - now intros ->. +Qed. + +Lemma unorm_nonnil d : unorm d <> Nil. +Proof. + unfold unorm. now destruct nzhead. +Qed. + +Lemma nzhead_invol d : nzhead (nzhead d) = nzhead d. +Proof. + now induction d. +Qed. + +Lemma unorm_invol d : unorm (unorm d) = unorm d. +Proof. + unfold unorm. + destruct (nzhead d) eqn:E; trivial. + destruct (nzhead_nonzero _ _ E). +Qed. + +Lemma norm_invol d : norm (norm d) = norm d. +Proof. + unfold norm. + destruct d. + - f_equal. apply unorm_invol. + - destruct (nzhead d) eqn:E; auto. + destruct (nzhead_nonzero _ _ E). +Qed. diff --git a/theories/Numbers/DecimalN.v b/theories/Numbers/DecimalN.v new file mode 100644 index 0000000000..ef00e2805b --- /dev/null +++ b/theories/Numbers/DecimalN.v @@ -0,0 +1,107 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** * DecimalN + + Proofs that conversions between decimal numbers and [N] + are bijections *) + +Require Import Decimal DecimalFacts DecimalPos PArith NArith. + +Module Unsigned. + +Lemma of_to (n:N) : N.of_uint (N.to_uint n) = n. +Proof. + destruct n. + - reflexivity. + - apply DecimalPos.Unsigned.of_to. +Qed. + +Lemma to_of (d:uint) : N.to_uint (N.of_uint d) = unorm d. +Proof. + exact (DecimalPos.Unsigned.to_of d). +Qed. + +Lemma to_uint_inj n n' : N.to_uint n = N.to_uint n' -> n = n'. +Proof. + intros E. now rewrite <- (of_to n), <- (of_to n'), E. +Qed. + +Lemma to_uint_surj d : exists p, N.to_uint p = unorm d. +Proof. + exists (N.of_uint d). apply to_of. +Qed. + +Lemma of_uint_norm d : N.of_uint (unorm d) = N.of_uint d. +Proof. + now induction d. +Qed. + +Lemma of_inj d d' : + N.of_uint d = N.of_uint d' -> unorm d = unorm d'. +Proof. + intros. rewrite <- !to_of. now f_equal. +Qed. + +Lemma of_iff d d' : N.of_uint d = N.of_uint d' <-> unorm d = unorm d'. +Proof. + split. apply of_inj. intros E. rewrite <- of_uint_norm, E. + apply of_uint_norm. +Qed. + +End Unsigned. + +(** Conversion from/to signed decimal numbers *) + +Module Signed. + +Lemma of_to (n:N) : N.of_int (N.to_int n) = Some n. +Proof. + unfold N.to_int, N.of_int, norm. f_equal. + rewrite Unsigned.of_uint_norm. apply Unsigned.of_to. +Qed. + +Lemma to_of (d:int)(n:N) : N.of_int d = Some n -> N.to_int n = norm d. +Proof. + unfold N.of_int. + destruct (norm d) eqn:Hd; intros [= <-]. + unfold N.to_int. rewrite Unsigned.to_of. f_equal. + revert Hd; destruct d; simpl. + - intros [= <-]. apply unorm_invol. + - destruct (nzhead d); now intros [= <-]. +Qed. + +Lemma to_int_inj n n' : N.to_int n = N.to_int n' -> n = n'. +Proof. + intro E. + assert (E' : Some n = Some n'). + { now rewrite <- (of_to n), <- (of_to n'), E. } + now injection E'. +Qed. + +Lemma to_int_pos_surj d : exists n, N.to_int n = norm (Pos d). +Proof. + exists (N.of_uint d). unfold N.to_int. now rewrite Unsigned.to_of. +Qed. + +Lemma of_int_norm d : N.of_int (norm d) = N.of_int d. +Proof. + unfold N.of_int. now rewrite norm_invol. +Qed. + +Lemma of_inj_pos d d' : + N.of_int (Pos d) = N.of_int (Pos d') -> unorm d = unorm d'. +Proof. + unfold N.of_int. simpl. intros [= H]. apply Unsigned.of_inj. + change Pos.of_uint with N.of_uint in H. + now rewrite <- Unsigned.of_uint_norm, H, Unsigned.of_uint_norm. +Qed. + +End Signed. diff --git a/theories/Numbers/DecimalNat.v b/theories/Numbers/DecimalNat.v new file mode 100644 index 0000000000..5ffe1688b5 --- /dev/null +++ b/theories/Numbers/DecimalNat.v @@ -0,0 +1,302 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** * DecimalNat + + Proofs that conversions between decimal numbers and [nat] + are bijections. *) + +Require Import Decimal DecimalFacts Arith. + +Module Unsigned. + +(** A few helper functions used during proofs *) + +Definition hd d := + match d with + | Nil => 0 + | D0 _ => 0 + | D1 _ => 1 + | D2 _ => 2 + | D3 _ => 3 + | D4 _ => 4 + | D5 _ => 5 + | D6 _ => 6 + | D7 _ => 7 + | D8 _ => 8 + | D9 _ => 9 +end. + +Definition tl d := + match d with + | Nil => d + | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d => d +end. + +Fixpoint usize (d:uint) : nat := + match d with + | Nil => 0 + | D0 d => S (usize d) + | D1 d => S (usize d) + | D2 d => S (usize d) + | D3 d => S (usize d) + | D4 d => S (usize d) + | D5 d => S (usize d) + | D6 d => S (usize d) + | D7 d => S (usize d) + | D8 d => S (usize d) + | D9 d => S (usize d) + end. + +(** A direct version of [to_little_uint], not tail-recursive *) +Fixpoint to_lu n := + match n with + | 0 => Decimal.zero + | S n => Little.succ (to_lu n) + end. + +(** A direct version of [of_little_uint] *) +Fixpoint of_lu (d:uint) : nat := + match d with + | Nil => 0 + | D0 d => 10 * of_lu d + | D1 d => 1 + 10 * of_lu d + | D2 d => 2 + 10 * of_lu d + | D3 d => 3 + 10 * of_lu d + | D4 d => 4 + 10 * of_lu d + | D5 d => 5 + 10 * of_lu d + | D6 d => 6 + 10 * of_lu d + | D7 d => 7 + 10 * of_lu d + | D8 d => 8 + 10 * of_lu d + | D9 d => 9 + 10 * of_lu d + end. + +(** Properties of [to_lu] *) + +Lemma to_lu_succ n : to_lu (S n) = Little.succ (to_lu n). +Proof. + reflexivity. +Qed. + +Lemma to_little_uint_succ n d : + Nat.to_little_uint n (Little.succ d) = + Little.succ (Nat.to_little_uint n d). +Proof. + revert d; induction n; simpl; trivial. +Qed. + +Lemma to_lu_equiv n : + to_lu n = Nat.to_little_uint n zero. +Proof. + induction n; simpl; trivial. + now rewrite IHn, <- to_little_uint_succ. +Qed. + +Lemma to_uint_alt n : + Nat.to_uint n = rev (to_lu n). +Proof. + unfold Nat.to_uint. f_equal. symmetry. apply to_lu_equiv. +Qed. + +(** Properties of [of_lu] *) + +Lemma of_lu_eqn d : + of_lu d = hd d + 10 * of_lu (tl d). +Proof. + induction d; simpl; trivial. +Qed. + +Ltac simpl_of_lu := + match goal with + | |- context [ of_lu (?f ?x) ] => + rewrite (of_lu_eqn (f x)); simpl hd; simpl tl + end. + +Lemma of_lu_succ d : + of_lu (Little.succ d) = S (of_lu d). +Proof. + induction d; trivial. + simpl_of_lu. rewrite IHd. simpl_of_lu. + now rewrite Nat.mul_succ_r, <- (Nat.add_comm 10). +Qed. + +Lemma of_to_lu n : + of_lu (to_lu n) = n. +Proof. + induction n; simpl; trivial. rewrite of_lu_succ. now f_equal. +Qed. + +Lemma of_lu_revapp d d' : +of_lu (revapp d d') = + of_lu (rev d) + of_lu d' * 10^usize d. +Proof. + revert d'. + induction d; intro d'; simpl usize; + [ simpl; now rewrite Nat.mul_1_r | .. ]; + unfold rev; simpl revapp; rewrite 2 IHd; + rewrite <- Nat.add_assoc; f_equal; simpl_of_lu; simpl of_lu; + rewrite Nat.pow_succ_r'; ring. +Qed. + +Lemma of_uint_acc_spec n d : + Nat.of_uint_acc d n = of_lu (rev d) + n * 10^usize d. +Proof. + revert n. induction d; intros; + simpl Nat.of_uint_acc; rewrite ?Nat.tail_mul_spec, ?IHd; + simpl rev; simpl usize; rewrite ?Nat.pow_succ_r'; + [ simpl; now rewrite Nat.mul_1_r | .. ]; + unfold rev at 2; simpl revapp; rewrite of_lu_revapp; + simpl of_lu; ring. +Qed. + +Lemma of_uint_alt d : Nat.of_uint d = of_lu (rev d). +Proof. + unfold Nat.of_uint. now rewrite of_uint_acc_spec. +Qed. + +(** First main bijection result *) + +Lemma of_to (n:nat) : Nat.of_uint (Nat.to_uint n) = n. +Proof. + rewrite to_uint_alt, of_uint_alt, rev_rev. apply of_to_lu. +Qed. + +(** The other direction *) + +Lemma to_lu_tenfold n : n<>0 -> + to_lu (10 * n) = D0 (to_lu n). +Proof. + induction n. + - simpl. now destruct 1. + - intros _. + destruct (Nat.eq_dec n 0) as [->|H]; simpl; trivial. + rewrite !Nat.add_succ_r. + simpl in *. rewrite (IHn H). now destruct (to_lu n). +Qed. + +Lemma of_lu_0 d : of_lu d = 0 <-> nztail d = Nil. +Proof. + induction d; try simpl_of_lu; try easy. + rewrite Nat.add_0_l. + split; intros H. + - apply Nat.eq_mul_0_r in H; auto. + rewrite IHd in H. simpl. now rewrite H. + - simpl in H. destruct (nztail d); try discriminate. + now destruct IHd as [_ ->]. +Qed. + +Lemma to_of_lu_tenfold d : + to_lu (of_lu d) = lnorm d -> + to_lu (10 * of_lu d) = lnorm (D0 d). +Proof. + intro IH. + destruct (Nat.eq_dec (of_lu d) 0) as [H|H]. + - rewrite H. simpl. rewrite of_lu_0 in H. + unfold lnorm. simpl. now rewrite H. + - rewrite (to_lu_tenfold _ H), IH. + rewrite of_lu_0 in H. + unfold lnorm. simpl. now destruct (nztail d). +Qed. + +Lemma to_of_lu d : to_lu (of_lu d) = lnorm d. +Proof. + induction d; [ reflexivity | .. ]; + simpl_of_lu; + rewrite ?Nat.add_succ_l, Nat.add_0_l, ?to_lu_succ, to_of_lu_tenfold + by assumption; + unfold lnorm; simpl; now destruct nztail. +Qed. + +(** Second bijection result *) + +Lemma to_of (d:uint) : Nat.to_uint (Nat.of_uint d) = unorm d. +Proof. + rewrite to_uint_alt, of_uint_alt, to_of_lu. + apply rev_lnorm_rev. +Qed. + +(** Some consequences *) + +Lemma to_uint_inj n n' : Nat.to_uint n = Nat.to_uint n' -> n = n'. +Proof. + intro EQ. + now rewrite <- (of_to n), <- (of_to n'), EQ. +Qed. + +Lemma to_uint_surj d : exists n, Nat.to_uint n = unorm d. +Proof. + exists (Nat.of_uint d). apply to_of. +Qed. + +Lemma of_uint_norm d : Nat.of_uint (unorm d) = Nat.of_uint d. +Proof. + unfold Nat.of_uint. now induction d. +Qed. + +Lemma of_inj d d' : + Nat.of_uint d = Nat.of_uint d' -> unorm d = unorm d'. +Proof. + intros. rewrite <- !to_of. now f_equal. +Qed. + +Lemma of_iff d d' : Nat.of_uint d = Nat.of_uint d' <-> unorm d = unorm d'. +Proof. + split. apply of_inj. intros E. rewrite <- of_uint_norm, E. + apply of_uint_norm. +Qed. + +End Unsigned. + +(** Conversion from/to signed decimal numbers *) + +Module Signed. + +Lemma of_to (n:nat) : Nat.of_int (Nat.to_int n) = Some n. +Proof. + unfold Nat.to_int, Nat.of_int, norm. f_equal. + rewrite Unsigned.of_uint_norm. apply Unsigned.of_to. +Qed. + +Lemma to_of (d:int)(n:nat) : Nat.of_int d = Some n -> Nat.to_int n = norm d. +Proof. + unfold Nat.of_int. + destruct (norm d) eqn:Hd; intros [= <-]. + unfold Nat.to_int. rewrite Unsigned.to_of. f_equal. + revert Hd; destruct d; simpl. + - intros [= <-]. apply unorm_invol. + - destruct (nzhead d); now intros [= <-]. +Qed. + +Lemma to_int_inj n n' : Nat.to_int n = Nat.to_int n' -> n = n'. +Proof. + intro E. + assert (E' : Some n = Some n'). + { now rewrite <- (of_to n), <- (of_to n'), E. } + now injection E'. +Qed. + +Lemma to_int_pos_surj d : exists n, Nat.to_int n = norm (Pos d). +Proof. + exists (Nat.of_uint d). unfold Nat.to_int. now rewrite Unsigned.to_of. +Qed. + +Lemma of_int_norm d : Nat.of_int (norm d) = Nat.of_int d. +Proof. + unfold Nat.of_int. now rewrite norm_invol. +Qed. + +Lemma of_inj_pos d d' : + Nat.of_int (Pos d) = Nat.of_int (Pos d') -> unorm d = unorm d'. +Proof. + unfold Nat.of_int. simpl. intros [= H]. apply Unsigned.of_inj. + now rewrite <- Unsigned.of_uint_norm, H, Unsigned.of_uint_norm. +Qed. + +End Signed. diff --git a/theories/Numbers/DecimalPos.v b/theories/Numbers/DecimalPos.v new file mode 100644 index 0000000000..722e73d96b --- /dev/null +++ b/theories/Numbers/DecimalPos.v @@ -0,0 +1,383 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** * DecimalPos + + Proofs that conversions between decimal numbers and [positive] + are bijections. *) + +Require Import Decimal DecimalFacts PArith NArith. + +Module Unsigned. + +Local Open Scope N. + +(** A direct version of [of_little_uint] *) +Fixpoint of_lu (d:uint) : N := + match d with + | Nil => 0 + | D0 d => 10 * of_lu d + | D1 d => 1 + 10 * of_lu d + | D2 d => 2 + 10 * of_lu d + | D3 d => 3 + 10 * of_lu d + | D4 d => 4 + 10 * of_lu d + | D5 d => 5 + 10 * of_lu d + | D6 d => 6 + 10 * of_lu d + | D7 d => 7 + 10 * of_lu d + | D8 d => 8 + 10 * of_lu d + | D9 d => 9 + 10 * of_lu d + end. + +Definition hd d := +match d with + | Nil => 0 + | D0 _ => 0 + | D1 _ => 1 + | D2 _ => 2 + | D3 _ => 3 + | D4 _ => 4 + | D5 _ => 5 + | D6 _ => 6 + | D7 _ => 7 + | D8 _ => 8 + | D9 _ => 9 +end. + +Definition tl d := + match d with + | Nil => d + | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d => d +end. + +Lemma of_lu_eqn d : + of_lu d = hd d + 10 * (of_lu (tl d)). +Proof. + induction d; simpl; trivial. +Qed. + +Ltac simpl_of_lu := + match goal with + | |- context [ of_lu (?f ?x) ] => + rewrite (of_lu_eqn (f x)); simpl hd; simpl tl + end. + +Fixpoint usize (d:uint) : N := + match d with + | Nil => 0 + | D0 d => N.succ (usize d) + | D1 d => N.succ (usize d) + | D2 d => N.succ (usize d) + | D3 d => N.succ (usize d) + | D4 d => N.succ (usize d) + | D5 d => N.succ (usize d) + | D6 d => N.succ (usize d) + | D7 d => N.succ (usize d) + | D8 d => N.succ (usize d) + | D9 d => N.succ (usize d) + end. + +Lemma of_lu_revapp d d' : + of_lu (revapp d d') = + of_lu (rev d) + of_lu d' * 10^usize d. +Proof. + revert d'. + induction d; simpl; intro d'; [ now rewrite N.mul_1_r | .. ]; + unfold rev; simpl revapp; rewrite 2 IHd; + rewrite <- N.add_assoc; f_equal; simpl_of_lu; simpl of_lu; + rewrite N.pow_succ_r'; ring. +Qed. + +Definition Nadd n p := + match n with + | N0 => p + | Npos p0 => (p0+p)%positive + end. + +Lemma Nadd_simpl n p q : Npos (Nadd n (p * q)) = n + Npos p * Npos q. +Proof. + now destruct n. +Qed. + +Lemma of_uint_acc_eqn d acc : d<>Nil -> + Pos.of_uint_acc d acc = Pos.of_uint_acc (tl d) (Nadd (hd d) (10*acc)). +Proof. + destruct d; simpl; trivial. now destruct 1. +Qed. + +Lemma of_uint_acc_rev d acc : + Npos (Pos.of_uint_acc d acc) = + of_lu (rev d) + (Npos acc) * 10^usize d. +Proof. + revert acc. + induction d; intros; simpl usize; + [ simpl; now rewrite Pos.mul_1_r | .. ]; + rewrite N.pow_succ_r'; + unfold rev; simpl revapp; try rewrite of_lu_revapp; simpl of_lu; + rewrite of_uint_acc_eqn by easy; simpl tl; simpl hd; + rewrite IHd, Nadd_simpl; ring. +Qed. + +Lemma of_uint_alt d : Pos.of_uint d = of_lu (rev d). +Proof. + induction d; simpl; trivial; unfold rev; simpl revapp; + rewrite of_lu_revapp; simpl of_lu; try apply of_uint_acc_rev. + rewrite IHd. ring. +Qed. + +Lemma of_lu_rev d : Pos.of_uint (rev d) = of_lu d. +Proof. + rewrite of_uint_alt. now rewrite rev_rev. +Qed. + +Lemma of_lu_double_gen d : + of_lu (Little.double d) = N.double (of_lu d) /\ + of_lu (Little.succ_double d) = N.succ_double (of_lu d). +Proof. + rewrite N.double_spec, N.succ_double_spec. + induction d; try destruct IHd as (IH1,IH2); + simpl Little.double; simpl Little.succ_double; + repeat (simpl_of_lu; rewrite ?IH1, ?IH2); split; reflexivity || ring. +Qed. + +Lemma of_lu_double d : + of_lu (Little.double d) = N.double (of_lu d). +Proof. + apply of_lu_double_gen. +Qed. + +Lemma of_lu_succ_double d : + of_lu (Little.succ_double d) = N.succ_double (of_lu d). +Proof. + apply of_lu_double_gen. +Qed. + +(** First bijection result *) + +Lemma of_to (p:positive) : Pos.of_uint (Pos.to_uint p) = Npos p. +Proof. + unfold Pos.to_uint. + rewrite of_lu_rev. + induction p; simpl; trivial. + - now rewrite of_lu_succ_double, IHp. + - now rewrite of_lu_double, IHp. +Qed. + +(** The other direction *) + +Definition to_lu n := + match n with + | N0 => Decimal.zero + | Npos p => Pos.to_little_uint p + end. + +Lemma succ_double_alt d : + Little.succ_double d = Little.succ (Little.double d). +Proof. + now induction d. +Qed. + +Lemma double_succ d : + Little.double (Little.succ d) = + Little.succ (Little.succ_double d). +Proof. + induction d; simpl; f_equal; auto using succ_double_alt. +Qed. + +Lemma to_lu_succ n : + to_lu (N.succ n) = Little.succ (to_lu n). +Proof. + destruct n; simpl; trivial. + induction p; simpl; rewrite ?IHp; + auto using succ_double_alt, double_succ. +Qed. + +Lemma nat_iter_S n {A} (f:A->A) i : + Nat.iter (S n) f i = f (Nat.iter n f i). +Proof. + reflexivity. +Qed. + +Lemma nat_iter_0 {A} (f:A->A) i : Nat.iter 0 f i = i. +Proof. + reflexivity. +Qed. + +Lemma to_ldec_tenfold p : + to_lu (10 * Npos p) = D0 (to_lu (Npos p)). +Proof. + induction p using Pos.peano_rect. + - trivial. + - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)). + rewrite N.mul_succ_r. + change 10 at 2 with (Nat.iter 10%nat N.succ 0). + rewrite ?nat_iter_S, nat_iter_0. + rewrite !N.add_succ_r, N.add_0_r, !to_lu_succ, IHp. + destruct (to_lu (N.pos p)); simpl; auto. +Qed. + +Lemma of_lu_0 d : of_lu d = 0 <-> nztail d = Nil. +Proof. + induction d; try simpl_of_lu; split; trivial; try discriminate; + try (intros H; now apply N.eq_add_0 in H). + - rewrite N.add_0_l. intros H. + apply N.eq_mul_0_r in H; [|easy]. rewrite IHd in H. + simpl. now rewrite H. + - simpl. destruct (nztail d); try discriminate. + now destruct IHd as [_ ->]. +Qed. + +Lemma to_of_lu_tenfold d : + to_lu (of_lu d) = lnorm d -> + to_lu (10 * of_lu d) = lnorm (D0 d). +Proof. + intro IH. + destruct (N.eq_dec (of_lu d) 0) as [H|H]. + - rewrite H. simpl. rewrite of_lu_0 in H. + unfold lnorm. simpl. now rewrite H. + - destruct (of_lu d) eqn:Eq; [easy| ]. + rewrite to_ldec_tenfold; auto. rewrite IH. + rewrite <- Eq in H. rewrite of_lu_0 in H. + unfold lnorm. simpl. now destruct (nztail d). +Qed. + +Lemma Nadd_alt n m : n + m = Nat.iter (N.to_nat n) N.succ m. +Proof. + destruct n. trivial. + induction p using Pos.peano_rect. + - now rewrite N.add_1_l. + - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)). + now rewrite N.add_succ_l, IHp, N2Nat.inj_succ. +Qed. + +Ltac simpl_to_nat := simpl N.to_nat; unfold Pos.to_nat; simpl Pos.iter_op. + +Lemma to_of_lu d : to_lu (of_lu d) = lnorm d. +Proof. + induction d; [reflexivity|..]; + simpl_of_lu; rewrite Nadd_alt; simpl_to_nat; + rewrite ?nat_iter_S, nat_iter_0, ?to_lu_succ, to_of_lu_tenfold by assumption; + unfold lnorm; simpl; destruct nztail; auto. +Qed. + +(** Second bijection result *) + +Lemma to_of (d:uint) : N.to_uint (Pos.of_uint d) = unorm d. +Proof. + rewrite of_uint_alt. + unfold N.to_uint, Pos.to_uint. + destruct (of_lu (rev d)) eqn:H. + - rewrite of_lu_0 in H. rewrite <- rev_lnorm_rev. + unfold lnorm. now rewrite H. + - change (Pos.to_little_uint p) with (to_lu (N.pos p)). + rewrite <- H. rewrite to_of_lu. apply rev_lnorm_rev. +Qed. + +(** Some consequences *) + +Lemma to_uint_nonzero p : Pos.to_uint p <> zero. +Proof. + intro E. generalize (of_to p). now rewrite E. +Qed. + +Lemma to_uint_nonnil p : Pos.to_uint p <> Nil. +Proof. + intros E. generalize (of_to p). now rewrite E. +Qed. + +Lemma to_uint_inj p p' : Pos.to_uint p = Pos.to_uint p' -> p = p'. +Proof. + intro E. + assert (E' : N.pos p = N.pos p'). + { now rewrite <- (of_to p), <- (of_to p'), E. } + now injection E'. +Qed. + +Lemma to_uint_pos_surj d : + unorm d<>zero -> exists p, Pos.to_uint p = unorm d. +Proof. + intros. + destruct (Pos.of_uint d) eqn:E. + - destruct H. generalize (to_of d). now rewrite E. + - exists p. generalize (to_of d). now rewrite E. +Qed. + +Lemma of_uint_norm d : Pos.of_uint (unorm d) = Pos.of_uint d. +Proof. + now induction d. +Qed. + +Lemma of_inj d d' : + Pos.of_uint d = Pos.of_uint d' -> unorm d = unorm d'. +Proof. + intros. rewrite <- !to_of. now f_equal. +Qed. + +Lemma of_iff d d' : Pos.of_uint d = Pos.of_uint d' <-> unorm d = unorm d'. +Proof. + split. apply of_inj. intros E. rewrite <- of_uint_norm, E. + apply of_uint_norm. +Qed. + +End Unsigned. + +(** Conversion from/to signed decimal numbers *) + +Module Signed. + +Lemma of_to (p:positive) : Pos.of_int (Pos.to_int p) = Some p. +Proof. + unfold Pos.to_int, Pos.of_int, norm. + now rewrite Unsigned.of_to. +Qed. + +Lemma to_of (d:int)(p:positive) : + Pos.of_int d = Some p -> Pos.to_int p = norm d. +Proof. + unfold Pos.of_int. + destruct d; [ | intros [=]]. + simpl norm. rewrite <- Unsigned.to_of. + destruct (Pos.of_uint d); now intros [= <-]. +Qed. + +Lemma to_int_inj p p' : Pos.to_int p = Pos.to_int p' -> p = p'. +Proof. + intro E. + assert (E' : Some p = Some p'). + { now rewrite <- (of_to p), <- (of_to p'), E. } + now injection E'. +Qed. + +Lemma to_int_pos_surj d : + unorm d <> zero -> exists p, Pos.to_int p = norm (Pos d). +Proof. + simpl. unfold Pos.to_int. intros H. + destruct (Unsigned.to_uint_pos_surj d H) as (p,Hp). + exists p. now f_equal. +Qed. + +Lemma of_int_norm d : Pos.of_int (norm d) = Pos.of_int d. +Proof. + unfold Pos.of_int. + destruct d. + - simpl. now rewrite Unsigned.of_uint_norm. + - simpl. now destruct (nzhead d) eqn:H. +Qed. + +Lemma of_inj_pos d d' : + Pos.of_int (Pos d) = Pos.of_int (Pos d') -> unorm d = unorm d'. +Proof. + unfold Pos.of_int. + destruct (Pos.of_uint d) eqn:Hd, (Pos.of_uint d') eqn:Hd'; + intros [=]. + - apply Unsigned.of_inj; now rewrite Hd, Hd'. + - apply Unsigned.of_inj; rewrite Hd, Hd'; now f_equal. +Qed. + +End Signed. diff --git a/theories/Numbers/DecimalString.v b/theories/Numbers/DecimalString.v new file mode 100644 index 0000000000..591024baec --- /dev/null +++ b/theories/Numbers/DecimalString.v @@ -0,0 +1,265 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import Decimal Ascii String. + +(** * Conversion between decimal numbers and Coq strings *) + +(** Pretty straightforward, which is precisely the point of the + [Decimal.int] datatype. The only catch is [Decimal.Nil] : we could + choose to convert it as [""] or as ["0"]. In the first case, it is + awkward to consider "" (or "-") as a number, while in the second case + we don't have a perfect bijection. Since the second variant is implemented + thanks to the first one, we provide both. *) + +Local Open Scope string_scope. + +(** Parsing one char *) + +Definition uint_of_char (a:ascii)(d:option uint) := + match d with + | None => None + | Some d => + match a with + | "0" => Some (D0 d) + | "1" => Some (D1 d) + | "2" => Some (D2 d) + | "3" => Some (D3 d) + | "4" => Some (D4 d) + | "5" => Some (D5 d) + | "6" => Some (D6 d) + | "7" => Some (D7 d) + | "8" => Some (D8 d) + | "9" => Some (D9 d) + | _ => None + end + end%char. + +Lemma uint_of_char_spec c d d' : + uint_of_char c (Some d) = Some d' -> + (c = "0" /\ d' = D0 d \/ + c = "1" /\ d' = D1 d \/ + c = "2" /\ d' = D2 d \/ + c = "3" /\ d' = D3 d \/ + c = "4" /\ d' = D4 d \/ + c = "5" /\ d' = D5 d \/ + c = "6" /\ d' = D6 d \/ + c = "7" /\ d' = D7 d \/ + c = "8" /\ d' = D8 d \/ + c = "9" /\ d' = D9 d)%char. +Proof. + destruct c as [[|] [|] [|] [|] [|] [|] [|] [|]]; + intros [= <-]; intuition. +Qed. + +(** Decimal/String conversion where [Nil] is [""] *) + +Module NilEmpty. + +Fixpoint string_of_uint (d:uint) := + match d with + | Nil => EmptyString + | D0 d => String "0" (string_of_uint d) + | D1 d => String "1" (string_of_uint d) + | D2 d => String "2" (string_of_uint d) + | D3 d => String "3" (string_of_uint d) + | D4 d => String "4" (string_of_uint d) + | D5 d => String "5" (string_of_uint d) + | D6 d => String "6" (string_of_uint d) + | D7 d => String "7" (string_of_uint d) + | D8 d => String "8" (string_of_uint d) + | D9 d => String "9" (string_of_uint d) + end. + +Fixpoint uint_of_string s := + match s with + | EmptyString => Some Nil + | String a s => uint_of_char a (uint_of_string s) + end. + +Definition string_of_int (d:int) := + match d with + | Pos d => string_of_uint d + | Neg d => String "-" (string_of_uint d) + end. + +Definition int_of_string s := + match s with + | EmptyString => Some (Pos Nil) + | String a s' => + if Ascii.eqb a "-" then option_map Neg (uint_of_string s') + else option_map Pos (uint_of_string s) + end. + +(* NB: For the moment whitespace between - and digits are not accepted. + And in this variant [int_of_string "-" = Some (Neg Nil)]. + +Compute int_of_string "-123456890123456890123456890123456890". +Compute string_of_int (-123456890123456890123456890123456890). +*) + +(** Corresponding proofs *) + +Lemma usu d : + uint_of_string (string_of_uint d) = Some d. +Proof. + induction d; simpl; rewrite ?IHd; simpl; auto. +Qed. + +Lemma sus s d : + uint_of_string s = Some d -> string_of_uint d = s. +Proof. + revert d. + induction s; simpl. + - now intros d [= <-]. + - intros d. + destruct (uint_of_string s); [intros H | intros [=]]. + apply uint_of_char_spec in H. + intuition subst; simpl; f_equal; auto. +Qed. + +Lemma isi d : int_of_string (string_of_int d) = Some d. +Proof. + destruct d; simpl. + - unfold int_of_string. + destruct (string_of_uint d) eqn:Hd. + + now destruct d. + + case Ascii.eqb_spec. + * intros ->. now destruct d. + * rewrite <- Hd, usu; auto. + - rewrite usu; auto. +Qed. + +Lemma sis s d : + int_of_string s = Some d -> string_of_int d = s. +Proof. + destruct s; [intros [= <-]| ]; simpl; trivial. + case Ascii.eqb_spec. + - intros ->. destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. + simpl; f_equal. now apply sus. + - destruct d; [ | now destruct uint_of_char]. + simpl string_of_int. + intros. apply sus; simpl. + destruct uint_of_char; simpl in *; congruence. +Qed. + +End NilEmpty. + +(** Decimal/String conversions where [Nil] is ["0"] *) + +Module NilZero. + +Definition string_of_uint (d:uint) := + match d with + | Nil => "0" + | _ => NilEmpty.string_of_uint d + end. + +Definition uint_of_string s := + match s with + | EmptyString => None + | _ => NilEmpty.uint_of_string s + end. + +Definition string_of_int (d:int) := + match d with + | Pos d => string_of_uint d + | Neg d => String "-" (string_of_uint d) + end. + +Definition int_of_string s := + match s with + | EmptyString => None + | String a s' => + if Ascii.eqb a "-" then option_map Neg (uint_of_string s') + else option_map Pos (uint_of_string s) + end. + +(** Corresponding proofs *) + +Lemma uint_of_string_nonnil s : uint_of_string s <> Some Nil. +Proof. + destruct s; simpl. + - easy. + - destruct (NilEmpty.uint_of_string s); [intros H | intros [=]]. + apply uint_of_char_spec in H. + now intuition subst. +Qed. + +Lemma sus s d : + uint_of_string s = Some d -> string_of_uint d = s. +Proof. + destruct s; [intros [=] | intros H]. + apply NilEmpty.sus in H. now destruct d. +Qed. + +Lemma usu d : + d<>Nil -> uint_of_string (string_of_uint d) = Some d. +Proof. + destruct d; (now destruct 1) || (intros _; apply NilEmpty.usu). +Qed. + +Lemma usu_nil : + uint_of_string (string_of_uint Nil) = Some Decimal.zero. +Proof. + reflexivity. +Qed. + +Lemma usu_gen d : + uint_of_string (string_of_uint d) = Some d \/ + uint_of_string (string_of_uint d) = Some Decimal.zero. +Proof. + destruct d; (now right) || (left; now apply usu). +Qed. + +Lemma isi d : + d<>Pos Nil -> d<>Neg Nil -> + int_of_string (string_of_int d) = Some d. +Proof. + destruct d; simpl. + - intros H _. + unfold int_of_string. + destruct (string_of_uint d) eqn:Hd. + + now destruct d. + + case Ascii.eqb_spec. + * intros ->. now destruct d. + * rewrite <- Hd, usu; auto. now intros ->. + - intros _ H. + rewrite usu; auto. now intros ->. +Qed. + +Lemma isi_posnil : + int_of_string (string_of_int (Pos Nil)) = Some (Pos Decimal.zero). +Proof. + reflexivity. +Qed. + +(** Warning! (-0) won't parse (compatibility with the behavior of Z). *) + +Lemma isi_negnil : + int_of_string (string_of_int (Neg Nil)) = Some (Neg (D0 Nil)). +Proof. + reflexivity. +Qed. + +Lemma sis s d : + int_of_string s = Some d -> string_of_int d = s. +Proof. + destruct s; [intros [=]| ]; simpl. + case Ascii.eqb_spec. + - intros ->. destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. + simpl; f_equal. now apply sus. + - destruct d; [ | now destruct uint_of_char]. + simpl string_of_int. + intros. apply sus; simpl. + destruct uint_of_char; simpl in *; congruence. +Qed. + +End NilZero. diff --git a/theories/Numbers/DecimalZ.v b/theories/Numbers/DecimalZ.v new file mode 100644 index 0000000000..3a08379635 --- /dev/null +++ b/theories/Numbers/DecimalZ.v @@ -0,0 +1,75 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** * DecimalZ + + Proofs that conversions between decimal numbers and [Z] + are bijections. *) + +Require Import Decimal DecimalFacts DecimalPos DecimalN ZArith. + +Lemma of_to (z:Z) : Z.of_int (Z.to_int z) = z. +Proof. + destruct z; simpl. + - trivial. + - unfold Z.of_uint. rewrite DecimalPos.Unsigned.of_to. now destruct p. + - unfold Z.of_uint. rewrite DecimalPos.Unsigned.of_to. destruct p; auto. +Qed. + +Lemma to_of (d:int) : Z.to_int (Z.of_int d) = norm d. +Proof. + destruct d; simpl; unfold Z.to_int, Z.of_uint. + - rewrite <- (DecimalN.Unsigned.to_of d). unfold N.of_uint. + now destruct (Pos.of_uint d). + - destruct (Pos.of_uint d) eqn:Hd; simpl; f_equal. + + generalize (DecimalPos.Unsigned.to_of d). rewrite Hd. simpl. + intros H. symmetry in H. apply unorm_0 in H. now rewrite H. + + assert (Hp := DecimalPos.Unsigned.to_of d). rewrite Hd in Hp. simpl in *. + rewrite Hp. unfold unorm in *. + destruct (nzhead d); trivial. + generalize (DecimalPos.Unsigned.of_to p). now rewrite Hp. +Qed. + +(** Some consequences *) + +Lemma to_int_inj n n' : Z.to_int n = Z.to_int n' -> n = n'. +Proof. + intro EQ. + now rewrite <- (of_to n), <- (of_to n'), EQ. +Qed. + +Lemma to_int_surj d : exists n, Z.to_int n = norm d. +Proof. + exists (Z.of_int d). apply to_of. +Qed. + +Lemma of_int_norm d : Z.of_int (norm d) = Z.of_int d. +Proof. + unfold Z.of_int, Z.of_uint. + destruct d. + - simpl. now rewrite DecimalPos.Unsigned.of_uint_norm. + - simpl. destruct (nzhead d) eqn:H; + [ induction d; simpl; auto; discriminate | + destruct (nzhead_nonzero _ _ H) | .. ]; + f_equal; f_equal; apply DecimalPos.Unsigned.of_iff; + unfold unorm; now rewrite H. +Qed. + +Lemma of_inj d d' : + Z.of_int d = Z.of_int d' -> norm d = norm d'. +Proof. + intros. rewrite <- !to_of. now f_equal. +Qed. + +Lemma of_iff d d' : Z.of_int d = Z.of_int d' <-> norm d = norm d'. +Proof. + split. apply of_inj. intros E. rewrite <- of_int_norm, E. + apply of_int_norm. +Qed. diff --git a/theories/Numbers/Integer/Abstract/ZAdd.v b/theories/Numbers/Integer/Abstract/ZAdd.v new file mode 100644 index 0000000000..c4c5174dac --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZAdd.v @@ -0,0 +1,299 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Export ZBase. + +Module ZAddProp (Import Z : ZAxiomsMiniSig'). +Include ZBaseProp Z. + +(** Theorems that are either not valid on N or have different proofs + on N and Z *) + +Hint Rewrite opp_0 : nz. + +Theorem add_pred_l : forall n m, P n + m == P (n + m). +Proof. +intros n m. +rewrite <- (succ_pred n) at 2. +now rewrite add_succ_l, pred_succ. +Qed. + +Theorem add_pred_r : forall n m, n + P m == P (n + m). +Proof. +intros n m; rewrite 2 (add_comm n); apply add_pred_l. +Qed. + +Theorem add_opp_r : forall n m, n + (- m) == n - m. +Proof. +nzinduct m. +now nzsimpl. +intro m. rewrite opp_succ, sub_succ_r, add_pred_r. now rewrite pred_inj_wd. +Qed. + +Theorem sub_0_l : forall n, 0 - n == - n. +Proof. +intro n; rewrite <- add_opp_r; now rewrite add_0_l. +Qed. + +Theorem sub_succ_l : forall n m, S n - m == S (n - m). +Proof. +intros n m; rewrite <- 2 add_opp_r; now rewrite add_succ_l. +Qed. + +Theorem sub_pred_l : forall n m, P n - m == P (n - m). +Proof. +intros n m. rewrite <- (succ_pred n) at 2. +rewrite sub_succ_l; now rewrite pred_succ. +Qed. + +Theorem sub_pred_r : forall n m, n - (P m) == S (n - m). +Proof. +intros n m. rewrite <- (succ_pred m) at 2. +rewrite sub_succ_r; now rewrite succ_pred. +Qed. + +Theorem opp_pred : forall n, - (P n) == S (- n). +Proof. +intro n. rewrite <- (succ_pred n) at 2. +rewrite opp_succ. now rewrite succ_pred. +Qed. + +Theorem sub_diag : forall n, n - n == 0. +Proof. +nzinduct n. +now nzsimpl. +intro n. rewrite sub_succ_r, sub_succ_l; now rewrite pred_succ. +Qed. + +Theorem add_opp_diag_l : forall n, - n + n == 0. +Proof. +intro n; now rewrite add_comm, add_opp_r, sub_diag. +Qed. + +Theorem add_opp_diag_r : forall n, n + (- n) == 0. +Proof. +intro n; rewrite add_comm; apply add_opp_diag_l. +Qed. + +Theorem add_opp_l : forall n m, - m + n == n - m. +Proof. +intros n m; rewrite <- add_opp_r; now rewrite add_comm. +Qed. + +Theorem add_sub_assoc : forall n m p, n + (m - p) == (n + m) - p. +Proof. +intros n m p; rewrite <- 2 add_opp_r; now rewrite add_assoc. +Qed. + +Theorem opp_involutive : forall n, - (- n) == n. +Proof. +nzinduct n. +now nzsimpl. +intro n. rewrite opp_succ, opp_pred. now rewrite succ_inj_wd. +Qed. + +Theorem opp_add_distr : forall n m, - (n + m) == - n + (- m). +Proof. +intros n m; nzinduct n. +now nzsimpl. +intro n. rewrite add_succ_l; do 2 rewrite opp_succ; rewrite add_pred_l. +now rewrite pred_inj_wd. +Qed. + +Theorem opp_sub_distr : forall n m, - (n - m) == - n + m. +Proof. +intros n m; rewrite <- add_opp_r, opp_add_distr. +now rewrite opp_involutive. +Qed. + +Theorem opp_inj : forall n m, - n == - m -> n == m. +Proof. +intros n m H. apply opp_wd in H. now rewrite 2 opp_involutive in H. +Qed. + +Theorem opp_inj_wd : forall n m, - n == - m <-> n == m. +Proof. +intros n m; split; [apply opp_inj | intros; now f_equiv]. +Qed. + +Theorem eq_opp_l : forall n m, - n == m <-> n == - m. +Proof. +intros n m. now rewrite <- (opp_inj_wd (- n) m), opp_involutive. +Qed. + +Theorem eq_opp_r : forall n m, n == - m <-> - n == m. +Proof. +symmetry; apply eq_opp_l. +Qed. + +Theorem sub_add_distr : forall n m p, n - (m + p) == (n - m) - p. +Proof. +intros n m p; rewrite <- add_opp_r, opp_add_distr, add_assoc. +now rewrite 2 add_opp_r. +Qed. + +Theorem sub_sub_distr : forall n m p, n - (m - p) == (n - m) + p. +Proof. +intros n m p; rewrite <- add_opp_r, opp_sub_distr, add_assoc. +now rewrite add_opp_r. +Qed. + +Theorem sub_opp_l : forall n m, - n - m == - m - n. +Proof. +intros n m. rewrite <- 2 add_opp_r. now rewrite add_comm. +Qed. + +Theorem sub_opp_r : forall n m, n - (- m) == n + m. +Proof. +intros n m; rewrite <- add_opp_r; now rewrite opp_involutive. +Qed. + +Theorem add_sub_swap : forall n m p, n + m - p == n - p + m. +Proof. +intros n m p. rewrite <- add_sub_assoc, <- (add_opp_r n p), <- add_assoc. +now rewrite add_opp_l. +Qed. + +Theorem sub_cancel_l : forall n m p, n - m == n - p <-> m == p. +Proof. +intros n m p. rewrite <- (add_cancel_l (n - m) (n - p) (- n)). +rewrite 2 add_sub_assoc. rewrite add_opp_diag_l; rewrite 2 sub_0_l. +apply opp_inj_wd. +Qed. + +Theorem sub_cancel_r : forall n m p, n - p == m - p <-> n == m. +Proof. +intros n m p. +stepl (n - p + p == m - p + p) by apply add_cancel_r. +now do 2 rewrite <- sub_sub_distr, sub_diag, sub_0_r. +Qed. + +(** The next several theorems are devoted to moving terms from one + side of an equation to the other. The name contains the operation + in the original equation ([add] or [sub]) and the indication + whether the left or right term is moved. *) + +Theorem add_move_l : forall n m p, n + m == p <-> m == p - n. +Proof. +intros n m p. +stepl (n + m - n == p - n) by apply sub_cancel_r. +now rewrite add_comm, <- add_sub_assoc, sub_diag, add_0_r. +Qed. + +Theorem add_move_r : forall n m p, n + m == p <-> n == p - m. +Proof. +intros n m p; rewrite add_comm; now apply add_move_l. +Qed. + +(** The two theorems above do not allow rewriting subformulas of the + form [n - m == p] to [n == p + m] since subtraction is in the + right-hand side of the equation. Hence the following two + theorems. *) + +Theorem sub_move_l : forall n m p, n - m == p <-> - m == p - n. +Proof. +intros n m p; rewrite <- (add_opp_r n m); apply add_move_l. +Qed. + +Theorem sub_move_r : forall n m p, n - m == p <-> n == p + m. +Proof. +intros n m p; rewrite <- (add_opp_r n m). now rewrite add_move_r, sub_opp_r. +Qed. + +Theorem add_move_0_l : forall n m, n + m == 0 <-> m == - n. +Proof. +intros n m; now rewrite add_move_l, sub_0_l. +Qed. + +Theorem add_move_0_r : forall n m, n + m == 0 <-> n == - m. +Proof. +intros n m; now rewrite add_move_r, sub_0_l. +Qed. + +Theorem sub_move_0_l : forall n m, n - m == 0 <-> - m == - n. +Proof. +intros n m. now rewrite sub_move_l, sub_0_l. +Qed. + +Theorem sub_move_0_r : forall n m, n - m == 0 <-> n == m. +Proof. +intros n m. now rewrite sub_move_r, add_0_l. +Qed. + +(** The following section is devoted to cancellation of like + terms. The name includes the first operator and the position of + the term being canceled. *) + +Theorem add_simpl_l : forall n m, n + m - n == m. +Proof. +intros; now rewrite add_sub_swap, sub_diag, add_0_l. +Qed. + +Theorem add_simpl_r : forall n m, n + m - m == n. +Proof. +intros; now rewrite <- add_sub_assoc, sub_diag, add_0_r. +Qed. + +Theorem sub_simpl_l : forall n m, - n - m + n == - m. +Proof. +intros; now rewrite <- add_sub_swap, add_opp_diag_l, sub_0_l. +Qed. + +Theorem sub_simpl_r : forall n m, n - m + m == n. +Proof. +intros; now rewrite <- sub_sub_distr, sub_diag, sub_0_r. +Qed. + +Theorem sub_add : forall n m, m - n + n == m. +Proof. + intros. now rewrite <- add_sub_swap, add_simpl_r. +Qed. + +(** Now we have two sums or differences; the name includes the two + operators and the position of the terms being canceled *) + +Theorem add_add_simpl_l_l : forall n m p, (n + m) - (n + p) == m - p. +Proof. +intros n m p. now rewrite (add_comm n m), <- add_sub_assoc, +sub_add_distr, sub_diag, sub_0_l, add_opp_r. +Qed. + +Theorem add_add_simpl_l_r : forall n m p, (n + m) - (p + n) == m - p. +Proof. +intros n m p. rewrite (add_comm p n); apply add_add_simpl_l_l. +Qed. + +Theorem add_add_simpl_r_l : forall n m p, (n + m) - (m + p) == n - p. +Proof. +intros n m p. rewrite (add_comm n m); apply add_add_simpl_l_l. +Qed. + +Theorem add_add_simpl_r_r : forall n m p, (n + m) - (p + m) == n - p. +Proof. +intros n m p. rewrite (add_comm p m); apply add_add_simpl_r_l. +Qed. + +Theorem sub_add_simpl_r_l : forall n m p, (n - m) + (m + p) == n + p. +Proof. +intros n m p. now rewrite <- sub_sub_distr, sub_add_distr, sub_diag, +sub_0_l, sub_opp_r. +Qed. + +Theorem sub_add_simpl_r_r : forall n m p, (n - m) + (p + m) == n + p. +Proof. +intros n m p. rewrite (add_comm p m); apply sub_add_simpl_r_l. +Qed. + +(** Of course, there are many other variants *) + +End ZAddProp. + diff --git a/theories/Numbers/Integer/Abstract/ZAddOrder.v b/theories/Numbers/Integer/Abstract/ZAddOrder.v new file mode 100644 index 0000000000..7f5b0df68e --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZAddOrder.v @@ -0,0 +1,287 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Export ZLt. + +Module ZAddOrderProp (Import Z : ZAxiomsMiniSig'). +Include ZOrderProp Z. + +(** Theorems that are either not valid on N or have different proofs + on N and Z *) + +Theorem add_neg_neg : forall n m, n < 0 -> m < 0 -> n + m < 0. +Proof. +intros. rewrite <- (add_0_l 0). now apply add_lt_mono. +Qed. + +Theorem add_neg_nonpos : forall n m, n < 0 -> m <= 0 -> n + m < 0. +Proof. +intros. rewrite <- (add_0_l 0). now apply add_lt_le_mono. +Qed. + +Theorem add_nonpos_neg : forall n m, n <= 0 -> m < 0 -> n + m < 0. +Proof. +intros. rewrite <- (add_0_l 0). now apply add_le_lt_mono. +Qed. + +Theorem add_nonpos_nonpos : forall n m, n <= 0 -> m <= 0 -> n + m <= 0. +Proof. +intros. rewrite <- (add_0_l 0). now apply add_le_mono. +Qed. + +(** Sub and order *) + +Theorem lt_0_sub : forall n m, 0 < m - n <-> n < m. +Proof. +intros n m. now rewrite (add_lt_mono_r _ _ n), add_0_l, sub_simpl_r. +Qed. + +Notation sub_pos := lt_0_sub (only parsing). + +Theorem le_0_sub : forall n m, 0 <= m - n <-> n <= m. +Proof. +intros n m. now rewrite (add_le_mono_r _ _ n), add_0_l, sub_simpl_r. +Qed. + +Notation sub_nonneg := le_0_sub (only parsing). + +Theorem lt_sub_0 : forall n m, n - m < 0 <-> n < m. +Proof. +intros n m. now rewrite (add_lt_mono_r _ _ m), add_0_l, sub_simpl_r. +Qed. + +Notation sub_neg := lt_sub_0 (only parsing). + +Theorem le_sub_0 : forall n m, n - m <= 0 <-> n <= m. +Proof. +intros n m. now rewrite (add_le_mono_r _ _ m), add_0_l, sub_simpl_r. +Qed. + +Notation sub_nonpos := le_sub_0 (only parsing). + +Theorem opp_lt_mono : forall n m, n < m <-> - m < - n. +Proof. +intros n m. now rewrite <- lt_0_sub, <- add_opp_l, <- sub_opp_r, lt_0_sub. +Qed. + +Theorem opp_le_mono : forall n m, n <= m <-> - m <= - n. +Proof. +intros n m. now rewrite <- le_0_sub, <- add_opp_l, <- sub_opp_r, le_0_sub. +Qed. + +Theorem opp_pos_neg : forall n, 0 < - n <-> n < 0. +Proof. +intro n; now rewrite (opp_lt_mono n 0), opp_0. +Qed. + +Theorem opp_neg_pos : forall n, - n < 0 <-> 0 < n. +Proof. +intro n. now rewrite (opp_lt_mono 0 n), opp_0. +Qed. + +Theorem opp_nonneg_nonpos : forall n, 0 <= - n <-> n <= 0. +Proof. +intro n; now rewrite (opp_le_mono n 0), opp_0. +Qed. + +Theorem opp_nonpos_nonneg : forall n, - n <= 0 <-> 0 <= n. +Proof. +intro n. now rewrite (opp_le_mono 0 n), opp_0. +Qed. + +Theorem lt_m1_0 : -1 < 0. +Proof. +apply opp_neg_pos, lt_0_1. +Qed. + +Theorem sub_lt_mono_l : forall n m p, n < m <-> p - m < p - n. +Proof. +intros. now rewrite <- 2 add_opp_r, <- add_lt_mono_l, opp_lt_mono. +Qed. + +Theorem sub_lt_mono_r : forall n m p, n < m <-> n - p < m - p. +Proof. +intros. now rewrite <- 2 add_opp_r, add_lt_mono_r. +Qed. + +Theorem sub_lt_mono : forall n m p q, n < m -> q < p -> n - p < m - q. +Proof. +intros n m p q H1 H2. +apply lt_trans with (m - p); +[now apply sub_lt_mono_r | now apply sub_lt_mono_l]. +Qed. + +Theorem sub_le_mono_l : forall n m p, n <= m <-> p - m <= p - n. +Proof. +intros. now rewrite <- 2 add_opp_r, <- add_le_mono_l, opp_le_mono. +Qed. + +Theorem sub_le_mono_r : forall n m p, n <= m <-> n - p <= m - p. +Proof. +intros. now rewrite <- 2 add_opp_r, add_le_mono_r. +Qed. + +Theorem sub_le_mono : forall n m p q, n <= m -> q <= p -> n - p <= m - q. +Proof. +intros n m p q H1 H2. +apply le_trans with (m - p); +[now apply sub_le_mono_r | now apply sub_le_mono_l]. +Qed. + +Theorem sub_lt_le_mono : forall n m p q, n < m -> q <= p -> n - p < m - q. +Proof. +intros n m p q H1 H2. +apply lt_le_trans with (m - p); +[now apply sub_lt_mono_r | now apply sub_le_mono_l]. +Qed. + +Theorem sub_le_lt_mono : forall n m p q, n <= m -> q < p -> n - p < m - q. +Proof. +intros n m p q H1 H2. +apply le_lt_trans with (m - p); +[now apply sub_le_mono_r | now apply sub_lt_mono_l]. +Qed. + +Theorem le_lt_sub_lt : forall n m p q, n <= m -> p - n < q - m -> p < q. +Proof. +intros n m p q H1 H2. apply (le_lt_add_lt (- m) (- n)); +[now apply -> opp_le_mono | now rewrite 2 add_opp_r]. +Qed. + +Theorem lt_le_sub_lt : forall n m p q, n < m -> p - n <= q - m -> p < q. +Proof. +intros n m p q H1 H2. apply (lt_le_add_lt (- m) (- n)); +[now apply -> opp_lt_mono | now rewrite 2 add_opp_r]. +Qed. + +Theorem le_le_sub_lt : forall n m p q, n <= m -> p - n <= q - m -> p <= q. +Proof. +intros n m p q H1 H2. apply (le_le_add_le (- m) (- n)); +[now apply -> opp_le_mono | now rewrite 2 add_opp_r]. +Qed. + +Theorem lt_add_lt_sub_r : forall n m p, n + p < m <-> n < m - p. +Proof. +intros n m p. now rewrite (sub_lt_mono_r _ _ p), add_simpl_r. +Qed. + +Theorem le_add_le_sub_r : forall n m p, n + p <= m <-> n <= m - p. +Proof. +intros n m p. now rewrite (sub_le_mono_r _ _ p), add_simpl_r. +Qed. + +Theorem lt_add_lt_sub_l : forall n m p, n + p < m <-> p < m - n. +Proof. +intros n m p. rewrite add_comm; apply lt_add_lt_sub_r. +Qed. + +Theorem le_add_le_sub_l : forall n m p, n + p <= m <-> p <= m - n. +Proof. +intros n m p. rewrite add_comm; apply le_add_le_sub_r. +Qed. + +Theorem lt_sub_lt_add_r : forall n m p, n - p < m <-> n < m + p. +Proof. +intros n m p. now rewrite (add_lt_mono_r _ _ p), sub_simpl_r. +Qed. + +Theorem le_sub_le_add_r : forall n m p, n - p <= m <-> n <= m + p. +Proof. +intros n m p. now rewrite (add_le_mono_r _ _ p), sub_simpl_r. +Qed. + +Theorem lt_sub_lt_add_l : forall n m p, n - m < p <-> n < m + p. +Proof. +intros n m p. rewrite add_comm; apply lt_sub_lt_add_r. +Qed. + +Theorem le_sub_le_add_l : forall n m p, n - m <= p <-> n <= m + p. +Proof. +intros n m p. rewrite add_comm; apply le_sub_le_add_r. +Qed. + +Theorem lt_sub_lt_add : forall n m p q, n - m < p - q <-> n + q < m + p. +Proof. +intros n m p q. now rewrite lt_sub_lt_add_l, add_sub_assoc, <- lt_add_lt_sub_r. +Qed. + +Theorem le_sub_le_add : forall n m p q, n - m <= p - q <-> n + q <= m + p. +Proof. +intros n m p q. now rewrite le_sub_le_add_l, add_sub_assoc, <- le_add_le_sub_r. +Qed. + +Theorem lt_sub_pos : forall n m, 0 < m <-> n - m < n. +Proof. +intros n m. now rewrite (sub_lt_mono_l _ _ n), sub_0_r. +Qed. + +Theorem le_sub_nonneg : forall n m, 0 <= m <-> n - m <= n. +Proof. +intros n m. now rewrite (sub_le_mono_l _ _ n), sub_0_r. +Qed. + +Theorem sub_lt_cases : forall n m p q, n - m < p - q -> n < m \/ q < p. +Proof. +intros. now apply add_lt_cases, lt_sub_lt_add. +Qed. + +Theorem sub_le_cases : forall n m p q, n - m <= p - q -> n <= m \/ q <= p. +Proof. +intros. now apply add_le_cases, le_sub_le_add. +Qed. + +Theorem sub_neg_cases : forall n m, n - m < 0 -> n < 0 \/ 0 < m. +Proof. +intros. +rewrite <- (opp_neg_pos m). apply add_neg_cases. now rewrite add_opp_r. +Qed. + +Theorem sub_pos_cases : forall n m, 0 < n - m -> 0 < n \/ m < 0. +Proof. +intros. +rewrite <- (opp_pos_neg m). apply add_pos_cases. now rewrite add_opp_r. +Qed. + +Theorem sub_nonpos_cases : forall n m, n - m <= 0 -> n <= 0 \/ 0 <= m. +Proof. +intros. +rewrite <- (opp_nonpos_nonneg m). apply add_nonpos_cases. now rewrite add_opp_r. +Qed. + +Theorem sub_nonneg_cases : forall n m, 0 <= n - m -> 0 <= n \/ m <= 0. +Proof. +intros. +rewrite <- (opp_nonneg_nonpos m). apply add_nonneg_cases. now rewrite add_opp_r. +Qed. + +Section PosNeg. + +Variable P : Z.t -> Prop. +Hypothesis P_wd : Proper (eq ==> iff) P. + +Theorem zero_pos_neg : + P 0 -> (forall n, 0 < n -> P n /\ P (- n)) -> forall n, P n. +Proof. +intros H1 H2 n. destruct (lt_trichotomy n 0) as [H3 | [H3 | H3]]. +apply opp_pos_neg, H2 in H3. destruct H3 as [_ H3]. +now rewrite opp_involutive in H3. +now rewrite H3. +apply H2 in H3; now destruct H3. +Qed. + +End PosNeg. + +Ltac zero_pos_neg n := induction_maker n ltac:(apply zero_pos_neg). + +End ZAddOrderProp. + + diff --git a/theories/Numbers/Integer/Abstract/ZAxioms.v b/theories/Numbers/Integer/Abstract/ZAxioms.v new file mode 100644 index 0000000000..4f1ab7752d --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZAxioms.v @@ -0,0 +1,124 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Export NZAxioms. +Require Import Bool NZParity NZPow NZSqrt NZLog NZGcd NZDiv NZBits. + +(** We obtain integers by postulating that successor of predecessor + is identity. *) + +Module Type ZAxiom (Import Z : NZAxiomsSig'). + Axiom succ_pred : forall n, S (P n) == n. +End ZAxiom. + +(** For historical reasons, ZAxiomsMiniSig isn't just NZ + ZAxiom, + we also add an [opp] function, that can be seen as a shortcut + for [sub 0]. *) + +Module Type Opp (Import T:Typ). + Parameter Inline opp : t -> t. +End Opp. + +Module Type OppNotation (T:Typ)(Import O : Opp T). + Notation "- x" := (opp x) (at level 35, right associativity). +End OppNotation. + +Module Type Opp' (T:Typ) := Opp T <+ OppNotation T. + +Module Type IsOpp (Import Z : NZAxiomsSig')(Import O : Opp' Z). + Declare Instance opp_wd : Proper (eq==>eq) opp. + Axiom opp_0 : - 0 == 0. + Axiom opp_succ : forall n, - (S n) == P (- n). +End IsOpp. + +Module Type OppCstNotation (Import A : NZAxiomsSig)(Import B : Opp A). + Notation "- 1" := (opp one). + Notation "- 2" := (opp two). +End OppCstNotation. + +Module Type ZAxiomsMiniSig := NZOrdAxiomsSig <+ ZAxiom <+ Opp <+ IsOpp. +Module Type ZAxiomsMiniSig' := NZOrdAxiomsSig' <+ ZAxiom <+ Opp' <+ IsOpp + <+ OppCstNotation. + + +(** Other functions and their specifications *) + +(** Absolute value *) + +Module Type HasAbs(Import Z : ZAxiomsMiniSig'). + Parameter Inline abs : t -> t. + Axiom abs_eq : forall n, 0<=n -> abs n == n. + Axiom abs_neq : forall n, n<=0 -> abs n == -n. +End HasAbs. + +(** A sign function *) + +Module Type HasSgn (Import Z : ZAxiomsMiniSig'). + Parameter Inline sgn : t -> t. + Axiom sgn_null : forall n, n==0 -> sgn n == 0. + Axiom sgn_pos : forall n, 0<n -> sgn n == 1. + Axiom sgn_neg : forall n, n<0 -> sgn n == -1. +End HasSgn. + +(** Divisions *) + +(** First, the usual Coq convention of Truncated-Toward-Bottom + (a.k.a Floor). We simply extend the NZ signature. *) + +Module Type ZDivSpecific (Import A:ZAxiomsMiniSig')(Import B : DivMod' A). + Axiom mod_pos_bound : forall a b, 0 < b -> 0 <= a mod b < b. + Axiom mod_neg_bound : forall a b, b < 0 -> b < a mod b <= 0. +End ZDivSpecific. + +Module Type ZDiv (Z:ZAxiomsMiniSig) := NZDiv.NZDiv Z <+ ZDivSpecific Z. +Module Type ZDiv' (Z:ZAxiomsMiniSig) := NZDiv.NZDiv' Z <+ ZDivSpecific Z. + +(** Then, the Truncated-Toward-Zero convention. + For not colliding with Floor operations, we use different names +*) + +Module Type QuotRem (Import A : Typ). + Parameters Inline quot rem : t -> t -> t. +End QuotRem. + +Module Type QuotRemNotation (A : Typ)(Import B : QuotRem A). + Infix "÷" := quot (at level 40, left associativity). + Infix "rem" := rem (at level 40, no associativity). +End QuotRemNotation. + +Module Type QuotRem' (A : Typ) := QuotRem A <+ QuotRemNotation A. + +Module Type QuotRemSpec (Import A : ZAxiomsMiniSig')(Import B : QuotRem' A). + Declare Instance quot_wd : Proper (eq==>eq==>eq) quot. + Declare Instance rem_wd : Proper (eq==>eq==>eq) B.rem. + Axiom quot_rem : forall a b, b ~= 0 -> a == b*(a÷b) + (a rem b). + Axiom rem_bound_pos : forall a b, 0<=a -> 0<b -> 0 <= a rem b < b. + Axiom rem_opp_l : forall a b, b ~= 0 -> (-a) rem b == - (a rem b). + Axiom rem_opp_r : forall a b, b ~= 0 -> a rem (-b) == a rem b. +End QuotRemSpec. + +Module Type ZQuot (Z:ZAxiomsMiniSig) := QuotRem Z <+ QuotRemSpec Z. +Module Type ZQuot' (Z:ZAxiomsMiniSig) := QuotRem' Z <+ QuotRemSpec Z. + +(** For all other functions, the NZ axiomatizations are enough. *) + +(** Let's group everything *) + +Module Type ZAxiomsSig := ZAxiomsMiniSig <+ OrderFunctions + <+ HasAbs <+ HasSgn <+ NZParity.NZParity + <+ NZPow.NZPow <+ NZSqrt.NZSqrt <+ NZLog.NZLog2 <+ NZGcd.NZGcd + <+ ZDiv <+ ZQuot <+ NZBits.NZBits <+ NZSquare. + +Module Type ZAxiomsSig' := ZAxiomsMiniSig' <+ OrderFunctions' + <+ HasAbs <+ HasSgn <+ NZParity.NZParity + <+ NZPow.NZPow' <+ NZSqrt.NZSqrt' <+ NZLog.NZLog2 <+ NZGcd.NZGcd' + <+ ZDiv' <+ ZQuot' <+ NZBits.NZBits' <+ NZSquare. diff --git a/theories/Numbers/Integer/Abstract/ZBase.v b/theories/Numbers/Integer/Abstract/ZBase.v new file mode 100644 index 0000000000..7fdd018d33 --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZBase.v @@ -0,0 +1,38 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Export Decidable. +Require Export ZAxioms. +Require Import NZProperties. + +Module ZBaseProp (Import Z : ZAxiomsMiniSig'). +Include NZProp Z. + +(* Theorems that are true for integers but not for natural numbers *) + +Theorem pred_inj : forall n m, P n == P m -> n == m. +Proof. +intros n m H. apply succ_wd in H. now rewrite 2 succ_pred in H. +Qed. + +Theorem pred_inj_wd : forall n1 n2, P n1 == P n2 <-> n1 == n2. +Proof. +intros n1 n2; split; [apply pred_inj | intros; now f_equiv]. +Qed. + +Lemma succ_m1 : S (-1) == 0. +Proof. + now rewrite one_succ, opp_succ, opp_0, succ_pred. +Qed. + +End ZBaseProp. + diff --git a/theories/Numbers/Integer/Abstract/ZBits.v b/theories/Numbers/Integer/Abstract/ZBits.v new file mode 100644 index 0000000000..4aabda77ee --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZBits.v @@ -0,0 +1,1949 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import + Bool ZAxioms ZMulOrder ZPow ZDivFloor ZSgnAbs ZParity NZLog. + +(** Derived properties of bitwise operations *) + +Module Type ZBitsProp + (Import A : ZAxiomsSig') + (Import B : ZMulOrderProp A) + (Import C : ZParityProp A B) + (Import D : ZSgnAbsProp A B) + (Import E : ZPowProp A B C D) + (Import F : ZDivProp A B D) + (Import G : NZLog2Prop A A A B E). + +Include BoolEqualityFacts A. + +Ltac order_nz := try apply pow_nonzero; order'. +Ltac order_pos' := try apply abs_nonneg; order_pos. +Hint Rewrite div_0_l mod_0_l div_1_r mod_1_r : nz. + +(** Some properties of power and division *) + +Lemma pow_sub_r : forall a b c, a~=0 -> 0<=c<=b -> a^(b-c) == a^b / a^c. +Proof. + intros a b c Ha (H,H'). rewrite <- (sub_simpl_r b c) at 2. + rewrite pow_add_r; trivial. + rewrite div_mul. reflexivity. + now apply pow_nonzero. + now apply le_0_sub. +Qed. + +Lemma pow_div_l : forall a b c, b~=0 -> 0<=c -> a mod b == 0 -> + (a/b)^c == a^c / b^c. +Proof. + intros a b c Hb Hc H. rewrite (div_mod a b Hb) at 2. + rewrite H, add_0_r, pow_mul_l, mul_comm, div_mul. reflexivity. + now apply pow_nonzero. +Qed. + +(** An injection from bits [true] and [false] to numbers 1 and 0. + We declare it as a (local) coercion for shorter statements. *) + +Definition b2z (b:bool) := if b then 1 else 0. +Local Coercion b2z : bool >-> t. + +Instance b2z_wd : Proper (Logic.eq ==> eq) b2z := _. + +Lemma exists_div2 a : exists a' (b:bool), a == 2*a' + b. +Proof. + elim (Even_or_Odd a); [intros (a',H)| intros (a',H)]. + exists a'. exists false. now nzsimpl. + exists a'. exists true. now simpl. +Qed. + +(** We can compact [testbit_odd_0] [testbit_even_0] + [testbit_even_succ] [testbit_odd_succ] in only two lemmas. *) + +Lemma testbit_0_r a (b:bool) : testbit (2*a+b) 0 = b. +Proof. + destruct b; simpl; rewrite ?add_0_r. + apply testbit_odd_0. + apply testbit_even_0. +Qed. + +Lemma testbit_succ_r a (b:bool) n : 0<=n -> + testbit (2*a+b) (succ n) = testbit a n. +Proof. + destruct b; simpl; rewrite ?add_0_r. + now apply testbit_odd_succ. + now apply testbit_even_succ. +Qed. + +(** Alternative characterisations of [testbit] *) + +(** This concise equation could have been taken as specification + for testbit in the interface, but it would have been hard to + implement with little initial knowledge about div and mod *) + +Lemma testbit_spec' a n : 0<=n -> a.[n] == (a / 2^n) mod 2. +Proof. + intro Hn. revert a. apply le_ind with (4:=Hn). + solve_proper. + intros a. nzsimpl. + destruct (exists_div2 a) as (a' & b & H). rewrite H at 1. + rewrite testbit_0_r. apply mod_unique with a'; trivial. + left. destruct b; split; simpl; order'. + clear n Hn. intros n Hn IH a. + destruct (exists_div2 a) as (a' & b & H). rewrite H at 1. + rewrite testbit_succ_r, IH by trivial. f_equiv. + rewrite pow_succ_r, <- div_div by order_pos. f_equiv. + apply div_unique with b; trivial. + left. destruct b; split; simpl; order'. +Qed. + +(** This characterisation that uses only basic operations and + power was initially taken as specification for testbit. + We describe [a] as having a low part and a high part, with + the corresponding bit in the middle. This characterisation + is moderatly complex to implement, but also moderately + usable... *) + +Lemma testbit_spec a n : 0<=n -> + exists l h, 0<=l<2^n /\ a == l + (a.[n] + 2*h)*2^n. +Proof. + intro Hn. exists (a mod 2^n). exists (a / 2^n / 2). split. + apply mod_pos_bound; order_pos. + rewrite add_comm, mul_comm, (add_comm a.[n]). + rewrite (div_mod a (2^n)) at 1 by order_nz. do 2 f_equiv. + rewrite testbit_spec' by trivial. apply div_mod. order'. +Qed. + +Lemma testbit_true : forall a n, 0<=n -> + (a.[n] = true <-> (a / 2^n) mod 2 == 1). +Proof. + intros a n Hn. + rewrite <- testbit_spec' by trivial. + destruct a.[n]; split; simpl; now try order'. +Qed. + +Lemma testbit_false : forall a n, 0<=n -> + (a.[n] = false <-> (a / 2^n) mod 2 == 0). +Proof. + intros a n Hn. + rewrite <- testbit_spec' by trivial. + destruct a.[n]; split; simpl; now try order'. +Qed. + +Lemma testbit_eqb : forall a n, 0<=n -> + a.[n] = eqb ((a / 2^n) mod 2) 1. +Proof. + intros a n Hn. + apply eq_true_iff_eq. now rewrite testbit_true, eqb_eq. +Qed. + +(** Results about the injection [b2z] *) + +Lemma b2z_inj : forall (a0 b0:bool), a0 == b0 -> a0 = b0. +Proof. + intros [|] [|]; simpl; trivial; order'. +Qed. + +Lemma add_b2z_double_div2 : forall (a0:bool) a, (a0+2*a)/2 == a. +Proof. + intros a0 a. rewrite mul_comm, div_add by order'. + now rewrite div_small, add_0_l by (destruct a0; split; simpl; order'). +Qed. + +Lemma add_b2z_double_bit0 : forall (a0:bool) a, (a0+2*a).[0] = a0. +Proof. + intros a0 a. apply b2z_inj. + rewrite testbit_spec' by order. + nzsimpl. rewrite mul_comm, mod_add by order'. + now rewrite mod_small by (destruct a0; split; simpl; order'). +Qed. + +Lemma b2z_div2 : forall (a0:bool), a0/2 == 0. +Proof. + intros a0. rewrite <- (add_b2z_double_div2 a0 0). now nzsimpl. +Qed. + +Lemma b2z_bit0 : forall (a0:bool), a0.[0] = a0. +Proof. + intros a0. rewrite <- (add_b2z_double_bit0 a0 0) at 2. now nzsimpl. +Qed. + +(** The specification of testbit by low and high parts is complete *) + +Lemma testbit_unique : forall a n (a0:bool) l h, + 0<=l<2^n -> a == l + (a0 + 2*h)*2^n -> a.[n] = a0. +Proof. + intros a n a0 l h Hl EQ. + assert (0<=n). + destruct (le_gt_cases 0 n) as [Hn|Hn]; trivial. + rewrite pow_neg_r in Hl by trivial. destruct Hl; order. + apply b2z_inj. rewrite testbit_spec' by trivial. + symmetry. apply mod_unique with h. + left; destruct a0; simpl; split; order'. + symmetry. apply div_unique with l. + now left. + now rewrite add_comm, (add_comm _ a0), mul_comm. +Qed. + +(** All bits of number 0 are 0 *) + +Lemma bits_0 : forall n, 0.[n] = false. +Proof. + intros n. + destruct (le_gt_cases 0 n). + apply testbit_false; trivial. nzsimpl; order_nz. + now apply testbit_neg_r. +Qed. + +(** For negative numbers, we are actually doing two's complement *) + +Lemma bits_opp : forall a n, 0<=n -> (-a).[n] = negb (P a).[n]. +Proof. + intros a n Hn. + destruct (testbit_spec (-a) n Hn) as (l & h & Hl & EQ). + fold (b2z (-a).[n]) in EQ. + apply negb_sym. + apply testbit_unique with (2^n-l-1) (-h-1). + split. + apply lt_succ_r. rewrite sub_1_r, succ_pred. now apply lt_0_sub. + apply le_succ_l. rewrite sub_1_r, succ_pred. apply le_sub_le_add_r. + rewrite <- (add_0_r (2^n)) at 1. now apply add_le_mono_l. + rewrite <- add_sub_swap, sub_1_r. f_equiv. + apply opp_inj. rewrite opp_add_distr, opp_sub_distr. + rewrite (add_comm _ l), <- add_assoc. + rewrite EQ at 1. apply add_cancel_l. + rewrite <- opp_add_distr. + rewrite <- (mul_1_l (2^n)) at 2. rewrite <- mul_add_distr_r. + rewrite <- mul_opp_l. + f_equiv. + rewrite !opp_add_distr. + rewrite <- mul_opp_r. + rewrite opp_sub_distr, opp_involutive. + rewrite (add_comm h). + rewrite mul_add_distr_l. + rewrite !add_assoc. + apply add_cancel_r. + rewrite mul_1_r. + rewrite add_comm, add_assoc, !add_opp_r, sub_1_r, two_succ, pred_succ. + destruct (-a).[n]; simpl. now rewrite sub_0_r. now nzsimpl'. +Qed. + +(** All bits of number (-1) are 1 *) + +Lemma bits_m1 : forall n, 0<=n -> (-1).[n] = true. +Proof. + intros. now rewrite bits_opp, one_succ, pred_succ, bits_0. +Qed. + +(** Various ways to refer to the lowest bit of a number *) + +Lemma bit0_odd : forall a, a.[0] = odd a. +Proof. + intros. symmetry. + destruct (exists_div2 a) as (a' & b & EQ). + rewrite EQ, testbit_0_r, add_comm, odd_add_mul_2. + destruct b; simpl; apply odd_1 || apply odd_0. +Qed. + +Lemma bit0_eqb : forall a, a.[0] = eqb (a mod 2) 1. +Proof. + intros a. rewrite testbit_eqb by order. now nzsimpl. +Qed. + +Lemma bit0_mod : forall a, a.[0] == a mod 2. +Proof. + intros a. rewrite testbit_spec' by order. now nzsimpl. +Qed. + +(** Hence testing a bit is equivalent to shifting and testing parity *) + +Lemma testbit_odd : forall a n, a.[n] = odd (a>>n). +Proof. + intros. now rewrite <- bit0_odd, shiftr_spec, add_0_l. +Qed. + +(** [log2] gives the highest nonzero bit of positive numbers *) + +Lemma bit_log2 : forall a, 0<a -> a.[log2 a] = true. +Proof. + intros a Ha. + assert (Ha' := log2_nonneg a). + destruct (log2_spec_alt a Ha) as (r & EQ & Hr). + rewrite EQ at 1. + rewrite testbit_true, add_comm by trivial. + rewrite <- (mul_1_l (2^log2 a)) at 1. + rewrite div_add by order_nz. + rewrite div_small; trivial. + rewrite add_0_l. apply mod_small. split; order'. +Qed. + +Lemma bits_above_log2 : forall a n, 0<=a -> log2 a < n -> + a.[n] = false. +Proof. + intros a n Ha H. + assert (Hn : 0<=n). + transitivity (log2 a). apply log2_nonneg. order'. + rewrite testbit_false by trivial. + rewrite div_small. nzsimpl; order'. + split. order. apply log2_lt_cancel. now rewrite log2_pow2. +Qed. + +(** Hence the number of bits of [a] is [1+log2 a] + (see [Pos.size_nat] and [Pos.size]). +*) + +(** For negative numbers, things are the other ways around: + log2 gives the highest zero bit (for numbers below -1). +*) + +Lemma bit_log2_neg : forall a, a < -1 -> a.[log2 (P (-a))] = false. +Proof. + intros a Ha. + rewrite <- (opp_involutive a) at 1. + rewrite bits_opp. + apply negb_false_iff. + apply bit_log2. + apply opp_lt_mono in Ha. rewrite opp_involutive in Ha. + apply lt_succ_lt_pred. now rewrite <- one_succ. + apply log2_nonneg. +Qed. + +Lemma bits_above_log2_neg : forall a n, a < 0 -> log2 (P (-a)) < n -> + a.[n] = true. +Proof. + intros a n Ha H. + assert (Hn : 0<=n). + transitivity (log2 (P (-a))). apply log2_nonneg. order'. + rewrite <- (opp_involutive a), bits_opp, negb_true_iff by trivial. + apply bits_above_log2; trivial. + now rewrite <- opp_succ, opp_nonneg_nonpos, le_succ_l. +Qed. + +(** Accesing a high enough bit of a number gives its sign *) + +Lemma bits_iff_nonneg : forall a n, log2 (abs a) < n -> + (0<=a <-> a.[n] = false). +Proof. + intros a n Hn. split; intros H. + rewrite abs_eq in Hn; trivial. now apply bits_above_log2. + destruct (le_gt_cases 0 a); trivial. + rewrite abs_neq in Hn by order. + rewrite bits_above_log2_neg in H; try easy. + apply le_lt_trans with (log2 (-a)); trivial. + apply log2_le_mono. apply le_pred_l. +Qed. + +Lemma bits_iff_nonneg' : forall a, + 0<=a <-> a.[S (log2 (abs a))] = false. +Proof. + intros. apply bits_iff_nonneg. apply lt_succ_diag_r. +Qed. + +Lemma bits_iff_nonneg_ex : forall a, + 0<=a <-> (exists k, forall m, k<m -> a.[m] = false). +Proof. + intros a. split. + intros Ha. exists (log2 a). intros m Hm. now apply bits_above_log2. + intros (k,Hk). destruct (le_gt_cases k (log2 (abs a))). + now apply bits_iff_nonneg', Hk, lt_succ_r. + apply (bits_iff_nonneg a (S k)). + now apply lt_succ_r, lt_le_incl. + apply Hk. apply lt_succ_diag_r. +Qed. + +Lemma bits_iff_neg : forall a n, log2 (abs a) < n -> + (a<0 <-> a.[n] = true). +Proof. + intros a n Hn. + now rewrite lt_nge, <- not_false_iff_true, (bits_iff_nonneg a n). +Qed. + +Lemma bits_iff_neg' : forall a, a<0 <-> a.[S (log2 (abs a))] = true. +Proof. + intros. apply bits_iff_neg. apply lt_succ_diag_r. +Qed. + +Lemma bits_iff_neg_ex : forall a, + a<0 <-> (exists k, forall m, k<m -> a.[m] = true). +Proof. + intros a. split. + intros Ha. exists (log2 (P (-a))). intros m Hm. now apply bits_above_log2_neg. + intros (k,Hk). destruct (le_gt_cases k (log2 (abs a))). + now apply bits_iff_neg', Hk, lt_succ_r. + apply (bits_iff_neg a (S k)). + now apply lt_succ_r, lt_le_incl. + apply Hk. apply lt_succ_diag_r. +Qed. + +(** Testing bits after division or multiplication by a power of two *) + +Lemma div2_bits : forall a n, 0<=n -> (a/2).[n] = a.[S n]. +Proof. + intros a n Hn. + apply eq_true_iff_eq. rewrite 2 testbit_true by order_pos. + rewrite pow_succ_r by trivial. + now rewrite div_div by order_pos. +Qed. + +Lemma div_pow2_bits : forall a n m, 0<=n -> 0<=m -> (a/2^n).[m] = a.[m+n]. +Proof. + intros a n m Hn. revert a m. apply le_ind with (4:=Hn). + solve_proper. + intros a m Hm. now nzsimpl. + clear n Hn. intros n Hn IH a m Hm. nzsimpl; trivial. + rewrite <- div_div by order_pos. + now rewrite IH, div2_bits by order_pos. +Qed. + +Lemma double_bits_succ : forall a n, (2*a).[S n] = a.[n]. +Proof. + intros a n. + destruct (le_gt_cases 0 n) as [Hn|Hn]. + now rewrite <- div2_bits, mul_comm, div_mul by order'. + rewrite (testbit_neg_r a n Hn). + apply le_succ_l in Hn. le_elim Hn. + now rewrite testbit_neg_r. + now rewrite Hn, bit0_odd, odd_mul, odd_2. +Qed. + +Lemma double_bits : forall a n, (2*a).[n] = a.[P n]. +Proof. + intros a n. rewrite <- (succ_pred n) at 1. apply double_bits_succ. +Qed. + +Lemma mul_pow2_bits_add : forall a n m, 0<=n -> (a*2^n).[n+m] = a.[m]. +Proof. + intros a n m Hn. revert a m. apply le_ind with (4:=Hn). + solve_proper. + intros a m. now nzsimpl. + clear n Hn. intros n Hn IH a m. nzsimpl; trivial. + rewrite mul_assoc, (mul_comm _ 2), <- mul_assoc. + now rewrite double_bits_succ. +Qed. + +Lemma mul_pow2_bits : forall a n m, 0<=n -> (a*2^n).[m] = a.[m-n]. +Proof. + intros. + rewrite <- (add_simpl_r m n) at 1. rewrite add_sub_swap, add_comm. + now apply mul_pow2_bits_add. +Qed. + +Lemma mul_pow2_bits_low : forall a n m, m<n -> (a*2^n).[m] = false. +Proof. + intros. + destruct (le_gt_cases 0 n). + rewrite mul_pow2_bits by trivial. + apply testbit_neg_r. now apply lt_sub_0. + now rewrite pow_neg_r, mul_0_r, bits_0. +Qed. + +(** Selecting the low part of a number can be done by a modulo *) + +Lemma mod_pow2_bits_high : forall a n m, 0<=n<=m -> + (a mod 2^n).[m] = false. +Proof. + intros a n m (Hn,H). + destruct (mod_pos_bound a (2^n)) as [LE LT]. order_pos. + le_elim LE. + apply bits_above_log2; try order. + apply lt_le_trans with n; trivial. + apply log2_lt_pow2; trivial. + now rewrite <- LE, bits_0. +Qed. + +Lemma mod_pow2_bits_low : forall a n m, m<n -> + (a mod 2^n).[m] = a.[m]. +Proof. + intros a n m H. + destruct (le_gt_cases 0 m) as [Hm|Hm]; [|now rewrite !testbit_neg_r]. + rewrite testbit_eqb; trivial. + rewrite <- (mod_add _ (2^(P (n-m))*(a/2^n))) by order'. + rewrite <- div_add by order_nz. + rewrite (mul_comm _ 2), mul_assoc, <- pow_succ_r, succ_pred. + rewrite mul_comm, mul_assoc, <- pow_add_r, (add_comm m), sub_add; trivial. + rewrite add_comm, <- div_mod by order_nz. + symmetry. apply testbit_eqb; trivial. + apply le_0_sub; order. + now apply lt_le_pred, lt_0_sub. +Qed. + +(** We now prove that having the same bits implies equality. + For that we use a notion of equality over functional + streams of bits. *) + +Definition eqf (f g:t -> bool) := forall n:t, f n = g n. + +Instance eqf_equiv : Equivalence eqf. +Proof. + split; congruence. +Qed. + +Local Infix "===" := eqf (at level 70, no associativity). + +Instance testbit_eqf : Proper (eq==>eqf) testbit. +Proof. + intros a a' Ha n. now rewrite Ha. +Qed. + +(** Only zero corresponds to the always-false stream. *) + +Lemma bits_inj_0 : + forall a, (forall n, a.[n] = false) -> a == 0. +Proof. + intros a H. destruct (lt_trichotomy a 0) as [Ha|[Ha|Ha]]; trivial. + apply (bits_above_log2_neg a (S (log2 (P (-a))))) in Ha. + now rewrite H in Ha. + apply lt_succ_diag_r. + apply bit_log2 in Ha. now rewrite H in Ha. +Qed. + +(** If two numbers produce the same stream of bits, they are equal. *) + +Lemma bits_inj : forall a b, testbit a === testbit b -> a == b. +Proof. + assert (AUX : forall n, 0<=n -> forall a b, + 0<=a<2^n -> testbit a === testbit b -> a == b). + intros n Hn. apply le_ind with (4:=Hn). + solve_proper. + intros a b Ha H. rewrite pow_0_r, one_succ, lt_succ_r in Ha. + assert (Ha' : a == 0) by (destruct Ha; order). + rewrite Ha' in *. + symmetry. apply bits_inj_0. + intros m. now rewrite <- H, bits_0. + clear n Hn. intros n Hn IH a b (Ha,Ha') H. + rewrite (div_mod a 2), (div_mod b 2) by order'. + f_equiv; [ | now rewrite <- 2 bit0_mod, H]. + f_equiv. + apply IH. + split. apply div_pos; order'. + apply div_lt_upper_bound. order'. now rewrite <- pow_succ_r. + intros m. + destruct (le_gt_cases 0 m). + rewrite 2 div2_bits by trivial. apply H. + now rewrite 2 testbit_neg_r. + intros a b H. + destruct (le_gt_cases 0 a) as [Ha|Ha]. + apply (AUX a); trivial. split; trivial. + apply pow_gt_lin_r; order'. + apply succ_inj, opp_inj. + assert (0 <= - S a). + apply opp_le_mono. now rewrite opp_involutive, opp_0, le_succ_l. + apply (AUX (-(S a))); trivial. split; trivial. + apply pow_gt_lin_r; order'. + intros m. destruct (le_gt_cases 0 m). + now rewrite 2 bits_opp, 2 pred_succ, H. + now rewrite 2 testbit_neg_r. +Qed. + +Lemma bits_inj_iff : forall a b, testbit a === testbit b <-> a == b. +Proof. + split. apply bits_inj. intros EQ; now rewrite EQ. +Qed. + +(** In fact, checking the bits at positive indexes is enough. *) + +Lemma bits_inj' : forall a b, + (forall n, 0<=n -> a.[n] = b.[n]) -> a == b. +Proof. + intros a b H. apply bits_inj. + intros n. destruct (le_gt_cases 0 n). + now apply H. + now rewrite 2 testbit_neg_r. +Qed. + +Lemma bits_inj_iff' : forall a b, (forall n, 0<=n -> a.[n] = b.[n]) <-> a == b. +Proof. + split. apply bits_inj'. intros EQ n Hn; now rewrite EQ. +Qed. + +Ltac bitwise := apply bits_inj'; intros ?m ?Hm; autorewrite with bitwise. + +Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise. + +(** The streams of bits that correspond to a numbers are + exactly the ones which are stationary after some point. *) + +Lemma are_bits : forall (f:t->bool), Proper (eq==>Logic.eq) f -> + ((exists n, forall m, 0<=m -> f m = n.[m]) <-> + (exists k, forall m, k<=m -> f m = f k)). +Proof. + intros f Hf. split. + intros (a,H). + destruct (le_gt_cases 0 a). + exists (S (log2 a)). intros m Hm. apply le_succ_l in Hm. + rewrite 2 H, 2 bits_above_log2; trivial using lt_succ_diag_r. + order_pos. apply le_trans with (log2 a); order_pos. + exists (S (log2 (P (-a)))). intros m Hm. apply le_succ_l in Hm. + rewrite 2 H, 2 bits_above_log2_neg; trivial using lt_succ_diag_r. + order_pos. apply le_trans with (log2 (P (-a))); order_pos. + intros (k,Hk). + destruct (lt_ge_cases k 0) as [LT|LE]. + case_eq (f 0); intros H0. + exists (-1). intros m Hm. rewrite bits_m1, Hk by order. + symmetry; rewrite <- H0. apply Hk; order. + exists 0. intros m Hm. rewrite bits_0, Hk by order. + symmetry; rewrite <- H0. apply Hk; order. + revert f Hf Hk. apply le_ind with (4:=LE). + (* compat : solve_proper fails here *) + apply proper_sym_impl_iff. exact eq_sym. + clear k LE. intros k k' Hk IH f Hf H. apply IH; trivial. + now setoid_rewrite Hk. + (* /compat *) + intros f Hf H0. destruct (f 0). + exists (-1). intros m Hm. now rewrite bits_m1, H0. + exists 0. intros m Hm. now rewrite bits_0, H0. + clear k LE. intros k LE IH f Hf Hk. + destruct (IH (fun m => f (S m))) as (n, Hn). + solve_proper. + intros m Hm. apply Hk. now rewrite <- succ_le_mono. + exists (f 0 + 2*n). intros m Hm. + le_elim Hm. + rewrite <- (succ_pred m), Hn, <- div2_bits. + rewrite mul_comm, div_add, b2z_div2, add_0_l; trivial. order'. + now rewrite <- lt_succ_r, succ_pred. + now rewrite <- lt_succ_r, succ_pred. + rewrite <- Hm. + symmetry. apply add_b2z_double_bit0. +Qed. + +(** * Properties of shifts *) + +(** First, a unified specification for [shiftl] : the [shiftl_spec] + below (combined with [testbit_neg_r]) is equivalent to + [shiftl_spec_low] and [shiftl_spec_high]. *) + +Lemma shiftl_spec : forall a n m, 0<=m -> (a << n).[m] = a.[m-n]. +Proof. + intros. + destruct (le_gt_cases n m). + now apply shiftl_spec_high. + rewrite shiftl_spec_low, testbit_neg_r; trivial. now apply lt_sub_0. +Qed. + +(** A shiftl by a negative number is a shiftr, and vice-versa *) + +Lemma shiftr_opp_r : forall a n, a >> (-n) == a << n. +Proof. + intros. bitwise. now rewrite shiftr_spec, shiftl_spec, add_opp_r. +Qed. + +Lemma shiftl_opp_r : forall a n, a << (-n) == a >> n. +Proof. + intros. bitwise. now rewrite shiftr_spec, shiftl_spec, sub_opp_r. +Qed. + +(** Shifts correspond to multiplication or division by a power of two *) + +Lemma shiftr_div_pow2 : forall a n, 0<=n -> a >> n == a / 2^n. +Proof. + intros. bitwise. now rewrite shiftr_spec, div_pow2_bits. +Qed. + +Lemma shiftr_mul_pow2 : forall a n, n<=0 -> a >> n == a * 2^(-n). +Proof. + intros. bitwise. rewrite shiftr_spec, mul_pow2_bits; trivial. + now rewrite sub_opp_r. + now apply opp_nonneg_nonpos. +Qed. + +Lemma shiftl_mul_pow2 : forall a n, 0<=n -> a << n == a * 2^n. +Proof. + intros. bitwise. now rewrite shiftl_spec, mul_pow2_bits. +Qed. + +Lemma shiftl_div_pow2 : forall a n, n<=0 -> a << n == a / 2^(-n). +Proof. + intros. bitwise. rewrite shiftl_spec, div_pow2_bits; trivial. + now rewrite add_opp_r. + now apply opp_nonneg_nonpos. +Qed. + +(** Shifts are morphisms *) + +Instance shiftr_wd : Proper (eq==>eq==>eq) shiftr. +Proof. + intros a a' Ha n n' Hn. + destruct (le_ge_cases n 0) as [H|H]; assert (H':=H); rewrite Hn in H'. + now rewrite 2 shiftr_mul_pow2, Ha, Hn. + now rewrite 2 shiftr_div_pow2, Ha, Hn. +Qed. + +Instance shiftl_wd : Proper (eq==>eq==>eq) shiftl. +Proof. + intros a a' Ha n n' Hn. now rewrite <- 2 shiftr_opp_r, Ha, Hn. +Qed. + +(** We could also have specified shiftl with an addition on the left. *) + +Lemma shiftl_spec_alt : forall a n m, 0<=n -> (a << n).[m+n] = a.[m]. +Proof. + intros. now rewrite shiftl_mul_pow2, mul_pow2_bits, add_simpl_r. +Qed. + +(** Chaining several shifts. The only case for which + there isn't any simple expression is a true shiftr + followed by a true shiftl. +*) + +Lemma shiftl_shiftl : forall a n m, 0<=n -> + (a << n) << m == a << (n+m). +Proof. + intros a n p Hn. bitwise. + rewrite 2 (shiftl_spec _ _ m) by trivial. + rewrite add_comm, sub_add_distr. + destruct (le_gt_cases 0 (m-p)) as [H|H]. + now rewrite shiftl_spec. + rewrite 2 testbit_neg_r; trivial. + apply lt_sub_0. now apply lt_le_trans with 0. +Qed. + +Lemma shiftr_shiftl_l : forall a n m, 0<=n -> + (a << n) >> m == a << (n-m). +Proof. + intros. now rewrite <- shiftl_opp_r, shiftl_shiftl, add_opp_r. +Qed. + +Lemma shiftr_shiftl_r : forall a n m, 0<=n -> + (a << n) >> m == a >> (m-n). +Proof. + intros. now rewrite <- 2 shiftl_opp_r, shiftl_shiftl, opp_sub_distr, add_comm. +Qed. + +Lemma shiftr_shiftr : forall a n m, 0<=m -> + (a >> n) >> m == a >> (n+m). +Proof. + intros a n p Hn. bitwise. + rewrite 3 shiftr_spec; trivial. + now rewrite (add_comm n p), add_assoc. + now apply add_nonneg_nonneg. +Qed. + +(** shifts and constants *) + +Lemma shiftl_1_l : forall n, 1 << n == 2^n. +Proof. + intros n. destruct (le_gt_cases 0 n). + now rewrite shiftl_mul_pow2, mul_1_l. + rewrite shiftl_div_pow2, div_1_l, pow_neg_r; try order. + apply pow_gt_1. order'. now apply opp_pos_neg. +Qed. + +Lemma shiftl_0_r : forall a, a << 0 == a. +Proof. + intros. rewrite shiftl_mul_pow2 by order. now nzsimpl. +Qed. + +Lemma shiftr_0_r : forall a, a >> 0 == a. +Proof. + intros. now rewrite <- shiftl_opp_r, opp_0, shiftl_0_r. +Qed. + +Lemma shiftl_0_l : forall n, 0 << n == 0. +Proof. + intros. + destruct (le_ge_cases 0 n). + rewrite shiftl_mul_pow2 by trivial. now nzsimpl. + rewrite shiftl_div_pow2 by trivial. + rewrite <- opp_nonneg_nonpos in H. nzsimpl; order_nz. +Qed. + +Lemma shiftr_0_l : forall n, 0 >> n == 0. +Proof. + intros. now rewrite <- shiftl_opp_r, shiftl_0_l. +Qed. + +Lemma shiftl_eq_0_iff : forall a n, 0<=n -> (a << n == 0 <-> a == 0). +Proof. + intros a n Hn. + rewrite shiftl_mul_pow2 by trivial. rewrite eq_mul_0. split. + intros [H | H]; trivial. contradict H; order_nz. + intros H. now left. +Qed. + +Lemma shiftr_eq_0_iff : forall a n, + a >> n == 0 <-> a==0 \/ (0<a /\ log2 a < n). +Proof. + intros a n. + destruct (le_gt_cases 0 n) as [Hn|Hn]. + rewrite shiftr_div_pow2, div_small_iff by order_nz. + destruct (lt_trichotomy a 0) as [LT|[EQ|LT]]. + split. + intros [(H,_)|(H,H')]. order. generalize (pow_nonneg 2 n le_0_2); order. + intros [H|(H,H')]; order. + rewrite EQ. split. now left. intros _; left. split; order_pos. + split. intros [(H,H')|(H,H')]; right. split; trivial. + apply log2_lt_pow2; trivial. + generalize (pow_nonneg 2 n le_0_2); order. + intros [H|(H,H')]. order. left. + split. order. now apply log2_lt_pow2. + rewrite shiftr_mul_pow2 by order. rewrite eq_mul_0. + split; intros [H|H]. + now left. + elim (pow_nonzero 2 (-n)); try apply opp_nonneg_nonpos; order'. + now left. + destruct H. generalize (log2_nonneg a); order. +Qed. + +Lemma shiftr_eq_0 : forall a n, 0<=a -> log2 a < n -> a >> n == 0. +Proof. + intros a n Ha H. apply shiftr_eq_0_iff. + le_elim Ha. right. now split. now left. +Qed. + +(** Properties of [div2]. *) + +Lemma div2_div : forall a, div2 a == a/2. +Proof. + intros. rewrite div2_spec, shiftr_div_pow2. now nzsimpl. order'. +Qed. + +Instance div2_wd : Proper (eq==>eq) div2. +Proof. + intros a a' Ha. now rewrite 2 div2_div, Ha. +Qed. + +Lemma div2_odd : forall a, a == 2*(div2 a) + odd a. +Proof. + intros a. rewrite div2_div, <- bit0_odd, bit0_mod. + apply div_mod. order'. +Qed. + +(** Properties of [lxor] and others, directly deduced + from properties of [xorb] and others. *) + +Instance lxor_wd : Proper (eq ==> eq ==> eq) lxor. +Proof. + intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. +Qed. + +Instance land_wd : Proper (eq ==> eq ==> eq) land. +Proof. + intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. +Qed. + +Instance lor_wd : Proper (eq ==> eq ==> eq) lor. +Proof. + intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. +Qed. + +Instance ldiff_wd : Proper (eq ==> eq ==> eq) ldiff. +Proof. + intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. +Qed. + +Lemma lxor_eq : forall a a', lxor a a' == 0 -> a == a'. +Proof. + intros a a' H. bitwise. apply xorb_eq. + now rewrite <- lxor_spec, H, bits_0. +Qed. + +Lemma lxor_nilpotent : forall a, lxor a a == 0. +Proof. + intros. bitwise. apply xorb_nilpotent. +Qed. + +Lemma lxor_eq_0_iff : forall a a', lxor a a' == 0 <-> a == a'. +Proof. + split. apply lxor_eq. intros EQ; rewrite EQ; apply lxor_nilpotent. +Qed. + +Lemma lxor_0_l : forall a, lxor 0 a == a. +Proof. + intros. bitwise. apply xorb_false_l. +Qed. + +Lemma lxor_0_r : forall a, lxor a 0 == a. +Proof. + intros. bitwise. apply xorb_false_r. +Qed. + +Lemma lxor_comm : forall a b, lxor a b == lxor b a. +Proof. + intros. bitwise. apply xorb_comm. +Qed. + +Lemma lxor_assoc : + forall a b c, lxor (lxor a b) c == lxor a (lxor b c). +Proof. + intros. bitwise. apply xorb_assoc. +Qed. + +Lemma lor_0_l : forall a, lor 0 a == a. +Proof. + intros. bitwise. trivial. +Qed. + +Lemma lor_0_r : forall a, lor a 0 == a. +Proof. + intros. bitwise. apply orb_false_r. +Qed. + +Lemma lor_comm : forall a b, lor a b == lor b a. +Proof. + intros. bitwise. apply orb_comm. +Qed. + +Lemma lor_assoc : + forall a b c, lor a (lor b c) == lor (lor a b) c. +Proof. + intros. bitwise. apply orb_assoc. +Qed. + +Lemma lor_diag : forall a, lor a a == a. +Proof. + intros. bitwise. apply orb_diag. +Qed. + +Lemma lor_eq_0_l : forall a b, lor a b == 0 -> a == 0. +Proof. + intros a b H. bitwise. + apply (orb_false_iff a.[m] b.[m]). + now rewrite <- lor_spec, H, bits_0. +Qed. + +Lemma lor_eq_0_iff : forall a b, lor a b == 0 <-> a == 0 /\ b == 0. +Proof. + intros a b. split. + split. now apply lor_eq_0_l in H. + rewrite lor_comm in H. now apply lor_eq_0_l in H. + intros (EQ,EQ'). now rewrite EQ, lor_0_l. +Qed. + +Lemma land_0_l : forall a, land 0 a == 0. +Proof. + intros. bitwise. trivial. +Qed. + +Lemma land_0_r : forall a, land a 0 == 0. +Proof. + intros. bitwise. apply andb_false_r. +Qed. + +Lemma land_comm : forall a b, land a b == land b a. +Proof. + intros. bitwise. apply andb_comm. +Qed. + +Lemma land_assoc : + forall a b c, land a (land b c) == land (land a b) c. +Proof. + intros. bitwise. apply andb_assoc. +Qed. + +Lemma land_diag : forall a, land a a == a. +Proof. + intros. bitwise. apply andb_diag. +Qed. + +Lemma ldiff_0_l : forall a, ldiff 0 a == 0. +Proof. + intros. bitwise. trivial. +Qed. + +Lemma ldiff_0_r : forall a, ldiff a 0 == a. +Proof. + intros. bitwise. now rewrite andb_true_r. +Qed. + +Lemma ldiff_diag : forall a, ldiff a a == 0. +Proof. + intros. bitwise. apply andb_negb_r. +Qed. + +Lemma lor_land_distr_l : forall a b c, + lor (land a b) c == land (lor a c) (lor b c). +Proof. + intros. bitwise. apply orb_andb_distrib_l. +Qed. + +Lemma lor_land_distr_r : forall a b c, + lor a (land b c) == land (lor a b) (lor a c). +Proof. + intros. bitwise. apply orb_andb_distrib_r. +Qed. + +Lemma land_lor_distr_l : forall a b c, + land (lor a b) c == lor (land a c) (land b c). +Proof. + intros. bitwise. apply andb_orb_distrib_l. +Qed. + +Lemma land_lor_distr_r : forall a b c, + land a (lor b c) == lor (land a b) (land a c). +Proof. + intros. bitwise. apply andb_orb_distrib_r. +Qed. + +Lemma ldiff_ldiff_l : forall a b c, + ldiff (ldiff a b) c == ldiff a (lor b c). +Proof. + intros. bitwise. now rewrite negb_orb, andb_assoc. +Qed. + +Lemma lor_ldiff_and : forall a b, + lor (ldiff a b) (land a b) == a. +Proof. + intros. bitwise. + now rewrite <- andb_orb_distrib_r, orb_comm, orb_negb_r, andb_true_r. +Qed. + +Lemma land_ldiff : forall a b, + land (ldiff a b) b == 0. +Proof. + intros. bitwise. + now rewrite <-andb_assoc, (andb_comm (negb _)), andb_negb_r, andb_false_r. +Qed. + +(** Properties of [setbit] and [clearbit] *) + +Definition setbit a n := lor a (1 << n). +Definition clearbit a n := ldiff a (1 << n). + +Lemma setbit_spec' : forall a n, setbit a n == lor a (2^n). +Proof. + intros. unfold setbit. now rewrite shiftl_1_l. +Qed. + +Lemma clearbit_spec' : forall a n, clearbit a n == ldiff a (2^n). +Proof. + intros. unfold clearbit. now rewrite shiftl_1_l. +Qed. + +Instance setbit_wd : Proper (eq==>eq==>eq) setbit. +Proof. unfold setbit. solve_proper. Qed. + +Instance clearbit_wd : Proper (eq==>eq==>eq) clearbit. +Proof. unfold clearbit. solve_proper. Qed. + +Lemma pow2_bits_true : forall n, 0<=n -> (2^n).[n] = true. +Proof. + intros. rewrite <- (mul_1_l (2^n)). + now rewrite mul_pow2_bits, sub_diag, bit0_odd, odd_1. +Qed. + +Lemma pow2_bits_false : forall n m, n~=m -> (2^n).[m] = false. +Proof. + intros. + destruct (le_gt_cases 0 n); [|now rewrite pow_neg_r, bits_0]. + destruct (le_gt_cases n m). + rewrite <- (mul_1_l (2^n)), mul_pow2_bits; trivial. + rewrite <- (succ_pred (m-n)), <- div2_bits. + now rewrite div_small, bits_0 by (split; order'). + rewrite <- lt_succ_r, succ_pred, lt_0_sub. order. + rewrite <- (mul_1_l (2^n)), mul_pow2_bits_low; trivial. +Qed. + +Lemma pow2_bits_eqb : forall n m, 0<=n -> (2^n).[m] = eqb n m. +Proof. + intros n m Hn. apply eq_true_iff_eq. rewrite eqb_eq. split. + destruct (eq_decidable n m) as [H|H]. trivial. + now rewrite (pow2_bits_false _ _ H). + intros EQ. rewrite EQ. apply pow2_bits_true; order. +Qed. + +Lemma setbit_eqb : forall a n m, 0<=n -> + (setbit a n).[m] = eqb n m || a.[m]. +Proof. + intros. now rewrite setbit_spec', lor_spec, pow2_bits_eqb, orb_comm. +Qed. + +Lemma setbit_iff : forall a n m, 0<=n -> + ((setbit a n).[m] = true <-> n==m \/ a.[m] = true). +Proof. + intros. now rewrite setbit_eqb, orb_true_iff, eqb_eq. +Qed. + +Lemma setbit_eq : forall a n, 0<=n -> (setbit a n).[n] = true. +Proof. + intros. apply setbit_iff; trivial. now left. +Qed. + +Lemma setbit_neq : forall a n m, 0<=n -> n~=m -> + (setbit a n).[m] = a.[m]. +Proof. + intros a n m Hn H. rewrite setbit_eqb; trivial. + rewrite <- eqb_eq in H. apply not_true_is_false in H. now rewrite H. +Qed. + +Lemma clearbit_eqb : forall a n m, + (clearbit a n).[m] = a.[m] && negb (eqb n m). +Proof. + intros. + destruct (le_gt_cases 0 m); [| now rewrite 2 testbit_neg_r]. + rewrite clearbit_spec', ldiff_spec. f_equal. f_equal. + destruct (le_gt_cases 0 n) as [Hn|Hn]. + now apply pow2_bits_eqb. + symmetry. rewrite pow_neg_r, bits_0, <- not_true_iff_false, eqb_eq; order. +Qed. + +Lemma clearbit_iff : forall a n m, + (clearbit a n).[m] = true <-> a.[m] = true /\ n~=m. +Proof. + intros. rewrite clearbit_eqb, andb_true_iff, <- eqb_eq. + now rewrite negb_true_iff, not_true_iff_false. +Qed. + +Lemma clearbit_eq : forall a n, (clearbit a n).[n] = false. +Proof. + intros. rewrite clearbit_eqb, (proj2 (eqb_eq _ _) (eq_refl n)). + apply andb_false_r. +Qed. + +Lemma clearbit_neq : forall a n m, n~=m -> + (clearbit a n).[m] = a.[m]. +Proof. + intros a n m H. rewrite clearbit_eqb. + rewrite <- eqb_eq in H. apply not_true_is_false in H. rewrite H. + apply andb_true_r. +Qed. + +(** Shifts of bitwise operations *) + +Lemma shiftl_lxor : forall a b n, + (lxor a b) << n == lxor (a << n) (b << n). +Proof. + intros. bitwise. now rewrite !shiftl_spec, lxor_spec. +Qed. + +Lemma shiftr_lxor : forall a b n, + (lxor a b) >> n == lxor (a >> n) (b >> n). +Proof. + intros. bitwise. now rewrite !shiftr_spec, lxor_spec. +Qed. + +Lemma shiftl_land : forall a b n, + (land a b) << n == land (a << n) (b << n). +Proof. + intros. bitwise. now rewrite !shiftl_spec, land_spec. +Qed. + +Lemma shiftr_land : forall a b n, + (land a b) >> n == land (a >> n) (b >> n). +Proof. + intros. bitwise. now rewrite !shiftr_spec, land_spec. +Qed. + +Lemma shiftl_lor : forall a b n, + (lor a b) << n == lor (a << n) (b << n). +Proof. + intros. bitwise. now rewrite !shiftl_spec, lor_spec. +Qed. + +Lemma shiftr_lor : forall a b n, + (lor a b) >> n == lor (a >> n) (b >> n). +Proof. + intros. bitwise. now rewrite !shiftr_spec, lor_spec. +Qed. + +Lemma shiftl_ldiff : forall a b n, + (ldiff a b) << n == ldiff (a << n) (b << n). +Proof. + intros. bitwise. now rewrite !shiftl_spec, ldiff_spec. +Qed. + +Lemma shiftr_ldiff : forall a b n, + (ldiff a b) >> n == ldiff (a >> n) (b >> n). +Proof. + intros. bitwise. now rewrite !shiftr_spec, ldiff_spec. +Qed. + +(** For integers, we do have a binary complement function *) + +Definition lnot a := P (-a). + +Instance lnot_wd : Proper (eq==>eq) lnot. +Proof. unfold lnot. solve_proper. Qed. + +Lemma lnot_spec : forall a n, 0<=n -> (lnot a).[n] = negb a.[n]. +Proof. + intros. unfold lnot. rewrite <- (opp_involutive a) at 2. + rewrite bits_opp, negb_involutive; trivial. +Qed. + +Lemma lnot_involutive : forall a, lnot (lnot a) == a. +Proof. + intros a. bitwise. now rewrite 2 lnot_spec, negb_involutive. +Qed. + +Lemma lnot_0 : lnot 0 == -1. +Proof. + unfold lnot. now rewrite opp_0, <- sub_1_r, sub_0_l. +Qed. + +Lemma lnot_m1 : lnot (-1) == 0. +Proof. + unfold lnot. now rewrite opp_involutive, one_succ, pred_succ. +Qed. + +(** Complement and other operations *) + +Lemma lor_m1_r : forall a, lor a (-1) == -1. +Proof. + intros. bitwise. now rewrite bits_m1, orb_true_r. +Qed. + +Lemma lor_m1_l : forall a, lor (-1) a == -1. +Proof. + intros. now rewrite lor_comm, lor_m1_r. +Qed. + +Lemma land_m1_r : forall a, land a (-1) == a. +Proof. + intros. bitwise. now rewrite bits_m1, andb_true_r. +Qed. + +Lemma land_m1_l : forall a, land (-1) a == a. +Proof. + intros. now rewrite land_comm, land_m1_r. +Qed. + +Lemma ldiff_m1_r : forall a, ldiff a (-1) == 0. +Proof. + intros. bitwise. now rewrite bits_m1, andb_false_r. +Qed. + +Lemma ldiff_m1_l : forall a, ldiff (-1) a == lnot a. +Proof. + intros. bitwise. now rewrite lnot_spec, bits_m1. +Qed. + +Lemma lor_lnot_diag : forall a, lor a (lnot a) == -1. +Proof. + intros a. bitwise. rewrite lnot_spec, bits_m1; trivial. + now destruct a.[m]. +Qed. + +Lemma add_lnot_diag : forall a, a + lnot a == -1. +Proof. + intros a. unfold lnot. + now rewrite add_pred_r, add_opp_r, sub_diag, one_succ, opp_succ, opp_0. +Qed. + +Lemma ldiff_land : forall a b, ldiff a b == land a (lnot b). +Proof. + intros. bitwise. now rewrite lnot_spec. +Qed. + +Lemma land_lnot_diag : forall a, land a (lnot a) == 0. +Proof. + intros. now rewrite <- ldiff_land, ldiff_diag. +Qed. + +Lemma lnot_lor : forall a b, lnot (lor a b) == land (lnot a) (lnot b). +Proof. + intros a b. bitwise. now rewrite !lnot_spec, lor_spec, negb_orb. +Qed. + +Lemma lnot_land : forall a b, lnot (land a b) == lor (lnot a) (lnot b). +Proof. + intros a b. bitwise. now rewrite !lnot_spec, land_spec, negb_andb. +Qed. + +Lemma lnot_ldiff : forall a b, lnot (ldiff a b) == lor (lnot a) b. +Proof. + intros a b. bitwise. + now rewrite !lnot_spec, ldiff_spec, negb_andb, negb_involutive. +Qed. + +Lemma lxor_lnot_lnot : forall a b, lxor (lnot a) (lnot b) == lxor a b. +Proof. + intros a b. bitwise. now rewrite !lnot_spec, xorb_negb_negb. +Qed. + +Lemma lnot_lxor_l : forall a b, lnot (lxor a b) == lxor (lnot a) b. +Proof. + intros a b. bitwise. now rewrite !lnot_spec, !lxor_spec, negb_xorb_l. +Qed. + +Lemma lnot_lxor_r : forall a b, lnot (lxor a b) == lxor a (lnot b). +Proof. + intros a b. bitwise. now rewrite !lnot_spec, !lxor_spec, negb_xorb_r. +Qed. + +Lemma lxor_m1_r : forall a, lxor a (-1) == lnot a. +Proof. + intros. now rewrite <- (lxor_0_r (lnot a)), <- lnot_m1, lxor_lnot_lnot. +Qed. + +Lemma lxor_m1_l : forall a, lxor (-1) a == lnot a. +Proof. + intros. now rewrite lxor_comm, lxor_m1_r. +Qed. + +Lemma lxor_lor : forall a b, land a b == 0 -> + lxor a b == lor a b. +Proof. + intros a b H. bitwise. + assert (a.[m] && b.[m] = false) + by now rewrite <- land_spec, H, bits_0. + now destruct a.[m], b.[m]. +Qed. + +Lemma lnot_shiftr : forall a n, 0<=n -> lnot (a >> n) == (lnot a) >> n. +Proof. + intros a n Hn. bitwise. + now rewrite lnot_spec, 2 shiftr_spec, lnot_spec by order_pos. +Qed. + +(** [(ones n)] is [2^n-1], the number with [n] digits 1 *) + +Definition ones n := P (1<<n). + +Instance ones_wd : Proper (eq==>eq) ones. +Proof. unfold ones. solve_proper. Qed. + +Lemma ones_equiv : forall n, ones n == P (2^n). +Proof. + intros. unfold ones. + destruct (le_gt_cases 0 n). + now rewrite shiftl_mul_pow2, mul_1_l. + f_equiv. rewrite pow_neg_r; trivial. + rewrite <- shiftr_opp_r. apply shiftr_eq_0_iff. right; split. + order'. rewrite log2_1. now apply opp_pos_neg. +Qed. + +Lemma ones_add : forall n m, 0<=n -> 0<=m -> + ones (m+n) == 2^m * ones n + ones m. +Proof. + intros n m Hn Hm. rewrite !ones_equiv. + rewrite <- !sub_1_r, mul_sub_distr_l, mul_1_r, <- pow_add_r by trivial. + rewrite add_sub_assoc, sub_add. reflexivity. +Qed. + +Lemma ones_div_pow2 : forall n m, 0<=m<=n -> ones n / 2^m == ones (n-m). +Proof. + intros n m (Hm,H). symmetry. apply div_unique with (ones m). + left. rewrite ones_equiv. split. + rewrite <- lt_succ_r, succ_pred. order_pos. + now rewrite <- le_succ_l, succ_pred. + rewrite <- (sub_add m n) at 1. rewrite (add_comm _ m). + apply ones_add; trivial. now apply le_0_sub. +Qed. + +Lemma ones_mod_pow2 : forall n m, 0<=m<=n -> (ones n) mod (2^m) == ones m. +Proof. + intros n m (Hm,H). symmetry. apply mod_unique with (ones (n-m)). + left. rewrite ones_equiv. split. + rewrite <- lt_succ_r, succ_pred. order_pos. + now rewrite <- le_succ_l, succ_pred. + rewrite <- (sub_add m n) at 1. rewrite (add_comm _ m). + apply ones_add; trivial. now apply le_0_sub. +Qed. + +Lemma ones_spec_low : forall n m, 0<=m<n -> (ones n).[m] = true. +Proof. + intros n m (Hm,H). apply testbit_true; trivial. + rewrite ones_div_pow2 by (split; order). + rewrite <- (pow_1_r 2). rewrite ones_mod_pow2. + rewrite ones_equiv. now nzsimpl'. + split. order'. apply le_add_le_sub_r. nzsimpl. now apply le_succ_l. +Qed. + +Lemma ones_spec_high : forall n m, 0<=n<=m -> (ones n).[m] = false. +Proof. + intros n m (Hn,H). le_elim Hn. + apply bits_above_log2; rewrite ones_equiv. + rewrite <-lt_succ_r, succ_pred; order_pos. + rewrite log2_pred_pow2; trivial. now rewrite <-le_succ_l, succ_pred. + rewrite ones_equiv. now rewrite <- Hn, pow_0_r, one_succ, pred_succ, bits_0. +Qed. + +Lemma ones_spec_iff : forall n m, 0<=n -> + ((ones n).[m] = true <-> 0<=m<n). +Proof. + intros n m Hn. split. intros H. + destruct (lt_ge_cases m 0) as [Hm|Hm]. + now rewrite testbit_neg_r in H. + split; trivial. apply lt_nge. intro H'. rewrite ones_spec_high in H. + discriminate. now split. + apply ones_spec_low. +Qed. + +Lemma lor_ones_low : forall a n, 0<=a -> log2 a < n -> + lor a (ones n) == ones n. +Proof. + intros a n Ha H. bitwise. destruct (le_gt_cases n m). + rewrite ones_spec_high, bits_above_log2; try split; trivial. + now apply lt_le_trans with n. + apply le_trans with (log2 a); order_pos. + rewrite ones_spec_low, orb_true_r; try split; trivial. +Qed. + +Lemma land_ones : forall a n, 0<=n -> land a (ones n) == a mod 2^n. +Proof. + intros a n Hn. bitwise. destruct (le_gt_cases n m). + rewrite ones_spec_high, mod_pow2_bits_high, andb_false_r; + try split; trivial. + rewrite ones_spec_low, mod_pow2_bits_low, andb_true_r; + try split; trivial. +Qed. + +Lemma land_ones_low : forall a n, 0<=a -> log2 a < n -> + land a (ones n) == a. +Proof. + intros a n Ha H. + assert (Hn : 0<=n) by (generalize (log2_nonneg a); order). + rewrite land_ones; trivial. apply mod_small. + split; trivial. + apply log2_lt_cancel. now rewrite log2_pow2. +Qed. + +Lemma ldiff_ones_r : forall a n, 0<=n -> + ldiff a (ones n) == (a >> n) << n. +Proof. + intros a n Hn. bitwise. destruct (le_gt_cases n m). + rewrite ones_spec_high, shiftl_spec_high, shiftr_spec; trivial. + rewrite sub_add; trivial. apply andb_true_r. + now apply le_0_sub. + now split. + rewrite ones_spec_low, shiftl_spec_low, andb_false_r; + try split; trivial. +Qed. + +Lemma ldiff_ones_r_low : forall a n, 0<=a -> log2 a < n -> + ldiff a (ones n) == 0. +Proof. + intros a n Ha H. bitwise. destruct (le_gt_cases n m). + rewrite ones_spec_high, bits_above_log2; trivial. + now apply lt_le_trans with n. + split; trivial. now apply le_trans with (log2 a); order_pos. + rewrite ones_spec_low, andb_false_r; try split; trivial. +Qed. + +Lemma ldiff_ones_l_low : forall a n, 0<=a -> log2 a < n -> + ldiff (ones n) a == lxor a (ones n). +Proof. + intros a n Ha H. bitwise. destruct (le_gt_cases n m). + rewrite ones_spec_high, bits_above_log2; trivial. + now apply lt_le_trans with n. + split; trivial. now apply le_trans with (log2 a); order_pos. + rewrite ones_spec_low, xorb_true_r; try split; trivial. +Qed. + +(** Bitwise operations and sign *) + +Lemma shiftl_nonneg : forall a n, 0 <= (a << n) <-> 0 <= a. +Proof. + intros a n. + destruct (le_ge_cases 0 n) as [Hn|Hn]. + (* 0<=n *) + rewrite 2 bits_iff_nonneg_ex. split; intros (k,Hk). + exists (k-n). intros m Hm. + destruct (le_gt_cases 0 m); [|now rewrite testbit_neg_r]. + rewrite <- (add_simpl_r m n), <- (shiftl_spec a n) by order_pos. + apply Hk. now apply lt_sub_lt_add_r. + exists (k+n). intros m Hm. + destruct (le_gt_cases 0 m); [|now rewrite testbit_neg_r]. + rewrite shiftl_spec by trivial. apply Hk. now apply lt_add_lt_sub_r. + (* n<=0*) + rewrite <- shiftr_opp_r, 2 bits_iff_nonneg_ex. split; intros (k,Hk). + destruct (le_gt_cases 0 k). + exists (k-n). intros m Hm. apply lt_sub_lt_add_r in Hm. + rewrite <- (add_simpl_r m n), <- add_opp_r, <- (shiftr_spec a (-n)). + now apply Hk. order. + assert (EQ : a >> (-n) == 0). + apply bits_inj'. intros m Hm. rewrite bits_0. apply Hk; order. + apply shiftr_eq_0_iff in EQ. + rewrite <- bits_iff_nonneg_ex. destruct EQ as [EQ|[LT _]]; order. + exists (k+n). intros m Hm. + destruct (le_gt_cases 0 m); [|now rewrite testbit_neg_r]. + rewrite shiftr_spec by trivial. apply Hk. + rewrite add_opp_r. now apply lt_add_lt_sub_r. +Qed. + +Lemma shiftl_neg : forall a n, (a << n) < 0 <-> a < 0. +Proof. + intros a n. now rewrite 2 lt_nge, shiftl_nonneg. +Qed. + +Lemma shiftr_nonneg : forall a n, 0 <= (a >> n) <-> 0 <= a. +Proof. + intros. rewrite <- shiftl_opp_r. apply shiftl_nonneg. +Qed. + +Lemma shiftr_neg : forall a n, (a >> n) < 0 <-> a < 0. +Proof. + intros a n. now rewrite 2 lt_nge, shiftr_nonneg. +Qed. + +Lemma div2_nonneg : forall a, 0 <= div2 a <-> 0 <= a. +Proof. + intros. rewrite div2_spec. apply shiftr_nonneg. +Qed. + +Lemma div2_neg : forall a, div2 a < 0 <-> a < 0. +Proof. + intros a. now rewrite 2 lt_nge, div2_nonneg. +Qed. + +Lemma lor_nonneg : forall a b, 0 <= lor a b <-> 0<=a /\ 0<=b. +Proof. + intros a b. + rewrite 3 bits_iff_nonneg_ex. split. intros (k,Hk). + split; exists k; intros m Hm; apply (orb_false_elim a.[m] b.[m]); + rewrite <- lor_spec; now apply Hk. + intros ((k,Hk),(k',Hk')). + destruct (le_ge_cases k k'); [ exists k' | exists k ]; + intros m Hm; rewrite lor_spec, Hk, Hk'; trivial; order. +Qed. + +Lemma lor_neg : forall a b, lor a b < 0 <-> a < 0 \/ b < 0. +Proof. + intros a b. rewrite 3 lt_nge, lor_nonneg. split. + apply not_and. apply le_decidable. + now intros [H|H] (H',H''). +Qed. + +Lemma lnot_nonneg : forall a, 0 <= lnot a <-> a < 0. +Proof. + intros a; unfold lnot. + now rewrite <- opp_succ, opp_nonneg_nonpos, le_succ_l. +Qed. + +Lemma lnot_neg : forall a, lnot a < 0 <-> 0 <= a. +Proof. + intros a. now rewrite le_ngt, lt_nge, lnot_nonneg. +Qed. + +Lemma land_nonneg : forall a b, 0 <= land a b <-> 0<=a \/ 0<=b. +Proof. + intros a b. + now rewrite <- (lnot_involutive (land a b)), lnot_land, lnot_nonneg, + lor_neg, !lnot_neg. +Qed. + +Lemma land_neg : forall a b, land a b < 0 <-> a < 0 /\ b < 0. +Proof. + intros a b. + now rewrite <- (lnot_involutive (land a b)), lnot_land, lnot_neg, + lor_nonneg, !lnot_nonneg. +Qed. + +Lemma ldiff_nonneg : forall a b, 0 <= ldiff a b <-> 0<=a \/ b<0. +Proof. + intros. now rewrite ldiff_land, land_nonneg, lnot_nonneg. +Qed. + +Lemma ldiff_neg : forall a b, ldiff a b < 0 <-> a<0 /\ 0<=b. +Proof. + intros. now rewrite ldiff_land, land_neg, lnot_neg. +Qed. + +Lemma lxor_nonneg : forall a b, 0 <= lxor a b <-> (0<=a <-> 0<=b). +Proof. + assert (H : forall a b, 0<=a -> 0<=b -> 0<=lxor a b). + intros a b. rewrite 3 bits_iff_nonneg_ex. intros (k,Hk) (k', Hk'). + destruct (le_ge_cases k k'); [ exists k' | exists k]; + intros m Hm; rewrite lxor_spec, Hk, Hk'; trivial; order. + assert (H' : forall a b, 0<=a -> b<0 -> lxor a b<0). + intros a b. rewrite bits_iff_nonneg_ex, 2 bits_iff_neg_ex. + intros (k,Hk) (k', Hk'). + destruct (le_ge_cases k k'); [ exists k' | exists k]; + intros m Hm; rewrite lxor_spec, Hk, Hk'; trivial; order. + intros a b. + split. + intros Hab. split. + intros Ha. destruct (le_gt_cases 0 b) as [Hb|Hb]; trivial. + generalize (H' _ _ Ha Hb). order. + intros Hb. destruct (le_gt_cases 0 a) as [Ha|Ha]; trivial. + generalize (H' _ _ Hb Ha). rewrite lxor_comm. order. + intros E. + destruct (le_gt_cases 0 a) as [Ha|Ha]. apply H; trivial. apply E; trivial. + destruct (le_gt_cases 0 b) as [Hb|Hb]. apply H; trivial. apply E; trivial. + rewrite <- lxor_lnot_lnot. apply H; now apply lnot_nonneg. +Qed. + +(** Bitwise operations and log2 *) + +Lemma log2_bits_unique : forall a n, + a.[n] = true -> + (forall m, n<m -> a.[m] = false) -> + log2 a == n. +Proof. + intros a n H H'. + destruct (lt_trichotomy a 0) as [Ha|[Ha|Ha]]. + (* a < 0 *) + destruct (proj1 (bits_iff_neg_ex a) Ha) as (k,Hk). + destruct (le_gt_cases n k). + specialize (Hk (S k) (lt_succ_diag_r _)). + rewrite H' in Hk. discriminate. apply lt_succ_r; order. + specialize (H' (S n) (lt_succ_diag_r _)). + rewrite Hk in H'. discriminate. apply lt_succ_r; order. + (* a = 0 *) + now rewrite Ha, bits_0 in H. + (* 0 < a *) + apply le_antisymm; apply le_ngt; intros LT. + specialize (H' _ LT). now rewrite bit_log2 in H'. + now rewrite bits_above_log2 in H by order. +Qed. + +Lemma log2_shiftr : forall a n, 0<a -> log2 (a >> n) == max 0 (log2 a - n). +Proof. + intros a n Ha. + destruct (le_gt_cases 0 (log2 a - n)); + [rewrite max_r | rewrite max_l]; try order. + apply log2_bits_unique. + now rewrite shiftr_spec, sub_add, bit_log2. + intros m Hm. + destruct (le_gt_cases 0 m); [|now rewrite testbit_neg_r]. + rewrite shiftr_spec; trivial. apply bits_above_log2; try order. + now apply lt_sub_lt_add_r. + rewrite lt_sub_lt_add_r, add_0_l in H. + apply log2_nonpos. apply le_lteq; right. + apply shiftr_eq_0_iff. right. now split. +Qed. + +Lemma log2_shiftl : forall a n, 0<a -> 0<=n -> log2 (a << n) == log2 a + n. +Proof. + intros a n Ha Hn. + rewrite shiftl_mul_pow2, add_comm by trivial. + now apply log2_mul_pow2. +Qed. + +Lemma log2_shiftl' : forall a n, 0<a -> log2 (a << n) == max 0 (log2 a + n). +Proof. + intros a n Ha. + rewrite <- shiftr_opp_r, log2_shiftr by trivial. + destruct (le_gt_cases 0 (log2 a + n)); + [rewrite 2 max_r | rewrite 2 max_l]; rewrite ?sub_opp_r; try order. +Qed. + +Lemma log2_lor : forall a b, 0<=a -> 0<=b -> + log2 (lor a b) == max (log2 a) (log2 b). +Proof. + assert (AUX : forall a b, 0<=a -> a<=b -> log2 (lor a b) == log2 b). + intros a b Ha H. + le_elim Ha; [|now rewrite <- Ha, lor_0_l]. + apply log2_bits_unique. + now rewrite lor_spec, bit_log2, orb_true_r by order. + intros m Hm. assert (H' := log2_le_mono _ _ H). + now rewrite lor_spec, 2 bits_above_log2 by order. + (* main *) + intros a b Ha Hb. destruct (le_ge_cases a b) as [H|H]. + rewrite max_r by now apply log2_le_mono. + now apply AUX. + rewrite max_l by now apply log2_le_mono. + rewrite lor_comm. now apply AUX. +Qed. + +Lemma log2_land : forall a b, 0<=a -> 0<=b -> + log2 (land a b) <= min (log2 a) (log2 b). +Proof. + assert (AUX : forall a b, 0<=a -> a<=b -> log2 (land a b) <= log2 a). + intros a b Ha Hb. + apply le_ngt. intros LT. + assert (H : 0 <= land a b) by (apply land_nonneg; now left). + le_elim H. + generalize (bit_log2 (land a b) H). + now rewrite land_spec, bits_above_log2. + rewrite <- H in LT. apply log2_lt_cancel in LT; order. + (* main *) + intros a b Ha Hb. + destruct (le_ge_cases a b) as [H|H]. + rewrite min_l by now apply log2_le_mono. now apply AUX. + rewrite min_r by now apply log2_le_mono. rewrite land_comm. now apply AUX. +Qed. + +Lemma log2_lxor : forall a b, 0<=a -> 0<=b -> + log2 (lxor a b) <= max (log2 a) (log2 b). +Proof. + assert (AUX : forall a b, 0<=a -> a<=b -> log2 (lxor a b) <= log2 b). + intros a b Ha Hb. + apply le_ngt. intros LT. + assert (H : 0 <= lxor a b) by (apply lxor_nonneg; split; order). + le_elim H. + generalize (bit_log2 (lxor a b) H). + rewrite lxor_spec, 2 bits_above_log2; try order. discriminate. + apply le_lt_trans with (log2 b); trivial. now apply log2_le_mono. + rewrite <- H in LT. apply log2_lt_cancel in LT; order. + (* main *) + intros a b Ha Hb. + destruct (le_ge_cases a b) as [H|H]. + rewrite max_r by now apply log2_le_mono. now apply AUX. + rewrite max_l by now apply log2_le_mono. rewrite lxor_comm. now apply AUX. +Qed. + +(** Bitwise operations and arithmetical operations *) + +Local Notation xor3 a b c := (xorb (xorb a b) c). +Local Notation lxor3 a b c := (lxor (lxor a b) c). +Local Notation nextcarry a b c := ((a&&b) || (c && (a||b))). +Local Notation lnextcarry a b c := (lor (land a b) (land c (lor a b))). + +Lemma add_bit0 : forall a b, (a+b).[0] = xorb a.[0] b.[0]. +Proof. + intros. now rewrite !bit0_odd, odd_add. +Qed. + +Lemma add3_bit0 : forall a b c, + (a+b+c).[0] = xor3 a.[0] b.[0] c.[0]. +Proof. + intros. now rewrite !add_bit0. +Qed. + +Lemma add3_bits_div2 : forall (a0 b0 c0 : bool), + (a0 + b0 + c0)/2 == nextcarry a0 b0 c0. +Proof. + assert (H : 1+1 == 2) by now nzsimpl'. + intros [|] [|] [|]; simpl; rewrite ?add_0_l, ?add_0_r, ?H; + (apply div_same; order') || (apply div_small; split; order') || idtac. + symmetry. apply div_unique with 1. left; split; order'. now nzsimpl'. +Qed. + +Lemma add_carry_div2 : forall a b (c0:bool), + (a + b + c0)/2 == a/2 + b/2 + nextcarry a.[0] b.[0] c0. +Proof. + intros. + rewrite <- add3_bits_div2. + rewrite (add_comm ((a/2)+_)). + rewrite <- div_add by order'. + f_equiv. + rewrite <- !div2_div, mul_comm, mul_add_distr_l. + rewrite (div2_odd a), <- bit0_odd at 1. + rewrite (div2_odd b), <- bit0_odd at 1. + rewrite add_shuffle1. + rewrite <-(add_assoc _ _ c0). apply add_comm. +Qed. + +(** The main result concerning addition: we express the bits of the sum + in term of bits of [a] and [b] and of some carry stream which is also + recursively determined by another equation. +*) + +Lemma add_carry_bits_aux : forall n, 0<=n -> + forall a b (c0:bool), -(2^n) <= a < 2^n -> -(2^n) <= b < 2^n -> + exists c, + a+b+c0 == lxor3 a b c /\ c/2 == lnextcarry a b c /\ c.[0] = c0. +Proof. + intros n Hn. apply le_ind with (4:=Hn). + solve_proper. + (* base *) + intros a b c0. rewrite !pow_0_r, !one_succ, !lt_succ_r, <- !one_succ. + intros (Ha1,Ha2) (Hb1,Hb2). + le_elim Ha1; rewrite <- ?le_succ_l, ?succ_m1 in Ha1; + le_elim Hb1; rewrite <- ?le_succ_l, ?succ_m1 in Hb1. + (* base, a = 0, b = 0 *) + exists c0. + rewrite (le_antisymm _ _ Ha2 Ha1), (le_antisymm _ _ Hb2 Hb1). + rewrite !add_0_l, !lxor_0_l, !lor_0_r, !land_0_r, !lor_0_r. + rewrite b2z_div2, b2z_bit0; now repeat split. + (* base, a = 0, b = -1 *) + exists (-c0). rewrite <- Hb1, (le_antisymm _ _ Ha2 Ha1). repeat split. + rewrite add_0_l, lxor_0_l, lxor_m1_l. + unfold lnot. now rewrite opp_involutive, add_comm, add_opp_r, sub_1_r. + rewrite land_0_l, !lor_0_l, land_m1_r. + symmetry. apply div_unique with c0. left; destruct c0; simpl; split; order'. + now rewrite two_succ, mul_succ_l, mul_1_l, add_opp_r, sub_add. + rewrite bit0_odd, odd_opp; destruct c0; simpl; apply odd_1 || apply odd_0. + (* base, a = -1, b = 0 *) + exists (-c0). rewrite <- Ha1, (le_antisymm _ _ Hb2 Hb1). repeat split. + rewrite add_0_r, lxor_0_r, lxor_m1_l. + unfold lnot. now rewrite opp_involutive, add_comm, add_opp_r, sub_1_r. + rewrite land_0_r, lor_0_r, lor_0_l, land_m1_r. + symmetry. apply div_unique with c0. left; destruct c0; simpl; split; order'. + now rewrite two_succ, mul_succ_l, mul_1_l, add_opp_r, sub_add. + rewrite bit0_odd, odd_opp; destruct c0; simpl; apply odd_1 || apply odd_0. + (* base, a = -1, b = -1 *) + exists (c0 + 2*(-1)). rewrite <- Ha1, <- Hb1. repeat split. + rewrite lxor_m1_l, lnot_m1, lxor_0_l. + now rewrite two_succ, mul_succ_l, mul_1_l, add_comm, add_assoc. + rewrite land_m1_l, lor_m1_l. + apply add_b2z_double_div2. + apply add_b2z_double_bit0. + (* step *) + clear n Hn. intros n Hn IH a b c0 Ha Hb. + set (c1:=nextcarry a.[0] b.[0] c0). + destruct (IH (a/2) (b/2) c1) as (c & IH1 & IH2 & Hc); clear IH. + split. + apply div_le_lower_bound. order'. now rewrite mul_opp_r, <- pow_succ_r. + apply div_lt_upper_bound. order'. now rewrite <- pow_succ_r. + split. + apply div_le_lower_bound. order'. now rewrite mul_opp_r, <- pow_succ_r. + apply div_lt_upper_bound. order'. now rewrite <- pow_succ_r. + exists (c0 + 2*c). repeat split. + (* step, add *) + bitwise. + le_elim Hm. + rewrite <- (succ_pred m), lt_succ_r in Hm. + rewrite <- (succ_pred m), <- !div2_bits, <- 2 lxor_spec by trivial. + f_equiv. + rewrite add_b2z_double_div2, <- IH1. apply add_carry_div2. + rewrite <- Hm. + now rewrite add_b2z_double_bit0, add3_bit0, b2z_bit0. + (* step, carry *) + rewrite add_b2z_double_div2. + bitwise. + le_elim Hm. + rewrite <- (succ_pred m), lt_succ_r in Hm. + rewrite <- (succ_pred m), <- !div2_bits, IH2 by trivial. + autorewrite with bitwise. now rewrite add_b2z_double_div2. + rewrite <- Hm. + now rewrite add_b2z_double_bit0. + (* step, carry0 *) + apply add_b2z_double_bit0. +Qed. + +Lemma add_carry_bits : forall a b (c0:bool), exists c, + a+b+c0 == lxor3 a b c /\ c/2 == lnextcarry a b c /\ c.[0] = c0. +Proof. + intros a b c0. + set (n := max (abs a) (abs b)). + apply (add_carry_bits_aux n). + (* positivity *) + unfold n. + destruct (le_ge_cases (abs a) (abs b)); + [rewrite max_r|rewrite max_l]; order_pos'. + (* bound for a *) + assert (Ha : abs a < 2^n). + apply lt_le_trans with (2^(abs a)). apply pow_gt_lin_r; order_pos'. + apply pow_le_mono_r. order'. unfold n. + destruct (le_ge_cases (abs a) (abs b)); + [rewrite max_r|rewrite max_l]; try order. + apply abs_lt in Ha. destruct Ha; split; order. + (* bound for b *) + assert (Hb : abs b < 2^n). + apply lt_le_trans with (2^(abs b)). apply pow_gt_lin_r; order_pos'. + apply pow_le_mono_r. order'. unfold n. + destruct (le_ge_cases (abs a) (abs b)); + [rewrite max_r|rewrite max_l]; try order. + apply abs_lt in Hb. destruct Hb; split; order. +Qed. + +(** Particular case : the second bit of an addition *) + +Lemma add_bit1 : forall a b, + (a+b).[1] = xor3 a.[1] b.[1] (a.[0] && b.[0]). +Proof. + intros a b. + destruct (add_carry_bits a b false) as (c & EQ1 & EQ2 & Hc). + simpl in EQ1; rewrite add_0_r in EQ1. rewrite EQ1. + autorewrite with bitwise. f_equal. + rewrite one_succ, <- div2_bits, EQ2 by order. + autorewrite with bitwise. + rewrite Hc. simpl. apply orb_false_r. +Qed. + +(** In an addition, there will be no carries iff there is + no common bits in the numbers to add *) + +Lemma nocarry_equiv : forall a b c, + c/2 == lnextcarry a b c -> c.[0] = false -> + (c == 0 <-> land a b == 0). +Proof. + intros a b c H H'. + split. intros EQ; rewrite EQ in *. + rewrite div_0_l in H by order'. + symmetry in H. now apply lor_eq_0_l in H. + intros EQ. rewrite EQ, lor_0_l in H. + apply bits_inj'. intros n Hn. rewrite bits_0. + apply le_ind with (4:=Hn). + solve_proper. + trivial. + clear n Hn. intros n Hn IH. + rewrite <- div2_bits, H; trivial. + autorewrite with bitwise. + now rewrite IH. +Qed. + +(** When there is no common bits, the addition is just a xor *) + +Lemma add_nocarry_lxor : forall a b, land a b == 0 -> + a+b == lxor a b. +Proof. + intros a b H. + destruct (add_carry_bits a b false) as (c & EQ1 & EQ2 & Hc). + simpl in EQ1; rewrite add_0_r in EQ1. rewrite EQ1. + apply (nocarry_equiv a b c) in H; trivial. + rewrite H. now rewrite lxor_0_r. +Qed. + +(** A null [ldiff] implies being smaller *) + +Lemma ldiff_le : forall a b, 0<=b -> ldiff a b == 0 -> 0 <= a <= b. +Proof. + assert (AUX : forall n, 0<=n -> + forall a b, 0 <= a < 2^n -> 0<=b -> ldiff a b == 0 -> a <= b). + intros n Hn. apply le_ind with (4:=Hn); clear n Hn. + solve_proper. + intros a b Ha Hb _. rewrite pow_0_r, one_succ, lt_succ_r in Ha. + setoid_replace a with 0 by (destruct Ha; order'); trivial. + intros n Hn IH a b (Ha,Ha') Hb H. + assert (NEQ : 2 ~= 0) by order'. + rewrite (div_mod a 2 NEQ), (div_mod b 2 NEQ). + apply add_le_mono. + apply mul_le_mono_pos_l; try order'. + apply IH. + split. apply div_pos; order'. + apply div_lt_upper_bound; try order'. now rewrite <- pow_succ_r. + apply div_pos; order'. + rewrite <- (pow_1_r 2), <- 2 shiftr_div_pow2 by order'. + rewrite <- shiftr_ldiff, H, shiftr_div_pow2, pow_1_r, div_0_l; order'. + rewrite <- 2 bit0_mod. + apply bits_inj_iff in H. specialize (H 0). + rewrite ldiff_spec, bits_0 in H. + destruct a.[0], b.[0]; try discriminate; simpl; order'. + (* main *) + intros a b Hb Hd. + assert (Ha : 0<=a). + apply le_ngt; intros Ha'. apply (lt_irrefl 0). rewrite <- Hd at 1. + apply ldiff_neg. now split. + split; trivial. apply (AUX a); try split; trivial. apply pow_gt_lin_r; order'. +Qed. + +(** Subtraction can be a ldiff when the opposite ldiff is null. *) + +Lemma sub_nocarry_ldiff : forall a b, ldiff b a == 0 -> + a-b == ldiff a b. +Proof. + intros a b H. + apply add_cancel_r with b. + rewrite sub_add. + symmetry. + rewrite add_nocarry_lxor; trivial. + bitwise. + apply bits_inj_iff in H. specialize (H m). + rewrite ldiff_spec, bits_0 in H. + now destruct a.[m], b.[m]. + apply land_ldiff. +Qed. + +(** Adding numbers with no common bits cannot lead to a much bigger number *) + +Lemma add_nocarry_lt_pow2 : forall a b n, land a b == 0 -> + a < 2^n -> b < 2^n -> a+b < 2^n. +Proof. + intros a b n H Ha Hb. + destruct (le_gt_cases a 0) as [Ha'|Ha']. + apply le_lt_trans with (0+b). now apply add_le_mono_r. now nzsimpl. + destruct (le_gt_cases b 0) as [Hb'|Hb']. + apply le_lt_trans with (a+0). now apply add_le_mono_l. now nzsimpl. + rewrite add_nocarry_lxor by order. + destruct (lt_ge_cases 0 (lxor a b)); [|apply le_lt_trans with 0; order_pos]. + apply log2_lt_pow2; trivial. + apply log2_lt_pow2 in Ha; trivial. + apply log2_lt_pow2 in Hb; trivial. + apply le_lt_trans with (max (log2 a) (log2 b)). + apply log2_lxor; order. + destruct (le_ge_cases (log2 a) (log2 b)); + [rewrite max_r|rewrite max_l]; order. +Qed. + +Lemma add_nocarry_mod_lt_pow2 : forall a b n, 0<=n -> land a b == 0 -> + a mod 2^n + b mod 2^n < 2^n. +Proof. + intros a b n Hn H. + apply add_nocarry_lt_pow2. + bitwise. + destruct (le_gt_cases n m). + rewrite mod_pow2_bits_high; now split. + now rewrite !mod_pow2_bits_low, <- land_spec, H, bits_0. + apply mod_pos_bound; order_pos. + apply mod_pos_bound; order_pos. +Qed. + +End ZBitsProp. diff --git a/theories/Numbers/Integer/Abstract/ZDivEucl.v b/theories/Numbers/Integer/Abstract/ZDivEucl.v new file mode 100644 index 0000000000..a70ecd19d8 --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZDivEucl.v @@ -0,0 +1,633 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import ZAxioms ZMulOrder ZSgnAbs NZDiv. + +(** * Euclidean Division for integers, Euclid convention + + We use here the "usual" formulation of the Euclid Theorem + [forall a b, b<>0 -> exists r q, a = b*q+r /\ 0 <= r < |b| ] + + The outcome of the modulo function is hence always positive. + This corresponds to convention "E" in the following paper: + + R. Boute, "The Euclidean definition of the functions div and mod", + ACM Transactions on Programming Languages and Systems, + Vol. 14, No.2, pp. 127-144, April 1992. + + See files [ZDivTrunc] and [ZDivFloor] for others conventions. + + We simply extend NZDiv with a bound for modulo that holds + regardless of the sign of a and b. This new specification + subsume mod_bound_pos, which nonetheless stays there for + subtyping. Note also that ZAxiomSig now already contain + a div and a modulo (that follow the Floor convention). + We just ignore them here. +*) + +Module Type EuclidSpec (Import A : ZAxiomsSig')(Import B : DivMod A). + Axiom mod_always_pos : forall a b, b ~= 0 -> 0 <= B.modulo a b < abs b. +End EuclidSpec. + +Module Type ZEuclid (Z:ZAxiomsSig) := NZDiv.NZDiv Z <+ EuclidSpec Z. + +Module ZEuclidProp + (Import A : ZAxiomsSig') + (Import B : ZMulOrderProp A) + (Import C : ZSgnAbsProp A B) + (Import D : ZEuclid A). + + (** We put notations in a scope, to avoid warnings about + redefinitions of notations *) + Declare Scope euclid. + Infix "/" := D.div : euclid. + Infix "mod" := D.modulo : euclid. + Local Open Scope euclid. + + Module Import Private_NZDiv := Nop <+ NZDivProp A D B. + +(** Another formulation of the main equation *) + +Lemma mod_eq : + forall a b, b~=0 -> a mod b == a - b*(a/b). +Proof. +intros. +rewrite <- add_move_l. +symmetry. now apply div_mod. +Qed. + +Ltac pos_or_neg a := + let LT := fresh "LT" in + let LE := fresh "LE" in + destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT]. + +(** Uniqueness theorems *) + +Theorem div_mod_unique : forall b q1 q2 r1 r2 : t, + 0<=r1<abs b -> 0<=r2<abs b -> + b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. +Proof. +intros b q1 q2 r1 r2 Hr1 Hr2 EQ. +pos_or_neg b. +rewrite abs_eq in * by trivial. +apply div_mod_unique with b; trivial. +rewrite abs_neq' in * by auto using lt_le_incl. +rewrite eq_sym_iff. apply div_mod_unique with (-b); trivial. +rewrite 2 mul_opp_l. +rewrite add_move_l, sub_opp_r. +rewrite <-add_assoc. +symmetry. rewrite add_move_l, sub_opp_r. +now rewrite (add_comm r2), (add_comm r1). +Qed. + +Theorem div_unique: + forall a b q r, 0<=r<abs b -> a == b*q + r -> q == a/b. +Proof. +intros a b q r Hr EQ. +assert (Hb : b~=0). + pos_or_neg b. + rewrite abs_eq in Hr; intuition; order. + rewrite <- opp_0, eq_opp_r. rewrite abs_neq' in Hr; intuition; order. +destruct (div_mod_unique b q (a/b) r (a mod b)); trivial. +now apply mod_always_pos. +now rewrite <- div_mod. +Qed. + +Theorem mod_unique: + forall a b q r, 0<=r<abs b -> a == b*q + r -> r == a mod b. +Proof. +intros a b q r Hr EQ. +assert (Hb : b~=0). + pos_or_neg b. + rewrite abs_eq in Hr; intuition; order. + rewrite <- opp_0, eq_opp_r. rewrite abs_neq' in Hr; intuition; order. +destruct (div_mod_unique b q (a/b) r (a mod b)); trivial. +now apply mod_always_pos. +now rewrite <- div_mod. +Qed. + +(** Sign rules *) + +Lemma div_opp_r : forall a b, b~=0 -> a/(-b) == -(a/b). +Proof. +intros. symmetry. +apply div_unique with (a mod b). +rewrite abs_opp; now apply mod_always_pos. +rewrite mul_opp_opp; now apply div_mod. +Qed. + +Lemma mod_opp_r : forall a b, b~=0 -> a mod (-b) == a mod b. +Proof. +intros. symmetry. +apply mod_unique with (-(a/b)). +rewrite abs_opp; now apply mod_always_pos. +rewrite mul_opp_opp; now apply div_mod. +Qed. + +Lemma div_opp_l_z : forall a b, b~=0 -> a mod b == 0 -> + (-a)/b == -(a/b). +Proof. +intros a b Hb Hab. symmetry. +apply div_unique with (-(a mod b)). +rewrite Hab, opp_0. split; [order|]. +pos_or_neg b; [rewrite abs_eq | rewrite abs_neq']; order. +now rewrite mul_opp_r, <-opp_add_distr, <-div_mod. +Qed. + +Lemma div_opp_l_nz : forall a b, b~=0 -> a mod b ~= 0 -> + (-a)/b == -(a/b)-sgn b. +Proof. +intros a b Hb Hab. symmetry. +apply div_unique with (abs b -(a mod b)). +rewrite lt_sub_lt_add_l. +rewrite <- le_add_le_sub_l. nzsimpl. +rewrite <- (add_0_l (abs b)) at 2. +rewrite <- add_lt_mono_r. +destruct (mod_always_pos a b); intuition order. +rewrite <- 2 add_opp_r, mul_add_distr_l, 2 mul_opp_r. +rewrite sgn_abs. +rewrite add_shuffle2, add_opp_diag_l; nzsimpl. +rewrite <-opp_add_distr, <-div_mod; order. +Qed. + +Lemma mod_opp_l_z : forall a b, b~=0 -> a mod b == 0 -> + (-a) mod b == 0. +Proof. +intros a b Hb Hab. symmetry. +apply mod_unique with (-(a/b)). +split; [order|now rewrite abs_pos]. +now rewrite <-opp_0, <-Hab, mul_opp_r, <-opp_add_distr, <-div_mod. +Qed. + +Lemma mod_opp_l_nz : forall a b, b~=0 -> a mod b ~= 0 -> + (-a) mod b == abs b - (a mod b). +Proof. +intros a b Hb Hab. symmetry. +apply mod_unique with (-(a/b)-sgn b). +rewrite lt_sub_lt_add_l. +rewrite <- le_add_le_sub_l. nzsimpl. +rewrite <- (add_0_l (abs b)) at 2. +rewrite <- add_lt_mono_r. +destruct (mod_always_pos a b); intuition order. +rewrite <- 2 add_opp_r, mul_add_distr_l, 2 mul_opp_r. +rewrite sgn_abs. +rewrite add_shuffle2, add_opp_diag_l; nzsimpl. +rewrite <-opp_add_distr, <-div_mod; order. +Qed. + +Lemma div_opp_opp_z : forall a b, b~=0 -> a mod b == 0 -> + (-a)/(-b) == a/b. +Proof. +intros. now rewrite div_opp_r, div_opp_l_z, opp_involutive. +Qed. + +Lemma div_opp_opp_nz : forall a b, b~=0 -> a mod b ~= 0 -> + (-a)/(-b) == a/b + sgn(b). +Proof. +intros. rewrite div_opp_r, div_opp_l_nz by trivial. +now rewrite opp_sub_distr, opp_involutive. +Qed. + +Lemma mod_opp_opp_z : forall a b, b~=0 -> a mod b == 0 -> + (-a) mod (-b) == 0. +Proof. +intros. now rewrite mod_opp_r, mod_opp_l_z. +Qed. + +Lemma mod_opp_opp_nz : forall a b, b~=0 -> a mod b ~= 0 -> + (-a) mod (-b) == abs b - a mod b. +Proof. +intros. now rewrite mod_opp_r, mod_opp_l_nz. +Qed. + +(** A division by itself returns 1 *) + +Lemma div_same : forall a, a~=0 -> a/a == 1. +Proof. +intros. symmetry. apply div_unique with 0. +split; [order|now rewrite abs_pos]. +now nzsimpl. +Qed. + +Lemma mod_same : forall a, a~=0 -> a mod a == 0. +Proof. +intros. +rewrite mod_eq, div_same by trivial. nzsimpl. apply sub_diag. +Qed. + +(** A division of a small number by a bigger one yields zero. *) + +Theorem div_small: forall a b, 0<=a<b -> a/b == 0. +Proof. exact div_small. Qed. + +(** Same situation, in term of modulo: *) + +Theorem mod_small: forall a b, 0<=a<b -> a mod b == a. +Proof. exact mod_small. Qed. + +(** * Basic values of divisions and modulo. *) + +Lemma div_0_l: forall a, a~=0 -> 0/a == 0. +Proof. +intros. pos_or_neg a. apply div_0_l; order. +apply opp_inj. rewrite <- div_opp_r, opp_0 by trivial. now apply div_0_l. +Qed. + +Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0. +Proof. +intros; rewrite mod_eq, div_0_l; now nzsimpl. +Qed. + +Lemma div_1_r: forall a, a/1 == a. +Proof. +intros. symmetry. apply div_unique with 0. +assert (H:=lt_0_1); rewrite abs_pos; intuition; order. +now nzsimpl. +Qed. + +Lemma mod_1_r: forall a, a mod 1 == 0. +Proof. +intros. rewrite mod_eq, div_1_r; nzsimpl; auto using sub_diag. +apply neq_sym, lt_neq; apply lt_0_1. +Qed. + +Lemma div_1_l: forall a, 1<a -> 1/a == 0. +Proof. exact div_1_l. Qed. + +Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1. +Proof. exact mod_1_l. Qed. + +Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a. +Proof. +intros. symmetry. apply div_unique with 0. +split; [order|now rewrite abs_pos]. +nzsimpl; apply mul_comm. +Qed. + +Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0. +Proof. +intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag. +Qed. + +Theorem div_unique_exact a b q: b~=0 -> a == b*q -> q == a/b. +Proof. + intros Hb H. rewrite H, mul_comm. symmetry. now apply div_mul. +Qed. + +(** * Order results about mod and div *) + +(** A modulo cannot grow beyond its starting point. *) + +Theorem mod_le: forall a b, 0<=a -> b~=0 -> a mod b <= a. +Proof. +intros. pos_or_neg b. apply mod_le; order. +rewrite <- mod_opp_r by trivial. apply mod_le; order. +Qed. + +Theorem div_pos : forall a b, 0<=a -> 0<b -> 0<= a/b. +Proof. exact div_pos. Qed. + +Lemma div_str_pos : forall a b, 0<b<=a -> 0 < a/b. +Proof. exact div_str_pos. Qed. + +Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> 0<=a<abs b). +Proof. +intros a b Hb. +split. +intros EQ. +rewrite (div_mod a b Hb), EQ; nzsimpl. +now apply mod_always_pos. +intros. pos_or_neg b. +apply div_small. +now rewrite <- (abs_eq b). +apply opp_inj; rewrite opp_0, <- div_opp_r by trivial. +apply div_small. +rewrite <- (abs_neq' b) by order. trivial. +Qed. + +Lemma mod_small_iff : forall a b, b~=0 -> (a mod b == a <-> 0<=a<abs b). +Proof. +intros. +rewrite <- div_small_iff, mod_eq by trivial. +rewrite sub_move_r, <- (add_0_r a) at 1. rewrite add_cancel_l. +rewrite eq_sym_iff, eq_mul_0. tauto. +Qed. + +(** As soon as the divisor is strictly greater than 1, + the division is strictly decreasing. *) + +Lemma div_lt : forall a b, 0<a -> 1<b -> a/b < a. +Proof. exact div_lt. Qed. + +(** [le] is compatible with a positive division. *) + +Lemma div_le_mono : forall a b c, 0<c -> a<=b -> a/c <= b/c. +Proof. +intros a b c Hc Hab. +rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ]; + [|rewrite EQ; order]. +rewrite <- lt_succ_r. +rewrite (mul_lt_mono_pos_l c) by order. +nzsimpl. +rewrite (add_lt_mono_r _ _ (a mod c)). +rewrite <- div_mod by order. +apply lt_le_trans with b; trivial. +rewrite (div_mod b c) at 1 by order. +rewrite <- add_assoc, <- add_le_mono_l. +apply le_trans with (c+0). +nzsimpl; destruct (mod_always_pos b c); try order. +rewrite abs_eq in *; order. +rewrite <- add_le_mono_l. destruct (mod_always_pos a c); order. +Qed. + +(** In this convention, [div] performs Rounding-Toward-Bottom + when divisor is positive, and Rounding-Toward-Top otherwise. + + Since we cannot speak of rational values here, we express this + fact by multiplying back by [b], and this leads to a nice + unique statement. +*) + +Lemma mul_div_le : forall a b, b~=0 -> b*(a/b) <= a. +Proof. +intros. +rewrite (div_mod a b) at 2; trivial. +rewrite <- (add_0_r (b*(a/b))) at 1. +rewrite <- add_le_mono_l. +now destruct (mod_always_pos a b). +Qed. + +(** Giving a reversed bound is slightly more complex *) + +Lemma mul_succ_div_gt: forall a b, 0<b -> a < b*(S (a/b)). +Proof. +intros. +nzsimpl. +rewrite (div_mod a b) at 1; try order. +rewrite <- add_lt_mono_l. +destruct (mod_always_pos a b). order. +rewrite abs_eq in *; order. +Qed. + +Lemma mul_pred_div_gt: forall a b, b<0 -> a < b*(P (a/b)). +Proof. +intros a b Hb. +rewrite mul_pred_r, <- add_opp_r. +rewrite (div_mod a b) at 1; try order. +rewrite <- add_lt_mono_l. +destruct (mod_always_pos a b). order. +rewrite <- opp_pos_neg in Hb. rewrite abs_neq' in *; order. +Qed. + +(** NB: The three previous properties could be used as + specifications for [div]. *) + +(** Inequality [mul_div_le] is exact iff the modulo is zero. *) + +Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0). +Proof. +intros. +rewrite (div_mod a b) at 1; try order. +rewrite <- (add_0_r (b*(a/b))) at 2. +apply add_cancel_l. +Qed. + +(** Some additional inequalities about div. *) + +Theorem div_lt_upper_bound: + forall a b q, 0<b -> a < b*q -> a/b < q. +Proof. +intros. +rewrite (mul_lt_mono_pos_l b) by trivial. +apply le_lt_trans with a; trivial. +apply mul_div_le; order. +Qed. + +Theorem div_le_upper_bound: + forall a b q, 0<b -> a <= b*q -> a/b <= q. +Proof. +intros. +rewrite <- (div_mul q b) by order. +apply div_le_mono; trivial. now rewrite mul_comm. +Qed. + +Theorem div_le_lower_bound: + forall a b q, 0<b -> b*q <= a -> q <= a/b. +Proof. +intros. +rewrite <- (div_mul q b) by order. +apply div_le_mono; trivial. now rewrite mul_comm. +Qed. + +(** A division respects opposite monotonicity for the divisor *) + +Lemma div_le_compat_l: forall p q r, 0<=p -> 0<q<=r -> p/r <= p/q. +Proof. exact div_le_compat_l. Qed. + +(** * Relations between usual operations and mod and div *) + +Lemma mod_add : forall a b c, c~=0 -> + (a + b * c) mod c == a mod c. +Proof. +intros. +symmetry. +apply mod_unique with (a/c+b); trivial. +now apply mod_always_pos. +rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. +now rewrite mul_comm. +Qed. + +Lemma div_add : forall a b c, c~=0 -> + (a + b * c) / c == a / c + b. +Proof. +intros. +apply (mul_cancel_l _ _ c); try order. +apply (add_cancel_r _ _ ((a+b*c) mod c)). +rewrite <- div_mod, mod_add by order. +rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. +now rewrite mul_comm. +Qed. + +Lemma div_add_l: forall a b c, b~=0 -> + (a * b + c) / b == a + c / b. +Proof. + intros a b c. rewrite (add_comm _ c), (add_comm a). + now apply div_add. +Qed. + +(** Cancellations. *) + +(** With the current convention, the following isn't always true + when [c<0]: [-3*-1 / -2*-1 = 3/2 = 1] while [-3/-2 = 2] *) + +Lemma div_mul_cancel_r : forall a b c, b~=0 -> 0<c -> + (a*c)/(b*c) == a/b. +Proof. +intros. +symmetry. +apply div_unique with ((a mod b)*c). +(* ineqs *) +rewrite abs_mul, (abs_eq c) by order. +rewrite <-(mul_0_l c), <-mul_lt_mono_pos_r, <-mul_le_mono_pos_r by trivial. +now apply mod_always_pos. +(* equation *) +rewrite (div_mod a b) at 1 by order. +rewrite mul_add_distr_r. +rewrite add_cancel_r. +rewrite <- 2 mul_assoc. now rewrite (mul_comm c). +Qed. + +Lemma div_mul_cancel_l : forall a b c, b~=0 -> 0<c -> + (c*a)/(c*b) == a/b. +Proof. +intros. rewrite !(mul_comm c); now apply div_mul_cancel_r. +Qed. + +Lemma mul_mod_distr_l: forall a b c, b~=0 -> 0<c -> + (c*a) mod (c*b) == c * (a mod b). +Proof. +intros. +rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))). +rewrite <- div_mod. +rewrite div_mul_cancel_l by trivial. +rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. +apply div_mod; order. +rewrite <- neq_mul_0; intuition; order. +Qed. + +Lemma mul_mod_distr_r: forall a b c, b~=0 -> 0<c -> + (a*c) mod (b*c) == (a mod b) * c. +Proof. + intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l. +Qed. + + +(** Operations modulo. *) + +Theorem mod_mod: forall a n, n~=0 -> + (a mod n) mod n == a mod n. +Proof. +intros. rewrite mod_small_iff by trivial. +now apply mod_always_pos. +Qed. + +Lemma mul_mod_idemp_l : forall a b n, n~=0 -> + ((a mod n)*b) mod n == (a*b) mod n. +Proof. + intros a b n Hn. symmetry. + rewrite (div_mod a n) at 1 by order. + rewrite add_comm, (mul_comm n), (mul_comm _ b). + rewrite mul_add_distr_l, mul_assoc. + rewrite mod_add by trivial. + now rewrite mul_comm. +Qed. + +Lemma mul_mod_idemp_r : forall a b n, n~=0 -> + (a*(b mod n)) mod n == (a*b) mod n. +Proof. + intros. rewrite !(mul_comm a). now apply mul_mod_idemp_l. +Qed. + +Theorem mul_mod: forall a b n, n~=0 -> + (a * b) mod n == ((a mod n) * (b mod n)) mod n. +Proof. + intros. now rewrite mul_mod_idemp_l, mul_mod_idemp_r. +Qed. + +Lemma add_mod_idemp_l : forall a b n, n~=0 -> + ((a mod n)+b) mod n == (a+b) mod n. +Proof. + intros a b n Hn. symmetry. + rewrite (div_mod a n) at 1 by order. + rewrite <- add_assoc, add_comm, mul_comm. + now rewrite mod_add. +Qed. + +Lemma add_mod_idemp_r : forall a b n, n~=0 -> + (a+(b mod n)) mod n == (a+b) mod n. +Proof. + intros. rewrite !(add_comm a). now apply add_mod_idemp_l. +Qed. + +Theorem add_mod: forall a b n, n~=0 -> + (a+b) mod n == (a mod n + b mod n) mod n. +Proof. + intros. now rewrite add_mod_idemp_l, add_mod_idemp_r. +Qed. + +(** With the current convention, the following result isn't always + true with a negative intermediate divisor. For instance + [ 3/(-2)/(-2) = 1 <> 0 = 3 / (-2*-2) ] and + [ 3/(-2)/2 = -1 <> 0 = 3 / (-2*2) ]. *) + +Lemma div_div : forall a b c, 0<b -> c~=0 -> + (a/b)/c == a/(b*c). +Proof. + intros a b c Hb Hc. + apply div_unique with (b*((a/b) mod c) + a mod b). + (* begin 0<= ... <abs(b*c) *) + rewrite abs_mul. + destruct (mod_always_pos (a/b) c), (mod_always_pos a b); try order. + split. + apply add_nonneg_nonneg; trivial. + apply mul_nonneg_nonneg; order. + apply lt_le_trans with (b*((a/b) mod c) + abs b). + now rewrite <- add_lt_mono_l. + rewrite (abs_eq b) by order. + now rewrite <- mul_succ_r, <- mul_le_mono_pos_l, le_succ_l. + (* end 0<= ... < abs(b*c) *) + rewrite (div_mod a b) at 1 by order. + rewrite add_assoc, add_cancel_r. + rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. + apply div_mod; order. +Qed. + +(** Similarly, the following result doesn't always hold when [b<0]. + For instance [3 mod (-2*-2)) = 3] while + [3 mod (-2) + (-2)*((3/-2) mod -2) = -1]. *) + +Lemma mod_mul_r : forall a b c, 0<b -> c~=0 -> + a mod (b*c) == a mod b + b*((a/b) mod c). +Proof. + intros a b c Hb Hc. + apply add_cancel_l with (b*c*(a/(b*c))). + rewrite <- div_mod by (apply neq_mul_0; split; order). + rewrite <- div_div by trivial. + rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l. + rewrite <- div_mod by order. + apply div_mod; order. +Qed. + +Lemma mod_div: forall a b, b~=0 -> + a mod b / b == 0. +Proof. + intros a b Hb. + rewrite div_small_iff by assumption. + auto using mod_always_pos. +Qed. + +(** A last inequality: *) + +Theorem div_mul_le: + forall a b c, 0<=a -> 0<b -> 0<=c -> c*(a/b) <= (c*a)/b. +Proof. exact div_mul_le. Qed. + +(** mod is related to divisibility *) + +Lemma mod_divides : forall a b, b~=0 -> + (a mod b == 0 <-> (b|a)). +Proof. +intros a b Hb. split. +intros Hab. exists (a/b). rewrite mul_comm. + rewrite (div_mod a b Hb) at 1. rewrite Hab; now nzsimpl. +intros (c,Hc). rewrite Hc. now apply mod_mul. +Qed. + +End ZEuclidProp. diff --git a/theories/Numbers/Integer/Abstract/ZDivFloor.v b/theories/Numbers/Integer/Abstract/ZDivFloor.v new file mode 100644 index 0000000000..a0d1821b63 --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZDivFloor.v @@ -0,0 +1,669 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import ZAxioms ZMulOrder ZSgnAbs NZDiv. + +(** * Euclidean Division for integers (Floor convention) + + We use here the convention known as Floor, or Round-Toward-Bottom, + where [a/b] is the closest integer below the exact fraction. + It can be summarized by: + + [a = bq+r /\ 0 <= |r| < |b| /\ Sign(r) = Sign(b)] + + This is the convention followed historically by [Z.div] in Coq, and + corresponds to convention "F" in the following paper: + + R. Boute, "The Euclidean definition of the functions div and mod", + ACM Transactions on Programming Languages and Systems, + Vol. 14, No.2, pp. 127-144, April 1992. + + See files [ZDivTrunc] and [ZDivEucl] for others conventions. +*) + +Module Type ZDivProp + (Import A : ZAxiomsSig') + (Import B : ZMulOrderProp A) + (Import C : ZSgnAbsProp A B). + +(** We benefit from what already exists for NZ *) +Module Import Private_NZDiv := Nop <+ NZDivProp A A B. + +(** Another formulation of the main equation *) + +Lemma mod_eq : + forall a b, b~=0 -> a mod b == a - b*(a/b). +Proof. +intros. +rewrite <- add_move_l. +symmetry. now apply div_mod. +Qed. + +(** We have a general bound for absolute values *) + +Lemma mod_bound_abs : + forall a b, b~=0 -> abs (a mod b) < abs b. +Proof. +intros. +destruct (abs_spec b) as [(LE,EQ)|(LE,EQ)]; rewrite EQ. +destruct (mod_pos_bound a b). order. now rewrite abs_eq. +destruct (mod_neg_bound a b). order. rewrite abs_neq; trivial. +now rewrite <- opp_lt_mono. +Qed. + +(** Uniqueness theorems *) + +Theorem div_mod_unique : forall b q1 q2 r1 r2 : t, + (0<=r1<b \/ b<r1<=0) -> (0<=r2<b \/ b<r2<=0) -> + b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. +Proof. +intros b q1 q2 r1 r2 Hr1 Hr2 EQ. +destruct Hr1; destruct Hr2; try (intuition; order). +apply div_mod_unique with b; trivial. +rewrite <- (opp_inj_wd r1 r2). +apply div_mod_unique with (-b); trivial. +rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto. +rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto. +now rewrite 2 mul_opp_l, <- 2 opp_add_distr, opp_inj_wd. +Qed. + +Theorem div_unique: + forall a b q r, (0<=r<b \/ b<r<=0) -> a == b*q + r -> q == a/b. +Proof. +intros a b q r Hr EQ. +assert (Hb : b~=0) by (destruct Hr; intuition; order). +destruct (div_mod_unique b q (a/b) r (a mod b)); trivial. +destruct Hr; [left; apply mod_pos_bound|right; apply mod_neg_bound]; + intuition order. +now rewrite <- div_mod. +Qed. + +Theorem div_unique_pos: + forall a b q r, 0<=r<b -> a == b*q + r -> q == a/b. +Proof. intros; apply div_unique with r; auto. Qed. + +Theorem div_unique_neg: + forall a b q r, b<r<=0 -> a == b*q + r -> q == a/b. +Proof. intros; apply div_unique with r; auto. Qed. + +Theorem mod_unique: + forall a b q r, (0<=r<b \/ b<r<=0) -> a == b*q + r -> r == a mod b. +Proof. +intros a b q r Hr EQ. +assert (Hb : b~=0) by (destruct Hr; intuition; order). +destruct (div_mod_unique b q (a/b) r (a mod b)); trivial. +destruct Hr; [left; apply mod_pos_bound|right; apply mod_neg_bound]; + intuition order. +now rewrite <- div_mod. +Qed. + +Theorem mod_unique_pos: + forall a b q r, 0<=r<b -> a == b*q + r -> r == a mod b. +Proof. intros; apply mod_unique with q; auto. Qed. + +Theorem mod_unique_neg: + forall a b q r, b<r<=0 -> a == b*q + r -> r == a mod b. +Proof. intros; apply mod_unique with q; auto. Qed. + +(** Sign rules *) + +Ltac pos_or_neg a := + let LT := fresh "LT" in + let LE := fresh "LE" in + destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT]. + +Fact mod_bound_or : forall a b, b~=0 -> 0<=a mod b<b \/ b<a mod b<=0. +Proof. +intros. +destruct (lt_ge_cases 0 b); [left|right]. + apply mod_pos_bound; trivial. apply mod_neg_bound; order. +Qed. + +Fact opp_mod_bound_or : forall a b, b~=0 -> + 0 <= -(a mod b) < -b \/ -b < -(a mod b) <= 0. +Proof. +intros. +destruct (lt_ge_cases 0 b); [right|left]. +rewrite <- opp_lt_mono, opp_nonpos_nonneg. + destruct (mod_pos_bound a b); intuition; order. +rewrite <- opp_lt_mono, opp_nonneg_nonpos. + destruct (mod_neg_bound a b); intuition; order. +Qed. + +Lemma div_opp_opp : forall a b, b~=0 -> -a/-b == a/b. +Proof. +intros. symmetry. apply div_unique with (- (a mod b)). +now apply opp_mod_bound_or. +rewrite mul_opp_l, <- opp_add_distr, <- div_mod; order. +Qed. + +Lemma mod_opp_opp : forall a b, b~=0 -> (-a) mod (-b) == - (a mod b). +Proof. +intros. symmetry. apply mod_unique with (a/b). +now apply opp_mod_bound_or. +rewrite mul_opp_l, <- opp_add_distr, <- div_mod; order. +Qed. + +(** With the current conventions, the other sign rules are rather complex. *) + +Lemma div_opp_l_z : + forall a b, b~=0 -> a mod b == 0 -> (-a)/b == -(a/b). +Proof. +intros a b Hb H. symmetry. apply div_unique with 0. +destruct (lt_ge_cases 0 b); [left|right]; intuition; order. +rewrite <- opp_0, <- H. +rewrite mul_opp_r, <- opp_add_distr, <- div_mod; order. +Qed. + +Lemma div_opp_l_nz : + forall a b, b~=0 -> a mod b ~= 0 -> (-a)/b == -(a/b)-1. +Proof. +intros a b Hb H. symmetry. apply div_unique with (b - a mod b). +destruct (lt_ge_cases 0 b); [left|right]. +rewrite le_0_sub. rewrite <- (sub_0_r b) at 5. rewrite <- sub_lt_mono_l. +destruct (mod_pos_bound a b); intuition; order. +rewrite le_sub_0. rewrite <- (sub_0_r b) at 1. rewrite <- sub_lt_mono_l. +destruct (mod_neg_bound a b); intuition; order. +rewrite <- (add_opp_r b), mul_sub_distr_l, mul_1_r, sub_add_simpl_r_l. +rewrite mul_opp_r, <-opp_add_distr, <-div_mod; order. +Qed. + +Lemma mod_opp_l_z : + forall a b, b~=0 -> a mod b == 0 -> (-a) mod b == 0. +Proof. +intros a b Hb H. symmetry. apply mod_unique with (-(a/b)). +destruct (lt_ge_cases 0 b); [left|right]; intuition; order. +rewrite <- opp_0, <- H. +rewrite mul_opp_r, <- opp_add_distr, <- div_mod; order. +Qed. + +Lemma mod_opp_l_nz : + forall a b, b~=0 -> a mod b ~= 0 -> (-a) mod b == b - a mod b. +Proof. +intros a b Hb H. symmetry. apply mod_unique with (-(a/b)-1). +destruct (lt_ge_cases 0 b); [left|right]. +rewrite le_0_sub. rewrite <- (sub_0_r b) at 5. rewrite <- sub_lt_mono_l. +destruct (mod_pos_bound a b); intuition; order. +rewrite le_sub_0. rewrite <- (sub_0_r b) at 1. rewrite <- sub_lt_mono_l. +destruct (mod_neg_bound a b); intuition; order. +rewrite <- (add_opp_r b), mul_sub_distr_l, mul_1_r, sub_add_simpl_r_l. +rewrite mul_opp_r, <-opp_add_distr, <-div_mod; order. +Qed. + +Lemma div_opp_r_z : + forall a b, b~=0 -> a mod b == 0 -> a/(-b) == -(a/b). +Proof. +intros. rewrite <- (opp_involutive a) at 1. +rewrite div_opp_opp; auto using div_opp_l_z. +Qed. + +Lemma div_opp_r_nz : + forall a b, b~=0 -> a mod b ~= 0 -> a/(-b) == -(a/b)-1. +Proof. +intros. rewrite <- (opp_involutive a) at 1. +rewrite div_opp_opp; auto using div_opp_l_nz. +Qed. + +Lemma mod_opp_r_z : + forall a b, b~=0 -> a mod b == 0 -> a mod (-b) == 0. +Proof. +intros. rewrite <- (opp_involutive a) at 1. +now rewrite mod_opp_opp, mod_opp_l_z, opp_0. +Qed. + +Lemma mod_opp_r_nz : + forall a b, b~=0 -> a mod b ~= 0 -> a mod (-b) == (a mod b) - b. +Proof. +intros. rewrite <- (opp_involutive a) at 1. +rewrite mod_opp_opp, mod_opp_l_nz by trivial. +now rewrite opp_sub_distr, add_comm, add_opp_r. +Qed. + +(** The sign of [a mod b] is the one of [b] (when it isn't null) *) + +Lemma mod_sign_nz : forall a b, b~=0 -> a mod b ~= 0 -> + sgn (a mod b) == sgn b. +Proof. +intros a b Hb H. destruct (lt_ge_cases 0 b) as [Hb'|Hb']. +destruct (mod_pos_bound a b Hb'). rewrite 2 sgn_pos; order. +destruct (mod_neg_bound a b). order. rewrite 2 sgn_neg; order. +Qed. + +Lemma mod_sign : forall a b, b~=0 -> sgn (a mod b) ~= -sgn b. +Proof. +intros a b Hb H. +destruct (eq_decidable (a mod b) 0) as [EQ|NEQ]. +apply Hb, sgn_null_iff, opp_inj. now rewrite <- H, opp_0, EQ, sgn_0. +apply Hb, sgn_null_iff. apply eq_mul_0_l with 2; try order'. nzsimpl'. +apply add_move_0_l. rewrite <- H. symmetry. now apply mod_sign_nz. +Qed. + +Lemma mod_sign_mul : forall a b, b~=0 -> 0 <= (a mod b) * b. +Proof. +intros. destruct (lt_ge_cases 0 b). +apply mul_nonneg_nonneg; destruct (mod_pos_bound a b); order. +apply mul_nonpos_nonpos; destruct (mod_neg_bound a b); order. +Qed. + +(** A division by itself returns 1 *) + +Lemma div_same : forall a, a~=0 -> a/a == 1. +Proof. +intros. pos_or_neg a. apply div_same; order. +rewrite <- div_opp_opp by trivial. now apply div_same. +Qed. + +Lemma mod_same : forall a, a~=0 -> a mod a == 0. +Proof. +intros. rewrite mod_eq, div_same by trivial. nzsimpl. apply sub_diag. +Qed. + +(** A division of a small number by a bigger one yields zero. *) + +Theorem div_small: forall a b, 0<=a<b -> a/b == 0. +Proof. exact div_small. Qed. + +(** Same situation, in term of modulo: *) + +Theorem mod_small: forall a b, 0<=a<b -> a mod b == a. +Proof. exact mod_small. Qed. + +(** * Basic values of divisions and modulo. *) + +Lemma div_0_l: forall a, a~=0 -> 0/a == 0. +Proof. +intros. pos_or_neg a. apply div_0_l; order. +rewrite <- div_opp_opp, opp_0 by trivial. now apply div_0_l. +Qed. + +Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0. +Proof. +intros; rewrite mod_eq, div_0_l; now nzsimpl. +Qed. + +Lemma div_1_r: forall a, a/1 == a. +Proof. +intros. symmetry. apply div_unique with 0. left. split; order || apply lt_0_1. +now nzsimpl. +Qed. + +Lemma mod_1_r: forall a, a mod 1 == 0. +Proof. +intros. rewrite mod_eq, div_1_r; nzsimpl; auto using sub_diag. +intro EQ; symmetry in EQ; revert EQ; apply lt_neq; apply lt_0_1. +Qed. + +Lemma div_1_l: forall a, 1<a -> 1/a == 0. +Proof. exact div_1_l. Qed. + +Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1. +Proof. exact mod_1_l. Qed. + +Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a. +Proof. +intros. symmetry. apply div_unique with 0. +destruct (lt_ge_cases 0 b); [left|right]; split; order. +nzsimpl; apply mul_comm. +Qed. + +Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0. +Proof. +intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag. +Qed. + +Theorem div_unique_exact a b q: b~=0 -> a == b*q -> q == a/b. +Proof. + intros Hb H. rewrite H, mul_comm. symmetry. now apply div_mul. +Qed. + +(** * Order results about mod and div *) + +(** A modulo cannot grow beyond its starting point. *) + +Theorem mod_le: forall a b, 0<=a -> 0<b -> a mod b <= a. +Proof. exact mod_le. Qed. + +Theorem div_pos : forall a b, 0<=a -> 0<b -> 0<= a/b. +Proof. exact div_pos. Qed. + +Lemma div_str_pos : forall a b, 0<b<=a -> 0 < a/b. +Proof. exact div_str_pos. Qed. + +Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> 0<=a<b \/ b<a<=0). +Proof. +intros a b Hb. +split. +intros EQ. +rewrite (div_mod a b Hb), EQ; nzsimpl. +now apply mod_bound_or. +destruct 1. now apply div_small. +rewrite <- div_opp_opp by trivial. apply div_small; trivial. +rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto. +Qed. + +Lemma mod_small_iff : forall a b, b~=0 -> (a mod b == a <-> 0<=a<b \/ b<a<=0). +Proof. +intros. +rewrite <- div_small_iff, mod_eq by trivial. +rewrite sub_move_r, <- (add_0_r a) at 1. rewrite add_cancel_l. +rewrite eq_sym_iff, eq_mul_0. tauto. +Qed. + +(** As soon as the divisor is strictly greater than 1, + the division is strictly decreasing. *) + +Lemma div_lt : forall a b, 0<a -> 1<b -> a/b < a. +Proof. exact div_lt. Qed. + +(** [le] is compatible with a positive division. *) + +Lemma div_le_mono : forall a b c, 0<c -> a<=b -> a/c <= b/c. +Proof. +intros a b c Hc Hab. +rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ]; + [|rewrite EQ; order]. +rewrite <- lt_succ_r. +rewrite (mul_lt_mono_pos_l c) by order. +nzsimpl. +rewrite (add_lt_mono_r _ _ (a mod c)). +rewrite <- div_mod by order. +apply lt_le_trans with b; trivial. +rewrite (div_mod b c) at 1 by order. +rewrite <- add_assoc, <- add_le_mono_l. +apply le_trans with (c+0). +nzsimpl; destruct (mod_pos_bound b c); order. +rewrite <- add_le_mono_l. destruct (mod_pos_bound a c); order. +Qed. + +(** In this convention, [div] performs Rounding-Toward-Bottom. + + Since we cannot speak of rational values here, we express this + fact by multiplying back by [b], and this leads to separates + statements according to the sign of [b]. + + First, [a/b] is below the exact fraction ... +*) + +Lemma mul_div_le : forall a b, 0<b -> b*(a/b) <= a. +Proof. +intros. +rewrite (div_mod a b) at 2; try order. +rewrite <- (add_0_r (b*(a/b))) at 1. +rewrite <- add_le_mono_l. +now destruct (mod_pos_bound a b). +Qed. + +Lemma mul_div_ge : forall a b, b<0 -> a <= b*(a/b). +Proof. +intros. rewrite <- div_opp_opp, opp_le_mono, <-mul_opp_l by order. +apply mul_div_le. now rewrite opp_pos_neg. +Qed. + +(** ... and moreover it is the larger such integer, since [S(a/b)] + is strictly above the exact fraction. +*) + +Lemma mul_succ_div_gt: forall a b, 0<b -> a < b*(S (a/b)). +Proof. +intros. +nzsimpl. +rewrite (div_mod a b) at 1; try order. +rewrite <- add_lt_mono_l. +destruct (mod_pos_bound a b); order. +Qed. + +Lemma mul_succ_div_lt: forall a b, b<0 -> b*(S (a/b)) < a. +Proof. +intros. rewrite <- div_opp_opp, opp_lt_mono, <-mul_opp_l by order. +apply mul_succ_div_gt. now rewrite opp_pos_neg. +Qed. + +(** NB: The four previous properties could be used as + specifications for [div]. *) + +(** Inequality [mul_div_le] is exact iff the modulo is zero. *) + +Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0). +Proof. +intros. +rewrite (div_mod a b) at 1; try order. +rewrite <- (add_0_r (b*(a/b))) at 2. +apply add_cancel_l. +Qed. + +(** Some additional inequalities about div. *) + +Theorem div_lt_upper_bound: + forall a b q, 0<b -> a < b*q -> a/b < q. +Proof. +intros. +rewrite (mul_lt_mono_pos_l b) by trivial. +apply le_lt_trans with a; trivial. +now apply mul_div_le. +Qed. + +Theorem div_le_upper_bound: + forall a b q, 0<b -> a <= b*q -> a/b <= q. +Proof. +intros. +rewrite <- (div_mul q b) by order. +apply div_le_mono; trivial. now rewrite mul_comm. +Qed. + +Theorem div_le_lower_bound: + forall a b q, 0<b -> b*q <= a -> q <= a/b. +Proof. +intros. +rewrite <- (div_mul q b) by order. +apply div_le_mono; trivial. now rewrite mul_comm. +Qed. + +(** A division respects opposite monotonicity for the divisor *) + +Lemma div_le_compat_l: forall p q r, 0<=p -> 0<q<=r -> p/r <= p/q. +Proof. exact div_le_compat_l. Qed. + +(** * Relations between usual operations and mod and div *) + +Lemma mod_add : forall a b c, c~=0 -> + (a + b * c) mod c == a mod c. +Proof. +intros. +symmetry. +apply mod_unique with (a/c+b); trivial. +now apply mod_bound_or. +rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. +now rewrite mul_comm. +Qed. + +Lemma div_add : forall a b c, c~=0 -> + (a + b * c) / c == a / c + b. +Proof. +intros. +apply (mul_cancel_l _ _ c); try order. +apply (add_cancel_r _ _ ((a+b*c) mod c)). +rewrite <- div_mod, mod_add by order. +rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. +now rewrite mul_comm. +Qed. + +Lemma div_add_l: forall a b c, b~=0 -> + (a * b + c) / b == a + c / b. +Proof. + intros a b c. rewrite (add_comm _ c), (add_comm a). + now apply div_add. +Qed. + +(** Cancellations. *) + +Lemma div_mul_cancel_r : forall a b c, b~=0 -> c~=0 -> + (a*c)/(b*c) == a/b. +Proof. +intros. +symmetry. +apply div_unique with ((a mod b)*c). +(* ineqs *) +destruct (lt_ge_cases 0 c). +rewrite <-(mul_0_l c), <-2mul_lt_mono_pos_r, <-2mul_le_mono_pos_r by trivial. +now apply mod_bound_or. +rewrite <-(mul_0_l c), <-2mul_lt_mono_neg_r, <-2mul_le_mono_neg_r by order. +destruct (mod_bound_or a b); tauto. +(* equation *) +rewrite (div_mod a b) at 1 by order. +rewrite mul_add_distr_r. +rewrite add_cancel_r. +rewrite <- 2 mul_assoc. now rewrite (mul_comm c). +Qed. + +Lemma div_mul_cancel_l : forall a b c, b~=0 -> c~=0 -> + (c*a)/(c*b) == a/b. +Proof. +intros. rewrite !(mul_comm c); now apply div_mul_cancel_r. +Qed. + +Lemma mul_mod_distr_l: forall a b c, b~=0 -> c~=0 -> + (c*a) mod (c*b) == c * (a mod b). +Proof. +intros. +rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))). +rewrite <- div_mod. +rewrite div_mul_cancel_l by trivial. +rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. +apply div_mod; order. +rewrite <- neq_mul_0; auto. +Qed. + +Lemma mul_mod_distr_r: forall a b c, b~=0 -> c~=0 -> + (a*c) mod (b*c) == (a mod b) * c. +Proof. + intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l. +Qed. + + +(** Operations modulo. *) + +Theorem mod_mod: forall a n, n~=0 -> + (a mod n) mod n == a mod n. +Proof. +intros. rewrite mod_small_iff by trivial. +now apply mod_bound_or. +Qed. + +Lemma mul_mod_idemp_l : forall a b n, n~=0 -> + ((a mod n)*b) mod n == (a*b) mod n. +Proof. + intros a b n Hn. symmetry. + rewrite (div_mod a n) at 1 by order. + rewrite add_comm, (mul_comm n), (mul_comm _ b). + rewrite mul_add_distr_l, mul_assoc. + intros. rewrite mod_add by trivial. + now rewrite mul_comm. +Qed. + +Lemma mul_mod_idemp_r : forall a b n, n~=0 -> + (a*(b mod n)) mod n == (a*b) mod n. +Proof. + intros. rewrite !(mul_comm a). now apply mul_mod_idemp_l. +Qed. + +Theorem mul_mod: forall a b n, n~=0 -> + (a * b) mod n == ((a mod n) * (b mod n)) mod n. +Proof. + intros. now rewrite mul_mod_idemp_l, mul_mod_idemp_r. +Qed. + +Lemma add_mod_idemp_l : forall a b n, n~=0 -> + ((a mod n)+b) mod n == (a+b) mod n. +Proof. + intros a b n Hn. symmetry. + rewrite (div_mod a n) at 1 by order. + rewrite <- add_assoc, add_comm, mul_comm. + intros. now rewrite mod_add. +Qed. + +Lemma add_mod_idemp_r : forall a b n, n~=0 -> + (a+(b mod n)) mod n == (a+b) mod n. +Proof. + intros. rewrite !(add_comm a). now apply add_mod_idemp_l. +Qed. + +Theorem add_mod: forall a b n, n~=0 -> + (a+b) mod n == (a mod n + b mod n) mod n. +Proof. + intros. now rewrite add_mod_idemp_l, add_mod_idemp_r. +Qed. + +(** With the current convention, the following result isn't always + true with a negative last divisor. For instance + [ 3/(-2)/(-2) = 1 <> 0 = 3 / (-2*-2) ], or + [ 5/2/(-2) = -1 <> -2 = 5 / (2*-2) ]. *) + +Lemma div_div : forall a b c, b~=0 -> 0<c -> + (a/b)/c == a/(b*c). +Proof. + intros a b c Hb Hc. + apply div_unique with (b*((a/b) mod c) + a mod b). + (* begin 0<= ... <b*c \/ ... *) + apply neg_pos_cases in Hb. destruct Hb as [Hb|Hb]. + right. + destruct (mod_pos_bound (a/b) c), (mod_neg_bound a b); trivial. + split. + apply le_lt_trans with (b*((a/b) mod c) + b). + now rewrite <- mul_succ_r, <- mul_le_mono_neg_l, le_succ_l. + now rewrite <- add_lt_mono_l. + apply add_nonpos_nonpos; trivial. + apply mul_nonpos_nonneg; order. + left. + destruct (mod_pos_bound (a/b) c), (mod_pos_bound a b); trivial. + split. + apply add_nonneg_nonneg; trivial. + apply mul_nonneg_nonneg; order. + apply lt_le_trans with (b*((a/b) mod c) + b). + now rewrite <- add_lt_mono_l. + now rewrite <- mul_succ_r, <- mul_le_mono_pos_l, le_succ_l. + (* end 0<= ... < b*c \/ ... *) + rewrite (div_mod a b) at 1 by order. + rewrite add_assoc, add_cancel_r. + rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. + apply div_mod; order. +Qed. + +(** Similarly, the following result doesn't always hold when [c<0]. + For instance [3 mod (-2*-2)) = 3] while + [3 mod (-2) + (-2)*((3/-2) mod -2) = -1]. +*) + +Lemma rem_mul_r : forall a b c, b~=0 -> 0<c -> + a mod (b*c) == a mod b + b*((a/b) mod c). +Proof. + intros a b c Hb Hc. + apply add_cancel_l with (b*c*(a/(b*c))). + rewrite <- div_mod by (apply neq_mul_0; split; order). + rewrite <- div_div by trivial. + rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l. + rewrite <- div_mod by order. + apply div_mod; order. +Qed. + +Lemma mod_div: forall a b, b~=0 -> + a mod b / b == 0. +Proof. + intros a b Hb. + rewrite div_small_iff by assumption. + auto using mod_bound_or. +Qed. + +(** A last inequality: *) + +Theorem div_mul_le: + forall a b c, 0<=a -> 0<b -> 0<=c -> c*(a/b) <= (c*a)/b. +Proof. exact div_mul_le. Qed. + +End ZDivProp. diff --git a/theories/Numbers/Integer/Abstract/ZDivTrunc.v b/theories/Numbers/Integer/Abstract/ZDivTrunc.v new file mode 100644 index 0000000000..31e427383d --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZDivTrunc.v @@ -0,0 +1,642 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import ZAxioms ZMulOrder ZSgnAbs NZDiv. + +(** * Euclidean Division for integers (Trunc convention) + + We use here the convention known as Trunc, or Round-Toward-Zero, + where [a/b] is the integer with the largest absolute value to + be between zero and the exact fraction. It can be summarized by: + + [a = bq+r /\ 0 <= |r| < |b| /\ Sign(r) = Sign(a)] + + This is the convention of Ocaml and many other systems (C, ASM, ...). + This convention is named "T" in the following paper: + + R. Boute, "The Euclidean definition of the functions div and mod", + ACM Transactions on Programming Languages and Systems, + Vol. 14, No.2, pp. 127-144, April 1992. + + See files [ZDivFloor] and [ZDivEucl] for others conventions. +*) + +Module Type ZQuotProp + (Import A : ZAxiomsSig') + (Import B : ZMulOrderProp A) + (Import C : ZSgnAbsProp A B). + +(** We benefit from what already exists for NZ *) + + Module Import Private_Div. + Module Quot2Div <: NZDiv A. + Definition div := quot. + Definition modulo := A.rem. + Definition div_wd := quot_wd. + Definition mod_wd := rem_wd. + Definition div_mod := quot_rem. + Definition mod_bound_pos := rem_bound_pos. + End Quot2Div. + Module NZQuot := Nop <+ NZDivProp A Quot2Div B. + End Private_Div. + +Ltac pos_or_neg a := + let LT := fresh "LT" in + let LE := fresh "LE" in + destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT]. + +(** Another formulation of the main equation *) + +Lemma rem_eq : + forall a b, b~=0 -> a rem b == a - b*(a÷b). +Proof. +intros. +rewrite <- add_move_l. +symmetry. now apply quot_rem. +Qed. + +(** A few sign rules (simple ones) *) + +Lemma rem_opp_opp : forall a b, b ~= 0 -> (-a) rem (-b) == - (a rem b). +Proof. intros. now rewrite rem_opp_r, rem_opp_l. Qed. + +Lemma quot_opp_l : forall a b, b ~= 0 -> (-a)÷b == -(a÷b). +Proof. +intros. +rewrite <- (mul_cancel_l _ _ b) by trivial. +rewrite <- (add_cancel_r _ _ ((-a) rem b)). +now rewrite <- quot_rem, rem_opp_l, mul_opp_r, <- opp_add_distr, <- quot_rem. +Qed. + +Lemma quot_opp_r : forall a b, b ~= 0 -> a÷(-b) == -(a÷b). +Proof. +intros. +assert (-b ~= 0) by (now rewrite eq_opp_l, opp_0). +rewrite <- (mul_cancel_l _ _ (-b)) by trivial. +rewrite <- (add_cancel_r _ _ (a rem (-b))). +now rewrite <- quot_rem, rem_opp_r, mul_opp_opp, <- quot_rem. +Qed. + +Lemma quot_opp_opp : forall a b, b ~= 0 -> (-a)÷(-b) == a÷b. +Proof. intros. now rewrite quot_opp_r, quot_opp_l, opp_involutive. Qed. + +(** Uniqueness theorems *) + +Theorem quot_rem_unique : forall b q1 q2 r1 r2 : t, + (0<=r1<b \/ b<r1<=0) -> (0<=r2<b \/ b<r2<=0) -> + b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. +Proof. +intros b q1 q2 r1 r2 Hr1 Hr2 EQ. +destruct Hr1; destruct Hr2; try (intuition; order). +apply NZQuot.div_mod_unique with b; trivial. +rewrite <- (opp_inj_wd r1 r2). +apply NZQuot.div_mod_unique with (-b); trivial. +rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto. +rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto. +now rewrite 2 mul_opp_l, <- 2 opp_add_distr, opp_inj_wd. +Qed. + +Theorem quot_unique: + forall a b q r, 0<=a -> 0<=r<b -> a == b*q + r -> q == a÷b. +Proof. intros; now apply NZQuot.div_unique with r. Qed. + +Theorem rem_unique: + forall a b q r, 0<=a -> 0<=r<b -> a == b*q + r -> r == a rem b. +Proof. intros; now apply NZQuot.mod_unique with q. Qed. + +(** A division by itself returns 1 *) + +Lemma quot_same : forall a, a~=0 -> a÷a == 1. +Proof. +intros. pos_or_neg a. apply NZQuot.div_same; order. +rewrite <- quot_opp_opp by trivial. now apply NZQuot.div_same. +Qed. + +Lemma rem_same : forall a, a~=0 -> a rem a == 0. +Proof. +intros. rewrite rem_eq, quot_same by trivial. nzsimpl. apply sub_diag. +Qed. + +(** A division of a small number by a bigger one yields zero. *) + +Theorem quot_small: forall a b, 0<=a<b -> a÷b == 0. +Proof. exact NZQuot.div_small. Qed. + +(** Same situation, in term of remulo: *) + +Theorem rem_small: forall a b, 0<=a<b -> a rem b == a. +Proof. exact NZQuot.mod_small. Qed. + +(** * Basic values of divisions and modulo. *) + +Lemma quot_0_l: forall a, a~=0 -> 0÷a == 0. +Proof. +intros. pos_or_neg a. apply NZQuot.div_0_l; order. +rewrite <- quot_opp_opp, opp_0 by trivial. now apply NZQuot.div_0_l. +Qed. + +Lemma rem_0_l: forall a, a~=0 -> 0 rem a == 0. +Proof. +intros; rewrite rem_eq, quot_0_l; now nzsimpl. +Qed. + +Lemma quot_1_r: forall a, a÷1 == a. +Proof. +intros. pos_or_neg a. now apply NZQuot.div_1_r. +apply opp_inj. rewrite <- quot_opp_l. apply NZQuot.div_1_r; order. +intro EQ; symmetry in EQ; revert EQ; apply lt_neq, lt_0_1. +Qed. + +Lemma rem_1_r: forall a, a rem 1 == 0. +Proof. +intros. rewrite rem_eq, quot_1_r; nzsimpl; auto using sub_diag. +intro EQ; symmetry in EQ; revert EQ; apply lt_neq; apply lt_0_1. +Qed. + +Lemma quot_1_l: forall a, 1<a -> 1÷a == 0. +Proof. exact NZQuot.div_1_l. Qed. + +Lemma rem_1_l: forall a, 1<a -> 1 rem a == 1. +Proof. exact NZQuot.mod_1_l. Qed. + +Lemma quot_mul : forall a b, b~=0 -> (a*b)÷b == a. +Proof. +intros. pos_or_neg a; pos_or_neg b. apply NZQuot.div_mul; order. +rewrite <- quot_opp_opp, <- mul_opp_r by order. apply NZQuot.div_mul; order. +rewrite <- opp_inj_wd, <- quot_opp_l, <- mul_opp_l by order. +apply NZQuot.div_mul; order. +rewrite <- opp_inj_wd, <- quot_opp_r, <- mul_opp_opp by order. +apply NZQuot.div_mul; order. +Qed. + +Lemma rem_mul : forall a b, b~=0 -> (a*b) rem b == 0. +Proof. +intros. rewrite rem_eq, quot_mul by trivial. rewrite mul_comm; apply sub_diag. +Qed. + +Theorem quot_unique_exact a b q: b~=0 -> a == b*q -> q == a÷b. +Proof. + intros Hb H. rewrite H, mul_comm. symmetry. now apply quot_mul. +Qed. + +(** The sign of [a rem b] is the one of [a] (when it's not null) *) + +Lemma rem_nonneg : forall a b, b~=0 -> 0 <= a -> 0 <= a rem b. +Proof. + intros. pos_or_neg b. destruct (rem_bound_pos a b); order. + rewrite <- rem_opp_r; trivial. + destruct (rem_bound_pos a (-b)); trivial. +Qed. + +Lemma rem_nonpos : forall a b, b~=0 -> a <= 0 -> a rem b <= 0. +Proof. + intros a b Hb Ha. + apply opp_nonneg_nonpos. apply opp_nonneg_nonpos in Ha. + rewrite <- rem_opp_l by trivial. now apply rem_nonneg. +Qed. + +Lemma rem_sign_mul : forall a b, b~=0 -> 0 <= (a rem b) * a. +Proof. +intros a b Hb. destruct (le_ge_cases 0 a). + apply mul_nonneg_nonneg; trivial. now apply rem_nonneg. + apply mul_nonpos_nonpos; trivial. now apply rem_nonpos. +Qed. + +Lemma rem_sign_nz : forall a b, b~=0 -> a rem b ~= 0 -> + sgn (a rem b) == sgn a. +Proof. +intros a b Hb H. destruct (lt_trichotomy 0 a) as [LT|[EQ|LT]]. +rewrite 2 sgn_pos; try easy. + generalize (rem_nonneg a b Hb (lt_le_incl _ _ LT)). order. +now rewrite <- EQ, rem_0_l, sgn_0. +rewrite 2 sgn_neg; try easy. + generalize (rem_nonpos a b Hb (lt_le_incl _ _ LT)). order. +Qed. + +Lemma rem_sign : forall a b, a~=0 -> b~=0 -> sgn (a rem b) ~= -sgn a. +Proof. +intros a b Ha Hb H. +destruct (eq_decidable (a rem b) 0) as [EQ|NEQ]. +apply Ha, sgn_null_iff, opp_inj. now rewrite <- H, opp_0, EQ, sgn_0. +apply Ha, sgn_null_iff. apply eq_mul_0_l with 2; try order'. nzsimpl'. +apply add_move_0_l. rewrite <- H. symmetry. now apply rem_sign_nz. +Qed. + +(** Operations and absolute value *) + +Lemma rem_abs_l : forall a b, b ~= 0 -> (abs a) rem b == abs (a rem b). +Proof. +intros a b Hb. destruct (le_ge_cases 0 a) as [LE|LE]. +rewrite 2 abs_eq; try easy. now apply rem_nonneg. +rewrite 2 abs_neq, rem_opp_l; try easy. now apply rem_nonpos. +Qed. + +Lemma rem_abs_r : forall a b, b ~= 0 -> a rem (abs b) == a rem b. +Proof. +intros a b Hb. destruct (le_ge_cases 0 b). +now rewrite abs_eq. now rewrite abs_neq, ?rem_opp_r. +Qed. + +Lemma rem_abs : forall a b, b ~= 0 -> (abs a) rem (abs b) == abs (a rem b). +Proof. +intros. now rewrite rem_abs_r, rem_abs_l. +Qed. + +Lemma quot_abs_l : forall a b, b ~= 0 -> (abs a)÷b == (sgn a)*(a÷b). +Proof. +intros a b Hb. destruct (lt_trichotomy 0 a) as [LT|[EQ|LT]]. +rewrite abs_eq, sgn_pos by order. now nzsimpl. +rewrite <- EQ, abs_0, quot_0_l; trivial. now nzsimpl. +rewrite abs_neq, quot_opp_l, sgn_neg by order. + rewrite mul_opp_l. now nzsimpl. +Qed. + +Lemma quot_abs_r : forall a b, b ~= 0 -> a÷(abs b) == (sgn b)*(a÷b). +Proof. +intros a b Hb. destruct (lt_trichotomy 0 b) as [LT|[EQ|LT]]. +rewrite abs_eq, sgn_pos by order. now nzsimpl. +order. +rewrite abs_neq, quot_opp_r, sgn_neg by order. + rewrite mul_opp_l. now nzsimpl. +Qed. + +Lemma quot_abs : forall a b, b ~= 0 -> (abs a)÷(abs b) == abs (a÷b). +Proof. +intros a b Hb. +pos_or_neg a; [rewrite (abs_eq a)|rewrite (abs_neq a)]; + try apply opp_nonneg_nonpos; try order. +pos_or_neg b; [rewrite (abs_eq b)|rewrite (abs_neq b)]; + try apply opp_nonneg_nonpos; try order. +rewrite abs_eq; try easy. apply NZQuot.div_pos; order. +rewrite <- abs_opp, <- quot_opp_r, abs_eq; try easy. + apply NZQuot.div_pos; order. +pos_or_neg b; [rewrite (abs_eq b)|rewrite (abs_neq b)]; + try apply opp_nonneg_nonpos; try order. +rewrite <- (abs_opp (_÷_)), <- quot_opp_l, abs_eq; try easy. + apply NZQuot.div_pos; order. +rewrite <- (quot_opp_opp a b), abs_eq; try easy. + apply NZQuot.div_pos; order. +Qed. + +(** We have a general bound for absolute values *) + +Lemma rem_bound_abs : + forall a b, b~=0 -> abs (a rem b) < abs b. +Proof. +intros. rewrite <- rem_abs; trivial. +apply rem_bound_pos. apply abs_nonneg. now apply abs_pos. +Qed. + +(** * Order results about rem and quot *) + +(** A modulo cannot grow beyond its starting point. *) + +Theorem rem_le: forall a b, 0<=a -> 0<b -> a rem b <= a. +Proof. exact NZQuot.mod_le. Qed. + +Theorem quot_pos : forall a b, 0<=a -> 0<b -> 0<= a÷b. +Proof. exact NZQuot.div_pos. Qed. + +Lemma quot_str_pos : forall a b, 0<b<=a -> 0 < a÷b. +Proof. exact NZQuot.div_str_pos. Qed. + +Lemma quot_small_iff : forall a b, b~=0 -> (a÷b==0 <-> abs a < abs b). +Proof. +intros. pos_or_neg a; pos_or_neg b. +rewrite NZQuot.div_small_iff; try order. rewrite 2 abs_eq; intuition; order. +rewrite <- opp_inj_wd, opp_0, <- quot_opp_r, NZQuot.div_small_iff by order. + rewrite (abs_eq a), (abs_neq' b); intuition; order. +rewrite <- opp_inj_wd, opp_0, <- quot_opp_l, NZQuot.div_small_iff by order. + rewrite (abs_neq' a), (abs_eq b); intuition; order. +rewrite <- quot_opp_opp, NZQuot.div_small_iff by order. + rewrite (abs_neq' a), (abs_neq' b); intuition; order. +Qed. + +Lemma rem_small_iff : forall a b, b~=0 -> (a rem b == a <-> abs a < abs b). +Proof. +intros. rewrite rem_eq, <- quot_small_iff by order. +rewrite sub_move_r, <- (add_0_r a) at 1. rewrite add_cancel_l. +rewrite eq_sym_iff, eq_mul_0. tauto. +Qed. + +(** As soon as the divisor is strictly greater than 1, + the division is strictly decreasing. *) + +Lemma quot_lt : forall a b, 0<a -> 1<b -> a÷b < a. +Proof. exact NZQuot.div_lt. Qed. + +(** [le] is compatible with a positive division. *) + +Lemma quot_le_mono : forall a b c, 0<c -> a<=b -> a÷c <= b÷c. +Proof. +intros. pos_or_neg a. apply NZQuot.div_le_mono; auto. +pos_or_neg b. apply le_trans with 0. + rewrite <- opp_nonneg_nonpos, <- quot_opp_l by order. + apply quot_pos; order. + apply quot_pos; order. +rewrite opp_le_mono in *. rewrite <- 2 quot_opp_l by order. + apply NZQuot.div_le_mono; intuition; order. +Qed. + +(** With this choice of division, + rounding of quot is always done toward zero: *) + +Lemma mul_quot_le : forall a b, 0<=a -> b~=0 -> 0 <= b*(a÷b) <= a. +Proof. +intros. pos_or_neg b. +split. +apply mul_nonneg_nonneg; [|apply quot_pos]; order. +apply NZQuot.mul_div_le; order. +rewrite <- mul_opp_opp, <- quot_opp_r by order. +split. +apply mul_nonneg_nonneg; [|apply quot_pos]; order. +apply NZQuot.mul_div_le; order. +Qed. + +Lemma mul_quot_ge : forall a b, a<=0 -> b~=0 -> a <= b*(a÷b) <= 0. +Proof. +intros. +rewrite <- opp_nonneg_nonpos, opp_le_mono, <-mul_opp_r, <-quot_opp_l by order. +rewrite <- opp_nonneg_nonpos in *. +destruct (mul_quot_le (-a) b); tauto. +Qed. + +(** For positive numbers, considering [S (a÷b)] leads to an upper bound for [a] *) + +Lemma mul_succ_quot_gt: forall a b, 0<=a -> 0<b -> a < b*(S (a÷b)). +Proof. exact NZQuot.mul_succ_div_gt. Qed. + +(** Similar results with negative numbers *) + +Lemma mul_pred_quot_lt: forall a b, a<=0 -> 0<b -> b*(P (a÷b)) < a. +Proof. +intros. +rewrite opp_lt_mono, <- mul_opp_r, opp_pred, <- quot_opp_l by order. +rewrite <- opp_nonneg_nonpos in *. +now apply mul_succ_quot_gt. +Qed. + +Lemma mul_pred_quot_gt: forall a b, 0<=a -> b<0 -> a < b*(P (a÷b)). +Proof. +intros. +rewrite <- mul_opp_opp, opp_pred, <- quot_opp_r by order. +rewrite <- opp_pos_neg in *. +now apply mul_succ_quot_gt. +Qed. + +Lemma mul_succ_quot_lt: forall a b, a<=0 -> b<0 -> b*(S (a÷b)) < a. +Proof. +intros. +rewrite opp_lt_mono, <- mul_opp_l, <- quot_opp_opp by order. +rewrite <- opp_nonneg_nonpos, <- opp_pos_neg in *. +now apply mul_succ_quot_gt. +Qed. + +(** Inequality [mul_quot_le] is exact iff the modulo is zero. *) + +Lemma quot_exact : forall a b, b~=0 -> (a == b*(a÷b) <-> a rem b == 0). +Proof. +intros. rewrite rem_eq by order. rewrite sub_move_r; nzsimpl; tauto. +Qed. + +(** Some additional inequalities about quot. *) + +Theorem quot_lt_upper_bound: + forall a b q, 0<=a -> 0<b -> a < b*q -> a÷b < q. +Proof. exact NZQuot.div_lt_upper_bound. Qed. + +Theorem quot_le_upper_bound: + forall a b q, 0<b -> a <= b*q -> a÷b <= q. +Proof. +intros. +rewrite <- (quot_mul q b) by order. +apply quot_le_mono; trivial. now rewrite mul_comm. +Qed. + +Theorem quot_le_lower_bound: + forall a b q, 0<b -> b*q <= a -> q <= a÷b. +Proof. +intros. +rewrite <- (quot_mul q b) by order. +apply quot_le_mono; trivial. now rewrite mul_comm. +Qed. + +(** A division respects opposite monotonicity for the divisor *) + +Lemma quot_le_compat_l: forall p q r, 0<=p -> 0<q<=r -> p÷r <= p÷q. +Proof. exact NZQuot.div_le_compat_l. Qed. + +(** * Relations between usual operations and rem and quot *) + +(** Unlike with other division conventions, some results here aren't + always valid, and need to be restricted. For instance + [(a+b*c) rem c <> a rem c] for [a=9,b=-5,c=2] *) + +Lemma rem_add : forall a b c, c~=0 -> 0 <= (a+b*c)*a -> + (a + b * c) rem c == a rem c. +Proof. +assert (forall a b c, c~=0 -> 0<=a -> 0<=a+b*c -> (a+b*c) rem c == a rem c). + intros. pos_or_neg c. apply NZQuot.mod_add; order. + rewrite <- (rem_opp_r a), <- (rem_opp_r (a+b*c)) by order. + rewrite <- mul_opp_opp in *. + apply NZQuot.mod_add; order. +intros a b c Hc Habc. +destruct (le_0_mul _ _ Habc) as [(Habc',Ha)|(Habc',Ha)]. auto. +apply opp_inj. revert Ha Habc'. +rewrite <- 2 opp_nonneg_nonpos. +rewrite <- 2 rem_opp_l, opp_add_distr, <- mul_opp_l by order. auto. +Qed. + +Lemma quot_add : forall a b c, c~=0 -> 0 <= (a+b*c)*a -> + (a + b * c) ÷ c == a ÷ c + b. +Proof. +intros. +rewrite <- (mul_cancel_l _ _ c) by trivial. +rewrite <- (add_cancel_r _ _ ((a+b*c) rem c)). +rewrite <- quot_rem, rem_add by trivial. +now rewrite mul_add_distr_l, add_shuffle0, <-quot_rem, mul_comm. +Qed. + +Lemma quot_add_l: forall a b c, b~=0 -> 0 <= (a*b+c)*c -> + (a * b + c) ÷ b == a + c ÷ b. +Proof. + intros a b c. rewrite add_comm, (add_comm a). now apply quot_add. +Qed. + +(** Cancellations. *) + +Lemma quot_mul_cancel_r : forall a b c, b~=0 -> c~=0 -> + (a*c)÷(b*c) == a÷b. +Proof. +assert (Aux1 : forall a b c, 0<=a -> 0<b -> c~=0 -> (a*c)÷(b*c) == a÷b). + intros. pos_or_neg c. apply NZQuot.div_mul_cancel_r; order. + rewrite <- quot_opp_opp, <- 2 mul_opp_r. apply NZQuot.div_mul_cancel_r; order. + rewrite <- neq_mul_0; intuition order. +assert (Aux2 : forall a b c, 0<=a -> b~=0 -> c~=0 -> (a*c)÷(b*c) == a÷b). + intros. pos_or_neg b. apply Aux1; order. + apply opp_inj. rewrite <- 2 quot_opp_r, <- mul_opp_l; try order. apply Aux1; order. + rewrite <- neq_mul_0; intuition order. +intros. pos_or_neg a. apply Aux2; order. +apply opp_inj. rewrite <- 2 quot_opp_l, <- mul_opp_l; try order. apply Aux2; order. +rewrite <- neq_mul_0; intuition order. +Qed. + +Lemma quot_mul_cancel_l : forall a b c, b~=0 -> c~=0 -> + (c*a)÷(c*b) == a÷b. +Proof. +intros. rewrite !(mul_comm c); now apply quot_mul_cancel_r. +Qed. + +Lemma mul_rem_distr_r: forall a b c, b~=0 -> c~=0 -> + (a*c) rem (b*c) == (a rem b) * c. +Proof. +intros. +assert (b*c ~= 0) by (rewrite <- neq_mul_0; tauto). +rewrite ! rem_eq by trivial. +rewrite quot_mul_cancel_r by order. +now rewrite mul_sub_distr_r, <- !mul_assoc, (mul_comm (a÷b) c). +Qed. + +Lemma mul_rem_distr_l: forall a b c, b~=0 -> c~=0 -> + (c*a) rem (c*b) == c * (a rem b). +Proof. +intros; rewrite !(mul_comm c); now apply mul_rem_distr_r. +Qed. + +(** Operations modulo. *) + +Theorem rem_rem: forall a n, n~=0 -> + (a rem n) rem n == a rem n. +Proof. +intros. pos_or_neg a; pos_or_neg n. apply NZQuot.mod_mod; order. +rewrite <- ! (rem_opp_r _ n) by trivial. apply NZQuot.mod_mod; order. +apply opp_inj. rewrite <- !rem_opp_l by order. apply NZQuot.mod_mod; order. +apply opp_inj. rewrite <- !rem_opp_opp by order. apply NZQuot.mod_mod; order. +Qed. + +Lemma mul_rem_idemp_l : forall a b n, n~=0 -> + ((a rem n)*b) rem n == (a*b) rem n. +Proof. +assert (Aux1 : forall a b n, 0<=a -> 0<=b -> n~=0 -> + ((a rem n)*b) rem n == (a*b) rem n). + intros. pos_or_neg n. apply NZQuot.mul_mod_idemp_l; order. + rewrite <- ! (rem_opp_r _ n) by order. apply NZQuot.mul_mod_idemp_l; order. +assert (Aux2 : forall a b n, 0<=a -> n~=0 -> + ((a rem n)*b) rem n == (a*b) rem n). + intros. pos_or_neg b. now apply Aux1. + apply opp_inj. rewrite <-2 rem_opp_l, <-2 mul_opp_r by order. + apply Aux1; order. +intros a b n Hn. pos_or_neg a. now apply Aux2. +apply opp_inj. rewrite <-2 rem_opp_l, <-2 mul_opp_l, <-rem_opp_l by order. +apply Aux2; order. +Qed. + +Lemma mul_rem_idemp_r : forall a b n, n~=0 -> + (a*(b rem n)) rem n == (a*b) rem n. +Proof. +intros. rewrite !(mul_comm a). now apply mul_rem_idemp_l. +Qed. + +Theorem mul_rem: forall a b n, n~=0 -> + (a * b) rem n == ((a rem n) * (b rem n)) rem n. +Proof. +intros. now rewrite mul_rem_idemp_l, mul_rem_idemp_r. +Qed. + +(** addition and modulo + + Generally speaking, unlike with other conventions, 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. +*) + +Lemma add_rem_idemp_l : forall a b n, n~=0 -> 0 <= a*b -> + ((a rem n)+b) rem n == (a+b) rem n. +Proof. +assert (Aux : forall a b n, 0<=a -> 0<=b -> n~=0 -> + ((a rem n)+b) rem n == (a+b) rem n). + intros. pos_or_neg n. apply NZQuot.add_mod_idemp_l; order. + rewrite <- ! (rem_opp_r _ n) by order. apply NZQuot.add_mod_idemp_l; order. +intros a b n Hn Hab. destruct (le_0_mul _ _ Hab) as [(Ha,Hb)|(Ha,Hb)]. +now apply Aux. +apply opp_inj. rewrite <-2 rem_opp_l, 2 opp_add_distr, <-rem_opp_l by order. +rewrite <- opp_nonneg_nonpos in *. +now apply Aux. +Qed. + +Lemma add_rem_idemp_r : forall a b n, n~=0 -> 0 <= a*b -> + (a+(b rem n)) rem n == (a+b) rem n. +Proof. +intros. rewrite !(add_comm a). apply add_rem_idemp_l; trivial. +now rewrite mul_comm. +Qed. + +Theorem add_rem: forall a b n, n~=0 -> 0 <= a*b -> + (a+b) rem n == (a rem n + b rem n) rem n. +Proof. +intros a b n Hn Hab. rewrite add_rem_idemp_l, add_rem_idemp_r; trivial. +reflexivity. +destruct (le_0_mul _ _ Hab) as [(Ha,Hb)|(Ha,Hb)]; + destruct (le_0_mul _ _ (rem_sign_mul b n Hn)) as [(Hb',Hm)|(Hb',Hm)]; + auto using mul_nonneg_nonneg, mul_nonpos_nonpos. + setoid_replace b with 0 by order. rewrite rem_0_l by order. nzsimpl; order. + setoid_replace b with 0 by order. rewrite rem_0_l by order. nzsimpl; order. +Qed. + +(** Conversely, the following results need less restrictions here. *) + +Lemma quot_quot : forall a b c, b~=0 -> c~=0 -> + (a÷b)÷c == a÷(b*c). +Proof. +assert (Aux1 : forall a b c, 0<=a -> 0<b -> c~=0 -> (a÷b)÷c == a÷(b*c)). + intros. pos_or_neg c. apply NZQuot.div_div; order. + apply opp_inj. rewrite <- 2 quot_opp_r, <- mul_opp_r; trivial. + apply NZQuot.div_div; order. + rewrite <- neq_mul_0; intuition order. +assert (Aux2 : forall a b c, 0<=a -> b~=0 -> c~=0 -> (a÷b)÷c == a÷(b*c)). + intros. pos_or_neg b. apply Aux1; order. + apply opp_inj. rewrite <- quot_opp_l, <- 2 quot_opp_r, <- mul_opp_l; trivial. + apply Aux1; trivial. + rewrite <- neq_mul_0; intuition order. +intros. pos_or_neg a. apply Aux2; order. +apply opp_inj. rewrite <- 3 quot_opp_l; try order. apply Aux2; order. +rewrite <- neq_mul_0. tauto. +Qed. + +Lemma mod_mul_r : forall a b c, b~=0 -> c~=0 -> + a rem (b*c) == a rem b + b*((a÷b) rem c). +Proof. + intros a b c Hb Hc. + apply add_cancel_l with (b*c*(a÷(b*c))). + rewrite <- quot_rem by (apply neq_mul_0; split; order). + rewrite <- quot_quot by trivial. + rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l. + rewrite <- quot_rem by order. + apply quot_rem; order. +Qed. + +Lemma rem_quot: forall a b, b~=0 -> + a rem b ÷ b == 0. +Proof. + intros a b Hb. + rewrite quot_small_iff by assumption. + auto using rem_bound_abs. +Qed. + +(** A last inequality: *) + +Theorem quot_mul_le: + forall a b c, 0<=a -> 0<b -> 0<=c -> c*(a÷b) <= (c*a)÷b. +Proof. exact NZQuot.div_mul_le. Qed. + +End ZQuotProp. + diff --git a/theories/Numbers/Integer/Abstract/ZGcd.v b/theories/Numbers/Integer/Abstract/ZGcd.v new file mode 100644 index 0000000000..f0b7bf9d25 --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZGcd.v @@ -0,0 +1,276 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Properties of the greatest common divisor *) + +Require Import ZAxioms ZMulOrder ZSgnAbs NZGcd. + +Module Type ZGcdProp + (Import A : ZAxiomsSig') + (Import B : ZMulOrderProp A) + (Import C : ZSgnAbsProp A B). + + Include NZGcdProp A A B. + +(** Results concerning divisibility*) + +Lemma divide_opp_l : forall n m, (-n | m) <-> (n | m). +Proof. + intros n m. split; intros (p,Hp); exists (-p); rewrite Hp. + now rewrite mul_opp_l, mul_opp_r. + now rewrite mul_opp_opp. +Qed. + +Lemma divide_opp_r : forall n m, (n | -m) <-> (n | m). +Proof. + intros n m. split; intros (p,Hp); exists (-p). + now rewrite mul_opp_l, <- Hp, opp_involutive. + now rewrite Hp, mul_opp_l. +Qed. + +Lemma divide_abs_l : forall n m, (abs n | m) <-> (n | m). +Proof. + intros n m. destruct (abs_eq_or_opp n) as [H|H]; rewrite H. + easy. apply divide_opp_l. +Qed. + +Lemma divide_abs_r : forall n m, (n | abs m) <-> (n | m). +Proof. + intros n m. destruct (abs_eq_or_opp m) as [H|H]; rewrite H. + easy. apply divide_opp_r. +Qed. + +Lemma divide_1_r_abs : forall n, (n | 1) -> abs n == 1. +Proof. + intros n Hn. apply divide_1_r_nonneg. apply abs_nonneg. + now apply divide_abs_l. +Qed. + +Lemma divide_1_r : forall n, (n | 1) -> n==1 \/ n==-1. +Proof. + intros n (m,H). rewrite mul_comm in H. now apply eq_mul_1 with m. +Qed. + +Lemma divide_antisym_abs : forall n m, + (n | m) -> (m | n) -> abs n == abs m. +Proof. + intros. apply divide_antisym_nonneg; try apply abs_nonneg. + now apply divide_abs_l, divide_abs_r. + now apply divide_abs_l, divide_abs_r. +Qed. + +Lemma divide_antisym : forall n m, + (n | m) -> (m | n) -> n == m \/ n == -m. +Proof. + intros. now apply abs_eq_cases, divide_antisym_abs. +Qed. + +Lemma divide_sub_r : forall n m p, (n | m) -> (n | p) -> (n | m - p). +Proof. + intros n m p H H'. rewrite <- add_opp_r. + apply divide_add_r; trivial. now apply divide_opp_r. +Qed. + +Lemma divide_add_cancel_r : forall n m p, (n | m) -> (n | m + p) -> (n | p). +Proof. + intros n m p H H'. rewrite <- (add_simpl_l m p). now apply divide_sub_r. +Qed. + +(** Properties of gcd *) + +Lemma gcd_opp_l : forall n m, gcd (-n) m == gcd n m. +Proof. + intros. apply gcd_unique_alt; try apply gcd_nonneg. + intros. rewrite divide_opp_r. apply gcd_divide_iff. +Qed. + +Lemma gcd_opp_r : forall n m, gcd n (-m) == gcd n m. +Proof. + intros. now rewrite gcd_comm, gcd_opp_l, gcd_comm. +Qed. + +Lemma gcd_abs_l : forall n m, gcd (abs n) m == gcd n m. +Proof. + intros. destruct (abs_eq_or_opp n) as [H|H]; rewrite H. + easy. apply gcd_opp_l. +Qed. + +Lemma gcd_abs_r : forall n m, gcd n (abs m) == gcd n m. +Proof. + intros. now rewrite gcd_comm, gcd_abs_l, gcd_comm. +Qed. + +Lemma gcd_0_l : forall n, gcd 0 n == abs n. +Proof. + intros. rewrite <- gcd_abs_r. apply gcd_0_l_nonneg, abs_nonneg. +Qed. + +Lemma gcd_0_r : forall n, gcd n 0 == abs n. +Proof. + intros. now rewrite gcd_comm, gcd_0_l. +Qed. + +Lemma gcd_diag : forall n, gcd n n == abs n. +Proof. + intros. rewrite <- gcd_abs_l, <- gcd_abs_r. + apply gcd_diag_nonneg, abs_nonneg. +Qed. + +Lemma gcd_add_mult_diag_r : forall n m p, gcd n (m+p*n) == gcd n m. +Proof. + intros. apply gcd_unique_alt; try apply gcd_nonneg. + intros. rewrite gcd_divide_iff. split; intros (U,V); split; trivial. + apply divide_add_r; trivial. now apply divide_mul_r. + apply divide_add_cancel_r with (p*n); trivial. + now apply divide_mul_r. now rewrite add_comm. +Qed. + +Lemma gcd_add_diag_r : forall n m, gcd n (m+n) == gcd n m. +Proof. + intros n m. rewrite <- (mul_1_l n) at 2. apply gcd_add_mult_diag_r. +Qed. + +Lemma gcd_sub_diag_r : forall n m, gcd n (m-n) == gcd n m. +Proof. + intros n m. rewrite <- (mul_1_l n) at 2. + rewrite <- add_opp_r, <- mul_opp_l. apply gcd_add_mult_diag_r. +Qed. + +Definition Bezout n m p := exists a b, a*n + b*m == p. + +Instance Bezout_wd : Proper (eq==>eq==>eq==>iff) Bezout. +Proof. + unfold Bezout. intros x x' Hx y y' Hy z z' Hz. + setoid_rewrite Hx. setoid_rewrite Hy. now setoid_rewrite Hz. +Qed. + +Lemma bezout_1_gcd : forall n m, Bezout n m 1 -> gcd n m == 1. +Proof. + intros n m (q & r & H). + apply gcd_unique; trivial using divide_1_l, le_0_1. + intros p Hn Hm. + rewrite <- H. apply divide_add_r; now apply divide_mul_r. +Qed. + +Lemma gcd_bezout : forall n m p, gcd n m == p -> Bezout n m p. +Proof. + (* First, a version restricted to natural numbers *) + assert (aux : forall n, 0<=n -> forall m, 0<=m -> Bezout n m (gcd n m)). + intros n Hn; pattern n. + apply strong_right_induction with (z:=0); trivial. + unfold Bezout. solve_proper. + clear n Hn. intros n Hn IHn. + apply le_lteq in Hn; destruct Hn as [Hn|Hn]. + intros m Hm; pattern m. + apply strong_right_induction with (z:=0); trivial. + unfold Bezout. solve_proper. + clear m Hm. intros m Hm IHm. + destruct (lt_trichotomy n m) as [LT|[EQ|LT]]. + (* n < m *) + destruct (IHm (m-n)) as (a & b & EQ). + apply sub_nonneg; order. + now apply lt_sub_pos. + exists (a-b). exists b. + rewrite gcd_sub_diag_r in EQ. rewrite <- EQ. + rewrite mul_sub_distr_r, mul_sub_distr_l. + now rewrite add_sub_assoc, add_sub_swap. + (* n = m *) + rewrite EQ. rewrite gcd_diag_nonneg; trivial. + exists 1. exists 0. now nzsimpl. + (* m < n *) + destruct (IHn m Hm LT n) as (a & b & EQ). order. + exists b. exists a. now rewrite gcd_comm, <- EQ, add_comm. + (* n = 0 *) + intros m Hm. rewrite <- Hn, gcd_0_l_nonneg; trivial. + exists 0. exists 1. now nzsimpl. + (* Then we relax the positivity condition on n *) + assert (aux' : forall n m, 0<=m -> Bezout n m (gcd n m)). + intros n m Hm. + destruct (le_ge_cases 0 n). now apply aux. + assert (Hn' : 0 <= -n) by now apply opp_nonneg_nonpos. + destruct (aux (-n) Hn' m Hm) as (a & b & EQ). + exists (-a). exists b. now rewrite <- gcd_opp_l, <- EQ, mul_opp_r, mul_opp_l. + (* And finally we do the same for m *) + intros n m p Hp. rewrite <- Hp; clear Hp. + destruct (le_ge_cases 0 m). now apply aux'. + assert (Hm' : 0 <= -m) by now apply opp_nonneg_nonpos. + destruct (aux' n (-m) Hm') as (a & b & EQ). + exists a. exists (-b). now rewrite <- gcd_opp_r, <- EQ, mul_opp_r, mul_opp_l. +Qed. + +Lemma gcd_mul_mono_l : + forall n m p, gcd (p * n) (p * m) == abs p * gcd n m. +Proof. + intros n m p. + apply gcd_unique. + apply mul_nonneg_nonneg; trivial using gcd_nonneg, abs_nonneg. + destruct (gcd_divide_l n m) as (q,Hq). + rewrite Hq at 2. rewrite mul_assoc. apply mul_divide_mono_r. + rewrite <- (abs_sgn p) at 2. rewrite <- mul_assoc. apply divide_factor_l. + destruct (gcd_divide_r n m) as (q,Hq). + rewrite Hq at 2. rewrite mul_assoc. apply mul_divide_mono_r. + rewrite <- (abs_sgn p) at 2. rewrite <- mul_assoc. apply divide_factor_l. + intros q H H'. + destruct (gcd_bezout n m (gcd n m) (eq_refl _)) as (a & b & EQ). + rewrite <- EQ, <- sgn_abs, mul_add_distr_l. apply divide_add_r. + rewrite mul_shuffle2. now apply divide_mul_l. + rewrite mul_shuffle2. now apply divide_mul_l. +Qed. + +Lemma gcd_mul_mono_l_nonneg : + forall n m p, 0<=p -> gcd (p*n) (p*m) == p * gcd n m. +Proof. + intros. rewrite <- (abs_eq p) at 3; trivial. apply gcd_mul_mono_l. +Qed. + +Lemma gcd_mul_mono_r : + forall n m p, gcd (n * p) (m * p) == gcd n m * abs p. +Proof. + intros n m p. now rewrite !(mul_comm _ p), gcd_mul_mono_l, mul_comm. +Qed. + +Lemma gcd_mul_mono_r_nonneg : + forall n m p, 0<=p -> gcd (n*p) (m*p) == gcd n m * p. +Proof. + intros. rewrite <- (abs_eq p) at 3; trivial. apply gcd_mul_mono_r. +Qed. + +Lemma gauss : forall n m p, (n | m * p) -> gcd n m == 1 -> (n | p). +Proof. + intros n m p H G. + destruct (gcd_bezout n m 1 G) as (a & b & EQ). + rewrite <- (mul_1_l p), <- EQ, mul_add_distr_r. + apply divide_add_r. rewrite mul_shuffle0. apply divide_factor_r. + rewrite <- mul_assoc. now apply divide_mul_r. +Qed. + +Lemma divide_mul_split : forall n m p, n ~= 0 -> (n | m * p) -> + exists q r, n == q*r /\ (q | m) /\ (r | p). +Proof. + intros n m p Hn H. + assert (G := gcd_nonneg n m). + apply le_lteq in G; destruct G as [G|G]. + destruct (gcd_divide_l n m) as (q,Hq). + exists (gcd n m). exists q. + split. now rewrite mul_comm. + split. apply gcd_divide_r. + destruct (gcd_divide_r n m) as (r,Hr). + rewrite Hr in H. rewrite Hq in H at 1. + rewrite mul_shuffle0 in H. apply mul_divide_cancel_r in H; [|order]. + apply gauss with r; trivial. + apply mul_cancel_r with (gcd n m); [order|]. + rewrite mul_1_l. + rewrite <- gcd_mul_mono_r_nonneg, <- Hq, <- Hr; order. + symmetry in G. apply gcd_eq_0 in G. destruct G as (Hn',_); order. +Qed. + +(** TODO : more about rel_prime (i.e. gcd == 1), about prime ... *) + +End ZGcdProp. diff --git a/theories/Numbers/Integer/Abstract/ZLcm.v b/theories/Numbers/Integer/Abstract/ZLcm.v new file mode 100644 index 0000000000..0ab528de80 --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZLcm.v @@ -0,0 +1,473 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import ZAxioms ZMulOrder ZSgnAbs ZGcd ZDivTrunc ZDivFloor. + +(** * Least Common Multiple *) + +(** Unlike other functions around, we will define lcm below instead of + axiomatizing it. Indeed, there is no "prior art" about lcm in the + standard library to be compliant with, and the generic definition + of lcm via gcd is quite reasonable. + + By the way, we also state here some combined properties of div/mod + and quot/rem and gcd. +*) + +Module Type ZLcmProp + (Import A : ZAxiomsSig') + (Import B : ZMulOrderProp A) + (Import C : ZSgnAbsProp A B) + (Import D : ZDivProp A B C) + (Import E : ZQuotProp A B C) + (Import F : ZGcdProp A B C). + +(** The two notions of division are equal on non-negative numbers *) + +Lemma quot_div_nonneg : forall a b, 0<=a -> 0<b -> a÷b == a/b. +Proof. + intros. apply div_unique_pos with (a rem b). + now apply rem_bound_pos. + apply quot_rem. order. +Qed. + +Lemma rem_mod_nonneg : forall a b, 0<=a -> 0<b -> a rem b == a mod b. +Proof. + intros. apply mod_unique_pos with (a÷b). + now apply rem_bound_pos. + apply quot_rem. order. +Qed. + +(** We can use the sign rule to have an relation between divisions. *) + +Lemma quot_div : forall a b, b~=0 -> + a÷b == (sgn a)*(sgn b)*(abs a / abs b). +Proof. + assert (AUX : forall a b, 0<b -> a÷b == (sgn a)*(sgn b)*(abs a / abs b)). + intros a b Hb. rewrite (sgn_pos b), (abs_eq b), mul_1_r by order. + destruct (lt_trichotomy 0 a) as [Ha|[Ha|Ha]]. + rewrite sgn_pos, abs_eq, mul_1_l, quot_div_nonneg; order. + rewrite <- Ha, abs_0, sgn_0, quot_0_l, div_0_l, mul_0_l; order. + rewrite sgn_neg, abs_neq, mul_opp_l, mul_1_l, eq_opp_r, <-quot_opp_l + by order. + apply quot_div_nonneg; trivial. apply opp_nonneg_nonpos; order. + (* main *) + intros a b Hb. + apply neg_pos_cases in Hb. destruct Hb as [Hb|Hb]; [|now apply AUX]. + rewrite <- (opp_involutive b) at 1. rewrite quot_opp_r. + rewrite AUX, abs_opp, sgn_opp, mul_opp_r, mul_opp_l, opp_involutive. + reflexivity. + now apply opp_pos_neg. + rewrite eq_opp_l, opp_0; order. +Qed. + +Lemma rem_mod : forall a b, b~=0 -> + a rem b == (sgn a) * ((abs a) mod (abs b)). +Proof. + intros a b Hb. + rewrite <- rem_abs_r by trivial. + assert (Hb' := proj2 (abs_pos b) Hb). + destruct (lt_trichotomy 0 a) as [Ha|[Ha|Ha]]. + rewrite (abs_eq a), sgn_pos, mul_1_l, rem_mod_nonneg; order. + rewrite <- Ha, abs_0, sgn_0, mod_0_l, rem_0_l, mul_0_l; order. + rewrite sgn_neg, (abs_neq a), mul_opp_l, mul_1_l, eq_opp_r, <-rem_opp_l + by order. + apply rem_mod_nonneg; trivial. apply opp_nonneg_nonpos; order. +Qed. + +(** Modulo and remainder are null at the same place, + and this correspond to the divisibility relation. *) + +Lemma mod_divide : forall a b, b~=0 -> (a mod b == 0 <-> (b|a)). +Proof. + intros a b Hb. split. + intros Hab. exists (a/b). rewrite mul_comm. + rewrite (div_mod a b Hb) at 1. rewrite Hab; now nzsimpl. + intros (c,Hc). rewrite Hc. now apply mod_mul. +Qed. + +Lemma rem_divide : forall a b, b~=0 -> (a rem b == 0 <-> (b|a)). +Proof. + intros a b Hb. split. + intros Hab. exists (a÷b). rewrite mul_comm. + rewrite (quot_rem a b Hb) at 1. rewrite Hab; now nzsimpl. + intros (c,Hc). rewrite Hc. now apply rem_mul. +Qed. + +Lemma rem_mod_eq_0 : forall a b, b~=0 -> (a rem b == 0 <-> a mod b == 0). +Proof. + intros a b Hb. now rewrite mod_divide, rem_divide. +Qed. + +(** When division is exact, div and quot agree *) + +Lemma quot_div_exact : forall a b, b~=0 -> (b|a) -> a÷b == a/b. +Proof. + intros a b Hb H. + apply mul_cancel_l with b; trivial. + assert (H':=H). + apply rem_divide, quot_exact in H; trivial. + apply mod_divide, div_exact in H'; trivial. + now rewrite <-H,<-H'. +Qed. + +Lemma divide_div_mul_exact : forall a b c, b~=0 -> (b|a) -> + (c*a)/b == c*(a/b). +Proof. + intros a b c Hb H. + apply mul_cancel_l with b; trivial. + rewrite mul_assoc, mul_shuffle0. + assert (H':=H). apply mod_divide, div_exact in H'; trivial. + rewrite <- H', (mul_comm a c). + symmetry. apply div_exact; trivial. + apply mod_divide; trivial. + now apply divide_mul_r. +Qed. + +Lemma divide_quot_mul_exact : forall a b c, b~=0 -> (b|a) -> + (c*a)÷b == c*(a÷b). +Proof. + intros a b c Hb H. + rewrite 2 quot_div_exact; trivial. + apply divide_div_mul_exact; trivial. + now apply divide_mul_r. +Qed. + +(** Gcd of divided elements, for exact divisions *) + +Lemma gcd_div_factor : forall a b c, 0<c -> (c|a) -> (c|b) -> + gcd (a/c) (b/c) == (gcd a b)/c. +Proof. + intros a b c Hc Ha Hb. + apply mul_cancel_l with c; try order. + assert (H:=gcd_greatest _ _ _ Ha Hb). + apply mod_divide, div_exact in H; try order. + rewrite <- H. + rewrite <- gcd_mul_mono_l_nonneg; try order. + f_equiv; symmetry; apply div_exact; try order; + apply mod_divide; trivial; try order. +Qed. + +Lemma gcd_quot_factor : forall a b c, 0<c -> (c|a) -> (c|b) -> + gcd (a÷c) (b÷c) == (gcd a b)÷c. +Proof. + intros a b c Hc Ha Hb. rewrite !quot_div_exact; trivial; try order. + now apply gcd_div_factor. now apply gcd_greatest. +Qed. + +Lemma gcd_div_gcd : forall a b g, g~=0 -> g == gcd a b -> + gcd (a/g) (b/g) == 1. +Proof. + intros a b g NZ EQ. rewrite gcd_div_factor. + now rewrite <- EQ, div_same. + generalize (gcd_nonneg a b); order. + rewrite EQ; apply gcd_divide_l. + rewrite EQ; apply gcd_divide_r. +Qed. + +Lemma gcd_quot_gcd : forall a b g, g~=0 -> g == gcd a b -> + gcd (a÷g) (b÷g) == 1. +Proof. + intros a b g NZ EQ. rewrite !quot_div_exact; trivial. + now apply gcd_div_gcd. + rewrite EQ; apply gcd_divide_r. + rewrite EQ; apply gcd_divide_l. +Qed. + +(** The following equality is crucial for Euclid algorithm *) + +Lemma gcd_mod : forall a b, b~=0 -> gcd (a mod b) b == gcd b a. +Proof. + intros a b Hb. rewrite mod_eq; trivial. + rewrite <- add_opp_r, mul_comm, <- mul_opp_l. + rewrite (gcd_comm _ b). + apply gcd_add_mult_diag_r. +Qed. + +Lemma gcd_rem : forall a b, b~=0 -> gcd (a rem b) b == gcd b a. +Proof. + intros a b Hb. rewrite rem_eq; trivial. + rewrite <- add_opp_r, mul_comm, <- mul_opp_l. + rewrite (gcd_comm _ b). + apply gcd_add_mult_diag_r. +Qed. + +(** We now define lcm thanks to gcd: + + lcm a b = a * (b / gcd a b) + = (a / gcd a b) * b + = (a*b) / gcd a b + + We had an abs in order to have an always-nonnegative lcm, + in the spirit of gcd. Nota: [lcm 0 0] should be 0, which + isn't garantee with the third equation above. +*) + +Definition lcm a b := abs (a*(b/gcd a b)). + +Instance lcm_wd : Proper (eq==>eq==>eq) lcm. +Proof. unfold lcm. solve_proper. Qed. + +Lemma lcm_equiv1 : forall a b, gcd a b ~= 0 -> + a * (b / gcd a b) == (a*b)/gcd a b. +Proof. + intros a b H. rewrite divide_div_mul_exact; try easy. apply gcd_divide_r. +Qed. + +Lemma lcm_equiv2 : forall a b, gcd a b ~= 0 -> + (a / gcd a b) * b == (a*b)/gcd a b. +Proof. + intros a b H. rewrite 2 (mul_comm _ b). + rewrite divide_div_mul_exact; try easy. apply gcd_divide_l. +Qed. + +Lemma gcd_div_swap : forall a b, + (a / gcd a b) * b == a * (b / gcd a b). +Proof. + intros a b. destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ]. + apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ, EQ'. now nzsimpl. + now rewrite lcm_equiv1, <-lcm_equiv2. +Qed. + +Lemma divide_lcm_l : forall a b, (a | lcm a b). +Proof. + unfold lcm. intros a b. apply divide_abs_r, divide_factor_l. +Qed. + +Lemma divide_lcm_r : forall a b, (b | lcm a b). +Proof. + unfold lcm. intros a b. apply divide_abs_r. rewrite <- gcd_div_swap. + apply divide_factor_r. +Qed. + +Lemma divide_div : forall a b c, a~=0 -> (a|b) -> (b|c) -> (b/a|c/a). +Proof. + intros a b c Ha Hb (c',Hc). exists c'. + now rewrite <- divide_div_mul_exact, <- Hc. +Qed. + +Lemma lcm_least : forall a b c, + (a | c) -> (b | c) -> (lcm a b | c). +Proof. + intros a b c Ha Hb. unfold lcm. apply divide_abs_l. + destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ]. + apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ in *. now nzsimpl. + assert (Ga := gcd_divide_l a b). + assert (Gb := gcd_divide_r a b). + set (g:=gcd a b) in *. + assert (Ha' := divide_div g a c NEQ Ga Ha). + assert (Hb' := divide_div g b c NEQ Gb Hb). + destruct Ha' as (a',Ha'). rewrite Ha', mul_comm in Hb'. + apply gauss in Hb'; [|apply gcd_div_gcd; unfold g; trivial using gcd_comm]. + destruct Hb' as (b',Hb'). + exists b'. + rewrite mul_shuffle3, <- Hb'. + rewrite (proj2 (div_exact c g NEQ)). + rewrite Ha', mul_shuffle3, (mul_comm a a'). f_equiv. + symmetry. apply div_exact; trivial. + apply mod_divide; trivial. + apply mod_divide; trivial. transitivity a; trivial. +Qed. + +Lemma lcm_nonneg : forall a b, 0 <= lcm a b. +Proof. + intros a b. unfold lcm. apply abs_nonneg. +Qed. + +Lemma lcm_comm : forall a b, lcm a b == lcm b a. +Proof. + intros a b. unfold lcm. rewrite (gcd_comm b), (mul_comm b). + now rewrite <- gcd_div_swap. +Qed. + +Lemma lcm_divide_iff : forall n m p, + (lcm n m | p) <-> (n | p) /\ (m | p). +Proof. + intros. split. split. + transitivity (lcm n m); trivial using divide_lcm_l. + transitivity (lcm n m); trivial using divide_lcm_r. + intros (H,H'). now apply lcm_least. +Qed. + +Lemma lcm_unique : forall n m p, + 0<=p -> (n|p) -> (m|p) -> + (forall q, (n|q) -> (m|q) -> (p|q)) -> + lcm n m == p. +Proof. + intros n m p Hp Hn Hm H. + apply divide_antisym_nonneg; trivial. apply lcm_nonneg. + now apply lcm_least. + apply H. apply divide_lcm_l. apply divide_lcm_r. +Qed. + +Lemma lcm_unique_alt : forall n m p, 0<=p -> + (forall q, (p|q) <-> (n|q) /\ (m|q)) -> + lcm n m == p. +Proof. + intros n m p Hp H. + apply lcm_unique; trivial. + apply H, divide_refl. + apply H, divide_refl. + intros. apply H. now split. +Qed. + +Lemma lcm_assoc : forall n m p, lcm n (lcm m p) == lcm (lcm n m) p. +Proof. + intros. apply lcm_unique_alt; try apply lcm_nonneg. + intros. now rewrite !lcm_divide_iff, and_assoc. +Qed. + +Lemma lcm_0_l : forall n, lcm 0 n == 0. +Proof. + intros. apply lcm_unique; trivial. order. + apply divide_refl. + apply divide_0_r. +Qed. + +Lemma lcm_0_r : forall n, lcm n 0 == 0. +Proof. + intros. now rewrite lcm_comm, lcm_0_l. +Qed. + +Lemma lcm_1_l_nonneg : forall n, 0<=n -> lcm 1 n == n. +Proof. + intros. apply lcm_unique; trivial using divide_1_l, le_0_1, divide_refl. +Qed. + +Lemma lcm_1_r_nonneg : forall n, 0<=n -> lcm n 1 == n. +Proof. + intros. now rewrite lcm_comm, lcm_1_l_nonneg. +Qed. + +Lemma lcm_diag_nonneg : forall n, 0<=n -> lcm n n == n. +Proof. + intros. apply lcm_unique; trivial using divide_refl. +Qed. + +Lemma lcm_eq_0 : forall n m, lcm n m == 0 <-> n == 0 \/ m == 0. +Proof. + intros. split. + intros EQ. + apply eq_mul_0. + apply divide_0_l. rewrite <- EQ. apply lcm_least. + apply divide_factor_l. apply divide_factor_r. + destruct 1 as [EQ|EQ]; rewrite EQ. apply lcm_0_l. apply lcm_0_r. +Qed. + +Lemma divide_lcm_eq_r : forall n m, 0<=m -> (n|m) -> lcm n m == m. +Proof. + intros n m Hm H. apply lcm_unique_alt; trivial. + intros q. split. split; trivial. now transitivity m. + now destruct 1. +Qed. + +Lemma divide_lcm_iff : forall n m, 0<=m -> ((n|m) <-> lcm n m == m). +Proof. + intros n m Hn. split. now apply divide_lcm_eq_r. + intros EQ. rewrite <- EQ. apply divide_lcm_l. +Qed. + +Lemma lcm_opp_l : forall n m, lcm (-n) m == lcm n m. +Proof. + intros. apply lcm_unique_alt; try apply lcm_nonneg. + intros. rewrite divide_opp_l. apply lcm_divide_iff. +Qed. + +Lemma lcm_opp_r : forall n m, lcm n (-m) == lcm n m. +Proof. + intros. now rewrite lcm_comm, lcm_opp_l, lcm_comm. +Qed. + +Lemma lcm_abs_l : forall n m, lcm (abs n) m == lcm n m. +Proof. + intros. destruct (abs_eq_or_opp n) as [H|H]; rewrite H. + easy. apply lcm_opp_l. +Qed. + +Lemma lcm_abs_r : forall n m, lcm n (abs m) == lcm n m. +Proof. + intros. now rewrite lcm_comm, lcm_abs_l, lcm_comm. +Qed. + +Lemma lcm_1_l : forall n, lcm 1 n == abs n. +Proof. + intros. rewrite <- lcm_abs_r. apply lcm_1_l_nonneg, abs_nonneg. +Qed. + +Lemma lcm_1_r : forall n, lcm n 1 == abs n. +Proof. + intros. now rewrite lcm_comm, lcm_1_l. +Qed. + +Lemma lcm_diag : forall n, lcm n n == abs n. +Proof. + intros. rewrite <- lcm_abs_l, <- lcm_abs_r. + apply lcm_diag_nonneg, abs_nonneg. +Qed. + +Lemma lcm_mul_mono_l : + forall n m p, lcm (p * n) (p * m) == abs p * lcm n m. +Proof. + intros n m p. + destruct (eq_decidable p 0) as [Hp|Hp]. + rewrite Hp. nzsimpl. rewrite lcm_0_l, abs_0. now nzsimpl. + destruct (eq_decidable (gcd n m) 0) as [Hg|Hg]. + apply gcd_eq_0 in Hg. destruct Hg as (Hn,Hm); rewrite Hn, Hm. + nzsimpl. rewrite lcm_0_l. now nzsimpl. + unfold lcm. + rewrite gcd_mul_mono_l. + rewrite !abs_mul, mul_assoc. f_equiv. + rewrite <- (abs_sgn p) at 1. rewrite <- mul_assoc. + rewrite div_mul_cancel_l; trivial. + rewrite divide_div_mul_exact; trivial. rewrite abs_mul. + rewrite <- (sgn_abs (sgn p)), sgn_sgn. + destruct (sgn_spec p) as [(_,EQ)|[(EQ,_)|(_,EQ)]]. + rewrite EQ. now nzsimpl. order. + rewrite EQ. rewrite mul_opp_l, mul_opp_r, opp_involutive. now nzsimpl. + apply gcd_divide_r. + contradict Hp. now apply abs_0_iff. +Qed. + +Lemma lcm_mul_mono_l_nonneg : + forall n m p, 0<=p -> lcm (p*n) (p*m) == p * lcm n m. +Proof. + intros. rewrite <- (abs_eq p) at 3; trivial. apply lcm_mul_mono_l. +Qed. + +Lemma lcm_mul_mono_r : + forall n m p, lcm (n * p) (m * p) == lcm n m * abs p. +Proof. + intros n m p. now rewrite !(mul_comm _ p), lcm_mul_mono_l, mul_comm. +Qed. + +Lemma lcm_mul_mono_r_nonneg : + forall n m p, 0<=p -> lcm (n*p) (m*p) == lcm n m * p. +Proof. + intros. rewrite <- (abs_eq p) at 3; trivial. apply lcm_mul_mono_r. +Qed. + +Lemma gcd_1_lcm_mul : forall n m, n~=0 -> m~=0 -> + (gcd n m == 1 <-> lcm n m == abs (n*m)). +Proof. + intros n m Hn Hm. split; intros H. + unfold lcm. rewrite H. now rewrite div_1_r. + unfold lcm in *. + rewrite !abs_mul in H. apply mul_cancel_l in H; [|now rewrite abs_0_iff]. + assert (H' := gcd_divide_r n m). + assert (Hg : gcd n m ~= 0) by (red; rewrite gcd_eq_0; destruct 1; order). + apply mod_divide in H'; trivial. apply div_exact in H'; trivial. + assert (m / gcd n m ~=0) by (contradict Hm; rewrite H', Hm; now nzsimpl). + rewrite <- (mul_1_l (abs (_/_))) in H. + rewrite H' in H at 3. rewrite abs_mul in H. + apply mul_cancel_r in H; [|now rewrite abs_0_iff]. + rewrite abs_eq in H. order. apply gcd_nonneg. +Qed. + +End ZLcmProp. diff --git a/theories/Numbers/Integer/Abstract/ZLt.v b/theories/Numbers/Integer/Abstract/ZLt.v new file mode 100644 index 0000000000..726b041c21 --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZLt.v @@ -0,0 +1,134 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Export ZMul. + +Module ZOrderProp (Import Z : ZAxiomsMiniSig'). +Include ZMulProp Z. + +(** Instances of earlier theorems for m == 0 *) + +Theorem neg_pos_cases : forall n, n ~= 0 <-> n < 0 \/ n > 0. +Proof. +intro; apply lt_gt_cases. +Qed. + +Theorem nonpos_pos_cases : forall n, n <= 0 \/ n > 0. +Proof. +intro; apply le_gt_cases. +Qed. + +Theorem neg_nonneg_cases : forall n, n < 0 \/ n >= 0. +Proof. +intro; apply lt_ge_cases. +Qed. + +Theorem nonpos_nonneg_cases : forall n, n <= 0 \/ n >= 0. +Proof. +intro; apply le_ge_cases. +Qed. + +Ltac zinduct n := induction_maker n ltac:(apply order_induction_0). + +(** Theorems that are either not valid on N or have different proofs + on N and Z *) + +Theorem lt_pred_l : forall n, P n < n. +Proof. +intro n; rewrite <- (succ_pred n) at 2; apply lt_succ_diag_r. +Qed. + +Theorem le_pred_l : forall n, P n <= n. +Proof. +intro; apply lt_le_incl; apply lt_pred_l. +Qed. + +Theorem lt_le_pred : forall n m, n < m <-> n <= P m. +Proof. +intros n m; rewrite <- (succ_pred m); rewrite pred_succ. apply lt_succ_r. +Qed. + +Theorem nle_pred_r : forall n, ~ n <= P n. +Proof. +intro; rewrite <- lt_le_pred; apply lt_irrefl. +Qed. + +Theorem lt_pred_le : forall n m, P n < m <-> n <= m. +Proof. +intros n m; rewrite <- (succ_pred n) at 2. +symmetry; apply le_succ_l. +Qed. + +Theorem lt_lt_pred : forall n m, n < m -> P n < m. +Proof. +intros; apply lt_pred_le; now apply lt_le_incl. +Qed. + +Theorem le_le_pred : forall n m, n <= m -> P n <= m. +Proof. +intros; apply lt_le_incl; now apply lt_pred_le. +Qed. + +Theorem lt_pred_lt : forall n m, n < P m -> n < m. +Proof. +intros n m H; apply lt_trans with (P m); [assumption | apply lt_pred_l]. +Qed. + +Theorem le_pred_lt : forall n m, n <= P m -> n <= m. +Proof. +intros; apply lt_le_incl; now apply lt_le_pred. +Qed. + +Theorem pred_lt_mono : forall n m, n < m <-> P n < P m. +Proof. +intros; rewrite lt_le_pred; symmetry; apply lt_pred_le. +Qed. + +Theorem pred_le_mono : forall n m, n <= m <-> P n <= P m. +Proof. +intros; rewrite <- lt_pred_le; now rewrite lt_le_pred. +Qed. + +Theorem lt_succ_lt_pred : forall n m, S n < m <-> n < P m. +Proof. +intros n m; now rewrite (pred_lt_mono (S n) m), pred_succ. +Qed. + +Theorem le_succ_le_pred : forall n m, S n <= m <-> n <= P m. +Proof. +intros n m; now rewrite (pred_le_mono (S n) m), pred_succ. +Qed. + +Theorem lt_pred_lt_succ : forall n m, P n < m <-> n < S m. +Proof. +intros; rewrite lt_pred_le; symmetry; apply lt_succ_r. +Qed. + +Theorem le_pred_lt_succ : forall n m, P n <= m <-> n <= S m. +Proof. +intros n m; now rewrite (pred_le_mono n (S m)), pred_succ. +Qed. + +Theorem neq_pred_l : forall n, P n ~= n. +Proof. +intro; apply lt_neq; apply lt_pred_l. +Qed. + +Theorem lt_m1_r : forall n m, n < m -> m < 0 -> n < -1. +Proof. +intros n m H1 H2. apply lt_le_pred in H2. +setoid_replace (P 0) with (-1) in H2. now apply lt_le_trans with m. +apply eq_opp_r. now rewrite one_succ, opp_pred, opp_0. +Qed. + +End ZOrderProp. + diff --git a/theories/Numbers/Integer/Abstract/ZMaxMin.v b/theories/Numbers/Integer/Abstract/ZMaxMin.v new file mode 100644 index 0000000000..f3f3a861b7 --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZMaxMin.v @@ -0,0 +1,181 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import ZAxioms ZMulOrder GenericMinMax. + +(** * Properties of minimum and maximum specific to integer numbers *) + +Module Type ZMaxMinProp (Import Z : ZAxiomsMiniSig'). +Include ZMulOrderProp Z. + +(** The following results are concrete instances of [max_monotone] + and similar lemmas. *) + +(** Succ *) + +Lemma succ_max_distr : forall n m, S (max n m) == max (S n) (S m). +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?succ_le_mono. +Qed. + +Lemma succ_min_distr : forall n m, S (min n m) == min (S n) (S m). +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?succ_le_mono. +Qed. + +(** Pred *) + +Lemma pred_max_distr : forall n m, P (max n m) == max (P n) (P m). +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?pred_le_mono. +Qed. + +Lemma pred_min_distr : forall n m, P (min n m) == min (P n) (P m). +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?pred_le_mono. +Qed. + +(** Add *) + +Lemma add_max_distr_l : forall n m p, max (p + n) (p + m) == p + max n m. +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_l. +Qed. + +Lemma add_max_distr_r : forall n m p, max (n + p) (m + p) == max n m + p. +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_r. +Qed. + +Lemma add_min_distr_l : forall n m p, min (p + n) (p + m) == p + min n m. +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_l. +Qed. + +Lemma add_min_distr_r : forall n m p, min (n + p) (m + p) == min n m + p. +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_r. +Qed. + +(** Opp *) + +Lemma opp_max_distr : forall n m, -(max n m) == min (-n) (-m). +Proof. + intros. destruct (le_ge_cases n m). + rewrite max_r by trivial. symmetry. apply min_r. now rewrite <- opp_le_mono. + rewrite max_l by trivial. symmetry. apply min_l. now rewrite <- opp_le_mono. +Qed. + +Lemma opp_min_distr : forall n m, -(min n m) == max (-n) (-m). +Proof. + intros. destruct (le_ge_cases n m). + rewrite min_l by trivial. symmetry. apply max_l. now rewrite <- opp_le_mono. + rewrite min_r by trivial. symmetry. apply max_r. now rewrite <- opp_le_mono. +Qed. + +(** Sub *) + +Lemma sub_max_distr_l : forall n m p, max (p - n) (p - m) == p - min n m. +Proof. + intros. destruct (le_ge_cases n m). + rewrite min_l by trivial. apply max_l. now rewrite <- sub_le_mono_l. + rewrite min_r by trivial. apply max_r. now rewrite <- sub_le_mono_l. +Qed. + +Lemma sub_max_distr_r : forall n m p, max (n - p) (m - p) == max n m - p. +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply sub_le_mono_r. +Qed. + +Lemma sub_min_distr_l : forall n m p, min (p - n) (p - m) == p - max n m. +Proof. + intros. destruct (le_ge_cases n m). + rewrite max_r by trivial. apply min_r. now rewrite <- sub_le_mono_l. + rewrite max_l by trivial. apply min_l. now rewrite <- sub_le_mono_l. +Qed. + +Lemma sub_min_distr_r : forall n m p, min (n - p) (m - p) == min n m - p. +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply sub_le_mono_r. +Qed. + +(** Mul *) + +Lemma mul_max_distr_nonneg_l : forall n m p, 0 <= p -> + max (p * n) (p * m) == p * max n m. +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_nonneg_l. +Qed. + +Lemma mul_max_distr_nonneg_r : forall n m p, 0 <= p -> + max (n * p) (m * p) == max n m * p. +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_nonneg_r. +Qed. + +Lemma mul_min_distr_nonneg_l : forall n m p, 0 <= p -> + min (p * n) (p * m) == p * min n m. +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_nonneg_l. +Qed. + +Lemma mul_min_distr_nonneg_r : forall n m p, 0 <= p -> + min (n * p) (m * p) == min n m * p. +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_nonneg_r. +Qed. + +Lemma mul_max_distr_nonpos_l : forall n m p, p <= 0 -> + max (p * n) (p * m) == p * min n m. +Proof. + intros. destruct (le_ge_cases n m). + rewrite min_l by trivial. rewrite max_l. reflexivity. now apply mul_le_mono_nonpos_l. + rewrite min_r by trivial. rewrite max_r. reflexivity. now apply mul_le_mono_nonpos_l. +Qed. + +Lemma mul_max_distr_nonpos_r : forall n m p, p <= 0 -> + max (n * p) (m * p) == min n m * p. +Proof. + intros. destruct (le_ge_cases n m). + rewrite min_l by trivial. rewrite max_l. reflexivity. now apply mul_le_mono_nonpos_r. + rewrite min_r by trivial. rewrite max_r. reflexivity. now apply mul_le_mono_nonpos_r. +Qed. + +Lemma mul_min_distr_nonpos_l : forall n m p, p <= 0 -> + min (p * n) (p * m) == p * max n m. +Proof. + intros. destruct (le_ge_cases n m). + rewrite max_r by trivial. rewrite min_r. reflexivity. now apply mul_le_mono_nonpos_l. + rewrite max_l by trivial. rewrite min_l. reflexivity. now apply mul_le_mono_nonpos_l. +Qed. + +Lemma mul_min_distr_nonpos_r : forall n m p, p <= 0 -> + min (n * p) (m * p) == max n m * p. +Proof. + intros. destruct (le_ge_cases n m). + rewrite max_r by trivial. rewrite min_r. reflexivity. now apply mul_le_mono_nonpos_r. + rewrite max_l by trivial. rewrite min_l. reflexivity. now apply mul_le_mono_nonpos_r. +Qed. + +End ZMaxMinProp. diff --git a/theories/Numbers/Integer/Abstract/ZMul.v b/theories/Numbers/Integer/Abstract/ZMul.v new file mode 100644 index 0000000000..120647dcc4 --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZMul.v @@ -0,0 +1,77 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Export ZAdd. + +Module ZMulProp (Import Z : ZAxiomsMiniSig'). +Include ZAddProp Z. + +(** A note on naming: right (correspondingly, left) distributivity + happens when the sum is multiplied by a number on the right + (left), not when the sum itself is the right (left) factor in the + product (see planetmath.org and mathworld.wolfram.com). In the old + library BinInt, distributivity over subtraction was named + correctly, but distributivity over addition was named + incorrectly. The names in Isabelle/HOL library are also + incorrect. *) + +(** Theorems that are either not valid on N or have different proofs + on N and Z *) + +Theorem mul_pred_r : forall n m, n * (P m) == n * m - n. +Proof. +intros n m. +rewrite <- (succ_pred m) at 2. +now rewrite mul_succ_r, <- add_sub_assoc, sub_diag, add_0_r. +Qed. + +Theorem mul_pred_l : forall n m, (P n) * m == n * m - m. +Proof. +intros n m; rewrite (mul_comm (P n) m), (mul_comm n m). apply mul_pred_r. +Qed. + +Theorem mul_opp_l : forall n m, (- n) * m == - (n * m). +Proof. +intros n m. apply add_move_0_r. +now rewrite <- mul_add_distr_r, add_opp_diag_l, mul_0_l. +Qed. + +Theorem mul_opp_r : forall n m, n * (- m) == - (n * m). +Proof. +intros n m; rewrite (mul_comm n (- m)), (mul_comm n m); apply mul_opp_l. +Qed. + +Theorem mul_opp_opp : forall n m, (- n) * (- m) == n * m. +Proof. +intros n m; now rewrite mul_opp_l, mul_opp_r, opp_involutive. +Qed. + +Theorem mul_opp_comm : forall n m, (- n) * m == n * (- m). +Proof. +intros n m. now rewrite mul_opp_l, <- mul_opp_r. +Qed. + +Theorem mul_sub_distr_l : forall n m p, n * (m - p) == n * m - n * p. +Proof. +intros n m p. do 2 rewrite <- add_opp_r. rewrite mul_add_distr_l. +now rewrite mul_opp_r. +Qed. + +Theorem mul_sub_distr_r : forall n m p, (n - m) * p == n * p - m * p. +Proof. +intros n m p; rewrite (mul_comm (n - m) p), (mul_comm n p), (mul_comm m p); +now apply mul_sub_distr_l. +Qed. + +End ZMulProp. + + diff --git a/theories/Numbers/Integer/Abstract/ZMulOrder.v b/theories/Numbers/Integer/Abstract/ZMulOrder.v new file mode 100644 index 0000000000..cd9523d34e --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZMulOrder.v @@ -0,0 +1,218 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Export ZAddOrder. + +Module Type ZMulOrderProp (Import Z : ZAxiomsMiniSig'). +Include ZAddOrderProp Z. + +Theorem mul_lt_mono_nonpos : + forall n m p q, m <= 0 -> n < m -> q <= 0 -> p < q -> m * q < n * p. +Proof. +intros n m p q H1 H2 H3 H4. +apply le_lt_trans with (m * p). +apply mul_le_mono_nonpos_l; [assumption | now apply lt_le_incl]. +apply -> mul_lt_mono_neg_r; [assumption | now apply lt_le_trans with q]. +Qed. + +Theorem mul_le_mono_nonpos : + forall n m p q, m <= 0 -> n <= m -> q <= 0 -> p <= q -> m * q <= n * p. +Proof. +intros n m p q H1 H2 H3 H4. +apply le_trans with (m * p). +now apply mul_le_mono_nonpos_l. +apply mul_le_mono_nonpos_r; [now apply le_trans with q | assumption]. +Qed. + +Theorem mul_nonpos_nonpos : forall n m, n <= 0 -> m <= 0 -> 0 <= n * m. +Proof. +intros n m H1 H2. +rewrite <- (mul_0_l m). now apply mul_le_mono_nonpos_r. +Qed. + +Theorem mul_nonneg_nonpos : forall n m, 0 <= n -> m <= 0 -> n * m <= 0. +Proof. +intros n m H1 H2. +rewrite <- (mul_0_l m). now apply mul_le_mono_nonpos_r. +Qed. + +Theorem mul_nonpos_nonneg : forall n m, n <= 0 -> 0 <= m -> n * m <= 0. +Proof. +intros; rewrite mul_comm; now apply mul_nonneg_nonpos. +Qed. + +Notation mul_pos := lt_0_mul (only parsing). + +Theorem lt_mul_0 : + forall n m, n * m < 0 <-> n < 0 /\ m > 0 \/ n > 0 /\ m < 0. +Proof. +intros n m; split; [intro H | intros [[H1 H2] | [H1 H2]]]. +destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; +[| rewrite H1 in H; rewrite mul_0_l in H; false_hyp H lt_irrefl |]; +(destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; +[| rewrite H2 in H; rewrite mul_0_r in H; false_hyp H lt_irrefl |]); +try (left; now split); try (right; now split). +assert (H3 : n * m > 0) by now apply mul_neg_neg. +exfalso; now apply (lt_asymm (n * m) 0). +assert (H3 : n * m > 0) by now apply mul_pos_pos. +exfalso; now apply (lt_asymm (n * m) 0). +now apply mul_neg_pos. now apply mul_pos_neg. +Qed. + +Notation mul_neg := lt_mul_0 (only parsing). + +Theorem le_0_mul : + forall n m, 0 <= n * m -> 0 <= n /\ 0 <= m \/ n <= 0 /\ m <= 0. +Proof. +assert (R : forall n, 0 == n <-> n == 0) by (intros; split; apply eq_sym). +intros n m. repeat rewrite lt_eq_cases. repeat rewrite R. +rewrite lt_0_mul, eq_mul_0. +pose proof (lt_trichotomy n 0); pose proof (lt_trichotomy m 0). tauto. +Qed. + +Notation mul_nonneg := le_0_mul (only parsing). + +Theorem le_mul_0 : + forall n m, n * m <= 0 -> 0 <= n /\ m <= 0 \/ n <= 0 /\ 0 <= m. +Proof. +assert (R : forall n, 0 == n <-> n == 0) by (intros; split; apply eq_sym). +intros n m. repeat rewrite lt_eq_cases. repeat rewrite R. +rewrite lt_mul_0, eq_mul_0. +pose proof (lt_trichotomy n 0); pose proof (lt_trichotomy m 0). tauto. +Qed. + +Notation mul_nonpos := le_mul_0 (only parsing). + +Notation le_0_square := square_nonneg (only parsing). + +Theorem nlt_square_0 : forall n, ~ n * n < 0. +Proof. +intros n H. apply lt_nge in H. apply H. apply square_nonneg. +Qed. + +Theorem square_lt_mono_nonpos : forall n m, n <= 0 -> m < n -> n * n < m * m. +Proof. +intros n m H1 H2. now apply mul_lt_mono_nonpos. +Qed. + +Theorem square_le_mono_nonpos : forall n m, n <= 0 -> m <= n -> n * n <= m * m. +Proof. +intros n m H1 H2. now apply mul_le_mono_nonpos. +Qed. + +Theorem square_lt_simpl_nonpos : forall n m, m <= 0 -> n * n < m * m -> m < n. +Proof. +intros n m H1 H2. destruct (le_gt_cases n 0); [|order]. +destruct (lt_ge_cases m n) as [LE|GT]; trivial. +apply square_le_mono_nonpos in GT; order. +Qed. + +Theorem square_le_simpl_nonpos : forall n m, m <= 0 -> n * n <= m * m -> m <= n. +Proof. +intros n m H1 H2. destruct (le_gt_cases n 0); [|order]. +destruct (le_gt_cases m n) as [LE|GT]; trivial. +apply square_lt_mono_nonpos in GT; order. +Qed. + +Theorem lt_1_mul_neg : forall n m, n < -1 -> m < 0 -> 1 < n * m. +Proof. +intros n m H1 H2. apply (mul_lt_mono_neg_r m) in H1. +apply opp_pos_neg in H2. rewrite mul_opp_l, mul_1_l in H1. +now apply lt_1_l with (- m). +assumption. +Qed. + +Theorem lt_mul_m1_neg : forall n m, 1 < n -> m < 0 -> n * m < -1. +Proof. +intros n m H1 H2. apply (mul_lt_mono_neg_r m) in H1. +rewrite mul_1_l in H1. now apply lt_m1_r with m. +assumption. +Qed. + +Theorem lt_mul_m1_pos : forall n m, n < -1 -> 0 < m -> n * m < -1. +Proof. +intros n m H1 H2. apply (mul_lt_mono_pos_r m) in H1. +rewrite mul_opp_l, mul_1_l in H1. +apply opp_neg_pos in H2. now apply lt_m1_r with (- m). +assumption. +Qed. + +Theorem lt_1_mul_l : forall n m, 1 < n -> + n * m < -1 \/ n * m == 0 \/ 1 < n * m. +Proof. +intros n m H; destruct (lt_trichotomy m 0) as [H1 | [H1 | H1]]. +left. now apply lt_mul_m1_neg. +right; left; now rewrite H1, mul_0_r. +right; right; now apply lt_1_mul_pos. +Qed. + +Theorem lt_m1_mul_r : forall n m, n < -1 -> + n * m < -1 \/ n * m == 0 \/ 1 < n * m. +Proof. +intros n m H; destruct (lt_trichotomy m 0) as [H1 | [H1 | H1]]. +right; right. now apply lt_1_mul_neg. +right; left; now rewrite H1, mul_0_r. +left. now apply lt_mul_m1_pos. +Qed. + +Theorem eq_mul_1 : forall n m, n * m == 1 -> n == 1 \/ n == -1. +Proof. +assert (F := lt_m1_0). +zero_pos_neg n. +(* n = 0 *) +intros m. nzsimpl. now left. +(* 0 < n, proving P n /\ P (-n) *) +intros n Hn. rewrite <- le_succ_l, <- one_succ in Hn. +le_elim Hn; split; intros m H. +destruct (lt_1_mul_l n m) as [|[|]]; order'. +rewrite mul_opp_l, eq_opp_l in H. destruct (lt_1_mul_l n m) as [|[|]]; order'. +now left. +intros; right. now f_equiv. +Qed. + +Theorem lt_mul_diag_l : forall n m, n < 0 -> (1 < m <-> n * m < n). +Proof. +intros n m H. stepr (n * m < n * 1) by now rewrite mul_1_r. +now apply mul_lt_mono_neg_l. +Qed. + +Theorem lt_mul_diag_r : forall n m, 0 < n -> (1 < m <-> n < n * m). +Proof. +intros n m H. stepr (n * 1 < n * m) by now rewrite mul_1_r. +now apply mul_lt_mono_pos_l. +Qed. + +Theorem le_mul_diag_l : forall n m, n < 0 -> (1 <= m <-> n * m <= n). +Proof. +intros n m H. stepr (n * m <= n * 1) by now rewrite mul_1_r. +now apply mul_le_mono_neg_l. +Qed. + +Theorem le_mul_diag_r : forall n m, 0 < n -> (1 <= m <-> n <= n * m). +Proof. +intros n m H. stepr (n * 1 <= n * m) by now rewrite mul_1_r. +now apply mul_le_mono_pos_l. +Qed. + +Theorem lt_mul_r : forall n m p, 0 < n -> 1 < p -> n < m -> n < m * p. +Proof. +intros. stepl (n * 1) by now rewrite mul_1_r. +apply mul_lt_mono_nonneg. +now apply lt_le_incl. assumption. apply le_0_1. assumption. +Qed. + +(** Alternative name : *) + +Definition mul_eq_1 := eq_mul_1. + +End ZMulOrderProp. + diff --git a/theories/Numbers/Integer/Abstract/ZParity.v b/theories/Numbers/Integer/Abstract/ZParity.v new file mode 100644 index 0000000000..a5e53b3615 --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZParity.v @@ -0,0 +1,54 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import Bool ZMulOrder NZParity. + +(** Some more properties of [even] and [odd]. *) + +Module Type ZParityProp (Import Z : ZAxiomsSig') + (Import ZP : ZMulOrderProp Z). + +Include NZParityProp Z Z ZP. + +Lemma odd_pred : forall n, odd (P n) = even n. +Proof. + intros. rewrite <- (succ_pred n) at 2. symmetry. apply even_succ. +Qed. + +Lemma even_pred : forall n, even (P n) = odd n. +Proof. + intros. rewrite <- (succ_pred n) at 2. symmetry. apply odd_succ. +Qed. + +Lemma even_opp : forall n, even (-n) = even n. +Proof. + assert (H : forall n, Even n -> Even (-n)). + intros n (m,H). exists (-m). rewrite mul_opp_r. now f_equiv. + intros. rewrite eq_iff_eq_true, !even_spec. + split. rewrite <- (opp_involutive n) at 2. apply H. + apply H. +Qed. + +Lemma odd_opp : forall n, odd (-n) = odd n. +Proof. + intros. rewrite <- !negb_even. now rewrite even_opp. +Qed. + +Lemma even_sub : forall n m, even (n-m) = Bool.eqb (even n) (even m). +Proof. + intros. now rewrite <- add_opp_r, even_add, even_opp. +Qed. + +Lemma odd_sub : forall n m, odd (n-m) = xorb (odd n) (odd m). +Proof. + intros. now rewrite <- add_opp_r, odd_add, odd_opp. +Qed. + +End ZParityProp. diff --git a/theories/Numbers/Integer/Abstract/ZPow.v b/theories/Numbers/Integer/Abstract/ZPow.v new file mode 100644 index 0000000000..a4b964e52f --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZPow.v @@ -0,0 +1,137 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Properties of the power function *) + +Require Import Bool ZAxioms ZMulOrder ZParity ZSgnAbs NZPow. + +Module Type ZPowProp + (Import A : ZAxiomsSig') + (Import B : ZMulOrderProp A) + (Import C : ZParityProp A B) + (Import D : ZSgnAbsProp A B). + + Include NZPowProp A A B. + +(** A particular case of [pow_add_r], with no precondition *) + +Lemma pow_twice_r a b : a^(2*b) == a^b * a^b. +Proof. + rewrite two_succ. nzsimpl. + destruct (le_gt_cases 0 b). + - now rewrite pow_add_r. + - rewrite !pow_neg_r. now nzsimpl. trivial. + now apply add_neg_neg. +Qed. + +(** Parity of power *) + +Lemma even_pow : forall a b, 0<b -> even (a^b) = even a. +Proof. + intros a b Hb. apply lt_ind with (4:=Hb). solve_proper. + now nzsimpl. + clear b Hb. intros b Hb IH. nzsimpl; [|order]. + rewrite even_mul, IH. now destruct (even a). +Qed. + +Lemma odd_pow : forall a b, 0<b -> odd (a^b) = odd a. +Proof. + intros. now rewrite <- !negb_even, even_pow. +Qed. + +(** Properties of power of negative numbers *) + +Lemma pow_opp_even : forall a b, Even b -> (-a)^b == a^b. +Proof. + intros a b (c,H). rewrite H. + destruct (le_gt_cases 0 c). + rewrite 2 pow_mul_r by order'. + rewrite 2 pow_2_r. + now rewrite mul_opp_opp. + assert (2*c < 0) by (apply mul_pos_neg; order'). + now rewrite !pow_neg_r. +Qed. + +Lemma pow_opp_odd : forall a b, Odd b -> (-a)^b == -(a^b). +Proof. + intros a b (c,H). rewrite H. + destruct (le_gt_cases 0 c) as [LE|GT]. + assert (0 <= 2*c) by (apply mul_nonneg_nonneg; order'). + rewrite add_1_r, !pow_succ_r; trivial. + rewrite pow_opp_even by (now exists c). + apply mul_opp_l. + apply double_above in GT. rewrite mul_0_r in GT. + rewrite !pow_neg_r by trivial. now rewrite opp_0. +Qed. + +Lemma pow_even_abs : forall a b, Even b -> a^b == (abs a)^b. +Proof. + intros. destruct (abs_eq_or_opp a) as [EQ|EQ]; rewrite EQ. + reflexivity. + symmetry. now apply pow_opp_even. +Qed. + +Lemma pow_even_nonneg : forall a b, Even b -> 0 <= a^b. +Proof. + intros. rewrite pow_even_abs by trivial. + apply pow_nonneg, abs_nonneg. +Qed. + +Lemma pow_odd_abs_sgn : forall a b, Odd b -> a^b == sgn a * (abs a)^b. +Proof. + intros a b H. + destruct (sgn_spec a) as [(LT,EQ)|[(EQ',EQ)|(LT,EQ)]]; rewrite EQ. + nzsimpl. + rewrite abs_eq; order. + rewrite <- EQ'. nzsimpl. + destruct (le_gt_cases 0 b). + apply pow_0_l. + assert (b~=0) by (contradict H; now rewrite H, <-odd_spec, odd_0). + order. + now rewrite pow_neg_r. + rewrite abs_neq by order. + rewrite pow_opp_odd; trivial. + now rewrite mul_opp_opp, mul_1_l. +Qed. + +Lemma pow_odd_sgn : forall a b, 0<=b -> Odd b -> sgn (a^b) == sgn a. +Proof. + intros a b Hb H. + destruct (sgn_spec a) as [(LT,EQ)|[(EQ',EQ)|(LT,EQ)]]; rewrite EQ. + apply sgn_pos. apply pow_pos_nonneg; trivial. + rewrite <- EQ'. rewrite pow_0_l. apply sgn_0. + assert (b~=0) by (contradict H; now rewrite H, <-odd_spec, odd_0). + order. + apply sgn_neg. + rewrite <- (opp_involutive a). rewrite pow_opp_odd by trivial. + apply opp_neg_pos. + apply pow_pos_nonneg; trivial. + now apply opp_pos_neg. +Qed. + +Lemma abs_pow : forall a b, abs (a^b) == (abs a)^b. +Proof. + intros a b. + destruct (Even_or_Odd b). + rewrite pow_even_abs by trivial. + apply abs_eq, pow_nonneg, abs_nonneg. + rewrite pow_odd_abs_sgn by trivial. + rewrite abs_mul. + destruct (lt_trichotomy 0 a) as [Ha|[Ha|Ha]]. + rewrite (sgn_pos a), (abs_eq 1), mul_1_l by order'. + apply abs_eq, pow_nonneg, abs_nonneg. + rewrite <- Ha, sgn_0, abs_0, mul_0_l. + symmetry. apply pow_0_l'. intro Hb. rewrite Hb in H. + apply (Even_Odd_False 0); trivial. exists 0; now nzsimpl. + rewrite (sgn_neg a), abs_opp, (abs_eq 1), mul_1_l by order'. + apply abs_eq, pow_nonneg, abs_nonneg. +Qed. + +End ZPowProp. diff --git a/theories/Numbers/Integer/Abstract/ZProperties.v b/theories/Numbers/Integer/Abstract/ZProperties.v new file mode 100644 index 0000000000..e4b997cfdc --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZProperties.v @@ -0,0 +1,32 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Export ZAxioms ZMaxMin ZSgnAbs ZParity ZPow ZDivTrunc ZDivFloor + ZGcd ZLcm NZLog NZSqrt ZBits. + +(** The two following functors summarize all known facts about N. + + - [ZBasicProp] provides properties of basic functions: + + - * min max <= < + + - [ZExtraProp] provides properties of advanced functions: + pow, sqrt, log2, div, gcd, and bitwise functions. + + If necessary, the earlier all-in-one functor [ZProp] + could be re-obtained via [ZBasicProp <+ ZExtraProp] *) + +Module Type ZBasicProp (Z:ZAxiomsMiniSig) := ZMaxMinProp Z. + +Module Type ZExtraProp (Z:ZAxiomsSig)(P:ZBasicProp Z) := + ZSgnAbsProp Z P <+ ZParityProp Z P <+ ZPowProp Z P + <+ NZSqrtProp Z Z P <+ NZSqrtUpProp Z Z P + <+ NZLog2Prop Z Z Z P <+ NZLog2UpProp Z Z Z P + <+ ZDivProp Z P <+ ZQuotProp Z P <+ ZGcdProp Z P <+ ZLcmProp Z P + <+ ZBitsProp Z P. diff --git a/theories/Numbers/Integer/Abstract/ZSgnAbs.v b/theories/Numbers/Integer/Abstract/ZSgnAbs.v new file mode 100644 index 0000000000..dda1287269 --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZSgnAbs.v @@ -0,0 +1,366 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Properties of [abs] and [sgn] *) + +Require Import ZMulOrder. + +(** Since we already have [max], we could have defined [abs]. *) + +Module GenericAbs (Import Z : ZAxiomsMiniSig') + (Import ZP : ZMulOrderProp Z) <: HasAbs Z. + Definition abs n := max n (-n). + Lemma abs_eq : forall n, 0<=n -> abs n == n. + Proof. + intros. unfold abs. apply max_l. + apply le_trans with 0; auto. + rewrite opp_nonpos_nonneg; auto. + Qed. + Lemma abs_neq : forall n, n<=0 -> abs n == -n. + Proof. + intros. unfold abs. apply max_r. + apply le_trans with 0; auto. + rewrite opp_nonneg_nonpos; auto. + Qed. +End GenericAbs. + +(** We can deduce a [sgn] function from a [compare] function *) + +Module Type ZDecAxiomsSig := ZAxiomsMiniSig <+ HasCompare. +Module Type ZDecAxiomsSig' := ZAxiomsMiniSig' <+ HasCompare. + +Module Type GenericSgn (Import Z : ZDecAxiomsSig') + (Import ZP : ZMulOrderProp Z) <: HasSgn Z. + Definition sgn n := + match compare 0 n with Eq => 0 | Lt => 1 | Gt => -1 end. + Lemma sgn_null : forall n, n==0 -> sgn n == 0. + Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed. + Lemma sgn_pos : forall n, 0<n -> sgn n == 1. + Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed. + Lemma sgn_neg : forall n, n<0 -> sgn n == -1. + Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed. +End GenericSgn. + + +(** Derived properties of [abs] and [sgn] *) + +Module Type ZSgnAbsProp (Import Z : ZAxiomsSig') + (Import ZP : ZMulOrderProp Z). + +Ltac destruct_max n := + destruct (le_ge_cases 0 n); + [rewrite (abs_eq n) by auto | rewrite (abs_neq n) by auto]. + +Instance abs_wd : Proper (eq==>eq) abs. +Proof. + intros x y EQ. destruct_max x. + rewrite abs_eq; trivial. now rewrite <- EQ. + rewrite abs_neq; try order. now rewrite opp_inj_wd. +Qed. + +Lemma abs_max : forall n, abs n == max n (-n). +Proof. + intros n. destruct_max n. + rewrite max_l; auto with relations. + apply le_trans with 0; auto. + rewrite opp_nonpos_nonneg; auto. + rewrite max_r; auto with relations. + apply le_trans with 0; auto. + rewrite opp_nonneg_nonpos; auto. +Qed. + +Lemma abs_neq' : forall n, 0<=-n -> abs n == -n. +Proof. + intros. apply abs_neq. now rewrite <- opp_nonneg_nonpos. +Qed. + +Lemma abs_nonneg : forall n, 0 <= abs n. +Proof. + intros n. destruct_max n; auto. + now rewrite opp_nonneg_nonpos. +Qed. + +Lemma abs_eq_iff : forall n, abs n == n <-> 0<=n. +Proof. + split; try apply abs_eq. intros EQ. + rewrite <- EQ. apply abs_nonneg. +Qed. + +Lemma abs_neq_iff : forall n, abs n == -n <-> n<=0. +Proof. + split; try apply abs_neq. intros EQ. + rewrite <- opp_nonneg_nonpos, <- EQ. apply abs_nonneg. +Qed. + +Lemma abs_opp : forall n, abs (-n) == abs n. +Proof. + intros. destruct_max n. + rewrite (abs_neq (-n)), opp_involutive. reflexivity. + now rewrite opp_nonpos_nonneg. + rewrite (abs_eq (-n)). reflexivity. + now rewrite opp_nonneg_nonpos. +Qed. + +Lemma abs_0 : abs 0 == 0. +Proof. + apply abs_eq. apply le_refl. +Qed. + +Lemma abs_0_iff : forall n, abs n == 0 <-> n==0. +Proof. + split. destruct_max n; auto. + now rewrite eq_opp_l, opp_0. + intros EQ; rewrite EQ. rewrite abs_eq; auto using eq_refl, le_refl. +Qed. + +Lemma abs_pos : forall n, 0 < abs n <-> n~=0. +Proof. + intros. rewrite <- abs_0_iff. split; [intros LT| intros NEQ]. + intro EQ. rewrite EQ in LT. now elim (lt_irrefl 0). + assert (LE : 0 <= abs n) by apply abs_nonneg. + rewrite lt_eq_cases in LE; destruct LE; auto. + elim NEQ; auto with relations. +Qed. + +Lemma abs_eq_or_opp : forall n, abs n == n \/ abs n == -n. +Proof. + intros. destruct_max n; auto with relations. +Qed. + +Lemma abs_or_opp_abs : forall n, n == abs n \/ n == - abs n. +Proof. + intros. destruct_max n; rewrite ? opp_involutive; auto with relations. +Qed. + +Lemma abs_involutive : forall n, abs (abs n) == abs n. +Proof. + intros. apply abs_eq. apply abs_nonneg. +Qed. + +Lemma abs_spec : forall n, + (0 <= n /\ abs n == n) \/ (n < 0 /\ abs n == -n). +Proof. + intros. destruct (le_gt_cases 0 n). + left; split; auto. now apply abs_eq. + right; split; auto. apply abs_neq. now apply lt_le_incl. +Qed. + +Lemma abs_case_strong : + forall (P:t->Prop) n, Proper (eq==>iff) P -> + (0<=n -> P n) -> (n<=0 -> P (-n)) -> P (abs n). +Proof. + intros. destruct_max n; auto. +Qed. + +Lemma abs_case : forall (P:t->Prop) n, Proper (eq==>iff) P -> + P n -> P (-n) -> P (abs n). +Proof. intros. now apply abs_case_strong. Qed. + +Lemma abs_eq_cases : forall n m, abs n == abs m -> n == m \/ n == - m. +Proof. + intros n m EQ. destruct (abs_or_opp_abs n) as [EQn|EQn]. + rewrite EQn, EQ. apply abs_eq_or_opp. + rewrite EQn, EQ, opp_inj_wd, eq_opp_l, or_comm. apply abs_eq_or_opp. +Qed. + +Lemma abs_lt : forall a b, abs a < b <-> -b < a < b. +Proof. + intros a b. + destruct (abs_spec a) as [[LE EQ]|[LT EQ]]; rewrite EQ; clear EQ. + split; try split; try destruct 1; try order. + apply lt_le_trans with 0; trivial. apply opp_neg_pos; order. + rewrite opp_lt_mono, opp_involutive. + split; try split; try destruct 1; try order. + apply lt_le_trans with 0; trivial. apply opp_nonpos_nonneg; order. +Qed. + +Lemma abs_le : forall a b, abs a <= b <-> -b <= a <= b. +Proof. + intros a b. + destruct (abs_spec a) as [[LE EQ]|[LT EQ]]; rewrite EQ; clear EQ. + split; try split; try destruct 1; try order. + apply le_trans with 0; trivial. apply opp_nonpos_nonneg; order. + rewrite opp_le_mono, opp_involutive. + split; try split; try destruct 1; try order. + apply le_trans with 0. order. apply opp_nonpos_nonneg; order. +Qed. + +(** Triangular inequality *) + +Lemma abs_triangle : forall n m, abs (n + m) <= abs n + abs m. +Proof. + intros. destruct_max n; destruct_max m. + rewrite abs_eq. apply le_refl. now apply add_nonneg_nonneg. + destruct_max (n+m); try rewrite opp_add_distr; + apply add_le_mono_l || apply add_le_mono_r. + apply le_trans with 0; auto. now rewrite opp_nonneg_nonpos. + apply le_trans with 0; auto. now rewrite opp_nonpos_nonneg. + destruct_max (n+m); try rewrite opp_add_distr; + apply add_le_mono_l || apply add_le_mono_r. + apply le_trans with 0; auto. now rewrite opp_nonneg_nonpos. + apply le_trans with 0; auto. now rewrite opp_nonpos_nonneg. + rewrite abs_neq, opp_add_distr. apply le_refl. + now apply add_nonpos_nonpos. +Qed. + +Lemma abs_sub_triangle : forall n m, abs n - abs m <= abs (n-m). +Proof. + intros. + rewrite le_sub_le_add_l, add_comm. + rewrite <- (sub_simpl_r n m) at 1. + apply abs_triangle. +Qed. + +(** Absolute value and multiplication *) + +Lemma abs_mul : forall n m, abs (n * m) == abs n * abs m. +Proof. + assert (H : forall n m, 0<=n -> abs (n*m) == n * abs m). + intros. destruct_max m. + rewrite abs_eq. apply eq_refl. now apply mul_nonneg_nonneg. + rewrite abs_neq, mul_opp_r. reflexivity. now apply mul_nonneg_nonpos . + intros. destruct_max n. now apply H. + rewrite <- mul_opp_opp, H, abs_opp. reflexivity. + now apply opp_nonneg_nonpos. +Qed. + +Lemma abs_square : forall n, abs n * abs n == n * n. +Proof. + intros. rewrite <- abs_mul. apply abs_eq. apply le_0_square. +Qed. + +(** Some results about the sign function. *) + +Ltac destruct_sgn n := + let LT := fresh "LT" in + let EQ := fresh "EQ" in + let GT := fresh "GT" in + destruct (lt_trichotomy 0 n) as [LT|[EQ|GT]]; + [rewrite (sgn_pos n) by auto| + rewrite (sgn_null n) by auto with relations| + rewrite (sgn_neg n) by auto]. + +Instance sgn_wd : Proper (eq==>eq) sgn. +Proof. + intros x y Hxy. destruct_sgn x. + rewrite sgn_pos; auto with relations. rewrite <- Hxy; auto. + rewrite sgn_null; auto with relations. rewrite <- Hxy; auto with relations. + rewrite sgn_neg; auto with relations. rewrite <- Hxy; auto. +Qed. + +Lemma sgn_spec : forall n, + 0 < n /\ sgn n == 1 \/ + 0 == n /\ sgn n == 0 \/ + 0 > n /\ sgn n == -1. +Proof. + intros n. + destruct_sgn n; [left|right;left|right;right]; auto with relations. +Qed. + +Lemma sgn_0 : sgn 0 == 0. +Proof. + now apply sgn_null. +Qed. + +Lemma sgn_pos_iff : forall n, sgn n == 1 <-> 0<n. +Proof. + split; try apply sgn_pos. destruct_sgn n; auto. + intros. elim (lt_neq 0 1); auto. apply lt_0_1. + intros. elim (lt_neq (-1) 1); auto. + apply lt_trans with 0. rewrite opp_neg_pos. apply lt_0_1. apply lt_0_1. +Qed. + +Lemma sgn_null_iff : forall n, sgn n == 0 <-> n==0. +Proof. + split; try apply sgn_null. destruct_sgn n; auto with relations. + intros. elim (lt_neq 0 1); auto with relations. apply lt_0_1. + intros. elim (lt_neq (-1) 0); auto. + rewrite opp_neg_pos. apply lt_0_1. +Qed. + +Lemma sgn_neg_iff : forall n, sgn n == -1 <-> n<0. +Proof. + split; try apply sgn_neg. destruct_sgn n; auto with relations. + intros. elim (lt_neq (-1) 1); auto with relations. + apply lt_trans with 0. rewrite opp_neg_pos. apply lt_0_1. apply lt_0_1. + intros. elim (lt_neq (-1) 0); auto with relations. + rewrite opp_neg_pos. apply lt_0_1. +Qed. + +Lemma sgn_opp : forall n, sgn (-n) == - sgn n. +Proof. + intros. destruct_sgn n. + apply sgn_neg. now rewrite opp_neg_pos. + setoid_replace n with 0 by auto with relations. + rewrite opp_0. apply sgn_0. + rewrite opp_involutive. apply sgn_pos. now rewrite opp_pos_neg. +Qed. + +Lemma sgn_nonneg : forall n, 0 <= sgn n <-> 0 <= n. +Proof. + split. + destruct_sgn n; intros. + now apply lt_le_incl. + order. + elim (lt_irrefl 0). apply lt_le_trans with 1; auto using lt_0_1. + now rewrite <- opp_nonneg_nonpos. + rewrite lt_eq_cases; destruct 1. + rewrite sgn_pos by auto. apply lt_le_incl, lt_0_1. + rewrite sgn_null by auto with relations. apply le_refl. +Qed. + +Lemma sgn_nonpos : forall n, sgn n <= 0 <-> n <= 0. +Proof. + intros. rewrite <- 2 opp_nonneg_nonpos, <- sgn_opp. apply sgn_nonneg. +Qed. + +Lemma sgn_mul : forall n m, sgn (n*m) == sgn n * sgn m. +Proof. + intros. destruct_sgn n; nzsimpl. + destruct_sgn m. + apply sgn_pos. now apply mul_pos_pos. + apply sgn_null. rewrite eq_mul_0; auto with relations. + apply sgn_neg. now apply mul_pos_neg. + apply sgn_null. rewrite eq_mul_0; auto with relations. + destruct_sgn m; try rewrite mul_opp_opp; nzsimpl. + apply sgn_neg. now apply mul_neg_pos. + apply sgn_null. rewrite eq_mul_0; auto with relations. + apply sgn_pos. now apply mul_neg_neg. +Qed. + +Lemma sgn_abs : forall n, n * sgn n == abs n. +Proof. + intros. symmetry. + destruct_sgn n; try rewrite mul_opp_r; nzsimpl. + apply abs_eq. now apply lt_le_incl. + rewrite abs_0_iff; auto with relations. + apply abs_neq. now apply lt_le_incl. +Qed. + +Lemma abs_sgn : forall n, abs n * sgn n == n. +Proof. + intros. + destruct_sgn n; try rewrite mul_opp_r; nzsimpl; auto. + apply abs_eq. now apply lt_le_incl. + rewrite eq_opp_l. apply abs_neq. now apply lt_le_incl. +Qed. + +Lemma sgn_sgn : forall x, sgn (sgn x) == sgn x. +Proof. + intros. + destruct (sgn_spec x) as [(LT,EQ)|[(EQ',EQ)|(LT,EQ)]]; rewrite EQ. + apply sgn_pos, lt_0_1. + now apply sgn_null. + apply sgn_neg. rewrite opp_neg_pos. apply lt_0_1. +Qed. + +End ZSgnAbsProp. + + diff --git a/theories/Numbers/Integer/Binary/ZBinary.v b/theories/Numbers/Integer/Binary/ZBinary.v new file mode 100644 index 0000000000..bed827fd0e --- /dev/null +++ b/theories/Numbers/Integer/Binary/ZBinary.v @@ -0,0 +1,55 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + + +Require Import ZAxioms ZProperties BinInt. + +Local Open Scope Z_scope. + +(** BinInt.Z is already implementing [ZAxiomsMiniSig] *) + +Module Z + <: ZAxiomsSig <: UsualOrderedTypeFull <: TotalOrder + <: UsualDecidableTypeFull + := BinInt.Z. + +(** * An [order] tactic for integers *) + +Ltac z_order := Z.order. + +(** Note that [z_order] is domain-agnostic: it will not prove + [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *) + +Section TestOrder. + Let test : forall x y, x<=y -> y<=x -> x=y. + Proof. + z_order. + Qed. +End TestOrder. + +(** Z forms a ring *) + +(*Lemma Zring : ring_theory 0 1 NZadd NZmul NZsub Z.opp NZeq. +Proof. +constructor. +exact Zadd_0_l. +exact Zadd_comm. +exact Zadd_assoc. +exact Zmul_1_l. +exact Zmul_comm. +exact Zmul_assoc. +exact Zmul_add_distr_r. +intros; now rewrite Zadd_opp_minus. +exact Zadd_opp_r. +Qed. + +Add Ring ZR : Zring.*) diff --git a/theories/Numbers/Integer/NatPairs/ZNatPairs.v b/theories/Numbers/Integer/NatPairs/ZNatPairs.v new file mode 100644 index 0000000000..995d96b314 --- /dev/null +++ b/theories/Numbers/Integer/NatPairs/ZNatPairs.v @@ -0,0 +1,348 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Import NSub ZAxioms. +Require Export Ring. + +Declare Scope pair_scope. +Local Open Scope pair_scope. + +Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope. +Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope. + +Module ZPairsAxiomsMod (Import N : NAxiomsMiniSig) <: ZAxiomsMiniSig. + Module Import NProp. + Include NSubProp N. + End NProp. + +Declare Scope NScope. +Delimit Scope NScope with N. +Bind Scope NScope with N.t. +Infix "==" := N.eq (at level 70) : NScope. +Notation "x ~= y" := (~ N.eq x y) (at level 70) : NScope. +Notation "0" := N.zero : NScope. +Notation "1" := N.one : NScope. +Notation "2" := N.two : NScope. +Infix "+" := N.add : NScope. +Infix "-" := N.sub : NScope. +Infix "*" := N.mul : NScope. +Infix "<" := N.lt : NScope. +Infix "<=" := N.le : NScope. +Local Open Scope NScope. + +(** The definitions of functions ([add], [mul], etc.) will be unfolded + by the properties functor. Since we don't want [add_comm] to refer + to unfolded definitions of equality: [fun p1 p2 => (fst p1 + + snd p2) = (fst p2 + snd p1)], we will provide an extra layer of + definitions. *) + +Module Z. + +Definition t := (N.t * N.t)%type. +Definition zero : t := (0, 0). +Definition one : t := (1,0). +Definition two : t := (2,0). +Definition eq (p q : t) := (p#1 + q#2 == q#1 + p#2). +Definition succ (n : t) : t := (N.succ n#1, n#2). +Definition pred (n : t) : t := (n#1, N.succ n#2). +Definition opp (n : t) : t := (n#2, n#1). +Definition add (n m : t) : t := (n#1 + m#1, n#2 + m#2). +Definition sub (n m : t) : t := (n#1 + m#2, n#2 + m#1). +Definition mul (n m : t) : t := + (n#1 * m#1 + n#2 * m#2, n#1 * m#2 + n#2 * m#1). +Definition lt (n m : t) := n#1 + m#2 < m#1 + n#2. +Definition le (n m : t) := n#1 + m#2 <= m#1 + n#2. +Definition min (n m : t) : t := (min (n#1 + m#2) (m#1 + n#2), n#2 + m#2). +Definition max (n m : t) : t := (max (n#1 + m#2) (m#1 + n#2), n#2 + m#2). + +(** NB : We do not have [Z.pred (Z.succ n) = n] but only [Z.pred (Z.succ n) == n]. + It could be possible to consider as canonical only pairs where + one of the elements is 0, and make all operations convert + canonical values into other canonical values. In that case, we + could get rid of setoids and arrive at integers as signed natural + numbers. *) + +(** NB : Unfortunately, the elements of the pair keep increasing during + many operations, even during subtraction. *) + +End Z. + +Declare Scope ZScope. +Delimit Scope ZScope with Z. +Bind Scope ZScope with Z.t. +Infix "==" := Z.eq (at level 70) : ZScope. +Notation "x ~= y" := (~ Z.eq x y) (at level 70) : ZScope. +Notation "0" := Z.zero : ZScope. +Notation "1" := Z.one : ZScope. +Notation "2" := Z.two : ZScope. +Infix "+" := Z.add : ZScope. +Infix "-" := Z.sub : ZScope. +Infix "*" := Z.mul : ZScope. +Notation "- x" := (Z.opp x) : ZScope. +Infix "<" := Z.lt : ZScope. +Infix "<=" := Z.le : ZScope. +Local Open Scope ZScope. + +Lemma sub_add_opp : forall n m, Z.sub n m = Z.add n (Z.opp m). +Proof. reflexivity. Qed. + +Instance eq_equiv : Equivalence Z.eq. +Proof. +split. +unfold Reflexive, Z.eq. reflexivity. +unfold Symmetric, Z.eq; now symmetry. +unfold Transitive, Z.eq. intros (n1,n2) (m1,m2) (p1,p2) H1 H2; simpl in *. +apply (add_cancel_r _ _ (m1+m2)%N). +rewrite add_shuffle2, H1, add_shuffle1, H2. +now rewrite add_shuffle1, (add_comm m1). +Qed. + +Instance pair_wd : Proper (N.eq==>N.eq==>Z.eq) (@pair N.t N.t). +Proof. +intros n1 n2 H1 m1 m2 H2; unfold Z.eq; simpl; now rewrite H1, H2. +Qed. + +Instance succ_wd : Proper (Z.eq ==> Z.eq) Z.succ. +Proof. +unfold Z.succ, Z.eq; intros n m H; simpl. +do 2 rewrite add_succ_l; now rewrite H. +Qed. + +Instance pred_wd : Proper (Z.eq ==> Z.eq) Z.pred. +Proof. +unfold Z.pred, Z.eq; intros n m H; simpl. +do 2 rewrite add_succ_r; now rewrite H. +Qed. + +Instance add_wd : Proper (Z.eq ==> Z.eq ==> Z.eq) Z.add. +Proof. +unfold Z.eq, Z.add; intros n1 m1 H1 n2 m2 H2; simpl. +now rewrite add_shuffle1, H1, H2, add_shuffle1. +Qed. + +Instance opp_wd : Proper (Z.eq ==> Z.eq) Z.opp. +Proof. +unfold Z.eq, Z.opp; intros (n1,n2) (m1,m2) H; simpl in *. +now rewrite (add_comm n2), (add_comm m2). +Qed. + +Instance sub_wd : Proper (Z.eq ==> Z.eq ==> Z.eq) Z.sub. +Proof. +intros n1 m1 H1 n2 m2 H2. rewrite 2 sub_add_opp. now do 2 f_equiv. +Qed. + +Lemma mul_comm : forall n m, n*m == m*n. +Proof. +intros (n1,n2) (m1,m2); compute. +rewrite (add_comm (m1*n2)%N). +do 2 f_equiv; apply mul_comm. +Qed. + +Instance mul_wd : Proper (Z.eq ==> Z.eq ==> Z.eq) Z.mul. +Proof. +assert (forall n, Proper (Z.eq ==> Z.eq) (Z.mul n)). + unfold Z.mul, Z.eq. intros (n1,n2) (p1,p2) (q1,q2) H; simpl in *. + rewrite add_shuffle1, (add_comm (n1*p1)%N). + symmetry. rewrite add_shuffle1. + rewrite <- ! mul_add_distr_l. + rewrite (add_comm p2), (add_comm q2), H. + reflexivity. +intros n n' Hn m m' Hm. +rewrite Hm, (mul_comm n), (mul_comm n'), Hn. +reflexivity. +Qed. + +Section Induction. +Variable A : Z.t -> Prop. +Hypothesis A_wd : Proper (Z.eq==>iff) A. + +Theorem bi_induction : + A 0 -> (forall n, A n <-> A (Z.succ n)) -> forall n, A n. +Proof. +Open Scope NScope. +intros A0 AS n; unfold Z.zero, Z.succ, Z.eq in *. +destruct n as [n m]. +cut (forall p, A (p, 0)); [intro H1 |]. +cut (forall p, A (0, p)); [intro H2 |]. +destruct (add_dichotomy n m) as [[p H] | [p H]]. +rewrite (A_wd (n, m) (0, p)) by (rewrite add_0_l; now rewrite add_comm). +apply H2. +rewrite (A_wd (n, m) (p, 0)) by now rewrite add_0_r. apply H1. +induct p. assumption. intros p IH. +apply (A_wd (0, p) (1, N.succ p)) in IH; [| now rewrite add_0_l, add_1_l]. +rewrite one_succ in IH. now apply AS. +induct p. assumption. intros p IH. +replace 0 with (snd (p, 0)); [| reflexivity]. +replace (N.succ p) with (N.succ (fst (p, 0))); [| reflexivity]. now apply -> AS. +Close Scope NScope. +Qed. + +End Induction. + +(* Time to prove theorems in the language of Z *) + +Theorem pred_succ : forall n, Z.pred (Z.succ n) == n. +Proof. +unfold Z.pred, Z.succ, Z.eq; intro n; simpl; now nzsimpl. +Qed. + +Theorem succ_pred : forall n, Z.succ (Z.pred n) == n. +Proof. +intro n; unfold Z.succ, Z.pred, Z.eq; simpl; now nzsimpl. +Qed. + +Theorem one_succ : 1 == Z.succ 0. +Proof. +unfold Z.eq; simpl. now nzsimpl'. +Qed. + +Theorem two_succ : 2 == Z.succ 1. +Proof. +unfold Z.eq; simpl. now nzsimpl'. +Qed. + +Theorem opp_0 : - 0 == 0. +Proof. +unfold Z.opp, Z.eq; simpl. now nzsimpl. +Qed. + +Theorem opp_succ : forall n, - (Z.succ n) == Z.pred (- n). +Proof. +reflexivity. +Qed. + +Theorem add_0_l : forall n, 0 + n == n. +Proof. +intro n; unfold Z.add, Z.eq; simpl. now nzsimpl. +Qed. + +Theorem add_succ_l : forall n m, (Z.succ n) + m == Z.succ (n + m). +Proof. +intros n m; unfold Z.add, Z.eq; simpl. now nzsimpl. +Qed. + +Theorem sub_0_r : forall n, n - 0 == n. +Proof. +intro n; unfold Z.sub, Z.eq; simpl. now nzsimpl. +Qed. + +Theorem sub_succ_r : forall n m, n - (Z.succ m) == Z.pred (n - m). +Proof. +intros n m; unfold Z.sub, Z.eq; simpl. symmetry; now rewrite add_succ_r. +Qed. + +Theorem mul_0_l : forall n, 0 * n == 0. +Proof. +intros (n1,n2); unfold Z.mul, Z.eq; simpl; now nzsimpl. +Qed. + +Theorem mul_succ_l : forall n m, (Z.succ n) * m == n * m + m. +Proof. +intros (n1,n2) (m1,m2); unfold Z.mul, Z.succ, Z.eq; simpl; nzsimpl. +rewrite <- (add_assoc _ m1), (add_comm m1), (add_assoc _ _ m1). +now rewrite <- (add_assoc _ m2), (add_comm m2), (add_assoc _ (n2*m1)%N m2). +Qed. + +(** Order *) + +Lemma lt_eq_cases : forall n m, n<=m <-> n<m \/ n==m. +Proof. +intros; apply N.lt_eq_cases. +Qed. + +Theorem lt_irrefl : forall n, ~ (n < n). +Proof. +intros; apply N.lt_irrefl. +Qed. + +Theorem lt_succ_r : forall n m, n < (Z.succ m) <-> n <= m. +Proof. +intros n m; unfold Z.lt, Z.le, Z.eq; simpl; nzsimpl. apply lt_succ_r. +Qed. + +Theorem min_l : forall n m, n <= m -> Z.min n m == n. +Proof. +unfold Z.min, Z.le, Z.eq; simpl; intros (n1,n2) (m1,m2) H; simpl in *. +rewrite min_l by assumption. +now rewrite <- add_assoc, (add_comm m2). +Qed. + +Theorem min_r : forall n m, m <= n -> Z.min n m == m. +Proof. +unfold Z.min, Z.le, Z.eq; simpl; intros (n1,n2) (m1,m2) H; simpl in *. +rewrite min_r by assumption. +now rewrite add_assoc. +Qed. + +Theorem max_l : forall n m, m <= n -> Z.max n m == n. +Proof. +unfold Z.max, Z.le, Z.eq; simpl; intros (n1,n2) (m1,m2) H; simpl in *. +rewrite max_l by assumption. +now rewrite <- add_assoc, (add_comm m2). +Qed. + +Theorem max_r : forall n m, n <= m -> Z.max n m == m. +Proof. +unfold Z.max, Z.le, Z.eq; simpl; intros n m H. +rewrite max_r by assumption. +now rewrite add_assoc. +Qed. + +Theorem lt_nge : forall n m, n < m <-> ~(m<=n). +Proof. +intros. apply lt_nge. +Qed. + +Instance lt_wd : Proper (Z.eq ==> Z.eq ==> iff) Z.lt. +Proof. +assert (forall n, Proper (Z.eq==>iff) (Z.lt n)). + intros (n1,n2). apply proper_sym_impl_iff; auto with *. + unfold Z.lt, Z.eq; intros (r1,r2) (s1,s2) Eq H; simpl in *. + apply le_lt_add_lt with (r1+r2)%N (r1+r2)%N; [apply le_refl; auto with *|]. + rewrite add_shuffle2, (add_comm s2), Eq. + rewrite (add_comm s1 n2), (add_shuffle1 n2), (add_comm n2 r1). + now rewrite <- add_lt_mono_r. +intros n n' Hn m m' Hm. +rewrite Hm. rewrite 2 lt_nge, 2 lt_eq_cases, Hn; auto with *. +Qed. + +Definition t := Z.t. +Definition eq := Z.eq. +Definition zero := Z.zero. +Definition one := Z.one. +Definition two := Z.two. +Definition succ := Z.succ. +Definition pred := Z.pred. +Definition add := Z.add. +Definition sub := Z.sub. +Definition mul := Z.mul. +Definition opp := Z.opp. +Definition lt := Z.lt. +Definition le := Z.le. +Definition min := Z.min. +Definition max := Z.max. + +End ZPairsAxiomsMod. + +(* For example, let's build integers out of pairs of Peano natural numbers +and get their properties *) + +(* The following lines increase the compilation time at least twice *) +(* +Require PeanoNat. + +Module Export ZPairsPeanoAxiomsMod := ZPairsAxiomsMod PeanoNat.Nat. +Module Export ZPairsPropMod := ZPropFunct ZPairsPeanoAxiomsMod. + +Eval compute in (3, 5) * (4, 6). +*) + diff --git a/theories/Numbers/NaryFunctions.v b/theories/Numbers/NaryFunctions.v new file mode 100644 index 0000000000..ee28628ed9 --- /dev/null +++ b/theories/Numbers/NaryFunctions.v @@ -0,0 +1,142 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Pierre Letouzey, Jerome Vouillon, PPS, Paris 7, 2008 *) +(************************************************************************) + +Local Open Scope type_scope. + +Require Import List. + +(** * Generic dependently-typed operators about [n]-ary functions *) + +(** The type of [n]-ary function: [nfun A n B] is + [A -> ... -> A -> B] with [n] occurrences of [A] in this type. *) + +Fixpoint nfun A n B := + match n with + | O => B + | S n => A -> (nfun A n B) + end. + +Notation " A ^^ n --> B " := (nfun A n B) + (at level 50, n at next level) : type_scope. + +(** [napply_cst _ _ a n f] iterates [n] times the application of a + particular constant [a] to the [n]-ary function [f]. *) + +Fixpoint napply_cst (A B:Type)(a:A) n : (A^^n-->B) -> B := + match n return (A^^n-->B) -> B with + | O => fun x => x + | S n => fun x => napply_cst _ _ a n (x a) + end. + + +(** A generic transformation from an n-ary function to another one.*) + +Fixpoint nfun_to_nfun (A B C:Type)(f:B -> C) n : + (A^^n-->B) -> (A^^n-->C) := + match n return (A^^n-->B) -> (A^^n-->C) with + | O => f + | S n => fun g a => nfun_to_nfun _ _ _ f n (g a) + end. + +(** [napply_except_last _ _ n f] expects [n] arguments of type [A], + applies [n-1] of them to [f] and discard the last one. *) + +Definition napply_except_last (A B:Type) := + nfun_to_nfun A B (A->B) (fun b a => b). + +(** [napply_then_last _ _ a n f] expects [n] arguments of type [A], + applies them to [f] and then apply [a] to the result. *) + +Definition napply_then_last (A B:Type)(a:A) := + nfun_to_nfun A (A->B) B (fun fab => fab a). + +(** [napply_discard _ b n] expects [n] arguments, discards then, + and returns [b]. *) + +Fixpoint napply_discard (A B:Type)(b:B) n : A^^n-->B := + match n return A^^n-->B with + | O => b + | S n => fun _ => napply_discard _ _ b n + end. + +(** A fold function *) + +Fixpoint nfold A B (f:A->B->B)(b:B) n : (A^^n-->B) := + match n return (A^^n-->B) with + | O => b + | S n => fun a => (nfold _ _ f (f a b) n) + end. + + +(** [n]-ary products : [nprod A n] is [A*...*A*unit], + with [n] occurrences of [A] in this type. *) + +Fixpoint nprod A n : Type := match n with + | O => unit + | S n => (A * nprod A n)%type +end. + +Notation "A ^ n" := (nprod A n) : type_scope. + +(** [n]-ary curryfication / uncurryfication *) + +Fixpoint ncurry (A B:Type) n : (A^n -> B) -> (A^^n-->B) := + match n return (A^n -> B) -> (A^^n-->B) with + | O => fun x => x tt + | S n => fun f a => ncurry _ _ n (fun p => f (a,p)) + end. + +Fixpoint nuncurry (A B:Type) n : (A^^n-->B) -> (A^n -> B) := + match n return (A^^n-->B) -> (A^n -> B) with + | O => fun x _ => x + | S n => fun f p => let (x,p) := p in nuncurry _ _ n (f x) p + end. + +(** Earlier functions can also be defined via [ncurry/nuncurry]. + For instance : *) + +Definition nfun_to_nfun_bis A B C (f:B->C) n : + (A^^n-->B) -> (A^^n-->C) := + fun anb => ncurry _ _ n (fun an => f ((nuncurry _ _ n anb) an)). + +(** We can also us it to obtain another [fold] function, + equivalent to the previous one, but with a nicer expansion + (see for instance Int31.iszero). *) + +Fixpoint nfold_bis A B (f:A->B->B)(b:B) n : (A^^n-->B) := + match n return (A^^n-->B) with + | O => b + | S n => fun a => + nfun_to_nfun_bis _ _ _ (f a) n (nfold_bis _ _ f b n) + end. + +(** From [nprod] to [list] *) + +Fixpoint nprod_to_list (A:Type) n : A^n -> list A := + match n with + | O => fun _ => nil + | S n => fun p => let (x,p) := p in x::(nprod_to_list _ n p) + end. + +(** From [list] to [nprod] *) + +Fixpoint nprod_of_list (A:Type)(l:list A) : A^(length l) := + match l return A^(length l) with + | nil => tt + | x::l => (x, nprod_of_list _ l) + end. + +(** This gives an additional way to write the fold *) + +Definition nfold_list (A B:Type)(f:A->B->B)(b:B) n : (A^^n-->B) := + ncurry _ _ n (fun p => fold_right f b (nprod_to_list _ _ p)). + diff --git a/theories/Numbers/NatInt/NZAdd.v b/theories/Numbers/NatInt/NZAdd.v new file mode 100644 index 0000000000..9fcb029b3c --- /dev/null +++ b/theories/Numbers/NatInt/NZAdd.v @@ -0,0 +1,109 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Import NZAxioms NZBase. + +Module Type NZAddProp (Import NZ : NZAxiomsSig')(Import NZBase : NZBaseProp NZ). + +Hint Rewrite + pred_succ add_0_l add_succ_l mul_0_l mul_succ_l sub_0_r sub_succ_r : nz. +Hint Rewrite one_succ two_succ : nz'. +Ltac nzsimpl := autorewrite with nz. +Ltac nzsimpl' := autorewrite with nz nz'. + +Theorem add_0_r : forall n, n + 0 == n. +Proof. + nzinduct n. + - now nzsimpl. + - intro. nzsimpl. now rewrite succ_inj_wd. +Qed. + +Theorem add_succ_r : forall n m, n + S m == S (n + m). +Proof. + intros n m; nzinduct n. + - now nzsimpl. + - intro. nzsimpl. now rewrite succ_inj_wd. +Qed. + +Theorem add_succ_comm : forall n m, S n + m == n + S m. +Proof. +intros n m. now rewrite add_succ_r, add_succ_l. +Qed. + +Hint Rewrite add_0_r add_succ_r : nz. + +Theorem add_comm : forall n m, n + m == m + n. +Proof. + intros n m; nzinduct n. + - now nzsimpl. + - intro. nzsimpl. now rewrite succ_inj_wd. +Qed. + +Theorem add_1_l : forall n, 1 + n == S n. +Proof. +intro n; now nzsimpl'. +Qed. + +Theorem add_1_r : forall n, n + 1 == S n. +Proof. +intro n; now nzsimpl'. +Qed. + +Hint Rewrite add_1_l add_1_r : nz. + +Theorem add_assoc : forall n m p, n + (m + p) == (n + m) + p. +Proof. + intros n m p; nzinduct n. + - now nzsimpl. + - intro. nzsimpl. now rewrite succ_inj_wd. +Qed. + +Theorem add_cancel_l : forall n m p, p + n == p + m <-> n == m. +Proof. +intros n m p; nzinduct p. +- now nzsimpl. +- intro p. nzsimpl. now rewrite succ_inj_wd. +Qed. + +Theorem add_cancel_r : forall n m p, n + p == m + p <-> n == m. +Proof. +intros n m p. rewrite (add_comm n p), (add_comm m p). apply add_cancel_l. +Qed. + +Theorem add_shuffle0 : forall n m p, n+m+p == n+p+m. +Proof. +intros n m p. rewrite <- 2 add_assoc, add_cancel_l. apply add_comm. +Qed. + +Theorem add_shuffle1 : forall n m p q, (n + m) + (p + q) == (n + p) + (m + q). +Proof. +intros n m p q. rewrite 2 add_assoc, add_cancel_r. apply add_shuffle0. +Qed. + +Theorem add_shuffle2 : forall n m p q, (n + m) + (p + q) == (n + q) + (m + p). +Proof. +intros n m p q. rewrite (add_comm p). apply add_shuffle1. +Qed. + +Theorem add_shuffle3 : forall n m p, n + (m + p) == m + (n + p). +Proof. +intros n m p. now rewrite add_comm, <- add_assoc, (add_comm p). +Qed. + +Theorem sub_1_r : forall n, n - 1 == P n. +Proof. +intro n; now nzsimpl'. +Qed. + +Hint Rewrite sub_1_r : nz. + +End NZAddProp. diff --git a/theories/Numbers/NatInt/NZAddOrder.v b/theories/Numbers/NatInt/NZAddOrder.v new file mode 100644 index 0000000000..5f102e853b --- /dev/null +++ b/theories/Numbers/NatInt/NZAddOrder.v @@ -0,0 +1,170 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Import NZAxioms NZBase NZMul NZOrder. + +Module Type NZAddOrderProp (Import NZ : NZOrdAxiomsSig'). +Include NZBaseProp NZ <+ NZMulProp NZ <+ NZOrderProp NZ. + +Theorem add_lt_mono_l : forall n m p, n < m <-> p + n < p + m. +Proof. + intros n m p; nzinduct p. - now nzsimpl. + - intro p. nzsimpl. now rewrite <- succ_lt_mono. +Qed. + +Theorem add_lt_mono_r : forall n m p, n < m <-> n + p < m + p. +Proof. +intros n m p. rewrite (add_comm n p), (add_comm m p); apply add_lt_mono_l. +Qed. + +Theorem add_lt_mono : forall n m p q, n < m -> p < q -> n + p < m + q. +Proof. +intros n m p q H1 H2. +apply lt_trans with (m + p); +[now apply add_lt_mono_r | now apply add_lt_mono_l]. +Qed. + +Theorem add_le_mono_l : forall n m p, n <= m <-> p + n <= p + m. +Proof. + intros n m p; nzinduct p. - now nzsimpl. + - intro p. nzsimpl. now rewrite <- succ_le_mono. +Qed. + +Theorem add_le_mono_r : forall n m p, n <= m <-> n + p <= m + p. +Proof. +intros n m p. rewrite (add_comm n p), (add_comm m p); apply add_le_mono_l. +Qed. + +Theorem add_le_mono : forall n m p q, n <= m -> p <= q -> n + p <= m + q. +Proof. +intros n m p q H1 H2. +apply le_trans with (m + p); +[now apply add_le_mono_r | now apply add_le_mono_l]. +Qed. + +Theorem add_lt_le_mono : forall n m p q, n < m -> p <= q -> n + p < m + q. +Proof. +intros n m p q H1 H2. +apply lt_le_trans with (m + p); +[now apply add_lt_mono_r | now apply add_le_mono_l]. +Qed. + +Theorem add_le_lt_mono : forall n m p q, n <= m -> p < q -> n + p < m + q. +Proof. +intros n m p q H1 H2. +apply le_lt_trans with (m + p); +[now apply add_le_mono_r | now apply add_lt_mono_l]. +Qed. + +Theorem add_pos_pos : forall n m, 0 < n -> 0 < m -> 0 < n + m. +Proof. +intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_mono. +Qed. + +Theorem add_pos_nonneg : forall n m, 0 < n -> 0 <= m -> 0 < n + m. +Proof. +intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_le_mono. +Qed. + +Theorem add_nonneg_pos : forall n m, 0 <= n -> 0 < m -> 0 < n + m. +Proof. +intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_lt_mono. +Qed. + +Theorem add_nonneg_nonneg : forall n m, 0 <= n -> 0 <= m -> 0 <= n + m. +Proof. +intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_mono. +Qed. + +Theorem lt_add_pos_l : forall n m, 0 < n -> m < n + m. +Proof. +intros n m. rewrite (add_lt_mono_r 0 n m). now nzsimpl. +Qed. + +Theorem lt_add_pos_r : forall n m, 0 < n -> m < m + n. +Proof. +intros; rewrite add_comm; now apply lt_add_pos_l. +Qed. + +Theorem le_lt_add_lt : forall n m p q, n <= m -> p + m < q + n -> p < q. +Proof. +intros n m p q H1 H2. destruct (le_gt_cases q p); [| assumption]. +contradict H2. rewrite nlt_ge. now apply add_le_mono. +Qed. + +Theorem lt_le_add_lt : forall n m p q, n < m -> p + m <= q + n -> p < q. +Proof. +intros n m p q H1 H2. destruct (le_gt_cases q p); [| assumption]. +contradict H2. rewrite nle_gt. now apply add_le_lt_mono. +Qed. + +Theorem le_le_add_le : forall n m p q, n <= m -> p + m <= q + n -> p <= q. +Proof. +intros n m p q H1 H2. destruct (le_gt_cases p q); [assumption |]. +contradict H2. rewrite nle_gt. now apply add_lt_le_mono. +Qed. + +Theorem add_lt_cases : forall n m p q, n + m < p + q -> n < p \/ m < q. +Proof. +intros n m p q H; +destruct (le_gt_cases p n) as [H1 | H1]; [| now left]. +destruct (le_gt_cases q m) as [H2 | H2]; [| now right]. +contradict H; rewrite nlt_ge. now apply add_le_mono. +Qed. + +Theorem add_le_cases : forall n m p q, n + m <= p + q -> n <= p \/ m <= q. +Proof. +intros n m p q H. +destruct (le_gt_cases n p) as [H1 | H1]. - now left. +- destruct (le_gt_cases m q) as [H2 | H2]. + now right. + + contradict H; rewrite nle_gt. now apply add_lt_mono. +Qed. + +Theorem add_neg_cases : forall n m, n + m < 0 -> n < 0 \/ m < 0. +Proof. +intros n m H; apply add_lt_cases; now nzsimpl. +Qed. + +Theorem add_pos_cases : forall n m, 0 < n + m -> 0 < n \/ 0 < m. +Proof. +intros n m H; apply add_lt_cases; now nzsimpl. +Qed. + +Theorem add_nonpos_cases : forall n m, n + m <= 0 -> n <= 0 \/ m <= 0. +Proof. +intros n m H; apply add_le_cases; now nzsimpl. +Qed. + +Theorem add_nonneg_cases : forall n m, 0 <= n + m -> 0 <= n \/ 0 <= m. +Proof. +intros n m H; apply add_le_cases; now nzsimpl. +Qed. + +(** Substraction *) + +(** We can prove the existence of a subtraction of any number by + a smaller one *) + +Lemma le_exists_sub : forall n m, n<=m -> exists p, m == p+n /\ 0<=p. +Proof. + intros n m H. apply le_ind with (4:=H). - solve_proper. + - exists 0; nzsimpl; split; order. + - clear m H. intros m H (p & EQ & LE). exists (S p). + split. + nzsimpl. now f_equiv. + now apply le_le_succ_r. +Qed. + +(** For the moment, it doesn't seem possible to relate + this existing subtraction with [sub]. +*) + +End NZAddOrderProp. + diff --git a/theories/Numbers/NatInt/NZAxioms.v b/theories/Numbers/NatInt/NZAxioms.v new file mode 100644 index 0000000000..8c364cde7d --- /dev/null +++ b/theories/Numbers/NatInt/NZAxioms.v @@ -0,0 +1,148 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Initial Author : Evgeny Makarov, INRIA, 2007 *) + +Require Export Equalities Orders NumPrelude GenericMinMax. + +(** Axiomatization of a domain with zero, successor, predecessor, + and a bi-directional induction principle. We require [P (S n) = n] + but not the other way around, since this domain is meant + to be either N or Z. In fact it can be a few other things, + for instance [Z/nZ] (See file [NZDomain] for a study of that). +*) + +Module Type ZeroSuccPred (Import T:Typ). + Parameter Inline(20) zero : t. + Parameter Inline(50) succ : t -> t. + Parameter Inline pred : t -> t. +End ZeroSuccPred. + +Module Type ZeroSuccPredNotation (T:Typ)(Import NZ:ZeroSuccPred T). + Notation "0" := zero. + Notation S := succ. + Notation P := pred. +End ZeroSuccPredNotation. + +Module Type ZeroSuccPred' (T:Typ) := + ZeroSuccPred T <+ ZeroSuccPredNotation T. + +Module Type IsNZDomain (Import E:Eq')(Import NZ:ZeroSuccPred' E). + Declare Instance succ_wd : Proper (eq ==> eq) S. + Declare Instance pred_wd : Proper (eq ==> eq) P. + Axiom pred_succ : forall n, P (S n) == n. + Axiom bi_induction : + forall A : t -> Prop, Proper (eq==>iff) A -> + A 0 -> (forall n, A n <-> A (S n)) -> forall n, A n. +End IsNZDomain. + +(** Axiomatization of some more constants + + Simply denoting "1" for (S 0) and so on works ok when implementing + by nat, but leaves some (N.succ N0) when implementing by N. +*) + +Module Type OneTwo (Import T:Typ). + Parameter Inline(20) one two : t. +End OneTwo. + +Module Type OneTwoNotation (T:Typ)(Import NZ:OneTwo T). + Notation "1" := one. + Notation "2" := two. +End OneTwoNotation. + +Module Type OneTwo' (T:Typ) := OneTwo T <+ OneTwoNotation T. + +Module Type IsOneTwo (E:Eq')(Z:ZeroSuccPred' E)(O:OneTwo' E). + Import E Z O. + Axiom one_succ : 1 == S 0. + Axiom two_succ : 2 == S 1. +End IsOneTwo. + +Module Type NZDomainSig := + EqualityType <+ ZeroSuccPred <+ IsNZDomain <+ OneTwo <+ IsOneTwo. +Module Type NZDomainSig' := + EqualityType' <+ ZeroSuccPred' <+ IsNZDomain <+ OneTwo' <+ IsOneTwo. + +(** Axiomatization of basic operations : [+] [-] [*] *) + +Module Type AddSubMul (Import T:Typ). + Parameters Inline add sub mul : t -> t -> t. +End AddSubMul. + +Module Type AddSubMulNotation (T:Typ)(Import NZ:AddSubMul T). + Notation "x + y" := (add x y). + Notation "x - y" := (sub x y). + Notation "x * y" := (mul x y). +End AddSubMulNotation. + +Module Type AddSubMul' (T:Typ) := AddSubMul T <+ AddSubMulNotation T. + +Module Type IsAddSubMul (Import E:NZDomainSig')(Import NZ:AddSubMul' E). + Declare Instance add_wd : Proper (eq ==> eq ==> eq) add. + Declare Instance sub_wd : Proper (eq ==> eq ==> eq) sub. + Declare Instance mul_wd : Proper (eq ==> eq ==> eq) mul. + Axiom add_0_l : forall n, 0 + n == n. + Axiom add_succ_l : forall n m, (S n) + m == S (n + m). + Axiom sub_0_r : forall n, n - 0 == n. + Axiom sub_succ_r : forall n m, n - (S m) == P (n - m). + Axiom mul_0_l : forall n, 0 * n == 0. + Axiom mul_succ_l : forall n m, S n * m == n * m + m. +End IsAddSubMul. + +Module Type NZBasicFunsSig := NZDomainSig <+ AddSubMul <+ IsAddSubMul. +Module Type NZBasicFunsSig' := NZDomainSig' <+ AddSubMul' <+IsAddSubMul. + +(** Old name for the same interface: *) + +Module Type NZAxiomsSig := NZBasicFunsSig. +Module Type NZAxiomsSig' := NZBasicFunsSig'. + +(** Axiomatization of order *) + +Module Type NZOrd := NZDomainSig <+ HasLt <+ HasLe. +Module Type NZOrd' := NZDomainSig' <+ HasLt <+ HasLe <+ + LtNotation <+ LeNotation <+ LtLeNotation. + +Module Type IsNZOrd (Import NZ : NZOrd'). + Declare Instance lt_wd : Proper (eq ==> eq ==> iff) lt. + Axiom lt_eq_cases : forall n m, n <= m <-> n < m \/ n == m. + Axiom lt_irrefl : forall n, ~ (n < n). + Axiom lt_succ_r : forall n m, n < S m <-> n <= m. +End IsNZOrd. + +(** NB: the compatibility of [le] can be proved later from [lt_wd] + and [lt_eq_cases] *) + +Module Type NZOrdSig := NZOrd <+ IsNZOrd. +Module Type NZOrdSig' := NZOrd' <+ IsNZOrd. + +(** Everything together : *) + +Module Type NZOrdAxiomsSig <: NZBasicFunsSig <: NZOrdSig + := NZOrdSig <+ AddSubMul <+ IsAddSubMul <+ HasMinMax. +Module Type NZOrdAxiomsSig' <: NZOrdAxiomsSig + := NZOrdSig' <+ AddSubMul' <+ IsAddSubMul <+ HasMinMax. + + +(** Same, plus a comparison function. *) + +Module Type NZDecOrdSig := NZOrdSig <+ HasCompare. +Module Type NZDecOrdSig' := NZOrdSig' <+ HasCompare. + +Module Type NZDecOrdAxiomsSig := NZOrdAxiomsSig <+ HasCompare. +Module Type NZDecOrdAxiomsSig' := NZOrdAxiomsSig' <+ HasCompare. + +(** A square function *) + +Module Type NZSquare (Import NZ : NZBasicFunsSig'). + Parameter Inline square : t -> t. + Axiom square_spec : forall n, square n == n * n. +End NZSquare. diff --git a/theories/Numbers/NatInt/NZBase.v b/theories/Numbers/NatInt/NZBase.v new file mode 100644 index 0000000000..840a798d9b --- /dev/null +++ b/theories/Numbers/NatInt/NZBase.v @@ -0,0 +1,89 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Import NZAxioms. + +Module Type NZBaseProp (Import NZ : NZDomainSig'). + +Include BackportEq NZ NZ. (** eq_refl, eq_sym, eq_trans *) + +Lemma eq_sym_iff : forall x y, x==y <-> y==x. +Proof. +intros; split; symmetry; auto. +Qed. + +(* TODO: how register ~= (which is just a notation) as a Symmetric relation, + hence allowing "symmetry" tac ? *) + +Theorem neq_sym : forall n m, n ~= m -> m ~= n. +Proof. +intros n m H1 H2; symmetry in H2; false_hyp H2 H1. +Qed. + +Theorem eq_stepl : forall x y z, x == y -> x == z -> z == y. +Proof. +intros x y z H1 H2; now rewrite <- H1. +Qed. + +Declare Left Step eq_stepl. +(* The right step lemma is just the transitivity of eq *) +Declare Right Step (@Equivalence_Transitive _ _ eq_equiv). + +Theorem succ_inj : forall n1 n2, S n1 == S n2 -> n1 == n2. +Proof. +intros n1 n2 H. +apply pred_wd in H. now do 2 rewrite pred_succ in H. +Qed. + +(* The following theorem is useful as an equivalence for proving +bidirectional induction steps *) +Theorem succ_inj_wd : forall n1 n2, S n1 == S n2 <-> n1 == n2. +Proof. +intros; split. +- apply succ_inj. +- intros. now f_equiv. +Qed. + +Theorem succ_inj_wd_neg : forall n m, S n ~= S m <-> n ~= m. +Proof. +intros; now rewrite succ_inj_wd. +Qed. + +(* We cannot prove that the predecessor is injective, nor that it is +left-inverse to the successor at this point *) + +Section CentralInduction. + +Variable A : t -> Prop. +Hypothesis A_wd : Proper (eq==>iff) A. + +Theorem central_induction : + forall z, A z -> + (forall n, A n <-> A (S n)) -> + forall n, A n. +Proof. +intros z Base Step; revert Base; pattern z; apply bi_induction. +- solve_proper. +- intro; now apply bi_induction. +- intro; pose proof (Step n); tauto. +Qed. + +End CentralInduction. + +Tactic Notation "nzinduct" ident(n) := + induction_maker n ltac:(apply bi_induction). + +Tactic Notation "nzinduct" ident(n) constr(u) := + induction_maker n ltac:(apply central_induction with (z := u)). + +End NZBaseProp. + diff --git a/theories/Numbers/NatInt/NZBits.v b/theories/Numbers/NatInt/NZBits.v new file mode 100644 index 0000000000..eefa51572f --- /dev/null +++ b/theories/Numbers/NatInt/NZBits.v @@ -0,0 +1,66 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import Bool NZAxioms NZMulOrder NZParity NZPow NZDiv NZLog. + +(** Axiomatization of some bitwise operations *) + +Module Type Bits (Import A : Typ). + Parameter Inline testbit : t -> t -> bool. + Parameters Inline shiftl shiftr land lor ldiff lxor : t -> t -> t. + Parameter Inline div2 : t -> t. +End Bits. + +Module Type BitsNotation (Import A : Typ)(Import B : Bits A). + Notation "a .[ n ]" := (testbit a n) (at level 5, format "a .[ n ]"). + Infix ">>" := shiftr (at level 30, no associativity). + Infix "<<" := shiftl (at level 30, no associativity). +End BitsNotation. + +Module Type Bits' (A:Typ) := Bits A <+ BitsNotation A. + +Module Type NZBitsSpec + (Import A : NZOrdAxiomsSig')(Import B : Bits' A). + + Declare Instance testbit_wd : Proper (eq==>eq==>Logic.eq) testbit. + Axiom testbit_odd_0 : forall a, (2*a+1).[0] = true. + Axiom testbit_even_0 : forall a, (2*a).[0] = false. + Axiom testbit_odd_succ : forall a n, 0<=n -> (2*a+1).[S n] = a.[n]. + Axiom testbit_even_succ : forall a n, 0<=n -> (2*a).[S n] = a.[n]. + Axiom testbit_neg_r : forall a n, n<0 -> a.[n] = false. + + Axiom shiftr_spec : forall a n m, 0<=m -> (a >> n).[m] = a.[m+n]. + Axiom shiftl_spec_high : forall a n m, 0<=m -> n<=m -> (a << n).[m] = a.[m-n]. + Axiom shiftl_spec_low : forall a n m, m<n -> (a << n).[m] = false. + + Axiom land_spec : forall a b n, (land a b).[n] = a.[n] && b.[n]. + Axiom lor_spec : forall a b n, (lor a b).[n] = a.[n] || b.[n]. + Axiom ldiff_spec : forall a b n, (ldiff a b).[n] = a.[n] && negb b.[n]. + Axiom lxor_spec : forall a b n, (lxor a b).[n] = xorb a.[n] b.[n]. + Axiom div2_spec : forall a, div2 a == a >> 1. + +End NZBitsSpec. + +Module Type NZBits (A:NZOrdAxiomsSig) := Bits A <+ NZBitsSpec A. +Module Type NZBits' (A:NZOrdAxiomsSig) := Bits' A <+ NZBitsSpec A. + +(** In the functor of properties will also be defined: + - [setbit : t -> t -> t ] defined as [lor a (1<<n)]. + - [clearbit : t -> t -> t ] defined as [ldiff a (1<<n)]. + - [ones : t -> t], the number with [n] initial true bits, + corresponding to [2^n - 1]. + - a logical complement [lnot]. For integer numbers it will + be a [t->t], doing a swap of all bits, while on natural + numbers, it will be a bounded complement [t->t->t], swapping + only the first [n] bits. +*) + +(** For the moment, no shared properties about NZ here, + since properties and proofs for N and Z are quite different *) diff --git a/theories/Numbers/NatInt/NZDiv.v b/theories/Numbers/NatInt/NZDiv.v new file mode 100644 index 0000000000..b94cef7cee --- /dev/null +++ b/theories/Numbers/NatInt/NZDiv.v @@ -0,0 +1,548 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Euclidean Division *) + +Require Import NZAxioms NZMulOrder. + +(** The first signatures will be common to all divisions over NZ, N and Z *) + +Module Type DivMod (Import A : Typ). + Parameters Inline div modulo : t -> t -> t. +End DivMod. + +Module Type DivModNotation (A : Typ)(Import B : DivMod A). + Infix "/" := div. + Infix "mod" := modulo (at level 40, no associativity). +End DivModNotation. + +Module Type DivMod' (A : Typ) := DivMod A <+ DivModNotation A. + +Module Type NZDivSpec (Import A : NZOrdAxiomsSig')(Import B : DivMod' A). + Declare Instance div_wd : Proper (eq==>eq==>eq) div. + Declare Instance mod_wd : Proper (eq==>eq==>eq) modulo. + Axiom div_mod : forall a b, b ~= 0 -> a == b*(a/b) + (a mod b). + Axiom mod_bound_pos : forall a b, 0<=a -> 0<b -> 0 <= a mod b < b. +End NZDivSpec. + +(** The different divisions will only differ in the conditions + they impose on [modulo]. For NZ, we have only described the + behavior on positive numbers. +*) + +Module Type NZDiv (A : NZOrdAxiomsSig) := DivMod A <+ NZDivSpec A. +Module Type NZDiv' (A : NZOrdAxiomsSig) := NZDiv A <+ DivModNotation A. + +Module Type NZDivProp + (Import A : NZOrdAxiomsSig') + (Import B : NZDiv' A) + (Import C : NZMulOrderProp A). + +(** Uniqueness theorems *) + +Theorem div_mod_unique : + forall b q1 q2 r1 r2, 0<=r1<b -> 0<=r2<b -> + b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. +Proof. +intros b. +assert (U : forall q1 q2 r1 r2, + b*q1+r1 == b*q2+r2 -> 0<=r1<b -> 0<=r2 -> q1<q2 -> False). +- intros q1 q2 r1 r2 EQ LT Hr1 Hr2. + contradict EQ. + apply lt_neq. + apply lt_le_trans with (b*q1+b). + + rewrite <- add_lt_mono_l. tauto. + + apply le_trans with (b*q2). + * rewrite mul_comm, <- mul_succ_l, mul_comm. + apply mul_le_mono_nonneg_l; intuition; try order. + rewrite le_succ_l; auto. + * rewrite <- (add_0_r (b*q2)) at 1. + rewrite <- add_le_mono_l. tauto. + +- intros q1 q2 r1 r2 Hr1 Hr2 EQ; destruct (lt_trichotomy q1 q2) as [LT|[EQ'|GT]]. + + elim (U q1 q2 r1 r2); intuition. + + split; auto. rewrite EQ' in EQ. rewrite add_cancel_l in EQ; auto. + + elim (U q2 q1 r2 r1); intuition. +Qed. + +Theorem div_unique: + forall a b q r, 0<=a -> 0<=r<b -> + a == b*q + r -> q == a/b. +Proof. +intros a b q r Ha (Hb,Hr) EQ. +destruct (div_mod_unique b q (a/b) r (a mod b)); auto. +- apply mod_bound_pos; order. +- rewrite <- div_mod; order. +Qed. + +Theorem mod_unique: + forall a b q r, 0<=a -> 0<=r<b -> + a == b*q + r -> r == a mod b. +Proof. +intros a b q r Ha (Hb,Hr) EQ. +destruct (div_mod_unique b q (a/b) r (a mod b)); auto. +- apply mod_bound_pos; order. +- rewrite <- div_mod; order. +Qed. + +Theorem div_unique_exact a b q: + 0<=a -> 0<b -> a == b*q -> q == a/b. +Proof. + intros Ha Hb H. apply div_unique with 0; nzsimpl; now try split. +Qed. + +(** A division by itself returns 1 *) + +Lemma div_same : forall a, 0<a -> a/a == 1. +Proof. +intros. symmetry. apply div_unique_exact; nzsimpl; order. +Qed. + +Lemma mod_same : forall a, 0<a -> a mod a == 0. +Proof. +intros. symmetry. +apply mod_unique with 1; intuition; try order. +now nzsimpl. +Qed. + +(** A division of a small number by a bigger one yields zero. *) + +Theorem div_small: forall a b, 0<=a<b -> a/b == 0. +Proof. +intros. symmetry. +apply div_unique with a; intuition; try order. +now nzsimpl. +Qed. + +(** Same situation, in term of modulo: *) + +Theorem mod_small: forall a b, 0<=a<b -> a mod b == a. +Proof. +intros. symmetry. +apply mod_unique with 0; intuition; try order. +now nzsimpl. +Qed. + +(** * Basic values of divisions and modulo. *) + +Lemma div_0_l: forall a, 0<a -> 0/a == 0. +Proof. +intros; apply div_small; split; order. +Qed. + +Lemma mod_0_l: forall a, 0<a -> 0 mod a == 0. +Proof. +intros; apply mod_small; split; order. +Qed. + +Lemma div_1_r: forall a, 0<=a -> a/1 == a. +Proof. +intros. symmetry. apply div_unique_exact; nzsimpl; order'. +Qed. + +Lemma mod_1_r: forall a, 0<=a -> a mod 1 == 0. +Proof. +intros. symmetry. +apply mod_unique with a; try split; try order; try apply lt_0_1. +now nzsimpl. +Qed. + +Lemma div_1_l: forall a, 1<a -> 1/a == 0. +Proof. +intros; apply div_small; split; auto. apply le_0_1. +Qed. + +Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1. +Proof. +intros; apply mod_small; split; auto. apply le_0_1. +Qed. + +Lemma div_mul : forall a b, 0<=a -> 0<b -> (a*b)/b == a. +Proof. +intros; symmetry. apply div_unique_exact; trivial. +- apply mul_nonneg_nonneg; order. +- apply mul_comm. +Qed. + +Lemma mod_mul : forall a b, 0<=a -> 0<b -> (a*b) mod b == 0. +Proof. +intros; symmetry. +apply mod_unique with a; try split; try order. +- apply mul_nonneg_nonneg; order. +- nzsimpl; apply mul_comm. +Qed. + + +(** * Order results about mod and div *) + +(** A modulo cannot grow beyond its starting point. *) + +Theorem mod_le: forall a b, 0<=a -> 0<b -> a mod b <= a. +Proof. +intros. destruct (le_gt_cases b a). +- apply le_trans with b; auto. + apply lt_le_incl. destruct (mod_bound_pos a b); auto. +- rewrite lt_eq_cases; right. + apply mod_small; auto. +Qed. + + +(* Division of positive numbers is positive. *) + +Lemma div_pos: forall a b, 0<=a -> 0<b -> 0 <= a/b. +Proof. +intros. +rewrite (mul_le_mono_pos_l _ _ b); auto; nzsimpl. +rewrite (add_le_mono_r _ _ (a mod b)). +rewrite <- div_mod by order. +nzsimpl. +apply mod_le; auto. +Qed. + +Lemma div_str_pos : forall a b, 0<b<=a -> 0 < a/b. +Proof. +intros a b (Hb,Hab). +assert (LE : 0 <= a/b) by (apply div_pos; order). +assert (MOD : a mod b < b) by (destruct (mod_bound_pos a b); order). +rewrite lt_eq_cases in LE; destruct LE as [LT|EQ]; auto. +exfalso; revert Hab. +rewrite (div_mod a b), <-EQ; nzsimpl; order. +Qed. + +Lemma div_small_iff : forall a b, 0<=a -> 0<b -> (a/b==0 <-> a<b). +Proof. +intros a b Ha Hb; split; intros Hab. +- destruct (lt_ge_cases a b); auto. + symmetry in Hab. contradict Hab. apply lt_neq, div_str_pos; auto. +- apply div_small; auto. +Qed. + +Lemma mod_small_iff : forall a b, 0<=a -> 0<b -> (a mod b == a <-> a<b). +Proof. +intros a b Ha Hb. split; intros H; auto using mod_small. +rewrite <- div_small_iff; auto. +rewrite <- (mul_cancel_l _ _ b) by order. +rewrite <- (add_cancel_r _ _ (a mod b)). +rewrite <- div_mod, H by order. now nzsimpl. +Qed. + +Lemma div_str_pos_iff : forall a b, 0<=a -> 0<b -> (0<a/b <-> b<=a). +Proof. +intros a b Ha Hb; split; intros Hab. +- destruct (lt_ge_cases a b) as [LT|LE]; auto. + rewrite <- div_small_iff in LT; order. +- apply div_str_pos; auto. +Qed. + + +(** As soon as the divisor is strictly greater than 1, + the division is strictly decreasing. *) + +Lemma div_lt : forall a b, 0<a -> 1<b -> a/b < a. +Proof. +intros. +assert (0 < b) by (apply lt_trans with 1; auto using lt_0_1). +destruct (lt_ge_cases a b). +- rewrite div_small; try split; order. +- rewrite (div_mod a b) at 2 by order. + apply lt_le_trans with (b*(a/b)). + + rewrite <- (mul_1_l (a/b)) at 1. + rewrite <- mul_lt_mono_pos_r; auto. + apply div_str_pos; auto. + + rewrite <- (add_0_r (b*(a/b))) at 1. + rewrite <- add_le_mono_l. destruct (mod_bound_pos a b); order. +Qed. + +(** [le] is compatible with a positive division. *) + +Lemma div_le_mono : forall a b c, 0<c -> 0<=a<=b -> a/c <= b/c. +Proof. +intros a b c Hc (Ha,Hab). +rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ]; + [|rewrite EQ; order]. +rewrite <- lt_succ_r. +rewrite (mul_lt_mono_pos_l c) by order. +nzsimpl. +rewrite (add_lt_mono_r _ _ (a mod c)). +rewrite <- div_mod by order. +apply lt_le_trans with b; auto. +rewrite (div_mod b c) at 1 by order. +rewrite <- add_assoc, <- add_le_mono_l. +apply le_trans with (c+0). +- nzsimpl; destruct (mod_bound_pos b c); order. +- rewrite <- add_le_mono_l. destruct (mod_bound_pos a c); order. +Qed. + +(** The following two properties could be used as specification of div *) + +Lemma mul_div_le : forall a b, 0<=a -> 0<b -> b*(a/b) <= a. +Proof. +intros. +rewrite (add_le_mono_r _ _ (a mod b)), <- div_mod by order. +rewrite <- (add_0_r a) at 1. +rewrite <- add_le_mono_l. destruct (mod_bound_pos a b); order. +Qed. + +Lemma mul_succ_div_gt : forall a b, 0<=a -> 0<b -> a < b*(S (a/b)). +Proof. +intros. +rewrite (div_mod a b) at 1 by order. +rewrite (mul_succ_r). +rewrite <- add_lt_mono_l. +destruct (mod_bound_pos a b); auto. +Qed. + + +(** The previous inequality is exact iff the modulo is zero. *) + +Lemma div_exact : forall a b, 0<=a -> 0<b -> (a == b*(a/b) <-> a mod b == 0). +Proof. +intros. rewrite (div_mod a b) at 1 by order. +rewrite <- (add_0_r (b*(a/b))) at 2. +apply add_cancel_l. +Qed. + +(** Some additional inequalities about div. *) + +Theorem div_lt_upper_bound: + forall a b q, 0<=a -> 0<b -> a < b*q -> a/b < q. +Proof. +intros. +rewrite (mul_lt_mono_pos_l b) by order. +apply le_lt_trans with a; auto. +apply mul_div_le; auto. +Qed. + +Theorem div_le_upper_bound: + forall a b q, 0<=a -> 0<b -> a <= b*q -> a/b <= q. +Proof. +intros. +rewrite (mul_le_mono_pos_l _ _ b) by order. +apply le_trans with a; auto. +apply mul_div_le; auto. +Qed. + +Theorem div_le_lower_bound: + forall a b q, 0<=a -> 0<b -> b*q <= a -> q <= a/b. +Proof. +intros a b q Ha Hb H. +destruct (lt_ge_cases 0 q). +- rewrite <- (div_mul q b); try order. + apply div_le_mono; auto. + rewrite mul_comm; split; auto. + apply lt_le_incl, mul_pos_pos; auto. +- apply le_trans with 0; auto; apply div_pos; auto. +Qed. + +(** A division respects opposite monotonicity for the divisor *) + +Lemma div_le_compat_l: forall p q r, 0<=p -> 0<q<=r -> + p/r <= p/q. +Proof. + intros p q r Hp (Hq,Hqr). + apply div_le_lower_bound; auto. + rewrite (div_mod p r) at 2 by order. + apply le_trans with (r*(p/r)). + - apply mul_le_mono_nonneg_r; try order. + apply div_pos; order. + - rewrite <- (add_0_r (r*(p/r))) at 1. + rewrite <- add_le_mono_l. destruct (mod_bound_pos p r); order. +Qed. + + +(** * Relations between usual operations and mod and div *) + +Lemma mod_add : forall a b c, 0<=a -> 0<=a+b*c -> 0<c -> + (a + b * c) mod c == a mod c. +Proof. + intros. + symmetry. + apply mod_unique with (a/c+b); auto. + - apply mod_bound_pos; auto. + - rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. + now rewrite mul_comm. +Qed. + +Lemma div_add : forall a b c, 0<=a -> 0<=a+b*c -> 0<c -> + (a + b * c) / c == a / c + b. +Proof. + intros. + apply (mul_cancel_l _ _ c); try order. + apply (add_cancel_r _ _ ((a+b*c) mod c)). + rewrite <- div_mod, mod_add by order. + rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. + now rewrite mul_comm. +Qed. + +Lemma div_add_l: forall a b c, 0<=c -> 0<=a*b+c -> 0<b -> + (a * b + c) / b == a + c / b. +Proof. + intros a b c. rewrite (add_comm _ c), (add_comm a). + intros. apply div_add; auto. +Qed. + +(** Cancellations. *) + +Lemma div_mul_cancel_r : forall a b c, 0<=a -> 0<b -> 0<c -> + (a*c)/(b*c) == a/b. +Proof. + intros. + symmetry. + apply div_unique with ((a mod b)*c). + - apply mul_nonneg_nonneg; order. + - split. + + apply mul_nonneg_nonneg; destruct (mod_bound_pos a b); order. + + rewrite <- mul_lt_mono_pos_r; auto. destruct (mod_bound_pos a b); auto. + - rewrite (div_mod a b) at 1 by order. + rewrite mul_add_distr_r. + rewrite add_cancel_r. + rewrite <- 2 mul_assoc. now rewrite (mul_comm c). +Qed. + +Lemma div_mul_cancel_l : forall a b c, 0<=a -> 0<b -> 0<c -> + (c*a)/(c*b) == a/b. +Proof. + intros. rewrite !(mul_comm c); apply div_mul_cancel_r; auto. +Qed. + +Lemma mul_mod_distr_l: forall a b c, 0<=a -> 0<b -> 0<c -> + (c*a) mod (c*b) == c * (a mod b). +Proof. + intros. + rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))). + rewrite <- div_mod. + - rewrite div_mul_cancel_l; auto. + rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. + apply div_mod; order. + - rewrite <- neq_mul_0; intuition; order. +Qed. + +Lemma mul_mod_distr_r: forall a b c, 0<=a -> 0<b -> 0<c -> + (a*c) mod (b*c) == (a mod b) * c. +Proof. + intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l. +Qed. + +(** Operations modulo. *) + +Theorem mod_mod: forall a n, 0<=a -> 0<n -> + (a mod n) mod n == a mod n. +Proof. + intros. destruct (mod_bound_pos a n); auto. now rewrite mod_small_iff. +Qed. + +Lemma mul_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0<n -> + ((a mod n)*b) mod n == (a*b) mod n. +Proof. + intros a b n Ha Hb Hn. symmetry. + generalize (mul_nonneg_nonneg _ _ Ha Hb). + rewrite (div_mod a n) at 1 2 by order. + rewrite add_comm, (mul_comm n), (mul_comm _ b). + rewrite mul_add_distr_l, mul_assoc. + intros. rewrite mod_add; auto. + - now rewrite mul_comm. + - apply mul_nonneg_nonneg; destruct (mod_bound_pos a n); auto. +Qed. + +Lemma mul_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0<n -> + (a*(b mod n)) mod n == (a*b) mod n. +Proof. + intros. rewrite !(mul_comm a). apply mul_mod_idemp_l; auto. +Qed. + +Theorem mul_mod: forall a b n, 0<=a -> 0<=b -> 0<n -> + (a * b) mod n == ((a mod n) * (b mod n)) mod n. +Proof. + intros. rewrite mul_mod_idemp_l, mul_mod_idemp_r; trivial. - reflexivity. + - now destruct (mod_bound_pos b n). +Qed. + +Lemma add_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0<n -> + ((a mod n)+b) mod n == (a+b) mod n. +Proof. + intros a b n Ha Hb Hn. symmetry. + generalize (add_nonneg_nonneg _ _ Ha Hb). + rewrite (div_mod a n) at 1 2 by order. + rewrite <- add_assoc, add_comm, mul_comm. + intros. rewrite mod_add; trivial. - reflexivity. + - apply add_nonneg_nonneg; auto. destruct (mod_bound_pos a n); auto. +Qed. + +Lemma add_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0<n -> + (a+(b mod n)) mod n == (a+b) mod n. +Proof. + intros. rewrite !(add_comm a). apply add_mod_idemp_l; auto. +Qed. + +Theorem add_mod: forall a b n, 0<=a -> 0<=b -> 0<n -> + (a+b) mod n == (a mod n + b mod n) mod n. +Proof. + intros. rewrite add_mod_idemp_l, add_mod_idemp_r; trivial. - reflexivity. + - now destruct (mod_bound_pos b n). +Qed. + +Lemma div_div : forall a b c, 0<=a -> 0<b -> 0<c -> + (a/b)/c == a/(b*c). +Proof. + intros a b c Ha Hb Hc. + apply div_unique with (b*((a/b) mod c) + a mod b); trivial. + (* begin 0<= ... <b*c *) + - destruct (mod_bound_pos (a/b) c), (mod_bound_pos a b); auto using div_pos. + split. + + apply add_nonneg_nonneg; auto. + apply mul_nonneg_nonneg; order. + + apply lt_le_trans with (b*((a/b) mod c) + b). + * rewrite <- add_lt_mono_l; auto. + * rewrite <- mul_succ_r, <- mul_le_mono_pos_l, le_succ_l; auto. + (* end 0<= ... < b*c *) + - rewrite (div_mod a b) at 1 by order. + rewrite add_assoc, add_cancel_r. + rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. + apply div_mod; order. +Qed. + +Lemma mod_mul_r : forall a b c, 0<=a -> 0<b -> 0<c -> + a mod (b*c) == a mod b + b*((a/b) mod c). +Proof. + intros a b c Ha Hb Hc. + apply add_cancel_l with (b*c*(a/(b*c))). + rewrite <- div_mod by (apply neq_mul_0; split; order). + rewrite <- div_div by trivial. + rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l. + rewrite <- div_mod by order. + apply div_mod; order. +Qed. + +(** A last inequality: *) + +Theorem div_mul_le: + forall a b c, 0<=a -> 0<b -> 0<=c -> c*(a/b) <= (c*a)/b. +Proof. + intros. + apply div_le_lower_bound; auto. + - apply mul_nonneg_nonneg; auto. + - rewrite mul_assoc, (mul_comm b c), <- mul_assoc. + apply mul_le_mono_nonneg_l; auto. + apply mul_div_le; auto. +Qed. + +(** mod is related to divisibility *) + +Lemma mod_divides : forall a b, 0<=a -> 0<b -> + (a mod b == 0 <-> exists c, a == b*c). +Proof. + split. + - intros. exists (a/b). rewrite div_exact; auto. + - intros (c,Hc). rewrite Hc, mul_comm. apply mod_mul; auto. + rewrite (mul_le_mono_pos_l _ _ b); auto. nzsimpl. order. +Qed. + +End NZDivProp. + diff --git a/theories/Numbers/NatInt/NZDomain.v b/theories/Numbers/NatInt/NZDomain.v new file mode 100644 index 0000000000..acebfcf1d2 --- /dev/null +++ b/theories/Numbers/NatInt/NZDomain.v @@ -0,0 +1,364 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Export NumPrelude NZAxioms. +Require Import NZBase NZOrder NZAddOrder Plus Minus. + +(** In this file, we investigate the shape of domains satisfying + the [NZDomainSig] interface. In particular, we define a + translation from Peano numbers [nat] into NZ. +*) + +Local Notation "f ^ n" := (fun x => nat_rect _ x (fun _ => f) n). + +Instance nat_rect_wd n {A} (R:relation A) : + Proper (R==>(R==>R)==>R) (fun x f => nat_rect (fun _ => _) x (fun _ => f) n). +Proof. +intros x y eq_xy f g eq_fg; induction n; [assumption | now apply eq_fg]. +Qed. + +Module NZDomainProp (Import NZ:NZDomainSig'). +Include NZBaseProp NZ. + +(** * Relationship between points thanks to [succ] and [pred]. *) + +(** For any two points, one is an iterated successor of the other. *) + +Lemma itersucc_or_itersucc n m : exists k, n == (S^k) m \/ m == (S^k) n. +Proof. +revert n. +apply central_induction with (z:=m). + { intros x y eq_xy; apply ex_iff_morphism. + intros n; apply or_iff_morphism. + + split; intros; etransitivity; try eassumption; now symmetry. + + split; intros; (etransitivity; [eassumption|]); [|symmetry]; + (eapply nat_rect_wd; [eassumption|apply succ_wd]). + } +exists 0%nat. now left. +intros n. split; intros [k [L|R]]. +exists (Datatypes.S k). left. now apply succ_wd. +destruct k as [|k]. +simpl in R. exists 1%nat. left. now apply succ_wd. +rewrite nat_rect_succ_r in R. exists k. now right. +destruct k as [|k]; simpl in L. +exists 1%nat. now right. +apply succ_inj in L. exists k. now left. +exists (Datatypes.S k). right. now rewrite nat_rect_succ_r. +Qed. + +(** Generalized version of [pred_succ] when iterating *) + +Lemma succ_swap_pred : forall k n m, n == (S^k) m -> m == (P^k) n. +Proof. +induction k. +simpl; auto with *. +simpl; intros. apply pred_wd in H. rewrite pred_succ in H. apply IHk in H; auto. +rewrite <- nat_rect_succ_r in H; auto. +Qed. + +(** From a given point, all others are iterated successors + or iterated predecessors. *) + +Lemma itersucc_or_iterpred : forall n m, exists k, n == (S^k) m \/ n == (P^k) m. +Proof. +intros n m. destruct (itersucc_or_itersucc n m) as (k,[H|H]). +exists k; left; auto. +exists k; right. apply succ_swap_pred; auto. +Qed. + +(** In particular, all points are either iterated successors of [0] + or iterated predecessors of [0] (or both). *) + +Lemma itersucc0_or_iterpred0 : + forall n, exists p:nat, n == (S^p) 0 \/ n == (P^p) 0. +Proof. + intros n. exact (itersucc_or_iterpred n 0). +Qed. + +(** * Study of initial point w.r.t. [succ] (if any). *) + +Definition initial n := forall m, n ~= S m. + +Lemma initial_alt : forall n, initial n <-> S (P n) ~= n. +Proof. +split. intros Bn EQ. symmetry in EQ. destruct (Bn _ EQ). +intros NEQ m EQ. apply NEQ. rewrite EQ, pred_succ; auto with *. +Qed. + +Lemma initial_alt2 : forall n, initial n <-> ~exists m, n == S m. +Proof. firstorder. Qed. + +(** First case: let's assume such an initial point exists + (i.e. [S] isn't surjective)... *) + +Section InitialExists. +Hypothesis init : t. +Hypothesis Initial : initial init. + +(** ... then we have unicity of this initial point. *) + +Lemma initial_unique : forall m, initial m -> m == init. +Proof. +intros m Im. destruct (itersucc_or_itersucc init m) as (p,[H|H]). +destruct p. now simpl in *. destruct (Initial _ H). +destruct p. now simpl in *. destruct (Im _ H). +Qed. + +(** ... then all other points are descendant of it. *) + +Lemma initial_ancestor : forall m, exists p, m == (S^p) init. +Proof. +intros m. destruct (itersucc_or_itersucc init m) as (p,[H|H]). +destruct p; simpl in *; auto. exists O; auto with *. destruct (Initial _ H). +exists p; auto. +Qed. + +(** NB : We would like to have [pred n == n] for the initial element, + but nothing forces that. For instance we can have -3 as initial point, + and P(-3) = 2. A bit odd indeed, but legal according to [NZDomainSig]. + We can hence have [n == (P^k) m] without [exists k', m == (S^k') n]. +*) + +(** We need decidability of [eq] (or classical reasoning) for this: *) + +Section SuccPred. +Hypothesis eq_decidable : forall n m, n==m \/ n~=m. +Lemma succ_pred_approx : forall n, ~initial n -> S (P n) == n. +Proof. +intros n NB. rewrite initial_alt in NB. +destruct (eq_decidable (S (P n)) n); auto. +elim NB; auto. +Qed. +End SuccPred. +End InitialExists. + +(** Second case : let's suppose now [S] surjective, i.e. no initial point. *) + +Section InitialDontExists. + +Hypothesis succ_onto : forall n, exists m, n == S m. + +Lemma succ_onto_gives_succ_pred : forall n, S (P n) == n. +Proof. +intros n. destruct (succ_onto n) as (m,H). rewrite H, pred_succ; auto with *. +Qed. + +Lemma succ_onto_pred_injective : forall n m, P n == P m -> n == m. +Proof. +intros n m. intros H; apply succ_wd in H. +rewrite !succ_onto_gives_succ_pred in H; auto. +Qed. + +End InitialDontExists. + + +(** To summarize: + + S is always injective, P is always surjective (thanks to [pred_succ]). + + I) If S is not surjective, we have an initial point, which is unique. + This bottom is below zero: we have N shifted (or not) to the left. + P cannot be injective: P init = P (S (P init)). + (P init) can be arbitrary. + + II) If S is surjective, we have [forall n, S (P n) = n], S and P are + bijective and reciprocal. + + IIa) if [exists k<>O, 0 == S^k 0], then we have a cyclic structure Z/nZ + IIb) otherwise, we have Z +*) + + +(** * An alternative induction principle using [S] and [P]. *) + +(** It is weaker than [bi_induction]. For instance it cannot prove that + we can go from one point by many [S] _or_ many [P], but only by many + [S] mixed with many [P]. Think of a model with two copies of N: + + 0, 1=S 0, 2=S 1, ... + 0', 1'=S 0', 2'=S 1', ... + + and P 0 = 0' and P 0' = 0. +*) + +Lemma bi_induction_pred : + forall A : t -> Prop, Proper (eq==>iff) A -> + A 0 -> (forall n, A n -> A (S n)) -> (forall n, A n -> A (P n)) -> + forall n, A n. +Proof. +intros. apply bi_induction; auto. +clear n. intros n; split; auto. +intros G; apply H2 in G. rewrite pred_succ in G; auto. +Qed. + +Lemma central_induction_pred : + forall A : t -> Prop, Proper (eq==>iff) A -> forall n0, + A n0 -> (forall n, A n -> A (S n)) -> (forall n, A n -> A (P n)) -> + forall n, A n. +Proof. +intros. +assert (A 0). +destruct (itersucc_or_iterpred 0 n0) as (k,[Hk|Hk]); rewrite Hk; clear Hk. + clear H2. induction k; simpl in *; auto. + clear H1. induction k; simpl in *; auto. +apply bi_induction_pred; auto. +Qed. + +End NZDomainProp. + +(** We now focus on the translation from [nat] into [NZ]. + First, relationship with [0], [succ], [pred]. +*) + +Module NZOfNat (Import NZ:NZDomainSig'). + +Definition ofnat (n : nat) : t := (S^n) 0. + +Declare Scope ofnat. +Local Open Scope ofnat. +Notation "[ n ]" := (ofnat n) (at level 7) : ofnat. + +Lemma ofnat_zero : [O] == 0. +Proof. +reflexivity. +Qed. + +Lemma ofnat_succ : forall n, [Datatypes.S n] == succ [n]. +Proof. + now unfold ofnat. +Qed. + +Lemma ofnat_pred : forall n, n<>O -> [Peano.pred n] == P [n]. +Proof. + unfold ofnat. destruct n. destruct 1; auto. + intros _. simpl. symmetry. apply pred_succ. +Qed. + +(** Since [P 0] can be anything in NZ (either [-1], [0], or even other + numbers, we cannot state previous lemma for [n=O]. *) + +End NZOfNat. + + +(** If we require in addition a strict order on NZ, we can prove that + [ofnat] is injective, and hence that NZ is infinite + (i.e. we ban Z/nZ models) *) + +Module NZOfNatOrd (Import NZ:NZOrdSig'). +Include NZOfNat NZ. +Include NZBaseProp NZ <+ NZOrderProp NZ. +Local Open Scope ofnat. + +Theorem ofnat_S_gt_0 : + forall n : nat, 0 < [Datatypes.S n]. +Proof. +unfold ofnat. +intros n; induction n as [| n IH]; simpl in *. +apply lt_succ_diag_r. +apply lt_trans with (S 0). apply lt_succ_diag_r. now rewrite <- succ_lt_mono. +Qed. + +Theorem ofnat_S_neq_0 : + forall n : nat, 0 ~= [Datatypes.S n]. +Proof. +intros. apply lt_neq, ofnat_S_gt_0. +Qed. + +Lemma ofnat_injective : forall n m, [n]==[m] -> n = m. +Proof. +induction n as [|n IH]; destruct m; auto. +intros H; elim (ofnat_S_neq_0 _ H). +intros H; symmetry in H; elim (ofnat_S_neq_0 _ H). +intros. f_equal. apply IH. now rewrite <- succ_inj_wd. +Qed. + +Lemma ofnat_eq : forall n m, [n]==[m] <-> n = m. +Proof. +split. apply ofnat_injective. intros; now subst. +Qed. + +(* In addition, we can prove that [ofnat] preserves order. *) + +Lemma ofnat_lt : forall n m : nat, [n]<[m] <-> (n<m)%nat. +Proof. +induction n as [|n IH]; destruct m; repeat rewrite ofnat_zero; split. +intro H; elim (lt_irrefl _ H). +inversion 1. +auto with arith. +intros; apply ofnat_S_gt_0. +intro H; elim (lt_asymm _ _ H); apply ofnat_S_gt_0. +inversion 1. +rewrite !ofnat_succ, <- succ_lt_mono, IH; auto with arith. +rewrite !ofnat_succ, <- succ_lt_mono, IH; auto with arith. +Qed. + +Lemma ofnat_le : forall n m : nat, [n]<=[m] <-> (n<=m)%nat. +Proof. +intros. rewrite lt_eq_cases, ofnat_lt, ofnat_eq. +split. +destruct 1; subst; auto with arith. +apply Lt.le_lt_or_eq. +Qed. + +End NZOfNatOrd. + + +(** For basic operations, we can prove correspondance with + their counterpart in [nat]. *) + +Module NZOfNatOps (Import NZ:NZAxiomsSig'). +Include NZOfNat NZ. +Local Open Scope ofnat. + +Lemma ofnat_add_l : forall n m, [n]+m == (S^n) m. +Proof. + induction n; intros. + apply add_0_l. + rewrite ofnat_succ, add_succ_l. simpl. now f_equiv. +Qed. + +Lemma ofnat_add : forall n m, [n+m] == [n]+[m]. +Proof. + intros. rewrite ofnat_add_l. + induction n; simpl. reflexivity. + now f_equiv. +Qed. + +Lemma ofnat_mul : forall n m, [n*m] == [n]*[m]. +Proof. + induction n; simpl; intros. + symmetry. apply mul_0_l. + rewrite plus_comm. + rewrite ofnat_add, mul_succ_l. + now f_equiv. +Qed. + +Lemma ofnat_sub_r : forall n m, n-[m] == (P^m) n. +Proof. + induction m; simpl; intros. + apply sub_0_r. + rewrite sub_succ_r. now f_equiv. +Qed. + +Lemma ofnat_sub : forall n m, m<=n -> [n-m] == [n]-[m]. +Proof. + intros n m H. rewrite ofnat_sub_r. + revert n H. induction m. intros. + rewrite <- minus_n_O. now simpl. + intros. + destruct n. + inversion H. + rewrite nat_rect_succ_r. + simpl. + etransitivity. apply IHm. auto with arith. + eapply nat_rect_wd; [symmetry;apply pred_succ|apply pred_wd]. +Qed. + +End NZOfNatOps. diff --git a/theories/Numbers/NatInt/NZGcd.v b/theories/Numbers/NatInt/NZGcd.v new file mode 100644 index 0000000000..1ac89ce942 --- /dev/null +++ b/theories/Numbers/NatInt/NZGcd.v @@ -0,0 +1,309 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Greatest Common Divisor *) + +Require Import NZAxioms NZMulOrder. + +(** Interface of a gcd function, then its specification on naturals *) + +Module Type Gcd (Import A : Typ). + Parameter Inline gcd : t -> t -> t. +End Gcd. + +Module Type NZGcdSpec (A : NZOrdAxiomsSig')(B : Gcd A). + Import A B. + Definition divide n m := exists p, m == p*n. + Local Notation "( n | m )" := (divide n m) (at level 0). + Axiom gcd_divide_l : forall n m, (gcd n m | n). + Axiom gcd_divide_r : forall n m, (gcd n m | m). + Axiom gcd_greatest : forall n m p, (p | n) -> (p | m) -> (p | gcd n m). + Axiom gcd_nonneg : forall n m, 0 <= gcd n m. +End NZGcdSpec. + +Module Type DivideNotation (A:NZOrdAxiomsSig')(B:Gcd A)(C:NZGcdSpec A B). + Import A B C. + Notation "( n | m )" := (divide n m) (at level 0). +End DivideNotation. + +Module Type NZGcd (A : NZOrdAxiomsSig) := Gcd A <+ NZGcdSpec A. +Module Type NZGcd' (A : NZOrdAxiomsSig) := + Gcd A <+ NZGcdSpec A <+ DivideNotation A. + +(** Derived properties of gcd *) + +Module NZGcdProp + (Import A : NZOrdAxiomsSig') + (Import B : NZGcd' A) + (Import C : NZMulOrderProp A). + +(** Results concerning divisibility*) + +Instance divide_wd : Proper (eq==>eq==>iff) divide. +Proof. + unfold divide. intros x x' Hx y y' Hy. + setoid_rewrite Hx. setoid_rewrite Hy. easy. +Qed. + +Lemma divide_1_l : forall n, (1 | n). +Proof. + intros n. exists n. now nzsimpl. +Qed. + +Lemma divide_0_r : forall n, (n | 0). +Proof. + intros n. exists 0. now nzsimpl. +Qed. + +Lemma divide_0_l : forall n, (0 | n) -> n==0. +Proof. + intros n (m,Hm). revert Hm. now nzsimpl. +Qed. + +Lemma eq_mul_1_nonneg : forall n m, + 0<=n -> n*m == 1 -> n==1 /\ m==1. +Proof. + intros n m Hn H. + le_elim Hn. + - destruct (lt_ge_cases m 0) as [Hm|Hm]. + + generalize (mul_pos_neg n m Hn Hm). order'. + + le_elim Hm. + * apply le_succ_l in Hn. rewrite <- one_succ in Hn. + le_elim Hn. + -- generalize (lt_1_mul_pos n m Hn Hm). order. + -- rewrite <- Hn, mul_1_l in H. now split. + * rewrite <- Hm, mul_0_r in H. order'. + - rewrite <- Hn, mul_0_l in H. order'. +Qed. + +Lemma eq_mul_1_nonneg' : forall n m, + 0<=m -> n*m == 1 -> n==1 /\ m==1. +Proof. + intros n m Hm H. rewrite mul_comm in H. + now apply and_comm, eq_mul_1_nonneg. +Qed. + +Lemma divide_1_r_nonneg : forall n, 0<=n -> (n | 1) -> n==1. +Proof. + intros n Hn (m,Hm). symmetry in Hm. + now apply (eq_mul_1_nonneg' m n). +Qed. + +Lemma divide_refl : forall n, (n | n). +Proof. + intros n. exists 1. now nzsimpl. +Qed. + +Lemma divide_trans : forall n m p, (n | m) -> (m | p) -> (n | p). +Proof. + intros n m p (q,Hq) (r,Hr). exists (r*q). + now rewrite Hr, Hq, mul_assoc. +Qed. + +Instance divide_reflexive : Reflexive divide | 5 := divide_refl. +Instance divide_transitive : Transitive divide | 5 := divide_trans. + +(** Due to sign, no general antisymmetry result *) + +Lemma divide_antisym_nonneg : forall n m, + 0<=n -> 0<=m -> (n | m) -> (m | n) -> n == m. +Proof. + intros n m Hn Hm (q,Hq) (r,Hr). + le_elim Hn. + - destruct (lt_ge_cases q 0) as [Hq'|Hq']. + + generalize (mul_neg_pos q n Hq' Hn). order. + + rewrite Hq, mul_assoc in Hr. symmetry in Hr. + apply mul_id_l in Hr; [|order]. + destruct (eq_mul_1_nonneg' r q) as [_ H]; trivial. + now rewrite H, mul_1_l in Hq. + - rewrite <- Hn, mul_0_r in Hq. now rewrite <- Hn. +Qed. + +Lemma mul_divide_mono_l : forall n m p, (n | m) -> (p * n | p * m). +Proof. + intros n m p (q,Hq). exists q. now rewrite mul_shuffle3, Hq. +Qed. + +Lemma mul_divide_mono_r : forall n m p, (n | m) -> (n * p | m * p). +Proof. + intros n m p (q,Hq). exists q. now rewrite mul_assoc, Hq. +Qed. + +Lemma mul_divide_cancel_l : forall n m p, p ~= 0 -> + ((p * n | p * m) <-> (n | m)). +Proof. + intros n m p Hp. split. + - intros (q,Hq). exists q. now rewrite mul_shuffle3, mul_cancel_l in Hq. + - apply mul_divide_mono_l. +Qed. + +Lemma mul_divide_cancel_r : forall n m p, p ~= 0 -> + ((n * p | m * p) <-> (n | m)). +Proof. + intros. rewrite 2 (mul_comm _ p). now apply mul_divide_cancel_l. +Qed. + +Lemma divide_add_r : forall n m p, (n | m) -> (n | p) -> (n | m + p). +Proof. + intros n m p (q,Hq) (r,Hr). exists (q+r). + now rewrite mul_add_distr_r, Hq, Hr. +Qed. + +Lemma divide_mul_l : forall n m p, (n | m) -> (n | m * p). +Proof. + intros n m p (q,Hq). exists (q*p). now rewrite mul_shuffle0, Hq. +Qed. + +Lemma divide_mul_r : forall n m p, (n | p) -> (n | m * p). +Proof. + intros n m p. rewrite mul_comm. apply divide_mul_l. +Qed. + +Lemma divide_factor_l : forall n m, (n | n * m). +Proof. + intros. apply divide_mul_l, divide_refl. +Qed. + +Lemma divide_factor_r : forall n m, (n | m * n). +Proof. + intros. apply divide_mul_r, divide_refl. +Qed. + +Lemma divide_pos_le : forall n m, 0 < m -> (n | m) -> n <= m. +Proof. + intros n m Hm (q,Hq). + destruct (le_gt_cases n 0) as [Hn|Hn]. - order. + - rewrite Hq. + destruct (lt_ge_cases q 0) as [Hq'|Hq']. + + generalize (mul_neg_pos q n Hq' Hn). order. + + le_elim Hq'. + * rewrite <- (mul_1_l n) at 1. apply mul_le_mono_pos_r; trivial. + now rewrite one_succ, le_succ_l. + * rewrite <- Hq', mul_0_l in Hq. order. +Qed. + +(** Basic properties of gcd *) + +Lemma gcd_unique : forall n m p, + 0<=p -> (p|n) -> (p|m) -> + (forall q, (q|n) -> (q|m) -> (q|p)) -> + gcd n m == p. +Proof. + intros n m p Hp Hn Hm H. + apply divide_antisym_nonneg; trivial. - apply gcd_nonneg. + - apply H. + apply gcd_divide_l. + apply gcd_divide_r. + - now apply gcd_greatest. +Qed. + +Instance gcd_wd : Proper (eq==>eq==>eq) gcd. +Proof. + intros x x' Hx y y' Hy. + apply gcd_unique. + - apply gcd_nonneg. + - rewrite Hx. apply gcd_divide_l. + - rewrite Hy. apply gcd_divide_r. + - intro. rewrite Hx, Hy. apply gcd_greatest. +Qed. + +Lemma gcd_divide_iff : forall n m p, + (p | gcd n m) <-> (p | n) /\ (p | m). +Proof. + intros. split. - split. + + transitivity (gcd n m); trivial using gcd_divide_l. + + transitivity (gcd n m); trivial using gcd_divide_r. + - intros (H,H'). now apply gcd_greatest. +Qed. + +Lemma gcd_unique_alt : forall n m p, 0<=p -> + (forall q, (q|p) <-> (q|n) /\ (q|m)) -> + gcd n m == p. +Proof. + intros n m p Hp H. + apply gcd_unique; trivial. + - apply H. apply divide_refl. + - apply H. apply divide_refl. + - intros. apply H. now split. +Qed. + +Lemma gcd_comm : forall n m, gcd n m == gcd m n. +Proof. + intros. apply gcd_unique_alt; try apply gcd_nonneg. + intros. rewrite and_comm. apply gcd_divide_iff. +Qed. + +Lemma gcd_assoc : forall n m p, gcd n (gcd m p) == gcd (gcd n m) p. +Proof. + intros. apply gcd_unique_alt; try apply gcd_nonneg. + intros. now rewrite !gcd_divide_iff, and_assoc. +Qed. + +Lemma gcd_0_l_nonneg : forall n, 0<=n -> gcd 0 n == n. +Proof. + intros. apply gcd_unique; trivial. + - apply divide_0_r. + - apply divide_refl. +Qed. + +Lemma gcd_0_r_nonneg : forall n, 0<=n -> gcd n 0 == n. +Proof. + intros. now rewrite gcd_comm, gcd_0_l_nonneg. +Qed. + +Lemma gcd_1_l : forall n, gcd 1 n == 1. +Proof. + intros. apply gcd_unique; trivial using divide_1_l, le_0_1. +Qed. + +Lemma gcd_1_r : forall n, gcd n 1 == 1. +Proof. + intros. now rewrite gcd_comm, gcd_1_l. +Qed. + +Lemma gcd_diag_nonneg : forall n, 0<=n -> gcd n n == n. +Proof. + intros. apply gcd_unique; trivial using divide_refl. +Qed. + +Lemma gcd_eq_0_l : forall n m, gcd n m == 0 -> n == 0. +Proof. + intros. + generalize (gcd_divide_l n m). rewrite H. apply divide_0_l. +Qed. + +Lemma gcd_eq_0_r : forall n m, gcd n m == 0 -> m == 0. +Proof. + intros. apply gcd_eq_0_l with n. now rewrite gcd_comm. +Qed. + +Lemma gcd_eq_0 : forall n m, gcd n m == 0 <-> n == 0 /\ m == 0. +Proof. + intros. split. + - split. + + now apply gcd_eq_0_l with m. + + now apply gcd_eq_0_r with n. + - intros (EQ,EQ'). rewrite EQ, EQ'. now apply gcd_0_r_nonneg. +Qed. + +Lemma gcd_mul_diag_l : forall n m, 0<=n -> gcd n (n*m) == n. +Proof. + intros n m Hn. apply gcd_unique_alt; trivial. + intros q. split. - split; trivial. now apply divide_mul_l. + - now destruct 1. +Qed. + +Lemma divide_gcd_iff : forall n m, 0<=n -> ((n|m) <-> gcd n m == n). +Proof. + intros n m Hn. split. + - intros (q,Hq). rewrite Hq. + rewrite mul_comm. now apply gcd_mul_diag_l. + - intros EQ. rewrite <- EQ. apply gcd_divide_r. +Qed. + +End NZGcdProp. diff --git a/theories/Numbers/NatInt/NZLog.v b/theories/Numbers/NatInt/NZLog.v new file mode 100644 index 0000000000..1951cfc3ef --- /dev/null +++ b/theories/Numbers/NatInt/NZLog.v @@ -0,0 +1,896 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Base-2 Logarithm *) + +Require Import NZAxioms NZMulOrder NZPow. + +(** Interface of a log2 function, then its specification on naturals *) + +Module Type Log2 (Import A : Typ). + Parameter Inline log2 : t -> t. +End Log2. + +Module Type NZLog2Spec (A : NZOrdAxiomsSig')(B : Pow' A)(C : Log2 A). + Import A B C. + Axiom log2_spec : forall a, 0<a -> 2^(log2 a) <= a < 2^(S (log2 a)). + Axiom log2_nonpos : forall a, a<=0 -> log2 a == 0. +End NZLog2Spec. + +Module Type NZLog2 (A : NZOrdAxiomsSig)(B : Pow A) := Log2 A <+ NZLog2Spec A B. + +(** Derived properties of logarithm *) + +Module Type NZLog2Prop + (Import A : NZOrdAxiomsSig') + (Import B : NZPow' A) + (Import C : NZLog2 A B) + (Import D : NZMulOrderProp A) + (Import E : NZPowProp A B D). + +(** log2 is always non-negative *) + +Lemma log2_nonneg : forall a, 0 <= log2 a. +Proof. + intros a. destruct (le_gt_cases a 0) as [Ha|Ha]. + - now rewrite log2_nonpos. + - destruct (log2_spec a Ha) as (_,LT). + apply lt_succ_r, (pow_gt_1 2). + order'. + + rewrite <- le_succ_l, <- one_succ in Ha. order. +Qed. + +(** A tactic for proving positivity and non-negativity *) + +Ltac order_pos := +((apply add_pos_pos || apply add_nonneg_nonneg || + apply mul_pos_pos || apply mul_nonneg_nonneg || + apply pow_nonneg || apply pow_pos_nonneg || + apply log2_nonneg || apply (le_le_succ_r 0)); + order_pos) (* in case of success of an apply, we recurse *) +|| order'. (* otherwise *) + +(** The spec of log2 indeed determines it *) + +Lemma log2_unique : forall a b, 0<=b -> 2^b<=a<2^(S b) -> log2 a == b. +Proof. + intros a b Hb (LEb,LTb). + assert (Ha : 0 < a). + - apply lt_le_trans with (2^b); trivial. + apply pow_pos_nonneg; order'. + - assert (Hc := log2_nonneg a). + destruct (log2_spec a Ha) as (LEc,LTc). + assert (log2 a <= b). + + apply lt_succ_r, (pow_lt_mono_r_iff 2); try order'. + now apply le_le_succ_r. + + assert (b <= log2 a). + * apply lt_succ_r, (pow_lt_mono_r_iff 2); try order'. + now apply le_le_succ_r. + * order. +Qed. + +(** Hence log2 is a morphism. *) + +Instance log2_wd : Proper (eq==>eq) log2. +Proof. + intros x x' Hx. + destruct (le_gt_cases x 0). + - rewrite 2 log2_nonpos; trivial. + reflexivity. + now rewrite <- Hx. + - apply log2_unique. + apply log2_nonneg. + + rewrite Hx in *. now apply log2_spec. +Qed. + +(** An alternate specification *) + +Lemma log2_spec_alt : forall a, 0<a -> exists r, + a == 2^(log2 a) + r /\ 0 <= r < 2^(log2 a). +Proof. + intros a Ha. + destruct (log2_spec _ Ha) as (LE,LT). + destruct (le_exists_sub _ _ LE) as (r & Hr & Hr'). + exists r. + split. - now rewrite add_comm. + - split. + trivial. + + apply (add_lt_mono_r _ _ (2^log2 a)). + rewrite <- Hr. generalize LT. + rewrite pow_succ_r by order_pos. + rewrite two_succ at 1. now nzsimpl. +Qed. + +Lemma log2_unique' : forall a b c, 0<=b -> 0<=c<2^b -> + a == 2^b + c -> log2 a == b. +Proof. + intros a b c Hb (Hc,H) EQ. + apply log2_unique. - trivial. + - rewrite EQ. + split. + + rewrite <- add_0_r at 1. now apply add_le_mono_l. + + rewrite pow_succ_r by order. + rewrite two_succ at 2. nzsimpl. now apply add_lt_mono_l. +Qed. + +(** log2 is exact on powers of 2 *) + +Lemma log2_pow2 : forall a, 0<=a -> log2 (2^a) == a. +Proof. + intros a Ha. + apply log2_unique' with 0; trivial. + - split; order_pos. - now nzsimpl. +Qed. + +(** log2 and predecessors of powers of 2 *) + +Lemma log2_pred_pow2 : forall a, 0<a -> log2 (P (2^a)) == P a. +Proof. + intros a Ha. + assert (Ha' : S (P a) == a) by (now rewrite lt_succ_pred with 0). + apply log2_unique. + - apply lt_succ_r; order. + - rewrite <-le_succ_l, <-lt_succ_r, Ha'. + rewrite lt_succ_pred with 0. + + split; try easy. apply pow_lt_mono_r_iff; try order'. + rewrite succ_lt_mono, Ha'. apply lt_succ_diag_r. + + apply pow_pos_nonneg; order'. +Qed. + +(** log2 and basic constants *) + +Lemma log2_1 : log2 1 == 0. +Proof. + rewrite <- (pow_0_r 2). now apply log2_pow2. +Qed. + +Lemma log2_2 : log2 2 == 1. +Proof. + rewrite <- (pow_1_r 2). apply log2_pow2; order'. +Qed. + +(** log2 n is strictly positive for 1<n *) + +Lemma log2_pos : forall a, 1<a -> 0 < log2 a. +Proof. + intros a Ha. + assert (Ha' : 0 < a) by order'. + assert (H := log2_nonneg a). le_elim H; trivial. + generalize (log2_spec a Ha'). rewrite <- H in *. nzsimpl; try order. + intros (_,H'). rewrite two_succ in H'. apply lt_succ_r in H'; order. +Qed. + +(** Said otherwise, log2 is null only below 1 *) + +Lemma log2_null : forall a, log2 a == 0 <-> a <= 1. +Proof. + intros a. split; intros H. + - destruct (le_gt_cases a 1) as [Ha|Ha]; trivial. + generalize (log2_pos a Ha); order. + - le_elim H. + + apply log2_nonpos. apply lt_succ_r. now rewrite <- one_succ. + + rewrite H. apply log2_1. +Qed. + +(** log2 is a monotone function (but not a strict one) *) + +Lemma log2_le_mono : forall a b, a<=b -> log2 a <= log2 b. +Proof. + intros a b H. + destruct (le_gt_cases a 0) as [Ha|Ha]. + - rewrite log2_nonpos; order_pos. + - assert (Hb : 0 < b) by order. + destruct (log2_spec a Ha) as (LEa,_). + destruct (log2_spec b Hb) as (_,LTb). + apply lt_succ_r, (pow_lt_mono_r_iff 2); order_pos. +Qed. + +(** No reverse result for <=, consider for instance log2 3 <= log2 2 *) + +Lemma log2_lt_cancel : forall a b, log2 a < log2 b -> a < b. +Proof. + intros a b H. + destruct (le_gt_cases b 0) as [Hb|Hb]. + - rewrite (log2_nonpos b) in H; trivial. + generalize (log2_nonneg a); order. + - destruct (le_gt_cases a 0) as [Ha|Ha]. + order. + + destruct (log2_spec a Ha) as (_,LTa). + destruct (log2_spec b Hb) as (LEb,_). + apply le_succ_l in H. + apply (pow_le_mono_r_iff 2) in H; order_pos. +Qed. + +(** When left side is a power of 2, we have an equivalence for <= *) + +Lemma log2_le_pow2 : forall a b, 0<a -> (2^b<=a <-> b <= log2 a). +Proof. + intros a b Ha. + split; intros H. + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + generalize (log2_nonneg a); order. + + rewrite <- (log2_pow2 b); trivial. now apply log2_le_mono. + - transitivity (2^(log2 a)). + + apply pow_le_mono_r; order'. + + now destruct (log2_spec a Ha). +Qed. + +(** When right side is a square, we have an equivalence for < *) + +Lemma log2_lt_pow2 : forall a b, 0<a -> (a<2^b <-> log2 a < b). +Proof. + intros a b Ha. + split; intros H. + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + rewrite pow_neg_r in H; order. + + apply (pow_lt_mono_r_iff 2); try order_pos. + apply le_lt_trans with a; trivial. + now destruct (log2_spec a Ha). + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + generalize (log2_nonneg a); order. + + apply log2_lt_cancel; try order. + now rewrite log2_pow2. +Qed. + +(** Comparing log2 and identity *) + +Lemma log2_lt_lin : forall a, 0<a -> log2 a < a. +Proof. + intros a Ha. + apply (pow_lt_mono_r_iff 2); try order_pos. + apply le_lt_trans with a. + - now destruct (log2_spec a Ha). + - apply pow_gt_lin_r; order'. +Qed. + +Lemma log2_le_lin : forall a, 0<=a -> log2 a <= a. +Proof. + intros a Ha. + le_elim Ha. + - now apply lt_le_incl, log2_lt_lin. + - rewrite <- Ha, log2_nonpos; order. +Qed. + +(** Log2 and multiplication. *) + +(** Due to rounding error, we don't have the usual + [log2 (a*b) = log2 a + log2 b] but we may be off by 1 at most *) + +Lemma log2_mul_below : forall a b, 0<a -> 0<b -> + log2 a + log2 b <= log2 (a*b). +Proof. + intros a b Ha Hb. + apply log2_le_pow2; try order_pos. + rewrite pow_add_r by order_pos. + apply mul_le_mono_nonneg; try apply log2_spec; order_pos. +Qed. + +Lemma log2_mul_above : forall a b, 0<=a -> 0<=b -> + log2 (a*b) <= log2 a + log2 b + 1. +Proof. + intros a b Ha Hb. + le_elim Ha. + - le_elim Hb. + + apply lt_succ_r. + rewrite add_1_r, <- add_succ_r, <- add_succ_l. + apply log2_lt_pow2; try order_pos. + rewrite pow_add_r by order_pos. + apply mul_lt_mono_nonneg; try order; now apply log2_spec. + + rewrite <- Hb. nzsimpl. rewrite log2_nonpos; order_pos. + - rewrite <- Ha. nzsimpl. rewrite log2_nonpos; order_pos. +Qed. + +(** And we can't find better approximations in general. + - The lower bound is exact for powers of 2. + - Concerning the upper bound, for any c>1, take a=b=2^c-1, + then log2 (a*b) = c+c -1 while (log2 a) = (log2 b) = c-1 +*) + +(** At least, we get back the usual equation when we multiply by 2 (or 2^k) *) + +Lemma log2_mul_pow2 : forall a b, 0<a -> 0<=b -> log2 (a*2^b) == b + log2 a. +Proof. + intros a b Ha Hb. + apply log2_unique; try order_pos. split. + - rewrite pow_add_r, mul_comm; try order_pos. + apply mul_le_mono_nonneg_r. + order_pos. + now apply log2_spec. + - rewrite <-add_succ_r, pow_add_r, mul_comm; try order_pos. + apply mul_lt_mono_pos_l. + order_pos. + now apply log2_spec. +Qed. + +Lemma log2_double : forall a, 0<a -> log2 (2*a) == S (log2 a). +Proof. + intros a Ha. generalize (log2_mul_pow2 a 1 Ha le_0_1). now nzsimpl'. +Qed. + +(** Two numbers with same log2 cannot be far away. *) + +Lemma log2_same : forall a b, 0<a -> 0<b -> log2 a == log2 b -> a < 2*b. +Proof. + intros a b Ha Hb H. + apply log2_lt_cancel. rewrite log2_double, H by trivial. + apply lt_succ_diag_r. +Qed. + +(** Log2 and successor : + - the log2 function climbs by at most 1 at a time + - otherwise it stays at the same value + - the +1 steps occur for powers of two +*) + +Lemma log2_succ_le : forall a, log2 (S a) <= S (log2 a). +Proof. + intros a. + destruct (lt_trichotomy 0 a) as [LT|[EQ|LT]]. + - apply (pow_le_mono_r_iff 2); try order_pos. + transitivity (S a). + + apply log2_spec. + apply lt_succ_r; order. + + now apply le_succ_l, log2_spec. + - rewrite <- EQ, <- one_succ, log2_1; order_pos. + - rewrite 2 log2_nonpos. + order_pos. + order'. + now rewrite le_succ_l. +Qed. + +Lemma log2_succ_or : forall a, + log2 (S a) == S (log2 a) \/ log2 (S a) == log2 a. +Proof. + intros. + destruct (le_gt_cases (log2 (S a)) (log2 a)) as [H|H]. + - right. generalize (log2_le_mono _ _ (le_succ_diag_r a)); order. + - left. apply le_succ_l in H. generalize (log2_succ_le a); order. +Qed. + +Lemma log2_eq_succ_is_pow2 : forall a, + log2 (S a) == S (log2 a) -> exists b, S a == 2^b. +Proof. + intros a H. + destruct (le_gt_cases a 0) as [Ha|Ha]. + - rewrite 2 (proj2 (log2_null _)) in H. + generalize (lt_succ_diag_r 0); order. + + order'. + apply le_succ_l. order'. + - assert (Ha' : 0 < S a) by (apply lt_succ_r; order). + exists (log2 (S a)). + generalize (proj1 (log2_spec (S a) Ha')) (proj2 (log2_spec a Ha)). + rewrite <- le_succ_l, <- H. order. +Qed. + +Lemma log2_eq_succ_iff_pow2 : forall a, 0<a -> + (log2 (S a) == S (log2 a) <-> exists b, S a == 2^b). +Proof. + intros a Ha. + split. - apply log2_eq_succ_is_pow2. + - intros (b,Hb). + assert (Hb' : 0 < b). + + apply (pow_gt_1 2); try order'; now rewrite <- Hb, one_succ, <- succ_lt_mono. + + rewrite Hb, log2_pow2; try order'. + setoid_replace a with (P (2^b)). * rewrite log2_pred_pow2; trivial. + symmetry; now apply lt_succ_pred with 0. + * apply succ_inj. rewrite Hb. symmetry. apply lt_succ_pred with 0. + rewrite <- Hb, lt_succ_r; order. +Qed. + +Lemma log2_succ_double : forall a, 0<a -> log2 (2*a+1) == S (log2 a). +Proof. + intros a Ha. + rewrite add_1_r. + destruct (log2_succ_or (2*a)) as [H|H]; [exfalso|now rewrite H, log2_double]. + apply log2_eq_succ_is_pow2 in H. destruct H as (b,H). + destruct (lt_trichotomy b 0) as [LT|[EQ|LT]]. + - rewrite pow_neg_r in H; trivial. + apply (mul_pos_pos 2), succ_lt_mono in Ha; try order'. + rewrite <- one_succ in Ha. order'. + - rewrite EQ, pow_0_r in H. + apply (mul_pos_pos 2), succ_lt_mono in Ha; try order'. + rewrite <- one_succ in Ha. order'. + - assert (EQ:=lt_succ_pred 0 b LT). + rewrite <- EQ, pow_succ_r in H; [|now rewrite <- lt_succ_r, EQ]. + destruct (lt_ge_cases a (2^(P b))) as [LT'|LE']. + + generalize (mul_2_mono_l _ _ LT'). rewrite add_1_l. order. + + rewrite (mul_le_mono_pos_l _ _ 2) in LE'; try order'. + rewrite <- H in LE'. apply le_succ_l in LE'. order. +Qed. + +(** Log2 and addition *) + +Lemma log2_add_le : forall a b, a~=1 -> b~=1 -> log2 (a+b) <= log2 a + log2 b. +Proof. + intros a b Ha Hb. + destruct (lt_trichotomy a 1) as [Ha'|[Ha'|Ha']]; [|order|]. + - rewrite one_succ, lt_succ_r in Ha'. + rewrite (log2_nonpos a); trivial. nzsimpl. apply log2_le_mono. + rewrite <- (add_0_l b) at 2. now apply add_le_mono. + - destruct (lt_trichotomy b 1) as [Hb'|[Hb'|Hb']]; [|order|]. + + rewrite one_succ, lt_succ_r in Hb'. + rewrite (log2_nonpos b); trivial. nzsimpl. apply log2_le_mono. + rewrite <- (add_0_r a) at 2. now apply add_le_mono. + + clear Ha Hb. + apply lt_succ_r. + apply log2_lt_pow2; try order_pos. + rewrite pow_succ_r by order_pos. + rewrite two_succ, one_succ at 1. nzsimpl. + apply add_lt_mono. + * apply lt_le_trans with (2^(S (log2 a))). -- apply log2_spec; order'. + -- apply pow_le_mono_r. ++ order'. + ++ rewrite <- add_1_r. apply add_le_mono_l. + rewrite one_succ; now apply le_succ_l, log2_pos. + * apply lt_le_trans with (2^(S (log2 b))). + -- apply log2_spec; order'. + -- apply pow_le_mono_r. ++ order'. + ++ rewrite <- add_1_l. apply add_le_mono_r. + rewrite one_succ; now apply le_succ_l, log2_pos. +Qed. + +(** The sum of two log2 is less than twice the log2 of the sum. + The large inequality is obvious thanks to monotonicity. + The strict one requires some more work. This is almost + a convexity inequality for points [2a], [2b] and their middle [a+b] : + ideally, we would have [2*log(a+b) >= log(2a)+log(2b) = 2+log a+log b]. + Here, we cannot do better: consider for instance a=2 b=4, then 1+2<2*2 +*) + +Lemma add_log2_lt : forall a b, 0<a -> 0<b -> + log2 a + log2 b < 2 * log2 (a+b). +Proof. + intros a b Ha Hb. nzsimpl'. + assert (H : log2 a <= log2 (a+b)). + - apply log2_le_mono. rewrite <- (add_0_r a) at 1. apply add_le_mono; order. + - assert (H' : log2 b <= log2 (a+b)). + + apply log2_le_mono. rewrite <- (add_0_l b) at 1. apply add_le_mono; order. + + le_elim H. + * apply lt_le_trans with (log2 (a+b) + log2 b). + -- now apply add_lt_mono_r. -- now apply add_le_mono_l. + * rewrite <- H at 1. apply add_lt_mono_l. + le_elim H'; trivial. + symmetry in H. apply log2_same in H; try order_pos. + symmetry in H'. apply log2_same in H'; try order_pos. + revert H H'. nzsimpl'. rewrite <- add_lt_mono_l, <- add_lt_mono_r; order. +Qed. + +End NZLog2Prop. + +Module NZLog2UpProp + (Import A : NZDecOrdAxiomsSig') + (Import B : NZPow' A) + (Import C : NZLog2 A B) + (Import D : NZMulOrderProp A) + (Import E : NZPowProp A B D) + (Import F : NZLog2Prop A B C D E). + +(** * [log2_up] : a binary logarithm that rounds up instead of down *) + +(** For once, we define instead of axiomatizing, thanks to log2 *) + +Definition log2_up a := + match compare 1 a with + | Lt => S (log2 (P a)) + | _ => 0 + end. + +Lemma log2_up_eqn0 : forall a, a<=1 -> log2_up a == 0. +Proof. + intros a Ha. unfold log2_up. case compare_spec; try order. +Qed. + +Lemma log2_up_eqn : forall a, 1<a -> log2_up a == S (log2 (P a)). +Proof. + intros a Ha. unfold log2_up. case compare_spec; try order. +Qed. + +Lemma log2_up_spec : forall a, 1<a -> + 2^(P (log2_up a)) < a <= 2^(log2_up a). +Proof. + intros a Ha. + rewrite log2_up_eqn; trivial. + rewrite pred_succ. + rewrite <- (lt_succ_pred 1 a Ha) at 2 3. + rewrite lt_succ_r, le_succ_l. + apply log2_spec. + apply succ_lt_mono. now rewrite (lt_succ_pred 1 a Ha), <- one_succ. +Qed. + +Lemma log2_up_nonpos : forall a, a<=0 -> log2_up a == 0. +Proof. + intros. apply log2_up_eqn0. order'. +Qed. + +Instance log2_up_wd : Proper (eq==>eq) log2_up. +Proof. + assert (Proper (eq==>eq==>Logic.eq) compare). + - repeat red; intros; do 2 case compare_spec; trivial; order. + - intros a a' Ha. unfold log2_up. rewrite Ha at 1. + case compare; now rewrite ?Ha. +Qed. + +(** [log2_up] is always non-negative *) + +Lemma log2_up_nonneg : forall a, 0 <= log2_up a. +Proof. + intros a. unfold log2_up. case compare_spec; try order. + intros. apply le_le_succ_r, log2_nonneg. +Qed. + +(** The spec of [log2_up] indeed determines it *) + +Lemma log2_up_unique : forall a b, 0<b -> 2^(P b)<a<=2^b -> log2_up a == b. +Proof. + intros a b Hb (LEb,LTb). + assert (Ha : 1 < a). + - apply le_lt_trans with (2^(P b)); trivial. + rewrite one_succ. apply le_succ_l. + apply pow_pos_nonneg. + order'. + + apply lt_succ_r. + now rewrite (lt_succ_pred 0 b Hb). + - assert (Hc := log2_up_nonneg a). + destruct (log2_up_spec a Ha) as (LTc,LEc). + assert (b <= log2_up a). + + apply lt_succ_r. rewrite <- (lt_succ_pred 0 b Hb). + rewrite <- succ_lt_mono. + apply (pow_lt_mono_r_iff 2); try order'. + + assert (Hc' : 0 < log2_up a) by order. + assert (log2_up a <= b). + * apply lt_succ_r. rewrite <- (lt_succ_pred 0 _ Hc'). + rewrite <- succ_lt_mono. + apply (pow_lt_mono_r_iff 2); try order'. + * order. +Qed. + +(** [log2_up] is exact on powers of 2 *) + +Lemma log2_up_pow2 : forall a, 0<=a -> log2_up (2^a) == a. +Proof. + intros a Ha. + le_elim Ha. + - apply log2_up_unique; trivial. + split; try order. + apply pow_lt_mono_r; try order'. + rewrite <- (lt_succ_pred 0 a Ha) at 2. + now apply lt_succ_r. + - now rewrite <- Ha, pow_0_r, log2_up_eqn0. +Qed. + +(** [log2_up] and successors of powers of 2 *) + +Lemma log2_up_succ_pow2 : forall a, 0<=a -> log2_up (S (2^a)) == S a. +Proof. + intros a Ha. + rewrite log2_up_eqn, pred_succ, log2_pow2; try easy. + rewrite one_succ, <- succ_lt_mono. apply pow_pos_nonneg; order'. +Qed. + +(** Basic constants *) + +Lemma log2_up_1 : log2_up 1 == 0. +Proof. + now apply log2_up_eqn0. +Qed. + +Lemma log2_up_2 : log2_up 2 == 1. +Proof. + rewrite <- (pow_1_r 2). apply log2_up_pow2; order'. +Qed. + +(** Links between log2 and [log2_up] *) + +Lemma le_log2_log2_up : forall a, log2 a <= log2_up a. +Proof. + intros a. unfold log2_up. case compare_spec; intros H. + - rewrite <- H, log2_1. order. + - rewrite <- (lt_succ_pred 1 a H) at 1. apply log2_succ_le. + - rewrite log2_nonpos. + order. + now rewrite <-lt_succ_r, <-one_succ. +Qed. + +Lemma le_log2_up_succ_log2 : forall a, log2_up a <= S (log2 a). +Proof. + intros a. unfold log2_up. case compare_spec; intros H; try order_pos. + rewrite <- succ_le_mono. apply log2_le_mono. + rewrite <- (lt_succ_pred 1 a H) at 2. apply le_succ_diag_r. +Qed. + +Lemma log2_log2_up_spec : forall a, 0<a -> + 2^log2 a <= a <= 2^log2_up a. +Proof. + intros a H. split. + - now apply log2_spec. + - rewrite <-le_succ_l, <-one_succ in H. le_elim H. + + now apply log2_up_spec. + + now rewrite <-H, log2_up_1, pow_0_r. +Qed. + +Lemma log2_log2_up_exact : + forall a, 0<a -> (log2 a == log2_up a <-> exists b, a == 2^b). +Proof. + intros a Ha. + split. + - intros. exists (log2 a). + generalize (log2_log2_up_spec a Ha). rewrite <-H. + destruct 1; order. + - intros (b,Hb). rewrite Hb. + destruct (le_gt_cases 0 b). + + now rewrite log2_pow2, log2_up_pow2. + + rewrite pow_neg_r; trivial. now rewrite log2_nonpos, log2_up_nonpos. +Qed. + +(** [log2_up] n is strictly positive for 1<n *) + +Lemma log2_up_pos : forall a, 1<a -> 0 < log2_up a. +Proof. + intros. rewrite log2_up_eqn; trivial. apply lt_succ_r; order_pos. +Qed. + +(** Said otherwise, [log2_up] is null only below 1 *) + +Lemma log2_up_null : forall a, log2_up a == 0 <-> a <= 1. +Proof. + intros a. split; intros H. + - destruct (le_gt_cases a 1) as [Ha|Ha]; trivial. + generalize (log2_up_pos a Ha); order. + - now apply log2_up_eqn0. +Qed. + +(** [log2_up] is a monotone function (but not a strict one) *) + +Lemma log2_up_le_mono : forall a b, a<=b -> log2_up a <= log2_up b. +Proof. + intros a b H. + destruct (le_gt_cases a 1) as [Ha|Ha]. + - rewrite log2_up_eqn0; trivial. apply log2_up_nonneg. + - rewrite 2 log2_up_eqn; try order. + rewrite <- succ_le_mono. apply log2_le_mono, succ_le_mono. + rewrite 2 lt_succ_pred with 1; order. +Qed. + +(** No reverse result for <=, consider for instance log2_up 4 <= log2_up 3 *) + +Lemma log2_up_lt_cancel : forall a b, log2_up a < log2_up b -> a < b. +Proof. + intros a b H. + destruct (le_gt_cases b 1) as [Hb|Hb]. + - rewrite (log2_up_eqn0 b) in H; trivial. + generalize (log2_up_nonneg a); order. + - destruct (le_gt_cases a 1) as [Ha|Ha]. + order. + + rewrite 2 log2_up_eqn in H; try order. + rewrite <- succ_lt_mono in H. apply log2_lt_cancel, succ_lt_mono in H. + rewrite 2 lt_succ_pred with 1 in H; order. +Qed. + +(** When left side is a power of 2, we have an equivalence for < *) + +Lemma log2_up_lt_pow2 : forall a b, 0<a -> (2^b<a <-> b < log2_up a). +Proof. + intros a b Ha. + split; intros H. + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + generalize (log2_up_nonneg a); order. + + apply (pow_lt_mono_r_iff 2). * order'. * apply log2_up_nonneg. + * apply lt_le_trans with a; trivial. + apply (log2_up_spec a). + apply le_lt_trans with (2^b); trivial. + rewrite one_succ, le_succ_l. apply pow_pos_nonneg; order'. + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + now rewrite pow_neg_r. + + rewrite <- (log2_up_pow2 b) in H; trivial. now apply log2_up_lt_cancel. +Qed. + +(** When right side is a square, we have an equivalence for <= *) + +Lemma log2_up_le_pow2 : forall a b, 0<a -> (a<=2^b <-> log2_up a <= b). +Proof. + intros a b Ha. + split; intros H. + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + rewrite pow_neg_r in H; order. + + rewrite <- (log2_up_pow2 b); trivial. now apply log2_up_le_mono. + - transitivity (2^(log2_up a)). + + now apply log2_log2_up_spec. + + apply pow_le_mono_r; order'. +Qed. + +(** Comparing [log2_up] and identity *) + +Lemma log2_up_lt_lin : forall a, 0<a -> log2_up a < a. +Proof. + intros a Ha. + assert (H : S (P a) == a) by (now apply lt_succ_pred with 0). + rewrite <- H at 2. apply lt_succ_r. apply log2_up_le_pow2; trivial. + rewrite <- H at 1. apply le_succ_l. + apply pow_gt_lin_r. - order'. - apply lt_succ_r; order. +Qed. + +Lemma log2_up_le_lin : forall a, 0<=a -> log2_up a <= a. +Proof. + intros a Ha. + le_elim Ha. + - now apply lt_le_incl, log2_up_lt_lin. + - rewrite <- Ha, log2_up_nonpos; order. +Qed. + +(** [log2_up] and multiplication. *) + +(** Due to rounding error, we don't have the usual + [log2_up (a*b) = log2_up a + log2_up b] but we may be off by 1 at most *) + +Lemma log2_up_mul_above : forall a b, 0<=a -> 0<=b -> + log2_up (a*b) <= log2_up a + log2_up b. +Proof. + intros a b Ha Hb. + assert (Ha':=log2_up_nonneg a). + assert (Hb':=log2_up_nonneg b). + le_elim Ha. + - le_elim Hb. + + apply log2_up_le_pow2; try order_pos. + rewrite pow_add_r; trivial. + apply mul_le_mono_nonneg; try apply log2_log2_up_spec; order'. + + rewrite <- Hb. nzsimpl. rewrite log2_up_nonpos; order_pos. + - rewrite <- Ha. nzsimpl. rewrite log2_up_nonpos; order_pos. +Qed. + +Lemma log2_up_mul_below : forall a b, 0<a -> 0<b -> + log2_up a + log2_up b <= S (log2_up (a*b)). +Proof. + intros a b Ha Hb. + rewrite <-le_succ_l, <-one_succ in Ha. le_elim Ha. + - rewrite <-le_succ_l, <-one_succ in Hb. le_elim Hb. + + assert (Ha' : 0 < log2_up a) by (apply log2_up_pos; trivial). + assert (Hb' : 0 < log2_up b) by (apply log2_up_pos; trivial). + rewrite <- (lt_succ_pred 0 (log2_up a)); trivial. + rewrite <- (lt_succ_pred 0 (log2_up b)); trivial. + nzsimpl. rewrite <- succ_le_mono, le_succ_l. + apply (pow_lt_mono_r_iff 2). * order'. * apply log2_up_nonneg. + * rewrite pow_add_r; try (apply lt_succ_r; rewrite (lt_succ_pred 0); trivial). + apply lt_le_trans with (a*b). + -- apply mul_lt_mono_nonneg; try order_pos; try now apply log2_up_spec. + -- apply log2_up_spec. + setoid_replace 1 with (1*1) by now nzsimpl. + apply mul_lt_mono_nonneg; order'. + + rewrite <- Hb, log2_up_1; nzsimpl. apply le_succ_diag_r. + - rewrite <- Ha, log2_up_1; nzsimpl. apply le_succ_diag_r. +Qed. + +(** And we can't find better approximations in general. + - The upper bound is exact for powers of 2. + - Concerning the lower bound, for any c>1, take a=b=2^c+1, + then [log2_up (a*b) = c+c +1] while [(log2_up a) = (log2_up b) = c+1] +*) + +(** At least, we get back the usual equation when we multiply by 2 (or 2^k) *) + +Lemma log2_up_mul_pow2 : forall a b, 0<a -> 0<=b -> + log2_up (a*2^b) == b + log2_up a. +Proof. + intros a b Ha Hb. + rewrite <- le_succ_l, <- one_succ in Ha; le_elim Ha. + - apply log2_up_unique. + apply add_nonneg_pos; trivial. now apply log2_up_pos. + + split. + * assert (EQ := lt_succ_pred 0 _ (log2_up_pos _ Ha)). + rewrite <- EQ. nzsimpl. rewrite pow_add_r, mul_comm; trivial. + -- apply mul_lt_mono_pos_r. ++ order_pos. ++ now apply log2_up_spec. + -- rewrite <- lt_succ_r, EQ. now apply log2_up_pos. + * rewrite pow_add_r, mul_comm; trivial. + -- apply mul_le_mono_nonneg_l. ++ order_pos. ++ now apply log2_up_spec. + -- apply log2_up_nonneg. + - now rewrite <- Ha, mul_1_l, log2_up_1, add_0_r, log2_up_pow2. +Qed. + +Lemma log2_up_double : forall a, 0<a -> log2_up (2*a) == S (log2_up a). +Proof. + intros a Ha. generalize (log2_up_mul_pow2 a 1 Ha le_0_1). now nzsimpl'. +Qed. + +(** Two numbers with same [log2_up] cannot be far away. *) + +Lemma log2_up_same : forall a b, 0<a -> 0<b -> log2_up a == log2_up b -> a < 2*b. +Proof. + intros a b Ha Hb H. + apply log2_up_lt_cancel. rewrite log2_up_double, H by trivial. + apply lt_succ_diag_r. +Qed. + +(** [log2_up] and successor : + - the [log2_up] function climbs by at most 1 at a time + - otherwise it stays at the same value + - the +1 steps occur after powers of two +*) + +Lemma log2_up_succ_le : forall a, log2_up (S a) <= S (log2_up a). +Proof. + intros a. + destruct (lt_trichotomy 1 a) as [LT|[EQ|LT]]. + - rewrite 2 log2_up_eqn; trivial. + + rewrite pred_succ, <- succ_le_mono. rewrite <-(lt_succ_pred 1 a LT) at 1. + apply log2_succ_le. + + apply lt_succ_r; order. + - rewrite <- EQ, <- two_succ, log2_up_1, log2_up_2. now nzsimpl'. + - rewrite 2 log2_up_eqn0. + order_pos. + order'. + now rewrite le_succ_l. +Qed. + +Lemma log2_up_succ_or : forall a, + log2_up (S a) == S (log2_up a) \/ log2_up (S a) == log2_up a. +Proof. + intros. + destruct (le_gt_cases (log2_up (S a)) (log2_up a)). + - right. generalize (log2_up_le_mono _ _ (le_succ_diag_r a)); order. + - left. apply le_succ_l in H. generalize (log2_up_succ_le a); order. +Qed. + +Lemma log2_up_eq_succ_is_pow2 : forall a, + log2_up (S a) == S (log2_up a) -> exists b, a == 2^b. +Proof. + intros a H. + destruct (le_gt_cases a 0) as [Ha|Ha]. + - rewrite 2 (proj2 (log2_up_null _)) in H. + generalize (lt_succ_diag_r 0); order. + + order'. + apply le_succ_l. order'. + - assert (Ha' : 1 < S a) by (now rewrite one_succ, <- succ_lt_mono). + exists (log2_up a). + generalize (proj1 (log2_up_spec (S a) Ha')) (proj2 (log2_log2_up_spec a Ha)). + rewrite H, pred_succ, lt_succ_r. order. +Qed. + +Lemma log2_up_eq_succ_iff_pow2 : forall a, 0<a -> + (log2_up (S a) == S (log2_up a) <-> exists b, a == 2^b). +Proof. + intros a Ha. + split. - apply log2_up_eq_succ_is_pow2. + - intros (b,Hb). + destruct (lt_ge_cases b 0) as [Hb'|Hb']. + + rewrite pow_neg_r in Hb; order. + + rewrite Hb, log2_up_pow2; try order'. + now rewrite log2_up_succ_pow2. +Qed. + +Lemma log2_up_succ_double : forall a, 0<a -> + log2_up (2*a+1) == 2 + log2 a. +Proof. + intros a Ha. + rewrite log2_up_eqn. - rewrite add_1_r, pred_succ, log2_double; now nzsimpl'. + - apply le_lt_trans with (0+1). + now nzsimpl'. + + apply add_lt_mono_r. order_pos. +Qed. + +(** [log2_up] and addition *) + +Lemma log2_up_add_le : forall a b, a~=1 -> b~=1 -> + log2_up (a+b) <= log2_up a + log2_up b. +Proof. + intros a b Ha Hb. + destruct (lt_trichotomy a 1) as [Ha'|[Ha'|Ha']]; [|order|]. + - rewrite (log2_up_eqn0 a) by order. nzsimpl. apply log2_up_le_mono. + rewrite one_succ, lt_succ_r in Ha'. + rewrite <- (add_0_l b) at 2. now apply add_le_mono. + - destruct (lt_trichotomy b 1) as [Hb'|[Hb'|Hb']]; [|order|]. + + rewrite (log2_up_eqn0 b) by order. nzsimpl. apply log2_up_le_mono. + rewrite one_succ, lt_succ_r in Hb'. + rewrite <- (add_0_r a) at 2. now apply add_le_mono. + + clear Ha Hb. + transitivity (log2_up (a*b)). + * now apply log2_up_le_mono, add_le_mul. + * apply log2_up_mul_above; order'. +Qed. + +(** The sum of two [log2_up] is less than twice the [log2_up] of the sum. + The large inequality is obvious thanks to monotonicity. + The strict one requires some more work. This is almost + a convexity inequality for points [2a], [2b] and their middle [a+b] : + ideally, we would have [2*log(a+b) >= log(2a)+log(2b) = 2+log a+log b]. + Here, we cannot do better: consider for instance a=3 b=5, then 2+3<2*3 +*) + +Lemma add_log2_up_lt : forall a b, 0<a -> 0<b -> + log2_up a + log2_up b < 2 * log2_up (a+b). +Proof. + intros a b Ha Hb. nzsimpl'. + assert (H : log2_up a <= log2_up (a+b)). + - apply log2_up_le_mono. rewrite <- (add_0_r a) at 1. apply add_le_mono; order. + - assert (H' : log2_up b <= log2_up (a+b)). + + apply log2_up_le_mono. rewrite <- (add_0_l b) at 1. apply add_le_mono; order. + + le_elim H. + * apply lt_le_trans with (log2_up (a+b) + log2_up b). + -- now apply add_lt_mono_r. -- now apply add_le_mono_l. + * rewrite <- H at 1. apply add_lt_mono_l. + le_elim H'. -- trivial. + -- symmetry in H. apply log2_up_same in H; try order_pos. + symmetry in H'. apply log2_up_same in H'; try order_pos. + revert H H'. nzsimpl'. rewrite <- add_lt_mono_l, <- add_lt_mono_r; order. +Qed. + +End NZLog2UpProp. + diff --git a/theories/Numbers/NatInt/NZMul.v b/theories/Numbers/NatInt/NZMul.v new file mode 100644 index 0000000000..1492188452 --- /dev/null +++ b/theories/Numbers/NatInt/NZMul.v @@ -0,0 +1,94 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Import NZAxioms NZBase NZAdd. + +Module Type NZMulProp (Import NZ : NZAxiomsSig')(Import NZBase : NZBaseProp NZ). +Include NZAddProp NZ NZBase. + +Theorem mul_0_r : forall n, n * 0 == 0. +Proof. +nzinduct n; intros; now nzsimpl. +Qed. + +Theorem mul_succ_r : forall n m, n * (S m) == n * m + n. +Proof. + intros n m; nzinduct n. + - now nzsimpl. + - intro n. nzsimpl. rewrite succ_inj_wd, <- add_assoc, (add_comm m n), add_assoc. + now rewrite add_cancel_r. +Qed. + +Hint Rewrite mul_0_r mul_succ_r : nz. + +Theorem mul_comm : forall n m, n * m == m * n. +Proof. + intros n m; nzinduct n. + - now nzsimpl. + - intro. nzsimpl. now rewrite add_cancel_r. +Qed. + +Theorem mul_add_distr_r : forall n m p, (n + m) * p == n * p + m * p. +Proof. + intros n m p; nzinduct n. + - now nzsimpl. + - intro n. nzsimpl. rewrite <- add_assoc, (add_comm p (m*p)), add_assoc. + now rewrite add_cancel_r. +Qed. + +Theorem mul_add_distr_l : forall n m p, n * (m + p) == n * m + n * p. +Proof. +intros n m p. +rewrite (mul_comm n (m + p)), (mul_comm n m), (mul_comm n p). +apply mul_add_distr_r. +Qed. + +Theorem mul_assoc : forall n m p, n * (m * p) == (n * m) * p. +Proof. + intros n m p; nzinduct n. - now nzsimpl. + - intro n. nzsimpl. rewrite mul_add_distr_r. + now rewrite add_cancel_r. +Qed. + +Theorem mul_1_l : forall n, 1 * n == n. +Proof. +intro n. now nzsimpl'. +Qed. + +Theorem mul_1_r : forall n, n * 1 == n. +Proof. +intro n. now nzsimpl'. +Qed. + +Hint Rewrite mul_1_l mul_1_r : nz. + +Theorem mul_shuffle0 : forall n m p, n*m*p == n*p*m. +Proof. +intros n m p. now rewrite <- 2 mul_assoc, (mul_comm m). +Qed. + +Theorem mul_shuffle1 : forall n m p q, (n * m) * (p * q) == (n * p) * (m * q). +Proof. +intros n m p q. now rewrite 2 mul_assoc, (mul_shuffle0 n). +Qed. + +Theorem mul_shuffle2 : forall n m p q, (n * m) * (p * q) == (n * q) * (m * p). +Proof. +intros n m p q. rewrite (mul_comm p). apply mul_shuffle1. +Qed. + +Theorem mul_shuffle3 : forall n m p, n * (m * p) == m * (n * p). +Proof. +intros n m p. now rewrite mul_assoc, (mul_comm n), mul_assoc. +Qed. + +End NZMulProp. diff --git a/theories/Numbers/NatInt/NZMulOrder.v b/theories/Numbers/NatInt/NZMulOrder.v new file mode 100644 index 0000000000..dc4167e96f --- /dev/null +++ b/theories/Numbers/NatInt/NZMulOrder.v @@ -0,0 +1,405 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Import NZAxioms. +Require Import NZAddOrder. + +Module Type NZMulOrderProp (Import NZ : NZOrdAxiomsSig'). +Include NZAddOrderProp NZ. + +Theorem mul_lt_pred : + forall p q n m, S p == q -> (p * n < p * m <-> q * n + m < q * m + n). +Proof. +intros p q n m H. rewrite <- H. nzsimpl. +rewrite <- ! add_assoc, (add_comm n m). +now rewrite <- add_lt_mono_r. +Qed. + +Theorem mul_lt_mono_pos_l : forall p n m, 0 < p -> (n < m <-> p * n < p * m). +Proof. + intros p n m Hp. revert n m. apply lt_ind with (4:=Hp). - solve_proper. + - intros. now nzsimpl. + - clear p Hp. intros p Hp IH n m. nzsimpl. + assert (LR : forall n m, n < m -> p * n + n < p * m + m) + by (intros n1 m1 H; apply add_lt_mono; trivial; now rewrite <- IH). + split; intros H. + + now apply LR. + + destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial. + * rewrite EQ in H. order. + * apply LR in GT. order. +Qed. + +Theorem mul_lt_mono_pos_r : forall p n m, 0 < p -> (n < m <-> n * p < m * p). +Proof. +intros p n m. +rewrite (mul_comm n p), (mul_comm m p). now apply mul_lt_mono_pos_l. +Qed. + +Theorem mul_lt_mono_neg_l : forall p n m, p < 0 -> (n < m <-> p * m < p * n). +Proof. +nzord_induct p. +- order. +- intros p Hp _ n m Hp'. apply lt_succ_l in Hp'. order. +- intros p Hp IH n m _. apply le_succ_l in Hp. + le_elim Hp. + + assert (LR : forall n m, n < m -> p * m < p * n). + * intros n1 m1 H. apply (le_lt_add_lt n1 m1). + -- now apply lt_le_incl. + -- rewrite <- 2 mul_succ_l. now rewrite <- IH. + * split; intros H. + -- now apply LR. + -- destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial. + ++ rewrite EQ in H. order. + ++ apply LR in GT. order. + + rewrite (mul_lt_pred p (S p)), Hp; now nzsimpl. +Qed. + +Theorem mul_lt_mono_neg_r : forall p n m, p < 0 -> (n < m <-> m * p < n * p). +Proof. +intros p n m. +rewrite (mul_comm n p), (mul_comm m p). now apply mul_lt_mono_neg_l. +Qed. + +Theorem mul_le_mono_nonneg_l : forall n m p, 0 <= p -> n <= m -> p * n <= p * m. +Proof. +intros n m p H1 H2. le_elim H1. +- le_elim H2. + apply lt_le_incl. now apply mul_lt_mono_pos_l. + + apply eq_le_incl; now rewrite H2. +- apply eq_le_incl; rewrite <- H1; now do 2 rewrite mul_0_l. +Qed. + +Theorem mul_le_mono_nonpos_l : forall n m p, p <= 0 -> n <= m -> p * m <= p * n. +Proof. +intros n m p H1 H2. le_elim H1. +- le_elim H2. + apply lt_le_incl. now apply mul_lt_mono_neg_l. + + apply eq_le_incl; now rewrite H2. +- apply eq_le_incl; rewrite H1; now do 2 rewrite mul_0_l. +Qed. + +Theorem mul_le_mono_nonneg_r : forall n m p, 0 <= p -> n <= m -> n * p <= m * p. +Proof. +intros n m p H1 H2; +rewrite (mul_comm n p), (mul_comm m p); now apply mul_le_mono_nonneg_l. +Qed. + +Theorem mul_le_mono_nonpos_r : forall n m p, p <= 0 -> n <= m -> m * p <= n * p. +Proof. +intros n m p H1 H2; +rewrite (mul_comm n p), (mul_comm m p); now apply mul_le_mono_nonpos_l. +Qed. + +Theorem mul_cancel_l : forall n m p, p ~= 0 -> (p * n == p * m <-> n == m). +Proof. +intros n m p Hp; split; intro H; [|now f_equiv]. +apply lt_gt_cases in Hp; destruct Hp as [Hp|Hp]; + destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial. +- apply (mul_lt_mono_neg_l p) in LT; order. +- apply (mul_lt_mono_neg_l p) in GT; order. +- apply (mul_lt_mono_pos_l p) in LT; order. +- apply (mul_lt_mono_pos_l p) in GT; order. +Qed. + +Theorem mul_cancel_r : forall n m p, p ~= 0 -> (n * p == m * p <-> n == m). +Proof. +intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_cancel_l. +Qed. + +Theorem mul_id_l : forall n m, m ~= 0 -> (n * m == m <-> n == 1). +Proof. +intros n m H. +stepl (n * m == 1 * m) by now rewrite mul_1_l. now apply mul_cancel_r. +Qed. + +Theorem mul_id_r : forall n m, n ~= 0 -> (n * m == n <-> m == 1). +Proof. +intros n m; rewrite mul_comm; apply mul_id_l. +Qed. + +Theorem mul_le_mono_pos_l : forall n m p, 0 < p -> (n <= m <-> p * n <= p * m). +Proof. +intros n m p H; do 2 rewrite lt_eq_cases. +rewrite (mul_lt_mono_pos_l p n m) by assumption. +now rewrite -> (mul_cancel_l n m p) by +(intro H1; rewrite H1 in H; false_hyp H lt_irrefl). +Qed. + +Theorem mul_le_mono_pos_r : forall n m p, 0 < p -> (n <= m <-> n * p <= m * p). +Proof. +intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_le_mono_pos_l. +Qed. + +Theorem mul_le_mono_neg_l : forall n m p, p < 0 -> (n <= m <-> p * m <= p * n). +Proof. +intros n m p H; do 2 rewrite lt_eq_cases. +rewrite (mul_lt_mono_neg_l p n m); [| assumption]. +rewrite -> (mul_cancel_l m n p) + by (intro H1; rewrite H1 in H; false_hyp H lt_irrefl). +now setoid_replace (n == m) with (m == n) by (split; now intro). +Qed. + +Theorem mul_le_mono_neg_r : forall n m p, p < 0 -> (n <= m <-> m * p <= n * p). +Proof. +intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_le_mono_neg_l. +Qed. + +Theorem mul_lt_mono_nonneg : + forall n m p q, 0 <= n -> n < m -> 0 <= p -> p < q -> n * p < m * q. +Proof. +intros n m p q H1 H2 H3 H4. +apply le_lt_trans with (m * p). +- apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl]. +- apply -> mul_lt_mono_pos_l; [assumption | now apply le_lt_trans with n]. +Qed. + +(* There are still many variants of the theorem above. One can assume 0 < n +or 0 < p or n <= m or p <= q. *) + +Theorem mul_le_mono_nonneg : + forall n m p q, 0 <= n -> n <= m -> 0 <= p -> p <= q -> n * p <= m * q. +Proof. +intros n m p q H1 H2 H3 H4. +le_elim H2; le_elim H4. +- apply lt_le_incl; now apply mul_lt_mono_nonneg. +- rewrite <- H4; apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl]. +- rewrite <- H2; apply mul_le_mono_nonneg_l; [assumption | now apply lt_le_incl]. +- rewrite H2; rewrite H4; now apply eq_le_incl. +Qed. + +Theorem mul_pos_pos : forall n m, 0 < n -> 0 < m -> 0 < n * m. +Proof. +intros n m H1 H2. rewrite <- (mul_0_l m). now apply mul_lt_mono_pos_r. +Qed. + +Theorem mul_neg_neg : forall n m, n < 0 -> m < 0 -> 0 < n * m. +Proof. +intros n m H1 H2. rewrite <- (mul_0_l m). now apply mul_lt_mono_neg_r. +Qed. + +Theorem mul_pos_neg : forall n m, 0 < n -> m < 0 -> n * m < 0. +Proof. +intros n m H1 H2. rewrite <- (mul_0_l m). now apply mul_lt_mono_neg_r. +Qed. + +Theorem mul_neg_pos : forall n m, n < 0 -> 0 < m -> n * m < 0. +Proof. +intros; rewrite mul_comm; now apply mul_pos_neg. +Qed. + +Theorem mul_nonneg_nonneg : forall n m, 0 <= n -> 0 <= m -> 0 <= n*m. +Proof. +intros. rewrite <- (mul_0_l m). apply mul_le_mono_nonneg; order. +Qed. + +Theorem mul_pos_cancel_l : forall n m, 0 < n -> (0 < n*m <-> 0 < m). +Proof. +intros n m Hn. rewrite <- (mul_0_r n) at 1. + symmetry. now apply mul_lt_mono_pos_l. +Qed. + +Theorem mul_pos_cancel_r : forall n m, 0 < m -> (0 < n*m <-> 0 < n). +Proof. +intros n m Hn. rewrite <- (mul_0_l m) at 1. + symmetry. now apply mul_lt_mono_pos_r. +Qed. + +Theorem mul_nonneg_cancel_l : forall n m, 0 < n -> (0 <= n*m <-> 0 <= m). +Proof. +intros n m Hn. rewrite <- (mul_0_r n) at 1. + symmetry. now apply mul_le_mono_pos_l. +Qed. + +Theorem mul_nonneg_cancel_r : forall n m, 0 < m -> (0 <= n*m <-> 0 <= n). +Proof. +intros n m Hn. rewrite <- (mul_0_l m) at 1. + symmetry. now apply mul_le_mono_pos_r. +Qed. + +Theorem lt_1_mul_pos : forall n m, 1 < n -> 0 < m -> 1 < n * m. +Proof. +intros n m H1 H2. apply (mul_lt_mono_pos_r m) in H1. +- rewrite mul_1_l in H1. now apply lt_1_l with m. +- assumption. +Qed. + +Theorem eq_mul_0 : forall n m, n * m == 0 <-> n == 0 \/ m == 0. +Proof. +intros n m; split. +- intro H; destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; + destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; + try (now right); try (now left). + + exfalso; now apply (lt_neq 0 (n * m)); [apply mul_neg_neg |]. + + exfalso; now apply (lt_neq (n * m) 0); [apply mul_neg_pos |]. + + exfalso; now apply (lt_neq (n * m) 0); [apply mul_pos_neg |]. + + exfalso; now apply (lt_neq 0 (n * m)); [apply mul_pos_pos |]. +- intros [H | H]. + now rewrite H, mul_0_l. + now rewrite H, mul_0_r. +Qed. + +Theorem neq_mul_0 : forall n m, n ~= 0 /\ m ~= 0 <-> n * m ~= 0. +Proof. +intros n m; split; intro H. +- intro H1; apply eq_mul_0 in H1. tauto. +- split; intro H1; rewrite H1 in H; + (rewrite mul_0_l in H || rewrite mul_0_r in H); now apply H. +Qed. + +Theorem eq_square_0 : forall n, n * n == 0 <-> n == 0. +Proof. +intro n; rewrite eq_mul_0; tauto. +Qed. + +Theorem eq_mul_0_l : forall n m, n * m == 0 -> m ~= 0 -> n == 0. +Proof. +intros n m H1 H2. apply eq_mul_0 in H1. destruct H1 as [H1 | H1]. +- assumption. - false_hyp H1 H2. +Qed. + +Theorem eq_mul_0_r : forall n m, n * m == 0 -> n ~= 0 -> m == 0. +Proof. +intros n m H1 H2; apply eq_mul_0 in H1. destruct H1 as [H1 | H1]. +- false_hyp H1 H2. - assumption. +Qed. + +(** Some alternative names: *) + +Definition mul_eq_0 := eq_mul_0. +Definition mul_eq_0_l := eq_mul_0_l. +Definition mul_eq_0_r := eq_mul_0_r. + +Theorem lt_0_mul n m : 0 < n * m <-> (0 < n /\ 0 < m) \/ (m < 0 /\ n < 0). +Proof. +split; [intro H | intros [[H1 H2] | [H1 H2]]]. +- destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; + [| rewrite H1 in H; rewrite mul_0_l in H; false_hyp H lt_irrefl |]; + (destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; + [| rewrite H2 in H; rewrite mul_0_r in H; false_hyp H lt_irrefl |]); + try (left; now split); try (right; now split). + + assert (H3 : n * m < 0) by now apply mul_neg_pos. + exfalso; now apply (lt_asymm (n * m) 0). + + assert (H3 : n * m < 0) by now apply mul_pos_neg. + exfalso; now apply (lt_asymm (n * m) 0). +- now apply mul_pos_pos. - now apply mul_neg_neg. +Qed. + +Theorem square_lt_mono_nonneg : forall n m, 0 <= n -> n < m -> n * n < m * m. +Proof. +intros n m H1 H2. now apply mul_lt_mono_nonneg. +Qed. + +Theorem square_le_mono_nonneg : forall n m, 0 <= n -> n <= m -> n * n <= m * m. +Proof. +intros n m H1 H2. now apply mul_le_mono_nonneg. +Qed. + +(* The converse theorems require nonnegativity (or nonpositivity) of the +other variable *) + +Theorem square_lt_simpl_nonneg : forall n m, 0 <= m -> n * n < m * m -> n < m. +Proof. +intros n m H1 H2. destruct (lt_ge_cases n 0). +- now apply lt_le_trans with 0. +- destruct (lt_ge_cases n m) as [LT|LE]; trivial. + apply square_le_mono_nonneg in LE; order. +Qed. + +Theorem square_le_simpl_nonneg : forall n m, 0 <= m -> n * n <= m * m -> n <= m. +Proof. +intros n m H1 H2. destruct (lt_ge_cases n 0). +- apply lt_le_incl; now apply lt_le_trans with 0. +- destruct (le_gt_cases n m) as [LE|LT]; trivial. + apply square_lt_mono_nonneg in LT; order. +Qed. + +Theorem mul_2_mono_l : forall n m, n < m -> 1 + 2 * n < 2 * m. +Proof. +intros n m. rewrite <- le_succ_l, (mul_le_mono_pos_l (S n) m two). +- rewrite two_succ. nzsimpl. now rewrite le_succ_l. +- order'. +Qed. + +Lemma add_le_mul : forall a b, 1<a -> 1<b -> a+b <= a*b. +Proof. + assert (AUX : forall a b, 0<a -> 0<b -> (S a)+(S b) <= (S a)*(S b)). + - intros a b Ha Hb. + nzsimpl. rewrite <- succ_le_mono. apply le_succ_l. + rewrite <- add_assoc, <- (add_0_l (a+b)), (add_comm b). + apply add_lt_mono_r. + now apply mul_pos_pos. + - intros a b Ha Hb. + assert (Ha' := lt_succ_pred 1 a Ha). + assert (Hb' := lt_succ_pred 1 b Hb). + rewrite <- Ha', <- Hb'. apply AUX; rewrite succ_lt_mono, <- one_succ; order. +Qed. + +(** A few results about squares *) + +Lemma square_nonneg : forall a, 0 <= a * a. +Proof. + intros. rewrite <- (mul_0_r a). destruct (le_gt_cases a 0). + - now apply mul_le_mono_nonpos_l. + - apply mul_le_mono_nonneg_l; order. +Qed. + +Lemma crossmul_le_addsquare : forall a b, 0<=a -> 0<=b -> b*a+a*b <= a*a+b*b. +Proof. + assert (AUX : forall a b, 0<=a<=b -> b*a+a*b <= a*a+b*b). + - intros a b (Ha,H). + destruct (le_exists_sub _ _ H) as (d & EQ & Hd). + rewrite EQ. + rewrite 2 mul_add_distr_r. + rewrite !add_assoc. apply add_le_mono_r. + rewrite add_comm. apply add_le_mono_l. + apply mul_le_mono_nonneg_l; trivial. order. + - intros a b Ha Hb. + destruct (le_gt_cases a b). + + apply AUX; split; order. + + rewrite (add_comm (b*a)), (add_comm (a*a)). + apply AUX; split; order. +Qed. + +Lemma add_square_le : forall a b, 0<=a -> 0<=b -> + a*a + b*b <= (a+b)*(a+b). +Proof. + intros a b Ha Hb. + rewrite mul_add_distr_r, !mul_add_distr_l. + rewrite add_assoc. + apply add_le_mono_r. + rewrite <- add_assoc. + rewrite <- (add_0_r (a*a)) at 1. + apply add_le_mono_l. + apply add_nonneg_nonneg; now apply mul_nonneg_nonneg. +Qed. + +Lemma square_add_le : forall a b, 0<=a -> 0<=b -> + (a+b)*(a+b) <= 2*(a*a + b*b). +Proof. + intros a b Ha Hb. + rewrite !mul_add_distr_l, !mul_add_distr_r. nzsimpl'. + rewrite <- !add_assoc. apply add_le_mono_l. + rewrite !add_assoc. apply add_le_mono_r. + apply crossmul_le_addsquare; order. +Qed. + +Lemma quadmul_le_squareadd : forall a b, 0<=a -> 0<=b -> + 2*2*a*b <= (a+b)*(a+b). +Proof. + intros. + nzsimpl'. + rewrite !mul_add_distr_l, !mul_add_distr_r. + rewrite (add_comm _ (b*b)), add_assoc. + apply add_le_mono_r. + rewrite (add_shuffle0 (a*a)), (mul_comm b a). + apply add_le_mono_r. + rewrite (mul_comm a b) at 1. + now apply crossmul_le_addsquare. +Qed. + +End NZMulOrderProp. diff --git a/theories/Numbers/NatInt/NZOrder.v b/theories/Numbers/NatInt/NZOrder.v new file mode 100644 index 0000000000..89bc5cfecb --- /dev/null +++ b/theories/Numbers/NatInt/NZOrder.v @@ -0,0 +1,664 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Import NZAxioms NZBase Decidable OrdersTac. + +Module Type NZOrderProp + (Import NZ : NZOrdSig')(Import NZBase : NZBaseProp NZ). + +Instance le_wd : Proper (eq==>eq==>iff) le. +Proof. +intros n n' Hn m m' Hm. now rewrite <- !lt_succ_r, Hn, Hm. +Qed. + +Ltac le_elim H := rewrite lt_eq_cases in H; destruct H as [H | H]. + +Theorem lt_le_incl : forall n m, n < m -> n <= m. +Proof. +intros. apply lt_eq_cases. now left. +Qed. + +Theorem le_refl : forall n, n <= n. +Proof. +intro. apply lt_eq_cases. now right. +Qed. + +Theorem lt_succ_diag_r : forall n, n < S n. +Proof. +intro n. rewrite lt_succ_r. apply le_refl. +Qed. + +Theorem le_succ_diag_r : forall n, n <= S n. +Proof. +intro; apply lt_le_incl; apply lt_succ_diag_r. +Qed. + +Theorem neq_succ_diag_l : forall n, S n ~= n. +Proof. +intros n H. apply (lt_irrefl n). rewrite <- H at 2. apply lt_succ_diag_r. +Qed. + +Theorem neq_succ_diag_r : forall n, n ~= S n. +Proof. +intro n; apply neq_sym, neq_succ_diag_l. +Qed. + +Theorem nlt_succ_diag_l : forall n, ~ S n < n. +Proof. +intros n H. apply (lt_irrefl (S n)). rewrite lt_succ_r. now apply lt_le_incl. +Qed. + +Theorem nle_succ_diag_l : forall n, ~ S n <= n. +Proof. +intros n H; le_elim H. ++ false_hyp H nlt_succ_diag_l. + false_hyp H neq_succ_diag_l. +Qed. + +Theorem le_succ_l : forall n m, S n <= m <-> n < m. +Proof. +intro n; nzinduct m n. +- split; intro H. + false_hyp H nle_succ_diag_l. + false_hyp H lt_irrefl. +- intro m. + rewrite (lt_eq_cases (S n) (S m)), !lt_succ_r, (lt_eq_cases n m), succ_inj_wd. + rewrite or_cancel_r. + + reflexivity. + + intros LE EQ; rewrite EQ in LE; false_hyp LE nle_succ_diag_l. + + intros LT EQ; rewrite EQ in LT; false_hyp LT lt_irrefl. +Qed. + +(** Trichotomy *) + +Theorem le_gt_cases : forall n m, n <= m \/ n > m. +Proof. +intros n m; nzinduct n m. +- left; apply le_refl. +- intro n. rewrite lt_succ_r, le_succ_l, !lt_eq_cases. intuition. +Qed. + +Theorem lt_trichotomy : forall n m, n < m \/ n == m \/ m < n. +Proof. +intros n m. generalize (le_gt_cases n m); rewrite lt_eq_cases; tauto. +Qed. + +Notation lt_eq_gt_cases := lt_trichotomy (only parsing). + +(** Asymmetry and transitivity. *) + +Theorem lt_asymm : forall n m, n < m -> ~ m < n. +Proof. +intros n m; nzinduct n m. +- intros H; false_hyp H lt_irrefl. +- intro n; split; intros H H1 H2. + + apply lt_succ_r in H2. le_elim H2. + * apply H; auto. apply le_succ_l. now apply lt_le_incl. + * rewrite H2 in H1. false_hyp H1 nlt_succ_diag_l. + + apply le_succ_l in H1. le_elim H1. + * apply H; auto. rewrite lt_succ_r. now apply lt_le_incl. + * rewrite <- H1 in H2. false_hyp H2 nlt_succ_diag_l. +Qed. + +Notation lt_ngt := lt_asymm (only parsing). + +Theorem lt_trans : forall n m p, n < m -> m < p -> n < p. +Proof. +intros n m p; nzinduct p m. +- intros _ H; false_hyp H lt_irrefl. +- intro p. rewrite 2 lt_succ_r. + split; intros H H1 H2. + + apply lt_le_incl; le_elim H2; [now apply H | now rewrite H2 in H1]. + + assert (n <= p) as H3 by (auto using lt_le_incl). + le_elim H3. + * assumption. + * rewrite <- H3 in H2. + elim (lt_asymm n m); auto. +Qed. + +Theorem le_trans : forall n m p, n <= m -> m <= p -> n <= p. +Proof. +intros n m p. rewrite 3 lt_eq_cases. +intros [LT|EQ] [LT'|EQ']; try rewrite EQ; try rewrite <- EQ'; + generalize (lt_trans n m p); auto with relations. +Qed. + +(** Some type classes about order *) + +Instance lt_strorder : StrictOrder lt. +Proof. split. - exact lt_irrefl. - exact lt_trans. Qed. + +Instance le_preorder : PreOrder le. +Proof. split. - exact le_refl. - exact le_trans. Qed. + +Instance le_partialorder : PartialOrder _ le. +Proof. +intros x y. compute. split. +- intro EQ; now rewrite EQ. +- rewrite 2 lt_eq_cases. intuition. elim (lt_irrefl x). now transitivity y. +Qed. + +(** We know enough now to benefit from the generic [order] tactic. *) + +Definition lt_compat := lt_wd. +Definition lt_total := lt_trichotomy. +Definition le_lteq := lt_eq_cases. + +Module Private_OrderTac. +Module IsTotal. + Definition eq_equiv := eq_equiv. + Definition lt_strorder := lt_strorder. + Definition lt_compat := lt_compat. + Definition lt_total := lt_total. + Definition le_lteq := le_lteq. +End IsTotal. +Module Tac := !MakeOrderTac NZ IsTotal. +End Private_OrderTac. +Ltac order := Private_OrderTac.Tac.order. + +(** Some direct consequences of [order]. *) + +Theorem lt_neq : forall n m, n < m -> n ~= m. +Proof. order. Qed. + +Theorem le_neq : forall n m, n < m <-> n <= m /\ n ~= m. +Proof. intuition order. Qed. + +Theorem eq_le_incl : forall n m, n == m -> n <= m. +Proof. order. Qed. + +Lemma lt_stepl : forall x y z, x < y -> x == z -> z < y. +Proof. order. Qed. + +Lemma lt_stepr : forall x y z, x < y -> y == z -> x < z. +Proof. order. Qed. + +Lemma le_stepl : forall x y z, x <= y -> x == z -> z <= y. +Proof. order. Qed. + +Lemma le_stepr : forall x y z, x <= y -> y == z -> x <= z. +Proof. order. Qed. + +Declare Left Step lt_stepl. +Declare Right Step lt_stepr. +Declare Left Step le_stepl. +Declare Right Step le_stepr. + +Theorem le_lt_trans : forall n m p, n <= m -> m < p -> n < p. +Proof. order. Qed. + +Theorem lt_le_trans : forall n m p, n < m -> m <= p -> n < p. +Proof. order. Qed. + +Theorem le_antisymm : forall n m, n <= m -> m <= n -> n == m. +Proof. order. Qed. + +(** More properties of [<] and [<=] with respect to [S] and [0]. *) + +Theorem le_succ_r : forall n m, n <= S m <-> n <= m \/ n == S m. +Proof. +intros n m; rewrite lt_eq_cases. now rewrite lt_succ_r. +Qed. + +Theorem lt_succ_l : forall n m, S n < m -> n < m. +Proof. +intros n m H; apply le_succ_l; order. +Qed. + +Theorem le_le_succ_r : forall n m, n <= m -> n <= S m. +Proof. +intros n m LE. apply lt_succ_r in LE. order. +Qed. + +Theorem lt_lt_succ_r : forall n m, n < m -> n < S m. +Proof. +intros. rewrite lt_succ_r. order. +Qed. + +Theorem succ_lt_mono : forall n m, n < m <-> S n < S m. +Proof. +intros n m. rewrite <- le_succ_l. symmetry. apply lt_succ_r. +Qed. + +Theorem succ_le_mono : forall n m, n <= m <-> S n <= S m. +Proof. +intros n m. now rewrite 2 lt_eq_cases, <- succ_lt_mono, succ_inj_wd. +Qed. + +Theorem lt_0_1 : 0 < 1. +Proof. +rewrite one_succ. apply lt_succ_diag_r. +Qed. + +Theorem le_0_1 : 0 <= 1. +Proof. +apply lt_le_incl, lt_0_1. +Qed. + +Theorem lt_1_2 : 1 < 2. +Proof. +rewrite two_succ. apply lt_succ_diag_r. +Qed. + +Theorem lt_0_2 : 0 < 2. +Proof. + transitivity 1. - apply lt_0_1. - apply lt_1_2. +Qed. + +Theorem le_0_2 : 0 <= 2. +Proof. +apply lt_le_incl, lt_0_2. +Qed. + +(** The order tactic enriched with some knowledge of 0,1,2 *) + +Ltac order' := generalize lt_0_1 lt_1_2; order. + +Theorem lt_1_l : forall n m, 0 < n -> n < m -> 1 < m. +Proof. +intros n m H1 H2. rewrite <- le_succ_l, <- one_succ in H1. order. +Qed. + +(** More Trichotomy, decidability and double negation elimination. *) + +(** The following theorem is cleary redundant, but helps not to +remember whether one has to say le_gt_cases or lt_ge_cases *) + +Theorem lt_ge_cases : forall n m, n < m \/ n >= m. +Proof. +intros n m; destruct (le_gt_cases m n); intuition order. +Qed. + +Theorem le_ge_cases : forall n m, n <= m \/ n >= m. +Proof. +intros n m; destruct (le_gt_cases n m); intuition order. +Qed. + +Theorem lt_gt_cases : forall n m, n ~= m <-> n < m \/ n > m. +Proof. +intros n m; destruct (lt_trichotomy n m); intuition order. +Qed. + +(** Decidability of equality, even though true in each finite ring, does not +have a uniform proof. Otherwise, the proof for two fixed numbers would +reduce to a normal form that will say if the numbers are equal or not, +which cannot be true in all finite rings. Therefore, we prove decidability +in the presence of order. *) + +Theorem eq_decidable : forall n m, decidable (n == m). +Proof. +intros n m; destruct (lt_trichotomy n m) as [ | [ | ]]; + (right; order) || (left; order). +Qed. + +(** DNE stands for double-negation elimination *) + +Theorem eq_dne : forall n m, ~ ~ n == m <-> n == m. +Proof. +intros n m; split; intro H. +- destruct (eq_decidable n m) as [H1 | H1]. + + assumption. + false_hyp H1 H. +- intro H1; now apply H1. +Qed. + +Theorem le_ngt : forall n m, n <= m <-> ~ n > m. +Proof. intuition order. Qed. + +(** Redundant but useful *) + +Theorem nlt_ge : forall n m, ~ n < m <-> n >= m. +Proof. intuition order. Qed. + +Theorem lt_decidable : forall n m, decidable (n < m). +Proof. +intros n m; destruct (le_gt_cases m n); [right|left]; order. +Qed. + +Theorem lt_dne : forall n m, ~ ~ n < m <-> n < m. +Proof. +intros n m; split; intro H. +- destruct (lt_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H]. +- intro H1; false_hyp H H1. +Qed. + +Theorem nle_gt : forall n m, ~ n <= m <-> n > m. +Proof. intuition order. Qed. + +(** Redundant but useful *) + +Theorem lt_nge : forall n m, n < m <-> ~ n >= m. +Proof. intuition order. Qed. + +Theorem le_decidable : forall n m, decidable (n <= m). +Proof. +intros n m; destruct (le_gt_cases n m); [left|right]; order. +Qed. + +Theorem le_dne : forall n m, ~ ~ n <= m <-> n <= m. +Proof. +intros n m; split; intro H. +- destruct (le_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H]. +- intro H1; false_hyp H H1. +Qed. + +Theorem nlt_succ_r : forall n m, ~ m < S n <-> n < m. +Proof. +intros n m; rewrite lt_succ_r. intuition order. +Qed. + +(** The difference between integers and natural numbers is that for +every integer there is a predecessor, which is not true for natural +numbers. However, for both classes, every number that is bigger than +some other number has a predecessor. The proof of this fact by regular +induction does not go through, so we need to use strong +(course-of-value) induction. *) + +Lemma lt_exists_pred_strong : + forall z n m, z < m -> m <= n -> exists k, m == S k /\ z <= k. +Proof. +intro z; nzinduct n z. +- order. +- intro n; split; intros IH m H1 H2. + + apply le_succ_r in H2. destruct H2 as [H2 | H2]. + * now apply IH. * exists n. now split; [| rewrite <- lt_succ_r; rewrite <- H2]. + + apply IH. * assumption. * now apply le_le_succ_r. +Qed. + +Theorem lt_exists_pred : + forall z n, z < n -> exists k, n == S k /\ z <= k. +Proof. +intros z n H; apply lt_exists_pred_strong with (z := z) (n := n). +- assumption. - apply le_refl. +Qed. + +Lemma lt_succ_pred : forall z n, z < n -> S (P n) == n. +Proof. + intros z n H. + destruct (lt_exists_pred _ _ H) as (n' & EQ & LE). + rewrite EQ. now rewrite pred_succ. +Qed. + +(** Stronger variant of induction with assumptions n >= 0 (n < 0) +in the induction step *) + +Section Induction. + +Variable A : t -> Prop. +Hypothesis A_wd : Proper (eq==>iff) A. + +Section Center. + +Variable z : t. (* A z is the basis of induction *) + +Section RightInduction. + +Let A' (n : t) := forall m, z <= m -> m < n -> A m. +Let right_step := forall n, z <= n -> A n -> A (S n). +Let right_step' := forall n, z <= n -> A' n -> A n. +Let right_step'' := forall n, A' n <-> A' (S n). + +Lemma rs_rs' : A z -> right_step -> right_step'. +Proof. +intros Az RS n H1 H2. +le_elim H1. +- apply lt_exists_pred in H1. destruct H1 as [k [H3 H4]]. + rewrite H3. apply RS; trivial. apply H2; trivial. + rewrite H3; apply lt_succ_diag_r. +- rewrite <- H1; apply Az. +Qed. + +Lemma rs'_rs'' : right_step' -> right_step''. +Proof. +intros RS' n; split; intros H1 m H2 H3. +- apply lt_succ_r in H3; le_elim H3; + [now apply H1 | rewrite H3 in *; now apply RS']. +- apply H1; [assumption | now apply lt_lt_succ_r]. +Qed. + +Lemma rbase : A' z. +Proof. +intros m H1 H2. apply le_ngt in H1. false_hyp H2 H1. +Qed. + +Lemma A'A_right : (forall n, A' n) -> forall n, z <= n -> A n. +Proof. +intros H1 n H2. apply H1 with (n := S n); [assumption | apply lt_succ_diag_r]. +Qed. + +Theorem strong_right_induction: right_step' -> forall n, z <= n -> A n. +Proof. +intro RS'; apply A'A_right; unfold A'; nzinduct n z; +[apply rbase | apply rs'_rs''; apply RS']. +Qed. + +Theorem right_induction : A z -> right_step -> forall n, z <= n -> A n. +Proof. +intros Az RS; apply strong_right_induction; now apply rs_rs'. +Qed. + +Theorem right_induction' : + (forall n, n <= z -> A n) -> right_step -> forall n, A n. +Proof. +intros L R n. +destruct (lt_trichotomy n z) as [H | [H | H]]. +- apply L; now apply lt_le_incl. +- apply L; now apply eq_le_incl. +- apply right_induction. + + apply L; now apply eq_le_incl. + + assumption. + + now apply lt_le_incl. +Qed. + +Theorem strong_right_induction' : + (forall n, n <= z -> A n) -> right_step' -> forall n, A n. +Proof. +intros L R n. +destruct (lt_trichotomy n z) as [H | [H | H]]. +- apply L; now apply lt_le_incl. +- apply L; now apply eq_le_incl. +- apply strong_right_induction. + + assumption. + now apply lt_le_incl. +Qed. + +End RightInduction. + +Section LeftInduction. + +Let A' (n : t) := forall m, m <= z -> n <= m -> A m. +Let left_step := forall n, n < z -> A (S n) -> A n. +Let left_step' := forall n, n <= z -> A' (S n) -> A n. +Let left_step'' := forall n, A' n <-> A' (S n). + +Lemma ls_ls' : A z -> left_step -> left_step'. +Proof. +intros Az LS n H1 H2. le_elim H1. +- apply LS; trivial. apply H2; [now apply le_succ_l | now apply eq_le_incl]. +- rewrite H1; apply Az. +Qed. + +Lemma ls'_ls'' : left_step' -> left_step''. +Proof. +intros LS' n; split; intros H1 m H2 H3. +- apply le_succ_l in H3. apply lt_le_incl in H3. now apply H1. +- le_elim H3. + + apply le_succ_l in H3. now apply H1. + + rewrite <- H3 in *; now apply LS'. +Qed. + +Lemma lbase : A' (S z). +Proof. +intros m H1 H2. apply le_succ_l in H2. +apply le_ngt in H1. false_hyp H2 H1. +Qed. + +Lemma A'A_left : (forall n, A' n) -> forall n, n <= z -> A n. +Proof. +intros H1 n H2. apply (H1 n); [assumption | now apply eq_le_incl]. +Qed. + +Theorem strong_left_induction: left_step' -> forall n, n <= z -> A n. +Proof. +intro LS'; apply A'A_left; unfold A'; nzinduct n (S z); +[apply lbase | apply ls'_ls''; apply LS']. +Qed. + +Theorem left_induction : A z -> left_step -> forall n, n <= z -> A n. +Proof. +intros Az LS; apply strong_left_induction; now apply ls_ls'. +Qed. + +Theorem left_induction' : + (forall n, z <= n -> A n) -> left_step -> forall n, A n. +Proof. +intros R L n. +destruct (lt_trichotomy n z) as [H | [H | H]]. +- apply left_induction. + + apply R. now apply eq_le_incl. + + assumption. + + now apply lt_le_incl. +- rewrite H; apply R; now apply eq_le_incl. +- apply R; now apply lt_le_incl. +Qed. + +Theorem strong_left_induction' : + (forall n, z <= n -> A n) -> left_step' -> forall n, A n. +Proof. +intros R L n. +destruct (lt_trichotomy n z) as [H | [H | H]]. +- apply strong_left_induction; auto. now apply lt_le_incl. +- rewrite H; apply R; now apply eq_le_incl. +- apply R; now apply lt_le_incl. +Qed. + +End LeftInduction. + +Theorem order_induction : + A z -> + (forall n, z <= n -> A n -> A (S n)) -> + (forall n, n < z -> A (S n) -> A n) -> + forall n, A n. +Proof. +intros Az RS LS n. +destruct (lt_trichotomy n z) as [H | [H | H]]. +- now apply left_induction; [| | apply lt_le_incl]. +- now rewrite H. +- now apply right_induction; [| | apply lt_le_incl]. +Qed. + +Theorem order_induction' : + A z -> + (forall n, z <= n -> A n -> A (S n)) -> + (forall n, n <= z -> A n -> A (P n)) -> + forall n, A n. +Proof. +intros Az AS AP n; apply order_induction; try assumption. +intros m H1 H2. apply AP in H2; [|now apply le_succ_l]. +now rewrite pred_succ in H2. +Qed. + +End Center. + +Theorem order_induction_0 : + A 0 -> + (forall n, 0 <= n -> A n -> A (S n)) -> + (forall n, n < 0 -> A (S n) -> A n) -> + forall n, A n. +Proof (order_induction 0). + +Theorem order_induction'_0 : + A 0 -> + (forall n, 0 <= n -> A n -> A (S n)) -> + (forall n, n <= 0 -> A n -> A (P n)) -> + forall n, A n. +Proof (order_induction' 0). + +(** Elimintation principle for < *) + +Theorem lt_ind : forall (n : t), + A (S n) -> + (forall m, n < m -> A m -> A (S m)) -> + forall m, n < m -> A m. +Proof. +intros n H1 H2 m H3. +apply right_induction with (S n); [assumption | | now apply le_succ_l]. +intros; apply H2; try assumption. now apply le_succ_l. +Qed. + +(** Elimination principle for <= *) + +Theorem le_ind : forall (n : t), + A n -> + (forall m, n <= m -> A m -> A (S m)) -> + forall m, n <= m -> A m. +Proof. +intros n H1 H2 m H3. +now apply right_induction with n. +Qed. + +End Induction. + +Tactic Notation "nzord_induct" ident(n) := + induction_maker n ltac:(apply order_induction_0). + +Tactic Notation "nzord_induct" ident(n) constr(z) := + induction_maker n ltac:(apply order_induction with z). + +Section WF. + +Variable z : t. + +Let Rlt (n m : t) := z <= n < m. +Let Rgt (n m : t) := m < n <= z. + +Instance Rlt_wd : Proper (eq ==> eq ==> iff) Rlt. +Proof. +intros x1 x2 H1 x3 x4 H2; unfold Rlt. rewrite H1; now rewrite H2. +Qed. + +Instance Rgt_wd : Proper (eq ==> eq ==> iff) Rgt. +Proof. +intros x1 x2 H1 x3 x4 H2; unfold Rgt; rewrite H1; now rewrite H2. +Qed. + +Theorem lt_wf : well_founded Rlt. +Proof. +unfold well_founded. +apply strong_right_induction' with (z := z). +- auto with typeclass_instances. +- intros n H; constructor; intros y [H1 H2]. + apply nle_gt in H2. elim H2. now apply le_trans with z. +- intros n H1 H2; constructor; intros m [H3 H4]. now apply H2. +Qed. + +Theorem gt_wf : well_founded Rgt. +Proof. +unfold well_founded. +apply strong_left_induction' with (z := z). +- auto with typeclass_instances. +- intros n H; constructor; intros y [H1 H2]. + apply nle_gt in H2. + + elim H2. + + now apply le_lt_trans with n. +- intros n H1 H2; constructor; intros m [H3 H4]. + apply H2. + + assumption. + now apply le_succ_l. +Qed. + +End WF. + +End NZOrderProp. + +(** If we have moreover a [compare] function, we can build + an [OrderedType] structure. *) + +(* Temporary workaround for bug #2949: remove this problematic + unused functor +Module NZOrderedType (NZ : NZDecOrdSig') + <: DecidableTypeFull <: OrderedTypeFull + := NZ <+ NZBaseProp <+ NZOrderProp <+ Compare2EqBool <+ HasEqBool2Dec. +*) diff --git a/theories/Numbers/NatInt/NZParity.v b/theories/Numbers/NatInt/NZParity.v new file mode 100644 index 0000000000..84b8a96e64 --- /dev/null +++ b/theories/Numbers/NatInt/NZParity.v @@ -0,0 +1,265 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import Bool NZAxioms NZMulOrder. + +(** Parity functions *) + +Module Type NZParity (Import A : NZAxiomsSig'). + Parameter Inline even odd : t -> bool. + Definition Even n := exists m, n == 2*m. + Definition Odd n := exists m, n == 2*m+1. + Axiom even_spec : forall n, even n = true <-> Even n. + Axiom odd_spec : forall n, odd n = true <-> Odd n. +End NZParity. + +Module Type NZParityProp + (Import A : NZOrdAxiomsSig') + (Import B : NZParity A) + (Import C : NZMulOrderProp A). + +(** Morphisms *) + +Instance Even_wd : Proper (eq==>iff) Even. +Proof. unfold Even. solve_proper. Qed. + +Instance Odd_wd : Proper (eq==>iff) Odd. +Proof. unfold Odd. solve_proper. Qed. + +Instance even_wd : Proper (eq==>Logic.eq) even. +Proof. + intros x x' EQ. rewrite eq_iff_eq_true, 2 even_spec. now f_equiv. +Qed. + +Instance odd_wd : Proper (eq==>Logic.eq) odd. +Proof. + intros x x' EQ. rewrite eq_iff_eq_true, 2 odd_spec. now f_equiv. +Qed. + +(** Evenness and oddity are dual notions *) + +Lemma Even_or_Odd : forall x, Even x \/ Odd x. +Proof. + nzinduct x. + - left. exists 0. now nzsimpl. + - intros x. + split; intros [(y,H)|(y,H)]. + + right. exists y. rewrite H. now nzsimpl. + + left. exists (S y). rewrite H. now nzsimpl'. + + right. + assert (LT : exists z, z<y). + * destruct (lt_ge_cases 0 y) as [LT|GT]; [now exists 0 | exists x]. + rewrite <- le_succ_l, H. nzsimpl'. + rewrite <- (add_0_r y) at 3. now apply add_le_mono_l. + * destruct LT as (z,LT). + destruct (lt_exists_pred z y LT) as (y' & Hy' & _). + exists y'. rewrite <- succ_inj_wd, H, Hy'. now nzsimpl'. + + left. exists y. rewrite <- succ_inj_wd. rewrite H. now nzsimpl. +Qed. + +Lemma double_below : forall n m, n<=m -> 2*n < 2*m+1. +Proof. + intros. nzsimpl'. apply lt_succ_r. now apply add_le_mono. +Qed. + +Lemma double_above : forall n m, n<m -> 2*n+1 < 2*m. +Proof. + intros. nzsimpl'. + rewrite <- le_succ_l, <- add_succ_l, <- add_succ_r. + apply add_le_mono; now apply le_succ_l. +Qed. + +Lemma Even_Odd_False : forall x, Even x -> Odd x -> False. +Proof. +intros x (y,E) (z,O). rewrite O in E; clear O. +destruct (le_gt_cases y z) as [LE|GT]. +- generalize (double_below _ _ LE); order. +- generalize (double_above _ _ GT); order. +Qed. + +Lemma orb_even_odd : forall n, orb (even n) (odd n) = true. +Proof. + intros. + destruct (Even_or_Odd n) as [H|H]. + - rewrite <- even_spec in H. now rewrite H. + - rewrite <- odd_spec in H. now rewrite H, orb_true_r. +Qed. + +Lemma negb_odd : forall n, negb (odd n) = even n. +Proof. + intros. + generalize (Even_or_Odd n) (Even_Odd_False n). + rewrite <- even_spec, <- odd_spec. + destruct (odd n), (even n) ; simpl; intuition. +Qed. + +Lemma negb_even : forall n, negb (even n) = odd n. +Proof. + intros. rewrite <- negb_odd. apply negb_involutive. +Qed. + +(** Constants *) + +Lemma even_0 : even 0 = true. +Proof. + rewrite even_spec. exists 0. now nzsimpl. +Qed. + +Lemma odd_0 : odd 0 = false. +Proof. + now rewrite <- negb_even, even_0. +Qed. + +Lemma odd_1 : odd 1 = true. +Proof. + rewrite odd_spec. exists 0. now nzsimpl'. +Qed. + +Lemma even_1 : even 1 = false. +Proof. + now rewrite <- negb_odd, odd_1. +Qed. + +Lemma even_2 : even 2 = true. +Proof. + rewrite even_spec. exists 1. now nzsimpl'. +Qed. + +Lemma odd_2 : odd 2 = false. +Proof. + now rewrite <- negb_even, even_2. +Qed. + +(** Parity and successor *) + +Lemma Odd_succ : forall n, Odd (S n) <-> Even n. +Proof. + split; intros (m,H). + - exists m. apply succ_inj. now rewrite add_1_r in H. + - exists m. rewrite add_1_r. now f_equiv. +Qed. + +Lemma odd_succ : forall n, odd (S n) = even n. +Proof. + intros. apply eq_iff_eq_true. rewrite even_spec, odd_spec. + apply Odd_succ. +Qed. + +Lemma even_succ : forall n, even (S n) = odd n. +Proof. + intros. now rewrite <- negb_odd, odd_succ, negb_even. +Qed. + +Lemma Even_succ : forall n, Even (S n) <-> Odd n. +Proof. + intros. now rewrite <- even_spec, even_succ, odd_spec. +Qed. + +(** Parity and successor of successor *) + +Lemma Even_succ_succ : forall n, Even (S (S n)) <-> Even n. +Proof. + intros. now rewrite Even_succ, Odd_succ. +Qed. + +Lemma Odd_succ_succ : forall n, Odd (S (S n)) <-> Odd n. +Proof. + intros. now rewrite Odd_succ, Even_succ. +Qed. + +Lemma even_succ_succ : forall n, even (S (S n)) = even n. +Proof. + intros. now rewrite even_succ, odd_succ. +Qed. + +Lemma odd_succ_succ : forall n, odd (S (S n)) = odd n. +Proof. + intros. now rewrite odd_succ, even_succ. +Qed. + +(** Parity and addition *) + +Lemma even_add : forall n m, even (n+m) = Bool.eqb (even n) (even m). +Proof. + intros. + case_eq (even n); case_eq (even m); + rewrite <- ?negb_true_iff, ?negb_even, ?odd_spec, ?even_spec; + intros (m',Hm) (n',Hn). + - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm. + - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm, add_assoc. + - exists (n'+m'). now rewrite mul_add_distr_l, Hn, Hm, add_shuffle0. + - exists (n'+m'+1). rewrite Hm,Hn. nzsimpl'. now rewrite add_shuffle1. +Qed. + +Lemma odd_add : forall n m, odd (n+m) = xorb (odd n) (odd m). +Proof. + intros. rewrite <- !negb_even. rewrite even_add. + now destruct (even n), (even m). +Qed. + +(** Parity and multiplication *) + +Lemma even_mul : forall n m, even (mul n m) = even n || even m. +Proof. + intros. + case_eq (even n); simpl; rewrite ?even_spec. + - intros (n',Hn). exists (n'*m). now rewrite Hn, mul_assoc. + - case_eq (even m); simpl; rewrite ?even_spec. + + intros (m',Hm). exists (n*m'). now rewrite Hm, !mul_assoc, (mul_comm 2). + (* odd / odd *) + + rewrite <- !negb_true_iff, !negb_even, !odd_spec. + intros (m',Hm) (n',Hn). exists (n'*2*m' +n'+m'). + rewrite Hn,Hm, !mul_add_distr_l, !mul_add_distr_r, !mul_1_l, !mul_1_r. + now rewrite add_shuffle1, add_assoc, !mul_assoc. +Qed. + +Lemma odd_mul : forall n m, odd (mul n m) = odd n && odd m. +Proof. + intros. rewrite <- !negb_even. rewrite even_mul. + now destruct (even n), (even m). +Qed. + +(** A particular case : adding by an even number *) + +Lemma even_add_even : forall n m, Even m -> even (n+m) = even n. +Proof. + intros n m Hm. apply even_spec in Hm. + rewrite even_add, Hm. now destruct (even n). +Qed. + +Lemma odd_add_even : forall n m, Even m -> odd (n+m) = odd n. +Proof. + intros n m Hm. apply even_spec in Hm. + rewrite odd_add, <- (negb_even m), Hm. now destruct (odd n). +Qed. + +Lemma even_add_mul_even : forall n m p, Even m -> even (n+m*p) = even n. +Proof. + intros n m p Hm. apply even_spec in Hm. + apply even_add_even. apply even_spec. now rewrite even_mul, Hm. +Qed. + +Lemma odd_add_mul_even : forall n m p, Even m -> odd (n+m*p) = odd n. +Proof. + intros n m p Hm. apply even_spec in Hm. + apply odd_add_even. apply even_spec. now rewrite even_mul, Hm. +Qed. + +Lemma even_add_mul_2 : forall n m, even (n+2*m) = even n. +Proof. + intros. apply even_add_mul_even. apply even_spec, even_2. +Qed. + +Lemma odd_add_mul_2 : forall n m, odd (n+2*m) = odd n. +Proof. + intros. apply odd_add_mul_even. apply even_spec, even_2. +Qed. + +End NZParityProp. diff --git a/theories/Numbers/NatInt/NZPow.v b/theories/Numbers/NatInt/NZPow.v new file mode 100644 index 0000000000..830540bc66 --- /dev/null +++ b/theories/Numbers/NatInt/NZPow.v @@ -0,0 +1,413 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Power Function *) + +Require Import NZAxioms NZMulOrder. + +(** Interface of a power function, then its specification on naturals *) + +Module Type Pow (Import A : Typ). + Parameters Inline pow : t -> t -> t. +End Pow. + +Module Type PowNotation (A : Typ)(Import B : Pow A). + Infix "^" := pow. +End PowNotation. + +Module Type Pow' (A : Typ) := Pow A <+ PowNotation A. + +Module Type NZPowSpec (Import A : NZOrdAxiomsSig')(Import B : Pow' A). + Declare Instance pow_wd : Proper (eq==>eq==>eq) pow. + Axiom pow_0_r : forall a, a^0 == 1. + Axiom pow_succ_r : forall a b, 0<=b -> a^(succ b) == a * a^b. + Axiom pow_neg_r : forall a b, b<0 -> a^b == 0. +End NZPowSpec. + +(** The above [pow_neg_r] specification is useless (and trivially + provable) for N. Having it here already allows deriving + some slightly more general statements. *) + +Module Type NZPow (A : NZOrdAxiomsSig) := Pow A <+ NZPowSpec A. +Module Type NZPow' (A : NZOrdAxiomsSig) := Pow' A <+ NZPowSpec A. + +(** Derived properties of power *) + +Module Type NZPowProp + (Import A : NZOrdAxiomsSig') + (Import B : NZPow' A) + (Import C : NZMulOrderProp A). + +Hint Rewrite pow_0_r pow_succ_r : nz. + +(** Power and basic constants *) + +Lemma pow_0_l : forall a, 0<a -> 0^a == 0. +Proof. + intros a Ha. + destruct (lt_exists_pred _ _ Ha) as (a' & EQ & Ha'). + rewrite EQ. now nzsimpl. +Qed. + +Lemma pow_0_l' : forall a, a~=0 -> 0^a == 0. +Proof. + intros a Ha. + destruct (lt_trichotomy a 0) as [LT|[EQ|GT]]; try order. + - now rewrite pow_neg_r. + - now apply pow_0_l. +Qed. + +Lemma pow_1_r : forall a, a^1 == a. +Proof. + intros. now nzsimpl'. +Qed. + +Lemma pow_1_l : forall a, 0<=a -> 1^a == 1. +Proof. + apply le_ind; intros. - solve_proper. + - now nzsimpl. + - now nzsimpl. +Qed. + +Hint Rewrite pow_1_r pow_1_l : nz. + +Lemma pow_2_r : forall a, a^2 == a*a. +Proof. + intros. rewrite two_succ. nzsimpl; order'. +Qed. + +Hint Rewrite pow_2_r : nz. + +(** Power and nullity *) + +Lemma pow_eq_0 : forall a b, 0<=b -> a^b == 0 -> a == 0. +Proof. + intros a b Hb. apply le_ind with (4:=Hb). + - solve_proper. + - rewrite pow_0_r. order'. + - clear b Hb. intros b Hb IH. + rewrite pow_succ_r by trivial. + intros H. apply eq_mul_0 in H. destruct H; trivial. + now apply IH. +Qed. + +Lemma pow_nonzero : forall a b, a~=0 -> 0<=b -> a^b ~= 0. +Proof. + intros a b Ha Hb. contradict Ha. now apply pow_eq_0 with b. +Qed. + +Lemma pow_eq_0_iff : forall a b, a^b == 0 <-> b<0 \/ (0<b /\ a==0). +Proof. + intros a b. split. + - intros H. + destruct (lt_trichotomy b 0) as [Hb|[Hb|Hb]]. + + now left. + + rewrite Hb, pow_0_r in H; order'. + + right. split; trivial. apply pow_eq_0 with b; order. + - intros [Hb|[Hb Ha]]. + now rewrite pow_neg_r. + + rewrite Ha. apply pow_0_l'. order. +Qed. + +(** Power and addition, multiplication *) + +Lemma pow_add_r : forall a b c, 0<=b -> 0<=c -> + a^(b+c) == a^b * a^c. +Proof. + intros a b c Hb. apply le_ind with (4:=Hb). - solve_proper. + - now nzsimpl. + - clear b Hb. intros b Hb IH Hc. + nzsimpl; trivial. + + rewrite IH; trivial. apply mul_assoc. + + now apply add_nonneg_nonneg. +Qed. + +Lemma pow_mul_l : forall a b c, + (a*b)^c == a^c * b^c. +Proof. + intros a b c. + destruct (lt_ge_cases c 0) as [Hc|Hc]. + - rewrite !(pow_neg_r _ _ Hc). now nzsimpl. + - apply le_ind with (4:=Hc). + solve_proper. + + now nzsimpl. + + clear c Hc. intros c Hc IH. + nzsimpl; trivial. + rewrite IH; trivial. apply mul_shuffle1. +Qed. + +Lemma pow_mul_r : forall a b c, 0<=b -> 0<=c -> + a^(b*c) == (a^b)^c. +Proof. + intros a b c Hb. apply le_ind with (4:=Hb). - solve_proper. + - intros. now nzsimpl. + - clear b Hb. intros b Hb IH Hc. + nzsimpl; trivial. + rewrite pow_add_r, IH, pow_mul_l; trivial. + apply mul_comm. + + now apply mul_nonneg_nonneg. +Qed. + +(** Positivity *) + +Lemma pow_nonneg : forall a b, 0<=a -> 0<=a^b. +Proof. + intros a b Ha. + destruct (lt_ge_cases b 0) as [Hb|Hb]. + - now rewrite !(pow_neg_r _ _ Hb). + - apply le_ind with (4:=Hb). + solve_proper. + + nzsimpl; order'. + + clear b Hb. intros b Hb IH. + nzsimpl; trivial. now apply mul_nonneg_nonneg. +Qed. + +Lemma pow_pos_nonneg : forall a b, 0<a -> 0<=b -> 0<a^b. +Proof. + intros a b Ha Hb. apply le_ind with (4:=Hb). - solve_proper. + - nzsimpl; order'. + - clear b Hb. intros b Hb IH. + nzsimpl; trivial. now apply mul_pos_pos. +Qed. + +(** Monotonicity *) + +Lemma pow_lt_mono_l : forall a b c, 0<c -> 0<=a<b -> a^c < b^c. +Proof. + intros a b c Hc. apply lt_ind with (4:=Hc). - solve_proper. + - intros (Ha,H). nzsimpl; trivial; order. + - clear c Hc. intros c Hc IH (Ha,H). + nzsimpl; try order. + apply mul_lt_mono_nonneg; trivial. + + apply pow_nonneg; try order. + + apply IH. now split. +Qed. + +Lemma pow_le_mono_l : forall a b c, 0<=a<=b -> a^c <= b^c. +Proof. + intros a b c (Ha,H). + destruct (lt_trichotomy c 0) as [Hc|[Hc|Hc]]. + - rewrite !(pow_neg_r _ _ Hc); now nzsimpl. + - rewrite Hc; now nzsimpl. + - apply lt_eq_cases in H. destruct H as [H|H]; [|now rewrite <- H]. + apply lt_le_incl, pow_lt_mono_l; now try split. +Qed. + +Lemma pow_gt_1 : forall a b, 1<a -> (0<b <-> 1<a^b). +Proof. + intros a b Ha. split; intros Hb. + - rewrite <- (pow_1_l b) by order. + apply pow_lt_mono_l; try split; order'. + - destruct (lt_trichotomy b 0) as [H|[H|H]]; trivial. + + rewrite pow_neg_r in Hb; order'. + + rewrite H, pow_0_r in Hb. order. +Qed. + +Lemma pow_lt_mono_r : forall a b c, 1<a -> 0<=c -> b<c -> a^b < a^c. +Proof. + intros a b c Ha Hc H. + destruct (lt_ge_cases b 0) as [Hb|Hb]. + - rewrite pow_neg_r by trivial. apply pow_pos_nonneg; order'. + - assert (H' : b<=c) by order. + destruct (le_exists_sub _ _ H') as (d & EQ & Hd). + rewrite EQ, pow_add_r; trivial. rewrite <- (mul_1_l (a^b)) at 1. + apply mul_lt_mono_pos_r. + + apply pow_pos_nonneg; order'. + + apply pow_gt_1; trivial. + apply lt_eq_cases in Hd; destruct Hd as [LT|EQ']; trivial. + rewrite <- EQ' in *. rewrite add_0_l in EQ. order. +Qed. + +(** NB: since 0^0 > 0^1, the following result isn't valid with a=0 *) + +Lemma pow_le_mono_r : forall a b c, 0<a -> b<=c -> a^b <= a^c. +Proof. + intros a b c Ha H. + destruct (lt_ge_cases b 0) as [Hb|Hb]. + - rewrite (pow_neg_r _ _ Hb). apply pow_nonneg; order. + - apply le_succ_l in Ha; rewrite <- one_succ in Ha. + apply lt_eq_cases in Ha; destruct Ha as [Ha|Ha]; [|rewrite <- Ha]. + + apply lt_eq_cases in H; destruct H as [H|H]; [|now rewrite <- H]. + apply lt_le_incl, pow_lt_mono_r; order. + + nzsimpl; order. +Qed. + +Lemma pow_le_mono : forall a b c d, 0<a<=c -> b<=d -> + a^b <= c^d. +Proof. + intros. transitivity (a^d). + - apply pow_le_mono_r; intuition order. + - apply pow_le_mono_l; intuition order. +Qed. + +Lemma pow_lt_mono : forall a b c d, 0<a<c -> 0<b<d -> + a^b < c^d. +Proof. + intros a b c d (Ha,Hac) (Hb,Hbd). + apply le_succ_l in Ha; rewrite <- one_succ in Ha. + apply lt_eq_cases in Ha; destruct Ha as [Ha|Ha]; [|rewrite <- Ha]. + - transitivity (a^d). + + apply pow_lt_mono_r; intuition order. + + apply pow_lt_mono_l; try split; order'. + - nzsimpl; try order. apply pow_gt_1; order. +Qed. + +(** Injectivity *) + +Lemma pow_inj_l : forall a b c, 0<=a -> 0<=b -> 0<c -> + a^c == b^c -> a == b. +Proof. + intros a b c Ha Hb Hc EQ. + destruct (lt_trichotomy a b) as [LT|[EQ'|GT]]; trivial. + - assert (a^c < b^c) by (apply pow_lt_mono_l; try split; trivial). + order. + - assert (b^c < a^c) by (apply pow_lt_mono_l; try split; trivial). + order. +Qed. + +Lemma pow_inj_r : forall a b c, 1<a -> 0<=b -> 0<=c -> + a^b == a^c -> b == c. +Proof. + intros a b c Ha Hb Hc EQ. + destruct (lt_trichotomy b c) as [LT|[EQ'|GT]]; trivial. + - assert (a^b < a^c) by (apply pow_lt_mono_r; try split; trivial). + order. + - assert (a^c < a^b) by (apply pow_lt_mono_r; try split; trivial). + order. +Qed. + +(** Monotonicity results, both ways *) + +Lemma pow_lt_mono_l_iff : forall a b c, 0<=a -> 0<=b -> 0<c -> + (a<b <-> a^c < b^c). +Proof. + intros a b c Ha Hb Hc. + split; intro LT. + - apply pow_lt_mono_l; try split; trivial. + - destruct (le_gt_cases b a) as [LE|GT]; trivial. + assert (b^c <= a^c) by (apply pow_le_mono_l; try split; order). + order. +Qed. + +Lemma pow_le_mono_l_iff : forall a b c, 0<=a -> 0<=b -> 0<c -> + (a<=b <-> a^c <= b^c). +Proof. + intros a b c Ha Hb Hc. + split; intro LE. + - apply pow_le_mono_l; try split; trivial. + - destruct (le_gt_cases a b) as [LE'|GT]; trivial. + assert (b^c < a^c) by (apply pow_lt_mono_l; try split; trivial). + order. +Qed. + +Lemma pow_lt_mono_r_iff : forall a b c, 1<a -> 0<=c -> + (b<c <-> a^b < a^c). +Proof. + intros a b c Ha Hc. + split; intro LT. + - now apply pow_lt_mono_r. + - destruct (le_gt_cases c b) as [LE|GT]; trivial. + assert (a^c <= a^b) by (apply pow_le_mono_r; order'). + order. +Qed. + +Lemma pow_le_mono_r_iff : forall a b c, 1<a -> 0<=c -> + (b<=c <-> a^b <= a^c). +Proof. + intros a b c Ha Hc. + split; intro LE. + - apply pow_le_mono_r; order'. + - destruct (le_gt_cases b c) as [LE'|GT]; trivial. + assert (a^c < a^b) by (apply pow_lt_mono_r; order'). + order. +Qed. + +(** For any a>1, the a^x function is above the identity function *) + +Lemma pow_gt_lin_r : forall a b, 1<a -> 0<=b -> b < a^b. +Proof. + intros a b Ha Hb. apply le_ind with (4:=Hb). - solve_proper. + - nzsimpl. order'. + - clear b Hb. intros b Hb IH. nzsimpl; trivial. + rewrite <- !le_succ_l in *. rewrite <- two_succ in Ha. + transitivity (2*(S b)). + + nzsimpl'. rewrite <- 2 succ_le_mono. + rewrite <- (add_0_l b) at 1. apply add_le_mono; order. + + apply mul_le_mono_nonneg; trivial. + * order'. + * now apply lt_le_incl, lt_succ_r. +Qed. + +(** Someday, we should say something about the full Newton formula. + In the meantime, we can at least provide some inequalities about + (a+b)^c. +*) + +Lemma pow_add_lower : forall a b c, 0<=a -> 0<=b -> 0<c -> + a^c + b^c <= (a+b)^c. +Proof. + intros a b c Ha Hb Hc. apply lt_ind with (4:=Hc). - solve_proper. + - nzsimpl; order. + - clear c Hc. intros c Hc IH. + assert (0<=c) by order'. + nzsimpl; trivial. + transitivity ((a+b)*(a^c + b^c)). + + rewrite mul_add_distr_r, !mul_add_distr_l. + apply add_le_mono. + * rewrite <- add_0_r at 1. apply add_le_mono_l. + apply mul_nonneg_nonneg; trivial. + apply pow_nonneg; trivial. + * rewrite <- add_0_l at 1. apply add_le_mono_r. + apply mul_nonneg_nonneg; trivial. + apply pow_nonneg; trivial. + + apply mul_le_mono_nonneg_l; trivial. + now apply add_nonneg_nonneg. +Qed. + +(** This upper bound can also be seen as a convexity proof for x^c : + image of (a+b)/2 is below the middle of the images of a and b +*) + +Lemma pow_add_upper : forall a b c, 0<=a -> 0<=b -> 0<c -> + (a+b)^c <= 2^(pred c) * (a^c + b^c). +Proof. + assert (aux : forall a b c, 0<=a<=b -> 0<c -> + (a + b) * (a ^ c + b ^ c) <= 2 * (a * a ^ c + b * b ^ c)). + (* begin *) + - intros a b c (Ha,H) Hc. + rewrite !mul_add_distr_l, !mul_add_distr_r. nzsimpl'. + rewrite <- !add_assoc. apply add_le_mono_l. + rewrite !add_assoc. apply add_le_mono_r. + destruct (le_exists_sub _ _ H) as (d & EQ & Hd). + rewrite EQ. + rewrite 2 mul_add_distr_r. + rewrite !add_assoc. apply add_le_mono_r. + rewrite add_comm. apply add_le_mono_l. + apply mul_le_mono_nonneg_l; trivial. + apply pow_le_mono_l; try split; order. + (* end *) + - intros a b c Ha Hb Hc. apply lt_ind with (4:=Hc). + solve_proper. + + nzsimpl; order. + + clear c Hc. intros c Hc IH. + assert (0<=c) by order. + nzsimpl; trivial. + transitivity ((a+b)*(2^(pred c) * (a^c + b^c))). + * apply mul_le_mono_nonneg_l; trivial. + now apply add_nonneg_nonneg. + * rewrite mul_assoc. rewrite (mul_comm (a+b)). + assert (EQ : S (P c) == c) by (apply lt_succ_pred with 0; order'). + assert (LE : 0 <= P c) by (now rewrite succ_le_mono, EQ, le_succ_l). + assert (EQ' : 2^c == 2^(P c) * 2) by (rewrite <- EQ at 1; nzsimpl'; order). + rewrite EQ', <- !mul_assoc. + apply mul_le_mono_nonneg_l. + -- apply pow_nonneg; order'. + -- destruct (le_gt_cases a b). + ++ apply aux; try split; order'. + ++ rewrite (add_comm a), (add_comm (a^c)), (add_comm (a*a^c)). + apply aux; try split; order'. +Qed. + +End NZPowProp. diff --git a/theories/Numbers/NatInt/NZProperties.v b/theories/Numbers/NatInt/NZProperties.v new file mode 100644 index 0000000000..fbcf43e880 --- /dev/null +++ b/theories/Numbers/NatInt/NZProperties.v @@ -0,0 +1,20 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Export NZAxioms NZMulOrder. + +(** This functor summarizes all known facts about NZ. + For the moment it is only an alias to [NZMulOrderProp], which + subsumes all others. +*) + +Module Type NZProp := NZMulOrderProp. diff --git a/theories/Numbers/NatInt/NZSqrt.v b/theories/Numbers/NatInt/NZSqrt.v new file mode 100644 index 0000000000..85ed71b8a4 --- /dev/null +++ b/theories/Numbers/NatInt/NZSqrt.v @@ -0,0 +1,735 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Square Root Function *) + +Require Import NZAxioms NZMulOrder. + +(** Interface of a sqrt function, then its specification on naturals *) + +Module Type Sqrt (Import A : Typ). + Parameter Inline sqrt : t -> t. +End Sqrt. + +Module Type SqrtNotation (A : Typ)(Import B : Sqrt A). + Notation "√ x" := (sqrt x) (at level 6). +End SqrtNotation. + +Module Type Sqrt' (A : Typ) := Sqrt A <+ SqrtNotation A. + +Module Type NZSqrtSpec (Import A : NZOrdAxiomsSig')(Import B : Sqrt' A). + Axiom sqrt_spec : forall a, 0<=a -> √a * √a <= a < S (√a) * S (√a). + Axiom sqrt_neg : forall a, a<0 -> √a == 0. +End NZSqrtSpec. + +Module Type NZSqrt (A : NZOrdAxiomsSig) := Sqrt A <+ NZSqrtSpec A. +Module Type NZSqrt' (A : NZOrdAxiomsSig) := Sqrt' A <+ NZSqrtSpec A. + +(** Derived properties of power *) + +Module Type NZSqrtProp + (Import A : NZOrdAxiomsSig') + (Import B : NZSqrt' A) + (Import C : NZMulOrderProp A). + +Local Notation "a ²" := (a*a) (at level 5, no associativity, format "a ²"). + +(** First, sqrt is non-negative *) + +Lemma sqrt_spec_nonneg : forall b, + b² < (S b)² -> 0 <= b. +Proof. + intros b LT. + destruct (le_gt_cases 0 b) as [Hb|Hb]; trivial. exfalso. + assert ((S b)² < b²). + - rewrite mul_succ_l, <- (add_0_r b²). + apply add_lt_le_mono. + + apply mul_lt_mono_neg_l; trivial. apply lt_succ_diag_r. + + now apply le_succ_l. + - order. +Qed. + +Lemma sqrt_nonneg : forall a, 0<=√a. +Proof. + intros. destruct (lt_ge_cases a 0) as [Ha|Ha]. + - now rewrite (sqrt_neg _ Ha). + - apply sqrt_spec_nonneg. destruct (sqrt_spec a Ha). order. +Qed. + +(** The spec of sqrt indeed determines it *) + +Lemma sqrt_unique : forall a b, b² <= a < (S b)² -> √a == b. +Proof. + intros a b (LEb,LTb). + assert (Ha : 0<=a) by (transitivity (b²); trivial using square_nonneg). + assert (Hb : 0<=b) by (apply sqrt_spec_nonneg; order). + assert (Ha': 0<=√a) by now apply sqrt_nonneg. + destruct (sqrt_spec a Ha) as (LEa,LTa). + assert (b <= √a). + - apply lt_succ_r, square_lt_simpl_nonneg; [|order]. + now apply lt_le_incl, lt_succ_r. + - assert (√a <= b). + + apply lt_succ_r, square_lt_simpl_nonneg; [|order]. + now apply lt_le_incl, lt_succ_r. + + order. +Qed. + +(** Hence sqrt is a morphism *) + +Instance sqrt_wd : Proper (eq==>eq) sqrt. +Proof. + intros x x' Hx. + destruct (lt_ge_cases x 0) as [H|H]. + - rewrite 2 sqrt_neg; trivial. + reflexivity. + + now rewrite <- Hx. + - apply sqrt_unique. rewrite Hx in *. now apply sqrt_spec. +Qed. + +(** An alternate specification *) + +Lemma sqrt_spec_alt : forall a, 0<=a -> exists r, + a == (√a)² + r /\ 0 <= r <= 2*√a. +Proof. + intros a Ha. + destruct (sqrt_spec _ Ha) as (LE,LT). + destruct (le_exists_sub _ _ LE) as (r & Hr & Hr'). + exists r. + split. - now rewrite add_comm. + - split. + trivial. + + apply (add_le_mono_r _ _ (√a)²). + rewrite <- Hr, add_comm. + generalize LT. nzsimpl'. now rewrite lt_succ_r, add_assoc. +Qed. + +Lemma sqrt_unique' : forall a b c, 0<=c<=2*b -> + a == b² + c -> √a == b. +Proof. + intros a b c (Hc,H) EQ. + apply sqrt_unique. + rewrite EQ. + split. + - rewrite <- add_0_r at 1. now apply add_le_mono_l. + - nzsimpl. apply lt_succ_r. + rewrite <- add_assoc. apply add_le_mono_l. + generalize H; now nzsimpl'. +Qed. + +(** Sqrt is exact on squares *) + +Lemma sqrt_square : forall a, 0<=a -> √(a²) == a. +Proof. + intros a Ha. + apply sqrt_unique' with 0. + - split. + order. + apply mul_nonneg_nonneg; order'. - now nzsimpl. +Qed. + +(** Sqrt and predecessors of squares *) + +Lemma sqrt_pred_square : forall a, 0<a -> √(P a²) == P a. +Proof. + intros a Ha. + apply sqrt_unique. + assert (EQ := lt_succ_pred 0 a Ha). + rewrite EQ. split. + - apply lt_succ_r. + rewrite (lt_succ_pred 0). + + assert (0 <= P a) by (now rewrite <- lt_succ_r, EQ). + assert (P a < a) by (now rewrite <- le_succ_l, EQ). + apply mul_lt_mono_nonneg; trivial. + + now apply mul_pos_pos. + - apply le_succ_l. + rewrite (lt_succ_pred 0). + reflexivity. + now apply mul_pos_pos. +Qed. + +(** Sqrt is a monotone function (but not a strict one) *) + +Lemma sqrt_le_mono : forall a b, a <= b -> √a <= √b. +Proof. + intros a b Hab. + destruct (lt_ge_cases a 0) as [Ha|Ha]. + - rewrite (sqrt_neg _ Ha). apply sqrt_nonneg. + - assert (Hb : 0 <= b) by order. + destruct (sqrt_spec a Ha) as (LE,_). + destruct (sqrt_spec b Hb) as (_,LT). + apply lt_succ_r. + apply square_lt_simpl_nonneg; try order. + now apply lt_le_incl, lt_succ_r, sqrt_nonneg. +Qed. + +(** No reverse result for <=, consider for instance √2 <= √1 *) + +Lemma sqrt_lt_cancel : forall a b, √a < √b -> a < b. +Proof. + intros a b H. + destruct (lt_ge_cases b 0) as [Hb|Hb]. + - rewrite (sqrt_neg b Hb) in H; generalize (sqrt_nonneg a); order. + - destruct (lt_ge_cases a 0) as [Ha|Ha]; [order|]. + destruct (sqrt_spec a Ha) as (_,LT). + destruct (sqrt_spec b Hb) as (LE,_). + apply le_succ_l in H. + assert ((S (√a))² <= (√b)²). + + apply mul_le_mono_nonneg; trivial. + * now apply lt_le_incl, lt_succ_r, sqrt_nonneg. + * now apply lt_le_incl, lt_succ_r, sqrt_nonneg. + + order. +Qed. + +(** When left side is a square, we have an equivalence for <= *) + +Lemma sqrt_le_square : forall a b, 0<=a -> 0<=b -> (b²<=a <-> b <= √a). +Proof. + intros a b Ha Hb. split; intros H. + - rewrite <- (sqrt_square b); trivial. + now apply sqrt_le_mono. + - destruct (sqrt_spec a Ha) as (LE,LT). + transitivity (√a)²; trivial. + now apply mul_le_mono_nonneg. +Qed. + +(** When right side is a square, we have an equivalence for < *) + +Lemma sqrt_lt_square : forall a b, 0<=a -> 0<=b -> (a<b² <-> √a < b). +Proof. + intros a b Ha Hb. split; intros H. + - destruct (sqrt_spec a Ha) as (LE,_). + apply square_lt_simpl_nonneg; try order. + - rewrite <- (sqrt_square b Hb) in H. + now apply sqrt_lt_cancel. +Qed. + +(** Sqrt and basic constants *) + +Lemma sqrt_0 : √0 == 0. +Proof. + rewrite <- (mul_0_l 0) at 1. now apply sqrt_square. +Qed. + +Lemma sqrt_1 : √1 == 1. +Proof. + rewrite <- (mul_1_l 1) at 1. apply sqrt_square. order'. +Qed. + +Lemma sqrt_2 : √2 == 1. +Proof. + apply sqrt_unique' with 1. - nzsimpl; split; order'. - now nzsimpl'. +Qed. + +Lemma sqrt_pos : forall a, 0 < √a <-> 0 < a. +Proof. + intros a. split; intros Ha. - apply sqrt_lt_cancel. now rewrite sqrt_0. + - rewrite <- le_succ_l, <- one_succ, <- sqrt_1. apply sqrt_le_mono. + now rewrite one_succ, le_succ_l. +Qed. + +Lemma sqrt_lt_lin : forall a, 1<a -> √a<a. +Proof. + intros a Ha. rewrite <- sqrt_lt_square; try order'. + rewrite <- (mul_1_r a) at 1. + rewrite <- mul_lt_mono_pos_l; order'. +Qed. + +Lemma sqrt_le_lin : forall a, 0<=a -> √a<=a. +Proof. + intros a Ha. + destruct (le_gt_cases a 0) as [H|H]. + - setoid_replace a with 0 by order. now rewrite sqrt_0. + - destruct (le_gt_cases a 1) as [H'|H']. + + rewrite <- le_succ_l, <- one_succ in H. + setoid_replace a with 1 by order. now rewrite sqrt_1. + + now apply lt_le_incl, sqrt_lt_lin. +Qed. + +(** Sqrt and multiplication. *) + +(** Due to rounding error, we don't have the usual √(a*b) = √a*√b + but only lower and upper bounds. *) + +Lemma sqrt_mul_below : forall a b, √a * √b <= √(a*b). +Proof. + intros a b. + destruct (lt_ge_cases a 0) as [Ha|Ha]. + - rewrite (sqrt_neg a Ha). nzsimpl. apply sqrt_nonneg. + - destruct (lt_ge_cases b 0) as [Hb|Hb]. + + rewrite (sqrt_neg b Hb). nzsimpl. apply sqrt_nonneg. + + assert (Ha':=sqrt_nonneg a). + assert (Hb':=sqrt_nonneg b). + apply sqrt_le_square; try now apply mul_nonneg_nonneg. + rewrite mul_shuffle1. + apply mul_le_mono_nonneg; try now apply mul_nonneg_nonneg. + * now apply sqrt_spec. + * now apply sqrt_spec. +Qed. + +Lemma sqrt_mul_above : forall a b, 0<=a -> 0<=b -> √(a*b) < S (√a) * S (√b). +Proof. + intros a b Ha Hb. + apply sqrt_lt_square. + - now apply mul_nonneg_nonneg. + - apply mul_nonneg_nonneg. + + now apply lt_le_incl, lt_succ_r, sqrt_nonneg. + + now apply lt_le_incl, lt_succ_r, sqrt_nonneg. + - rewrite mul_shuffle1. + apply mul_lt_mono_nonneg; trivial; now apply sqrt_spec. +Qed. + +(** And we can't find better approximations in general. + - The lower bound is exact for squares + - Concerning the upper bound, for any c>0, take a=b=c²-1, + then √(a*b) = c² -1 while S √a = S √b = c +*) + +(** Sqrt and successor : + - the sqrt function climbs by at most 1 at a time + - otherwise it stays at the same value + - the +1 steps occur for squares +*) + +Lemma sqrt_succ_le : forall a, 0<=a -> √(S a) <= S (√a). +Proof. + intros a Ha. + apply lt_succ_r. + apply sqrt_lt_square. + - now apply le_le_succ_r. + - apply le_le_succ_r, le_le_succ_r, sqrt_nonneg. + - rewrite <- (add_1_l (S (√a))). + apply lt_le_trans with (1²+(S (√a))²). + + rewrite mul_1_l, add_1_l, <- succ_lt_mono. + now apply sqrt_spec. + + apply add_square_le. * order'. * apply le_le_succ_r, sqrt_nonneg. +Qed. + +Lemma sqrt_succ_or : forall a, 0<=a -> √(S a) == S (√a) \/ √(S a) == √a. +Proof. + intros a Ha. + destruct (le_gt_cases (√(S a)) (√a)) as [H|H]. + - right. generalize (sqrt_le_mono _ _ (le_succ_diag_r a)); order. + - left. apply le_succ_l in H. generalize (sqrt_succ_le a Ha); order. +Qed. + +Lemma sqrt_eq_succ_iff_square : forall a, 0<=a -> + (√(S a) == S (√a) <-> exists b, 0<b /\ S a == b²). +Proof. + intros a Ha. split. + - intros EQ. exists (S (√a)). + split. + apply lt_succ_r, sqrt_nonneg. + + generalize (proj2 (sqrt_spec a Ha)). rewrite <- le_succ_l. + assert (Ha' : 0 <= S a) by now apply le_le_succ_r. + generalize (proj1 (sqrt_spec (S a) Ha')). rewrite EQ; order. + - intros (b & Hb & H). + rewrite H. rewrite sqrt_square; try order. + symmetry. + rewrite <- (lt_succ_pred 0 b Hb). f_equiv. + rewrite <- (lt_succ_pred 0 b²) in H. + apply succ_inj in H. + now rewrite H, sqrt_pred_square. + + now apply mul_pos_pos. +Qed. + +(** Sqrt and addition *) + +Lemma sqrt_add_le : forall a b, √(a+b) <= √a + √b. +Proof. + assert (AUX : forall a b, a<0 -> √(a+b) <= √a + √b). + - intros a b Ha. rewrite (sqrt_neg a Ha). nzsimpl. + apply sqrt_le_mono. + rewrite <- (add_0_l b) at 2. + apply add_le_mono_r; order. + - intros a b. + destruct (lt_ge_cases a 0) as [Ha|Ha]. + now apply AUX. + + destruct (lt_ge_cases b 0) as [Hb|Hb]. + * rewrite (add_comm a), (add_comm (√a)); now apply AUX. + * assert (Ha':=sqrt_nonneg a). + assert (Hb':=sqrt_nonneg b). + rewrite <- lt_succ_r. + apply sqrt_lt_square. + -- now apply add_nonneg_nonneg. + -- now apply lt_le_incl, lt_succ_r, add_nonneg_nonneg. + -- destruct (sqrt_spec a Ha) as (_,LTa). + destruct (sqrt_spec b Hb) as (_,LTb). + revert LTa LTb. nzsimpl. rewrite 3 lt_succ_r. + intros LTa LTb. + assert (H:=add_le_mono _ _ _ _ LTa LTb). + etransitivity; [eexact H|]. clear LTa LTb H. + rewrite <- (add_assoc _ (√a) (√a)). + rewrite <- (add_assoc _ (√b) (√b)). + rewrite add_shuffle1. + rewrite <- (add_assoc _ (√a + √b)). + rewrite (add_shuffle1 (√a) (√b)). + apply add_le_mono_r. + now apply add_square_le. +Qed. + +(** convexity inequality for sqrt: sqrt of middle is above middle + of square roots. *) + +Lemma add_sqrt_le : forall a b, 0<=a -> 0<=b -> √a + √b <= √(2*(a+b)). +Proof. + intros a b Ha Hb. + assert (Ha':=sqrt_nonneg a). + assert (Hb':=sqrt_nonneg b). + apply sqrt_le_square. + - apply mul_nonneg_nonneg. + order'. + now apply add_nonneg_nonneg. + - now apply add_nonneg_nonneg. + - transitivity (2*((√a)² + (√b)²)). + + now apply square_add_le. + + apply mul_le_mono_nonneg_l. * order'. + * apply add_le_mono; now apply sqrt_spec. +Qed. + +End NZSqrtProp. + +Module Type NZSqrtUpProp + (Import A : NZDecOrdAxiomsSig') + (Import B : NZSqrt' A) + (Import C : NZMulOrderProp A) + (Import D : NZSqrtProp A B C). + +(** * [sqrt_up] : a square root that rounds up instead of down *) + +Local Notation "a ²" := (a*a) (at level 5, no associativity, format "a ²"). + +(** For once, we define instead of axiomatizing, thanks to sqrt *) + +Definition sqrt_up a := + match compare 0 a with + | Lt => S √(P a) + | _ => 0 + end. + +Local Notation "√° a" := (sqrt_up a) (at level 6, no associativity). + +Lemma sqrt_up_eqn0 : forall a, a<=0 -> √°a == 0. +Proof. + intros a Ha. unfold sqrt_up. case compare_spec; try order. +Qed. + +Lemma sqrt_up_eqn : forall a, 0<a -> √°a == S √(P a). +Proof. + intros a Ha. unfold sqrt_up. case compare_spec; try order. +Qed. + +Lemma sqrt_up_spec : forall a, 0<a -> (P √°a)² < a <= (√°a)². +Proof. + intros a Ha. + rewrite sqrt_up_eqn, pred_succ; trivial. + assert (Ha' := lt_succ_pred 0 a Ha). + rewrite <- Ha' at 3 4. + rewrite le_succ_l, lt_succ_r. + apply sqrt_spec. + now rewrite <- lt_succ_r, Ha'. +Qed. + +(** First, [sqrt_up] is non-negative *) + +Lemma sqrt_up_nonneg : forall a, 0<=√°a. +Proof. + intros. destruct (le_gt_cases a 0) as [Ha|Ha]. + - now rewrite sqrt_up_eqn0. + - rewrite sqrt_up_eqn; trivial. apply le_le_succ_r, sqrt_nonneg. +Qed. + +(** [sqrt_up] is a morphism *) + +Instance sqrt_up_wd : Proper (eq==>eq) sqrt_up. +Proof. + assert (Proper (eq==>eq==>Logic.eq) compare). + - intros x x' Hx y y' Hy. do 2 case compare_spec; trivial; order. + - intros x x' Hx; unfold sqrt_up; rewrite Hx; case compare; now rewrite ?Hx. +Qed. + +(** The spec of [sqrt_up] indeed determines it *) + +Lemma sqrt_up_unique : forall a b, 0<b -> (P b)² < a <= b² -> √°a == b. +Proof. + intros a b Hb (LEb,LTb). + assert (Ha : 0<a) + by (apply le_lt_trans with (P b)²; trivial using square_nonneg). + rewrite sqrt_up_eqn; trivial. + assert (Hb' := lt_succ_pred 0 b Hb). + rewrite <- Hb'. f_equiv. apply sqrt_unique. + rewrite <- le_succ_l, <- lt_succ_r, Hb'. + rewrite (lt_succ_pred 0 a Ha). now split. +Qed. + +(** [sqrt_up] is exact on squares *) + +Lemma sqrt_up_square : forall a, 0<=a -> √°(a²) == a. +Proof. + intros a Ha. + le_elim Ha. + - rewrite sqrt_up_eqn by (now apply mul_pos_pos). + rewrite sqrt_pred_square; trivial. apply (lt_succ_pred 0); trivial. + - rewrite sqrt_up_eqn0; trivial. rewrite <- Ha. now nzsimpl. +Qed. + +(** [sqrt_up] and successors of squares *) + +Lemma sqrt_up_succ_square : forall a, 0<=a -> √°(S a²) == S a. +Proof. + intros a Ha. + rewrite sqrt_up_eqn by (now apply lt_succ_r, mul_nonneg_nonneg). + now rewrite pred_succ, sqrt_square. +Qed. + +(** Basic constants *) + +Lemma sqrt_up_0 : √°0 == 0. +Proof. + rewrite <- (mul_0_l 0) at 1. now apply sqrt_up_square. +Qed. + +Lemma sqrt_up_1 : √°1 == 1. +Proof. + rewrite <- (mul_1_l 1) at 1. apply sqrt_up_square. order'. +Qed. + +Lemma sqrt_up_2 : √°2 == 2. +Proof. + rewrite sqrt_up_eqn by order'. + now rewrite two_succ, pred_succ, sqrt_1. +Qed. + +(** Links between sqrt and [sqrt_up] *) + +Lemma le_sqrt_sqrt_up : forall a, √a <= √°a. +Proof. + intros a. unfold sqrt_up. case compare_spec; intros H. + - rewrite <- H, sqrt_0. order. + - rewrite <- (lt_succ_pred 0 a H) at 1. apply sqrt_succ_le. + apply lt_succ_r. now rewrite (lt_succ_pred 0 a H). + - now rewrite sqrt_neg. +Qed. + +Lemma le_sqrt_up_succ_sqrt : forall a, √°a <= S (√a). +Proof. + intros a. unfold sqrt_up. + case compare_spec; intros H; try apply le_le_succ_r, sqrt_nonneg. + rewrite <- succ_le_mono. apply sqrt_le_mono. + rewrite <- (lt_succ_pred 0 a H) at 2. apply le_succ_diag_r. +Qed. + +Lemma sqrt_sqrt_up_spec : forall a, 0<=a -> (√a)² <= a <= (√°a)². +Proof. + intros a H. split. + - now apply sqrt_spec. + - le_elim H. + + now apply sqrt_up_spec. + + now rewrite <-H, sqrt_up_0, mul_0_l. +Qed. + +Lemma sqrt_sqrt_up_exact : + forall a, 0<=a -> (√a == √°a <-> exists b, 0<=b /\ a == b²). +Proof. + intros a Ha. + split. - intros. exists √a. + split. + apply sqrt_nonneg. + + generalize (sqrt_sqrt_up_spec a Ha). rewrite <-H. destruct 1; order. + - intros (b & Hb & Hb'). rewrite Hb'. + now rewrite sqrt_square, sqrt_up_square. +Qed. + +(** [sqrt_up] is a monotone function (but not a strict one) *) + +Lemma sqrt_up_le_mono : forall a b, a <= b -> √°a <= √°b. +Proof. + intros a b H. + destruct (le_gt_cases a 0) as [Ha|Ha]. + - rewrite (sqrt_up_eqn0 _ Ha). apply sqrt_up_nonneg. + - rewrite 2 sqrt_up_eqn by order. rewrite <- succ_le_mono. + apply sqrt_le_mono, succ_le_mono. rewrite 2 (lt_succ_pred 0); order. +Qed. + +(** No reverse result for <=, consider for instance √°3 <= √°2 *) + +Lemma sqrt_up_lt_cancel : forall a b, √°a < √°b -> a < b. +Proof. + intros a b H. + destruct (le_gt_cases b 0) as [Hb|Hb]. + - rewrite (sqrt_up_eqn0 _ Hb) in H; generalize (sqrt_up_nonneg a); order. + - destruct (le_gt_cases a 0) as [Ha|Ha]; [order|]. + rewrite <- (lt_succ_pred 0 a Ha), <- (lt_succ_pred 0 b Hb), <- succ_lt_mono. + apply sqrt_lt_cancel, succ_lt_mono. now rewrite <- 2 sqrt_up_eqn. +Qed. + +(** When left side is a square, we have an equivalence for < *) + +Lemma sqrt_up_lt_square : forall a b, 0<=a -> 0<=b -> (b² < a <-> b < √°a). +Proof. + intros a b Ha Hb. split; intros H. + - destruct (sqrt_up_spec a) as (LE,LT). + + apply le_lt_trans with b²; trivial using square_nonneg. + + apply square_lt_simpl_nonneg; try order. apply sqrt_up_nonneg. + - apply sqrt_up_lt_cancel. now rewrite sqrt_up_square. +Qed. + +(** When right side is a square, we have an equivalence for <= *) + +Lemma sqrt_up_le_square : forall a b, 0<=a -> 0<=b -> (a <= b² <-> √°a <= b). +Proof. + intros a b Ha Hb. split; intros H. + - rewrite <- (sqrt_up_square b Hb). + now apply sqrt_up_le_mono. + - apply square_le_mono_nonneg in H; [|now apply sqrt_up_nonneg]. + transitivity (√°a)²; trivial. now apply sqrt_sqrt_up_spec. +Qed. + +Lemma sqrt_up_pos : forall a, 0 < √°a <-> 0 < a. +Proof. + intros a. split; intros Ha. - apply sqrt_up_lt_cancel. now rewrite sqrt_up_0. + - rewrite <- le_succ_l, <- one_succ, <- sqrt_up_1. apply sqrt_up_le_mono. + now rewrite one_succ, le_succ_l. +Qed. + +Lemma sqrt_up_lt_lin : forall a, 2<a -> √°a < a. +Proof. + intros a Ha. + rewrite sqrt_up_eqn by order'. + assert (Ha' := lt_succ_pred 2 a Ha). + rewrite <- Ha' at 2. rewrite <- succ_lt_mono. + apply sqrt_lt_lin. rewrite succ_lt_mono. now rewrite Ha', <- two_succ. +Qed. + +Lemma sqrt_up_le_lin : forall a, 0<=a -> √°a<=a. +Proof. + intros a Ha. + le_elim Ha. + - rewrite sqrt_up_eqn; trivial. apply le_succ_l. + apply le_lt_trans with (P a). + apply sqrt_le_lin. + now rewrite <- lt_succ_r, (lt_succ_pred 0). + + rewrite <- (lt_succ_pred 0 a) at 2; trivial. apply lt_succ_diag_r. + - now rewrite <- Ha, sqrt_up_0. +Qed. + +(** [sqrt_up] and multiplication. *) + +(** Due to rounding error, we don't have the usual [√(a*b) = √a*√b] + but only lower and upper bounds. *) + +Lemma sqrt_up_mul_above : forall a b, 0<=a -> 0<=b -> √°(a*b) <= √°a * √°b. +Proof. + intros a b Ha Hb. + apply sqrt_up_le_square. + - now apply mul_nonneg_nonneg. + - apply mul_nonneg_nonneg; apply sqrt_up_nonneg. + - rewrite mul_shuffle1. + apply mul_le_mono_nonneg; trivial; now apply sqrt_sqrt_up_spec. +Qed. + +Lemma sqrt_up_mul_below : forall a b, 0<a -> 0<b -> (P √°a)*(P √°b) < √°(a*b). +Proof. + intros a b Ha Hb. + apply sqrt_up_lt_square. + - apply mul_nonneg_nonneg; order. + - apply mul_nonneg_nonneg; apply lt_succ_r. + + rewrite (lt_succ_pred 0); now rewrite sqrt_up_pos. + + rewrite (lt_succ_pred 0); now rewrite sqrt_up_pos. + - rewrite mul_shuffle1. + apply mul_lt_mono_nonneg; trivial using square_nonneg; + now apply sqrt_up_spec. +Qed. + +(** And we can't find better approximations in general. + - The upper bound is exact for squares + - Concerning the lower bound, for any c>0, take [a=b=c²+1], + then [√°(a*b) = c²+1] while [P √°a = P √°b = c] +*) + +(** [sqrt_up] and successor : + - the [sqrt_up] function climbs by at most 1 at a time + - otherwise it stays at the same value + - the +1 steps occur after squares +*) + +Lemma sqrt_up_succ_le : forall a, 0<=a -> √°(S a) <= S (√°a). +Proof. + intros a Ha. + apply sqrt_up_le_square. + - now apply le_le_succ_r. + - apply le_le_succ_r, sqrt_up_nonneg. + - rewrite <- (add_1_l (√°a)). + apply le_trans with (1²+(√°a)²). + + rewrite mul_1_l, add_1_l, <- succ_le_mono. + now apply sqrt_sqrt_up_spec. + + apply add_square_le. * order'. * apply sqrt_up_nonneg. +Qed. + +Lemma sqrt_up_succ_or : forall a, 0<=a -> √°(S a) == S (√°a) \/ √°(S a) == √°a. +Proof. + intros a Ha. + destruct (le_gt_cases (√°(S a)) (√°a)) as [H|H]. + - right. generalize (sqrt_up_le_mono _ _ (le_succ_diag_r a)); order. + - left. apply le_succ_l in H. generalize (sqrt_up_succ_le a Ha); order. +Qed. + +Lemma sqrt_up_eq_succ_iff_square : forall a, 0<=a -> + (√°(S a) == S (√°a) <-> exists b, 0<=b /\ a == b²). +Proof. + intros a Ha. split. + - intros EQ. + le_elim Ha. + + exists (√°a). split. * apply sqrt_up_nonneg. + * generalize (proj2 (sqrt_up_spec a Ha)). + assert (Ha' : 0 < S a) by (apply lt_succ_r; order'). + generalize (proj1 (sqrt_up_spec (S a) Ha')). + rewrite EQ, pred_succ, lt_succ_r. order. + + exists 0. nzsimpl. now split. + - intros (b & Hb & H). + now rewrite H, sqrt_up_succ_square, sqrt_up_square. +Qed. + +(** [sqrt_up] and addition *) + +Lemma sqrt_up_add_le : forall a b, √°(a+b) <= √°a + √°b. +Proof. + assert (AUX : forall a b, a<=0 -> √°(a+b) <= √°a + √°b). + - intros a b Ha. rewrite (sqrt_up_eqn0 a Ha). nzsimpl. + apply sqrt_up_le_mono. + rewrite <- (add_0_l b) at 2. + apply add_le_mono_r; order. + - intros a b. + destruct (le_gt_cases a 0) as [Ha|Ha]. + now apply AUX. + + destruct (le_gt_cases b 0) as [Hb|Hb]. + * rewrite (add_comm a), (add_comm (√°a)); now apply AUX. + * rewrite 2 sqrt_up_eqn; trivial. + -- nzsimpl. rewrite <- succ_le_mono. + transitivity (√(P a) + √b). + ++ rewrite <- (lt_succ_pred 0 a Ha) at 1. nzsimpl. apply sqrt_add_le. + ++ apply add_le_mono_l. + apply le_sqrt_sqrt_up. + -- now apply add_pos_pos. +Qed. + +(** Convexity-like inequality for [sqrt_up]: [sqrt_up] of middle is above middle + of square roots. We cannot say more, for instance take a=b=2, then + 2+2 <= S 3 *) + +Lemma add_sqrt_up_le : forall a b, 0<=a -> 0<=b -> √°a + √°b <= S √°(2*(a+b)). +Proof. + intros a b Ha Hb. + le_elim Ha;[le_elim Hb|]. + - rewrite 3 sqrt_up_eqn; trivial. + + nzsimpl. rewrite <- 2 succ_le_mono. + etransitivity; [eapply add_sqrt_le|]. + * apply lt_succ_r. now rewrite (lt_succ_pred 0 a Ha). + * apply lt_succ_r. now rewrite (lt_succ_pred 0 b Hb). + * apply sqrt_le_mono. + apply lt_succ_r. rewrite (lt_succ_pred 0). + -- apply mul_lt_mono_pos_l. ++ order'. + ++ apply add_lt_mono. + ** apply le_succ_l. now rewrite (lt_succ_pred 0). + ** apply le_succ_l. now rewrite (lt_succ_pred 0). + -- apply mul_pos_pos. ++ order'. ++ now apply add_pos_pos. + + apply mul_pos_pos. * order'. * now apply add_pos_pos. + - rewrite <- Hb, sqrt_up_0. nzsimpl. apply le_le_succ_r, sqrt_up_le_mono. + rewrite <- (mul_1_l a) at 1. apply mul_le_mono_nonneg_r; order'. + - rewrite <- Ha, sqrt_up_0. nzsimpl. apply le_le_succ_r, sqrt_up_le_mono. + rewrite <- (mul_1_l b) at 1. apply mul_le_mono_nonneg_r; order'. +Qed. + +End NZSqrtUpProp. diff --git a/theories/Numbers/Natural/Abstract/NAdd.v b/theories/Numbers/Natural/Abstract/NAdd.v new file mode 100644 index 0000000000..dc5f8e5372 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NAdd.v @@ -0,0 +1,81 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Export NBase. + +Module NAddProp (Import N : NAxiomsMiniSig'). +Include NBaseProp N. + +(** For theorems about [add] that are both valid for [N] and [Z], see [NZAdd] *) +(** Now comes theorems valid for natural numbers but not for Z *) + +Theorem eq_add_0 : forall n m, n + m == 0 <-> n == 0 /\ m == 0. +Proof. +intros n m; induct n. +nzsimpl; intuition. +intros n IH. nzsimpl. +setoid_replace (S (n + m) == 0) with False by + (apply neg_false; apply neq_succ_0). +setoid_replace (S n == 0) with False by + (apply neg_false; apply neq_succ_0). tauto. +Qed. + +Theorem eq_add_succ : + forall n m, (exists p, n + m == S p) <-> + (exists n', n == S n') \/ (exists m', m == S m'). +Proof. +intros n m; cases n. +split; intro H. +destruct H as [p H]. rewrite add_0_l in H; right; now exists p. +destruct H as [[n' H] | [m' H]]. +symmetry in H; false_hyp H neq_succ_0. +exists m'; now rewrite add_0_l. +intro n; split; intro H. +left; now exists n. +exists (n + m); now rewrite add_succ_l. +Qed. + +Theorem eq_add_1 : forall n m, + n + m == 1 -> n == 1 /\ m == 0 \/ n == 0 /\ m == 1. +Proof. +intros n m. rewrite one_succ. intro H. +assert (H1 : exists p, n + m == S p) by now exists 0. +apply eq_add_succ in H1. destruct H1 as [[n' H1] | [m' H1]]. +left. rewrite H1 in H; rewrite add_succ_l in H; apply succ_inj in H. +apply eq_add_0 in H. destruct H as [H2 H3]; rewrite H2 in H1; now split. +right. rewrite H1 in H; rewrite add_succ_r in H; apply succ_inj in H. +apply eq_add_0 in H. destruct H as [H2 H3]; rewrite H3 in H1; now split. +Qed. + +Theorem succ_add_discr : forall n m, m ~= S (n + m). +Proof. +intro n; induct m. +apply neq_sym. apply neq_succ_0. +intros m IH H. apply succ_inj in H. rewrite add_succ_r in H. +unfold not in IH; now apply IH. +Qed. + +Theorem add_pred_l : forall n m, n ~= 0 -> P n + m == P (n + m). +Proof. +intros n m; cases n. +intro H; now elim H. +intros n IH; rewrite add_succ_l; now do 2 rewrite pred_succ. +Qed. + +Theorem add_pred_r : forall n m, m ~= 0 -> n + P m == P (n + m). +Proof. +intros n m H; rewrite (add_comm n (P m)); +rewrite (add_comm n m); now apply add_pred_l. +Qed. + +End NAddProp. + diff --git a/theories/Numbers/Natural/Abstract/NAddOrder.v b/theories/Numbers/Natural/Abstract/NAddOrder.v new file mode 100644 index 0000000000..2da3f0bfcb --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NAddOrder.v @@ -0,0 +1,48 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Export NOrder. + +Module NAddOrderProp (Import N : NAxiomsMiniSig'). +Include NOrderProp N. + +(** Theorems true for natural numbers, not for integers *) + +Theorem le_add_r : forall n m, n <= n + m. +Proof. +intro n; induct m. +rewrite add_0_r; now apply eq_le_incl. +intros m IH. rewrite add_succ_r; now apply le_le_succ_r. +Qed. + +Theorem lt_lt_add_r : forall n m p, n < m -> n < m + p. +Proof. +intros n m p H; rewrite <- (add_0_r n). +apply add_lt_le_mono; [assumption | apply le_0_l]. +Qed. + +Theorem lt_lt_add_l : forall n m p, n < m -> n < p + m. +Proof. +intros n m p; rewrite add_comm; apply lt_lt_add_r. +Qed. + +Theorem add_pos_l : forall n m, 0 < n -> 0 < n + m. +Proof. +intros; apply add_pos_nonneg. assumption. apply le_0_l. +Qed. + +Theorem add_pos_r : forall n m, 0 < m -> 0 < n + m. +Proof. +intros; apply add_nonneg_pos. apply le_0_l. assumption. +Qed. + +End NAddOrderProp. diff --git a/theories/Numbers/Natural/Abstract/NAxioms.v b/theories/Numbers/Natural/Abstract/NAxioms.v new file mode 100644 index 0000000000..dd09ac5f3e --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NAxioms.v @@ -0,0 +1,69 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Export Bool NZAxioms NZParity NZPow NZSqrt NZLog NZDiv NZGcd NZBits. + +(** From [NZ], we obtain natural numbers just by stating that [pred 0] == 0 *) + +Module Type NAxiom (Import NZ : NZDomainSig'). + Axiom pred_0 : P 0 == 0. +End NAxiom. + +Module Type NAxiomsMiniSig := NZOrdAxiomsSig <+ NAxiom. +Module Type NAxiomsMiniSig' := NZOrdAxiomsSig' <+ NAxiom. + +(** Let's now add some more functions and their specification *) + +(** Division Function : we reuse NZDiv.DivMod and NZDiv.NZDivCommon, + and add to that a N-specific constraint. *) + +Module Type NDivSpecific (Import N : NAxiomsMiniSig')(Import DM : DivMod' N). + Axiom mod_upper_bound : forall a b, b ~= 0 -> a mod b < b. +End NDivSpecific. + +(** For all other functions, the NZ axiomatizations are enough. *) + +(** We now group everything together. *) + +Module Type NAxiomsSig := NAxiomsMiniSig <+ OrderFunctions + <+ NZParity.NZParity <+ NZPow.NZPow <+ NZSqrt.NZSqrt <+ NZLog.NZLog2 + <+ NZGcd.NZGcd <+ NZDiv.NZDiv <+ NZBits.NZBits <+ NZSquare. + +Module Type NAxiomsSig' := NAxiomsMiniSig' <+ OrderFunctions' + <+ NZParity.NZParity <+ NZPow.NZPow' <+ NZSqrt.NZSqrt' <+ NZLog.NZLog2 + <+ NZGcd.NZGcd' <+ NZDiv.NZDiv' <+ NZBits.NZBits' <+ NZSquare. + + +(** It could also be interesting to have a constructive recursor function. *) + +Module Type NAxiomsRec (Import NZ : NZDomainSig'). + +Parameter Inline recursion : forall {A : Type}, A -> (t -> A -> A) -> t -> A. + +Declare Instance recursion_wd {A : Type} (Aeq : relation A) : + Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) recursion. + +Axiom recursion_0 : + forall {A} (a : A) (f : t -> A -> A), recursion a f 0 = a. + +Axiom recursion_succ : + forall {A} (Aeq : relation A) (a : A) (f : t -> A -> A), + Aeq a a -> Proper (eq==>Aeq==>Aeq) f -> + forall n, Aeq (recursion a f (S n)) (f n (recursion a f n)). + +End NAxiomsRec. + +Module Type NAxiomsRecSig := NAxiomsMiniSig <+ NAxiomsRec. +Module Type NAxiomsRecSig' := NAxiomsMiniSig' <+ NAxiomsRec. + +Module Type NAxiomsFullSig := NAxiomsSig <+ NAxiomsRec. +Module Type NAxiomsFullSig' := NAxiomsSig' <+ NAxiomsRec. diff --git a/theories/Numbers/Natural/Abstract/NBase.v b/theories/Numbers/Natural/Abstract/NBase.v new file mode 100644 index 0000000000..ad0b3d3d2a --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NBase.v @@ -0,0 +1,187 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Export Decidable. +Require Export NAxioms. +Require Import NZProperties. + +Module NBaseProp (Import N : NAxiomsMiniSig'). +(** First, we import all known facts about both natural numbers and integers. *) +Include NZProp N. + +(** From [pred_0] and order facts, we can prove that 0 isn't a successor. *) + +Theorem neq_succ_0 : forall n, S n ~= 0. +Proof. + intros n EQ. + assert (EQ' := pred_succ n). + rewrite EQ, pred_0 in EQ'. + rewrite <- EQ' in EQ. + now apply (neq_succ_diag_l 0). +Qed. + +Theorem neq_0_succ : forall n, 0 ~= S n. +Proof. +intro n; apply neq_sym; apply neq_succ_0. +Qed. + +(** Next, we show that all numbers are nonnegative and recover regular + induction from the bidirectional induction on NZ *) + +Theorem le_0_l : forall n, 0 <= n. +Proof. +nzinduct n. +now apply eq_le_incl. +intro n; split. +apply le_le_succ_r. +intro H; apply le_succ_r in H; destruct H as [H | H]. +assumption. +symmetry in H; false_hyp H neq_succ_0. +Qed. + +Theorem induction : + forall A : N.t -> Prop, Proper (N.eq==>iff) A -> + A 0 -> (forall n, A n -> A (S n)) -> forall n, A n. +Proof. +intros A A_wd A0 AS n; apply right_induction with 0; try assumption. +intros; auto; apply le_0_l. apply le_0_l. +Qed. + +(** The theorems [bi_induction], [central_induction] and the tactic [nzinduct] +refer to bidirectional induction, which is not useful on natural +numbers. Therefore, we define a new induction tactic for natural numbers. +We do not have to call "Declare Left Step" and "Declare Right Step" +commands again, since the data for stepl and stepr tactics is inherited +from NZ. *) + +Ltac induct n := induction_maker n ltac:(apply induction). + +Theorem case_analysis : + forall A : N.t -> Prop, Proper (N.eq==>iff) A -> + A 0 -> (forall n, A (S n)) -> forall n, A n. +Proof. +intros; apply induction; auto. +Qed. + +Ltac cases n := induction_maker n ltac:(apply case_analysis). + +Theorem neq_0 : ~ forall n, n == 0. +Proof. +intro H; apply (neq_succ_0 0). apply H. +Qed. + +Theorem neq_0_r : forall n, n ~= 0 <-> exists m, n == S m. +Proof. +cases n. split; intro H; +[now elim H | destruct H as [m H]; symmetry in H; false_hyp H neq_succ_0]. +intro n; split; intro H; [now exists n | apply neq_succ_0]. +Qed. + +Theorem zero_or_succ : forall n, n == 0 \/ exists m, n == S m. +Proof. +cases n. +now left. +intro n; right; now exists n. +Qed. + +Theorem eq_pred_0 : forall n, P n == 0 <-> n == 0 \/ n == 1. +Proof. +cases n. +rewrite pred_0. now split; [left|]. +intro n. rewrite pred_succ. +split. intros H; right. now rewrite H, one_succ. +intros [H|H]. elim (neq_succ_0 _ H). +apply succ_inj_wd. now rewrite <- one_succ. +Qed. + +Theorem succ_pred : forall n, n ~= 0 -> S (P n) == n. +Proof. +cases n. +intro H; exfalso; now apply H. +intros; now rewrite pred_succ. +Qed. + +Theorem pred_inj : forall n m, n ~= 0 -> m ~= 0 -> P n == P m -> n == m. +Proof. +intros n m; cases n. +intros H; exfalso; now apply H. +intros n _; cases m. +intros H; exfalso; now apply H. +intros m H2 H3. do 2 rewrite pred_succ in H3. now rewrite H3. +Qed. + +(** The following induction principle is useful for reasoning about, e.g., +Fibonacci numbers *) + +Section PairInduction. + +Variable A : N.t -> Prop. +Hypothesis A_wd : Proper (N.eq==>iff) A. + +Theorem pair_induction : + A 0 -> A 1 -> + (forall n, A n -> A (S n) -> A (S (S n))) -> forall n, A n. +Proof. +rewrite one_succ. +intros until 3. +assert (D : forall n, A n /\ A (S n)); [ |intro n; exact (proj1 (D n))]. +induct n; [ | intros n [IH1 IH2]]; auto. +Qed. + +End PairInduction. + +(** The following is useful for reasoning about, e.g., Ackermann function *) + +Section TwoDimensionalInduction. + +Variable R : N.t -> N.t -> Prop. +Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R. + +Theorem two_dim_induction : + R 0 0 -> + (forall n m, R n m -> R n (S m)) -> + (forall n, (forall m, R n m) -> R (S n) 0) -> forall n m, R n m. +Proof. +intros H1 H2 H3. induct n. +induct m. +exact H1. exact (H2 0). +intros n IH. induct m. +now apply H3. exact (H2 (S n)). +Qed. + +End TwoDimensionalInduction. + + +Section DoubleInduction. + +Variable R : N.t -> N.t -> Prop. +Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R. + +Theorem double_induction : + (forall m, R 0 m) -> + (forall n, R (S n) 0) -> + (forall n m, R n m -> R (S n) (S m)) -> forall n m, R n m. +Proof. +intros H1 H2 H3; induct n; auto. +intros n H; cases m; auto. +Qed. + +End DoubleInduction. + +Ltac double_induct n m := + try intros until n; + try intros until m; + pattern n, m; apply double_induction; clear n m; + [solve_proper | | | ]. + +End NBaseProp. + diff --git a/theories/Numbers/Natural/Abstract/NBits.v b/theories/Numbers/Natural/Abstract/NBits.v new file mode 100644 index 0000000000..90663de3f2 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NBits.v @@ -0,0 +1,1465 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import Bool NAxioms NSub NPow NDiv NParity NLog. + +(** Derived properties of bitwise operations *) + +Module Type NBitsProp + (Import A : NAxiomsSig') + (Import B : NSubProp A) + (Import C : NParityProp A B) + (Import D : NPowProp A B C) + (Import E : NDivProp A B) + (Import F : NLog2Prop A B C D). + +Include BoolEqualityFacts A. + +Ltac order_nz := try apply pow_nonzero; order'. +Hint Rewrite div_0_l mod_0_l div_1_r mod_1_r : nz. + +(** Some properties of power and division *) + +Lemma pow_sub_r : forall a b c, a~=0 -> c<=b -> a^(b-c) == a^b / a^c. +Proof. + intros a b c Ha H. + apply div_unique with 0. + generalize (pow_nonzero a c Ha) (le_0_l (a^c)); order'. + nzsimpl. now rewrite <- pow_add_r, add_comm, sub_add. +Qed. + +Lemma pow_div_l : forall a b c, b~=0 -> a mod b == 0 -> + (a/b)^c == a^c / b^c. +Proof. + intros a b c Hb H. + apply div_unique with 0. + generalize (pow_nonzero b c Hb) (le_0_l (b^c)); order'. + nzsimpl. rewrite <- pow_mul_l. f_equiv. now apply div_exact. +Qed. + +(** An injection from bits [true] and [false] to numbers 1 and 0. + We declare it as a (local) coercion for shorter statements. *) + +Definition b2n (b:bool) := if b then 1 else 0. +Local Coercion b2n : bool >-> t. + +Instance b2n_proper : Proper (Logic.eq ==> eq) b2n. +Proof. solve_proper. Qed. + +Lemma exists_div2 a : exists a' (b:bool), a == 2*a' + b. +Proof. + elim (Even_or_Odd a); [intros (a',H)| intros (a',H)]. + exists a'. exists false. now nzsimpl. + exists a'. exists true. now simpl. +Qed. + +(** We can compact [testbit_odd_0] [testbit_even_0] + [testbit_even_succ] [testbit_odd_succ] in only two lemmas. *) + +Lemma testbit_0_r a (b:bool) : testbit (2*a+b) 0 = b. +Proof. + destruct b; simpl; rewrite ?add_0_r. + apply testbit_odd_0. + apply testbit_even_0. +Qed. + +Lemma testbit_succ_r a (b:bool) n : + testbit (2*a+b) (succ n) = testbit a n. +Proof. + destruct b; simpl; rewrite ?add_0_r. + apply testbit_odd_succ, le_0_l. + apply testbit_even_succ, le_0_l. +Qed. + +(** Alternative characterisations of [testbit] *) + +(** This concise equation could have been taken as specification + for testbit in the interface, but it would have been hard to + implement with little initial knowledge about div and mod *) + +Lemma testbit_spec' a n : a.[n] == (a / 2^n) mod 2. +Proof. + revert a. induct n. + intros a. nzsimpl. + destruct (exists_div2 a) as (a' & b & H). rewrite H at 1. + rewrite testbit_0_r. apply mod_unique with a'; trivial. + destruct b; order'. + intros n IH a. + destruct (exists_div2 a) as (a' & b & H). rewrite H at 1. + rewrite testbit_succ_r, IH. f_equiv. + rewrite pow_succ_r', <- div_div by order_nz. f_equiv. + apply div_unique with b; trivial. + destruct b; order'. +Qed. + +(** This characterisation that uses only basic operations and + power was initially taken as specification for testbit. + We describe [a] as having a low part and a high part, with + the corresponding bit in the middle. This characterisation + is moderatly complex to implement, but also moderately + usable... *) + +Lemma testbit_spec a n : + exists l h, 0<=l<2^n /\ a == l + (a.[n] + 2*h)*2^n. +Proof. + exists (a mod 2^n). exists (a / 2^n / 2). split. + split; [apply le_0_l | apply mod_upper_bound; order_nz]. + rewrite add_comm, mul_comm, (add_comm a.[n]). + rewrite (div_mod a (2^n)) at 1 by order_nz. do 2 f_equiv. + rewrite testbit_spec'. apply div_mod. order'. +Qed. + +Lemma testbit_true : forall a n, + a.[n] = true <-> (a / 2^n) mod 2 == 1. +Proof. + intros a n. + rewrite <- testbit_spec'; destruct a.[n]; split; simpl; now try order'. +Qed. + +Lemma testbit_false : forall a n, + a.[n] = false <-> (a / 2^n) mod 2 == 0. +Proof. + intros a n. + rewrite <- testbit_spec'; destruct a.[n]; split; simpl; now try order'. +Qed. + +Lemma testbit_eqb : forall a n, + a.[n] = eqb ((a / 2^n) mod 2) 1. +Proof. + intros a n. + apply eq_true_iff_eq. now rewrite testbit_true, eqb_eq. +Qed. + +(** Results about the injection [b2n] *) + +Lemma b2n_inj : forall (a0 b0:bool), a0 == b0 -> a0 = b0. +Proof. + intros [|] [|]; simpl; trivial; order'. +Qed. + +Lemma add_b2n_double_div2 : forall (a0:bool) a, (a0+2*a)/2 == a. +Proof. + intros a0 a. rewrite mul_comm, div_add by order'. + now rewrite div_small, add_0_l by (destruct a0; order'). +Qed. + +Lemma add_b2n_double_bit0 : forall (a0:bool) a, (a0+2*a).[0] = a0. +Proof. + intros a0 a. apply b2n_inj. + rewrite testbit_spec'. nzsimpl. rewrite mul_comm, mod_add by order'. + now rewrite mod_small by (destruct a0; order'). +Qed. + +Lemma b2n_div2 : forall (a0:bool), a0/2 == 0. +Proof. + intros a0. rewrite <- (add_b2n_double_div2 a0 0). now nzsimpl. +Qed. + +Lemma b2n_bit0 : forall (a0:bool), a0.[0] = a0. +Proof. + intros a0. rewrite <- (add_b2n_double_bit0 a0 0) at 2. now nzsimpl. +Qed. + +(** The specification of testbit by low and high parts is complete *) + +Lemma testbit_unique : forall a n (a0:bool) l h, + l<2^n -> a == l + (a0 + 2*h)*2^n -> a.[n] = a0. +Proof. + intros a n a0 l h Hl EQ. + apply b2n_inj. rewrite testbit_spec' by trivial. + symmetry. apply mod_unique with h. destruct a0; simpl; order'. + symmetry. apply div_unique with l; trivial. + now rewrite add_comm, (add_comm _ a0), mul_comm. +Qed. + +(** All bits of number 0 are 0 *) + +Lemma bits_0 : forall n, 0.[n] = false. +Proof. + intros n. apply testbit_false. nzsimpl; order_nz. +Qed. + +(** Various ways to refer to the lowest bit of a number *) + +Lemma bit0_odd : forall a, a.[0] = odd a. +Proof. + intros. symmetry. + destruct (exists_div2 a) as (a' & b & EQ). + rewrite EQ, testbit_0_r, add_comm, odd_add_mul_2. + destruct b; simpl; apply odd_1 || apply odd_0. +Qed. + +Lemma bit0_eqb : forall a, a.[0] = eqb (a mod 2) 1. +Proof. + intros a. rewrite testbit_eqb. now nzsimpl. +Qed. + +Lemma bit0_mod : forall a, a.[0] == a mod 2. +Proof. + intros a. rewrite testbit_spec'. now nzsimpl. +Qed. + +(** Hence testing a bit is equivalent to shifting and testing parity *) + +Lemma testbit_odd : forall a n, a.[n] = odd (a>>n). +Proof. + intros. now rewrite <- bit0_odd, shiftr_spec, add_0_l. +Qed. + +(** [log2] gives the highest nonzero bit *) + +Lemma bit_log2 : forall a, a~=0 -> a.[log2 a] = true. +Proof. + intros a Ha. + assert (Ha' : 0 < a) by (generalize (le_0_l a); order). + destruct (log2_spec_alt a Ha') as (r & EQ & (_,Hr)). + rewrite EQ at 1. + rewrite testbit_true, add_comm. + rewrite <- (mul_1_l (2^log2 a)) at 1. + rewrite div_add by order_nz. + rewrite div_small by trivial. + rewrite add_0_l. apply mod_small. order'. +Qed. + +Lemma bits_above_log2 : forall a n, log2 a < n -> + a.[n] = false. +Proof. + intros a n H. + rewrite testbit_false. + rewrite div_small. nzsimpl; order'. + apply log2_lt_cancel. rewrite log2_pow2; trivial using le_0_l. +Qed. + +(** Hence the number of bits of [a] is [1+log2 a] + (see [Pos.size_nat] and [Pos.size]). +*) + +(** Testing bits after division or multiplication by a power of two *) + +Lemma div2_bits : forall a n, (a/2).[n] = a.[S n]. +Proof. + intros. apply eq_true_iff_eq. + rewrite 2 testbit_true. + rewrite pow_succ_r by apply le_0_l. + now rewrite div_div by order_nz. +Qed. + +Lemma div_pow2_bits : forall a n m, (a/2^n).[m] = a.[m+n]. +Proof. + intros a n. revert a. induct n. + intros a m. now nzsimpl. + intros n IH a m. nzsimpl; try apply le_0_l. + rewrite <- div_div by order_nz. + now rewrite IH, div2_bits. +Qed. + +Lemma double_bits_succ : forall a n, (2*a).[S n] = a.[n]. +Proof. + intros. rewrite <- div2_bits. now rewrite mul_comm, div_mul by order'. +Qed. + +Lemma mul_pow2_bits_add : forall a n m, (a*2^n).[m+n] = a.[m]. +Proof. + intros. rewrite <- div_pow2_bits. now rewrite div_mul by order_nz. +Qed. + +Lemma mul_pow2_bits_high : forall a n m, n<=m -> (a*2^n).[m] = a.[m-n]. +Proof. + intros. + rewrite <- (sub_add n m) at 1 by order'. + now rewrite mul_pow2_bits_add. +Qed. + +Lemma mul_pow2_bits_low : forall a n m, m<n -> (a*2^n).[m] = false. +Proof. + intros. apply testbit_false. + rewrite <- (sub_add m n) by order'. rewrite pow_add_r, mul_assoc. + rewrite div_mul by order_nz. + rewrite <- (succ_pred (n-m)). rewrite pow_succ_r. + now rewrite (mul_comm 2), mul_assoc, mod_mul by order'. + apply lt_le_pred. + apply sub_gt in H. generalize (le_0_l (n-m)); order. + now apply sub_gt. +Qed. + +(** Selecting the low part of a number can be done by a modulo *) + +Lemma mod_pow2_bits_high : forall a n m, n<=m -> + (a mod 2^n).[m] = false. +Proof. + intros a n m H. + destruct (eq_0_gt_0_cases (a mod 2^n)) as [EQ|LT]. + now rewrite EQ, bits_0. + apply bits_above_log2. + apply lt_le_trans with n; trivial. + apply log2_lt_pow2; trivial. + apply mod_upper_bound; order_nz. +Qed. + +Lemma mod_pow2_bits_low : forall a n m, m<n -> + (a mod 2^n).[m] = a.[m]. +Proof. + intros a n m H. + rewrite testbit_eqb. + rewrite <- (mod_add _ (2^(P (n-m))*(a/2^n))) by order'. + rewrite <- div_add by order_nz. + rewrite (mul_comm _ 2), mul_assoc, <- pow_succ_r', succ_pred + by now apply sub_gt. + rewrite mul_comm, mul_assoc, <- pow_add_r, (add_comm m), sub_add + by order. + rewrite add_comm, <- div_mod by order_nz. + symmetry. apply testbit_eqb. +Qed. + +(** We now prove that having the same bits implies equality. + For that we use a notion of equality over functional + streams of bits. *) + +Definition eqf (f g:t -> bool) := forall n:t, f n = g n. + +Instance eqf_equiv : Equivalence eqf. +Proof. + split; congruence. +Qed. + +Local Infix "===" := eqf (at level 70, no associativity). + +Instance testbit_eqf : Proper (eq==>eqf) testbit. +Proof. + intros a a' Ha n. now rewrite Ha. +Qed. + +(** Only zero corresponds to the always-false stream. *) + +Lemma bits_inj_0 : + forall a, (forall n, a.[n] = false) -> a == 0. +Proof. + intros a H. destruct (eq_decidable a 0) as [EQ|NEQ]; trivial. + apply bit_log2 in NEQ. now rewrite H in NEQ. +Qed. + +(** If two numbers produce the same stream of bits, they are equal. *) + +Lemma bits_inj : forall a b, testbit a === testbit b -> a == b. +Proof. + intros a. pattern a. + apply strong_right_induction with 0;[solve_proper|clear a|apply le_0_l]. + intros a _ IH b H. + destruct (eq_0_gt_0_cases a) as [EQ|LT]. + rewrite EQ in H |- *. symmetry. apply bits_inj_0. + intros n. now rewrite <- H, bits_0. + rewrite (div_mod a 2), (div_mod b 2) by order'. + f_equiv; [ | now rewrite <- 2 bit0_mod, H]. + f_equiv. + apply IH; trivial using le_0_l. + apply div_lt; order'. + intro n. rewrite 2 div2_bits. apply H. +Qed. + +Lemma bits_inj_iff : forall a b, testbit a === testbit b <-> a == b. +Proof. + split. apply bits_inj. intros EQ; now rewrite EQ. +Qed. + +Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise. + +Ltac bitwise := apply bits_inj; intros ?m; autorewrite with bitwise. + +(** The streams of bits that correspond to a natural numbers are + exactly the ones that are always 0 after some point *) + +Lemma are_bits : forall (f:t->bool), Proper (eq==>Logic.eq) f -> + ((exists n, f === testbit n) <-> + (exists k, forall m, k<=m -> f m = false)). +Proof. + intros f Hf. split. + intros (a,H). + exists (S (log2 a)). intros m Hm. apply le_succ_l in Hm. + rewrite H, bits_above_log2; trivial using lt_succ_diag_r. + intros (k,Hk). + revert f Hf Hk. induct k. + intros f Hf H0. + exists 0. intros m. rewrite bits_0, H0; trivial. apply le_0_l. + intros k IH f Hf Hk. + destruct (IH (fun m => f (S m))) as (n, Hn). + solve_proper. + intros m Hm. apply Hk. now rewrite <- succ_le_mono. + exists (f 0 + 2*n). intros m. + destruct (zero_or_succ m) as [Hm|(m', Hm)]; rewrite Hm. + symmetry. apply add_b2n_double_bit0. + rewrite Hn, <- div2_bits. + rewrite mul_comm, div_add, b2n_div2, add_0_l; trivial. order'. +Qed. + +(** Properties of shifts *) + +Lemma shiftr_spec' : forall a n m, (a >> n).[m] = a.[m+n]. +Proof. + intros. apply shiftr_spec. apply le_0_l. +Qed. + +Lemma shiftl_spec_high' : forall a n m, n<=m -> (a << n).[m] = a.[m-n]. +Proof. + intros. apply shiftl_spec_high; trivial. apply le_0_l. +Qed. + +Lemma shiftr_div_pow2 : forall a n, a >> n == a / 2^n. +Proof. + intros. bitwise. rewrite shiftr_spec'. + symmetry. apply div_pow2_bits. +Qed. + +Lemma shiftl_mul_pow2 : forall a n, a << n == a * 2^n. +Proof. + intros. bitwise. + destruct (le_gt_cases n m) as [H|H]. + now rewrite shiftl_spec_high', mul_pow2_bits_high. + now rewrite shiftl_spec_low, mul_pow2_bits_low. +Qed. + +Lemma shiftl_spec_alt : forall a n m, (a << n).[m+n] = a.[m]. +Proof. + intros. now rewrite shiftl_mul_pow2, mul_pow2_bits_add. +Qed. + +Instance shiftr_wd : Proper (eq==>eq==>eq) shiftr. +Proof. + intros a a' Ha b b' Hb. now rewrite 2 shiftr_div_pow2, Ha, Hb. +Qed. + +Instance shiftl_wd : Proper (eq==>eq==>eq) shiftl. +Proof. + intros a a' Ha b b' Hb. now rewrite 2 shiftl_mul_pow2, Ha, Hb. +Qed. + +Lemma shiftl_shiftl : forall a n m, + (a << n) << m == a << (n+m). +Proof. + intros. now rewrite !shiftl_mul_pow2, pow_add_r, mul_assoc. +Qed. + +Lemma shiftr_shiftr : forall a n m, + (a >> n) >> m == a >> (n+m). +Proof. + intros. + now rewrite !shiftr_div_pow2, pow_add_r, div_div by order_nz. +Qed. + +Lemma shiftr_shiftl_l : forall a n m, m<=n -> + (a << n) >> m == a << (n-m). +Proof. + intros. + rewrite shiftr_div_pow2, !shiftl_mul_pow2. + rewrite <- (sub_add m n) at 1 by trivial. + now rewrite pow_add_r, mul_assoc, div_mul by order_nz. +Qed. + +Lemma shiftr_shiftl_r : forall a n m, n<=m -> + (a << n) >> m == a >> (m-n). +Proof. + intros. + rewrite !shiftr_div_pow2, shiftl_mul_pow2. + rewrite <- (sub_add n m) at 1 by trivial. + rewrite pow_add_r, (mul_comm (2^(m-n))). + now rewrite <- div_div, div_mul by order_nz. +Qed. + +(** shifts and constants *) + +Lemma shiftl_1_l : forall n, 1 << n == 2^n. +Proof. + intros. now rewrite shiftl_mul_pow2, mul_1_l. +Qed. + +Lemma shiftl_0_r : forall a, a << 0 == a. +Proof. + intros. rewrite shiftl_mul_pow2. now nzsimpl. +Qed. + +Lemma shiftr_0_r : forall a, a >> 0 == a. +Proof. + intros. rewrite shiftr_div_pow2. now nzsimpl. +Qed. + +Lemma shiftl_0_l : forall n, 0 << n == 0. +Proof. + intros. rewrite shiftl_mul_pow2. now nzsimpl. +Qed. + +Lemma shiftr_0_l : forall n, 0 >> n == 0. +Proof. + intros. rewrite shiftr_div_pow2. nzsimpl; order_nz. +Qed. + +Lemma shiftl_eq_0_iff : forall a n, a << n == 0 <-> a == 0. +Proof. + intros a n. rewrite shiftl_mul_pow2. rewrite eq_mul_0. split. + intros [H | H]; trivial. contradict H; order_nz. + intros H. now left. +Qed. + +Lemma shiftr_eq_0_iff : forall a n, + a >> n == 0 <-> a==0 \/ (0<a /\ log2 a < n). +Proof. + intros a n. + rewrite shiftr_div_pow2, div_small_iff by order_nz. + destruct (eq_0_gt_0_cases a) as [EQ|LT]. + rewrite EQ. split. now left. intros _. + assert (H : 2~=0) by order'. + generalize (pow_nonzero 2 n H) (le_0_l (2^n)); order. + rewrite log2_lt_pow2; trivial. + split. right; split; trivial. intros [H|[_ H]]; now order. +Qed. + +Lemma shiftr_eq_0 : forall a n, log2 a < n -> a >> n == 0. +Proof. + intros a n H. rewrite shiftr_eq_0_iff. + destruct (eq_0_gt_0_cases a) as [EQ|LT]. now left. right; now split. +Qed. + +(** Properties of [div2]. *) + +Lemma div2_div : forall a, div2 a == a/2. +Proof. + intros. rewrite div2_spec, shiftr_div_pow2. now nzsimpl. +Qed. + +Instance div2_wd : Proper (eq==>eq) div2. +Proof. + intros a a' Ha. now rewrite 2 div2_div, Ha. +Qed. + +Lemma div2_odd : forall a, a == 2*(div2 a) + odd a. +Proof. + intros a. rewrite div2_div, <- bit0_odd, bit0_mod. + apply div_mod. order'. +Qed. + +(** Properties of [lxor] and others, directly deduced + from properties of [xorb] and others. *) + +Instance lxor_wd : Proper (eq ==> eq ==> eq) lxor. +Proof. + intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. +Qed. + +Instance land_wd : Proper (eq ==> eq ==> eq) land. +Proof. + intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. +Qed. + +Instance lor_wd : Proper (eq ==> eq ==> eq) lor. +Proof. + intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. +Qed. + +Instance ldiff_wd : Proper (eq ==> eq ==> eq) ldiff. +Proof. + intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. +Qed. + +Lemma lxor_eq : forall a a', lxor a a' == 0 -> a == a'. +Proof. + intros a a' H. bitwise. apply xorb_eq. + now rewrite <- lxor_spec, H, bits_0. +Qed. + +Lemma lxor_nilpotent : forall a, lxor a a == 0. +Proof. + intros. bitwise. apply xorb_nilpotent. +Qed. + +Lemma lxor_eq_0_iff : forall a a', lxor a a' == 0 <-> a == a'. +Proof. + split. apply lxor_eq. intros EQ; rewrite EQ; apply lxor_nilpotent. +Qed. + +Lemma lxor_0_l : forall a, lxor 0 a == a. +Proof. + intros. bitwise. apply xorb_false_l. +Qed. + +Lemma lxor_0_r : forall a, lxor a 0 == a. +Proof. + intros. bitwise. apply xorb_false_r. +Qed. + +Lemma lxor_comm : forall a b, lxor a b == lxor b a. +Proof. + intros. bitwise. apply xorb_comm. +Qed. + +Lemma lxor_assoc : + forall a b c, lxor (lxor a b) c == lxor a (lxor b c). +Proof. + intros. bitwise. apply xorb_assoc. +Qed. + +Lemma lor_0_l : forall a, lor 0 a == a. +Proof. + intros. bitwise. trivial. +Qed. + +Lemma lor_0_r : forall a, lor a 0 == a. +Proof. + intros. bitwise. apply orb_false_r. +Qed. + +Lemma lor_comm : forall a b, lor a b == lor b a. +Proof. + intros. bitwise. apply orb_comm. +Qed. + +Lemma lor_assoc : + forall a b c, lor a (lor b c) == lor (lor a b) c. +Proof. + intros. bitwise. apply orb_assoc. +Qed. + +Lemma lor_diag : forall a, lor a a == a. +Proof. + intros. bitwise. apply orb_diag. +Qed. + +Lemma lor_eq_0_l : forall a b, lor a b == 0 -> a == 0. +Proof. + intros a b H. bitwise. + apply (orb_false_iff a.[m] b.[m]). + now rewrite <- lor_spec, H, bits_0. +Qed. + +Lemma lor_eq_0_iff : forall a b, lor a b == 0 <-> a == 0 /\ b == 0. +Proof. + intros a b. split. + split. now apply lor_eq_0_l in H. + rewrite lor_comm in H. now apply lor_eq_0_l in H. + intros (EQ,EQ'). now rewrite EQ, lor_0_l. +Qed. + +Lemma land_0_l : forall a, land 0 a == 0. +Proof. + intros. bitwise. trivial. +Qed. + +Lemma land_0_r : forall a, land a 0 == 0. +Proof. + intros. bitwise. apply andb_false_r. +Qed. + +Lemma land_comm : forall a b, land a b == land b a. +Proof. + intros. bitwise. apply andb_comm. +Qed. + +Lemma land_assoc : + forall a b c, land a (land b c) == land (land a b) c. +Proof. + intros. bitwise. apply andb_assoc. +Qed. + +Lemma land_diag : forall a, land a a == a. +Proof. + intros. bitwise. apply andb_diag. +Qed. + +Lemma ldiff_0_l : forall a, ldiff 0 a == 0. +Proof. + intros. bitwise. trivial. +Qed. + +Lemma ldiff_0_r : forall a, ldiff a 0 == a. +Proof. + intros. bitwise. now rewrite andb_true_r. +Qed. + +Lemma ldiff_diag : forall a, ldiff a a == 0. +Proof. + intros. bitwise. apply andb_negb_r. +Qed. + +Lemma lor_land_distr_l : forall a b c, + lor (land a b) c == land (lor a c) (lor b c). +Proof. + intros. bitwise. apply orb_andb_distrib_l. +Qed. + +Lemma lor_land_distr_r : forall a b c, + lor a (land b c) == land (lor a b) (lor a c). +Proof. + intros. bitwise. apply orb_andb_distrib_r. +Qed. + +Lemma land_lor_distr_l : forall a b c, + land (lor a b) c == lor (land a c) (land b c). +Proof. + intros. bitwise. apply andb_orb_distrib_l. +Qed. + +Lemma land_lor_distr_r : forall a b c, + land a (lor b c) == lor (land a b) (land a c). +Proof. + intros. bitwise. apply andb_orb_distrib_r. +Qed. + +Lemma ldiff_ldiff_l : forall a b c, + ldiff (ldiff a b) c == ldiff a (lor b c). +Proof. + intros. bitwise. now rewrite negb_orb, andb_assoc. +Qed. + +Lemma lor_ldiff_and : forall a b, + lor (ldiff a b) (land a b) == a. +Proof. + intros. bitwise. + now rewrite <- andb_orb_distrib_r, orb_comm, orb_negb_r, andb_true_r. +Qed. + +Lemma land_ldiff : forall a b, + land (ldiff a b) b == 0. +Proof. + intros. bitwise. + now rewrite <-andb_assoc, (andb_comm (negb _)), andb_negb_r, andb_false_r. +Qed. + +(** Properties of [setbit] and [clearbit] *) + +Definition setbit a n := lor a (1<<n). +Definition clearbit a n := ldiff a (1<<n). + +Lemma setbit_spec' : forall a n, setbit a n == lor a (2^n). +Proof. + intros. unfold setbit. now rewrite shiftl_1_l. +Qed. + +Lemma clearbit_spec' : forall a n, clearbit a n == ldiff a (2^n). +Proof. + intros. unfold clearbit. now rewrite shiftl_1_l. +Qed. + +Instance setbit_wd : Proper (eq==>eq==>eq) setbit. +Proof. unfold setbit. solve_proper. Qed. + +Instance clearbit_wd : Proper (eq==>eq==>eq) clearbit. +Proof. unfold clearbit. solve_proper. Qed. + +Lemma pow2_bits_true : forall n, (2^n).[n] = true. +Proof. + intros. rewrite <- (mul_1_l (2^n)). rewrite <- (add_0_l n) at 2. + now rewrite mul_pow2_bits_add, bit0_odd, odd_1. +Qed. + +Lemma pow2_bits_false : forall n m, n~=m -> (2^n).[m] = false. +Proof. + intros. + rewrite <- (mul_1_l (2^n)). + destruct (le_gt_cases n m). + rewrite mul_pow2_bits_high; trivial. + rewrite <- (succ_pred (m-n)) by (apply sub_gt; order). + now rewrite <- div2_bits, div_small, bits_0 by order'. + rewrite mul_pow2_bits_low; trivial. +Qed. + +Lemma pow2_bits_eqb : forall n m, (2^n).[m] = eqb n m. +Proof. + intros. apply eq_true_iff_eq. rewrite eqb_eq. split. + destruct (eq_decidable n m) as [H|H]. trivial. + now rewrite (pow2_bits_false _ _ H). + intros EQ. rewrite EQ. apply pow2_bits_true. +Qed. + +Lemma setbit_eqb : forall a n m, + (setbit a n).[m] = eqb n m || a.[m]. +Proof. + intros. now rewrite setbit_spec', lor_spec, pow2_bits_eqb, orb_comm. +Qed. + +Lemma setbit_iff : forall a n m, + (setbit a n).[m] = true <-> n==m \/ a.[m] = true. +Proof. + intros. now rewrite setbit_eqb, orb_true_iff, eqb_eq. +Qed. + +Lemma setbit_eq : forall a n, (setbit a n).[n] = true. +Proof. + intros. apply setbit_iff. now left. +Qed. + +Lemma setbit_neq : forall a n m, n~=m -> + (setbit a n).[m] = a.[m]. +Proof. + intros a n m H. rewrite setbit_eqb. + rewrite <- eqb_eq in H. apply not_true_is_false in H. now rewrite H. +Qed. + +Lemma clearbit_eqb : forall a n m, + (clearbit a n).[m] = a.[m] && negb (eqb n m). +Proof. + intros. now rewrite clearbit_spec', ldiff_spec, pow2_bits_eqb. +Qed. + +Lemma clearbit_iff : forall a n m, + (clearbit a n).[m] = true <-> a.[m] = true /\ n~=m. +Proof. + intros. rewrite clearbit_eqb, andb_true_iff, <- eqb_eq. + now rewrite negb_true_iff, not_true_iff_false. +Qed. + +Lemma clearbit_eq : forall a n, (clearbit a n).[n] = false. +Proof. + intros. rewrite clearbit_eqb, (proj2 (eqb_eq _ _) (eq_refl n)). + apply andb_false_r. +Qed. + +Lemma clearbit_neq : forall a n m, n~=m -> + (clearbit a n).[m] = a.[m]. +Proof. + intros a n m H. rewrite clearbit_eqb. + rewrite <- eqb_eq in H. apply not_true_is_false in H. rewrite H. + apply andb_true_r. +Qed. + +(** Shifts of bitwise operations *) + +Lemma shiftl_lxor : forall a b n, + (lxor a b) << n == lxor (a << n) (b << n). +Proof. + intros. bitwise. + destruct (le_gt_cases n m). + now rewrite !shiftl_spec_high', lxor_spec. + now rewrite !shiftl_spec_low. +Qed. + +Lemma shiftr_lxor : forall a b n, + (lxor a b) >> n == lxor (a >> n) (b >> n). +Proof. + intros. bitwise. now rewrite !shiftr_spec', lxor_spec. +Qed. + +Lemma shiftl_land : forall a b n, + (land a b) << n == land (a << n) (b << n). +Proof. + intros. bitwise. + destruct (le_gt_cases n m). + now rewrite !shiftl_spec_high', land_spec. + now rewrite !shiftl_spec_low. +Qed. + +Lemma shiftr_land : forall a b n, + (land a b) >> n == land (a >> n) (b >> n). +Proof. + intros. bitwise. now rewrite !shiftr_spec', land_spec. +Qed. + +Lemma shiftl_lor : forall a b n, + (lor a b) << n == lor (a << n) (b << n). +Proof. + intros. bitwise. + destruct (le_gt_cases n m). + now rewrite !shiftl_spec_high', lor_spec. + now rewrite !shiftl_spec_low. +Qed. + +Lemma shiftr_lor : forall a b n, + (lor a b) >> n == lor (a >> n) (b >> n). +Proof. + intros. bitwise. now rewrite !shiftr_spec', lor_spec. +Qed. + +Lemma shiftl_ldiff : forall a b n, + (ldiff a b) << n == ldiff (a << n) (b << n). +Proof. + intros. bitwise. + destruct (le_gt_cases n m). + now rewrite !shiftl_spec_high', ldiff_spec. + now rewrite !shiftl_spec_low. +Qed. + +Lemma shiftr_ldiff : forall a b n, + (ldiff a b) >> n == ldiff (a >> n) (b >> n). +Proof. + intros. bitwise. now rewrite !shiftr_spec', ldiff_spec. +Qed. + +(** We cannot have a function complementing all bits of a number, + otherwise it would have an infinity of bit 1. Nonetheless, + we can design a bounded complement *) + +Definition ones n := P (1 << n). + +Definition lnot a n := lxor a (ones n). + +Instance ones_wd : Proper (eq==>eq) ones. +Proof. unfold ones. solve_proper. Qed. + +Instance lnot_wd : Proper (eq==>eq==>eq) lnot. +Proof. unfold lnot. solve_proper. Qed. + +Lemma ones_equiv : forall n, ones n == P (2^n). +Proof. + intros; unfold ones; now rewrite shiftl_1_l. +Qed. + +Lemma ones_add : forall n m, ones (m+n) == 2^m * ones n + ones m. +Proof. + intros n m. rewrite !ones_equiv. + rewrite <- !sub_1_r, mul_sub_distr_l, mul_1_r, <- pow_add_r. + rewrite add_sub_assoc, sub_add. reflexivity. + apply pow_le_mono_r. order'. + rewrite <- (add_0_r m) at 1. apply add_le_mono_l, le_0_l. + rewrite <- (pow_0_r 2). apply pow_le_mono_r. order'. apply le_0_l. +Qed. + +Lemma ones_div_pow2 : forall n m, m<=n -> ones n / 2^m == ones (n-m). +Proof. + intros n m H. symmetry. apply div_unique with (ones m). + rewrite ones_equiv. + apply le_succ_l. rewrite succ_pred; order_nz. + rewrite <- (sub_add m n H) at 1. rewrite (add_comm _ m). + apply ones_add. +Qed. + +Lemma ones_mod_pow2 : forall n m, m<=n -> (ones n) mod (2^m) == ones m. +Proof. + intros n m H. symmetry. apply mod_unique with (ones (n-m)). + rewrite ones_equiv. + apply le_succ_l. rewrite succ_pred; order_nz. + rewrite <- (sub_add m n H) at 1. rewrite (add_comm _ m). + apply ones_add. +Qed. + +Lemma ones_spec_low : forall n m, m<n -> (ones n).[m] = true. +Proof. + intros. apply testbit_true. rewrite ones_div_pow2 by order. + rewrite <- (pow_1_r 2). rewrite ones_mod_pow2. + rewrite ones_equiv. now nzsimpl'. + apply le_add_le_sub_r. nzsimpl. now apply le_succ_l. +Qed. + +Lemma ones_spec_high : forall n m, n<=m -> (ones n).[m] = false. +Proof. + intros. + destruct (eq_0_gt_0_cases n) as [EQ|LT]; rewrite ones_equiv. + now rewrite EQ, pow_0_r, one_succ, pred_succ, bits_0. + apply bits_above_log2. + rewrite log2_pred_pow2; trivial. rewrite <-le_succ_l, succ_pred; order. +Qed. + +Lemma ones_spec_iff : forall n m, (ones n).[m] = true <-> m<n. +Proof. + intros. split. intros H. + apply lt_nge. intro H'. apply ones_spec_high in H'. + rewrite H in H'; discriminate. + apply ones_spec_low. +Qed. + +Lemma lnot_spec_low : forall a n m, m<n -> + (lnot a n).[m] = negb a.[m]. +Proof. + intros. unfold lnot. now rewrite lxor_spec, ones_spec_low. +Qed. + +Lemma lnot_spec_high : forall a n m, n<=m -> + (lnot a n).[m] = a.[m]. +Proof. + intros. unfold lnot. now rewrite lxor_spec, ones_spec_high, xorb_false_r. +Qed. + +Lemma lnot_involutive : forall a n, lnot (lnot a n) n == a. +Proof. + intros a n. bitwise. + destruct (le_gt_cases n m). + now rewrite 2 lnot_spec_high. + now rewrite 2 lnot_spec_low, negb_involutive. +Qed. + +Lemma lnot_0_l : forall n, lnot 0 n == ones n. +Proof. + intros. unfold lnot. apply lxor_0_l. +Qed. + +Lemma lnot_ones : forall n, lnot (ones n) n == 0. +Proof. + intros. unfold lnot. apply lxor_nilpotent. +Qed. + +(** Bounded complement and other operations *) + +Lemma lor_ones_low : forall a n, log2 a < n -> + lor a (ones n) == ones n. +Proof. + intros a n H. bitwise. destruct (le_gt_cases n m). + rewrite ones_spec_high, bits_above_log2; trivial. + now apply lt_le_trans with n. + now rewrite ones_spec_low, orb_true_r. +Qed. + +Lemma land_ones : forall a n, land a (ones n) == a mod 2^n. +Proof. + intros a n. bitwise. destruct (le_gt_cases n m). + now rewrite ones_spec_high, mod_pow2_bits_high, andb_false_r. + now rewrite ones_spec_low, mod_pow2_bits_low, andb_true_r. +Qed. + +Lemma land_ones_low : forall a n, log2 a < n -> + land a (ones n) == a. +Proof. + intros; rewrite land_ones. apply mod_small. + apply log2_lt_cancel. rewrite log2_pow2; trivial using le_0_l. +Qed. + +Lemma ldiff_ones_r : forall a n, + ldiff a (ones n) == (a >> n) << n. +Proof. + intros a n. bitwise. destruct (le_gt_cases n m). + rewrite ones_spec_high, shiftl_spec_high', shiftr_spec'; trivial. + rewrite sub_add; trivial. apply andb_true_r. + now rewrite ones_spec_low, shiftl_spec_low, andb_false_r. +Qed. + +Lemma ldiff_ones_r_low : forall a n, log2 a < n -> + ldiff a (ones n) == 0. +Proof. + intros a n H. bitwise. destruct (le_gt_cases n m). + rewrite ones_spec_high, bits_above_log2; trivial. + now apply lt_le_trans with n. + now rewrite ones_spec_low, andb_false_r. +Qed. + +Lemma ldiff_ones_l_low : forall a n, log2 a < n -> + ldiff (ones n) a == lnot a n. +Proof. + intros a n H. bitwise. destruct (le_gt_cases n m). + rewrite ones_spec_high, lnot_spec_high, bits_above_log2; trivial. + now apply lt_le_trans with n. + now rewrite ones_spec_low, lnot_spec_low. +Qed. + +Lemma lor_lnot_diag : forall a n, + lor a (lnot a n) == lor a (ones n). +Proof. + intros a n. bitwise. + destruct (le_gt_cases n m). + rewrite lnot_spec_high, ones_spec_high; trivial. now destruct a.[m]. + rewrite lnot_spec_low, ones_spec_low; trivial. now destruct a.[m]. +Qed. + +Lemma lor_lnot_diag_low : forall a n, log2 a < n -> + lor a (lnot a n) == ones n. +Proof. + intros a n H. now rewrite lor_lnot_diag, lor_ones_low. +Qed. + +Lemma land_lnot_diag : forall a n, + land a (lnot a n) == ldiff a (ones n). +Proof. + intros a n. bitwise. + destruct (le_gt_cases n m). + rewrite lnot_spec_high, ones_spec_high; trivial. now destruct a.[m]. + rewrite lnot_spec_low, ones_spec_low; trivial. now destruct a.[m]. +Qed. + +Lemma land_lnot_diag_low : forall a n, log2 a < n -> + land a (lnot a n) == 0. +Proof. + intros. now rewrite land_lnot_diag, ldiff_ones_r_low. +Qed. + +Lemma lnot_lor_low : forall a b n, log2 a < n -> log2 b < n -> + lnot (lor a b) n == land (lnot a n) (lnot b n). +Proof. + intros a b n Ha Hb. bitwise. destruct (le_gt_cases n m). + rewrite !lnot_spec_high, lor_spec, !bits_above_log2; trivial. + now apply lt_le_trans with n. + now apply lt_le_trans with n. + now rewrite !lnot_spec_low, lor_spec, negb_orb. +Qed. + +Lemma lnot_land_low : forall a b n, log2 a < n -> log2 b < n -> + lnot (land a b) n == lor (lnot a n) (lnot b n). +Proof. + intros a b n Ha Hb. bitwise. destruct (le_gt_cases n m). + rewrite !lnot_spec_high, land_spec, !bits_above_log2; trivial. + now apply lt_le_trans with n. + now apply lt_le_trans with n. + now rewrite !lnot_spec_low, land_spec, negb_andb. +Qed. + +Lemma ldiff_land_low : forall a b n, log2 a < n -> + ldiff a b == land a (lnot b n). +Proof. + intros a b n Ha. bitwise. destruct (le_gt_cases n m). + rewrite (bits_above_log2 a m). trivial. + now apply lt_le_trans with n. + rewrite !lnot_spec_low; trivial. +Qed. + +Lemma lnot_ldiff_low : forall a b n, log2 a < n -> log2 b < n -> + lnot (ldiff a b) n == lor (lnot a n) b. +Proof. + intros a b n Ha Hb. bitwise. destruct (le_gt_cases n m). + rewrite !lnot_spec_high, ldiff_spec, !bits_above_log2; trivial. + now apply lt_le_trans with n. + now apply lt_le_trans with n. + now rewrite !lnot_spec_low, ldiff_spec, negb_andb, negb_involutive. +Qed. + +Lemma lxor_lnot_lnot : forall a b n, + lxor (lnot a n) (lnot b n) == lxor a b. +Proof. + intros a b n. bitwise. destruct (le_gt_cases n m). + rewrite !lnot_spec_high; trivial. + rewrite !lnot_spec_low, xorb_negb_negb; trivial. +Qed. + +Lemma lnot_lxor_l : forall a b n, + lnot (lxor a b) n == lxor (lnot a n) b. +Proof. + intros a b n. bitwise. destruct (le_gt_cases n m). + rewrite !lnot_spec_high, lxor_spec; trivial. + rewrite !lnot_spec_low, lxor_spec, negb_xorb_l; trivial. +Qed. + +Lemma lnot_lxor_r : forall a b n, + lnot (lxor a b) n == lxor a (lnot b n). +Proof. + intros a b n. bitwise. destruct (le_gt_cases n m). + rewrite !lnot_spec_high, lxor_spec; trivial. + rewrite !lnot_spec_low, lxor_spec, negb_xorb_r; trivial. +Qed. + +Lemma lxor_lor : forall a b, land a b == 0 -> + lxor a b == lor a b. +Proof. + intros a b H. bitwise. + assert (a.[m] && b.[m] = false) + by now rewrite <- land_spec, H, bits_0. + now destruct a.[m], b.[m]. +Qed. + +(** Bitwise operations and log2 *) + +Lemma log2_bits_unique : forall a n, + a.[n] = true -> + (forall m, n<m -> a.[m] = false) -> + log2 a == n. +Proof. + intros a n H H'. + destruct (eq_0_gt_0_cases a) as [Ha|Ha]. + now rewrite Ha, bits_0 in H. + apply le_antisymm; apply le_ngt; intros LT. + specialize (H' _ LT). now rewrite bit_log2 in H' by order. + now rewrite bits_above_log2 in H by order. +Qed. + +Lemma log2_shiftr : forall a n, log2 (a >> n) == log2 a - n. +Proof. + intros a n. + destruct (eq_0_gt_0_cases a) as [Ha|Ha]. + now rewrite Ha, shiftr_0_l, log2_nonpos, sub_0_l by order. + destruct (lt_ge_cases (log2 a) n). + rewrite shiftr_eq_0, log2_nonpos by order. + symmetry. rewrite sub_0_le; order. + apply log2_bits_unique. + now rewrite shiftr_spec', sub_add, bit_log2 by order. + intros m Hm. + rewrite shiftr_spec'; trivial. apply bits_above_log2; try order. + now apply lt_sub_lt_add_r. +Qed. + +Lemma log2_shiftl : forall a n, a~=0 -> log2 (a << n) == log2 a + n. +Proof. + intros a n Ha. + rewrite shiftl_mul_pow2, add_comm by trivial. + apply log2_mul_pow2. generalize (le_0_l a); order. apply le_0_l. +Qed. + +Lemma log2_lor : forall a b, + log2 (lor a b) == max (log2 a) (log2 b). +Proof. + assert (AUX : forall a b, a<=b -> log2 (lor a b) == log2 b). + intros a b H. + destruct (eq_0_gt_0_cases a) as [Ha|Ha]. now rewrite Ha, lor_0_l. + apply log2_bits_unique. + now rewrite lor_spec, bit_log2, orb_true_r by order. + intros m Hm. assert (H' := log2_le_mono _ _ H). + now rewrite lor_spec, 2 bits_above_log2 by order. + (* main *) + intros a b. destruct (le_ge_cases a b) as [H|H]. + rewrite max_r by now apply log2_le_mono. + now apply AUX. + rewrite max_l by now apply log2_le_mono. + rewrite lor_comm. now apply AUX. +Qed. + +Lemma log2_land : forall a b, + log2 (land a b) <= min (log2 a) (log2 b). +Proof. + assert (AUX : forall a b, a<=b -> log2 (land a b) <= log2 a). + intros a b H. + apply le_ngt. intros H'. + destruct (eq_decidable (land a b) 0) as [EQ|NEQ]. + rewrite EQ in H'. apply log2_lt_cancel in H'. generalize (le_0_l a); order. + generalize (bit_log2 (land a b) NEQ). + now rewrite land_spec, bits_above_log2. + (* main *) + intros a b. + destruct (le_ge_cases a b) as [H|H]. + rewrite min_l by now apply log2_le_mono. now apply AUX. + rewrite min_r by now apply log2_le_mono. rewrite land_comm. now apply AUX. +Qed. + +Lemma log2_lxor : forall a b, + log2 (lxor a b) <= max (log2 a) (log2 b). +Proof. + assert (AUX : forall a b, a<=b -> log2 (lxor a b) <= log2 b). + intros a b H. + apply le_ngt. intros H'. + destruct (eq_decidable (lxor a b) 0) as [EQ|NEQ]. + rewrite EQ in H'. apply log2_lt_cancel in H'. generalize (le_0_l a); order. + generalize (bit_log2 (lxor a b) NEQ). + rewrite lxor_spec, 2 bits_above_log2; try order. discriminate. + apply le_lt_trans with (log2 b); trivial. now apply log2_le_mono. + (* main *) + intros a b. + destruct (le_ge_cases a b) as [H|H]. + rewrite max_r by now apply log2_le_mono. now apply AUX. + rewrite max_l by now apply log2_le_mono. rewrite lxor_comm. now apply AUX. +Qed. + +(** Bitwise operations and arithmetical operations *) + +Local Notation xor3 a b c := (xorb (xorb a b) c). +Local Notation lxor3 a b c := (lxor (lxor a b) c). + +Local Notation nextcarry a b c := ((a&&b) || (c && (a||b))). +Local Notation lnextcarry a b c := (lor (land a b) (land c (lor a b))). + +Lemma add_bit0 : forall a b, (a+b).[0] = xorb a.[0] b.[0]. +Proof. + intros. now rewrite !bit0_odd, odd_add. +Qed. + +Lemma add3_bit0 : forall a b c, + (a+b+c).[0] = xor3 a.[0] b.[0] c.[0]. +Proof. + intros. now rewrite !add_bit0. +Qed. + +Lemma add3_bits_div2 : forall (a0 b0 c0 : bool), + (a0 + b0 + c0)/2 == nextcarry a0 b0 c0. +Proof. + assert (H : 1+1 == 2) by now nzsimpl'. + intros [|] [|] [|]; simpl; rewrite ?add_0_l, ?add_0_r, ?H; + (apply div_same; order') || (apply div_small; order') || idtac. + symmetry. apply div_unique with 1. order'. now nzsimpl'. +Qed. + +Lemma add_carry_div2 : forall a b (c0:bool), + (a + b + c0)/2 == a/2 + b/2 + nextcarry a.[0] b.[0] c0. +Proof. + intros. + rewrite <- add3_bits_div2. + rewrite (add_comm ((a/2)+_)). + rewrite <- div_add by order'. + f_equiv. + rewrite <- !div2_div, mul_comm, mul_add_distr_l. + rewrite (div2_odd a), <- bit0_odd at 1. fold (b2n a.[0]). + rewrite (div2_odd b), <- bit0_odd at 1. fold (b2n b.[0]). + rewrite add_shuffle1. + rewrite <-(add_assoc _ _ c0). apply add_comm. +Qed. + +(** The main result concerning addition: we express the bits of the sum + in term of bits of [a] and [b] and of some carry stream which is also + recursively determined by another equation. +*) + +Lemma add_carry_bits : forall a b (c0:bool), exists c, + a+b+c0 == lxor3 a b c /\ c/2 == lnextcarry a b c /\ c.[0] = c0. +Proof. + intros a b c0. + (* induction over some n such that [a<2^n] and [b<2^n] *) + set (n:=max a b). + assert (Ha : a<2^n). + apply lt_le_trans with (2^a). apply pow_gt_lin_r, lt_1_2. + apply pow_le_mono_r. order'. unfold n. + destruct (le_ge_cases a b); [rewrite max_r|rewrite max_l]; order'. + assert (Hb : b<2^n). + apply lt_le_trans with (2^b). apply pow_gt_lin_r, lt_1_2. + apply pow_le_mono_r. order'. unfold n. + destruct (le_ge_cases a b); [rewrite max_r|rewrite max_l]; order'. + clearbody n. + revert a b c0 Ha Hb. induct n. + (*base*) + intros a b c0. rewrite !pow_0_r, !one_succ, !lt_succ_r. intros Ha Hb. + exists c0. + setoid_replace a with 0 by (generalize (le_0_l a); order'). + setoid_replace b with 0 by (generalize (le_0_l b); order'). + rewrite !add_0_l, !lxor_0_l, !lor_0_r, !land_0_r, !lor_0_r. + rewrite b2n_div2, b2n_bit0; now repeat split. + (*step*) + intros n IH a b c0 Ha Hb. + set (c1:=nextcarry a.[0] b.[0] c0). + destruct (IH (a/2) (b/2) c1) as (c & IH1 & IH2 & Hc); clear IH. + apply div_lt_upper_bound; trivial. order'. now rewrite <- pow_succ_r'. + apply div_lt_upper_bound; trivial. order'. now rewrite <- pow_succ_r'. + exists (c0 + 2*c). repeat split. + (* - add *) + bitwise. + destruct (zero_or_succ m) as [EQ|[m' EQ]]; rewrite EQ; clear EQ. + now rewrite add_b2n_double_bit0, add3_bit0, b2n_bit0. + rewrite <- !div2_bits, <- 2 lxor_spec. + f_equiv. + rewrite add_b2n_double_div2, <- IH1. apply add_carry_div2. + (* - carry *) + rewrite add_b2n_double_div2. + bitwise. + destruct (zero_or_succ m) as [EQ|[m' EQ]]; rewrite EQ; clear EQ. + now rewrite add_b2n_double_bit0. + rewrite <- !div2_bits, IH2. autorewrite with bitwise. + now rewrite add_b2n_double_div2. + (* - carry0 *) + apply add_b2n_double_bit0. +Qed. + +(** Particular case : the second bit of an addition *) + +Lemma add_bit1 : forall a b, + (a+b).[1] = xor3 a.[1] b.[1] (a.[0] && b.[0]). +Proof. + intros a b. + destruct (add_carry_bits a b false) as (c & EQ1 & EQ2 & Hc). + simpl in EQ1; rewrite add_0_r in EQ1. rewrite EQ1. + autorewrite with bitwise. f_equal. + rewrite one_succ, <- div2_bits, EQ2. + autorewrite with bitwise. + rewrite Hc. simpl. apply orb_false_r. +Qed. + +(** In an addition, there will be no carries iff there is + no common bits in the numbers to add *) + +Lemma nocarry_equiv : forall a b c, + c/2 == lnextcarry a b c -> c.[0] = false -> + (c == 0 <-> land a b == 0). +Proof. + intros a b c H H'. + split. intros EQ; rewrite EQ in *. + rewrite div_0_l in H by order'. + symmetry in H. now apply lor_eq_0_l in H. + intros EQ. rewrite EQ, lor_0_l in H. + apply bits_inj_0. + induct n. trivial. + intros n IH. + rewrite <- div2_bits, H. + autorewrite with bitwise. + now rewrite IH. +Qed. + +(** When there is no common bits, the addition is just a xor *) + +Lemma add_nocarry_lxor : forall a b, land a b == 0 -> + a+b == lxor a b. +Proof. + intros a b H. + destruct (add_carry_bits a b false) as (c & EQ1 & EQ2 & Hc). + simpl in EQ1; rewrite add_0_r in EQ1. rewrite EQ1. + apply (nocarry_equiv a b c) in H; trivial. + rewrite H. now rewrite lxor_0_r. +Qed. + +(** A null [ldiff] implies being smaller *) + +Lemma ldiff_le : forall a b, ldiff a b == 0 -> a <= b. +Proof. + cut (forall n a b, a < 2^n -> ldiff a b == 0 -> a <= b). + intros H a b. apply (H a), pow_gt_lin_r; order'. + induct n. + intros a b Ha _. rewrite pow_0_r, one_succ, lt_succ_r in Ha. + assert (Ha' : a == 0) by (generalize (le_0_l a); order'). + rewrite Ha'. apply le_0_l. + intros n IH a b Ha H. + assert (NEQ : 2 ~= 0) by order'. + rewrite (div_mod a 2 NEQ), (div_mod b 2 NEQ). + apply add_le_mono. + apply mul_le_mono_l. + apply IH. + apply div_lt_upper_bound; trivial. now rewrite <- pow_succ_r'. + rewrite <- (pow_1_r 2), <- 2 shiftr_div_pow2. + now rewrite <- shiftr_ldiff, H, shiftr_div_pow2, pow_1_r, div_0_l. + rewrite <- 2 bit0_mod. + apply bits_inj_iff in H. specialize (H 0). + rewrite ldiff_spec, bits_0 in H. + destruct a.[0], b.[0]; try discriminate; simpl; order'. +Qed. + +(** Subtraction can be a ldiff when the opposite ldiff is null. *) + +Lemma sub_nocarry_ldiff : forall a b, ldiff b a == 0 -> + a-b == ldiff a b. +Proof. + intros a b H. + apply add_cancel_r with b. + rewrite sub_add. + symmetry. + rewrite add_nocarry_lxor. + bitwise. + apply bits_inj_iff in H. specialize (H m). + rewrite ldiff_spec, bits_0 in H. + now destruct a.[m], b.[m]. + apply land_ldiff. + now apply ldiff_le. +Qed. + +(** We can express lnot in term of subtraction *) + +Lemma add_lnot_diag_low : forall a n, log2 a < n -> + a + lnot a n == ones n. +Proof. + intros a n H. + assert (H' := land_lnot_diag_low a n H). + rewrite add_nocarry_lxor, lxor_lor by trivial. + now apply lor_lnot_diag_low. +Qed. + +Lemma lnot_sub_low : forall a n, log2 a < n -> + lnot a n == ones n - a. +Proof. + intros a n H. + now rewrite <- (add_lnot_diag_low a n H), add_comm, add_sub. +Qed. + +(** Adding numbers with no common bits cannot lead to a much bigger number *) + +Lemma add_nocarry_lt_pow2 : forall a b n, land a b == 0 -> + a < 2^n -> b < 2^n -> a+b < 2^n. +Proof. + intros a b n H Ha Hb. + rewrite add_nocarry_lxor by trivial. + apply div_small_iff. order_nz. + rewrite <- shiftr_div_pow2, shiftr_lxor, !shiftr_div_pow2. + rewrite 2 div_small by trivial. + apply lxor_0_l. +Qed. + +Lemma add_nocarry_mod_lt_pow2 : forall a b n, land a b == 0 -> + a mod 2^n + b mod 2^n < 2^n. +Proof. + intros a b n H. + apply add_nocarry_lt_pow2. + bitwise. + destruct (le_gt_cases n m). + now rewrite mod_pow2_bits_high. + now rewrite !mod_pow2_bits_low, <- land_spec, H, bits_0. + apply mod_upper_bound; order_nz. + apply mod_upper_bound; order_nz. +Qed. + +End NBitsProp. diff --git a/theories/Numbers/Natural/Abstract/NDefOps.v b/theories/Numbers/Natural/Abstract/NDefOps.v new file mode 100644 index 0000000000..4539dea276 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NDefOps.v @@ -0,0 +1,441 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Import Bool. (* To get the orb and negb function *) +Require Import RelationPairs. +Require Export NStrongRec. + +(** In this module, we derive generic implementations of usual operators + just via the use of a [recursion] function. *) + +Module NdefOpsProp (Import N : NAxiomsRecSig'). +Include NStrongRecProp N. + +(** Nullity Test *) + +Definition if_zero (A : Type) (a b : A) (n : N.t) : A := + recursion a (fun _ _ => b) n. + +Arguments if_zero [A] a b n. + +Instance if_zero_wd (A : Type) : + Proper (Logic.eq ==> Logic.eq ==> N.eq ==> Logic.eq) (@if_zero A). +Proof. +unfold if_zero. (* TODO : solve_proper : SLOW + BUG *) +f_equiv'. +Qed. + +Theorem if_zero_0 : forall (A : Type) (a b : A), if_zero a b 0 = a. +Proof. +unfold if_zero; intros; now rewrite recursion_0. +Qed. + +Theorem if_zero_succ : + forall (A : Type) (a b : A) (n : N.t), if_zero a b (S n) = b. +Proof. +intros; unfold if_zero. +now rewrite recursion_succ. +Qed. + +(*****************************************************) +(** Addition *) + +Definition def_add (x y : N.t) := recursion y (fun _ => S) x. + +Local Infix "+++" := def_add (at level 50, left associativity). + +Instance def_add_wd : Proper (N.eq ==> N.eq ==> N.eq) def_add. +Proof. +unfold def_add. f_equiv'. +Qed. + +Theorem def_add_0_l : forall y, 0 +++ y == y. +Proof. +intro y. unfold def_add. now rewrite recursion_0. +Qed. + +Theorem def_add_succ_l : forall x y, S x +++ y == S (x +++ y). +Proof. +intros x y; unfold def_add. +rewrite recursion_succ; f_equiv'. +Qed. + +Theorem def_add_add : forall n m, n +++ m == n + m. +Proof. +intros n m; induct n. +now rewrite def_add_0_l, add_0_l. +intros n H. now rewrite def_add_succ_l, add_succ_l, H. +Qed. + +(*****************************************************) +(** Multiplication *) + +Definition def_mul (x y : N.t) := recursion 0 (fun _ p => p +++ x) y. + +Local Infix "**" := def_mul (at level 40, left associativity). + +Instance def_mul_wd : Proper (N.eq ==> N.eq ==> N.eq) def_mul. +Proof. +unfold def_mul. (* TODO : solve_proper SLOW + BUG *) +f_equiv'. +Qed. + +Theorem def_mul_0_r : forall x, x ** 0 == 0. +Proof. +intro. unfold def_mul. now rewrite recursion_0. +Qed. + +Theorem def_mul_succ_r : forall x y, x ** S y == x ** y +++ x. +Proof. +intros x y; unfold def_mul. +rewrite recursion_succ; auto with *. +f_equiv'. +Qed. + +Theorem def_mul_mul : forall n m, n ** m == n * m. +Proof. +intros n m; induct m. +now rewrite def_mul_0_r, mul_0_r. +intros m IH; now rewrite def_mul_succ_r, mul_succ_r, def_add_add, IH. +Qed. + +(*****************************************************) +(** Order *) + +Definition ltb (m : N.t) : N.t -> bool := +recursion + (if_zero false true) + (fun _ f n => recursion false (fun n' _ => f n') n) + m. + +Local Infix "<<" := ltb (at level 70, no associativity). + +Instance ltb_wd : Proper (N.eq ==> N.eq ==> Logic.eq) ltb. +Proof. +unfold ltb. f_equiv'. +Qed. + +Theorem ltb_base : forall n, 0 << n = if_zero false true n. +Proof. +intro n; unfold ltb; now rewrite recursion_0. +Qed. + +Theorem ltb_step : + forall m n, S m << n = recursion false (fun n' _ => m << n') n. +Proof. +intros m n; unfold ltb at 1. +f_equiv. +rewrite recursion_succ; f_equiv'. +Qed. + +(* Above, we rewrite applications of function. Is it possible to rewrite +functions themselves, i.e., rewrite (recursion lt_base lt_step (S n)) to +lt_step n (recursion lt_base lt_step n)? *) + +Theorem ltb_0 : forall n, n << 0 = false. +Proof. +cases n. +rewrite ltb_base; now rewrite if_zero_0. +intro n; rewrite ltb_step. now rewrite recursion_0. +Qed. + +Theorem ltb_0_succ : forall n, 0 << S n = true. +Proof. +intro n; rewrite ltb_base; now rewrite if_zero_succ. +Qed. + +Theorem succ_ltb_mono : forall n m, (S n << S m) = (n << m). +Proof. +intros n m. +rewrite ltb_step. rewrite recursion_succ; f_equiv'. +Qed. + +Theorem ltb_lt : forall n m, n << m = true <-> n < m. +Proof. +double_induct n m. +cases m. +rewrite ltb_0. split; intro H; [discriminate H | false_hyp H nlt_0_r]. +intro n. rewrite ltb_0_succ. split; intro; [apply lt_0_succ | reflexivity]. +intro n. rewrite ltb_0. split; intro H; [discriminate | false_hyp H nlt_0_r]. +intros n m. rewrite succ_ltb_mono. now rewrite <- succ_lt_mono. +Qed. + +Theorem ltb_ge : forall n m, n << m = false <-> n >= m. +Proof. +intros. rewrite <- not_true_iff_false, ltb_lt. apply nlt_ge. +Qed. + +(*****************************************************) +(** Even *) + +Definition even (x : N.t) := recursion true (fun _ p => negb p) x. + +Instance even_wd : Proper (N.eq==>Logic.eq) even. +Proof. +unfold even. f_equiv'. +Qed. + +Theorem even_0 : even 0 = true. +Proof. +unfold even. +now rewrite recursion_0. +Qed. + +Theorem even_succ : forall x, even (S x) = negb (even x). +Proof. +unfold even. +intro x; rewrite recursion_succ; f_equiv'. +Qed. + +(*****************************************************) +(** Division by 2 *) + +Definition half_aux (x : N.t) : N.t * N.t := + recursion (0, 0) (fun _ p => let (x1, x2) := p in (S x2, x1)) x. + +Definition half (x : N.t) := snd (half_aux x). + +Instance half_aux_wd : Proper (N.eq ==> N.eq*N.eq) half_aux. +Proof. +intros x x' Hx. unfold half_aux. +f_equiv; trivial. +intros y y' Hy (u,v) (u',v') (Hu,Hv). compute in *. +rewrite Hu, Hv; auto with *. +Qed. + +Instance half_wd : Proper (N.eq==>N.eq) half. +Proof. +unfold half. f_equiv'. +Qed. + +Lemma half_aux_0 : half_aux 0 = (0,0). +Proof. +unfold half_aux. rewrite recursion_0; auto. +Qed. + +Lemma half_aux_succ : forall x, + half_aux (S x) = (S (snd (half_aux x)), fst (half_aux x)). +Proof. +intros. +remember (half_aux x) as h. +destruct h as (f,s); simpl in *. +unfold half_aux in *. +rewrite recursion_succ, <- Heqh; simpl; f_equiv'. +Qed. + +Theorem half_aux_spec : forall n, + n == fst (half_aux n) + snd (half_aux n). +Proof. +apply induction. +intros x x' Hx. setoid_rewrite Hx; auto with *. +rewrite half_aux_0; simpl; rewrite add_0_l; auto with *. +intros. +rewrite half_aux_succ. simpl. +rewrite add_succ_l, add_comm; auto. +now f_equiv. +Qed. + +Theorem half_aux_spec2 : forall n, + fst (half_aux n) == snd (half_aux n) \/ + fst (half_aux n) == S (snd (half_aux n)). +Proof. +apply induction. +intros x x' Hx. setoid_rewrite Hx; auto with *. +rewrite half_aux_0; simpl. auto with *. +intros. +rewrite half_aux_succ; simpl. +destruct H; auto with *. +right; now f_equiv. +Qed. + +Theorem half_0 : half 0 == 0. +Proof. +unfold half. rewrite half_aux_0; simpl; auto with *. +Qed. + +Theorem half_1 : half 1 == 0. +Proof. +unfold half. rewrite one_succ, half_aux_succ, half_aux_0; simpl; auto with *. +Qed. + +Theorem half_double : forall n, + n == 2 * half n \/ n == 1 + 2 * half n. +Proof. +intros. unfold half. +nzsimpl'. +destruct (half_aux_spec2 n) as [H|H]; [left|right]. +rewrite <- H at 1. apply half_aux_spec. +rewrite <- add_succ_l. rewrite <- H at 1. apply half_aux_spec. +Qed. + +Theorem half_upper_bound : forall n, 2 * half n <= n. +Proof. +intros. +destruct (half_double n) as [E|E]; rewrite E at 2. +apply le_refl. +nzsimpl. +apply le_le_succ_r, le_refl. +Qed. + +Theorem half_lower_bound : forall n, n <= 1 + 2 * half n. +Proof. +intros. +destruct (half_double n) as [E|E]; rewrite E at 1. +nzsimpl. +apply le_le_succ_r, le_refl. +apply le_refl. +Qed. + +Theorem half_nz : forall n, 1 < n -> 0 < half n. +Proof. +intros n LT. +assert (LE : 0 <= half n) by apply le_0_l. +le_elim LE; auto. +destruct (half_double n) as [E|E]; + rewrite <- LE, mul_0_r, ?add_0_r in E; rewrite E in LT. +order'. +order. +Qed. + +Theorem half_decrease : forall n, 0 < n -> half n < n. +Proof. +intros n LT. +destruct (half_double n) as [E|E]; rewrite E at 2; nzsimpl'. +rewrite <- add_0_l at 1. +rewrite <- add_lt_mono_r. +assert (LE : 0 <= half n) by apply le_0_l. +le_elim LE; auto. +rewrite <- LE, mul_0_r in E. rewrite E in LT. destruct (nlt_0_r _ LT). +rewrite <- add_succ_l. +rewrite <- add_0_l at 1. +rewrite <- add_lt_mono_r. +apply lt_0_succ. +Qed. + + +(*****************************************************) +(** Power *) + +Definition pow (n m : N.t) := recursion 1 (fun _ r => n*r) m. + +Local Infix "^^" := pow (at level 30, right associativity). + +Instance pow_wd : Proper (N.eq==>N.eq==>N.eq) pow. +Proof. +unfold pow. f_equiv'. +Qed. + +Lemma pow_0 : forall n, n^^0 == 1. +Proof. +intros. unfold pow. rewrite recursion_0. auto with *. +Qed. + +Lemma pow_succ : forall n m, n^^(S m) == n*(n^^m). +Proof. +intros. unfold pow. rewrite recursion_succ; f_equiv'. +Qed. + + +(*****************************************************) +(** Logarithm for the base 2 *) + +Definition log (x : N.t) : N.t := +strong_rec 0 + (fun g x => + if x << 2 then 0 + else S (g (half x))) + x. + +Instance log_prewd : + Proper ((N.eq==>N.eq)==>N.eq==>N.eq) + (fun g x => if x<<2 then 0 else S (g (half x))). +Proof. +intros g g' Hg n n' Hn. +rewrite Hn. +destruct (n' << 2); auto with *. +f_equiv. apply Hg. now f_equiv. +Qed. + +Instance log_wd : Proper (N.eq==>N.eq) log. +Proof. +intros x x' Exx'. unfold log. +apply strong_rec_wd; f_equiv'. +Qed. + +Lemma log_good_step : forall n h1 h2, + (forall m, m < n -> h1 m == h2 m) -> + (if n << 2 then 0 else S (h1 (half n))) == + (if n << 2 then 0 else S (h2 (half n))). +Proof. +intros n h1 h2 E. +destruct (n<<2) eqn:H. +auto with *. +f_equiv. apply E, half_decrease. +rewrite two_succ, <- not_true_iff_false, ltb_lt, nlt_ge, le_succ_l in H. +order'. +Qed. +Hint Resolve log_good_step : core. + +Theorem log_init : forall n, n < 2 -> log n == 0. +Proof. +intros n Hn. unfold log. rewrite strong_rec_fixpoint; auto with *. +replace (n << 2) with true; auto with *. +symmetry. now rewrite ltb_lt. +Qed. + +Theorem log_step : forall n, 2 <= n -> log n == S (log (half n)). +Proof. +intros n Hn. unfold log. rewrite strong_rec_fixpoint; auto with *. +replace (n << 2) with false; auto with *. +symmetry. rewrite <- not_true_iff_false, ltb_lt, nlt_ge; auto. +Qed. + +Theorem pow2_log : forall n, 0 < n -> half n < 2^^(log n) <= n. +Proof. +intro n; generalize (le_refl n). set (k:=n) at -2. clearbody k. +revert k. pattern n. apply induction; clear n. +intros n n' Hn; setoid_rewrite Hn; auto with *. +intros k Hk1 Hk2. + le_elim Hk1. destruct (nlt_0_r _ Hk1). + rewrite Hk1 in Hk2. destruct (nlt_0_r _ Hk2). + +intros n IH k Hk1 Hk2. +destruct (lt_ge_cases k 2) as [LT|LE]. +(* base *) +rewrite log_init, pow_0 by auto. +rewrite <- le_succ_l, <- one_succ in Hk2. +le_elim Hk2. +rewrite two_succ, <- nle_gt, le_succ_l in LT. destruct LT; auto. +rewrite <- Hk2. +rewrite half_1; auto using lt_0_1, le_refl. +(* step *) +rewrite log_step, pow_succ by auto. +rewrite two_succ, le_succ_l in LE. +destruct (IH (half k)) as (IH1,IH2). + rewrite <- lt_succ_r. apply lt_le_trans with k; auto. + now apply half_decrease. + apply half_nz; auto. +set (K:=2^^log (half k)) in *; clearbody K. +split. +rewrite <- le_succ_l in IH1. +apply mul_le_mono_l with (p:=2) in IH1. +eapply lt_le_trans; eauto. +nzsimpl'. +rewrite lt_succ_r. +eapply le_trans; [ eapply half_lower_bound | ]. +nzsimpl'; apply le_refl. +eapply le_trans; [ | eapply half_upper_bound ]. +apply mul_le_mono_l; auto. +Qed. + +End NdefOpsProp. + diff --git a/theories/Numbers/Natural/Abstract/NDiv.v b/theories/Numbers/Natural/Abstract/NDiv.v new file mode 100644 index 0000000000..4c26a071f0 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NDiv.v @@ -0,0 +1,243 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import NAxioms NSub NZDiv. + +(** Properties of Euclidean Division *) + +Module Type NDivProp (Import N : NAxiomsSig')(Import NP : NSubProp N). + +(** We benefit from what already exists for NZ *) +Module Import Private_NZDiv := Nop <+ NZDivProp N N NP. + +Ltac auto' := try rewrite <- neq_0_lt_0; auto using le_0_l. + +(** Let's now state again theorems, but without useless hypothesis. *) + +Lemma mod_upper_bound : forall a b, b ~= 0 -> a mod b < b. +Proof. intros. apply mod_bound_pos; auto'. Qed. + +(** Another formulation of the main equation *) + +Lemma mod_eq : + forall a b, b~=0 -> a mod b == a - b*(a/b). +Proof. +intros. +symmetry. apply add_sub_eq_l. symmetry. +now apply div_mod. +Qed. + +(** Uniqueness theorems *) + +Theorem div_mod_unique : + forall b q1 q2 r1 r2, r1<b -> r2<b -> + b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. +Proof. intros. apply div_mod_unique with b; auto'. Qed. + +Theorem div_unique: + forall a b q r, r<b -> a == b*q + r -> q == a/b. +Proof. intros; apply div_unique with r; auto'. Qed. + +Theorem mod_unique: + forall a b q r, r<b -> a == b*q + r -> r == a mod b. +Proof. intros. apply mod_unique with q; auto'. Qed. + +Theorem div_unique_exact: forall a b q, b~=0 -> a == b*q -> q == a/b. +Proof. intros. apply div_unique_exact; auto'. Qed. + +(** A division by itself returns 1 *) + +Lemma div_same : forall a, a~=0 -> a/a == 1. +Proof. intros. apply div_same; auto'. Qed. + +Lemma mod_same : forall a, a~=0 -> a mod a == 0. +Proof. intros. apply mod_same; auto'. Qed. + +(** A division of a small number by a bigger one yields zero. *) + +Theorem div_small: forall a b, a<b -> a/b == 0. +Proof. intros. apply div_small; auto'. Qed. + +(** Same situation, in term of modulo: *) + +Theorem mod_small: forall a b, a<b -> a mod b == a. +Proof. intros. apply mod_small; auto'. Qed. + +(** * Basic values of divisions and modulo. *) + +Lemma div_0_l: forall a, a~=0 -> 0/a == 0. +Proof. intros. apply div_0_l; auto'. Qed. + +Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0. +Proof. intros. apply mod_0_l; auto'. Qed. + +Lemma div_1_r: forall a, a/1 == a. +Proof. intros. apply div_1_r; auto'. Qed. + +Lemma mod_1_r: forall a, a mod 1 == 0. +Proof. intros. apply mod_1_r; auto'. Qed. + +Lemma div_1_l: forall a, 1<a -> 1/a == 0. +Proof. exact div_1_l. Qed. + +Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1. +Proof. exact mod_1_l. Qed. + +Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a. +Proof. intros. apply div_mul; auto'. Qed. + +Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0. +Proof. intros. apply mod_mul; auto'. Qed. + + +(** * Order results about mod and div *) + +(** A modulo cannot grow beyond its starting point. *) + +Theorem mod_le: forall a b, b~=0 -> a mod b <= a. +Proof. intros. apply mod_le; auto'. Qed. + +Lemma div_str_pos : forall a b, 0<b<=a -> 0 < a/b. +Proof. exact div_str_pos. Qed. + +Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> a<b). +Proof. intros. apply div_small_iff; auto'. Qed. + +Lemma mod_small_iff : forall a b, b~=0 -> (a mod b == a <-> a<b). +Proof. intros. apply mod_small_iff; auto'. Qed. + +Lemma div_str_pos_iff : forall a b, b~=0 -> (0<a/b <-> b<=a). +Proof. intros. apply div_str_pos_iff; auto'. Qed. + + +(** As soon as the divisor is strictly greater than 1, + the division is strictly decreasing. *) + +Lemma div_lt : forall a b, 0<a -> 1<b -> a/b < a. +Proof. exact div_lt. Qed. + +(** [le] is compatible with a positive division. *) + +Lemma div_le_mono : forall a b c, c~=0 -> a<=b -> a/c <= b/c. +Proof. intros. apply div_le_mono; auto'. Qed. + +Lemma mul_div_le : forall a b, b~=0 -> b*(a/b) <= a. +Proof. intros. apply mul_div_le; auto'. Qed. + +Lemma mul_succ_div_gt: forall a b, b~=0 -> a < b*(S (a/b)). +Proof. intros; apply mul_succ_div_gt; auto'. Qed. + +(** The previous inequality is exact iff the modulo is zero. *) + +Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0). +Proof. intros. apply div_exact; auto'. Qed. + +(** Some additional inequalities about div. *) + +Theorem div_lt_upper_bound: + forall a b q, b~=0 -> a < b*q -> a/b < q. +Proof. intros. apply div_lt_upper_bound; auto'. Qed. + +Theorem div_le_upper_bound: + forall a b q, b~=0 -> a <= b*q -> a/b <= q. +Proof. intros; apply div_le_upper_bound; auto'. Qed. + +Theorem div_le_lower_bound: + forall a b q, b~=0 -> b*q <= a -> q <= a/b. +Proof. intros; apply div_le_lower_bound; auto'. Qed. + +(** A division respects opposite monotonicity for the divisor *) + +Lemma div_le_compat_l: forall p q r, 0<q<=r -> p/r <= p/q. +Proof. intros. apply div_le_compat_l. auto'. auto. Qed. + +(** * Relations between usual operations and mod and div *) + +Lemma mod_add : forall a b c, c~=0 -> + (a + b * c) mod c == a mod c. +Proof. intros. apply mod_add; auto'. Qed. + +Lemma div_add : forall a b c, c~=0 -> + (a + b * c) / c == a / c + b. +Proof. intros. apply div_add; auto'. Qed. + +Lemma div_add_l: forall a b c, b~=0 -> + (a * b + c) / b == a + c / b. +Proof. intros. apply div_add_l; auto'. Qed. + +(** Cancellations. *) + +Lemma div_mul_cancel_r : forall a b c, b~=0 -> c~=0 -> + (a*c)/(b*c) == a/b. +Proof. intros. apply div_mul_cancel_r; auto'. Qed. + +Lemma div_mul_cancel_l : forall a b c, b~=0 -> c~=0 -> + (c*a)/(c*b) == a/b. +Proof. intros. apply div_mul_cancel_l; auto'. Qed. + +Lemma mul_mod_distr_r: forall a b c, b~=0 -> c~=0 -> + (a*c) mod (b*c) == (a mod b) * c. +Proof. intros. apply mul_mod_distr_r; auto'. Qed. + +Lemma mul_mod_distr_l: forall a b c, b~=0 -> c~=0 -> + (c*a) mod (c*b) == c * (a mod b). +Proof. intros. apply mul_mod_distr_l; auto'. Qed. + +(** Operations modulo. *) + +Theorem mod_mod: forall a n, n~=0 -> + (a mod n) mod n == a mod n. +Proof. intros. apply mod_mod; auto'. Qed. + +Lemma mul_mod_idemp_l : forall a b n, n~=0 -> + ((a mod n)*b) mod n == (a*b) mod n. +Proof. intros. apply mul_mod_idemp_l; auto'. Qed. + +Lemma mul_mod_idemp_r : forall a b n, n~=0 -> + (a*(b mod n)) mod n == (a*b) mod n. +Proof. intros. apply mul_mod_idemp_r; auto'. Qed. + +Theorem mul_mod: forall a b n, n~=0 -> + (a * b) mod n == ((a mod n) * (b mod n)) mod n. +Proof. intros. apply mul_mod; auto'. Qed. + +Lemma add_mod_idemp_l : forall a b n, n~=0 -> + ((a mod n)+b) mod n == (a+b) mod n. +Proof. intros. apply add_mod_idemp_l; auto'. Qed. + +Lemma add_mod_idemp_r : forall a b n, n~=0 -> + (a+(b mod n)) mod n == (a+b) mod n. +Proof. intros. apply add_mod_idemp_r; auto'. Qed. + +Theorem add_mod: forall a b n, n~=0 -> + (a+b) mod n == (a mod n + b mod n) mod n. +Proof. intros. apply add_mod; auto'. Qed. + +Lemma div_div : forall a b c, b~=0 -> c~=0 -> + (a/b)/c == a/(b*c). +Proof. intros. apply div_div; auto'. Qed. + +Lemma mod_mul_r : forall a b c, b~=0 -> c~=0 -> + a mod (b*c) == a mod b + b*((a/b) mod c). +Proof. intros. apply mod_mul_r; auto'. Qed. + +(** A last inequality: *) + +Theorem div_mul_le: + forall a b c, b~=0 -> c*(a/b) <= (c*a)/b. +Proof. intros. apply div_mul_le; auto'. Qed. + +(** mod is related to divisibility *) + +Lemma mod_divides : forall a b, b~=0 -> + (a mod b == 0 <-> exists c, a == b*c). +Proof. intros. apply mod_divides; auto'. Qed. + +End NDivProp. diff --git a/theories/Numbers/Natural/Abstract/NGcd.v b/theories/Numbers/Natural/Abstract/NGcd.v new file mode 100644 index 0000000000..96fb4247cc --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NGcd.v @@ -0,0 +1,215 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Properties of the greatest common divisor *) + +Require Import NAxioms NSub NZGcd. + +Module Type NGcdProp + (Import A : NAxiomsSig') + (Import B : NSubProp A). + + Include NZGcdProp A A B. + +(** Results concerning divisibility*) + +Definition divide_1_r n : (n | 1) -> n == 1 + := divide_1_r_nonneg n (le_0_l n). + +Definition divide_antisym n m : (n | m) -> (m | n) -> n == m + := divide_antisym_nonneg n m (le_0_l n) (le_0_l m). + +Lemma divide_add_cancel_r : forall n m p, (n | m) -> (n | m + p) -> (n | p). +Proof. + intros n m p (q,Hq) (r,Hr). + exists (r-q). rewrite mul_sub_distr_r, <- Hq, <- Hr. + now rewrite add_comm, add_sub. +Qed. + +Lemma divide_sub_r : forall n m p, (n | m) -> (n | p) -> (n | m - p). +Proof. + intros n m p H H'. + destruct (le_ge_cases m p) as [LE|LE]. + apply sub_0_le in LE. rewrite LE. apply divide_0_r. + apply divide_add_cancel_r with p; trivial. + now rewrite add_comm, sub_add. +Qed. + +(** Properties of gcd *) + +Definition gcd_0_l n : gcd 0 n == n := gcd_0_l_nonneg n (le_0_l n). +Definition gcd_0_r n : gcd n 0 == n := gcd_0_r_nonneg n (le_0_l n). +Definition gcd_diag n : gcd n n == n := gcd_diag_nonneg n (le_0_l n). +Definition gcd_unique' n m p := gcd_unique n m p (le_0_l p). +Definition gcd_unique_alt' n m p := gcd_unique_alt n m p (le_0_l p). +Definition divide_gcd_iff' n m := divide_gcd_iff n m (le_0_l n). + +Lemma gcd_add_mult_diag_r : forall n m p, gcd n (m+p*n) == gcd n m. +Proof. + intros. apply gcd_unique_alt'. + intros. rewrite gcd_divide_iff. split; intros (U,V); split; trivial. + apply divide_add_r; trivial. now apply divide_mul_r. + apply divide_add_cancel_r with (p*n); trivial. + now apply divide_mul_r. now rewrite add_comm. +Qed. + +Lemma gcd_add_diag_r : forall n m, gcd n (m+n) == gcd n m. +Proof. + intros n m. rewrite <- (mul_1_l n) at 2. apply gcd_add_mult_diag_r. +Qed. + +Lemma gcd_sub_diag_r : forall n m, n<=m -> gcd n (m-n) == gcd n m. +Proof. + intros n m H. symmetry. + rewrite <- (sub_add n m H) at 1. apply gcd_add_diag_r. +Qed. + +(** On natural numbers, we should use a particular form + for the Bezout identity, since we don't have full subtraction. *) + +Definition Bezout n m p := exists a b, a*n == p + b*m. + +Instance Bezout_wd : Proper (eq==>eq==>eq==>iff) Bezout. +Proof. + unfold Bezout. intros x x' Hx y y' Hy z z' Hz. + setoid_rewrite Hx. setoid_rewrite Hy. now setoid_rewrite Hz. +Qed. + +Lemma bezout_1_gcd : forall n m, Bezout n m 1 -> gcd n m == 1. +Proof. + intros n m (q & r & H). + apply gcd_unique; trivial using divide_1_l, le_0_1. + intros p Hn Hm. + apply divide_add_cancel_r with (r*m). + now apply divide_mul_r. + rewrite add_comm, <- H. now apply divide_mul_r. +Qed. + +(** For strictly positive numbers, we have Bezout in the two directions. *) + +Lemma gcd_bezout_pos_pos : forall n, 0<n -> forall m, 0<m -> + Bezout n m (gcd n m) /\ Bezout m n (gcd n m). +Proof. + intros n Hn. rewrite <- le_succ_l, <- one_succ in Hn. + pattern n. apply strong_right_induction with (z:=1); trivial. + unfold Bezout. solve_proper. + clear n Hn. intros n Hn IHn. + intros m Hm. rewrite <- le_succ_l, <- one_succ in Hm. + pattern m. apply strong_right_induction with (z:=1); trivial. + unfold Bezout. solve_proper. + clear m Hm. intros m Hm IHm. + destruct (lt_trichotomy n m) as [LT|[EQ|LT]]. + (* n < m *) + destruct (IHm (m-n)) as ((a & b & EQ), (a' & b' & EQ')). + rewrite one_succ, le_succ_l. + apply lt_add_lt_sub_l; now nzsimpl. + apply sub_lt; order'. + split. + exists (a+b). exists b. + rewrite mul_add_distr_r, EQ, mul_sub_distr_l, <- add_assoc. + rewrite gcd_sub_diag_r by order. + rewrite sub_add. reflexivity. apply mul_le_mono_l; order. + exists a'. exists (a'+b'). + rewrite gcd_sub_diag_r in EQ' by order. + rewrite (add_comm a'), mul_add_distr_r, add_assoc, <- EQ'. + rewrite mul_sub_distr_l, sub_add. reflexivity. apply mul_le_mono_l; order. + (* n = m *) + rewrite EQ. rewrite gcd_diag. + split. + exists 1. exists 0. now nzsimpl. + exists 1. exists 0. now nzsimpl. + (* m < n *) + rewrite gcd_comm, and_comm. + apply IHn; trivial. + now rewrite <- le_succ_l, <- one_succ. +Qed. + +Lemma gcd_bezout_pos : forall n m, 0<n -> Bezout n m (gcd n m). +Proof. + intros n m Hn. + destruct (eq_0_gt_0_cases m) as [EQ|LT]. + rewrite EQ, gcd_0_r. exists 1. exists 0. now nzsimpl. + now apply gcd_bezout_pos_pos. +Qed. + +(** For arbitrary natural numbers, we could only say that at least + one of the Bezout identities holds. *) + +Lemma gcd_bezout : forall n m, + Bezout n m (gcd n m) \/ Bezout m n (gcd n m). +Proof. + intros n m. + destruct (eq_0_gt_0_cases n) as [EQ|LT]. + right. rewrite EQ, gcd_0_l. exists 1. exists 0. now nzsimpl. + left. now apply gcd_bezout_pos. +Qed. + +Lemma gcd_mul_mono_l : + forall n m p, gcd (p * n) (p * m) == p * gcd n m. +Proof. + intros n m p. + apply gcd_unique'. + apply mul_divide_mono_l, gcd_divide_l. + apply mul_divide_mono_l, gcd_divide_r. + intros q H H'. + destruct (eq_0_gt_0_cases n) as [EQ|LT]. + rewrite EQ in *. now rewrite gcd_0_l. + destruct (gcd_bezout_pos n m) as (a & b & EQ); trivial. + apply divide_add_cancel_r with (p*m*b). + now apply divide_mul_l. + rewrite <- mul_assoc, <- mul_add_distr_l, add_comm, (mul_comm m), <- EQ. + rewrite (mul_comm a), mul_assoc. + now apply divide_mul_l. +Qed. + +Lemma gcd_mul_mono_r : + forall n m p, gcd (n*p) (m*p) == gcd n m * p. +Proof. + intros. rewrite !(mul_comm _ p). apply gcd_mul_mono_l. +Qed. + +Lemma gauss : forall n m p, (n | m * p) -> gcd n m == 1 -> (n | p). +Proof. + intros n m p H G. + destruct (eq_0_gt_0_cases n) as [EQ|LT]. + rewrite EQ in *. rewrite gcd_0_l in G. now rewrite <- (mul_1_l p), <- G. + destruct (gcd_bezout_pos n m) as (a & b & EQ); trivial. + rewrite G in EQ. + apply divide_add_cancel_r with (m*p*b). + now apply divide_mul_l. + rewrite (mul_comm _ b), mul_assoc. rewrite <- (mul_1_l p) at 2. + rewrite <- mul_add_distr_r, add_comm, <- EQ. + now apply divide_mul_l, divide_factor_r. +Qed. + +Lemma divide_mul_split : forall n m p, n ~= 0 -> (n | m * p) -> + exists q r, n == q*r /\ (q | m) /\ (r | p). +Proof. + intros n m p Hn H. + assert (G := gcd_nonneg n m). le_elim G. + destruct (gcd_divide_l n m) as (q,Hq). + exists (gcd n m). exists q. + split. now rewrite mul_comm. + split. apply gcd_divide_r. + destruct (gcd_divide_r n m) as (r,Hr). + rewrite Hr in H. rewrite Hq in H at 1. + rewrite mul_shuffle0 in H. apply mul_divide_cancel_r in H; [|order]. + apply gauss with r; trivial. + apply mul_cancel_r with (gcd n m); [order|]. + rewrite mul_1_l. + rewrite <- gcd_mul_mono_r, <- Hq, <- Hr; order. + symmetry in G. apply gcd_eq_0 in G. destruct G as (Hn',_); order. +Qed. + +(** TODO : relation between gcd and division and modulo *) + +(** TODO : more about rel_prime (i.e. gcd == 1), about prime ... *) + +End NGcdProp. diff --git a/theories/Numbers/Natural/Abstract/NIso.v b/theories/Numbers/Natural/Abstract/NIso.v new file mode 100644 index 0000000000..d41d0aff56 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NIso.v @@ -0,0 +1,101 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Import NBase. + +Module Homomorphism (N1 N2 : NAxiomsRecSig). + +Local Notation "n == m" := (N2.eq n m) (at level 70, no associativity). + +Definition homomorphism (f : N1.t -> N2.t) : Prop := + f N1.zero == N2.zero /\ forall n, f (N1.succ n) == N2.succ (f n). + +Definition natural_isomorphism : N1.t -> N2.t := + N1.recursion N2.zero (fun (n : N1.t) (p : N2.t) => N2.succ p). + +Instance natural_isomorphism_wd : Proper (N1.eq ==> N2.eq) natural_isomorphism. +Proof. +unfold natural_isomorphism. +repeat red; intros. f_equiv; trivial. +repeat red; intros. now f_equiv. +Qed. + +Theorem natural_isomorphism_0 : natural_isomorphism N1.zero == N2.zero. +Proof. +unfold natural_isomorphism; now rewrite N1.recursion_0. +Qed. + +Theorem natural_isomorphism_succ : + forall n : N1.t, natural_isomorphism (N1.succ n) == N2.succ (natural_isomorphism n). +Proof. +unfold natural_isomorphism. +intro n. rewrite N1.recursion_succ; auto with *. +repeat red; intros. now f_equiv. +Qed. + +Theorem hom_nat_iso : homomorphism natural_isomorphism. +Proof. +unfold homomorphism, natural_isomorphism; split; +[exact natural_isomorphism_0 | exact natural_isomorphism_succ]. +Qed. + +End Homomorphism. + +Module Inverse (N1 N2 : NAxiomsRecSig). + +Module Import NBasePropMod1 := NBaseProp N1. +(* This makes the tactic induct available. Since it is taken from +(NBasePropFunct NAxiomsMod1), it refers to induction on N1. *) + +Module Hom12 := Homomorphism N1 N2. +Module Hom21 := Homomorphism N2 N1. + +Local Notation h12 := Hom12.natural_isomorphism. +Local Notation h21 := Hom21.natural_isomorphism. +Local Notation "n == m" := (N1.eq n m) (at level 70, no associativity). + +Lemma inverse_nat_iso : forall n : N1.t, h21 (h12 n) == n. +Proof. +induct n. +now rewrite Hom12.natural_isomorphism_0, Hom21.natural_isomorphism_0. +intros n IH. +now rewrite Hom12.natural_isomorphism_succ, Hom21.natural_isomorphism_succ, IH. +Qed. + +End Inverse. + +Module Isomorphism (N1 N2 : NAxiomsRecSig). + +Module Hom12 := Homomorphism N1 N2. +Module Hom21 := Homomorphism N2 N1. +Module Inverse12 := Inverse N1 N2. +Module Inverse21 := Inverse N2 N1. + +Local Notation h12 := Hom12.natural_isomorphism. +Local Notation h21 := Hom21.natural_isomorphism. + +Definition isomorphism (f1 : N1.t -> N2.t) (f2 : N2.t -> N1.t) : Prop := + Hom12.homomorphism f1 /\ Hom21.homomorphism f2 /\ + forall n, N1.eq (f2 (f1 n)) n /\ + forall n, N2.eq (f1 (f2 n)) n. + +Theorem iso_nat_iso : isomorphism h12 h21. +Proof. +unfold isomorphism. +split. apply Hom12.hom_nat_iso. +split. apply Hom21.hom_nat_iso. +split. apply Inverse12.inverse_nat_iso. +apply Inverse21.inverse_nat_iso. +Qed. + +End Isomorphism. + diff --git a/theories/Numbers/Natural/Abstract/NLcm.v b/theories/Numbers/Natural/Abstract/NLcm.v new file mode 100644 index 0000000000..47b74193ed --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NLcm.v @@ -0,0 +1,292 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import NAxioms NSub NDiv NGcd. + +(** * Least Common Multiple *) + +(** Unlike other functions around, we will define lcm below instead of + axiomatizing it. Indeed, there is no "prior art" about lcm in the + standard library to be compliant with, and the generic definition + of lcm via gcd is quite reasonable. + + By the way, we also state here some combined properties of div/mod + and gcd. +*) + +Module Type NLcmProp + (Import A : NAxiomsSig') + (Import B : NSubProp A) + (Import C : NDivProp A B) + (Import D : NGcdProp A B). + +(** Divibility and modulo *) + +Lemma mod_divide : forall a b, b~=0 -> (a mod b == 0 <-> (b|a)). +Proof. + intros a b Hb. split. + intros Hab. exists (a/b). rewrite mul_comm. + rewrite (div_mod a b Hb) at 1. rewrite Hab; now nzsimpl. + intros (c,Hc). rewrite Hc. now apply mod_mul. +Qed. + +Lemma divide_div_mul_exact : forall a b c, b~=0 -> (b|a) -> + (c*a)/b == c*(a/b). +Proof. + intros a b c Hb H. + apply mul_cancel_l with b; trivial. + rewrite mul_assoc, mul_shuffle0. + assert (H':=H). apply mod_divide, div_exact in H'; trivial. + rewrite <- H', (mul_comm a c). + symmetry. apply div_exact; trivial. + apply mod_divide; trivial. + now apply divide_mul_r. +Qed. + +(** Gcd of divided elements, for exact divisions *) + +Lemma gcd_div_factor : forall a b c, c~=0 -> (c|a) -> (c|b) -> + gcd (a/c) (b/c) == (gcd a b)/c. +Proof. + intros a b c Hc Ha Hb. + apply mul_cancel_l with c; try order. + assert (H:=gcd_greatest _ _ _ Ha Hb). + apply mod_divide, div_exact in H; try order. + rewrite <- H. + rewrite <- gcd_mul_mono_l; try order. + f_equiv; symmetry; apply div_exact; try order; + apply mod_divide; trivial; try order. +Qed. + +Lemma gcd_div_gcd : forall a b g, g~=0 -> g == gcd a b -> + gcd (a/g) (b/g) == 1. +Proof. + intros a b g NZ EQ. rewrite gcd_div_factor. + now rewrite <- EQ, div_same. + generalize (gcd_nonneg a b); order. + rewrite EQ; apply gcd_divide_l. + rewrite EQ; apply gcd_divide_r. +Qed. + +(** The following equality is crucial for Euclid algorithm *) + +Lemma gcd_mod : forall a b, b~=0 -> gcd (a mod b) b == gcd b a. +Proof. + intros a b Hb. rewrite (gcd_comm _ b). + rewrite <- (gcd_add_mult_diag_r b (a mod b) (a/b)). + now rewrite add_comm, mul_comm, <- div_mod. +Qed. + +(** We now define lcm thanks to gcd: + + lcm a b = a * (b / gcd a b) + = (a / gcd a b) * b + = (a*b) / gcd a b + + Nota: [lcm 0 0] should be 0, which isn't garantee with the third + equation above. +*) + +Definition lcm a b := a*(b/gcd a b). + +Instance lcm_wd : Proper (eq==>eq==>eq) lcm. +Proof. unfold lcm. solve_proper. Qed. + +Lemma lcm_equiv1 : forall a b, gcd a b ~= 0 -> + a * (b / gcd a b) == (a*b)/gcd a b. +Proof. + intros a b H. rewrite divide_div_mul_exact; try easy. apply gcd_divide_r. +Qed. + +Lemma lcm_equiv2 : forall a b, gcd a b ~= 0 -> + (a / gcd a b) * b == (a*b)/gcd a b. +Proof. + intros a b H. rewrite 2 (mul_comm _ b). + rewrite divide_div_mul_exact; try easy. apply gcd_divide_l. +Qed. + +Lemma gcd_div_swap : forall a b, + (a / gcd a b) * b == a * (b / gcd a b). +Proof. + intros a b. destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ]. + apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ, EQ'. now nzsimpl. + now rewrite lcm_equiv1, <-lcm_equiv2. +Qed. + +Lemma divide_lcm_l : forall a b, (a | lcm a b). +Proof. + unfold lcm. intros a b. apply divide_factor_l. +Qed. + +Lemma divide_lcm_r : forall a b, (b | lcm a b). +Proof. + unfold lcm. intros a b. rewrite <- gcd_div_swap. + apply divide_factor_r. +Qed. + +Lemma divide_div : forall a b c, a~=0 -> (a|b) -> (b|c) -> (b/a|c/a). +Proof. + intros a b c Ha Hb (c',Hc). exists c'. + now rewrite <- divide_div_mul_exact, Hc. +Qed. + +Lemma lcm_least : forall a b c, + (a | c) -> (b | c) -> (lcm a b | c). +Proof. + intros a b c Ha Hb. unfold lcm. + destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ]. + apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ in *. now nzsimpl. + assert (Ga := gcd_divide_l a b). + assert (Gb := gcd_divide_r a b). + set (g:=gcd a b) in *. + assert (Ha' := divide_div g a c NEQ Ga Ha). + assert (Hb' := divide_div g b c NEQ Gb Hb). + destruct Ha' as (a',Ha'). rewrite Ha', mul_comm in Hb'. + apply gauss in Hb'; [|apply gcd_div_gcd; unfold g; trivial using gcd_comm]. + destruct Hb' as (b',Hb'). + exists b'. + rewrite mul_shuffle3, <- Hb'. + rewrite (proj2 (div_exact c g NEQ)). + rewrite Ha', mul_shuffle3, (mul_comm a a'). f_equiv. + symmetry. apply div_exact; trivial. + apply mod_divide; trivial. + apply mod_divide; trivial. transitivity a; trivial. +Qed. + +Lemma lcm_comm : forall a b, lcm a b == lcm b a. +Proof. + intros a b. unfold lcm. rewrite (gcd_comm b), (mul_comm b). + now rewrite <- gcd_div_swap. +Qed. + +Lemma lcm_divide_iff : forall n m p, + (lcm n m | p) <-> (n | p) /\ (m | p). +Proof. + intros. split. split. + transitivity (lcm n m); trivial using divide_lcm_l. + transitivity (lcm n m); trivial using divide_lcm_r. + intros (H,H'). now apply lcm_least. +Qed. + +Lemma lcm_unique : forall n m p, + 0<=p -> (n|p) -> (m|p) -> + (forall q, (n|q) -> (m|q) -> (p|q)) -> + lcm n m == p. +Proof. + intros n m p Hp Hn Hm H. + apply divide_antisym; trivial. + now apply lcm_least. + apply H. apply divide_lcm_l. apply divide_lcm_r. +Qed. + +Lemma lcm_unique_alt : forall n m p, 0<=p -> + (forall q, (p|q) <-> (n|q) /\ (m|q)) -> + lcm n m == p. +Proof. + intros n m p Hp H. + apply lcm_unique; trivial. + apply H, divide_refl. + apply H, divide_refl. + intros. apply H. now split. +Qed. + +Lemma lcm_assoc : forall n m p, lcm n (lcm m p) == lcm (lcm n m) p. +Proof. + intros. apply lcm_unique_alt. apply le_0_l. + intros. now rewrite !lcm_divide_iff, and_assoc. +Qed. + +Lemma lcm_0_l : forall n, lcm 0 n == 0. +Proof. + intros. apply lcm_unique; trivial. order. + apply divide_refl. + apply divide_0_r. +Qed. + +Lemma lcm_0_r : forall n, lcm n 0 == 0. +Proof. + intros. now rewrite lcm_comm, lcm_0_l. +Qed. + +Lemma lcm_1_l : forall n, lcm 1 n == n. +Proof. + intros. apply lcm_unique; trivial using divide_1_l, le_0_l, divide_refl. +Qed. + +Lemma lcm_1_r : forall n, lcm n 1 == n. +Proof. + intros. now rewrite lcm_comm, lcm_1_l. +Qed. + +Lemma lcm_diag : forall n, lcm n n == n. +Proof. + intros. apply lcm_unique; trivial using divide_refl, le_0_l. +Qed. + +Lemma lcm_eq_0 : forall n m, lcm n m == 0 <-> n == 0 \/ m == 0. +Proof. + intros. split. + intros EQ. + apply eq_mul_0. + apply divide_0_l. rewrite <- EQ. apply lcm_least. + apply divide_factor_l. apply divide_factor_r. + destruct 1 as [EQ|EQ]; rewrite EQ. apply lcm_0_l. apply lcm_0_r. +Qed. + +Lemma divide_lcm_eq_r : forall n m, (n|m) -> lcm n m == m. +Proof. + intros n m H. apply lcm_unique_alt; trivial using le_0_l. + intros q. split. split; trivial. now transitivity m. + now destruct 1. +Qed. + +Lemma divide_lcm_iff : forall n m, (n|m) <-> lcm n m == m. +Proof. + intros n m. split. now apply divide_lcm_eq_r. + intros EQ. rewrite <- EQ. apply divide_lcm_l. +Qed. + +Lemma lcm_mul_mono_l : + forall n m p, lcm (p * n) (p * m) == p * lcm n m. +Proof. + intros n m p. + destruct (eq_decidable p 0) as [Hp|Hp]. + rewrite Hp. nzsimpl. rewrite lcm_0_l. now nzsimpl. + destruct (eq_decidable (gcd n m) 0) as [Hg|Hg]. + apply gcd_eq_0 in Hg. destruct Hg as (Hn,Hm); rewrite Hn, Hm. + nzsimpl. rewrite lcm_0_l. now nzsimpl. + unfold lcm. + rewrite gcd_mul_mono_l. + rewrite mul_assoc. f_equiv. + now rewrite div_mul_cancel_l. +Qed. + +Lemma lcm_mul_mono_r : + forall n m p, lcm (n * p) (m * p) == lcm n m * p. +Proof. + intros n m p. now rewrite !(mul_comm _ p), lcm_mul_mono_l, mul_comm. +Qed. + +Lemma gcd_1_lcm_mul : forall n m, n~=0 -> m~=0 -> + (gcd n m == 1 <-> lcm n m == n*m). +Proof. + intros n m Hn Hm. split; intros H. + unfold lcm. rewrite H. now rewrite div_1_r. + unfold lcm in *. + apply mul_cancel_l in H; trivial. + assert (Hg : gcd n m ~= 0) by (red; rewrite gcd_eq_0; destruct 1; order). + assert (H' := gcd_divide_r n m). + apply mod_divide in H'; trivial. apply div_exact in H'; trivial. + rewrite H in H'. + rewrite <- (mul_1_l m) in H' at 1. + now apply mul_cancel_r in H'. +Qed. + +End NLcmProp. diff --git a/theories/Numbers/Natural/Abstract/NLog.v b/theories/Numbers/Natural/Abstract/NLog.v new file mode 100644 index 0000000000..fe6fcee567 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NLog.v @@ -0,0 +1,25 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Base-2 Logarithm Properties *) + +Require Import NAxioms NSub NPow NParity NZLog. + +Module Type NLog2Prop + (A : NAxiomsSig) + (B : NSubProp A) + (C : NParityProp A B) + (D : NPowProp A B C). + + (** For the moment we simply reuse NZ properties *) + + Include NZLog2Prop A A A B D.Private_NZPow. + Include NZLog2UpProp A A A B D.Private_NZPow. +End NLog2Prop. diff --git a/theories/Numbers/Natural/Abstract/NMaxMin.v b/theories/Numbers/Natural/Abstract/NMaxMin.v new file mode 100644 index 0000000000..3cf4d3f9f2 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NMaxMin.v @@ -0,0 +1,137 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import NAxioms NSub GenericMinMax. + +(** * Properties of minimum and maximum specific to natural numbers *) + +Module Type NMaxMinProp (Import N : NAxiomsMiniSig'). +Include NSubProp N. + +(** Zero *) + +Lemma max_0_l : forall n, max 0 n == n. +Proof. + intros. apply max_r. apply le_0_l. +Qed. + +Lemma max_0_r : forall n, max n 0 == n. +Proof. + intros. apply max_l. apply le_0_l. +Qed. + +Lemma min_0_l : forall n, min 0 n == 0. +Proof. + intros. apply min_l. apply le_0_l. +Qed. + +Lemma min_0_r : forall n, min n 0 == 0. +Proof. + intros. apply min_r. apply le_0_l. +Qed. + +(** The following results are concrete instances of [max_monotone] + and similar lemmas. *) + +(** Succ *) + +Lemma succ_max_distr : forall n m, S (max n m) == max (S n) (S m). +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?succ_le_mono. +Qed. + +Lemma succ_min_distr : forall n m, S (min n m) == min (S n) (S m). +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?succ_le_mono. +Qed. + +(** Add *) + +Lemma add_max_distr_l : forall n m p, max (p + n) (p + m) == p + max n m. +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_l. +Qed. + +Lemma add_max_distr_r : forall n m p, max (n + p) (m + p) == max n m + p. +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_r. +Qed. + +Lemma add_min_distr_l : forall n m p, min (p + n) (p + m) == p + min n m. +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_l. +Qed. + +Lemma add_min_distr_r : forall n m p, min (n + p) (m + p) == min n m + p. +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_r. +Qed. + +(** Mul *) + +Lemma mul_max_distr_l : forall n m p, max (p * n) (p * m) == p * max n m. +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_l. +Qed. + +Lemma mul_max_distr_r : forall n m p, max (n * p) (m * p) == max n m * p. +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_r. +Qed. + +Lemma mul_min_distr_l : forall n m p, min (p * n) (p * m) == p * min n m. +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_l. +Qed. + +Lemma mul_min_distr_r : forall n m p, min (n * p) (m * p) == min n m * p. +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_r. +Qed. + +(** Sub *) + +Lemma sub_max_distr_l : forall n m p, max (p - n) (p - m) == p - min n m. +Proof. + intros. destruct (le_ge_cases n m). + rewrite min_l by trivial. apply max_l. now apply sub_le_mono_l. + rewrite min_r by trivial. apply max_r. now apply sub_le_mono_l. +Qed. + +Lemma sub_max_distr_r : forall n m p, max (n - p) (m - p) == max n m - p. +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply sub_le_mono_r. +Qed. + +Lemma sub_min_distr_l : forall n m p, min (p - n) (p - m) == p - max n m. +Proof. + intros. destruct (le_ge_cases n m). + rewrite max_r by trivial. apply min_r. now apply sub_le_mono_l. + rewrite max_l by trivial. apply min_l. now apply sub_le_mono_l. +Qed. + +Lemma sub_min_distr_r : forall n m p, min (n - p) (m - p) == min n m - p. +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply sub_le_mono_r. +Qed. + +End NMaxMinProp. diff --git a/theories/Numbers/Natural/Abstract/NMulOrder.v b/theories/Numbers/Natural/Abstract/NMulOrder.v new file mode 100644 index 0000000000..b7f1c8e453 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NMulOrder.v @@ -0,0 +1,84 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Export NAddOrder. + +Module NMulOrderProp (Import N : NAxiomsMiniSig'). +Include NAddOrderProp N. + +(** Theorems that are either not valid on Z or have different proofs + on N and Z *) + +Theorem square_lt_mono : forall n m, n < m <-> n * n < m * m. +Proof. +intros n m; split; intro; +[apply square_lt_mono_nonneg | apply square_lt_simpl_nonneg]; +try assumption; apply le_0_l. +Qed. + +Theorem square_le_mono : forall n m, n <= m <-> n * n <= m * m. +Proof. +intros n m; split; intro; +[apply square_le_mono_nonneg | apply square_le_simpl_nonneg]; +try assumption; apply le_0_l. +Qed. + +Theorem mul_le_mono_l : forall n m p, n <= m -> p * n <= p * m. +Proof. +intros; apply mul_le_mono_nonneg_l. apply le_0_l. assumption. +Qed. + +Theorem mul_le_mono_r : forall n m p, n <= m -> n * p <= m * p. +Proof. +intros; apply mul_le_mono_nonneg_r. apply le_0_l. assumption. +Qed. + +Theorem mul_lt_mono : forall n m p q, n < m -> p < q -> n * p < m * q. +Proof. +intros; apply mul_lt_mono_nonneg; try assumption; apply le_0_l. +Qed. + +Theorem mul_le_mono : forall n m p q, n <= m -> p <= q -> n * p <= m * q. +Proof. +intros; apply mul_le_mono_nonneg; try assumption; apply le_0_l. +Qed. + +Theorem lt_0_mul' : forall n m, n * m > 0 <-> n > 0 /\ m > 0. +Proof. +intros n m; split; [intro H | intros [H1 H2]]. +apply lt_0_mul in H. destruct H as [[H1 H2] | [H1 H2]]. now split. + false_hyp H1 nlt_0_r. +now apply mul_pos_pos. +Qed. + +Notation mul_pos := lt_0_mul' (only parsing). + +Theorem eq_mul_1 : forall n m, n * m == 1 <-> n == 1 /\ m == 1. +Proof. +intros n m. +split; [| intros [H1 H2]; now rewrite H1, H2, mul_1_l]. +intro H; destruct (lt_trichotomy n 1) as [H1 | [H1 | H1]]. +apply lt_1_r in H1. rewrite H1, mul_0_l in H. order'. +rewrite H1, mul_1_l in H; now split. +destruct (eq_0_gt_0_cases m) as [H2 | H2]. +rewrite H2, mul_0_r in H. order'. +apply (mul_lt_mono_pos_r m) in H1; [| assumption]. rewrite mul_1_l in H1. +assert (H3 : 1 < n * m) by now apply (lt_1_l m). +rewrite H in H3; false_hyp H3 lt_irrefl. +Qed. + +(** Alternative name : *) + +Definition mul_eq_1 := eq_mul_1. + +End NMulOrderProp. + diff --git a/theories/Numbers/Natural/Abstract/NOrder.v b/theories/Numbers/Natural/Abstract/NOrder.v new file mode 100644 index 0000000000..acaecad93c --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NOrder.v @@ -0,0 +1,247 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Export NAdd. + +Module NOrderProp (Import N : NAxiomsMiniSig'). +Include NAddProp N. + +(* Theorems that are true for natural numbers but not for integers *) + +Theorem lt_wf_0 : well_founded lt. +Proof. +setoid_replace lt with (fun n m => 0 <= n < m). +apply lt_wf. +intros x y; split. +intro H; split; [apply le_0_l | assumption]. now intros [_ H]. +Defined. + +(* "le_0_l : forall n : N, 0 <= n" was proved in NBase.v *) + +Theorem nlt_0_r : forall n, ~ n < 0. +Proof. +intro n; apply le_ngt. apply le_0_l. +Qed. + +Theorem nle_succ_0 : forall n, ~ (S n <= 0). +Proof. +intros n H; apply le_succ_l in H; false_hyp H nlt_0_r. +Qed. + +Theorem le_0_r : forall n, n <= 0 <-> n == 0. +Proof. +intros n; split; intro H. +le_elim H; [false_hyp H nlt_0_r | assumption]. +now apply eq_le_incl. +Qed. + +Theorem lt_0_succ : forall n, 0 < S n. +Proof. +induct n; [apply lt_succ_diag_r | intros n H; now apply lt_lt_succ_r]. +Qed. + +Theorem neq_0_lt_0 : forall n, n ~= 0 <-> 0 < n. +Proof. +cases n. +split; intro H; [now elim H | intro; now apply lt_irrefl with 0]. +intro n; split; intro H; [apply lt_0_succ | apply neq_succ_0]. +Qed. + +Theorem eq_0_gt_0_cases : forall n, n == 0 \/ 0 < n. +Proof. +cases n. +now left. +intro; right; apply lt_0_succ. +Qed. + +Theorem zero_one : forall n, n == 0 \/ n == 1 \/ 1 < n. +Proof. +setoid_rewrite one_succ. +induct n. now left. +cases n. intros; right; now left. +intros n IH. destruct IH as [H | [H | H]]. +false_hyp H neq_succ_0. +right; right. rewrite H. apply lt_succ_diag_r. +right; right. now apply lt_lt_succ_r. +Qed. + +Theorem lt_1_r : forall n, n < 1 <-> n == 0. +Proof. +setoid_rewrite one_succ. +cases n. +split; intro; [reflexivity | apply lt_succ_diag_r]. +intros n. rewrite <- succ_lt_mono. +split; intro H; [false_hyp H nlt_0_r | false_hyp H neq_succ_0]. +Qed. + +Theorem le_1_r : forall n, n <= 1 <-> n == 0 \/ n == 1. +Proof. +setoid_rewrite one_succ. +cases n. +split; intro; [now left | apply le_succ_diag_r]. +intro n. rewrite <- succ_le_mono, le_0_r, succ_inj_wd. +split; [intro; now right | intros [H | H]; [false_hyp H neq_succ_0 | assumption]]. +Qed. + +Theorem lt_lt_0 : forall n m, n < m -> 0 < m. +Proof. +intros n m; induct n. +trivial. +intros n IH H. apply IH; now apply lt_succ_l. +Qed. + +Theorem lt_1_l' : forall n m p, n < m -> m < p -> 1 < p. +Proof. +intros. apply lt_1_l with m; auto. +apply le_lt_trans with n; auto. now apply le_0_l. +Qed. + +(** Elimination principlies for < and <= for relations *) + +Section RelElim. + +Variable R : relation N.t. +Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R. + +Theorem le_ind_rel : + (forall m, R 0 m) -> + (forall n m, n <= m -> R n m -> R (S n) (S m)) -> + forall n m, n <= m -> R n m. +Proof. +intros Base Step; induct n. +intros; apply Base. +intros n IH m H. elim H using le_ind. +solve_proper. +apply Step; [| apply IH]; now apply eq_le_incl. +intros k H1 H2. apply le_succ_l in H1. apply lt_le_incl in H1. auto. +Qed. + +Theorem lt_ind_rel : + (forall m, R 0 (S m)) -> + (forall n m, n < m -> R n m -> R (S n) (S m)) -> + forall n m, n < m -> R n m. +Proof. +intros Base Step; induct n. +intros m H. apply lt_exists_pred in H; destruct H as [m' [H _]]. +rewrite H; apply Base. +intros n IH m H. elim H using lt_ind. +solve_proper. +apply Step; [| apply IH]; now apply lt_succ_diag_r. +intros k H1 H2. apply lt_succ_l in H1. auto. +Qed. + +End RelElim. + +(** Predecessor and order *) + +Theorem succ_pred_pos : forall n, 0 < n -> S (P n) == n. +Proof. +intros n H; apply succ_pred; intro H1; rewrite H1 in H. +false_hyp H lt_irrefl. +Qed. + +Theorem le_pred_l : forall n, P n <= n. +Proof. +cases n. +rewrite pred_0; now apply eq_le_incl. +intros; rewrite pred_succ; apply le_succ_diag_r. +Qed. + +Theorem lt_pred_l : forall n, n ~= 0 -> P n < n. +Proof. +cases n. +intro H; exfalso; now apply H. +intros; rewrite pred_succ; apply lt_succ_diag_r. +Qed. + +Theorem le_le_pred : forall n m, n <= m -> P n <= m. +Proof. +intros n m H; apply le_trans with n. apply le_pred_l. assumption. +Qed. + +Theorem lt_lt_pred : forall n m, n < m -> P n < m. +Proof. +intros n m H; apply le_lt_trans with n. apply le_pred_l. assumption. +Qed. + +Theorem lt_le_pred : forall n m, n < m -> n <= P m. + (* Converse is false for n == m == 0 *) +Proof. +intro n; cases m. +intro H; false_hyp H nlt_0_r. +intros m IH. rewrite pred_succ; now apply lt_succ_r. +Qed. + +Theorem lt_pred_le : forall n m, P n < m -> n <= m. + (* Converse is false for n == m == 0 *) +Proof. +intros n m; cases n. +rewrite pred_0; intro H; now apply lt_le_incl. +intros n IH. rewrite pred_succ in IH. now apply le_succ_l. +Qed. + +Theorem lt_pred_lt : forall n m, n < P m -> n < m. +Proof. +intros n m H; apply lt_le_trans with (P m); [assumption | apply le_pred_l]. +Qed. + +Theorem le_pred_le : forall n m, n <= P m -> n <= m. +Proof. +intros n m H; apply le_trans with (P m); [assumption | apply le_pred_l]. +Qed. + +Theorem pred_le_mono : forall n m, n <= m -> P n <= P m. + (* Converse is false for n == 1, m == 0 *) +Proof. +intros n m H; elim H using le_ind_rel. +solve_proper. +intro; rewrite pred_0; apply le_0_l. +intros p q H1 _; now do 2 rewrite pred_succ. +Qed. + +Theorem pred_lt_mono : forall n m, n ~= 0 -> (n < m <-> P n < P m). +Proof. +intros n m H1; split; intro H2. +assert (m ~= 0). apply neq_0_lt_0. now apply lt_lt_0 with n. +now rewrite <- (succ_pred n) in H2; rewrite <- (succ_pred m) in H2 ; +[apply succ_lt_mono | | |]. +assert (m ~= 0). apply neq_0_lt_0. apply lt_lt_0 with (P n). +apply lt_le_trans with (P m). assumption. apply le_pred_l. +apply succ_lt_mono in H2. now do 2 rewrite succ_pred in H2. +Qed. + +Theorem lt_succ_lt_pred : forall n m, S n < m <-> n < P m. +Proof. +intros n m. rewrite pred_lt_mono by apply neq_succ_0. now rewrite pred_succ. +Qed. + +Theorem le_succ_le_pred : forall n m, S n <= m -> n <= P m. + (* Converse is false for n == m == 0 *) +Proof. +intros n m H. apply lt_le_pred. now apply le_succ_l. +Qed. + +Theorem lt_pred_lt_succ : forall n m, P n < m -> n < S m. + (* Converse is false for n == m == 0 *) +Proof. +intros n m H. apply lt_succ_r. now apply lt_pred_le. +Qed. + +Theorem le_pred_le_succ : forall n m, P n <= m <-> n <= S m. +Proof. +intros n m; cases n. +rewrite pred_0. split; intro H; apply le_0_l. +intro n. rewrite pred_succ. apply succ_le_mono. +Qed. + +End NOrderProp. + diff --git a/theories/Numbers/Natural/Abstract/NParity.v b/theories/Numbers/Natural/Abstract/NParity.v new file mode 100644 index 0000000000..cb89e1d729 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NParity.v @@ -0,0 +1,65 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import Bool NSub NZParity. + +(** Some additional properties of [even], [odd]. *) + +Module Type NParityProp (Import N : NAxiomsSig')(Import NP : NSubProp N). + +Include NZParityProp N N NP. + +Lemma odd_pred : forall n, n~=0 -> odd (P n) = even n. +Proof. + intros. rewrite <- (succ_pred n) at 2 by trivial. + symmetry. apply even_succ. +Qed. + +Lemma even_pred : forall n, n~=0 -> even (P n) = odd n. +Proof. + intros. rewrite <- (succ_pred n) at 2 by trivial. + symmetry. apply odd_succ. +Qed. + +Lemma even_sub : forall n m, m<=n -> even (n-m) = Bool.eqb (even n) (even m). +Proof. + intros. + case_eq (even n); case_eq (even m); + rewrite <- ?negb_true_iff, ?negb_even, ?odd_spec, ?even_spec; + intros (m',Hm) (n',Hn). + exists (n'-m'). now rewrite mul_sub_distr_l, Hn, Hm. + exists (n'-m'-1). + rewrite !mul_sub_distr_l, Hn, Hm, sub_add_distr, mul_1_r. + rewrite two_succ at 5. rewrite <- (add_1_l 1). rewrite sub_add_distr. + symmetry. apply sub_add. + apply le_add_le_sub_l. + rewrite add_1_l, <- two_succ, <- (mul_1_r 2) at 1. + rewrite <- mul_sub_distr_l. rewrite <- mul_le_mono_pos_l by order'. + rewrite one_succ, le_succ_l. rewrite <- lt_add_lt_sub_l, add_0_r. + destruct (le_gt_cases n' m') as [LE|GT]; trivial. + generalize (double_below _ _ LE). order. + exists (n'-m'). rewrite mul_sub_distr_l, Hn, Hm. + apply add_sub_swap. + apply mul_le_mono_pos_l; try order'. + destruct (le_gt_cases m' n') as [LE|GT]; trivial. + generalize (double_above _ _ GT). order. + exists (n'-m'). rewrite Hm,Hn, mul_sub_distr_l. + rewrite sub_add_distr. rewrite add_sub_swap. apply add_sub. + apply succ_le_mono. + rewrite add_1_r in Hm,Hn. order. +Qed. + +Lemma odd_sub : forall n m, m<=n -> odd (n-m) = xorb (odd n) (odd m). +Proof. + intros. rewrite <- !negb_even. rewrite even_sub by trivial. + now destruct (even n), (even m). +Qed. + +End NParityProp. diff --git a/theories/Numbers/Natural/Abstract/NPow.v b/theories/Numbers/Natural/Abstract/NPow.v new file mode 100644 index 0000000000..fc1cc93b11 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NPow.v @@ -0,0 +1,162 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Properties of the power function *) + +Require Import Bool NAxioms NSub NParity NZPow. + +(** Derived properties of power, specialized on natural numbers *) + +Module Type NPowProp + (Import A : NAxiomsSig') + (Import B : NSubProp A) + (Import C : NParityProp A B). + + Module Import Private_NZPow := Nop <+ NZPowProp A A B. + +Ltac auto' := trivial; try rewrite <- neq_0_lt_0; auto using le_0_l. +Ltac wrap l := intros; apply l; auto'. + +Lemma pow_succ_r' : forall a b, a^(S b) == a * a^b. +Proof. wrap pow_succ_r. Qed. + +(** Power and basic constants *) + +Lemma pow_0_l : forall a, a~=0 -> 0^a == 0. +Proof. wrap pow_0_l. Qed. + +Definition pow_1_r : forall a, a^1 == a + := pow_1_r. + +Lemma pow_1_l : forall a, 1^a == 1. +Proof. wrap pow_1_l. Qed. + +Definition pow_2_r : forall a, a^2 == a*a + := pow_2_r. + +(** Power and addition, multiplication *) + +Lemma pow_add_r : forall a b c, a^(b+c) == a^b * a^c. +Proof. wrap pow_add_r. Qed. + +Lemma pow_mul_l : forall a b c, (a*b)^c == a^c * b^c. +Proof. wrap pow_mul_l. Qed. + +Lemma pow_mul_r : forall a b c, a^(b*c) == (a^b)^c. +Proof. wrap pow_mul_r. Qed. + +(** Power and nullity *) + +Lemma pow_eq_0 : forall a b, b~=0 -> a^b == 0 -> a == 0. +Proof. intros. apply (pow_eq_0 a b); trivial. auto'. Qed. + +Lemma pow_nonzero : forall a b, a~=0 -> a^b ~= 0. +Proof. wrap pow_nonzero. Qed. + +Lemma pow_eq_0_iff : forall a b, a^b == 0 <-> b~=0 /\ a==0. +Proof. + intros a b. split. + rewrite pow_eq_0_iff. intros [H |[H H']]. + generalize (le_0_l b); order. split; order. + intros (Hb,Ha). rewrite Ha. now apply pow_0_l'. +Qed. + +(** Monotonicity *) + +Lemma pow_lt_mono_l : forall a b c, c~=0 -> a<b -> a^c < b^c. +Proof. wrap pow_lt_mono_l. Qed. + +Lemma pow_le_mono_l : forall a b c, a<=b -> a^c <= b^c. +Proof. wrap pow_le_mono_l. Qed. + +Lemma pow_gt_1 : forall a b, 1<a -> b~=0 -> 1<a^b. +Proof. wrap pow_gt_1. Qed. + +Lemma pow_lt_mono_r : forall a b c, 1<a -> b<c -> a^b < a^c. +Proof. wrap pow_lt_mono_r. Qed. + +(** NB: since 0^0 > 0^1, the following result isn't valid with a=0 *) + +Lemma pow_le_mono_r : forall a b c, a~=0 -> b<=c -> a^b <= a^c. +Proof. wrap pow_le_mono_r. Qed. + +Lemma pow_le_mono : forall a b c d, a~=0 -> a<=c -> b<=d -> + a^b <= c^d. +Proof. wrap pow_le_mono. Qed. + +Definition pow_lt_mono : forall a b c d, 0<a<c -> 0<b<d -> + a^b < c^d + := pow_lt_mono. + +(** Injectivity *) + +Lemma pow_inj_l : forall a b c, c~=0 -> a^c == b^c -> a == b. +Proof. intros; eapply pow_inj_l; eauto; auto'. Qed. + +Lemma pow_inj_r : forall a b c, 1<a -> a^b == a^c -> b == c. +Proof. intros; eapply pow_inj_r; eauto; auto'. Qed. + +(** Monotonicity results, both ways *) + +Lemma pow_lt_mono_l_iff : forall a b c, c~=0 -> + (a<b <-> a^c < b^c). +Proof. wrap pow_lt_mono_l_iff. Qed. + +Lemma pow_le_mono_l_iff : forall a b c, c~=0 -> + (a<=b <-> a^c <= b^c). +Proof. wrap pow_le_mono_l_iff. Qed. + +Lemma pow_lt_mono_r_iff : forall a b c, 1<a -> + (b<c <-> a^b < a^c). +Proof. wrap pow_lt_mono_r_iff. Qed. + +Lemma pow_le_mono_r_iff : forall a b c, 1<a -> + (b<=c <-> a^b <= a^c). +Proof. wrap pow_le_mono_r_iff. Qed. + +(** For any a>1, the a^x function is above the identity function *) + +Lemma pow_gt_lin_r : forall a b, 1<a -> b < a^b. +Proof. wrap pow_gt_lin_r. Qed. + +(** Someday, we should say something about the full Newton formula. + In the meantime, we can at least provide some inequalities about + (a+b)^c. +*) + +Lemma pow_add_lower : forall a b c, c~=0 -> + a^c + b^c <= (a+b)^c. +Proof. wrap pow_add_lower. Qed. + +(** This upper bound can also be seen as a convexity proof for x^c : + image of (a+b)/2 is below the middle of the images of a and b +*) + +Lemma pow_add_upper : forall a b c, c~=0 -> + (a+b)^c <= 2^(pred c) * (a^c + b^c). +Proof. wrap pow_add_upper. Qed. + +(** Power and parity *) + +Lemma even_pow : forall a b, b~=0 -> even (a^b) = even a. +Proof. + intros a b Hb. rewrite neq_0_lt_0 in Hb. + apply lt_ind with (4:=Hb). solve_proper. + now nzsimpl. + clear b Hb. intros b Hb IH. + rewrite pow_succ_r', even_mul, IH. now destruct (even a). +Qed. + +Lemma odd_pow : forall a b, b~=0 -> odd (a^b) = odd a. +Proof. + intros. now rewrite <- !negb_even, even_pow. +Qed. + +End NPowProp. diff --git a/theories/Numbers/Natural/Abstract/NProperties.v b/theories/Numbers/Natural/Abstract/NProperties.v new file mode 100644 index 0000000000..bcf906cf92 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NProperties.v @@ -0,0 +1,30 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Export NAxioms. +Require Import NMaxMin NParity NPow NSqrt NLog NDiv NGcd NLcm NBits. + +(** The two following functors summarize all known facts about N. + + - [NBasicProp] provides properties of basic functions: + + - * min max <= < + + - [NExtraProp] provides properties of advanced functions: + pow, sqrt, log2, div, gcd, and bitwise functions. + + If necessary, the earlier all-in-one functor [NProp] + could be re-obtained via [NBasicProp <+ NExtraProp] *) + +Module Type NBasicProp (N:NAxiomsMiniSig) := NMaxMinProp N. + +Module Type NExtraProp (N:NAxiomsSig)(P:NBasicProp N) := + NParityProp N P <+ NPowProp N P <+ NSqrtProp N P + <+ NLog2Prop N P <+ NDivProp N P <+ NGcdProp N P <+ NLcmProp N P + <+ NBitsProp N P. diff --git a/theories/Numbers/Natural/Abstract/NSqrt.v b/theories/Numbers/Natural/Abstract/NSqrt.v new file mode 100644 index 0000000000..6bffe693e6 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NSqrt.v @@ -0,0 +1,77 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Properties of Square Root Function *) + +Require Import NAxioms NSub NZSqrt. + +Module NSqrtProp (Import A : NAxiomsSig')(Import B : NSubProp A). + + Module Import Private_NZSqrt := Nop <+ NZSqrtProp A A B. + + Ltac auto' := trivial; try rewrite <- neq_0_lt_0; auto using le_0_l. + Ltac wrap l := intros; apply l; auto'. + + (** We redefine NZSqrt's results, without the non-negative hyps *) + +Lemma sqrt_spec' : forall a, √a*√a <= a < S (√a) * S (√a). +Proof. wrap sqrt_spec. Qed. + +Definition sqrt_unique : forall a b, b*b<=a<(S b)*(S b) -> √a == b + := sqrt_unique. + +Lemma sqrt_square : forall a, √(a*a) == a. +Proof. wrap sqrt_square. Qed. + +Definition sqrt_le_mono : forall a b, a<=b -> √a <= √b + := sqrt_le_mono. + +Definition sqrt_lt_cancel : forall a b, √a < √b -> a < b + := sqrt_lt_cancel. + +Lemma sqrt_le_square : forall a b, b*b<=a <-> b <= √a. +Proof. wrap sqrt_le_square. Qed. + +Lemma sqrt_lt_square : forall a b, a<b*b <-> √a < b. +Proof. wrap sqrt_lt_square. Qed. + +Definition sqrt_0 := sqrt_0. +Definition sqrt_1 := sqrt_1. +Definition sqrt_2 := sqrt_2. + +Definition sqrt_lt_lin : forall a, 1<a -> √a<a + := sqrt_lt_lin. + +Lemma sqrt_le_lin : forall a, √a<=a. +Proof. wrap sqrt_le_lin. Qed. + +Definition sqrt_mul_below : forall a b, √a * √b <= √(a*b) + := sqrt_mul_below. + +Lemma sqrt_mul_above : forall a b, √(a*b) < S (√a) * S (√b). +Proof. wrap sqrt_mul_above. Qed. + +Lemma sqrt_succ_le : forall a, √(S a) <= S (√a). +Proof. wrap sqrt_succ_le. Qed. + +Lemma sqrt_succ_or : forall a, √(S a) == S (√a) \/ √(S a) == √a. +Proof. wrap sqrt_succ_or. Qed. + +Definition sqrt_add_le : forall a b, √(a+b) <= √a + √b + := sqrt_add_le. + +Lemma add_sqrt_le : forall a b, √a + √b <= √(2*(a+b)). +Proof. wrap add_sqrt_le. Qed. + +(** For the moment, we include stuff about [sqrt_up] with patching them. *) + +Include NZSqrtUpProp A A B Private_NZSqrt. + +End NSqrtProp. diff --git a/theories/Numbers/Natural/Abstract/NStrongRec.v b/theories/Numbers/Natural/Abstract/NStrongRec.v new file mode 100644 index 0000000000..f76d8ae8a2 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NStrongRec.v @@ -0,0 +1,197 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(** This file defined the strong (course-of-value, well-founded) recursion +and proves its properties *) + +Require Export NSub. + +Ltac f_equiv' := repeat (repeat f_equiv; try intros ? ? ?; auto). + +Module NStrongRecProp (Import N : NAxiomsRecSig'). +Include NSubProp N. + +Section StrongRecursion. + +Variable A : Type. +Variable Aeq : relation A. +Variable Aeq_equiv : Equivalence Aeq. + +(** [strong_rec] allows defining a recursive function [phi] given by + an equation [phi(n) = F(phi)(n)] where recursive calls to [phi] + in [F] are made on strictly lower numbers than [n]. + + For [strong_rec a F n]: + - Parameter [a:A] is a default value used internally, it has no + effect on the final result. + - Parameter [F:(N->A)->N->A] is the step function: + [F f n] should return [phi(n)] when [f] is a function + that coincide with [phi] for numbers strictly less than [n]. +*) + +Definition strong_rec (a : A) (f : (N.t -> A) -> N.t -> A) (n : N.t) : A := + recursion (fun _ => a) (fun _ => f) (S n) n. + +(** For convenience, we use in proofs an intermediate definition + between [recursion] and [strong_rec]. *) + +Definition strong_rec0 (a : A) (f : (N.t -> A) -> N.t -> A) : N.t -> N.t -> A := + recursion (fun _ => a) (fun _ => f). + +Lemma strong_rec_alt : forall a f n, + strong_rec a f n = strong_rec0 a f (S n) n. +Proof. +reflexivity. +Qed. + +Instance strong_rec0_wd : + Proper (Aeq ==> ((N.eq ==> Aeq) ==> N.eq ==> Aeq) ==> N.eq ==> N.eq ==> Aeq) + strong_rec0. +Proof. +unfold strong_rec0; f_equiv'. +Qed. + +Instance strong_rec_wd : + Proper (Aeq ==> ((N.eq ==> Aeq) ==> N.eq ==> Aeq) ==> N.eq ==> Aeq) strong_rec. +Proof. +intros a a' Eaa' f f' Eff' n n' Enn'. +rewrite !strong_rec_alt; f_equiv'. +Qed. + +Section FixPoint. + +Variable f : (N.t -> A) -> N.t -> A. +Variable f_wd : Proper ((N.eq==>Aeq)==>N.eq==>Aeq) f. + +Lemma strong_rec0_0 : forall a m, + (strong_rec0 a f 0 m) = a. +Proof. +intros. unfold strong_rec0. rewrite recursion_0; auto. +Qed. + +Lemma strong_rec0_succ : forall a n m, + Aeq (strong_rec0 a f (S n) m) (f (strong_rec0 a f n) m). +Proof. +intros. unfold strong_rec0. +f_equiv. +rewrite recursion_succ; f_equiv'. +Qed. + +Lemma strong_rec_0 : forall a, + Aeq (strong_rec a f 0) (f (fun _ => a) 0). +Proof. +intros. rewrite strong_rec_alt, strong_rec0_succ; f_equiv'. +rewrite strong_rec0_0. reflexivity. +Qed. + +(* We need an assumption saying that for every n, the step function (f h n) +calls h only on the segment [0 ... n - 1]. This means that if h1 and h2 +coincide on values < n, then (f h1 n) coincides with (f h2 n) *) + +Hypothesis step_good : + forall (n : N.t) (h1 h2 : N.t -> A), + (forall m : N.t, m < n -> Aeq (h1 m) (h2 m)) -> Aeq (f h1 n) (f h2 n). + +Lemma strong_rec0_more_steps : forall a k n m, m < n -> + Aeq (strong_rec0 a f n m) (strong_rec0 a f (n+k) m). +Proof. + intros a k n. pattern n. + apply induction; clear n. + + intros n n' Hn; setoid_rewrite Hn; auto with *. + + intros m Hm. destruct (nlt_0_r _ Hm). + + intros n IH m Hm. + rewrite lt_succ_r in Hm. + rewrite add_succ_l. + rewrite 2 strong_rec0_succ. + apply step_good. + intros m' Hm'. + apply IH. + apply lt_le_trans with m; auto. +Qed. + +Lemma strong_rec0_fixpoint : forall (a : A) (n : N.t), + Aeq (strong_rec0 a f (S n) n) (f (fun n => strong_rec0 a f (S n) n) n). +Proof. +intros. +rewrite strong_rec0_succ. +apply step_good. +intros m Hm. +symmetry. +setoid_replace n with (S m + (n - S m)). +apply strong_rec0_more_steps. +apply lt_succ_diag_r. +rewrite add_comm. +symmetry. +apply sub_add. +rewrite le_succ_l; auto. +Qed. + +Theorem strong_rec_fixpoint : forall (a : A) (n : N.t), + Aeq (strong_rec a f n) (f (strong_rec a f) n). +Proof. +intros. +transitivity (f (fun n => strong_rec0 a f (S n) n) n). +rewrite strong_rec_alt. +apply strong_rec0_fixpoint. +f_equiv. +intros x x' Hx; rewrite strong_rec_alt, Hx; auto with *. +Qed. + +(** NB: without the [step_good] hypothesis, we have proved that + [strong_rec a f 0] is [f (fun _ => a) 0]. Now we can prove + that the first argument of [f] is arbitrary in this case... +*) + +Theorem strong_rec_0_any : forall (a : A)(any : N.t->A), + Aeq (strong_rec a f 0) (f any 0). +Proof. +intros. +rewrite strong_rec_fixpoint. +apply step_good. +intros m Hm. destruct (nlt_0_r _ Hm). +Qed. + +(** ... and that first argument of [strong_rec] is always arbitrary. *) + +Lemma strong_rec_any_fst_arg : forall a a' n, + Aeq (strong_rec a f n) (strong_rec a' f n). +Proof. +intros a a' n. +generalize (le_refl n). +set (k:=n) at -2. clearbody k. revert k. pattern n. +apply induction; clear n. +(* compat *) +intros n n' Hn. setoid_rewrite Hn; auto with *. +(* 0 *) +intros k Hk. rewrite le_0_r in Hk. +rewrite Hk, strong_rec_0. symmetry. apply strong_rec_0_any. +(* S *) +intros n IH k Hk. +rewrite 2 strong_rec_fixpoint. +apply step_good. +intros m Hm. +apply IH. +rewrite succ_le_mono. +apply le_trans with k; auto. +rewrite le_succ_l; auto. +Qed. + +End FixPoint. +End StrongRecursion. + +Arguments strong_rec [A] a f n. + +End NStrongRecProp. + diff --git a/theories/Numbers/Natural/Abstract/NSub.v b/theories/Numbers/Natural/Abstract/NSub.v new file mode 100644 index 0000000000..453b0c0d4c --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NSub.v @@ -0,0 +1,322 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Export NMulOrder. + +Module Type NSubProp (Import N : NAxiomsMiniSig'). +Include NMulOrderProp N. + +Theorem sub_0_l : forall n, 0 - n == 0. +Proof. +induct n. +apply sub_0_r. +intros n IH; rewrite sub_succ_r; rewrite IH. now apply pred_0. +Qed. + +Theorem sub_succ : forall n m, S n - S m == n - m. +Proof. +intro n; induct m. +rewrite sub_succ_r. do 2 rewrite sub_0_r. now rewrite pred_succ. +intros m IH. rewrite sub_succ_r. rewrite IH. now rewrite sub_succ_r. +Qed. + +Theorem sub_diag : forall n, n - n == 0. +Proof. +induct n. apply sub_0_r. intros n IH; rewrite sub_succ; now rewrite IH. +Qed. + +Theorem sub_gt : forall n m, n > m -> n - m ~= 0. +Proof. +intros n m H; elim H using lt_ind_rel; clear n m H. +solve_proper. +intro; rewrite sub_0_r; apply neq_succ_0. +intros; now rewrite sub_succ. +Qed. + +Theorem add_sub_assoc : forall n m p, p <= m -> n + (m - p) == (n + m) - p. +Proof. +intros n m p; induct p. +intro; now do 2 rewrite sub_0_r. +intros p IH H. do 2 rewrite sub_succ_r. +rewrite <- IH by (apply lt_le_incl; now apply le_succ_l). +rewrite add_pred_r by (apply sub_gt; now apply le_succ_l). +reflexivity. +Qed. + +Theorem sub_succ_l : forall n m, n <= m -> S m - n == S (m - n). +Proof. +intros n m H. rewrite <- (add_1_l m). rewrite <- (add_1_l (m - n)). +symmetry; now apply add_sub_assoc. +Qed. + +Theorem add_sub : forall n m, (n + m) - m == n. +Proof. +intros n m. rewrite <- add_sub_assoc by (apply le_refl). +rewrite sub_diag; now rewrite add_0_r. +Qed. + +Theorem sub_add : forall n m, n <= m -> (m - n) + n == m. +Proof. +intros n m H. rewrite add_comm. rewrite add_sub_assoc by assumption. +rewrite add_comm. apply add_sub. +Qed. + +Theorem add_sub_eq_l : forall n m p, m + p == n -> n - m == p. +Proof. +intros n m p H. symmetry. +assert (H1 : m + p - m == n - m) by now rewrite H. +rewrite add_comm in H1. now rewrite add_sub in H1. +Qed. + +Theorem add_sub_eq_r : forall n m p, m + p == n -> n - p == m. +Proof. +intros n m p H; rewrite add_comm in H; now apply add_sub_eq_l. +Qed. + +(* This could be proved by adding m to both sides. Then the proof would +use add_sub_assoc and sub_0_le, which is proven below. *) + +Theorem add_sub_eq_nz : forall n m p, p ~= 0 -> n - m == p -> m + p == n. +Proof. +intros n m p H; double_induct n m. +intros m H1; rewrite sub_0_l in H1. symmetry in H1; false_hyp H1 H. +intro n; rewrite sub_0_r; now rewrite add_0_l. +intros n m IH H1. rewrite sub_succ in H1. apply IH in H1. +rewrite add_succ_l; now rewrite H1. +Qed. + +Theorem sub_add_distr : forall n m p, n - (m + p) == (n - m) - p. +Proof. +intros n m; induct p. +rewrite add_0_r; now rewrite sub_0_r. +intros p IH. rewrite add_succ_r; do 2 rewrite sub_succ_r. now rewrite IH. +Qed. + +Theorem add_sub_swap : forall n m p, p <= n -> n + m - p == n - p + m. +Proof. +intros n m p H. +rewrite (add_comm n m). +rewrite <- add_sub_assoc by assumption. +now rewrite (add_comm m (n - p)). +Qed. + +(** Sub and order *) + +Theorem le_sub_l : forall n m, n - m <= n. +Proof. +intro n; induct m. +rewrite sub_0_r; now apply eq_le_incl. +intros m IH. rewrite sub_succ_r. +apply le_trans with (n - m); [apply le_pred_l | assumption]. +Qed. + +Theorem sub_0_le : forall n m, n - m == 0 <-> n <= m. +Proof. +double_induct n m. +intro m; split; intro; [apply le_0_l | apply sub_0_l]. +intro m; rewrite sub_0_r; split; intro H; +[false_hyp H neq_succ_0 | false_hyp H nle_succ_0]. +intros n m H. rewrite <- succ_le_mono. now rewrite sub_succ. +Qed. + +Theorem sub_add_le : forall n m, n <= n - m + m. +Proof. +intros. +destruct (le_ge_cases n m) as [LE|GE]. +rewrite <- sub_0_le in LE. rewrite LE; nzsimpl. +now rewrite <- sub_0_le. +rewrite sub_add by assumption. apply le_refl. +Qed. + +Theorem le_sub_le_add_r : forall n m p, + n - p <= m <-> n <= m + p. +Proof. +intros n m p. +split; intros LE. +rewrite (add_le_mono_r _ _ p) in LE. +apply le_trans with (n-p+p); auto using sub_add_le. +destruct (le_ge_cases n p) as [LE'|GE]. +rewrite <- sub_0_le in LE'. rewrite LE'. apply le_0_l. +rewrite (add_le_mono_r _ _ p). now rewrite sub_add. +Qed. + +Theorem le_sub_le_add_l : forall n m p, n - m <= p <-> n <= m + p. +Proof. +intros n m p. rewrite add_comm; apply le_sub_le_add_r. +Qed. + +Theorem lt_sub_lt_add_r : forall n m p, + n - p < m -> n < m + p. +Proof. +intros n m p LT. +rewrite (add_lt_mono_r _ _ p) in LT. +apply le_lt_trans with (n-p+p); auto using sub_add_le. +Qed. + +(** Unfortunately, we do not have [n < m + p -> n - p < m]. + For instance [1<0+2] but not [1-2<0]. *) + +Theorem lt_sub_lt_add_l : forall n m p, n - m < p -> n < m + p. +Proof. +intros n m p. rewrite add_comm; apply lt_sub_lt_add_r. +Qed. + +Theorem le_add_le_sub_r : forall n m p, n + p <= m -> n <= m - p. +Proof. +intros n m p LE. +apply (add_le_mono_r _ _ p). +rewrite sub_add. assumption. +apply le_trans with (n+p); trivial. +rewrite <- (add_0_l p) at 1. rewrite <- add_le_mono_r. apply le_0_l. +Qed. + +(** Unfortunately, we do not have [n <= m - p -> n + p <= m]. + For instance [0<=1-2] but not [2+0<=1]. *) + +Theorem le_add_le_sub_l : forall n m p, n + p <= m -> p <= m - n. +Proof. +intros n m p. rewrite add_comm; apply le_add_le_sub_r. +Qed. + +Theorem lt_add_lt_sub_r : forall n m p, n + p < m <-> n < m - p. +Proof. +intros n m p. +destruct (le_ge_cases p m) as [LE|GE]. +rewrite <- (sub_add p m) at 1 by assumption. +now rewrite <- add_lt_mono_r. +assert (GE' := GE). rewrite <- sub_0_le in GE'; rewrite GE'. +split; intros LT. +elim (lt_irrefl m). apply le_lt_trans with (n+p); trivial. + rewrite <- (add_0_l m). apply add_le_mono. apply le_0_l. assumption. +now elim (nlt_0_r n). +Qed. + +Theorem lt_add_lt_sub_l : forall n m p, n + p < m <-> p < m - n. +Proof. +intros n m p. rewrite add_comm; apply lt_add_lt_sub_r. +Qed. + +Theorem sub_lt : forall n m, m <= n -> 0 < m -> n - m < n. +Proof. +intros n m LE LT. +assert (LE' := le_sub_l n m). rewrite lt_eq_cases in LE'. +destruct LE' as [LT'|EQ]. assumption. +apply add_sub_eq_nz in EQ; [|order]. +rewrite (add_lt_mono_r _ _ n), add_0_l in LT. order. +Qed. + +Lemma sub_le_mono_r : forall n m p, n <= m -> n-p <= m-p. +Proof. + intros. rewrite le_sub_le_add_r. transitivity m. assumption. apply sub_add_le. +Qed. + +Lemma sub_le_mono_l : forall n m p, n <= m -> p-m <= p-n. +Proof. + intros. rewrite le_sub_le_add_r. + transitivity (p-n+n); [ apply sub_add_le | now apply add_le_mono_l]. +Qed. + +(** Sub and mul *) + +Theorem mul_pred_r : forall n m, n * (P m) == n * m - n. +Proof. +intros n m; cases m. +now rewrite pred_0, mul_0_r, sub_0_l. +intro m; rewrite pred_succ, mul_succ_r, <- add_sub_assoc. +now rewrite sub_diag, add_0_r. +now apply eq_le_incl. +Qed. + +Theorem mul_sub_distr_r : forall n m p, (n - m) * p == n * p - m * p. +Proof. +intros n m p; induct n. +now rewrite sub_0_l, mul_0_l, sub_0_l. +intros n IH. destruct (le_gt_cases m n) as [H | H]. +rewrite sub_succ_l by assumption. do 2 rewrite mul_succ_l. +rewrite (add_comm ((n - m) * p) p), (add_comm (n * p) p). +rewrite <- (add_sub_assoc p (n * p) (m * p)) by now apply mul_le_mono_r. +now apply add_cancel_l. +assert (H1 : S n <= m); [now apply le_succ_l |]. +setoid_replace (S n - m) with 0 by now apply sub_0_le. +setoid_replace ((S n * p) - m * p) with 0 by (apply sub_0_le; now apply mul_le_mono_r). +apply mul_0_l. +Qed. + +Theorem mul_sub_distr_l : forall n m p, p * (n - m) == p * n - p * m. +Proof. +intros n m p; rewrite (mul_comm p (n - m)), (mul_comm p n), (mul_comm p m). +apply mul_sub_distr_r. +Qed. + +(** Alternative definitions of [<=] and [<] based on [+] *) + +Definition le_alt n m := exists p, p + n == m. +Definition lt_alt n m := exists p, S p + n == m. + +Lemma le_equiv : forall n m, le_alt n m <-> n <= m. +Proof. +split. +intros (p,H). rewrite <- H, add_comm. apply le_add_r. +intro H. exists (m-n). now apply sub_add. +Qed. + +Lemma lt_equiv : forall n m, lt_alt n m <-> n < m. +Proof. +split. +intros (p,H). rewrite <- H, add_succ_l, lt_succ_r, add_comm. apply le_add_r. +intro H. exists (m-S n). rewrite add_succ_l, <- add_succ_r. +apply sub_add. now rewrite le_succ_l. +Qed. + +Instance le_alt_wd : Proper (eq==>eq==>iff) le_alt. +Proof. + intros x x' Hx y y' Hy; unfold le_alt. + setoid_rewrite Hx. setoid_rewrite Hy. auto with *. +Qed. + +Instance lt_alt_wd : Proper (eq==>eq==>iff) lt_alt. +Proof. + intros x x' Hx y y' Hy; unfold lt_alt. + setoid_rewrite Hx. setoid_rewrite Hy. auto with *. +Qed. + +(** With these alternative definition, the dichotomy: + +[forall n m, n <= m \/ m <= n] + +becomes: + +[forall n m, (exists p, p + n == m) \/ (exists p, p + m == n)] + +We will need this in the proof of induction principle for integers +constructed as pairs of natural numbers. This formula can be proved +from know properties of [<=]. However, it can also be done directly. *) + +Theorem le_alt_dichotomy : forall n m, le_alt n m \/ le_alt m n. +Proof. +intros n m; induct n. +left; exists m; apply add_0_r. +intros n IH. +destruct IH as [[p H] | [p H]]. +destruct (zero_or_succ p) as [H1 | [p' H1]]; rewrite H1 in H. +rewrite add_0_l in H. right; exists (S 0); rewrite H, add_succ_l; + now rewrite add_0_l. +left; exists p'; rewrite add_succ_r; now rewrite add_succ_l in H. +right; exists (S p). rewrite add_succ_l; now rewrite H. +Qed. + +Theorem add_dichotomy : + forall n m, (exists p, p + n == m) \/ (exists p, p + m == n). +Proof. exact le_alt_dichotomy. Qed. + +End NSubProp. + diff --git a/theories/Numbers/Natural/Binary/NBinary.v b/theories/Numbers/Natural/Binary/NBinary.v new file mode 100644 index 0000000000..c9e1c64013 --- /dev/null +++ b/theories/Numbers/Natural/Binary/NBinary.v @@ -0,0 +1,49 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Import BinPos. +Require Export BinNat. +Require Import NAxioms NProperties. + +Local Open Scope N_scope. + +(** * [BinNat.N] already implements [NAxiomSig] *) + +Module N <: NAxiomsSig := N. + +(* +Require Import NDefOps. +Module Import NBinaryDefOpsMod := NdefOpsPropFunct NBinaryAxiomsMod. + +(* Some fun comparing the efficiency of the generic log defined +by strong (course-of-value) recursion and the log defined by recursion +on notation *) + +Time Eval vm_compute in (log 500000). (* 11 sec *) + +Fixpoint binposlog (p : positive) : N := +match p with +| xH => 0 +| xO p' => N.succ (binposlog p') +| xI p' => N.succ (binposlog p') +end. + +Definition binlog (n : N) : N := +match n with +| 0 => 0 +| Npos p => binposlog p +end. + +Time Eval vm_compute in (binlog 500000). (* 0 sec *) +Time Eval vm_compute in (binlog 1000000000000000000000000000000). (* 0 sec *) + +*) diff --git a/theories/Numbers/Natural/Peano/NPeano.v b/theories/Numbers/Natural/Peano/NPeano.v new file mode 100644 index 0000000000..6000bdcf79 --- /dev/null +++ b/theories/Numbers/Natural/Peano/NPeano.v @@ -0,0 +1,97 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Import PeanoNat Even NAxioms. + +(** This file is DEPRECATED ! Use [PeanoNat] (or [Arith]) instead. *) + +(** [PeanoNat.Nat] already implements [NAxiomSig] *) + +Module Nat <: NAxiomsSig := Nat. + +(** Compat notations for stuff that used to be at the beginning of NPeano. *) + +Notation leb := Nat.leb (only parsing). +Notation ltb := Nat.ltb (only parsing). +Notation leb_le := Nat.leb_le (only parsing). +Notation ltb_lt := Nat.ltb_lt (only parsing). +Notation pow := Nat.pow (only parsing). +Notation pow_0_r := Nat.pow_0_r (only parsing). +Notation pow_succ_r := Nat.pow_succ_r (only parsing). +Notation square := Nat.square (only parsing). +Notation square_spec := Nat.square_spec (only parsing). +Notation Even := Nat.Even (only parsing). +Notation Odd := Nat.Odd (only parsing). +Notation even := Nat.even (only parsing). +Notation odd := Nat.odd (only parsing). +Notation even_spec := Nat.even_spec (only parsing). +Notation odd_spec := Nat.odd_spec (only parsing). + +Lemma Even_equiv n : Even n <-> Even.even n. +Proof. symmetry. apply Even.even_equiv. Qed. +Lemma Odd_equiv n : Odd n <-> Even.odd n. +Proof. symmetry. apply Even.odd_equiv. Qed. + +Notation divmod := Nat.divmod (only parsing). +Notation div := Nat.div (only parsing). +Notation modulo := Nat.modulo (only parsing). +Notation divmod_spec := Nat.divmod_spec (only parsing). +Notation div_mod := Nat.div_mod (only parsing). +Notation mod_bound_pos := Nat.mod_bound_pos (only parsing). +Notation sqrt_iter := Nat.sqrt_iter (only parsing). +Notation sqrt := Nat.sqrt (only parsing). +Notation sqrt_iter_spec := Nat.sqrt_iter_spec (only parsing). +Notation sqrt_spec := Nat.sqrt_spec (only parsing). +Notation log2_iter := Nat.log2_iter (only parsing). +Notation log2 := Nat.log2 (only parsing). +Notation log2_iter_spec := Nat.log2_iter_spec (only parsing). +Notation log2_spec := Nat.log2_spec (only parsing). +Notation log2_nonpos := Nat.log2_nonpos (only parsing). +Notation gcd := Nat.gcd (only parsing). +Notation divide := Nat.divide (only parsing). +Notation gcd_divide := Nat.gcd_divide (only parsing). +Notation gcd_divide_l := Nat.gcd_divide_l (only parsing). +Notation gcd_divide_r := Nat.gcd_divide_r (only parsing). +Notation gcd_greatest := Nat.gcd_greatest (only parsing). +Notation testbit := Nat.testbit (only parsing). +Notation shiftl := Nat.shiftl (only parsing). +Notation shiftr := Nat.shiftr (only parsing). +Notation bitwise := Nat.bitwise (only parsing). +Notation land := Nat.land (only parsing). +Notation lor := Nat.lor (only parsing). +Notation ldiff := Nat.ldiff (only parsing). +Notation lxor := Nat.lxor (only parsing). +Notation double_twice := Nat.double_twice (only parsing). +Notation testbit_0_l := Nat.testbit_0_l (only parsing). +Notation testbit_odd_0 := Nat.testbit_odd_0 (only parsing). +Notation testbit_even_0 := Nat.testbit_even_0 (only parsing). +Notation testbit_odd_succ := Nat.testbit_odd_succ (only parsing). +Notation testbit_even_succ := Nat.testbit_even_succ (only parsing). +Notation shiftr_spec := Nat.shiftr_spec (only parsing). +Notation shiftl_spec_high := Nat.shiftl_spec_high (only parsing). +Notation shiftl_spec_low := Nat.shiftl_spec_low (only parsing). +Notation div2_bitwise := Nat.div2_bitwise (only parsing). +Notation odd_bitwise := Nat.odd_bitwise (only parsing). +Notation div2_decr := Nat.div2_decr (only parsing). +Notation testbit_bitwise_1 := Nat.testbit_bitwise_1 (only parsing). +Notation testbit_bitwise_2 := Nat.testbit_bitwise_2 (only parsing). +Notation land_spec := Nat.land_spec (only parsing). +Notation ldiff_spec := Nat.ldiff_spec (only parsing). +Notation lor_spec := Nat.lor_spec (only parsing). +Notation lxor_spec := Nat.lxor_spec (only parsing). + +Infix "<=?" := Nat.leb (at level 70) : nat_scope. +Infix "<?" := Nat.ltb (at level 70) : nat_scope. +Infix "^" := Nat.pow : nat_scope. +Infix "/" := Nat.div : nat_scope. +Infix "mod" := Nat.modulo (at level 40, no associativity) : nat_scope. +Notation "( x | y )" := (Nat.divide x y) (at level 0) : nat_scope. diff --git a/theories/Numbers/NumPrelude.v b/theories/Numbers/NumPrelude.v new file mode 100644 index 0000000000..7cf13feaea --- /dev/null +++ b/theories/Numbers/NumPrelude.v @@ -0,0 +1,26 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +Require Export Setoid Morphisms Morphisms_Prop. + +Set Implicit Arguments. + +(* The following tactic uses solve_proper to solve the goals +relating to well-definedness that are produced by applying induction. +We declare it to take the tactic that applies the induction theorem +and not the induction theorem itself because the tactic may, for +example, supply additional arguments, as does NZinduct_center in +NZBase.v *) + +Ltac induction_maker n t := + try intros until n; pattern n; t; clear n; [solve_proper | ..]. + |