diff options
Diffstat (limited to 'src/versions/standard')
| -rw-r--r-- | src/versions/standard/Array/PArray_standard.v | 398 | ||||
| -rw-r--r-- | src/versions/standard/Int63/Int63Axioms_standard.v | 313 | ||||
| -rw-r--r-- | src/versions/standard/Int63/Int63Native_standard.v | 143 | ||||
| -rw-r--r-- | src/versions/standard/Int63/Int63Op_standard.v | 334 | ||||
| -rw-r--r-- | src/versions/standard/Int63/Int63Properties_standard.v | 2768 | ||||
| -rw-r--r-- | src/versions/standard/Int63/Int63_standard.v | 23 | ||||
| -rw-r--r-- | src/versions/standard/Makefile.local | 36 | ||||
| -rw-r--r-- | src/versions/standard/Structures_standard.v | 64 | ||||
| -rw-r--r-- | src/versions/standard/Tactics_standard.v | 162 | ||||
| -rw-r--r-- | src/versions/standard/_CoqProject | 159 | ||||
| -rw-r--r-- | src/versions/standard/coq_micromega_full.ml | 2215 | ||||
| -rw-r--r-- | src/versions/standard/g_smtcoq_standard.ml4 | 119 | ||||
| -rw-r--r-- | src/versions/standard/mutils_full.ml | 358 | ||||
| -rw-r--r-- | src/versions/standard/mutils_full.mli | 77 | ||||
| -rw-r--r-- | src/versions/standard/smtcoq_plugin_standard.mlpack | 54 | ||||
| -rw-r--r-- | src/versions/standard/structures.ml | 234 | ||||
| -rw-r--r-- | src/versions/standard/structures.mli | 122 |
17 files changed, 0 insertions, 7579 deletions
diff --git a/src/versions/standard/Array/PArray_standard.v b/src/versions/standard/Array/PArray_standard.v deleted file mode 100644 index 4ebcd63..0000000 --- a/src/versions/standard/Array/PArray_standard.v +++ /dev/null @@ -1,398 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -(* Software implementation of arrays, based on finite maps using AVL - trees *) - - -Require Import Int31. -Require Export Int63. -Require FMapAVL. - -Local Open Scope int63_scope. - - -Module Map := FMapAVL.Make(IntOrderedType). - -(* An array is represented as a tuple of a finite map, the default - element, and the length *) -Definition array (A:Type) : Type := - (Map.t A * A * int)%type. - -Definition make {A:Type} (l:int) (d:A) : array A := (Map.empty A, d, l). - -Definition get {A:Type} (t:array A) (i:int) : A := - let (td,_) := t in - let (t,d) := td in - match Map.find i t with - | Some x => x - | None => d - end. - -Definition default {A:Type} (t:array A) : A := - let (td,_) := t in let (_,d) := td in d. - -Definition set {A:Type} (t:array A) (i:int) (a:A) : array A := - let (td,l) := t in - if l <= i then - t - else - let (t,d) := td in - (Map.add i a t, d, l). - -Definition length {A:Type} (t:array A) : int := - let (_,l) := t in l. - -Definition copy {A:Type} (t:array A) : array A := t. - -Definition reroot : forall {A:Type}, array A -> array A := @copy. - -Definition init {A:Type} (l:int) (f:int -> A) (d:A) : array A := - let r := - if l == 0 then - Map.empty A - else - foldi (fun j m => Map.add j (f j) m) 0 (l-1) (Map.empty A) in - (r, d, l). - -Definition map {A B:Type} (f:A -> B) (t:array A) : array B := - let (td,l) := t in - let (t,d) := td in - (Map.map f t, f d, l). - -Module Export PArrayNotations. -Delimit Scope array_scope with array. -Notation "t '.[' i ']'" := (get t i) (at level 50) : array_scope. -Notation "t '.[' i '<-' a ']'" := (set t i a) (at level 50) : array_scope. -End PArrayNotations. - -Local Open Scope array_scope. - -Definition max_array_length := 4194302%int31. - -(** Axioms *) -Axiom get_outofbound : forall A (t:array A) i, (i < length t) = false -> t.[i] = default t. - -Axiom get_set_same : forall A t i (a:A), (i < length t) = true -> t.[i<-a].[i] = a. -Axiom get_set_other : forall A t i j (a:A), i <> j -> t.[i<-a].[j] = t.[j]. -Axiom default_set : forall A t i (a:A), default (t.[i<-a]) = default t. - - -Axiom get_make : forall A (a:A) size i, (make size a).[i] = a. -Axiom default_make : forall A (a:A) size, (default (make size a)) = a. - -Axiom ltb_length : forall A (t:array A), length t <= max_array_length = true. - -Axiom length_make : forall A size (a:A), - length (make size a) = if size <= max_array_length then size else max_array_length. -Axiom length_set : forall A t i (a:A), - length (t.[i<-a]) = length t. - -Axiom get_copy : forall A (t:array A) i, (copy t).[i] = t.[i]. -Axiom length_copy : forall A (t:array A), length (copy t) = length t. - -Axiom get_reroot : forall A (t:array A) i, (reroot t).[i] = t.[i]. -Axiom length_reroot : forall A (t:array A), length (reroot t) = length t. - - -Axiom length_init : forall A f size (def:A), - length (init size f def) = if size <= max_array_length then size else max_array_length. - -Axiom get_init : forall A f size (def:A) i, - (init size f def).[i] = if i < length (init size f def) then f i else def. - -Axiom default_init : forall A f size (def:A), default (init size f def) = def. - -(* Not true in this implementation (see #71, many thanks to Andres Erbsen) *) -(* -Axiom get_ext : forall A (t1 t2:array A), - length t1 = length t2 -> - (forall i, i < length t1 = true -> t1.[i] = t2.[i]) -> - default t1 = default t2 -> - t1 = t2. -*) - -(* Definition *) -Definition to_list {A:Type} (t:array A) := - let len := length t in - if 0 == len then nil - else foldi_down (fun i l => t.[i] :: l)%list (len - 1) 0 nil. - -Definition forallbi {A:Type} (f:int-> A->bool) (t:array A) := - let len := length t in - if 0 == len then true - else forallb (fun i => f i (t.[i])) 0 (len - 1). - -Definition forallb {A:Type} (f: A->bool) (t:array A) := - let len := length t in - if 0 == len then true - else forallb (fun i => f (t.[i])) 0 (len - 1). - -Definition existsbi {A:Type} (f:int->A->bool) (t:array A) := - let len := length t in - if 0 == len then false - else existsb (fun i => f i (t.[i])) 0 (len - 1). - -Definition existsb {A:Type} (f:A->bool) (t:array A) := - let len := length t in - if 0 == len then false - else existsb (fun i => f (t.[i])) 0 (len - 1). - -(* TODO : We should add init as native and add it *) -Definition mapi {A B:Type} (f:int->A->B) (t:array A) := - let size := length t in - let def := f size (default t) in - let tb := make size def in - if size == 0 then tb - else foldi (fun i tb => tb.[i<- f i (t.[i])]) 0 (size - 1) tb. - -Definition foldi_left {A B:Type} (f:int -> A -> B -> A) a (t:array B) := - let len := length t in - if 0 == len then a - else foldi (fun i a => f i a (t.[i])) 0 (len - 1) a. - -Definition fold_left {A B:Type} (f: A -> B -> A) a (t:array B) := - let len := length t in - if 0 == len then a - else foldi (fun i a => f a (t.[i])) 0 (length t - 1) a. - -Definition foldi_right {A B:Type} (f:int -> A -> B -> B) (t:array A) b := - let len := length t in - if 0 == len then b - else foldi_down (fun i b => f i (t.[i]) b) (len - 1) 0 b. - -Definition fold_right {A B:Type} (f: A -> B -> B) (t:array A) b := - let len := length t in - if 0 == len then b - else foldi_down (fun i b => f (t.[i]) b) (len - 1) 0 b. - -(* Lemmas *) - -Lemma default_copy : forall A (t:array A), default (copy t) = default t. -Proof. - intros A t;assert (length t < length t = false). - apply Bool.not_true_is_false; apply leb_not_gtb; apply leb_refl. - rewrite <- (get_outofbound _ (copy t) (length t)), <- (get_outofbound _ t (length t)), get_copy;trivial. -Qed. - -Lemma reroot_default : forall A (t:array A), default (reroot t) = default t. -Proof. - intros A t;assert (length t < length t = false). - apply Bool.not_true_is_false; apply leb_not_gtb; apply leb_refl. - rewrite <- (get_outofbound _ (reroot t) (length t)), <- (get_outofbound _ t (length t)), get_reroot;trivial. -Qed. - -Lemma get_set_same_default : - forall (A : Type) (t : array A) (i : int) , - (t .[ i <- default t]) .[ i] = default t. -Proof. - intros A t i;case_eq (i < (length t));intros. - rewrite get_set_same;trivial. - rewrite get_outofbound, default_set;trivial. - rewrite length_set;trivial. -Qed. - -Lemma get_not_default_lt : forall A (t:array A) x, - t.[x] <> default t -> x < length t = true. -Proof. - intros A t x Hd. - case_eq (x < length t);intros Heq;[trivial | ]. - elim Hd;rewrite get_outofbound;trivial. -Qed. - -Lemma foldi_left_Ind : - forall A B (P : int -> A -> Prop) (f : int -> A -> B -> A) (t:array B), - (forall a i, i < length t = true -> P i a -> P (i+1) (f i a (t.[i]))) -> - forall a, P 0 a -> - P (length t) (foldi_left f a t). -Proof. - intros;unfold foldi_left. - destruct (reflect_eqb 0 (length t)). - rewrite <- e;trivial. - assert ((length t - 1) + 1 = length t) by ring. - rewrite <- H1 at 1;apply foldi_Ind;auto. - assert (W:= leb_max_int (length t));rewrite leb_spec in W. - rewrite ltb_spec, to_Z_sub_1_diff;auto with zarith. - intros Hlt;elim (ltb_0 _ Hlt). - intros;apply H;trivial. rewrite ltb_leb_sub1;auto. -Qed. - -Lemma fold_left_Ind : - forall A B (P : int -> A -> Prop) (f : A -> B -> A) (t:array B), - (forall a i, i < length t = true -> P i a -> P (i+1) (f a (t.[i]))) -> - forall a, P 0 a -> - P (length t) (fold_left f a t). -Proof. - intros. - apply (foldi_left_Ind A B P (fun i => f));trivial. -Qed. - -Lemma fold_left_ind : - forall A B (P : A -> Prop) (f : A -> B -> A) (t:array B), - (forall a i, i < length t = true -> P a -> P (f a (t.[i]))) -> - forall a, P a -> - P (fold_left f a t). -Proof. - intros;apply (fold_left_Ind A B (fun _ => P));trivial. -Qed. - -Lemma foldi_right_Ind : - forall A B (P : int -> A -> Prop) (f : int -> B -> A -> A) (t:array B), - (forall a i, i < length t = true -> P (i+1) a -> P i (f i (t.[i]) a)) -> - forall a, P (length t) a -> - P 0 (foldi_right f t a). -Proof. - intros;unfold foldi_right. - destruct (reflect_eqb 0 (length t)). - rewrite e;trivial. - set (P' z a := (*-1 <= z < [|length t|] ->*) P (of_Z (z + 1)) a). - assert (P' ([|0|] - 1)%Z (foldi_down (fun (i : int) (b : A) => f i (t .[ i]) b) (length t - 1) 0 a)). - apply foldi_down_ZInd;unfold P'. - intros Hlt;elim (ltb_0 _ Hlt). - rewrite to_Z_sub_1_diff;auto. - ring_simplify ([|length t|] - 1 + 1)%Z;rewrite of_to_Z;trivial. - intros;ring_simplify ([|i|] - 1 + 1)%Z;rewrite of_to_Z;auto. - assert (i < length t = true). - rewrite ltb_leb_sub1;auto. - apply H;trivial. - exact H1. -Qed. - -Lemma fold_right_Ind : - forall A B (P : int -> A -> Prop) (f : B -> A -> A) (t:array B), - (forall a i, i < length t = true -> P (i+1) a -> P i (f (t.[i]) a)) -> - forall a, P (length t) a -> - P 0 (fold_right f t a). -Proof. - intros;apply (foldi_right_Ind A B P (fun i => f));trivial. -Qed. - -Lemma fold_right_ind : - forall A B (P : A -> Prop) (f : B -> A -> A) (t:array B), - (forall a i, i < length t = true -> P a -> P (f (t.[i]) a)) -> - forall a, P a -> - P (fold_right f t a). -Proof. - intros;apply (fold_right_Ind A B (fun i => P));trivial. -Qed. - -Lemma forallbi_spec : forall A (f : int -> A -> bool) t, - forallbi f t = true <-> forall i, i < length t = true -> f i (t.[i]) = true. -Proof. - unfold forallbi;intros A f t. - destruct (reflect_eqb 0 (length t)). - split;[intros | trivial]. - elim (ltb_0 i);rewrite e;trivial. - rewrite forallb_spec;split;intros Hi i;intros;apply Hi. - apply leb_0. rewrite <- ltb_leb_sub1;auto. rewrite ltb_leb_sub1;auto. -Qed. - -Lemma forallb_spec : forall A (f : A -> bool) t, - forallb f t = true <-> forall i, i < length t = true -> f (t.[i]) = true. -Proof. - intros A f;apply (forallbi_spec A (fun i => f)). -Qed. - -Lemma existsbi_spec : forall A (f : int -> A -> bool) t, - existsbi f t = true <-> exists i, i < length t = true /\ f i (t.[i]) = true. -Proof. - unfold existsbi;intros A f t. - destruct (reflect_eqb 0 (length t)). - split;[discriminate | intros [i [Hi _]];rewrite <- e in Hi;elim (ltb_0 _ Hi)]. - rewrite existsb_spec. repeat setoid_rewrite Bool.andb_true_iff. - split;intros [i H];decompose [and] H;clear H;exists i;repeat split;trivial. - rewrite ltb_leb_sub1;auto. apply leb_0. rewrite <- ltb_leb_sub1;auto. -Qed. - -Lemma existsb_spec : forall A (f : A -> bool) t, - existsb f t = true <-> exists i, i < length t = true /\ f (t.[i]) = true. -Proof. - intros A f;apply (existsbi_spec A (fun i => f)). -Qed. - -Local Open Scope list_scope. - -Definition to_list_ntr A (t:array A) := - let len := length t in - if 0 == len then nil - else foldi_ntr _ (fun i l => t.[i] :: l) 0 (len - 1) nil. - -Lemma to_list_to_list_ntr : forall A (t:array A), - to_list t = to_list_ntr _ t. -Proof. - unfold to_list, to_list_ntr; intros A t. - destruct (reflect_eqb 0 (length t));trivial. - rewrite foldi_ntr_foldi_down;trivial. - apply leb_ltb_trans with max_array_length;[ | trivial]. - apply leb_trans with (length t);[ | apply ltb_length]. - rewrite leb_spec, sub_spec. - rewrite to_Z_1, Zmod_small;try omega. - generalize (to_Z_bounded (length t)). - assert (0%Z <> [|length t|]);[ | omega]. - intros Heq;elim n;apply to_Z_inj;trivial. -Qed. - -Lemma fold_left_to_list : forall (A B:Type) (t:array A) (f: B -> A -> B) b, - fold_left f b t = List.fold_left f (to_list t) b. -Proof. - intros A B t f;rewrite to_list_to_list_ntr. - unfold fold_left, to_list_ntr; destruct (reflect_eqb 0 (length t));[trivial | ]. - set (P1 := fun i => forall b, - foldi (fun (i : int) (a : B) => f a (t .[ i])) i (length t - 1) b = - List.fold_left f - (foldi_ntr (list A) (fun (i : int) (l : list A) => t .[ i] :: l) i - (length t - 1) nil) b). - assert (W: P1 0);[ | trivial]. - apply int_ind_bounded with (max := length t - 1);unfold P1. - apply leb_0. - intros b;unfold foldi_ntr;rewrite foldi_eq, foldi_cont_eq;trivial. - intros i _ Hlt Hrec b. - unfold foldi_ntr;rewrite foldi_lt, foldi_cont_lt;trivial;simpl. - apply Hrec. -Qed. - -Require Import Bool. -Local Open Scope bool_scope. - -Definition eqb {A:Type} (Aeqb: A->A->bool) (t1 t2:array A) := - (length t1 == length t2) && - Aeqb (default t1) (default t2) && - forallbi (fun i a1 => Aeqb a1 (t2.[i])) t1. - -(* -Lemma reflect_eqb : forall (A:Type) (Aeqb:A->A->bool), - (forall a1 a2, reflect (a1 = a2) (Aeqb a1 a2)) -> - forall t1 t2, reflect (t1 = t2) (eqb Aeqb t1 t2). -Proof. - intros A Aeqb HA t1 t2. - case_eq (eqb Aeqb t1 t2);unfold eqb;intros H;constructor. - rewrite !andb_true_iff in H;destruct H as [[H1 H2] H3]. - apply get_ext. - rewrite (reflect_iff _ _ (reflect_eqb _ _));trivial. - rewrite forallbi_spec in H3. - intros i Hlt;rewrite (reflect_iff _ _ (HA _ _));auto. - rewrite (reflect_iff _ _ (HA _ _));trivial. - intros Heq;rewrite Heq in H;clear Heq. - revert H; rewrite Int63Axioms.eqb_refl;simpl. - case_eq (Aeqb (default t2) (default t2));simpl;intros H0 H1. - rewrite <- not_true_iff_false, forallbi_spec in H1;apply H1. - intros i _; rewrite <- (reflect_iff _ _ (HA _ _));trivial. - rewrite <- not_true_iff_false, <- (reflect_iff _ _ (HA _ _)) in H0;apply H0;trivial. -Qed. -*) - - -(* - Local Variables: - coq-load-path: ((rec "../../.." "SMTCoq")) - End: -*) diff --git a/src/versions/standard/Int63/Int63Axioms_standard.v b/src/versions/standard/Int63/Int63Axioms_standard.v deleted file mode 100644 index e9c2dfe..0000000 --- a/src/versions/standard/Int63/Int63Axioms_standard.v +++ /dev/null @@ -1,313 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -Require Import Bvector. -(* Require Export BigNumPrelude. *) -Require Import Int31 Cyclic31. -Require Export Int63Native. -Require Export Int63Op. -Require Import Psatz. - -Local Open Scope Z_scope. - - -(* Taken from BigNumPrelude *) - - 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 <- (Z.mul_1_r y);apply Z.mul_le_mono_nonneg;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. - - -(* Int63Axioms *) - -Definition wB := (2^(Z_of_nat size)). - -Notation "[| x |]" := (to_Z x) (at level 0, x at level 99) : int63_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. - -Local Open Scope int63_scope. -Local Open Scope Z_scope. - -(* Bijection : int63 <-> Bvector size *) - -Theorem to_Z_inj : forall x y, [|x|] = [|y|] -> x = y. -Proof Ring31.Int31_canonic. - -Theorem of_to_Z : forall x, of_Z ([|x|]) = x. -Proof. exact phi_inv_phi. Qed. - -(* Comparisons *) -Theorem eqb_refl x : (x == x)%int = true. -Proof. now rewrite Ring31.eqb31_eq. Qed. - -Theorem ltb_spec x y : (x < y)%int = true <-> [|x|] < [|y|]. -Proof. - unfold ltb. rewrite spec_compare, <- Z.compare_lt_iff. - change (phi x ?= phi y) with ([|x|] ?= [|y|]). - case ([|x|] ?= [|y|]); intuition; discriminate. -Qed. - -Theorem leb_spec x y : (x <= y)%int = true <-> [|x|] <= [|y|]. -Proof. - unfold leb. rewrite spec_compare, <- Z.compare_le_iff. - change (phi x ?= phi y) with ([|x|] ?= [|y|]). - case ([|x|] ?= [|y|]); intuition; discriminate. -Qed. - - -(** Specification of logical operations *) -Lemma lsl_spec_alt p : - forall x, [| addmuldiv31_alt p x 0 |] = ([|x|] * 2^(Z.of_nat p)) mod wB. -Proof. - induction p as [ |p IHp]; simpl; intro x. - - rewrite Z.mul_1_r. symmetry. apply Zmod_small. apply phi_bounded. - - rewrite IHp, phi_twice, Zmult_mod_idemp_l, Z.double_spec, - Z.mul_comm, Z.mul_assoc, Z.mul_comm, - Z.pow_pos_fold, Zpos_P_of_succ_nat, <- Z.add_1_r, Z.pow_add_r. - * reflexivity. - * apply Zle_0_nat. - * exact Z.le_0_1. -Qed. - -Theorem lsl_spec x p : [| x << p |] = ([|x|] * 2^[|p|]) mod wB. -Proof. - unfold lsl. - rewrite addmuldiv31_equiv, lsl_spec_alt, Nat2Z.inj_abs_nat, Z.abs_eq. - - reflexivity. - - now destruct (phi_bounded p). -Qed. - - -Lemma div_greater (p x:int) (H:Z.of_nat Int31.size <= [|p|]) : [|x|] / 2 ^ [|p|] = 0. -Proof. - apply Z.div_small. destruct (phi_bounded x) as [H1 H2]. split; auto. - apply (Z.lt_le_trans _ _ _ H2). apply Z.pow_le_mono_r; auto. - exact Z.lt_0_2. -Qed. - -Theorem lsr_spec x p : [|x >> p|] = [|x|] / 2 ^ [|p|]. -Proof. - unfold lsr. case_eq (p < 31%int31)%int; intro Heq. - - assert (H : [|31%int31 - p|] = 31 - [|p|]). - * rewrite spec_sub. rewrite Zmod_small; auto. - split. - + rewrite ltb_spec in Heq. assert (forall x y, x < y -> 0 <= y - x) by (intros;lia); auto. - + assert (H:forall x y z, 0 <= y /\ x < z -> x - y < z) by (intros;lia). - apply H. destruct (phi_bounded p). destruct (phi_bounded (31%int31)). split; auto. - * rewrite spec_add_mul_div. - + rewrite Z.add_0_l. change (phi (31%int31 - p)) with [|31%int31 - p|]. rewrite H. replace (31 - (31 - [|p|])) with [|p|] by ring. apply Zmod_small. split. - ++ apply div_le_0. now destruct (phi_bounded x). - ++ apply div_lt. apply phi_bounded. - + change (phi (31%int31 - p)) with [|31%int31 - p|]. rewrite H. assert (forall x y, 0 <= y -> x - y <= x) by (intros;lia). apply H0. now destruct (phi_bounded p). - - rewrite div_greater; auto. - destruct (Z.le_gt_cases [|31%int31|] [|p|]); auto. - rewrite <- ltb_spec in H. rewrite H in Heq. discriminate. -Qed. - - -Lemma bit_testbit x i : bit x i = Z.testbit [|x|] [|i|]. -Admitted. -(* Proof. *) -(* case_eq [|i|]. *) -(* - simpl. change 0 with [|0|]. intro Heq. apply Ring31.Int31_canonic in Heq. subst i. *) -(* unfold bit. *) - - -Lemma Z_pos_xO_pow i x (Hi:0 <= i) : Z.pos x < 2 ^ i <-> Z.pos x~0 < 2 ^ (i+1). -Proof. rewrite Pos2Z.inj_xO, Z.pow_add_r; auto using Z.le_0_1; lia. Qed. - -Lemma Z_pos_xI_pow i x (Hi:0 <= i) : Z.pos x < 2 ^ i <-> Z.pos x~1 < 2 ^ (i+1). -Proof. rewrite Pos2Z.inj_xI, Z.pow_add_r; auto using Z.le_0_1; lia. Qed. - -Lemma pow_nonneg i (Hi : 1 <= 2 ^ i) : 0 <= i. -Proof. - destruct (Z.le_gt_cases 0 i); auto. - rewrite (Z.pow_neg_r _ _ H) in Hi. lia. -Qed. - -Lemma pow_pos i (Hi : 1 < 2 ^ i) : 0 < i. -Proof. - destruct (Z.lt_trichotomy 0 i) as [H|[H|H]]; auto. - - subst i. lia. - - rewrite (Z.pow_neg_r _ _ H) in Hi. lia. -Qed. - -Lemma pos_land_bounded : forall x y i, - Z.pos x < 2 ^ i -> Z.pos y < 2 ^ i -> Z.of_N (Pos.land x y) < 2 ^ i. -Proof. - induction x as [x IHx|x IHx| ]; intros [y|y| ] i; auto. - - simpl. intro H. - assert (H4:0 <= i - 1) by (assert (H4:0 < i); try lia; apply pow_pos; apply (Z.le_lt_trans _ (Z.pos x~1)); auto; lia). - generalize H. replace i with ((i-1)+1) at 1 2 by ring. rewrite <- !Z_pos_xI_pow; auto. intros H1 H2. - assert (H3:=IHx _ _ H1 H2). - unfold Pos.Nsucc_double. case_eq (Pos.land x y). - * intros _. eapply Z.le_lt_trans; [ |exact H]. clear. lia. - * intros p Hp. revert H3. rewrite Hp, N2Z.inj_pos, Z_pos_xI_pow; auto. - replace (i - 1 + 1) with i by ring. clear. lia. - - simpl. intro H. - assert (H4:0 <= i - 1) by (assert (H4:0 < i); try lia; apply pow_pos; apply (Z.le_lt_trans _ (Z.pos x~1)); auto; lia). - generalize H. replace i with ((i-1)+1) at 1 2 by ring. rewrite <- Z_pos_xI_pow, <- Z_pos_xO_pow; auto. intros H1 H2. - assert (H3:=IHx _ _ H1 H2). - unfold Pos.Ndouble. case_eq (Pos.land x y). - * intros _. eapply Z.le_lt_trans; [ |exact H]. clear. lia. - * intros p Hp. revert H3. rewrite Hp, N2Z.inj_pos, Z_pos_xO_pow; auto. - replace (i - 1 + 1) with i by ring. clear. lia. - - simpl. intro H. - assert (H4:0 <= i - 1) by (assert (H4:0 < i); try lia; apply pow_pos; apply (Z.le_lt_trans _ (Z.pos x~0)); auto; lia). - generalize H. replace i with ((i-1)+1) at 1 2 by ring. rewrite <- Z_pos_xI_pow, <- Z_pos_xO_pow; auto. intros H1 H2. - assert (H3:=IHx _ _ H1 H2). - unfold Pos.Ndouble. case_eq (Pos.land x y). - * intros _. eapply Z.le_lt_trans; [ |exact H]. clear. lia. - * intros p Hp. revert H3. rewrite Hp, N2Z.inj_pos, Z_pos_xO_pow; auto. - replace (i - 1 + 1) with i by ring. clear. lia. - - simpl. intro H. - assert (H4:0 <= i - 1) by (assert (H4:0 < i); try lia; apply pow_pos; apply (Z.le_lt_trans _ (Z.pos x~0)); auto; lia). - generalize H. replace i with ((i-1)+1) at 1 2 by ring. rewrite <- !Z_pos_xO_pow; auto. intros H1 H2. - assert (H3:=IHx _ _ H1 H2). - unfold Pos.Ndouble. case_eq (Pos.land x y). - * intros _. eapply Z.le_lt_trans; [ |exact H]. clear. lia. - * intros p Hp. revert H3. rewrite Hp, N2Z.inj_pos, Z_pos_xO_pow; auto. - replace (i - 1 + 1) with i by ring. clear. lia. - - simpl. intros H _. apply (Z.le_lt_trans _ (Z.pos x~0)); lia. - - simpl. intros H _. apply (Z.le_lt_trans _ 1); lia. -Qed. - - -Lemma Z_land_bounded i : forall x y, - 0 <= x < 2 ^ i -> 0 <= y < 2 ^ i -> 0 <= Z.land x y < 2 ^ i. -Proof. - intros [ |p|p] [ |q|q]; auto. - - intros [_ H1] [_ H2]. simpl. split. - * apply N2Z.is_nonneg. - * now apply pos_land_bounded. -Admitted. - -Theorem land_spec x y i : bit (x land y) i = bit x i && bit y i. -Proof. - rewrite !bit_testbit. change (x land y) with (land31 x y). unfold land31. - rewrite phi_phi_inv. rewrite Zmod_small. - - apply Z.land_spec. - - split. - * rewrite Z.land_nonneg. left. now destruct (phi_bounded x). - * now destruct (Z_land_bounded _ _ _ (phi_bounded x) (phi_bounded y)). -Qed. - - -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|]. - -(** Iterators *) - -Axiom foldi_cont_gt : forall A B f from to cont, - (to < from)%int = true -> foldi_cont (A:=A) (B:=B) f from to cont = cont. - -Axiom foldi_cont_eq : forall A B f from to cont, - from = to -> foldi_cont (A:=A) (B:=B) f from to cont = f from cont. - -Axiom foldi_cont_lt : forall A B f from to cont, - (from < to)%int = true-> - foldi_cont (A:=A) (B:=B) f from to cont = - f from (fun a' => foldi_cont f (from + 1%int) to cont a'). - -Axiom foldi_down_cont_lt : forall A B f from downto cont, - (from < downto)%int = true -> foldi_down_cont (A:=A) (B:=B) f from downto cont = cont. - -Axiom foldi_down_cont_eq : forall A B f from downto cont, - from = downto -> foldi_down_cont (A:=A) (B:=B) f from downto cont = f from cont. - -Axiom foldi_down_cont_gt : forall A B f from downto cont, - (downto < from)%int = true-> - foldi_down_cont (A:=A) (B:=B) f from downto cont = - f from (fun a' => foldi_down_cont f (from-1) downto cont a'). - -(** Print *) - -Axiom print_int_spec : forall x, x = print_int x. - -(** 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)%int = 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)%int = 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. - - -(* - Local Variables: - coq-load-path: ((rec "../../.." "SMTCoq")) - End: -*) diff --git a/src/versions/standard/Int63/Int63Native_standard.v b/src/versions/standard/Int63/Int63Native_standard.v deleted file mode 100644 index 9fd425b..0000000 --- a/src/versions/standard/Int63/Int63Native_standard.v +++ /dev/null @@ -1,143 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -Require Export DoubleType. -Require Import Int31 Cyclic31 Ring31. -Require Import ZArith. -Require Import Bool. - - -Definition size := size. - -Notation int := int31. - -Delimit Scope int63_scope with int. -Bind Scope int63_scope with int. - -(* Some constants *) -Notation "0" := 0%int31 : int63_scope. -Notation "1" := 1%int31 : int63_scope. -Notation "2" := 2%int31 : int63_scope. -Notation "3" := 3%int31 : int63_scope. - -(* Comparisons *) -Definition eqb := eqb31. -Notation "m '==' n" := (eqb m n) (at level 70, no associativity) : int63_scope. - -Definition ltb : int -> int -> bool := - fun i j => match compare31 i j with | Lt => true | _ => false end. -Notation "m < n" := (ltb m n) : int63_scope. - -Definition leb : int -> int -> bool := - fun i j => match compare31 i j with | Gt => false | _ => true end. -Notation "m <= n" := (leb m n) : int63_scope. - - -Lemma eqb_correct : forall i j, (i==j)%int = true -> i = j. -Proof. exact eqb31_correct. Qed. - -(* Logical operations *) -Definition lsl : int -> int -> int := - fun i j => addmuldiv31 j i 0. -Infix "<<" := lsl (at level 30, no associativity) : int63_scope. - -Definition lsr : int -> int -> int := - fun i j => if (j < 31%int31)%int then addmuldiv31 (31-j)%int31 0 i else 0%int31. -Infix ">>" := lsr (at level 30, no associativity) : int63_scope. - -Definition land : int -> int -> int := land31. -Global Arguments land i j : simpl never. -Global Opaque land. -Infix "land" := land (at level 40, left associativity) : int63_scope. - -Definition lor : int -> int -> int := lor31. -Global Arguments lor i j : simpl never. -Global Opaque lor. -Infix "lor" := lor (at level 40, left associativity) : int63_scope. - -Definition lxor : int -> int -> int := lxor31. -Global Arguments lxor i j : simpl never. -Global Opaque lxor. -Infix "lxor" := lxor (at level 40, left associativity) : int63_scope. - -(* Arithmetic modulo operations *) -Notation "n + m" := (add31 n m) : int63_scope. -Notation "n - m" := (sub31 n m) : int63_scope. -Notation "n * m" := (mul31 n m) : int63_scope. - -Definition mulc : int -> int -> int * int := - fun i j => match mul31c i j with - | W0 => (0%int, 0%int) - | WW h l => (h, l) - end. - -Definition div : int -> int -> int := - fun i j => let (q,_) := div31 i j in q. -Notation "n / m" := (div n m) : int63_scope. - -Definition modulo : int -> int -> int := - fun i j => let (_,r) := div31 i j in r. -Notation "n '\%' m" := (modulo n m) (at level 40, left associativity) : int63_scope. - - -(* Iterators *) - -Definition firstr i := if ((i land 1) == 0)%int then D0 else D1. -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 (i == 0)%int then - case0 - else - let si := (i >> 1)%int in - caserec (firstr i) si (recr_aux next A case0 caserec si) - end. -Definition recr := recr_aux size. -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. - -Definition foldi_cont - {A B : Type} - (f : int -> (A -> B) -> A -> B) - (from to : int) - (cont : A -> B) : A -> B := - if ltb to from then - cont - else - let (_,r) := iter_int31 (to - from) _ (fun (jy: (int * (A -> B))%type) => - let (j,y) := jy in ((j-1)%int, f j y) - ) (to, cont) in - f from r. - -Definition foldi_down_cont - {A B : Type} - (f : int -> (A -> B) -> A -> B) - (from downto : int) - (cont : A -> B) : A -> B := - if ltb from downto then - cont - else - let (_,r) := iter_int31 (from - downto) _ (fun (jy: (int * (A -> B))%type) => - let (j,y) := jy in ((j+1)%int, f j y) - ) (downto, cont) in - f from r. - -(* Fake print *) - -Definition print_int : int -> int := fun i => i. diff --git a/src/versions/standard/Int63/Int63Op_standard.v b/src/versions/standard/Int63/Int63Op_standard.v deleted file mode 100644 index 2998adb..0000000 --- a/src/versions/standard/Int63/Int63Op_standard.v +++ /dev/null @@ -1,334 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -Require Import Int31 Cyclic31. -Require Export Int63Native. -(* Require Import BigNumPrelude. *) -Require Import Bvector. - - -Local Open Scope int63_scope. - -(** The number of digits as a int *) -Definition digits := 31%int31. - -(** The bigger int *) -Definition max_int := Eval vm_compute in 0 - 1. - -(** Access to the nth digits *) -Definition get_digit x p := (0 < (x land (1 << p))). - -Definition set_digit x p (b:bool) := - if (0 <= p) && (p < digits) 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. - -(** Parity *) -Definition is_even (i:int) := is_zero (i land 1). - -(** 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. -Notation "- x" := (opp x) : int63_scope. - -Definition oppcarry i := max_int - i. - -Definition succ i := i + 1. - -Definition pred i := i - 1. - -Definition addcarry i j := i + j + 1. - -Definition subcarry i j := i - j - 1. - -(** 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 efficiancy *) -Definition addc : int -> int -> carry int := add31c. -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 efficiancy *) -Definition addcarryc : int -> int -> carry int := add31carryc. - -Definition subc_def x y := - if y <= x then C0 (x - y) else C1 (x - y). -(* the same but direct implementation for efficiancy *) -Definition subc : int -> int -> carry int := sub31c. -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 efficiancy *) -Definition subcarryc : int -> int -> carry int := sub31carryc. - -Definition diveucl_def x y := (x/y, x\%y). -(* the same but direct implementation for efficiancy *) -Definition diveucl : int -> int -> int * int := div31. - -Definition diveucl_21 : int -> int -> int -> int * int := div3121. - -Definition addmuldiv_def p x y := - (x << p) lor (y >> (digits - p)). -(* the same but direct implementation for efficiancy *) -Definition addmuldiv : int -> int -> int -> int := addmuldiv31. - -Definition oppc (i:int) := 0 -c i. - -Definition succc i := i +c 1. - -Definition predc i := i -c 1. - -(** Comparison *) -Definition compare_def x y := - if x < y then Lt - else if (x == y) then Eq else Gt. - -Definition compare : int -> int -> comparison := compare31. -Notation "n ?= m" := (compare n m) (at level 70, no associativity) : int63_scope. - -(** Exotic operations *) - -(** I should add the definition (like for compare) *) -Definition head0 : int -> int := head031. -Definition tail0 : int -> int := tail031. - -(** Iterators *) - -Definition foldi {A} (f:int -> A -> A) from to := - foldi_cont (fun i cont a => cont (f i a)) from to (fun a => a). - -Definition fold {A} (f: A -> A) from to := - foldi_cont (fun i cont a => cont (f a)) from to (fun a => a). - -Definition foldi_down {A} (f:int -> A -> A) from downto := - foldi_down_cont (fun i cont a => cont (f i a)) from downto (fun a => a). - -Definition fold_down {A} (f:A -> A) from downto := - foldi_down_cont (fun i cont a => cont (f a)) from downto (fun a => a). - -Definition forallb (f:int -> bool) from to := - foldi_cont (fun i cont _ => if f i then cont tt else false) from to (fun _ => true) tt. - -Definition existsb (f:int -> bool) from to := - foldi_cont (fun i cont _ => if f i then true else cont tt) from to (fun _ => false) tt. - -(** Translation to Z *) - -(* Fixpoint to_Z_rec (n:nat) (i:int) := *) -(* match n with *) -(* | O => 0%Z *) -(* | S n => *) -(* (if is_even i then Zdouble else Zdouble_plus_one) (to_Z_rec n (i >> 1)) *) -(* end. *) - -(* Definition to_Z := to_Z_rec size. *) - -Definition to_Z := phi. -Definition of_Z := phi_inv. - -(* 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. *) - -(** 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). - -(** Square root functions using newton iteration **) - -Definition sqrt_step (rec: int -> int -> int) (i j: int) := - let quo := i/j in - if quo < j then rec i ((j + (i/j)%int) >> 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. - -(* Extra function on equality *) - -Definition cast_digit d1 d2 : - option (forall P : Int31.digits -> Type, P d1 -> P d2) := - match d1, d2 with - | D0, D0 | D1, D1 => Some (fun P h => h) - | _, _ => None - end. - -(* May need to improve this definition, but no reported efficiency problem for the moment *) -Definition cast i j : - option (forall P : int -> Type, P i -> P j) := - match i, j return option (forall P : int -> Type, P i -> P j) with - | I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d21 d22 d23 d24 d25 d26 d27 d28 d29 d30, I31 d'0 d'1 d'2 d'3 d'4 d'5 d'6 d'7 d'8 d'9 d'10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30 => - match - cast_digit d0 d'0, - cast_digit d1 d'1, - cast_digit d2 d'2, - cast_digit d3 d'3, - cast_digit d4 d'4, - cast_digit d5 d'5, - cast_digit d6 d'6, - cast_digit d7 d'7, - cast_digit d8 d'8, - cast_digit d9 d'9, - cast_digit d10 d'10, - cast_digit d11 d'11, - cast_digit d12 d'12, - cast_digit d13 d'13, - cast_digit d14 d'14, - cast_digit d15 d'15, - cast_digit d16 d'16, - cast_digit d17 d'17, - cast_digit d18 d'18, - cast_digit d19 d'19, - cast_digit d20 d'20, - cast_digit d21 d'21, - cast_digit d22 d'22, - cast_digit d23 d'23, - cast_digit d24 d'24, - cast_digit d25 d'25, - cast_digit d26 d'26, - cast_digit d27 d'27, - cast_digit d28 d'28, - cast_digit d29 d'29, - cast_digit d30 d'30 - with - | Some k0, - Some k1, - Some k2, - Some k3, - Some k4, - Some k5, - Some k6, - Some k7, - Some k8, - Some k9, - Some k10, - Some k11, - Some k12, - Some k13, - Some k14, - Some k15, - Some k16, - Some k17, - Some k18, - Some k19, - Some k20, - Some k21, - Some k22, - Some k23, - Some k24, - Some k25, - Some k26, - Some k27, - Some k28, - Some k29, - Some k30 => - Some (fun P h => - k0 (fun d0 => P (I31 d0 d'1 d'2 d'3 d'4 d'5 d'6 d'7 d'8 d'9 d'10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k1 (fun d1 => P (I31 d0 d1 d'2 d'3 d'4 d'5 d'6 d'7 d'8 d'9 d'10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k2 (fun d2 => P (I31 d0 d1 d2 d'3 d'4 d'5 d'6 d'7 d'8 d'9 d'10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k3 (fun d3 => P (I31 d0 d1 d2 d3 d'4 d'5 d'6 d'7 d'8 d'9 d'10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k4 (fun d4 => P (I31 d0 d1 d2 d3 d4 d'5 d'6 d'7 d'8 d'9 d'10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k5 (fun d5 => P (I31 d0 d1 d2 d3 d4 d5 d'6 d'7 d'8 d'9 d'10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k6 (fun d6 => P (I31 d0 d1 d2 d3 d4 d5 d6 d'7 d'8 d'9 d'10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k7 (fun d7 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d'8 d'9 d'10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k8 (fun d8 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d'9 d'10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k9 (fun d9 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d'10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k10 (fun d10 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d'11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k11 (fun d11 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d'12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k12 (fun d12 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d'13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k13 (fun d13 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d'14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k14 (fun d14 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d'15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k15 (fun d15 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d'16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k16 (fun d16 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d'17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k17 (fun d17 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d'18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k18 (fun d18 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d'19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k19 (fun d19 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d'20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k20 (fun d20 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d'21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k21 (fun d21 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d21 d'22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k22 (fun d22 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d21 d22 d'23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k23 (fun d23 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d21 d22 d23 d'24 d'25 d'26 d'27 d'28 d'29 d'30)) (k24 (fun d24 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d21 d22 d23 d24 d'25 d'26 d'27 d'28 d'29 d'30)) (k25 (fun d25 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d21 d22 d23 d24 d25 d'26 d'27 d'28 d'29 d'30)) (k26 (fun d26 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d21 d22 d23 d24 d25 d26 d'27 d'28 d'29 d'30)) (k27 (fun d27 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d21 d22 d23 d24 d25 d26 d27 d'28 d'29 d'30)) (k28 (fun d28 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d21 d22 d23 d24 d25 d26 d27 d28 d'29 d'30)) (k29 (fun d29 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d21 d22 d23 d24 d25 d26 d27 d28 d29 d'30)) (k30 (fun d30 => P (I31 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19 d20 d21 d22 d23 d24 d25 d26 d27 d28 d29 d30)) h))))))))))))))))))))))))))))))) - | _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _ => None - end - end. - - -Definition eqo i j : option (i = j) := - match cast i j with - | Some k => Some (k (fun j => i = j) (refl_equal i)) - | None => None - end. - - -(* - Local Variables: - coq-load-path: ((rec "../../.." "SMTCoq")) - End: -*) diff --git a/src/versions/standard/Int63/Int63Properties_standard.v b/src/versions/standard/Int63/Int63Properties_standard.v deleted file mode 100644 index a55295e..0000000 --- a/src/versions/standard/Int63/Int63Properties_standard.v +++ /dev/null @@ -1,2768 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -Require Import Zgcd_alt. -Require Import Bvector. -Require Import Int31 Cyclic31. -Require Export Int63Axioms. -Require Import Eqdep_dec. -Require Import Psatz. -Require Import Znumtheory Zpow_facts. - -Local Open Scope int63_scope. -Local Open Scope Z_scope. - - -Notation Zpower_2 := Z.pow_2_r. -Notation Zpower_Zsucc := Z.pow_succ_r. - - -(* Taken from BigNumPrelude *) - -Lemma Zlt0_not_eq : forall n, 0<n -> n<>0. -Proof. - auto with zarith. -Qed. - -Definition Z_div_plus_l a b c H := Zdiv.Z_div_plus_full_l a b c (Zlt0_not_eq _ H). - -Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. - Proof. - intros a b H H1;case (Z_mod_lt a b);auto with zarith;intros H2 H3;split;auto. - case (Z.le_gt_cases b a); intros H4; auto with zarith. - rewrite Zmod_small; auto with zarith. - Qed. - - -(** Trivial lemmas without axiom *) - -Lemma wB_diff_0 : wB <> 0. -Proof. compute;discriminate. 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. - -(** 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. - -(* TODO: fill these proofs *) -Lemma cast_refl : forall i, cast i i = Some (fun P H => H). -Admitted. -(* Proof. *) -(* unfold cast;intros. *) -(* generalize (eqb_correct i i). *) -(* rewrite eqb_refl;intros. *) -(* rewrite (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. -Admitted. -(* Proof. *) -(* intros;unfold cast;intros; generalize (eqb_correct i j). *) -(* rewrite H;trivial. *) -(* Qed. *) - -Lemma eqo_refl : forall i, eqo i i = Some (eq_refl i). -Admitted. -(* Proof. *) -(* unfold eqo;intros. *) -(* generalize (eqb_correct i i). *) -(* rewrite eqb_refl;intros. *) -(* rewrite (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. -Admitted. -(* Proof. *) -(* unfold eqo;intros; generalize (eqb_correct i j). *) -(* rewrite H;trivial. *) -(* Qed. *) - -(** translation with Z *) -Require Import Ndigits. - -Lemma Z_of_N_double : forall n, Z_of_N (N.double n) = Z.double (Z_of_N n). -Proof. - destruct n;simpl;trivial. -Qed. - -Lemma Z_of_N_double_plus_one : forall n, Z_of_N (Ndouble_plus_one n) = Zdouble_plus_one (Z_of_N n). -Proof. - destruct n;simpl;trivial. -Qed. - -Lemma to_Z_bounded : forall x, 0 <= [|x|] < wB. -Proof. apply phi_bounded. Qed. -(* unfold to_Z, wB;induction size;intros. *) -(* simpl;auto with zarith. *) -(* rewrite inj_S;simpl;assert (W:= IHn (x >> 1)%int). *) -(* rewrite Zpower_Zsucc;auto with zarith. *) -(* destruct (is_even x). *) -(* rewrite Z.double_mult;auto with zarith. *) -(* rewrite Zdouble_plus_one_mult;auto with zarith. *) -(* Qed. *) - -(* TODO: move_this *) -(* Lemma orb_true_iff : forall b1 b2, b1 || b2 = true <-> b1 = true \/ b2 = true. *) -(* Proof. *) -(* split;intros;[apply orb_prop | apply orb_true_intro];trivial. *) -(* Qed. *) - -Lemma to_Z_eq : forall x y, [|x|] = [|y|] <-> x = y. -Proof. - split;intros;subst;trivial. - apply to_Z_inj;trivial. -Qed. - -Lemma leb_ltb_eqb : forall x y, ((x <= y) = (x < y) || (x == y))%int. -Proof. - intros. - apply eq_true_iff_eq. - rewrite leb_spec, orb_true_iff, ltb_spec, eqb_spec, <- to_Z_eq;omega. -Qed. - - -(** Comparison *) - -Lemma compare_spec : - forall x y, compare x y = ([|x|] ?= [|y|]). -Proof. - intros;rewrite compare_def_spec;unfold compare_def. - case_eq (x < y)%int;intros Heq. - rewrite ltb_spec in Heq. - red in Heq;rewrite Heq;trivial. - rewrite <- not_true_iff_false, ltb_spec in Heq. - case_eq (x == y)%int;intros Heq1. - rewrite eqb_spec in Heq1;rewrite Heq1, Z.compare_refl;trivial. - rewrite <- not_true_iff_false, eqb_spec in Heq1. - symmetry;change ([|x|] > [|y|]);rewrite <- to_Z_eq in Heq1;omega. -Qed. - -Lemma is_zero_spec : forall x : int, is_zero x = true <-> x = 0%int. -Proof. - unfold is_zero;intros;apply eqb_spec. -Qed. - - -(** Addition *) - -Lemma addc_spec : forall x y, [+|x +c y|] = [|x|] + [|y|]. -Proof. - intros;rewrite addc_def_spec;unfold addc_def. - assert (W1 := to_Z_bounded x); assert (W2 := to_Z_bounded y). - case_eq ((x + y < x)%int). - rewrite ltb_spec;intros. - change (wB + [|x+y|] = [|x|] + [|y|]). - rewrite add_spec in H |- *. - assert ([|x|] + [|y|] >= wB). - destruct (Z_lt_ge_dec ([|x|] + [|y|]) wB);auto with zarith. - elimtype False;rewrite Zmod_small in H;auto with zarith. - assert (([|x|] + [|y|]) mod wB = [|x|] + [|y|] - wB). - symmetry;apply Zmod_unique with 1;auto with zarith. - rewrite H1;ring. - rewrite <- not_true_iff_false, ltb_spec;intros. - change ([|x+y|] = [|x|] + [|y|]). - rewrite add_spec in *. - assert ([|x|] + [|y|] < wB). - destruct (Z_lt_ge_dec ([|x|] + [|y|]) wB);auto with zarith. - assert (([|x|] + [|y|]) mod wB = [|x|] + [|y|] - wB). - symmetry;apply Zmod_unique with 1;auto with zarith. - elim H;omega. - rewrite Zmod_small;auto with zarith. -Qed. - - -Lemma succc_spec : forall x, [+|succc x|] = [|x|] + 1. -Proof. intros; unfold succc; apply addc_spec. Qed. - -Lemma addcarry_spec : forall x y, [|addcarry x y|] = ([|x|] + [|y|] + 1) mod wB. -Proof. - unfold addcarry;intros. - rewrite add_spec,add_spec,Zplus_mod_idemp_l;trivial. -Qed. - -Lemma addcarryc_spec : forall x y, [+|addcarryc x y|] = [|x|] + [|y|] + 1. -Proof. - intros;rewrite addcarryc_def_spec;unfold addcarryc_def. - assert (W1 := to_Z_bounded x); assert (W2 := to_Z_bounded y). - case_eq ((addcarry x y <= x)%int). - rewrite leb_spec;intros. - change (wB + [|(addcarry x y)|] = [|x|] + [|y|] + 1). - rewrite addcarry_spec in H |- *. - assert ([|x|] + [|y|] + 1 >= wB). - destruct (Z_lt_ge_dec ([|x|] + [|y|] + 1) wB);auto with zarith. - elimtype False;rewrite Zmod_small in H;auto with zarith. - assert (([|x|] + [|y|] + 1) mod wB = [|x|] + [|y|] + 1 - wB). - symmetry;apply Zmod_unique with 1;auto with zarith. - rewrite H1;ring. - rewrite <- not_true_iff_false, leb_spec;intros. - change ([|addcarry x y|] = [|x|] + [|y|] + 1). - rewrite addcarry_spec in *. - assert ([|x|] + [|y|] + 1 < wB). - destruct (Z_lt_ge_dec ([|x|] + [|y|] + 1) wB);auto with zarith. - assert (([|x|] + [|y|] + 1) mod wB = [|x|] + [|y|] + 1 - wB). - symmetry;apply Zmod_unique with 1;auto with zarith. - elim H;omega. - rewrite Zmod_small;auto with zarith. -Qed. - -Lemma succ_spec : forall x, [|succ x|] = ([|x|] + 1) mod wB. -Proof. intros; apply add_spec. Qed. - -(** Subtraction *) -Lemma subc_spec : forall x y, [-|x -c y|] = [|x|] - [|y|]. -Proof. - intros;rewrite subc_def_spec;unfold subc_def. - assert (W1 := to_Z_bounded x); assert (W2 := to_Z_bounded y). - case_eq (y <= x)%int. - rewrite leb_spec;intros. - change ([|x - y|] = [|x|] - [|y|]). - rewrite sub_spec. - rewrite Zmod_small;auto with zarith. - rewrite <- not_true_iff_false, leb_spec;intros. - change (-wB + [|x - y|] = [|x|] - [|y|]). - rewrite sub_spec. - assert (([|x|] - [|y|]) mod wB = [|x|] - [|y|] + wB). - symmetry;apply Zmod_unique with (-1);auto with zarith. - rewrite H0;ring. -Qed. - -Lemma subcarry_spec : - forall x y, [|subcarry x y|] = ([|x|] - [|y|] - 1) mod wB. -Proof. - unfold subcarry; intros. - rewrite sub_spec,sub_spec,Zminus_mod_idemp_l;trivial. -Qed. - -Lemma subcarryc_spec : forall x y, [-|subcarryc x y|] = [|x|] - [|y|] - 1. - intros;rewrite subcarryc_def_spec;unfold subcarryc_def. - assert (W1 := to_Z_bounded x); assert (W2 := to_Z_bounded y). - (* fold (subcarry x y). *) - replace ((x - y - 1)%int) with (subcarry x y) by reflexivity. - case_eq (y < x)%int. - rewrite ltb_spec;intros. - change ([|subcarry x y|] = [|x|] - [|y|] - 1). - rewrite subcarry_spec. - rewrite Zmod_small;auto with zarith. - rewrite <- not_true_iff_false, ltb_spec;intros. - change (-wB + [|subcarry x y|] = [|x|] - [|y|] - 1). - rewrite subcarry_spec. - assert (([|x|] - [|y|] - 1) mod wB = [|x|] - [|y|] - 1 + wB). - symmetry;apply Zmod_unique with (-1);auto with zarith. - rewrite H0;ring. -Qed. - -Lemma oppc_spec : forall x : int, [-|oppc x|] = - [|x|]. -Proof. - unfold oppc;intros;rewrite subc_spec, to_Z_0;trivial. -Qed. - -Lemma opp_spec : forall x : int, [|- x|] = - [|x|] mod wB. -Proof. - unfold opp;intros. rewrite sub_spec, to_Z_0;trivial. -Qed. - -Lemma oppcarry_spec : forall x, [|oppcarry x|] = wB - [|x|] - 1. -Proof. - unfold oppcarry;intros. - rewrite sub_spec. - change [|max_int|] with (wB - 1). - rewrite <- Zminus_plus_distr, Zplus_comm, Zminus_plus_distr. - apply Zmod_small. - generalize (to_Z_bounded x);auto with zarith. -Qed. - -Lemma predc_spec : forall x, [-|predc x|] = [|x|] - 1. -Proof. intros; unfold predc; apply subc_spec. Qed. - -Lemma pred_spec : forall x, [|pred x|] = ([|x|] - 1) mod wB. -Proof. intros; unfold pred; apply sub_spec. Qed. - -Lemma diveucl_spec : - forall x y, - let (q,r) := diveucl x y in - ([|q|],[|r|]) = Z.div_eucl [|x|] [|y|]. -Proof. - intros;rewrite diveucl_def_spec. - unfold diveucl_def;rewrite div_spec, mod_spec. - unfold Z.div, Zmod;destruct (Z.div_eucl [|x|] [|y|]);trivial. -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 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 Zpower_2, 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 Zpower_2; - 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 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 _ _ (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_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 Zpower_2, 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 Zpower_2 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_test_true i j: 0 <= i -> 0 < j -> i/j >= j -> j ^ 2 <= i. -Proof. - intros Hi Hj Hd; rewrite Zpower_2. - 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 (Zle_or_lt j ((j + (i/j))/2)); auto. - intros H1; contradict H; apply Zle_not_lt. - 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 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_eq ((i / j < j)%int);[ | rewrite <- Bool.not_true_iff_false]; - rewrite ltb_spec, div_spec;intros. - assert ([| j + (i / j)%int|] = [|j|] + [|i|]/[|j|]). - { - rewrite add_spec, Zmod_small;rewrite div_spec; auto with zarith. - split. - - apply Z.add_nonneg_nonneg. - + apply Z.lt_le_incl; apply Z.le_lt_trans with (2 := H). apply Z_div_pos. - * apply Z.lt_gt. abstract omega. - * abstract omega. - + apply Z_div_pos. - * apply Z.lt_gt. assumption. - * abstract omega. - - abstract omega. - } - apply Hrec;rewrite lsr_spec, H0, 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|]));[ | 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. - case (Zle_lt_or_eq 1 [|j|]); auto with zarith. - { - intro. apply Z_div_pos. - - apply Zgt_pos_0. - - apply Z.add_nonneg_nonneg. - + abstract omega. - + assumption. - } - intros Hj1. - rewrite <- Hj1, Zdiv_1_r. - assert (0 <= ([|i|] - 1) /2)%Z;[ |apply Z_div_pos]; auto with zarith. - { - apply Z_div_pos. - - apply Zgt_pos_0. - - abstract omega. - } - 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. replace (and (Z.le (Z.pow (to_Z match ltb (div i j) j return int with | true => rec i (lsr (add31 j (div i j)) In) | false => j end) (Zpos (xO xH))) (to_Z i)) (Z.lt (to_Z i) (Z.pow (Z.add (to_Z match ltb (div i j) j return int with | true => rec i (lsr (add31 j (div i j)) In) | false => j end) (Zpos xH)) (Zpos (xO xH))))) with ([|sqrt_step rec i j|] ^ 2 <= [|i|] < ([|sqrt_step rec i j|] + 1) ^ 2) by reflexivity. 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. - replace (and (Z.le (Z.pow (to_Z match ltb (div i j) j return int with | true => iter_sqrt n (iter_sqrt n rec) i (lsr (add31 j (div i j)) In) | false => j end) (Zpos (xO xH))) (to_Z i)) (Z.lt (to_Z i) (Z.pow (Z.add (to_Z match ltb (div i j) j return int with | true => iter_sqrt n (iter_sqrt n rec) i (lsr (add31 j (div i j)) In) | false => j end) (Zpos xH)) (Zpos (xO xH))))) with ([|sqrt_step (iter_sqrt n (iter_sqrt n rec)) i j|] ^ 2 <= [|i|] < ([|sqrt_step (iter_sqrt n (iter_sqrt n rec)) i j|] + 1) ^ 2) by reflexivity. - 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, Zpower_Zsucc. - apply Z.le_trans with (2 ^Z_of_nat n + [|j2|]); auto with zarith. - apply Zle_0_nat. -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 Zpower_2; 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 Zpower_2; auto with zarith. -Qed. - -Lemma sqrt2_step_def rec ih il j: - sqrt2_step rec ih il j = - if (ih < j)%int then - let quo := fst (diveucl_21 ih il j) in - if (quo < j)%int then - let m := - match j +c quo with - | C0 m1 => m1 >> 1 - | C1 m1 => (m1 >> 1 + 1 << (digits -1))%int - 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 <-Zpower_2; apply Z.le_lt_trans with (2 := H1). - apply Z.le_trans with ([|ih|] * wB)%Z;try rewrite Zpower_2; 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 zn2z_to_Z_pos ih il : 0 <= [||WW ih il||]. -Proof. - simpl zn2z_to_Z;destruct (to_Z_bounded ih);destruct (to_Z_bounded il);auto with zarith. -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. - apply Z.lt_le_trans with (2:= Hih); auto with zarith. - cbv zeta. - case_eq (ih < j)%int;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)%int;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. - { - apply Z.add_nonneg_nonneg. - - apply Z_div_pos. - + apply Zgt_pos_0. - + assumption. - - apply Z_div_pos. - + apply Zgt_pos_0. - + abstract omega. - } - 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; assert (H10: forall (x:Z), 0 < x -> 1 <= x) by (intros; omega); auto. - split. - replace ([|j|] + [||WW ih il||]/ [|j|])%Z with - (1 * 2 + (([|j|] - 2) + [||WW ih il||] / [|j|])); try ring. - rewrite Z_div_plus_full_l; auto with zarith. - assert (0 <= ([|j|] - 2 + [||WW ih il||] / [|j|]) / 2) ; auto with zarith. - { - apply Z_div_pos. - - apply Zgt_pos_0. - - apply Z.add_nonneg_nonneg. - + abstract omega. - + assumption. - } - 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, Zpower_Zsucc. - 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)%int; [idtac | rewrite <- not_true_iff_false]; - rewrite ltb_spec; intros Heq. - unfold interp_carry; rewrite Zmult_1_l. - rewrite Zpower_2, 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; assert (([||WW ih il||] < [|s|] * [|s|] + 2 * [|s|] + 1) -> ([||WW ih il||] - [|s|] * [|s|] <= 2 * [|s|])) by omega; auto. - 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 Zpower_2, 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 Zpower_2, 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; assert (([||WW ih il||] < [|s|] * [|s|] + 2 * [|s|] + 1) -> ([||WW ih il||] - [|s|] * [|s|] <= 2 * [|s|])) by omega; auto. - 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)%int; [idtac | rewrite <- not_true_iff_false]; - rewrite ltb_spec, Hsih; intros Heq. - rewrite Zpower_2, 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; assert (([||WW ih il||] < [|s|] * [|s|] + 2 * [|s|] + 1) -> ([||WW ih il||] - [|s|] * [|s|] <= 2 * [|s|])) by omega; auto. - 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 Zpower_2, 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 Zpower_2, 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 Zpower_2, 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; assert (([||WW ih il||] < [|s|] * [|s|] + 2 * [|s|] + 1) -> ([||WW ih il||] - [|s|] * [|s|] <= 2 * [|s|])) by omega; auto. - unfold zn2z_to_Z. - rewrite <-H1. - ring_simplify. - apply trans_equal with (wB + ([|il|] - [|il1|])). - ring. - rewrite <-Hil2; ring. -Qed. - -Lemma to_Z_gcd : forall i j, - [|gcd i j|] = Zgcdn (2*size) [|j|] [|i|]. -Proof. - unfold gcd. - induction (2*size)%nat; intros. - reflexivity. - simpl. - generalize (to_Z_bounded j)(to_Z_bounded i); intros. - case_eq (j == 0)%int. - rewrite eqb_spec;intros H1;rewrite H1. - replace [|0|] with 0;trivial;rewrite Z.abs_eq;auto with zarith. - rewrite <- not_true_iff_false, eqb_spec;intros. - case_eq [|j|]; intros. - elim H1;apply to_Z_inj;assumption. - rewrite IHn, <- H2, mod_spec;trivial. - rewrite H2 in H;destruct H as (H, _);elim H;trivial. -Qed. - -Lemma gcd_spec : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|]. -Proof. - intros. - rewrite to_Z_gcd. - apply Zis_gcd_sym. - apply Zgcdn_is_gcd. - unfold Zgcd_bound. - generalize (to_Z_bounded b). - destruct [|b|]. - unfold size; intros _; change Int31.size with 31%nat; omega. - intros (_,H). - cut (Psize p <= size)%nat; [ omega | rewrite <- Zpower2_Psize; auto]. - intros (H,_); compute in H; elim H; auto. -Qed. - -Lemma head00_spec: forall x, [|x|] = 0 -> [|head0 x|] = [|digits|]. -Proof. - change 0 with [|0|];intros x Heq. - apply to_Z_inj in Heq;rewrite Heq;trivial. -Qed. - -Lemma tail00_spec: forall x, [|x|] = 0 -> [|tail0 x|] = [|digits|]. -Proof. - change 0 with [|0|];intros x Heq. - apply to_Z_inj in Heq;rewrite Heq;trivial. -Qed. - -(* lsr lsl *) -Lemma lsl_0_l i: 0 << i = 0%int. -Proof. - apply to_Z_inj. - generalize (lsl_spec 0 i). - rewrite to_Z_0, Zmult_0_l, Zmod_0_l; auto. -Qed. - -Lemma lsl_0_r i: i << 0 = i. -Proof. - apply to_Z_inj. - rewrite lsl_spec, to_Z_0, Zmult_1_r. - apply Zmod_small; apply (to_Z_bounded i). -Qed. - -Lemma lsl_M_r x i (H: (digits <= i = true)%int) : x << i = 0%int. -Proof. - apply to_Z_inj. - rewrite lsl_spec, to_Z_0. - rewrite leb_spec in H. - unfold wB; change (Z_of_nat size) with [|digits|]. - replace ([|i|]) with (([|i|] - [|digits|]) + [|digits|])%Z; try ring. - rewrite Zpower_exp, Zmult_assoc, Z_mod_mult; auto with arith. - apply Z.le_ge; auto with zarith. - case (to_Z_bounded digits); auto with zarith. -Qed. - -Lemma lsr_0_l i: 0 >> i = 0%int. -Proof. - apply to_Z_inj. - generalize (lsr_spec 0 i). - rewrite to_Z_0, Zdiv_0_l; auto. -Qed. - -Lemma lsr_0_r i: i >> 0 = i. -Proof. - apply to_Z_inj. - rewrite lsr_spec, to_Z_0, Zdiv_1_r; auto. -Qed. - -Lemma lsr_M_r x i (H: (digits <= i = true)%int) : x >> i = 0%int. -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 with (1 := H2x). - unfold wB; change (Z_of_nat size) with [|digits|]. - apply Zpower_le_monotone; auto with zarith. -Qed. - -Lemma add_le_r m n: - if (n <= m + n)%int 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)%int; 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)%int with true; auto. - apply sym_equal; rewrite leb_spec, H1; auto with zarith. -Qed. - -Lemma lsr_add i m n: ((i >> m) >> n = if n <= m + n then i >> (m + n) else 0)%int. -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)%int; 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. - apply Z.lt_le_trans with (1 := H2i). - apply Z.le_trans with (1 := H). - apply Zpower2_le_lin; auto with zarith. -Qed. - -Lemma lsl_add i m n: ((i << m) << n = if n <= m + n then i << (m + n) else 0)%int. -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)%int; intros H. - apply to_Z_inj; rewrite !lsl_spec, Zmult_mod, Zmod_mod, <- Zmult_mod. - rewrite <-Zmult_assoc, <- Zpower_exp; auto with zarith. - apply f_equal2 with (f := Zmod); auto. - rewrite add_spec, Zmod_small; auto with zarith. - apply to_Z_inj; rewrite !lsl_spec, Zmult_mod, Zmod_mod, <- Zmult_mod. - rewrite <-Zmult_assoc, <- Zpower_exp; auto with zarith. - unfold wB. - replace ([|m|] + [|n|])%Z with - ((([|m|] + [|n|]) - Z_of_nat size) + Z_of_nat size)%Z. - 2: ring. - rewrite Zpower_exp, Zmult_assoc, Z_mod_mult; auto with zarith. - assert (Z_of_nat size < wB)%Z; auto with zarith. - apply Zpower2_lt_lin; auto with zarith. -Qed. - - -Coercion b2i (b: bool) : int := if b then 1%int else 0%int. - -Lemma bit_0 n : bit 0 n = false. -Proof. unfold bit; rewrite lsr_0_l; auto. Qed. - -Lemma lsr_1 n : 1 >> n = (n == 0). -Proof. - case_eq (n == 0). - rewrite eqb_spec; intros H; rewrite H, lsr_0_r. - apply refl_equal. - intros Hn. - assert (H1n : (1 >> n = 0)%int); 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. - case (Zle_lt_or_eq 0 [|n|]); auto. - case (to_Z_bounded n); auto. - intros H1. - assert ((n == 0) = true). - rewrite eqb_spec; apply to_Z_inj; rewrite <-H1, to_Z_0; auto. - generalize H; rewrite Hn; discriminate. -Qed. - -Lemma bit_1 n : bit 1 n = (n == 0). -Proof. - unfold bit; rewrite lsr_1. - case (n == 0). - apply refl_equal. - rewrite lsl_0_l; apply refl_equal. -Qed. - -Lemma bit_M i n (H: (digits <= n = true)%int): bit i n = false. -Proof. unfold bit; rewrite lsr_M_r; auto. Qed. - -Lemma bit_half i n (H: (n < digits = true)%int) : bit (i>>1) n = bit i (n+1). -Proof. - unfold bit. - rewrite lsr_add. - case_eq (n <= (1 + n))%int. - replace (1+n)%int with (n+1)%int; [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_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: rewrite to_Z_eq, <-eqb_spec; intros H1; rewrite H1; auto. - 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. - generalize (eqb_spec (i << (digits - 1)) 0). - case (i << (digits - 1) == 0); auto. - intros (H3,_); case H2. - rewrite to_Z_eq; auto. -Qed. - -Lemma bit_split i : (i = (i>>1)<<1 + bit i 0)%int. -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_eq i1 i2: - i1 = i2 <-> forall i, bit i1 i = bit i2 i. -Admitted. (* Too slow *) -(* Proof. *) -(* split; try (intros; subst; auto; fail). *) -(* case (to_Z_bounded i2); case (to_Z_bounded i1). *) -(* unfold wB; generalize i1 i2; elim size; clear i1 i2. *) -(* replace (2^Z_of_nat 0) with 1%Z; auto with zarith. *) -(* intros; apply to_Z_inj; auto with zarith. *) -(* intros n IH i1 i2 H1i1 H2i1 H1i2 H2i2 H. *) -(* rewrite (bit_split i1), (bit_split i2). *) -(* rewrite H. *) -(* apply f_equal2 with (f := add31); auto. *) -(* apply f_equal2 with (f := lsl); auto. *) -(* apply IH; try rewrite lsr_spec; *) -(* replace (2^[|1|]) with 2%Z; auto with zarith. *) -(* apply Zdiv_lt_upper_bound; auto with zarith. *) -(* generalize H2i1; rewrite inj_S. *) -(* unfold Z.succ; rewrite Zpower_exp; auto with zarith. *) -(* apply Zdiv_lt_upper_bound; auto with zarith. *) -(* generalize H2i2; rewrite inj_S. *) -(* unfold Z.succ; rewrite Zpower_exp; auto with zarith. *) -(* intros i. *) -(* case (Zle_or_lt [|digits|] [|i|]); intros Hi. *) -(* rewrite !bit_M; auto; rewrite leb_spec; auto. *) -(* rewrite !bit_half; auto; rewrite ltb_spec; auto with zarith. *) -(* Qed. *) - -Lemma bit_lsr x i j : - (bit (x >> i) j = if j <= i + j then bit x (i + j) else false)%int. -Proof. - unfold bit; rewrite lsr_add; case leb; auto. -Qed. - -Lemma bit_lsl x i j : bit (x << i) j = -(if (j < i) || (digits <= j) then false else bit x (j - i))%int. -Proof. - assert (F1: 1 >= 0) by discriminate. - case_eq (digits <= j)%int; 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; [change (if true || false then false else negb (is_zero ((x >> (j - i)) << (digits - 1)))) with false | change (if false || false then false else negb (is_zero ((x >> (j - i)) << (digits - 1)))) with (negb (is_zero ((x >> (j - i)) << (digits - 1))))]. - 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. - 2: ring. - rewrite Zpower_exp; auto with zarith. - replace [|i|] with (([|i|] - ([|j|] + 1)) + ([|j|] + 1))%Z. - 2: 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. - 2: assert (0 < 2 ^ [|j|])%Z; 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, Zpower_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. - 2: ring. - case (to_Z_bounded i); intros H1i H2i. - rewrite Zpower_exp; [ |apply Z.le_ge; lia|apply Z.le_ge; assumption]. - 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: (apply Zlt0_not_eq; apply Z.pow_pos_nonneg; [apply Pos2Z.is_pos|assumption]). - rewrite (Z_div_mod_eq [|x|] (2^d1)) at 2; auto with zarith. - 2: apply Z.lt_gt; apply Zpower_gt_0; unfold d1; lia. - pattern d1 at 2; - replace d1 with (d2 + (1+ (d - [|j|] - 1)))%Z. - 2: unfold d1, d2; ring. - rewrite Zpower_exp; auto with zarith. - rewrite <-Zmult_assoc, Zmult_comm. - rewrite Z_div_plus_l; auto with zarith. - rewrite Zpower_exp, Zpower_1_r; auto with zarith. - rewrite <-Zplus_mod_idemp_l. - rewrite <-!Zmult_assoc, Zmult_comm, Z_mod_mult, Zplus_0_l; auto. -Qed. - - -Lemma bit_b2i (b: bool) i : bit b i = (i == 0) && b. -Proof. - case b; unfold bit; simpl b2i. - 2: rewrite lsr_0_l, lsl_0_l, andb_false_r; auto. - rewrite lsr_1; case (i == 0); auto. -Qed. - -Lemma bit_or_split i : (i = (i>>1)<<1 lor bit i 0)%int. -Proof. - rewrite bit_eq. - intros n; rewrite lor_spec. - rewrite bit_lsl, bit_lsr, bit_b2i. - case (to_Z_bounded n); intros Hi _. - case (Zle_lt_or_eq _ _ Hi). - 2: replace 0%Z with [|0|]; auto; rewrite to_Z_eq. - 2: intros H; rewrite <-H. - 2: replace (0 < 1)%int with true; auto. - intros H; clear Hi. - case_eq (n == 0). - rewrite eqb_spec; intros H1; generalize H; rewrite H1; discriminate. - intros _; rewrite orb_false_r. - case_eq (n < 1)%int. - rewrite ltb_spec, to_Z_1; intros HH; contradict HH; auto with zarith. - intros _. - generalize (@bit_M i n); case leb. - intros H1; rewrite H1; auto. - intros _. - case (to_Z_bounded n); intros H1n H2n. - assert (F1: [|n - 1|] = ([|n|] - 1)%Z). - rewrite sub_spec, Zmod_small; rewrite to_Z_1; auto with zarith. - generalize (add_le_r 1 (n - 1)); case leb; rewrite F1, to_Z_1; intros HH. - replace (1 + (n -1))%int with n. change (bit i n = bit i n). reflexivity. - apply to_Z_inj; rewrite add_spec, F1, Zmod_small; rewrite to_Z_1; - auto with zarith. - rewrite bit_M; auto; rewrite leb_spec. - replace [|n|] with wB; try discriminate; auto with zarith. -Qed. - -(* is_zero *) -Lemma is_zero_0: is_zero 0 = true. -Proof. apply refl_equal. 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_eq; 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_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. - -Lemma is_even_spec : forall x, - if is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1. -Proof. -intros x; rewrite is_even_bit. -generalize (bit_0_spec x); case bit; simpl; auto. -Qed. - -(* More land *) - -Lemma land_0_l i: 0 land i = 0%int. -Proof. - apply bit_eq; intros n. - rewrite land_spec, bit_0; auto. -Qed. - -Lemma land_0_r i: i land 0 = 0%int. -Proof. - apply bit_eq; intros n. - rewrite land_spec, bit_0, andb_false_r; auto. -Qed. - -Lemma land_assoc i1 i2 i3 : - i1 land (i2 land i3) = i1 land i2 land i3. -Proof. - apply bit_eq; intros n. - rewrite !land_spec, andb_assoc; auto. -Qed. - - -Lemma land_comm i j : i land j = j land i. -Proof. - apply bit_eq; intros n. - rewrite !land_spec, andb_comm; auto. -Qed. - -Lemma lor_comm i1 i2 : i1 lor i2 = i2 lor i1. -Proof. - apply bit_eq; intros n. - rewrite !lor_spec, orb_comm; auto. -Qed. - -Lemma lor_assoc i1 i2 i3 : - i1 lor (i2 lor i3) = i1 lor i2 lor i3. -Proof. - apply bit_eq; intros n. - rewrite !lor_spec, orb_assoc; auto. -Qed. - -Lemma land_lor_distrib_r i1 i2 i3 : - i1 land (i2 lor i3) = (i1 land i2) lor (i1 land i3). -Proof. - apply bit_eq; intros n. - rewrite !land_spec, !lor_spec, !land_spec, andb_orb_distrib_r; auto. -Qed. - -Lemma land_lor_distrib_l i1 i2 i3 : - (i1 lor i2) land i3 = (i1 land i3) lor (i2 land i3). -Proof. - apply bit_eq; intros n. - rewrite !land_spec, !lor_spec, !land_spec, andb_orb_distrib_l; auto. -Qed. - -Lemma lor_land_distrib_r i1 i2 i3: - i1 lor (i2 land i3) = (i1 lor i2) land (i1 lor i3). -Proof. - apply bit_eq; intros n. - rewrite !land_spec, !lor_spec, !land_spec, orb_andb_distrib_r; auto. -Qed. - -Lemma lor_land_distrib_l i1 i2 i3: - (i1 land i2) lor i3 = (i1 lor i3) land (i2 lor i3). -Proof. - apply bit_eq; intros n. - rewrite !land_spec, !lor_spec, !land_spec, orb_andb_distrib_l; auto. -Qed. - -Lemma absoption_land i1 i2 : i1 land (i1 lor i2) = i1. -Proof. - apply bit_eq; intros n. - rewrite land_spec, lor_spec, absoption_andb; auto. -Qed. - -Lemma absoption_lor i1 i2: i1 lor (i1 land i2) = i1. -Proof. - apply bit_eq; intros n. - rewrite lor_spec, land_spec, absoption_orb; auto. -Qed. - -Lemma land_lsl i1 i2 i: (i1 land i2) << i = (i1 << i) land (i2 << i). -Proof. - apply bit_eq; intros n. - rewrite land_spec, !bit_lsl, land_spec. - case (_ || _); auto. -Qed. - -Lemma lor_lsl i1 i2 i: (i1 lor i2) << i = (i1 << i) lor (i2 << i). -Proof. - apply bit_eq; intros n. - rewrite lor_spec, !bit_lsl, lor_spec. - case (_ || _); auto. -Qed. - -Lemma lxor_lsl i1 i2 i: (i1 lxor i2) << i = (i1 << i) lxor (i2 << i). -Proof. - apply bit_eq; intros n. - rewrite lxor_spec, !bit_lsl, lxor_spec. - case (_ || _); auto. -Qed. - -Lemma land_lsr i1 i2 i: (i1 land i2) >> i = (i1 >> i) land (i2 >> i). -Proof. - apply bit_eq; intros n. - rewrite land_spec, !bit_lsr, land_spec. - case (_ <= _)%int; auto. -Qed. - -Lemma lor_lsr i1 i2 i: (i1 lor i2) >> i = (i1 >> i) lor (i2 >> i). -Proof. - apply bit_eq; intros n. - rewrite lor_spec, !bit_lsr, lor_spec. - case (_ <= _)%int; auto. -Qed. - -Lemma lxor_lsr i1 i2 i: (i1 lxor i2) >> i = (i1 >> i) lxor (i2 >> i). -Proof. - apply bit_eq; intros n. - rewrite lxor_spec, !bit_lsr, lxor_spec. - case (_ <= _)%int; auto. -Qed. - -Lemma is_even_and i j : is_even (i land j) = is_even i || is_even j. -Proof. - rewrite !is_even_bit, land_spec; case bit; auto. -Qed. - -Lemma is_even_or i j : is_even (i lor j) = is_even i && is_even j. -Proof. - rewrite !is_even_bit, lor_spec; case bit; auto. -Qed. - -Lemma is_even_xor i j : is_even (i lxor j) = negb (xorb (is_even i) (is_even j)). -Proof. - rewrite !is_even_bit, lxor_spec; do 2 case bit; auto. -Qed. - -Lemma lsl_add_distr x y n: (x + y) << n = ((x << n) + (y << n))%int. -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 add_assoc x y z: (x + (y + z) = (x + y) + z)%int. -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)%int. -Proof. - apply to_Z_inj; rewrite !add_spec, Zplus_comm; auto. -Qed. - -Lemma lsr_add_distr x y n: (x + y) << n = ((x << n) + (y << n))%int. -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. - -Lemma is_even_add x y : - is_even (x + y) = negb (xorb (negb (is_even x)) (negb (is_even y))). -Proof. - assert (F : [|x + y|] mod 2 = ([|x|] mod 2 + [|y|] mod 2) mod 2). - assert (F1: (2 | wB)) by (apply Zpower_divide; apply refl_equal). - assert (F2: 0 < wB) by (apply refl_equal). - case (to_Z_bounded x); intros H1x H2x. - case (to_Z_bounded y); intros H1y H2y. - rewrite add_spec, <-Zmod_div_mod; auto with zarith. - rewrite (Z_div_mod_eq [|x|] 2) at 1; auto with zarith. - rewrite (Z_div_mod_eq [|y|] 2) at 1; auto with zarith. - rewrite Zplus_mod. - rewrite Zmult_comm, (fun x => Zplus_comm (x * 2)), Z_mod_plus; auto with zarith. - rewrite Zmult_comm, (fun x => Zplus_comm (x * 2)), Z_mod_plus; auto with zarith. - rewrite !Zmod_mod, <-Zplus_mod; auto. - generalize (is_even_spec (x + y)) (is_even_spec x) (is_even_spec y). - do 3 case is_even; auto; rewrite F; intros H1 H2 H3; - generalize H1; rewrite H2, H3; try discriminate. -Qed. - -Lemma bit_add_0 x y: bit (x + y) 0 = xorb (bit x 0) (bit y 0). -Proof. - rewrite <-(fun x => (negb_involutive (bit x 0))). - rewrite <-is_even_bit, is_even_add, !is_even_bit. - do 2 case bit; auto. -Qed. - -Lemma add_cancel_l x y z : (x + y = x + z)%int -> y = z. -Proof. - intros H; case (to_Z_bounded x); case (to_Z_bounded y); case (to_Z_bounded z); - intros H1z H2z H1y H2y H1x H2x. - generalize (add_le_r y x) (add_le_r z x); rewrite (add_comm y x), H, (add_comm z x). - case_eq (x <= x + z)%int; intros H1 H2 H3. - apply to_Z_inj; generalize H; rewrite <-to_Z_eq, !add_spec, !Zmod_small; auto with zarith. - apply to_Z_inj; assert ([|x|] + [|y|] = [|x|] + [|z|]); auto with zarith. - assert (F1: wB > 0) by apply refl_equal. - rewrite (Z_div_mod_eq ([|x|] + [|y|]) wB), (Z_div_mod_eq ([|x|] + [|z|]) wB); auto. - rewrite <-to_Z_eq, !add_spec in H; rewrite H. - replace (([|x|] + [|y|])/wB) with 1. - replace (([|x|] + [|z|])/wB) with 1; auto with zarith. - apply Zle_antisym. - apply Zdiv_le_lower_bound; auto with zarith. - assert (F2: [|x|] + [|z|] < 2 * wB); auto with zarith. - generalize (Zdiv_lt_upper_bound _ _ _ (Z.gt_lt _ _ F1) F2); auto with zarith. - apply Zle_antisym. - apply Zdiv_le_lower_bound; auto with zarith. - assert (F2: [|x|] + [|y|] < 2 * wB); auto with zarith. - generalize (Zdiv_lt_upper_bound _ _ _ (Z.gt_lt _ _ F1) F2); auto with zarith. -Qed. - -Lemma add_cancel_r x y z : (y + x = z + x)%int -> y = z. -Proof. - rewrite !(fun t => add_comm t x); intros Hl; apply (add_cancel_l x); auto. -Qed. - -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, Zpower_1_r; split. - { - apply Z_div_pos. - - apply Zgt_pos_0. - - assumption. - } - apply Zdiv_lt_upper_bound; auto with zarith. - rewrite (bit_split x) at 1. - rewrite add_spec, Zmod_small, lsl_spec, to_Z_1, Zpower_1_r, Zmod_small; - split; auto with zarith. - change wB with ((wB/2)*2); auto with zarith. - rewrite lsl_spec, to_Z_1, Zpower_1_r, Zmod_small; auto with zarith. - change wB with ((wB/2)*2); auto with zarith. - rewrite lsl_spec, to_Z_1, Zpower_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 lor_le x y : (y <= x lor y)%int = 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%int. - replace y with 0%int; 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, Zpower_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, Zpower_1_r; split. - { - apply Z_div_pos. - - apply Zgt_pos_0. - - abstract omega. - } - apply Zdiv_lt_upper_bound; auto with zarith. - rewrite lsr_spec, to_Z_1, Zpower_1_r; split. - { - apply Z_div_pos. - - apply Zgt_pos_0. - - abstract omega. - } - 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_add_or x y: - (forall n, bit x n = true -> bit y n = true -> False) <-> (x + y)%int= 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%int. - replace y with 0%int. - 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, Zpower_1_r; auto with zarith. - intros Hx Hy. - split. - intros Hn. - assert (F1: ((x >> 1) + (y >> 1))%int = (x >> 1) lor (y >> 1)). - apply IH. - rewrite lsr_spec, Zpower_1_r; split. - { - apply Z_div_pos. - - apply Zgt_pos_0. - - abstract omega. - } - apply Zdiv_lt_upper_bound; auto with zarith. - rewrite lsr_spec, Zpower_1_r; split. - { - apply Z_div_pos. - - apply Zgt_pos_0. - - abstract omega. - } - apply Zdiv_lt_upper_bound; auto with zarith. - intros m H1 H2. - case_eq (digits <= m)%int; [idtac | rewrite <- not_true_iff_false]; - intros Heq. - rewrite bit_M in H1; auto; discriminate. - rewrite leb_spec in Heq. - apply (Hn (m + 1)%int); - 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)%int. - 2: generalize (Hn 0%int); 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 := add31); auto. - rewrite add_comm, <-!add_assoc; apply f_equal2 with (f := add31); 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)%int = (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 Zpower_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 Zpower_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, Zpower_1_r; split. - { - apply Z_div_pos. - - apply Zgt_pos_0. - - abstract omega. - } - apply Zdiv_lt_upper_bound; auto with zarith. - rewrite lsr_spec, to_Z_1, Zpower_1_r; split. - { - apply Z_div_pos. - - apply Zgt_pos_0. - - abstract omega. - } - apply Zdiv_lt_upper_bound; auto with zarith. - intros _ HH m; case (to_Z_bounded m); intros H1m H2m. - case_eq (digits <= m)%int. - 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)%int. - 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 Heq1; rewrite <-to_Z_eq, lsl_spec, to_Z_1, Zpower_1_r, Zmod_small. - rewrite lsl_spec, to_Z_1, Zpower_1_r, Zmod_small; auto with zarith. - case (to_Z_bounded (x lor y)); intros H1xy H2xy. - rewrite lsr_spec, to_Z_1, Zpower_1_r; auto with zarith. - change wB with ((wB/2)*2); split. - { - apply Z.mul_nonneg_nonneg. - - apply Z_div_pos. - + apply Zgt_pos_0. - + assumption. - - apply Pos2Z.is_nonneg. - } - 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. - replace m with 0%int. - intros Hbx Hby; generalize F; rewrite <-to_Z_eq, Hbx, Hby; discriminate. - apply to_Z_inj; auto. -Qed. - -Lemma addmuldiv_spec : forall x y p, [|p|] <= [|digits|] -> - [| addmuldiv p x y |] = - ([|x|] * (2 ^ [|p|]) + [|y|] / (2 ^ ([|digits|] - [|p|]))) mod wB. -Proof. - intros x y p 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 leb; try discriminate. - rewrite sub_spec, Zmod_small; auto with zarith; intros H1. - case_eq (n < p)%int; try discriminate. - rewrite <- not_true_iff_false, ltb_spec; intros H2. - case leb; 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. - -Lemma lxor_comm: forall i1 i2 : int, i1 lxor i2 = i2 lxor i1. -Proof. - intros;apply bit_eq;intros. - rewrite !lxor_spec;apply xorb_comm. -Qed. - -Lemma lxor_assoc: forall i1 i2 i3 : int, i1 lxor (i2 lxor i3) = i1 lxor i2 lxor i3. -Proof. - intros;apply bit_eq;intros. - rewrite !lxor_spec, xorb_assoc;trivial. -Qed. - -Lemma lxor_0_l : forall i, 0 lxor i = i. -Proof. - intros;apply bit_eq;intros. - rewrite lxor_spec, bit_0, xorb_false_l;trivial. -Qed. - -Lemma lxor_0_r : forall i, i lxor 0 = i. -Proof. - intros;rewrite lxor_comm;apply lxor_0_l. -Qed. - -Lemma lxor_nilpotent: forall i, i lxor i = 0%int. -Proof. - intros;apply bit_eq;intros. - rewrite lxor_spec, xorb_nilpotent, bit_0;trivial. -Qed. - -Lemma lor_0_l : forall i, 0 lor i = i. -Proof. - intros;apply bit_eq;intros. - rewrite lor_spec, bit_0, orb_false_l;trivial. -Qed. - -Lemma lor_0_r : forall i, i lor 0 = i. -Proof. - intros;rewrite lor_comm;apply lor_0_l. -Qed. - -Lemma reflect_leb : forall i j, reflect ([|i|] <= [|j|])%Z (i <= j)%int. -Proof. - intros; apply iff_reflect. - symmetry;apply leb_spec. -Qed. - -Lemma reflect_eqb : forall i j, reflect (i = j)%Z (i == j). -Proof. - intros; apply iff_reflect. - symmetry;apply eqb_spec. -Qed. - -Lemma reflect_ltb : forall i j, reflect ([|i|] < [|j|])%Z (i < j)%int. -Proof. - intros; apply iff_reflect. - symmetry;apply ltb_spec. -Qed. - -Lemma lsr_is_even_eq : forall i j, - i >> 1 = j >> 1 -> - is_even i = is_even j -> - i = j. -Proof. - intros;apply bit_eq. - intros n;destruct (reflect_eqb n 0). - rewrite <- (negb_involutive (bit i n)), <- (negb_involutive (bit j n)). - rewrite e, <- !is_even_bit, H0;trivial. - assert (W1 : [|n|] <> 0) by (intros Heq;apply n0;apply to_Z_inj;trivial). - assert (W2 := to_Z_bounded n);clear n0. - assert (W3 : [|n-1|] = [|n|] - 1). - rewrite sub_spec, to_Z_1, Zmod_small;trivial;omega. - assert (H1 : n = ((n-1)+1)%int). - apply to_Z_inj;rewrite add_spec, W3. - rewrite Zmod_small;rewrite to_Z_1; omega. - destruct (reflect_ltb (n-1) digits). - rewrite <- ltb_spec in l. - rewrite H1, <- !bit_half, H;trivial. - assert ((digits <= n)%int = true). - rewrite leb_spec;omega. - rewrite !bit_M;trivial. -Qed. - -Lemma lsr1_bit : forall i k, (bit i k >> 1 = 0)%int. -Proof. - intros;destruct (bit i k);trivial. -Qed. - -Lemma bit_xor_split: forall i : int, i = (i >> 1) << 1 lxor bit i 0. -Proof. - intros. - rewrite bit_or_split at 1. - apply lsr_is_even_eq. - rewrite lxor_lsr, lor_lsr, lsr1_bit, lxor_0_r, lor_0_r;trivial. - rewrite is_even_or, is_even_xor. - rewrite is_even_lsl_1;trivial. - rewrite (xorb_true_l (is_even (bit i 0))), negb_involutive;trivial. -Qed. - -(** Order *) -Local Open Scope int63_scope. - -Lemma succ_max_int : forall x, - (x < max_int)%int = true -> (0 < x + 1)%int = true. -Proof. - intros x;rewrite ltb_spec, ltb_spec, add_spec. - intros; assert (W:= to_Z_bounded x); assert (W1:= to_Z_bounded max_int). - change [|0|] with 0%Z;change [|1|] with 1%Z. - rewrite Zmod_small;omega. -Qed. - -Lemma leb_max_int : forall x, (x <= max_int)%int = true. -Proof. - intros x;rewrite leb_spec;assert (W:= to_Z_bounded x). - change [|max_int|] with (wB - 1)%Z;omega. -Qed. - -Lemma leb_0 : forall x, 0 <= x = true. -Proof. - intros x;rewrite leb_spec;destruct (to_Z_bounded x);trivial. -Qed. - -Lemma ltb_0 : forall x, ~ (x < 0 = true). -Proof. - intros x;rewrite ltb_spec, to_Z_0;destruct (to_Z_bounded x);omega. -Qed. - -Lemma leb_trans : forall x y z, x <= y = true -> y <= z = true -> x <= z = true. -Proof. - intros x y z;rewrite !leb_spec;apply Z.le_trans. -Qed. - -Lemma ltb_trans : forall x y z, x < y = true -> y < z = true -> x < z = true. -Proof. - intros x y z;rewrite !ltb_spec;apply Z.lt_trans. -Qed. - -Lemma ltb_leb_trans : forall x y z, x < y = true -> y <= z = true -> x < z = true. -Proof. - intros x y z;rewrite leb_spec, !ltb_spec;apply Z.lt_le_trans. -Qed. - -Lemma leb_ltb_trans : forall x y z, x <= y = true -> y < z = true -> x < z = true. -Proof. - intros x y z;rewrite leb_spec, !ltb_spec;apply Z.le_lt_trans. -Qed. - -Lemma gtb_not_leb : forall n m, m < n = true -> ~(n <= m = true). -Proof. - intros n m; rewrite ltb_spec, leb_spec;omega. -Qed. - -Lemma leb_not_gtb : forall n m, m <= n = true -> ~(n < m = true). -Proof. - intros n m; rewrite ltb_spec, leb_spec;omega. -Qed. - -Lemma leb_refl : forall n, n <= n = true. -Proof. - intros n;rewrite leb_spec;apply Z.le_refl. -Qed. - -Lemma leb_negb_gtb : forall x y, x <= y = negb (y < x). -Proof. - intros x y;apply Bool.eq_true_iff_eq;split;intros. - apply Bool.eq_true_not_negb;apply leb_not_gtb;trivial. - rewrite Bool.negb_true_iff, <- Bool.not_true_iff_false in H. - rewrite leb_spec; rewrite ltb_spec in H;omega. -Qed. - -Lemma ltb_negb_geb : forall x y, x < y = negb (y <= x). -Proof. - intros;rewrite leb_negb_gtb, Bool.negb_involutive;trivial. -Qed. - -Lemma to_Z_sub_gt : forall x y, y <= x = true -> [|x - y|] = ([|x|] - [|y|])%Z. -Proof. - intros x y;assert (W:= to_Z_bounded x);assert (W0:= to_Z_bounded y); - rewrite leb_spec;intros;rewrite sub_spec, Zmod_small;omega. -Qed. - -Lemma not_0_ltb : forall x, x <> 0 <-> 0 < x = true. -Proof. - intros x;rewrite ltb_spec, to_Z_0;assert (W:=to_Z_bounded x);split. - intros Hd;assert ([|x|] <> 0)%Z;[ | omega]. - intros Heq;elim Hd;apply to_Z_inj;trivial. - intros Hlt Heq;elimtype False. - assert ([|x|] = 0)%Z;[ rewrite Heq, to_Z_0;trivial | omega]. -Qed. - -Lemma not_ltb_refl : forall i, ~(i < i = true). -Proof. - intros;rewrite ltb_spec;omega. -Qed. - -Lemma to_Z_sub_1 : forall x y, y < x = true -> ([| x - 1|] = [|x|] - 1)%Z. -Proof. - intros;apply to_Z_sub_gt. - generalize (leb_ltb_trans _ _ _ (leb_0 y) H). - rewrite ltb_spec, leb_spec, to_Z_0, to_Z_1;auto with zarith. -Qed. - -Lemma to_Z_sub_1_diff : forall x, x <> 0 -> ([| x - 1|] = [|x|] - 1)%Z. -Proof. - intros x;rewrite not_0_ltb;apply to_Z_sub_1. -Qed. - -Lemma to_Z_add_1 : forall x y, x < y = true -> [|x+1|] = ([|x|] + 1)%Z. -Proof. - intros x y;assert (W:= to_Z_bounded x);assert (W0:= to_Z_bounded y); - rewrite ltb_spec;intros;rewrite add_spec, to_Z_1, Zmod_small;omega. -Qed. - -Lemma ltb_leb_sub1 : forall x i, x <> 0 -> (i < x = true <-> i <= x - 1 = true). -Proof. - intros x i Hdiff. - rewrite ltb_spec, leb_spec, to_Z_sub_1_diff;trivial. - split;auto with zarith. -Qed. - -Lemma ltb_leb_add1 : forall x y i, i < y = true -> (i < x = true <-> i + 1 <= x = true). -Proof. - intros x y i Hlt. - rewrite ltb_spec, leb_spec. - rewrite (to_Z_add_1 i y);trivial. - split;auto with zarith. -Qed. - -(** Iterators *) - -Lemma foldi_gt : forall A f from to (a:A), - (to < from)%int = true -> foldi f from to a = a. -Proof. - intros;unfold foldi;rewrite foldi_cont_gt;trivial. -Qed. - -Lemma foldi_eq : forall A f from to (a:A), - from = to -> foldi f from to a = f from a. -Proof. - intros;unfold foldi;rewrite foldi_cont_eq;trivial. -Qed. - -Lemma foldi_lt : forall A f from to (a:A), - (from < to)%int = true -> foldi f from to a = foldi f (from + 1) to (f from a). -Proof. - intros;unfold foldi;rewrite foldi_cont_lt;trivial. -Qed. - -Lemma fold_gt : forall A f from to (a:A), - (to < from)%int = true -> fold f from to a = a. -Proof. - intros;apply foldi_gt;trivial. -Qed. - -Lemma fold_eq : forall A f from to (a:A), - from = to -> fold f from to a = f a. -Proof. - intros;apply foldi_eq;trivial. -Qed. - -Lemma fold_lt : forall A f from to (a:A), - (from < to)%int = true -> fold f from to a = fold f (from + 1) to (f a). -Proof. - intros;apply foldi_lt;trivial. -Qed. - -Lemma foldi_down_lt : forall A f from downto (a:A), - (from < downto)%int = true -> foldi_down f from downto a = a. -Proof. - intros;unfold foldi_down;rewrite foldi_down_cont_lt;trivial. -Qed. - -Lemma foldi_down_eq : forall A f from downto (a:A), - from = downto -> foldi_down f from downto a = f from a. -Proof. - intros;unfold foldi_down;rewrite foldi_down_cont_eq;trivial. -Qed. - -Lemma foldi_down_gt : forall A f from downto (a:A), - (downto < from)%int = true-> - foldi_down f from downto a = - foldi_down f (from-1) downto (f from a). -Proof. - intros;unfold foldi_down;rewrite foldi_down_cont_gt;trivial. -Qed. - -Lemma fold_down_lt : forall A f from downto (a:A), - (from < downto)%int = true -> fold_down f from downto a = a. -Proof. - intros;apply foldi_down_lt;trivial. -Qed. - -Lemma fold_down_eq : forall A f from downto (a:A), - from = downto -> fold_down f from downto a = f a. -Proof. - intros;apply foldi_down_eq;trivial. -Qed. - -Lemma fold_down_gt : forall A f from downto (a:A), - (downto < from)%int = true-> - fold_down f from downto a = - fold_down f (from-1) downto (f a). -Proof. - intros;apply foldi_down_gt;trivial. -Qed. - -Require Import Wf_Z. - -Lemma int_ind : forall (P:int -> Type), - P 0%int -> - (forall i, (i < max_int)%int = true -> P i -> P (i + 1)%int) -> - forall i, P i. -Proof. - intros P HP0 Hrec. - assert (forall z, (0 <= z)%Z -> forall i, z = [|i|] -> P i). - intros z H;pattern z;apply natlike_rec2;intros;trivial. - rewrite <- (of_to_Z i), <- H0;exact HP0. - assert (W:= to_Z_bounded i). - assert ([|i - 1|] = [|i|] - 1)%Z. - rewrite sub_spec, Zmod_small;rewrite to_Z_1;auto with zarith. - assert (i = i - 1 + 1)%int. - apply to_Z_inj. - rewrite add_spec, H2. - rewrite Zmod_small;rewrite to_Z_1;auto with zarith. - rewrite H3;apply Hrec. - rewrite ltb_spec, H2;change [|max_int|] with (wB - 1)%Z;auto with zarith. - apply X;auto with zarith. - intros;apply (X [|i|]);trivial. - destruct (to_Z_bounded i);trivial. -Qed. - -Lemma int_ind_bounded : forall (P:int-> Type) min max, - min <= max =true -> - P max -> - (forall i, min <= i + 1 = true-> i < max =true-> P (i + 1) -> P i) -> - P min. -Proof. - intros P min max Hle. - intros Hmax Hrec. - assert (W1:= to_Z_bounded max);assert (W2:= to_Z_bounded min). - assert (forall z, (0 <= z)%Z -> (z <= [|max|] - [|min|])%Z -> forall i, z = [|i|] -> P (max - i)%int). - intros z H1;pattern z;apply natlike_rec2;intros;trivial. - assert (max - i = max)%int. - apply to_Z_inj;rewrite sub_spec, <- H0, Zminus_0_r, Zmod_small;auto using to_Z_bounded. - rewrite H2;trivial. - assert (W3:= to_Z_bounded i);apply Hrec. - rewrite leb_spec,add_spec, sub_spec, to_Z_1, (Zmod_small ([|max|] - [|i|])), Zmod_small;auto with zarith. - rewrite ltb_spec, sub_spec, Zmod_small;auto with zarith. - assert (max - i + 1 = max - (i - 1))%int. - apply to_Z_inj;rewrite add_spec, !sub_spec, to_Z_1. - rewrite (Zmod_small ([|max|] - [|i|]));auto with zarith. - rewrite (Zmod_small ([|i|] - 1));auto with zarith. - apply f_equal2;auto with zarith. - rewrite H3;apply X;auto with zarith. - rewrite sub_spec, to_Z_1, <- H2, Zmod_small;auto with zarith. - rewrite leb_spec in Hle;assert (min = max - (max - min))%int. - apply to_Z_inj. - rewrite !sub_spec, !Zmod_small;auto with zarith. - rewrite Zmod_small;auto with zarith. - rewrite H;apply (X [| max - min |]);trivial;rewrite sub_spec, Zmod_small;auto with zarith. -Qed. - -Lemma foldi_cont_ZInd : forall A B (P: Z -> (A -> B) -> Prop) (f:int -> (A -> B) -> (A -> B)) min max cont, - (forall z, ([|max|] < z)%Z -> P z cont) -> - (forall i cont, min <= i = true -> i <= max = true -> P ([|i|] + 1)%Z cont -> P [|i|] (f i cont)) -> - P [|min|] (foldi_cont f min max cont). -Proof. - intros A B P f min max cont Ha Hf. - assert (Bmax:= to_Z_bounded max);assert (Bmin:= to_Z_bounded min). - case_eq (min <= max);intros Heq. - generalize (leb_refl min). - assert (P ([|max|] + 1)%Z cont) by (apply Ha;auto with zarith). - clear Ha;revert cont H. - pattern min at 2 3 4;apply int_ind_bounded with max;trivial. - intros;rewrite foldi_cont_eq;auto using leb_refl. - intros i Hle Hlt Hr cont Hcont Hle'. - rewrite foldi_cont_lt;[ | trivial]. - apply Hf;trivial. rewrite leb_spec;rewrite ltb_spec in Hlt;auto with zarith. - assert ([|i|] + 1 = [|i + 1|])%Z. - rewrite ltb_spec in Hlt;assert (W:= to_Z_bounded i);rewrite add_spec, to_Z_1, Zmod_small;omega. - rewrite H;apply Hr;trivial. - assert (max < min = true) by (rewrite ltb_negb_geb,Heq;trivial). - rewrite foldi_cont_gt;trivial;apply Ha;rewrite <- ltb_spec;trivial. -Qed. - - -(* Lemma of_pos_spec : forall p, [|of_pos p|] = Zpos p mod wB. *) -(* Proof. *) -(* unfold of_pos. *) -(* unfold wB. *) -(* assert (forall k, (k <= size)%nat -> *) -(* forall p : positive, [|of_pos_rec k p|] = Zpos p mod 2 ^ Z_of_nat k). *) -(* induction k. *) -(* simpl;intros;rewrite to_Z_0,Zmod_1_r;trivial. *) -(* Opaque Z_of_nat. *) -(* destruct p;simpl. *) -(* destruct (bit_add_or (of_pos_rec k p << 1) 1) as (H1, _). *) -(* rewrite <- H1;clear H1. *) -(* change (Zpos p~1) with (2*(Zpos p) + 1)%Z. *) -(* rewrite add_spec,lsl_spec, IHk, to_Z_1. *) -(* rewrite Zmult_comm, Zplus_mod_idemp_l, Zmod_small. *) -(* change 2%Z with (2^1)%Z. *) -(* rewrite Zmod_distr. *) -(* rewrite inj_S, Zpower_Zsucc;[ | apply Zle_0_nat]. *) -(* repeat change (2^1)%Z with 2%Z. *) -(* rewrite Zmult_mod_distr_l;trivial. *) -(* Transparent Z_of_nat. *) -(* rewrite inj_S;omega. *) -(* discriminate. *) -(* split;[discriminate | trivial]. *) -(* compute;trivial. *) -(* assert (W:0 <= Zpos p mod 2 ^ Z_of_nat k < 2 ^ Z_of_nat k). *) -(* apply Z.mod_pos_bound;auto with zarith. *) -(* change (2^1)%Z with 2%Z;split;try omega. *) -(* apply Z.lt_le_trans with (2 ^ Z_of_nat (S k)). *) -(* rewrite inj_S, Zpower_Zsucc;omega. *) -(* unfold wB;apply Zpower_le_monotone;auto with zarith. *) -(* split;auto using inj_le with zarith. *) -(* auto with zarith. *) -(* intros n H1 H2. *) -(* rewrite bit_1, eqb_spec in H2;subst. *) -(* rewrite bit_lsl in H1;discriminate H1. *) - -(* change (Zpos p~0) with (2*(Zpos p))%Z. *) -(* rewrite lsl_spec, IHk, to_Z_1. *) -(* rewrite Zmult_comm, Zmod_small. *) -(* rewrite inj_S, Zpower_Zsucc;[ | apply Zle_0_nat]. *) -(* rewrite Zmult_mod_distr_l;trivial. *) -(* assert (W:0 <= Zpos p mod 2 ^ Z_of_nat k < 2 ^ Z_of_nat k). *) -(* apply Z.mod_pos_bound;auto with zarith. *) -(* change (2^1)%Z with 2%Z;split;try omega. *) -(* apply Z.lt_le_trans with (2 ^ Z_of_nat (S k)). *) -(* rewrite inj_S, Zpower_Zsucc;omega. *) -(* unfold wB;apply Zpower_le_monotone;auto with zarith. *) -(* split;auto using inj_le with zarith. *) -(* auto with zarith. *) - -(* rewrite to_Z_1, Zmod_small;trivial. *) -(* split;auto with zarith. *) -(* apply Zpower_gt_1;auto with zarith. *) -(* rewrite inj_S;auto with zarith. *) - -(* apply H;auto with zarith. *) -(* Qed. *) - -Lemma of_Z_spec : forall z, [|of_Z z|] = z mod wB. -Admitted. (* no more of_pos *) -(* Proof. *) -(* unfold of_Z;destruct z. *) -(* assert (W:= to_Z_bounded 0);rewrite Zmod_small;trivial. *) -(* apply of_pos_spec. *) -(* rewrite opp_spec, of_pos_spec. *) -(* rewrite <- Zmod_opp_opp. *) -(* change (- Zpos p)%Z with (Zneg p). *) -(* destruct (Z_eq_dec (Zneg p mod wB) 0). *) -(* rewrite e, Z_mod_zero_opp_r;trivial. *) -(* rewrite Z_mod_nz_opp_r, Zminus_mod, Z_mod_same_full, Zmod_mod, Zminus_0_r, Zmod_mod;trivial. *) -(* Qed. *) - -Lemma foldi_cont_Ind : forall A B (P: int -> (A -> B) -> Prop) (f:int -> (A -> B) -> (A -> B)) min max cont, - max < max_int = true -> - (forall z, max < z = true -> P z cont) -> - (forall i cont, min <= i = true -> i <= max = true -> P (i + 1) cont -> P i (f i cont)) -> - P min (foldi_cont f min max cont). -Proof. - intros. - set (P' z cont := (0 <= z < wB)%Z -> P (of_Z z) cont). - assert (P' [|min|] (foldi_cont f min max cont)). - apply foldi_cont_ZInd;unfold P';intros. - assert ([|(of_Z z)|] = z). - rewrite of_Z_spec, Zmod_small;trivial. - apply H0;rewrite ltb_spec, H4;trivial. - rewrite of_to_Z;apply H1;trivial. - assert (i < max_int = true). - apply leb_ltb_trans with max;trivial. - rewrite <- (to_Z_add_1 _ _ H6), of_to_Z in H4;apply H4. - apply to_Z_bounded. - unfold P' in H2;rewrite of_to_Z in H2;apply H2;apply to_Z_bounded. -Qed. - -Lemma foldi_cont_ind : forall A B (P: (A -> B) -> Prop) (f:int -> (A -> B) -> (A -> B)) min max cont, - P cont -> - (forall i cont, min <= i = true -> i <= max = true -> P cont -> P (f i cont)) -> - P (foldi_cont f min max cont). -Proof. - intros A B P f min max cont Ha Hf. - set (P2 := fun (z:Z) b => P b);change (P2 [|min|] (foldi_cont f min max cont)). - apply foldi_cont_ZInd;trivial. -Qed. - -Lemma foldi_ZInd : forall A (P : Z -> A -> Prop) f min max a, - (max < min = true -> P ([|max|] + 1)%Z a) -> - P [|min|] a -> - (forall i a, min <= i = true -> i <= max = true -> - P [|i|] a -> P ([|i|] + 1)%Z (f i a)) -> - P ([|max|]+1)%Z (foldi f min max a). -Proof. - unfold foldi;intros A P f min max a Hlt;intros. - set (P' z cont := - if Zlt_bool [|max|] z then cont = (fun a0 : A => a0) - else forall a, P z a -> P ([|max|]+1)%Z (cont a)). - assert (P' [|min|] (foldi_cont (fun (i : int) (cont : A -> A) (a0 : A) => cont (f i a0)) min - max (fun a0 : A => a0))). - apply foldi_cont_ZInd;intros;red. - rewrite Zlt_is_lt_bool in H1;rewrite H1;trivial. - case_eq (Zlt_bool [|max|] [|i|]);intros. - rewrite <- Zlt_is_lt_bool in H4;rewrite leb_spec in H2;elimtype False;omega. - clear H4; revert H3;unfold P'. - case_eq (Zlt_bool [|max|] ([|i|] + 1));intros;auto. - rewrite <- Zlt_is_lt_bool in H3; assert ([|i|] = [|max|]) by (rewrite leb_spec in H2;omega). - rewrite H4, <- H6;apply H0;trivial. - revert H1;unfold P'. - case_eq (Zlt_bool [|max|] [|min|]);auto. - rewrite <- Zlt_is_lt_bool, <- ltb_spec;intros;rewrite foldi_cont_gt;auto. -Qed. - -Lemma foldi_Ind : forall A (P : int -> A -> Prop) f min max a, - (max < max_int = true) -> - (max < min = true -> P (max + 1) a) -> - P min a -> - (forall i a, min <= i = true -> i <= max = true -> - P i a -> P (i + 1) (f i a)) -> - P (max+1) (foldi f min max a). -Proof. - intros. - set (P' z a := (0 <= z < wB)%Z -> P (of_Z z) a). - assert (W:= to_Z_add_1 _ _ H). - assert (P' ([|max|]+1)%Z (foldi f min max a)). - apply foldi_ZInd;unfold P';intros. - rewrite <- W, of_to_Z;auto. - rewrite of_to_Z;trivial. - assert (i < max_int = true). - apply leb_ltb_trans with max;trivial. - rewrite <- (to_Z_add_1 _ _ H7), of_to_Z;apply H2;trivial. - rewrite of_to_Z in H5;apply H5;apply to_Z_bounded. - unfold P' in H3;rewrite <- W, of_to_Z in H3;apply H3;apply to_Z_bounded. -Qed. - -Lemma foldi_ind : forall A (P: A -> Prop) (f:int -> A -> A) min max a, - P a -> - (forall i a, min <= i = true -> i <= max = true -> P a -> P (f i a)) -> - P (foldi f min max a). -Proof. - unfold foldi;intros A P f min max a Ha Hr;revert a Ha. - apply foldi_cont_ind;auto. -Qed. - -Lemma fold_ind : forall A (P: A -> Prop) (f: A -> A) min max a, - P a -> (forall a, P a -> P (f a)) -> P (fold f min max a). -Proof. - unfold fold;intros A P f min max a Ha Hr;revert a Ha. - apply foldi_cont_ind;auto. -Qed. - -Lemma foldi_down_cont_ZInd : - forall A B (P: Z -> (A -> B) -> Prop) (f:int -> (A -> B) -> (A -> B)) max min cont, - (forall z, (z < [|min|])%Z -> P z cont) -> - (forall i cont, min <= i = true -> i <= max = true -> P ([|i|] - 1)%Z cont -> P [|i|] (f i cont)) -> - P [|max|] (foldi_down_cont f max min cont). -Proof. - intros A B P f max min cont Ha Hf. - assert (Bmax:= to_Z_bounded max);assert (Bmin:= to_Z_bounded min). - case_eq (min <= max);intros Heq. - generalize (leb_refl max). - assert (P ([|min|] -1)%Z cont) by (apply Ha;auto with zarith). - clear Ha;revert cont H Heq. - pattern max at 1 2 4 5;apply int_ind;trivial. - intros; assert (0 = min). - apply to_Z_inj;revert Heq;rewrite leb_spec, to_Z_0;omega. - rewrite foldi_down_cont_eq;subst;auto. - intros i Hmaxi Hr cont Hcont Hmin Hmax. - generalize Hmin;rewrite leb_ltb_eqb;case_eq (min < i+1);simpl;intros Hlt Hmin'. - rewrite foldi_down_cont_gt;[ | trivial]. - apply Hf;trivial. - assert ([|i|] + 1 = [|i + 1|])%Z. - assert (W:= to_Z_bounded i);rewrite ltb_spec in Hmaxi; - assert (W2 := to_Z_bounded max_int);rewrite add_spec, to_Z_1, Zmod_small;auto with zarith. - assert (i + 1 - 1 = i). - rewrite leb_spec in *;rewrite ltb_spec in *. - assert (W1:= to_Z_bounded i); apply to_Z_inj;rewrite sub_spec,to_Z_1, Zmod_small;try omega. - assert ([|i|] = [|i+1|]-1)%Z. - rewrite <- H;ring. - rewrite <- H1, H0;apply Hr;trivial. - rewrite ltb_spec in Hlt;rewrite leb_spec;omega. - rewrite leb_spec in Hmax |- *;omega. - rewrite eqb_spec in Hmin';subst;rewrite foldi_down_cont_eq;auto. - assert (max < min = true) by (rewrite ltb_negb_geb,Heq;trivial). - rewrite foldi_down_cont_lt;trivial. - apply Ha;rewrite <- ltb_spec;trivial. -Qed. - -Lemma foldi_down_cont_ind : forall A B (P: (A -> B) -> Prop) (f:int -> (A -> B) -> (A -> B)) max min cont, - P cont -> - (forall i cont, min <= i = true -> i <= max = true -> P cont -> P (f i cont)) -> - P (foldi_down_cont f max min cont). -Proof. - intros A B P f max min cont Ha Hf. - set (P2 := fun (z:Z) b => P b);change (P2 [|max|] (foldi_down_cont f max min cont)). - apply foldi_down_cont_ZInd;trivial. -Qed. - -Lemma foldi_down_ZInd : - forall A (P: Z -> A -> Prop) (f:int -> A -> A) max min a, - (max < min = true -> P ([|min|] - 1)%Z a) -> - (P [|max|] a) -> - (forall i a, min <= i = true -> i <= max = true -> P [|i|]%Z a -> P ([|i|]-1)%Z (f i a)) -> - P ([|min|] - 1)%Z (foldi_down f max min a). -Proof. - unfold foldi_down;intros A P f max min a Hlt;intros. - set (P' z cont := - if Zlt_bool z [|min|] then cont = (fun a0 : A => a0) - else forall a, P z a -> P ([|min|] - 1)%Z (cont a)). - assert (P' [|max|] (foldi_down_cont (fun (i : int) (cont : A -> A) (a0 : A) => cont (f i a0)) max - min (fun a0 : A => a0))). - apply foldi_down_cont_ZInd;intros;red. - rewrite Zlt_is_lt_bool in H1;rewrite H1;trivial. - case_eq (Zlt_bool [|i|] [|min|]);intros. - rewrite <- Zlt_is_lt_bool in H4;rewrite leb_spec in H1;elimtype False;omega. - clear H4;revert H3;unfold P'. - case_eq (Zlt_bool ([|i|] - 1) [|min|]);intros;auto. - rewrite <- Zlt_is_lt_bool in H3; assert ([|i|] = [|min|]) by (rewrite leb_spec in H1;omega). - rewrite H4, <- H6. apply H0;trivial. - revert H1;unfold P'. - case_eq (Zlt_bool [|max|] [|min|]);auto. - rewrite <- Zlt_is_lt_bool, <- ltb_spec;intros;rewrite foldi_down_cont_lt;auto. -Qed. - -Lemma foldi_down_ind : forall A (P: A -> Prop) (f:int -> A -> A) max min a, - P a -> - (forall i a, min <= i = true -> i <= max = true -> P a -> P (f i a)) -> - P (foldi_down f max min a). -Proof. - unfold foldi_down;intros A P f max min a Ha Hr;revert a Ha. - apply foldi_down_cont_ind;auto. -Qed. - -Lemma fold_down_ind : forall A (P: A -> Prop) (f: A -> A) max min a, - P a -> (forall a, P a -> P (f a)) -> P (fold_down f max min a). -Proof. - unfold fold_down;intros A P f max min a Ha Hr;revert a Ha. - apply foldi_down_cont_ind;auto. -Qed. - -Lemma foldi_down_Ind : - forall A (P: int -> A -> Prop) (f:int -> A -> A) max min a, - 0 < min = true -> - (max < min = true -> P (min - 1) a) -> - (P max a) -> - (forall i a, min <= i = true -> i <= max = true -> P i a -> P (i - 1) (f i a)) -> - P (min - 1) (foldi_down f max min a). -Proof. - intros. - set (P' z a := (0 <= z < wB)%Z -> P (of_Z z) a). - assert (W:= to_Z_sub_1 _ _ H). - assert (P' ([|min|]-1)%Z (foldi_down f max min a)). - apply foldi_down_ZInd;unfold P';intros. - rewrite <- W, of_to_Z;auto. - rewrite of_to_Z;trivial. - assert (0 < i = true). - apply ltb_leb_trans with min;trivial. - rewrite <- (to_Z_sub_1 _ _ H7), of_to_Z;apply H2;trivial. - rewrite of_to_Z in H5;apply H5;apply to_Z_bounded. - unfold P' in H3;rewrite <- W, of_to_Z in H3;apply H3;apply to_Z_bounded. -Qed. - -Lemma foldi_down_min : - forall A f min max (a:A), - min < max_int = true-> - (min <= max) = true -> - foldi_down f max min a = f min (foldi_down f max (min + 1) a). -Proof. - intros. - set (P:= fun i => i <= max - min = true -> - forall a, foldi_down f (min + i) min a = f min (foldi_down f (min + i) (min + 1) a)). - assert (min < min + 1 = true). - rewrite ltb_leb_add1 with (y:=max_int), leb_refl;trivial. - assert (P (max - min)). - apply int_ind;unfold P. - replace (min + 0) with min. - intros _ a'; rewrite foldi_down_eq, foldi_down_lt;trivial. - apply to_Z_inj;rewrite add_spec, to_Z_0, Zplus_0_r, Zmod_small;auto using to_Z_bounded. - intros i Hi Hrec Hi1 a'. - rewrite add_assoc. - assert (Wi:= to_Z_add_1 _ _ Hi). - assert (Wmin:= to_Z_add_1 _ _ H). - assert ((min + 1) <= (min + i + 1) = true). - assert (W1 := to_Z_bounded min); assert (W2:= to_Z_bounded max); assert (W3:= to_Z_bounded i). - replace (min + i + 1) with (min + 1 + i). - rewrite leb_spec, (add_spec (min+1)). - unfold is_true in Hi1;rewrite leb_spec in *; rewrite ltb_spec in *. - rewrite sub_spec in Hi1;rewrite Zmod_small in Hi1;[ | omega]. - rewrite Zmod_small;omega. - rewrite <- !add_assoc, (add_comm 1 i);trivial. - rewrite leb_ltb_eqb in H2;revert H2. - case_eq (min + 1 < min + i + 1). - intros Hlt _;rewrite foldi_down_gt. - rewrite foldi_down_gt with (from := min + i + 1);trivial. - replace (min + i + 1 - 1) with (min + i). - apply Hrec. - apply leb_trans with (i+1);[rewrite leb_spec;omega | trivial]. - apply to_Z_inj;rewrite sub_spec, (add_spec (min + i)), to_Z_1, Zminus_mod_idemp_l. - assert (H100: forall (x:Z), (x + 1 - 1)%Z = x) by (intros; ring). rewrite H100. - rewrite Zmod_small;auto using to_Z_bounded. - apply leb_ltb_trans with (2:= Hlt). - rewrite leb_spec;omega. - simpl;rewrite eqb_spec;intros _ Heq. - rewrite <- Heq. - rewrite foldi_down_gt. - replace (min + 1 - 1) with min. - rewrite !foldi_down_eq;trivial. - apply to_Z_inj;rewrite sub_spec, add_spec, to_Z_1, Zminus_mod_idemp_l. - replace ([|min|] + 1 - 1)%Z with [|min|] by ring. - rewrite Zmod_small;auto using to_Z_bounded. - rewrite ltb_spec;omega. - generalize (H2 (leb_refl _) a). - replace (min + (max - min)) with max;trivial. - apply to_Z_inj;rewrite add_spec, sub_spec, Zplus_mod_idemp_r. - ring_simplify ([|min|] + ([|max|] - [|min|]))%Z. - rewrite Zmod_small;auto using to_Z_bounded. -Qed. - -Definition foldi_ntr A f min max (a:A) := - foldi_cont (fun i cont _ => f i (cont tt)) min max (fun _ => a) tt. - -Lemma foldi_ntr_foldi_down : forall A f min max (a:A), - max < max_int = true -> - foldi_down f max min a = foldi_ntr _ f min max a. -Proof. - intros;unfold foldi_ntr. - apply foldi_cont_Ind;trivial. - intros;apply foldi_down_lt;trivial. - intros i cont Hmin Hmax Heq;rewrite <- Heq;clear Heq. - apply foldi_down_min;trivial. - apply leb_ltb_trans with (1:= Hmax);trivial. -Qed. - - -(** Two iterators *) - -Lemma foldi_cont_ZInd2 : forall A B C D (P: Z -> (A -> B) -> (C -> D) -> Prop) (f1 : int -> (A -> B) -> (A -> B)) (f2 : int -> (C -> D) -> (C -> D)) min max cont1 cont2, - (forall z, ([|max|] < z)%Z -> P z cont1 cont2) -> - (forall i cont1 cont2, min <= i = true -> i <= max = true -> P ([|i|] + 1)%Z cont1 cont2 -> - P [|i|] (f1 i cont1) (f2 i cont2)) -> - P [|min|] (foldi_cont f1 min max cont1) (foldi_cont f2 min max cont2). -Proof. - intros. - set (P' z cont := - if Zlt_bool [|max|] z then cont = cont1 - else P z cont (foldi_cont f2 (of_Z z) max cont2)). - assert (P' [|min|] (foldi_cont f1 min max cont1)). - apply foldi_cont_ZInd;unfold P';intros. - rewrite Zlt_is_lt_bool in H1;rewrite H1;trivial. - case_eq (Zlt_bool [|max|] [|i|]);intros. - rewrite <- Zlt_is_lt_bool, <- ltb_spec in H4. - elim (not_ltb_refl max);apply ltb_leb_trans with i;trivial. - rewrite of_to_Z;generalize H2;rewrite leb_ltb_eqb, orb_true_iff;intros [Hlt | Heq]. - rewrite foldi_cont_lt;[apply H0 | ];trivial. - revert H3;case_eq (Zlt_bool [|max|] ([|i|] + 1)). - rewrite <- Zlt_is_lt_bool;rewrite ltb_spec in Hlt;intros;elimtype False;omega. - rewrite <- (to_Z_add_1 _ _ Hlt), of_to_Z; intros _ W;exact W. - rewrite eqb_spec in Heq;subst. - rewrite foldi_cont_eq;[apply H0 | ];trivial. - assert ([|max|] < [|max|] + 1)%Z by auto with zarith. - rewrite Zlt_is_lt_bool in H5;rewrite H5 in H3;rewrite H3. - apply H;rewrite Zlt_is_lt_bool;trivial. - revert H1;unfold P';case_eq (Zlt_bool [|max|] [|min|]). - rewrite <- Zlt_is_lt_bool;intros. - rewrite H2;rewrite foldi_cont_gt;[ | rewrite ltb_spec];auto. - rewrite of_to_Z;auto. -Qed. - - -Lemma foldi_cont_ind2 : forall A B C D (P: (A -> B) -> (C -> D) -> Prop) (f:int -> (A -> B) -> (A -> B)) (g:int -> (C -> D) -> (C -> D)) min max cont1 cont2, - P cont1 cont2 -> - (forall i cont1 cont2, min <= i = true -> i <= max = true -> P cont1 cont2 -> P (f i cont1) (g i cont2)) -> - P (foldi_cont f min max cont1) (foldi_cont g min max cont2). -Proof. - intros A B C D P f g min max cont1 cont2 Ha Hf. - set (P2 := fun (z:Z) b c => P b c);change (P2 [|min|] (foldi_cont f min max cont1) (foldi_cont g min max cont2)). - apply foldi_cont_ZInd2;trivial. -Qed. - - -Lemma foldi_ZInd2 : forall A B (P : Z -> A -> B -> Prop) f g min max a b, - (max < min = true -> P ([|max|] + 1)%Z a b) -> - P [|min|] a b -> - (forall i a b, min <= i = true -> i <= max = true -> - P [|i|] a b -> P ([|i|] + 1)%Z (f i a) (g i b)) -> - P ([|max|]+1)%Z (foldi f min max a) (foldi g min max b). -Proof. - unfold foldi;intros A B P f g min max a b Hlt;intros. - set (P' z cont1 cont2 := - if Zlt_bool [|max|] z then cont1 = (fun a : A => a) /\ cont2 = (fun b : B => b) - else forall a b, P z a b -> P ([|max|]+1)%Z (cont1 a) (cont2 b)). - assert (P' [|min|] (foldi_cont (fun (i : int) (cont : A -> A) (a : A) => cont (f i a)) min - max (fun a : A => a)) - (foldi_cont (fun (i : int) (cont : B -> B) (b : B) => cont (g i b)) min - max (fun b : B => b))). - apply foldi_cont_ZInd2;intros;red. - rewrite Zlt_is_lt_bool in H1;rewrite H1;auto. - case_eq (Zlt_bool [|max|] [|i|]);intros. - rewrite <- Zlt_is_lt_bool in H4;rewrite leb_spec in H2;elimtype False;omega. - clear H4; revert H3;unfold P'. - case_eq (Zlt_bool [|max|] ([|i|] + 1));intros;auto. - rewrite <- Zlt_is_lt_bool in H3; assert ([|i|] = [|max|]) by (rewrite leb_spec in H2;omega). - destruct H4;subst;rewrite <- H6;apply H0;trivial. - revert H1;unfold P'. - case_eq (Zlt_bool [|max|] [|min|]);auto. - rewrite <- Zlt_is_lt_bool, <- ltb_spec;intros;rewrite !foldi_cont_gt;auto. -Qed. - - -Lemma foldi_Ind2 : forall A B (P : int -> A -> B -> Prop) f g min max a b, - (max < max_int = true) -> - (max < min = true -> P (max + 1) a b) -> - P min a b -> - (forall i a b, min <= i = true -> i <= max = true -> - P i a b -> P (i + 1) (f i a) (g i b)) -> - P (max+1) (foldi f min max a) (foldi g min max b). -Proof. - intros. - set (P' z a b := (0 <= z < wB)%Z -> P (of_Z z) a b). - assert (W:= to_Z_add_1 _ _ H). - assert (P' ([|max|]+1)%Z (foldi f min max a) (foldi g min max b)). - apply foldi_ZInd2;unfold P';intros. - rewrite <- W, of_to_Z;auto. - rewrite of_to_Z;trivial. - assert (i < max_int = true). - apply leb_ltb_trans with max;trivial. - rewrite <- (to_Z_add_1 _ _ H7), of_to_Z;apply H2;trivial. - rewrite of_to_Z in H5;apply H5;apply to_Z_bounded. - unfold P' in H3;rewrite <- W, of_to_Z in H3;apply H3;apply to_Z_bounded. -Qed. - - -Lemma foldi_ind2 : forall A B (P: A -> B -> Prop) (f:int -> A -> A) (g:int -> B -> B) min max a b, - P a b -> - (forall i a b, min <= i = true -> i <= max = true -> P a b -> P (f i a) (g i b)) -> - P (foldi f min max a) (foldi g min max b). -Proof. - unfold foldi;intros A B P f g min max a b Ha Hr; revert a b Ha. - apply (foldi_cont_ind2 _ _ _ _ (fun cont1 cont2 => forall a b, P a b -> P (cont1 a) (cont2 b))); auto. -Qed. - - -Lemma fold_ind2 : forall A B (P: A -> B -> Prop) (f: A -> A) (g: B -> B) min max a b, - P a b -> (forall a b, P a b -> P (f a) (g b)) -> P (fold f min max a) (fold g min max b). -Proof. - unfold fold;intros A B P f g min max a b Ha Hr;revert a b Ha. - apply (foldi_cont_ind2 _ _ _ _ (fun cont1 cont2 => forall a b, P a b -> P (cont1 a) (cont2 b)));auto. -Qed. - -Lemma foldi_eq_compat : forall A (f1 f2:int -> A -> A) min max a, - (forall i a, min <= i = true -> i <= max = true -> f1 i a = f2 i a) -> - foldi f1 min max a = foldi f2 min max a. -Proof. - intros; set (P' (z:Z) (a1 a2:A) := a1 = a2). - assert (P' ([|max|] + 1)%Z (foldi f1 min max a) (foldi f2 min max a)). - apply foldi_ZInd2;unfold P';intros;subst;auto. - apply H0. -Qed. - -Lemma foldi_down_cont_ZInd2 : - forall A B C D (P: Z -> (A -> B) -> (C -> D) -> Prop) (f1:int -> (A -> B) -> (A -> B)) (f2:int -> (C -> D) -> (C -> D)) max min cont1 cont2, - (forall z, (z < [|min|])%Z -> P z cont1 cont2) -> - (forall i cont1 cont2, min <= i = true -> i <= max = true -> P ([|i|] - 1)%Z cont1 cont2 -> - P [|i|] (f1 i cont1) (f2 i cont2)) -> - P [|max|] (foldi_down_cont f1 max min cont1) (foldi_down_cont f2 max min cont2). -Proof. - intros. - set (P' z cont := - if Zlt_bool z [|min|] then cont = cont1 - else P z cont (foldi_down_cont f2 (of_Z z) min cont2)). - assert (P' [|max|] (foldi_down_cont f1 max min cont1)). - apply foldi_down_cont_ZInd;unfold P';intros. - rewrite Zlt_is_lt_bool in H1;rewrite H1;trivial. - case_eq (Zlt_bool [|i|] [|min|]);intros. - rewrite <- Zlt_is_lt_bool, <- ltb_spec in H4. - elim (not_ltb_refl min);apply leb_ltb_trans with i;trivial. - rewrite of_to_Z;generalize H1;rewrite leb_ltb_eqb, orb_true_iff;intros [Hlt | Heq]. - rewrite foldi_down_cont_gt;[apply H0 | ];trivial. - revert H3;case_eq (Zlt_bool ([|i|] - 1) [|min|]). - rewrite <- Zlt_is_lt_bool;rewrite ltb_spec in Hlt;intros;elimtype False;omega. - rewrite <- (to_Z_sub_1 _ _ Hlt), of_to_Z; intros _ W;exact W. - rewrite eqb_spec in Heq;subst. - rewrite foldi_down_cont_eq;[apply H0 | ];trivial. - assert ([|i|] - 1 < [|i|])%Z by auto with zarith. - rewrite Zlt_is_lt_bool in H5;rewrite H5 in H3;rewrite H3. - apply H;rewrite Zlt_is_lt_bool;trivial. - revert H1;unfold P';case_eq (Zlt_bool [|max|] [|min|]). - rewrite <- Zlt_is_lt_bool;intros. - rewrite H2;rewrite foldi_down_cont_lt;[ | rewrite ltb_spec];auto. - rewrite of_to_Z;auto. -Qed. - - -Lemma foldi_down_cont_ind2 : forall A B C D (P: (A -> B) -> (C -> D) -> Prop) (f:int -> (A -> B) -> (A -> B)) (g:int -> (C -> D) -> (C -> D)) max min cont1 cont2, - P cont1 cont2 -> - (forall i cont1 cont2, min <= i = true -> i <= max = true -> P cont1 cont2 -> P (f i cont1) (g i cont2)) -> - P (foldi_down_cont f max min cont1) (foldi_down_cont g max min cont2). -Proof. - intros A B C D P f g max min cont1 cont2 Ha Hf. - set (P2 := fun (z:Z) b c => P b c);change (P2 [|max|] (foldi_down_cont f max min cont1) (foldi_down_cont g max min cont2)). - apply foldi_down_cont_ZInd2;trivial. -Qed. - - -Lemma foldi_down_ZInd2 : - forall A B (P: Z -> A -> B -> Prop) (f1:int -> A -> A) (f2:int -> B -> B) max min a1 a2, - (max < min = true -> P ([|min|] - 1)%Z a1 a2) -> - (P [|max|] a1 a2) -> - (forall z, (z < [|min|])%Z -> P z a1 a2) -> - (forall i a1 a2, min <= i = true -> i <= max = true -> P [|i|] a1 a2 -> - P ([|i|] - 1)%Z (f1 i a1) (f2 i a2)) -> - P ([|min|] - 1)%Z (foldi_down f1 max min a1) (foldi_down f2 max min a2). -Proof. - unfold foldi_down;intros A B P f1 f2 max min a1 a2 Hlt;intros. - set (P' z cont1 cont2 := - if Zlt_bool z [|min|] then cont1 = (fun a0 : A => a0) /\ cont2 = (fun a0 : B => a0) - else forall a1 a2, P z a1 a2 -> P ([|min|] - 1)%Z (cont1 a1) (cont2 a2)). - assert (P' [|max|] (foldi_down_cont (fun (i : int) (cont : A -> A) (a0 : A) => cont (f1 i a0)) max - min (fun a0 : A => a0)) - (foldi_down_cont (fun (i : int) (cont : B -> B) (a0 : B) => cont (f2 i a0)) max - min (fun a0 : B => a0))). - apply foldi_down_cont_ZInd2;intros;red. - rewrite Zlt_is_lt_bool in H2;rewrite H2;auto. - case_eq (Zlt_bool [|i|] [|min|]);intros. - rewrite <- Zlt_is_lt_bool in H5;rewrite leb_spec in H2;elimtype False;omega. - clear H5;revert H4;unfold P'. - case_eq (Zlt_bool ([|i|] - 1) [|min|]);intros;auto. - rewrite <- Zlt_is_lt_bool in H4; assert ([|i|] = [|min|]) by (rewrite leb_spec in H2;omega). - destruct H5;subst;rewrite <- H7;apply H1;trivial. - revert H2;unfold P'. - case_eq (Zlt_bool [|max|] [|min|]);auto. - rewrite <- Zlt_is_lt_bool, <- ltb_spec;intros;rewrite foldi_down_cont_lt;auto. - destruct H3. rewrite H4;auto. -Qed. - - -Lemma foldi_down_ind2 : forall A B (P: A -> B -> Prop) (f:int -> A -> A) (g:int -> B -> B) max min a b, - P a b -> - (forall i a b, min <= i = true -> i <= max = true -> P a b -> P (f i a) (g i b)) -> - P (foldi_down f max min a) (foldi_down g max min b). -Proof. - unfold foldi_down;intros A B P f g max min a b Ha Hr;revert a b Ha. - apply (foldi_down_cont_ind2 _ _ _ _ (fun cont1 cont2 => forall a b, P a b -> P (cont1 a) (cont2 b)));auto. -Qed. - - -Lemma fold_down_ind2 : forall A B (P: A -> B -> Prop) (f: A -> A) (g: B -> B) max min a b, - P a b -> (forall a b, P a b -> P (f a) (g b)) -> P (fold_down f max min a) (fold_down g max min b). -Proof. - unfold fold_down;intros A B P f g max min a b Ha Hr;revert a b Ha. - apply (foldi_down_cont_ind2 _ _ _ _ (fun cont1 cont2 => forall a b, P a b -> P (cont1 a) (cont2 b)));auto. -Qed. - -Lemma foldi_down_eq_compat : forall A (f1 f2:int -> A -> A) max min a, - (forall i a, min <= i = true -> i <= max = true -> f1 i a = f2 i a) -> - foldi_down f1 max min a = foldi_down f2 max min a. -Proof. - intros; set (P' (z:Z) (a1 a2:A) := a1 = a2). - assert (P' ([|min|] - 1)%Z (foldi_down f1 max min a) (foldi_down f2 max min a)). - apply foldi_down_ZInd2;unfold P';intros;subst;auto. - apply H0. -Qed. - - -Lemma forallb_spec : forall f from to, - forallb f from to = true <-> - forall i, from <= i = true -> i <= to = true -> f i = true. -Proof. - unfold forallb;intros f from to. - setoid_rewrite leb_spec. - apply foldi_cont_ZInd. - intros;split;[intros;elimtype False;omega | trivial]. - intros i cont Hfr Hto Hcont. - case_eq (f i);intros Heq. - rewrite Hcont;clear Hcont;split;auto with zarith;intros. - assert (H2 : ([|i0|] = [|i|] \/ [|i|] + 1 <= [|i0|])%Z) by omega; destruct H2;auto with zarith. - apply to_Z_inj in H2;rewrite H2;trivial. - split;[discriminate | intros]. - rewrite leb_spec in Hto;rewrite <- Heq;auto with zarith. -Qed. - -Lemma forallb_eq_compat : forall f1 f2 from to, - (forall i, from <= i = true -> i <= to = true -> f1 i = f2 i) -> - forallb f1 from to = forallb f2 from to. -Proof. - unfold forallb;intros. - set (P' (z:Z) (cont1 cont2:unit -> bool) := cont1 tt = cont2 tt). - refine (foldi_cont_ZInd2 _ _ _ _ P' _ _ from to _ _ _ _);unfold P';intros;trivial. - rewrite H2, H;trivial. -Qed. - -Lemma existsb_spec : forall f from to, - existsb f from to = true <-> - exists i, ((from <= i) && (i <= to) && (f i)) = true . -Proof. - unfold existsb;intros. - repeat setoid_rewrite andb_true_iff;setoid_rewrite leb_spec. - apply foldi_cont_ZInd. - intros;split;[discriminate | intros [i [W1 W2]];elimtype False;omega]. - intros i cont Hfr Hto Hcont. - case_eq (f i);intros Heq. - split;trivial. - exists i;rewrite leb_spec in Hto;auto with zarith. - rewrite Hcont;clear Hcont;split;intros [i0 [W1 W2]]; - exists i0;split;auto with zarith. - assert (~ [|i|] = [|i0|]);[ | auto with zarith]. - intros W;apply to_Z_inj in W;rewrite W in Heq;rewrite Heq in W2;discriminate. -Qed. - -Lemma existsb_eq_compat : forall f1 f2 from to, - (forall i, from <= i = true -> i <= to = true -> f1 i = f2 i) -> - existsb f1 from to = existsb f2 from to. -Proof. - unfold existsb;intros. - set (P' (z:Z) (cont1 cont2:unit -> bool) := cont1 tt = cont2 tt). - refine (foldi_cont_ZInd2 _ _ _ _ P' _ _ from to _ _ _ _);unfold P';intros;trivial. - rewrite H2, H;trivial. -Qed. - - -Lemma bit_max_int : forall i, (i < digits)%int = true -> bit max_int i = true. -Proof. - intros;apply (forallb_spec (bit max_int) 0 (digits - 1)). - vm_compute;trivial. - apply leb_0. - rewrite ltb_spec in H. - destruct (to_Z_bounded i);rewrite leb_spec. - change [|digits - 1 |] with ([|digits|] - 1)%Z;omega. -Qed. - -Lemma land_max_int_l : forall i, max_int land i = i. -Proof. - intros;apply bit_eq;intros. - rewrite land_spec. - destruct (reflect_leb digits i0). - rewrite <- leb_spec in l. - rewrite !bit_M;trivial. - rewrite bit_max_int;trivial. - rewrite ltb_spec;omega. -Qed. - -Lemma land_max_int_r : forall i, i land max_int = i. -Proof. - intros;rewrite land_comm;apply land_max_int_l. -Qed. - - -(* int is an OrderedType *) - -Require Import OrderedType. - -Module IntOrderedType <: OrderedType. - - Definition t := int. - - Definition eq x y := (x == y) = true. - - Definition lt x y := (x < y) = true. - - Lemma eq_refl x : eq x x. - Proof. unfold eq. rewrite eqb_spec. reflexivity. Qed. - - Lemma eq_sym x y : eq x y -> eq y x. - Proof. unfold eq. rewrite !eqb_spec. intros ->. reflexivity. Qed. - - Lemma eq_trans x y z : eq x y -> eq y z -> eq x z. - Proof. unfold eq. rewrite !eqb_spec. intros -> ->. reflexivity. Qed. - - Lemma lt_trans x y z : lt x y -> lt y z -> lt x z. - Proof. apply ltb_trans. Qed. - - Lemma lt_not_eq x y : lt x y -> ~ eq x y. - Proof. unfold lt, eq. rewrite ltb_negb_geb, eqb_spec. intros H1 H2. rewrite H2, leb_refl in H1. discriminate. Qed. - - Definition compare x y : Compare lt eq x y. - Proof. - case_eq (x < y); intro e. - exact (LT e). - case_eq (x == y); intro e2. - exact (EQ e2). apply GT. unfold lt. rewrite ltb_negb_geb, leb_ltb_eqb, e, e2. reflexivity. - Defined. - - Definition eq_dec x y : { eq x y } + { ~ eq x y }. - Proof. - case_eq (x == y); intro e. - left; exact e. - right. intro H. rewrite H in e. discriminate. - Defined. - -End IntOrderedType. - - -(* - Local Variables: - coq-load-path: ((rec "../../.." "SMTCoq")) - End: -*) diff --git a/src/versions/standard/Int63/Int63_standard.v b/src/versions/standard/Int63/Int63_standard.v deleted file mode 100644 index 42ede79..0000000 --- a/src/versions/standard/Int63/Int63_standard.v +++ /dev/null @@ -1,23 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -(** Glue with the Int31 library of standard coq, which is linked to - native integers during VM computations. - - CAUTION: The name "Int63" is given for compatibility reasons, but - int31 is used. **) - -Require Export Ring31. -Require Export Int63Native. -Require Export Int63Op. -Require Export Int63Axioms. -Require Export Int63Properties. diff --git a/src/versions/standard/Makefile.local b/src/versions/standard/Makefile.local deleted file mode 100644 index 8abc72c..0000000 --- a/src/versions/standard/Makefile.local +++ /dev/null @@ -1,36 +0,0 @@ -######################################################################## -## This file is intended to developers: please do not use it ## -## directly, rather use the "configure.sh" script. ## -######################################################################## - - -test : - cd ../unit-tests; make cleanvo; make - -ztest : - cd ../unit-tests; make cleanvo; make zchaff - -vtest : - cd ../unit-tests; make cleanvo; make verit - -lfsctest : - cd ../unit-tests; make cleanvo; make lfsc - -paralleltest : - cd ../unit-tests; make parallel - -clean:: - cd ../unit-tests; make clean - - -CAMLLEX = $(CAMLBIN)ocamllex -CAMLYACC = $(CAMLBIN)ocamlyacc - -%.ml : %.mll - $(CAMLLEX) $< - -%.ml %.mli : %.mly - $(CAMLYACC) $< - -.PHONY: smtcoq_plugin.mlpack.d -smtcoq_plugin.mlpack.d : verit/veritParser.ml verit/veritLexer.ml ../3rdparty/alt-ergo/smtlib2_parse.ml ../3rdparty/alt-ergo/smtlib2_lex.ml smtlib2/sExprParser.ml smtlib2/sExprLexer.ml lfsc/lfscParser.ml lfsc/lfscLexer.ml diff --git a/src/versions/standard/Structures_standard.v b/src/versions/standard/Structures_standard.v deleted file mode 100644 index 1155874..0000000 --- a/src/versions/standard/Structures_standard.v +++ /dev/null @@ -1,64 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -Require Import Int63. - -Require Import List. - - -Section Trace. - - Definition trace (step:Type) := ((list step) * step)%type. - - Definition trace_to_list {step:Type} (t:trace step) : list step := - let (t, _) := t in t. - - Definition trace_length {step:Type} (t:trace step) : int := - let (t,_) := t in - List.fold_left (fun i _ => (i+1)%int) t 0%int. - - Fixpoint trace_get_aux {step:Type} (t:list step) (def:step) (i:int) : step := - match t with - | nil => def - | s::ss => - if (i == 0)%int then - s - else - trace_get_aux ss def (i-1) - end. - Definition trace_get {step:Type} (t:trace step) : int -> step := - let (t,def) := t in trace_get_aux t def. - - Definition trace_fold {state step:Type} (transition: state -> step -> state) (s0:state) (t:trace step) := - let (t,_) := t in - List.fold_left transition t s0. - - Lemma trace_fold_ind (state step : Type) (P : state -> Prop) (transition : state -> step -> state) (t : trace step) - (IH: forall (s0 : state) (i : int), (i < trace_length t)%int = true -> P s0 -> P (transition s0 (trace_get t i))) : - forall s0 : state, P s0 -> P (trace_fold transition s0 t). - Admitted. - -End Trace. - - -Require Import PeanoNat. - -Definition nat_eqb := Nat.eqb. -Definition nat_eqb_eq := Nat.eqb_eq. -Definition nat_eqb_refl := Nat.eqb_refl. - - -(* - Local Variables: - coq-load-path: ((rec "../.." "SMTCoq")) - End: -*) diff --git a/src/versions/standard/Tactics_standard.v b/src/versions/standard/Tactics_standard.v deleted file mode 100644 index 14b984b..0000000 --- a/src/versions/standard/Tactics_standard.v +++ /dev/null @@ -1,162 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -Require Import PropToBool. -Require Import Int63 List PArray Bool ZArith. -Require Import SMTCoq.State SMTCoq.SMT_terms SMTCoq.Trace SMT_classes_instances QInst. - -Declare ML Module "smtcoq_plugin". - - -(** Collect all the hypotheses from the context *) - -Ltac get_hyps_acc acc := - match goal with - | [ H : ?P |- _ ] => - let T := type of P in - lazymatch T with - | Prop => - lazymatch P with - | id _ => fail - | _ => - let _ := match goal with _ => change P with (id P) in H end in - match acc with - | Some ?t => get_hyps_acc (Some (H, t)) - | None => get_hyps_acc (Some H) - end - end - | _ => fail - end - | _ => acc - end. - -Ltac eliminate_id := - repeat match goal with - | [ H : ?P |- _ ] => - lazymatch P with - | id ?Q => change P with Q in H - | _ => fail - end - end. - -Ltac get_hyps := - let Hs := get_hyps_acc (@None nat) in - let _ := match goal with _ => eliminate_id end in - Hs. - - -(* Section Test. *) -(* Variable A : Type. *) -(* Hypothesis H1 : forall a:A, a = a. *) -(* Variable n : Z. *) -(* Hypothesis H2 : n = 17%Z. *) - -(* Goal True. *) -(* Proof. *) -(* let Hs := get_hyps in idtac Hs. *) -(* Abort. *) -(* End Test. *) - - -(** Tactics in bool *) - -Tactic Notation "verit_bool_base_auto" constr(h) := verit_bool_base h; try (exact _). -Tactic Notation "verit_bool_no_check_base_auto" constr(h) := verit_bool_no_check_base h; try (exact _). - -Tactic Notation "verit_bool" constr(h) := - let Hs := get_hyps in - match Hs with - | Some ?Hs => verit_bool_base_auto (Some (h, Hs)) - | None => verit_bool_base_auto (Some h) - end; - vauto. -Tactic Notation "verit_bool" := - let Hs := get_hyps in - verit_bool_base_auto Hs; vauto. - -Tactic Notation "verit_bool_no_check" constr(h) := - let Hs := get_hyps in - match Hs with - | Some ?Hs => verit_bool_no_check_base_auto (Some (h, Hs)) - | None => verit_bool_no_check_base_auto (Some h) - end; - vauto. -Tactic Notation "verit_bool_no_check" := - let Hs := get_hyps in - fun Hs => verit_bool_no_check_base_auto Hs; vauto. - - -(** Tactics in Prop **) - -Ltac zchaff := prop2bool; zchaff_bool; bool2prop. -Ltac zchaff_no_check := prop2bool; zchaff_bool_no_check; bool2prop. - -Tactic Notation "verit" constr(h) := - prop2bool; - [ .. | prop2bool_hyps h; - [ .. | let Hs := get_hyps in - match Hs with - | Some ?Hs => - prop2bool_hyps Hs; - [ .. | verit_bool_base_auto (Some (h, Hs)) ] - | None => verit_bool_base_auto (Some h) - end; vauto - ] - ]. -Tactic Notation "verit" := - prop2bool; - [ .. | let Hs := get_hyps in - match Hs with - | Some ?Hs => - prop2bool_hyps Hs; - [ .. | verit_bool_base_auto (Some Hs) ] - | None => verit_bool_base_auto (@None nat) - end; vauto - ]. -Tactic Notation "verit_no_check" constr(h) := - prop2bool; - [ .. | prop2bool_hyps h; - [ .. | let Hs := get_hyps in - match Hs with - | Some ?Hs => - prop2bool_hyps Hs; - [ .. | verit_bool_no_check_base_auto (Some (h, Hs)) ] - | None => verit_bool_no_check_base_auto (Some h) - end; vauto - ] - ]. -Tactic Notation "verit_no_check" := - prop2bool; - [ .. | let Hs := get_hyps in - match Hs with - | Some ?Hs => - prop2bool_hyps Hs; - [ .. | verit_bool_no_check_base_auto (Some Hs) ] - | None => verit_bool_no_check_base_auto (@None nat) - end; vauto - ]. - -Ltac cvc4 := prop2bool; [ .. | cvc4_bool; bool2prop ]. -Ltac cvc4_no_check := prop2bool; [ .. | cvc4_bool_no_check; bool2prop ]. - -Tactic Notation "smt" constr(h) := (prop2bool; [ .. | try verit h; cvc4_bool; try verit h; bool2prop ]). -Tactic Notation "smt" := (prop2bool; [ .. | try verit ; cvc4_bool; try verit ; bool2prop ]). -Tactic Notation "smt_no_check" constr(h) := (prop2bool; [ .. | try verit_no_check h; cvc4_bool_no_check; try verit_no_check h; bool2prop]). -Tactic Notation "smt_no_check" := (prop2bool; [ .. | try verit_no_check ; cvc4_bool_no_check; try verit_no_check ; bool2prop]). - - - -(* - Local Variables: - coq-load-path: ((rec "." "SMTCoq")) - End: -*) diff --git a/src/versions/standard/_CoqProject b/src/versions/standard/_CoqProject deleted file mode 100644 index 86dd443..0000000 --- a/src/versions/standard/_CoqProject +++ /dev/null @@ -1,159 +0,0 @@ -######################################################################## -## This file is intended to developers: please do not use it ## -## directly, rather use the "configure.sh" script. ## -######################################################################## - - - - -######################################################################## -## To generate the Makefile: ## -## coq_makefile -f Make -o Makefile ## -######################################################################## - - --R . SMTCoq - --I . --I bva --I classes --I array --I cnf --I euf --I lfsc --I lia --I smtlib2 --I trace --I verit --I zchaff --I versions/standard --I versions/standard/Int63 --I versions/standard/Array --I ../3rdparty/alt-ergo - -versions/standard/Int63/Int63.v -versions/standard/Int63/Int63Native.v -versions/standard/Int63/Int63Op.v -versions/standard/Int63/Int63Axioms.v -versions/standard/Int63/Int63Properties.v -versions/standard/Array/PArray.v - -versions/standard/mutils_full.ml -versions/standard/mutils_full.mli -versions/standard/coq_micromega_full.ml -versions/standard/Structures.v -versions/standard/structures.ml -versions/standard/structures.mli - -bva/BVList.v -bva/Bva_checker.v - -classes/SMT_classes.v -classes/SMT_classes_instances.v - -array/FArray.v -array/Array_checker.v - -trace/coqTerms.ml -trace/coqTerms.mli -trace/smtBtype.ml -trace/smtBtype.mli -trace/satAtom.ml -trace/satAtom.mli -trace/smtAtom.ml -trace/smtAtom.mli -trace/smtCertif.ml -trace/smtCertif.mli -trace/smtCnf.ml -trace/smtCnf.mli -trace/smtCommands.ml -trace/smtCommands.mli -trace/smtForm.ml -trace/smtForm.mli -trace/smtMaps.ml -trace/smtMaps.mli -trace/smtMisc.ml -trace/smtMisc.mli -trace/smtTrace.ml -trace/smtTrace.mli - -../3rdparty/alt-ergo/smtlib2_parse.ml -../3rdparty/alt-ergo/smtlib2_parse.mli -../3rdparty/alt-ergo/smtlib2_lex.ml -../3rdparty/alt-ergo/smtlib2_lex.mli -../3rdparty/alt-ergo/smtlib2_ast.ml -../3rdparty/alt-ergo/smtlib2_ast.mli -../3rdparty/alt-ergo/smtlib2_util.ml -../3rdparty/alt-ergo/smtlib2_util.mli - -smtlib2/smtlib2_genConstr.ml -smtlib2/smtlib2_genConstr.mli -smtlib2/sExpr.ml -smtlib2/sExpr.mli -smtlib2/smtlib2_solver.ml -smtlib2/smtlib2_solver.mli -smtlib2/sExprParser.ml -smtlib2/sExprParser.mli -smtlib2/sExprLexer.ml - -verit/veritParser.ml -verit/veritParser.mli -verit/veritLexer.ml -verit/veritLexer.mli -verit/verit.ml -verit/verit.mli -verit/veritSyntax.ml -verit/veritSyntax.mli - -lfsc/shashcons.mli -lfsc/shashcons.ml -lfsc/hstring.mli -lfsc/hstring.ml -lfsc/lfscParser.ml -lfsc/lfscParser.mli -lfsc/type.ml -lfsc/ast.ml -lfsc/ast.mli -lfsc/translator_sig.mli -lfsc/builtin.ml -lfsc/tosmtcoq.ml -lfsc/tosmtcoq.mli -lfsc/converter.ml -lfsc/lfsc.ml -lfsc/lfscLexer.ml - -zchaff/cnfParser.ml -zchaff/cnfParser.mli -zchaff/satParser.ml -zchaff/satParser.mli -zchaff/zchaff.ml -zchaff/zchaff.mli -zchaff/zchaffParser.ml -zchaff/zchaffParser.mli - -cnf/Cnf.v - -euf/Euf.v - -lia/lia.ml -lia/lia.mli -lia/Lia.v - -spl/Assumptions.v -spl/Syntactic.v -spl/Arithmetic.v -spl/Operators.v - -Conversion_tactics.v -Misc.v -SMTCoq.v -ReflectFacts.v -PropToBool.v -QInst.v -Tactics.v -SMT_terms.v -State.v -Trace.v - -g_smtcoq.ml4 -smtcoq_plugin.mlpack diff --git a/src/versions/standard/coq_micromega_full.ml b/src/versions/standard/coq_micromega_full.ml deleted file mode 100644 index d957110..0000000 --- a/src/versions/standard/coq_micromega_full.ml +++ /dev/null @@ -1,2215 +0,0 @@ -(*** This file is taken from Coq-8.9.0 to expose more functions than - coq_micromega.mli does. - See https://github.com/coq/coq/issues/9749 . ***) - - -(************************************************************************) -(* * 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) *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* ** Toplevel definition of tactics ** *) -(* *) -(* - Modules ISet, M, Mc, Env, Cache, CacheZ *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-20011 *) -(* *) -(************************************************************************) - -open Pp -open Names -open Goptions -open Mutils_full -open Constr -open Tactypes - -module Micromega = Micromega_plugin.Micromega -module Certificate = Micromega_plugin.Certificate -module Sos_types = Micromega_plugin.Sos_types -module Mfourier = Micromega_plugin.Mfourier - -(** - * Debug flag - *) - -let debug = false - -(* Limit the proof search *) - -let max_depth = max_int - -(* Search limit for provers over Q R *) -let lra_proof_depth = ref max_depth - - -(* Search limit for provers over Z *) -let lia_enum = ref true -let lia_proof_depth = ref max_depth - -let get_lia_option () = - (!lia_enum,!lia_proof_depth) - -let get_lra_option () = - !lra_proof_depth - - - -let _ = - - let int_opt l vref = - { - optdepr = false; - optname = List.fold_right (^) l ""; - optkey = l ; - optread = (fun () -> Some !vref); - optwrite = (fun x -> vref := (match x with None -> max_depth | Some v -> v)) - } in - - let lia_enum_opt = - { - optdepr = false; - optname = "Lia Enum"; - optkey = ["Lia2";"Enum"]; - optread = (fun () -> !lia_enum); - optwrite = (fun x -> lia_enum := x) - } in - let _ = declare_int_option (int_opt ["Lra2"; "Depth"] lra_proof_depth) in - let _ = declare_int_option (int_opt ["Lia2"; "Depth"] lia_proof_depth) in - let _ = declare_bool_option lia_enum_opt in - () - -(** - * Initialize a tag type to the Tag module declaration (see Mutils). - *) - -type tag = Tag.t - -(** - * An atom is of the form: - * pExpr1 \{<,>,=,<>,<=,>=\} pExpr2 - * where pExpr1, pExpr2 are polynomial expressions (see Micromega). pExprs are - * parametrized by 'cst, which is used as the type of constants. - *) - -type 'cst atom = 'cst Micromega.formula - -(** - * Micromega's encoding of formulas. - * By order of appearance: boolean constants, variables, atoms, conjunctions, - * disjunctions, negation, implication. -*) - -type 'cst formula = - | TT - | FF - | X of EConstr.constr - | A of 'cst atom * tag * EConstr.constr - | C of 'cst formula * 'cst formula - | D of 'cst formula * 'cst formula - | N of 'cst formula - | I of 'cst formula * Names.Id.t option * 'cst formula - -(** - * Formula pretty-printer. - *) - -let rec pp_formula o f = - match f with - | TT -> output_string o "tt" - | FF -> output_string o "ff" - | X c -> output_string o "X " - | A(_,t,_) -> Printf.fprintf o "A(%a)" Tag.pp t - | C(f1,f2) -> Printf.fprintf o "C(%a,%a)" pp_formula f1 pp_formula f2 - | D(f1,f2) -> Printf.fprintf o "D(%a,%a)" pp_formula f1 pp_formula f2 - | I(f1,n,f2) -> Printf.fprintf o "I(%a%s,%a)" - pp_formula f1 - (match n with - | Some id -> Names.Id.to_string id - | None -> "") pp_formula f2 - | N(f) -> Printf.fprintf o "N(%a)" pp_formula f - - -let rec map_atoms fct f = - match f with - | TT -> TT - | FF -> FF - | X x -> X x - | A (at,tg,cstr) -> A(fct at,tg,cstr) - | C (f1,f2) -> C(map_atoms fct f1, map_atoms fct f2) - | D (f1,f2) -> D(map_atoms fct f1, map_atoms fct f2) - | N f -> N(map_atoms fct f) - | I(f1,o,f2) -> I(map_atoms fct f1, o , map_atoms fct f2) - -let rec map_prop fct f = - match f with - | TT -> TT - | FF -> FF - | X x -> X (fct x) - | A (at,tg,cstr) -> A(at,tg,cstr) - | C (f1,f2) -> C(map_prop fct f1, map_prop fct f2) - | D (f1,f2) -> D(map_prop fct f1, map_prop fct f2) - | N f -> N(map_prop fct f) - | I(f1,o,f2) -> I(map_prop fct f1, o , map_prop fct f2) - -(** - * Collect the identifiers of a (string of) implications. Implication labels - * are inherited from Coq/CoC's higher order dependent type constructor (Pi). - *) - -let rec ids_of_formula f = - match f with - | I(f1,Some id,f2) -> id::(ids_of_formula f2) - | _ -> [] - -(** - * A clause is a list of (tagged) nFormulas. - * nFormulas are normalized formulas, i.e., of the form: - * cPol \{=,<>,>,>=\} 0 - * with cPol compact polynomials (see the Pol inductive type in EnvRing.v). - *) - -type 'cst clause = ('cst Micromega.nFormula * tag) list - -(** - * A CNF is a list of clauses. - *) - -type 'cst cnf = ('cst clause) list - -(** - * True and False are empty cnfs and clauses. - *) - -let tt : 'cst cnf = [] - -let ff : 'cst cnf = [ [] ] - -(** - * A refinement of cnf with tags left out. This is an intermediary form - * between the cnf tagged list representation ('cst cnf) used to solve psatz, - * and the freeform formulas ('cst formula) that is retrieved from Coq. - *) - -module Mc = Micromega - -type 'cst mc_cnf = ('cst Mc.nFormula) list list - -(** - * From a freeform formula, build a cnf. - * The parametric functions negate and normalize are theory-dependent, and - * originate in micromega.ml (extracted, e.g. for rnegate, from RMicromega.v - * and RingMicromega.v). - *) - -type 'a tagged_option = T of tag list | S of 'a - -let cnf - (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) - (unsat : 'cst Mc.nFormula -> bool) (deduce : 'cst Mc.nFormula -> 'cst Mc.nFormula -> 'cst Mc.nFormula option) (f:'cst formula) = - - let negate a t = - List.map (fun cl -> List.map (fun x -> (x,t)) cl) (negate a) in - - let normalise a t = - List.map (fun cl -> List.map (fun x -> (x,t)) cl) (normalise a) in - - let and_cnf x y = x @ y in - -let rec add_term t0 = function - | [] -> - (match deduce (fst t0) (fst t0) with - | Some u -> if unsat u then T [snd t0] else S (t0::[]) - | None -> S (t0::[])) - | t'::cl0 -> - (match deduce (fst t0) (fst t') with - | Some u -> - if unsat u - then T [snd t0 ; snd t'] - else (match add_term t0 cl0 with - | S cl' -> S (t'::cl') - | T l -> T l) - | None -> - (match add_term t0 cl0 with - | S cl' -> S (t'::cl') - | T l -> T l)) in - - - let rec or_clause cl1 cl2 = - match cl1 with - | [] -> S cl2 - | t0::cl -> - (match add_term t0 cl2 with - | S cl' -> or_clause cl cl' - | T l -> T l) in - - - - let or_clause_cnf t f = - List.fold_right (fun e (acc,tg) -> - match or_clause t e with - | S cl -> (cl :: acc,tg) - | T l -> (acc,tg@l)) f ([],[]) in - - - let rec or_cnf f f' = - match f with - | [] -> tt,[] - | e :: rst -> - let (rst_f',t) = or_cnf rst f' in - let (e_f', t') = or_clause_cnf e f' in - (rst_f' @ e_f', t @ t') in - - - let rec xcnf (polarity : bool) f = - match f with - | TT -> if polarity then (tt,[]) else (ff,[]) - | FF -> if polarity then (ff,[]) else (tt,[]) - | X p -> if polarity then (ff,[]) else (ff,[]) - | A(x,t,_) -> ((if polarity then normalise x t else negate x t),[]) - | N(e) -> xcnf (not polarity) e - | C(e1,e2) -> - let e1,t1 = xcnf polarity e1 in - let e2,t2 = xcnf polarity e2 in - if polarity - then and_cnf e1 e2, t1 @ t2 - else let f',t' = or_cnf e1 e2 in - (f', t1 @ t2 @ t') - | D(e1,e2) -> - let e1,t1 = xcnf polarity e1 in - let e2,t2 = xcnf polarity e2 in - if polarity - then let f',t' = or_cnf e1 e2 in - (f', t1 @ t2 @ t') - else and_cnf e1 e2, t1 @ t2 - | I(e1,_,e2) -> - let e1 , t1 = (xcnf (not polarity) e1) in - let e2 , t2 = (xcnf polarity e2) in - if polarity - then let f',t' = or_cnf e1 e2 in - (f', t1 @ t2 @ t') - else and_cnf e1 e2, t1 @ t2 in - - xcnf true f - -(** - * MODULE: Ordered set of integers. - *) - -module ISet = Set.Make(Int) - -(** - * Given a set of integers s=\{i0,...,iN\} and a list m, return the list of - * elements of m that are at position i0,...,iN. - *) - -let selecti s m = - let rec xselecti i m = - match m with - | [] -> [] - | e::m -> if ISet.mem i s then e::(xselecti (i+1) m) else xselecti (i+1) m in - xselecti 0 m - -(** - * MODULE: Mapping of the Coq data-strustures into Caml and Caml extracted - * code. This includes initializing Caml variables based on Coq terms, parsing - * various Coq expressions into Caml, and dumping Caml expressions into Coq. - * - * Opened here and in csdpcert.ml. - *) - -module M = -struct - - (** - * Location of the Coq libraries. - *) - - let logic_dir = ["Coq";"Logic";"Decidable"] - - let mic_modules = - [ - ["Coq";"Lists";"List"]; - ["ZMicromega"]; - ["Tauto"]; - ["RingMicromega"]; - ["EnvRing"]; - ["Coq"; "micromega"; "ZMicromega"]; - ["Coq"; "micromega"; "RMicromega"]; - ["Coq" ; "micromega" ; "Tauto"]; - ["Coq" ; "micromega" ; "RingMicromega"]; - ["Coq" ; "micromega" ; "EnvRing"]; - ["Coq";"QArith"; "QArith_base"]; - ["Coq";"Reals" ; "Rdefinitions"]; - ["Coq";"Reals" ; "Rpow_def"]; - ["LRing_normalise"]] - - let coq_modules = - Coqlib.(init_modules @ - [logic_dir] @ arith_modules @ zarith_base_modules @ mic_modules) - - let bin_module = [["Coq";"Numbers";"BinNums"]] - - let r_modules = - [["Coq";"Reals" ; "Rdefinitions"]; - ["Coq";"Reals" ; "Rpow_def"] ; - ["Coq";"Reals" ; "Raxioms"] ; - ["Coq";"QArith"; "Qreals"] ; - ] - - let z_modules = [["Coq";"ZArith";"BinInt"]] - - (** - * Initialization : a large amount of Caml symbols are derived from - * ZMicromega.v - *) - - let gen_constant_in_modules s m n = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules s m n) - let init_constant = gen_constant_in_modules "ZMicromega" Coqlib.init_modules - let constant = gen_constant_in_modules "ZMicromega" coq_modules - let bin_constant = gen_constant_in_modules "ZMicromega" bin_module - let r_constant = gen_constant_in_modules "ZMicromega" r_modules - let z_constant = gen_constant_in_modules "ZMicromega" z_modules - let m_constant = gen_constant_in_modules "ZMicromega" mic_modules - - let coq_and = lazy (init_constant "and") - let coq_or = lazy (init_constant "or") - let coq_not = lazy (init_constant "not") - - let coq_iff = lazy (init_constant "iff") - let coq_True = lazy (init_constant "True") - let coq_False = lazy (init_constant "False") - - let coq_cons = lazy (constant "cons") - let coq_nil = lazy (constant "nil") - let coq_list = lazy (constant "list") - - let coq_O = lazy (init_constant "O") - let coq_S = lazy (init_constant "S") - - let coq_N0 = lazy (bin_constant "N0") - let coq_Npos = lazy (bin_constant "Npos") - - let coq_xH = lazy (bin_constant "xH") - let coq_xO = lazy (bin_constant "xO") - let coq_xI = lazy (bin_constant "xI") - - let coq_Z = lazy (bin_constant "Z") - let coq_ZERO = lazy (bin_constant "Z0") - let coq_POS = lazy (bin_constant "Zpos") - let coq_NEG = lazy (bin_constant "Zneg") - - let coq_Q = lazy (constant "Q") - let coq_R = lazy (constant "R") - - let coq_Qmake = lazy (constant "Qmake") - - let coq_Rcst = lazy (constant "Rcst") - - let coq_C0 = lazy (m_constant "C0") - let coq_C1 = lazy (m_constant "C1") - let coq_CQ = lazy (m_constant "CQ") - let coq_CZ = lazy (m_constant "CZ") - let coq_CPlus = lazy (m_constant "CPlus") - let coq_CMinus = lazy (m_constant "CMinus") - let coq_CMult = lazy (m_constant "CMult") - let coq_CInv = lazy (m_constant "CInv") - let coq_COpp = lazy (m_constant "COpp") - - - let coq_R0 = lazy (constant "R0") - let coq_R1 = lazy (constant "R1") - - let coq_proofTerm = lazy (constant "ZArithProof") - let coq_doneProof = lazy (constant "DoneProof") - let coq_ratProof = lazy (constant "RatProof") - let coq_cutProof = lazy (constant "CutProof") - let coq_enumProof = lazy (constant "EnumProof") - - let coq_Zgt = lazy (z_constant "Z.gt") - let coq_Zge = lazy (z_constant "Z.ge") - let coq_Zle = lazy (z_constant "Z.le") - let coq_Zlt = lazy (z_constant "Z.lt") - let coq_Eq = lazy (init_constant "eq") - - let coq_Zplus = lazy (z_constant "Z.add") - let coq_Zminus = lazy (z_constant "Z.sub") - let coq_Zopp = lazy (z_constant "Z.opp") - let coq_Zmult = lazy (z_constant "Z.mul") - let coq_Zpower = lazy (z_constant "Z.pow") - - let coq_Qle = lazy (constant "Qle") - let coq_Qlt = lazy (constant "Qlt") - let coq_Qeq = lazy (constant "Qeq") - - let coq_Qplus = lazy (constant "Qplus") - let coq_Qminus = lazy (constant "Qminus") - let coq_Qopp = lazy (constant "Qopp") - let coq_Qmult = lazy (constant "Qmult") - let coq_Qpower = lazy (constant "Qpower") - - let coq_Rgt = lazy (r_constant "Rgt") - let coq_Rge = lazy (r_constant "Rge") - let coq_Rle = lazy (r_constant "Rle") - let coq_Rlt = lazy (r_constant "Rlt") - - let coq_Rplus = lazy (r_constant "Rplus") - let coq_Rminus = lazy (r_constant "Rminus") - let coq_Ropp = lazy (r_constant "Ropp") - let coq_Rmult = lazy (r_constant "Rmult") - let coq_Rinv = lazy (r_constant "Rinv") - let coq_Rpower = lazy (r_constant "pow") - let coq_IZR = lazy (r_constant "IZR") - let coq_IQR = lazy (r_constant "Q2R") - - - let coq_PEX = lazy (constant "PEX" ) - let coq_PEc = lazy (constant"PEc") - let coq_PEadd = lazy (constant "PEadd") - let coq_PEopp = lazy (constant "PEopp") - let coq_PEmul = lazy (constant "PEmul") - let coq_PEsub = lazy (constant "PEsub") - let coq_PEpow = lazy (constant "PEpow") - - let coq_PX = lazy (constant "PX" ) - let coq_Pc = lazy (constant"Pc") - let coq_Pinj = lazy (constant "Pinj") - - let coq_OpEq = lazy (constant "OpEq") - let coq_OpNEq = lazy (constant "OpNEq") - let coq_OpLe = lazy (constant "OpLe") - let coq_OpLt = lazy (constant "OpLt") - let coq_OpGe = lazy (constant "OpGe") - let coq_OpGt = lazy (constant "OpGt") - - let coq_PsatzIn = lazy (constant "PsatzIn") - let coq_PsatzSquare = lazy (constant "PsatzSquare") - let coq_PsatzMulE = lazy (constant "PsatzMulE") - let coq_PsatzMultC = lazy (constant "PsatzMulC") - let coq_PsatzAdd = lazy (constant "PsatzAdd") - let coq_PsatzC = lazy (constant "PsatzC") - let coq_PsatzZ = lazy (constant "PsatzZ") - - let coq_TT = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "TT") - let coq_FF = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "FF") - let coq_And = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "Cj") - let coq_Or = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "D") - let coq_Neg = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "N") - let coq_Atom = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "A") - let coq_X = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "X") - let coq_Impl = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "I") - let coq_Formula = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "BFormula") - - (** - * Initialization : a few Caml symbols are derived from other libraries; - * QMicromega, ZArithRing, RingMicromega. - *) - - let coq_QWitness = lazy - (gen_constant_in_modules "QMicromega" - [["Coq"; "micromega"; "QMicromega"]] "QWitness") - - let coq_Build = lazy - (gen_constant_in_modules "RingMicromega" - [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] - "Build_Formula") - let coq_Cstr = lazy - (gen_constant_in_modules "RingMicromega" - [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] "Formula") - - (** - * Parsing and dumping : transformation functions between Caml and Coq - * data-structures. - * - * dump_* functions go from Micromega to Coq terms - * parse_* functions go from Coq to Micromega terms - * pp_* functions pretty-print Coq terms. - *) - - exception ParseError - - (* A simple but useful getter function *) - - let get_left_construct sigma term = - match EConstr.kind sigma term with - | Construct((_,i),_) -> (i,[| |]) - | App(l,rst) -> - (match EConstr.kind sigma l with - | Construct((_,i),_) -> (i,rst) - | _ -> raise ParseError - ) - | _ -> raise ParseError - - (* Access the Micromega module *) - - (* parse/dump/print from numbers up to expressions and formulas *) - - let rec parse_nat sigma term = - let (i,c) = get_left_construct sigma term in - match i with - | 1 -> Mc.O - | 2 -> Mc.S (parse_nat sigma (c.(0))) - | i -> raise ParseError - - let pp_nat o n = Printf.fprintf o "%i" (CoqToCaml.nat n) - - let rec dump_nat x = - match x with - | Mc.O -> Lazy.force coq_O - | Mc.S p -> EConstr.mkApp(Lazy.force coq_S,[| dump_nat p |]) - - let rec parse_positive sigma term = - let (i,c) = get_left_construct sigma term in - match i with - | 1 -> Mc.XI (parse_positive sigma c.(0)) - | 2 -> Mc.XO (parse_positive sigma c.(0)) - | 3 -> Mc.XH - | i -> raise ParseError - - let rec dump_positive x = - match x with - | Mc.XH -> Lazy.force coq_xH - | Mc.XO p -> EConstr.mkApp(Lazy.force coq_xO,[| dump_positive p |]) - | Mc.XI p -> EConstr.mkApp(Lazy.force coq_xI,[| dump_positive p |]) - - let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x) - - let dump_n x = - match x with - | Mc.N0 -> Lazy.force coq_N0 - | Mc.Npos p -> EConstr.mkApp(Lazy.force coq_Npos,[| dump_positive p|]) - - let parse_z sigma term = - let (i,c) = get_left_construct sigma term in - match i with - | 1 -> Mc.Z0 - | 2 -> Mc.Zpos (parse_positive sigma c.(0)) - | 3 -> Mc.Zneg (parse_positive sigma c.(0)) - | i -> raise ParseError - - let dump_z x = - match x with - | Mc.Z0 ->Lazy.force coq_ZERO - | Mc.Zpos p -> EConstr.mkApp(Lazy.force coq_POS,[| dump_positive p|]) - | Mc.Zneg p -> EConstr.mkApp(Lazy.force coq_NEG,[| dump_positive p|]) - - let pp_z o x = Printf.fprintf o "%s" (Big_int.string_of_big_int (CoqToCaml.z_big_int x)) - - let dump_q q = - EConstr.mkApp(Lazy.force coq_Qmake, - [| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden|]) - - let parse_q sigma term = - match EConstr.kind sigma term with - | App(c, args) -> if EConstr.eq_constr sigma c (Lazy.force coq_Qmake) then - {Mc.qnum = parse_z sigma args.(0) ; Mc.qden = parse_positive sigma args.(1) } - else raise ParseError - | _ -> raise ParseError - - - let rec pp_Rcst o cst = - match cst with - | Mc.C0 -> output_string o "C0" - | Mc.C1 -> output_string o "C1" - | Mc.CQ q -> output_string o "CQ _" - | Mc.CZ z -> pp_z o z - | Mc.CPlus(x,y) -> Printf.fprintf o "(%a + %a)" pp_Rcst x pp_Rcst y - | Mc.CMinus(x,y) -> Printf.fprintf o "(%a - %a)" pp_Rcst x pp_Rcst y - | Mc.CMult(x,y) -> Printf.fprintf o "(%a * %a)" pp_Rcst x pp_Rcst y - | Mc.CInv t -> Printf.fprintf o "(/ %a)" pp_Rcst t - | Mc.COpp t -> Printf.fprintf o "(- %a)" pp_Rcst t - - - let rec dump_Rcst cst = - match cst with - | Mc.C0 -> Lazy.force coq_C0 - | Mc.C1 -> Lazy.force coq_C1 - | Mc.CQ q -> EConstr.mkApp(Lazy.force coq_CQ, [| dump_q q |]) - | Mc.CZ z -> EConstr.mkApp(Lazy.force coq_CZ, [| dump_z z |]) - | Mc.CPlus(x,y) -> EConstr.mkApp(Lazy.force coq_CPlus, [| dump_Rcst x ; dump_Rcst y |]) - | Mc.CMinus(x,y) -> EConstr.mkApp(Lazy.force coq_CMinus, [| dump_Rcst x ; dump_Rcst y |]) - | Mc.CMult(x,y) -> EConstr.mkApp(Lazy.force coq_CMult, [| dump_Rcst x ; dump_Rcst y |]) - | Mc.CInv t -> EConstr.mkApp(Lazy.force coq_CInv, [| dump_Rcst t |]) - | Mc.COpp t -> EConstr.mkApp(Lazy.force coq_COpp, [| dump_Rcst t |]) - - let rec dump_list typ dump_elt l = - match l with - | [] -> EConstr.mkApp(Lazy.force coq_nil,[| typ |]) - | e :: l -> EConstr.mkApp(Lazy.force coq_cons, - [| typ; dump_elt e;dump_list typ dump_elt l|]) - - let pp_list op cl elt o l = - let rec _pp o l = - match l with - | [] -> () - | [e] -> Printf.fprintf o "%a" elt e - | e::l -> Printf.fprintf o "%a ,%a" elt e _pp l in - Printf.fprintf o "%s%a%s" op _pp l cl - - let dump_var = dump_positive - - let dump_expr typ dump_z e = - let rec dump_expr e = - match e with - | Mc.PEX n -> EConstr.mkApp(Lazy.force coq_PEX,[| typ; dump_var n |]) - | Mc.PEc z -> EConstr.mkApp(Lazy.force coq_PEc,[| typ ; dump_z z |]) - | Mc.PEadd(e1,e2) -> EConstr.mkApp(Lazy.force coq_PEadd, - [| typ; dump_expr e1;dump_expr e2|]) - | Mc.PEsub(e1,e2) -> EConstr.mkApp(Lazy.force coq_PEsub, - [| typ; dump_expr e1;dump_expr e2|]) - | Mc.PEopp e -> EConstr.mkApp(Lazy.force coq_PEopp, - [| typ; dump_expr e|]) - | Mc.PEmul(e1,e2) -> EConstr.mkApp(Lazy.force coq_PEmul, - [| typ; dump_expr e1;dump_expr e2|]) - | Mc.PEpow(e,n) -> EConstr.mkApp(Lazy.force coq_PEpow, - [| typ; dump_expr e; dump_n n|]) - in - dump_expr e - - let dump_pol typ dump_c e = - let rec dump_pol e = - match e with - | Mc.Pc n -> EConstr.mkApp(Lazy.force coq_Pc, [|typ ; dump_c n|]) - | Mc.Pinj(p,pol) -> EConstr.mkApp(Lazy.force coq_Pinj , [| typ ; dump_positive p ; dump_pol pol|]) - | Mc.PX(pol1,p,pol2) -> EConstr.mkApp(Lazy.force coq_PX, [| typ ; dump_pol pol1 ; dump_positive p ; dump_pol pol2|]) in - dump_pol e - - let pp_pol pp_c o e = - let rec pp_pol o e = - match e with - | Mc.Pc n -> Printf.fprintf o "Pc %a" pp_c n - | Mc.Pinj(p,pol) -> Printf.fprintf o "Pinj(%a,%a)" pp_positive p pp_pol pol - | Mc.PX(pol1,p,pol2) -> Printf.fprintf o "PX(%a,%a,%a)" pp_pol pol1 pp_positive p pp_pol pol2 in - pp_pol o e - - let pp_cnf pp_c o f = - let pp_clause o l = List.iter (fun ((p,_),t) -> Printf.fprintf o "(%a @%a)" (pp_pol pp_c) p Tag.pp t) l in - List.iter (fun l -> Printf.fprintf o "[%a]" pp_clause l) f - - let dump_psatz typ dump_z e = - let z = Lazy.force typ in - let rec dump_cone e = - match e with - | Mc.PsatzIn n -> EConstr.mkApp(Lazy.force coq_PsatzIn,[| z; dump_nat n |]) - | Mc.PsatzMulC(e,c) -> EConstr.mkApp(Lazy.force coq_PsatzMultC, - [| z; dump_pol z dump_z e ; dump_cone c |]) - | Mc.PsatzSquare e -> EConstr.mkApp(Lazy.force coq_PsatzSquare, - [| z;dump_pol z dump_z e|]) - | Mc.PsatzAdd(e1,e2) -> EConstr.mkApp(Lazy.force coq_PsatzAdd, - [| z; dump_cone e1; dump_cone e2|]) - | Mc.PsatzMulE(e1,e2) -> EConstr.mkApp(Lazy.force coq_PsatzMulE, - [| z; dump_cone e1; dump_cone e2|]) - | Mc.PsatzC p -> EConstr.mkApp(Lazy.force coq_PsatzC,[| z; dump_z p|]) - | Mc.PsatzZ -> EConstr.mkApp(Lazy.force coq_PsatzZ,[| z|]) in - dump_cone e - - let pp_psatz pp_z o e = - let rec pp_cone o e = - match e with - | Mc.PsatzIn n -> - Printf.fprintf o "(In %a)%%nat" pp_nat n - | Mc.PsatzMulC(e,c) -> - Printf.fprintf o "( %a [*] %a)" (pp_pol pp_z) e pp_cone c - | Mc.PsatzSquare e -> - Printf.fprintf o "(%a^2)" (pp_pol pp_z) e - | Mc.PsatzAdd(e1,e2) -> - Printf.fprintf o "(%a [+] %a)" pp_cone e1 pp_cone e2 - | Mc.PsatzMulE(e1,e2) -> - Printf.fprintf o "(%a [*] %a)" pp_cone e1 pp_cone e2 - | Mc.PsatzC p -> - Printf.fprintf o "(%a)%%positive" pp_z p - | Mc.PsatzZ -> - Printf.fprintf o "0" in - pp_cone o e - - let dump_op = function - | Mc.OpEq-> Lazy.force coq_OpEq - | Mc.OpNEq-> Lazy.force coq_OpNEq - | Mc.OpLe -> Lazy.force coq_OpLe - | Mc.OpGe -> Lazy.force coq_OpGe - | Mc.OpGt-> Lazy.force coq_OpGt - | Mc.OpLt-> Lazy.force coq_OpLt - - let dump_cstr typ dump_constant {Mc.flhs = e1 ; Mc.fop = o ; Mc.frhs = e2} = - EConstr.mkApp(Lazy.force coq_Build, - [| typ; dump_expr typ dump_constant e1 ; - dump_op o ; - dump_expr typ dump_constant e2|]) - - let assoc_const sigma x l = - try - snd (List.find (fun (x',y) -> EConstr.eq_constr sigma x (Lazy.force x')) l) - with - Not_found -> raise ParseError - - let zop_table = [ - coq_Zgt, Mc.OpGt ; - coq_Zge, Mc.OpGe ; - coq_Zlt, Mc.OpLt ; - coq_Zle, Mc.OpLe ] - - let rop_table = [ - coq_Rgt, Mc.OpGt ; - coq_Rge, Mc.OpGe ; - coq_Rlt, Mc.OpLt ; - coq_Rle, Mc.OpLe ] - - let qop_table = [ - coq_Qlt, Mc.OpLt ; - coq_Qle, Mc.OpLe ; - coq_Qeq, Mc.OpEq - ] - - type gl = { env : Environ.env; sigma : Evd.evar_map } - - let is_convertible gl t1 t2 = - Reductionops.is_conv gl.env gl.sigma t1 t2 - - let parse_zop gl (op,args) = - let sigma = gl.sigma in - match EConstr.kind sigma op with - | Const (x,_) -> (assoc_const sigma op zop_table, args.(0) , args.(1)) - | Ind((n,0),_) -> - if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_Z) - then (Mc.OpEq, args.(1), args.(2)) - else raise ParseError - | _ -> failwith "parse_zop" - - let parse_rop gl (op,args) = - let sigma = gl.sigma in - match EConstr.kind sigma op with - | Const (x,_) -> (assoc_const sigma op rop_table, args.(0) , args.(1)) - | Ind((n,0),_) -> - if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_R) - then (Mc.OpEq, args.(1), args.(2)) - else raise ParseError - | _ -> failwith "parse_zop" - - let parse_qop gl (op,args) = - (assoc_const gl.sigma op qop_table, args.(0) , args.(1)) - - type 'a op = - | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr) - | Opp - | Power - | Ukn of string - - let assoc_ops sigma x l = - try - snd (List.find (fun (x',y) -> EConstr.eq_constr sigma x (Lazy.force x')) l) - with - Not_found -> Ukn "Oups" - - (** - * MODULE: Env is for environment. - *) - - module Env = - struct - let compute_rank_add env sigma v = - let rec _add env n v = - match env with - | [] -> ([v],n) - | e::l -> - if EConstr.eq_constr sigma e v - then (env,n) - else - let (env,n) = _add l ( n+1) v in - (e::env,n) in - let (env, n) = _add env 1 v in - (env, CamlToCoq.positive n) - - let get_rank env sigma v = - - let rec _get_rank env n = - match env with - | [] -> raise (Invalid_argument "get_rank") - | e::l -> - if EConstr.eq_constr sigma e v - then n - else _get_rank l (n+1) in - _get_rank env 1 - - - let empty = [] - - let elements env = env - - end (* MODULE END: Env *) - - (** - * This is the big generic function for expression parsers. - *) - - let parse_expr sigma parse_constant parse_exp ops_spec env term = - if debug - then ( - let _, env = Pfedit.get_current_context () in - Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.pr_leconstr_env env sigma term)); - -(* - let constant_or_variable env term = - try - ( Mc.PEc (parse_constant term) , env) - with ParseError -> - let (env,n) = Env.compute_rank_add env term in - (Mc.PEX n , env) in -*) - let parse_variable env term = - let (env,n) = Env.compute_rank_add env sigma term in - (Mc.PEX n , env) in - - let rec parse_expr env term = - let combine env op (t1,t2) = - let (expr1,env) = parse_expr env t1 in - let (expr2,env) = parse_expr env t2 in - (op expr1 expr2,env) in - - try (Mc.PEc (parse_constant term) , env) - with ParseError -> - match EConstr.kind sigma term with - | App(t,args) -> - ( - match EConstr.kind sigma t with - | Const c -> - ( match assoc_ops sigma t ops_spec with - | Binop f -> combine env f (args.(0),args.(1)) - | Opp -> let (expr,env) = parse_expr env args.(0) in - (Mc.PEopp expr, env) - | Power -> - begin - try - let (expr,env) = parse_expr env args.(0) in - let power = (parse_exp expr args.(1)) in - (power , env) - with e when CErrors.noncritical e -> - (* if the exponent is a variable *) - let (env,n) = Env.compute_rank_add env sigma term in (Mc.PEX n, env) - end - | Ukn s -> - if debug - then (Printf.printf "unknown op: %s\n" s; flush stdout;); - let (env,n) = Env.compute_rank_add env sigma term in (Mc.PEX n, env) - ) - | _ -> parse_variable env term - ) - | _ -> parse_variable env term in - parse_expr env term - - let zop_spec = - [ - coq_Zplus , Binop (fun x y -> Mc.PEadd(x,y)) ; - coq_Zminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Zmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Zopp , Opp ; - coq_Zpower , Power] - - let qop_spec = - [ - coq_Qplus , Binop (fun x y -> Mc.PEadd(x,y)) ; - coq_Qminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Qmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Qopp , Opp ; - coq_Qpower , Power] - - let rop_spec = - [ - coq_Rplus , Binop (fun x y -> Mc.PEadd(x,y)) ; - coq_Rminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Rmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Ropp , Opp ; - coq_Rpower , Power] - - let zconstant = parse_z - let qconstant = parse_q - - - let rconst_assoc = - [ - coq_Rplus , (fun x y -> Mc.CPlus(x,y)) ; - coq_Rminus , (fun x y -> Mc.CMinus(x,y)) ; - coq_Rmult , (fun x y -> Mc.CMult(x,y)) ; - (* coq_Rdiv , (fun x y -> Mc.CMult(x,Mc.CInv y)) ;*) - ] - - let rec rconstant sigma term = - match EConstr.kind sigma term with - | Const x -> - if EConstr.eq_constr sigma term (Lazy.force coq_R0) - then Mc.C0 - else if EConstr.eq_constr sigma term (Lazy.force coq_R1) - then Mc.C1 - else raise ParseError - | App(op,args) -> - begin - try - (* the evaluation order is important in the following *) - let f = assoc_const sigma op rconst_assoc in - let a = rconstant sigma args.(0) in - let b = rconstant sigma args.(1) in - f a b - with - ParseError -> - match op with - | op when EConstr.eq_constr sigma op (Lazy.force coq_Rinv) -> - let arg = rconstant sigma args.(0) in - if Mc.qeq_bool (Mc.q_of_Rcst arg) {Mc.qnum = Mc.Z0 ; Mc.qden = Mc.XH} - then raise ParseError (* This is a division by zero -- no semantics *) - else Mc.CInv(arg) - | op when EConstr.eq_constr sigma op (Lazy.force coq_IQR) -> Mc.CQ (parse_q sigma args.(0)) - | op when EConstr.eq_constr sigma op (Lazy.force coq_IZR) -> Mc.CZ (parse_z sigma args.(0)) - | _ -> raise ParseError - end - - | _ -> raise ParseError - - - let rconstant sigma term = - let _, env = Pfedit.get_current_context () in - if debug - then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.pr_leconstr_env env sigma term ++ fnl ()); - let res = rconstant sigma term in - if debug then - (Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ; - res - - - let parse_zexpr sigma = parse_expr sigma - (zconstant sigma) - (fun expr x -> - let exp = (parse_z sigma x) in - match exp with - | Mc.Zneg _ -> Mc.PEc Mc.Z0 - | _ -> Mc.PEpow(expr, Mc.Z.to_N exp)) - zop_spec - - let parse_qexpr sigma = parse_expr sigma - (qconstant sigma) - (fun expr x -> - let exp = parse_z sigma x in - match exp with - | Mc.Zneg _ -> - begin - match expr with - | Mc.PEc q -> Mc.PEc (Mc.qpower q exp) - | _ -> print_string "parse_qexpr parse error" ; flush stdout ; raise ParseError - end - | _ -> let exp = Mc.Z.to_N exp in - Mc.PEpow(expr,exp)) - qop_spec - - let parse_rexpr sigma = parse_expr sigma - (rconstant sigma) - (fun expr x -> - let exp = Mc.N.of_nat (parse_nat sigma x) in - Mc.PEpow(expr,exp)) - rop_spec - - let parse_arith parse_op parse_expr env cstr gl = - let sigma = gl.sigma in - if debug - then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.pr_leconstr_env gl.env sigma cstr ++ fnl ()); - match EConstr.kind sigma cstr with - | App(op,args) -> - let (op,lhs,rhs) = parse_op gl (op,args) in - let (e1,env) = parse_expr sigma env lhs in - let (e2,env) = parse_expr sigma env rhs in - ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env) - | _ -> failwith "error : parse_arith(2)" - - let parse_zarith = parse_arith parse_zop parse_zexpr - - let parse_qarith = parse_arith parse_qop parse_qexpr - - let parse_rarith = parse_arith parse_rop parse_rexpr - - (* generic parsing of arithmetic expressions *) - - let mkC f1 f2 = C(f1,f2) - let mkD f1 f2 = D(f1,f2) - let mkIff f1 f2 = C(I(f1,None,f2),I(f2,None,f1)) - let mkI f1 f2 = I(f1,None,f2) - - let mkformula_binary g term f1 f2 = - match f1 , f2 with - | X _ , X _ -> X(term) - | _ -> g f1 f2 - - (** - * This is the big generic function for formula parsers. - *) - - let parse_formula gl parse_atom env tg term = - let sigma = gl.sigma in - - let parse_atom env tg t = - try - let (at,env) = parse_atom env t gl in - (A(at,tg,t), env,Tag.next tg) - with e when CErrors.noncritical e -> (X(t),env,tg) in - - let is_prop term = - let sort = Retyping.get_sort_of gl.env gl.sigma term in - Sorts.is_prop sort in - - let rec xparse_formula env tg term = - match EConstr.kind sigma term with - | App(l,rst) -> - (match rst with - | [|a;b|] when EConstr.eq_constr sigma l (Lazy.force coq_and) -> - let f,env,tg = xparse_formula env tg a in - let g,env, tg = xparse_formula env tg b in - mkformula_binary mkC term f g,env,tg - | [|a;b|] when EConstr.eq_constr sigma l (Lazy.force coq_or) -> - let f,env,tg = xparse_formula env tg a in - let g,env,tg = xparse_formula env tg b in - mkformula_binary mkD term f g,env,tg - | [|a|] when EConstr.eq_constr sigma l (Lazy.force coq_not) -> - let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg) - | [|a;b|] when EConstr.eq_constr sigma l (Lazy.force coq_iff) -> - let f,env,tg = xparse_formula env tg a in - let g,env,tg = xparse_formula env tg b in - mkformula_binary mkIff term f g,env,tg - | _ -> parse_atom env tg term) - | Prod(typ,a,b) when EConstr.Vars.noccurn sigma 1 b -> - let f,env,tg = xparse_formula env tg a in - let g,env,tg = xparse_formula env tg b in - mkformula_binary mkI term f g,env,tg - | _ when EConstr.eq_constr sigma term (Lazy.force coq_True) -> (TT,env,tg) - | _ when EConstr.eq_constr sigma term (Lazy.force coq_False) -> (FF,env,tg) - | _ when is_prop term -> X(term),env,tg - | _ -> raise ParseError - in - xparse_formula env tg ((*Reductionops.whd_zeta*) term) - - let dump_formula typ dump_atom f = - let rec xdump f = - match f with - | TT -> EConstr.mkApp(Lazy.force coq_TT,[|typ|]) - | FF -> EConstr.mkApp(Lazy.force coq_FF,[|typ|]) - | C(x,y) -> EConstr.mkApp(Lazy.force coq_And,[|typ ; xdump x ; xdump y|]) - | D(x,y) -> EConstr.mkApp(Lazy.force coq_Or,[|typ ; xdump x ; xdump y|]) - | I(x,_,y) -> EConstr.mkApp(Lazy.force coq_Impl,[|typ ; xdump x ; xdump y|]) - | N(x) -> EConstr.mkApp(Lazy.force coq_Neg,[|typ ; xdump x|]) - | A(x,_,_) -> EConstr.mkApp(Lazy.force coq_Atom,[|typ ; dump_atom x|]) - | X(t) -> EConstr.mkApp(Lazy.force coq_X,[|typ ; t|]) in - xdump f - - - let prop_env_of_formula sigma form = - let rec doit env = function - | TT | FF | A(_,_,_) -> env - | X t -> fst (Env.compute_rank_add env sigma t) - | C(f1,f2) | D(f1,f2) | I(f1,_,f2) -> - doit (doit env f1) f2 - | N f -> doit env f in - - doit [] form - - let var_env_of_formula form = - - let rec vars_of_expr = function - | Mc.PEX n -> ISet.singleton (CoqToCaml.positive n) - | Mc.PEc z -> ISet.empty - | Mc.PEadd(e1,e2) | Mc.PEmul(e1,e2) | Mc.PEsub(e1,e2) -> - ISet.union (vars_of_expr e1) (vars_of_expr e2) - | Mc.PEopp e | Mc.PEpow(e,_)-> vars_of_expr e - in - - let vars_of_atom {Mc.flhs ; Mc.fop; Mc.frhs} = - ISet.union (vars_of_expr flhs) (vars_of_expr frhs) in - - let rec doit = function - | TT | FF | X _ -> ISet.empty - | A (a,t,c) -> vars_of_atom a - | C(f1,f2) | D(f1,f2) |I (f1,_,f2) -> ISet.union (doit f1) (doit f2) - | N f -> doit f in - - doit form - - - - - type 'cst dump_expr = (* 'cst is the type of the syntactic constants *) - { - interp_typ : EConstr.constr; - dump_cst : 'cst -> EConstr.constr; - dump_add : EConstr.constr; - dump_sub : EConstr.constr; - dump_opp : EConstr.constr; - dump_mul : EConstr.constr; - dump_pow : EConstr.constr; - dump_pow_arg : Mc.n -> EConstr.constr; - dump_op : (Mc.op2 * EConstr.constr) list - } - -let dump_zexpr = lazy - { - interp_typ = Lazy.force coq_Z; - dump_cst = dump_z; - dump_add = Lazy.force coq_Zplus; - dump_sub = Lazy.force coq_Zminus; - dump_opp = Lazy.force coq_Zopp; - dump_mul = Lazy.force coq_Zmult; - dump_pow = Lazy.force coq_Zpower; - dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n))); - dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) zop_table - } - -let dump_qexpr = lazy - { - interp_typ = Lazy.force coq_Q; - dump_cst = dump_q; - dump_add = Lazy.force coq_Qplus; - dump_sub = Lazy.force coq_Qminus; - dump_opp = Lazy.force coq_Qopp; - dump_mul = Lazy.force coq_Qmult; - dump_pow = Lazy.force coq_Qpower; - dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n))); - dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) qop_table - } - -let rec dump_Rcst_as_R cst = - match cst with - | Mc.C0 -> Lazy.force coq_R0 - | Mc.C1 -> Lazy.force coq_R1 - | Mc.CQ q -> EConstr.mkApp(Lazy.force coq_IQR, [| dump_q q |]) - | Mc.CZ z -> EConstr.mkApp(Lazy.force coq_IZR, [| dump_z z |]) - | Mc.CPlus(x,y) -> EConstr.mkApp(Lazy.force coq_Rplus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) - | Mc.CMinus(x,y) -> EConstr.mkApp(Lazy.force coq_Rminus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) - | Mc.CMult(x,y) -> EConstr.mkApp(Lazy.force coq_Rmult, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) - | Mc.CInv t -> EConstr.mkApp(Lazy.force coq_Rinv, [| dump_Rcst_as_R t |]) - | Mc.COpp t -> EConstr.mkApp(Lazy.force coq_Ropp, [| dump_Rcst_as_R t |]) - - -let dump_rexpr = lazy - { - interp_typ = Lazy.force coq_R; - dump_cst = dump_Rcst_as_R; - dump_add = Lazy.force coq_Rplus; - dump_sub = Lazy.force coq_Rminus; - dump_opp = Lazy.force coq_Ropp; - dump_mul = Lazy.force coq_Rmult; - dump_pow = Lazy.force coq_Rpower; - dump_pow_arg = (fun n -> dump_nat (CamlToCoq.nat (CoqToCaml.n n))); - dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) rop_table - } - - - - -(** [make_goal_of_formula depxr vars props form] where - - vars is an environment for the arithmetic variables occuring in form - - props is an environment for the propositions occuring in form - @return a goal where all the variables and propositions of the formula are quantified - -*) - -let prodn n env b = - let rec prodrec = function - | (0, env, b) -> b - | (n, ((v,t)::l), b) -> prodrec (n-1, l, EConstr.mkProd (v,t,b)) - | _ -> assert false - in - prodrec (n,env,b) - -let make_goal_of_formula sigma dexpr form = - - let vars_idx = - List.mapi (fun i v -> (v, i+1)) (ISet.elements (var_env_of_formula form)) in - - (* List.iter (fun (v,i) -> Printf.fprintf stdout "var %i has index %i\n" v i) vars_idx ;*) - - let props = prop_env_of_formula sigma form in - - let vars_n = List.map (fun (_,i) -> (Names.Id.of_string (Printf.sprintf "__x%i" i)) , dexpr.interp_typ) vars_idx in - let props_n = List.mapi (fun i _ -> (Names.Id.of_string (Printf.sprintf "__p%i" (i+1))) , EConstr.mkProp) props in - - let var_name_pos = List.map2 (fun (idx,_) (id,_) -> id,idx) vars_idx vars_n in - - let dump_expr i e = - let rec dump_expr = function - | Mc.PEX n -> EConstr.mkRel (i+(List.assoc (CoqToCaml.positive n) vars_idx)) - | Mc.PEc z -> dexpr.dump_cst z - | Mc.PEadd(e1,e2) -> EConstr.mkApp(dexpr.dump_add, - [| dump_expr e1;dump_expr e2|]) - | Mc.PEsub(e1,e2) -> EConstr.mkApp(dexpr.dump_sub, - [| dump_expr e1;dump_expr e2|]) - | Mc.PEopp e -> EConstr.mkApp(dexpr.dump_opp, - [| dump_expr e|]) - | Mc.PEmul(e1,e2) -> EConstr.mkApp(dexpr.dump_mul, - [| dump_expr e1;dump_expr e2|]) - | Mc.PEpow(e,n) -> EConstr.mkApp(dexpr.dump_pow, - [| dump_expr e; dexpr.dump_pow_arg n|]) - in dump_expr e in - - let mkop op e1 e2 = - try - EConstr.mkApp(List.assoc op dexpr.dump_op, [| e1; e2|]) - with Not_found -> - EConstr.mkApp(Lazy.force coq_Eq,[|dexpr.interp_typ ; e1 ;e2|]) in - - let dump_cstr i { Mc.flhs ; Mc.fop ; Mc.frhs } = - mkop fop (dump_expr i flhs) (dump_expr i frhs) in - - let rec xdump pi xi f = - match f with - | TT -> Lazy.force coq_True - | FF -> Lazy.force coq_False - | C(x,y) -> EConstr.mkApp(Lazy.force coq_and,[|xdump pi xi x ; xdump pi xi y|]) - | D(x,y) -> EConstr.mkApp(Lazy.force coq_or,[| xdump pi xi x ; xdump pi xi y|]) - | I(x,_,y) -> EConstr.mkArrow (xdump pi xi x) (xdump (pi+1) (xi+1) y) - | N(x) -> EConstr.mkArrow (xdump pi xi x) (Lazy.force coq_False) - | A(x,_,_) -> dump_cstr xi x - | X(t) -> let idx = Env.get_rank props sigma t in - EConstr.mkRel (pi+idx) in - - let nb_vars = List.length vars_n in - let nb_props = List.length props_n in - - (* Printf.fprintf stdout "NBProps : %i\n" nb_props ;*) - - let subst_prop p = - let idx = Env.get_rank props sigma p in - EConstr.mkVar (Names.Id.of_string (Printf.sprintf "__p%i" idx)) in - - let form' = map_prop subst_prop form in - - (prodn nb_props (List.map (fun (x,y) -> Name.Name x,y) props_n) - (prodn nb_vars (List.map (fun (x,y) -> Name.Name x,y) vars_n) - (xdump (List.length vars_n) 0 form)), - List.rev props_n, List.rev var_name_pos,form') - - (** - * Given a conclusion and a list of affectations, rebuild a term prefixed by - * the appropriate letins. - * TODO: reverse the list of bindings! - *) - - let set l concl = - let rec xset acc = function - | [] -> acc - | (e::l) -> - let (name,expr,typ) = e in - xset (EConstr.mkNamedLetIn - (Names.Id.of_string name) - expr typ acc) l in - xset concl l - -end (** - * MODULE END: M - *) - -open M - -let coq_Node = - lazy (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node") -let coq_Leaf = - lazy (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf") -let coq_Empty = - lazy (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty") - -let coq_VarMap = - lazy (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t") - - -let rec dump_varmap typ m = - match m with - | Mc.Empty -> EConstr.mkApp(Lazy.force coq_Empty,[| typ |]) - | Mc.Leaf v -> EConstr.mkApp(Lazy.force coq_Leaf,[| typ; v|]) - | Mc.Node(l,o,r) -> - EConstr.mkApp (Lazy.force coq_Node, [| typ; dump_varmap typ l; o ; dump_varmap typ r |]) - - -let vm_of_list env = - match env with - | [] -> Mc.Empty - | (d,_)::_ -> - List.fold_left (fun vm (c,i) -> - Mc.vm_add d (CamlToCoq.positive i) c vm) Mc.Empty env - -let rec dump_proof_term = function - | Micromega.DoneProof -> Lazy.force coq_doneProof - | Micromega.RatProof(cone,rst) -> - EConstr.mkApp(Lazy.force coq_ratProof, [| dump_psatz coq_Z dump_z cone; dump_proof_term rst|]) - | Micromega.CutProof(cone,prf) -> - EConstr.mkApp(Lazy.force coq_cutProof, - [| dump_psatz coq_Z dump_z cone ; - dump_proof_term prf|]) - | Micromega.EnumProof(c1,c2,prfs) -> - EConstr.mkApp (Lazy.force coq_enumProof, - [| dump_psatz coq_Z dump_z c1 ; dump_psatz coq_Z dump_z c2 ; - dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs |]) - - -let rec size_of_psatz = function - | Micromega.PsatzIn _ -> 1 - | Micromega.PsatzSquare _ -> 1 - | Micromega.PsatzMulC(_,p) -> 1 + (size_of_psatz p) - | Micromega.PsatzMulE(p1,p2) | Micromega.PsatzAdd(p1,p2) -> size_of_psatz p1 + size_of_psatz p2 - | Micromega.PsatzC _ -> 1 - | Micromega.PsatzZ -> 1 - -let rec size_of_pf = function - | Micromega.DoneProof -> 1 - | Micromega.RatProof(p,a) -> (size_of_pf a) + (size_of_psatz p) - | Micromega.CutProof(p,a) -> (size_of_pf a) + (size_of_psatz p) - | Micromega.EnumProof(p1,p2,l) -> (size_of_psatz p1) + (size_of_psatz p2) + (List.fold_left (fun acc p -> size_of_pf p + acc) 0 l) - -let dump_proof_term t = - if debug then Printf.printf "dump_proof_term %i\n" (size_of_pf t) ; - dump_proof_term t - - - -let pp_q o q = Printf.fprintf o "%a/%a" pp_z q.Micromega.qnum pp_positive q.Micromega.qden - - -let rec pp_proof_term o = function - | Micromega.DoneProof -> Printf.fprintf o "D" - | Micromega.RatProof(cone,rst) -> Printf.fprintf o "R[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst - | Micromega.CutProof(cone,rst) -> Printf.fprintf o "C[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst - | Micromega.EnumProof(c1,c2,rst) -> - Printf.fprintf o "EP[%a,%a,%a]" - (pp_psatz pp_z) c1 (pp_psatz pp_z) c2 - (pp_list "[" "]" pp_proof_term) rst - -let rec parse_hyps gl parse_arith env tg hyps = - match hyps with - | [] -> ([],env,tg) - | (i,t)::l -> - let (lhyps,env,tg) = parse_hyps gl parse_arith env tg l in - try - let (c,env,tg) = parse_formula gl parse_arith env tg t in - ((i,c)::lhyps, env,tg) - with e when CErrors.noncritical e -> (lhyps,env,tg) - (*(if debug then Printf.printf "parse_arith : %s\n" x);*) - - -(*exception ParseError*) - -let parse_goal gl parse_arith env hyps term = - (* try*) - let (f,env,tg) = parse_formula gl parse_arith env (Tag.from 0) term in - let (lhyps,env,tg) = parse_hyps gl parse_arith env tg hyps in - (lhyps,f,env) - (* with Failure x -> raise ParseError*) - -(** - * The datastructures that aggregate theory-dependent proof values. - *) -type ('synt_c, 'prf) domain_spec = { - typ : EConstr.constr; (* is the type of the interpretation domain - Z, Q, R*) - coeff : EConstr.constr ; (* is the type of the syntactic coeffs - Z , Q , Rcst *) - dump_coeff : 'synt_c -> EConstr.constr ; - proof_typ : EConstr.constr ; - dump_proof : 'prf -> EConstr.constr -} - -let zz_domain_spec = lazy { - typ = Lazy.force coq_Z; - coeff = Lazy.force coq_Z; - dump_coeff = dump_z ; - proof_typ = Lazy.force coq_proofTerm ; - dump_proof = dump_proof_term -} - -let qq_domain_spec = lazy { - typ = Lazy.force coq_Q; - coeff = Lazy.force coq_Q; - dump_coeff = dump_q ; - proof_typ = Lazy.force coq_QWitness ; - dump_proof = dump_psatz coq_Q dump_q -} - -(** Naive topological sort of constr according to the subterm-ordering *) - -(* An element is minimal x is minimal w.r.t y if - x <= y or (x and y are incomparable) *) - -(** - * Instanciate the current Coq goal with a Micromega formula, a varmap, and a - * witness. - *) - -let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic*) = - (* let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *) - let formula_typ = (EConstr.mkApp (Lazy.force coq_Cstr,[|spec.coeff|])) in - let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in - let vm = dump_varmap (spec.typ) (vm_of_list env) in - (* todo : directly generate the proof term - or generalize before conversion? *) - Proofview.Goal.nf_enter begin fun gl -> - Tacticals.New.tclTHENLIST - [ - Tactics.change_concl - (set - [ - ("__ff", ff, EConstr.mkApp(Lazy.force coq_Formula, [|formula_typ |])); - ("__varmap", vm, EConstr.mkApp(Lazy.force coq_VarMap, [|spec.typ|])); - ("__wit", cert, cert_typ) - ] - (Tacmach.New.pf_concl gl)) - ] - end - - -(** - * The datastructures that aggregate prover attributes. - *) - -type ('option,'a,'prf) prover = { - name : string ; (* name of the prover *) - get_option : unit ->'option ; (* find the options of the prover *) - prover : 'option * 'a list -> 'prf option ; (* the prover itself *) - hyps : 'prf -> ISet.t ; (* extract the indexes of the hypotheses really used in the proof *) - compact : 'prf -> (int -> int) -> 'prf ; (* remap the hyp indexes according to function *) - pp_prf : out_channel -> 'prf -> unit ;(* pretting printing of proof *) - pp_f : out_channel -> 'a -> unit (* pretty printing of the formulas (polynomials)*) -} - - - -(** - * Given a list of provers and a disjunction of atoms, find a proof of any of - * the atoms. Returns an (optional) pair of a proof and a prover - * datastructure. - *) - -let find_witness provers polys1 = - let provers = List.map (fun p -> - (fun l -> - match p.prover (p.get_option (),l) with - | None -> None - | Some prf -> Some(prf,p)) , p.name) provers in - try_any provers (List.map fst polys1) - -(** - * Given a list of provers and a CNF, find a proof for each of the clauses. - * Return the proofs as a list. - *) - -let witness_list prover l = - let rec xwitness_list l = - match l with - | [] -> Some [] - | e :: l -> - match find_witness prover e with - | None -> None - | Some w -> - (match xwitness_list l with - | None -> None - | Some l -> Some (w :: l) - ) in - xwitness_list l - -let witness_list_tags = witness_list - -(** - * Prune the proof object, according to the 'diff' between two cnf formulas. - *) - -let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = - - let compact_proof (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = - let new_cl = List.mapi (fun i (f,_) -> (f,i)) new_cl in - let remap i = - let formula = try fst (List.nth old_cl i) with Failure _ -> failwith "bad old index" in - List.assoc formula new_cl in -(* if debug then - begin - Printf.printf "\ncompact_proof : %a %a %a" - (pp_ml_list prover.pp_f) (List.map fst old_cl) - prover.pp_prf prf - (pp_ml_list prover.pp_f) (List.map fst new_cl) ; - flush stdout - end ; *) - let res = try prover.compact prf remap with x when CErrors.noncritical x -> - if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ; - (* This should not happen -- this is the recovery plan... *) - match prover.prover (prover.get_option () ,List.map fst new_cl) with - | None -> failwith "proof compaction error" - | Some p -> p - in - if debug then - begin - Printf.printf " -> %a\n" - prover.pp_prf res ; - flush stdout - end ; - res in - - let is_proof_compatible (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = - let hyps_idx = prover.hyps prf in - let hyps = selecti hyps_idx old_cl in - is_sublist Pervasives.(=) hyps new_cl in - - let cnf_res = List.combine cnf_ff res in (* we get pairs clause * proof *) - - List.map (fun x -> - let (o,p) = List.find (fun (l,p) -> is_proof_compatible l p x) cnf_res - in compact_proof o p x) cnf_ff' - - -(** - * "Hide out" tagged atoms of a formula by transforming them into generic - * variables. See the Tag module in mutils.ml for more. - *) - -let abstract_formula hyps f = - let rec xabs f = - match f with - | X c -> X c - | A(a,t,term) -> if TagSet.mem t hyps then A(a,t,term) else X(term) - | C(f1,f2) -> - (match xabs f1 , xabs f2 with - | X a1 , X a2 -> X (EConstr.mkApp(Lazy.force coq_and, [|a1;a2|])) - | f1 , f2 -> C(f1,f2) ) - | D(f1,f2) -> - (match xabs f1 , xabs f2 with - | X a1 , X a2 -> X (EConstr.mkApp(Lazy.force coq_or, [|a1;a2|])) - | f1 , f2 -> D(f1,f2) ) - | N(f) -> - (match xabs f with - | X a -> X (EConstr.mkApp(Lazy.force coq_not, [|a|])) - | f -> N f) - | I(f1,hyp,f2) -> - (match xabs f1 , hyp, xabs f2 with - | X a1 , Some _ , af2 -> af2 - | X a1 , None , X a2 -> X (EConstr.mkArrow a1 a2) - | af1 , _ , af2 -> I(af1,hyp,af2) - ) - | FF -> FF - | TT -> TT - in xabs f - - -(* [abstract_wrt_formula] is used in contexts whre f1 is already an abstraction of f2 *) -let rec abstract_wrt_formula f1 f2 = - match f1 , f2 with - | X c , _ -> X c - | A _ , A _ -> f2 - | C(a,b) , C(a',b') -> C(abstract_wrt_formula a a', abstract_wrt_formula b b') - | D(a,b) , D(a',b') -> D(abstract_wrt_formula a a', abstract_wrt_formula b b') - | I(a,_,b) , I(a',x,b') -> I(abstract_wrt_formula a a',x, abstract_wrt_formula b b') - | FF , FF -> FF - | TT , TT -> TT - | N x , N y -> N(abstract_wrt_formula x y) - | _ -> failwith "abstract_wrt_formula" - -(** - * This exception is raised by really_call_csdpcert if Coq's configure didn't - * find a CSDP executable. - *) - -exception CsdpNotFound - - -(** - * This is the core of Micromega: apply the prover, analyze the result and - * prune unused fomulas, and finally modify the proof state. - *) - -let formula_hyps_concl hyps concl = - List.fold_right - (fun (id,f) (cc,ids) -> - match f with - X _ -> (cc,ids) - | _ -> (I(f,Some id,cc), id::ids)) - hyps (concl,[]) - - -let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 gl = - - (* Express the goal as one big implication *) - let (ff,ids) = formula_hyps_concl polys1 polys2 in - - (* Convert the aplpication into a (mc_)cnf (a list of lists of formulas) *) - let cnf_ff,cnf_ff_tags = cnf negate normalise unsat deduce ff in - - if debug then - begin - Feedback.msg_notice (Pp.str "Formula....\n") ; - let formula_typ = (EConstr.mkApp(Lazy.force coq_Cstr, [|spec.coeff|])) in - let ff = dump_formula formula_typ - (dump_cstr spec.typ spec.dump_coeff) ff in - Feedback.msg_notice (Printer.pr_leconstr_env gl.env gl.sigma ff); - Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff - end; - - match witness_list_tags prover cnf_ff with - | None -> None - | Some res -> (*Printf.printf "\nList %i" (List.length `res); *) - let hyps = List.fold_left (fun s (cl,(prf,p)) -> - let tags = ISet.fold (fun i s -> let t = snd (List.nth cl i) in - if debug then (Printf.fprintf stdout "T : %i -> %a" i Tag.pp t) ; - (*try*) TagSet.add t s (* with Invalid_argument _ -> s*)) (p.hyps prf) TagSet.empty in - TagSet.union s tags) (List.fold_left (fun s i -> TagSet.add i s) TagSet.empty cnf_ff_tags) (List.combine cnf_ff res) in - - if debug then (Printf.printf "TForm : %a\n" pp_formula ff ; flush stdout; - Printf.printf "Hyps : %a\n" (fun o s -> TagSet.fold (fun i _ -> Printf.fprintf o "%a " Tag.pp i) s ()) hyps) ; - - let ff' = abstract_formula hyps ff in - let cnf_ff',_ = cnf negate normalise unsat deduce ff' in - - if debug then - begin - Feedback.msg_notice (Pp.str "\nAFormula\n") ; - let formula_typ = (EConstr.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in - let ff' = dump_formula formula_typ - (dump_cstr spec.typ spec.dump_coeff) ff' in - Feedback.msg_notice (Printer.pr_leconstr_env gl.env gl.sigma ff'); - Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff' - end; - - (* Even if it does not work, this does not mean it is not provable - -- the prover is REALLY incomplete *) - (* if debug then - begin - (* recompute the proofs *) - match witness_list_tags prover cnf_ff' with - | None -> failwith "abstraction is wrong" - | Some res -> () - end ; *) - let res' = compact_proofs cnf_ff res cnf_ff' in - - let (ff',res',ids) = (ff',res', ids_of_formula ff') in - - let res' = dump_list (spec.proof_typ) spec.dump_proof res' in - Some (ids,ff',res') - - -(** - * Parse the proof environment, and call micromega_tauto - *) - -let fresh_id avoid id gl = - Tactics.fresh_id_in_env avoid id (Proofview.Goal.env gl) - -let micromega_gen - parse_arith - (negate:'cst atom -> 'cst mc_cnf) - (normalise:'cst atom -> 'cst mc_cnf) - unsat deduce - spec dumpexpr prover tac = - Proofview.Goal.nf_enter begin fun gl -> - let sigma = Tacmach.New.project gl in - let concl = Tacmach.New.pf_concl gl in - let hyps = Tacmach.New.pf_hyps_types gl in - try - let gl0 = { env = Tacmach.New.pf_env gl; sigma } in - let (hyps,concl,env) = parse_goal gl0 parse_arith Env.empty hyps concl in - let env = Env.elements env in - let spec = Lazy.force spec in - let dumpexpr = Lazy.force dumpexpr in - - match micromega_tauto negate normalise unsat deduce spec prover env hyps concl gl0 with - | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") - | Some (ids,ff',res') -> - let (arith_goal,props,vars,ff_arith) = make_goal_of_formula sigma dumpexpr ff' in - let intro (id,_) = Tactics.introduction id in - - let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in - let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in - let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in - let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in - let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in - - let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; - micromega_order_change spec res' - (EConstr.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env' ff_arith ] in - - let goal_props = List.rev (prop_env_of_formula sigma ff') in - - let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in - - let arith_args = goal_props @ goal_vars in - - let kill_arith = - Tacticals.New.tclTHEN - (Tactics.keep []) - ((*Tactics.tclABSTRACT None*) - (Tacticals.New.tclTHEN tac_arith tac)) in - - Tacticals.New.tclTHENS - (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) - [ - kill_arith; - (Tacticals.New.tclTHENLIST - [(Tactics.generalize (List.map EConstr.mkVar ids)); - Tactics.exact_check (EConstr.applist (EConstr.mkVar goal_name, arith_args)) - ] ) - ] - with - | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") - | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") - | CsdpNotFound -> flush stdout ; - Tacticals.New.tclFAIL 0 (Pp.str - (" Skipping what remains of this tactic: the complexity of the goal requires " - ^ "the use of a specialized external tool called csdp. \n\n" - ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" - ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) - end - -let micromega_gen parse_arith - (negate:'cst atom -> 'cst mc_cnf) - (normalise:'cst atom -> 'cst mc_cnf) - unsat deduce - spec prover = - (micromega_gen parse_arith negate normalise unsat deduce spec prover) - - - -let micromega_order_changer cert env ff = - (*let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *) - let coeff = Lazy.force coq_Rcst in - let dump_coeff = dump_Rcst in - let typ = Lazy.force coq_R in - let cert_typ = (EConstr.mkApp(Lazy.force coq_list, [|Lazy.force coq_QWitness |])) in - - let formula_typ = (EConstr.mkApp (Lazy.force coq_Cstr,[| coeff|])) in - let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in - let vm = dump_varmap (typ) (vm_of_list env) in - Proofview.Goal.nf_enter begin fun gl -> - Tacticals.New.tclTHENLIST - [ - (Tactics.change_concl - (set - [ - ("__ff", ff, EConstr.mkApp(Lazy.force coq_Formula, [|formula_typ |])); - ("__varmap", vm, EConstr.mkApp - (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|typ|])); - ("__wit", cert, cert_typ) - ] - (Tacmach.New.pf_concl gl))); - (* Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids)*) - ] - end - -let micromega_genr prover tac = - let parse_arith = parse_rarith in - let negate = Mc.rnegate in - let normalise = Mc.rnormalise in - let unsat = Mc.runsat in - let deduce = Mc.rdeduce in - let spec = lazy { - typ = Lazy.force coq_R; - coeff = Lazy.force coq_Rcst; - dump_coeff = dump_q; - proof_typ = Lazy.force coq_QWitness ; - dump_proof = dump_psatz coq_Q dump_q - } in - Proofview.Goal.nf_enter begin fun gl -> - let sigma = Tacmach.New.project gl in - let concl = Tacmach.New.pf_concl gl in - let hyps = Tacmach.New.pf_hyps_types gl in - - try - let gl0 = { env = Tacmach.New.pf_env gl; sigma } in - let (hyps,concl,env) = parse_goal gl0 parse_arith Env.empty hyps concl in - let env = Env.elements env in - let spec = Lazy.force spec in - - let hyps' = List.map (fun (n,f) -> (n, map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in - let concl' = map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) concl in - - match micromega_tauto negate normalise unsat deduce spec prover env hyps' concl' gl0 with - | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") - | Some (ids,ff',res') -> - let (ff,ids) = formula_hyps_concl - (List.filter (fun (n,_) -> List.mem n ids) hyps) concl in - let ff' = abstract_wrt_formula ff' ff in - - let (arith_goal,props,vars,ff_arith) = make_goal_of_formula sigma (Lazy.force dump_rexpr) ff' in - let intro (id,_) = Tactics.introduction id in - - let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in - let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in - let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in - let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in - let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in - - let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; - micromega_order_changer res' env' ff_arith ] in - - let goal_props = List.rev (prop_env_of_formula sigma ff') in - - let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in - - let arith_args = goal_props @ goal_vars in - - let kill_arith = - Tacticals.New.tclTHEN - (Tactics.keep []) - ((*Tactics.tclABSTRACT None*) - (Tacticals.New.tclTHEN tac_arith tac)) in - - Tacticals.New.tclTHENS - (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) - [ - kill_arith; - (Tacticals.New.tclTHENLIST - [(Tactics.generalize (List.map EConstr.mkVar ids)); - Tactics.exact_check (EConstr.applist (EConstr.mkVar goal_name, arith_args)) - ] ) - ] - - with - | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") - | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") - | CsdpNotFound -> flush stdout ; - Tacticals.New.tclFAIL 0 (Pp.str - (" Skipping what remains of this tactic: the complexity of the goal requires " - ^ "the use of a specialized external tool called csdp. \n\n" - ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" - ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) - end - - - - -let micromega_genr prover = (micromega_genr prover) - - -let lift_ratproof prover l = - match prover l with - | None -> None - | Some c -> Some (Mc.RatProof( c,Mc.DoneProof)) - -type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list - -[@@@ocaml.warning "-37"] -type csdp_certificate = S of Sos_types.positivstellensatz option | F of string -(* Used to read the result of the execution of csdpcert *) - -type provername = string * int option - -(** - * The caching mechanism. - *) - -open Micromega_plugin.Persistent_cache - -module Cache = PHashtable(struct - type t = (provername * micromega_polys) - let equal = Pervasives.(=) - let hash = Hashtbl.hash -end) - -let csdp_cache = ".csdp.cache" - -(** - * Build the command to call csdpcert, and launch it. This in turn will call - * the sos driver to the csdp executable. - * Throw CsdpNotFound if Coq isn't aware of any csdp executable. - *) - -let require_csdp = - if System.is_in_system_path "csdp" - then lazy () - else lazy (raise CsdpNotFound) - -let really_call_csdpcert : provername -> micromega_polys -> Sos_types.positivstellensatz option = - fun provername poly -> - - Lazy.force require_csdp; - - let cmdname = - List.fold_left Filename.concat (Envars.coqlib ()) - ["plugins"; "micromega"; "csdpcert" ^ Coq_config.exec_extension] in - - match ((command cmdname [|cmdname|] (provername,poly)) : csdp_certificate) with - | F str -> failwith str - | S res -> res - -(** - * Check the cache before calling the prover. - *) - -let xcall_csdpcert = - Cache.memo csdp_cache (fun (prover,pb) -> really_call_csdpcert prover pb) - -(** - * Prover callback functions. - *) - -let call_csdpcert prover pb = xcall_csdpcert (prover,pb) - -let rec z_to_q_pol e = - match e with - | Mc.Pc z -> Mc.Pc {Mc.qnum = z ; Mc.qden = Mc.XH} - | Mc.Pinj(p,pol) -> Mc.Pinj(p,z_to_q_pol pol) - | Mc.PX(pol1,p,pol2) -> Mc.PX(z_to_q_pol pol1, p, z_to_q_pol pol2) - -let call_csdpcert_q provername poly = - match call_csdpcert provername poly with - | None -> None - | Some cert -> - let cert = Certificate.q_cert_of_pos cert in - if Mc.qWeakChecker poly cert - then Some cert - else ((print_string "buggy certificate") ;None) - -let call_csdpcert_z provername poly = - let l = List.map (fun (e,o) -> (z_to_q_pol e,o)) poly in - match call_csdpcert provername l with - | None -> None - | Some cert -> - let cert = Certificate.z_cert_of_pos cert in - if Mc.zWeakChecker poly cert - then Some cert - else ((print_string "buggy certificate" ; flush stdout) ;None) - -let xhyps_of_cone base acc prf = - let rec xtract e acc = - match e with - | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> acc - | Mc.PsatzIn n -> let n = (CoqToCaml.nat n) in - if n >= base - then ISet.add (n-base) acc - else acc - | Mc.PsatzMulC(_,c) -> xtract c acc - | Mc.PsatzAdd(e1,e2) | Mc.PsatzMulE(e1,e2) -> xtract e1 (xtract e2 acc) in - - xtract prf acc - -let hyps_of_cone prf = xhyps_of_cone 0 ISet.empty prf - -let compact_cone prf f = - let np n = CamlToCoq.nat (f (CoqToCaml.nat n)) in - - let rec xinterp prf = - match prf with - | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> prf - | Mc.PsatzIn n -> Mc.PsatzIn (np n) - | Mc.PsatzMulC(e,c) -> Mc.PsatzMulC(e,xinterp c) - | Mc.PsatzAdd(e1,e2) -> Mc.PsatzAdd(xinterp e1,xinterp e2) - | Mc.PsatzMulE(e1,e2) -> Mc.PsatzMulE(xinterp e1,xinterp e2) in - - xinterp prf - -let hyps_of_pt pt = - - let rec xhyps base pt acc = - match pt with - | Mc.DoneProof -> acc - | Mc.RatProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c) - | Mc.CutProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c) - | Mc.EnumProof(c1,c2,l) -> - let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in - List.fold_left (fun s x -> xhyps (base + 1) x s) s l in - - xhyps 0 pt ISet.empty - -let hyps_of_pt pt = - let res = hyps_of_pt pt in - if debug - then (Printf.fprintf stdout "\nhyps_of_pt : %a -> " pp_proof_term pt ; ISet.iter (fun i -> Printf.printf "%i " i) res); - res - -let compact_pt pt f = - let translate ofset x = - if x < ofset then x - else (f (x-ofset) + ofset) in - - let rec compact_pt ofset pt = - match pt with - | Mc.DoneProof -> Mc.DoneProof - | Mc.RatProof(c,pt) -> Mc.RatProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt ) - | Mc.CutProof(c,pt) -> Mc.CutProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt ) - | Mc.EnumProof(c1,c2,l) -> Mc.EnumProof(compact_cone c1 (translate (ofset)), compact_cone c2 (translate (ofset)), - Mc.map (fun x -> compact_pt (ofset+1) x) l) in - compact_pt 0 pt - -(** - * Definition of provers. - * Instantiates the type ('a,'prf) prover defined above. - *) - -let lift_pexpr_prover p l = p (List.map (fun (e,o) -> Mc.denorm e , o) l) - -module CacheZ = PHashtable(struct - type prover_option = bool * int - - type t = prover_option * ((Mc.z Mc.pol * Mc.op1) list) - let equal = (=) - let hash = Hashtbl.hash -end) - -module CacheQ = PHashtable(struct - type t = int * ((Mc.q Mc.pol * Mc.op1) list) - let equal = (=) - let hash = Hashtbl.hash -end) - -let memo_zlinear_prover = CacheZ.memo ".lia.cache" (fun ((ce,b),s) -> lift_pexpr_prover (Certificate.lia ce b) s) -let memo_nlia = CacheZ.memo ".nia.cache" (fun ((ce,b),s) -> lift_pexpr_prover (Certificate.nlia ce b) s) -let memo_nra = CacheQ.memo ".nra.cache" (fun (o,s) -> lift_pexpr_prover (Certificate.nlinear_prover o) s) - - - -let linear_prover_Q = { - name = "linear prover"; - get_option = get_lra_option ; - prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o Certificate.q_spec) l) ; - hyps = hyps_of_cone ; - compact = compact_cone ; - pp_prf = pp_psatz pp_q ; - pp_f = fun o x -> pp_pol pp_q o (fst x) -} - - -let linear_prover_R = { - name = "linear prover"; - get_option = get_lra_option ; - prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o Certificate.q_spec) l) ; - hyps = hyps_of_cone ; - compact = compact_cone ; - pp_prf = pp_psatz pp_q ; - pp_f = fun o x -> pp_pol pp_q o (fst x) -} - -let nlinear_prover_R = { - name = "nra"; - get_option = get_lra_option; - prover = memo_nra ; - hyps = hyps_of_cone ; - compact = compact_cone ; - pp_prf = pp_psatz pp_q ; - pp_f = fun o x -> pp_pol pp_q o (fst x) -} - -let non_linear_prover_Q str o = { - name = "real nonlinear prover"; - get_option = (fun () -> (str,o)); - prover = (fun (o,l) -> call_csdpcert_q o l); - hyps = hyps_of_cone; - compact = compact_cone ; - pp_prf = pp_psatz pp_q ; - pp_f = fun o x -> pp_pol pp_q o (fst x) -} - -let non_linear_prover_R str o = { - name = "real nonlinear prover"; - get_option = (fun () -> (str,o)); - prover = (fun (o,l) -> call_csdpcert_q o l); - hyps = hyps_of_cone; - compact = compact_cone; - pp_prf = pp_psatz pp_q; - pp_f = fun o x -> pp_pol pp_q o (fst x) -} - -let non_linear_prover_Z str o = { - name = "real nonlinear prover"; - get_option = (fun () -> (str,o)); - prover = (fun (o,l) -> lift_ratproof (call_csdpcert_z o) l); - hyps = hyps_of_pt; - compact = compact_pt; - pp_prf = pp_proof_term; - pp_f = fun o x -> pp_pol pp_z o (fst x) -} - -let linear_Z = { - name = "lia"; - get_option = get_lia_option; - prover = memo_zlinear_prover ; - hyps = hyps_of_pt; - compact = compact_pt; - pp_prf = pp_proof_term; - pp_f = fun o x -> pp_pol pp_z o (fst x) -} - -let nlinear_Z = { - name = "nlia"; - get_option = get_lia_option; - prover = memo_nlia ; - hyps = hyps_of_pt; - compact = compact_pt; - pp_prf = pp_proof_term; - pp_f = fun o x -> pp_pol pp_z o (fst x) -} - -(** - * Functions instantiating micromega_gen with the appropriate theories and - * solvers - *) - -let lra_Q = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ linear_prover_Q ] - -let psatz_Q i = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ] - -let lra_R = - micromega_genr [ linear_prover_R ] - -let psatz_R i = - micromega_genr [ non_linear_prover_R "real_nonlinear_prover" (Some i) ] - - -let psatz_Z i = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ] - -let sos_Z = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ non_linear_prover_Z "pure_sos" None ] - -let sos_Q = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ non_linear_prover_Q "pure_sos" None ] - - -let sos_R = - micromega_genr [ non_linear_prover_R "pure_sos" None ] - - -let xlia = micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ linear_Z ] - -let xnlia = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ nlinear_Z ] - -let nra = - micromega_genr [ nlinear_prover_R ] - -let nqa = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ nlinear_prover_R ] - - - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/src/versions/standard/g_smtcoq_standard.ml4 b/src/versions/standard/g_smtcoq_standard.ml4 deleted file mode 100644 index ecc2416..0000000 --- a/src/versions/standard/g_smtcoq_standard.ml4 +++ /dev/null @@ -1,119 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -DECLARE PLUGIN "smtcoq_plugin" - -open Stdarg - -(* This is requires since Coq 8.7 because the Ltac machinery became a - plugin - see: https://lists.gforge.inria.fr/pipermail/coq-commits/2017-February/021276.html *) -open Ltac_plugin - -VERNAC COMMAND EXTEND Vernac_zchaff CLASSIFIED AS QUERY -| [ "Parse_certif_zchaff" - ident(dimacs) ident(trace) string(fdimacs) string(fproof) ] -> - [ - Zchaff.parse_certif dimacs trace fdimacs fproof - ] -| [ "Zchaff_Checker" string(fdimacs) string(fproof) ] -> - [ - Zchaff.checker fdimacs fproof - ] -| [ "Zchaff_Theorem" ident(name) string(fdimacs) string(fproof) ] -> - [ - Zchaff.theorem name fdimacs fproof - ] -END - -VERNAC COMMAND EXTEND Vernac_verit CLASSIFIED AS QUERY -| [ "Parse_certif_verit" - ident(t_i) ident(t_func) ident(t_atom) ident(t_form) ident(root) ident(used_roots) ident(trace) string(fsmt) string(fproof) ] -> - [ - Verit.parse_certif t_i t_func t_atom t_form root used_roots trace fsmt fproof - ] -| [ "Verit_Checker" string(fsmt) string(fproof) ] -> - [ - Verit.checker fsmt fproof - ] -| [ "Verit_Checker_Debug" string(fsmt) string(fproof) ] -> - [ - Verit.checker_debug fsmt fproof - ] -| [ "Verit_Theorem" ident(name) string(fsmt) string(fproof) ] -> - [ - Verit.theorem name fsmt fproof - ] -END - -VERNAC COMMAND EXTEND Vernac_lfsc CLASSIFIED AS QUERY -| [ "Parse_certif_lfsc" - ident(t_i) ident(t_func) ident(t_atom) ident(t_form) ident(root) ident(used_roots) ident(trace) string(fsmt) string(fproof) ] -> - [ - Lfsc.parse_certif t_i t_func t_atom t_form root used_roots trace fsmt fproof - ] -| [ "Lfsc_Checker" string(fsmt) string(fproof) ] -> - [ - Lfsc.checker fsmt fproof - ] -| [ "Lfsc_Checker_Debug" string(fsmt) string(fproof) ] -> - [ - Lfsc.checker_debug fsmt fproof - ] -| [ "Lfsc_Theorem" ident(name) string(fsmt) string(fproof) ] -> - [ - Lfsc.theorem name fsmt fproof - ] -END - -TACTIC EXTEND Tactic_zchaff -| [ "zchaff_bool" ] -> [ Zchaff.tactic () ] -| [ "zchaff_bool_no_check" ] -> [ Zchaff.tactic_no_check () ] -END - -let lemmas_list = Summary.ref ~name:"Selected lemmas" [] - -let cache_lemmas (_, lems) = - lemmas_list := lems - -let declare_lemmas : Structures.constr_expr list -> Libobject.obj = - let open Libobject in - declare_object - { - (default_object "LEMMAS") with - cache_function = cache_lemmas; - load_function = (fun _ -> cache_lemmas); - } - -let add_lemmas lems = - Lib.add_anonymous_leaf (declare_lemmas (lems @ !lemmas_list)) - -let clear_lemmas () = - Lib.add_anonymous_leaf (declare_lemmas []) - -let get_lemmas () = !lemmas_list - -VERNAC COMMAND EXTEND Add_lemma CLASSIFIED AS SIDEFF -| [ "Add_lemmas" constr_list(lems) ] -> [ add_lemmas lems ] -| [ "Clear_lemmas" ] -> [ clear_lemmas () ] -END - - -TACTIC EXTEND Tactic_verit -| [ "verit_bool_base" constr(lpl) ] -> [ Verit.tactic lpl (get_lemmas ()) ] -| [ "verit_bool_no_check_base" constr(lpl) ] -> [ Verit.tactic_no_check lpl (get_lemmas ()) ] -END - -TACTIC EXTEND Tactic_cvc4 -| [ "cvc4_bool" ] -> [ Lfsc.tactic () ] -| [ "cvc4_bool_no_check" ] -> [ Lfsc.tactic_no_check () ] -END diff --git a/src/versions/standard/mutils_full.ml b/src/versions/standard/mutils_full.ml deleted file mode 100644 index efa2e4d..0000000 --- a/src/versions/standard/mutils_full.ml +++ /dev/null @@ -1,358 +0,0 @@ -(*** This file is taken from Coq-8.9.0 to solve a compilation issue due - to a wrong order in dependencies. - See https://github.com/coq/coq/issues/9768 . ***) - - -(************************************************************************) -(* * 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) *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* ** Utility functions ** *) -(* *) -(* - Modules CoqToCaml, CamlToCoq *) -(* - Modules Cmp, Tag, TagSet *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -module Micromega = Micromega_plugin.Micromega - -let rec pp_list f o l = - match l with - | [] -> () - | e::l -> f o e ; output_string o ";" ; pp_list f o l - - -let finally f rst = - try - let res = f () in - rst () ; res - with reraise -> - (try rst () - with any -> raise reraise - ); raise reraise - -let rec try_any l x = - match l with - | [] -> None - | (f,s)::l -> match f x with - | None -> try_any l x - | x -> x - -let all_sym_pairs f l = - let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in - - let rec xpairs acc l = - match l with - | [] -> acc - | e::l -> xpairs (pair_with acc e l) l in - xpairs [] l - -let all_pairs f l = - let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in - - let rec xpairs acc l = - match l with - | [] -> acc - | e::lx -> xpairs (pair_with acc e l) lx in - xpairs [] l - -let rec is_sublist f l1 l2 = - match l1 ,l2 with - | [] ,_ -> true - | e::l1', [] -> false - | e::l1' , e'::l2' -> - if f e e' then is_sublist f l1' l2' - else is_sublist f l1 l2' - -let extract pred l = - List.fold_left (fun (fd,sys) e -> - match fd with - | None -> - begin - match pred e with - | None -> fd, e::sys - | Some v -> Some(v,e) , sys - end - | _ -> (fd, e::sys) - ) (None,[]) l - -open Num -open Big_int - -let ppcm x y = - let g = gcd_big_int x y in - let x' = div_big_int x g in - let y' = div_big_int y g in - mult_big_int g (mult_big_int x' y') - -let denominator = function - | Int _ | Big_int _ -> unit_big_int - | Ratio r -> Ratio.denominator_ratio r - -let numerator = function - | Ratio r -> Ratio.numerator_ratio r - | Int i -> Big_int.big_int_of_int i - | Big_int i -> i - -let rec ppcm_list c l = - match l with - | [] -> c - | e::l -> ppcm_list (ppcm c (denominator e)) l - -let rec rec_gcd_list c l = - match l with - | [] -> c - | e::l -> rec_gcd_list (gcd_big_int c (numerator e)) l - -let gcd_list l = - let res = rec_gcd_list zero_big_int l in - if Int.equal (compare_big_int res zero_big_int) 0 - then unit_big_int else res - -let rats_to_ints l = - let c = ppcm_list unit_big_int l in - List.map (fun x -> (div_big_int (mult_big_int (numerator x) c) - (denominator x))) l - -(* assoc_pos j [a0...an] = [j,a0....an,j+n],j+n+1 *) -(** - * MODULE: Coq to Caml data-structure mappings - *) - -module CoqToCaml = -struct - open Micromega - - let rec nat = function - | O -> 0 - | S n -> (nat n) + 1 - - - let rec positive p = - match p with - | XH -> 1 - | XI p -> 1+ 2*(positive p) - | XO p -> 2*(positive p) - - let n nt = - match nt with - | N0 -> 0 - | Npos p -> positive p - - let rec index i = (* Swap left-right ? *) - match i with - | XH -> 1 - | XI i -> 1+(2*(index i)) - | XO i -> 2*(index i) - - open Big_int - - let rec positive_big_int p = - match p with - | XH -> unit_big_int - | XI p -> add_int_big_int 1 (mult_int_big_int 2 (positive_big_int p)) - | XO p -> (mult_int_big_int 2 (positive_big_int p)) - - let z_big_int x = - match x with - | Z0 -> zero_big_int - | Zpos p -> (positive_big_int p) - | Zneg p -> minus_big_int (positive_big_int p) - - let q_to_num {qnum = x ; qden = y} = - Big_int (z_big_int x) // (Big_int (z_big_int (Zpos y))) - -end - - -(** - * MODULE: Caml to Coq data-structure mappings - *) - -module CamlToCoq = -struct - open Micromega - - let rec nat = function - | 0 -> O - | n -> S (nat (n-1)) - - - let rec positive n = - if Int.equal n 1 then XH - else if Int.equal (n land 1) 1 then XI (positive (n lsr 1)) - else XO (positive (n lsr 1)) - - let n nt = - if nt < 0 - then assert false - else if Int.equal nt 0 then N0 - else Npos (positive nt) - - let rec index n = - if Int.equal n 1 then XH - else if Int.equal (n land 1) 1 then XI (index (n lsr 1)) - else XO (index (n lsr 1)) - - - let z x = - match compare x 0 with - | 0 -> Z0 - | 1 -> Zpos (positive x) - | _ -> (* this should be -1 *) - Zneg (positive (-x)) - - open Big_int - - let positive_big_int n = - let two = big_int_of_int 2 in - let rec _pos n = - if eq_big_int n unit_big_int then XH - else - let (q,m) = quomod_big_int n two in - if eq_big_int unit_big_int m - then XI (_pos q) - else XO (_pos q) in - _pos n - - let bigint x = - match sign_big_int x with - | 0 -> Z0 - | 1 -> Zpos (positive_big_int x) - | _ -> Zneg (positive_big_int (minus_big_int x)) - - let q n = - {Micromega.qnum = bigint (numerator n) ; - Micromega.qden = positive_big_int (denominator n)} - -end - -(** - * MODULE: Comparisons on lists: by evaluating the elements in a single list, - * between two lists given an ordering, and using a hash computation - *) - -module Cmp = -struct - - let rec compare_lexical l = - match l with - | [] -> 0 (* Equal *) - | f::l -> - let cmp = f () in - if Int.equal cmp 0 then compare_lexical l else cmp - - let rec compare_list cmp l1 l2 = - match l1 , l2 with - | [] , [] -> 0 - | [] , _ -> -1 - | _ , [] -> 1 - | e1::l1 , e2::l2 -> - let c = cmp e1 e2 in - if Int.equal c 0 then compare_list cmp l1 l2 else c - -end - -(** - * MODULE: Labels for atoms in propositional formulas. - * Tags are used to identify unused atoms in CNFs, and propagate them back to - * the original formula. The translation back to Coq then ignores these - * superfluous items, which speeds the translation up a bit. - *) - -module type Tag = -sig - - type t - - val from : int -> t - val next : t -> t - val pp : out_channel -> t -> unit - val compare : t -> t -> int - -end - -module Tag : Tag = -struct - - type t = int - - let from i = i - let next i = i + 1 - let pp o i = output_string o (string_of_int i) - let compare : int -> int -> int = Int.compare - -end - -(** - * MODULE: Ordered sets of tags. - *) - -module TagSet = Set.Make(Tag) - -(** As for Unix.close_process, our Unix.waipid will ignore all EINTR *) - -let rec waitpid_non_intr pid = - try snd (Unix.waitpid [] pid) - with Unix.Unix_error (Unix.EINTR, _, _) -> waitpid_non_intr pid - -(** - * Forking routine, plumbing the appropriate pipes where needed. - *) - -let command exe_path args vl = - (* creating pipes for stdin, stdout, stderr *) - let (stdin_read,stdin_write) = Unix.pipe () - and (stdout_read,stdout_write) = Unix.pipe () - and (stderr_read,stderr_write) = Unix.pipe () in - - (* Create the process *) - let pid = Unix.create_process exe_path args stdin_read stdout_write stderr_write in - - (* Write the data on the stdin of the created process *) - let outch = Unix.out_channel_of_descr stdin_write in - output_value outch vl ; - flush outch ; - - (* Wait for its completion *) - let status = waitpid_non_intr pid in - - finally - (* Recover the result *) - (fun () -> - match status with - | Unix.WEXITED 0 -> - let inch = Unix.in_channel_of_descr stdout_read in - begin - try Marshal.from_channel inch - with any -> - failwith - (Printf.sprintf "command \"%s\" exited %s" exe_path - (Printexc.to_string any)) - end - | Unix.WEXITED i -> - failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i) - | Unix.WSIGNALED i -> - failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i) - | Unix.WSTOPPED i -> - failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i)) - (* Cleanup *) - (fun () -> - List.iter (fun x -> try Unix.close x with any -> ()) - [stdin_read; stdin_write; - stdout_read; stdout_write; - stderr_read; stderr_write]) - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/src/versions/standard/mutils_full.mli b/src/versions/standard/mutils_full.mli deleted file mode 100644 index d506485..0000000 --- a/src/versions/standard/mutils_full.mli +++ /dev/null @@ -1,77 +0,0 @@ -(*** This file is taken from Coq-8.9.0 to solve a compilation issue due - to a wrong order in dependencies. - See https://github.com/coq/coq/issues/9768 . ***) - - -(************************************************************************) -(* * 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) *) -(************************************************************************) - -module Micromega = Micromega_plugin.Micromega - -val numerator : Num.num -> Big_int.big_int -val denominator : Num.num -> Big_int.big_int - -module Cmp : sig - - val compare_list : ('a -> 'b -> int) -> 'a list -> 'b list -> int - val compare_lexical : (unit -> int) list -> int - -end - -module Tag : sig - - type t - - val pp : out_channel -> t -> unit - val next : t -> t - val from : int -> t - -end - -module TagSet : CSig.SetS with type elt = Tag.t - -val pp_list : (out_channel -> 'a -> unit) -> out_channel -> 'a list -> unit - -module CamlToCoq : sig - - val positive : int -> Micromega.positive - val bigint : Big_int.big_int -> Micromega.z - val n : int -> Micromega.n - val nat : int -> Micromega.nat - val q : Num.num -> Micromega.q - val index : int -> Micromega.positive - val z : int -> Micromega.z - val positive_big_int : Big_int.big_int -> Micromega.positive - -end - -module CoqToCaml : sig - - val z_big_int : Micromega.z -> Big_int.big_int - val q_to_num : Micromega.q -> Num.num - val positive : Micromega.positive -> int - val n : Micromega.n -> int - val nat : Micromega.nat -> int - val index : Micromega.positive -> int - -end - -val rats_to_ints : Num.num list -> Big_int.big_int list - -val all_pairs : ('a -> 'a -> 'b) -> 'a list -> 'b list -val all_sym_pairs : ('a -> 'a -> 'b) -> 'a list -> 'b list -val try_any : (('a -> 'b option) * 'c) list -> 'a -> 'b option -val is_sublist : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool - -val gcd_list : Num.num list -> Big_int.big_int - -val extract : ('a -> 'b option) -> 'a list -> ('b * 'a) option * 'a list - -val command : string -> string array -> 'a -> 'b diff --git a/src/versions/standard/smtcoq_plugin_standard.mlpack b/src/versions/standard/smtcoq_plugin_standard.mlpack deleted file mode 100644 index 81ac24b..0000000 --- a/src/versions/standard/smtcoq_plugin_standard.mlpack +++ /dev/null @@ -1,54 +0,0 @@ -Mutils_full -Coq_micromega_full -Structures - -SmtMisc -CoqTerms -SmtBtype -SmtForm -SmtCertif -SmtTrace -SmtCnf -SatAtom -SmtAtom -SmtMaps - -SatParser -ZchaffParser -CnfParser -Zchaff - -Smtlib2_util -Smtlib2_ast -Smtlib2_parse -Smtlib2_lex -SExpr -SExprParser -SExprLexer -Smtlib2_solver - -Lia - -VeritSyntax -VeritParser -VeritLexer - -Shashcons -Hstring -Type -Ast -Builtin -Tosmtcoq -Converter -LfscParser -LfscLexer - -Smtlib2_genConstr - -SmtCommands - -Verit - -Lfsc - -G_smtcoq diff --git a/src/versions/standard/structures.ml b/src/versions/standard/structures.ml deleted file mode 100644 index 137e543..0000000 --- a/src/versions/standard/structures.ml +++ /dev/null @@ -1,234 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -open Entries - - -(* Constr generation and manipulation *) -type id = Names.variable -let mkId = Names.Id.of_string - - -type name = Names.Name.t -let name_of_id i = Names.Name i -let mkName s = - let id = mkId s in - name_of_id id -let string_of_name = function - Names.Name id -> Names.Id.to_string id - | _ -> failwith "unnamed rel" - - -type constr = Constr.t -type types = Constr.types -let eq_constr = Constr.equal -let hash_constr = Constr.hash -let mkProp = Constr.mkProp -let mkConst = Constr.mkConst -let mkVar = Constr.mkVar -let mkRel = Constr.mkRel -let isRel = Constr.isRel -let destRel = Constr.destRel -let lift = Vars.lift -let mkApp = Constr.mkApp -let decompose_app = Constr.decompose_app -let mkLambda = Constr.mkLambda -let mkProd = Constr.mkProd -let mkLetIn = Constr.mkLetIn - -let pr_constr_env env = Printer.pr_constr_env env Evd.empty -let pr_constr = pr_constr_env Environ.empty_env - - -let mkUConst : Constr.t -> Safe_typing.private_constants Entries.definition_entry = fun c -> - let env = Global.env () in - let evd = Evd.from_env env in - let evd, ty = Typing.type_of env evd (EConstr.of_constr c) in - { Entries.const_entry_body = Future.from_val ((c, Univ.ContextSet.empty), - Safe_typing.empty_private_constants); - const_entry_secctx = None; - const_entry_feedback = None; - const_entry_type = Some (EConstr.Unsafe.to_constr ty); (* Cannot contain evars since it comes from a Constr.t *) - const_entry_universes = Evd.const_univ_entry ~poly:false evd; - const_entry_opaque = false; - const_entry_inline_code = false } - -let mkTConst c noc ty = - let env = Global.env () in - let evd = Evd.from_env env in - let evd, _ = Typing.type_of env evd (EConstr.of_constr noc) in - { const_entry_body = Future.from_val ((c, Univ.ContextSet.empty), - Safe_typing.empty_private_constants); - const_entry_secctx = None; - const_entry_feedback = None; - const_entry_type = Some ty; - const_entry_universes = Evd.const_univ_entry ~poly:false evd; - const_entry_opaque = false; - const_entry_inline_code = false } - -(* TODO : Set -> Type *) -let declare_new_type t = - let _ = ComAssumption.declare_assumption false (Decl_kinds.Discharge, false, Decl_kinds.Definitional) (Constr.mkSet, Entries.Monomorphic_const_entry Univ.ContextSet.empty) UnivNames.empty_binders [] false Declaremods.NoInline (CAst.make t) in - Constr.mkVar t - -let declare_new_variable v constr_t = - let env = Global.env () in - let evd = Evd.from_env env in - let evd, _ = Typing.type_of env evd (EConstr.of_constr constr_t) in - let _ = ComAssumption.declare_assumption false (Decl_kinds.Discharge, false, Decl_kinds.Definitional) (constr_t, Evd.const_univ_entry ~poly:false evd) UnivNames.empty_binders [] false Declaremods.NoInline (CAst.make v) in - Constr.mkVar v - -let declare_constant n c = - Declare.declare_constant n (DefinitionEntry c, Decl_kinds.IsDefinition Decl_kinds.Definition) - - - -type cast_kind = Constr.cast_kind -let vmcast = Constr.VMcast -let mkCast = Constr.mkCast - - -(* EConstr *) -type econstr = EConstr.t -let econstr_of_constr = EConstr.of_constr - - -(* Modules *) -let gen_constant_in_modules s m n = UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules s m n -let gen_constant modules constant = lazy (gen_constant_in_modules "SMT" modules constant) - - -(* Int63 *) -let int63_modules = [["SMTCoq";"versions";"standard";"Int63";"Int63Native"]] - -(* 31-bits integers are "called" 63 bits (this is sound) *) -let int31_module = [["Coq";"Numbers";"Cyclic";"Int31";"Int31"]] -let cD0 = gen_constant int31_module "D0" -let cD1 = gen_constant int31_module "D1" -let cI31 = gen_constant int31_module "I31" - -let mkInt : int -> constr = fun i -> - let a = Array.make 31 (Lazy.force cD0) in - let j = ref i in - let k = ref 30 in - while !j <> 0 do - if !j land 1 = 1 then a.(!k) <- Lazy.force cD1; - j := !j lsr 1; - decr k - done; - mkApp (Lazy.force cI31, a) - -let cint = gen_constant int31_module "int31" - - -(* PArray *) -let parray_modules = [["SMTCoq";"versions";"standard";"Array";"PArray"]] - -let cmake = gen_constant parray_modules "make" -let cset = gen_constant parray_modules "set" - -let max_array_size : int = 4194302 -let mkArray : Constr.types * Constr.t array -> Constr.t = - fun (ty, a) -> - let l = (Array.length a) - 1 in - snd (Array.fold_left (fun (i,acc) c -> - let acc' = - if i = l then - acc - else - mkApp (Lazy.force cset, [|ty; acc; mkInt i; c|]) in - (i+1,acc') - ) (0, mkApp (Lazy.force cmake, [|ty; mkInt l; a.(l)|])) a) - - -(* Traces *) -(* WARNING: side effect on r! *) -let mkTrace step_to_coq next _ clist cnil ccons cpair size step def_step r = - let rec mkTrace s = - if s = size then - mkApp (Lazy.force cnil, [|step|]) - else ( - r := next !r; - let st = step_to_coq !r in - mkApp (Lazy.force ccons, [|step; st; mkTrace (s+1)|]) - ) in - mkApp (Lazy.force cpair, [|mkApp (Lazy.force clist, [|step|]); step; mkTrace 0; def_step|]) - - -(* Micromega *) -module Micromega_plugin_Micromega = Micromega_plugin.Micromega -module Micromega_plugin_Mutils = Mutils_full -module Micromega_plugin_Certificate = Micromega_plugin.Certificate -module Micromega_plugin_Coq_micromega = Coq_micromega_full - -let micromega_coq_proofTerm = - (* Cannot contain evars *) - lazy (EConstr.Unsafe.to_constr (Lazy.force (Micromega_plugin_Coq_micromega.M.coq_proofTerm))) - -let micromega_dump_proof_term p = - (* Cannot contain evars *) - EConstr.Unsafe.to_constr (Micromega_plugin_Coq_micromega.dump_proof_term p) - - -(* Tactics *) -type tactic = unit Proofview.tactic -let tclTHEN = Tacticals.New.tclTHEN -let tclTHENLAST = Tacticals.New.tclTHENLAST -let assert_before n c = Tactics.assert_before n (EConstr.of_constr c) - -let vm_cast_no_check c = Tactics.vm_cast_no_check (EConstr.of_constr c) - -let mk_tactic tac = - Proofview.Goal.nf_enter (fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let t = Proofview.Goal.concl gl in - let t = EConstr.to_constr sigma t in (* The goal should not contain uninstanciated evars *) - tac env sigma t - ) -let set_evars_tac noc = - mk_tactic ( - fun env sigma _ -> - let sigma, _ = Typing.type_of env sigma (EConstr.of_constr noc) in - Proofview.Unsafe.tclEVARS sigma) - - -(* Other differences between the two versions of Coq *) -type constr_expr = Constrexpr.constr_expr -let error s = CErrors.user_err (Pp.str s) -let warning n s = CWarnings.create ~name:n ~category:"SMTCoq plugin" Pp.str s - -let extern_constr c = Constrextern.extern_constr true Environ.empty_env Evd.empty (EConstr.of_constr c) - -let destruct_rel_decl r = Context.Rel.Declaration.get_name r, - Context.Rel.Declaration.get_type r - -(* Cannot contain evars since it comes from a Constr.t *) -let interp_constr env sigma t = Constrintern.interp_constr env sigma t |> fst |> EConstr.Unsafe.to_constr - -let ppconstr_lsimpleconstr = Ppconstr.lsimpleconstr - -let constrextern_extern_constr c = - let env = Global.env () in - Constrextern.extern_constr false env (Evd.from_env env) (EConstr.of_constr c) - -let get_rel_dec_name = function - | Context.Rel.Declaration.LocalAssum (n, _) | Context.Rel.Declaration.LocalDef (n, _, _) -> n - -let retyping_get_type_of env sigma c = - (* Cannot contain evars since it comes from a Constr.t *) - EConstr.Unsafe.to_constr (Retyping.get_type_of env sigma (EConstr.of_constr c)) - -let vm_conv = Vconv.vm_conv - -(* Cannot contain evars since it comes from a Constr.t *) -let cbv_vm env c t = EConstr.Unsafe.to_constr (Vnorm.cbv_vm env Evd.empty (EConstr.of_constr c) (EConstr.of_constr t)) diff --git a/src/versions/standard/structures.mli b/src/versions/standard/structures.mli deleted file mode 100644 index 9fa4673..0000000 --- a/src/versions/standard/structures.mli +++ /dev/null @@ -1,122 +0,0 @@ -(**************************************************************************) -(* *) -(* SMTCoq *) -(* Copyright (C) 2011 - 2022 *) -(* *) -(* See file "AUTHORS" for the list of authors *) -(* *) -(* This file is distributed under the terms of the CeCILL-C licence *) -(* *) -(**************************************************************************) - - -(* WARNING: currently, we map all the econstr into constr: we suppose - that the goal does not contain existencial variables *) - -(* Constr generation and manipulation *) -type id = Names.variable -val mkId : string -> id - -type name -val name_of_id : id -> name -val mkName : string -> name -val string_of_name : name -> string - -type constr = Constr.t -type types = constr -val eq_constr : constr -> constr -> bool -val hash_constr : constr -> int -val mkProp : types -val mkConst : Names.Constant.t -> constr -val mkVar : id -> constr -val mkRel : int -> constr -val isRel : constr -> bool -val destRel : constr -> int -val lift : int -> constr -> constr -val mkApp : constr * constr array -> constr -val decompose_app : constr -> constr * constr list -val mkLambda : name * types * constr -> constr -val mkProd : name * types * types -> types -val mkLetIn : name * constr * types * constr -> constr - -val pr_constr_env : Environ.env -> constr -> Pp.t -val pr_constr : constr -> Pp.t - -val mkUConst : constr -> Safe_typing.private_constants Entries.definition_entry -val mkTConst : constr -> constr -> types -> Safe_typing.private_constants Entries.definition_entry -val declare_new_type : id -> types -val declare_new_variable : id -> types -> constr -val declare_constant : id -> Safe_typing.private_constants Entries.definition_entry -> Names.Constant.t - -type cast_kind -val vmcast : cast_kind -val mkCast : constr * cast_kind * constr -> constr - - -(* EConstr *) -type econstr = EConstr.t -val econstr_of_constr : constr -> econstr - - -(* Modules *) -val gen_constant : string list list -> string -> constr lazy_t - - -(* Int63 *) -val int63_modules : string list list -val mkInt : int -> constr -val cint : constr lazy_t - - -(* PArray *) -val parray_modules : string list list -val max_array_size : int -val mkArray : types * constr array -> constr - - -(* Traces *) -val mkTrace : - ('a -> constr) -> - ('a -> 'a) -> - 'b -> - constr Lazy.t -> - constr Lazy.t -> - constr Lazy.t -> - constr Lazy.t -> - int -> constr -> constr -> 'a ref -> constr - - -(* Micromega *) -module Micromega_plugin_Micromega = Micromega_plugin.Micromega -module Micromega_plugin_Mutils = Mutils_full -module Micromega_plugin_Certificate = Micromega_plugin.Certificate -module Micromega_plugin_Coq_micromega = Coq_micromega_full - -val micromega_coq_proofTerm : constr lazy_t -val micromega_dump_proof_term : Micromega_plugin_Micromega.zArithProof -> constr - - -(* Tactics *) -type tactic = unit Proofview.tactic -val tclTHEN : tactic -> tactic -> tactic -val tclTHENLAST : tactic -> tactic -> tactic -val assert_before : name -> types -> tactic -val vm_cast_no_check : constr -> tactic -val mk_tactic : (Environ.env -> Evd.evar_map -> constr -> tactic) -> tactic -val set_evars_tac : constr -> tactic - - -(* Other differences between the two versions of Coq *) -type constr_expr = Constrexpr.constr_expr -val error : string -> 'a -val warning : string -> string -> unit -val extern_constr : constr -> constr_expr -val destruct_rel_decl : (constr, types) Context.Rel.Declaration.pt -> name * types -val interp_constr : Environ.env -> Evd.evar_map -> constr_expr -> constr -val ppconstr_lsimpleconstr : Notation_gram.tolerability -val constrextern_extern_constr : constr -> constr_expr -val get_rel_dec_name : (constr, types) Context.Rel.Declaration.pt -> name -val retyping_get_type_of : Environ.env -> Evd.evar_map -> constr -> constr - -val vm_conv : Reduction.conv_pb -> types Reduction.kernel_conversion_function -val cbv_vm : Environ.env -> constr -> types -> constr |