(************************************************************************)
(*         *   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 Export DoubleType.
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.
(** 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.
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).
(* 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).
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).
(** Comparison *)
Local Open Scope Z_scope.
Coercion b2i (b: bool) : int := if b then 1%int63 else 0%int63.
Local Hint Resolve Z.lt_gt Z.div_pos : zarith.
(* 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 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.